git.iko.soy/elk
on 2de786d help sign in
elk/src/Elm/Compiler/Type.hs
244 lines 5.8 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Elm.Compiler.Type
3 ( Type(..), toString
4 , Program(..)
5 )
6 where
8import Control.Arrow (second)
9import Data.Aeson ((.:), (.=))
10import qualified Data.Aeson as Json
11import qualified Data.Aeson.Types as Json
12import qualified Data.ByteString.Lazy.Char8 as BS
13import qualified Data.Text as Text
14import Text.PrettyPrint as P
16import qualified AST.Helpers as Help
17import qualified AST.Type as Type
18import qualified AST.Variable as Var
19import qualified Parse.Helpers as Parse
20import qualified Parse.Type as Type
21import qualified Reporting.Annotation as A
25data Type
26 = Lambda Type Type
27 | Var String
28 | Type String
29 | App Type [Type]
30 | Record [(String, Type)] (Maybe Type)
33data Program =
34 Program
35 { _message :: Type
36 , _aliases :: [( String, [String], Type )]
37 , _unions :: [( String, [String], [(String, [Type])] )]
38 }
42-- TO STRING
45data Context = None | ADT | Function
48toString :: Type -> String
49toString tipe =
50 P.render (toDoc None tipe)
53toDoc :: Context -> Type -> P.Doc
54toDoc context tipe =
55 case tipe of
56 Lambda _ _ ->
57 let t:ts =
58 map (toDoc Function) (collectLambdas tipe)
60 lambda =
61 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
62 in
63 case context of
64 None -> lambda
65 _ -> P.parens lambda
67 Var name ->
68 P.text name
70 Type name ->
71 P.text (if name == "_Tuple0" then "()" else name)
73 App (Type name) args
74 | name == "_Tuple0" ->
75 P.text "()"
77 | Help.isTuple name ->
78 P.sep
79 [ P.cat (zipWith (<+>) (P.lparen : repeat P.comma) (map (toDoc None) args))
80 , P.rparen
81 ]
83 | otherwise ->
84 let adt = P.hang (P.text name) 2 (P.sep $ map (toDoc ADT) args)
85 in
86 case (context, args) of
87 (ADT, _ : _) -> P.parens adt
88 _ -> adt
90 App _ _ ->
91 error $
92 "Somehow ended up with an unexpected type, please post a minimal example that\n"
93 ++ "reproduces this error to <https://github.com/elm-lang/elm-compiler/issues>"
95 Record _ _ ->
96 case flattenRecord tipe of
97 ([], Nothing) ->
98 P.text "{}"
100 (fields, Nothing) ->
101 P.sep
102 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
103 , P.rbrace
104 ]
106 (fields, Just x) ->
107 P.hang
108 (P.lbrace <+> P.text x <+> P.text "|")
109 4
110 (P.sep
111 [ P.sep (P.punctuate P.comma (map prettyField fields))
112 , P.rbrace
113 ]
114 )
115 where
116 prettyField (field, tipe) =
117 P.text field <+> P.text ":" <+> toDoc None tipe
120collectLambdas :: Type -> [Type]
121collectLambdas tipe =
122 case tipe of
123 Lambda arg body -> arg : collectLambdas body
124 _ -> [tipe]
127flattenRecord :: Type -> ( [(String, Type)], Maybe String )
128flattenRecord tipe =
129 case tipe of
130 Var x -> ([], Just x)
132 Record fields Nothing -> (fields, Nothing)
134 Record fields (Just ext) ->
135 let (fields',ext') = flattenRecord ext
136 in
137 (fields' ++ fields, ext')
139 _ -> error "Trying to flatten ill-formed record."
143-- JSON for TYPE
146instance Json.ToJSON Type where
147 toJSON tipe =
148 Json.String (Text.unwords (Text.words (Text.pack (toString tipe))))
151instance Json.FromJSON Type where
152 parseJSON value =
153 let
154 failure _ =
155 fail $
156 "Trying to decode a type string, but could not handle this value:\n"
157 ++ BS.unpack (Json.encode value)
158 in
159 case value of
160 Json.String text ->
161 either failure (return . fromRawType)
162 (Parse.iParse Type.expr (Text.unpack text))
164 Json.Object obj ->
165 fromObject obj
167 _ ->
168 failure ()
171fromObject :: Json.Object -> Json.Parser Type
172fromObject obj =
173 do tag <- obj .: "tag"
174 case (tag :: String) of
175 "lambda" ->
176 Lambda <$> obj .: "in" <*> obj .: "out"
178 "var" ->
179 Var <$> obj .: "name"
181 "type" ->
182 Type <$> obj .: "name"
184 "app" ->
185 App <$> obj .: "func" <*> obj .: "args"
187 "record" ->
188 Record <$> obj .: "fields" <*> obj .: "extension"
190 _ ->
191 fail $ "Error when decoding type with tag: " ++ tag
194fromRawType :: Type.Raw -> Type
195fromRawType (A.A _ astType) =
196 case astType of
197 Type.RLambda t1 t2 ->
198 Lambda (fromRawType t1) (fromRawType t2)
200 Type.RVar x ->
201 Var x
203 Type.RType var ->
204 Type (Var.toString var)
206 Type.RApp t ts ->
207 App (fromRawType t) (map fromRawType ts)
209 Type.RRecord fields ext ->
210 Record (map (second fromRawType) fields) (fmap fromRawType ext)
214-- JSON for PROGRAM
217instance Json.ToJSON Program where
218 toJSON (Program msg aliases unions) =
219 Json.object
220 [ "message" .= msg
221 , "aliases" .= Json.object (map toAliasField aliases)
222 , "unions" .= Json.object (map toUnionField unions)
223 ]
226toAliasField :: ( String, [String], Type ) -> Json.Pair
227toAliasField ( name, args, tipe ) =
228 Text.pack name .= Json.object
229 [ "args" .= args
230 , "type" .= tipe
231 ]
234toUnionField :: ( String, [String], [(String, [Type])] ) -> Json.Pair
235toUnionField ( name, args, constructors ) =
236 Text.pack name .= Json.object
237 [ "args" .= args
238 , "tags" .= Json.object (map toCtorObject constructors)
239 ]
242toCtorObject :: (String, [Type]) -> Json.Pair
243toCtorObject (name, args) =
244 Text.pack name .= args