git.iko.soy/elk
on 8a87749 help sign in
elk/src/Elm/Compiler/Type.hs
182 lines 4.8 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Elm.Compiler.Type
3 ( Type(..)
4 , toString
5 ) where
7import Control.Applicative ((<$>), (<*>))
8import Control.Arrow (second)
9import Data.Aeson ((.:), (.=))
10import qualified Data.Aeson 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
18data Type
19 = Lambda Type Type
20 | Var String
21 | Type String
22 | App Type [Type]
23 | Record [(String, Type)] (Maybe Type)
26-- TO STRING
28data Context = None | ADT | Function
31toString :: Type -> String
32toString tipe =
33 P.render (toDoc None tipe)
36toDoc :: Context -> Type -> P.Doc
37toDoc context tipe =
38 case tipe of
39 Lambda _ _ ->
40 let t:ts =
41 map (toDoc Function) (collectLambdas tipe)
43 lambda =
44 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
45 in
46 case context of
47 None -> lambda
48 _ -> P.parens lambda
50 Var name ->
51 P.text name
53 Type name ->
54 P.text (if name == "_Tuple0" then "()" else name)
56 App (Type name) args
57 | Help.isTuple name ->
58 P.sep
59 [ P.cat (zipWith (<+>) (P.lparen : repeat P.comma) (map (toDoc None) args))
60 , P.rparen
61 ]
63 | otherwise ->
64 let adt = P.hang (P.text name) 2 (P.sep $ map (toDoc ADT) args)
65 in
66 case (context, args) of
67 (ADT, _ : _) -> P.parens adt
68 _ -> adt
70 App _ _ ->
71 error $
72 "Somehow ended up with an unexpected type, please post a minimal example that\n"
73 ++ "reproduces this error to <https://github.com/elm-lang/elm-compiler/issues>"
75 Record _ _ ->
76 case flattenRecord tipe of
77 ([], Nothing) ->
78 P.text "{}"
80 (fields, Nothing) ->
81 P.sep
82 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
83 , P.rbrace
84 ]
86 (fields, Just x) ->
87 P.hang
88 (P.lbrace <+> P.text x <+> P.text "|")
89 4
90 (P.sep
91 [ P.cat (zipWith (<+>) (P.space : repeat P.comma) (map prettyField fields))
92 , P.rbrace
93 ])
94 where
95 prettyField (field, tipe) =
96 P.text field <+> P.text ":" <+> toDoc None tipe
99collectLambdas :: Type -> [Type]
100collectLambdas tipe =
101 case tipe of
102 Lambda arg body -> arg : collectLambdas body
103 _ -> [tipe]
106flattenRecord :: Type -> ( [(String, Type)], Maybe String )
107flattenRecord tipe =
108 case tipe of
109 Var x -> ([], Just x)
111 Record fields Nothing -> (fields, Nothing)
113 Record fields (Just ext) ->
114 let (fields',ext') = flattenRecord ext
115 in
116 (fields' ++ fields, ext')
118 _ -> error "Trying to flatten ill-formed record."
121-- JSON for TYPE
123instance Json.ToJSON Type where
124 toJSON tipe =
125 Json.object (getFields tipe)
126 where
127 getFields tipe =
128 case tipe of
129 Lambda t1 t2 ->
130 [ "tag" .= ("lambda" :: Text.Text)
131 , "in" .= Json.toJSON t1
132 , "out" .= Json.toJSON t2
133 ]
135 Var x ->
136 [ "tag" .= ("var" :: Text.Text)
137 , "name" .= Json.toJSON x
138 ]
140 Type name ->
141 [ "tag" .= ("type" :: Text.Text)
142 , "name" .= Json.toJSON name
143 ]
145 App t ts ->
146 [ "tag" .= ("app" :: Text.Text)
147 , "func" .= Json.toJSON t
148 , "args" .= Json.toJSON ts
149 ]
151 Record fields ext ->
152 [ "tag" .= ("record" :: Text.Text)
153 , "fields" .= Json.toJSON (map (Json.toJSON . second Json.toJSON) fields)
154 , "extension" .= Json.toJSON ext
155 ]
158instance Json.FromJSON Type where
159 parseJSON (Json.Object obj) =
160 do tag <- obj .: "tag"
161 case (tag :: String) of
162 "lambda" ->
163 Lambda <$> obj .: "in" <*> obj .: "out"
165 "var" ->
166 Var <$> obj .: "name"
168 "type" ->
169 Type <$> obj .: "name"
171 "app" ->
172 App <$> obj .: "func" <*> obj .: "args"
174 "record" ->
175 Record <$> obj .: "fields" <*> obj .: "extension"
177 _ ->
178 fail $ "Error when decoding type with tag: " ++ tag
181 parseJSON value =
182 fail $ "Cannot decode Value from: " ++ BS.unpack (Json.encode value)