Data.Config.Suckless.Script

lib/Data/Config/Suckless.hs

@@ -9,3 +9,4 @@ import Data.Config.Suckless.Syntax
 import Data.Config.Suckless.Parse
 import Data.Config.Suckless.KeyValue
 
+

lib/Data/Config/Suckless/Script.hs

@@ -0,0 +1,49 @@
+{-# Language UndecidableInstances #-}
+{-# Language PatternSynonyms #-}
+module Data.Config.Suckless.Script
+  ( module Exported
+  , module Data.Config.Suckless.Script
+  ) where
+
+import Data.Config.Suckless as Exported
+import Data.Config.Suckless.Script.Internal as Exported
+
+import Control.Monad.Reader
+import Data.HashMap.Strict qualified as HM
+import Prettyprinter
+import Prettyprinter.Render.Terminal
+import Data.List qualified as List
+import Data.Text qualified as Text
+import UnliftIO
+
+
+{- HLINT ignore "Functor law" -}
+
+helpList :: MonadUnliftIO m => Bool -> Maybe String -> RunM c m ()
+helpList hasDoc p = do
+
+  let match = maybe (const True) (Text.isPrefixOf . Text.pack) p
+
+  d <- ask >>= readTVarIO
+  let ks = [k | Id k <- List.sort (HM.keys d)
+           , match k
+           , not hasDoc || docDefined (HM.lookup (Id k) d)
+           ]
+
+  display_ $ vcat (fmap pretty ks)
+
+  where
+    docDefined (Just (Bind (Just w) _)) = True
+    docDefined _ = False
+
+helpEntry :: MonadUnliftIO m => Id -> RunM c m ()
+helpEntry what = do
+  man <- ask >>= readTVarIO
+           <&> HM.lookup what
+           <&> maybe mzero bindMan
+
+  liftIO $ hPutDoc stdout (pretty man)
+
+pattern HelpEntryBound :: forall {c}. Id -> [Syntax c]
+pattern HelpEntryBound what <- [ListVal (SymbolVal "builtin:lambda" : SymbolVal what : _ )]
+

lib/Data/Config/Suckless/Script/File.hs

@@ -0,0 +1,85 @@
+{-# Language MultiWayIf #-}
+module Data.Config.Suckless.Script.File where
+
+import Data.Config.Suckless
+import Data.Config.Suckless.Script.Internal
+
+import Control.Monad
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Cont
+import Data.Maybe
+import Data.Either
+import Data.Foldable
+import System.Directory
+import System.FilePath
+import System.FilePattern
+import Data.HashSet qualified as HS
+
+import Lens.Micro.Platform
+import UnliftIO
+import Control.Concurrent.STM qualified as STM
+import Streaming.Prelude qualified as S
+
+-- FIXME: skip-symlink
+glob :: forall m . MonadIO m
+     => [FilePattern]           -- ^ search patterns
+     -> [FilePattern]           -- ^ ignore patterns
+     -> FilePath                -- ^ directory
+     -> (FilePath -> m Bool)    -- ^ file action
+     -> m ()
+
+glob pat ignore dir action = do
+  q <- newTQueueIO
+  void $ liftIO (async $ go q dir >> atomically (writeTQueue q Nothing))
+  fix $ \next -> do
+    atomically (readTQueue q) >>= \case
+      Nothing -> pure ()
+      Just x -> do
+        r <- action x
+        when r next
+
+  where
+
+    matches p f = or [ i ?== f | i <- p ]
+    skip p = or [ i ?== p | i <- ignore ]
+
+    go q f = do
+
+      isD <- doesDirectoryExist f
+
+      if not isD then do
+        isF <- doesFileExist f
+        when (isF && matches pat f && not (skip f)) do
+          atomically $ writeTQueue q (Just f)
+      else do
+        co' <- (try @_ @IOError $ listDirectory f)
+                 <&> fromRight mempty
+
+        forConcurrently_ co' $ \x -> do
+          let p = normalise (f </> x)
+          unless (skip p) (go q p)
+
+entries :: forall c m . ( IsContext c
+                        , Exception (BadFormException c)
+                        , MonadUnliftIO m)
+         => MakeDictM c m ()
+entries = do
+  entry $ bindMatch "glob" $ \syn -> do
+
+    (p,i,d) <- case syn of
+                 [] -> pure (["*"], [], ".")
+
+                 [StringLike d, StringLike i, StringLike e] -> do
+                    pure ([i], [e], d)
+
+                 [StringLike d, ListVal (StringLikeList i), ListVal (StringLikeList e)] -> do
+                    pure (i, e, d)
+
+                 _ -> throwIO (BadFormException @c nil)
+
+    r <- S.toList_ $ glob p i d $ \fn -> do
+          S.yield (mkStr @c fn) -- do
+          pure True
+
+    pure (mkList r)
+

lib/Data/Config/Suckless/Script/Internal.hs

@@ -0,0 +1,968 @@
+{-# Language AllowAmbiguousTypes #-}
+{-# Language UndecidableInstances #-}
+{-# Language PatternSynonyms #-}
+{-# Language ViewPatterns #-}
+module Data.Config.Suckless.Script.Internal
+  ( module Data.Config.Suckless.Script.Internal
+  , module Export
+  ) where
+
+import Data.Config.Suckless
+
+import Control.Applicative
+import Control.Monad.Identity
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Data.ByteString (ByteString)
+import Data.ByteString.Char8 qualified as BS8
+import Data.Data
+import Data.Function as Export
+import Data.Functor as Export
+import Data.Hashable
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HM
+import Data.Kind
+import Data.List (isPrefixOf)
+import Data.List qualified as List
+import Data.Maybe
+import Data.String
+import Data.Text.IO qualified as TIO
+import Data.Text qualified as Text
+import Data.Text (Text)
+import Data.Time.Clock.POSIX
+import GHC.Generics hiding (C)
+import Prettyprinter
+import Prettyprinter.Render.Terminal
+import Safe
+import Streaming.Prelude qualified as S
+import System.Environment
+import Text.InterpolatedString.Perl6 (qc)
+import UnliftIO
+
+-- TODO: move-to-suckless-conf
+
+data ManApplyArg = ManApplyArg Text Text
+                   deriving stock (Eq,Show,Data,Generic)
+
+newtype ManApply = ManApply [ ManApplyArg ]
+                   deriving stock (Eq,Show,Data,Generic)
+                   deriving newtype (Semigroup,Monoid)
+
+data ManSynopsis =
+  ManSynopsis ManApply
+  deriving stock (Eq,Show,Data,Generic)
+
+data ManDesc     = ManDescRaw Text
+  deriving stock (Eq,Show,Data,Generic)
+
+data ManRetVal   = ManRetVal
+  deriving stock (Eq,Show,Data,Generic)
+
+newtype ManName a = ManName Id
+  deriving stock (Eq,Show,Data,Generic)
+  deriving newtype (IsString,Pretty)
+
+newtype ManBrief = ManBrief Text
+  deriving stock (Eq,Show,Data,Generic)
+  deriving newtype (Pretty,IsString)
+
+data ManReturns = ManReturns Text Text
+  deriving stock (Eq,Show,Data,Generic)
+
+newtype ManExamples =
+  ManExamples Text
+  deriving stock (Eq,Show,Data,Generic)
+  deriving newtype (Pretty,IsString,Monoid,Semigroup)
+
+class ManNameOf a ann where
+  manNameOf :: a -> ManName ann
+
+data Man a =
+  Man
+  { manName     :: Maybe (ManName a)
+  , manHidden   :: Bool
+  , manBrief    :: Maybe ManBrief
+  , manSynopsis :: [ManSynopsis]
+  , manDesc     :: Maybe ManDesc
+  , manReturns  :: Maybe ManReturns
+  , manExamples :: [ManExamples]
+  }
+  deriving stock (Eq,Show,Generic)
+
+instance Monoid (Man a) where
+  mempty = Man Nothing False Nothing mempty Nothing Nothing mempty
+
+instance Semigroup (Man a) where
+  (<>) a b = Man (manName b <|> manName a)
+                 (manHidden b || manHidden a)
+                 (manBrief b <|> manBrief a)
+                 (manSynopsis a <> manSynopsis b)
+                 (manDesc b <|> manDesc a)
+                 (manReturns b <|> manReturns a)
+                 (manExamples a <> manExamples b)
+
+instance ManNameOf Id a where
+  manNameOf = ManName
+
+
+instance Pretty ManDesc where
+  pretty = \case
+    ManDescRaw t -> pretty t
+
+instance IsString ManDesc where
+  fromString s = ManDescRaw (Text.pack s)
+
+instance Pretty (Man a) where
+  pretty e =   "NAME"
+             <> line
+             <> indent 8 (pretty (manName e) <> fmtBrief e)
+             <> line
+             <> fmtSynopsis
+             <> fmtDescription
+             <> retval
+             <> fmtExamples
+   where
+    fmtBrief a = case manBrief a of
+      Nothing -> mempty
+      Just x  -> " - " <> pretty x
+
+    retval = case manReturns e of
+      Nothing -> mempty
+      Just (ManReturns t s) ->
+        line <> "RETURN VALUE" <> line
+        <> indent 8 (
+            if not (Text.null s) then
+              (pretty t <> hsep ["","-",""] <> pretty s) <> line
+            else pretty t )
+
+    fmtDescription = line
+      <> "DESCRIPTION" <> line
+      <> indent 8 ( case manDesc e of
+           Nothing -> pretty (manBrief e)
+           Just x  -> pretty x)
+      <> line
+
+    fmtSynopsis = case manSynopsis e of
+      [] -> mempty
+      _  ->
+           line
+        <> "SYNOPSIS"
+        <> line
+        <> vcat (fmap synEntry (manSynopsis e))
+        <> line
+
+    fmtExamples = case manExamples e of
+      [] -> mempty
+      es -> line
+        <> "EXAMPLES"
+        <> line
+        <> indent 8 ( vcat (fmap pretty es) )
+
+    synEntry (ManSynopsis (ManApply [])) =
+      indent 8 ( parens (pretty (manName e)) ) <> line
+
+    synEntry (ManSynopsis (ManApply xs)) = do
+      indent 8 do
+        parens (pretty (manName e) <+>
+         hsep [ pretty n | ManApplyArg t n <- xs ]  )
+         <> line
+         <> line
+         <> vcat [ pretty n <+> ":" <+> pretty t | ManApplyArg t n <- xs ]
+
+stringLike :: Syntax c -> Maybe String
+stringLike = \case
+  LitStrVal s -> Just $ Text.unpack s
+  SymbolVal (Id s) -> Just $ Text.unpack s
+  _ -> Nothing
+
+stringLikeList :: [Syntax c] -> [String]
+stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes
+
+blobLike :: Syntax c -> Maybe ByteString
+blobLike = \case
+  LitStrVal s -> Just $ BS8.pack (Text.unpack s)
+  ListVal [SymbolVal "blob", LitStrVal s] -> Just $ BS8.pack (Text.unpack s)
+  _ -> Nothing
+
+pattern BlobLike :: forall {c} . ByteString -> Syntax c
+pattern BlobLike s <- (blobLike -> Just s)
+
+class Display a where
+  display :: MonadIO m => a -> m ()
+
+instance  {-# OVERLAPPABLE #-} Pretty w => Display w  where
+  display = liftIO . print . pretty
+
+instance IsContext c => Display (Syntax c) where
+  display = \case
+    LitStrVal s -> liftIO $ TIO.putStr s
+    -- ListVal [SymbolVal "small-encrypted-block", LitStrVal txt] -> do
+    --   let s = Text.unpack txt & BS8.pack & toBase58 & AsBase58 & pretty
+    --   liftIO $ print $ parens $ "small-encrypted-block" <+> parens ("blob" <+> dquotes s)
+    -- ListVal [SymbolVal "blob", LitStrVal txt] -> do
+    --   let s = Text.unpack txt & BS8.pack & toBase58 & AsBase58 & pretty
+    --   liftIO $ print $ parens $ "blob:base58" <+> dquotes s
+    x           -> liftIO $ putStr (show $ pretty x)
+
+instance Display Text where
+  display = liftIO . TIO.putStr
+
+instance Display String where
+  display = liftIO . putStr
+
+display_ :: (MonadIO m, Show a) => a -> m ()
+display_ = liftIO . print
+
+{- HLINT ignore "Functor law" -}
+
+class IsContext c => MkSym c a where
+  mkSym :: a -> Syntax c
+
+instance IsContext c => MkSym c String where
+  mkSym s = Symbol noContext (Id $ Text.pack s)
+
+instance IsContext c => MkSym c Text where
+  mkSym s = Symbol noContext (Id s)
+
+instance IsContext c => MkSym c Id where
+  mkSym = Symbol noContext
+
+class IsContext c => MkStr c s where
+  mkStr :: s -> Syntax c
+
+instance IsContext c => MkStr c String where
+  mkStr s = Literal noContext $ LitStr (Text.pack s)
+
+instance IsContext c => MkStr c Text where
+  mkStr s = Literal noContext $ LitStr s
+
+mkBool :: forall c . IsContext c => Bool -> Syntax c
+mkBool v = Literal noContext (LitBool v)
+
+
+class IsContext c => MkForm c a where
+ mkForm :: a-> [Syntax c] -> Syntax c
+
+instance (IsContext c, MkSym c s) => MkForm c s where
+ mkForm s sy = List noContext ( mkSym @c s :  sy )
+
+mkList :: forall c. IsContext c => [Syntax c] -> Syntax c
+mkList = List noContext
+
+isFalse :: forall c . IsContext c => Syntax c -> Bool
+isFalse = \case
+    Literal _ (LitBool False) -> True
+    ListVal [] -> True
+    _ -> False
+
+eatNil :: Monad m => (Syntax c -> m a) -> Syntax c -> m ()
+eatNil f = \case
+  Nil -> pure ()
+  x   -> void $ f x
+
+class IsContext c => MkInt c s where
+  mkInt :: s -> Syntax c
+
+instance (Integral i, IsContext c) => MkInt c i where
+  mkInt n = Literal noContext $ LitInt (fromIntegral n)
+
+class OptionalVal c b where
+  optional :: b -> Syntax c -> b
+
+instance IsContext c => OptionalVal c Int where
+  optional d = \case
+    LitIntVal x -> fromIntegral x
+    _           -> d
+
+hasKey :: IsContext c => Id -> [Syntax c] -> Maybe (Syntax c)
+hasKey k ss = headMay [ e | ListVal [SymbolVal z, e] <- ss, z == k]
+
+
+pattern Lambda :: forall {c}. [Id] -> Syntax c -> Syntax c
+pattern Lambda a e <- ListVal [SymbolVal "lambda", LambdaArgs a, e]
+
+pattern LambdaArgs :: [Id] -> Syntax c
+pattern LambdaArgs a <- (lambdaArgList -> Just a)
+
+
+lambdaArgList :: Syntax c -> Maybe [Id]
+
+lambdaArgList (ListVal a) = sequence argz
+  where
+    argz = flip fmap a \case
+      (SymbolVal x) -> Just x
+      _             -> Nothing
+
+lambdaArgList _ = Nothing
+
+
+pattern PairList :: [Syntax c] -> [Syntax c]
+pattern PairList es <- (pairList -> es)
+
+pairList :: [Syntax c ] -> [Syntax c]
+pairList syn = [ isPair s | s <- syn ] & takeWhile isJust & catMaybes
+
+optlist :: IsContext c => [Syntax c] -> [(Id, Syntax c)]
+optlist = reverse . go []
+  where
+    go acc ( SymbolVal i : b : rest ) = go ((i, b) : acc) rest
+    go acc [ SymbolVal i ] = (i, nil) : acc
+    go acc _ = acc
+
+
+isPair :: Syntax c -> Maybe (Syntax c)
+isPair = \case
+  e@(ListVal [_,_]) -> Just e
+  _ -> Nothing
+
+data BindAction c ( m :: Type -> Type)  =
+    BindLambda { fromLambda :: [Syntax c] -> RunM c m (Syntax c) }
+  | BindValue  (Syntax c)
+
+data Bind c ( m :: Type -> Type)  = Bind
+  { bindMan         :: Maybe (Man AnsiStyle)
+  , bindAction      :: BindAction c m
+  } deriving (Generic)
+
+deriving newtype instance Hashable Id
+
+newtype NameNotBoundException =
+  NameNotBound Id
+  deriving stock Show
+  deriving newtype (Generic,Typeable)
+
+newtype NotLambda = NotLambda Id
+                    deriving stock Show
+                    deriving newtype (Generic,Typeable)
+
+instance Exception NotLambda
+
+data BadFormException c = BadFormException (Syntax c)
+                        | ArityMismatch (Syntax c)
+
+newtype TypeCheckError c = TypeCheckError (Syntax c)
+
+instance Exception (TypeCheckError C)
+
+newtype BadValueException = BadValueException String
+                            deriving stock Show
+                            deriving newtype (Generic,Typeable)
+
+instance Exception NameNotBoundException
+
+instance IsContext c => Show (BadFormException c) where
+  show (BadFormException sy) = show $ "BadFormException" <+> pretty sy
+  show (ArityMismatch sy) = show $ "ArityMismatch" <+> pretty sy
+
+instance IsContext c => Show (TypeCheckError c) where
+  show (TypeCheckError sy) = show $ "TypeCheckError" <+> pretty sy
+
+instance Exception (BadFormException C)
+
+instance Exception BadValueException
+
+type Dict c m = HashMap Id (Bind c m)
+
+newtype RunM c m a = RunM { fromRunM :: ReaderT (TVar (Dict c m)) m a }
+                     deriving newtype ( Applicative
+                                      , Functor
+                                      , Monad
+                                      , MonadIO
+                                      , MonadUnliftIO
+                                      , MonadReader (TVar (Dict c m))
+                                      )
+
+instance MonadTrans (RunM c) where
+  lift = RunM . lift
+
+newtype MakeDictM c m a = MakeDictM { fromMakeDict :: Writer (Dict c m) a }
+                          deriving newtype ( Applicative
+                                           , Functor
+                                           , Monad
+                                           , MonadWriter (Dict c m)
+                                           )
+
+makeDict :: (IsContext c, Monad m) =>  MakeDictM c m () -> Dict c m
+makeDict w = execWriter ( fromMakeDict w )
+
+entry :: Dict c m  -> MakeDictM c m ()
+entry = tell
+
+hide :: MakeDictM c m ()
+hide = pure ()
+
+desc :: Doc ann -> MakeDictM c m () -> MakeDictM c m ()
+desc txt = censor (HM.map setDesc)
+  where
+    w0 = mempty { manDesc = Just (ManDescRaw $ Text.pack $ show txt) }
+    setDesc (Bind w x) = Bind (Just (maybe w0 (<> w0) w)) x
+
+brief :: ManBrief -> MakeDictM c m () -> MakeDictM c m ()
+brief txt = censor (HM.map setBrief)
+  where
+    w0 = mempty { manBrief = Just txt }
+    setBrief (Bind w x) = Bind (Just (maybe w0 (<> w0) w)) x
+
+returns :: Text -> Text -> MakeDictM c m () -> MakeDictM c m ()
+returns tp txt = censor (HM.map setReturns)
+  where
+    w0 = mempty { manReturns = Just (ManReturns tp txt) }
+    setReturns (Bind w x) = Bind (Just (maybe w0 (<>w0) w)) x
+
+
+addSynopsis :: ManSynopsis -> Bind c m -> Bind c m
+addSynopsis synopsis (Bind w x) = Bind (Just updatedMan) x
+  where
+    updatedMan = case w of
+      Nothing -> mempty { manSynopsis = [synopsis] }
+      Just man -> man { manSynopsis = manSynopsis man <> [synopsis] }
+
+noArgs :: MakeDictM c m () -> MakeDictM c m ()
+noArgs = censor (HM.map (addSynopsis (ManSynopsis (ManApply []))))
+
+arg :: Text -> Text -> ManApplyArg
+arg = ManApplyArg
+
+
+args :: [ManApplyArg] -> MakeDictM c m () -> MakeDictM c m ()
+args argList = censor (HM.map (addSynopsis (ManSynopsis (ManApply argList))))
+
+opt :: Doc a -> Doc a -> Doc a
+opt n d = n <+> "-" <+> d
+
+examples :: ManExamples -> MakeDictM c m () -> MakeDictM c m ()
+examples (ManExamples s) = censor (HM.map setExamples )
+  where
+    ex = ManExamples (Text.unlines $ Text.strip <$> Text.lines (Text.strip s))
+    ex0 = mempty { manExamples = [ex] }
+    setExamples (Bind w x) = Bind (Just (maybe ex0 (<>ex0) w)) x
+
+splitForms :: [String] -> [[String]]
+splitForms s0 = runIdentity $ S.toList_ (go mempty s0)
+  where
+    go acc ( "then" : rest ) = emit acc >> go mempty rest
+    go acc ( "and" : rest ) = emit acc >> go mempty rest
+    go acc ( x : rest ) | isPrefixOf "-"  x =  go ( x : acc ) rest
+    go acc ( x : rest ) | isPrefixOf "--" x =  go ( x : acc ) rest
+    go acc ( x : rest ) = go ( x : acc ) rest
+    go acc [] = emit acc
+
+    emit = S.yield . reverse
+
+applyLambda :: forall c m . ( IsContext c
+                            , MonadUnliftIO m
+                            , Exception (BadFormException c)
+                            )
+            => [Id]
+            -> Syntax c
+            -> [Syntax c]
+            -> RunM c m (Syntax c)
+applyLambda decl body args = do
+
+  when (length decl /= length args) do
+    throwIO (ArityMismatch @c nil)
+
+  ev <- mapM eval args
+  tv <- ask
+  d0 <- readTVarIO tv
+
+  forM_ (zip decl ev) $ \(n,v) -> do
+    bind n v
+
+  e <- eval body
+
+  atomically $ writeTVar tv d0
+  pure e
+
+apply_ :: forall c m . ( IsContext c
+                      , MonadUnliftIO m
+                      , Exception (BadFormException c)
+                      )
+      => Syntax c
+      -> [Syntax c]
+      -> RunM c m (Syntax c)
+
+apply_ s args = case s of
+  ListVal [SymbolVal "builtin:lambda", SymbolVal n]  -> apply n args
+  SymbolVal   what  -> apply what args
+  Lambda d body     -> applyLambda d body args
+  e -> throwIO $ BadFormException @c s
+
+apply :: forall c m . ( IsContext c
+                      , MonadUnliftIO m
+                      , Exception (BadFormException c)
+                      )
+      => Id
+      -> [Syntax c]
+      -> RunM c m (Syntax c)
+apply name args' = do
+  -- notice $ red "APPLY" <+> pretty name
+  what <- ask >>=  readTVarIO <&> HM.lookup name
+
+  case bindAction <$> what of
+    Just (BindLambda e) -> mapM eval args' >>= e
+
+    Just (BindValue (Lambda argz body) )  -> do
+      applyLambda argz body args'
+
+    Just (BindValue _) -> do
+      throwIO (NotLambda name)
+
+    Nothing -> throwIO (NameNotBound name)
+
+bind :: forall c m . ( IsContext c
+                     , MonadUnliftIO m
+                     , Exception (BadFormException c)
+                     )
+     => Id
+     -> Syntax c
+     -> RunM c m ()
+bind name expr = do
+  t <- ask
+
+  what <- case expr of
+           ListVal [SymbolVal "builtin:lambda", SymbolVal n] -> do
+             m <- readTVarIO t
+             HM.lookup n m & maybe (throwIO (NameNotBound n)) pure
+
+           e -> pure $ Bind mzero (BindValue e)
+
+  atomically do
+    modifyTVar t (HM.insert name what)
+
+bindBuiltins ::  forall c m . ( IsContext c
+                              , MonadUnliftIO m
+                              , Exception (BadFormException c)
+                              )
+            => Dict c m
+            -> RunM c m ()
+
+bindBuiltins  dict = do
+  t <- ask
+  atomically do
+    modifyTVar t (<> dict)
+
+eval :: forall c m . ( IsContext c
+                     , MonadUnliftIO m
+                     , Exception (BadFormException c)
+                     ) => Syntax c -> RunM c m (Syntax c)
+eval syn = handle (handleForm syn) $ do
+
+    dict <- ask >>= readTVarIO
+
+    case syn of
+
+      ListVal [ w, SymbolVal ".", b] -> do
+        pure  $ mkList  [w, b]
+
+      ListVal [ SymbolVal "quot", ListVal b] -> do
+        pure  $ mkList  b
+
+      ListVal [SymbolVal "define", SymbolVal what, e] -> do
+        ev <- eval e
+        bind what ev>> pure nil
+
+      ListVal [SymbolVal "lambda", arglist, body] -> do
+        pure $ mkForm @c "lambda" [ arglist, body ]
+
+      ListVal [SymbolVal "define", LambdaArgs (name : args), e] -> do
+        bind name ( mkForm @c  "lambda" [ mkList [ mkSym s | s <- args], e ] )
+        pure nil
+
+      ListVal [SymbolVal "false?", e'] -> do
+        e <- eval e'
+        pure $ if isFalse e then mkBool True else mkBool False
+
+      ListVal [SymbolVal "if", w, e1, e2] -> do
+        what <- eval w
+        if isFalse what then eval e2 else eval e1
+
+      ListVal (SymbolVal "begin" : what) -> do
+        evalTop what
+
+      e@(ListVal (SymbolVal "blob" : what)) -> do
+        pure e
+        -- evalTop what
+
+      lc@(ListVal (Lambda decl body : args))  -> do
+        applyLambda decl body args
+
+      ListVal (SymbolVal name : args') -> do
+        apply name args'
+
+      SymbolVal (Id s) | Text.isPrefixOf ":" s -> do
+        pure (mkSym @c (Text.drop 1 s))
+
+      SymbolVal name | HM.member name dict -> do
+        let what = HM.lookup name dict
+                     & maybe (BindValue (mkSym name)) bindAction
+
+        case what of
+          BindValue e  -> pure e
+          BindLambda e -> pure $ mkForm "builtin:lambda" [mkSym name]
+
+      e@(SymbolVal name) | not (HM.member name dict) -> do
+        pure e
+
+      e@Literal{} -> pure e
+
+      e -> throwIO $ BadFormException @c e
+
+  where
+    handleForm syn = \case
+      (BadFormException _  :: BadFormException c) -> do
+        throwIO (BadFormException syn)
+      (ArityMismatch s  :: BadFormException c) -> do
+        throwIO (ArityMismatch syn)
+
+runM :: forall c m a. ( IsContext c
+                      , MonadUnliftIO m
+                      , Exception (BadFormException c)
+                      ) => Dict c m -> RunM c m a ->  m a
+runM  d  m = do
+  tvd <- newTVarIO d
+  runReaderT (fromRunM m) tvd
+
+run :: forall c m . ( IsContext c
+                    , MonadUnliftIO m
+                    , Exception (BadFormException c)
+                    ) => Dict c m -> [Syntax c] -> m (Syntax c)
+run d sy = do
+  tvd <- newTVarIO d
+  lastDef nil <$> runReaderT (fromRunM (mapM eval sy)) tvd
+
+evalTop :: forall c m . ( IsContext c
+                        , MonadUnliftIO m
+                        , Exception (BadFormException c))
+     => [Syntax c]
+     -> RunM c m (Syntax c)
+evalTop syn = lastDef nil <$> mapM eval syn
+
+bindMatch :: Id -> ([Syntax c] -> RunM c m (Syntax c)) -> Dict c m
+bindMatch n fn = HM.singleton n (Bind man (BindLambda fn))
+  where
+    man = Just $ mempty { manName = Just (manNameOf n) }
+
+bindValue :: Id -> Syntax c -> Dict c m
+bindValue n e = HM.singleton n (Bind mzero (BindValue e))
+
+nil :: forall c . IsContext c => Syntax c
+nil = List noContext []
+
+nil_ :: (IsContext c, MonadIO m) =>  (a -> RunM c m b) -> a -> RunM c m (Syntax c)
+nil_ m w = m w >> pure (List noContext [])
+
+fixContext :: (IsContext c1, IsContext c2) => Syntax c1 -> Syntax c2
+fixContext = go
+  where
+    go = \case
+      List    _ xs -> List noContext (fmap go xs)
+      Symbol  _ w  -> Symbol noContext w
+      Literal _ l  -> Literal noContext l
+
+
+fmt :: Syntax c -> Doc ann
+fmt = \case
+  LitStrVal x -> pretty $ Text.unpack x
+  x -> pretty x
+
+internalEntries :: forall c m . (IsContext c, Exception (BadFormException c), MonadUnliftIO m) => MakeDictM c m ()
+internalEntries = do
+
+    entry $ bindValue "false"      (mkBool False)
+    entry $ bindValue "true"       (mkBool True)
+    entry $ bindValue "chr:semi"   (mkStr ";")
+    entry $ bindValue "chr:tilda"  (mkStr "~")
+    entry $ bindValue "chr:colon"  (mkStr ":")
+    entry $ bindValue "chr:comma"  (mkStr ",")
+    entry $ bindValue "chr:q"      (mkStr "'")
+    entry $ bindValue "chr:minus"  (mkStr "-")
+    entry $ bindValue "chr:dq"     (mkStr "\"")
+    entry $ bindValue "chr:lf"     (mkStr "\n")
+    entry $ bindValue "chr:cr"     (mkStr "\r")
+    entry $ bindValue "chr:tab"    (mkStr "\t")
+    entry $ bindValue "chr:space"  (mkStr " ")
+
+    brief "concatenates list of string-like elements into a string"
+      $ args [arg "list" "(list ...)"]
+      $ args [arg "..." "..."]
+      $ returns "string" ""
+      $ examples [qc|
+        (concat a b c d)
+        abcd|]
+      $ examples [qc|
+        (concat 1 2 3 4 5)
+        12345|]
+
+      $ entry $ bindMatch "concat" $ \syn -> do
+
+        case syn of
+          [ListVal xs] -> do
+            pure $ mkStr ( show $ hcat (fmap fmt xs) )
+
+          xs -> do
+            pure $ mkStr ( show $ hcat (fmap fmt xs) )
+
+    brief "creates a list of elements"
+      $ args [arg "..." "..."]
+      $ returns "list" ""
+      $ examples [qc|
+(list 1 2 3 fuu bar "baz")
+(1 2 3 fuu bar "baz")
+      |]
+      $ entry $ bindMatch "list" $ \case
+        es -> do
+          pure $ mkList es
+
+    entry $ bindMatch "dict" $ \case
+      (pairList -> es@(_:_)) -> do
+        pure $ mkForm "dict" es
+      [a, b] -> do
+        pure $ mkForm "dict" [ mkList [a, b] ]
+      _ -> throwIO (BadFormException @C nil)
+
+    brief "creates a dict from a linear list of string-like items"
+      $ args [arg "list-of-terms" "..."]
+      $ desc (    "macro; syntax sugar" <> line
+               <> "useful for creating function args" <> line
+               <> "leftover records are skipped"
+             )
+      $ returns "dict" ""
+      $ examples [qc|
+[kw a 1 b 2 c 3]
+(dict (a 1) (b 2) (c 3))
+
+[kw a]
+(dict (a ()))
+
+[kw a b]
+(dict (a b))
+
+[kw 1 2 3]
+(dict)
+
+[kw a b c]
+(dict (a b) (c ()))
+      |]
+      $ entry $ bindMatch "kw" $ \syn -> do
+         let wat = [ mkList @c [mkSym i, e] | (i,e) <- optlist syn ]
+         pure $ mkForm "dict" wat
+
+    entry $ bindMatch "iterate" $ nil_ $ \syn -> do
+      case syn of
+        [ListVal (SymbolVal "builtin:lambda" : SymbolVal fn : _), ListVal rs] -> do
+          mapM_ (apply @c fn . List.singleton) rs
+
+        [Lambda decl body,  ListVal args]  -> do
+          mapM_ (applyLambda decl body . List.singleton) args
+
+        _ -> do
+          throwIO (BadFormException @C nil)
+
+    entry $ bindMatch "repeat" $ nil_ $ \case
+      [LitIntVal n, Lambda [] b] -> do
+        replicateM_ (fromIntegral n) (applyLambda [] b [])
+
+      [LitIntVal n, e@(ListVal _)] -> do
+        replicateM_ (fromIntegral n) (eval e)
+
+      z ->
+        throwIO (BadFormException @C nil)
+
+    entry $ bindMatch "map" $ \syn -> do
+      case syn of
+        [ListVal (SymbolVal "builtin:lambda" : SymbolVal fn : _), ListVal rs] -> do
+          mapM (apply @c fn . List.singleton) rs
+            <&> mkList
+
+        [Lambda decl body,  ListVal args]  -> do
+          mapM (applyLambda decl body . List.singleton) args
+            <&> mkList
+
+        _ -> do
+          throwIO (BadFormException @C nil)
+
+    entry $ bindMatch "head" $ \case
+      [ ListVal es ] -> pure (head es)
+      _ -> throwIO (TypeCheckError @C nil)
+
+    brief "get tail of list"
+      $ args [arg "list" "list"]
+      $ desc "nil if the list is empty; error if not list"
+      $ examples [qc|
+      (tail [list 1 2 3])
+      (2 3)
+      (tail [list])
+      |]
+      $ entry $ bindMatch "tail" $ \case
+        [] -> pure nil
+        [ListVal []] -> pure nil
+        [ListVal es] -> pure $ mkList  (tail es)
+        _ -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "lookup" $ \case
+      [s, ListVal (SymbolVal "dict" : es) ] -> do
+        let val = headDef nil [ v | ListVal [k, v] <- es, k == s ]
+        pure val
+
+      [StringLike s, ListVal [] ] -> do
+        pure nil
+
+      _ -> throwIO (BadFormException @c nil)
+
+    brief "returns current unix time"
+      $ returns "int" "current unix time in seconds"
+      $ noArgs
+      $ entry $ bindMatch "now" $ \case
+        [] -> mkInt . round <$> liftIO getPOSIXTime
+        _  -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "display" $ nil_ \case
+      [ sy ] -> display sy
+      ss     -> display (mkList ss)
+
+    brief "prints new line character to stdout"
+      $ entry $ bindMatch "newline" $ nil_ $ \case
+          [] -> liftIO (putStrLn "")
+          _  -> throwIO (BadFormException @c nil)
+
+    brief "prints a list of terms to stdout"
+      $ entry $ bindMatch "print" $ nil_ $ \case
+          [ sy ] -> display sy
+          ss     -> mapM_ display ss
+
+    entry $ bindMatch "println" $ nil_ $ \case
+      [ sy ] -> display sy >> liftIO (putStrLn "")
+      ss     -> mapM_ display ss >> liftIO (putStrLn "")
+
+    entry $ bindMatch "str:read-stdin" $ \case
+      [] -> liftIO getContents <&> mkStr @c
+
+      _ -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "str:put" $ nil_ $ \case
+      [LitStrVal s] -> liftIO $ TIO.putStr s
+      _ -> throwIO (BadFormException @c nil)
+
+    brief "reads file as a string" do
+      entry $ bindMatch "str:read-file" $ \case
+        [StringLike fn] -> liftIO (TIO.readFile fn) <&> mkStr
+
+        _ -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "str:save" $ nil_ \case
+      [StringLike fn, StringLike what] ->
+        liftIO (writeFile fn what)
+
+      _ -> throwIO (BadFormException @c nil)
+
+    entry $ bindValue "space" $ mkStr " "
+
+    entry $ bindMatch "parse-top" $ \case
+
+      [SymbolVal w, LitStrVal s] -> do
+        pure $  parseTop s & either (const nil) (mkForm w . fmap fixContext)
+
+      [LitStrVal s] -> do
+        pure $  parseTop s & either (const nil) (mkList . fmap fixContext)
+
+      _ -> throwIO (BadFormException @c nil)
+
+    let atomFrom = \case
+          [StringLike s] -> pure (mkSym s)
+          [e]            -> pure (mkSym $ show $ pretty e)
+          _ -> throwIO (BadFormException @c nil)
+
+    brief "type of argument"
+      $ args [arg "term" "term"]
+      $ returns "symbol" "type"
+      $ entry $ bindMatch "type" \case
+        [ListVal _]    -> pure $ mkSym "list"
+        [SymbolVal _]  -> pure $ mkSym "symbol"
+        [LitStrVal _]  -> pure $ mkSym "string"
+        [LitIntVal _]  -> pure $ mkSym "int"
+        [LitScientificVal _] -> pure $ mkSym "float"
+        [LitBoolVal _] -> pure $ mkSym "bool"
+        _ -> throwIO (BadFormException @c nil)
+
+    brief "creates a symbol from argument"
+      $ args [arg "any-term" "term"]
+      $ returns "symbol" ""
+      do
+        entry $ bindMatch "sym"  atomFrom
+        entry $ bindMatch "atom" atomFrom
+
+    brief "compares two terms" $
+      args [arg "term" "a", arg "term" "b"] $
+      returns "boolean" "#t if terms are equal, otherwise #f" $
+        entry $ bindMatch "eq?" $ \case
+          [a, b] -> do
+            pure $ if a == b then mkBool True else mkBool False
+          _ -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "length" $ \case
+      [ListVal es] -> pure $ mkInt (length es)
+      [StringLike es] -> pure $ mkInt (length es)
+      _ -> pure $ mkInt 0
+
+    entry $ bindMatch "nil?" $ \case
+      [ListVal []] -> pure $ mkBool True
+      _ -> pure $ mkBool False
+
+    entry $ bindMatch "not" $ \case
+      [w] -> do
+        pure $ if isFalse w then mkBool True else mkBool False
+      _ -> throwIO (BadFormException @c nil)
+
+    brief "get system environment"
+     $ args []
+     $ args [ arg "string" "string" ]
+     $ returns "env" "single var or dict of all vars"
+     $ examples [qc|
+      (env HOME)
+      /home/user
+
+      (env)
+      (dict
+         (HOME "/home/user") ... (CC "gcc") ...)
+     |]
+     $ entry $ bindMatch "env" $ \case
+         [] -> do
+           s <- liftIO getEnvironment
+           pure $ mkForm "dict" [ mkList [mkSym @c a, mkStr b] | (a,b) <- s ]
+
+         [StringLike s] -> do
+           liftIO (lookupEnv s)
+              <&> maybe nil mkStr
+         _ -> throwIO (BadFormException @c nil)
+
+    -- FIXME: we-need-opaque-type
+    entry $ bindMatch "blob:read-stdin" $ \case
+      [] -> do
+        blob <- liftIO BS8.getContents <&> BS8.unpack
+        pure (mkForm "blob" [mkStr @c blob])
+
+      _ -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "blob:read-file" $ \case
+      [StringLike fn] -> do
+        blob <- liftIO (BS8.readFile fn) <&> BS8.unpack
+        pure (mkForm "blob" [mkStr @c blob])
+
+      _ -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "blob:save" $ nil_ $ \case
+      [StringLike fn, ListVal [SymbolVal "blob", LitStrVal t]] -> do
+        let s = Text.unpack t & BS8.pack
+        liftIO $ BS8.writeFile fn s
+
+      _ -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "blob:put" $ nil_ $ \case
+      [ListVal [SymbolVal "blob", LitStrVal t]] -> do
+        let s = Text.unpack t & BS8.pack
+        liftIO $ BS8.putStr s
+
+      _ -> throwIO (BadFormException @c nil)
+
+

lib/Data/Config/Suckless/Syntax.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# Language ViewPatterns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 module Data.Config.Suckless.Syntax
   ( Syntax(..)
@@ -18,6 +19,9 @@ module Data.Config.Suckless.Syntax
   , pattern LitStrVal
   , pattern LitBoolVal
   , pattern LitScientificVal
+  , pattern StringLike
+  , pattern StringLikeList
+  , pattern Nil
   )
   where
 
@@ -35,6 +39,8 @@ import Data.Aeson.Key
 import Data.Aeson.KeyMap qualified as Aeson
 import Data.Vector qualified as V
 import Data.Traversable (forM)
+import Data.Text qualified as Text
+import Data.Function
 
 import Prettyprinter
 
@@ -58,6 +64,28 @@ pattern ListVal :: [Syntax c] -> Syntax c
 pattern ListVal v <- List _ v
 
 
+stringLike :: Syntax c -> Maybe String
+stringLike = \case
+  LitStrVal s -> Just $ Text.unpack s
+  SymbolVal (Id s) -> Just $ Text.unpack s
+  _ -> Nothing
+
+stringLikeList :: [Syntax c] -> [String]
+stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes
+
+
+pattern StringLike :: forall {c} . String -> Syntax c
+pattern StringLike e <- (stringLike -> Just e)
+
+pattern StringLikeList :: forall {c} . [String] -> [Syntax c]
+pattern StringLikeList e <- (stringLikeList -> e)
+
+
+pattern Nil :: forall {c} . Syntax c
+pattern Nil <- ListVal []
+
+
+
 data family Context c :: Type
 
 class IsContext c where

suckless-conf.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               suckless-conf
-version:            0.1.2.6
+version:            0.1.2.7
 -- synopsis:
 -- description:
 license:            BSD-3-Clause
@@ -65,24 +65,39 @@ library
       , Data.Config.Suckless.Syntax
       , Data.Config.Suckless.Parse
       , Data.Config.Suckless.KeyValue
+      , Data.Config.Suckless.Script
+      , Data.Config.Suckless.Script.File
 
     other-modules:
         Data.Config.Suckless.Types
       , Data.Config.Suckless.Parse.Fuzzy
+      , Data.Config.Suckless.Script.Internal
 
     -- other-extensions:
     build-depends:    base
                     , aeson
                     , bytestring
                     , containers
+                    , directory
+                    , filepath
+                    , filepattern
+                    , fuzzy-parse >= 0.1.3.1
+                    , hashable
+                    , interpolatedstring-perl6
+                    , microlens-platform
                     , mtl
                     , prettyprinter
+                    , prettyprinter-ansi-terminal
                     , safe
                     , scientific
+                    , streaming
+                    , stm
                     , text
-                    , vector
+                    , time
+                    , transformers
+                    , unliftio
                     , unordered-containers
-                    , fuzzy-parse >= 0.1.3.1
+                    , vector
 
     hs-source-dirs:   lib
     default-language: Haskell2010