diff options
Diffstat (limited to 'src/Parser')
| -rw-r--r-- | src/Parser/Core.hs | 239 | ||||
| -rw-r--r-- | src/Parser/Expr.hs | 268 | ||||
| -rw-r--r-- | src/Parser/Shell.hs | 81 | ||||
| -rw-r--r-- | src/Parser/Statement.hs | 334 |
4 files changed, 716 insertions, 206 deletions
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs index 2a74d3d..132dbc8 100644 --- a/src/Parser/Core.hs +++ b/src/Parser/Core.hs @@ -1,37 +1,218 @@ module Parser.Core where +import Control.Applicative import Control.Monad import Control.Monad.State -import Control.Monad.Writer -import Data.Text (Text) -import qualified Data.Text.Lazy as TL -import Data.Void +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe +import Data.Set qualified as S +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import Data.Typeable import Text.Megaparsec hiding (State) import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L import Network () +import Script.Expr +import Script.Module import Test -type TestParser = ParsecT Void TestStream (WriterT [ Toplevel ] (State TestParserState)) +newtype TestParser a = TestParser (StateT TestParserState (ParsecT CustomTestError TestStream IO) a) + deriving + ( Functor, Applicative, Alternative, Monad + , MonadState TestParserState + , MonadPlus + , MonadFail + , MonadIO + , MonadParsec CustomTestError TestStream + ) type TestStream = TL.Text +type TestParseError = ParseError TestStream CustomTestError + +data CustomTestError + = ModuleNotFound ModuleName + | FileNotFound FilePath + | ImportModuleError (ParseErrorBundle TestStream CustomTestError) + deriving (Eq) + +instance Ord CustomTestError where + compare (ModuleNotFound a) (ModuleNotFound b) = compare a b + compare (ModuleNotFound _) _ = LT + compare _ (ModuleNotFound _) = GT + + compare (FileNotFound a) (FileNotFound b) = compare a b + compare (FileNotFound _) _ = LT + compare _ (FileNotFound _) = 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 + +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 + data Toplevel = ToplevelTest Test + | ToplevelDefinition ( VarName, SomeExpr ) + | ToplevelExport VarName + | ToplevelImport ( ModuleName, VarName ) data TestParserState = TestParserState - { testVars :: [(VarName, SomeExprType)] + { testSourcePath :: FilePath + , testVars :: [ ( VarName, ( FqVarName, SomeExprType )) ] , testContext :: SomeExpr + , testNextTypeVar :: Int + , testTypeUnif :: Map TypeVar SomeExprType + , testCurrentModuleName :: ModuleName + , testParseModule :: ModuleName -> ModuleName -> IO (Either CustomTestError Module) } -textSomeExprType :: SomeExprType -> Text -textSomeExprType (SomeExprType p) = textExprType p +newTypeVar :: TestParser TypeVar +newTypeVar = do + idx <- gets testNextTypeVar + modify $ \s -> s { testNextTypeVar = idx + 1 } + return $ TypeVar $ T.pack $ 'a' : show idx + +lookupVarType :: Int -> VarName -> TestParser ( FqVarName, SomeExprType ) +lookupVarType off name = do + gets (lookup name . testVars) >>= \case + Nothing -> do + registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ + "variable not in scope: `" <> textVarName name <> "'" + vtype <- ExprTypeVar <$> newTypeVar + let fqName = LocalVarName name + modify $ \s -> s { testVars = ( name, ( fqName, vtype )) : testVars s } + return ( fqName, vtype ) + Just ( fqName, t@(ExprTypeVar tvar) ) -> do + ( fqName, ) <$> gets (fromMaybe t . M.lookup tvar . testTypeUnif) + Just x -> return x + +lookupVarExpr :: Int -> SourceLine -> VarName -> TestParser SomeExpr +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)) + +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 + SomeExpr <$> unifyExpr off pa (FunVariable args sline fqn :: Expr (FunctionType a)) + +unify :: Int -> SomeExprType -> SomeExprType -> TestParser SomeExprType +unify _ (ExprTypeVar aname) (ExprTypeVar bname) | aname == bname = do + cur <- gets testTypeUnif + case M.lookup aname cur of + Just a -> return a + Nothing -> return (ExprTypeVar aname) + +unify off (ExprTypeVar aname) (ExprTypeVar bname) = do + cur <- gets testTypeUnif + case ( M.lookup aname cur, M.lookup bname cur ) of + ( Just a, Just b ) -> do + c <- unify off a b + modify $ \s -> s { testTypeUnif = M.insert aname c $ M.insert bname c $ cur } + return c + + ( Just a, Nothing ) -> do + modify $ \s -> s { testTypeUnif = M.insert bname a $ cur } + return a + + ( Nothing, Just b ) -> do + modify $ \s -> s { testTypeUnif = M.insert aname b $ cur } + return b + + ( Nothing, Nothing ) -> do + let b = ExprTypeVar bname + modify $ \s -> s { testTypeUnif = M.insert aname b $ cur } + return b + +unify off (ExprTypeVar aname) b = do + cur <- gets testTypeUnif + case M.lookup aname cur of + Just a -> do + c <- unify off a b + modify $ \s -> s { testTypeUnif = M.insert aname c $ cur } + return c + Nothing -> do + modify $ \s -> s { testTypeUnif = M.insert aname b $ cur } + return b + +unify off a (ExprTypeVar bname) = do + cur <- gets testTypeUnif + case M.lookup bname cur of + Just b -> do + c <- unify off a b + modify $ \s -> s { testTypeUnif = M.insert bname c $ cur } + return c + + Nothing -> do + modify $ \s -> s { testTypeUnif = M.insert bname a $ cur } + return a + +unify _ res@(ExprTypePrim (Proxy :: Proxy a)) (ExprTypePrim (Proxy :: Proxy b)) + | Just (Refl :: a :~: b) <- eqT + = return res + +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 <> "'" + + +unifyExpr :: forall a b proxy. (ExprType a, ExprType b) => Int -> proxy a -> Expr b -> TestParser (Expr a) +unifyExpr off pa expr = if + | Just (Refl :: a :~: b) <- eqT + -> return expr + + | DynVariable tvar sline name <- expr + -> do + _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) (ExprTypeVar tvar) + return $ Variable sline name + + | Just (Refl :: FunctionType a :~: b) <- eqT + -> 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) + + | Just (Refl :: DynamicType :~: b) <- eqT + , 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 expr <> "'" -lookupVarType :: VarName -> TestParser SomeExprType -lookupVarType name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") return =<< gets (lookup name . testVars) skipLineComment :: TestParser () skipLineComment = L.skipLineComment $ TL.pack "#" @@ -61,11 +242,12 @@ localState :: TestParser a -> TestParser a localState inner = do s <- get x <- inner - put s + s' <- get + put s { testNextTypeVar = testNextTypeVar s', testTypeUnif = testTypeUnif s' } return x -toplevel :: (a -> Toplevel) -> TestParser a -> TestParser () -toplevel f = tell . (: []) . f <=< L.nonIndented scn +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 @@ -80,3 +262,34 @@ listOf :: TestParser a -> TestParser [a] listOf item = do x <- item (x:) <$> choice [ symbol "," >> listOf item, return [] ] + +blockOf :: Monoid a => Pos -> TestParser a -> TestParser a +blockOf indent step = go + where + go = do + scn + pos <- L.indentLevel + optional eof >>= \case + Just _ -> return mempty + _ | pos < indent -> return mempty + | pos == indent -> mappend <$> step <*> go + | otherwise -> L.incorrectIndent EQ indent pos + + +getSourceLine :: TestParser SourceLine +getSourceLine = do + pstate <- statePosState <$> getParserState + return $ SourceLine $ T.concat + [ T.pack $ sourcePosPretty $ pstateSourcePos pstate + , T.pack ": " + , TL.toStrict $ TL.takeWhile (/='\n') $ pstateInput pstate + ] + + +getOrParseModule :: ModuleName -> TestParser Module +getOrParseModule name = do + current <- gets testCurrentModuleName + parseModule <- gets testParseModule + (TestParser $ lift $ lift $ parseModule current name) >>= \case + Right parsed -> return parsed + Left err -> customFailure err diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs index 8ea3ace..b9b5f01 100644 --- a/src/Parser/Expr.hs +++ b/src/Parser/Expr.hs @@ -1,5 +1,6 @@ module Parser.Expr ( identifier, + parseModuleName, varName, newVarName, @@ -7,6 +8,13 @@ module Parser.Expr ( someExpr, typedExpr, + literal, + variable, + + stringExpansion, + + checkFunctionArguments, + functionArguments, ) where import Control.Applicative (liftA2) @@ -15,30 +23,50 @@ 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 import Text.Megaparsec hiding (State) import Text.Megaparsec.Char import Text.Megaparsec.Char.Lexer qualified as L -import Text.Regex.TDFA qualified as RE -import Text.Regex.TDFA.Text qualified as RE +import Text.Megaparsec.Error.Builder qualified as Err import Parser.Core -import Test +import Script.Expr +import Script.Expr.Class + +reservedWords :: [ Text ] +reservedWords = + [ "test", "def", "let" + , "module", "export", "import" + ] identifier :: TestParser Text -identifier = do - lexeme $ TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_') +identifier = label "identifier" $ do + lexeme $ try $ do + off <- stateOffset <$> getParserState + lead <- lowerChar + rest <- takeWhileP Nothing (\x -> isAlphaNum x || x == '_') + let ident = TL.toStrict $ TL.fromChunks $ (T.singleton lead :) $ TL.toChunks rest + when (ident `elem` reservedWords) $ parseError $ Err.err off $ mconcat + [ Err.utoks $ TL.fromStrict ident + ] + return ident + +parseModuleName :: TestParser ModuleName +parseModuleName = do + x <- identifier + ModuleName . (x :) <$> many (symbol "." >> identifier) varName :: TestParser VarName -varName = VarName <$> identifier +varName = label "variable name" $ VarName <$> identifier newVarName :: forall a. ExprType a => TestParser (TypedVarName a) newVarName = do @@ -53,20 +81,21 @@ addVarName off (TypedVarName name) = do 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, SomeExprType @a Proxy) : testVars s } + modify $ \s -> s { testVars = ( name, ( LocalVarName name, ExprTypePrim @a Proxy )) : testVars s } someExpansion :: TestParser SomeExpr someExpansion = do void $ char '$' choice - [do name <- VarName . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_') - SomeExprType (_ :: Proxy a) <- lookupVarType name - return $ SomeExpr $ Variable @a name + [do off <- stateOffset <$> getParserState + sline <- getSourceLine + name <- VarName . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_') + lookupScalarVarExpr off sline name , between (char '{') (char '}') someExpr ] -stringExpansion :: ExprType a => Text -> (forall b. ExprType b => Expr b -> [Maybe (Expr a)]) -> TestParser (Expr a) -stringExpansion tname conv = do +expressionExpansion :: forall a. ExprType a => Text -> TestParser (Expr a) +expressionExpansion tname = do off <- stateOffset <$> getParserState SomeExpr e <- someExpansion let err = do @@ -74,7 +103,10 @@ stringExpansion tname conv = do [ tname, T.pack " expansion not defined for '", textExprType e, T.pack "'" ] return $ Undefined "expansion not defined for type" - maybe err return $ listToMaybe $ catMaybes $ conv e + maybe err (return . (<$> e)) $ listToMaybe $ catMaybes [ cast (id :: a -> a), exprExpansionConvTo, exprExpansionConvFrom ] + +stringExpansion :: TestParser (Expr Text) +stringExpansion = expressionExpansion "string" numberLiteral :: TestParser SomeExpr numberLiteral = label "number" $ lexeme $ do @@ -86,6 +118,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 '"' @@ -102,11 +141,7 @@ quotedString = label "string" $ lexeme $ do , char 't' >> return '\t' ] (Pure (T.singleton c) :) <$> inner - ,do e <- stringExpansion (T.pack "string") $ \e -> - [ cast e - , fmap (T.pack . show @Integer) <$> cast e - , fmap (T.pack . show @Scientific) <$> cast e - ] + ,do e <- stringExpansion (e:) <$> inner ] Concat <$> inner @@ -124,19 +159,14 @@ regex = label "regular expression" $ lexeme $ do , anySingle >>= \c -> return (Pure $ RegexPart $ T.pack ['\\', c]) ] (s:) <$> inner - ,do e <- stringExpansion (T.pack "regex") $ \e -> - [ cast e - , fmap RegexString <$> cast e - , fmap (RegexString . T.pack . show @Integer) <$> cast e - , fmap (RegexString . T.pack . show @Scientific) <$> cast e - ] + ,do e <- expressionExpansion (T.pack "regex") (e:) <$> inner ] parts <- inner let testEval = \case Pure (RegexPart p) -> p _ -> "" - case RE.compile RE.defaultCompOpt RE.defaultExecOpt $ T.concat $ map testEval parts of + case regexCompile $ T.concat $ map testEval parts of Left err -> registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat [ "failed to parse regular expression: ", T.pack err ] Right _ -> return () @@ -186,20 +216,20 @@ data SomeUnOp = forall a b. (ExprType a, ExprType b) => SomeUnOp (a -> b) applyUnOp :: forall a b sa. (ExprType a, ExprType b, ExprType sa) => - (a -> b) -> Expr sa -> Maybe (Expr b) -applyUnOp op x = do - Refl :: a :~: sa <- eqT - return $ op <$> x + Int -> (a -> b) -> Expr sa -> TestParser (Expr b) +applyUnOp off op x = do + x' <- unifyExpr off (Proxy @a) x + return $ op <$> x' data SomeBinOp = forall a b c. (ExprType a, ExprType b, ExprType c) => SomeBinOp (a -> b -> c) applyBinOp :: forall a b c sa sb. (ExprType a, ExprType b, ExprType c, ExprType sa, ExprType sb) => - (a -> b -> c) -> Expr sa -> Expr sb -> Maybe (Expr c) -applyBinOp op x y = do - Refl :: a :~: sa <- eqT - Refl :: b :~: sb <- eqT - return $ op <$> x <*> y + Int -> (a -> b -> c) -> Expr sa -> Expr sb -> TestParser (Expr c) +applyBinOp off op x y = do + x' <- unifyExpr off (Proxy @a) x + y' <- unifyExpr off (Proxy @b) y + return $ op <$> x' <*> y' someExpr :: TestParser SomeExpr someExpr = join inner <?> "expression" @@ -208,11 +238,13 @@ someExpr = join inner <?> "expression" parens = between (symbol "(") (symbol ")") - term = parens inner <|> literal <|> variable <?> "term" + term = label "term" $ choice + [ parens inner + , return <$> literal + , return <$> functionCall + ] - table = [ [ recordSelector - ] - , [ prefix "-" $ [ SomeUnOp (negate @Integer) + table = [ [ prefix "-" $ [ SomeUnOp (negate @Integer) , SomeUnOp (negate @Scientific) ] ] @@ -236,12 +268,30 @@ someExpr = join inner <?> "expression" [ 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) + , SomeBinOp ((>) @Scientific) + ] + , binary ">=" $ + [ SomeBinOp ((>=) @Integer) + , SomeBinOp ((>=) @Scientific) + ] + , binary "<=" $ + [ SomeBinOp ((<=) @Integer) + , SomeBinOp ((<=) @Scientific) + ] + , binary "<" $ + [ SomeBinOp ((<) @Integer) + , SomeBinOp ((<) @Scientific) + ] ] ] @@ -251,9 +301,11 @@ someExpr = join inner <?> "expression" void $ osymbol name return $ \p -> do SomeExpr e <- p - let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat + let err = FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat [T.pack "operator '", T.pack name, T.pack "' not defined for '", textExprType e, T.pack "'"] - maybe err return $ listToMaybe $ catMaybes $ map (\(SomeUnOp op) -> SomeExpr <$> applyUnOp op e) ops + region (const err) $ + choice $ map (\(SomeUnOp op) -> SomeExpr <$> applyUnOp off op e) ops + binary :: String -> [SomeBinOp] -> Operator TestParser (TestParser SomeExpr) binary name = binary' name (undefined :: forall a b. (a -> b -> Void) -> [a] -> [b] -> Integer) @@ -278,53 +330,109 @@ someExpr = join inner <?> "expression" let proxyOf :: proxy a -> Proxy a proxyOf _ = Proxy + let err = FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat + [T.pack "operator '", T.pack name, T.pack "' not defined for '", textExprType e, T.pack "' and '", textExprType f, T.pack "'"] + let tryop :: forall a b d sa sb. (ExprType a, ExprType b, ExprType d, ExprType sa, ExprType sb) => - (a -> b -> d) -> Proxy sa -> Proxy sb -> Maybe SomeExpr - tryop op pe pf = msum - [ SomeExpr <$> applyBinOp op e f - , do Refl <- eqT' op - ExprListUnpacker _ une <- exprListUnpacker pe - ExprListUnpacker _ unf <- exprListUnpacker pf + (a -> b -> d) -> Proxy sa -> Proxy sb -> TestParser SomeExpr + tryop op pe pf = foldl1 (<|>) $ + [ SomeExpr <$> applyBinOp off op e f + , do Refl <- maybe (parseError err) return $ eqT' op + ExprListUnpacker _ une <- maybe (parseError err) return $ exprListUnpacker pe + ExprListUnpacker _ unf <- maybe (parseError err) return $ exprListUnpacker pf tryop (listmap op) (une pe) (unf pf) ] - let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat - [T.pack "operator '", T.pack name, T.pack "' not defined for '", textExprType e, T.pack "' and '", textExprType f, T.pack "'"] - maybe err return $ listToMaybe $ catMaybes $ map (\(SomeBinOp op) -> tryop op (proxyOf e) (proxyOf f)) ops - - recordSelector :: Operator TestParser (TestParser SomeExpr) - recordSelector = Postfix $ fmap (foldl1 (flip (.))) $ some $ do - void $ osymbol "." - off <- stateOffset <$> getParserState - m <- identifier - return $ \p -> do - SomeExpr e <- p - let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat - [ T.pack "value of type ", textExprType e, T.pack " does not have member '", m, T.pack "'" ] - maybe err return $ applyRecordSelector m e <$> lookup m recordMembers + region (const err) $ + foldl1 (<|>) $ map (\(SomeBinOp op) -> tryop op (proxyOf e) (proxyOf f)) ops +typedExpr :: forall a. ExprType a => TestParser (Expr a) +typedExpr = do + off <- stateOffset <$> getParserState + SomeExpr e <- someExpr + unifyExpr off Proxy e + +literal :: TestParser SomeExpr +literal = label "literal" $ choice + [ numberLiteral + , boolLiteral + , SomeExpr <$> quotedString + , SomeExpr <$> regex + , list + ] + +variable :: TestParser SomeExpr +variable = label "variable" $ do + off <- stateOffset <$> getParserState + sline <- getSourceLine + name <- varName + e <- lookupVarExpr off sline name + recordSelector e <|> return e + +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 + +recordSelector :: SomeExpr -> TestParser SomeExpr +recordSelector (SomeExpr expr) = do + void $ osymbol "." + off <- stateOffset <$> getParserState + m <- identifier + let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat + [ T.pack "value of type ", textExprType expr, T.pack " does not have member '", m, T.pack "'" ] + e' <- maybe err return $ applyRecordSelector m expr <$> lookup m recordMembers + recordSelector e' <|> return e' + where 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 + +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 + 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 x <- identifier + off <- stateOffset <$> getParserState + y <- pparam <|> (promote off =<< identifier) + checkAndInsert off (Just (ArgumentKeyword x)) y $ parseArgs allowUnnamed + + ,do return M.empty ] - variable = label "variable" $ do - name <- varName - SomeExprType (_ :: Proxy a) <- lookupVarType name - return $ return $ SomeExpr $ Variable @a name + pparam = between (symbol "(") (symbol ")") param <|> lit -typedExpr :: forall a. ExprType a => TestParser (Expr a) -typedExpr = do - off <- stateOffset <$> getParserState - SomeExpr e <- someExpr - let err = do - registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat - [ T.pack "expected '", textExprType @a Proxy, T.pack "', expression has type '", textExprType e, T.pack "'" ] - return $ Undefined "unexpected type" - maybe err return $ cast e + checkAndInsert off kw x cont = M.insert kw <$> check off kw x <*> cont diff --git a/src/Parser/Shell.hs b/src/Parser/Shell.hs new file mode 100644 index 0000000..89595e8 --- /dev/null +++ b/src/Parser/Shell.hs @@ -0,0 +1,81 @@ +module Parser.Shell ( + ShellScript, + shellScript, +) where + +import Control.Applicative (liftA2) +import Control.Monad + +import Data.Char +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL + +import Text.Megaparsec +import Text.Megaparsec.Char +import Text.Megaparsec.Char.Lexer qualified as L + +import Parser.Core +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 + [ doubleQuotedString + , singleQuotedString + , escapedChar + , stringExpansion + , unquotedString + ] + where + specialChars = [ '\"', '\\', '$' ] + + unquotedString :: TestParser (Expr Text) + unquotedString = do + Pure . TL.toStrict <$> takeWhile1P Nothing (\c -> not (isSpace c) && c `notElem` specialChars) + + doubleQuotedString :: TestParser (Expr Text) + doubleQuotedString = do + void $ char '"' + let inner = choice + [ char '"' >> return [] + , (:) <$> (Pure . TL.toStrict <$> takeWhile1P Nothing (`notElem` specialChars)) <*> inner + , (:) <$> escapedChar <*> inner + , (:) <$> stringExpansion <*> inner + ] + App AnnNone (Pure T.concat) . foldr (liftA2 (:)) (Pure []) <$> inner + + singleQuotedString :: TestParser (Expr Text) + singleQuotedString = do + Pure . TL.toStrict <$> (char '\'' *> takeWhileP Nothing (/= '\'') <* char '\'') + + escapedChar :: TestParser (Expr Text) + escapedChar = do + void $ char '\\' + Pure <$> choice + [ char '\\' >> return "\\" + , char '"' >> return "\"" + , char '$' >> return "$" + , char 'n' >> return "\n" + , char 'r' >> return "\r" + , char 't' >> return "\t" + ] + +parseArguments :: TestParser (Expr [ Text ]) +parseArguments = foldr (liftA2 (:)) (Pure []) <$> many parseArgument + +shellStatement :: TestParser (Expr [ ShellStatement ]) +shellStatement = label "shell statement" $ do + line <- getSourceLine + command <- parseArgument + args <- parseArguments + return $ fmap (: []) $ ShellStatement + <$> command + <*> args + <*> pure line + +shellScript :: TestParser (Expr ShellScript) +shellScript = do + indent <- L.indentLevel + fmap ShellScript <$> blockOf indent shellStatement diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs index b2f3cd6..474fa03 100644 --- a/src/Parser/Statement.hs +++ b/src/Parser/Statement.hs @@ -1,17 +1,19 @@ module Parser.Statement ( testStep, + testBlock, ) where import Control.Monad import Control.Monad.Identity import Control.Monad.State +import Data.Bifunctor import Data.Kind import Data.Maybe -import qualified Data.Set as S +import Data.Set qualified as S import Data.Text qualified as T -import qualified Data.Text.Lazy as TL import Data.Typeable +import Data.Void import Text.Megaparsec hiding (State) import Text.Megaparsec.Char @@ -20,21 +22,14 @@ import qualified Text.Megaparsec.Char.Lexer as L import Network (Network, Node) import Parser.Core import Parser.Expr +import Parser.Shell import Process (Process) +import Script.Expr +import Script.Expr.Class import Test import Util -getSourceLine :: TestParser SourceLine -getSourceLine = do - pstate <- statePosState <$> getParserState - return $ SourceLine $ T.concat - [ T.pack $ sourcePosPretty $ pstateSourcePos pstate - , T.pack ": " - , TL.toStrict $ TL.takeWhile (/='\n') $ pstateInput pstate - ] - - -letStatement :: TestParser [TestStep] +letStatement :: TestParser (Expr (TestBlock ())) letStatement = do line <- getSourceLine indent <- L.indentLevel @@ -49,11 +44,10 @@ letStatement = do addVarName off tname void $ eol body <- testBlock indent - return [Let line tname e body] + return $ Let line tname e (TestBlockStep EmptyTestBlock . Scope <$> body) -forStatement :: TestParser [TestStep] +forStatement :: TestParser (Expr (TestBlock ())) forStatement = do - line <- getSourceLine ref <- L.indentLevel wsymbol "for" voff <- stateOffset <$> getParserState @@ -73,12 +67,81 @@ forStatement = do let tname = TypedVarName name addVarName voff tname body <- testBlock indent - return [For line tname (unpack <$> e) body] + return $ (\xs f -> mconcat $ map f xs) + <$> (unpack <$> e) + <*> LambdaAbstraction tname (TestBlockStep EmptyTestBlock . Scope <$> body) -exprStatement :: TestParser [ TestStep ] -exprStatement = do - expr <- typedExpr - return [ ExprStatement expr ] +shellStatement :: TestParser (Expr (TestBlock ())) +shellStatement = do + ref <- L.indentLevel + wsymbol "shell" + parseParams ref Nothing Nothing + + where + parseParamKeyword kw prev = do + off <- stateOffset <$> getParserState + wsymbol kw + when (isJust prev) $ do + registerParseError $ FancyError off $ S.singleton $ ErrorFail $ + "unexpected parameter with keyword ‘" <> kw <> "’" + + parseParams ref mbpname mbnode = choice + [ do + parseParamKeyword "as" mbpname + pname <- newVarName + parseParams ref (Just pname) mbnode + + , do + parseParamKeyword "on" mbnode + node <- typedExpr + parseParams ref mbpname (Just node) + + , do + off <- stateOffset <$> getParserState + symbol ":" + node <- case mbnode of + Just node -> return node + Nothing -> do + registerParseError $ FancyError off $ S.singleton $ ErrorFail $ + "missing parameter with keyword ‘on’" + return $ Undefined "" + + void eol + void $ L.indentGuard scn GT ref + script <- shellScript + cont <- fmap Scope <$> testBlock ref + let expr | Just pname <- mbpname = LambdaAbstraction pname cont + | otherwise = const <$> cont + return $ TestBlockStep EmptyTestBlock <$> + (SpawnShell mbpname <$> node <*> script <*> expr) + ] + +exprStatement :: TestParser (Expr (TestBlock ())) +exprStatement = do + ref <- L.indentLevel + off <- stateOffset <$> getParserState + SomeExpr expr <- someExpr + choice + [ continuePartial off ref expr + , unifyExpr off Proxy expr + ] + where + continuePartial :: ExprType a => Int -> Pos -> Expr a -> TestParser (Expr (TestBlock ())) + continuePartial off ref expr = do + symbol ":" + void eol + (fun :: Expr (FunctionType (TestBlock ()))) <- unifyExpr off Proxy expr + scn + indent <- L.indentGuard scn GT ref + 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 + choice + [ continuePartial coff indent fun' + , unifyExpr coff Proxy fun' + ] class (Typeable a, Typeable (ParamRep a)) => ParamType a where type ParamRep a :: Type @@ -90,9 +153,18 @@ class (Typeable a, Typeable (ParamRep a)) => ParamType a where paramDefault :: proxy a -> TestParser (ParamRep a) paramDefault _ = mzero + paramNewVariables :: proxy a -> ParamRep a -> NewVariables + paramNewVariables _ _ = NoNewVariables + paramNewVariablesEmpty :: proxy a -> NewVariables + paramNewVariablesEmpty _ = NoNewVariables -- to keep type info for optional parameters + paramFromSomeExpr :: proxy a -> SomeExpr -> Maybe (ParamRep a) paramFromSomeExpr _ (SomeExpr e) = cast e + paramExpr :: ParamRep a -> Expr a + default paramExpr :: ParamRep a ~ a => ParamRep a -> Expr a + paramExpr = Pure + instance ParamType SourceLine where parseParam _ = mzero showParamType _ = "<source line>" @@ -100,9 +172,14 @@ instance ParamType SourceLine where 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 _ = typedExpr + 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 @@ -110,14 +187,20 @@ instance ParamType a => ParamType [a] where parseParam _ = listOf (parseParam @a Proxy) showParamType _ = showParamType @a Proxy ++ " [, " ++ showParamType @a Proxy ++ " ...]" paramDefault _ = return [] + paramNewVariables _ = foldr (<>) (paramNewVariablesEmpty @a Proxy) . fmap (paramNewVariables @a Proxy) + paramNewVariablesEmpty _ = paramNewVariablesEmpty @a Proxy paramFromSomeExpr _ se@(SomeExpr e) = cast e <|> ((:[]) <$> paramFromSomeExpr @a Proxy se) + paramExpr = sequenceA . fmap paramExpr instance ParamType a => ParamType (Maybe a) where type ParamRep (Maybe a) = Maybe (ParamRep a) parseParam _ = Just <$> parseParam @a Proxy showParamType _ = showParamType @a Proxy paramDefault _ = return Nothing + paramNewVariables _ = foldr (<>) (paramNewVariablesEmpty @a Proxy) . fmap (paramNewVariables @a Proxy) + paramNewVariablesEmpty _ = paramNewVariablesEmpty @a Proxy paramFromSomeExpr _ se = Just <$> paramFromSomeExpr @a Proxy se + paramExpr = sequenceA . fmap paramExpr instance (ParamType a, ParamType b) => ParamType (Either a b) where type ParamRep (Either a b) = Either (ParamRep a) (ParamRep b) @@ -130,62 +213,106 @@ instance (ParamType a, ParamType b) => ParamType (Either a b) where (_ : _) -> fail "" showParamType _ = showParamType @a Proxy ++ " or " ++ showParamType @b Proxy paramFromSomeExpr _ se = (Left <$> paramFromSomeExpr @a Proxy se) <|> (Right <$> paramFromSomeExpr @b Proxy se) + paramExpr = either (fmap Left . paramExpr) (fmap Right . paramExpr) + +instance ExprType a => ParamType (Traced a) where + type ParamRep (Traced a) = Expr a + parseParam _ = parseParam (Proxy @(Expr a)) + showParamType _ = showParamType (Proxy @(Expr a)) + paramExpr = Trace data SomeParam f = forall a. ParamType a => SomeParam (Proxy a) (f (ParamRep a)) -data CommandDef a = CommandDef [(String, SomeParam Proxy)] ([SomeParam Identity] -> a) +data NewVariables + = NoNewVariables + | forall a. ExprType a => SomeNewVariables [ TypedVarName a ] + +instance Semigroup NewVariables where + NoNewVariables <> x = x + x <> NoNewVariables = x + SomeNewVariables (xs :: [ TypedVarName a ]) <> SomeNewVariables (ys :: [ TypedVarName b ]) + | Just (Refl :: a :~: b) <- eqT = SomeNewVariables (xs <> ys) + | otherwise = error "new variables with different types" + +instance Monoid NewVariables where + mempty = NoNewVariables + +someParamVars :: Foldable f => SomeParam f -> NewVariables +someParamVars (SomeParam proxy rep) = foldr (\x nvs -> paramNewVariables proxy x <> nvs) (paramNewVariablesEmpty proxy) rep + +data CommandDef a = CommandDef [(String, SomeParam Proxy)] ([SomeParam Identity] -> Expr a) instance Functor CommandDef where - fmap f (CommandDef types ctor) = CommandDef types (f . ctor) + fmap f (CommandDef types ctor) = CommandDef types (fmap f . ctor) instance Applicative CommandDef where - pure x = CommandDef [] (\case [] -> x; _ -> error "command arguments mismatch") - CommandDef types1 ctor1 <*> CommandDef types2 ctor2 = - CommandDef (types1 ++ types2) $ \params -> - let (params1, params2) = splitAt (length types1) params - in ctor1 params1 $ ctor2 params2 + pure x = CommandDef [] (\case [] -> Pure x; _ -> error "command arguments mismatch") + CommandDef types1 ctor1 <*> CommandDef types2 ctor2 = + CommandDef (types1 ++ types2) $ \params -> + let (params1, params2) = splitAt (length types1) params + in ctor1 params1 <*> ctor2 params2 param :: forall a. ParamType a => String -> CommandDef a param name = CommandDef [(name, SomeParam (Proxy @a) Proxy)] $ \case - [SomeParam Proxy (Identity x)] -> fromJust $ cast x + [SomeParam Proxy (Identity x)] -> paramExpr $ fromJust $ cast x _ -> error "command arguments mismatch" -data ParamOrContext a +newtype ParamOrContext a = ParamOrContext { fromParamOrContext :: a } + deriving (Functor, Foldable, Traversable) instance ParamType a => ParamType (ParamOrContext a) where - type ParamRep (ParamOrContext a) = ParamRep a - parseParam _ = parseParam @a Proxy + type ParamRep (ParamOrContext a) = ParamOrContext (ParamRep a) + parseParam _ = ParamOrContext <$> parseParam @a Proxy showParamType _ = showParamType @a Proxy paramDefault _ = gets testContext >>= \case se@(SomeExpr ctx) - | Just e <- paramFromSomeExpr @a Proxy se -> return e + | Just e <- paramFromSomeExpr @a Proxy se -> return (ParamOrContext e) | otherwise -> fail $ showParamType @a Proxy <> " not available from context type '" <> T.unpack (textExprType ctx) <> "'" + paramExpr = sequenceA . fmap paramExpr paramOrContext :: forall a. ParamType a => String -> CommandDef a -paramOrContext name = CommandDef [(name, SomeParam (Proxy @(ParamOrContext a)) Proxy)] $ \case - [SomeParam Proxy (Identity x)] -> fromJust $ cast x - _ -> error "command arguments mismatch" +paramOrContext name = fromParamOrContext <$> param name cmdLine :: CommandDef SourceLine cmdLine = param "" -data InnerBlock +newtype InnerBlock a = InnerBlock { fromInnerBlock :: [ a ] -> TestBlock () } -instance ParamType InnerBlock where - type ParamRep InnerBlock = [TestStep] +instance ExprType a => ParamType (InnerBlock a) where + type ParamRep (InnerBlock a) = ( [ TypedVarName a ], Expr (TestBlock ()) ) parseParam _ = mzero showParamType _ = "<code block>" + paramExpr ( vars, expr ) = fmap InnerBlock $ helper vars $ const <$> expr + where + helper :: ExprType a => [ TypedVarName a ] -> Expr ([ a ] -> b) -> Expr ([ a ] -> b) + helper ( v : vs ) = fmap combine . LambdaAbstraction v . helper vs + helper [] = id -instance ParamType TestStep where - parseParam _ = mzero - showParamType _ = "<code line>" + combine f (x : xs) = f x xs + combine _ [] = error "inner block parameter count mismatch" -innerBlock :: CommandDef [TestStep] -innerBlock = CommandDef [("", SomeParam (Proxy @InnerBlock) Proxy)] $ \case - [SomeParam Proxy (Identity x)] -> fromJust $ cast x - _ -> error "command arguments mismatch" +innerBlock :: CommandDef (TestStep ()) +innerBlock = ($ ([] :: [ Void ])) <$> innerBlockFun -command :: String -> CommandDef TestStep -> TestParser [TestStep] +innerBlockFun :: ExprType a => CommandDef (a -> TestStep ()) +innerBlockFun = (\f x -> f [ x ]) <$> innerBlockFunList + +innerBlockFunList :: ExprType a => CommandDef ([ a ] -> TestStep ()) +innerBlockFunList = (\ib -> Scope . fromInnerBlock ib) <$> param "" + +newtype ExprParam a = ExprParam { fromExprParam :: a } + deriving (Functor, Foldable, Traversable) + +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 + unifyExpr off Proxy e + showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">" + paramExpr = fmap ExprParam + +command :: String -> CommandDef (TestStep ()) -> TestParser (Expr (TestBlock ())) command name (CommandDef types ctor) = do indent <- L.indentLevel line <- getSourceLine @@ -193,19 +320,24 @@ command name (CommandDef types ctor) = do localState $ do restOfLine indent [] line $ map (fmap $ \(SomeParam p@(_ :: Proxy p) Proxy) -> SomeParam p $ Nothing @(ParamRep p)) types where - restOfLine :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> SourceLine -> [(String, SomeParam Maybe)] -> TestParser [TestStep] + restOfLine :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> SourceLine -> [(String, SomeParam Maybe)] -> TestParser (Expr (TestBlock ())) restOfLine cmdi partials line params = choice [do void $ lookAhead eol + let definedVariables = mconcat $ map (someParamVars . snd) params iparams <- forM params $ \case (_, SomeParam (p :: Proxy p) Nothing) | Just (Refl :: p :~: SourceLine) <- eqT -> return $ SomeParam p $ Identity line - | Just (Refl :: p :~: InnerBlock) <- eqT -> SomeParam p . Identity <$> restOfParts cmdi partials + + | SomeNewVariables (vars :: [ TypedVarName a ]) <- definedVariables + , Just (Refl :: p :~: InnerBlock a) <- eqT + -> SomeParam p . Identity . ( vars, ) <$> restOfParts cmdi partials + (sym, SomeParam p Nothing) -> choice [ SomeParam p . Identity <$> paramDefault p , fail $ "missing " ++ (if null sym then "" else "'" ++ sym ++ "' ") ++ showParamType p ] (_, SomeParam (p :: Proxy p) (Just x)) -> return $ SomeParam p $ Identity x - return [ctor iparams] + return $ (TestBlockStep EmptyTestBlock) <$> ctor iparams ,do symbol ":" scn @@ -215,16 +347,16 @@ command name (CommandDef types ctor) = do ,do tryParams cmdi partials line [] params ] - restOfParts :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> TestParser [TestStep] + restOfParts :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> TestParser (Expr (TestBlock ())) restOfParts cmdi [] = testBlock cmdi restOfParts cmdi partials@((partIndent, params) : rest) = do scn pos <- L.indentLevel line <- getSourceLine optional eof >>= \case - Just _ -> return [] + Just _ -> return $ Pure mempty _ | pos < partIndent -> restOfParts cmdi rest - | pos == partIndent -> (++) <$> restOfLine cmdi partials line params <*> restOfParts cmdi partials + | pos == partIndent -> mappend <$> restOfLine cmdi partials line params <*> restOfParts cmdi partials | otherwise -> L.incorrectIndent EQ partIndent pos tryParam sym (SomeParam (p :: Proxy p) cur) = do @@ -241,7 +373,7 @@ command name (CommandDef types ctor) = do ] tryParams _ _ _ _ [] = mzero -testLocal :: TestParser [TestStep] +testLocal :: TestParser (Expr (TestBlock ())) testLocal = do ref <- L.indentLevel wsymbol "local" @@ -249,9 +381,10 @@ testLocal = do void $ eol indent <- L.indentGuard scn GT ref - localState $ testBlock indent + localState $ do + fmap (TestBlockStep EmptyTestBlock . Scope) <$> testBlock indent -testWith :: TestParser [TestStep] +testWith :: TestParser (Expr (TestBlock ())) testWith = do ref <- L.indentLevel wsymbol "with" @@ -259,12 +392,12 @@ testWith = do off <- stateOffset <$> getParserState ctx@(SomeExpr (_ :: Expr ctxe)) <- someExpr let expected = - [ SomeExprType @Network Proxy - , SomeExprType @Node Proxy - , SomeExprType @Process Proxy + [ ExprTypePrim @Network Proxy + , ExprTypePrim @Node Proxy + , ExprTypePrim @Process Proxy ] notAllowed <- flip allM expected $ \case - SomeExprType (Proxy :: Proxy a) | Just (Refl :: ctxe :~: a) <- eqT -> return False + ExprTypePrim (Proxy :: Proxy a) | Just (Refl :: ctxe :~: a) <- eqT -> return False _ -> return True when notAllowed $ registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ "expected " <> T.intercalate ", " (map (("'"<>) . (<>"'") . textSomeExprType) expected) <> ", expression has type '" <> textExprType @ctxe Proxy <> "'" @@ -275,96 +408,71 @@ 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 [TestStep] +testSubnet :: TestParser (Expr (TestBlock ())) testSubnet = command "subnet" $ Subnet <$> param "" - <*> paramOrContext "of" - <*> innerBlock + <*> (fromExprParam <$> paramOrContext "of") + <*> innerBlockFun -testNode :: TestParser [TestStep] +testNode :: TestParser (Expr (TestBlock ())) testNode = command "node" $ DeclNode <$> param "" - <*> paramOrContext "on" - <*> innerBlock + <*> (fromExprParam <$> paramOrContext "on") + <*> innerBlockFun -testSpawn :: TestParser [TestStep] +testSpawn :: TestParser (Expr (TestBlock ())) testSpawn = command "spawn" $ Spawn <$> param "as" - <*> paramOrContext "on" - <*> innerBlock - -testSend :: TestParser [TestStep] -testSend = command "send" $ Send - <$> paramOrContext "to" - <*> param "" + <*> (bimap fromExprParam fromExprParam <$> paramOrContext "on") + <*> (maybe [] fromExprParam <$> param "args") + <*> innerBlockFun -testExpect :: TestParser [TestStep] +testExpect :: TestParser (Expr (TestBlock ())) testExpect = command "expect" $ Expect <$> cmdLine - <*> paramOrContext "from" + <*> (fromExprParam <$> paramOrContext "from") <*> param "" <*> param "capture" - <*> innerBlock - -testFlush :: TestParser [TestStep] -testFlush = command "flush" $ Flush - <$> paramOrContext "from" - <*> param "" - -testGuard :: TestParser [TestStep] -testGuard = command "guard" $ Guard - <$> cmdLine - <*> param "" + <*> innerBlockFunList -testDisconnectNode :: TestParser [TestStep] +testDisconnectNode :: TestParser (Expr (TestBlock ())) testDisconnectNode = command "disconnect_node" $ DisconnectNode - <$> paramOrContext "" + <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testDisconnectNodes :: TestParser [TestStep] +testDisconnectNodes :: TestParser (Expr (TestBlock ())) testDisconnectNodes = command "disconnect_nodes" $ DisconnectNodes - <$> paramOrContext "" + <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testDisconnectUpstream :: TestParser [TestStep] +testDisconnectUpstream :: TestParser (Expr (TestBlock ())) testDisconnectUpstream = command "disconnect_upstream" $ DisconnectUpstream - <$> paramOrContext "" + <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testPacketLoss :: TestParser [TestStep] +testPacketLoss :: TestParser (Expr (TestBlock ())) testPacketLoss = command "packet_loss" $ PacketLoss - <$> param "" - <*> paramOrContext "on" + <$> (fromExprParam <$> paramOrContext "") + <*> (fromExprParam <$> paramOrContext "on") <*> innerBlock -testBlock :: Pos -> TestParser [TestStep] -testBlock indent = concat <$> go - where - go = do - scn - pos <- L.indentLevel - optional eof >>= \case - Just _ -> return [] - _ | pos < indent -> return [] - | pos == indent -> (:) <$> testStep <*> go - | otherwise -> L.incorrectIndent EQ indent pos +testBlock :: Pos -> TestParser (Expr (TestBlock ())) +testBlock indent = blockOf indent testStep -testStep :: TestParser [TestStep] +testStep :: TestParser (Expr (TestBlock ())) testStep = choice [ letStatement , forStatement + , shellStatement , testLocal , testWith , testSubnet , testNode , testSpawn - , testSend , testExpect - , testFlush - , testGuard , testDisconnectNode , testDisconnectNodes , testDisconnectUpstream |