suckless-conf-0.1.2.9: lib/Data/Config/Suckless/Script/Internal.hs
{-# Language AllowAmbiguousTypes #-}
{-# Language UndecidableInstances #-}
{-# Language PatternSynonyms #-}
{-# Language ViewPatterns #-}
{-# Language RecordWildCards #-}
{-# Language MultiWayIf #-}
module Data.Config.Suckless.Script.Internal
( module Data.Config.Suckless.Script.Internal
, module Export
) where
import Data.Config.Suckless
import Data.Config.Suckless.Syntax
import Data.Config.Suckless.Parse.Fuzzy as P
import Data.Config.Suckless.Almost.RPC
import Data.Config.Suckless.System
import Data.Traversable
import Control.Applicative
import Control.Monad
import Control.Monad.Identity
import Control.Monad.Reader
import Control.Monad.Writer
import Data.Aeson as Aeson
import Data.Yaml qualified as Yaml
import Data.Ini qualified as Ini
import Data.Ini (Ini(..))
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.ByteString.Lazy.Char8 qualified as LBS8
import Data.Data
import Data.Coerce
import Data.Fixed
import Data.Foldable
import Data.Function as Export
import Data.Functor as Export
import Data.Hashable
import Data.HashSet (HashSet)
import Data.HashSet qualified as HS
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HM
import Data.Map qualified as Map
import Data.Kind
import Data.List (isPrefixOf)
import Data.List qualified as List
import Data.List ((\\))
import Data.List.Split (chunksOf)
import Data.Maybe
import Data.Either
import Data.String
import Data.Text.IO qualified as TIO
import Data.Text qualified as Text
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8With,encodeUtf8)
import Data.Text.Encoding.Error (ignore)
import Data.Time.Clock.POSIX
import Data.Time.Format (defaultTimeLocale, formatTime)
import Data.UUID.V4 qualified as UUID
import HTMLEntities.Text as Html
import GHC.Generics hiding (C)
import Prettyprinter
import Prettyprinter.Render.Terminal
import Safe
import Streaming.Prelude qualified as S
import System.Environment
import System.Directory qualified as Dir
import System.FilePath.Posix as P
import System.IO.Temp qualified as Temp
import System.Exit qualified as Exit
import System.Random as R
import System.Random.Shuffle (shuffleM)
import System.FilePattern
import Text.InterpolatedString.Perl6 (qc)
import Lens.Micro.Platform
import UnliftIO
import UnliftIO.Concurrent
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Maybe
-- 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]
, manIsAliasFor :: Maybe Id
}
deriving stock (Eq,Show,Generic)
instance Monoid (Man a) where
mempty = Man Nothing False Nothing mempty Nothing Nothing mempty Nothing
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)
(manIsAliasFor b <|> manIsAliasFor a)
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 4 (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 4 (
if not (Text.null s) then
(pretty t <> hsep ["","-",""] <> pretty s) <> line
else pretty t )
fmtDescription = line
<> "DESCRIPTION" <> line
<> indent 4 ( 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 4 ( vcat (fmap pretty es) )
synEntry (ManSynopsis (ManApply [])) =
indent 4 ( parens (pretty (manName e)) ) <> line
synEntry (ManSynopsis (ManApply xs)) = do
indent 4 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)
toSortable :: Syntax c -> Either Double Text
toSortable = \case
LitIntVal n -> Left (fromIntegral n)
LitScientificVal n -> Left (realToFrac n)
LitBoolVal False -> Left 0
LitBoolVal True -> Left 1
LitStrVal s -> Right s
SymbolVal (Id s) -> Right s
ListVal es -> Left (fromIntegral (length es))
OpaqueValue box -> Left 0
_ -> Left 0
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" -}
isNil :: forall c . IsContext c => Syntax c -> Bool
isNil = \case
ListVal [] -> True
_ -> False
isFalse :: forall c . IsContext c => Syntax c -> Bool
isFalse = \case
Literal _ (LitBool False) -> True
ListVal [] -> True
_ -> False
isTrue :: forall c . IsContext c => Syntax c -> Bool
isTrue = not . isFalse
eatNil :: Monad m => (Syntax c -> m a) -> Syntax c -> m ()
eatNil f = \case
Nil -> pure ()
x -> void $ f x
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)
-- FIXME: detect-invalid-varags
lambdaArgList :: Syntax c -> Maybe [Id]
lambdaArgList (ListVal a) = sequence argz
where
argz = flip fmap a \case
(SymbolVal x) -> Just x
_ -> Nothing
lambdaArgList _ = Nothing
pattern ArgList :: [Id] -> [Syntax c]
pattern ArgList a <- (argList -> Just a)
argList :: [Syntax c] -> Maybe [Id]
argList syn = sequence argz
where
argz = flip fmap syn \case
(SymbolVal x) | x `notElem` [".","_"] -> Just x
_ -> 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 ( TextLike i : b : rest ) = go ((Id i, b) : acc) rest
go acc [ TextLike i ] = (Id 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) }
| BindMacro { fromMacro :: [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)
data BadFormException c = BadFormException (Syntax c)
| ArityMismatch (Syntax c)
| NotLambda (Syntax c)
| NotBuiltinLambda Id
| RuntimeError (Syntax c)
| TypeCheckError (Syntax 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
show (NotLambda sy) = show $ "NotLambda" <+> pretty sy
show (TypeCheckError sy) = show $ "TypeCheckError" <+> pretty sy
show (RuntimeError sy) = show $ "RuntimeError" <+> pretty sy
show (NotBuiltinLambda sy) = show $ "NotBuiltinLambda" <+> 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 :: Bind c m -> Bind c m
hide (Bind w x) = Bind (Just updatedMan) x
where
updatedMan = case w of
Nothing -> mempty { manHidden = True }
Just man -> man { manHidden = True }
hidden :: MakeDictM c m () -> MakeDictM c m ()
hidden = censor (HM.map hide)
hideKeyPredicate :: (Id -> Bool) -> MakeDictM c m () -> MakeDictM c m ()
hideKeyPredicate p = censor $
HM.mapWithKey \k b -> if p k then hide b else b
hidePrefix :: Text -> MakeDictM c m () -> MakeDictM c m ()
hidePrefix p = hideKeyPredicate \(Id k) -> Text.isPrefixOf p k
hidePrefixes :: [Text] -> MakeDictM c m () -> MakeDictM c m ()
hidePrefixes ps = hideKeyPredicate \(Id k) ->
any (\p -> Text.isPrefixOf p k) ps
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.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
evargs :: forall c m . ( IsContext c
, MonadUnliftIO m
, Exception (BadFormException c)
)
=> Dict c m
-> [Syntax c]
-> RunM c m [Syntax c]
evargs dict = mapM (eval' dict)
applyLambda :: forall c m . ( IsContext c
, MonadUnliftIO m
, Exception (BadFormException c)
)
=> [Id]
-> Syntax c
-> [Syntax c]
-> RunM c m (Syntax c)
applyLambda decl body ev = do
let (manda,opt) = List.break (== ".") decl
when (length manda > length ev) do
throwIO (ArityMismatch @c nil)
tv <- ask
d0 <- readTVarIO tv
let (mandatory,optional) = splitAt (length manda) ev
forM_ (zip decl mandatory) $ \(n,v) -> do
bind n v
forM_ (headMay (tailSafe opt)) $ \n -> do
bind n (mkList optional)
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
ListVal (SymbolVal "builtin:closure" : e : free) -> do
apply_ e (free <> args)
ListVal (SymbolVal "builtin:rclosure" : e : free) -> do
apply_ e (args <> free)
SymbolVal "quasiquot" -> mkList <$> mapM (evalQQ mempty) args
SymbolVal "quasiquote" -> mkList <$> mapM (evalQQ mempty) args
SymbolVal what -> apply what args
Lambda d body -> applyLambda d body args
e -> throwIO $ NotLambda e
apply :: forall c m . ( IsContext c
, MonadUnliftIO m
, Exception (BadFormException c)
)
=> Id
-> [Syntax c]
-> RunM c m (Syntax c)
apply "quot" e = case e of
[ x ] -> pure x
_ -> throwIO $ BadFormException @c nil
apply "quasiquot" args = do
mkList <$> mapM (evalQQ mempty) args
apply name args' = do
what <- ask >>= readTVarIO <&> HM.lookup name
case bindAction <$> what of
Just (BindLambda e) -> do
e args'
Just (BindValue e) -> do
apply_ e args'
Just (BindMacro macro) -> do
macro args'
Just (BindValue _) -> do
throwIO (NotLambda (mkSym @c 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)
evalQQ :: forall c m . ( IsContext c
, MonadUnliftIO m
, Exception (BadFormException c)
) => Dict c m
-> Syntax c -> RunM c m (Syntax c)
evalQQ d0 = \case
-- SymbolVal (Id w) | Text.isPrefixOf "," w -> do
-- let what = Id (Text.drop 1 w)
-- lookupValue what >>= eval
ListVal [ SymbolVal ",", w ] -> eval' d0 w
List c es -> List c <$> mapM (evalQQ d0) es
other -> pure other
unsplice :: forall c m . ( IsContext c
, MonadUnliftIO m
, Exception (BadFormException c)
) => [Syntax c] -> RunM c m [Syntax c]
unsplice s = u s
where
u ( ListVal [SymbolVal ",@", e] : es) = unnest <$> eval @c e <*> u es
u ( e : es ) = (e:) <$> u es
u [] = pure []
unnest = \case
ListVal es -> mappend es
e -> (e :)
eval :: forall c m . ( IsContext c
, MonadUnliftIO m
, Exception (BadFormException c)
)
=> Syntax c
-> RunM c m (Syntax c)
eval = eval' mempty
eval' :: forall c m . ( IsContext c
, MonadUnliftIO m
, Exception (BadFormException c)
) => Dict c m
-> Syntax c
-> RunM c m (Syntax c)
eval' dict0 syn' = handle (handleForm syn') $ do
-- display_ $ "EVAL:" <+> pretty syn'
dict1 <- ask >>= readTVarIO
let dict = dict1 <> dict0
-- liiftIO $ print $ show $ "TRACE EXP" <+> pretty syn
let importDecls = HS.fromList [ "import", "define", "define-macro" :: Id ]
let isDefine x = x == "define" || x == "local"
case syn' of
SymbolVal (Id s) | Text.isPrefixOf ":" s -> do
pure (mkSym @c (Text.drop 1 s))
ListVal [ w, SymbolVal ".", b] -> do
pure $ mkList [w, b]
ListVal [ SymbolVal ":", b] -> do
pure $ mkList [b]
ListVal [ SymbolVal "'", ListVal b] -> do
pure $ mkList b
ListVal [ SymbolVal "'", StringLike x] -> do
pure $ mkSym x
ListVal [ SymbolVal "'", x] -> do
pure x
ListVal [ SymbolVal ",", x] -> do
pure x
ListVal [ SymbolVal ",@", x] -> do
eval x
ListVal [ SymbolVal "`", ListVal b] -> do
mkList <$> (unsplice b >>= mapM (evalQQ dict))
ListVal [ SymbolVal "quasiquot", ListVal b] -> do
mkList <$> (mapM (evalQQ dict) =<< unsplice b)
ListVal [ SymbolVal "quot", b] -> do
pure b
ListVal [ SymbolVal "eval", e ] -> eval e >>= eval
ListVal [ SymbolVal "import", e ] -> do
fn <- eval e >>= \case
StringLike x -> pure x
_ -> throwIO (BadFormException @c syn')
let importsName = "*runtime-imports*"
let alreadyError = RuntimeError $ mkForm "runtime-error" [ mkStr @c ["already imported", pretty fn] ]
let disappearedMessage = [mkStr @c [coerce importsName, "misteriously disappeared" :: Text]]
let disappeared = RuntimeError $ mkForm "runtime-error" disappearedMessage
initial <- newTVarIO (mempty :: HashMap Id (HashSet Id)) >>= mkOpaque
imp_ <- lookupValueDef initial importsName >>= \case
OpaqueVal e -> fromOpaque @(TVar (HashMap Id (HashSet Id))) e & \case
Just x -> pure x
Nothing -> throwIO disappeared
_ -> throwIO (RuntimeError (mkStr @c $ show $ pretty importsName <> "misteriously disappeared"))
seen <- atomically $ stateTVar imp_ (\e -> (HM.lookup (mkId fn) e, HM.insert (mkId fn) mempty e))
-- liftIO $ print $ pretty "import" <+> pretty fn
-- TODO: maybe-should-be-error
case seen of
Just{} -> pure nil
Nothing{} -> do
-- FIXME: fancy-error-handling
syn <- liftIO (TIO.readFile fn) <&> parseTop >>= either(error.show) pure
let decls = [ fixContext d
| d@(ListVal (SymbolVal what : rest)) <- syn
, what `HS.member` importDecls
]
void $ evalTop decls
pure nil
ListVal [SymbolVal def, SymbolVal what, e] | isDefine def -> do
ev <- eval e
bind what ev>> pure nil
ListVal [SymbolVal "define-macro", LambdaArgs (name:argz), e] -> do
t <- ask
let runMacro argvalz = do
de <- forM (zip argz argvalz) $ \(n,e) -> do
v <- eval e
pure (n, Bind mzero (BindValue v))
let d0 = HM.fromList de
eval' d0 e >>= eval' d0
let b = Bind mzero (BindMacro runMacro)
atomically $ modifyTVar t (HM.insert name b)
pure nil
w@(ListVal (SymbolVal "fn" : a@(SymbolVal{}) : rest)) -> do
let dot = mkSym "."
let (aa, body') = List.break (== dot) rest
& over _2 (List.dropWhile (==dot))
args <- argList (a:aa) & \case
Nothing -> throwIO (BadFormException @c w)
Just xs -> pure xs
body <- case body' of
[e] -> pure e
es -> pure $ mkList es
pure $ mkForm @c "lambda" [ mkList (fmap mkSym args), body ]
ListVal [SymbolVal "fn", LitIntVal n, body] -> do
pure $ mkForm @c "lambda" [ mkList [ mkSym ("_" <> show i) | i <- [1..n] ], body ]
ListVal (SymbolVal "fn1" : body) -> do
let e = case body of
[e] -> e
es -> mkList es
pure $ mkForm @c "lambda" [ mkList [ mkSym "_1" ], e ]
ListVal [SymbolVal "lambda", arglist, body] -> do
pure $ mkForm @c "lambda" [ arglist, body ]
ListVal [SymbolVal def, LambdaArgs (name : args), e] | isDefine def -> 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, e] -> do
what <- eval w
if not (isFalse what) then eval e else pure nil
ListVal [SymbolVal "if", w, e1, e2] -> do
what <- eval w
if isFalse what then eval e2 else eval e1
ListVal [SymbolVal "unless", w, e1] -> do
what <- eval w
if isFalse what then eval e1 else pure nil
ListVal (SymbolVal "begin" : what) -> do
evalTop what
e@(ListVal (SymbolVal "blob" : what)) -> do
pure e
r@(ListVal (SymbolVal "cond" : clauses)) -> do
flip fix clauses $ \next -> \case
(ListVal [SymbolVal "_", e1] : _) -> do
eval e1
(ListVal [p', e1] : rest) -> do
p <- eval p'
if isFalse p then
next rest
else do
eval e1
(_ : _) -> throwIO (BadFormException r)
[] -> pure nil
r@(ListVal (SymbolVal "match" : e' : clauses)) -> do
e <- eval e'
flip runContT pure $ callCC \exit -> do
for_ clauses $ \case
ListVal [ SymbolVal "_" , e1' ] -> do
e1 <- lift (eval e1')
-- error $ show $ "SHIT MATCHED" <+> pretty e1
exit e1
ListVal [ p, e1' ] -> do
lift (matchPattern p e e1') >>= \case
Nothing -> pure ()
Just m -> exit m
_ -> pure ()
pure nil
lc@(ListVal (Lambda decl body : args)) -> do
applyLambda decl body =<< evargs dict args
ListVal (SymbolVal name : args') -> do
apply name =<< evargs dict args'
ListVal (e' : args') -> do
e <- eval e'
apply_ e =<< evargs dict args'
SymbolVal name | HM.member name dict -> do
let what = HM.lookup name dict0 <|> HM.lookup name dict1
& maybe (BindValue (mkSym name)) bindAction
-- liftIO $ print $ "LOOKUP" <+> pretty name <+> pretty what
case what of
BindValue e -> pure e
BindLambda e -> pure $ mkForm "builtin:lambda" [mkSym name]
BindMacro _ -> pure nil
e@(SymbolVal name) | not (HM.member name dict) -> do
pure e
e@Literal{} -> pure e
e@OpaqueValue{} -> pure e
e -> do
throwIO $ NotLambda @c e
where
handleForm syn = \case
(BadFormException _ :: BadFormException c) -> do
throwIO (BadFormException syn)
(ArityMismatch s :: BadFormException c) -> do
throwIO (ArityMismatch syn)
(TypeCheckError s :: BadFormException c) -> do
throwIO (TypeCheckError syn)
other -> throwIO other
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
runTM :: forall c m a. ( IsContext c
, MonadUnliftIO m
, Exception (BadFormException c)
) => TVar (Dict c m) -> RunM c m a -> m a
runTM tvd m = do
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
runEval :: forall c m . ( IsContext c
, MonadUnliftIO m
, Exception (BadFormException c)
) => TVar (Dict c m) -> [Syntax c] -> m (Syntax c)
runEval tvd sy = do
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) }
{- HLINT ignore "Redundant <&>" -}
bindAlias :: forall c m . ( MonadUnliftIO m
, IsContext c
, Exception (BadFormException c))
=> Id -> Id -> Dict c m
bindAlias n fn = HM.singleton n (Bind man (BindLambda callAlias))
where
man = Just $ mempty { manName = Just (manNameOf n), manIsAliasFor = Just fn }
callAlias syn = do
ask >>= readTVarIO
<&> (fmap bindAction . HM.lookup fn)
>>= \case
Just (BindLambda la) -> la syn
_ -> throwIO (NotBuiltinLambda @c fn)
bindMacro :: Id -> ([Syntax c] -> RunM c m (Syntax c)) -> Dict c m
bindMacro n fn = HM.singleton n (Bind man (BindMacro 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))
lookupValue :: forall c m . (IsContext c, MonadUnliftIO m)
=> Id -> RunM c m (Syntax c)
lookupValue i = do
ask >>= readTVarIO
<&> (fmap bindAction . HM.lookup i)
>>= \case
Just (BindValue s) -> pure s
_ -> throwIO (NameNotBound i)
lookupValueDef :: forall c m . (IsContext c, Exception (BadFormException c), MonadUnliftIO m)
=> Syntax c
-> Id
-> RunM c m (Syntax c)
lookupValueDef defVal i = do
ask >>= readTVarIO
<&> (fmap bindAction . HM.lookup i)
>>= \case
Just (BindValue s) -> pure s
_ -> do
bind i defVal
pure defVal
nil_ :: (IsContext c, MonadIO m) => (a -> RunM c m b) -> a -> RunM c m (Syntax c)
nil_ m w = m w >> pure (List noContext [])
unwrapped :: IsContext c => [Syntax c] -> Syntax c
unwrapped = \case
[] -> nil
[ e ] -> e
( x:xs ) -> mkList (x:xs)
fixContext :: forall c1 c2 . (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
OpaqueValue box -> OpaqueValue box
fixList :: forall c . IsContext c => Syntax c -> Syntax c
fixList = \case
(ListVal es) -> mkList ( mkSym "list" : es )
e -> e
fmt :: Syntax c -> Doc ann
fmt = \case
LitStrVal x -> pretty $ Text.unpack x
x -> pretty x
newtype IniConfig = IniConfig Ini.Ini
instance IsContext c => MkSyntax c IniConfig where
mkSyntax (IniConfig (Ini{..})) = do
let section kvs = [ mkList [mkSym k, either (const (mkStr v)) fixContext (P.parseSyntax v)]
| (k,v) <- kvs
]
let globals = section iniGlobals
let sections = [ mkForm @c s (section pps) | (s, pps) <- HM.toList iniSections ]
mkList (globals <> sections)
bindCliArgs :: forall c m . (IsContext c, MonadUnliftIO m, Exception (BadFormException c))
=> [Syntax c] -> RunM c m ()
bindCliArgs a = do
bind "$*" (mkList a)
bind "*args" (mkList a)
forM_ (zip [1..] a) $ \(i,e) -> do
bind (fromString ("$"<>show i)) e
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 " ")
entry $ bindValue "chr:dot" (mkStr ".")
entry $ bindValue "dot" (mkStr ".")
entry $ bindAlias "local" "define"
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" (pure . mkStr . foldMap synToText)
let mkJoin x es = do
let xs = List.intersperse x es
pure $ mkStr ( show $ hcat (fmap fmt xs) )
entry $ bindMatch "join" $ \case
[ x, ListVal es ] -> mkJoin x es
(x : es ) -> mkJoin x es
_ -> throwIO (BadFormException @C nil)
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 $ mkList es
[a, b] -> do
pure $ mkList [ 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 [ mkList @c [mkSym i, e] | (i,e) <- optlist syn ]
pure $ wat
entry $ bindMatch "iterate" $ nil_ $ \case
[ what, ListVal es ] -> do
mapM_ (apply_ what . List.singleton) es
_ -> do
throwIO (BadFormException @C nil)
entry $ bindMatch "for" $ nil_ $ \case
[ ListVal es, what ] -> do
mapM_ (apply_ what . List.singleton) es
_ -> do
throwIO (BadFormException @C nil)
entry $ bindMatch "replicate" $ \case
[LitIntVal n, e] -> pure $ mkList (replicate (fromIntegral n) e)
_ -> pure 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 "apply" $ \case
[e, ListVal es] -> apply_ e es
e -> throwIO (BadFormException @c (mkList e))
entry $ bindMatch "eval" $ \syn -> do
r <- mapM eval syn
pure $ lastDef nil r
entry $ bindMatch "curry" \case
[e1, e2] -> pure $ mkForm "builtin:closure" [e1, e2]
e -> throwIO (BadFormException @c (mkList e))
entry $ bindMatch "rcurry" \case
[e1, e2] -> pure $ mkForm "builtin:rclosure" [e1, e2]
e -> throwIO (BadFormException @c (mkList e))
entry $ bindMatch "id" $ \case
[ e ] -> pure e
_ -> throwIO (BadFormException @C nil)
entry $ bindMatch "true?" $ \case
[ e ] | e == mkBool True -> pure $ mkBool True
_ -> pure $ mkBool False
entry $ bindMatch "inc" $ \case
[ LitIntVal n ] -> pure (mkInt (succ n))
_ -> throwIO (TypeCheckError @C nil)
entry $ bindMatch "dec" $ \case
[ LitIntVal n ] -> pure (mkInt (pred n))
_ -> throwIO (TypeCheckError @C nil)
entry $ bindMatch "map" $ \case
[ what, ListVal es ] -> do
mkList <$> mapM (apply_ what . List.singleton) es
_ -> do
throwIO (BadFormException @C nil)
entry $ bindMatch "for" $ \case
[ ListVal es, what ] -> do
mkList <$> mapM (apply_ what . List.singleton) es
e -> throwIO (BadFormException @c (mkList e))
entry $ bindMatch "quot" $ \case
[ syn ] -> pure $ mkList [syn]
_ -> do
throwIO (BadFormException @C nil)
entry $ bindMatch "quasiquot" $ \case
[ syn ] -> mkList . List.singleton <$> evalQQ mempty syn
_ -> do
throwIO (BadFormException @C nil)
entry $ bindMatch "last" $ \case
[ ListVal es ] -> pure (lastDef nil es)
[ StringLike es ] -> pure $ maybe nil (mkSym . List.singleton) (lastMay es)
_ -> throwIO (TypeCheckError @C nil)
entry $ bindMatch "head" $ \case
[ ListVal es ] -> pure (headDef nil es)
[ StringLike es ] -> pure $ maybe nil (mkSym . List.singleton) (headMay es)
_ -> throwIO (TypeCheckError @C nil)
entry $ bindAlias "car" "head"
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)
[StringLike es] -> pure $ case tailSafe es of
[] -> nil
xs -> mkSym xs
_ -> throwIO (BadFormException @c nil)
entry $ bindAlias "cdr" "tail"
entry $ bindMatch "cons" $ \case
[ e, ListVal es ] -> pure (mkList (e:es))
_ -> throwIO (BadFormException @C nil)
entry $ bindMatch "@" $ \syn -> do
case List.uncons (reverse syn) of
Nothing -> pure nil
Just (a, []) -> pure a
Just (a, fs) -> flip fix (a, fs) $ \next -> \case
(acc, []) -> pure acc
(acc, x:xs) -> do
acc' <- apply_ x [acc]
next (acc', xs)
entry $ bindMatch "void" $ nil_ $ const $ pure ()
entry $ bindMatch "split" $ \case
[TextLike sep, TextLike s] ->
pure $ mkList [mkStr x | x <- Text.splitOn sep s]
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "filter" $ \case
[pred, ListVal xs] -> do
filtered <- flip filterM xs $ \x -> do
res <- apply_ pred [x]
case res of
LitBoolVal True -> pure True
_ -> pure False
pure $ mkList filtered
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "list:chunks" $ \case
[ LitIntVal n, ListVal xs ] -> do
pure $ mkList [ mkList es | es <- chunksOf (fromIntegral n) xs ]
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "group-by" $ \case
[cmp, ListVal es] -> do
let groupByM _ [] = pure []
groupByM eq (x:xs) = do
(same, rest) <- partitionM (eq x) xs
groups <- groupByM eq rest
pure ((x:same) : groups)
let eqFunc a b = do
result <- apply_ cmp [a, b]
pure $ case result of
LitBoolVal v -> v
_ -> False -- Если не bool, считаем, что не равны
grouped <- groupByM eqFunc es
pure $ mkList [mkList group | group <- grouped]
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "sort-with" $ \case
[cmp, ListVal es] -> do
let cmpFunc a b = do
result <- apply_ cmp [a, b]
pure $ case result of
LitBoolVal v -> v
_ -> False -- Если не bool, считаем `x < y` ложным
sorted <- sortByM cmpFunc es
pure $ mkList sorted
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "sort" $ \case
[ListVal es] -> pure $ mkList $ (List.sortOn toSortable) es
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "sort-by" $ \case
[what, ListVal es] -> do
sorted <- forM es \e -> do
key <- apply_ what [e]
pure (key, e)
pure $ mkList [e | (_, e) <- List.sortOn (toSortable . fst) sorted]
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "append" $ \syn -> do
pure $ mkList $ flip fix (mempty, syn) $ \next (acc, terms) -> do
case terms of
[] -> acc
(ListVal xs : rest) -> next (acc <> xs, rest)
(other : rest) -> next (acc <> [other], rest)
entry $ bindMatch "flatten" $ \case
[ListVal es] -> pure $ mkList (concatMap flattenList es)
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "reverse" $ \case
[ListVal es] -> pure $ mkList (List.reverse es)
[LitStrVal s] -> pure $ mkStr (Text.reverse s)
[SymbolVal (Id s)] -> pure $ mkSym (Text.reverse s)
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "nub" $ \case
[ ListVal es ] -> pure $ mkList $ List.nub es
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "zip" $ \case
[ ListVal a, ListVal b ] -> pure $ mkList (zipWith (\x y -> mkList [x,y]) a b)
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "take" $ \case
[ LitIntVal n, ListVal es ] -> pure $ mkList $ take (fromIntegral n) es
[ LitIntVal n, StringLike es ] -> pure $ mkStr $ take (fromIntegral n) es
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "drop" $ \case
[ LitIntVal n, ListVal es ] -> pure $ mkList $ drop (fromIntegral n) es
[ LitIntVal n, StringLike es ] -> pure $ mkStr $ drop (fromIntegral n) es
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "nth" $ \case
[LitIntVal i, ListVal es] -> do
let idx = if i < 0 then length es + fromIntegral i else fromIntegral i
pure $ atDef nil es idx
[LitIntVal i, StringLike es] -> do
let idx = if i < 0 then length es + fromIntegral i else fromIntegral i
pure $ maybe nil (mkSym . List.singleton) $ atMay es idx
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "set!" $ nil_ $ \case
[SymbolVal v, e] -> do
-- tvd <- ask
bind v e
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "assoc" $ \case
[k, ListVal es ] -> pure $ headDef nil [ r | r@(ListVal (w:_)) <- es, k == w ]
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "coalesce" $ \case
[a] -> pure a
[a,b] | isFalse b -> pure a
| otherwise -> pure b
_ -> pure nil
entry $ bindAlias "nvl" "coalesce"
--TODO: integral sum
entry $ bindMatch "align" $ \syn -> do
(n,f,s) <- case syn of
[ LitIntVal n, TextLike s ] -> pure (n,' ',s)
[ LitIntVal n, TextLike f, TextLike s ] -> pure (n, maybe ' ' fst (Text.uncons f) ,s)
e -> throwIO (BadFormException @c (mkList e))
let shift = fromIntegral $ abs n
let fn = if n >= 0 then Text.justifyLeft else Text.justifyRight
pure $ mkStr (fn shift f s)
entry $ bindMatch "upper" $ \case
[ LitStrVal x ] -> pure $ mkStr $ Text.toUpper x
[ SymbolVal (Id x) ] -> pure $ mkStr $ Text.toUpper x
_ -> pure nil
entry $ bindMatch "lower" $ \case
[ LitStrVal x ] -> pure $ mkStr $ Text.toLower x
[ SymbolVal (Id x) ] -> pure $ mkStr $ Text.toLower x
_ -> pure nil
entry $ bindMatch "words" $ \case
[ TextLike x ] -> pure $ mkList [ mkStr y | y <- Text.words x ]
_ -> pure nil
entry $ bindMatch "unwords" $ \case
[ ListVal (TextLikeList xs) ] -> pure $ mkStr (Text.unwords xs)
( TextLikeList xs) -> pure $ mkStr (Text.unwords xs)
_ -> pure $ mkStr ""
entry $ bindMatch "lines" $ \case
[ TextLike x ] -> pure $ mkList [ mkStr y | y <- Text.lines x ]
_ -> pure nil
entry $ bindMatch "unlines" $ \case
[ ListVal (TextLikeList xs) ] -> pure $ mkStr (Text.unlines xs)
( TextLikeList xs) -> pure $ mkStr (Text.unwords xs)
_ -> pure $ mkStr ""
entry $ bindMatch "mod" $ \case
[LitIntVal a, LitIntVal b] | b /= 0 -> pure $ mkInt (mod a b)
_ -> throwIO (BadFormException @c nil)
entry $ bindAlias "%" "mod"
entry $ bindMatch "floor" $ \case
[LitScientificVal x] ->
pure $ mkInt (floor x)
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "ceiling" $ \case
[LitScientificVal x] ->
pure $ mkInt (ceiling x)
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "fixed" $ \case
[LitIntVal 1, LitScientificVal x] -> do
pure $ mkSym $ show (realToFrac $ realToFrac @_ @(Fixed E1) x)
[LitIntVal 2, LitScientificVal x] -> do
pure $ mkSym $ show (realToFrac $ realToFrac @_ @(Fixed E2) x)
[LitIntVal 3, LitScientificVal x] -> do
pure $ mkSym $ show $ (realToFrac $ realToFrac @_ @(Fixed E3) x)
[LitIntVal 6, LitScientificVal x] -> do
pure $ mkSym $ show (realToFrac $ realToFrac @_ @(Fixed E6) x)
[LitIntVal 9, LitScientificVal x] -> do
pure $ mkSym $ show (realToFrac $ realToFrac @_ @(Fixed E9) x)
[LitIntVal 12, LitScientificVal x] -> do
pure $ mkSym $ show (realToFrac $ realToFrac @_ @(Fixed E12) x)
[LitIntVal _, LitScientificVal x] -> do
pure $ mkDouble x
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "round" $ \case
[LitScientificVal x] -> do
pure $ mkDouble (realToFrac $ floor x)
[LitIntVal n, LitScientificVal x] -> do
let factor = 10 ^ n
rounded = fromIntegral (round (x * fromIntegral factor)) / fromIntegral factor
pure (mkDouble rounded)
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "sum" $ \x -> do
ds <- case x of
[ ListVal es ] -> pure es
es -> pure es
let v = flip mapMaybe ds \case
LitIntVal n -> Just $ realToFrac n
LitScientificVal n -> Just $ realToFrac @_ @Double n
_ -> Nothing
pure $ mkDouble $ sum v
entry $ bindMatch "assoc:nth" $ \case
[LitIntVal i, k, ListVal es ] -> do
pure $ headDef nil [ r | r@(ListVal ys) <- es, atMay ys (fromIntegral i) == Just k ]
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "unwrap" $ \case
[ ListVal [one] ] -> pure one
[ e ] -> pure e
other -> throwIO (BadFormException @c (mkList other))
entry $ bindAlias "unw" "unwrap"
entry $ bindMatch "lookup:uw" $ \case
[k, ListVal es ] -> do
let val = headDef nil [ unwrapped rest | ListVal (w:rest) <- es, k == w ]
pure val
[StringLike s, ListVal [] ] -> do
pure nil
_ -> throwIO (BadFormException @c nil)
entry $ bindAlias "@?" "lookup:uw"
entry $ bindMatch "lookup" $ \case
[k, ListVal es ] -> do
let val = headDef nil [ mkList rest | ListVal (w:rest) <- es, k == w ]
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)
let colorz = HM.fromList
[ ("red", pure (Red, True))
, ("red~", pure (Red, False))
, ("green", pure (Green, True))
, ("green~", pure (Green, False))
, ("yellow", pure (Yellow, True))
, ("yellow~", pure (Yellow, False))
, ("blue", pure (Blue, True))
, ("blue~", pure (Blue, False))
, ("magenta", pure (Magenta, True))
, ("magenta~",pure (Magenta, False))
, ("cyan", pure (Cyan, True))
, ("cyan~", pure (Cyan, False))
, ("white", pure (White, True))
, ("white~", pure (White, False))
, ("black", pure (Black, True))
, ("black~", pure (Black, False))
, ("_", mzero)
]
let fgc fg = case join (HM.lookup fg colorz) of
Just (co, True) -> color co
Just (co, False) -> colorDull co
Nothing -> mempty
let niceTerm f = \case
LitStrVal x -> do
let s = renderStrict $ layoutPretty defaultLayoutOptions (annotate f $ pretty x)
mkStr s
other -> do
let s = renderStrict $ layoutPretty defaultLayoutOptions (annotate f $ pretty other)
mkStr s
entry $ bindMatch "ansi" $ \case
[ SymbolVal fg, SymbolVal bg, term ] | HM.member fg colorz && HM.member bg colorz -> do
let b = case join (HM.lookup bg colorz) of
Just (co, True) -> bgColor co
Just (co, False) -> bgColorDull co
Nothing -> mempty
let f = b <> fgc fg
pure $ niceTerm f term
[ SymbolVal fg, s] | HM.member fg colorz -> do
let f = fgc fg
pure $ niceTerm f s
_ -> throwIO (BadFormException @c nil)
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 "flush:stdout" $ nil_ $ \case
[] -> liftIO do
hFlush stdout
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "str:getchar:stdin" $ \case
[] -> liftIO do
hSetBuffering stdin NoBuffering
mkStr . List.singleton <$> getChar
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "str: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 "extracts columns from string"
$ returns "[string]" "[fields]"
$ desc [qc|
str:cut n str
; extracts column n from str
str:cut a b str
; extracts columns a -- b from str
str:cut b a str
; extracts columns b -- a from str
; (like in previous case, but in reversed order)
str:cut '[a b c] str
; extracts columns a,b,c from str
|]
$ examples [qc|
$ echo A B C | bf6 [str:cut [list 2 1] [str:stdin]]
("C B")
|]
$ entry $ bindMatch "str:cut" $ \e -> do
let extract :: Int -> Int -> [Text] -> [Text]
extract a b =
let extractLine line =
let ws = Text.words line
len = length ws
a' = a
b' = if b < 0 then len - 1 else b
lo = max 0 (min a' b')
hi = min len (max a' b' + 1)
piece = take (hi - lo) (drop lo ws)
in Text.unwords (if a' > b' then reverse piece else piece)
in fmap extractLine
extractOne :: Int -> [Text] -> [Text]
extractOne n =
let i = max 0 n
in fmap \line -> atDef "" (Text.words line) i
extractMany :: [Int] -> [Text] -> [Text]
extractMany ns =
fmap \line ->
let ws = Text.words line
picked = [ atDef "" ws (max 0 i) | i <- ns ]
in Text.unwords picked
runCut range lines = do
let out = case range of
Left n -> extractOne n lines
Right (a,b) -> extract a b lines
pure $ mkList @c (fmap mkStr out)
runCutList ns lines = do
let out = extractMany ns lines
pure $ mkList @c (fmap mkStr out)
case e of
-- Один индекс
[LitIntVal n, ListVal (TextLikeList s)] ->
runCut (Left (fromIntegral n)) s
[LitIntVal n, TextLike s] ->
runCut (Left (fromIntegral n)) (Text.lines s)
-- Диапазон
[LitIntVal a, LitIntVal b, ListVal (TextLikeList s)] ->
runCut (Right (fromIntegral a, fromIntegral b)) s
[LitIntVal a, LitIntVal b, TextLike s] ->
runCut (Right (fromIntegral a, fromIntegral b)) (Text.lines s)
-- Список колонок
[ListVal (IntLikeList ns), ListVal (TextLikeList s)] ->
runCutList (map fromIntegral ns) s
[ListVal (IntLikeList ns), TextLike s] ->
runCutList (map fromIntegral ns) (Text.lines s)
_ -> throwIO (BadFormException @c nil)
brief "reads file as a string" do
entry $ bindMatch "str: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 $ bindMatch "str:append:file" $ nil_ \case
(StringLike fn : StringLikeList what) -> do
liftIO (forM_ what (appendFile fn))
e -> throwIO (BadFormException @c (mkList e))
entry $ bindValue "space" $ mkStr " "
let doParseTop w l s =
parseTop s & either (const nil) (mkForm w . fmap ( l . fixContext) )
let wrapWith e = \case
List c es -> List c (e : es)
other -> other
let lwrap = \case
e@(SymbolVal x) -> wrapWith e
_ -> id
entry $ bindMatch "json" \case
[ e ] -> pure $ mkStr $ LBS8.unpack $ Aeson.encode $ toJSON e
x -> pure $ mkStr $ LBS8.unpack $ Aeson.encode $ toJSON (mkList x)
entry $ bindMatch "json:stdin" $ const do
parseJson <$> liftIO (LBS.hGetContents stdin)
entry $ bindMatch "json:file" $ \case
[StringLike fn] -> do
parseJson <$> liftIO (LBS.readFile fn)
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "json:string" $ \case
[TextLike s] -> do
pure $ parseJson $ encodeUtf8 s & LBS.fromStrict
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "yaml:stdin" $ const do
parseYaml <$> liftIO (LBS.hGetContents stdin)
entry $ bindMatch "yaml:file" $ \case
[StringLike fn] -> do
parseYaml <$> liftIO (LBS.readFile fn)
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "ini:stdin" $ const do
parseIni <$> liftIO (LBS.hGetContents stdin)
entry $ bindMatch "ini:file" $ \case
[StringLike fn] -> do
parseIni <$> liftIO (LBS.readFile fn)
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "top:stdin" $ const do
liftIO TIO.getContents
<&> either (const nil) (mkList . fmap fixContext) . parseTop
entry $ bindMatch "top:string" $ \case
[TextLike s] -> do
pure $ either (const nil) (mkList . fmap fixContext) (parseTop s)
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "top:file" $ \case
[StringLike fn] -> do
liftIO $ TIO.readFile fn
<&> either (const nil) (mkList . fmap fixContext) . parseTop
_ -> throwIO (BadFormException @c nil)
let dropShebang = id
-- skips shebang
entry $ bindMatch "top:file:run" $ nil_ $ \case
a@(StringLike fn : args) -> do
bindCliArgs a
liftIO (TIO.readFile fn)
<&> either (error.show) (fmap (fixContext @C @c) . dropShebang ) . parseTop
<&> \case
(ListVal (SymbolVal "#!" : _) : rest) -> rest
rest -> rest
>>= evalTop
_ -> throwIO (BadFormException @c nil)
brief "parses string as toplevel and produces a form"
$ desc "parse:top:string SYMBOL STRING-LIKE"
$ entry $ bindMatch "parse:top:string" $ \case
[SymbolVal w, LitStrVal s] -> do
pure $ doParseTop w id s
[SymbolVal w, e@(SymbolVal r), LitStrVal s] -> do
pure $ doParseTop w (lwrap e) s
_ -> throwIO (BadFormException @c nil)
brief "parses file as toplevel form and produces a form"
$ desc "parse:top:file SYMBOL <FILENAME>"
$ entry $ bindMatch "parse:top:file" $ \case
[SymbolVal w, StringLike fn] -> do
s <- liftIO $ TIO.readFile fn
pure $ doParseTop w id s
[SymbolVal w, e@(SymbolVal r), StringLike fn] -> do
s <- liftIO $ TIO.readFile fn
pure $ doParseTop w (lwrap e) s
_ -> throwIO (BadFormException @c nil)
let atomFrom = \case
[StringLike s] -> pure (mkSym s)
[e] -> pure (mkSym $ show $ pretty e)
es -> atomFrom [concatTerms hcat es]
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 "real"
[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
entry $ bindMatch "int" $ \case
[ StringLike x ] -> pure $ maybe nil mkInt (readMay x)
[ LitScientificVal v ] -> pure $ mkInt (round v)
_ -> pure nil
entry $ bindMatch "str" $ \case
[] -> pure $ mkStr ""
[x] -> pure $ mkStr (show $ pretty x)
xs -> pure $ mkStr $ mconcat [ show (pretty e) | e <- xs ]
entry $ bindMatch "and" $ \case
xs -> pure $ mkBool $ and [ not (isFalse x) | x <- xs ]
entry $ bindMatch "or" $ \case
xs -> pure $ mkBool $ or [ not (isFalse x) | x <- xs ]
entry $ bindMatch "bf6:is" $ \case
[a,b] | a == b -> pure a
_ -> pure nil
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)
for_ ["int?", "sym?","bool?","str?","real?","is"] $ \pred -> do
let ref = "bf6:" <> pred
entry $ bindMatch pred $ \case
[a] -> do
-- error $ show $ "FUCK!" <+> pretty a
pure $ mkForm "builtin:closure" [mkSym ref, a]
e -> throwIO (BadFormException @c (mkList e))
entry $ bindMatch ref $ \case
[SymbolVal "_", b] ->do
if bf6TypeOfPred pred == bf6TypeOf b then pure b else pure nil
[a@(SymbolVal e), b] -> do
if a == b then pure b else pure nil
[a@(Literal _ _), b] -> do
if bf6TypeOfPred pred == bf6TypeOf b && a == b then pure b else pure nil
[a,b] -> do
apply_ a [b] >>= \w -> do
if isFalse w then pure nil else pure b
e -> throwIO (BadFormException @c (mkList e))
entry $ bindMatch "matched?" matched
entry $ bindMatch "le?" $ \case
[a, b] -> pure $ mkBool (compareSyn a b == LT)
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "gt?" $ \case
[a, b] -> pure $ mkBool (compareSyn a b == GT)
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "leq?" $ \case
[a, b] -> pure $ mkBool (compareSyn a b /= GT) -- LT или EQ
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "gte?" $ \case
[a, b] -> pure $ mkBool (compareSyn a b /= LT) -- GT или EQ
_ -> 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] -> pure (mkBool (isFalse w))
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "setenv" $ nil_ \case
[ StringLike k, StringLike v] -> liftIO $ setEnv k v
_ -> 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 $ mkList [ 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)
brief "decodes bytes as utf8 text"
$ desc "bytes:decode <BYTES>"
$ entry $ bindMatch "bytes:decode" $ \case
[ OpaqueVal box ] -> do
let lbs' = fromOpaque @LBS.ByteString box
<|>
(LBS.fromStrict <$> fromOpaque @BS.ByteString box)
lbs <- maybe (throwIO (UnexpectedType "unknown / ByteString")) pure lbs'
-- TODO: maybe-throw-on-invalid-encoding
let txt = decodeUtf8With ignore (LBS.toStrict lbs)
pure $ mkStr txt
_ -> throwIO (BadFormException @c nil)
brief "reads bytes from a file"
$ desc "bytes:file FILE"
$ entry $ bindMatch "bytes:file" $ \case
[ StringLike fn ] -> do
liftIO (LBS.readFile fn) >>= mkOpaque
_ -> throwIO (BadFormException @c nil)
brief "reads bytes from a file"
$ desc "bytes:strict:file FILE"
$ entry $ bindMatch "bytes:strict:file" $ \case
[ StringLike fn ] -> do
liftIO (BS.readFile fn) >>= mkOpaque
_ -> throwIO (BadFormException @c nil)
brief "reads bytes from a STDIN"
$ desc "bytes:stdin"
$ entry $ bindMatch "bytes:stdin" $ \case
[] -> do
liftIO LBS.getContents >>= mkOpaque
_ -> throwIO (BadFormException @c nil)
brief "writes bytes to STDOUT"
$ desc "bytes:put <BYTES>"
$ entry $ bindMatch "bytes:put" $ nil_ $ \case
[isOpaqueOf @LBS.ByteString -> Just s ] -> do
liftIO $ LBS.putStr s
[isOpaqueOf @ByteString -> Just s ] -> do
liftIO $ BS.putStr s
_ -> throwIO (BadFormException @c nil)
brief "writes bytes to FILE"
$ desc "bytes:write <FILE> <BYTES>"
$ entry $ bindMatch "bytes:write" $ nil_ $ \case
[StringLike fn, isOpaqueOf @LBS.ByteString -> Just s ] -> do
liftIO $ LBS.writeFile fn s
[StringLike fn, isOpaqueOf @ByteString -> Just s ] -> do
liftIO $ BS.writeFile fn s
_ -> throwIO (BadFormException @c nil)
brief "calls external process"
$ entry $ bindMatch "call:proc" \case
[StringLike what] -> lift do
callProc what mempty mempty <&> mkList @c . fmap (fixContext)
(StringLike x:xs) -> lift do
callProc x (fmap (show.pretty) xs) mempty <&> mkList @c . fmap (fixContext)
_ -> throwIO (BadFormException @c nil)
brief "calls external process"
$ entry $ bindMatch "call:proc:raw" \case
[StringLike what] -> lift do
callProcRaw what mempty <&> mkStr @c
(StringLike x:xs) -> lift do
callProcRaw x (fmap (show.pretty) xs) <&> mkStr @c
_ -> throwIO (BadFormException @c nil)
brief "call external process as pipe"
$ entry $ bindMatch "proc:pipe" \case
[StringLike name, ListVal (StringLikeList params), TextLike input ] -> lift do
mkStr @c <$> pipeProcText name params input
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "sleep" $ nil_ $ \case
[ LitIntVal n ] -> lift $ threadDelay ( fromIntegral n * 1000000 )
[ LitScientificVal n ] -> lift $ threadDelay ( round $ realToFrac n * 1000000 )
e -> throwIO (BadFormException @c (mkList e))
brief "call external process as pipe"
$ entry $ bindMatch "run:proc:attached" $ \syn -> do
(cmd, args) <- case syn of
[ StringLike name, ListVal (StringLikeList params) ] -> pure (name, params)
StringLikeList (name:params) -> pure (name, params)
e -> throwIO (BadFormException @c (mkList e))
runProcAttached cmd args >>= \case
Exit.ExitSuccess -> pure $ mkInt 0
Exit.ExitFailure n -> pure $ mkInt n
brief "call external process as pipe"
$ entry $ bindMatch "run:proc:quiet" $ \syn -> do
(cmd, args) <- case syn of
[ StringLike name, ListVal (StringLikeList params) ] -> pure (name, params)
StringLikeList (name:params) -> pure (name, params)
e -> throwIO (BadFormException @c (mkList e))
runProcQuiet cmd args >>= \case
Exit.ExitSuccess -> pure $ mkInt 0
Exit.ExitFailure n -> pure $ mkInt n
entry $ bindMatch "fallback" $ \case
[ e, expr ] -> do
try @_ @SomeException (eval expr) >>= \case
Right x -> pure x
Left _ -> eval e
other -> throwIO (BadFormException @c (mkList other))
entry $ bindMatch "grep" \case
[TextLike needle, what ] | matchOne needle what
-> pure what
[TextLike needle, e@(ListVal xs) ] | any (matchOne needle) xs ->
pure $ mkList (filter (matchOne needle) xs)
_ -> pure nil
entry $ bindMatch "pwd" $ const $ do
pwd <&> mkSym @c
entry $ bindMatch "cd" $ nil_ $ \case
[ StringLike dir ] -> cd dir
_ -> throwIO $ BadFormException @c nil
entry $ bindMatch "mkdir" $ nil_ $ \case
[ ListVal (StringLikeList p) ] -> do
forM_ p mkdir
(StringLikeList p) -> forM_ p mkdir
_ -> throwIO $ BadFormException @c nil
entry $ bindMatch "quit" $ nil_ $ \case
[] -> liftIO $ Exit.exitSuccess
_ -> throwIO $ BadFormException @c nil
entry $ bindMatch "die" $ nil_ $ \case
[] -> liftIO $ Exit.exitFailure
e -> liftIO $ Exit.die (show $ foldMap asSym e)
entry $ bindMatch "cp" $ nil_ $ \case
(StringLikeList p) -> liftIO do
case List.uncons (reverse p) of
Nothing -> pure ()
Just (dest, rest) -> do
forM_ (reverse rest) $ \f -> Dir.copyFileWithMetadata f dest
e -> throwIO $ BadFormException @c (mkList e)
entry $ bindMatch "rm" $ nil_ $ \case
(StringLikeList p) -> forM_ p rm
[ ListVal (StringLikeList p) ] -> forM_ p rm
_ -> throwIO $ BadFormException @c nil
entry $ bindMatch "mv" $ nil_ $ \case
[ StringLike a, StringLike b ] -> mv a b
_ -> throwIO $ BadFormException @c nil
entry $ bindMatch "touch" $ nil_ $ \case
[ StringLike p ] -> touch p
_ -> throwIO $ BadFormException @c nil
entry $ bindMatch "sys:temp:dir:get" $ const do
mkStr @c <$> sysTempDir
entry $ bindMatch "sys:temp:file" $ \case
[] -> mkSym @c <$> liftIO (Temp.emptySystemTempFile "bf6")
[ StringLike d ] -> mkSym @c <$> liftIO (Temp.emptyTempFile d "bf6")
[ StringLike d, StringLike p ] -> mkSym @c <$> liftIO (Temp.emptyTempFile d p)
e -> throwIO $ BadFormException @c (mkList e)
entry $ bindMatch "sys:temp:dir" $ \case
[ ] -> do
s <- sysTempDir
mkSym @c <$> liftIO (Temp.createTempDirectory s "bf6")
[ StringLike d ] -> do
mkSym @c <$> liftIO (Temp.createTempDirectory d "bf6")
[ StringLike d, StringLike p ] -> do
mkSym @c <$> liftIO (Temp.createTempDirectory d p)
e -> throwIO $ BadFormException @c (mkList e)
entry $ bindMatch "uuid" $ const do
mkSym @c . show <$> liftIO UUID.nextRandom
brief "splits command line arguments"
$ args [ arg "definintion" "list", arg "..." "CLI" ]
$ desc ""
$ entry $ bindMatch "cli:split" $ \case
[ListVal p] -> pure nil
[ListVal p, ListVal es0] -> do
opts <- Map.fromList <$> S.toList_ do
for_ p $ \case
StringLike x ->
S.yield (x, (0, mkSym x))
ListVal [StringLike x, LitIntVal n] ->
S.yield (x, (n, mkSym @c x))
ListVal [StringLike x, LitIntVal n, StringLike alias] ->
S.yield (x, (n, mkSym @c alias))
_ -> pure ()
-- error $ show opts
parsed <- S.toList_ $ flip fix es0 $ \go -> \case
[] -> pure ()
( w@(StringLike piece) : rest ) -> do
case Map.lookup piece opts of
Nothing -> S.yield (Right w) >> go rest
Just (0,s) -> S.yield (Left (mkList [s, mkBool True])) >> go rest
Just (1,s) -> S.yield (Left (mkList [s, headDef nil rest])) >> go (drop 1 rest)
Just (n',s) -> do
let n = fromIntegral n'
S.yield (Left (mkList [s, mkList (take n rest)]))
go (drop n rest)
( w : rest ) -> do
S.yield (Right w) >> go (drop 1 rest)
pure $ mkList [ mkList (lefts parsed)
, mkList (rights parsed)
]
_ -> pure nil
entry $ bindMatch "path:join" $ \case
StringLikeList es -> lift do
pure $ mkSym (joinPath es)
[ ListVal (StringLikeList es) ] -> do
pure $ mkSym (joinPath es)
_ -> pure nil
brief "get file size"
$ args [ arg "list" "filename" ]
$ returns "file-size" "double"
$ entry $ bindMatch "file:size" $ \case
[ StringLike p ] -> mkInt <$> fileSize p
_ -> throwIO $ BadFormException @c nil
entry $ bindMatch "path:split" $ \case
[ StringLike p ] -> pure $ mkList (fmap mkStr (splitPath p))
_ -> throwIO $ BadFormException @c nil
entry $ bindMatch "path:exists?" $ \case
[ StringLike p ] -> lift do
liftIO (Dir.doesPathExist p) <&> mkBool
_ -> pure $ mkBool False
entry $ bindMatch "path:dir?" $ \case
[ StringLike p ] -> lift do
liftIO (Dir.doesDirectoryExist p) <&> mkBool
_ -> pure $ mkBool False
entry $ bindMatch "path:file?" $ \case
[ StringLike p ] -> lift do
liftIO (Dir.doesFileExist p) <&> mkBool
_ -> pure $ mkBool False
entry $ bindMatch "path:ext" $ \case
[ StringLike p ] -> pure $ mkSym (P.takeExtension p)
_ -> throwIO $ BadFormException @c nil
entry $ bindMatch "path:base" $ \case
[ StringLike p ] -> pure $ mkSym (P.takeBaseName p)
_ -> throwIO $ BadFormException @c nil
entry $ bindMatch "path:filename" $ \case
[ StringLike p ] -> pure $ mkSym (P.takeFileName p)
_ -> throwIO $ BadFormException @c nil
entry $ bindMatch "path:dirname" $ \case
[ StringLike p ] -> pure $ mkSym (P.takeDirectory p)
_ -> throwIO $ BadFormException @c nil
entry $ bindMatch "path:expand" $ \case
[ StringLike p ] -> lift do
mkSym <$> canonicalizePath p
_ -> throwIO $ BadFormException @c nil
entry $ bindMatch "dir:list:files" $ \case
[ StringLike p, StringLike pat ] -> lift do
dirFiles p <&> mkList . fmap mkSym . filter ( (pat ?==) . takeFileName )
[ StringLike p ] -> lift do
dirFiles p <&> mkList . fmap mkSym
[] -> dirFiles "." <&> mkList . fmap mkSym
e -> throwIO $ BadFormException @c (mkList e)
entry $ bindMatch "dir:list:all" $ \case
[ StringLike p ] -> lift do
what <- S.toList_ $ dirEntries p $ \e -> do
let r = case e of
EntryFile what -> mkList @c [mkSym what, mkSym "file" ]
EntryDir what -> mkList @c [mkSym what, mkSym "dir" ]
EntryOther what -> mkList @c [mkSym what, mkSym "other" ]
S.yield r
pure True
pure $ mkList what
_ -> throwIO $ BadFormException @c nil
entry $ bindMatch "random:flip" $ const do
mkBool <$> randomIO @Bool
entry $ bindMatch "random:int" $ \case
[ ] -> mkInt <$> randomIO
[ LitIntVal a, LitIntVal b ] -> mkInt <$> randomRIO (a,b)
_ -> mkInt <$> randomIO
entry $ bindMatch "random:uint" $ \case
[ ] -> mkInt . abs <$> randomIO
[ LitIntVal a, LitIntVal b ] -> mkInt <$> randomRIO (abs a, abs b)
_ -> mkInt . abs <$> randomIO
entry $ bindMatch "random:float" $ \input -> do
case input of
[] -> mkDouble <$> randomIO
[ LitScientificVal a, LitScientificVal b ] -> do
x <- randomRIO (realToFrac a, realToFrac b)
pure $ mkDouble x
_ -> mkDouble <$> randomIO
brief "average of numeric list"
$ args [ arg "list" "list" ]
$ returns "double" "double"
$ entry $ bindMatch "stat:avg" \case
[ ListVal es ] -> pure $ safeAvg es
es -> pure $ safeAvg es
entry $ bindAlias "avg" "stat:avg"
brief "median of numeric list"
$ args [ arg "list" "list" ]
$ returns "double" "double"
$ entry $ bindMatch "stat:median" \case
[ ListVal es ] -> pure $ safeMedian es
es -> pure $ safeMedian es
entry $ bindAlias "median" "stat:median"
entry $ bindMatch "random:shuffle" $ \input -> do
case arglistOrList input of
[] -> pure $ mkList []
xs -> mkList <$> liftIO (shuffleM xs)
entry $ bindMatch "random:seq" $ \input -> do
case input of
(LitIntVal n : rest) | n > 0 -> do
case arglistOrList rest of
[] -> pure $ mkList []
xs -> do
shuffled <- liftIO (shuffleM xs)
pure . mkList $ take (fromIntegral n) shuffled
_ -> pure $ mkList []
entry $ bindMatch "random:choice" $ \input -> do
case arglistOrList input of
[] -> pure $ mkList []
xs -> do
i <- randomRIO (0, length xs - 1)
case Safe.atMay xs i of
Just v -> pure v
Nothing -> pure $ mkList []
entry $ bindMatch "strftime" $ \case
[ StringLike fmt, LitIntVal t ] -> do
let utcTime = posixSecondsToUTCTime (fromIntegral t)
formattedTime = formatTime defaultTimeLocale fmt utcTime
pure $ mkStr formattedTime
_ -> pure $ mkStr ""
entry $ bindMatch "forked" $ \case
[ e ] -> do
env <- ask
po <- pwd
oe <- liftIO $ getEnvironment
lift do
flip runContT pure do
a <- ContT $ withAsyncBound $ do
runEval env [e]
r <- wait a
cd po
restoreEnvironment oe
pure r
_ -> throwIO $ BadFormException @c nil
entry $ bindMatch "css" $ \case
[ sel, ListVal kwa ] -> do
let se = case sel of
ListVal es -> asSym $ concatTerms hcat $ List.intersperse (mkSym ",") es
TextLike s -> pretty $ mkSym @c s
other -> pretty $ mkSym @c (show $ pretty other)
let body = hsep
[ pretty k <> ":" <+> pretty v <> semi
| ListVal [TextLike k, v] <- kwa
]
let css = se <+> braces body
pure $ mkStr (show css)
_ -> pure nil
entry $ bindMatch "html" $ \syn -> do
let what = case syn of
(TextLike tag : ListVal a : [ListVal content] ) -> Just (tag,a,content)
(TextLike tag : ListVal a : content ) -> Just (tag,a,content)
[TextLike tag] -> Just (tag,mempty,mempty)
_ -> Nothing
case what of
Nothing -> pure nil
Just (tag, a, content) -> do
let attrs = [ Text.pack (show $ " " <> pretty k <> "=" <> dquotes (pretty (Html.text v)))
| ListVal [TextLike k, TextLike v] <- a
] & mconcat
let body = case concatTerms hsep (flattenList (mkList content)) of
TextLike s -> s
_ -> mempty
let closing = if null content then mempty else angles ( "/" <> pretty tag )
let wtf = angles (pretty tag <> pretty attrs) <> pretty body <> closing
pure $ mkStr (show wtf)
safeAvg :: forall c . IsContext c => [Syntax c] -> Syntax c
safeAvg [] = mkDouble 0.0
safeAvg es = mkDouble $ sum (map asDouble es) / fromIntegral (List.length es)
safeMedian :: forall c . IsContext c => [Syntax c] -> Syntax c
safeMedian [] = mkDouble 0.0
safeMedian esSorted =
let sorted = List.sort (map asDouble esSorted)
n = length sorted
in mkDouble $
if odd n
then sorted !! (n `div` 2)
else let i = n `div` 2
in (sorted !! (i - 1) + sorted !! i) / 2
asDouble :: forall c . IsContext c => Syntax c -> Double
asDouble = \case
LitIntVal n -> realToFrac n
LitScientificVal n -> realToFrac n
_ -> 0.0
arglistOrList :: forall c . IsContext c => [Syntax c] -> [Syntax c]
arglistOrList = \case
[ ListVal xs ] -> xs
xs@(_:_) -> xs
_ -> []
parseJson :: forall c . IsContext c => LBS.ByteString -> Syntax c
parseJson input = case Aeson.decode @Value input of
Just val -> mkSyntax @c val
Nothing -> nil
parseYaml :: forall c . IsContext c => LBS.ByteString -> Syntax c
parseYaml input =
case Yaml.decodeEither' @Value (LBS.toStrict input) of
Left _ -> nil @c
Right val -> mkSyntax @c val
parseIni :: forall c . IsContext c => LBS.ByteString -> Syntax c
parseIni input =
case Ini.parseIni (decodeUtf8With ignore $ LBS.toStrict input) of
Left _ -> nil
Right ini -> mkSyntax @c (IniConfig ini)
matchOne :: IsContext c => Text -> Syntax c -> Bool
matchOne what = \case
s@(TextLike x) | Text.isInfixOf what x -> True
e@(ListVal xs) -> or [ Text.isInfixOf what s | TextLike s <- xs ]
_ -> False
flattenList :: IsContext c => Syntax c -> [Syntax c]
flattenList (ListVal xs) = concatMap flattenList xs
flattenList x = [x]
partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
partitionM _ [] = pure ([], [])
partitionM p (x:xs) = do
(yes, no) <- partitionM p xs
b <- p x
pure $ if b then (x:yes, no) else (yes, x:no)
groupByM :: Monad m => (a -> a -> m Bool) -> [a] -> m [[a]]
groupByM _ [] = pure []
groupByM eq (x:xs) = do
(same, rest) <- partitionM (eq x) xs
groups <- groupByM eq rest
pure ((x:same) : groups)
toOrdering :: Bool -> Ordering
toOrdering True = LT
toOrdering False = GT
sortByM :: Monad m => (a -> a -> m Bool) -> [a] -> m [a]
sortByM cmp xs = do
let indexed = zip xs [0..]
keyVals <- mapM (\(a, i) -> do
k <- mapM (\b -> cmp a b) xs
pure (sum (map fromEnum k), i, a))
indexed
let sorted = List.sortOn (\(key, idx, _) -> (key, idx)) keyVals
pure $ map (\(_, _, val) -> val) sorted
compareSyn :: Syntax c -> Syntax c -> Ordering
compareSyn (LitIntVal a) (LitIntVal b) = compare a b
compareSyn (LitScientificVal a) (LitScientificVal b) = compare a b
compareSyn (LitIntVal a) (LitScientificVal b) = compare (fromIntegral a) b
compareSyn (LitScientificVal a) (LitIntVal b) = compare a (fromIntegral b)
compareSyn (TextLike a) (TextLike b) = compare a b
compareSyn (ListVal a) (ListVal b) = compareLists a b
compareSyn _ _ = error "type check error"
compareLists :: [Syntax c] -> [Syntax c] -> Ordering
compareLists [] [] = EQ
compareLists [] _ = LT
compareLists _ [] = GT
compareLists (x:xs) (y:ys) =
case compareSyn x y of
EQ -> compareLists xs ys
ord -> ord
concatTerms :: forall ann c . IsContext c => ( [Doc ann] -> Doc ann) -> [Syntax c] -> Syntax c
concatTerms s = \case
[ListVal xs] -> do
mkStr @c ( show $ pretty $ concatTerms s xs )
xs -> mkStr ( show $ s (fmap fmt xs) )
matched :: forall c m . ( IsContext c
, MonadUnliftIO m
, Exception (BadFormException c)
)
=> [Syntax c] -> RunM c m (Syntax c)
matched = \case
[ a, b ] -> do
syn <- apply_ a [b]
-- display_ $ show $ "AAAAA" <+> pretty a <+> pretty syn
(_,w) <- runWriterT $ scan syn
pure $ mkList [ mkList [mkSym n, e] | (n,e) <- w ]
where
scan = \case
ListVal [SymbolVal x, e] -> do
-- display_ $ "KHUYAK" <+> pretty x <+> pretty e
-- e' <- scan e
tell [(x, e)]
pure e
ListVal es -> do
es' <- mapM scan es
pure (mkList es')
e -> do
tell [("_", e)]
pure e
z -> throwIO (BadFormException @c (mkList z))
bf6TypeOf :: forall c . (IsContext c)
=> Syntax c
-> Maybe (Syntax c)
bf6TypeOf = \case
ListVal{} -> pure $ mkSym "list"
SymbolVal{} -> pure $ mkSym "symbol"
LitStrVal{} -> pure $ mkSym "string"
LitIntVal{} -> pure $ mkSym "int"
LitScientificVal{} -> pure $ mkSym "real"
LitBoolVal{} -> pure $ mkSym "bool"
OpaqueValue{} -> pure $ mkSym "opaque"
_ -> Nothing
bf6TypeOfPred :: forall c . (IsContext c)
=> Id
-> Maybe (Syntax c)
bf6TypeOfPred = \case
"list?" -> pure $ mkSym "list"
"sym?" -> pure $ mkSym "symbol"
"str?" -> pure $ mkSym "string"
"int?" -> pure $ mkSym "int"
"real?" -> pure $ mkSym "real"
"bool?" -> pure $ mkSym "bool"
_ -> Nothing
asSym :: forall ann c . IsContext c => Syntax c -> Doc ann
asSym = \case
TextLike s -> pretty (mkSym @c s)
other -> pretty other
restoreEnvironment :: MonadIO m => [(String, String)] -> m ()
restoreEnvironment newEnv = liftIO do
currentEnv <- getEnvironment
let toRemove = map fst currentEnv \\ map fst newEnv
mapM_ unsetEnv toRemove
mapM_ (uncurry setEnv) newEnv
substIn :: forall c . IsContext c => HashMap Id (Syntax c) -> Syntax c -> Syntax c
substIn repl = go
where
go = \case
List c xs -> List c (fmap go xs)
s@(Symbol _ n) -> fromMaybe s (HM.lookup n repl)
e -> e
matchPattern :: forall c m . (IsContext c, MonadUnliftIO m, Exception (BadFormException c))
=> Syntax c -- ^ pattern
-> Syntax c -- ^ expression
-> Syntax c -- ^ production
-> RunM c m (Maybe (Syntax c))
matchPattern p0 e0 syn = do
pMatchOne p0 e0 >>= \case
Nothing -> pure $ Nothing
Just repl -> do
d0 <- ask >>= readTVarIO
for_ (List.reverse repl) $ \(n,e) -> do
bind n e
r <- eval syn
t <- ask
atomically (writeTVar t d0)
pure $ Just r
where
pMatchOne p e = do
case p of
ListVal [ SymbolVal "?", SymbolVal n, pe ] -> do
pMatchOne pe e >>= \case
Just found -> pure $ Just $ (n,e) : found
Nothing -> pure Nothing
ListVal [ SymbolVal "list?" ] | isNil e -> pure $ Just []
ListVal (SymbolVal "list?" : rest) -> runMaybeT do
lls <- case e of
ListVal es -> pure es
_ -> mzero
flip fix (rest,lls,mempty) \next -> \case
([SymbolVal "..."], xs, rs) -> pure (("...", mkList xs) : rs)
([SymbolVal ".", SymbolVal b], xs, rs) -> do
pure ((b, mkList xs) : rs)
(SymbolVal "..." : _ : _ , _, _) -> throwIO $ BadFormException p
(SymbolVal "." : _, _, _) -> throwIO $ BadFormException p
(SymbolVal c : es, x:xs, rs) -> do
next (es,xs,(c,x):rs)
( pp : ps, x:xs, rs) -> do
r <- MaybeT (pMatchOne pp x)
next (ps, xs, r <> rs)
([],[],rs) -> pure rs
(what, _, _) -> mzero
ListVal [ SymbolVal pp, SymbolVal "_"] -> do
if bf6TypeOf e == bf6TypeOfPred pp then pure $ Just [] else pure Nothing
ListVal [ SymbolVal pp ] | isJust (bf6TypeOfPred @c pp) -> do
if bf6TypeOf e == bf6TypeOfPred pp then pure $ Just [] else pure Nothing
ListVal [ SymbolVal pp, ppe@(ListVal{}) ] -> do
let tp = bf6TypeOf e == bf6TypeOfPred pp
if not tp then
pure Nothing
else do
pe <- eval ppe
what <- apply_ @c pe [e]
if isTrue what then pure $ Just [] else pure Nothing
ListVal [ SymbolVal pp, pEq' ] -> do
if bf6TypeOf e == bf6TypeOfPred pp then do
pEq <- eval pEq'
if pEq == e then pure $ Just [] else pure Nothing
else
pure Nothing
SymbolVal n -> pure $ Just [(n,e)]
zu -> error $ show $ "not yet" <+> pretty zu