diff options
Diffstat (limited to 'src/Parser')
| -rw-r--r-- | src/Parser/Core.hs | 248 | ||||
| -rw-r--r-- | src/Parser/Expr.hs | 274 | ||||
| -rw-r--r-- | src/Parser/Shell.hs | 143 | ||||
| -rw-r--r-- | src/Parser/Statement.hs | 81 |
4 files changed, 589 insertions, 157 deletions
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs index 132dbc8..78fc666 100644 --- a/src/Parser/Core.hs +++ b/src/Parser/Core.hs @@ -1,13 +1,17 @@ module Parser.Core where import Control.Applicative +import Control.Arrow import Control.Monad import Control.Monad.State +import Control.Monad.Writer +import Data.List import Data.Map (Map) import Data.Map qualified as M import Data.Maybe import Data.Set qualified as S +import Data.Text (Text) import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Typeable @@ -18,8 +22,10 @@ import qualified Text.Megaparsec.Char.Lexer as L import Network () import Script.Expr +import Script.Expr.Class import Script.Module import Test +import Util newtype TestParser a = TestParser (StateT TestParserState (ParsecT CustomTestError TestStream IO) a) deriving @@ -38,6 +44,8 @@ type TestParseError = ParseError TestStream CustomTestError data CustomTestError = ModuleNotFound ModuleName | FileNotFound FilePath + | TestNotFound Text (Maybe FilePath) + | TestOrTagNotFound Text (Maybe FilePath) | ImportModuleError (ParseErrorBundle TestStream CustomTestError) deriving (Eq) @@ -50,15 +58,30 @@ instance Ord CustomTestError where compare (FileNotFound _) _ = LT compare _ (FileNotFound _) = GT + compare (TestNotFound a a') (TestNotFound b b') = compare ( a, a' ) ( b, b' ) + compare (TestNotFound _ _ ) _ = LT + compare _ (TestNotFound _ _ ) = GT + + compare (TestOrTagNotFound a a') (TestOrTagNotFound b b') = compare ( a, a' ) ( b, b' ) + compare (TestOrTagNotFound _ _ ) _ = LT + compare _ (TestOrTagNotFound _ _ ) = GT + -- Ord instance is required to store errors in Set, but there shouldn't be -- two ImportModuleErrors at the same possition, so "dummy" comparison -- should be ok. compare (ImportModuleError _) (ImportModuleError _) = EQ instance ShowErrorComponent CustomTestError where - showErrorComponent (ModuleNotFound name) = "module ‘" <> T.unpack (textModuleName name) <> "’ not found" - showErrorComponent (FileNotFound path) = "file ‘" <> path <> "’ not found" showErrorComponent (ImportModuleError bundle) = "error parsing imported module:\n" <> errorBundlePretty bundle + showErrorComponent err = showCustomTestError err + +showCustomTestError :: CustomTestError -> String +showCustomTestError = \case + ModuleNotFound name -> "module ‘" <> T.unpack (textModuleName name) <> "’ not found" + FileNotFound path -> "file ‘" <> path <> "’ not found" + TestNotFound tname mbpath -> "test ‘" <> T.unpack tname <> "’ not found" <> maybe "" (\path -> " in ‘" <> path <> "’") mbpath + TestOrTagNotFound tname mbpath -> "test or tag ‘" <> T.unpack tname <> "’ not found" <> maybe "" (\path -> " in ‘" <> path <> "’") mbpath + ImportModuleError bundle -> errorBundlePretty bundle runTestParser :: TestStream -> TestParserState -> TestParser a -> IO (Either (ParseErrorBundle TestStream CustomTestError) a) runTestParser content initState (TestParser parser) = flip (flip runParserT (testSourcePath initState)) content . flip evalStateT initState $ parser @@ -72,6 +95,7 @@ data Toplevel data TestParserState = TestParserState { testSourcePath :: FilePath , testVars :: [ ( VarName, ( FqVarName, SomeExprType )) ] + , testTypeVars :: [ ( VarName, SomeExprType ) ] , testContext :: SomeExpr , testNextTypeVar :: Int , testTypeUnif :: Map TypeVar SomeExprType @@ -104,17 +128,58 @@ lookupVarExpr off sline name = do ( fqn, etype ) <- lookupVarType off name case etype of ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline fqn :: Expr a) - ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar sline fqn - ExprTypeFunction args (_ :: Proxy a) -> return $ SomeExpr $ (FunVariable args sline fqn :: Expr (FunctionType a)) + ExprTypeConstr1 _ -> return $ SomeExpr $ (Undefined "incomplete type" :: Expr DynamicType) + ExprTypeFunction args (ExprTypePrim (_ :: Proxy a)) -> return $ SomeExpr $ (FunVariable args sline fqn :: Expr (FunctionType a)) + stype -> return $ SomeExpr $ DynVariable stype sline fqn lookupScalarVarExpr :: Int -> SourceLine -> VarName -> TestParser SomeExpr lookupScalarVarExpr off sline name = do ( fqn, etype ) <- lookupVarType off name case etype of ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline fqn :: Expr a) - ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar sline fqn - ExprTypeFunction args (pa :: Proxy a) -> do + ExprTypeConstr1 _ -> return $ SomeExpr $ (Undefined "incomplete type" :: Expr DynamicType) + ExprTypeFunction args (ExprTypePrim (pa :: Proxy a)) -> do SomeExpr <$> unifyExpr off pa (FunVariable args sline fqn :: Expr (FunctionType a)) + stype -> return $ SomeExpr $ DynVariable stype sline fqn + +lookupType :: Int -> VarName -> TestParser SomeExprType +lookupType off name = do + gets (lookup name . testTypeVars) >>= \case + Nothing -> do + registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ + "type not in scope: ‘" <> textVarName name <> "’" + return $ ExprTypeVar (TypeVar $ textVarName name) + Just x -> return x + + +resolveKnownTypeVars :: SomeExprType -> TestParser ( SomeExprType, [ TypeVar ] ) +resolveKnownTypeVars = fmap (fmap (uniq . sort)) . runWriterT . go + where + go stype = case stype of + ExprTypePrim {} -> return stype + ExprTypeConstr1 {} -> return stype + ExprTypeVar tvar -> do + gets (M.lookup tvar . testTypeUnif) >>= \case + Just stype' -> go stype' + Nothing -> tell [ tvar ] >> return stype + ExprTypeFunction args body -> ExprTypeFunction <$> go args <*> go body + ExprTypeArguments args -> ExprTypeArguments <$> mapM (\(SomeArgumentType a t) -> SomeArgumentType a <$> go t) args + ExprTypeApp ctor params -> do + ctor' <- go ctor + params' <- mapM go params + return $ case ( ctor', params' ) of + ( ExprTypeConstr1 (Proxy :: Proxy c'), [ ExprTypePrim (Proxy :: Proxy p') ] ) + -> ExprTypePrim (Proxy :: Proxy (c' p')) + _ -> ExprTypeApp ctor' params' + ExprTypeForall tvar inner -> ExprTypeForall tvar <$> go inner + +typeClosure :: SomeExprType -> TestParser SomeExprType +typeClosure stype = do + ( stype', freeVars ) <- resolveKnownTypeVars stype + return $ go freeVars stype' + where + go [] t = t + go (v : vs) t = ExprTypeForall v $ go vs t unify :: Int -> SomeExprType -> SomeExprType -> TestParser SomeExprType unify _ (ExprTypeVar aname) (ExprTypeVar bname) | aname == bname = do @@ -171,9 +236,53 @@ unify _ res@(ExprTypePrim (Proxy :: Proxy a)) (ExprTypePrim (Proxy :: Proxy b)) | Just (Refl :: a :~: b) <- eqT = return res +unify _ res@(ExprTypeConstr1 (Proxy :: Proxy a)) (ExprTypeConstr1 (Proxy :: Proxy b)) + | Just (Refl :: a :~: b) <- eqT + = return res + +unify off (ExprTypeFunction args res) (ExprTypeFunction args' res') + = ExprTypeFunction + <$> unify off args args' + <*> unify off res res' + +unify off (ExprTypeApp ac aparams) (ExprTypeApp bc bparams) + | length aparams == length bparams + = do + c <- unify off ac bc + params <- zipWithM (unify off) aparams bparams + return $ case ( c, params ) of + ( ExprTypeConstr1 (Proxy :: Proxy c'), [ ExprTypePrim (Proxy :: Proxy p') ] ) + -> ExprTypePrim (Proxy :: Proxy (c' p')) + _ -> ExprTypeApp c params + +unify off a@(ExprTypeApp {}) (ExprTypePrim bproxy) + | TypeDeconstructor1 c p <- matchTypeConstructor bproxy + = unify off a (ExprTypeApp (ExprTypeConstr1 c) [ ExprTypePrim p ]) + +unify off (ExprTypePrim aproxy) b@(ExprTypeApp {}) + | TypeDeconstructor1 c p <- matchTypeConstructor aproxy + = unify off (ExprTypeApp (ExprTypeConstr1 c) [ ExprTypePrim p ]) b + unify off a b = do parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ - "couldn't match expected type `" <> textSomeExprType a <> "' with actual type `" <> textSomeExprType b <> "'" + "couldn't match expected type ‘" <> textSomeExprType a <> "’ with actual type ‘" <> textSomeExprType b <> "’" + + +unifyArguments + :: FunctionArguments SomeArgumentType + -> FunctionArguments ( Int, SomeExpr ) + -> TestParser ( FunctionArguments SomeExpr, ( FunctionArguments SomeArgumentType, FunctionArguments ( Int, SomeExpr ) ) ) +unifyArguments (FunctionArguments am) (FunctionArguments bm) = (toArgs *** (toArgs *** toArgs)) <$> go (M.toAscList am) (M.toAscList bm) + where + toArgs = FunctionArguments . M.fromAscList + go [] bs = return ( [], ( [], bs ) ) + go as [] = return ( [], ( as, [] ) ) + go (a@( ak, SomeArgumentType _ at ) : as) (b@( bk, ( off, expr ) ) : bs) + | ak < bk = second (first (a :)) <$> go as (b : bs) + | bk < ak = second (second (b :)) <$> go (a : as) bs + | otherwise = do + expr' <- unifySomeExpr off at expr + first (( ak, expr' ) :) <$> go as bs unifyExpr :: forall a b proxy. (ExprType a, ExprType b) => Int -> proxy a -> Expr b -> TestParser (Expr a) @@ -181,27 +290,33 @@ unifyExpr off pa expr = if | Just (Refl :: a :~: b) <- eqT -> return expr - | DynVariable tvar sline name <- expr + | DynVariable stype sline name <- expr + , ExprTypeForall qvar itype <- stype -> do - _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) (ExprTypeVar tvar) + tvar <- newTypeVar + res <- unify off (ExprTypePrim (Proxy :: Proxy a)) $ renameVarInType qvar tvar itype + rtype <- M.lookup tvar <$> gets testTypeUnif + return $ ExposePrimType $ TypeApp res (fromMaybe (ExprTypeVar tvar) rtype) (Variable sline name) + + | DynVariable stype sline name <- expr + -> do + _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) stype return $ Variable sline name - | Just (Refl :: FunctionType a :~: b) <- eqT + | HidePrimType (_ :: Expr b') <- expr + -> unifyExpr off pa (ExposePrimType expr :: Expr b') + + | HideFunType args (_ :: Expr (FunctionType b')) <- expr + -> unifyExpr off pa (ExposeFunType args expr :: Expr (FunctionType b')) + + | TypeLambda tvar t f <- expr -> do - let FunctionArguments remaining = exprArgs expr - showType ( Nothing, SomeArgumentType atype ) = "`<" <> textExprType atype <> ">'" - showType ( Just (ArgumentKeyword kw), SomeArgumentType atype ) = "`" <> kw <> " <" <> textExprType atype <> ">'" - err = parseError . FancyError off . S.singleton . ErrorFail . T.unpack - - defaults <- fmap catMaybes $ forM (M.toAscList remaining) $ \case - arg@(_, SomeArgumentType RequiredArgument) -> err $ "missing " <> showType arg <> " argument" - (_, SomeArgumentType OptionalArgument) -> return Nothing - (kw, SomeArgumentType (ExprDefault def)) -> return $ Just ( kw, SomeExpr def ) - (kw, SomeArgumentType atype@ContextDefault) -> do - SomeExpr context <- gets testContext - context' <- unifyExpr off atype context - return $ Just ( kw, SomeExpr context' ) - return (FunctionEval $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr) + _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) t + Just (ExprTypePrim pt) <- M.lookup tvar <$> gets testTypeUnif + unifyExpr off pa (f $ ExprTypePrim pt) + + | Just (Refl :: FunctionType a :~: b) <- eqT + -> evalRemainingArguments off (exprArgs expr) expr | Just (Refl :: DynamicType :~: b) <- eqT , Undefined msg <- expr @@ -211,7 +326,79 @@ unifyExpr off pa expr = if | otherwise -> do parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ - "couldn't match expected type `" <> textExprType pa <> "' with actual type `" <> textExprType expr <> "'" + "couldn't match expected type ‘" <> textExprType pa <> "’ with actual type ‘" <> textExprType expr <> "’" + + +evalRemainingArguments :: ExprType a => Int -> FunctionArguments SomeArgumentType -> Expr (FunctionType a) -> TestParser (Expr a) +evalRemainingArguments off (FunctionArguments remaining) expr = do + let showType ( Nothing, SomeArgumentType _ stype ) = "‘<" <> textSomeExprType stype <> ">’" + showType ( Just (ArgumentKeyword kw), SomeArgumentType _ stype ) = "‘" <> kw <> " <" <> textSomeExprType stype <> ">’" + err = parseError . FancyError off . S.singleton . ErrorFail . T.unpack + + defaults <- fmap catMaybes $ forM (M.toAscList remaining) $ \case + arg@( _, SomeArgumentType RequiredArgument _ ) -> err $ "missing " <> showType arg <> " argument" + ( _, SomeArgumentType OptionalArgument _ ) -> return Nothing + ( kw, SomeArgumentType (ExprDefault def) _ ) -> return $ Just ( kw, def ) + ( kw, SomeArgumentType ContextDefault atype ) -> do + context <- unifySomeExpr off atype =<< gets testContext + return $ Just ( kw, context ) + sline <- getSourceLine + return (FunctionEval sline $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr) + + +unifySomeExpr :: Int -> SomeExprType -> SomeExpr -> TestParser SomeExpr +unifySomeExpr off stype sexpr@(SomeExpr (expr :: Expr a)) + | ExprTypePrim pa <- stype + = SomeExpr <$> unifyExpr off pa expr + + | ExprTypeConstr1 {} <- stype + = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ "unification with incomplete type" + + | ExprTypeVar tvar <- stype + = do + _ <- unify off (ExprTypeVar tvar) (someExprType sexpr) + return sexpr + + | Just (Refl :: a :~: DynamicType) <- eqT + , ExprTypeForall qvar itype <- someExprType sexpr + = do + tvar <- newTypeVar + itype' <- unify off stype $ renameVarInType qvar tvar itype + rtype <- M.lookup tvar <$> gets testTypeUnif + return $ SomeExpr (TypeApp itype' (fromMaybe (ExprTypeVar tvar) rtype) expr) + + | ExprTypeFunction args res <- stype + = case someExprType sexpr of + ExprTypeFunction args' res' -> do + _ <- unify off args args' + _ <- unify off res res' + return sexpr + _ -> do + _ <- unify off args (ExprTypeArguments mempty) + SomeExpr expr' <- unifySomeExpr off res sexpr + return $ SomeExpr $ FunctionAbstraction expr' + + | ExprTypeApp _ _ <- stype + , ExprTypeFunction args' res' <- someExprType sexpr + = do + ( _, ( remaining, _ ) ) <- case args' of + ExprTypeArguments args'' -> do + unifyArguments args'' mempty + _ -> do + _ <- unify off (ExprTypeArguments mempty) args' + return ( mempty, ( mempty, mempty ) ) + unify off stype res' >>= \case + ExprTypePrim (Proxy :: Proxy r) | Just (Refl :: a :~: FunctionType r) <- eqT -> + SomeExpr <$> evalRemainingArguments off remaining expr + _ | Just (Refl :: a :~: FunctionType DynamicType) <- eqT -> + SomeExpr <$> evalRemainingArguments off remaining expr + _ -> + error $ "expecting function type, got: " <> show (typeRep expr) + + | otherwise + = do + _ <- unify off stype (someExprType sexpr) + return sexpr skipLineComment :: TestParser () @@ -235,7 +422,7 @@ osymbol str = void $ try $ (string (TL.pack str) <* notFollowedBy operatorChar) wsymbol str = void $ try $ (string (TL.pack str) <* notFollowedBy wordChar) <* sc operatorChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) -operatorChar = satisfy $ (`elem` ['.', '+', '-', '*', '/', '=']) +operatorChar = satisfy $ (`elem` [ '!', '%', '&', '*', '+', '-', '.', '/', ':', '<', '=', '>', '?', '@', '^', '|', '~' ]) {-# INLINE operatorChar #-} localState :: TestParser a -> TestParser a @@ -249,15 +436,6 @@ localState inner = do toplevel :: (a -> b) -> TestParser a -> TestParser b toplevel f = return . f <=< L.nonIndented scn -block :: (a -> [b] -> TestParser c) -> TestParser a -> TestParser b -> TestParser c -block merge header item = L.indentBlock scn $ do - h <- header - choice - [ do symbol ":" - return $ L.IndentSome Nothing (merge h) item - , L.IndentNone <$> merge h [] - ] - listOf :: TestParser a -> TestParser [a] listOf item = do x <- item diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs index 079cfba..b2c6b84 100644 --- a/src/Parser/Expr.hs +++ b/src/Parser/Expr.hs @@ -4,17 +4,24 @@ module Parser.Expr ( varName, newVarName, - addVarName, + addVarName, addVarNameType, + constrName, + TermComplexity(..), someExpr, typedExpr, literal, variable, + constructor, + someExpansion, expansionTypeCheck, + expressionExpansion, stringExpansion, - checkFunctionArguments, functionArguments, + applyFunctionArguments, + + typeExpr, ) where import Control.Applicative (liftA2) @@ -76,12 +83,22 @@ newVarName = do return name addVarName :: forall a. ExprType a => Int -> TypedVarName a -> TestParser () -addVarName off (TypedVarName name) = do +addVarName off tname = addVarNameType off tname (ExprTypePrim @a Proxy) + +addVarNameType :: forall a. ExprType a => Int -> TypedVarName a -> SomeExprType -> TestParser () +addVarNameType off (TypedVarName name) stype = do gets (lookup name . testVars) >>= \case Just _ -> registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.pack "variable '" <> textVarName name <> T.pack "' already exists" Nothing -> return () - modify $ \s -> s { testVars = ( name, ( LocalVarName name, ExprTypePrim @a Proxy )) : testVars s } + modify $ \s -> s { testVars = ( name, ( LocalVarName name, stype )) : testVars s } + +constrName :: TestParser VarName +constrName = label "contructor name" $ do + lexeme $ try $ do + lead <- upperChar + rest <- takeWhileP Nothing (\x -> isAlphaNum x || x == '_') + return $ VarName $ TL.toStrict $ TL.fromChunks $ T.singleton lead : TL.toChunks rest someExpansion :: TestParser SomeExpr someExpansion = do @@ -91,13 +108,11 @@ someExpansion = do sline <- getSourceLine name <- VarName . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_') lookupScalarVarExpr off sline name - , between (char '{') (char '}') someExpr + , between (char '{') (char '}') (someExpr FunctionTerm) ] -expressionExpansion :: forall a. ExprType a => Text -> TestParser (Expr a) -expressionExpansion tname = do - off <- stateOffset <$> getParserState - SomeExpr e <- someExpansion +expansionTypeCheck :: forall a. ExprType a => Int -> Text -> SomeExpr -> TestParser (Expr a) +expansionTypeCheck off tname (SomeExpr e) = do let err = do registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat [ tname, T.pack " expansion not defined for '", textExprType e, T.pack "'" ] @@ -105,6 +120,11 @@ expressionExpansion tname = do maybe err (return . (<$> e)) $ listToMaybe $ catMaybes [ cast (id :: a -> a), exprExpansionConvTo, exprExpansionConvFrom ] +expressionExpansion :: forall a. ExprType a => Text -> TestParser (Expr a) +expressionExpansion tname = do + off <- stateOffset <$> getParserState + expansionTypeCheck off tname =<< someExpansion + stringExpansion :: TestParser (Expr Text) stringExpansion = expressionExpansion "string" @@ -118,6 +138,13 @@ numberLiteral = label "number" $ lexeme $ do else return $ SomeExpr $ Pure x ] +boolLiteral :: TestParser SomeExpr +boolLiteral = label "bool" $ lexeme $ do + SomeExpr . Pure <$> choice + [ wsymbol "True" *> return True + , wsymbol "False" *> return False + ] + quotedString :: TestParser (Expr Text) quotedString = label "string" $ lexeme $ do void $ char '"' @@ -142,7 +169,7 @@ quotedString = label "string" $ lexeme $ do regex :: TestParser (Expr Regex) regex = label "regular expression" $ lexeme $ do off <- stateOffset <$> getParserState - void $ char '/' + void $ try $ char '/' <* notFollowedBy (char '=') -- TODO: better parsing rules for regexes let inner = choice [ char '/' >> return [] , takeWhile1P Nothing (`notElem` ['/', '\\', '$']) >>= \s -> (Pure (RegexPart (TL.toStrict s)) :) <$> inner @@ -168,40 +195,51 @@ regex = label "regular expression" $ lexeme $ do list :: TestParser SomeExpr list = label "list" $ do symbol "[" - SomeExpr x <- someExpr - let enumErr off = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ - "list range enumeration not defined for '" <> textExprType x <> "'" - let exprList = foldr (liftA2 (:)) (Pure []) - SomeExpr <$> choice + choice [do symbol "]" - return $ exprList [x] - - ,do off <- stateOffset <$> getParserState - osymbol ".." - ExprEnumerator fromTo _ <- maybe (enumErr off) return $ exprEnumerator x - y <- typedExpr - symbol "]" - return $ fromTo <$> x <*> y - - ,do symbol "," - y <- typedExpr - - choice + tvar <- newTypeVar + return $ SomeExpr $ + TypeLambda tvar (ExprTypeApp (ExprTypeConstr1 (Proxy :: Proxy [])) [ ExprTypeVar tvar ]) $ + \case + (ExprTypePrim (Proxy :: Proxy a)) -> HidePrimType $ Pure ([] :: [ a ]) + _ -> Undefined "incomplete type" + + ,do SomeExpr x <- someExpr FunctionTerm + let enumErr off = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ + "list range enumeration not defined for ‘" <> textExprType x <> "’" + let exprList = foldr (liftA2 (:)) (Pure []) + + SomeExpr <$> choice [do symbol "]" - return $ exprList [x, y] + return $ exprList [ x ] ,do off <- stateOffset <$> getParserState osymbol ".." - ExprEnumerator _ fromThenTo <- maybe (enumErr off) return $ exprEnumerator x - z <- typedExpr + ExprEnumerator fromTo _ <- maybe (enumErr off) return $ exprEnumerator x + y <- typedExpr FunctionTerm symbol "]" - return $ fromThenTo <$> x <*> y <*> z + return $ fromTo <$> x <*> y ,do symbol "," - xs <- listOf typedExpr - symbol "]" - return $ exprList (x:y:xs) + y <- typedExpr FunctionTerm + + choice + [do symbol "]" + return $ exprList [ x, y ] + + ,do off <- stateOffset <$> getParserState + osymbol ".." + ExprEnumerator _ fromThenTo <- maybe (enumErr off) return $ exprEnumerator x + z <- typedExpr FunctionTerm + symbol "]" + return $ fromThenTo <$> x <*> y <*> z + + ,do symbol "," + xs <- listOf (typedExpr FunctionTerm) + symbol "]" + return $ exprList (x : y : xs) + ] ] ] @@ -224,14 +262,28 @@ applyBinOp off op x y = do y' <- unifyExpr off (Proxy @b) y return $ op <$> x' <*> y' -someExpr :: TestParser SomeExpr -someExpr = join inner <?> "expression" +data TermComplexity + = SimpleTerm -- variable name, literal or more complex term in parentheses + | FunctionTerm -- simple term or function call + +someExpr :: TermComplexity -> TestParser SomeExpr +someExpr complexity = label "expression" $ do + case complexity of + SimpleTerm -> join termSimple + FunctionTerm -> join inner where - inner = makeExprParser term table + inner = typeAnnotated $ makeExprParser termFunction table parens = between (symbol "(") (symbol ")") - term = label "term" $ choice + termSimple = label "term" $ choice + [ parens inner + , return <$> literal + , return <$> variable + , return <$> constructor + ] + + termFunction = label "term" $ choice [ parens inner , return <$> literal , return <$> functionCall @@ -257,15 +309,30 @@ someExpr = join inner <?> "expression" , SomeBinOp ((-) @Scientific) ] ] + , [ let tvar = TypeVar "a" + targs = FunctionArguments $ M.fromList + [ ( Just "$l", ( VarName "$l", SomeArgumentType RequiredArgument $ ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar tvar ]) ) + , ( Just "$r", ( VarName "$r", SomeArgumentType RequiredArgument $ ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar tvar ]) ) + ] + in infixrExpr "++" $ SomeExpr $ TypeLambda tvar (ExprTypeFunction (ExprTypeArguments $ fmap snd targs) (ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar tvar ])) $ \case + ExprTypePrim (Proxy :: Proxy a) -> + HideFunType (fmap snd targs) $ ArgsReq targs $ + FunctionAbstraction $ ((++) @a) + <$> (Variable SourceLineBuiltin $ LocalVarName $ VarName "$l") + <*> (Variable SourceLineBuiltin $ LocalVarName $ VarName "$r") + t -> Undefined ("ambiguous type ‘" <> T.unpack (textSomeExprType t) <> "’ for operator ‘++’") :: Expr DynamicType + ] , [ binary' "==" (\op xs ys -> length xs == length ys && and (zipWith op xs ys)) $ [ SomeBinOp ((==) @Integer) , SomeBinOp ((==) @Scientific) , SomeBinOp ((==) @Text) + , SomeBinOp ((==) @Bool) ] , binary' "/=" (\op xs ys -> length xs /= length ys || or (zipWith op xs ys)) $ [ SomeBinOp ((/=) @Integer) , SomeBinOp ((/=) @Scientific) , SomeBinOp ((/=) @Text) + , SomeBinOp ((/=) @Bool) ] , binary ">" $ [ SomeBinOp ((>) @Integer) @@ -298,6 +365,17 @@ someExpr = join inner <?> "expression" choice $ map (\(SomeUnOp op) -> SomeExpr <$> applyUnOp off op e) ops + infixrExpr :: String -> SomeExpr -> Operator TestParser (TestParser SomeExpr) + infixrExpr name fun = InfixR $ do + void $ osymbol name + return $ \p q -> do + loff <- stateOffset <$> getParserState + l <- p + roff <- stateOffset <$> getParserState + r <- q + applyFunctionArguments (FunctionArguments $ M.fromList [ ( Just "$l", ( loff, l ) ), ( Just "$r", ( roff, r ) ) ]) fun + + binary :: String -> [SomeBinOp] -> Operator TestParser (TestParser SomeExpr) binary name = binary' name (undefined :: forall a b. (a -> b -> Void) -> [a] -> [b] -> Integer) -- use 'Void' that can never match actually used type to disable recursion @@ -338,15 +416,34 @@ someExpr = join inner <?> "expression" region (const err) $ foldl1 (<|>) $ map (\(SomeBinOp op) -> tryop op (proxyOf e) (proxyOf f)) ops -typedExpr :: forall a. ExprType a => TestParser (Expr a) -typedExpr = do + typeAnnotated :: TestParser (TestParser SomeExpr) -> TestParser (TestParser SomeExpr) + typeAnnotated p = do + off <- stateOffset <$> getParserState + p' <- p + choice + [ do + -- colon starts a type annotation, except when at the end of line + void $ try $ (string ":" <* notFollowedBy operatorChar <* sc <* notFollowedBy eol) + stype <- typeExpr + return $ do + se <- p' + unifySomeExpr off stype se + + , do + return p' + ] + + +typedExpr :: forall a. ExprType a => TermComplexity -> TestParser (Expr a) +typedExpr complexity = do off <- stateOffset <$> getParserState - SomeExpr e <- someExpr + SomeExpr e <- someExpr complexity unifyExpr off Proxy e literal :: TestParser SomeExpr literal = label "literal" $ choice [ numberLiteral + , boolLiteral , SomeExpr <$> quotedString , SomeExpr <$> regex , list @@ -360,15 +457,19 @@ variable = label "variable" $ do e <- lookupVarExpr off sline name recordSelector e <|> return e +constructor :: TestParser SomeExpr +constructor = label "constructor" $ do + off <- stateOffset <$> getParserState + sline <- getSourceLine + name <- constrName + lookupVarExpr off sline name + functionCall :: TestParser SomeExpr functionCall = do sline <- getSourceLine - variable >>= \case - SomeExpr e'@(FunVariable argTypes _ _) -> do - let check = checkFunctionArguments argTypes - args <- functionArguments check someExpr literal (\poff -> lookupVarExpr poff sline . VarName) - return $ SomeExpr $ ArgsApp args e' - e -> return e + fun <- variable <|> constructor + args <- functionArguments (\poff _ e -> return ( poff, e )) (someExpr FunctionTerm) literal (\poff -> lookupVarExpr poff sline . VarName) + applyFunctionArguments args fun recordSelector :: SomeExpr -> TestParser SomeExpr recordSelector (SomeExpr expr) = do @@ -384,21 +485,6 @@ recordSelector (SomeExpr expr) = do applyRecordSelector m e (RecordSelector f) = SomeExpr $ App (AnnRecord m) (pure f) e -checkFunctionArguments :: FunctionArguments SomeArgumentType - -> Int -> Maybe ArgumentKeyword -> SomeExpr -> TestParser SomeExpr -checkFunctionArguments (FunctionArguments argTypes) poff kw sexpr@(SomeExpr expr) = do - case M.lookup kw argTypes of - Just (SomeArgumentType (_ :: ArgumentType expected)) -> do - withRecovery (\e -> registerParseError e >> return sexpr) $ do - SomeExpr <$> unifyExpr poff (Proxy @expected) 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 sexpr - - 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 @@ -426,3 +512,65 @@ functionArguments check param lit promote = do pparam = between (symbol "(") (symbol ")") param <|> lit checkAndInsert off kw x cont = M.insert kw <$> check off kw x <*> cont + + +applyFunctionArguments :: FunctionArguments ( Int, SomeExpr ) -> SomeExpr -> TestParser SomeExpr +applyFunctionArguments (FunctionArguments margs) sexpr + | M.null margs = return sexpr +applyFunctionArguments args sexpr@(SomeExpr (expr :: Expr a)) + | Just (Refl :: a :~: DynamicType) <- eqT + , ExprTypeForall qvar itype <- someExprType sexpr + = do + tvar <- newTypeVar + case renameVarInType qvar tvar itype of + ExprTypeFunction (ExprTypeArguments args') res' -> do + ( used, ( _, unexpectedArgs ) ) <- unifyArguments args' args + unexpectedArguments unexpectedArgs + t <- fromMaybe (ExprTypeVar tvar) . M.lookup tvar <$> gets testTypeUnif + resolveKnownTypeVars res' >>= \case + ( res''@(ExprTypePrim (Proxy :: Proxy r)), _ ) -> + return $ SomeExpr (ArgsApp used (ExposeFunType args' (TypeApp res'' t expr) :: Expr (FunctionType r))) + ( r, _ ) -> + return $ SomeExpr (ArgsApp used (ExposeFunType args' (TypeApp r t expr) :: Expr (FunctionType DynamicType))) + _ -> do + unexpectedArguments args + return sexpr + + | otherwise + = case someExprType sexpr of + ExprTypeFunction (ExprTypeArguments args') res' -> do + ( used, ( _, unexpectedArgs ) ) <- unifyArguments args' args + unexpectedArguments unexpectedArgs + resolveKnownTypeVars res' >>= \case + ( ExprTypePrim (Proxy :: Proxy r), _ ) + | Just (Refl :: a :~: FunctionType r) <- eqT + -> return $ SomeExpr (ArgsApp used expr) + _ + | Just (Refl :: a :~: FunctionType DynamicType) <- eqT + -> return $ SomeExpr (ArgsApp used expr) + _ -> + error $ "expecting function type, got: " <> show (typeRep expr) + _ -> do + unexpectedArguments args + return sexpr + where + unexpectedArguments (FunctionArguments amap) = do + forM_ (M.toAscList amap) $ \( kw, ( poff, _ ) ) -> + registerParseError $ FancyError poff $ S.singleton $ ErrorFail $ T.unpack $ + case kw of + Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword ‘" <> tkw <> "’" + Nothing -> "unexpected parameter" + + +typeExpr :: TestParser SomeExprType +typeExpr = do + off <- stateOffset <$> getParserState + choice + [ do + name <- constrName <?> "type constructor name" + lookupType off name + , do + between (symbol "[") (symbol "]") $ do + inner <- typeExpr + return $ ExprTypeApp (ExprTypeConstr1 (Proxy :: Proxy [])) [ inner ] + ] diff --git a/src/Parser/Shell.hs b/src/Parser/Shell.hs index 0f34fee..2d6026a 100644 --- a/src/Parser/Shell.hs +++ b/src/Parser/Shell.hs @@ -3,6 +3,7 @@ module Parser.Shell ( shellScript, ) where +import Control.Applicative (liftA2) import Control.Monad import Data.Char @@ -19,15 +20,18 @@ import Parser.Expr import Script.Expr import Script.Shell -parseArgument :: TestParser (Expr Text) -parseArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:)) (Pure [])) $ some $ choice +parseTextArgument :: TestParser (Expr Text) +parseTextArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:)) (Pure [])) $ some $ choice [ doubleQuotedString - , escapedChar + , singleQuotedString + , standaloneEscapedChar , stringExpansion , unquotedString ] where - specialChars = [ '\"', '\\', '$' ] + specialChars = [ '"', '\'', '\\', '$', '#', '|', '>', '<', ';', '[', ']'{-, '{', '}' -}, '(', ')'{-, '*', '?', '~', '&', '!' -} ] + + stringSpecialChars = [ '"', '\\', '$' ] unquotedString :: TestParser (Expr Text) unquotedString = do @@ -38,36 +42,129 @@ parseArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:) void $ char '"' let inner = choice [ char '"' >> return [] - , (:) <$> (Pure . TL.toStrict <$> takeWhile1P Nothing (`notElem` specialChars)) <*> inner - , (:) <$> escapedChar <*> inner + , (:) <$> (Pure . TL.toStrict <$> takeWhile1P Nothing (`notElem` stringSpecialChars)) <*> inner + , (:) <$> stringEscapedChar <*> inner , (:) <$> stringExpansion <*> inner ] App AnnNone (Pure T.concat) . foldr (liftA2 (:)) (Pure []) <$> inner - escapedChar :: TestParser (Expr Text) - escapedChar = do + singleQuotedString :: TestParser (Expr Text) + singleQuotedString = do + Pure . TL.toStrict <$> (char '\'' *> takeWhileP Nothing (/= '\'') <* char '\'') + + stringEscapedChar :: TestParser (Expr Text) + stringEscapedChar = do void $ char '\\' - Pure <$> choice - [ char '\\' >> return "\\" - , char '"' >> return "\"" - , char '$' >> return "$" - , char 'n' >> return "\n" + fmap Pure $ choice $ + map (\c -> char c >> return (T.singleton c)) stringSpecialChars ++ + [ char 'n' >> return "\n" , char 'r' >> return "\r" , char 't' >> return "\t" + , return "\\" ] -parseArguments :: TestParser (Expr [ Text ]) -parseArguments = foldr (liftA2 (:)) (Pure []) <$> many parseArgument + standaloneEscapedChar :: TestParser (Expr Text) + standaloneEscapedChar = do + void $ char '\\' + fmap T.singleton . Pure <$> printChar + +parseRedirection :: TestParser (Expr ShellArgument) +parseRedirection = choice + [ do + rsymbol "<" + fmap ShellRedirectStdin <$> parseTextArgument + , do + rsymbol ">" + fmap (ShellRedirectStdout False) <$> parseTextArgument + , do + rsymbol ">>" + fmap (ShellRedirectStdout True) <$> parseTextArgument + , do + rsymbol "2>" + fmap (ShellRedirectStderr False) <$> parseTextArgument + , do + rsymbol "2>>" + fmap (ShellRedirectStderr True) <$> parseTextArgument + ] + where + rsymbol str = void $ try $ (string str <* notFollowedBy (satisfy $ (`elem` [ '<', '>', '|' ]))) <* sc + +parseArgument :: TestParser (Expr ShellArgument) +parseArgument = choice + [ parseRedirection + , expressionExpansion "shell argument" <* sc + , fmap ShellArgument <$> parseTextArgument + ] + +parseArguments :: TestParser (Expr ShellArguments) +parseArguments = do + arglists <- many $ choice + [ do + off <- stateOffset <$> getParserState + se <- someExpansion + choice + [ do + notFollowedBy space1 + arg <- expansionTypeCheck off "shell argument" se + txt <- parseTextArgument + return $ joinArgument <$> arg <*> txt + , do + expansionTypeCheck off "shell arguments" se <* sc + ] + , fmap (ShellArguments . (: [])) <$> parseArgument + ] + return $ fmap mconcat $ foldr (liftA2 (:)) (Pure []) $ arglists + where + joinArgument (ShellArgument x) y = ShellArguments [ ShellArgument (x <> y) ] + joinArgument ax y = ShellArguments [ ax, ShellArgument y ] + +parseCommand :: TestParser (Expr ShellCommand) +parseCommand = label "shell statement" $ do + line <- getSourceLine + choice + [ do + args <- expressionExpansion "shell command" <* sc + args' <- parseArguments + return $ commandFromArgLists line <$> args <*> args' + , do + command <- parseTextArgument + args <- parseArguments + return $ ShellCommand + <$> command + <*> args + <*> pure line + ] + + where + commandFromArgLists line (ShellArguments (ShellArgument cmd : args)) (ShellArguments args') = + ShellCommand cmd (ShellArguments (args ++ args')) line + commandFromArgLists line (ShellArguments args) (ShellArguments args') = + ShellCommand "" (ShellArguments (args ++ args')) line + +parsePipeline :: Maybe (Expr ShellPipeline) -> TestParser (Expr ShellPipeline) +parsePipeline mbupper = do + cmd <- parseCommand + let pipeline = + case mbupper of + Nothing -> fmap (\ecmd -> ShellPipeline ecmd Nothing) cmd + Just upper -> liftA2 (\ecmd eupper -> ShellPipeline ecmd (Just eupper)) cmd upper + choice + [ do + psymbol "|" + parsePipeline (Just pipeline) + + , do + return pipeline + ] + where + psymbol str = void $ try $ (string str <* notFollowedBy (satisfy $ (`elem` [ '<', '>', '|', '&' ]))) <* sc -shellStatement :: TestParser (Expr [ ShellStatement ]) -shellStatement = label "shell statement" $ do - command <- parseArgument - args <- parseArguments - return $ fmap (: []) $ ShellStatement - <$> command - <*> args +parseStatement :: TestParser (Expr [ ShellStatement ]) +parseStatement = do + line <- getSourceLine + fmap ((: []) . flip ShellStatement line) <$> parsePipeline Nothing shellScript :: TestParser (Expr ShellScript) shellScript = do indent <- L.indentLevel - fmap ShellScript <$> blockOf indent shellStatement + fmap ShellScript <$> blockOf indent parseStatement diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs index 812c559..1c1b805 100644 --- a/src/Parser/Statement.hs +++ b/src/Parser/Statement.hs @@ -1,5 +1,6 @@ module Parser.Statement ( testStep, + testBlock, ) where import Control.Monad @@ -36,14 +37,14 @@ letStatement = do off <- stateOffset <$> getParserState name <- varName osymbol "=" - SomeExpr e <- someExpr + se@(SomeExpr e) <- someExpr FunctionTerm localState $ do let tname = TypedVarName name - addVarName off tname + addVarNameType off tname (someExprType se) void $ eol body <- testBlock indent - return $ Let line tname e body + return $ Let line tname e (TestBlockStep EmptyTestBlock . Scope <$> body) forStatement :: TestParser (Expr (TestBlock ())) forStatement = do @@ -54,7 +55,8 @@ forStatement = do wsymbol "in" loff <- stateOffset <$> getParserState - SomeExpr e <- someExpr + tvar <- newTypeVar + SomeExpr e <- unifySomeExpr loff (ExprTypeApp (ExprTypeConstr1 (Proxy :: Proxy [])) [ ExprTypeVar tvar ]) =<< someExpr FunctionTerm let err = parseError $ FancyError loff $ S.singleton $ ErrorFail $ T.unpack $ "expected a list, expression has type '" <> textExprType e <> "'" ExprListUnpacker unpack _ <- maybe err return $ exprListUnpacker e @@ -68,7 +70,7 @@ forStatement = do body <- testBlock indent return $ (\xs f -> mconcat $ map f xs) <$> (unpack <$> e) - <*> LambdaAbstraction tname body + <*> LambdaAbstraction tname (TestBlockStep EmptyTestBlock . Scope <$> body) shellStatement :: TestParser (Expr (TestBlock ())) shellStatement = do @@ -92,18 +94,12 @@ shellStatement = do , do parseParamKeyword "on" mbnode - node <- typedExpr + node <- typedExpr SimpleTerm parseParams ref mbpname (Just node) , do off <- stateOffset <$> getParserState symbol ":" - pname <- case mbpname of - Just pname -> return pname - Nothing -> do - registerParseError $ FancyError off $ S.singleton $ ErrorFail $ - "missing parameter with keyword ‘as’" - return $ TypedVarName (VarName "") node <- case mbnode of Just node -> return node Nothing -> do @@ -114,16 +110,18 @@ shellStatement = do void eol void $ L.indentGuard scn GT ref script <- shellScript - cont <- testBlock ref + cont <- fmap Scope <$> testBlock ref + let expr | Just pname <- mbpname = LambdaAbstraction pname cont + | otherwise = const <$> cont return $ TestBlockStep EmptyTestBlock <$> - (SpawnShell pname <$> node <*> script <*> LambdaAbstraction pname cont) + (SpawnShell mbpname <$> node <*> script <*> expr) ] exprStatement :: TestParser (Expr (TestBlock ())) exprStatement = do ref <- L.indentLevel off <- stateOffset <$> getParserState - SomeExpr expr <- someExpr + SomeExpr expr <- someExpr FunctionTerm choice [ continuePartial off ref expr , unifyExpr off Proxy expr @@ -139,8 +137,8 @@ exprStatement = do blockOf indent $ do coff <- stateOffset <$> getParserState sline <- getSourceLine - args <- functionArguments (checkFunctionArguments (exprArgs fun)) someExpr literal (\poff -> lookupVarExpr poff sline . VarName) - let fun' = ArgsApp args fun + args <- functionArguments (\poff _ e -> return ( poff, e )) (someExpr FunctionTerm) literal (\poff -> lookupVarExpr poff sline . VarName) + SomeExpr fun' <- applyFunctionArguments args (SomeExpr fun) choice [ continuePartial coff indent fun' , unifyExpr coff Proxy fun' @@ -172,19 +170,18 @@ instance ParamType SourceLine where parseParam _ = mzero showParamType _ = "<source line>" +instance ParamType CallStack where + type ParamRep CallStack = Expr CallStack + parseParam _ = mzero + showParamType _ = "<call stack>" + paramExpr = id + instance ExprType a => ParamType (TypedVarName a) where parseParam _ = newVarName showParamType _ = "<variable>" paramNewVariables _ var = SomeNewVariables [ var ] paramNewVariablesEmpty _ = SomeNewVariables @a [] -instance ExprType a => ParamType (Expr a) where - parseParam _ = do - off <- stateOffset <$> getParserState - SomeExpr e <- literal <|> between (symbol "(") (symbol ")") someExpr - unifyExpr off Proxy e - showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">" - instance ParamType a => ParamType [a] where type ParamRep [a] = [ParamRep a] parseParam _ = listOf (parseParam @a Proxy) @@ -220,8 +217,8 @@ instance (ParamType a, ParamType b) => ParamType (Either a b) where instance ExprType a => ParamType (Traced a) where type ParamRep (Traced a) = Expr a - parseParam _ = parseParam (Proxy @(Expr a)) - showParamType _ = showParamType (Proxy @(Expr a)) + parseParam _ = parseParam (Proxy @(ExprParam a)) + showParamType _ = showParamType (Proxy @(ExprParam a)) paramExpr = Trace data SomeParam f = forall a. ParamType a => SomeParam (Proxy a) (f (ParamRep a)) @@ -279,6 +276,9 @@ paramOrContext name = fromParamOrContext <$> param name cmdLine :: CommandDef SourceLine cmdLine = param "" +callStack :: CommandDef CallStack +callStack = param "" + newtype InnerBlock a = InnerBlock { fromInnerBlock :: [ a ] -> TestBlock () } instance ExprType a => ParamType (InnerBlock a) where @@ -294,14 +294,14 @@ instance ExprType a => ParamType (InnerBlock a) where combine f (x : xs) = f x xs combine _ [] = error "inner block parameter count mismatch" -innerBlock :: CommandDef (TestBlock ()) -innerBlock = ($ ([] :: [ Void ])) <$> innerBlockFun +innerBlock :: CommandDef (TestStep ()) +innerBlock = ($ ([] :: [ Void ])) <$> innerBlockFunList -innerBlockFun :: ExprType a => CommandDef (a -> TestBlock ()) +innerBlockFun :: ExprType a => CommandDef (a -> TestStep ()) innerBlockFun = (\f x -> f [ x ]) <$> innerBlockFunList -innerBlockFunList :: ExprType a => CommandDef ([ a ] -> TestBlock ()) -innerBlockFunList = fromInnerBlock <$> param "" +innerBlockFunList :: ExprType a => CommandDef ([ a ] -> TestStep ()) +innerBlockFunList = (\ib -> Scope . fromInnerBlock ib) <$> param "" newtype ExprParam a = ExprParam { fromExprParam :: a } deriving (Functor, Foldable, Traversable) @@ -310,7 +310,7 @@ instance ExprType a => ParamType (ExprParam a) where type ParamRep (ExprParam a) = Expr a parseParam _ = do off <- stateOffset <$> getParserState - SomeExpr e <- literal <|> variable <|> between (symbol "(") (symbol ")") someExpr + SomeExpr e <- someExpr SimpleTerm unifyExpr off Proxy e showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">" paramExpr = fmap ExprParam @@ -330,11 +330,15 @@ command name (CommandDef types ctor) = do iparams <- forM params $ \case (_, SomeParam (p :: Proxy p) Nothing) | Just (Refl :: p :~: SourceLine) <- eqT -> return $ SomeParam p $ Identity line + | Just (Refl :: p :~: CallStack) <- eqT -> return $ SomeParam p $ Identity $ Variable line callStackFqVarName | SomeNewVariables (vars :: [ TypedVarName a ]) <- definedVariables , Just (Refl :: p :~: InnerBlock a) <- eqT -> SomeParam p . Identity . ( vars, ) <$> restOfParts cmdi partials + | Just (Refl :: p :~: InnerBlock Void) <- eqT + -> SomeParam p . Identity . ( [], ) <$> restOfParts cmdi partials + (sym, SomeParam p Nothing) -> choice [ SomeParam p . Identity <$> paramDefault p , fail $ "missing " ++ (if null sym then "" else "'" ++ sym ++ "' ") ++ showParamType p @@ -384,7 +388,8 @@ testLocal = do void $ eol indent <- L.indentGuard scn GT ref - localState $ testBlock indent + localState $ do + fmap (TestBlockStep EmptyTestBlock . Scope) <$> testBlock indent testWith :: TestParser (Expr (TestBlock ())) testWith = do @@ -392,7 +397,7 @@ testWith = do wsymbol "with" off <- stateOffset <$> getParserState - ctx@(SomeExpr (_ :: Expr ctxe)) <- someExpr + ctx@(SomeExpr (_ :: Expr ctxe)) <- someExpr SimpleTerm let expected = [ ExprTypePrim @Network Proxy , ExprTypePrim @Node Proxy @@ -410,7 +415,7 @@ testWith = do indent <- L.indentGuard scn GT ref localState $ do modify $ \s -> s { testContext = ctx } - testBlock indent + fmap (TestBlockStep EmptyTestBlock . Scope) <$> testBlock indent testSubnet :: TestParser (Expr (TestBlock ())) testSubnet = command "subnet" $ Subnet @@ -428,13 +433,17 @@ testSpawn :: TestParser (Expr (TestBlock ())) testSpawn = command "spawn" $ Spawn <$> param "as" <*> (bimap fromExprParam fromExprParam <$> paramOrContext "on") + <*> (maybe [] fromExprParam <$> param "args") + <*> (maybe Nothing (Just . fromExprParam) <$> param "killwith") <*> innerBlockFun testExpect :: TestParser (Expr (TestBlock ())) testExpect = command "expect" $ Expect - <$> cmdLine + <$> callStack + <*> cmdLine <*> (fromExprParam <$> paramOrContext "from") <*> param "" + <*> (maybe 1 fromExprParam <$> param "timeout") <*> param "capture" <*> innerBlockFunList |