From e6f8e2eeb66880950bd35fd82d439d87e7fa6bf5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Wed, 28 Sep 2022 13:31:49 +0200 Subject: Generic record member selection expression --- src/Main.hs | 18 ++++++++++-------- src/Network.hs | 13 +++++++++++++ src/Network.hs-boot | 4 ++++ src/Parser.hs | 43 +++++++++++++++++++++++++++---------------- src/Test.hs | 14 ++++++++++---- 5 files changed, 64 insertions(+), 28 deletions(-) create mode 100644 src/Network.hs-boot (limited to 'src') 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 _ = "" instance ParamType NodeName where - parseParam = nodeName + parseParam = NodeName . textVarName <$> newVarName @Node Proxy showParamType _ = "" 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) ] -- cgit v1.2.3