git.iko.soy/elk
on 7063cad help sign in
elk/src/Type/Error.hs
404 lines 11 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Error
4 ( Type(..)
5 , Extension(..)
6 , iteratedDealias
7 , Localizer
8 , toDoc
9 , toDiffDocs
10 , Problem(..)
11 )
12 where
15import qualified Data.Map as Map
16import qualified Data.Maybe as Maybe
17import Data.Monoid ((<>))
19import qualified AST.Module.Name as ModuleName
20import qualified Data.Bag as Bag
21import qualified Elm.Name as N
22import qualified Reporting.Helpers as H
23import qualified Reporting.Render.Type as RT
27-- ERROR TYPES
30data Type
31 = Lambda Type Type [Type]
32 | Infinite
33 | Error
34 | FlexVar N.Name
35 | FlexSuper N.Name
36 | RigidVar N.Name
37 | RigidSuper N.Name
38 | Type ModuleName.Canonical N.Name [Type]
39 | Record (Map.Map N.Name Type) Extension
40 | Unit
41 | Tuple Type Type (Maybe Type)
42 | Alias ModuleName.Canonical N.Name [(N.Name, Type)] Type
45data Extension
46 = Closed
47 | FlexOpen N.Name
48 | RigidOpen N.Name
51iteratedDealias :: Type -> Type
52iteratedDealias tipe =
53 case tipe of
54 Alias _ _ _ realType ->
55 iteratedDealias realType
57 _ ->
58 tipe
62-- TO DOC
65type Localizer = Map.Map (ModuleName.Canonical, N.Name) String
68nameToDoc :: Localizer -> ModuleName.Canonical -> N.Name -> H.Doc
69nameToDoc dict home@(ModuleName.Canonical _ moduleName) name =
70 case Map.lookup (home, name) dict of
71 Nothing ->
72 H.nameToDoc moduleName <> "." <> H.nameToDoc name
74 Just string ->
75 H.text string
78toDoc :: Localizer -> RT.Context -> Type -> H.Doc
79toDoc dict ctx tipe =
80 case tipe of
81 Lambda a b cs ->
82 RT.lambda ctx
83 (toDoc dict RT.Func a)
84 (toDoc dict RT.Func b)
85 (map (toDoc dict RT.Func) cs)
87 Infinite ->
88 "∞"
90 Error ->
91 "?"
93 FlexVar name ->
94 H.nameToDoc name
96 FlexSuper name ->
97 H.nameToDoc name
99 RigidVar name ->
100 H.nameToDoc name
102 RigidSuper name ->
103 H.nameToDoc name
105 Type home name args ->
106 RT.apply ctx
107 (nameToDoc dict home name)
108 (map (toDoc dict RT.App) args)
110 Record fields ext ->
111 let
112 entryToDocs (fieldName, fieldType) =
113 ( H.nameToDoc fieldName, toDoc dict RT.None fieldType )
115 fieldDocs =
116 map entryToDocs (Map.toList fields)
117 in
118 RT.record fieldDocs $
119 case ext of
120 Closed -> Nothing
121 FlexOpen x -> Just (H.nameToDoc x)
122 RigidOpen x -> Just (H.nameToDoc x)
125 Unit ->
126 "()"
128 Tuple a b maybeC ->
129 RT.tuple
130 (toDoc dict RT.None a)
131 (toDoc dict RT.None b)
132 (map (toDoc dict RT.None) (Maybe.maybeToList maybeC))
134 Alias home name args _ ->
135 RT.apply ctx
136 (nameToDoc dict home name)
137 (map (toDoc dict RT.App . snd) args)
141-- DIFF
144toDiffDocs :: Localizer -> Type -> Type -> (H.Doc, H.Doc, [Problem])
145toDiffDocs dict a b =
146 case diff dict RT.None a b of
147 Similar aDoc bDoc ->
148 (aDoc, bDoc, [])
150 Different aDoc bDoc problems ->
151 (aDoc, bDoc, Bag.toList problems)
154data Diff a
155 = Similar a a
156 | Different a a (Bag.Bag Problem)
159instance Functor Diff where
160 fmap func d =
161 case d of
162 Similar a b -> Similar (func a) (func b)
163 Different a b ps -> Different (func a) (func b) ps
166instance Applicative Diff where
167 pure a =
168 Similar a a
170 (<*>) dFunc dArg =
171 case dFunc of
172 Similar aFunc bFunc ->
173 case dArg of
174 Similar a b -> Similar (aFunc a) (bFunc b)
175 Different a b ps -> Different (aFunc a) (bFunc b) ps
177 Different aFunc bFunc ps ->
178 case dArg of
179 Similar a b -> Different (aFunc a) (bFunc b) ps
180 Different a b ps2 -> Different (aFunc a) (bFunc b) (Bag.append ps ps2)
184-- PROBLEMS
187data Problem
188 = IntFloat
189 | MissingArgs Int
190 | ReturnMismatch Int Int
191 | TupleMismatch
192 | BadFlexSuper N.Name Type
193 | BadRigidVar N.Name Type
194 | BadRigidSuper N.Name Type
198-- COMPUTE DIFF
201diff :: Localizer -> RT.Context -> Type -> Type -> Diff H.Doc
202diff dict ctx tipe1 tipe2 =
203 case (tipe1, tipe2) of
204 (FlexVar x, FlexVar y) | x == y -> pure (H.nameToDoc x)
205 (FlexSuper x, FlexSuper y) | x == y -> pure (H.nameToDoc x)
206 (RigidVar x, RigidVar y) | x == y -> pure (H.nameToDoc x)
207 (RigidSuper x, RigidSuper y) | x == y -> pure (H.nameToDoc x)
209 (Infinite, Infinite) -> pure "∞"
210 (Error, Error) -> pure "?"
211 (Unit, Unit) -> pure "()"
213 (Tuple a b maybeC, Tuple x y maybeZ) ->
214 RT.tuple
215 <$> diff dict RT.None a x
216 <*> diff dict RT.None b y
217 <*>
218 case (maybeC, maybeZ) of
219 (Nothing, Nothing) -> pure []
220 (Just c , Nothing) -> Different [H.dullyellow (toDoc dict RT.None c)] [] (Bag.one TupleMismatch)
221 (Nothing, Just z ) -> Different [] [H.dullyellow (toDoc dict RT.None z)] (Bag.one TupleMismatch)
222 (Just c , Just z ) -> (:[]) <$> diff dict RT.None c z
224 (Record fields1 ext1, Record fields2 ext2) -> diffRecord dict fields1 ext1 fields2 ext2
226 (Type home1 name1 args1, Type home2 name2 args2) | home1 == home2 && name1 == name2 ->
227 RT.apply ctx (nameToDoc dict home1 name1) <$>
228 sequenceA (zipWith (diff dict RT.App) args1 args2)
230 (Alias home1 name1 args1 _, Alias home2 name2 args2 _) | home1 == home2 && name1 == name2 ->
231 RT.apply ctx (nameToDoc dict home1 name1) <$>
232 sequenceA (zipWith (diff dict RT.App) (map snd args1) (map snd args2))
234 (Alias _ _ _ alias1, other) -> diff dict ctx alias1 other
235 (other, Alias _ _ _ alias2) -> diff dict ctx other alias2
237 (Lambda a b cs, Lambda x y zs) -> diffLambda dict ctx (a:b:cs) (x:y:zs)
238 (Lambda a b cs, result ) -> diffLambda dict ctx (a:b:cs) [result]
239 (result , Lambda x y zs) -> diffLambda dict ctx [result] (x:y:zs)
241 (FlexVar x, other) -> Similar (H.nameToDoc x) (toDoc dict ctx other)
242 (other, FlexVar x) -> Similar (toDoc dict ctx other) (H.nameToDoc x)
244 pair ->
245 let
246 doc1 = H.dullyellow (toDoc dict ctx tipe1)
247 doc2 = H.dullyellow (toDoc dict ctx tipe2)
248 in
249 Different doc1 doc2 $
250 case pair of
251 (RigidVar x, other) -> Bag.one $ BadRigidVar x other
252 (FlexSuper x, other) -> Bag.one $ BadFlexSuper x other
253 (RigidSuper x, other) -> Bag.one $ BadRigidSuper x other
254 (other, RigidVar x) -> Bag.one $ BadRigidVar x other
255 (other, FlexSuper x) -> Bag.one $ BadFlexSuper x other
256 (other, RigidSuper x) -> Bag.one $ BadRigidSuper x other
258 (Type home1 name1 [], Type home2 name2 []) | isIntFloat home1 name1 home2 name2 -> Bag.one IntFloat
260 (_, _) -> Bag.empty
263isIntFloat :: ModuleName.Canonical -> N.Name -> ModuleName.Canonical -> N.Name -> Bool
264isIntFloat home1 name1 home2 name2 =
265 home1 == ModuleName.basics
266 &&
267 home2 == ModuleName.basics
268 &&
269 (
270 (name1 == N.int && name2 == N.float)
271 ||
272 (name1 == N.float && name2 == N.int)
273 )
277-- DIFF LAMBDAS
280--
281-- INVARIANT: notNull types1 && notNull types2
282--
283diffLambda :: Localizer -> RT.Context -> [Type] -> [Type] -> Diff H.Doc
284diffLambda dict ctx types1 types2 =
285 let
286 (result1:revArgs1) = reverse types1
287 (result2:revArgs2) = reverse types2
289 numArgs1 = length revArgs1
290 numArgs2 = length revArgs2
292 resultDiff = diff dict RT.Func result1 result2
293 in
294 case resultDiff of
295 Similar resultDoc1 resultDoc2 ->
296 if numArgs1 == numArgs2 then
297 (\resultDoc revArgsDoc ->
298 let (x:y:zs) = reverse (resultDoc:revArgsDoc) in
299 RT.lambda ctx x y zs
300 )
301 <$> resultDiff
302 <*> sequenceA (zipWith (diff dict RT.Func) revArgs1 revArgs2)
304 else if numArgs1 < numArgs2 then
305 diffArgMismatch dict ctx revArgs1 resultDoc1 revArgs2 resultDoc2
307 else
308 diffArgMismatch dict ctx revArgs2 resultDoc2 revArgs1 resultDoc1
310 Different resultDoc1 resultDoc2 problems ->
311 let
312 (x1:y1:zs1) = reverse (resultDoc1 : map (toDoc dict RT.Func) revArgs1)
313 (x2:y2:zs2) = reverse (resultDoc2 : map (toDoc dict RT.Func) revArgs2)
314 in
315 Different
316 (RT.lambda ctx x1 y1 zs1)
317 (RT.lambda ctx x2 y2 zs2)
318 (Bag.append (Bag.one (ReturnMismatch numArgs1 numArgs2)) problems)
321--
322-- INVARIANT: notNull shortRevArgs && notNull longRevArgs
323--
324diffArgMismatch :: Localizer -> RT.Context -> [Type] -> H.Doc -> [Type] -> H.Doc -> Diff H.Doc
325diffArgMismatch dict ctx shortRevArgs shortResult longRevArgs longResult =
326 case toGreedyMatch dict shortRevArgs longRevArgs (GreedyMatch [] []) of
327 Just (GreedyMatch shortRevArgDocs longRevArgDocs) ->
328 let
329 (a:b:cs) = reverse (shortResult:shortRevArgDocs)
330 (x:y:zs) = reverse (longResult:longRevArgDocs)
331 in
332 Different
333 (RT.lambda ctx a b cs)
334 (RT.lambda ctx x y zs)
335 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
337 Nothing ->
338 case toGreedyMatch dict (reverse shortRevArgs) (reverse longRevArgs) (GreedyMatch [] []) of
339 Just (GreedyMatch shortArgDocs longArgDocs) ->
340 let
341 (a:b:cs) = shortArgDocs ++ [shortResult]
342 (x:y:zs) = longArgDocs ++ [longResult ]
343 in
344 Different
345 (RT.lambda ctx a b cs)
346 (RT.lambda ctx x y zs)
347 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
349 Nothing ->
350 let
351 toYellowDoc tipe =
352 H.dullyellow (toDoc dict RT.Func tipe)
354 (a:b:cs) = reverse (shortResult : map toYellowDoc shortRevArgs)
355 (x:y:zs) = reverse (longResult : map toYellowDoc longRevArgs )
356 in
357 Different
358 (RT.lambda ctx a b cs)
359 (RT.lambda ctx x y zs)
360 (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
364-- GREEDY ARG MATCHER
367data GreedyMatch =
368 GreedyMatch [H.Doc] [H.Doc]
371toGreedyMatch :: Localizer -> [Type] -> [Type] -> GreedyMatch -> Maybe GreedyMatch
372toGreedyMatch dict shorterArgs longerArgs match@(GreedyMatch shorterDocs longerDocs) =
373 let
374 toYellowDoc tipe =
375 H.dullyellow (toDoc dict RT.Func tipe)
376 in
377 case (shorterArgs, longerArgs) of
378 (x:xs, y:ys) ->
379 case diff dict RT.Func x y of
380 Similar a b ->
381 toGreedyMatch dict xs ys $
382 GreedyMatch (a:shorterDocs) (b:longerDocs)
384 Different _ _ _ ->
385 toGreedyMatch dict shorterArgs ys $
386 GreedyMatch shorterDocs (toYellowDoc y : longerDocs)
388 ([], []) ->
389 Just match
391 ([], _:_) ->
392 Just (GreedyMatch shorterDocs (map toYellowDoc longerArgs))
394 (_:_, []) ->
395 Nothing
399-- RECORD DIFFS
402diffRecord :: Localizer -> Map.Map N.Name Type -> Extension -> Map.Map N.Name Type -> Extension -> Diff H.Doc
403diffRecord dict fields1 ext1 fields2 ext2 =
404 error "TODO" dict fields1 ext1 fields2 ext2