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
|
{-# OPTIONS_GHC -Wno-orphans #-}
module Parser (
parseTestFile,
) where
import Control.Monad
import Control.Monad.State
import Data.Map qualified as M
import Data.Maybe
import Data.Proxy
import Data.Set qualified as S
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.IO qualified as TL
import Data.Void
import Text.Megaparsec hiding (State)
import Text.Megaparsec.Char
import Text.Megaparsec.Char.Lexer qualified as L
import System.Directory
import System.Exit
import System.FilePath
import Network
import Parser.Core
import Parser.Expr
import Parser.Statement
import Test
import Test.Builtins
parseTestDefinition :: TestParser Toplevel
parseTestDefinition = label "test definition" $ toplevel ToplevelTest $ do
localState $ do
modify $ \s -> s
{ testContext = SomeExpr $ varExpr SourceLineBuiltin rootNetworkVar
}
block (\name steps -> return $ Test name $ mconcat steps) header testStep
where
header = do
wsymbol "test"
lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':')
parseDefinition :: TestParser Toplevel
parseDefinition = label "symbol definition" $ toplevel ToplevelDefinition $ do
def <- localState $ L.indentBlock scn $ do
wsymbol "def"
name <- varName
argsDecl <- functionArguments (\off _ -> return . ( off, )) varName mzero (\_ -> return . VarName)
atypes <- forM argsDecl $ \( off, vname :: VarName ) -> do
tvar <- newTypeVar
modify $ \s -> s { testVars = ( vname, ExprTypeVar tvar ) : testVars s }
return ( off, vname, tvar )
choice
[ do
osymbol ":"
let finish steps = do
atypes' <- getInferredTypes atypes
( name, ) . SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs (mconcat steps)
return $ L.IndentSome Nothing finish testStep
, do
osymbol "="
SomeExpr (expr :: Expr e) <- someExpr
atypes' <- getInferredTypes atypes
L.IndentNone . ( name, ) . SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs expr
]
modify $ \s -> s { testVars = fmap someExprType def : testVars s }
return def
where
getInferredTypes atypes = forM atypes $ \( off, vname, tvar@(TypeVar tvarname) ) -> do
let err msg = do
registerParseError . FancyError off . S.singleton . ErrorFail $ T.unpack msg
return ( vname, SomeArgumentType (OptionalArgument @DynamicType) )
gets (M.lookup tvar . testTypeUnif) >>= \case
Just (ExprTypePrim (_ :: Proxy a)) -> return ( vname, SomeArgumentType (RequiredArgument @a) )
Just (ExprTypeVar (TypeVar tvar')) -> err $ "ambiguous type for ‘" <> textVarName vname <> " : " <> tvar' <> "’"
Just (ExprTypeFunction {}) -> err $ "unsupported function type of ‘" <> textVarName vname <> "’"
Nothing -> err $ "ambiguous type for ‘" <> textVarName vname <> " : " <> tvarname <> "’"
replaceDynArgs :: forall a. Expr a -> TestParser (Expr a)
replaceDynArgs expr = do
unif <- gets testTypeUnif
return $ mapExpr (go unif) expr
where
go :: forall b. M.Map TypeVar SomeExprType -> Expr b -> Expr b
go unif = \case
ArgsApp args body -> ArgsApp (fmap replaceArgs args) body
where
replaceArgs (SomeExpr (DynVariable tvar sline vname))
| Just (ExprTypePrim (Proxy :: Proxy v)) <- M.lookup tvar unif
= SomeExpr (Variable sline vname :: Expr v)
replaceArgs (SomeExpr e) = SomeExpr (go unif e)
e -> e
parseTestModule :: FilePath -> TestParser Module
parseTestModule absPath = do
moduleName <- choice
[ label "module declaration" $ do
wsymbol "module"
off <- stateOffset <$> getParserState
x <- identifier
name <- (x:) <$> many (symbol "." >> identifier)
when (or (zipWith (/=) (reverse name) (reverse $ map T.pack $ splitDirectories $ dropExtension $ absPath))) $ do
registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
"module name does not match file path"
eol >> scn
return name
, do
return $ [ T.pack $ takeBaseName absPath ]
]
toplevels <- many $ choice
[ parseTestDefinition
, parseDefinition
]
let moduleTests = catMaybes $ map (\case ToplevelTest x -> Just x; _ -> Nothing) toplevels
moduleDefinitions = catMaybes $ map (\case ToplevelDefinition x -> Just x; _ -> Nothing) toplevels
eof
return Module {..}
parseTestFile :: FilePath -> IO Module
parseTestFile path = do
content <- TL.readFile path
absPath <- makeAbsolute path
let initState = TestParserState
{ testVars = concat
[ map (fmap someVarValueType) builtins
]
, testContext = SomeExpr (Undefined "void" :: Expr Void)
, testNextTypeVar = 0
, testTypeUnif = M.empty
}
res = runTestParser path content initState $ parseTestModule absPath
case res of
Left err -> putStr (errorBundlePretty err) >> exitFailure
Right testModule -> return testModule
|