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
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
|
module Parser.Core where
import Control.Applicative
import Control.Monad
import Control.Monad.Identity
import Control.Monad.State
import Data.Map (Map)
import Data.Map qualified as M
import Data.Maybe
import Data.Set qualified as S
import Data.Text qualified as T
import Data.Text.Lazy qualified 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
newtype TestParser a = TestParser (StateT TestParserState (ParsecT Void TestStream Identity) a)
deriving
( Functor, Applicative, Alternative, Monad
, MonadState TestParserState
, MonadPlus
, MonadFail
, MonadParsec Void TestStream
)
type TestStream = TL.Text
type TestParseError = ParseError TestStream Void
runTestParser :: String -> TestStream -> TestParserState -> TestParser a -> Either (ParseErrorBundle TestStream Void) a
runTestParser path content initState (TestParser parser) = runIdentity . flip (flip runParserT path) content . flip evalStateT initState $ parser
data Toplevel
= ToplevelTest Test
| ToplevelDefinition ( VarName, SomeExpr )
data TestParserState = TestParserState
{ testVars :: [ ( VarName, SomeExprType ) ]
, testContext :: SomeExpr
, testNextTypeVar :: Int
, testTypeUnif :: Map TypeVar SomeExprType
}
newTypeVar :: TestParser TypeVar
newTypeVar = do
idx <- gets testNextTypeVar
modify $ \s -> s { testNextTypeVar = idx + 1 }
return $ TypeVar $ T.pack $ 'a' : show idx
lookupVarType :: Int -> VarName -> TestParser SomeExprType
lookupVarType off name = do
gets (lookup name . testVars) >>= \case
Nothing -> do
registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
"variable not in scope: `" <> textVarName name <> "'"
vtype <- ExprTypeVar <$> newTypeVar
modify $ \s -> s { testVars = ( name, vtype ) : testVars s }
return vtype
Just t@(ExprTypeVar tvar) -> do
gets (fromMaybe t . M.lookup tvar . testTypeUnif)
Just x -> return x
lookupVarExpr :: Int -> SourceLine -> VarName -> TestParser SomeExpr
lookupVarExpr off sline name = do
lookupVarType off name >>= \case
ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline name :: Expr a)
ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar sline name
ExprTypeFunction args (_ :: Proxy a) -> return $ SomeExpr $ (FunVariable args sline name :: Expr (FunctionType a))
unify :: Int -> SomeExprType -> SomeExprType -> TestParser SomeExprType
unify _ (ExprTypeVar aname) (ExprTypeVar bname) | aname == bname = do
cur <- gets testTypeUnif
case M.lookup aname cur of
Just a -> return a
Nothing -> return (ExprTypeVar aname)
unify off (ExprTypeVar aname) (ExprTypeVar bname) = do
cur <- gets testTypeUnif
case ( M.lookup aname cur, M.lookup bname cur ) of
( Just a, Just b ) -> do
c <- unify off a b
modify $ \s -> s { testTypeUnif = M.insert aname c $ M.insert bname c $ cur }
return c
( Just a, Nothing ) -> do
modify $ \s -> s { testTypeUnif = M.insert bname a $ cur }
return a
( Nothing, Just b ) -> do
modify $ \s -> s { testTypeUnif = M.insert aname b $ cur }
return b
( Nothing, Nothing ) -> do
let b = ExprTypeVar bname
modify $ \s -> s { testTypeUnif = M.insert aname b $ cur }
return b
unify off (ExprTypeVar aname) b = do
cur <- gets testTypeUnif
case M.lookup aname cur of
Just a -> do
c <- unify off a b
modify $ \s -> s { testTypeUnif = M.insert aname c $ cur }
return c
Nothing -> do
modify $ \s -> s { testTypeUnif = M.insert aname b $ cur }
return b
unify off a (ExprTypeVar bname) = do
cur <- gets testTypeUnif
case M.lookup bname cur of
Just b -> do
c <- unify off a b
modify $ \s -> s { testTypeUnif = M.insert bname c $ cur }
return c
Nothing -> do
modify $ \s -> s { testTypeUnif = M.insert bname a $ cur }
return a
unify _ res@(ExprTypePrim (Proxy :: Proxy a)) (ExprTypePrim (Proxy :: Proxy b))
| Just (Refl :: a :~: b) <- eqT
= return res
unify off a b = do
parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
"couldn't match expected type `" <> textSomeExprType a <> "' with actual type `" <> textSomeExprType b <> "'"
unifyExpr :: forall a b proxy. (ExprType a, ExprType b) => Int -> proxy a -> Expr b -> TestParser (Expr a)
unifyExpr off pa expr = if
| Just (Refl :: a :~: b) <- eqT
-> return expr
| DynVariable tvar sline name <- expr
-> do
_ <- unify off (ExprTypePrim (Proxy :: Proxy a)) (ExprTypeVar tvar)
return $ Variable sline name
| Just (Refl :: FunctionType a :~: b) <- eqT
-> do
let FunctionArguments remaining = exprArgs expr
showType ( Nothing, SomeArgumentType atype ) = "`<" <> textExprType atype <> ">'"
showType ( Just (ArgumentKeyword kw), SomeArgumentType atype ) = "`" <> kw <> " <" <> textExprType atype <> ">'"
err = parseError . FancyError off . S.singleton . ErrorFail . T.unpack
defaults <- fmap catMaybes $ forM (M.toAscList remaining) $ \case
arg@(_, SomeArgumentType RequiredArgument) -> err $ "missing " <> showType arg <> " argument"
(_, SomeArgumentType OptionalArgument) -> return Nothing
(kw, SomeArgumentType (ExprDefault def)) -> return $ Just ( kw, SomeExpr def )
(kw, SomeArgumentType atype@ContextDefault) -> do
SomeExpr context <- gets testContext
context' <- unifyExpr off atype context
return $ Just ( kw, SomeExpr context' )
return (FunctionEval $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr)
| Just (Refl :: DynamicType :~: b) <- eqT
, Undefined msg <- expr
-> do
return $ Undefined msg
| otherwise
-> do
parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
"couldn't match expected type `" <> textExprType pa <> "' with actual type `" <> textExprType expr <> "'"
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
s' <- get
put s { testNextTypeVar = testNextTypeVar s', testTypeUnif = testTypeUnif s' }
return x
toplevel :: (a -> Toplevel) -> TestParser a -> TestParser Toplevel
toplevel f = return . 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 [] ]
getSourceLine :: TestParser SourceLine
getSourceLine = do
pstate <- statePosState <$> getParserState
return $ SourceLine $ T.concat
[ T.pack $ sourcePosPretty $ pstateSourcePos pstate
, T.pack ": "
, TL.toStrict $ TL.takeWhile (/='\n') $ pstateInput pstate
]
|