src/Fun/Syntax.hs


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

module Fun.Syntax where

import           Data.Either
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

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 $ "invalid arity in function " ++ (dName decl)]

checkBlock :: Block -> Either [SyntaxError] Block
checkBlock b@(FunctionBlock _ _) = checkFunctionArity 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