blob: 1c4846c8dee71b5211ed910ed3ae8c93e57ffd41 (
plain) (
blame)
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
|
module Fun.Syntax where
import Data.Either
import Data.List
import Fun.Tree
data SyntaxError = SyntaxError String
mergeSyntax :: [Either [SyntaxError] a] -> ([a] -> b) -> Either [SyntaxError] b
mergeSyntax d c | any isLeft d = Left $ concat $ lefts d
| otherwise = Right $ c $ rights d
-- TODO: Overloading only if first element is different
checkFunctionArity :: Block -> Either [SyntaxError] Block
checkFunctionArity (FunctionBlock decl defns) =
let declArity = length $ dTypes decl
defnArities = map (length . pElements . dPattern) defns
defnFirst = head defnArities -- can't fail because of parser
equality = all (== defnFirst) defnArities
smaller = defnFirst < declArity
in if equality && smaller
then Right $ FunctionBlock decl defns
else Left [SyntaxError msg]
where msg = "invalid arity in function " ++ (dName decl)
checkEntryExistence :: Tree -> Either [SyntaxError] Tree
checkEntryExistence tree =
let inProgram bs = filter (\b -> (dName . bDecl) b == "_start") bs
oneInProgram (Program bs) = length (inProgram bs) == 1
inTree ps = map oneInProgram ps
oneInTree (Tree ps) = length (filter (== True) (inTree ps)) == 1
in if oneInTree tree then Right tree else Left [SyntaxError msg]
where msg = "invalid amount of entry (_start) functions"
checkFunctionPatternDistinguishability :: Block -> Either [SyntaxError] Block
checkFunctionPatternDistinguishability f =
let defns (FunctionBlock _ d) = d
patterns = map (pElements . dPattern) $ defns f
unique = (all ((==) 1 . length) . (group . sort))
in if unique $ patterns then Right f else Left [SyntaxError msg]
where
msg = "pattern not fully distinguishable in function " ++ ((dName . bDecl) f)
checkFunctionPattern :: Block -> Either [SyntaxError] Block
checkFunctionPattern f = checkFunctionPatternDistinguishability f
checkFunction :: Block -> Either [SyntaxError] Block
checkFunction f = checkFunctionArity f >>= checkFunctionPattern
checkBlock :: Block -> Either [SyntaxError] Block
checkBlock b@(FunctionBlock _ _) = checkFunction b
checkProgram :: Program -> Either [SyntaxError] Program
checkProgram (Program blocks) = mergeSyntax (map checkBlock blocks) Program
checkTree :: Tree -> Either [SyntaxError] Tree
checkTree (Tree programs) =
mergeSyntax (map checkProgram programs) Tree >>= checkEntryExistence
|
