git.iko.soy/elk
on 267f708 help sign in
elk/src/Elm/Compiler/Type.hs
197 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 | name == "_Tuple0" ->
63 P.text "()"
65 | Help.isTuple name ->
66 P.sep
67 [ P.cat (zipWith (<+>) (P.lparen : repeat P.comma) (map (toDoc None) args))
68 , P.rparen
69 ]
71 | otherwise ->
72 let adt = P.hang (P.text name) 2 (P.sep $ map (toDoc ADT) args)
73 in
74 case (context, args) of
75 (ADT, _ : _) -> P.parens adt
76 _ -> adt
78 App _ _ ->
79 error $
80 "Somehow ended up with an unexpected type, please post a minimal example that\n"
81 ++ "reproduces this error to <https://github.com/elm-lang/elm-compiler/issues>"
83 Record _ _ ->
84 case flattenRecord tipe of
85 ([], Nothing) ->
86 P.text "{}"
88 (fields, Nothing) ->
89 P.sep
90 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
91 , P.rbrace
92 ]
94 (fields, Just x) ->
95 P.hang
96 (P.lbrace <+> P.text x <+> P.text "|")
97 4
98 (P.sep
99 [ P.sep (P.punctuate P.comma (map prettyField fields))
100 , P.rbrace
101 ]
102 )
103 where
104 prettyField (field, tipe) =
105 P.text field <+> P.text ":" <+> toDoc None tipe
108collectLambdas :: Type -> [Type]
109collectLambdas tipe =
110 case tipe of
111 Lambda arg body -> arg : collectLambdas body
112 _ -> [tipe]
115flattenRecord :: Type -> ( [(String, Type)], Maybe String )
116flattenRecord tipe =
117 case tipe of
118 Var x -> ([], Just x)
120 Record fields Nothing -> (fields, Nothing)
122 Record fields (Just ext) ->
123 let (fields',ext') = flattenRecord ext
124 in
125 (fields' ++ fields, ext')
127 _ -> error "Trying to flatten ill-formed record."
130-- JSON for TYPE
132instance Json.ToJSON Type where
133 toJSON tipe =
134 Json.String (Text.unwords (Text.words (Text.pack (toString tipe))))
137instance Json.FromJSON Type where
138 parseJSON value =
139 let
140 failure _ =
141 fail $
142 "Trying to decode a type string, but could not handle this value:\n"
143 ++ BS.unpack (Json.encode value)
144 in
145 case value of
146 Json.String text ->
147 either failure (return . fromRawType)
148 (Parse.iParse Type.expr (Text.unpack text))
150 Json.Object obj ->
151 fromObject obj
153 _ ->
154 failure ()
157fromObject :: Json.Object -> Json.Parser Type
158fromObject obj =
159 do tag <- obj .: "tag"
160 case (tag :: String) of
161 "lambda" ->
162 Lambda <$> obj .: "in" <*> obj .: "out"
164 "var" ->
165 Var <$> obj .: "name"
167 "type" ->
168 Type <$> obj .: "name"
170 "app" ->
171 App <$> obj .: "func" <*> obj .: "args"
173 "record" ->
174 Record <$> obj .: "fields" <*> obj .: "extension"
176 _ ->
177 fail $ "Error when decoding type with tag: " ++ tag
180fromRawType :: Type.Raw -> Type
181fromRawType (A.A _ astType) =
182 case astType of
183 Type.RLambda t1 t2 ->
184 Lambda (fromRawType t1) (fromRawType t2)
186 Type.RVar x ->
187 Var x
189 Type.RType var ->
190 Type (Var.toString var)
192 Type.RApp t ts ->
193 App (fromRawType t) (map fromRawType ts)
195 Type.RRecord fields ext ->
196 Record (map (second fromRawType) fields) (fmap fromRawType ext)