@@ -1,13 +1,16 @@
1−
1+{-# LANGUAGE PatternGuards #-}
22module Types.Alias (dealias, get, mistakes) where
33
44import Ast
5+import Located
56import Control.Arrow (second)
67import Data.List (group,sort)
8+import Data.Maybe (mapMaybe)
79import qualified Data.Map as Map
810import qualified Data.Set as Set
911import Types.Substitutions (subst)
1012import Types.Types
13+import Data.Generics.Uniplate.Data
1114
1215builtins :: [(String,([X],Type))]
1316builtins =
@@ -48,68 +51,59 @@ mistakes :: [Statement] -> [String]
4851mistakes stmts = badKinds stmts ++ dups stmts ++ badOrder stmts
4952
5053badKinds :: [Statement] -> [String]
51−badKinds stmts = map msg (concatMap badS stmts)
54+badKinds stmts = [msg tname | t <- universeBi stmts, tname <- badT t]
5255 where
5356 msg x = "Type Error: Type alias '" ++ x ++
5457 "' was given the wrong number of arguments."
5558
5659 badT :: Type -> [String]
57− badT t =
58− case t of
59− ADT name ts ->
60− case Map.lookup name (get stmts) of
61− Just (xs,t) | length xs == length ts -> []
62− | otherwise -> [name]
63− Nothing -> concatMap badT ts
64− LambdaT t u -> badT t ++ badT u
65− RecordT r t -> badT t ++ concatMap badT (concat (Map.elems r))
66− _ -> []
67−
68− badS :: Statement -> [String]
69− badS s =
70− case s of
71− Datatype _ _ tcs -> concatMap badT (concatMap snd tcs)
72− ExportEvent _ _ tipe -> badT tipe
73− ImportEvent _ _ _ tipe -> badT tipe
74− TypeAnnotation _ tipe -> badT tipe
75− TypeAlias _ _ tipe -> badT tipe
76− Definition _ -> []
77−
78−annotation :: Statement -> [String]
60+ badT (ADT name ts)
61+ | Just (xs, _) <- Map.lookup name (get stmts),
62+ length xs /= length ts = [name]
63+ badT _ = []
64+
65+annotation :: Def -> Maybe String
7966annotation s =
8067 case s of
81− TypeAnnotation name _ -> [name]
82− _ -> []
68+ TypeAnnotation name _ -> Just name
69+ _ -> Nothing
8370
84−definition :: Statement -> [String]
71+definition :: Def -> Maybe String
8572definition s =
8673 case s of
87− Definition d -> [defName d]
88− _ -> []
89−
90−defName :: Def -> String
91−defName d =
92− case d of
93− FnDef n _ _ -> n
94− OpDef n _ _ _ -> n
74+ FnDef name _ _ -> Just name
75+ OpDef name _ _ _ -> Just name
76+ _ -> Nothing
77+
78+checkTopLevelAndLets :: [Statement] -> (String -> [Def] -> [a]) -> [a]
79+checkTopLevelAndLets stmts fcheck =
80+ fcheck "at top-level" topLevelDefs ++
81+ concatMap (fcheck "in let binding") allLetDefs
82+ where
83+ topLevelDefs = mapMaybe maybeDef stmts
84+ maybeDef (Definition d) = Just d
85+ maybeDef _ = Nothing
86+ allLetDefs = [defList | Let defList _ <- universeBi stmts]
9587
9688dups :: [Statement] -> [String]
97−dups stmts = map defMsg (dup definition) ++ map annMsg (dup annotation)
98− where
99− dup :: (Statement -> [String]) -> [String]
100− dup f = map head . filter ((>1) . length) . group . sort $ concatMap f stmts
89+dups stmts = checkTopLevelAndLets stmts $ \ctxt defs ->
90+ let
91+ dup :: (Def -> Maybe String) -> [String]
92+ dup f = map head . filter ((>1) . length) . group . sort $ mapMaybe f defs
10193
10294 msg = "Syntax Error: There can only be one "
103− defMsg x = msg ++ "top-level definition of '" ++ x ++ "'."
104− annMsg x = msg ++ "type annotation for '" ++ x ++ "'."
95+ defMsg x = msg ++ "definition of '" ++ x ++ "' " ++ ctxt ++ "."
96+ annMsg x = msg ++ "type annotation for '" ++ x ++ "'" ++ ctxt ++ "."
97+ in
98+ map defMsg (dup definition) ++ map annMsg (dup annotation)
10599
106100badOrder :: [Statement] -> [String]
107−badOrder stmts = map msg $ missings (sort $ expectedPairs as ds) (sort $ actualPairs stmts)
108− where
101+badOrder stmts = checkTopLevelAndLets stmts $ \ctxt defs ->
102+ let
109103 msg x = "Syntax Error: The type annotation for '" ++ x ++
110− "' must be directly above its definition."
111− as = sort $ concatMap annotation stmts
112− ds = sort $ concatMap definition stmts
104+ "' must be directly above its definition in " ++ ctxt ++ "."
105+ as = sort $ mapMaybe annotation defs
106+ ds = sort $ mapMaybe definition defs
113107
114108 expectedPairs :: [String] -> [String] -> [String]
115109 expectedPairs as ds =
@@ -120,11 +114,14 @@ badOrder stmts = map msg $ missings (sort $ expectedPairs as ds) (sort $ actualP
120114 GT -> expectedPairs (x:xs) ys
121115 ( _ , _ ) -> []
122116
123− actualPairs :: [Statement] -> [String]
117+ actualPairs :: [Def] -> [String]
124118 actualPairs stmts =
125119 case stmts of
126− TypeAnnotation n _ : Definition d : rest ->
127− (if n == defName d then [n] else []) ++ actualPairs rest
120+ TypeAnnotation n _ : rest@(d : _) ->
121+ (if Just n == definition d
122+ then [n]
123+ else []
124+ ) ++ actualPairs rest
128125 t:s:rest -> actualPairs (s:rest)
129126 _ -> []
130127
@@ -136,4 +133,6 @@ badOrder stmts = map msg $ missings (sort $ expectedPairs as ds) (sort $ actualP
136133 EQ -> missings es as
137134 GT -> a : missings (e:es) as
138135 ( [] , _ ) -> actual
139− ( _ , [] ) -> expected
136+ ( _ , [] ) -> expected
137+ in
138+ map msg $ missings (sort $ expectedPairs as ds) (sort $ actualPairs defs)