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
|
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.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
}
textSomeExprType :: SomeExprType -> Text
textSomeExprType (SomeExprType p) = textExprType p
lookupVarType :: VarName -> TestParser SomeExprType
lookupVarType name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") return =<< gets (lookup name . testVars)
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 [] ]
|