diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Parser.hs | 101 |
1 files changed, 82 insertions, 19 deletions
diff --git a/src/Parser.hs b/src/Parser.hs index fb1b829..0f4e72c 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} + module Parser ( parseTestFile, ) where +import Control.Lens (Lens', makeLenses, (^.), (.~)) import Control.Monad.State import Data.Char @@ -12,6 +15,8 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.IO as TL import Data.Void +import Generics.Deriving.Base as G + import Text.Megaparsec hiding (State) import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L @@ -88,30 +93,88 @@ regex = label "regular expression" $ lexeme $ do Left err -> fail err Right re -> return (re, TL.toStrict pat) + +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) + +command :: (Generic b, GInit (Rep b)) => String -> [Param b] -> (b -> TestParser a) -> TestParser a +command name params fin = do + wsymbol name + let helper prev cur = do + (s, cur') <- choice $ 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 + return $ (sym, l .~ Just x $ cur) + (eol >> return cur') <|> helper (s:prev) cur' + + fin =<< helper [] (G.to ginit) + + +data SpawnBuilder = SpawnBuilder + { _spawnBuilderProc :: Maybe ProcName + , _spawnBuilderNode :: Maybe NodeName + } + deriving (Generic) + +makeLenses ''SpawnBuilder + testSpawn :: TestParser TestStep -testSpawn = do - wsymbol "spawn" - wsymbol "on" - nname <- nodeName - wsymbol "as" - pname <- procName - return $ Spawn pname nname +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) + + +data SendBuilder = SendBuilder + { _sendBuilderProc :: Maybe ProcName + , _sendBuilderLine :: Maybe Text + } + deriving (Generic) + +makeLenses ''SendBuilder testSend :: TestParser TestStep -testSend = do - wsymbol "send" - line <- quotedString - wsymbol "to" - pname <- procName - return $ Send pname line +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 (Regex, Text) + } + deriving (Generic) + +makeLenses ''ExpectBuilder testExpect :: TestParser TestStep -testExpect = do - wsymbol "expect" - (re, pat) <- regex - wsymbol "from" - pname <- procName - return $ Expect pname re pat +testExpect = command "expect" + [ Param "from" expectBuilderProc procName + , Param "" expectBuilderRegex regex + ] $ \b -> Expect + <$> (maybe (fail "missing 'from' <proc>") return $ b ^. expectBuilderProc) + <*> (maybe (fail "missing regex to match") (return . fst) $ b ^. expectBuilderRegex) + <*> (maybe (fail "missing regex to match") (return . snd) $ b ^. expectBuilderRegex) + testWait :: TestParser TestStep testWait = do |