git.iko.soy/elk
on 0bdfd73 help sign in
elk/src/Reporting/Render/Type.hs
235 lines 4.8 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Reporting.Render.Type
4 ( Context(..)
5 , lambda
6 , apply
7 , tuple
8 , record
9 , recordSnippet
10 , srcToDoc
11 , canToDoc
12 )
13 where
16import qualified Data.Map as Map
17import qualified Data.Maybe as Maybe
19import qualified AST.Source as Src
20import qualified AST.Canonical as Can
21import qualified AST.Module.Name as ModuleName
22import qualified Elm.Name as N
23import qualified Reporting.Annotation as A
24import qualified Reporting.Helpers as H
25import Reporting.Helpers ( Doc, (<+>), (<>) )
29-- TO DOC
32data Context
33 = None
34 | Func
35 | App
38lambda :: Context -> Doc -> Doc -> [Doc] -> Doc
39lambda context arg1 arg2 args =
40 let
41 lambdaDoc =
42 H.sep (arg1 : map ("->" <+>) (arg2:args))
43 in
44 case context of
45 None -> lambdaDoc
46 Func -> H.cat [ "(", lambdaDoc, ")" ]
47 App -> H.cat [ "(", lambdaDoc, ")" ]
50apply :: Context -> Doc -> [Doc] -> Doc
51apply context name args =
52 case args of
53 [] ->
54 name
56 _:_ ->
57 let
58 applyDoc =
59 H.hang 4 (H.sep (name : args))
60 in
61 case context of
62 App -> H.cat [ "(", applyDoc, ")" ]
63 Func -> applyDoc
64 None -> applyDoc
67tuple :: Doc -> Doc -> [Doc] -> Doc
68tuple a b cs =
69 let
70 entries =
71 zipWith (<+>) ("(" : repeat ",") (a:b:cs)
72 in
73 H.sep [ H.cat entries, ")" ]
76record :: [(Doc, Doc)] -> Maybe Doc -> Doc
77record entries maybeExt =
78 case (map entryToDoc entries, maybeExt) of
79 ([], Nothing) ->
80 "{}"
82 (fields, Nothing) ->
83 H.sep
84 [ H.cat (zipWith (<+>) ("{" : repeat ",") fields)
85 , "}"
86 ]
88 (fields, Just ext) ->
89 H.sep
90 [ H.hang 4 $ H.sep $
91 [ "{" <+> ext
92 , H.cat (zipWith (<+>) ("|" : repeat ",") fields)
93 ]
94 , "}"
95 ]
98entryToDoc :: (Doc, Doc) -> Doc
99entryToDoc (fieldName, fieldType) =
100 H.hang 4 (H.sep [ fieldName <+> ":", fieldType ])
103recordSnippet :: (Doc, Doc) -> [(Doc, Doc)] -> Doc
104recordSnippet entry entries =
105 let
106 field = "{" <+> entryToDoc entry
107 fields = zipWith (<+>) (repeat ",") (map entryToDoc entries ++ ["..."])
108 in
109 H.sep [ H.cat (field:fields), "}" ]
113-- SOURCE TYPE TO DOC
116srcToDoc :: Context -> Src.Type -> Doc
117srcToDoc 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)
128 Src.TVar name ->
129 H.nameToDoc name
131 Src.TType _ name args ->
132 apply context
133 (H.nameToDoc name)
134 (map (srcToDoc App) args)
136 Src.TTypeQual _ home name args ->
137 apply context
138 (H.nameToDoc home <> "." <> H.nameToDoc name)
139 (map (srcToDoc App) args)
141 Src.TRecord fields ext ->
142 record
143 (map fieldToDocs fields)
144 (fmap (H.nameToDoc . A.toValue) ext)
146 Src.TUnit ->
147 "()"
149 Src.TTuple a b cs ->
150 tuple
151 (srcToDoc None a)
152 (srcToDoc None b)
153 (map (srcToDoc None) cs)
156fieldToDocs :: (A.Located N.Name, Src.Type) -> (Doc, Doc)
157fieldToDocs (A.At _ fieldName, fieldType) =
158 ( H.nameToDoc fieldName
159 , srcToDoc None fieldType
160 )
163collectSrcArgs :: Src.Type -> (Src.Type, [Src.Type])
164collectSrcArgs 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)
172 _ ->
173 (tipe, [])
177-- CANONICAL TYPE TO DOC
180canToDoc :: Context -> Can.Type -> Doc
181canToDoc 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)
192 Can.TVar name ->
193 H.nameToDoc name
195 Can.TType (ModuleName.Canonical _ home) name args ->
196 apply context
197 (H.nameToDoc home <> "." <> H.nameToDoc name)
198 (map (canToDoc App) args)
200 Can.TRecord fields ext ->
201 record
202 (map entryToDocs (Map.toList fields))
203 (fmap H.nameToDoc ext)
205 Can.TUnit ->
206 "()"
208 Can.TTuple a b maybeC ->
209 tuple
210 (canToDoc None a)
211 (canToDoc None b)
212 (map (canToDoc None) (Maybe.maybeToList maybeC))
214 Can.TAlias (ModuleName.Canonical _ home) name args _ ->
215 apply context
216 (H.nameToDoc home <> "." <> H.nameToDoc name)
217 (map (canToDoc App . snd) args)
220entryToDocs :: (N.Name, Can.Type) -> (Doc, Doc)
221entryToDocs (name, tipe) =
222 (H.nameToDoc name, canToDoc None tipe)
225collectArgs :: Can.Type -> (Can.Type, [Can.Type])
226collectArgs tipe =
227 case tipe of
228 Can.TLambda a rest ->
229 let
230 (b, cs) = collectArgs rest
231 in
232 (a, b:cs)
234 _ ->
235 (tipe, [])