git.iko.soy/elk
on 73d2c2c help sign in
elk/src/Elm/Compiler/Type.hs
194 lines 4.8 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Elm.Compiler.Type
3 ( Type(..)
4 , toString
5 ) where
7import Control.Arrow (second)
8import Data.Aeson ((.:))
9import qualified Data.Aeson as Json
10import qualified Data.Aeson.Types as Json
11import qualified Data.ByteString.Lazy.Char8 as BS
12import qualified Data.Text as Text
13import Text.PrettyPrint as P
15import qualified AST.Helpers as Help
16import qualified AST.Type as Type
17import qualified AST.Variable as Var
18import qualified Parse.Helpers as Parse
19import qualified Parse.Type as Type
20import qualified Reporting.Annotation as A
23data Type
24 = Lambda Type Type
25 | Var String
26 | Type String
27 | App Type [Type]
28 | Record [(String, Type)] (Maybe Type)
31-- TO STRING
33data Context = None | ADT | Function
36toString :: Type -> String
37toString tipe =
38 P.render (toDoc None tipe)
41toDoc :: Context -> Type -> P.Doc
42toDoc context tipe =
43 case tipe of
44 Lambda _ _ ->
45 let t:ts =
46 map (toDoc Function) (collectLambdas tipe)
48 lambda =
49 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
50 in
51 case context of
52 None -> lambda
53 _ -> P.parens lambda
55 Var name ->
56 P.text name
58 Type name ->
59 P.text (if name == "_Tuple0" then "()" else name)
61 App (Type name) args
62 | Help.isTuple name ->
63 P.sep
64 [ P.cat (zipWith (<+>) (P.lparen : repeat P.comma) (map (toDoc None) args))
65 , P.rparen
66 ]
68 | otherwise ->
69 let adt = P.hang (P.text name) 2 (P.sep $ map (toDoc ADT) args)
70 in
71 case (context, args) of
72 (ADT, _ : _) -> P.parens adt
73 _ -> adt
75 App _ _ ->
76 error $
77 "Somehow ended up with an unexpected type, please post a minimal example that\n"
78 ++ "reproduces this error to <https://github.com/elm-lang/elm-compiler/issues>"
80 Record _ _ ->
81 case flattenRecord tipe of
82 ([], Nothing) ->
83 P.text "{}"
85 (fields, Nothing) ->
86 P.sep
87 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
88 , P.rbrace
89 ]
91 (fields, Just x) ->
92 P.hang
93 (P.lbrace <+> P.text x <+> P.text "|")
94 4
95 (P.sep
96 [ P.sep (P.punctuate P.comma (map prettyField fields))
97 , P.rbrace
98 ]
99 )
100 where
101 prettyField (field, tipe) =
102 P.text field <+> P.text ":" <+> toDoc None tipe
105collectLambdas :: Type -> [Type]
106collectLambdas tipe =
107 case tipe of
108 Lambda arg body -> arg : collectLambdas body
109 _ -> [tipe]
112flattenRecord :: Type -> ( [(String, Type)], Maybe String )
113flattenRecord tipe =
114 case tipe of
115 Var x -> ([], Just x)
117 Record fields Nothing -> (fields, Nothing)
119 Record fields (Just ext) ->
120 let (fields',ext') = flattenRecord ext
121 in
122 (fields' ++ fields, ext')
124 _ -> error "Trying to flatten ill-formed record."
127-- JSON for TYPE
129instance Json.ToJSON Type where
130 toJSON tipe =
131 Json.String (Text.unwords (Text.words (Text.pack (toString tipe))))
134instance Json.FromJSON Type where
135 parseJSON value =
136 let
137 failure _ =
138 fail $
139 "Trying to decode a type string, but could not handle this value:\n"
140 ++ BS.unpack (Json.encode value)
141 in
142 case value of
143 Json.String text ->
144 either failure (return . fromRawType)
145 (Parse.iParse Type.expr (Text.unpack text))
147 Json.Object obj ->
148 fromObject obj
150 _ ->
151 failure ()
154fromObject :: Json.Object -> Json.Parser Type
155fromObject obj =
156 do tag <- obj .: "tag"
157 case (tag :: String) of
158 "lambda" ->
159 Lambda <$> obj .: "in" <*> obj .: "out"
161 "var" ->
162 Var <$> obj .: "name"
164 "type" ->
165 Type <$> obj .: "name"
167 "app" ->
168 App <$> obj .: "func" <*> obj .: "args"
170 "record" ->
171 Record <$> obj .: "fields" <*> obj .: "extension"
173 _ ->
174 fail $ "Error when decoding type with tag: " ++ tag
177fromRawType :: Type.Raw -> Type
178fromRawType (A.A _ astType) =
179 case astType of
180 Type.RLambda t1 t2 ->
181 Lambda (fromRawType t1) (fromRawType t2)
183 Type.RVar x ->
184 Var x
186 Type.RType var ->
187 Type (Var.toString var)
189 Type.RApp t ts ->
190 App (fromRawType t) (map fromRawType ts)
192 Type.RRecord fields ext ->
193 Record (map (second fromRawType) fields) (fmap fromRawType ext)