diff --git a/app/Api.hs b/app/Api.hs index 60be5bc..669eb05 100644 --- a/app/Api.hs +++ b/app/Api.hs @@ -5,8 +5,8 @@ import Relude import Polysemy (Members, Sem) import Polysemy.Error (Error) import Servant.API -import Servant.Client.Streaming (ClientM, ClientError, client) -import Servant.Polysemy.Client (runClient, ServantClient) +import Servant.Client.Streaming (ClientError, ClientM, client) +import Servant.Polysemy.Client (ServantClient, runClient) import Api.Spec import Api.Types diff --git a/app/Api/Spec.hs b/app/Api/Spec.hs index 37e0874..1bfb9f5 100644 --- a/app/Api/Spec.hs +++ b/app/Api/Spec.hs @@ -4,6 +4,9 @@ import Servant.API import Api.Types -type Api = "api" :> (ReqBody '[FormUrlEncoded] GetSections :> Post '[JSON] [Section] - :<|> ReqBody '[FormUrlEncoded] GetTopics :> Post '[JSON] [TopicInfo] - :<|> ReqBody '[FormUrlEncoded] GetTopic :> Post '[JSON] Topic) +type Api = + "api" + :> ( ReqBody '[FormUrlEncoded] GetSections :> Post '[JSON] [Section] + :<|> ReqBody '[FormUrlEncoded] GetTopics :> Post '[JSON] [TopicInfo] + :<|> ReqBody '[FormUrlEncoded] GetTopic :> Post '[JSON] Topic + ) diff --git a/app/Api/Types.hs b/app/Api/Types.hs index 961ca62..3cb64b2 100644 --- a/app/Api/Types.hs +++ b/app/Api/Types.hs @@ -1,35 +1,37 @@ {-# LANGUAGE Strict #-} -module Api.Types ( GetSections(GetSections) - , Section(..) - , GetTopics(GetTopics) - , TopicInfo(..) - , GetTopic(..) - , Topic(..) - , ThreadHead(..) - , ThreadPost(..) - ) where +module Api.Types ( + GetSections (GetSections) + , Section (..) + , GetTopics (GetTopics) + , TopicInfo (..) + , GetTopic (..) + , Topic (..) + , ThreadHead (..) + , ThreadPost (..) +) where import Relude -import Data.Aeson (FromJSON(parseJSON), Value(Object), (.:), withObject) +import Color.Print +import Color.Utils +import Data.Aeson (FromJSON (parseJSON), Value (Object), withObject, (.:)) import Data.HashMap.Strict qualified as M import Polysemy.Commonmark.AST (commonmark) import Polysemy.Output.IO import Polysemy.Sgr -import Color.Print import System.Console.ANSI -import Web.FormUrlEncoded (Form(Form), ToForm(toForm)) -import Color.Utils +import Web.FormUrlEncoded (Form (Form), ToForm (toForm)) data GetSections = GetSections instance ToForm GetSections where toForm GetSections = Form $ M.fromList [("type", ["sections"]), ("key", ["anon"])] -data Section = Section { id :: Integer - , thread_group_name, description :: Text - } - deriving stock (Generic, Show) +data Section = Section + { id :: Integer + , thread_group_name, description :: Text + } + deriving stock (Generic, Show) instance NFData Section instance FromJSON Section @@ -45,10 +47,11 @@ data GetTopics = GetTopics instance ToForm GetTopics where toForm GetTopics = Form $ M.fromList [("type", ["threads"]), ("key", ["anon"])] -data TopicInfo = TopicInfo { id, group_id, nbr_ansfers :: Integer - , thrname, date, name, last_activity_date, last_activity_user :: Text - } - deriving stock (Generic, Show) +data TopicInfo = TopicInfo + { id, group_id, nbr_ansfers :: Integer + , thrname, date, name, last_activity_date, last_activity_user :: Text + } + deriving stock (Generic, Show) instance NFData TopicInfo instance FromJSON TopicInfo @@ -62,17 +65,21 @@ instance PrintColor TopicInfo where withSgr [SetColor Foreground Dull White] do putTextLnO $ " at " <> last_activity_date <> " #" <> show topic_id -data GetTopic = GetTopic { topic_id :: Integer } +data GetTopic = GetTopic {topic_id :: Integer} instance ToForm GetTopic where - toForm GetTopic {topic_id} = Form $ M.fromList [ ("type", ["topic"]) - , ("key", ["anon"]) - , ("id", [show topic_id]) - ] + toForm GetTopic{topic_id} = + Form $ + M.fromList + [ ("type", ["topic"]) + , ("key", ["anon"]) + , ("id", [show topic_id]) + ] -data Topic = Topic { thread :: ThreadHead - , post :: [ThreadPost] - } - deriving stock (Generic, Show) +data Topic = Topic + { thread :: ThreadHead + , post :: [ThreadPost] + } + deriving stock (Generic, Show) instance NFData Topic instance FromJSON Topic @@ -80,37 +87,44 @@ instance PrintColor Topic where printColor Topic{thread, post} = sequenceA_ $ intersperse (putTextLnO "") (printColor <$> threadHeadToPost thread : post) -data ThreadHead = ThreadHead { info :: TopicInfo - , message :: Text - } - deriving stock (Generic, Show) +data ThreadHead = ThreadHead + { info :: TopicInfo + , message :: Text + } + deriving stock (Generic, Show) instance NFData ThreadHead instance FromJSON ThreadHead where - parseJSON = withObject "ThreadHead" \o -> ThreadHead <$> parseJSON (Object o) - <*> o .: "message" + parseJSON = withObject "ThreadHead" \o -> + ThreadHead <$> parseJSON (Object o) + <*> o .: "message" threadHeadToPost :: ThreadHead -> ThreadPost -threadHeadToPost ThreadHead{info, message} = ThreadPost { id = info.id - , topic_id = info.id - , name = info.name - , date = info.date - , message - } +threadHeadToPost ThreadHead{info, message} = + ThreadPost + { id = info.id + , topic_id = info.id + , name = info.name + , date = info.date + , message + } -data ThreadPost = ThreadPost { id, topic_id :: Integer - , name, date, message :: Text - } - deriving stock (Generic, Show) +data ThreadPost = ThreadPost + { id, topic_id :: Integer + , name, date, message :: Text + } + deriving stock (Generic, Show) instance NFData ThreadPost instance FromJSON ThreadPost instance PrintColor ThreadPost where printColor ThreadPost{id = post_id, name, date, message} = do - withSgr [ SetPaletteColor Foreground (textColor name) - , SetConsoleIntensity BoldIntensity - -- , SetSwapForegroundBackground True - ] do - putTextO $ "@" <> name + withSgr + [ SetPaletteColor Foreground (textColor name) + , SetConsoleIntensity BoldIntensity + -- , SetSwapForegroundBackground True + ] + do + putTextO $ "@" <> name withSgr [SetColor Foreground Dull White] do putTextLnO $ " " <> date <> " #" <> show post_id case commonmark "" message of diff --git a/app/Cli.hs b/app/Cli.hs index b909c00..fefee23 100644 --- a/app/Cli.hs +++ b/app/Cli.hs @@ -1,12 +1,13 @@ {-# LANGUAGE Strict #-} -module Cli ( Options(..) - , Choice(..) - , optsParser - , choiceParser - , optsInfo - , getOpts - ) where +module Cli ( + Options (..) + , Choice (..) + , optsParser + , choiceParser + , optsInfo + , getOpts +) where import Relude import Prelude (foldl1) @@ -24,39 +25,68 @@ data Options = Options optsParser :: Parser Options optsParser = Options <$> switch (long "no-ansi" <> short 'A' <> help "disable ANSI codes") - <*> (Just <$> option auto (metavar "COLUMNS_NUMBER" - <> long "columns" - <> short 'c' - <> help "number of columns") - <|> pure Nothing) - <*> choiceParser + <*> ( Just + <$> option + auto + ( metavar "COLUMNS_NUMBER" + <> long "columns" + <> short 'c' + <> help "number of columns" + ) + <|> pure Nothing + ) + <*> choiceParser -data Choice = GetSections - | GetTopics { maxEntries :: Maybe Int } - | GetTopic { topic_id :: Integer } - deriving stock (Show) +data Choice + = GetSections + | GetTopics {maxEntries :: Maybe Int} + | GetTopic {topic_id :: Integer} + deriving stock (Show) choiceParser :: Parser Choice -choiceParser = foldl1 (<|>) - [ subparser - (command "ss" (info - (pure GetSections - <**> helper) - (progDesc "Request list of sections"))) - , subparser - (command "ts" (info - (GetTopics <$> (Just <$> option auto (metavar "MAX_ENTRIES_NUMBER" - <> long "max-entries" - <> short 'm' - <> help "max number of entries")) - <**> helper) - (progDesc "Request list of topics"))) - , subparser - (command "t" (info - (GetTopic <$> argument auto (metavar "TOPIC_ID") - <**> helper) - (progDesc "Request a topic"))) - ] +choiceParser = + foldl1 + (<|>) + [ subparser + ( command + "ss" + ( info + ( pure GetSections + <**> helper + ) + (progDesc "Request list of sections") + ) + ) + , subparser + ( command + "ts" + ( info + ( GetTopics + <$> ( Just + <$> option + auto + ( metavar "MAX_ENTRIES_NUMBER" + <> long "max-entries" + <> short 'm' + <> help "max number of entries" + ) + ) + <**> helper + ) + (progDesc "Request list of topics") + ) + ) + , subparser + ( command + "t" + ( info + ( GetTopic <$> argument auto (metavar "TOPIC_ID") + <**> helper + ) + (progDesc "Request a topic") + ) + ) + ] optsInfo :: ParserInfo Options optsInfo = info (optsParser <**> helper) mempty diff --git a/app/Color/Print.hs b/app/Color/Print.hs index 52b1a2d..b184383 100644 --- a/app/Color/Print.hs +++ b/app/Color/Print.hs @@ -1,4 +1,4 @@ -module Color.Print (PrintColor(..)) where +module Color.Print (PrintColor (..)) where import Relude diff --git a/app/Color/Utils.hs b/app/Color/Utils.hs index 5774c69..97b92b3 100644 --- a/app/Color/Utils.hs +++ b/app/Color/Utils.hs @@ -7,5 +7,6 @@ import Data.ByteString qualified as B -- | Returns number < 216 textColor :: Text -> Word8 -textColor t = let result = B.head . finalize . start $ encodeUtf8 t - in result `mod` 216 +textColor t = + let result = B.head . finalize . start $ encodeUtf8 t + in result `mod` 216 diff --git a/app/Main.hs b/app/Main.hs index 39594b2..d397736 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -5,15 +5,15 @@ import Relude hiding (Proxy) import Api qualified as Api import Api.Types (last_activity_date) import Cli +import Color.Print import Network.HTTP.Client import Polysemy (Member, Members, Sem) import Polysemy.Embed (Embed) import Polysemy.Error (Error, errorToIOFinal) +import Polysemy.Final (Final, embedToFinal, runFinal) import Polysemy.Output (Output) import Polysemy.Output.IO (putTextLnO, runOutputToStdout) import Polysemy.Sgr (Sgr, SgrRegion, ignoreSgrFull, runSgrFull, withSgr) -import Polysemy.Final (Final, embedToFinal, runFinal) -import Color.Print import Servant.Client import Servant.Polysemy.Client (ServantClient, runServantClientWith) import System.Console.ANSI @@ -21,12 +21,17 @@ import System.Console.ANSI defProxy :: Proxy defProxy = Proxy "127.0.0.1" 4444 -runProgram :: ClientEnv - -> Sem [ Output Text - , ServantClient, Error ClientError - , Embed IO, Final IO - ] () - -> IO () +runProgram :: + ClientEnv -> + Sem + [ Output Text + , ServantClient + , Error ClientError + , Embed IO + , Final IO + ] + () -> + IO () runProgram clientEnv = (>>= either (error . fromString . displayException) pure) . runFinal @@ -35,12 +40,17 @@ runProgram clientEnv = . runServantClientWith clientEnv . runOutputToStdout -sgrFullInterpreter :: Member (Output Text) r - => Bool -> Sem (SgrRegion : Sgr : r) a -> Sem r a +sgrFullInterpreter :: + Member (Output Text) r => + Bool -> + Sem (SgrRegion : Sgr : r) a -> + Sem r a sgrFullInterpreter noAnsi = if noAnsi then ignoreSgrFull else runSgrFull -program :: Members [Error ClientError, ServantClient, Output Text, Sgr, SgrRegion] r - => Choice -> Sem r () +program :: + Members [Error ClientError, ServantClient, Output Text, Sgr, SgrRegion] r => + Choice -> + Sem r () program GetSections = do sections <- Api.getSections withSgr [SetColor Foreground Vivid White] do @@ -48,8 +58,10 @@ program GetSections = do program GetTopics{maxEntries} = do topics <- Api.getTopics withSgr [SetColor Foreground Vivid White] do - sequenceA_ $ intersperse (putTextLnO "") - (fmap printColor . maybe id take maxEntries . reverse $ sortBy (comparing (.last_activity_date)) topics) + sequenceA_ $ + intersperse + (putTextLnO "") + (fmap printColor . maybe id take maxEntries . reverse $ sortBy (comparing (.last_activity_date)) topics) program GetTopic{topic_id} = do topic <- Api.getTopic topic_id withSgr [SetColor Foreground Vivid White] do @@ -58,9 +70,10 @@ program GetTopic{topic_id} = do main :: IO () main = do Options{noAnsi, choice} <- getOpts - manager' <- newManager $ - defaultManagerSettings - & (managerSetProxy $ proxyEnvironmentNamed "I2P_HTTP_PROXY" $ Just defProxy) + manager' <- + newManager $ + defaultManagerSettings + & (managerSetProxy $ proxyEnvironmentNamed "I2P_HTTP_PROXY" $ Just defProxy) let clientEnv = mkClientEnv manager' (BaseUrl Http "4rum.i2p" 80 "") runProgram clientEnv . sgrFullInterpreter noAnsi $ program choice diff --git a/app/Polysemy/Commonmark/AST.hs b/app/Polysemy/Commonmark/AST.hs index cdfb5a8..1666693 100644 --- a/app/Polysemy/Commonmark/AST.hs +++ b/app/Polysemy/Commonmark/AST.hs @@ -4,54 +4,62 @@ module Polysemy.Commonmark.AST (Inline, Block, commonmark) where import Relude +import Color.Print +import Color.Utils import Commonmark (commonmarkWith) import Commonmark.Extensions.Strikethrough import Commonmark.Parser (ParseError) import Commonmark.Syntax (defaultSyntaxSpec) import Commonmark.Types import Data.Char qualified as C -import Data.Sequence ( Seq ((:<|), Empty) - , ViewL ((:<)), ViewR ((:>)) - , viewl, viewr - ) +import Data.Sequence ( + Seq (Empty, (:<|)) + , ViewL ((:<)) + , ViewR ((:>)) + , viewl + , viewr + ) import Data.Text qualified as T -import Polysemy.Output.IO (putTextO, putTextLnO) +import Polysemy.Output.IO (putTextLnO, putTextO) import Polysemy.Sgr (withSgr) -import Color.Print import System.Console.ANSI qualified as ANSI -import Color.Utils commonmark :: String -> Text -> Either ParseError Block commonmark filename source = - runIdentity $ commonmarkWith @Identity @Inline @Block (defaultSyntaxSpec <> strikethroughSpec) - filename - source + runIdentity $ + commonmarkWith @Identity @Inline @Block + (defaultSyntaxSpec <> strikethroughSpec) + filename + source -- TODO: add spoilers -data InlinePiece = Str Text - | Emph Inline - | Strong Inline - | Underline Inline - | Strikethrough Inline - | Autolink { dest :: Text } - | Link { dest :: Text - , descr :: Inline - } - | Code Text - deriving stock (Show) +data InlinePiece + = Str Text + | Emph Inline + | Strong Inline + | Underline Inline + | Strikethrough Inline + | Autolink {dest :: Text} + | Link + { dest :: Text + , descr :: Inline + } + | Code Text + deriving stock (Show) newtype Inline = Inline (Seq InlinePiece) - deriving newtype (IsList, Show) + deriving newtype (IsList, Show) mapText :: (Text -> Text) -> Inline -> Inline -mapText f (Inline pieces) = Inline (mapText' <$> pieces) where +mapText f (Inline pieces) = Inline (mapText' <$> pieces) + where mapText' (Str t) = Str (f t) mapText' (Emph i) = Emph (mapText f i) mapText' (Strong i) = Strong (mapText f i) mapText' (Underline i) = Underline (mapText f i) mapText' (Strikethrough i) = Strikethrough (mapText f i) - mapText' (Autolink t) = Link {dest = t, descr = str (f t)} - mapText' Link{dest, descr} = Link { dest, descr = mapText f descr } + mapText' (Autolink t) = Link{dest = t, descr = str (f t)} + mapText' Link{dest, descr} = Link{dest, descr = mapText f descr} mapText' (Code t) = Code t instance Semigroup Inline where @@ -81,27 +89,31 @@ instance IsInline Inline where escapedChar c = str $ "\\" <> one c emph = Inline . one . Emph strong = Inline . one . Strong - link dest _title (Inline (Str descr :<| Empty)) | dest == descr = Inline $ one Autolink {dest} + link dest _title (Inline (Str descr :<| Empty)) | dest == descr = Inline $ one Autolink{dest} link dest _title descr = - descr <> fromList [ Str " (" - , Underline (str dest) - , Str ")"] + descr + <> fromList + [ Str " (" + , Underline (str dest) + , Str ")" + ] image = link code c = Inline . one $ Code $ "`" <> c <> "`" rawInline _ = code -data BlockPiece = Paragraph Inline - | Plain Inline - | ThematicBreak - | BlockQuote Block - | CodeBlock Text Text - | Heading Int Inline - | ReferenceLinkDefinition { label, dest, title :: Text } - | List ListType ListSpacing [Block] - deriving stock (Show) +data BlockPiece + = Paragraph Inline + | Plain Inline + | ThematicBreak + | BlockQuote Block + | CodeBlock Text Text + | Heading Int Inline + | ReferenceLinkDefinition {label, dest, title :: Text} + | List ListType ListSpacing [Block] + deriving stock (Show) newtype Block = Block [BlockPiece] - deriving newtype (Show, Semigroup, Monoid) + deriving newtype (Show, Semigroup, Monoid) instance Rangeable Block where ranged = const id @@ -123,7 +135,8 @@ instance IsBlock Inline Block where instance PrintColor Inline where -- TODO: needs to be aware of prefix and line length -- and perform line wrapping - printColor (Inline pieces) = for_ pieces printPiece where + printColor (Inline pieces) = for_ pieces printPiece + where printPiece (Str t) = case t of "" -> pass "@" -> putTextO t @@ -134,22 +147,24 @@ instance PrintColor Inline where in if not (T.null withUsername) && isNotPartOfWord then do putTextO beforeUsername - withSgr [ ANSI.SetPaletteColor ANSI.Foreground (textColor username) - -- , ANSI.SetSwapForegroundBackground True - , ANSI.SetConsoleIntensity ANSI.BoldIntensity - ] do - putTextO $ "@" <> username + withSgr + [ ANSI.SetPaletteColor ANSI.Foreground (textColor username) + , -- , ANSI.SetSwapForegroundBackground True + ANSI.SetConsoleIntensity ANSI.BoldIntensity + ] + do + putTextO $ "@" <> username printPiece (Str rest) else putTextO t - where - isUsernameSym c = C.isAlphaNum c || elem c ['_', '-'] + where + isUsernameSym c = C.isAlphaNum c || elem c ['_', '-'] printPiece (Emph i) = withSgr [ANSI.SetItalicized True] $ printColor i printPiece (Strong i) = withSgr [ANSI.SetConsoleIntensity ANSI.BoldIntensity] $ printColor i printPiece (Underline i) = withSgr [ANSI.SetUnderlining ANSI.SingleUnderline] $ printColor i printPiece (Strikethrough i) = printColor (mapText mkStrikethrough i) - where - mkStrikethrough :: (IsString s, ToString s) => s -> s - mkStrikethrough s = fromString do { c <- toString s; [c, chr 822] } + where + mkStrikethrough :: (IsString s, ToString s) => s -> s + mkStrikethrough s = fromString do c <- toString s; [c, chr 822] printPiece Autolink{dest} = do withSgr [ANSI.SetUnderlining ANSI.SingleUnderline] do putTextO dest @@ -158,16 +173,19 @@ instance PrintColor Inline where withSgr [ANSI.SetUnderlining ANSI.SingleUnderline] do putTextO $ " (" <> dest <> ")" printPiece (Code t) = - withSgr [ ANSI.SetColor ANSI.Background ANSI.Vivid ANSI.Black - , ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White - ] do - putTextO t + withSgr + [ ANSI.SetColor ANSI.Background ANSI.Vivid ANSI.Black + , ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White + ] + do + putTextO t instance HasStrikethrough Inline where strikethrough = Inline . one . Strikethrough instance PrintColor Block where - printColor = printBlockP "" where + printColor = printBlockP "" + where printBlockP prefix (Block b) = for_ b (printBlockOne prefix) printBlockOne prefix (Paragraph i) = do @@ -207,14 +225,14 @@ instance PrintColor Block where listPrefixes :: ListType -> [Text] listPrefixes (BulletList c) = repeat (fromString [c, ' ']) listPrefixes (OrderedList start enumType delimType) = - [start..] <&> \i -> enumFor i <> delim <> " " - where - infAlph xs = xs ++ ((<>) <$> infAlph xs <*> xs) - enumFor i = case enumType of - UpperAlpha -> infAlph (fromString . one <$> ['A'..'Z']) !!? i & fromMaybe (error "Impossible") - LowerAlpha -> infAlph (fromString . one <$> ['a'..'z']) !!? i & fromMaybe (error "Impossible") - _ -> show i - delim = case delimType of - Period -> "." - OneParen -> ")" - TwoParens -> "))" + [start ..] <&> \i -> enumFor i <> delim <> " " + where + infAlph xs = xs ++ ((<>) <$> infAlph xs <*> xs) + enumFor i = case enumType of + UpperAlpha -> infAlph (fromString . one <$> ['A' .. 'Z']) !!? i & fromMaybe (error "Impossible") + LowerAlpha -> infAlph (fromString . one <$> ['a' .. 'z']) !!? i & fromMaybe (error "Impossible") + _ -> show i + delim = case delimType of + Period -> "." + OneParen -> ")" + TwoParens -> "))" diff --git a/app/Polysemy/Output/IO.hs b/app/Polysemy/Output/IO.hs index 6c0ef50..6569218 100644 --- a/app/Polysemy/Output/IO.hs +++ b/app/Polysemy/Output/IO.hs @@ -1,14 +1,17 @@ -module Polysemy.Output.IO ( runOutputToIO - , runOutputToStdout, runOutputToStderr - , putTextO, putTextLnO - ) where +module Polysemy.Output.IO ( + runOutputToIO + , runOutputToStdout + , runOutputToStderr + , putTextO + , putTextLnO +) where import Relude import Data.Text (unpack) import Polysemy (Member, Sem, interpret) import Polysemy.Embed (Embed, embed) -import Polysemy.Output (Output(Output), output) +import Polysemy.Output (Output (Output), output) import System.IO (hPutStr) runOutputToIO :: Member (Embed IO) r => Handle -> Sem (Output Text ': r) () -> Sem r () diff --git a/app/Polysemy/Sgr.hs b/app/Polysemy/Sgr.hs index f18a7a0..e51399c 100644 --- a/app/Polysemy/Sgr.hs +++ b/app/Polysemy/Sgr.hs @@ -1,10 +1,16 @@ {-# LANGUAGE TemplateHaskell #-} -module Polysemy.Sgr ( Sgr, sgr - , runSgrToOutput, ignoreSgr - , SgrRegion, withSgr - , SgrFull, runSgrFull, ignoreSgrFull - ) where +module Polysemy.Sgr ( + Sgr + , sgr + , runSgrToOutput + , ignoreSgr + , SgrRegion + , withSgr + , SgrFull + , runSgrFull + , ignoreSgrFull +) where import Relude hiding (Reader, ask, asks, local, runReader) @@ -19,9 +25,10 @@ data Sgr :: Effect where $(makeSem ''Sgr) -runSgrToOutput :: Member (Output Text) r - => Sem (Sgr : r) a - -> Sem r a +runSgrToOutput :: + Member (Output Text) r => + Sem (Sgr : r) a -> + Sem r a runSgrToOutput = interpret \(Sgr cs) -> output $ pack $ ANSI.setSGRCode cs ignoreSgr :: Sem (Sgr : r) a -> Sem r a @@ -30,10 +37,11 @@ ignoreSgr = interpret \(Sgr _) -> pass type SgrRegion :: Effect type SgrRegion = Reader [ANSI.SGR] -withSgr :: Members [SgrRegion, Sgr] r - => [ANSI.SGR] - -> Sem r a - -> Sem r a +withSgr :: + Members [SgrRegion, Sgr] r => + [ANSI.SGR] -> + Sem r a -> + Sem r a withSgr es act = do asks (++ es) >>= sgr result <- local (++ es) act @@ -46,8 +54,10 @@ runSgrRegion = runReader [ANSI.Reset] type SgrFull :: [Effect] type SgrFull = [SgrRegion, Sgr] -runSgrFull :: Member (Output Text) r - => Sem (SgrRegion : Sgr : r) a -> Sem r a +runSgrFull :: + Member (Output Text) r => + Sem (SgrRegion : Sgr : r) a -> + Sem r a runSgrFull = runSgrToOutput . runSgrRegion ignoreSgrFull :: Sem (SgrRegion : Sgr : r) a -> Sem r a diff --git a/flake.nix b/flake.nix index 340100d..ec44658 100644 --- a/flake.nix +++ b/flake.nix @@ -124,7 +124,7 @@ thisNative.env.overrideAttrs (a: { nativeBuildInputs = a.nativeBuildInputs ++ [ thisNative.passthru.pkgs.fourmolu ]; }); - ghci = default.overrideAttrs (_: { + ghci = default.overrideAttrs (_: { shellHook = '' ghci ${unwords (options ++ extensions)} ${findFiles} exit $? diff --git a/nix/dependencies.nix b/nix/dependencies.nix index 98fdba6..66cb157 100644 --- a/nix/dependencies.nix +++ b/nix/dependencies.nix @@ -160,8 +160,18 @@ with builtins; mapAttrs (_: v: }) {}; compact = final.callPackage ({ haskell }: haskell.lib.doJailbreak - (prev.compact.overrideAttrs (_: { doCheck = false; doHaddock = false; doBenchmark = false; }))) {}; + (prev.compact.overrideAttrs (_: { + doCheck = false; + doBenchmark = false; + doHoogle = false; + doHaddock = false; + }))) {}; type-errors = final.callPackage ({ haskell }: haskell.lib.doJailbreak - (prev.type-errors.overrideAttrs (_: { doCheck = false; doHaddock = false; doBenchmark = false; }))) {}; + (prev.type-errors.overrideAttrs (_: { + doCheck = false; + doBenchmark = false; + doHoogle = false; + doHaddock = false; + }))) {}; }