diff options
| -rw-r--r-- | erebos-tester.cabal | 3 | ||||
| -rw-r--r-- | src/Parser.hs | 200 |
2 files changed, 103 insertions, 100 deletions
diff --git a/erebos-tester.cabal b/erebos-tester.cabal index ea82eb0..37d316b 100644 --- a/erebos-tester.cabal +++ b/erebos-tester.cabal @@ -40,8 +40,7 @@ executable erebos-tester-core Test Util other-extensions: TemplateHaskell - default-extensions: DeriveGeneric - ExistentialQuantification + default-extensions: ExistentialQuantification FlexibleContexts FlexibleInstances GADTs diff --git a/src/Parser.hs b/src/Parser.hs index 5a5ec28..2ab64ef 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -6,8 +6,8 @@ module Parser ( parseTestFile, ) where -import Control.Lens (Lens', makeLenses, (^.), (.~)) import Control.Monad.Combinators.Expr +import Control.Monad.Identity import Control.Monad.State import Data.Char @@ -21,9 +21,6 @@ import qualified Data.Text.Lazy.IO as TL import Data.Typeable import Data.Void -import Generics.Deriving.Base (Generic, Rep, U1(..), M1(..), K1(..), (:*:)(..)) -import Generics.Deriving.Base qualified as G - import Text.Megaparsec hiding (State) import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L @@ -57,8 +54,7 @@ scn :: TestParser () scn = L.space space1 skipLineComment empty sc :: TestParser () -sc = L.space (void $ takeWhile1P Nothing f) skipLineComment empty - where f x = x == ' ' || x == '\t' +sc = L.space hspace1 skipLineComment empty wordChar :: TestParser (Token TestStream) wordChar = alphaNumChar <|> char '_' @@ -276,14 +272,6 @@ typedExpr = do maybe err return $ cast e -class GInit f where ginit :: f x -instance GInit U1 where ginit = U1 -instance GInit (K1 i (Maybe a)) where ginit = K1 Nothing -instance GInit f => GInit (M1 i c f) where ginit = M1 ginit -instance (GInit f, GInit h) => GInit (f :*: h) where ginit = ginit :*: ginit - -data Param a = forall b. Param String (Lens' a (Maybe b)) (TestParser b) - getSourceLine :: TestParser SourceLine getSourceLine = do pstate <- statePosState <$> getParserState @@ -307,104 +295,120 @@ letStatement = do return [Let line name e] -command :: (Generic b, GInit (Rep b)) => String -> [Param b] -> (SourceLine -> b -> TestParser a) -> TestParser [a] -command name params fin = do - origline <- getSourceLine - wsymbol name - let blockHelper line prev cur = L.indentBlock scn $ helper line prev cur - helper line prev cur = choice $ concat - [[ do void $ eol - L.IndentNone . (:[]) <$> fin line cur - ] - ,[ do void $ lexeme (char ':') - return $ L.IndentSome Nothing (return . concat) $ do - line' <- getSourceLine - blockHelper line' prev cur - ] - , flip map params $ \(Param sym l p) -> do - x <- if null sym - then do - x <- p - when (any null prev) $ do - fail $ "multiple unnamed parameters" - return x - else do - wsymbol sym - when (any (== sym) prev) $ do - fail $ "multiple '" ++ sym ++ "' parameters" - p - helper line (sym:prev) (l .~ Just x $ cur) - ] +class Typeable a => ParamType a where + parseParam :: TestParser a + showParamType :: proxy a -> String - blockHelper origline [] (G.to ginit) + paramDefault :: TestParser a + paramDefault = mzero +instance ParamType SourceLine where + parseParam = mzero + showParamType _ = "<source line>" -data SpawnBuilder = SpawnBuilder - { _spawnBuilderProc :: Maybe ProcName - , _spawnBuilderNode :: Maybe NodeName - } - deriving (Generic) +instance ParamType NodeName where + parseParam = nodeName + showParamType _ = "<node>" -makeLenses ''SpawnBuilder +instance ParamType ProcName where + parseParam = procName + showParamType _ = "<proc>" -testSpawn :: TestParser [TestStep] -testSpawn = command "spawn" - [ Param "on" spawnBuilderNode nodeName - , Param "as" spawnBuilderProc procName - ] $ \_ b -> Spawn - <$> (maybe (fail "missing 'as' <proc>") return $ b ^. spawnBuilderProc) - <*> (maybe (fail "missing 'on' <node>") return $ b ^. spawnBuilderNode) +instance ParamType VarName where + parseParam = newVarName @Text Proxy + showParamType _ = "<variable>" +instance ExprType a => ParamType (Expr a) where + parseParam = typedExpr + showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">" -data SendBuilder = SendBuilder - { _sendBuilderProc :: Maybe ProcName - , _sendBuilderLine :: Maybe (Expr Text) - } - deriving (Generic) +instance ParamType a => ParamType [a] where + parseParam = listOf parseParam + showParamType _ = showParamType @a Proxy ++ " [, " ++ showParamType @a Proxy ++ " ...]" + paramDefault = return [] -makeLenses ''SendBuilder +data SomeParam f = forall a. ParamType a => SomeParam (f a) -testSend :: TestParser [TestStep] -testSend = command "send" - [ Param "to" sendBuilderProc procName - , Param "" sendBuilderLine quotedString - ] $ \_ b -> Send - <$> (maybe (fail "missing 'to' <proc>") return $ b ^. sendBuilderProc) - <*> (maybe (fail "missing line to send") return $ b ^. sendBuilderLine) - - -data ExpectBuilder = ExpectBuilder - { _expectBuilderProc :: Maybe ProcName - , _expectBuilderRegex :: Maybe (Expr Regex) - , _expectBuilderCaptures :: Maybe [VarName] - } - deriving (Generic) +data CommandDef a = CommandDef [(String, SomeParam Proxy)] ([SomeParam Identity] -> a) -makeLenses ''ExpectBuilder +instance Functor CommandDef where + fmap f (CommandDef types ctor) = CommandDef types (f . ctor) -testExpect :: TestParser [TestStep] -testExpect = command "expect" - [ Param "from" expectBuilderProc procName - , Param "" expectBuilderRegex regex - , Param "capture" expectBuilderCaptures (listOf $ newVarName @Text Proxy) - ] $ \s b -> Expect s - <$> (maybe (fail "missing 'from' <proc>") return $ b ^. expectBuilderProc) - <*> (maybe (fail "missing regex to match") return $ b ^. expectBuilderRegex) - <*> (maybe (return []) return $ b ^. expectBuilderCaptures) - - -data GuardBuilder = GuardBuilder - { _guardBuilderExpr :: Maybe (Expr Bool) - } - deriving (Generic) +instance Applicative CommandDef where + pure x = CommandDef [] (\[] -> x) + CommandDef types1 ctor1 <*> CommandDef types2 ctor2 = + CommandDef (types1 ++ types2) $ \params -> + let (params1, params2) = splitAt (length types1) params + in ctor1 params1 $ ctor2 params2 -makeLenses ''GuardBuilder +param :: forall a. ParamType a => String -> CommandDef a +param name = CommandDef [(name, SomeParam (Proxy @a))] (\[SomeParam (Identity x)] -> fromJust $ cast x) + +cmdLine :: CommandDef SourceLine +cmdLine = param "" + +command :: String -> CommandDef a -> TestParser [a] +command name (CommandDef types ctor) = do + line <- getSourceLine + L.indentBlock scn $ do + wsymbol name + helper line $ map (fmap $ \(SomeParam (_ :: Proxy p)) -> SomeParam $ Nothing @p) types + where + helper line params = choice + [do void $ lookAhead eol + iparams <- forM params $ \case + (_, SomeParam (Nothing :: Maybe p)) + | Just (Refl :: p :~: SourceLine) <- eqT -> return $ SomeParam $ Identity line + (sym, SomeParam (Nothing :: Maybe p)) -> choice + [ SomeParam . Identity <$> paramDefault @p + , fail $ "missing " ++ (if null sym then "" else "'" ++ sym ++ "' ") ++ showParamType @p Proxy + ] + (_, SomeParam (Just x)) -> return $ SomeParam $ Identity x + return $ L.IndentNone [ctor iparams] + + ,do symbol ":" + return $ L.IndentSome Nothing (return . concat) $ do + line' <- getSourceLine + L.indentBlock scn $ helper line' params + + ,do tryParams line [] params + ] + + tryParam sym (SomeParam (cur :: Maybe p)) = do + when (not $ null sym) $ wsymbol sym + when (isJust cur) $ do + fail $ "multiple " ++ (if null sym then "unnamed" else "'" ++ sym ++ "'") ++ " parameters" + SomeParam . Just <$> parseParam @p + + tryParams line prev ((sym, p) : ps) = choice $ + (if null sym then reverse else id) {- try unnamed parameter as last option -} $ + [do p' <- tryParam sym p + helper line $ concat [reverse prev, [(sym, p')], ps] + ,do tryParams line ((sym, p) : prev) ps + ] + tryParams _ _ [] = mzero + +testSpawn :: TestParser [TestStep] +testSpawn = command "spawn" $ Spawn + <$> param "as" + <*> param "on" + +testSend :: TestParser [TestStep] +testSend = command "send" $ Send + <$> param "to" + <*> param "" + +testExpect :: TestParser [TestStep] +testExpect = command "expect" $ Expect + <$> cmdLine + <*> param "from" + <*> param "" + <*> param "capture" testGuard :: TestParser [TestStep] -testGuard = command "guard" - [ Param "" guardBuilderExpr typedExpr - ] $ \s b -> Guard s - <$> (maybe (fail "missing guard expression") return $ b ^. guardBuilderExpr) +testGuard = command "guard" $ Guard + <$> cmdLine + <*> param "" testWait :: TestParser [TestStep] |