git.iko.soy/elk
on 98db71d help sign in
elk/src/Elm/Compiler/Type.hs
249 lines 5.9 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.parse Type.expr (replacePrimes (Text.unpack text))
164 Json.Object obj ->
165 fromObject obj
167 _ ->
168 failure ()
171replacePrimes :: String -> String
172replacePrimes string =
173 map (\c -> if c == '\'' then '_' else c) string
176fromObject :: Json.Object -> Json.Parser Type
177fromObject obj =
178 do tag <- obj .: "tag"
179 case (tag :: String) of
180 "lambda" ->
181 Lambda <$> obj .: "in" <*> obj .: "out"
183 "var" ->
184 Var <$> obj .: "name"
186 "type" ->
187 Type <$> obj .: "name"
189 "app" ->
190 App <$> obj .: "func" <*> obj .: "args"
192 "record" ->
193 Record <$> obj .: "fields" <*> obj .: "extension"
195 _ ->
196 fail $ "Error when decoding type with tag: " ++ tag
199fromRawType :: Type.Raw -> Type
200fromRawType (A.A _ astType) =
201 case astType of
202 Type.RLambda t1 t2 ->
203 Lambda (fromRawType t1) (fromRawType t2)
205 Type.RVar x ->
206 Var x
208 Type.RType var ->
209 Type (Var.toString var)
211 Type.RApp t ts ->
212 App (fromRawType t) (map fromRawType ts)
214 Type.RRecord fields ext ->
215 Record (map (second fromRawType) fields) (fmap fromRawType ext)
219-- JSON for PROGRAM
222instance Json.ToJSON Program where
223 toJSON (Program msg aliases unions) =
224 Json.object
225 [ "message" .= msg
226 , "aliases" .= Json.object (map toAliasField aliases)
227 , "unions" .= Json.object (map toUnionField unions)
228 ]
231toAliasField :: ( String, [String], Type ) -> Json.Pair
232toAliasField ( name, args, tipe ) =
233 Text.pack name .= Json.object
234 [ "args" .= args
235 , "type" .= tipe
236 ]
239toUnionField :: ( String, [String], [(String, [Type])] ) -> Json.Pair
240toUnionField ( name, args, constructors ) =
241 Text.pack name .= Json.object
242 [ "args" .= args
243 , "tags" .= Json.object (map toCtorObject constructors)
244 ]
247toCtorObject :: (String, [Type]) -> Json.Pair
248toCtorObject (name, args) =
249 Text.pack name .= args