git.iko.soy/elk
on 014d640 help sign in
elk/src/Elm/Compiler/Type.hs
246 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 { _model :: Type
36 , _msg :: Type
37 , _aliases :: [( String, [String], Type )]
38 , _unions :: [( String, [String], [(String, [Type])] )]
39 }
43-- TO STRING
46data Context = None | ADT | Function
49toString :: Type -> String
50toString tipe =
51 P.render (toDoc None tipe)
54toDoc :: Context -> Type -> P.Doc
55toDoc context tipe =
56 case tipe of
57 Lambda _ _ ->
58 let t:ts =
59 map (toDoc Function) (collectLambdas tipe)
61 lambda =
62 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
63 in
64 case context of
65 None -> lambda
66 _ -> P.parens lambda
68 Var name ->
69 P.text name
71 Type name ->
72 P.text (if name == "_Tuple0" then "()" else name)
74 App (Type name) args
75 | name == "_Tuple0" ->
76 P.text "()"
78 | Help.isTuple name ->
79 P.sep
80 [ P.cat (zipWith (<+>) (P.lparen : repeat P.comma) (map (toDoc None) args))
81 , P.rparen
82 ]
84 | otherwise ->
85 let adt = P.hang (P.text name) 2 (P.sep $ map (toDoc ADT) args)
86 in
87 case (context, args) of
88 (ADT, _ : _) -> P.parens adt
89 _ -> adt
91 App _ _ ->
92 error $
93 "Somehow ended up with an unexpected type, please post a minimal example that\n"
94 ++ "reproduces this error to <https://github.com/elm-lang/elm-compiler/issues>"
96 Record _ _ ->
97 case flattenRecord tipe of
98 ([], Nothing) ->
99 P.text "{}"
101 (fields, Nothing) ->
102 P.sep
103 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
104 , P.rbrace
105 ]
107 (fields, Just x) ->
108 P.hang
109 (P.lbrace <+> P.text x <+> P.text "|")
110 4
111 (P.sep
112 [ P.sep (P.punctuate P.comma (map prettyField fields))
113 , P.rbrace
114 ]
115 )
116 where
117 prettyField (field, tipe) =
118 P.text field <+> P.text ":" <+> toDoc None tipe
121collectLambdas :: Type -> [Type]
122collectLambdas tipe =
123 case tipe of
124 Lambda arg body -> arg : collectLambdas body
125 _ -> [tipe]
128flattenRecord :: Type -> ( [(String, Type)], Maybe String )
129flattenRecord tipe =
130 case tipe of
131 Var x -> ([], Just x)
133 Record fields Nothing -> (fields, Nothing)
135 Record fields (Just ext) ->
136 let (fields',ext') = flattenRecord ext
137 in
138 (fields' ++ fields, ext')
140 _ -> error "Trying to flatten ill-formed record."
144-- JSON for TYPE
147instance Json.ToJSON Type where
148 toJSON tipe =
149 Json.String (Text.unwords (Text.words (Text.pack (toString tipe))))
152instance Json.FromJSON Type where
153 parseJSON value =
154 let
155 failure _ =
156 fail $
157 "Trying to decode a type string, but could not handle this value:\n"
158 ++ BS.unpack (Json.encode value)
159 in
160 case value of
161 Json.String text ->
162 either failure (return . fromRawType)
163 (Parse.iParse Type.expr (Text.unpack text))
165 Json.Object obj ->
166 fromObject obj
168 _ ->
169 failure ()
172fromObject :: Json.Object -> Json.Parser Type
173fromObject obj =
174 do tag <- obj .: "tag"
175 case (tag :: String) of
176 "lambda" ->
177 Lambda <$> obj .: "in" <*> obj .: "out"
179 "var" ->
180 Var <$> obj .: "name"
182 "type" ->
183 Type <$> obj .: "name"
185 "app" ->
186 App <$> obj .: "func" <*> obj .: "args"
188 "record" ->
189 Record <$> obj .: "fields" <*> obj .: "extension"
191 _ ->
192 fail $ "Error when decoding type with tag: " ++ tag
195fromRawType :: Type.Raw -> Type
196fromRawType (A.A _ astType) =
197 case astType of
198 Type.RLambda t1 t2 ->
199 Lambda (fromRawType t1) (fromRawType t2)
201 Type.RVar x ->
202 Var x
204 Type.RType var ->
205 Type (Var.toString var)
207 Type.RApp t ts ->
208 App (fromRawType t) (map fromRawType ts)
210 Type.RRecord fields ext ->
211 Record (map (second fromRawType) fields) (fmap fromRawType ext)
215-- JSON for PROGRAM
218instance Json.ToJSON Program where
219 toJSON (Program model msg aliases unions) =
220 Json.object
221 [ "model" .= model
222 , "message" .= msg
223 , "aliases" .= Json.object (map toAliasField aliases)
224 , "unions" .= Json.object (map toUnionField unions)
225 ]
228toAliasField :: ( String, [String], Type ) -> Json.Pair
229toAliasField ( name, args, tipe ) =
230 Text.pack name .= Json.object
231 [ "args" .= args
232 , "type" .= tipe
233 ]
236toUnionField :: ( String, [String], [(String, [Type])] ) -> Json.Pair
237toUnionField ( name, args, constructors ) =
238 Text.pack name .= Json.object
239 [ "args" .= args
240 , "type" .= Json.object (map toCtorObject constructors)
241 ]
244toCtorObject :: (String, [Type]) -> Json.Pair
245toCtorObject (name, args) =
246 Text.pack name .= args