From 8bfe1686806ad9507faf3956cc8659613e9962d7 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Tue, 30 Nov 2021 19:59:42 +0100
Subject: Parser: generalize order of command parameters

---
 erebos-tester.cabal |  13 +++++--
 src/Parser.hs       | 101 ++++++++++++++++++++++++++++++++++++++++++----------
 2 files changed, 93 insertions(+), 21 deletions(-)

diff --git a/erebos-tester.cabal b/erebos-tester.cabal
index 6817c72..770b71d 100644
--- a/erebos-tester.cabal
+++ b/erebos-tester.cabal
@@ -37,13 +37,22 @@ executable erebos-tester-core
                        Parser
                        Process
                        Test
-  -- other-extensions:
-  default-extensions:  ImportQualifiedPost
+  other-extensions:    TemplateHaskell
+  default-extensions:  DeriveGeneric
+                       ExistentialQuantification
+                       FlexibleContexts
+                       FlexibleInstances
+                       ImportQualifiedPost
                        LambdaCase
+                       RankNTypes
+                       TypeFamilies
+                       TypeOperators
   build-depends:       base             >=4.13 && <5,
                        containers ^>=0.6.2.1,
                        directory ^>=1.3.6.0,
                        filepath ^>=1.4.2.1,
+                       generic-deriving >=1.14 && <1.15,
+                       lens             >=5.0 && <5.1,
                        megaparsec       >=9.0 && <10,
                        mtl ^>=2.2.2,
                        process ^>=1.6.9,
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
-- 
cgit v1.2.3