From 36021097e17ab1cfa971564cb70128d704e88f2d Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Mon, 19 Oct 2020 17:04:16 -0400 Subject: Remove $ from Alpha --- Alpha.hs | 12 +++++------- Biz/Bild/Deps.nix | 1 + Biz/Bild/Rules.nix | 7 ++++++- Biz/Pie.hs | 6 +++--- Control/Concurrent/Go.hs | 2 +- Que/Server.hs | 35 +++++++++++++---------------------- Que/Website.hs | 14 +++++++------- 7 files changed, 36 insertions(+), 41 deletions(-) diff --git a/Alpha.hs b/Alpha.hs index 934cc31..e19f9be 100644 --- a/Alpha.hs +++ b/Alpha.hs @@ -46,13 +46,11 @@ module Alpha ) where -import Data.Function ((&)) -import Data.Functor ((<&>)) import Data.String import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Lazy as LazyText -import Protolude as X +import Protolude as X hiding (($), (&)) -- | Debugging printf say :: Text -> IO () @@ -60,7 +58,7 @@ say = putText -- | Alias for map, fmap, <$> ( (a -> b) -> f a -> f b -( b) -> a -> b -(<|) = ($) +f <| g = f (g) infixr 0 <| -- | Reverse function application. Do the left side, then pass the -- return value to the function on the right side. (|>) :: a -> (a -> b) -> b -(|>) = (&) +f |> g = g (f) -- | Alias for <&>. Can be read as "and then". Basically does into a -- functor, does some computation, then returns the same kind of -- functor. Could also be defined as `f >>= return . g` (/>) :: Functor f => f a -> (a -> b) -> f b -(/>) = (<&>) +f /> g = fmap g f -- | Removes newlines from text. chomp :: Text -> Text diff --git a/Biz/Bild/Deps.nix b/Biz/Bild/Deps.nix index dccbd81..a1e72ba 100644 --- a/Biz/Bild/Deps.nix +++ b/Biz/Bild/Deps.nix @@ -7,6 +7,7 @@ "bytestring" "capability" "clay" + "cmark" "config-ini" "containers" "directory" diff --git a/Biz/Bild/Rules.nix b/Biz/Bild/Rules.nix index 6afe9a0..9fea5df 100644 --- a/Biz/Bild/Rules.nix +++ b/Biz/Bild/Rules.nix @@ -36,6 +36,10 @@ let deps = lib.lists.flatten (removeNull (map (builtins.match "^-- : dep ([[:alnum:]._-]*)$") (lines content))); + + sysdeps = lib.lists.flatten (removeNull + (map (builtins.match "^-- : sys ([[:alum:]._-]*)$") + (lines content))); }; mkGhc = compiler: (deps: compiler (hp: @@ -56,7 +60,7 @@ in { in stdenv.mkDerivation { name = data.module; src = ../.; - nativeBuildInputs = [ ghc ]; + nativeBuildInputs = [ ghc ] ++ depsToPackageSet nixpkgs data.sysdeps; strictDeps = true; buildPhase = '' mkdir -p $out/bin @@ -111,6 +115,7 @@ in { "ghcjs-base" ]) + nixpkgs.cmark nixpkgs.figlet nixpkgs.hlint nixpkgs.lolcat diff --git a/Biz/Pie.hs b/Biz/Pie.hs index 3823db3..7e1c19e 100644 --- a/Biz/Pie.hs +++ b/Biz/Pie.hs @@ -97,7 +97,7 @@ loadForm :: Namespace -> IO Form loadForm ns = Directory.doesFileExist file >>= \case False -> touch file >> return mempty True -> Aeson.decodeFileStrict file >>= \case - Nothing -> panic $ Text.pack $ "could not decode: " ++ file + Nothing -> panic <| Text.pack <| "could not decode: " ++ file Just x -> return x where file = formFile ns @@ -123,7 +123,7 @@ move mov form = case mov of Exit.ExitFailure _ -> Process.callProcess "git" ["switch", "-c", branch] >> return form - Update -> Haskeline.runInputT Haskeline.defaultSettings $ do + Update -> Haskeline.runInputT Haskeline.defaultSettings <| do timestamp <- liftIO Clock.getCurrentTime onTrack <- parseBool Haskeline.runInputT Haskeline.defaultSettings $ do + Feedback -> Haskeline.runInputT Haskeline.defaultSettings <| do timestamp <- liftIO Clock.getCurrentTime user <- parseText IO (Channel a) chan n = do (i, o) <- Chan.newChan n - return $ Channel i o n + return <| Channel i o n -- | A channel for broadcasting to multiple consumers. See 'mult'. type Mult a = Chan.OutChan a diff --git a/Que/Server.hs b/Que/Server.hs index 4cb0b32..9217ee8 100644 --- a/Que/Server.hs +++ b/Que/Server.hs @@ -25,13 +25,7 @@ module Que.Server ) where -import Alpha hiding - ( Text, - get, - gets, - modify, - poll, - ) +import Alpha hiding (gets, modify, poll) import qualified Control.Concurrent.Go as Go import qualified Control.Concurrent.STM as STM import qualified Control.Exception as Exception @@ -41,11 +35,8 @@ import qualified Data.ByteString.Lazy as BSL import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap import qualified Data.Text.Encoding as Encoding -import Data.Text.Lazy - ( Text, - fromStrict, - ) -import qualified Data.Text.Lazy.IO as Text +import qualified Data.Text.Lazy as Text.Lazy +import qualified Data.Text.Lazy.IO as Text.Lazy.IO import qualified Network.HTTP.Types.Status as Http import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp @@ -105,7 +96,7 @@ instance Envy.DefConfig Config where instance Envy.FromEnv Config -routes :: Scotty.ScottyT Text App () +routes :: Scotty.ScottyT Text.Lazy.Text App () routes = do Scotty.middleware logStdout let quepath = "^\\/([[:alnum:]_-]+)\\/([[:alnum:]._/-]*)$" @@ -117,7 +108,7 @@ routes = do -- GET /_/dash Scotty.get (Scotty.literal "/_/dash") <| do authkey <- fromMaybe "" [Text] -> Scotty.ActionT Text App () +guardNs :: Text.Lazy.Text -> [Text.Lazy.Text] -> Scotty.ActionT Text.Lazy.Text App () guardNs ns whitelist = when (not <| ns `elem` whitelist) <| do Scotty.status Http.methodNotAllowed405 Scotty.text @@ -179,10 +170,10 @@ guardNs ns whitelist = when (not <| ns `elem` whitelist) <| do -- | recover from a scotty-thrown exception. (!:) :: -- | action that might throw - Scotty.ActionT Text App a -> + Scotty.ActionT Text.Lazy.Text App a -> -- | a function providing a default response instead - (Text -> Scotty.ActionT Text App a) -> - Scotty.ActionT Text App a + (Text.Lazy.Text -> Scotty.ActionT Text.Lazy.Text App a) -> + Scotty.ActionT Text.Lazy.Text App a (!:) = Scotty.rescue -- | Forever write the data from 'Que' to 'Wai.StreamingBody'. @@ -212,7 +203,7 @@ insertQue ns qp q as = as {ques = newQues} newQues = HashMap.insert ns newQbase (ques as) newQbase = HashMap.insert qp q <| grab ns <| ques as -extract :: Scotty.ActionT Text App (Namespace, Quepath) +extract :: Scotty.ActionT Text.Lazy.Text App (Namespace, Quepath) extract = do ns <- Scotty.param "1" path <- Scotty.param "2" @@ -232,7 +223,7 @@ modify :: (AppState -> AppState) -> App () modify f = ask >>= liftIO . atomically . flip STM.modifyTVar' f -- | housing for a set of que paths -type Namespace = Text +type Namespace = Text.Lazy.Text -- | a que is just a channel of bytes type Que = Go.Channel Message diff --git a/Que/Website.hs b/Que/Website.hs index 7eb3ae6..623173b 100644 --- a/Que/Website.hs +++ b/Que/Website.hs @@ -38,8 +38,8 @@ main = do [src, ns] -> return (src, Text.pack ns) _ -> Exit.die "usage: que-website [namespace]" mKey <- getKey ns - putText $ "serving " <> Text.pack src <> " at " <> ns - run mKey ns $ + putText <| "serving " <> Text.pack src <> " at " <> ns + run mKey ns <| Sources { index = src "index.md", client = src "client.py", @@ -98,7 +98,7 @@ run key ns Sources {..} = Async.runConcurrently actions |> void toHtml :: FilePath -> IO ByteString toHtml md = BS.pack - <$> Process.readProcess + void [] serve :: Maybe Key -> Namespace -> Text -> ByteString -> IO () -serve Nothing "pub" path content = runReq defaultHttpConfig $ do +serve Nothing "pub" path content = runReq defaultHttpConfig <| do _ <- req POST @@ -120,9 +120,9 @@ serve Nothing "pub" path content = runReq defaultHttpConfig $ do (ReqBodyBs content) ignoreResponse mempty - liftIO $ return () + liftIO <| return () serve Nothing p _ _ = panic <| "no auth key provided for ns: " <> p -serve (Just key) ns path content = runReq defaultHttpConfig $ do +serve (Just key) ns path content = runReq defaultHttpConfig <| do let options = header "Authorization" (encodeUtf8 key) <> responseTimeout maxBound _ <- @@ -132,4 +132,4 @@ serve (Just key) ns path content = runReq defaultHttpConfig $ do (ReqBodyBs content) ignoreResponse options - liftIO $ return () + liftIO <| return () -- cgit v1.2.3