git.iko.soy/elk
on dd2feec help sign in
elk/src/Elm/Compiler/Type.hs
264 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 , decoder
12 , encodeMetadata
13 )
14 where
17import qualified Data.Text as Text
18import qualified Data.Text.Encoding as Text
19import qualified Text.PrettyPrint as P
20import Text.PrettyPrint ((<+>))
22import qualified AST.Source as Src
23import qualified Elm.Name as N
24import qualified Parse.Primitives as Parse
25import qualified Parse.Type as Type
26import qualified Reporting.Annotation as A
27import qualified Json.Decode as Decode
28import qualified Json.Encode as Encode
29import Json.Encode ((==>))
33-- TYPES
36data Type
37 = Lambda Type Type
38 | Var N.Name
39 | Type N.Name [Type]
40 | Record [(N.Name, Type)] (Maybe Type)
41 | Unit
42 | Tuple Type Type [Type]
45data DebugMetadata =
46 DebugMetadata
47 { _message :: Type
48 , _aliases :: [Alias]
49 , _unions :: [Union]
50 }
53data Alias = Alias N.Name [N.Name] Type
54data Union = Union N.Name [N.Name] [(N.Name, [Type])]
58-- TO STRING
61data Format = OneLine | MultiLine
64toString :: Format -> Type -> String
65toString format tipe =
66 let
67 mode =
68 case format of
69 OneLine ->
70 P.OneLineMode
71 MultiLine ->
72 P.PageMode
73 in
74 P.renderStyle (P.Style mode 80 1.0) (toDoc None tipe)
77data Context = None | InType | InFunction
80toDoc :: Context -> Type -> P.Doc
81toDoc context tipe =
82 case tipe of
83 Lambda _ _ ->
84 let t:ts =
85 map (toDoc InFunction) (collectLambdas tipe)
87 lambda =
88 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
89 in
90 case context of
91 None -> lambda
92 _ -> P.parens lambda
94 Var name ->
95 P.text (N.toString name)
97 Unit ->
98 "()"
100 Tuple a b cs ->
101 P.sep
102 [ P.cat $
103 [ "(" <+> toDoc None a
104 , "," <+> toDoc None b
105 ]
106 ++ map ("," <+>) (map (toDoc None) cs)
107 , ")"
108 ]
110 Type name args ->
111 case args of
112 [] ->
113 P.text (N.toString name)
115 _ ->
116 let
117 application =
118 P.hang
119 (P.text (N.toString name))
120 2
121 (P.sep $ map (toDoc InType) args)
122 in
123 case context of
124 InType ->
125 P.parens application
127 _ ->
128 application
130 Record _ _ ->
131 case flattenRecord tipe of
132 ([], Nothing) ->
133 P.text "{}"
135 (fields, Nothing) ->
136 P.sep
137 [ P.cat (zipWith (<+>) ("{" : repeat ",") (map prettyField fields))
138 , "}"
139 ]
141 (fields, Just x) ->
142 P.hang
143 ("{" <+> P.text (N.toString x) <+> "|")
144 4
145 (P.sep
146 [ P.sep (P.punctuate "," (map prettyField fields))
147 , "}"
148 ]
149 )
150 where
151 prettyField (field, fieldType) =
152 P.text (N.toString field) <+> ":" <+> toDoc None fieldType
155collectLambdas :: Type -> [Type]
156collectLambdas tipe =
157 case tipe of
158 Lambda arg body -> arg : collectLambdas body
159 _ -> [tipe]
162flattenRecord :: Type -> ( [(N.Name, Type)], Maybe N.Name )
163flattenRecord tipe =
164 case tipe of
165 Var x ->
166 ([], Just x)
168 Record fields Nothing ->
169 (fields, Nothing)
171 Record fields (Just ext) ->
172 let (fields',ext') = flattenRecord ext
173 in
174 (fields' ++ fields, ext')
176 _ ->
177 error "Trying to flatten ill-formed record."
181-- JSON for TYPE
184encode :: Type -> Encode.Value
185encode tipe =
186 Encode.text (Text.pack (toString OneLine tipe))
189decoder :: Decode.Decoder () Type
190decoder =
191 do txt <- Decode.text
192 case Parse.run Type.expression (Text.encodeUtf8 (Text.replace "'" "_" txt)) of
193 Left _ ->
194 Decode.fail ()
196 Right (tipe, _, _) ->
197 Decode.succeed (fromRawType tipe)
200fromRawType :: Src.Type -> Type
201fromRawType (A.At _ astType) =
202 case astType of
203 Src.TLambda t1 t2 ->
204 Lambda (fromRawType t1) (fromRawType t2)
206 Src.TVar x ->
207 Var x
209 Src.TUnit ->
210 Unit
212 Src.TTuple a b cs ->
213 Tuple
214 (fromRawType a)
215 (fromRawType b)
216 (map fromRawType cs)
218 Src.TType _ name args ->
219 Type name (map fromRawType args)
221 Src.TTypeQual _ _ name args ->
222 Type name (map fromRawType args)
224 Src.TRecord fields ext ->
225 let fromField (A.At _ field, tipe) = (field, fromRawType tipe) in
226 Record
227 (map fromField fields)
228 (fmap fromRawType ext)
232-- JSON for PROGRAM
235encodeMetadata :: DebugMetadata -> Encode.Value
236encodeMetadata (DebugMetadata msg aliases unions) =
237 Encode.object
238 [ "message" ==> encode msg
239 , "aliases" ==> Encode.object (map toAliasField aliases)
240 , "unions" ==> Encode.object (map toUnionField unions)
241 ]
244toAliasField :: Alias -> ( Text.Text, Encode.Value )
245toAliasField (Alias name args tipe) =
246 N.toText name ==>
247 Encode.object
248 [ "args" ==> Encode.list Encode.name args
249 , "type" ==> encode tipe
250 ]
253toUnionField :: Union -> ( Text.Text, Encode.Value )
254toUnionField (Union name args constructors) =
255 N.toText name ==>
256 Encode.object
257 [ "args" ==> Encode.list Encode.name args
258 , "tags" ==> Encode.object (map toCtorObject constructors)
259 ]
262toCtorObject :: (N.Name, [Type]) -> ( Text.Text, Encode.Value )
263toCtorObject (name, args) =
264 N.toText name ==> Encode.list encode args