git.iko.soy/elk
on aeb02cd help sign in
elk/src/Elm/Compiler/Type.hs
177 lines 4.6 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Elm.Compiler.Type
3 ( Type(..)
4 , toString
5 ) where
7import Control.Applicative ((<$>), (<*>))
8import Control.Arrow (second)
9import Data.Aeson ((.:), (.=))
10import qualified Data.Aeson as Json
11import qualified Data.ByteString.Lazy.Char8 as BS
12import qualified Data.Text as Text
13import Text.PrettyPrint as P
15import qualified AST.Helpers as Help
18data Type
19 = Lambda Type Type
20 | Var String
21 | Type String
22 | App Type [Type]
23 | Record [(String, Type)] (Maybe Type)
26-- TO STRING
28data Context = None | ADT | Function
31toString :: Type -> String
32toString tipe =
33 P.render (toDoc None tipe)
36toDoc :: Context -> Type -> P.Doc
37toDoc context tipe =
38 case tipe of
39 Lambda _ _ ->
40 let t:ts =
41 map (toDoc Function) (collectLambdas tipe)
43 lambda =
44 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
45 in
46 case context of
47 None -> lambda
48 _ -> P.parens lambda
50 Var name ->
51 P.text name
53 Type name ->
54 P.text (if name == "_Tuple0" then "()" else name)
56 App (Type name) args
57 | Help.isTuple name ->
58 P.sep
59 [ P.cat (zipWith (<+>) (P.lparen : repeat P.comma) (map (toDoc None) args))
60 , P.rparen
61 ]
63 | otherwise ->
64 let adt = P.hang (P.text name) 2 (P.sep $ map (toDoc ADT) args)
65 in
66 case (context, args) of
67 (ADT, _ : _) -> P.parens adt
68 _ -> adt
70 Record _ _ ->
71 case flattenRecord tipe of
72 ([], Nothing) ->
73 P.text "{}"
75 (fields, Nothing) ->
76 P.sep
77 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
78 , P.rbrace
79 ]
81 (fields, Just x) ->
82 P.hang
83 (P.lbrace <+> P.text x <+> P.text "|")
84 4
85 (P.sep
86 [ P.cat (zipWith (<+>) (P.space : repeat P.comma) (map prettyField fields))
87 , P.rbrace
88 ])
89 where
90 prettyField (field, tipe) =
91 P.text field <+> P.text ":" <+> toDoc None tipe
94collectLambdas :: Type -> [Type]
95collectLambdas tipe =
96 case tipe of
97 Lambda arg body -> arg : collectLambdas body
98 _ -> [tipe]
101flattenRecord :: Type -> ( [(String, Type)], Maybe String )
102flattenRecord tipe =
103 case tipe of
104 Var x -> ([], Just x)
106 Record fields Nothing -> (fields, Nothing)
108 Record fields (Just ext) ->
109 let (fields',ext') = flattenRecord ext
110 in
111 (fields' ++ fields, ext')
113 _ -> error "Trying to flatten ill-formed record."
116-- JSON for TYPE
118instance Json.ToJSON Type where
119 toJSON tipe =
120 Json.object (getFields tipe)
121 where
122 getFields tipe =
123 case tipe of
124 Lambda t1 t2 ->
125 [ "tag" .= ("lambda" :: Text.Text)
126 , "in" .= Json.toJSON t1
127 , "out" .= Json.toJSON t2
128 ]
130 Var x ->
131 [ "tag" .= ("var" :: Text.Text)
132 , "name" .= Json.toJSON x
133 ]
135 Type name ->
136 [ "tag" .= ("type" :: Text.Text)
137 , "name" .= Json.toJSON name
138 ]
140 App t ts ->
141 [ "tag" .= ("app" :: Text.Text)
142 , "func" .= Json.toJSON t
143 , "args" .= Json.toJSON ts
144 ]
146 Record fields ext ->
147 [ "tag" .= ("record" :: Text.Text)
148 , "fields" .= Json.toJSON (map (Json.toJSON . second Json.toJSON) fields)
149 , "extension" .= Json.toJSON ext
150 ]
153instance Json.FromJSON Type where
154 parseJSON (Json.Object obj) =
155 do tag <- obj .: "tag"
156 case (tag :: String) of
157 "lambda" ->
158 Lambda <$> obj .: "in" <*> obj .: "out"
160 "var" ->
161 Var <$> obj .: "name"
163 "type" ->
164 Type <$> obj .: "name"
166 "app" ->
167 App <$> obj .: "func" <*> obj .: "args"
169 "record" ->
170 Record <$> obj .: "fields" <*> obj .: "extension"
172 _ ->
173 fail $ "Error when decoding type with tag: " ++ tag
176 parseJSON value =
177 fail $ "Cannot decode Value from: " ++ BS.unpack (Json.encode value)