git.iko.soy/elk
on a5bc960 help sign in
elk/compiler/Transform/Check.hs
86 lines 2.9 kB history raw
1module Transform.Check (mistakes) where
3import Transform.SortDefinitions (boundVars)
4import SourceSyntax.Everything
5import qualified SourceSyntax.Type as T
6import Data.List as List
7import qualified Data.Map as Map
8import qualified Data.Set as Set
9import Data.Data
10import Data.Generics.Uniplate.Data
13mistakes :: (Data t, Data v) => [Declaration t v] -> [String]
14mistakes decls =
15 concatMap (\defs -> duplicates defs ++ badOrder defs) (getLets decls)
18getLets :: (Data t, Data v) => [Declaration t v] -> [[Def t v]]
19getLets decls = defs : concatMap getSubLets defs
20 where
21 defs = concatMap (\d -> case d of Definition d -> [d] ; _ -> []) decls
23 getSubLets def =
24 case def of
25 Def pattern expr -> [ defs | Let defs _ <- universeBi expr ]
26 TypeAnnotation _ _ -> []
29duplicates :: [Def t v] -> [String]
30duplicates defs =
31 map defMsg (dup definition) ++ map annMsg (dup annotation)
32 where
33 dup f = map head . filter ((>1) . length) . List.group . List.sort $ concatMap f defs
35 msg = "Syntax Error: There can only be one "
36 defMsg x = msg ++ " definition of '" ++ x ++ "'."
37 annMsg x = msg ++ " type annotation for '" ++ x ++ "'."
40badOrder :: [Def t v] -> [String]
41badOrder defs =
42 map msg $ missings (List.sort $ expectedPairs as ds) (List.sort $ actualPairs defs)
43 where
44 msg x = "Syntax Error: The type annotation for '" ++ x ++
45 "' must be directly above its definition."
46 as = List.sort $ concatMap annotation defs
47 ds = List.sort $ concatMap definition defs
49 expectedPairs :: [String] -> [String] -> [String]
50 expectedPairs as ds =
51 case (as,ds) of
52 (x:xs, y:ys) -> case compare x y of
53 LT -> expectedPairs xs (y:ys)
54 EQ -> x : expectedPairs xs ys
55 GT -> expectedPairs (x:xs) ys
56 ( _ , _ ) -> []
58 actualPairs defs =
59 case defs of
60 TypeAnnotation name _ : Def (PVar name') _ : rest ->
61 (if name == name' then [name] else []) ++ actualPairs rest
62 t:s:rest -> actualPairs (s:rest)
63 _ -> []
65 missings :: [String] -> [String] -> [String]
66 missings expected actual =
67 case (expected, actual) of
68 (e:es, a:as) -> case compare e a of
69 LT -> e : missings es (a:as)
70 EQ -> missings es as
71 GT -> a : missings (e:es) as
72 ( [] , _ ) -> actual
73 ( _ , [] ) -> expected
76annotation :: Def t v -> [String]
77annotation def =
78 case def of
79 TypeAnnotation name _ -> [name]
80 _ -> []
82definition :: Def t v -> [String]
83definition def =
84 case def of
85 Def pattern _ -> Set.toList (boundVars pattern)
86 _ -> []