@@ -8,11 +8,17 @@ import Control.Applicative ((<$>), (<*>))
88import Control.Arrow (second)
99import Data.Aeson ((.:), (.=))
1010import qualified Data.Aeson as Json
11+import qualified Data.Aeson.Types as Json
1112import qualified Data.ByteString.Lazy.Char8 as BS
1213import qualified Data.Text as Text
1314import Text.PrettyPrint as P
1415
1516import qualified AST.Helpers as Help
17+import qualified AST.Type as Type
18+import qualified AST.Variable as Var
19+import qualified Parse.Helpers as Parse
20+import qualified Parse.Type as Type
21+import qualified Reporting.Annotation as A
1622
1723
1824data Type
@@ -122,62 +128,68 @@ flattenRecord tipe =
122128-- JSON for TYPE
123129
124130instance Json.ToJSON Type where
125− toJSON tipe =
126− Json.object (getFields tipe)
127− where
128− getFields tipe =
129− case tipe of
130− Lambda t1 t2 ->
131− [ "tag" .= ("lambda" :: Text.Text)
132− , "in" .= Json.toJSON t1
133− , "out" .= Json.toJSON t2
134− ]
131+ toJSON tipe =
132+ Json.String (Text.pack (toString tipe))
135133
136− Var x ->
137− [ "tag" .= ("var" :: Text.Text)
138− , "name" .= Json.toJSON x
139− ]
140134
141− Type name ->
142− [ "tag" .= ("type" :: Text.Text)
143− , "name" .= Json.toJSON name
144− ]
135+instance Json.FromJSON Type where
136+ parseJSON value =
137+ let
138+ failure _ =
139+ fail $
140+ "Trying to decode a type string, but could not handle this value:\n"
141+ ++ BS.unpack (Json.encode value)
142+ in
143+ case value of
144+ Json.String text ->
145+ either failure (return . fromRawType)
146+ (Parse.iParse Type.expr (Text.unpack text))
145147
146− App t ts ->
147− [ "tag" .= ("app" :: Text.Text)
148− , "func" .= Json.toJSON t
149− , "args" .= Json.toJSON ts
150− ]
148+ Json.Object obj ->
149+ fromObject obj
151150
152− Record fields ext ->
153− [ "tag" .= ("record" :: Text.Text)
154− , "fields" .= Json.toJSON (map (Json.toJSON . second Json.toJSON) fields)
155− , "extension" .= Json.toJSON ext
156− ]
151+ _ ->
152+ failure ()
157153
158154
159−instance Json.FromJSON Type where
160− parseJSON (Json.Object obj) =
161− do tag <- obj .: "tag"
162− case (tag :: String) of
163− "lambda" ->
164− Lambda <$> obj .: "in" <*> obj .: "out"
155+fromObject :: Json.Object -> Json.Parser Type
156+fromObject obj =
157+ do tag <- obj .: "tag"
158+ case (tag :: String) of
159+ "lambda" ->
160+ Lambda <$> obj .: "in" <*> obj .: "out"
161+
162+ "var" ->
163+ Var <$> obj .: "name"
164+
165+ "type" ->
166+ Type <$> obj .: "name"
167+
168+ "app" ->
169+ App <$> obj .: "func" <*> obj .: "args"
170+
171+ "record" ->
172+ Record <$> obj .: "fields" <*> obj .: "extension"
173+
174+ _ ->
175+ fail $ "Error when decoding type with tag: " ++ tag
165176
166− "var" ->
167− Var <$> obj .: "name"
168177
169− "type" ->
170− Type <$> obj .: "name"
178+fromRawType :: Type.Raw -> Type
179+fromRawType (A.A _ astType) =
180+ case astType of
181+ Type.RLambda t1 t2 ->
182+ Lambda (fromRawType t1) (fromRawType t2)
171183
172− "app" ->
173− App <$> obj .: "func" <*> obj .: "args"
184+ Type.RVar x ->
185+ Var x
174186
175− "record" ->
176− Record <$> obj .: "fields" <*> obj .: "extension"
187+ Type.RType var ->
188+ Type (Var.toString var)
177189
178− _ ->
179− fail $ "Error when decoding type with tag: " ++ tag
190+ Type.RApp t ts ->
191+ App (fromRawType t) (map fromRawType ts)
180192
193+ Type.RRecord fields ext ->
194+ Record (map (second fromRawType) fields) (fmap fromRawType ext)
181195
182− parseJSON value =
183− fail $ "Cannot decode Value from: " ++ BS.unpack (Json.encode value)