git.iko.soy/elk
on 2deedfb help sign in
elk/src/Elm/Compiler/Type.hs
262 lines 5.7 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Elm.Compiler.Type
4 ( Type(..)
5 , Format(..)
6 , toString
7 , DebugMetadata(..)
8 , Alias(..)
9 , Union(..)
10 , encode
11 , decoder
12 , encodeMetadata
13 )
14 where
17import Data.Text (Text)
18import qualified Data.Text as Text
19import qualified Data.Text.Encoding as Text
20import qualified Text.PrettyPrint as P
21import Text.PrettyPrint ((<+>))
23import qualified AST.Source as Src
24import qualified Elm.Name as N
25import qualified Parse.Primitives 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 N.Name
40 | Type N.Name [Type]
41 | Record [(N.Name, Type)] (Maybe Type)
42 | Unit
43 | Tuple Type Type [Type]
46data DebugMetadata =
47 DebugMetadata
48 { _message :: Type
49 , _aliases :: [Alias]
50 , _unions :: [Union]
51 }
54data Alias = Alias N.Name [N.Name] Type
55data Union = Union N.Name [N.Name] [(N.Name, [Type])]
59-- TO STRING
62data Format = OneLine | MultiLine
65toString :: Format -> Type -> String
66toString format tipe =
67 let
68 mode =
69 case format of
70 OneLine ->
71 P.OneLineMode
72 MultiLine ->
73 P.PageMode
74 in
75 P.renderStyle (P.Style mode 80 1.0) (toDoc None tipe)
78data Context = None | InType | InFunction
81toDoc :: Context -> Type -> P.Doc
82toDoc context tipe =
83 case tipe of
84 Lambda _ _ ->
85 let t:ts =
86 map (toDoc InFunction) (collectLambdas tipe)
88 lambda =
89 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
90 in
91 case context of
92 None -> lambda
93 _ -> P.parens lambda
95 Var name ->
96 P.text (Text.unpack name)
98 Unit ->
99 "()"
101 Tuple a b cs ->
102 P.sep
103 [ P.cat $
104 [ "(" <+> toDoc None a
105 , "," <+> toDoc None b
106 ]
107 ++ map ("," <+>) (map (toDoc None) cs)
108 , ")"
109 ]
111 Type name args ->
112 case args of
113 [] ->
114 P.text (Text.unpack name)
116 _ ->
117 let
118 application =
119 P.hang
120 (P.text (Text.unpack name))
121 2
122 (P.sep $ map (toDoc InType) args)
123 in
124 case context of
125 InType ->
126 P.parens application
128 _ ->
129 application
131 Record _ _ ->
132 case flattenRecord tipe of
133 ([], Nothing) ->
134 P.text "{}"
136 (fields, Nothing) ->
137 P.sep
138 [ P.cat (zipWith (<+>) ("{" : repeat ",") (map prettyField fields))
139 , "}"
140 ]
142 (fields, Just x) ->
143 P.hang
144 ("{" <+> P.text (Text.unpack x) <+> "|")
145 4
146 (P.sep
147 [ P.sep (P.punctuate "," (map prettyField fields))
148 , "}"
149 ]
150 )
151 where
152 prettyField (field, fieldType) =
153 P.text (Text.unpack field) <+> ":" <+> toDoc None fieldType
156collectLambdas :: Type -> [Type]
157collectLambdas tipe =
158 case tipe of
159 Lambda arg body -> arg : collectLambdas body
160 _ -> [tipe]
163flattenRecord :: Type -> ( [(Text, Type)], Maybe Text )
164flattenRecord tipe =
165 case tipe of
166 Var x ->
167 ([], Just x)
169 Record fields Nothing ->
170 (fields, Nothing)
172 Record fields (Just ext) ->
173 let (fields',ext') = flattenRecord ext
174 in
175 (fields' ++ fields, ext')
177 _ ->
178 error "Trying to flatten ill-formed record."
182-- JSON for TYPE
185encode :: Type -> Encode.Value
186encode tipe =
187 Encode.text (Text.pack (toString OneLine tipe))
190decoder :: Decode.Decoder Type
191decoder =
192 do txt <- Decode.text
193 case Parse.run Type.expression (Text.encodeUtf8 (Text.replace "'" "_" txt)) of
194 Left _ ->
195 Decode.fail "Expecting a type, like (String -> Int)"
197 Right (tipe, _, _) ->
198 Decode.succeed (fromRawType tipe)
201fromRawType :: Src.Type -> Type
202fromRawType (A.At _ astType) =
203 case astType of
204 Src.TLambda t1 t2 ->
205 Lambda (fromRawType t1) (fromRawType t2)
207 Src.TVar x ->
208 Var x
210 Src.TUnit ->
211 Unit
213 Src.TTuple a b cs ->
214 Tuple
215 (fromRawType a)
216 (fromRawType b)
217 (map fromRawType cs)
219 Src.TType _ _ name args ->
220 Type name (map fromRawType args)
222 Src.TRecord fields ext ->
223 let fromField (A.At _ field, tipe) = (field, fromRawType tipe) in
224 Record
225 (map fromField fields)
226 (fmap fromRawType ext)
230-- JSON for PROGRAM
233encodeMetadata :: DebugMetadata -> Encode.Value
234encodeMetadata (DebugMetadata msg aliases unions) =
235 Encode.object
236 [ "message" ==> encode msg
237 , "aliases" ==> Encode.object (map toAliasField aliases)
238 , "unions" ==> Encode.object (map toUnionField unions)
239 ]
242toAliasField :: Alias -> ( String, Encode.Value )
243toAliasField (Alias name args tipe) =
244 Text.unpack name ==>
245 Encode.object
246 [ "args" ==> Encode.list Encode.text args
247 , "type" ==> encode tipe
248 ]
251toUnionField :: Union -> ( String, Encode.Value )
252toUnionField (Union name args constructors) =
253 Text.unpack name ==>
254 Encode.object
255 [ "args" ==> Encode.list Encode.text args
256 , "tags" ==> Encode.object (map toCtorObject constructors)
257 ]
260toCtorObject :: (Text, [Type]) -> ( String, Encode.Value )
261toCtorObject (name, args) =
262 Text.unpack name ==> Encode.list encode args