git.iko.soy/elk
on 3fe6d87 help sign in
elk/src/Type/Error.hs
235 lines 4.9 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Error
4 ( Type(..)
5 , Extension(..)
6 , iteratedDealias
7 , Localizer
8 , toDoc
9 )
10 where
13import qualified Data.Map as Map
14import qualified Data.Maybe as Maybe
15import Data.Monoid ((<>))
17import qualified AST.Module.Name as ModuleName
18import qualified Elm.Name as N
19import qualified Reporting.Helpers as H
20import qualified Reporting.Render.Type as RT
24-- ERROR TYPES
27data Type
28 = Lambda Type Type [Type]
29 | Infinite
30 | Error
31 | FlexVar N.Name
32 | FlexSuper N.Name
33 | RigidVar N.Name
34 | RigidSuper N.Name
35 | Type ModuleName.Canonical N.Name [Type]
36 | Record (Map.Map N.Name Type) Extension
37 | Unit
38 | Tuple Type Type (Maybe Type)
39 | Alias ModuleName.Canonical N.Name [(N.Name, Type)] Type
42data Extension
43 = Closed
44 | FlexOpen N.Name
45 | RigidOpen N.Name
48iteratedDealias :: Type -> Type
49iteratedDealias tipe =
50 case tipe of
51 Alias _ _ _ realType ->
52 iteratedDealias realType
54 _ ->
55 tipe
59-- TO DOC
62type Localizer = Map.Map (ModuleName.Canonical, N.Name) String
65nameToDoc :: Localizer -> ModuleName.Canonical -> N.Name -> H.Doc
66nameToDoc localizer home@(ModuleName.Canonical _ moduleName) name =
67 case Map.lookup (home, name) localizer of
68 Nothing ->
69 H.nameToDoc moduleName <> "." <> H.nameToDoc name
71 Just string ->
72 H.text string
75toDoc :: Localizer -> RT.Context -> Type -> H.Doc
76toDoc localizer context tipe =
77 case tipe of
78 Lambda a b cs ->
79 RT.lambda context
80 (toDoc localizer RT.Func a)
81 (toDoc localizer RT.Func b)
82 (map (toDoc localizer RT.Func) cs)
84 Infinite ->
85 "∞"
87 Error ->
88 "?"
90 FlexVar name ->
91 H.nameToDoc name
93 FlexSuper name ->
94 H.nameToDoc name
96 RigidVar name ->
97 H.nameToDoc name
99 RigidSuper name ->
100 H.nameToDoc name
102 Type home name args ->
103 RT.apply context
104 (nameToDoc localizer home name)
105 (map (toDoc localizer RT.App) args)
107 Record fields ext ->
108 let
109 entryToDocs (fieldName, fieldType) =
110 ( H.nameToDoc fieldName, toDoc localizer RT.None fieldType )
112 fieldDocs =
113 map entryToDocs (Map.toList fields)
114 in
115 RT.record fieldDocs $
116 case ext of
117 Closed -> Nothing
118 FlexOpen x -> Just (H.nameToDoc x)
119 RigidOpen x -> Just (H.nameToDoc x)
122 Unit ->
123 "()"
125 Tuple a b maybeC ->
126 RT.tuple
127 (toDoc localizer RT.None a)
128 (toDoc localizer RT.None b)
129 (map (toDoc localizer RT.None) (Maybe.maybeToList maybeC))
131 Alias home name args _ ->
132 RT.apply context
133 (nameToDoc localizer home name)
134 (map (toDoc localizer RT.App . snd) args)
138{-- DIFF
141data Diff
142 = TooFewArgs
143 |
148-- DETECT MISSING ARGS
151detectMissingArgs :: Type -> Type -> Maybe (Type, [Type])
152detectMissingArgs actual expected =
153 detectMissingArgsHelp (reverseArgs actual) (reverseArgs expected)
156detectMissingArgsHelp :: [Type] -> [Type] -> Maybe (Type, [Type])
157detectMissingArgsHelp actuals expecteds =
158 case (actuals, expecteds) of
159 (x:xs, y:ys) -> if isMatchy x y then detectMissingArgsHelp xs ys else Nothing
160 (x:xs, []) -> Just (x, xs)
161 ([], []) -> Nothing
162 ([], _:_) -> Nothing
165reverseArgs :: Type -> [Type]
166reverseArgs tipe =
167 case tipe of
168 Lambda a b cs -> reverse (a:b:cs)
169 Infinite -> [tipe]
170 Error -> [tipe]
171 FlexVar _ -> [tipe]
172 FlexSuper _ -> [tipe]
173 RigidVar _ -> [tipe]
174 RigidSuper _ -> [tipe]
175 Type _ _ _ -> [tipe]
176 Record _ _ -> [tipe]
177 Unit -> [tipe]
178 Tuple _ _ _ -> [tipe]
179 Alias _ _ _ t -> reverseArgs t
182isMatchy :: Type -> Type -> Bool
183isMatchy t1 t2 =
184 case (t1, t2) of
185 (Lambda a b cs, Lambda x y zs) ->
186 isMatchy a x && isMatchy b y && length cs == length zs && and (zipWith isMatchy cs zs)
188 (Infinite, Infinite) ->
189 True
191 (Error, Error) ->
192 True
194 (FlexVar _, _) ->
195 True
197 (_, FlexVar _) ->
198 True
200 (FlexSuper x, FlexSuper y) ->
201 x == y
203 (RigidVar x, RigidVar y) ->
204 x == y
206 (RigidSuper x, RigidSuper y) ->
207 x == y
209 (Type home1 name1 args1, Type home2 name2 args2) ->
210 home1 == home2 && name1 == name2 && and (zipWith isMatchy args1 args2)
212 (Record fields1 ext1, Record fields2 ext2) ->
213 isMatchRecord
214 (Map.size (Map.difference fields1 fields2))
215 (Map.intersectionWith isMatchy fields1 fields2)
216 (Map.size (Map.difference fields2 fields1))
218 (Unit, Unit) ->
219 True
221 (Tuple a b Nothing, Tuple x y Nothing) ->
222 isMatchy a x && isMatchy b y
224 (Tuple a b (Just c), Tuple x y (Just z)) ->
225 isMatchy a x && isMatchy b y && isMatchy c z
227 (Alias _ _ _ alias1, tipe2) ->
228 isMatchy alias1 tipe2
230 (tipe1, Alias _ _ _ alias2) ->
231 isMatchy tipe1 alias2
233 (_, _) ->
234 False
235-}