git.iko.soy/elk
on e00a3f3 help sign in
elk/src/Elm/Compiler/Type.hs
246 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 qualified Text.PrettyPrint as P
18import Text.PrettyPrint ((<+>))
20import qualified AST.Helpers as Help
21import qualified AST.Type as Type
22import qualified AST.Variable as Var
23import qualified Parse.Helpers as Parse
24import qualified Parse.Type as Type
25import qualified Reporting.Annotation as A
26import qualified Json.Decode as Decode
27import qualified Json.Encode as Encode
28import Json.Encode ((==>))
32-- TYPES
35data Type
36 = Lambda Type Type
37 | Var Text
38 | Type Text
39 | App Type [Type]
40 | Record [(Text, Type)] (Maybe Type)
43data Program =
44 Program
45 { _message :: Type
46 , _aliases :: [( Text, [Text], Type )]
47 , _unions :: [( Text, [Text], [(Text, [Type])] )]
48 }
52-- TO STRING
55data Format = OneLine | MultiLine
58toString :: Format -> Type -> String
59toString format tipe =
60 let
61 mode =
62 case format of
63 OneLine ->
64 P.OneLineMode
65 MultiLine ->
66 P.PageMode
67 in
68 P.renderStyle (P.Style mode 80 1.0) (toDoc None tipe)
71data Context = None | InType | InFunction
74toDoc :: Context -> Type -> P.Doc
75toDoc context tipe =
76 case tipe of
77 Lambda _ _ ->
78 let t:ts =
79 map (toDoc InFunction) (collectLambdas tipe)
81 lambda =
82 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
83 in
84 case context of
85 None -> lambda
86 _ -> P.parens lambda
88 Var name ->
89 P.text (Text.unpack name)
91 Type name ->
92 P.text (Text.unpack (if name == Help.zeroTuple then "()" else name))
94 App (Type name) args ->
95 if name == Help.zeroTuple then
96 P.text "()"
98 else if Help.isTuple name then
99 P.sep
100 [ P.cat (zipWith (<+>) (P.lparen : repeat P.comma) (map (toDoc None) args))
101 , P.rparen
102 ]
104 else
105 let
106 application =
107 P.hang
108 (P.text (Text.unpack name))
109 2
110 (P.sep $ map (toDoc InType) args)
111 in
112 case (context, args) of
113 (InType, _ : _) ->
114 P.parens application
116 _ ->
117 application
119 App _ _ ->
120 error $
121 "Somehow ended up with an unexpected type, please post a minimal example that\n"
122 ++ "reproduces this error to <https://github.com/elm-lang/elm-compiler/issues>"
124 Record _ _ ->
125 case flattenRecord tipe of
126 ([], Nothing) ->
127 P.text "{}"
129 (fields, Nothing) ->
130 P.sep
131 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
132 , P.rbrace
133 ]
135 (fields, Just x) ->
136 P.hang
137 (P.lbrace <+> P.text (Text.unpack x) <+> P.text "|")
138 4
139 (P.sep
140 [ P.sep (P.punctuate P.comma (map prettyField fields))
141 , P.rbrace
142 ]
143 )
144 where
145 prettyField (field, fieldType) =
146 P.text (Text.unpack field) <+> P.text ":" <+> toDoc None fieldType
149collectLambdas :: Type -> [Type]
150collectLambdas tipe =
151 case tipe of
152 Lambda arg body -> arg : collectLambdas body
153 _ -> [tipe]
156flattenRecord :: Type -> ( [(Text, Type)], Maybe Text )
157flattenRecord tipe =
158 case tipe of
159 Var x ->
160 ([], Just x)
162 Record fields Nothing ->
163 (fields, Nothing)
165 Record fields (Just ext) ->
166 let (fields',ext') = flattenRecord ext
167 in
168 (fields' ++ fields, ext')
170 _ ->
171 error "Trying to flatten ill-formed record."
175-- JSON for TYPE
178encode :: Type -> Encode.Value
179encode tipe =
180 Encode.text (Text.pack (toString OneLine tipe))
183decoder :: Decode.Decoder Type
184decoder =
185 do txt <- Decode.text
186 case Parse.run Type.expression txt of
187 Left _ ->
188 Decode.fail "a type, like (String -> Int)"
190 Right (tipe, _, _) ->
191 Decode.succeed (fromRawType tipe)
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.rawToText var)
206 Type.RApp t ts ->
207 App (fromRawType t) (map fromRawType ts)
209 Type.RRecord fields ext ->
210 Record (map (A.drop *** fromRawType) fields) (fmap fromRawType ext)
214-- JSON for PROGRAM
217encodeProgram :: Program -> Encode.Value
218encodeProgram (Program msg aliases unions) =
219 Encode.object
220 [ "message" ==> encode msg
221 , "aliases" ==> Encode.object (map toAliasField aliases)
222 , "unions" ==> Encode.object (map toUnionField unions)
223 ]
226toAliasField :: ( Text, [Text], Type ) -> ( String, Encode.Value )
227toAliasField ( name, args, tipe ) =
228 Text.unpack name ==>
229 Encode.object
230 [ "args" ==> Encode.list Encode.text args
231 , "type" ==> encode tipe
232 ]
235toUnionField :: ( Text, [Text], [(Text, [Type])] ) -> ( String, Encode.Value )
236toUnionField ( name, args, constructors ) =
237 Text.unpack name ==>
238 Encode.object
239 [ "args" ==> Encode.list Encode.text args
240 , "tags" ==> Encode.object (map toCtorObject constructors)
241 ]
244toCtorObject :: (Text, [Type]) -> ( String, Encode.Value )
245toCtorObject (name, args) =
246 Text.unpack name ==> Encode.list encode args