summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Parser/Core.hs19
-rw-r--r--src/Parser/Expr.hs95
-rw-r--r--src/Run.hs4
-rw-r--r--src/Test.hs93
-rw-r--r--src/Test/Builtins.hs6
5 files changed, 184 insertions, 33 deletions
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index 2a2fc89..dd2df12 100644
--- a/src/Parser/Core.hs
+++ b/src/Parser/Core.hs
@@ -60,6 +60,7 @@ lookupVarExpr off name = do
lookupVarType off name >>= \case
ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable name :: Expr a)
ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar name
+ ExprTypeFunction args (_ :: Proxy a) -> return $ SomeExpr $ (FunVariable args name :: Expr (FunctionType a))
unify :: Int -> SomeExprType -> SomeExprType -> TestParser SomeExprType
unify _ (ExprTypeVar aname) (ExprTypeVar bname) | aname == bname = do
@@ -122,24 +123,32 @@ unify off a b = do
unifyExpr :: forall a b proxy. (ExprType a, ExprType b) => Int -> proxy a -> Expr b -> TestParser (Expr a)
-unifyExpr off pa x = if
+unifyExpr off pa expr = if
| Just (Refl :: a :~: b) <- eqT
- -> return x
+ -> return expr
- | DynVariable tvar name <- x
+ | DynVariable tvar name <- expr
-> do
_ <- unify off (ExprTypePrim (Proxy :: Proxy a)) (ExprTypeVar tvar)
return $ Variable name
+ | Just (Refl :: FunctionType a :~: b) <- eqT
+ -> do
+ case exprArgs expr of
+ remaining
+ | anull remaining -> return (FunctionEval expr)
+ | otherwise -> parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
+ "missing function arguments"
+
| Just (Refl :: DynamicType :~: b) <- eqT
- , Undefined msg <- x
+ , Undefined msg <- expr
-> do
return $ Undefined msg
| otherwise
-> do
parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
- "couldn't match expected type `" <> textExprType pa <> "' with actual type `" <> textExprType x <> "'"
+ "couldn't match expected type `" <> textExprType pa <> "' with actual type `" <> textExprType expr <> "'"
skipLineComment :: TestParser ()
diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs
index f9b1e32..04035c1 100644
--- a/src/Parser/Expr.hs
+++ b/src/Parser/Expr.hs
@@ -7,6 +7,8 @@ module Parser.Expr (
someExpr,
typedExpr,
+
+ functionArguments,
) where
import Control.Applicative (liftA2)
@@ -15,12 +17,13 @@ import Control.Monad
import Control.Monad.State
import Data.Char
+import Data.Map qualified as M
import Data.Maybe
import Data.Scientific
-import qualified Data.Set as S
+import Data.Set qualified as S
import Data.Text (Text)
import Data.Text qualified as T
-import qualified Data.Text.Lazy as TL
+import Data.Text.Lazy qualified as TL
import Data.Typeable
import Data.Void
@@ -211,7 +214,11 @@ someExpr = join inner <?> "expression"
parens = between (symbol "(") (symbol ")")
- term = parens inner <|> literal <|> variable <?> "term"
+ term = label "term" $ choice
+ [ parens inner
+ , return <$> literal
+ , return <$> variable
+ ]
table = [ [ recordSelector
]
@@ -330,21 +337,81 @@ someExpr = join inner <?> "expression"
applyRecordSelector :: ExprType a => Text -> Expr a -> RecordSelector a -> SomeExpr
applyRecordSelector m e (RecordSelector f) = SomeExpr $ App (AnnRecord m) (pure f) e
- literal = label "literal" $ choice
- [ return <$> numberLiteral
- , return . SomeExpr <$> quotedString
- , return . SomeExpr <$> regex
- , return <$> list
- ]
+literal :: TestParser SomeExpr
+literal = label "literal" $ choice
+ [ numberLiteral
+ , SomeExpr <$> quotedString
+ , SomeExpr <$> regex
+ , list
+ ]
- variable = label "variable" $ do
- off <- stateOffset <$> getParserState
- name <- varName
- e <- lookupVarExpr off name
- return $ return e
+variable :: TestParser SomeExpr
+variable = label "variable" $ do
+ off <- stateOffset <$> getParserState
+ name <- varName
+ lookupVarExpr off name >>= \case
+ SomeExpr e'@(FunVariable (FunctionArguments argTypes) _) -> do
+ let check poff kw expr = do
+ case M.lookup kw argTypes of
+ Just expected -> do
+ withRecovery registerParseError $ do
+ void $ unify poff expected (someExprType expr)
+ return expr
+ Nothing -> do
+ registerParseError $ FancyError poff $ S.singleton $ ErrorFail $ T.unpack $
+ case kw of
+ Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword `" <> tkw <> "'"
+ Nothing -> "unexpected parameter"
+ return expr
+
+ args <- functionArguments check someExpr literal (\poff -> lookupVarExpr poff . VarName)
+ return $ SomeExpr $ ArgsApp args e'
+ e -> do
+ return e
typedExpr :: forall a. ExprType a => TestParser (Expr a)
typedExpr = do
off <- stateOffset <$> getParserState
SomeExpr e <- someExpr
unifyExpr off Proxy e
+
+
+functionArguments :: (Int -> Maybe ArgumentKeyword -> a -> TestParser b) -> TestParser a -> TestParser a -> (Int -> Text -> TestParser a) -> TestParser (FunctionArguments b)
+functionArguments check param lit promote = do
+ args <- parseArgs True
+ return $ FunctionArguments args
+ where
+ parseArgs allowUnnamed = choice
+ [do off <- stateOffset <$> getParserState
+ x <- pparam
+ if allowUnnamed
+ then do
+ checkAndInsert off Nothing x $ parseArgs False
+ else do
+ registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat
+ [ T.pack "multiple unnamed parameters" ]
+ parseArgs False
+
+ ,do off <- stateOffset <$> getParserState
+ x <- identifier
+ choice
+ [do off' <- stateOffset <$> getParserState
+ y <- pparam <|> (promote off' =<< identifier)
+ checkAndInsert off' (Just (ArgumentKeyword x)) y $ parseArgs allowUnnamed
+
+ ,if allowUnnamed
+ then do
+ y <- promote off x
+ checkAndInsert off Nothing y $ return M.empty
+ else do
+ registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat
+ [ T.pack "multiple unnamed parameters" ]
+ return M.empty
+ ]
+
+ ,do return M.empty
+ ]
+
+ pparam = between (symbol "(") (symbol ")") param <|> lit
+
+ checkAndInsert off kw x cont = M.insert kw <$> check off kw x <*> cont
diff --git a/src/Run.hs b/src/Run.hs
index 2bee6ec..24bba48 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -188,7 +188,7 @@ evalSteps = mapM_ $ \case
withVar :: ExprType e => VarName -> e -> TestRun a -> TestRun a
-withVar name value = local (fmap $ \s -> s { tsVars = (name, SomeVarValue value) : tsVars s })
+withVar name value = local (fmap $ \s -> s { tsVars = ( name, SomeVarValue mempty $ const value ) : tsVars s })
withInternet :: (Network -> TestRun a) -> TestRun a
withInternet inner = do
@@ -310,7 +310,7 @@ expect (SourceLine sline) p expr tvars inner = do
throwError Failed
outProc OutputMatch p line
- local (fmap $ \s -> s { tsVars = zip vars (map SomeVarValue capture) ++ tsVars s }) inner
+ local (fmap $ \s -> s { tsVars = zip vars (map (SomeVarValue mempty . const) capture) ++ tsVars s }) inner
Nothing -> exprFailed (T.pack "expect") (SourceLine sline) (Just $ procName p) expr
diff --git a/src/Test.hs b/src/Test.hs
index bb65b81..8c5a3ef 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -9,22 +9,29 @@ module Test (
VarName(..), TypedVarName(..), textVarName, unpackVarName,
ExprType(..), SomeExpr(..),
TypeVar(..), SomeExprType(..), someExprType, textSomeExprType,
- DynamicType,
+ FunctionType, DynamicType,
SomeVarValue(..), fromSomeVarValue, textSomeVarValue, someVarValueType,
RecordSelector(..),
ExprListUnpacker(..),
ExprEnumerator(..),
- Expr(..), eval, gatherVars,
+ Expr(..), eval, gatherVars, evalSome,
AppAnnotation(..),
+ ArgumentKeyword(..), FunctionArguments(..),
+ anull, exprArgs,
+
Regex(RegexPart, RegexString), regexMatch,
) where
+import Control.Monad
+
import Data.Char
import Data.List
+import Data.Map (Map)
+import Data.Map qualified as M
import Data.Scientific
import Data.Text (Text)
-import qualified Data.Text as T
+import Data.Text qualified as T
import Data.Typeable
import Text.Regex.TDFA qualified as RE
@@ -130,6 +137,12 @@ instance ExprType TestBlock where
textExprValue _ = "<test block>"
+data FunctionType a = FunctionType (FunctionArguments SomeExpr -> a)
+
+instance ExprType a => ExprType (FunctionType a) where
+ textExprType _ = "function type"
+ textExprValue _ = "<function type>"
+
data DynamicType
instance ExprType DynamicType where
@@ -144,26 +157,42 @@ newtype TypeVar = TypeVar Text
data SomeExprType
= forall a. ExprType a => ExprTypePrim (Proxy a)
| ExprTypeVar TypeVar
+ | forall a. ExprType a => ExprTypeFunction (FunctionArguments SomeExprType) (Proxy a)
someExprType :: SomeExpr -> SomeExprType
+someExprType (SomeExpr (DynVariable tvar _)) = ExprTypeVar tvar
+someExprType (SomeExpr fun@(FunVariable params _)) = ExprTypeFunction params (proxyOfFunctionType fun)
+ where
+ proxyOfFunctionType :: Expr (FunctionType a) -> Proxy a
+ proxyOfFunctionType _ = Proxy
someExprType (SomeExpr (_ :: Expr a)) = ExprTypePrim (Proxy @a)
textSomeExprType :: SomeExprType -> Text
textSomeExprType (ExprTypePrim p) = textExprType p
textSomeExprType (ExprTypeVar (TypeVar name)) = name
+textSomeExprType (ExprTypeFunction _ r) = "function:" <> textExprType r
-data SomeVarValue = forall a. ExprType a => SomeVarValue a
+data SomeVarValue = forall a. ExprType a => SomeVarValue (FunctionArguments SomeExprType) (FunctionArguments SomeExpr -> a)
fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => VarName -> SomeVarValue -> m a
-fromSomeVarValue name (SomeVarValue value) = maybe (fail err) return $ cast value
- where err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textVarName name, T.pack "' has type ", textExprType (Just value) ]
+fromSomeVarValue name (SomeVarValue args (value :: args -> b)) = do
+ maybe (fail err) return $ do
+ guard $ anull args
+ cast $ value mempty
+ where
+ err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textVarName name, T.pack "' has type ",
+ if anull args then textExprType @b Proxy else "function type" ]
textSomeVarValue :: SomeVarValue -> Text
-textSomeVarValue (SomeVarValue value) = textExprValue value
+textSomeVarValue (SomeVarValue args value)
+ | anull args = textExprValue $ value mempty
+ | otherwise = "<function>"
someVarValueType :: SomeVarValue -> SomeExprType
-someVarValueType (SomeVarValue (_ :: a)) = ExprTypePrim (Proxy @a)
+someVarValueType (SomeVarValue args (_ :: args -> a))
+ | anull args = ExprTypePrim (Proxy @a)
+ | otherwise = ExprTypeFunction args (Proxy @a)
data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b)
@@ -176,6 +205,9 @@ data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a])
data Expr a where
Variable :: ExprType a => VarName -> Expr a
DynVariable :: TypeVar -> VarName -> Expr DynamicType
+ FunVariable :: ExprType a => FunctionArguments SomeExprType -> VarName -> Expr (FunctionType a)
+ ArgsApp :: FunctionArguments SomeExpr -> Expr (FunctionType a) -> Expr (FunctionType a)
+ FunctionEval :: Expr (FunctionType a) -> Expr a
Pure :: a -> Expr a
App :: AppAnnotation b -> Expr (a -> b) -> Expr a -> Expr b
Concat :: [Expr Text] -> Expr Text
@@ -196,6 +228,13 @@ instance Applicative Expr where
eval :: MonadEval m => Expr a -> m a
eval (Variable name) = fromSomeVarValue name =<< lookupVar name
eval (DynVariable _ _) = fail "ambiguous type"
+eval (FunVariable _ name) = funFromSomeVarValue name =<< lookupVar name
+eval (ArgsApp args efun) = do
+ FunctionType fun <- eval efun
+ return $ FunctionType $ \args' -> fun (args <> args')
+eval (FunctionEval efun) = do
+ FunctionType fun <- eval efun
+ return $ fun mempty
eval (Pure value) = return value
eval (App _ f x) = eval f <*> eval x
eval (Concat xs) = T.concat <$> mapM eval xs
@@ -207,16 +246,25 @@ eval (Regex xs) = mapM eval xs >>= \case
eval (RootNetwork) = rootNetwork
eval (Undefined err) = fail err
+evalSome :: MonadEval m => SomeExpr -> m SomeVarValue
+evalSome (SomeExpr expr) = SomeVarValue mempty . const <$> eval expr
+
gatherVars :: forall a m. MonadEval m => Expr a -> m [((VarName, [Text]), SomeVarValue)]
gatherVars = fmap (uniqOn fst . sortOn fst) . helper
where
helper :: forall b. Expr b -> m [((VarName, [Text]), SomeVarValue)]
helper (Variable var) = (:[]) . ((var, []),) <$> lookupVar var
helper (DynVariable _ var) = (:[]) . ((var, []),) <$> lookupVar var
+ helper (FunVariable _ var) = (:[]) . ((var, []),) <$> lookupVar var
+ helper (ArgsApp (FunctionArguments args) fun) = do
+ v <- helper fun
+ vs <- mapM (\(SomeExpr e) -> helper e) $ M.elems args
+ return $ concat (v : vs)
+ helper (FunctionEval efun) = helper efun
helper (Pure _) = return []
helper e@(App (AnnRecord sel) _ x)
| Just (var, sels) <- gatherSelectors x
- = do val <- SomeVarValue <$> eval e
+ = do val <- SomeVarValue mempty . const <$> eval e
return [((var, sels ++ [sel]), val)]
| otherwise = helper x
helper (App _ f x) = (++) <$> helper f <*> helper x
@@ -233,6 +281,33 @@ gatherVars = fmap (uniqOn fst . sortOn fst) . helper
return (var, sels ++ [sel])
_ -> Nothing
+
+data ArgumentKeyword = ArgumentKeyword Text
+ deriving (Show, Eq, Ord)
+
+newtype FunctionArguments a = FunctionArguments (Map (Maybe ArgumentKeyword) a)
+ deriving (Show, Semigroup, Monoid)
+
+anull :: FunctionArguments a -> Bool
+anull (FunctionArguments args) = M.null args
+
+exprArgs :: Expr (FunctionType a) -> FunctionArguments SomeExprType
+exprArgs (FunVariable args _) = args
+exprArgs (ArgsApp (FunctionArguments applied) expr) =
+ let FunctionArguments args = exprArgs expr
+ in FunctionArguments (args `M.difference` applied)
+exprArgs _ = error "exprArgs on unexpected type"
+
+funFromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => VarName -> SomeVarValue -> m (FunctionType a)
+funFromSomeVarValue name (SomeVarValue args (value :: args -> b)) = do
+ maybe (fail err) return $ do
+ guard $ not $ anull args
+ FunctionType <$> cast value
+ where
+ err = T.unpack $ T.concat [ T.pack "expected function returning ", textExprType @a Proxy, T.pack ", but variable '", textVarName name, T.pack "' has ",
+ (if anull args then "type" else "function type returting ") <> textExprType @b Proxy ]
+
+
data Regex = RegexCompiled Text RE.Regex
| RegexPart Text
| RegexString Text
diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs
index 9deb2df..2ab38aa 100644
--- a/src/Test/Builtins.hs
+++ b/src/Test/Builtins.hs
@@ -6,8 +6,8 @@ import Test
builtins :: [ ( VarName, SomeVarValue ) ]
builtins =
- [ ( VarName "wait", SomeVarValue builtinWait )
+ [ ( VarName "wait", builtinWait )
]
-builtinWait :: TestBlock
-builtinWait = TestBlock [ Wait ]
+builtinWait :: SomeVarValue
+builtinWait = SomeVarValue mempty $ const $ TestBlock [ Wait ]
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-14 16:41:50 +0000