git.iko.soy/elk
on 22bb2ee help sign in
elk/src/Elm/Compiler/Type.hs
269 lines 5.8 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 , Error(..)
12 , decoder
13 , encodeMetadata
14 )
15 where
18import Data.Text (Text)
19import qualified Data.Text as Text
20import qualified Data.Text.Encoding as Text
21import qualified Text.PrettyPrint as P
22import Text.PrettyPrint ((<+>))
24import qualified AST.Source as Src
25import qualified Elm.Name as N
26import qualified Parse.Primitives as Parse
27import qualified Parse.Type as Type
28import qualified Reporting.Annotation as A
29import qualified Json.Decode as Decode
30import qualified Json.Encode as Encode
31import Json.Encode ((==>))
35-- TYPES
38data Type
39 = Lambda Type Type
40 | Var N.Name
41 | Type N.Name [Type]
42 | Record [(N.Name, Type)] (Maybe Type)
43 | Unit
44 | Tuple Type Type [Type]
47data DebugMetadata =
48 DebugMetadata
49 { _message :: Type
50 , _aliases :: [Alias]
51 , _unions :: [Union]
52 }
55data Alias = Alias N.Name [N.Name] Type
56data Union = Union N.Name [N.Name] [(N.Name, [Type])]
60-- TO STRING
63data Format = OneLine | MultiLine
66toString :: Format -> Type -> String
67toString format tipe =
68 let
69 mode =
70 case format of
71 OneLine ->
72 P.OneLineMode
73 MultiLine ->
74 P.PageMode
75 in
76 P.renderStyle (P.Style mode 80 1.0) (toDoc None tipe)
79data Context = None | InType | InFunction
82toDoc :: Context -> Type -> P.Doc
83toDoc context tipe =
84 case tipe of
85 Lambda _ _ ->
86 let t:ts =
87 map (toDoc InFunction) (collectLambdas tipe)
89 lambda =
90 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
91 in
92 case context of
93 None -> lambda
94 _ -> P.parens lambda
96 Var name ->
97 P.text (Text.unpack name)
99 Unit ->
100 "()"
102 Tuple a b cs ->
103 P.sep
104 [ P.cat $
105 [ "(" <+> toDoc None a
106 , "," <+> toDoc None b
107 ]
108 ++ map ("," <+>) (map (toDoc None) cs)
109 , ")"
110 ]
112 Type name args ->
113 case args of
114 [] ->
115 P.text (Text.unpack name)
117 _ ->
118 let
119 application =
120 P.hang
121 (P.text (Text.unpack name))
122 2
123 (P.sep $ map (toDoc InType) args)
124 in
125 case context of
126 InType ->
127 P.parens application
129 _ ->
130 application
132 Record _ _ ->
133 case flattenRecord tipe of
134 ([], Nothing) ->
135 P.text "{}"
137 (fields, Nothing) ->
138 P.sep
139 [ P.cat (zipWith (<+>) ("{" : repeat ",") (map prettyField fields))
140 , "}"
141 ]
143 (fields, Just x) ->
144 P.hang
145 ("{" <+> P.text (Text.unpack x) <+> "|")
146 4
147 (P.sep
148 [ P.sep (P.punctuate "," (map prettyField fields))
149 , "}"
150 ]
151 )
152 where
153 prettyField (field, fieldType) =
154 P.text (Text.unpack field) <+> ":" <+> toDoc None fieldType
157collectLambdas :: Type -> [Type]
158collectLambdas tipe =
159 case tipe of
160 Lambda arg body -> arg : collectLambdas body
161 _ -> [tipe]
164flattenRecord :: Type -> ( [(Text, Type)], Maybe Text )
165flattenRecord tipe =
166 case tipe of
167 Var x ->
168 ([], Just x)
170 Record fields Nothing ->
171 (fields, Nothing)
173 Record fields (Just ext) ->
174 let (fields',ext') = flattenRecord ext
175 in
176 (fields' ++ fields, ext')
178 _ ->
179 error "Trying to flatten ill-formed record."
183-- JSON for TYPE
186encode :: Type -> Encode.Value
187encode tipe =
188 Encode.text (Text.pack (toString OneLine tipe))
191data Error = BadType
194decoder :: Decode.Decoder Error Type
195decoder =
196 do txt <- Decode.text
197 case Parse.run Type.expression (Text.encodeUtf8 (Text.replace "'" "_" txt)) of
198 Left _ ->
199 Decode.fail BadType
201 Right (tipe, _, _) ->
202 Decode.succeed (fromRawType tipe)
205fromRawType :: Src.Type -> Type
206fromRawType (A.At _ astType) =
207 case astType of
208 Src.TLambda t1 t2 ->
209 Lambda (fromRawType t1) (fromRawType t2)
211 Src.TVar x ->
212 Var x
214 Src.TUnit ->
215 Unit
217 Src.TTuple a b cs ->
218 Tuple
219 (fromRawType a)
220 (fromRawType b)
221 (map fromRawType cs)
223 Src.TType _ name args ->
224 Type name (map fromRawType args)
226 Src.TTypeQual _ _ name args ->
227 Type name (map fromRawType args)
229 Src.TRecord fields ext ->
230 let fromField (A.At _ field, tipe) = (field, fromRawType tipe) in
231 Record
232 (map fromField fields)
233 (fmap fromRawType ext)
237-- JSON for PROGRAM
240encodeMetadata :: DebugMetadata -> Encode.Value
241encodeMetadata (DebugMetadata msg aliases unions) =
242 Encode.object
243 [ "message" ==> encode msg
244 , "aliases" ==> Encode.object (map toAliasField aliases)
245 , "unions" ==> Encode.object (map toUnionField unions)
246 ]
249toAliasField :: Alias -> ( String, Encode.Value )
250toAliasField (Alias name args tipe) =
251 Text.unpack name ==>
252 Encode.object
253 [ "args" ==> Encode.list Encode.text args
254 , "type" ==> encode tipe
255 ]
258toUnionField :: Union -> ( String, Encode.Value )
259toUnionField (Union name args constructors) =
260 Text.unpack name ==>
261 Encode.object
262 [ "args" ==> Encode.list Encode.text args
263 , "tags" ==> Encode.object (map toCtorObject constructors)
264 ]
267toCtorObject :: (Text, [Type]) -> ( String, Encode.Value )
268toCtorObject (name, args) =
269 Text.unpack name ==> Encode.list encode args