summaryrefslogtreecommitdiff
path: root/src/Parser
diff options
context:
space:
mode:
Diffstat (limited to 'src/Parser')
-rw-r--r--src/Parser/Core.hs171
-rw-r--r--src/Parser/Expr.hs210
-rw-r--r--src/Parser/Statement.hs84
3 files changed, 355 insertions, 110 deletions
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index 2a74d3d..10a572b 100644
--- a/src/Parser/Core.hs
+++ b/src/Parser/Core.hs
@@ -1,11 +1,17 @@
module Parser.Core where
+import Control.Applicative
import Control.Monad
+import Control.Monad.Identity
import Control.Monad.State
-import Control.Monad.Writer
-import Data.Text (Text)
-import qualified Data.Text.Lazy as TL
+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 Data.Void
import Text.Megaparsec hiding (State)
@@ -15,23 +21,156 @@ import qualified Text.Megaparsec.Char.Lexer as L
import Network ()
import Test
-type TestParser = ParsecT Void TestStream (WriterT [ Toplevel ] (State TestParserState))
+newtype TestParser a = TestParser (StateT TestParserState (ParsecT Void TestStream Identity) a)
+ deriving
+ ( Functor, Applicative, Alternative, Monad
+ , MonadState TestParserState
+ , MonadPlus
+ , MonadFail
+ , MonadParsec Void TestStream
+ )
type TestStream = TL.Text
+type TestParseError = ParseError TestStream Void
+
+runTestParser :: String -> TestStream -> TestParserState -> TestParser a -> Either (ParseErrorBundle TestStream Void) a
+runTestParser path content initState (TestParser parser) = runIdentity . flip (flip runParserT path) content . flip evalStateT initState $ parser
+
data Toplevel
= ToplevelTest Test
+ | ToplevelDefinition ( VarName, SomeVarValue )
data TestParserState = TestParserState
- { testVars :: [(VarName, SomeExprType)]
+ { testVars :: [ ( VarName, SomeExprType ) ]
, testContext :: SomeExpr
+ , testNextTypeVar :: Int
+ , testTypeUnif :: Map TypeVar SomeExprType
}
-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 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
+ modify $ \s -> s { testVars = ( name, vtype ) : testVars s }
+ return vtype
+ Just t@(ExprTypeVar tvar) -> do
+ gets (fromMaybe t . M.lookup tvar . testTypeUnif)
+ Just x -> return x
+
+lookupVarExpr :: Int -> SourceLine -> VarName -> TestParser SomeExpr
+lookupVarExpr off sline name = do
+ lookupVarType off name >>= \case
+ ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline name :: Expr a)
+ ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar sline name
+ ExprTypeFunction args (_ :: Proxy a) -> return $ SomeExpr $ (FunVariable args sline name :: 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 "#"
@@ -64,8 +203,8 @@ localState inner = do
put s
return x
-toplevel :: (a -> Toplevel) -> TestParser a -> TestParser ()
-toplevel f = tell . (: []) . f <=< L.nonIndented scn
+toplevel :: (a -> Toplevel) -> TestParser a -> TestParser Toplevel
+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 +219,13 @@ listOf :: TestParser a -> TestParser [a]
listOf item = do
x <- item
(x:) <$> choice [ symbol "," >> listOf item, return [] ]
+
+
+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
+ ]
diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs
index 8ea3ace..4ed0215 100644
--- a/src/Parser/Expr.hs
+++ b/src/Parser/Expr.hs
@@ -7,6 +7,11 @@ module Parser.Expr (
someExpr,
typedExpr,
+ literal,
+ variable,
+
+ checkFunctionArguments,
+ functionArguments,
) where
import Control.Applicative (liftA2)
@@ -15,12 +20,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
@@ -34,11 +40,14 @@ import Parser.Core
import Test
identifier :: TestParser Text
-identifier = do
- lexeme $ TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_')
+identifier = label "identifier" $ do
+ lexeme $ do
+ lead <- lowerChar
+ rest <- takeWhileP Nothing (\x -> isAlphaNum x || x == '_')
+ return $ TL.toStrict $ TL.fromChunks $ (T.singleton lead :) $ TL.toChunks rest
varName :: TestParser VarName
-varName = VarName <$> identifier
+varName = label "variable name" $ VarName <$> identifier
newVarName :: forall a. ExprType a => TestParser (TypedVarName a)
newVarName = do
@@ -53,15 +62,16 @@ 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, 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 == '_')
+ lookupVarExpr off sline name
, between (char '{') (char '}') someExpr
]
@@ -186,20 +196,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 +218,13 @@ 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
- ]
- , [ prefix "-" $ [ SomeUnOp (negate @Integer)
+ table = [ [ prefix "-" $ [ SomeUnOp (negate @Integer)
, SomeUnOp (negate @Scientific)
]
]
@@ -242,6 +254,22 @@ someExpr = join inner <?> "expression"
, SomeBinOp ((/=) @Scientific)
, SomeBinOp ((/=) @Text)
]
+ , binary ">" $
+ [ SomeBinOp ((>) @Integer)
+ , SomeBinOp ((>) @Scientific)
+ ]
+ , binary ">=" $
+ [ SomeBinOp ((>=) @Integer)
+ , SomeBinOp ((>=) @Scientific)
+ ]
+ , binary "<=" $
+ [ SomeBinOp ((<=) @Integer)
+ , SomeBinOp ((<=) @Scientific)
+ ]
+ , binary "<" $
+ [ SomeBinOp ((<) @Integer)
+ , SomeBinOp ((<) @Scientific)
+ ]
]
]
@@ -251,9 +279,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 +308,117 @@ 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
+ region (const err) $
+ foldl1 (<|>) $ map (\(SomeBinOp op) -> tryop op (proxyOf e) (proxyOf f)) ops
- recordSelector :: Operator TestParser (TestParser SomeExpr)
- recordSelector = Postfix $ fmap (foldl1 (flip (.))) $ some $ do
+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
+ , SomeExpr <$> quotedString
+ , SomeExpr <$> regex
+ , list
+ ]
+
+variable :: TestParser SomeExpr
+variable = label "variable" $ do
+ off <- stateOffset <$> getParserState
+ sline <- getSourceLine
+ name <- varName
+ lookupVarExpr off sline name >>= \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 -> do
+ recordSelector e <|> return e
+
+ where
+ recordSelector :: SomeExpr -> TestParser SomeExpr
+ recordSelector (SomeExpr e) = 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
+ 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 "'" ]
+ e' <- maybe err return $ applyRecordSelector m e <$> lookup m recordMembers
+ recordSelector e' <|> return e'
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 expr = do
+ case M.lookup kw argTypes of
+ Just (SomeArgumentType (_ :: ArgumentType expected)) -> do
+ withRecovery registerParseError $ do
+ void $ unify poff (ExprTypePrim (Proxy @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
+
+
+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
]
- 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/Statement.hs b/src/Parser/Statement.hs
index b2f3cd6..c7cdf5a 100644
--- a/src/Parser/Statement.hs
+++ b/src/Parser/Statement.hs
@@ -8,9 +8,8 @@ import Control.Monad.State
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 Text.Megaparsec hiding (State)
@@ -24,16 +23,6 @@ import Process (Process)
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 = do
line <- getSourceLine
@@ -76,9 +65,34 @@ forStatement = do
return [For line tname (unpack <$> e) body]
exprStatement :: TestParser [ TestStep ]
-exprStatement = do
- expr <- typedExpr
- return [ ExprStatement expr ]
+exprStatement = do
+ ref <- L.indentLevel
+ off <- stateOffset <$> getParserState
+ SomeExpr expr <- someExpr
+ choice
+ [ do
+ continuePartial off ref expr
+ , do
+ stmt <- unifyExpr off Proxy expr
+ return [ ExprStatement stmt ]
+ ]
+ where
+ continuePartial :: ExprType a => Int -> Pos -> Expr a -> TestParser [ TestStep ]
+ 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'
+ , (: []) . ExprStatement <$> unifyExpr coff Proxy fun'
+ ]
class (Typeable a, Typeable (ParamRep a)) => ParamType a where
type ParamRep a :: Type
@@ -102,7 +116,10 @@ instance ExprType a => ParamType (TypedVarName a) where
showParamType _ = "<variable>"
instance ExprType a => ParamType (Expr a) where
- parseParam _ = typedExpr
+ parseParam _ = do
+ off <- stateOffset <$> getParserState
+ SomeExpr e <- literal <|> variable <|> between (symbol "(") (symbol ")") someExpr
+ unifyExpr off Proxy e
showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">"
instance ParamType a => ParamType [a] where
@@ -259,12 +276,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 <> "'"
@@ -295,11 +312,6 @@ testSpawn = command "spawn" $ Spawn
<*> paramOrContext "on"
<*> innerBlock
-testSend :: TestParser [TestStep]
-testSend = command "send" $ Send
- <$> paramOrContext "to"
- <*> param ""
-
testExpect :: TestParser [TestStep]
testExpect = command "expect" $ Expect
<$> cmdLine
@@ -308,16 +320,6 @@ testExpect = command "expect" $ Expect
<*> param "capture"
<*> innerBlock
-testFlush :: TestParser [TestStep]
-testFlush = command "flush" $ Flush
- <$> paramOrContext "from"
- <*> param ""
-
-testGuard :: TestParser [TestStep]
-testGuard = command "guard" $ Guard
- <$> cmdLine
- <*> param ""
-
testDisconnectNode :: TestParser [TestStep]
testDisconnectNode = command "disconnect_node" $ DisconnectNode
<$> paramOrContext ""
@@ -340,8 +342,11 @@ testPacketLoss = command "packet_loss" $ PacketLoss
<*> innerBlock
-testBlock :: Pos -> TestParser [TestStep]
-testBlock indent = concat <$> go
+testBlock :: Pos -> TestParser [ TestStep ]
+testBlock indent = blockOf indent testStep
+
+blockOf :: Pos -> TestParser [ a ] -> TestParser [ a ]
+blockOf indent step = concat <$> go
where
go = do
scn
@@ -349,7 +354,7 @@ testBlock indent = concat <$> go
optional eof >>= \case
Just _ -> return []
_ | pos < indent -> return []
- | pos == indent -> (:) <$> testStep <*> go
+ | pos == indent -> (:) <$> step <*> go
| otherwise -> L.incorrectIndent EQ indent pos
testStep :: TestParser [TestStep]
@@ -361,10 +366,7 @@ testStep = choice
, testSubnet
, testNode
, testSpawn
- , testSend
, testExpect
- , testFlush
- , testGuard
, testDisconnectNode
, testDisconnectNodes
, testDisconnectUpstream
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-10 05:10:54 +0000