summaryrefslogtreecommitdiff
path: root/src/Parser.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Parser.hs')
-rw-r--r--src/Parser.hs43
1 files changed, 27 insertions, 16 deletions
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)