From 13f549d68fb235522ae98bf04d2e09abdb1442ea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Thu, 27 Feb 2025 16:39:04 +0100 Subject: Refactor script/expression related code to multiple modules --- erebos-tester.cabal | 3 + src/Main.hs | 1 + src/Network.hs | 2 +- src/Network.hs-boot | 5 - src/Parser.hs | 2 + src/Parser/Core.hs | 2 + src/Parser/Expr.hs | 2 +- src/Parser/Statement.hs | 1 + src/Run.hs | 1 + src/Run/Monad.hs | 2 +- src/Script/Expr.hs | 443 +++++++++++++++++++++++++++++++++++++++++ src/Script/Expr/Class.hs | 15 +- src/Script/Module.hs | 20 ++ src/Script/Var.hs | 56 ++++++ src/Test.hs | 498 +---------------------------------------------- src/Test/Builtins.hs | 1 + 16 files changed, 544 insertions(+), 510 deletions(-) delete mode 100644 src/Network.hs-boot create mode 100644 src/Script/Expr.hs create mode 100644 src/Script/Module.hs create mode 100644 src/Script/Var.hs diff --git a/erebos-tester.cabal b/erebos-tester.cabal index 87aa6e2..cc8d46a 100644 --- a/erebos-tester.cabal +++ b/erebos-tester.cabal @@ -59,7 +59,10 @@ executable erebos-tester Process Run Run.Monad + Script.Expr Script.Expr.Class + Script.Module + Script.Var Test Test.Builtins Util diff --git a/src/Main.hs b/src/Main.hs index 9b0667d..65a5692 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -23,6 +23,7 @@ import Output import Parser import Process import Run +import Script.Module import Test import Util import Version diff --git a/src/Network.hs b/src/Network.hs index 6a4f41d..3059773 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -26,8 +26,8 @@ import System.FilePath import System.Process import Network.Ip +import Script.Expr import Script.Expr.Class -import Test {- NETWORK STRUCTURE diff --git a/src/Network.hs-boot b/src/Network.hs-boot deleted file mode 100644 index 1b5e9c4..0000000 --- a/src/Network.hs-boot +++ /dev/null @@ -1,5 +0,0 @@ -module Network where - -data Network -data Node -data NodeName diff --git a/src/Parser.hs b/src/Parser.hs index 1d1d540..e9bf3d2 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -30,6 +30,8 @@ import Network import Parser.Core import Parser.Expr import Parser.Statement +import Script.Expr +import Script.Module import Test import Test.Builtins diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs index 5fb2139..abd8b96 100644 --- a/src/Parser/Core.hs +++ b/src/Parser/Core.hs @@ -17,6 +17,8 @@ import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L import Network () +import Script.Expr +import Script.Module import Test newtype TestParser a = TestParser (StateT TestParserState (ParsecT CustomTestError TestStream IO) a) diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs index da137af..5d60973 100644 --- a/src/Parser/Expr.hs +++ b/src/Parser/Expr.hs @@ -39,8 +39,8 @@ import Text.Regex.TDFA qualified as RE import Text.Regex.TDFA.Text qualified as RE import Parser.Core +import Script.Expr import Script.Expr.Class -import Test reservedWords :: [ Text ] reservedWords = diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs index 97ae4fc..dd5832d 100644 --- a/src/Parser/Statement.hs +++ b/src/Parser/Statement.hs @@ -22,6 +22,7 @@ import Network (Network, Node) import Parser.Core import Parser.Expr import Process (Process) +import Script.Expr import Script.Expr.Class import Test import Util diff --git a/src/Run.hs b/src/Run.hs index 1b2f448..fcd1d0d 100644 --- a/src/Run.hs +++ b/src/Run.hs @@ -31,6 +31,7 @@ import Network.Ip import Output import Process import Run.Monad +import Script.Expr import Test import Test.Builtins diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs index 3fc511a..1c96c90 100644 --- a/src/Run/Monad.hs +++ b/src/Run/Monad.hs @@ -24,7 +24,7 @@ import {-# SOURCE #-} GDB import Network.Ip import Output import {-# SOURCE #-} Process -import Test +import Script.Expr newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed IO) a } deriving (Functor, Applicative, Monad, MonadReader (TestEnv, TestState), MonadIO) diff --git a/src/Script/Expr.hs b/src/Script/Expr.hs new file mode 100644 index 0000000..e8f6993 --- /dev/null +++ b/src/Script/Expr.hs @@ -0,0 +1,443 @@ +module Script.Expr ( + Expr(..), varExpr, mapExpr, + + MonadEval(..), VariableDictionary, GlobalDefs, + lookupVar, tryLookupVar, withVar, withTypedVar, + eval, evalSome, evalSomeWith, + + FunctionType, DynamicType, + ExprType(..), SomeExpr(..), + TypeVar(..), SomeExprType(..), someExprType, textSomeExprType, + + VarValue(..), SomeVarValue(..), + svvVariables, svvArguments, + someConstValue, fromConstValue, + fromSomeVarValue, textSomeVarValue, someVarValueType, + + ArgumentKeyword(..), FunctionArguments(..), + anull, exprArgs, + SomeArgumentType(..), ArgumentType(..), + + Traced(..), EvalTrace, VarNameSelectors, gatherVars, + AppAnnotation(..), + + module Script.Var, + + Regex(RegexPart, RegexString), regexMatch, +) where + +import Control.Monad +import Control.Monad.Reader + +import Data.Char +import Data.Foldable +import Data.List +import Data.Map (Map) +import Data.Map qualified as M +import Data.String +import Data.Text (Text) +import Data.Text qualified as T +import Data.Typeable + +import Text.Regex.TDFA qualified as RE +import Text.Regex.TDFA.Text qualified as RE + +import Script.Expr.Class +import Script.Var +import Util + + +data Expr a where + Let :: forall a b. ExprType b => SourceLine -> TypedVarName b -> Expr b -> Expr a -> Expr a + Variable :: ExprType a => SourceLine -> FqVarName -> Expr a + DynVariable :: TypeVar -> SourceLine -> FqVarName -> Expr DynamicType + FunVariable :: ExprType a => FunctionArguments SomeArgumentType -> SourceLine -> FqVarName -> Expr (FunctionType a) + ArgsReq :: ExprType a => FunctionArguments ( VarName, SomeArgumentType ) -> Expr (FunctionType a) -> Expr (FunctionType a) + ArgsApp :: ExprType a => FunctionArguments SomeExpr -> Expr (FunctionType a) -> Expr (FunctionType a) + FunctionAbstraction :: ExprType a => Expr a -> Expr (FunctionType a) + FunctionEval :: ExprType a => Expr (FunctionType a) -> Expr a + LambdaAbstraction :: ExprType a => TypedVarName a -> Expr b -> Expr (a -> b) + Pure :: a -> Expr a + App :: AppAnnotation b -> Expr (a -> b) -> Expr a -> Expr b + Concat :: [ Expr Text ] -> Expr Text + Regex :: [ Expr Regex ] -> Expr Regex + Undefined :: String -> Expr a + Trace :: Expr a -> Expr (Traced a) + +data AppAnnotation b = AnnNone + | ExprType b => AnnRecord Text + +instance Functor Expr where + fmap f x = Pure f <*> x + +instance Applicative Expr where + pure = Pure + (<*>) = App AnnNone + +instance Semigroup a => Semigroup (Expr a) where + e <> f = (<>) <$> e <*> f + +instance Monoid a => Monoid (Expr a) where + mempty = Pure mempty + +varExpr :: ExprType a => SourceLine -> TypedVarName a -> Expr a +varExpr sline (TypedVarName name) = Variable sline (LocalVarName name) + +mapExpr :: forall a. (forall b. Expr b -> Expr b) -> Expr a -> Expr a +mapExpr f = go + where + go :: forall c. Expr c -> Expr c + go = \case + Let sline vname vval expr -> f $ Let sline vname (go vval) (go expr) + e@Variable {} -> f e + e@DynVariable {} -> f e + e@FunVariable {} -> f e + ArgsReq args expr -> f $ ArgsReq args (go expr) + ArgsApp args expr -> f $ ArgsApp (fmap (\(SomeExpr e) -> SomeExpr (go e)) args) (go expr) + FunctionAbstraction expr -> f $ FunctionAbstraction (go expr) + FunctionEval expr -> f $ FunctionEval (go expr) + LambdaAbstraction tvar expr -> f $ LambdaAbstraction tvar (go expr) + e@Pure {} -> f e + App ann efun earg -> f $ App ann (go efun) (go earg) + e@Concat {} -> f e + e@Regex {} -> f e + e@Undefined {} -> f e + Trace expr -> f $ Trace (go expr) + + + +class MonadFail m => MonadEval m where + askGlobalDefs :: m GlobalDefs + askDictionary :: m VariableDictionary + withDictionary :: (VariableDictionary -> VariableDictionary) -> m a -> m a + +type GlobalDefs = Map ( ModuleName, VarName ) SomeVarValue + +type VariableDictionary = [ ( VarName, SomeVarValue ) ] + +lookupVar :: MonadEval m => FqVarName -> m SomeVarValue +lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackFqVarName name ++ "'") return =<< tryLookupVar name + +tryLookupVar :: MonadEval m => FqVarName -> m (Maybe SomeVarValue) +tryLookupVar (LocalVarName name) = lookup name <$> askDictionary +tryLookupVar (GlobalVarName mname var) = M.lookup ( mname, var ) <$> askGlobalDefs + +withVar :: (MonadEval m, ExprType e) => VarName -> e -> m a -> m a +withVar name value = withDictionary (( name, someConstValue value ) : ) + +withTypedVar :: (MonadEval m, ExprType e) => TypedVarName e -> e -> m a -> m a +withTypedVar (TypedVarName name) = withVar name + +isInternalVar :: FqVarName -> Bool +isInternalVar (GlobalVarName {}) = False +isInternalVar (LocalVarName (VarName name)) + | Just ( '$', _ ) <- T.uncons name = True + | otherwise = False + + +newtype SimpleEval a = SimpleEval (Reader ( GlobalDefs, VariableDictionary ) a) + deriving (Functor, Applicative, Monad) + +runSimpleEval :: SimpleEval a -> GlobalDefs -> VariableDictionary -> a +runSimpleEval (SimpleEval x) = curry $ runReader x + +instance MonadFail SimpleEval where + fail = error . ("eval failed: " <>) + +instance MonadEval SimpleEval where + askGlobalDefs = SimpleEval (asks fst) + askDictionary = SimpleEval (asks snd) + withDictionary f (SimpleEval inner) = SimpleEval (local (fmap f) inner) + +eval :: forall m a. MonadEval m => Expr a -> m a +eval = \case + Let _ (TypedVarName name) valExpr expr -> do + val <- eval valExpr + withVar name val $ eval expr + Variable sline name -> fromSomeVarValue sline name =<< lookupVar name + DynVariable _ _ name -> fail $ "ambiguous type of ‘" <> unpackFqVarName name <> "’" + FunVariable _ sline name -> funFromSomeVarValue sline name =<< lookupVar name + ArgsReq (FunctionArguments req) efun -> do + gdefs <- askGlobalDefs + dict <- askDictionary + return $ FunctionType $ \(FunctionArguments args) -> + let used = M.intersectionWith (\value ( vname, _ ) -> ( vname, value )) args req + FunctionType fun = runSimpleEval (eval efun) gdefs (toList used ++ dict) + in fun $ FunctionArguments $ args `M.difference` req + ArgsApp eargs efun -> do + FunctionType fun <- eval efun + args <- mapM evalSome eargs + return $ FunctionType $ \args' -> fun (args <> args') + FunctionAbstraction expr -> do + val <- eval expr + return $ FunctionType $ const val + FunctionEval efun -> do + FunctionType fun <- eval efun + return $ fun mempty + LambdaAbstraction (TypedVarName name) expr -> do + gdefs <- askGlobalDefs + dict <- askDictionary + return $ \x -> runSimpleEval (eval expr) gdefs (( name, someConstValue x ) : dict) + Pure value -> return value + App _ f x -> eval f <*> eval x + Concat xs -> T.concat <$> mapM eval xs + Regex xs -> mapM eval xs >>= \case + [ re@RegexCompiled {} ] -> return re + parts -> case regexCompile $ T.concat $ map regexSource parts of + Left err -> fail err + Right re -> return re + Undefined err -> fail err + Trace expr -> Traced <$> gatherVars expr <*> eval expr + +evalToVarValue :: MonadEval m => Expr a -> m (VarValue a) +evalToVarValue expr = do + VarValue + <$> gatherVars expr + <*> pure mempty + <*> (const . const <$> eval expr) + +evalFunToVarValue :: MonadEval m => Expr (FunctionType a) -> m (VarValue a) +evalFunToVarValue expr = do + FunctionType fun <- eval expr + VarValue + <$> gatherVars expr + <*> pure (exprArgs expr) + <*> pure (const fun) + +evalSome :: MonadEval m => SomeExpr -> m SomeVarValue +evalSome (SomeExpr expr) + | IsFunType <- asFunType expr = SomeVarValue <$> evalFunToVarValue expr + | otherwise = SomeVarValue <$> evalToVarValue expr + +evalSomeWith :: GlobalDefs -> SomeExpr -> SomeVarValue +evalSomeWith gdefs sexpr = runSimpleEval (evalSome sexpr) gdefs [] + + +data FunctionType a = FunctionType (FunctionArguments SomeVarValue -> a) + +instance ExprType a => ExprType (FunctionType a) where + textExprType _ = "function type" + textExprValue _ = "" + +data DynamicType + +instance ExprType DynamicType where + textExprType _ = "ambiguous type" + textExprValue _ = "" + + +data SomeExpr = forall a. ExprType a => SomeExpr (Expr a) + +newtype TypeVar = TypeVar Text + deriving (Eq, Ord) + +data SomeExprType + = forall a. ExprType a => ExprTypePrim (Proxy a) + | ExprTypeVar TypeVar + | forall a. ExprType a => ExprTypeFunction (FunctionArguments SomeArgumentType) (Proxy a) + +someExprType :: SomeExpr -> SomeExprType +someExprType (SomeExpr expr) = go expr + where + go :: forall e. ExprType e => Expr e -> SomeExprType + go = \case + DynVariable tvar _ _ -> ExprTypeVar tvar + (e :: Expr a) + | IsFunType <- asFunType e -> ExprTypeFunction (gof e) (proxyOfFunctionType e) + | otherwise -> ExprTypePrim (Proxy @a) + + gof :: forall e. ExprType e => Expr (FunctionType e) -> FunctionArguments SomeArgumentType + gof = \case + Let _ _ _ body -> gof body + Variable {} -> error "someExprType: gof: variable" + FunVariable params _ _ -> params + ArgsReq args body -> fmap snd args <> gof body + ArgsApp (FunctionArguments used) body -> + let FunctionArguments args = gof body + in FunctionArguments $ args `M.difference` used + FunctionAbstraction {} -> mempty + FunctionEval {} -> error "someExprType: gof: function eval" + Pure {} -> error "someExprType: gof: pure" + App {} -> error "someExprType: gof: app" + Undefined {} -> error "someExprType: gof: undefined" + + proxyOfFunctionType :: Expr (FunctionType a) -> Proxy a + proxyOfFunctionType _ = Proxy + +textSomeExprType :: SomeExprType -> Text +textSomeExprType (ExprTypePrim p) = textExprType p +textSomeExprType (ExprTypeVar (TypeVar name)) = name +textSomeExprType (ExprTypeFunction _ r) = "function:" <> textExprType r + +data AsFunType a + = forall b. (a ~ FunctionType b, ExprType b) => IsFunType + | NotFunType + +asFunType :: Expr a -> AsFunType a +asFunType = \case + Let _ _ _ expr -> asFunType expr + FunVariable {} -> IsFunType + ArgsReq {} -> IsFunType + ArgsApp {} -> IsFunType + FunctionAbstraction {} -> IsFunType + _ -> NotFunType + + +data VarValue a = VarValue + { vvVariables :: EvalTrace + , vvArguments :: FunctionArguments SomeArgumentType + , vvFunction :: SourceLine -> FunctionArguments SomeVarValue -> a + } + +data SomeVarValue = forall a. ExprType a => SomeVarValue (VarValue a) + +svvVariables :: SomeVarValue -> EvalTrace +svvVariables (SomeVarValue vv) = vvVariables vv + +svvArguments :: SomeVarValue -> FunctionArguments SomeArgumentType +svvArguments (SomeVarValue vv) = vvArguments vv + +someConstValue :: ExprType a => a -> SomeVarValue +someConstValue = SomeVarValue . VarValue [] mempty . const . const + +fromConstValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> FqVarName -> VarValue a -> m a +fromConstValue sline name (VarValue _ args value :: VarValue b) = do + maybe (fail err) return $ do + guard $ anull args + cast $ value sline mempty + where + err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has type ", + if anull args then textExprType @b Proxy else "function type" ] + +fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> FqVarName -> SomeVarValue -> m a +fromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do + maybe (fail err) return $ do + guard $ anull args + cast $ value sline mempty + where + err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has type ", + if anull args then textExprType @b Proxy else "function type" ] + +textSomeVarValue :: SourceLine -> SomeVarValue -> Text +textSomeVarValue sline (SomeVarValue (VarValue _ args value)) + | anull args = textExprValue $ value sline mempty + | otherwise = "" + +someVarValueType :: SomeVarValue -> SomeExprType +someVarValueType (SomeVarValue (VarValue _ args _ :: VarValue a)) + | anull args = ExprTypePrim (Proxy @a) + | otherwise = ExprTypeFunction args (Proxy @a) + + +newtype ArgumentKeyword = ArgumentKeyword Text + deriving (Show, Eq, Ord, IsString) + +newtype FunctionArguments a = FunctionArguments (Map (Maybe ArgumentKeyword) a) + deriving (Show, Semigroup, Monoid, Functor, Foldable, Traversable) + +anull :: FunctionArguments a -> Bool +anull (FunctionArguments args) = M.null args + +exprArgs :: Expr (FunctionType a) -> FunctionArguments SomeArgumentType +exprArgs = \case + Let _ _ _ expr -> exprArgs expr + Variable {} -> mempty + FunVariable args _ _ -> args + ArgsReq args expr -> fmap snd args <> exprArgs expr + ArgsApp (FunctionArguments applied) expr -> + let FunctionArguments args = exprArgs expr + in FunctionArguments (args `M.difference` applied) + FunctionAbstraction {} -> mempty + FunctionEval {} -> mempty + Pure {} -> error "exprArgs: pure" + App {} -> error "exprArgs: app" + Undefined {} -> error "exprArgs: undefined" + +funFromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> FqVarName -> SomeVarValue -> m (FunctionType a) +funFromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do + maybe (fail err) return $ do + FunctionType <$> cast (value sline) + where + err = T.unpack $ T.concat [ T.pack "expected function returning ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has ", + (if anull args then "type " else "function type returting ") <> textExprType @b Proxy ] + +data SomeArgumentType = forall a. ExprType a => SomeArgumentType (ArgumentType a) + +data ArgumentType a + = RequiredArgument + | OptionalArgument + | ExprDefault (Expr a) + | ContextDefault + + +data Traced a = Traced EvalTrace a + +type VarNameSelectors = ( FqVarName, [ Text ] ) +type EvalTrace = [ ( VarNameSelectors, SomeVarValue ) ] + +gatherVars :: forall a m. MonadEval m => Expr a -> m EvalTrace +gatherVars = fmap (uniqOn fst . sortOn fst) . helper + where + helper :: forall b. Expr b -> m EvalTrace + helper = \case + Let _ (TypedVarName var) _ expr -> withDictionary (filter ((var /=) . fst)) $ helper expr + Variable _ var + | isInternalVar var -> return [] + | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var + DynVariable _ _ var -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var + FunVariable _ _ var -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var + ArgsReq args expr -> withDictionary (filter ((`notElem` map fst (toList args)) . fst)) $ helper expr + ArgsApp (FunctionArguments args) fun -> do + v <- helper fun + vs <- mapM (\(SomeExpr e) -> helper e) $ M.elems args + return $ concat (v : vs) + FunctionAbstraction expr -> helper expr + FunctionEval efun -> helper efun + LambdaAbstraction (TypedVarName var) expr -> withDictionary (filter ((var /=) . fst)) $ helper expr + Pure _ -> return [] + e@(App (AnnRecord sel) _ x) + | Just (var, sels) <- gatherSelectors x + -> do + val <- SomeVarValue . VarValue [] mempty . const . const <$> eval e + return [ (( var, sels ++ [ sel ] ), val ) ] + | otherwise -> do + helper x + App _ f x -> (++) <$> helper f <*> helper x + Concat es -> concat <$> mapM helper es + Regex es -> concat <$> mapM helper es + Undefined {} -> return [] + Trace expr -> helper expr + + gatherSelectors :: forall b. Expr b -> Maybe ( FqVarName, [ Text ] ) + gatherSelectors = \case + Variable _ var -> Just (var, []) + App (AnnRecord sel) _ x -> do + (var, sels) <- gatherSelectors x + return (var, sels ++ [sel]) + _ -> Nothing + + +data Regex = RegexCompiled Text RE.Regex + | RegexPart Text + | RegexString Text + +instance ExprType Regex where + textExprType _ = T.pack "regex" + textExprValue _ = T.pack "" + +regexCompile :: Text -> Either String Regex +regexCompile src = either Left (Right . RegexCompiled src) $ RE.compile RE.defaultCompOpt RE.defaultExecOpt $ + T.singleton '^' <> src <> T.singleton '$' + +regexMatch :: Regex -> Text -> Either String (Maybe (Text, Text, Text, [Text])) +regexMatch (RegexCompiled _ re) text = RE.regexec re text +regexMatch _ _ = Left "regex not compiled" + +regexSource :: Regex -> Text +regexSource (RegexCompiled src _) = src +regexSource (RegexPart src) = src +regexSource (RegexString str) = T.concatMap escapeChar str + where + escapeChar c | isAlphaNum c = T.singleton c + | c `elem` ['`', '\'', '<', '>'] = T.singleton c + | otherwise = T.pack ['\\', c] diff --git a/src/Script/Expr/Class.hs b/src/Script/Expr/Class.hs index 590b99c..64b4241 100644 --- a/src/Script/Expr/Class.hs +++ b/src/Script/Expr/Class.hs @@ -24,6 +24,14 @@ class Typeable a => ExprType a where exprEnumerator :: proxy a -> Maybe (ExprEnumerator a) exprEnumerator _ = Nothing + +data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b) + +data ExprListUnpacker a = forall e. ExprType e => ExprListUnpacker (a -> [e]) (Proxy a -> Proxy e) + +data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a]) + + instance ExprType Integer where textExprType _ = T.pack "integer" textExprValue x = T.pack (show x) @@ -52,10 +60,3 @@ instance ExprType a => ExprType [a] where textExprValue x = "[" <> T.intercalate ", " (map textExprValue x) <> "]" exprListUnpacker _ = Just $ ExprListUnpacker id (const Proxy) - - -data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b) - -data ExprListUnpacker a = forall e. ExprType e => ExprListUnpacker (a -> [e]) (Proxy a -> Proxy e) - -data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a]) diff --git a/src/Script/Module.hs b/src/Script/Module.hs new file mode 100644 index 0000000..3ea59bf --- /dev/null +++ b/src/Script/Module.hs @@ -0,0 +1,20 @@ +module Script.Module ( + Module(..), + ModuleName(..), textModuleName, + moduleExportedDefinitions, +) where + +import Script.Expr +import Test + +data Module = Module + { moduleName :: ModuleName + , moduleTests :: [ Test ] + , moduleDefinitions :: [ ( VarName, SomeExpr ) ] + , moduleExports :: [ VarName ] + } + +moduleExportedDefinitions :: Module -> [ ( VarName, ( FqVarName, SomeExpr )) ] +moduleExportedDefinitions Module {..} = + map (\( var, expr ) -> ( var, ( GlobalVarName moduleName var, expr ))) $ + filter ((`elem` moduleExports) . fst) moduleDefinitions diff --git a/src/Script/Var.hs b/src/Script/Var.hs new file mode 100644 index 0000000..668060c --- /dev/null +++ b/src/Script/Var.hs @@ -0,0 +1,56 @@ +module Script.Var ( + VarName(..), textVarName, unpackVarName, + FqVarName(..), textFqVarName, unpackFqVarName, unqualifyName, + TypedVarName(..), + ModuleName(..), textModuleName, + SourceLine(..), textSourceLine, +) where + +import Data.Text (Text) +import Data.Text qualified as T + + +newtype VarName = VarName Text + deriving (Eq, Ord) + +textVarName :: VarName -> Text +textVarName (VarName name) = name + +unpackVarName :: VarName -> String +unpackVarName = T.unpack . textVarName + + +data FqVarName + = GlobalVarName ModuleName VarName + | LocalVarName VarName + deriving (Eq, Ord) + +textFqVarName :: FqVarName -> Text +textFqVarName (GlobalVarName mname vname) = textModuleName mname <> "." <> textVarName vname +textFqVarName (LocalVarName vname) = textVarName vname + +unpackFqVarName :: FqVarName -> String +unpackFqVarName = T.unpack . textFqVarName + +unqualifyName :: FqVarName -> VarName +unqualifyName (GlobalVarName _ name) = name +unqualifyName (LocalVarName name) = name + + +newtype TypedVarName a = TypedVarName { fromTypedVarName :: VarName } + deriving (Eq, Ord) + + +newtype ModuleName = ModuleName [ Text ] + deriving (Eq, Ord, Show) + +textModuleName :: ModuleName -> Text +textModuleName (ModuleName parts) = T.intercalate "." parts + +data SourceLine + = SourceLine Text + | SourceLineBuiltin + +textSourceLine :: SourceLine -> Text +textSourceLine (SourceLine text) = text +textSourceLine SourceLineBuiltin = "" diff --git a/src/Test.hs b/src/Test.hs index 435250e..3458c04 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -1,73 +1,15 @@ module Test ( - Module(..), ModuleName(..), textModuleName, moduleExportedDefinitions, Test(..), TestStep(..), TestBlock(..), - SourceLine(..), textSourceLine, - - MonadEval(..), lookupVar, tryLookupVar, withVar, - VarName(..), textVarName, unpackVarName, - FqVarName(..), textFqVarName, unpackFqVarName, unqualifyName, - TypedVarName(..), withTypedVar, - ExprType(..), SomeExpr(..), - TypeVar(..), SomeExprType(..), someExprType, textSomeExprType, - FunctionType, DynamicType, - - VarValue(..), SomeVarValue(..), GlobalDefs, - svvVariables, svvArguments, - someConstValue, fromConstValue, - fromSomeVarValue, textSomeVarValue, someVarValueType, - - Expr(..), varExpr, mapExpr, eval, evalSome, evalSomeWith, - Traced(..), EvalTrace, VarNameSelectors, gatherVars, - AppAnnotation(..), - - ArgumentKeyword(..), FunctionArguments(..), - anull, exprArgs, - SomeArgumentType(..), ArgumentType(..), - - Regex(RegexPart, RegexString), regexMatch, ) where -import Control.Monad -import Control.Monad.Reader - -import Data.Char -import Data.Foldable -import Data.List -import Data.Map (Map) -import Data.Map qualified as M import Data.Scientific -import Data.String import Data.Text (Text) -import Data.Text qualified as T -import Data.Typeable - -import Text.Regex.TDFA qualified as RE -import Text.Regex.TDFA.Text qualified as RE -import {-# SOURCE #-} Network -import {-# SOURCE #-} Process -import Script.Expr.Class -import Util - -data Module = Module - { moduleName :: ModuleName - , moduleTests :: [ Test ] - , moduleDefinitions :: [ ( VarName, SomeExpr ) ] - , moduleExports :: [ VarName ] - } - -newtype ModuleName = ModuleName [ Text ] - deriving (Eq, Ord, Show) - -textModuleName :: ModuleName -> Text -textModuleName (ModuleName parts) = T.intercalate "." parts - -moduleExportedDefinitions :: Module -> [ ( VarName, ( FqVarName, SomeExpr )) ] -moduleExportedDefinitions Module {..} = - map (\( var, expr ) -> ( var, ( GlobalVarName moduleName var, expr ))) $ - filter ((`elem` moduleExports) . fst) moduleDefinitions +import Network +import Process +import Script.Expr data Test = Test { testName :: Text @@ -91,440 +33,6 @@ data TestStep | PacketLoss Scientific Node TestBlock | Wait -data SourceLine - = SourceLine Text - | SourceLineBuiltin - -textSourceLine :: SourceLine -> Text -textSourceLine (SourceLine text) = text -textSourceLine SourceLineBuiltin = "" - - -class MonadFail m => MonadEval m where - askGlobalDefs :: m GlobalDefs - askDictionary :: m VariableDictionary - withDictionary :: (VariableDictionary -> VariableDictionary) -> m a -> m a - -type VariableDictionary = [ ( VarName, SomeVarValue ) ] - -lookupVar :: MonadEval m => FqVarName -> m SomeVarValue -lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackFqVarName name ++ "'") return =<< tryLookupVar name - -tryLookupVar :: MonadEval m => FqVarName -> m (Maybe SomeVarValue) -tryLookupVar (LocalVarName name) = lookup name <$> askDictionary -tryLookupVar (GlobalVarName mname var) = M.lookup ( mname, var ) <$> askGlobalDefs - -withVar :: (MonadEval m, ExprType e) => VarName -> e -> m a -> m a -withVar name value = withDictionary (( name, someConstValue value ) : ) - - -newtype VarName = VarName Text - deriving (Eq, Ord) - -textVarName :: VarName -> Text -textVarName (VarName name) = name - -unpackVarName :: VarName -> String -unpackVarName = T.unpack . textVarName - -data FqVarName - = GlobalVarName ModuleName VarName - | LocalVarName VarName - deriving (Eq, Ord) - -textFqVarName :: FqVarName -> Text -textFqVarName (GlobalVarName mname vname) = textModuleName mname <> "." <> textVarName vname -textFqVarName (LocalVarName vname) = textVarName vname - -unpackFqVarName :: FqVarName -> String -unpackFqVarName = T.unpack . textFqVarName - -unqualifyName :: FqVarName -> VarName -unqualifyName (GlobalVarName _ name) = name -unqualifyName (LocalVarName name) = name - -newtype TypedVarName a = TypedVarName { fromTypedVarName :: VarName } - deriving (Eq, Ord) - -withTypedVar :: (MonadEval m, ExprType e) => TypedVarName e -> e -> m a -> m a -withTypedVar (TypedVarName name) = withVar name - -isInternalVar :: FqVarName -> Bool -isInternalVar (GlobalVarName {}) = False -isInternalVar (LocalVarName (VarName name)) - | Just ( '$', _ ) <- T.uncons name = True - | otherwise = False - - -instance ExprType Regex where - textExprType _ = T.pack "regex" - textExprValue _ = T.pack "" - instance ExprType TestBlock where textExprType _ = "test block" textExprValue _ = "" - - -data FunctionType a = FunctionType (FunctionArguments SomeVarValue -> a) - -instance ExprType a => ExprType (FunctionType a) where - textExprType _ = "function type" - textExprValue _ = "" - -data DynamicType - -instance ExprType DynamicType where - textExprType _ = "ambiguous type" - textExprValue _ = "" - -data SomeExpr = forall a. ExprType a => SomeExpr (Expr a) - -newtype TypeVar = TypeVar Text - deriving (Eq, Ord) - -data SomeExprType - = forall a. ExprType a => ExprTypePrim (Proxy a) - | ExprTypeVar TypeVar - | forall a. ExprType a => ExprTypeFunction (FunctionArguments SomeArgumentType) (Proxy a) - -someExprType :: SomeExpr -> SomeExprType -someExprType (SomeExpr expr) = go expr - where - go :: forall e. ExprType e => Expr e -> SomeExprType - go = \case - DynVariable tvar _ _ -> ExprTypeVar tvar - (e :: Expr a) - | IsFunType <- asFunType e -> ExprTypeFunction (gof e) (proxyOfFunctionType e) - | otherwise -> ExprTypePrim (Proxy @a) - - gof :: forall e. ExprType e => Expr (FunctionType e) -> FunctionArguments SomeArgumentType - gof = \case - Let _ _ _ body -> gof body - Variable {} -> error "someExprType: gof: variable" - FunVariable params _ _ -> params - ArgsReq args body -> fmap snd args <> gof body - ArgsApp (FunctionArguments used) body -> - let FunctionArguments args = gof body - in FunctionArguments $ args `M.difference` used - FunctionAbstraction {} -> mempty - FunctionEval {} -> error "someExprType: gof: function eval" - Pure {} -> error "someExprType: gof: pure" - App {} -> error "someExprType: gof: app" - Undefined {} -> error "someExprType: gof: undefined" - - proxyOfFunctionType :: Expr (FunctionType a) -> Proxy a - proxyOfFunctionType _ = Proxy - -textSomeExprType :: SomeExprType -> Text -textSomeExprType (ExprTypePrim p) = textExprType p -textSomeExprType (ExprTypeVar (TypeVar name)) = name -textSomeExprType (ExprTypeFunction _ r) = "function:" <> textExprType r - -data AsFunType a - = forall b. (a ~ FunctionType b, ExprType b) => IsFunType - | NotFunType - -asFunType :: Expr a -> AsFunType a -asFunType = \case - Let _ _ _ expr -> asFunType expr - FunVariable {} -> IsFunType - ArgsReq {} -> IsFunType - ArgsApp {} -> IsFunType - FunctionAbstraction {} -> IsFunType - _ -> NotFunType - - -data SomeVarValue = forall a. ExprType a => SomeVarValue (VarValue a) - -svvVariables :: SomeVarValue -> EvalTrace -svvVariables (SomeVarValue vv) = vvVariables vv - -svvArguments :: SomeVarValue -> FunctionArguments SomeArgumentType -svvArguments (SomeVarValue vv) = vvArguments vv - -data VarValue a = VarValue - { vvVariables :: EvalTrace - , vvArguments :: FunctionArguments SomeArgumentType - , vvFunction :: SourceLine -> FunctionArguments SomeVarValue -> a - } - -type GlobalDefs = Map ( ModuleName, VarName ) SomeVarValue - -someConstValue :: ExprType a => a -> SomeVarValue -someConstValue = SomeVarValue . VarValue [] mempty . const . const - -fromConstValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> FqVarName -> VarValue a -> m a -fromConstValue sline name (VarValue _ args value :: VarValue b) = do - maybe (fail err) return $ do - guard $ anull args - cast $ value sline mempty - where - err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has type ", - if anull args then textExprType @b Proxy else "function type" ] - -fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> FqVarName -> SomeVarValue -> m a -fromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do - maybe (fail err) return $ do - guard $ anull args - cast $ value sline mempty - where - err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has type ", - if anull args then textExprType @b Proxy else "function type" ] - -textSomeVarValue :: SourceLine -> SomeVarValue -> Text -textSomeVarValue sline (SomeVarValue (VarValue _ args value)) - | anull args = textExprValue $ value sline mempty - | otherwise = "" - -someVarValueType :: SomeVarValue -> SomeExprType -someVarValueType (SomeVarValue (VarValue _ args _ :: VarValue a)) - | anull args = ExprTypePrim (Proxy @a) - | otherwise = ExprTypeFunction args (Proxy @a) - - - -data Expr a where - Let :: forall a b. ExprType b => SourceLine -> TypedVarName b -> Expr b -> Expr a -> Expr a - Variable :: ExprType a => SourceLine -> FqVarName -> Expr a - DynVariable :: TypeVar -> SourceLine -> FqVarName -> Expr DynamicType - FunVariable :: ExprType a => FunctionArguments SomeArgumentType -> SourceLine -> FqVarName -> Expr (FunctionType a) - ArgsReq :: ExprType a => FunctionArguments ( VarName, SomeArgumentType ) -> Expr (FunctionType a) -> Expr (FunctionType a) - ArgsApp :: ExprType a => FunctionArguments SomeExpr -> Expr (FunctionType a) -> Expr (FunctionType a) - FunctionAbstraction :: ExprType a => Expr a -> Expr (FunctionType a) - FunctionEval :: ExprType a => Expr (FunctionType a) -> Expr a - LambdaAbstraction :: ExprType a => TypedVarName a -> Expr b -> Expr (a -> b) - Pure :: a -> Expr a - App :: AppAnnotation b -> Expr (a -> b) -> Expr a -> Expr b - Concat :: [Expr Text] -> Expr Text - Regex :: [Expr Regex] -> Expr Regex - Undefined :: String -> Expr a - Trace :: Expr a -> Expr (Traced a) - -data AppAnnotation b = AnnNone - | ExprType b => AnnRecord Text - -instance Functor Expr where - fmap f x = Pure f <*> x - -instance Applicative Expr where - pure = Pure - (<*>) = App AnnNone - -instance Semigroup a => Semigroup (Expr a) where - e <> f = (<>) <$> e <*> f - -instance Monoid a => Monoid (Expr a) where - mempty = Pure mempty - -varExpr :: ExprType a => SourceLine -> TypedVarName a -> Expr a -varExpr sline (TypedVarName name) = Variable sline (LocalVarName name) - -mapExpr :: forall a. (forall b. Expr b -> Expr b) -> Expr a -> Expr a -mapExpr f = go - where - go :: forall c. Expr c -> Expr c - go = \case - Let sline vname vval expr -> f $ Let sline vname (go vval) (go expr) - e@Variable {} -> f e - e@DynVariable {} -> f e - e@FunVariable {} -> f e - ArgsReq args expr -> f $ ArgsReq args (go expr) - ArgsApp args expr -> f $ ArgsApp (fmap (\(SomeExpr e) -> SomeExpr (go e)) args) (go expr) - FunctionAbstraction expr -> f $ FunctionAbstraction (go expr) - FunctionEval expr -> f $ FunctionEval (go expr) - LambdaAbstraction tvar expr -> f $ LambdaAbstraction tvar (go expr) - e@Pure {} -> f e - App ann efun earg -> f $ App ann (go efun) (go earg) - e@Concat {} -> f e - e@Regex {} -> f e - e@Undefined {} -> f e - Trace expr -> f $ Trace (go expr) - - -newtype SimpleEval a = SimpleEval (Reader ( GlobalDefs, VariableDictionary ) a) - deriving (Functor, Applicative, Monad) - -runSimpleEval :: SimpleEval a -> GlobalDefs -> VariableDictionary -> a -runSimpleEval (SimpleEval x) = curry $ runReader x - -instance MonadFail SimpleEval where - fail = error . ("eval failed: " <>) - -instance MonadEval SimpleEval where - askGlobalDefs = SimpleEval (asks fst) - askDictionary = SimpleEval (asks snd) - withDictionary f (SimpleEval inner) = SimpleEval (local (fmap f) inner) - - -eval :: forall m a. MonadEval m => Expr a -> m a -eval = \case - Let _ (TypedVarName name) valExpr expr -> do - val <- eval valExpr - withVar name val $ eval expr - Variable sline name -> fromSomeVarValue sline name =<< lookupVar name - DynVariable _ _ name -> fail $ "ambiguous type of ‘" <> unpackFqVarName name <> "’" - FunVariable _ sline name -> funFromSomeVarValue sline name =<< lookupVar name - ArgsReq (FunctionArguments req) efun -> do - gdefs <- askGlobalDefs - dict <- askDictionary - return $ FunctionType $ \(FunctionArguments args) -> - let used = M.intersectionWith (\value ( vname, _ ) -> ( vname, value )) args req - FunctionType fun = runSimpleEval (eval efun) gdefs (toList used ++ dict) - in fun $ FunctionArguments $ args `M.difference` req - ArgsApp eargs efun -> do - FunctionType fun <- eval efun - args <- mapM evalSome eargs - return $ FunctionType $ \args' -> fun (args <> args') - FunctionAbstraction expr -> do - val <- eval expr - return $ FunctionType $ const val - FunctionEval efun -> do - FunctionType fun <- eval efun - return $ fun mempty - LambdaAbstraction (TypedVarName name) expr -> do - gdefs <- askGlobalDefs - dict <- askDictionary - return $ \x -> runSimpleEval (eval expr) gdefs (( name, someConstValue x ) : dict) - Pure value -> return value - App _ f x -> eval f <*> eval x - Concat xs -> T.concat <$> mapM eval xs - Regex xs -> mapM eval xs >>= \case - [ re@RegexCompiled {} ] -> return re - parts -> case regexCompile $ T.concat $ map regexSource parts of - Left err -> fail err - Right re -> return re - Undefined err -> fail err - Trace expr -> Traced <$> gatherVars expr <*> eval expr - -evalToVarValue :: MonadEval m => Expr a -> m (VarValue a) -evalToVarValue expr = do - VarValue - <$> gatherVars expr - <*> pure mempty - <*> (const . const <$> eval expr) - -evalFunToVarValue :: MonadEval m => Expr (FunctionType a) -> m (VarValue a) -evalFunToVarValue expr = do - FunctionType fun <- eval expr - VarValue - <$> gatherVars expr - <*> pure (exprArgs expr) - <*> pure (const fun) - -evalSome :: MonadEval m => SomeExpr -> m SomeVarValue -evalSome (SomeExpr expr) - | IsFunType <- asFunType expr = SomeVarValue <$> evalFunToVarValue expr - | otherwise = SomeVarValue <$> evalToVarValue expr - -evalSomeWith :: GlobalDefs -> SomeExpr -> SomeVarValue -evalSomeWith gdefs sexpr = runSimpleEval (evalSome sexpr) gdefs [] - - -data Traced a = Traced EvalTrace a - -type VarNameSelectors = ( FqVarName, [ Text ] ) -type EvalTrace = [ ( VarNameSelectors, SomeVarValue ) ] - -gatherVars :: forall a m. MonadEval m => Expr a -> m EvalTrace -gatherVars = fmap (uniqOn fst . sortOn fst) . helper - where - helper :: forall b. Expr b -> m EvalTrace - helper = \case - Let _ (TypedVarName var) _ expr -> withDictionary (filter ((var /=) . fst)) $ helper expr - Variable _ var - | isInternalVar var -> return [] - | otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var - DynVariable _ _ var -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var - FunVariable _ _ var -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var - ArgsReq args expr -> withDictionary (filter ((`notElem` map fst (toList args)) . fst)) $ helper expr - ArgsApp (FunctionArguments args) fun -> do - v <- helper fun - vs <- mapM (\(SomeExpr e) -> helper e) $ M.elems args - return $ concat (v : vs) - FunctionAbstraction expr -> helper expr - FunctionEval efun -> helper efun - LambdaAbstraction (TypedVarName var) expr -> withDictionary (filter ((var /=) . fst)) $ helper expr - Pure _ -> return [] - e@(App (AnnRecord sel) _ x) - | Just (var, sels) <- gatherSelectors x - -> do - val <- SomeVarValue . VarValue [] mempty . const . const <$> eval e - return [ (( var, sels ++ [ sel ] ), val ) ] - | otherwise -> do - helper x - App _ f x -> (++) <$> helper f <*> helper x - Concat es -> concat <$> mapM helper es - Regex es -> concat <$> mapM helper es - Undefined {} -> return [] - Trace expr -> helper expr - - gatherSelectors :: forall b. Expr b -> Maybe ( FqVarName, [ Text ] ) - gatherSelectors = \case - Variable _ var -> Just (var, []) - App (AnnRecord sel) _ x -> do - (var, sels) <- gatherSelectors x - return (var, sels ++ [sel]) - _ -> Nothing - - -newtype ArgumentKeyword = ArgumentKeyword Text - deriving (Show, Eq, Ord, IsString) - -newtype FunctionArguments a = FunctionArguments (Map (Maybe ArgumentKeyword) a) - deriving (Show, Semigroup, Monoid, Functor, Foldable, Traversable) - -anull :: FunctionArguments a -> Bool -anull (FunctionArguments args) = M.null args - -exprArgs :: Expr (FunctionType a) -> FunctionArguments SomeArgumentType -exprArgs = \case - Let _ _ _ expr -> exprArgs expr - Variable {} -> mempty - FunVariable args _ _ -> args - ArgsReq args expr -> fmap snd args <> exprArgs expr - ArgsApp (FunctionArguments applied) expr -> - let FunctionArguments args = exprArgs expr - in FunctionArguments (args `M.difference` applied) - FunctionAbstraction {} -> mempty - FunctionEval {} -> mempty - Pure {} -> error "exprArgs: pure" - App {} -> error "exprArgs: app" - Undefined {} -> error "exprArgs: undefined" - -funFromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> FqVarName -> SomeVarValue -> m (FunctionType a) -funFromSomeVarValue sline name (SomeVarValue (VarValue _ args value :: VarValue b)) = do - maybe (fail err) return $ do - FunctionType <$> cast (value sline) - where - err = T.unpack $ T.concat [ T.pack "expected function returning ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has ", - (if anull args then "type " else "function type returting ") <> textExprType @b Proxy ] - -data SomeArgumentType = forall a. ExprType a => SomeArgumentType (ArgumentType a) - -data ArgumentType a - = RequiredArgument - | OptionalArgument - | ExprDefault (Expr a) - | ContextDefault - - -data Regex = RegexCompiled Text RE.Regex - | RegexPart Text - | RegexString Text - -regexCompile :: Text -> Either String Regex -regexCompile src = either Left (Right . RegexCompiled src) $ RE.compile RE.defaultCompOpt RE.defaultExecOpt $ - T.singleton '^' <> src <> T.singleton '$' - -regexMatch :: Regex -> Text -> Either String (Maybe (Text, Text, Text, [Text])) -regexMatch (RegexCompiled _ re) text = RE.regexec re text -regexMatch _ _ = Left "regex not compiled" - -regexSource :: Regex -> Text -regexSource (RegexCompiled src _) = src -regexSource (RegexPart src) = src -regexSource (RegexString str) = T.concatMap escapeChar str - where - escapeChar c | isAlphaNum c = T.singleton c - | c `elem` ['`', '\'', '<', '>'] = T.singleton c - | otherwise = T.pack ['\\', c] diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs index bf22ff8..723b480 100644 --- a/src/Test/Builtins.hs +++ b/src/Test/Builtins.hs @@ -7,6 +7,7 @@ import Data.Maybe import Data.Text (Text) import Process (Process) +import Script.Expr import Test builtins :: GlobalDefs -- cgit v1.2.3