git.iko.soy/elk
on 441aeba help sign in
elk/src/Elm/Compiler/Type.hs
229 lines 5.4 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Elm.Compiler.Type
4 ( Type(..), toString
5 , Program(..)
6 , encode
7 , decoder
8 , encodeProgram
9 )
10 where
12import Control.Arrow ((***))
13import qualified Data.Text as Text
14import Data.Text (Text)
15import Text.PrettyPrint as P
17import qualified AST.Helpers as Help
18import qualified AST.Type as Type
19import qualified AST.Variable as Var
20import qualified Parse.Helpers as Parse
21import qualified Parse.Type as Type
22import qualified Reporting.Annotation as A
23import qualified Json.Decode as Decode
24import qualified Json.Encode as Encode
25import Json.Encode ((==>))
29-- TYPES
32data Type
33 = Lambda Type Type
34 | Var Text
35 | Type Text
36 | App Type [Type]
37 | Record [(Text, Type)] (Maybe Type)
40data Program =
41 Program
42 { _message :: Type
43 , _aliases :: [( Text, [Text], Type )]
44 , _unions :: [( Text, [Text], [(Text, [Type])] )]
45 }
49-- TO STRING
52data Context = None | ADT | Function
55toString :: Type -> String
56toString tipe =
57 P.render (toDoc None tipe)
60toDoc :: Context -> Type -> P.Doc
61toDoc context tipe =
62 case tipe of
63 Lambda _ _ ->
64 let t:ts =
65 map (toDoc Function) (collectLambdas tipe)
67 lambda =
68 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
69 in
70 case context of
71 None -> lambda
72 _ -> P.parens lambda
74 Var name ->
75 P.text (Text.unpack name)
77 Type name ->
78 P.text (Text.unpack (if name == "_Tuple0" then "()" else name))
80 App (Type name) args ->
81 if name == "_Tuple0" then
82 P.text "()"
84 else if Help.isTuple name then
85 P.sep
86 [ P.cat (zipWith (<+>) (P.lparen : repeat P.comma) (map (toDoc None) args))
87 , P.rparen
88 ]
90 else
91 let
92 application =
93 P.hang
94 (P.text (Text.unpack name))
95 2
96 (P.sep $ map (toDoc ADT) args)
97 in
98 case (context, args) of
99 (ADT, _ : _) -> P.parens application
100 _ -> application
102 App _ _ ->
103 error $
104 "Somehow ended up with an unexpected type, please post a minimal example that\n"
105 ++ "reproduces this error to <https://github.com/elm-lang/elm-compiler/issues>"
107 Record _ _ ->
108 case flattenRecord tipe of
109 ([], Nothing) ->
110 P.text "{}"
112 (fields, Nothing) ->
113 P.sep
114 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
115 , P.rbrace
116 ]
118 (fields, Just x) ->
119 P.hang
120 (P.lbrace <+> P.text (Text.unpack x) <+> P.text "|")
121 4
122 (P.sep
123 [ P.sep (P.punctuate P.comma (map prettyField fields))
124 , P.rbrace
125 ]
126 )
127 where
128 prettyField (field, fieldType) =
129 P.text (Text.unpack field) <+> P.text ":" <+> toDoc None fieldType
132collectLambdas :: Type -> [Type]
133collectLambdas tipe =
134 case tipe of
135 Lambda arg body -> arg : collectLambdas body
136 _ -> [tipe]
139flattenRecord :: Type -> ( [(Text, Type)], Maybe Text )
140flattenRecord tipe =
141 case tipe of
142 Var x ->
143 ([], Just x)
145 Record fields Nothing ->
146 (fields, Nothing)
148 Record fields (Just ext) ->
149 let (fields',ext') = flattenRecord ext
150 in
151 (fields' ++ fields, ext')
153 _ ->
154 error "Trying to flatten ill-formed record."
158-- JSON for TYPE
161encode :: Type -> Encode.Value
162encode tipe =
163 Encode.text (Text.unwords (Text.words (Text.pack (toString tipe))))
166decoder :: Decode.Decoder Type
167decoder =
168 do txt <- Decode.text
169 case Parse.run Type.expression txt of
170 Left _ ->
171 Decode.fail "a type, like (String -> Int)"
173 Right (tipe, _, _) ->
174 Decode.succeed (fromRawType tipe)
177fromRawType :: Type.Raw -> Type
178fromRawType (A.A _ astType) =
179 case astType of
180 Type.RLambda t1 t2 ->
181 Lambda (fromRawType t1) (fromRawType t2)
183 Type.RVar x ->
184 Var x
186 Type.RType var ->
187 Type (Var.rawToText var)
189 Type.RApp t ts ->
190 App (fromRawType t) (map fromRawType ts)
192 Type.RRecord fields ext ->
193 Record (map (A.drop *** fromRawType) fields) (fmap fromRawType ext)
197-- JSON for PROGRAM
200encodeProgram :: Program -> Encode.Value
201encodeProgram (Program msg aliases unions) =
202 Encode.object
203 [ "message" ==> encode msg
204 , "aliases" ==> Encode.object (map toAliasField aliases)
205 , "unions" ==> Encode.object (map toUnionField unions)
206 ]
209toAliasField :: ( Text, [Text], Type ) -> ( String, Encode.Value )
210toAliasField ( name, args, tipe ) =
211 Text.unpack name ==>
212 Encode.object
213 [ "args" ==> Encode.list Encode.text args
214 , "type" ==> encode tipe
215 ]
218toUnionField :: ( Text, [Text], [(Text, [Type])] ) -> ( String, Encode.Value )
219toUnionField ( name, args, constructors ) =
220 Text.unpack name ==>
221 Encode.object
222 [ "args" ==> Encode.list Encode.text args
223 , "tags" ==> Encode.object (map toCtorObject constructors)
224 ]
227toCtorObject :: (Text, [Type]) -> ( String, Encode.Value )
228toCtorObject (name, args) =
229 Text.unpack name ==> Encode.list encode args