1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
|
module Parser.Core where
import Control.Monad
import Control.Monad.State
import Control.Monad.Writer
import Data.Text (Text)
import qualified Data.Text.Lazy as TL
import Data.Typeable
import Data.Void
import Text.Megaparsec hiding (State)
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import Network ()
import Test
type TestParser = ParsecT Void TestStream (WriterT [ Toplevel ] (State TestParserState))
type TestStream = TL.Text
data Toplevel
= ToplevelTest Test
data TestParserState = TestParserState
{ testVars :: [(VarName, SomeExprType)]
, testContext :: SomeExpr
}
someEmptyVar :: SomeExprType -> SomeVarValue
someEmptyVar (SomeExprType (Proxy :: Proxy a)) = SomeVarValue $ emptyVarValue @a
textSomeExprType :: SomeExprType -> Text
textSomeExprType (SomeExprType p) = textExprType p
instance MonadEval TestParser where
lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") (return . someEmptyVar) =<< gets (lookup name . testVars)
rootNetwork = return emptyVarValue
skipLineComment :: TestParser ()
skipLineComment = L.skipLineComment $ TL.pack "#"
scn :: TestParser ()
scn = L.space space1 skipLineComment empty
sc :: TestParser ()
sc = L.space hspace1 skipLineComment empty
wordChar :: TestParser (Token TestStream)
wordChar = alphaNumChar <|> char '_'
lexeme :: TestParser a -> TestParser a
lexeme = L.lexeme sc
symbol, osymbol, wsymbol :: String -> TestParser ()
symbol str = void $ (string (TL.pack str)) <* sc
osymbol str = void $ try $ (string (TL.pack str) <* notFollowedBy operatorChar) <* sc
wsymbol str = void $ try $ (string (TL.pack str) <* notFollowedBy wordChar) <* sc
operatorChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s)
operatorChar = satisfy $ (`elem` ['.', '+', '-', '*', '/', '='])
{-# INLINE operatorChar #-}
localState :: TestParser a -> TestParser a
localState inner = do
s <- get
x <- inner
put s
return x
toplevel :: (a -> Toplevel) -> TestParser a -> TestParser ()
toplevel f = tell . (: []) . f <=< L.nonIndented scn
block :: (a -> [b] -> TestParser c) -> TestParser a -> TestParser b -> TestParser c
block merge header item = L.indentBlock scn $ do
h <- header
choice
[ do symbol ":"
return $ L.IndentSome Nothing (merge h) item
, L.IndentNone <$> merge h []
]
listOf :: TestParser a -> TestParser [a]
listOf item = do
x <- item
(x:) <$> choice [ symbol "," >> listOf item, return [] ]
|