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
|
{-# 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 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
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
]
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 $ varExpr SourceLineBuiltin rootNetworkVar
, 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
|