git.iko.soy/elk
on ea77dcf help sign in
elk/src/Elm/Compiler/Type.hs
273 lines 6.4 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Elm.Compiler.Type
4 ( Type(..)
5 , Format(..)
6 , toString
7 , Program(..)
8 , encode
9 , decoder
10 , encodeProgram
11 )
12 where
14import Control.Arrow ((***))
15import Data.Aeson ((.:))
16import qualified Data.Aeson as Aeson
17import qualified Data.Text as Text
18import Data.Text (Text)
19import qualified Text.PrettyPrint as P
20import Text.PrettyPrint ((<+>))
22import qualified AST.Helpers as Help
23import qualified AST.Type as Type
24import qualified AST.Variable as Var
25import qualified Parse.Helpers as Parse
26import qualified Parse.Type as Type
27import qualified Reporting.Annotation as A
28import qualified Json.Decode as Decode
29import qualified Json.Encode as Encode
30import Json.Encode ((==>))
34-- TYPES
37data Type
38 = Lambda Type Type
39 | Var Text
40 | Type Text [Type]
41 | Record [(Text, Type)] (Maybe Type)
44data Program =
45 Program
46 { _message :: Type
47 , _aliases :: [( Text, [Text], Type )]
48 , _unions :: [( Text, [Text], [(Text, [Type])] )]
49 }
53-- TO STRING
56data Format = OneLine | MultiLine
59toString :: Format -> Type -> String
60toString format tipe =
61 let
62 mode =
63 case format of
64 OneLine ->
65 P.OneLineMode
66 MultiLine ->
67 P.PageMode
68 in
69 P.renderStyle (P.Style mode 80 1.0) (toDoc None tipe)
72data Context = None | InType | InFunction
75toDoc :: Context -> Type -> P.Doc
76toDoc context tipe =
77 case tipe of
78 Lambda _ _ ->
79 let t:ts =
80 map (toDoc InFunction) (collectLambdas tipe)
82 lambda =
83 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
84 in
85 case context of
86 None -> lambda
87 _ -> P.parens lambda
89 Var name ->
90 P.text (Text.unpack name)
92 Type name [] ->
93 P.text (if name == Help.zeroTuple then "()" else Text.unpack name)
95 Type name arguments@(arg:args) ->
96 if Help.isTuple name then
97 P.sep
98 [ P.cat ("(" <+> toDoc None arg : map (\a -> "," <+> toDoc None a) args)
99 , ")"
100 ]
102 else
103 let
104 application =
105 P.hang
106 (P.text (Text.unpack name))
107 2
108 (P.sep $ map (toDoc InType) arguments)
109 in
110 case context of
111 InType ->
112 P.parens application
114 _ ->
115 application
117 Record _ _ ->
118 case flattenRecord tipe of
119 ([], Nothing) ->
120 P.text "{}"
122 (fields, Nothing) ->
123 P.sep
124 [ P.cat (zipWith (<+>) ("{" : repeat ",") (map prettyField fields))
125 , "}"
126 ]
128 (fields, Just x) ->
129 P.hang
130 ("{" <+> P.text (Text.unpack x) <+> "|")
131 4
132 (P.sep
133 [ P.sep (P.punctuate "," (map prettyField fields))
134 , "}"
135 ]
136 )
137 where
138 prettyField (field, fieldType) =
139 P.text (Text.unpack field) <+> ":" <+> toDoc None fieldType
142collectLambdas :: Type -> [Type]
143collectLambdas tipe =
144 case tipe of
145 Lambda arg body -> arg : collectLambdas body
146 _ -> [tipe]
149flattenRecord :: Type -> ( [(Text, Type)], Maybe Text )
150flattenRecord tipe =
151 case tipe of
152 Var x ->
153 ([], Just x)
155 Record fields Nothing ->
156 (fields, Nothing)
158 Record fields (Just ext) ->
159 let (fields',ext') = flattenRecord ext
160 in
161 (fields' ++ fields, ext')
163 _ ->
164 error "Trying to flatten ill-formed record."
168-- JSON for TYPE
171encode :: Type -> Encode.Value
172encode tipe =
173 Encode.text (Text.pack (toString OneLine tipe))
176decoder :: Decode.Decoder Type
177decoder =
178 Decode.oneOf
179 [
180 do txt <- Decode.text
181 case Parse.run Type.expression (Text.replace "'" "_" txt) of
182 Left _ ->
183 Decode.fail "Expecting a type, like (String -> Int)"
185 Right (tipe, _, _) ->
186 Decode.succeed (fromRawType tipe)
187 ,
188 Decode.aeson
189 ]
192instance Aeson.FromJSON Type where
193 parseJSON =
194 Aeson.withObject "Type" $ \object ->
195 do tag <- object .: "tag"
196 case (tag :: String) of
197 "lambda" ->
198 Lambda <$> object .: "in" <*> object .: "out"
200 "var" ->
201 Var <$> object .: "name"
203 "type" ->
204 do name <- object .: "name"
205 return (Type name [])
207 "app" ->
208 do func <- object .: "func"
209 args <- object .: "args"
210 case func of
211 Type name [] ->
212 return (Type name args)
214 _ ->
215 fail "unexpected type application"
217 "record" ->
218 Record <$> object .: "fields" <*> object .: "extension"
220 _ ->
221 fail $ "Error when decoding type with tag: " ++ tag
224fromRawType :: Type.Raw -> Type
225fromRawType (A.A _ astType) =
226 case astType of
227 Type.RLambda t1 t2 ->
228 Lambda (fromRawType t1) (fromRawType t2)
230 Type.RVar x ->
231 Var x
233 Type.RType (A.A _ name) args ->
234 Type (Var.rawToText name) (map fromRawType args)
236 Type.RRecord fields ext ->
237 Record (map (A.drop *** fromRawType) fields) (fmap fromRawType ext)
241-- JSON for PROGRAM
244encodeProgram :: Program -> Encode.Value
245encodeProgram (Program msg aliases unions) =
246 Encode.object
247 [ "message" ==> encode msg
248 , "aliases" ==> Encode.object (map toAliasField aliases)
249 , "unions" ==> Encode.object (map toUnionField unions)
250 ]
253toAliasField :: ( Text, [Text], Type ) -> ( String, Encode.Value )
254toAliasField ( name, args, tipe ) =
255 Text.unpack name ==>
256 Encode.object
257 [ "args" ==> Encode.list Encode.text args
258 , "type" ==> encode tipe
259 ]
262toUnionField :: ( Text, [Text], [(Text, [Type])] ) -> ( String, Encode.Value )
263toUnionField ( name, args, constructors ) =
264 Text.unpack name ==>
265 Encode.object
266 [ "args" ==> Encode.list Encode.text args
267 , "tags" ==> Encode.object (map toCtorObject constructors)
268 ]
271toCtorObject :: (Text, [Type]) -> ( String, Encode.Value )
272toCtorObject (name, args) =
273 Text.unpack name ==> Encode.list encode args