summaryrefslogtreecommitdiff
path: root/src/Parser
diff options
context:
space:
mode:
Diffstat (limited to 'src/Parser')
-rw-r--r--src/Parser/Core.hs337
-rw-r--r--src/Parser/Expr.hs330
-rw-r--r--src/Parser/Shell.hs170
-rw-r--r--src/Parser/Statement.hs174
4 files changed, 804 insertions, 207 deletions
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index 5fb4c5f..78fc666 100644
--- a/src/Parser/Core.hs
+++ b/src/Parser/Core.hs
@@ -1,51 +1,106 @@
module Parser.Core where
import Control.Applicative
+import Control.Arrow
import Control.Monad
-import Control.Monad.Identity
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
-import Data.Void
import Text.Megaparsec hiding (State)
import Text.Megaparsec.Char
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 Void TestStream Identity) a)
+newtype TestParser a = TestParser (StateT TestParserState (ParsecT CustomTestError TestStream IO) a)
deriving
( Functor, Applicative, Alternative, Monad
, MonadState TestParserState
, MonadPlus
, MonadFail
- , MonadParsec Void TestStream
+ , MonadIO
+ , MonadParsec CustomTestError 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
+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)
+
+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
+
+ 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 (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
data Toplevel
= ToplevelTest Test
| ToplevelDefinition ( VarName, SomeExpr )
+ | ToplevelExport VarName
+ | ToplevelImport ( ModuleName, VarName )
data TestParserState = TestParserState
- { testVars :: [ ( VarName, SomeExprType ) ]
+ { testSourcePath :: FilePath
+ , testVars :: [ ( VarName, ( FqVarName, SomeExprType )) ]
+ , testTypeVars :: [ ( VarName, SomeExprType ) ]
, testContext :: SomeExpr
, testNextTypeVar :: Int
, testTypeUnif :: Map TypeVar SomeExprType
+ , testCurrentModuleName :: ModuleName
+ , testParseModule :: ModuleName -> ModuleName -> IO (Either CustomTestError Module)
}
newTypeVar :: TestParser TypeVar
@@ -54,25 +109,77 @@ newTypeVar = do
modify $ \s -> s { testNextTypeVar = idx + 1 }
return $ TypeVar $ T.pack $ 'a' : show idx
-lookupVarType :: Int -> VarName -> TestParser SomeExprType
+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
- modify $ \s -> s { testVars = ( name, vtype ) : testVars s }
- return vtype
- Just t@(ExprTypeVar tvar) -> do
- gets (fromMaybe t . M.lookup tvar . testTypeUnif)
+ 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
- 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))
+ ( fqn, etype ) <- lookupVarType off name
+ case etype of
+ ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline fqn :: Expr 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)
+ 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
@@ -129,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)
@@ -139,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
+ 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)) (ExprTypeVar tvar)
+ _ <- 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
@@ -169,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 ()
@@ -193,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
@@ -204,23 +433,26 @@ localState inner = do
put s { testNextTypeVar = testNextTypeVar s', testTypeUnif = testTypeUnif s' }
return x
-toplevel :: (a -> Toplevel) -> TestParser a -> TestParser Toplevel
+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
(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
@@ -230,3 +462,12 @@ getSourceLine = do
, 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 5ff3f15..b2c6b84 100644
--- a/src/Parser/Expr.hs
+++ b/src/Parser/Expr.hs
@@ -1,17 +1,27 @@
module Parser.Expr (
identifier,
+ parseModuleName,
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)
@@ -34,11 +44,10 @@ import Text.Megaparsec hiding (State)
import Text.Megaparsec.Char
import Text.Megaparsec.Char.Lexer qualified as L
import Text.Megaparsec.Error.Builder qualified as Err
-import Text.Regex.TDFA qualified as RE
-import Text.Regex.TDFA.Text qualified as RE
import Parser.Core
-import Test
+import Script.Expr
+import Script.Expr.Class
reservedWords :: [ Text ]
reservedWords =
@@ -58,6 +67,11 @@ identifier = label "identifier" $ do
]
return ident
+parseModuleName :: TestParser ModuleName
+parseModuleName = do
+ x <- identifier
+ ModuleName . (x :) <$> many (symbol "." >> identifier)
+
varName :: TestParser VarName
varName = label "variable name" $ VarName <$> identifier
@@ -69,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, 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
@@ -83,20 +107,26 @@ someExpansion = do
[do off <- stateOffset <$> getParserState
sline <- getSourceLine
name <- VarName . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_')
- lookupVarExpr off sline name
- , between (char '{') (char '}') someExpr
+ lookupScalarVarExpr off sline name
+ , between (char '{') (char '}') (someExpr FunctionTerm)
]
-stringExpansion :: ExprType a => Text -> (forall b. ExprType b => Expr b -> [Maybe (Expr a)]) -> TestParser (Expr a)
-stringExpansion tname conv = 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 "'" ]
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 ]
+
+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"
numberLiteral :: TestParser SomeExpr
numberLiteral = label "number" $ lexeme $ do
@@ -108,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 '"'
@@ -124,11 +161,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
@@ -136,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
@@ -146,19 +179,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 ()
@@ -167,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)
+ ]
]
]
@@ -223,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
@@ -256,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)
@@ -297,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
@@ -337,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
@@ -359,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
@@ -383,22 +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 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
@@ -415,22 +501,10 @@ functionArguments check param lit promote = do
[ 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 x <- identifier
+ off <- stateOffset <$> getParserState
+ y <- pparam <|> (promote off =<< identifier)
+ checkAndInsert off (Just (ArgumentKeyword x)) y $ parseArgs allowUnnamed
,do return M.empty
]
@@ -438,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
new file mode 100644
index 0000000..2d6026a
--- /dev/null
+++ b/src/Parser/Shell.hs
@@ -0,0 +1,170 @@
+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
+
+parseTextArgument :: TestParser (Expr Text)
+parseTextArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:)) (Pure [])) $ some $ choice
+ [ doubleQuotedString
+ , singleQuotedString
+ , standaloneEscapedChar
+ , stringExpansion
+ , unquotedString
+ ]
+ where
+ specialChars = [ '"', '\'', '\\', '$', '#', '|', '>', '<', ';', '[', ']'{-, '{', '}' -}, '(', ')'{-, '*', '?', '~', '&', '!' -} ]
+
+ stringSpecialChars = [ '"', '\\', '$' ]
+
+ 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` stringSpecialChars)) <*> inner
+ , (:) <$> stringEscapedChar <*> 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 '\'')
+
+ stringEscapedChar :: TestParser (Expr Text)
+ stringEscapedChar = do
+ void $ char '\\'
+ 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 "\\"
+ ]
+
+ 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
+
+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 parseStatement
diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs
index 4bed1ef..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
@@ -21,11 +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
-letStatement :: TestParser (Expr TestBlock)
+letStatement :: TestParser (Expr (TestBlock ()))
letStatement = do
line <- getSourceLine
indent <- L.indentLevel
@@ -33,16 +37,16 @@ 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 :: TestParser (Expr (TestBlock ()))
forStatement = do
ref <- L.indentLevel
wsymbol "for"
@@ -51,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
@@ -65,30 +70,75 @@ forStatement = do
body <- testBlock indent
return $ (\xs f -> mconcat $ map f xs)
<$> (unpack <$> e)
- <*> LambdaAbstraction tname body
+ <*> LambdaAbstraction tname (TestBlockStep EmptyTestBlock . Scope <$> body)
-exprStatement :: TestParser (Expr TestBlock)
+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 SimpleTerm
+ 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
+ SomeExpr expr <- someExpr FunctionTerm
choice
[ continuePartial off ref expr
, unifyExpr off Proxy expr
]
where
- continuePartial :: ExprType a => Int -> Pos -> Expr a -> TestParser (Expr TestBlock)
+ 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
+ (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
+ 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'
@@ -120,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 <|> variable <|> 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)
@@ -168,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))
@@ -227,10 +276,13 @@ paramOrContext name = fromParamOrContext <$> param name
cmdLine :: CommandDef SourceLine
cmdLine = param ""
-newtype InnerBlock a = InnerBlock { fromInnerBlock :: [ a ] -> TestBlock }
+callStack :: CommandDef CallStack
+callStack = param ""
+
+newtype InnerBlock a = InnerBlock { fromInnerBlock :: [ a ] -> TestBlock () }
instance ExprType a => ParamType (InnerBlock a) where
- type ParamRep (InnerBlock a) = ( [ TypedVarName a ], Expr TestBlock )
+ type ParamRep (InnerBlock a) = ( [ TypedVarName a ], Expr (TestBlock ()) )
parseParam _ = mzero
showParamType _ = "<code block>"
paramExpr ( vars, expr ) = fmap InnerBlock $ helper vars $ const <$> expr
@@ -242,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)
@@ -258,12 +310,12 @@ 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
-command :: String -> CommandDef TestStep -> TestParser (Expr TestBlock)
+command :: String -> CommandDef (TestStep ()) -> TestParser (Expr (TestBlock ()))
command name (CommandDef types ctor) = do
indent <- L.indentLevel
line <- getSourceLine
@@ -271,24 +323,28 @@ 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 (Expr TestBlock)
+ 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 :~: 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
]
(_, SomeParam (p :: Proxy p) (Just x)) -> return $ SomeParam p $ Identity x
- return $ (TestBlock . (: [])) <$> ctor iparams
+ return $ (TestBlockStep EmptyTestBlock) <$> ctor iparams
,do symbol ":"
scn
@@ -298,7 +354,7 @@ command name (CommandDef types ctor) = do
,do tryParams cmdi partials line [] params
]
- restOfParts :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> TestParser (Expr TestBlock)
+ restOfParts :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> TestParser (Expr (TestBlock ()))
restOfParts cmdi [] = testBlock cmdi
restOfParts cmdi partials@((partIndent, params) : rest) = do
scn
@@ -324,7 +380,7 @@ command name (CommandDef types ctor) = do
]
tryParams _ _ _ _ [] = mzero
-testLocal :: TestParser (Expr TestBlock)
+testLocal :: TestParser (Expr (TestBlock ()))
testLocal = do
ref <- L.indentLevel
wsymbol "local"
@@ -332,15 +388,16 @@ 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 :: TestParser (Expr (TestBlock ()))
testWith = do
ref <- L.indentLevel
wsymbol "with"
off <- stateOffset <$> getParserState
- ctx@(SomeExpr (_ :: Expr ctxe)) <- someExpr
+ ctx@(SomeExpr (_ :: Expr ctxe)) <- someExpr SimpleTerm
let expected =
[ ExprTypePrim @Network Proxy
, ExprTypePrim @Node Proxy
@@ -358,75 +415,68 @@ 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 :: TestParser (Expr (TestBlock ()))
testSubnet = command "subnet" $ Subnet
<$> param ""
<*> (fromExprParam <$> paramOrContext "of")
<*> innerBlockFun
-testNode :: TestParser (Expr TestBlock)
+testNode :: TestParser (Expr (TestBlock ()))
testNode = command "node" $ DeclNode
<$> param ""
<*> (fromExprParam <$> paramOrContext "on")
<*> innerBlockFun
-testSpawn :: TestParser (Expr TestBlock)
+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 :: TestParser (Expr (TestBlock ()))
testExpect = command "expect" $ Expect
- <$> cmdLine
+ <$> callStack
+ <*> cmdLine
<*> (fromExprParam <$> paramOrContext "from")
<*> param ""
+ <*> (maybe 1 fromExprParam <$> param "timeout")
<*> param "capture"
<*> innerBlockFunList
-testDisconnectNode :: TestParser (Expr TestBlock)
+testDisconnectNode :: TestParser (Expr (TestBlock ()))
testDisconnectNode = command "disconnect_node" $ DisconnectNode
<$> (fromExprParam <$> paramOrContext "")
<*> innerBlock
-testDisconnectNodes :: TestParser (Expr TestBlock)
+testDisconnectNodes :: TestParser (Expr (TestBlock ()))
testDisconnectNodes = command "disconnect_nodes" $ DisconnectNodes
<$> (fromExprParam <$> paramOrContext "")
<*> innerBlock
-testDisconnectUpstream :: TestParser (Expr TestBlock)
+testDisconnectUpstream :: TestParser (Expr (TestBlock ()))
testDisconnectUpstream = command "disconnect_upstream" $ DisconnectUpstream
<$> (fromExprParam <$> paramOrContext "")
<*> innerBlock
-testPacketLoss :: TestParser (Expr TestBlock)
+testPacketLoss :: TestParser (Expr (TestBlock ()))
testPacketLoss = command "packet_loss" $ PacketLoss
<$> (fromExprParam <$> paramOrContext "")
<*> (fromExprParam <$> paramOrContext "on")
<*> innerBlock
-testBlock :: Pos -> TestParser (Expr TestBlock)
+testBlock :: Pos -> TestParser (Expr (TestBlock ()))
testBlock indent = blockOf indent testStep
-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
-
-testStep :: TestParser (Expr TestBlock)
+testStep :: TestParser (Expr (TestBlock ()))
testStep = choice
[ letStatement
, forStatement
+ , shellStatement
, testLocal
, testWith
, testSubnet
generated by cgit v1.2.3 (git 2.25.1) at 2026-09-11 19:33:01 +0000