module Fay.Convert
(showToFay
,readFromFay)
where
import Control.Applicative
import Control.Monad
import Control.Monad.State
import Data.Aeson
import Data.Attoparsec.Number
import Data.Char
import Data.Data
import Data.Function
import Data.Generics.Aliases
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as Map
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import Numeric
import Safe
import qualified Text.Show.Pretty as Show
showToFay :: Show a => a -> Maybe Value
showToFay = Show.reify >=> convert where
convert value = case value of
Show.Con "True" _ -> return (Bool True)
Show.Con "False" _ -> return (Bool False)
Show.Con name values -> fmap (Object . Map.fromList . (("instance",string name) :))
(slots values)
Show.Rec name fields -> fmap (Object . Map.fromList . (("instance",string name) :))
(mapM (uncurry keyval) fields)
Show.InfixCons _ _ -> Nothing
Show.Tuple [] -> return Null
Show.Tuple values -> fmap (Array . Vector.fromList) (mapM convert values)
Show.List values -> fmap (Array . Vector.fromList) (mapM convert values)
Show.String chars -> fmap string (readMay chars)
Show.Char char -> fmap (string.return) (readMay char)
Show.Neg{} -> double <|> int
Show.Integer{} -> int
Show.Float{} -> double
Show.Ratio{} -> double
where double = convertDouble value
int = convertInt value
convertDouble = fmap (Number . D) . pDouble
convertInt = fmap (Number . I) . pInt
pDouble :: Show.Value -> Maybe Double
pDouble value = case value of
Show.Float str -> getDouble str
Show.Ratio x y -> liftM2 (on (/) fromIntegral) (pInt x) (pInt y)
Show.Neg str -> fmap (* (1)) (pDouble str)
_ -> Nothing
pInt value = case value of
Show.Integer str -> getInt str
Show.Neg str -> fmap (* (1)) (pInt str)
_ -> Nothing
getDouble :: String -> Maybe Double
getDouble = fmap fst . listToMaybe . readFloat
getInt :: String -> Maybe Integer
getInt = fmap fst . listToMaybe . readInt 10 isDigit charToInt
where charToInt c = fromEnum c fromEnum '0'
string = String . Text.pack
slots = zipWithM keyval (map (("slot"++).show) [1::Int ..])
keyval key val = fmap (Text.pack key,) (convert val)
readFromFay :: Data a => Value -> Maybe a
readFromFay value =
parseDataOrTuple value
`ext1R` parseArray value
`extR` parseDouble value
`extR` parseInt value
`extR` parseBool value
`extR` parseString value
`extR` parseChar value
`extR` parseText value
`extR` parseUnit value
parseDataOrTuple :: Data a => Value -> Maybe a
parseDataOrTuple value = result where
result = getAndParse value
typ = dataTypeOf (fromJust result)
getAndParse x =
case x of
Object obj -> parseObject typ obj
Array tuple -> parseTuple typ tuple
_ -> mzero
parseTuple :: Data a => DataType -> Vector Value -> Maybe a
parseTuple typ arr =
case dataTypeConstrs typ of
[cons] -> evalStateT (fromConstrM (do i:next <- get
put next
value <- lift (Vector.indexM arr i)
lift (readFromFay value))
cons)
[0..]
_ -> Nothing
parseObject :: Data a => DataType -> HashMap Text Value -> Maybe a
parseObject typ obj = listToMaybe (catMaybes choices) where
choices = map makeConstructor constructors
constructors = dataTypeConstrs typ
makeConstructor cons = do
name <- Map.lookup (Text.pack "instance") obj >>= parseString
guard (showConstr cons == name)
if null fields
then makeSimple obj cons
else makeRecord obj cons fields
where fields = constrFields cons
makeSimple :: Data a => HashMap Text Value -> Constr -> Maybe a
makeSimple obj cons =
evalStateT (fromConstrM (do i:next <- get
put next
value <- lift (Map.lookup (Text.pack ("slot" ++ show i)) obj)
lift (readFromFay value))
cons)
[1..]
makeRecord :: Data a => HashMap Text Value -> Constr -> [String] -> Maybe a
makeRecord obj cons fields =
evalStateT (fromConstrM (do key:next <- get
put next
value <- lift (Map.lookup (Text.pack key) obj)
lift (readFromFay value))
cons)
fields
parseDouble :: Value -> Maybe Double
parseDouble value = do
number <- parseNumber value
case number of
I n -> return (fromIntegral n)
D n -> return n
parseInt :: Value -> Maybe Int
parseInt value = do
number <- parseNumber value
case number of
I n -> return (fromIntegral n)
_ -> mzero
parseNumber :: Value -> Maybe Number
parseNumber value =
case value of
Number n -> return n
_ -> mzero
parseBool :: Value -> Maybe Bool
parseBool value =
case value of
Bool n -> return n
_ -> mzero
parseString :: Value -> Maybe String
parseString value =
case value of
String s -> return (Text.unpack s)
_ -> mzero
parseChar :: Value -> Maybe Char
parseChar value =
case value of
String s | Just (c,_) <- Text.uncons s -> return c
_ -> mzero
parseText :: Value -> Maybe Text
parseText value =
case value of
String s -> return s
_ -> mzero
parseArray :: Data a => Value -> Maybe [a]
parseArray value =
case value of
Array xs -> mapM readFromFay (Vector.toList xs)
_ -> mzero
parseUnit :: Value -> Maybe ()
parseUnit value =
case value of
Null -> return ()
_ -> mzero