mirror of https://github.com/voidlizard/hbs2
1596 lines
48 KiB
Haskell
1596 lines
48 KiB
Haskell
{-# Language AllowAmbiguousTypes #-}
|
||
{-# Language UndecidableInstances #-}
|
||
{-# Language PatternSynonyms #-}
|
||
{-# Language ViewPatterns #-}
|
||
{-# Language RecordWildCards #-}
|
||
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.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.Data
|
||
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.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)
|
||
import Data.Text.Encoding.Error (ignore)
|
||
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 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" -}
|
||
|
||
|
||
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 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) }
|
||
| 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)
|
||
| 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
|
||
|
||
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)
|
||
|
||
hidePrefix :: Id -> MakeDictM c m () -> MakeDictM c m ()
|
||
hidePrefix (Id p) = censor (HM.filterWithKey exclude)
|
||
where
|
||
exclude (Id k) _ = not (Text.isPrefixOf p k)
|
||
|
||
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
|
||
|
||
when (length decl /= length ev) do
|
||
throwIO (ArityMismatch @c nil)
|
||
|
||
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 "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 (Lambda argz body) ) -> do
|
||
applyLambda argz body 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
|
||
|
||
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
|
||
|
||
dict1 <- ask >>= readTVarIO
|
||
|
||
let dict = dict0 <> dict1
|
||
|
||
-- liftIO $ print $ show $ "TRACE EXP" <+> pretty syn
|
||
|
||
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 "`", ListVal b] -> do
|
||
mkList <$> mapM (evalQQ dict) b
|
||
|
||
ListVal [ SymbolVal "quasiquot", ListVal b] -> do
|
||
mkList <$> mapM (evalQQ dict) b
|
||
|
||
ListVal [ SymbolVal "quot", b] -> do
|
||
pure b
|
||
|
||
ListVal [ SymbolVal "eval", e ] -> eval e >>= eval
|
||
|
||
ListVal [SymbolVal "define", SymbolVal what, e] -> 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
|
||
|
||
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 =<< 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
|
||
|
||
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) }
|
||
|
||
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)
|
||
|
||
|
||
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 :: 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)
|
||
|
||
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) )
|
||
|
||
entry $ bindMatch "join" $ \case
|
||
[ x, ListVal es ] -> do
|
||
let xs = List.intersperse x es
|
||
pure $ mkStr ( show $ hcat (fmap fmt xs) )
|
||
|
||
_ -> 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 "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 "eval" $ \syn -> do
|
||
r <- mapM eval syn
|
||
pure $ lastDef nil r
|
||
|
||
entry $ bindMatch "id" $ \case
|
||
[ e ] -> pure e
|
||
_ -> throwIO (BadFormException @C nil)
|
||
|
||
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 "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 $ 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)
|
||
|
||
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 "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 "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-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 "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 "assoc" $ \case
|
||
[k, ListVal es ] -> pure $ headDef nil [ r | r@(ListVal (w:_)) <- es, k == w ]
|
||
_ -> throwIO (BadFormException @c nil)
|
||
|
||
--TODO: integral sum
|
||
|
||
entry $ bindMatch "upper" $ \case
|
||
[ LitStrVal x ] -> pure $ mkStr $ Text.toUpper x
|
||
[ SymbolVal (Id x) ] -> pure $ mkSym $ Text.toUpper x
|
||
_ -> pure nil
|
||
|
||
entry $ bindMatch "lower" $ \case
|
||
[ LitStrVal x ] -> pure $ mkStr $ Text.toLower x
|
||
[ SymbolVal (Id x) ] -> pure $ mkSym $ Text.toLower x
|
||
_ -> pure nil
|
||
|
||
entry $ bindMatch "words" $ \case
|
||
[ TextLike x ] -> pure $ mkList [ mkSym y | y <- Text.words x ]
|
||
_ -> pure nil
|
||
|
||
entry $ bindMatch "lines" $ \case
|
||
[ TextLike x ] -> pure $ mkList [ mkSym y | y <- Text.lines x ]
|
||
_ -> pure nil
|
||
|
||
entry $ bindMatch "mod" $ \case
|
||
[LitIntVal a, LitIntVal b] | b /= 0 -> pure $ mkInt (a `mod` b)
|
||
_ -> throwIO (BadFormException @c nil)
|
||
|
||
entry $ bindMatch "%" $ \case
|
||
[LitIntVal a, LitIntVal b] | b /= 0 -> pure $ mkInt (a `mod` b)
|
||
_ -> throwIO (BadFormException @c nil)
|
||
|
||
entry $ bindMatch "sum" $ \case
|
||
[ ListVal es ] -> do
|
||
let v = flip mapMaybe es \case
|
||
LitIntVal n -> Just $ realToFrac n
|
||
LitScientificVal n -> Just $ realToFrac @_ @Double n
|
||
_ -> Nothing
|
||
|
||
pure $ mkDouble $ sum v
|
||
|
||
_ -> pure $ mkDouble 0
|
||
|
||
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 "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
|
||
-- let wtf = show $ pretty s
|
||
-- let x = Text.unpack $ renderStrict $ layoutPretty defaultLayoutOptions (annotate f $ pretty wtf)
|
||
-- -- error $ show x
|
||
-- pure $ mkStr x
|
||
|
||
_ -> 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 "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 "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 $ 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:stdin" $ const do
|
||
parseJson <$> liftIO (LBS.hGetContents stdin)
|
||
|
||
entry $ bindMatch "json:file" $ \case
|
||
[StringLike fn] -> do
|
||
parseYaml <$> liftIO (LBS.readFile fn)
|
||
|
||
_ -> 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:file" $ \case
|
||
[StringLike fn] -> do
|
||
liftIO $ TIO.readFile fn
|
||
<&> either (const nil) (mkList . fmap fixContext) . parseTop
|
||
|
||
_ -> 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)
|
||
_ -> 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 "str" $ \case
|
||
[] -> pure $ mkStr ""
|
||
[x] -> pure $ mkStr (show $ pretty x)
|
||
xs -> pure $ mkStr $ mconcat [ show (pretty e) | e <- xs ]
|
||
|
||
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] -> 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 $ 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 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)
|
||
|
||
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
|
||
|
||
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 -- Если `cmp x y` → True, то `x < y`
|
||
toOrdering False = GT -- Иначе `x > y`
|
||
|
||
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
|
||
|