git.iko.soy/elk
on 8a72f65 help sign in
elk/compiler/src/Elm/Compiler/Type.hs
243 lines 5.2 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.ANSI.Leijen as P
20import Text.PrettyPrint.ANSI.Leijen ((<+>))
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 N.Name)
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 case format of
67 OneLine ->
68 P.displayS (P.renderPretty 1.0 maxBound (toDoc None tipe)) ""
70 MultiLine ->
71 P.displayS (P.renderPretty 1.0 80 (toDoc None tipe)) ""
74data Context = None | InType | InFunction
77toDoc :: Context -> Type -> P.Doc
78toDoc context tipe =
79 case tipe of
80 Lambda _ _ ->
81 let t:ts =
82 map (toDoc InFunction) (collectLambdas tipe)
84 lambda =
85 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
86 in
87 case context of
88 None -> lambda
89 _ -> P.parens lambda
91 Var name ->
92 P.text (N.toString name)
94 Unit ->
95 "()"
97 Tuple a b cs ->
98 P.sep
99 [ P.cat $
100 [ "(" <+> toDoc None a
101 , "," <+> toDoc None b
102 ]
103 ++ map ("," <+>) (map (toDoc None) cs)
104 , ")"
105 ]
107 Type name args ->
108 case args of
109 [] ->
110 P.text (N.toString name)
112 _ ->
113 let
114 docName =
115 P.text (N.toString name)
117 application =
118 P.hang 2 $ P.sep (docName : map (toDoc InType) args)
119 in
120 case context of
121 InType ->
122 P.parens application
124 _ ->
125 application
127 Record [] Nothing ->
128 "{}"
130 Record fields ext ->
131 case ext of
132 Nothing ->
133 P.sep
134 [ P.cat (zipWith (<+>) ("{" : repeat ",") (map entryToDoc fields))
135 , "}"
136 ]
138 Just x ->
139 P.hang 4 $
140 P.sep
141 [ "{" <+> P.text (N.toString x) <+> "|"
142 , P.sep (P.punctuate "," (map entryToDoc fields))
143 , "}"
144 ]
147entryToDoc :: (N.Name, Type) -> P.Doc
148entryToDoc (field, fieldType) =
149 P.text (N.toString field) <+> ":" <+> toDoc None fieldType
152collectLambdas :: Type -> [Type]
153collectLambdas tipe =
154 case tipe of
155 Lambda arg body -> arg : collectLambdas body
156 _ -> [tipe]
160-- JSON for TYPE
163encode :: Type -> Encode.Value
164encode tipe =
165 Encode.text (Text.pack (toString OneLine tipe))
168decoder :: Decode.Decoder () Type
169decoder =
170 do txt <- Decode.text
171 case Parse.run Type.expression (Text.encodeUtf8 (Text.replace "'" "_" txt)) of
172 Left _ ->
173 Decode.fail ()
175 Right (tipe, _, _) ->
176 Decode.succeed (fromRawType tipe)
179fromRawType :: Src.Type -> Type
180fromRawType (A.At _ astType) =
181 case astType of
182 Src.TLambda t1 t2 ->
183 Lambda (fromRawType t1) (fromRawType t2)
185 Src.TVar x ->
186 Var x
188 Src.TUnit ->
189 Unit
191 Src.TTuple a b cs ->
192 Tuple
193 (fromRawType a)
194 (fromRawType b)
195 (map fromRawType cs)
197 Src.TType _ name args ->
198 Type name (map fromRawType args)
200 Src.TTypeQual _ _ name args ->
201 Type name (map fromRawType args)
203 Src.TRecord fields ext ->
204 let fromField (A.At _ field, tipe) = (field, fromRawType tipe) in
205 Record
206 (map fromField fields)
207 (fmap A.toValue ext)
211-- JSON for PROGRAM
214encodeMetadata :: DebugMetadata -> Encode.Value
215encodeMetadata (DebugMetadata msg aliases unions) =
216 Encode.object
217 [ "message" ==> encode msg
218 , "aliases" ==> Encode.object (map toAliasField aliases)
219 , "unions" ==> Encode.object (map toUnionField unions)
220 ]
223toAliasField :: Alias -> ( Text.Text, Encode.Value )
224toAliasField (Alias name args tipe) =
225 N.toText name ==>
226 Encode.object
227 [ "args" ==> Encode.list Encode.name args
228 , "type" ==> encode tipe
229 ]
232toUnionField :: Union -> ( Text.Text, Encode.Value )
233toUnionField (Union name args constructors) =
234 N.toText name ==>
235 Encode.object
236 [ "args" ==> Encode.list Encode.name args
237 , "tags" ==> Encode.object (map toCtorObject constructors)
238 ]
241toCtorObject :: (N.Name, [Type]) -> ( Text.Text, Encode.Value )
242toCtorObject (name, args) =
243 N.toText name ==> Encode.list encode args