git.iko.soy/elk
on 774aebd help sign in
elk/src/Elm/Compiler/Type.hs
245 lines 5.7 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 qualified Data.Text as Text
16import Data.Text (Text)
17import Text.PrettyPrint as P
19import qualified AST.Helpers as Help
20import qualified AST.Type as Type
21import qualified AST.Variable as Var
22import qualified Parse.Helpers as Parse
23import qualified Parse.Type as Type
24import qualified Reporting.Annotation as A
25import qualified Json.Decode as Decode
26import qualified Json.Encode as Encode
27import Json.Encode ((==>))
31-- TYPES
34data Type
35 = Lambda Type Type
36 | Var Text
37 | Type Text
38 | App Type [Type]
39 | Record [(Text, Type)] (Maybe Type)
42data Program =
43 Program
44 { _message :: Type
45 , _aliases :: [( Text, [Text], Type )]
46 , _unions :: [( Text, [Text], [(Text, [Type])] )]
47 }
51-- TO STRING
54data Format = OneLine | MultiLine
57toString :: Format -> Type -> String
58toString format tipe =
59 let
60 mode =
61 case format of
62 OneLine ->
63 P.OneLineMode
64 MultiLine ->
65 P.PageMode
66 in
67 P.renderStyle (P.Style mode 80 1.0) (toDoc None tipe)
70data Context = None | InType | InFunction
73toDoc :: Context -> Type -> P.Doc
74toDoc context tipe =
75 case tipe of
76 Lambda _ _ ->
77 let t:ts =
78 map (toDoc InFunction) (collectLambdas tipe)
80 lambda =
81 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
82 in
83 case context of
84 None -> lambda
85 _ -> P.parens lambda
87 Var name ->
88 P.text (Text.unpack name)
90 Type name ->
91 P.text (Text.unpack (if name == "_Tuple0" then "()" else name))
93 App (Type name) args ->
94 if name == "_Tuple0" then
95 P.text "()"
97 else if Help.isTuple name then
98 P.sep
99 [ P.cat (zipWith (<+>) (P.lparen : repeat P.comma) (map (toDoc None) args))
100 , P.rparen
101 ]
103 else
104 let
105 application =
106 P.hang
107 (P.text (Text.unpack name))
108 2
109 (P.sep $ map (toDoc InType) args)
110 in
111 case (context, args) of
112 (InType, _ : _) ->
113 P.parens application
115 _ ->
116 application
118 App _ _ ->
119 error $
120 "Somehow ended up with an unexpected type, please post a minimal example that\n"
121 ++ "reproduces this error to <https://github.com/elm-lang/elm-compiler/issues>"
123 Record _ _ ->
124 case flattenRecord tipe of
125 ([], Nothing) ->
126 P.text "{}"
128 (fields, Nothing) ->
129 P.sep
130 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
131 , P.rbrace
132 ]
134 (fields, Just x) ->
135 P.hang
136 (P.lbrace <+> P.text (Text.unpack x) <+> P.text "|")
137 4
138 (P.sep
139 [ P.sep (P.punctuate P.comma (map prettyField fields))
140 , P.rbrace
141 ]
142 )
143 where
144 prettyField (field, fieldType) =
145 P.text (Text.unpack field) <+> P.text ":" <+> toDoc None fieldType
148collectLambdas :: Type -> [Type]
149collectLambdas tipe =
150 case tipe of
151 Lambda arg body -> arg : collectLambdas body
152 _ -> [tipe]
155flattenRecord :: Type -> ( [(Text, Type)], Maybe Text )
156flattenRecord tipe =
157 case tipe of
158 Var x ->
159 ([], Just x)
161 Record fields Nothing ->
162 (fields, Nothing)
164 Record fields (Just ext) ->
165 let (fields',ext') = flattenRecord ext
166 in
167 (fields' ++ fields, ext')
169 _ ->
170 error "Trying to flatten ill-formed record."
174-- JSON for TYPE
177encode :: Type -> Encode.Value
178encode tipe =
179 Encode.text (Text.pack (toString OneLine tipe))
182decoder :: Decode.Decoder Type
183decoder =
184 do txt <- Decode.text
185 case Parse.run Type.expression txt of
186 Left _ ->
187 Decode.fail "a type, like (String -> Int)"
189 Right (tipe, _, _) ->
190 Decode.succeed (fromRawType tipe)
193fromRawType :: Type.Raw -> Type
194fromRawType (A.A _ astType) =
195 case astType of
196 Type.RLambda t1 t2 ->
197 Lambda (fromRawType t1) (fromRawType t2)
199 Type.RVar x ->
200 Var x
202 Type.RType var ->
203 Type (Var.rawToText var)
205 Type.RApp t ts ->
206 App (fromRawType t) (map fromRawType ts)
208 Type.RRecord fields ext ->
209 Record (map (A.drop *** fromRawType) fields) (fmap fromRawType ext)
213-- JSON for PROGRAM
216encodeProgram :: Program -> Encode.Value
217encodeProgram (Program msg aliases unions) =
218 Encode.object
219 [ "message" ==> encode msg
220 , "aliases" ==> Encode.object (map toAliasField aliases)
221 , "unions" ==> Encode.object (map toUnionField unions)
222 ]
225toAliasField :: ( Text, [Text], Type ) -> ( String, Encode.Value )
226toAliasField ( name, args, tipe ) =
227 Text.unpack name ==>
228 Encode.object
229 [ "args" ==> Encode.list Encode.text args
230 , "type" ==> encode tipe
231 ]
234toUnionField :: ( Text, [Text], [(Text, [Type])] ) -> ( String, Encode.Value )
235toUnionField ( name, args, constructors ) =
236 Text.unpack name ==>
237 Encode.object
238 [ "args" ==> Encode.list Encode.text args
239 , "tags" ==> Encode.object (map toCtorObject constructors)
240 ]
243toCtorObject :: (Text, [Type]) -> ( String, Encode.Value )
244toCtorObject (name, args) =
245 Text.unpack name ==> Encode.list encode args