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
|
{-# LANGUAGE OverloadedStrings #-}
module Language.SimpleShell.Parser.Function
( functionP
, functionP0
)
where
import Language.SimpleShell.AST.Expr (Expr)
import Language.SimpleShell.AST.Function (Function(..))
import Language.SimpleShell.AST.Name (FunName, VarName)
import Language.SimpleShell.AST.SimpleType (SimpleType, FunSig, Typed)
import Language.SimpleShell.Parser (symbol)
import Language.SimpleShell.Parser.Expr
( runExprParser
, strongTermP
, strongTermP_
)
import Language.SimpleShell.Parser.Name (nameP, keyword)
import Language.SimpleShell.Parser.Root (RootParser)
import Language.SimpleShell.Parser.SimpleType (simpleTypeP, forceType)
import Control.Applicative ((<|>))
import Text.Megaparsec (sepBy)
functionPrefixP :: RootParser (SimpleType, FunName, [Typed VarName])
functionPrefixP = do
keyword "function"
t' <- simpleTypeP
fname <- nameP
params <- symbol "(" *> paramP `sepBy` symbol "," <* symbol ")"
symbol "="
return (t', fname, params)
functionP :: RootParser Function
functionP = do
(t', fname, params) <- functionPrefixP
let vars = map snd params
body <- forceType t' (bodyP params) <|> fail "Function return type mismatch."
return $ Function fname vars body
-- | First-pass function parser.
functionP0 :: RootParser (FunName, FunSig)
functionP0 = do
(t', fname, params) <- functionPrefixP
let ts = map fst params
bodyP_
return (fname, (t', ts))
paramP :: RootParser (Typed VarName)
paramP = (,) <$> simpleTypeP <*> nameP
bodyP :: [Typed VarName] -> RootParser (Typed Expr)
bodyP params = runExprParser params strongTermP
bodyP_ :: RootParser ()
bodyP_ = runExprParser [] strongTermP_
|
