git.iko.soy/elk
on fe7bbbd help sign in
elk/src/Elm/Compiler/Type.hs
258 lines 6.1 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Elm.Compiler.Type
4 ( Type(..), toString
5 , Program(..)
6 )
7 where
9import Control.Arrow ((***))
10import Data.Aeson ((.:), (.=))
11import qualified Data.Aeson as Json
12import qualified Data.Aeson.Types as Json
13import qualified Data.ByteString.Lazy.Char8 as BS
14import qualified Data.Text as Text
15import Data.Text (Text)
16import Text.PrettyPrint as P
18import qualified AST.Helpers as Help
19import qualified AST.Type as Type
20import qualified AST.Variable as Var
21import qualified Parse.Helpers as Parse
22import qualified Parse.Type as Type
23import qualified Reporting.Annotation as A
27data Type
28 = Lambda Type Type
29 | Var Text
30 | Type Text
31 | App Type [Type]
32 | Record [(Text, Type)] (Maybe Type)
35data Program =
36 Program
37 { _message :: Type
38 , _aliases :: [( Text, [Text], Type )]
39 , _unions :: [( Text, [Text], [(Text, [Type])] )]
40 }
44-- TO STRING
47data Context = None | ADT | Function
50toString :: Type -> String
51toString tipe =
52 P.render (toDoc None tipe)
55toDoc :: Context -> Type -> P.Doc
56toDoc context tipe =
57 case tipe of
58 Lambda _ _ ->
59 let t:ts =
60 map (toDoc Function) (collectLambdas tipe)
62 lambda =
63 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
64 in
65 case context of
66 None -> lambda
67 _ -> P.parens lambda
69 Var name ->
70 P.text (Text.unpack name)
72 Type name ->
73 P.text (Text.unpack (if name == "_Tuple0" then "()" else name))
75 App (Type name) args ->
76 if name == "_Tuple0" then
77 P.text "()"
79 else if Help.isTuple name then
80 P.sep
81 [ P.cat (zipWith (<+>) (P.lparen : repeat P.comma) (map (toDoc None) args))
82 , P.rparen
83 ]
85 else
86 let
87 application =
88 P.hang
89 (P.text (Text.unpack name))
90 2
91 (P.sep $ map (toDoc ADT) args)
92 in
93 case (context, args) of
94 (ADT, _ : _) -> P.parens application
95 _ -> application
97 App _ _ ->
98 error $
99 "Somehow ended up with an unexpected type, please post a minimal example that\n"
100 ++ "reproduces this error to <https://github.com/elm-lang/elm-compiler/issues>"
102 Record _ _ ->
103 case flattenRecord tipe of
104 ([], Nothing) ->
105 P.text "{}"
107 (fields, Nothing) ->
108 P.sep
109 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
110 , P.rbrace
111 ]
113 (fields, Just x) ->
114 P.hang
115 (P.lbrace <+> P.text (Text.unpack x) <+> P.text "|")
116 4
117 (P.sep
118 [ P.sep (P.punctuate P.comma (map prettyField fields))
119 , P.rbrace
120 ]
121 )
122 where
123 prettyField (field, fieldType) =
124 P.text (Text.unpack field) <+> P.text ":" <+> toDoc None fieldType
127collectLambdas :: Type -> [Type]
128collectLambdas tipe =
129 case tipe of
130 Lambda arg body -> arg : collectLambdas body
131 _ -> [tipe]
134flattenRecord :: Type -> ( [(Text, Type)], Maybe Text )
135flattenRecord tipe =
136 case tipe of
137 Var x ->
138 ([], Just x)
140 Record fields Nothing ->
141 (fields, Nothing)
143 Record fields (Just ext) ->
144 let (fields',ext') = flattenRecord ext
145 in
146 (fields' ++ fields, ext')
148 _ ->
149 error "Trying to flatten ill-formed record."
153-- JSON for TYPE
156instance Json.ToJSON Type where
157 toJSON tipe =
158 Json.String (Text.unwords (Text.words (Text.pack (toString tipe))))
161instance Json.FromJSON Type where
162 parseJSON value =
163 let
164 failure _ =
165 fail $
166 "Trying to decode a type string, but could not handle this value:\n"
167 ++ BS.unpack (Json.encode value)
168 in
169 case value of
170 Json.String txt ->
171 case Parse.run Type.expression (Text.replace "'" "_" txt) of
172 Left err ->
173 failure err
175 Right (tipe, _, _) ->
176 return (fromRawType tipe)
178 Json.Object obj ->
179 fromObject obj
181 _ ->
182 failure ()
185fromObject :: Json.Object -> Json.Parser Type
186fromObject obj =
187 do tag <- obj .: "tag"
188 case (tag :: String) of
189 "lambda" ->
190 Lambda <$> obj .: "in" <*> obj .: "out"
192 "var" ->
193 Var <$> obj .: "name"
195 "type" ->
196 Type <$> obj .: "name"
198 "app" ->
199 App <$> obj .: "func" <*> obj .: "args"
201 "record" ->
202 Record <$> obj .: "fields" <*> obj .: "extension"
204 _ ->
205 fail $ "Error when decoding type with tag: " ++ tag
208fromRawType :: Type.Raw -> Type
209fromRawType (A.A _ astType) =
210 case astType of
211 Type.RLambda t1 t2 ->
212 Lambda (fromRawType t1) (fromRawType t2)
214 Type.RVar x ->
215 Var x
217 Type.RType var ->
218 Type (Var.rawToText var)
220 Type.RApp t ts ->
221 App (fromRawType t) (map fromRawType ts)
223 Type.RRecord fields ext ->
224 Record (map (A.drop *** fromRawType) fields) (fmap fromRawType ext)
228-- JSON for PROGRAM
231instance Json.ToJSON Program where
232 toJSON (Program msg aliases unions) =
233 Json.object
234 [ "message" .= msg
235 , "aliases" .= Json.object (map toAliasField aliases)
236 , "unions" .= Json.object (map toUnionField unions)
237 ]
240toAliasField :: ( Text, [Text], Type ) -> Json.Pair
241toAliasField ( name, args, tipe ) =
242 name .= Json.object
243 [ "args" .= args
244 , "type" .= tipe
245 ]
248toUnionField :: ( Text, [Text], [(Text, [Type])] ) -> Json.Pair
249toUnionField ( name, args, constructors ) =
250 name .= Json.object
251 [ "args" .= args
252 , "tags" .= Json.object (map toCtorObject constructors)
253 ]
256toCtorObject :: (Text, [Type]) -> Json.Pair
257toCtorObject (name, args) =
258 name .= args