git.iko.soy/elk
on 4bcde7e help sign in
elk/compiler/Transform/Check.hs
90 lines 3.0 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
11import Text.PrettyPrint as P
14mistakes :: (Data t, Data v) => [Declaration t v] -> [Doc]
15mistakes decls =
16 map prettify $ concatMap findErrors (getLets decls)
17 where
18 prettify = P.sep . map P.text . words
19 findErrors defs = duplicates defs ++ badOrder defs
22getLets :: (Data t, Data v) => [Declaration t v] -> [[Def t v]]
23getLets decls = defs : concatMap getSubLets defs
24 where
25 defs = concatMap (\d -> case d of Definition d -> [d] ; _ -> []) decls
27 getSubLets def =
28 case def of
29 Def pattern expr -> [ defs | Let defs _ <- universeBi expr ]
30 TypeAnnotation _ _ -> []
33duplicates :: [Def t v] -> [String]
34duplicates defs =
35 map defMsg (dup definition) ++ map annMsg (dup annotation)
36 where
37 dup f = map head . filter ((>1) . length) . List.group . List.sort $ concatMap f defs
39 msg = "Syntax Error: There can only be one "
40 defMsg x = msg ++ " definition of '" ++ x ++ "'."
41 annMsg x = msg ++ " type annotation for '" ++ x ++ "'."
44badOrder :: [Def t v] -> [String]
45badOrder defs =
46 map msg $ missings (List.sort $ expectedPairs as ds) (List.sort $ actualPairs defs)
47 where
48 msg x = "Syntax Error: The type annotation for '" ++ x ++
49 "' must be directly above its definition."
50 as = List.sort $ concatMap annotation defs
51 ds = List.sort $ concatMap definition defs
53 expectedPairs :: [String] -> [String] -> [String]
54 expectedPairs as ds =
55 case (as,ds) of
56 (x:xs, y:ys) -> case compare x y of
57 LT -> expectedPairs xs (y:ys)
58 EQ -> x : expectedPairs xs ys
59 GT -> expectedPairs (x:xs) ys
60 ( _ , _ ) -> []
62 actualPairs defs =
63 case defs of
64 TypeAnnotation name _ : Def (PVar name') _ : rest ->
65 (if name == name' then [name] else []) ++ actualPairs rest
66 t:s:rest -> actualPairs (s:rest)
67 _ -> []
69 missings :: [String] -> [String] -> [String]
70 missings expected actual =
71 case (expected, actual) of
72 (e:es, a:as) -> case compare e a of
73 LT -> e : missings es (a:as)
74 EQ -> missings es as
75 GT -> a : missings (e:es) as
76 ( [] , _ ) -> actual
77 ( _ , [] ) -> expected
80annotation :: Def t v -> [String]
81annotation def =
82 case def of
83 TypeAnnotation name _ -> [name]
84 _ -> []
86definition :: Def t v -> [String]
87definition def =
88 case def of
89 Def pattern _ -> Set.toList (boundVars pattern)
90 _ -> []