git.iko.soy/elk
on 635dbba help sign in
elk/compiler/src/Elm/Compiler/Type.hs
231 lines 5.0 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Elm.Compiler.Type
4 ( Type(..)
5 , Context(..)
6 , toDoc
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 DOC
61data Context = None | InType | InFunction
64toDoc :: Context -> Type -> P.Doc
65toDoc context tipe =
66 case tipe of
67 Lambda _ _ ->
68 let t:ts =
69 map (toDoc InFunction) (collectLambdas tipe)
71 lambda =
72 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
73 in
74 case context of
75 None -> lambda
76 _ -> P.parens lambda
78 Var name ->
79 P.text (N.toString name)
81 Unit ->
82 "()"
84 Tuple a b cs ->
85 P.sep
86 [ P.cat $
87 [ "(" <+> toDoc None a
88 , "," <+> toDoc None b
89 ]
90 ++ map ("," <+>) (map (toDoc None) cs)
91 , ")"
92 ]
94 Type name args ->
95 case args of
96 [] ->
97 P.text (N.toString name)
99 _ ->
100 let
101 docName =
102 P.text (N.toString name)
104 application =
105 P.hang 2 $ P.sep (docName : map (toDoc InType) args)
106 in
107 case context of
108 InType ->
109 P.parens application
111 _ ->
112 application
114 Record [] Nothing ->
115 "{}"
117 Record fields ext ->
118 case ext of
119 Nothing ->
120 P.sep
121 [ P.cat (zipWith (<+>) ("{" : repeat ",") (map entryToDoc fields))
122 , "}"
123 ]
125 Just x ->
126 P.hang 4 $
127 P.sep
128 [ "{" <+> P.text (N.toString x) <+> "|"
129 , P.sep (P.punctuate "," (map entryToDoc fields))
130 , "}"
131 ]
134entryToDoc :: (N.Name, Type) -> P.Doc
135entryToDoc (field, fieldType) =
136 P.text (N.toString field) <+> ":" <+> toDoc None fieldType
139collectLambdas :: Type -> [Type]
140collectLambdas tipe =
141 case tipe of
142 Lambda arg body -> arg : collectLambdas body
143 _ -> [tipe]
147-- JSON for TYPE
150encode :: Type -> Encode.Value
151encode tipe =
152 Encode.text $ Text.pack $
153 P.displayS (P.renderPretty 1.0 (maxBound `div` 2) (toDoc None tipe)) ""
156decoder :: Decode.Decoder () Type
157decoder =
158 do txt <- Decode.text
159 case Parse.run Type.expression (Text.encodeUtf8 (Text.replace "'" "_" txt)) of
160 Left _ ->
161 Decode.fail ()
163 Right (tipe, _, _) ->
164 Decode.succeed (fromRawType tipe)
167fromRawType :: Src.Type -> Type
168fromRawType (A.At _ astType) =
169 case astType of
170 Src.TLambda t1 t2 ->
171 Lambda (fromRawType t1) (fromRawType t2)
173 Src.TVar x ->
174 Var x
176 Src.TUnit ->
177 Unit
179 Src.TTuple a b cs ->
180 Tuple
181 (fromRawType a)
182 (fromRawType b)
183 (map fromRawType cs)
185 Src.TType _ name args ->
186 Type name (map fromRawType args)
188 Src.TTypeQual _ _ name args ->
189 Type name (map fromRawType args)
191 Src.TRecord fields ext ->
192 let fromField (A.At _ field, tipe) = (field, fromRawType tipe) in
193 Record
194 (map fromField fields)
195 (fmap A.toValue ext)
199-- JSON for PROGRAM
202encodeMetadata :: DebugMetadata -> Encode.Value
203encodeMetadata (DebugMetadata msg aliases unions) =
204 Encode.object
205 [ "message" ==> encode msg
206 , "aliases" ==> Encode.object (map toAliasField aliases)
207 , "unions" ==> Encode.object (map toUnionField unions)
208 ]
211toAliasField :: Alias -> ( Text.Text, Encode.Value )
212toAliasField (Alias name args tipe) =
213 N.toText name ==>
214 Encode.object
215 [ "args" ==> Encode.list Encode.name args
216 , "type" ==> encode tipe
217 ]
220toUnionField :: Union -> ( Text.Text, Encode.Value )
221toUnionField (Union name args constructors) =
222 N.toText name ==>
223 Encode.object
224 [ "args" ==> Encode.list Encode.name args
225 , "tags" ==> Encode.object (map toCtorObject constructors)
226 ]
229toCtorObject :: (N.Name, [Type]) -> ( Text.Text, Encode.Value )
230toCtorObject (name, args) =
231 N.toText name ==> Encode.list encode args