git.iko.soy/elk
on d7e3cd7 help sign in
elk/src/Type/Error.hs
229 lines 4.8 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
16import qualified AST.Module.Name as ModuleName
17import qualified Elm.Name as N
18import qualified Reporting.Helpers as H
19import qualified Reporting.Render.Type as RT
23-- ERROR TYPES
26data Type
27 = Lambda Type Type [Type]
28 | Infinite
29 | Error
30 | FlexVar N.Name
31 | FlexSuper N.Name
32 | RigidVar N.Name
33 | RigidSuper N.Name
34 | Type ModuleName.Canonical N.Name [Type]
35 | Record (Map.Map N.Name Type) Extension
36 | Unit
37 | Tuple Type Type (Maybe Type)
38 | Alias ModuleName.Canonical N.Name [(N.Name, Type)] Type
41data Extension
42 = Closed
43 | FlexOpen N.Name
44 | RigidOpen N.Name
47iteratedDealias :: Type -> Type
48iteratedDealias tipe =
49 case tipe of
50 Alias _ _ _ realType ->
51 iteratedDealias realType
53 _ ->
54 tipe
58-- TO DOC
61type Localizer = Map.Map (ModuleName.Canonical, N.Name) (Maybe N.Name)
64toDoc :: Localizer -> RT.Context -> Type -> H.Doc
65toDoc localizer context tipe =
66 case tipe of
67 Lambda a b cs ->
68 RT.lambda context
69 (toDoc localizer RT.Func a)
70 (toDoc localizer RT.Func b)
71 (map (toDoc localizer RT.Func) cs)
73 Infinite ->
74 "∞"
76 Error ->
77 "?"
79 FlexVar name ->
80 H.nameToDoc name
82 FlexSuper name ->
83 H.nameToDoc name
85 RigidVar name ->
86 H.nameToDoc name
88 RigidSuper name ->
89 H.nameToDoc name
91 Type home name args ->
92 RT.apply context
93 (toLocal localizer home name)
94 (map (toDoc localizer RT.App) args)
96 Record fields ext ->
97 let
98 entryToDocs (fieldName, fieldType) =
99 ( H.nameToDoc fieldName, toDoc localizer RT.None fieldType )
101 fieldDocs =
102 map entryToDocs (Map.toList fields)
103 in
104 RT.record fieldDocs $
105 case ext of
106 Closed -> Nothing
107 FlexOpen x -> Just (H.nameToDoc x)
108 RigidOpen x -> Just (H.nameToDoc x)
111 Unit ->
112 "()"
114 Tuple a b maybeC ->
115 RT.tuple
116 (toDoc localizer RT.None a)
117 (toDoc localizer RT.None b)
118 (map (toDoc localizer RT.None) (Maybe.maybeToList maybeC))
120 Alias home name args _ ->
121 RT.apply context
122 (toLocal localizer home name)
123 (map (toDoc localizer RT.App . snd) args)
126toLocal :: Localizer -> ModuleName.Canonical -> N.Name -> H.Doc
127toLocal localizer home name =
128 error "TODO toLocal" localizer home name
132{-- DIFF
135data Diff
136 = TooFewArgs
137 |
142-- DETECT MISSING ARGS
145detectMissingArgs :: Type -> Type -> Maybe (Type, [Type])
146detectMissingArgs actual expected =
147 detectMissingArgsHelp (reverseArgs actual) (reverseArgs expected)
150detectMissingArgsHelp :: [Type] -> [Type] -> Maybe (Type, [Type])
151detectMissingArgsHelp actuals expecteds =
152 case (actuals, expecteds) of
153 (x:xs, y:ys) -> if isMatchy x y then detectMissingArgsHelp xs ys else Nothing
154 (x:xs, []) -> Just (x, xs)
155 ([], []) -> Nothing
156 ([], _:_) -> Nothing
159reverseArgs :: Type -> [Type]
160reverseArgs tipe =
161 case tipe of
162 Lambda a b cs -> reverse (a:b:cs)
163 Infinite -> [tipe]
164 Error -> [tipe]
165 FlexVar _ -> [tipe]
166 FlexSuper _ -> [tipe]
167 RigidVar _ -> [tipe]
168 RigidSuper _ -> [tipe]
169 Type _ _ _ -> [tipe]
170 Record _ _ -> [tipe]
171 Unit -> [tipe]
172 Tuple _ _ _ -> [tipe]
173 Alias _ _ _ t -> reverseArgs t
176isMatchy :: Type -> Type -> Bool
177isMatchy t1 t2 =
178 case (t1, t2) of
179 (Lambda a b cs, Lambda x y zs) ->
180 isMatchy a x && isMatchy b y && length cs == length zs && and (zipWith isMatchy cs zs)
182 (Infinite, Infinite) ->
183 True
185 (Error, Error) ->
186 True
188 (FlexVar _, _) ->
189 True
191 (_, FlexVar _) ->
192 True
194 (FlexSuper x, FlexSuper y) ->
195 x == y
197 (RigidVar x, RigidVar y) ->
198 x == y
200 (RigidSuper x, RigidSuper y) ->
201 x == y
203 (Type home1 name1 args1, Type home2 name2 args2) ->
204 home1 == home2 && name1 == name2 && and (zipWith isMatchy args1 args2)
206 (Record fields1 ext1, Record fields2 ext2) ->
207 isMatchRecord
208 (Map.size (Map.difference fields1 fields2))
209 (Map.intersectionWith isMatchy fields1 fields2)
210 (Map.size (Map.difference fields2 fields1))
212 (Unit, Unit) ->
213 True
215 (Tuple a b Nothing, Tuple x y Nothing) ->
216 isMatchy a x && isMatchy b y
218 (Tuple a b (Just c), Tuple x y (Just z)) ->
219 isMatchy a x && isMatchy b y && isMatchy c z
221 (Alias _ _ _ alias1, tipe2) ->
222 isMatchy alias1 tipe2
224 (tipe1, Alias _ _ _ alias2) ->
225 isMatchy tipe1 alias2
227 (_, _) ->
228 False
229-}