git.iko.soy/elk
on 666edc3 help sign in
elk/src/Elm/Compiler/Type.hs
234 lines 5.3 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Elm.Compiler.Type
4 ( Type(..)
5 , Format(..)
6 , toString
7 , Program(..)
8 , encode
9 , decoder
10 , encodeProgram
11 )
12 where
14import Control.Arrow ((***))
15import qualified Data.Text as Text
16import Data.Text (Text)
17import qualified Text.PrettyPrint as P
18import Text.PrettyPrint ((<+>))
20import qualified AST.Helpers as Help
21import qualified AST.Type as Type
22import qualified AST.Variable as Var
23import qualified Parse.Helpers as Parse
24import qualified Parse.Type as Type
25import qualified Reporting.Annotation as A
26import qualified Json.Decode as Decode
27import qualified Json.Encode as Encode
28import Json.Encode ((==>))
32-- TYPES
35data Type
36 = Lambda Type Type
37 | Var Text
38 | Type Text [Type]
39 | Record [(Text, Type)] (Maybe Type)
42data Program =
43 Program
44 { _message :: Type
45 , _aliases :: [( Text, [Text], Type )]
46 , _unions :: [( Text, [Text], [(Text, [Type])] )]
47 }
51-- TO STRING
54data Format = OneLine | MultiLine
57toString :: Format -> Type -> String
58toString format tipe =
59 let
60 mode =
61 case format of
62 OneLine ->
63 P.OneLineMode
64 MultiLine ->
65 P.PageMode
66 in
67 P.renderStyle (P.Style mode 80 1.0) (toDoc None tipe)
70data Context = None | InType | InFunction
73toDoc :: Context -> Type -> P.Doc
74toDoc context tipe =
75 case tipe of
76 Lambda _ _ ->
77 let t:ts =
78 map (toDoc InFunction) (collectLambdas tipe)
80 lambda =
81 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
82 in
83 case context of
84 None -> lambda
85 _ -> P.parens lambda
87 Var name ->
88 P.text (Text.unpack name)
90 Type name [] ->
91 P.text (if name == Help.zeroTuple then "()" else Text.unpack name)
93 Type name arguments@(arg:args) ->
94 if Help.isTuple name then
95 P.sep
96 [ P.cat ("(" <+> toDoc None arg : map (\a -> "," <+> toDoc None a) args)
97 , ")"
98 ]
100 else
101 let
102 application =
103 P.hang
104 (P.text (Text.unpack name))
105 2
106 (P.sep $ map (toDoc InType) arguments)
107 in
108 case context of
109 InType ->
110 P.parens application
112 _ ->
113 application
115 Record _ _ ->
116 case flattenRecord tipe of
117 ([], Nothing) ->
118 P.text "{}"
120 (fields, Nothing) ->
121 P.sep
122 [ P.cat (zipWith (<+>) ("{" : repeat ",") (map prettyField fields))
123 , "}"
124 ]
126 (fields, Just x) ->
127 P.hang
128 ("{" <+> P.text (Text.unpack x) <+> "|")
129 4
130 (P.sep
131 [ P.sep (P.punctuate "," (map prettyField fields))
132 , "}"
133 ]
134 )
135 where
136 prettyField (field, fieldType) =
137 P.text (Text.unpack field) <+> ":" <+> toDoc None fieldType
140collectLambdas :: Type -> [Type]
141collectLambdas tipe =
142 case tipe of
143 Lambda arg body -> arg : collectLambdas body
144 _ -> [tipe]
147flattenRecord :: Type -> ( [(Text, Type)], Maybe Text )
148flattenRecord tipe =
149 case tipe of
150 Var x ->
151 ([], Just x)
153 Record fields Nothing ->
154 (fields, Nothing)
156 Record fields (Just ext) ->
157 let (fields',ext') = flattenRecord ext
158 in
159 (fields' ++ fields, ext')
161 _ ->
162 error "Trying to flatten ill-formed record."
166-- JSON for TYPE
169encode :: Type -> Encode.Value
170encode tipe =
171 Encode.text (Text.pack (toString OneLine tipe))
174decoder :: Decode.Decoder Type
175decoder =
176 do txt <- Decode.text
177 case Parse.run Type.expression txt of
178 Left _ ->
179 Decode.fail "a type, like (String -> Int)"
181 Right (tipe, _, _) ->
182 Decode.succeed (fromRawType tipe)
185fromRawType :: Type.Raw -> Type
186fromRawType (A.A _ astType) =
187 case astType of
188 Type.RLambda t1 t2 ->
189 Lambda (fromRawType t1) (fromRawType t2)
191 Type.RVar x ->
192 Var x
194 Type.RType (A.A _ name) args ->
195 Type (Var.rawToText name) (map fromRawType args)
197 Type.RRecord fields ext ->
198 Record (map (A.drop *** fromRawType) fields) (fmap fromRawType ext)
202-- JSON for PROGRAM
205encodeProgram :: Program -> Encode.Value
206encodeProgram (Program msg aliases unions) =
207 Encode.object
208 [ "message" ==> encode msg
209 , "aliases" ==> Encode.object (map toAliasField aliases)
210 , "unions" ==> Encode.object (map toUnionField unions)
211 ]
214toAliasField :: ( Text, [Text], Type ) -> ( String, Encode.Value )
215toAliasField ( name, args, tipe ) =
216 Text.unpack name ==>
217 Encode.object
218 [ "args" ==> Encode.list Encode.text args
219 , "type" ==> encode tipe
220 ]
223toUnionField :: ( Text, [Text], [(Text, [Type])] ) -> ( String, Encode.Value )
224toUnionField ( name, args, constructors ) =
225 Text.unpack name ==>
226 Encode.object
227 [ "args" ==> Encode.list Encode.text args
228 , "tags" ==> Encode.object (map toCtorObject constructors)
229 ]
232toCtorObject :: (Text, [Type]) -> ( String, Encode.Value )
233toCtorObject (name, args) =
234 Text.unpack name ==> Encode.list encode args