Permalink
Fetching contributors…
Cannot retrieve contributors at this time
253 lines (222 sloc) 8.26 KB
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
-- | Convert a Haskell value to a (JSON representation of a) Fay value.
module Fay.Convert
(showToFay
,readFromFay
,readFromFay'
,encodeFay
,decodeFay)
where
import Fay.Compiler.Prelude
import Control.Monad.State (evalStateT, get, lift, put)
import Control.Spoon
import Data.Aeson
import Data.Aeson.Types (parseEither)
import Data.Data
import Data.Generics.Aliases
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as Map
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time.Clock (UTCTime)
import Data.Vector (Vector)
import qualified Data.Vector as Vector
--------------------------------------------------------------------------------
-- The conversion functions.
-- | Convert a Haskell value to a Fay json value. This can fail when primitive
-- values aren't handled by explicit cases. 'encodeFay' can be used to
-- resolve this issue.
showToFay :: Data a => a -> Maybe Value
showToFay = spoon . encodeFay id
-- | Convert a Haskell value to a Fay json value. This can fail when primitive
-- values aren't handled by explicit cases. When this happens, you can add
-- additional cases via the first parameter.
--
-- The first parameter is a function that can be used to override the
-- conversion. This usually looks like using 'extQ' to additional type-
-- specific cases.
encodeFay :: (GenericQ Value -> GenericQ Value) -> GenericQ Value
encodeFay specialCases = specialCases $
encodeGeneric rec
`extQ` unit
`extQ` Bool
`extQ` (toJSON :: Int -> Value)
`extQ` (toJSON :: Float -> Value)
`extQ` (toJSON :: Double -> Value)
`extQ` (toJSON :: UTCTime -> Value)
`ext1Q` list
`extQ` string
`extQ` char
`extQ` text
where
rec :: GenericQ Value
rec = encodeFay specialCases
unit () = Null
list :: Data a => [a] -> Value
list = Array . Vector.fromList . map rec
string = String . Text.pack
char = String . Text.pack . (:[])
text = String
encodeGeneric :: GenericQ Value -> GenericQ Value
encodeGeneric rec x =
case constrName of
'(':(dropWhile (==',') -> ")") ->
Array $ Vector.fromList $ gmapQ rec x
_ -> Object $ Map.fromList $ map (first Text.pack) fields
where
fields =
("instance", String $ Text.pack constrName) :
zip labels (gmapQ rec x)
constrName = showConstr constr
constr = toConstr x
-- Note: constrFields can throw errors for non-algebraic datatypes. These
-- ought to be taken care of in the other cases of encodeFay.
labels = case constrFields constr of
[] -> map (("slot"++).show) [1::Int ..]
ls -> ls
-- | Convert a Fay json value to a Haskell value.
readFromFay :: Data a => Value -> Maybe a
readFromFay = either (const Nothing) Just . decodeFay (const id)
-- | Convert a Fay json value to a Haskell value. This is like readFromFay,
-- except it yields helpful error messages on failure.
readFromFay' :: Data a => Value -> Either String a
readFromFay' = decodeFay (const id)
-- | Convert a Fay json value to a Haskell value.
--
-- The first parameter is a function that can be used to override the
-- conversion. This usually looks like using 'extR' to additional type-
-- specific cases.
decodeFay :: Data b
=> (forall a. Data a => Value -> Either String a -> Either String a)
-> Value
-> Either String b
decodeFay specialCases value = specialCases value $
parseDataOrTuple rec value
`extR` parseUnit value
`extR` parseBool value
`extR` parseInt value
`extR` parseFloat value
`extR` parseDouble value
`ext1R` parseArray rec value
`extR` parseUTCTime value
`extR` parseString value
`extR` parseChar value
`extR` parseText value
where
rec :: GenericParser
rec = decodeFay specialCases
type GenericParser = forall a. Data a => Value -> Either String a
-- | Parse a data type or record or tuple.
parseDataOrTuple :: forall a. Data a => GenericParser -> Value -> Either String a
parseDataOrTuple rec value = result where
result = getAndParse value
typ = dataTypeOf (undefined :: a)
getAndParse x =
case x of
Object obj -> parseObject rec typ obj
Array tuple -> parseTuple rec typ tuple
_ -> badData value
-- | Parse a tuple.
parseTuple :: Data a => GenericParser -> DataType -> Vector Value -> Either String a
parseTuple rec typ arr =
case dataTypeConstrs typ of
[cons] -> evalStateT (fromConstrM (do i:next <- get
put next
value <- lift (Vector.indexM arr i)
lift (rec value))
cons)
[0..]
_ -> badData (Array arr)
-- | Parse a data constructor from an object.
parseObject :: Data a => GenericParser -> DataType -> HashMap Text Value -> Either String a
parseObject rec typ obj =
case Map.lookup (Text.pack "instance") obj of
Just (parseString -> Right name) ->
case filter (\con -> showConstr con == name) (dataTypeConstrs typ) of
[con] ->
let fields = constrFields con
in if null fields
then makeSimple rec obj con
else makeRecord rec obj con fields
_ -> badData (Object obj)
_ -> badData (Object obj)
-- | Make a simple ADT constructor from an object: { "slot1": 1, "slot2": 2} -> Foo 1 2
makeSimple :: Data a => GenericParser -> HashMap Text Value -> Constr -> Either String a
makeSimple rec obj cons =
evalStateT (fromConstrM (do i:next <- get
put next
value <- lift (lookupField obj (Text.pack ("slot" ++ show i)))
lift (rec value))
cons)
[(1::Integer)..]
-- | Make a record from a key-value: { "x": 1 } -> Foo { x = 1 }
makeRecord :: Data a => GenericParser -> HashMap Text Value -> Constr -> [String] -> Either String a
makeRecord rec obj cons =
evalStateT $
fromConstrM
(do key:next <- get
put next
value <- lift (lookupField obj (Text.pack key))
lift $ rec value)
cons
lookupField :: HashMap Text Value -> Text -> Either String Value
lookupField obj key =
justRight ("Missing field " ++ Text.unpack key ++ " in " ++ show (Object obj)) $
Map.lookup key obj
-- | Parse a float.
parseFloat :: Value -> Either String Float
parseFloat = parseEither parseJSON
-- | Parse a double.
parseDouble :: Value -> Either String Double
parseDouble = parseEither parseJSON
-- | Parse an int.
parseInt :: Value -> Either String Int
parseInt = parseEither parseJSON
-- | Parse a bool.
parseBool :: Value -> Either String Bool
parseBool value = case value of
Bool n -> return n
_ -> badData value
-- | Parse a string.
parseString :: Value -> Either String String
parseString value = case value of
String s -> return (Text.unpack s)
_ -> badData value
parseUTCTime :: Value -> Either String UTCTime
parseUTCTime value = case fromJSON value of
Success t -> Right t
Error _ -> badData value
-- | Parse a char.
parseChar :: Value -> Either String Char
parseChar value = case value of
String s | Just (c,_) <- Text.uncons s -> return c
_ -> badData value
-- | Parse a Text.
parseText :: Value -> Either String Text
parseText value = case value of
String s -> return s
_ -> badData value
-- | Parse an array.
parseArray :: Data a => GenericParser -> Value -> Either String [a]
parseArray rec value = case value of
Array xs -> mapM rec (Vector.toList xs)
_ -> badData value
-- | Parse unit.
parseUnit :: Value -> Either String ()
parseUnit value = case value of
Null -> return ()
_ -> badData value
badData :: forall a. Data a => Value -> Either String a
badData value = Left $
"Bad data in decodeFay - expected valid " ++
show (typeOf (undefined :: a)) ++
", but got:\n" ++
show value
justRight :: b -> Maybe a -> Either b a
justRight x Nothing = Left x
justRight _ (Just y) = Right y