Generic record member selection expression

5 files changed, 64 insertions, 28 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 02d690f..b6c952f 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -165,27 +165,29 @@ createNode nname@(NodeName tnname) inner = do
     net <- asks $ tsNetwork . snd
     let name = T.unpack tnname
         dir = netDir net </> ("erebos_" ++ name)
-        node = Node { nodeName = nname
-                    , nodeNetwork = net
-                    , nodeDir = dir
-                    }
 
-    ip <- liftIO $ do
+    node <- liftIO $ do
         exists <- doesPathExist dir
         when exists $ ioError $ userError $ dir ++ " exists"
         createDirectoryIfMissing True dir
 
         modifyMVar (netNodes net) $ \nodes -> do
             let ip = "192.168.0." ++ show (11 + length nodes)
+                node = Node { nodeName = nname
+                            , nodeIp = T.pack ip
+                            , nodeNetwork = net
+                            , nodeDir = dir
+                            }
+
             callCommand $ "ip netns add \""++ name ++ "\""
             callCommand $ "ip link add \"veth_" ++ name ++ ".0\" group 1 type veth peer name \"veth_" ++ name ++ ".1\" netns \"" ++ name ++ "\""
             callCommand $ "ip link set dev \"veth_" ++ name ++ ".0\" master br0 up"
             callOn node $ "ip addr add " ++ ip ++ "/24 broadcast 192.168.0.255 dev \"veth_" ++ name ++ ".1\""
             callOn node $ "ip link set dev \"veth_" ++ name++ ".1\" up"
             callOn node $ "ip link set dev lo up"
-            return $ (node : nodes, ip)
+            return $ (node : nodes, node)
 
-    local (fmap $ \s -> s { tsVars = (VarName [tnname, T.pack "ip"], SomeVarValue (T.pack ip)) : tsVars s }) $ do
+    local (fmap $ \s -> s { tsVars = (VarName tnname, SomeVarValue node) : tsVars s }) $ do
         inner node
 
 callOn :: Node -> String -> IO ()
@@ -315,7 +317,7 @@ evalSteps = mapM_ $ \case
             evalSteps inner
 
     Spawn pname nname inner -> do
-        getNode nname $ \node -> do
+        either getNode ((>>=) . eval) nname $ \node -> do
             opts <- asks $ teOptions . fst
             p <- spawnOn (Right node) pname Nothing $
                 fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts)
diff --git a/src/Network.hs b/src/Network.hs
index 633db16..5872d13 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -4,12 +4,14 @@ module Network (
     NodeName(..), textNodeName, unpackNodeName,
 ) where
 
+import Control.Arrow
 import Control.Concurrent
 
 import Data.Text (Text)
 import Data.Text qualified as T
 
 import Process
+import Test
 
 data Network = Network
     { netNodes :: MVar [Node]
@@ -19,6 +21,7 @@ data Network = Network
 
 data Node = Node
     { nodeName :: NodeName
+    , nodeIp :: Text
     , nodeNetwork :: Network
     , nodeDir :: FilePath
     }
@@ -31,3 +34,13 @@ textNodeName (NodeName name) = name
 
 unpackNodeName :: NodeName -> String
 unpackNodeName (NodeName tname) = T.unpack tname
+
+
+instance ExprType Node where
+    textExprType _ = T.pack "node"
+    textExprValue n = T.pack "n:" <> textNodeName (nodeName n)
+    emptyVarValue = Node (NodeName T.empty) T.empty undefined undefined
+
+    recordMembers = map (first T.pack)
+        [ ("ip", RecordSelector $ nodeIp)
+        ]
diff --git a/src/Network.hs-boot b/src/Network.hs-boot
new file mode 100644
index 0000000..820fdaf
--- /dev/null
+++ b/src/Network.hs-boot
@@ -0,0 +1,4 @@
+module Network where
+
+data Node
+data NodeName
diff --git a/src/Parser.hs b/src/Parser.hs
index 7534eaa..0f3747d 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -27,7 +27,7 @@ import qualified Text.Megaparsec.Char.Lexer as L
 
 import System.Exit
 
-import Network (NodeName(..))
+import Network (Node, NodeName(..))
 import Process (ProcName(..))
 import Test
 
@@ -46,7 +46,6 @@ someEmptyVar :: SomeExprType -> SomeVarValue
 someEmptyVar (SomeExprType (Proxy :: Proxy a)) = SomeVarValue $ emptyVarValue @a
 
 instance MonadEval TestParser where
-    lookupVar (VarName [_, ip]) | ip == T.pack "ip" = return $ SomeVarValue T.empty
     lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") (return . someEmptyVar) =<< gets (lookup name . testVars)
 
 skipLineComment :: TestParser ()
@@ -90,12 +89,6 @@ listOf item = do
     x <- item
     (x:) <$> choice [ symbol "," >> listOf item, return [] ]
 
-nodeName :: TestParser NodeName
-nodeName = label "network node name" $ lexeme $ do
-    c <- lowerChar
-    cs <- takeWhileP Nothing (\x -> isAlphaNum x || x == '_' || x == '-')
-    return $ NodeName $ TL.toStrict (c `TL.cons` cs)
-
 procName :: TestParser ProcName
 procName = label "process name" $ lexeme $ do
     c <- lowerChar
@@ -107,13 +100,11 @@ identifier = do
     lexeme $ TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_')
 
 varName :: TestParser VarName
-varName = lexeme $ do
-    VarName . T.splitOn (T.singleton '.') . TL.toStrict <$>
-        takeWhile1P Nothing (\x -> isAlphaNum x || x == '_' || x == '.')
+varName = VarName <$> identifier
 
 newVarName :: forall a proxy. ExprType a => proxy a -> TestParser VarName
 newVarName proxy = do
-    name <- VarName . (:[]) <$> identifier
+    name <- varName
     addVarName proxy name
     return name
 
@@ -128,7 +119,7 @@ someExpansion :: TestParser SomeExpr
 someExpansion = do
     void $ char '$'
     choice
-        [do name <- VarName . (:[]) . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_')
+        [do name <- VarName . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_')
             SomeVarValue (_ :: a) <- lookupVar name
             return $ SomeExpr $ Variable @a name
         , between (char '{') (char '}') someExpr
@@ -219,7 +210,9 @@ someExpr = join inner <?> "expression"
 
     term = parens inner <|> literal <|> variable <?> "term"
 
-    table = [ [ prefix "-" $ [ SomeUnOp (negate @Integer) ]
+    table = [ [ recordSelector
+              ]
+            , [ prefix "-" $ [ SomeUnOp (negate @Integer) ]
               ]
             , [ binary "*" $ [ SomeBinOp ((*) @Integer) ]
               , binary "/" $ [ SomeBinOp (div @Integer) ]
@@ -257,6 +250,20 @@ someExpr = join inner <?> "expression"
                     [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) -> SomeExpr <$> applyBinOp op e f) ops
 
+    recordSelector :: Operator TestParser (TestParser SomeExpr)
+    recordSelector = Postfix $ do
+        void $ osymbol "."
+        off <- stateOffset <$> getParserState
+        VarName m <- varName
+        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 e <$> lookup m recordMembers
+
+    applyRecordSelector :: ExprType a => Expr a -> RecordSelector a -> SomeExpr
+    applyRecordSelector e (RecordSelector f) = SomeExpr $ UnOp f e
+
     literal = label "literal" $ choice
         [ return . SomeExpr <$> integerLiteral
         , return . SomeExpr <$> quotedString
@@ -292,7 +299,7 @@ letStatement = do
     line <- getSourceLine
     indent <- L.indentLevel
     wsymbol "let"
-    name <- VarName . (:[]) <$> identifier
+    name <- varName
     osymbol "="
     SomeExpr (e :: Expr a) <- someExpr
     void $ eol
@@ -316,7 +323,7 @@ instance ParamType SourceLine where
     showParamType _ = "<source line>"
 
 instance ParamType NodeName where
-    parseParam = nodeName
+    parseParam = NodeName . textVarName <$> newVarName @Node Proxy
     showParamType _ = "<node>"
 
 instance ParamType ProcName where
@@ -336,6 +343,10 @@ instance ParamType a => ParamType [a] where
     showParamType _ = showParamType @a Proxy ++ " [, " ++ showParamType @a Proxy ++ " ...]"
     paramDefault = return []
 
+instance (ParamType a, ParamType b) => ParamType (Either a b) where
+    parseParam = try (Left <$> parseParam) <|> (Right <$> parseParam)
+    showParamType _ = showParamType @a Proxy ++ " or " ++ showParamType @b Proxy
+
 data SomeParam f = forall a. ParamType a => SomeParam (f a)
 
 data CommandDef a = CommandDef [(String, SomeParam Proxy)] ([SomeParam Identity] -> a)
diff --git a/src/Test.hs b/src/Test.hs
index 41649ef..a90035b 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -7,6 +7,7 @@ module Test (
     VarName(..), textVarName, unpackVarName,
     ExprType(..),
     SomeVarValue(..), fromSomeVarValue, textSomeVarValue,
+    RecordSelector(..),
     Expr(..), eval, gatherVars,
     Regex,
 ) where
@@ -22,7 +23,7 @@ import Data.Typeable
 import Text.Regex.TDFA
 import Text.Regex.TDFA.Text
 
-import Network
+import {-# SOURCE #-} Network
 import Process
 import Util
 
@@ -32,7 +33,7 @@ data Test = Test
     }
 
 data TestStep = forall a. ExprType a => Let SourceLine VarName (Expr a) [TestStep]
-              | Spawn ProcName NodeName [TestStep]
+              | Spawn ProcName (Either NodeName (Expr Node)) [TestStep]
               | Send ProcName (Expr Text)
               | Expect SourceLine ProcName (Expr Regex) [VarName] [TestStep]
               | Guard SourceLine (Expr Bool)
@@ -45,11 +46,11 @@ class MonadFail m => MonadEval m where
   lookupVar :: VarName -> m SomeVarValue
 
 
-data VarName = VarName [Text]
+newtype VarName = VarName Text
     deriving (Eq, Ord)
 
 textVarName :: VarName -> Text
-textVarName (VarName name) = T.concat $ intersperse (T.singleton '.') name
+textVarName (VarName name ) = name
 
 unpackVarName :: VarName -> String
 unpackVarName = T.unpack . textVarName
@@ -60,6 +61,9 @@ class Typeable a => ExprType a where
     textExprValue :: a -> Text
     emptyVarValue :: a
 
+    recordMembers :: [(Text, RecordSelector a)]
+    recordMembers = []
+
 instance ExprType Integer where
     textExprType _ = T.pack "integer"
     textExprValue x = T.pack (show x)
@@ -83,6 +87,8 @@ instance ExprType Regex where
 
 data SomeVarValue = forall a. ExprType a => SomeVarValue a
 
+data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b)
+
 fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => VarName -> SomeVarValue -> m a
 fromSomeVarValue name (SomeVarValue value) = maybe (fail err) return $ cast value
   where err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textVarName name, T.pack "' has type ", textExprType (Just value) ]