@@ -1,3 +1,4 @@
1+{-# OPTIONS_GHC -Wall #-}
12{-# LANGUAGE OverloadedStrings #-}
23module Elm.Compiler.Type
34 ( Type(..), toString
@@ -11,6 +12,7 @@ import qualified Data.Aeson as Json
1112import qualified Data.Aeson.Types as Json
1213import qualified Data.ByteString.Lazy.Char8 as BS
1314import qualified Data.Text as Text
15+import Data.Text (Text)
1416import Text.PrettyPrint as P
1517
1618import qualified AST.Helpers as Help
@@ -24,17 +26,17 @@ import qualified Reporting.Annotation as A
2426
2527data Type
2628 = Lambda Type Type
27− | Var String
28− | Type String
29+ | Var Text
30+ | Type Text
2931 | App Type [Type]
30− | Record [(String, Type)] (Maybe Type)
32+ | Record [(Text, Type)] (Maybe Type)
3133
3234
3335data Program =
3436 Program
3537 { _message :: Type
36− , _aliases :: [( String, [String], Type )]
37− , _unions :: [( String, [String], [(String, [Type])] )]
38+ , _aliases :: [( Text, [Text], Type )]
39+ , _unions :: [( Text, [Text], [(Text, [Type])] )]
3840 }
3941
4042
@@ -65,27 +67,32 @@ toDoc context tipe =
6567 _ -> P.parens lambda
6668
6769 Var name ->
68− P.text name
70+ P.text (Text.unpack name)
6971
7072 Type name ->
71− P.text (if name == "_Tuple0" then "()" else name)
72−
73− App (Type name) args
74− | name == "_Tuple0" ->
75− P.text "()"
76−
77− | Help.isTuple name ->
78− P.sep
79− [ P.cat (zipWith (<+>) (P.lparen : repeat P.comma) (map (toDoc None) args))
80− , P.rparen
81− ]
82−
83− | otherwise ->
84− let adt = P.hang (P.text name) 2 (P.sep $ map (toDoc ADT) args)
85− in
86− case (context, args) of
87− (ADT, _ : _) -> P.parens adt
88− _ -> adt
73+ P.text (Text.unpack (if name == "_Tuple0" then "()" else name))
74+
75+ App (Type name) args ->
76+ if name == "_Tuple0" then
77+ P.text "()"
78+
79+ else if Help.isTuple name then
80+ P.sep
81+ [ P.cat (zipWith (<+>) (P.lparen : repeat P.comma) (map (toDoc None) args))
82+ , P.rparen
83+ ]
84+
85+ else
86+ let
87+ application =
88+ P.hang
89+ (P.text (Text.unpack name))
90+ 2
91+ (P.sep $ map (toDoc ADT) args)
92+ in
93+ case (context, args) of
94+ (ADT, _ : _) -> P.parens application
95+ _ -> application
8996
9097 App _ _ ->
9198 error $
@@ -105,7 +112,7 @@ toDoc context tipe =
105112
106113 (fields, Just x) ->
107114 P.hang
108− (P.lbrace <+> P.text x <+> P.text "|")
115+ (P.lbrace <+> P.text (Text.unpack x) <+> P.text "|")
109116 4
110117 (P.sep
111118 [ P.sep (P.punctuate P.comma (map prettyField fields))
@@ -113,8 +120,8 @@ toDoc context tipe =
113120 ]
114121 )
115122 where
116− prettyField (field, tipe) =
117− P.text field <+> P.text ":" <+> toDoc None tipe
123+ prettyField (field, fieldType) =
124+ P.text (Text.unpack field) <+> P.text ":" <+> toDoc None fieldType
118125
119126
120127collectLambdas :: Type -> [Type]
@@ -124,19 +131,22 @@ collectLambdas tipe =
124131 _ -> [tipe]
125132
126133
127−flattenRecord :: Type -> ( [(String, Type)], Maybe String )
134+flattenRecord :: Type -> ( [(Text, Type)], Maybe Text )
128135flattenRecord tipe =
129− case tipe of
130− Var x -> ([], Just x)
136+ case tipe of
137+ Var x ->
138+ ([], Just x)
131139
132− Record fields Nothing -> (fields, Nothing)
140+ Record fields Nothing ->
141+ (fields, Nothing)
133142
134− Record fields (Just ext) ->
135− let (fields',ext') = flattenRecord ext
136− in
137− (fields' ++ fields, ext')
143+ Record fields (Just ext) ->
144+ let (fields',ext') = flattenRecord ext
145+ in
146+ (fields' ++ fields, ext')
138147
139− _ -> error "Trying to flatten ill-formed record."
148+ _ ->
149+ error "Trying to flatten ill-formed record."
140150
141151
142152
@@ -157,9 +167,13 @@ instance Json.FromJSON Type where
157167 ++ BS.unpack (Json.encode value)
158168 in
159169 case value of
160− Json.String text ->
161− either failure (return . fromRawType) $
162− Parse.parse Type.expr (replacePrimes (Text.unpack text))
170+ Json.String txt ->
171+ case Parse.run Type.expression (Text.replace "'" "_" txt) of
172+ Left err ->
173+ failure err
174+
175+ Right (tipe, _, _) ->
176+ return (fromRawType tipe)
163177
164178 Json.Object obj ->
165179 fromObject obj
@@ -168,11 +182,6 @@ instance Json.FromJSON Type where
168182 failure ()
169183
170184
171−replacePrimes :: String -> String
172−replacePrimes string =
173− map (\c -> if c == '\'' then '_' else c) string
174−
175−
176185fromObject :: Json.Object -> Json.Parser Type
177186fromObject obj =
178187 do tag <- obj .: "tag"
@@ -206,7 +215,7 @@ fromRawType (A.A _ astType) =
206215 Var x
207216
208217 Type.RType var ->
209− Type (Var.toString var)
218+ Type (Var.toText var)
210219
211220 Type.RApp t ts ->
212221 App (fromRawType t) (map fromRawType ts)
@@ -228,22 +237,22 @@ instance Json.ToJSON Program where
228237 ]
229238
230239
231−toAliasField :: ( String, [String], Type ) -> Json.Pair
240+toAliasField :: ( Text, [Text], Type ) -> Json.Pair
232241toAliasField ( name, args, tipe ) =
233− Text.pack name .= Json.object
242+ name .= Json.object
234243 [ "args" .= args
235244 , "type" .= tipe
236245 ]
237246
238247
239−toUnionField :: ( String, [String], [(String, [Type])] ) -> Json.Pair
248+toUnionField :: ( Text, [Text], [(Text, [Type])] ) -> Json.Pair
240249toUnionField ( name, args, constructors ) =
241− Text.pack name .= Json.object
250+ name .= Json.object
242251 [ "args" .= args
243252 , "tags" .= Json.object (map toCtorObject constructors)
244253 ]
245254
246255
247−toCtorObject :: (String, [Type]) -> Json.Pair
256+toCtorObject :: (Text, [Type]) -> Json.Pair
248257toCtorObject (name, args) =
249− Text.pack name .= args
258+ name .= args