git.iko.soy/elk
on 74db13f help sign in
elk/src/Reporting/Render/Type.hs
270 lines 5.7 kB history raw
1module Reporting.Render.Type
2 ( Localizer
3 , typeDecl
4 , aliasDecl
5 , annotation
6 , tipe
7 )
8 where
10import qualified Data.Map as Map
11import Text.PrettyPrint.ANSI.Leijen
13import qualified AST.Helpers as Help
16type Localizer =
17 Map.Map String String
20typeDecl =
21 error "TODO"
24aliasDecl =
25 error "TODO"
28annotation =
29 error "TODO"
32tipe =
33 error "TODO"
37{-- HELPERS
39commaCat :: [Doc] -> Doc
40commaCat docs =
41 cat (punctuate comma docs)
44commaSep :: [Doc] -> Doc
45commaSep docs =
46 sep (punctuate comma docs)
49parensIf :: Bool -> Doc -> Doc
50parensIf bool doc =
51 if bool then parens doc else doc
54variable :: String -> Doc
55variable x =
56 if Help.isOp x then parens (text x) else text x
60-- PRETTY PRINTING
62instance (P.Pretty t) => P.Pretty (Port t) where
63 pretty dealiaser needsParens portType =
64 P.pretty dealiaser needsParens (getPortType portType)
67instance P.Pretty Raw' where
68 pretty dealiaser needsParens tipe =
69 case tipe of
70 RLambda arg body ->
71 P.parensIf needsParens (prettyLambda dealiaser getRawLambda arg body)
73 RVar x ->
74 P.text x
76 RType var ->
77 prettyType dealiaser var
79 RApp func args ->
80 let
81 isTuple (A.A _ (RType name)) = Help.isTuple (Var.toString name)
82 isTuple _ = False
83 in
84 prettyApp dealiaser needsParens isTuple func args
86 RRecord fields ext ->
87 prettyRecord dealiaser (flattenRawRecord fields ext)
90instance P.Pretty Canonical where
91 pretty dealiaser needsParens tipe =
92 case tipe of
93 Lambda arg body ->
94 P.parensIf needsParens (prettyLambda dealiaser getCanLambda arg body)
96 Var x ->
97 P.text x
99 Type var ->
100 prettyType dealiaser var
102 App func args ->
103 let
104 isTuple (Type name) = Help.isTuple (Var.toString name)
105 isTuple _ = False
106 in
107 prettyApp dealiaser needsParens isTuple func args
109 Record fields ext ->
110 prettyRecord dealiaser (flattenCanRecord fields ext)
112 Aliased name args _ ->
113 P.parensIf (needsParens && not (null args)) $
114 P.hang
115 (P.pretty dealiaser False name)
116 2
117 (P.sep (map (P.pretty dealiaser True . snd) args))
120-- PRETTY HELPERS
122prettyType :: (Var.ToString var) => P.Dealiaser -> var -> P.Doc
123prettyType dealiaser var =
124 let
125 v = Var.toString var
126 in
127 P.text $
128 if v == "_Tuple0" then
129 "()"
130 else
131 maybe v id (Map.lookup v dealiaser)
134-- PRETTY LAMBDAS
136prettyLambda :: (P.Pretty t) => P.Dealiaser -> (t -> Maybe (t,t)) -> t -> t -> P.Doc
137prettyLambda dealiaser getLambda arg body =
138 let
139 rest =
140 gatherLambda getLambda body
142 prettyArg t =
143 P.pretty dealiaser (Maybe.isJust (getLambda t)) t
144 in
145 P.sep
146 [ prettyArg arg
147 , P.sep (map (\t -> P.text "->" <+> prettyArg t) rest)
148 ]
151getRawLambda :: Raw -> Maybe (Raw, Raw)
152getRawLambda (A.A _ tipe) =
153 case tipe of
154 RLambda arg body -> Just (arg, body)
155 _ -> Nothing
158getCanLambda :: Canonical -> Maybe (Canonical, Canonical)
159getCanLambda tipe =
160 case tipe of
161 Lambda arg body -> Just (arg, body)
162 _ -> Nothing
165gatherLambda :: (t -> Maybe (t,t)) -> t -> [t]
166gatherLambda get tipe =
167 case get tipe of
168 Just (arg, body) ->
169 arg : gatherLambda get body
171 Nothing ->
172 [tipe]
175collectLambdas :: Canonical -> [Canonical]
176collectLambdas tipe =
177 gatherLambda getCanLambda tipe
180-- PRETTY APP
182prettyApp :: (P.Pretty t) => P.Dealiaser -> Bool -> (t -> Bool) -> t -> [t] -> P.Doc
183prettyApp dealiaser needsParens isTuple func args
184 | isTuple func =
185 P.parens $ P.sep $
186 P.punctuate P.comma (map (P.pretty dealiaser False) args)
188 | null args =
189 P.pretty dealiaser needsParens func
191 | otherwise =
192 P.parensIf needsParens $
193 P.hang
194 (P.pretty dealiaser True func)
195 2
196 (P.sep (map (P.pretty dealiaser True) args))
199-- PRETTY RECORD
201prettyRecord :: (P.Pretty t) => P.Dealiaser -> ([(String, t)], Maybe String) -> P.Doc
202prettyRecord dealiaser recordInfo =
203 let
204 prettyField (field, tipe) =
205 P.hang
206 (P.text field <+> P.text ":")
207 4
208 (P.pretty dealiaser False tipe)
209 in
210 case recordInfo of
211 ([], Nothing) ->
212 P.text "{}"
214 (fields, Nothing) ->
215 P.sep
216 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
217 , P.rbrace
218 ]
220 (fields, Just x) ->
221 P.hang
222 (P.lbrace <+> P.text x <+> P.text "|")
223 4
224 (P.sep
225 [ P.sep (P.punctuate P.comma (map prettyField fields))
226 , P.rbrace
227 ]
228 )
231flattenRawRecord
232 :: [(String, Raw)]
233 -> Maybe Raw
234 -> ( [(String, Raw)], Maybe String )
235flattenRawRecord fields ext =
236 case ext of
237 Nothing ->
238 (fields, Nothing)
240 Just (A.A _ (RVar x)) ->
241 (fields, Just x)
243 Just (A.A _ (RRecord fields' ext')) ->
244 flattenRawRecord (fields' ++ fields) ext'
246 _ ->
247 error "Trying to flatten ill-formed record."
250flattenCanRecord
251 :: [(String, Canonical)]
252 -> Maybe Canonical
253 -> ( [(String, Canonical)], Maybe String )
254flattenCanRecord fields ext =
255 case ext of
256 Nothing ->
257 (fields, Nothing)
259 Just (Var x) ->
260 (fields, Just x)
262 Just (Record fields' ext') ->
263 flattenCanRecord (fields' ++ fields) ext'
265 Just (Aliased _ args tipe) ->
266 flattenCanRecord fields (Just (dealias args tipe))
268 _ ->
269 error "Trying to flatten ill-formed record."
270--}