git.iko.soy/elk
on master help sign in
Move srcToDoc and canToDoc implementations into Render.Type
commit3fe6d87c32f6ea6815957231f3360566c463b432 authorEvan Czaplicki <evancz@users.noreply.github.com> dateSat 10 Feb 2018, 18:33 (9 years ago) parent4914a41
3 files changed+139−132
compare with master
unifiedsplit
src/Reporting/Error/Canonicalize.hs+1−63 src/Reporting/Error/Main.hs+1−68 src/Reporting/Render/Type.hs+137−1
src/Reporting/Error/Canonicalize.hs+1−63
@@ -1103,67 +1103,5 @@ aliasToUnionDoc name args tipe =
11031103 , H.green $
11041104 H.indent 4 (H.nameToDoc name)
11051105 , H.dullyellow $
1106− H.indent 8 (typeToDoc RT.App tipe)
1106+ H.indent 8 (RT.srcToDoc RT.App tipe)
11071107 ]
1108−
1109−
1110−typeToDoc :: RT.Context -> Src.Type -> Doc
1111−typeToDoc context (A.At _ tipe) =
1112− case tipe of
1113− Src.TLambda arg1 next ->
1114− case next of
1115− A.At _ (Src.TLambda arg2 result) ->
1116− RT.lambda context
1117− (typeToDoc RT.Func arg1)
1118− (typeToDoc RT.Func arg2)
1119− (map (typeToDoc RT.Func) (collectArgs result))
1120−
1121− _ ->
1122− RT.lambda context
1123− (typeToDoc RT.Func arg1)
1124− (typeToDoc RT.Func next)
1125− []
1126−
1127− Src.TVar name ->
1128− H.nameToDoc name
1129−
1130− Src.TType _ name args ->
1131− RT.apply context
1132− (H.nameToDoc name)
1133− (map (typeToDoc RT.App) args)
1134−
1135− Src.TTypeQual _ home name args ->
1136− RT.apply context
1137− (H.nameToDoc home <> "." <> H.nameToDoc name)
1138− (map (typeToDoc RT.App) args)
1139−
1140− Src.TRecord fields ext ->
1141− RT.record
1142− (map fieldToDocs fields)
1143− (fmap (H.nameToDoc . A.toValue) ext)
1144−
1145− Src.TUnit ->
1146− "()"
1147−
1148− Src.TTuple a b cs ->
1149− RT.tuple
1150− (typeToDoc RT.None a)
1151− (typeToDoc RT.None b)
1152− (map (typeToDoc RT.None) cs)
1153−
1154−
1155−fieldToDocs :: (A.Located N.Name, Src.Type) -> (Doc, Doc)
1156−fieldToDocs (A.At _ fieldName, fieldType) =
1157− ( H.nameToDoc fieldName
1158− , typeToDoc RT.None fieldType
1159− )
1160−
1161−
1162−collectArgs :: Src.Type -> [Src.Type]
1163−collectArgs tipe =
1164− case tipe of
1165− A.At _ (Src.TLambda a b) ->
1166− a : collectArgs b
1167−
1168− _ ->
1169− [tipe]
src/Reporting/Error/Main.hs+1−68
@@ -7,12 +7,7 @@ module Reporting.Error.Main
77 where
88
99
10−import qualified Data.Map as Map
11−import qualified Data.Maybe as Maybe
12−import Data.Monoid ((<>))
13−
1410import qualified AST.Canonical as Can
15−import qualified AST.Module.Name as ModuleName
1611import qualified Elm.Name as N
1712import qualified Reporting.Error.Canonicalize as E
1813import qualified Reporting.Helpers as H
@@ -47,7 +42,7 @@ toReport source err =
4742 ,
4843 H.stack
4944 [ "The type of `main` value I am seeing is:"
50− , H.indent 4 $ H.dullyellow $ typeToDoc RT.None tipe
45+ , H.indent 4 $ H.dullyellow $ RT.canToDoc RT.None tipe
5146 , H.reflow $
5247 "I only know how to handle Html, Svg, and Programs\
5348 \ though. Modify `main` to be one of those types of values!"
@@ -125,65 +120,3 @@ toReport source err =
125120 \ everything with encoders and decoders for more control and better errors."
126121 ]
127122 )
128−
129−
130−
131−-- TYPE TO DOC
132−
133−
134−typeToDoc :: RT.Context -> Can.Type -> H.Doc
135−typeToDoc context tipe =
136− case tipe of
137− Can.TLambda arg1 result ->
138− let
139− (arg2, rest) = collectArgs result
140− in
141− RT.lambda context
142− (typeToDoc RT.Func arg1)
143− (typeToDoc RT.Func arg2)
144− (map (typeToDoc RT.Func) rest)
145−
146− Can.TVar name ->
147− H.nameToDoc name
148−
149− Can.TType (ModuleName.Canonical _ home) name args ->
150− RT.apply context
151− (H.nameToDoc home <> "." <> H.nameToDoc name)
152− (map (typeToDoc RT.App) args)
153−
154− Can.TRecord fields ext ->
155− RT.record
156− (map entryToDocs (Map.toList fields))
157− (fmap H.nameToDoc ext)
158−
159− Can.TUnit ->
160− "()"
161−
162− Can.TTuple a b maybeC ->
163− RT.tuple
164− (typeToDoc RT.None a)
165− (typeToDoc RT.None b)
166− (map (typeToDoc RT.None) (Maybe.maybeToList maybeC))
167−
168− Can.TAlias (ModuleName.Canonical _ home) name args _ ->
169− RT.apply context
170− (H.nameToDoc home <> "." <> H.nameToDoc name)
171− (map (typeToDoc RT.App . snd) args)
172−
173−
174−entryToDocs :: (N.Name, Can.Type) -> (H.Doc, H.Doc)
175−entryToDocs (name, tipe) =
176− (H.nameToDoc name, typeToDoc RT.None tipe)
177−
178−
179−collectArgs :: Can.Type -> (Can.Type, [Can.Type])
180−collectArgs tipe =
181− case tipe of
182− Can.TLambda a rest ->
183− let
184− (b, cs) = collectArgs rest
185− in
186− (a, b:cs)
187−
188− _ ->
189− (tipe, [])
src/Reporting/Render/Type.hs+137−1
@@ -7,12 +7,22 @@ module Reporting.Render.Type
77 , tuple
88 , record
99 , recordSnippet
10+ , srcToDoc
11+ , canToDoc
1012 )
1113 where
1214
1315
16+import qualified Data.Map as Map
17+import qualified Data.Maybe as Maybe
18+
19+import qualified AST.Source as Src
20+import qualified AST.Canonical as Can
21+import qualified AST.Module.Name as ModuleName
22+import qualified Elm.Name as N
23+import qualified Reporting.Annotation as A
1424import qualified Reporting.Helpers as H
15−import Reporting.Helpers ( Doc, (<+>) )
25+import Reporting.Helpers ( Doc, (<+>), (<>) )
1626
1727
1828
@@ -97,3 +107,129 @@ recordSnippet entry entries =
97107 fields = zipWith (<+>) (repeat ",") (map entryToDoc entries ++ ["..."])
98108 in
99109 H.sep [ H.cat (field:fields), "}" ]
110+
111+
112+
113+-- SOURCE TYPE TO DOC
114+
115+
116+srcToDoc :: Context -> Src.Type -> Doc
117+srcToDoc context (A.At _ tipe) =
118+ case tipe of
119+ Src.TLambda arg1 result ->
120+ let
121+ (arg2, rest) = collectSrcArgs result
122+ in
123+ lambda context
124+ (srcToDoc Func arg1)
125+ (srcToDoc Func arg2)
126+ (map (srcToDoc Func) rest)
127+
128+ Src.TVar name ->
129+ H.nameToDoc name
130+
131+ Src.TType _ name args ->
132+ apply context
133+ (H.nameToDoc name)
134+ (map (srcToDoc App) args)
135+
136+ Src.TTypeQual _ home name args ->
137+ apply context
138+ (H.nameToDoc home <> "." <> H.nameToDoc name)
139+ (map (srcToDoc App) args)
140+
141+ Src.TRecord fields ext ->
142+ record
143+ (map fieldToDocs fields)
144+ (fmap (H.nameToDoc . A.toValue) ext)
145+
146+ Src.TUnit ->
147+ "()"
148+
149+ Src.TTuple a b cs ->
150+ tuple
151+ (srcToDoc None a)
152+ (srcToDoc None b)
153+ (map (srcToDoc None) cs)
154+
155+
156+fieldToDocs :: (A.Located N.Name, Src.Type) -> (Doc, Doc)
157+fieldToDocs (A.At _ fieldName, fieldType) =
158+ ( H.nameToDoc fieldName
159+ , srcToDoc None fieldType
160+ )
161+
162+
163+collectSrcArgs :: Src.Type -> (Src.Type, [Src.Type])
164+collectSrcArgs tipe =
165+ case tipe of
166+ A.At _ (Src.TLambda a result) ->
167+ let
168+ (b, cs) = collectSrcArgs result
169+ in
170+ (a, b:cs)
171+
172+ _ ->
173+ (tipe, [])
174+
175+
176+
177+-- CANONICAL TYPE TO DOC
178+
179+
180+canToDoc :: Context -> Can.Type -> Doc
181+canToDoc context tipe =
182+ case tipe of
183+ Can.TLambda arg1 result ->
184+ let
185+ (arg2, rest) = collectArgs result
186+ in
187+ lambda context
188+ (canToDoc Func arg1)
189+ (canToDoc Func arg2)
190+ (map (canToDoc Func) rest)
191+
192+ Can.TVar name ->
193+ H.nameToDoc name
194+
195+ Can.TType (ModuleName.Canonical _ home) name args ->
196+ apply context
197+ (H.nameToDoc home <> "." <> H.nameToDoc name)
198+ (map (canToDoc App) args)
199+
200+ Can.TRecord fields ext ->
201+ record
202+ (map entryToDocs (Map.toList fields))
203+ (fmap H.nameToDoc ext)
204+
205+ Can.TUnit ->
206+ "()"
207+
208+ Can.TTuple a b maybeC ->
209+ tuple
210+ (canToDoc None a)
211+ (canToDoc None b)
212+ (map (canToDoc None) (Maybe.maybeToList maybeC))
213+
214+ Can.TAlias (ModuleName.Canonical _ home) name args _ ->
215+ apply context
216+ (H.nameToDoc home <> "." <> H.nameToDoc name)
217+ (map (canToDoc App . snd) args)
218+
219+
220+entryToDocs :: (N.Name, Can.Type) -> (Doc, Doc)
221+entryToDocs (name, tipe) =
222+ (H.nameToDoc name, canToDoc None tipe)
223+
224+
225+collectArgs :: Can.Type -> (Can.Type, [Can.Type])
226+collectArgs tipe =
227+ case tipe of
228+ Can.TLambda a rest ->
229+ let
230+ (b, cs) = collectArgs rest
231+ in
232+ (a, b:cs)
233+
234+ _ ->
235+ (tipe, [])