#if __GLASGOW_HASKELL__ < 710
#endif
module Generics.SOP.JSON (
JsonFieldName
, JsonTagName
, JsonOptions(..)
, defaultJsonOptions
, Tag(..)
, JsonInfo(..)
, jsonInfo
, gtoJSON
, gparseJSON
, UpdateFromJSON(..)
, gupdateFromJSON
, replaceWithJSON
, parseWith
, ToJSON(..)
, FromJSON(..)
, Proxy(..)
) where
import Control.Arrow (first)
import Control.Monad
import Data.Aeson (ToJSON(..), FromJSON(..), Value(..))
import Data.Aeson.Types (Parser, modifyFailure)
import Data.List (intercalate)
import Data.Text (Text)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Text as Text
import qualified Data.Vector as Vector
import Generics.SOP
import Generics.SOP.Lens
import Generics.SOP.Util.PartialResult
type JsonFieldName = String
type JsonTagName = String
data JsonOptions = JsonOptions {
jsonFieldName :: DatatypeName -> FieldName -> JsonFieldName
, jsonTagName :: ConstructorName -> JsonTagName
}
defaultJsonOptions :: JsonOptions
defaultJsonOptions = JsonOptions {
jsonFieldName = const id
, jsonTagName = id
}
data Tag = NoTag | Tag JsonTagName
data JsonInfo :: [*] -> * where
JsonZero :: ConstructorName -> JsonInfo '[]
JsonOne :: Tag -> JsonInfo '[a]
JsonMultiple :: SListI xs => Tag -> JsonInfo xs
JsonRecord :: SListI xs => Tag -> NP (K String) xs -> JsonInfo xs
jsonInfoFor :: forall xs. JsonOptions -> DatatypeName -> (ConstructorName -> Tag) -> ConstructorInfo xs -> JsonInfo xs
jsonInfoFor _ _ tag (Infix n _ _) = JsonMultiple (tag n)
jsonInfoFor _ _ tag (Constructor n) =
case shape :: Shape xs of
ShapeNil -> JsonZero n
ShapeCons ShapeNil -> JsonOne (tag n)
_ -> JsonMultiple (tag n)
jsonInfoFor opts d tag (Record n fields) =
JsonRecord (tag n) (hliftA jfieldName fields)
where
jfieldName :: FieldInfo a -> K String a
jfieldName (FieldInfo name) = K (jsonFieldName opts d name)
jsonInfo :: forall a. (HasDatatypeInfo a, SListI (Code a))
=> Proxy a -> JsonOptions -> NP JsonInfo (Code a)
jsonInfo pa opts =
case datatypeInfo pa of
Newtype _ _ _ -> JsonOne NoTag :* Nil
ADT _ n cs -> hliftA (jsonInfoFor opts n (tag cs)) cs
where
tag :: NP ConstructorInfo (Code a) -> ConstructorName -> Tag
tag cs | _ :* Nil <- cs = const NoTag
| otherwise = Tag . jsonTagName opts
gtoJSON :: forall a. (Generic a, HasDatatypeInfo a, All2 ToJSON (Code a))
=> JsonOptions -> a -> Value
gtoJSON opts a =
hcollapse $ hcliftA2 allpt gtoJSON' (jsonInfo (Proxy :: Proxy a) opts)
(unSOP $ from a)
gtoJSON' :: All ToJSON xs => JsonInfo xs -> NP I xs -> K Value xs
gtoJSON' (JsonZero n) Nil =
K $ String (Text.pack n)
gtoJSON' (JsonOne tag) (I a :* Nil) =
tagValue tag (toJSON a)
gtoJSON' (JsonMultiple tag) cs =
tagValue tag
. Array
. Vector.fromList
. hcollapse
. hcliftA pt (K . toJSON . unI)
$ cs
gtoJSON' (JsonRecord tag fields) cs =
tagValue tag
. Object
. HashMap.fromList
. hcollapse
$ hcliftA2 pt (\(K field) (I a) -> K (Text.pack field, toJSON a)) fields cs
#if __GLASGOW_HASKELL__ < 800
gtoJSON' _ _ = error "inaccessible"
#endif
gparseJSON :: forall a. (Generic a, HasDatatypeInfo a, All2 FromJSON (Code a))
=> JsonOptions -> Value -> Parser a
gparseJSON opts v = to `liftM` gparseJSON' v (jsonInfo (Proxy :: Proxy a) opts)
gparseJSON' :: forall (xss :: [[*]]). All2 FromJSON xss
=> Value -> NP JsonInfo xss -> Parser (SOP I xss)
gparseJSON' v info = runPartial failWith
. msum
. hcollapse
$ hcliftA2 allpf (parseConstructor v) info injs
where
failWith :: [String] -> Parser (SOP I xss)
failWith [] = fail $ "Unknown error"
failWith errs = fail $ intercalate " or " errs
injs :: NP (Injection (NP I) xss) xss
injs = injections
parseConstructor :: forall (xss :: [[*]]) (xs :: [*]). All FromJSON xs
=> Value -> JsonInfo xs -> Injection (NP I) xss xs -> K (Partial Parser (SOP I xss)) xs
parseConstructor v info (Fn inj) = K $ do
vals <- parseValues info v
prod <- lift . hsequence $ hcliftA pf aux vals
return $ SOP $ unK (inj prod)
where
aux :: FromJSON a => K (Maybe String, Value) a -> Parser a
aux (K (Just fName, val)) = modifyFailure (\str -> fName ++ ": " ++ str) $ parseJSON val
aux (K (Nothing, val)) = parseJSON val
parseValues :: forall (xs :: [*]). SListI xs
=> JsonInfo xs -> Value -> Partial Parser (NP (K (Maybe String, Value)) xs)
parseValues (JsonZero n) =
withText ("Expected literal " ++ show n) $ \txt -> do
guard $ Text.unpack txt == n
return Nil
parseValues (JsonOne tag) =
untag tag $ \v ->
return (K (Nothing, v) :* Nil)
parseValues (JsonMultiple tag) =
untag tag $ withArray "Array" $ \arr -> do
case fromList (map (\v -> (Nothing, v)) arr) of
Just values -> return values
Nothing -> fail $ "Got " ++ show (length arr) ++ "values, "
++ "expected " ++ show (lengthSList (Proxy :: Proxy xs))
parseValues (JsonRecord tag fields) =
untag tag $ withObject "Object" $ \obj -> do
values <- hsequenceK =<< lineup fields obj
return $ hliftA2 pairFieldName fields values
where
pairFieldName (K x) (K y) = K (Just x, y)
untag :: (Monad m, Functor m) => Tag -> (Value -> Partial m a) -> Value -> Partial m a
untag NoTag f = f
untag (Tag n) f = withObject "Object" $ \obj ->
case obj of
[(n', v)] | n' == n -> partialResult $ f v
_ -> fail $ "Expected tag " ++ show n
class UpdateFromJSON a where
updateFromJSON :: Value -> Parser (a -> a)
replaceWithJSON :: FromJSON a => Value -> Parser (a -> a)
replaceWithJSON v = parseJSON v >>= \new -> return $ \_old -> new
parseWith :: UpdateFromJSON a => a -> Value -> Parser a
parseWith a = liftM ($ a) . updateFromJSON
instance
#if __GLASGOW_HASKELL__ >= 710
#endif
FromJSON a => UpdateFromJSON [a] where updateFromJSON = replaceWithJSON
instance
#if __GLASGOW_HASKELL__ >= 710
#endif
FromJSON a => UpdateFromJSON (Maybe a) where updateFromJSON = replaceWithJSON
instance UpdateFromJSON Int where updateFromJSON = replaceWithJSON
instance UpdateFromJSON Double where updateFromJSON = replaceWithJSON
instance UpdateFromJSON Rational where updateFromJSON = replaceWithJSON
instance UpdateFromJSON Bool where updateFromJSON = replaceWithJSON
instance UpdateFromJSON Text where updateFromJSON = replaceWithJSON
instance
#if __GLASGOW_HASKELL__ >= 710
#endif
UpdateFromJSON String where updateFromJSON = replaceWithJSON
gupdateFromJSON :: forall a xs. (Generic a, HasDatatypeInfo a, All UpdateFromJSON xs, Code a ~ '[xs])
=> JsonOptions -> Value -> Parser (a -> a)
gupdateFromJSON opts v = do
case jsonInfo (Proxy :: Proxy a) opts of
JsonRecord _ fields :* Nil -> gupdateRecord fields glenses v
_ :* Nil -> error "cannot update non-record type"
#if __GLASGOW_HASKELL__ < 800
_ -> error "inaccessible"
#endif
gupdateRecord :: forall (xs :: [*]) (a :: *). All UpdateFromJSON xs
=> NP (K String) xs -> NP (GLens (->) (->) a) xs -> Value -> Parser (a -> a)
gupdateRecord fields lenses = withObject "Object" $ \obj -> do
values :: NP (K (Maybe Value)) xs <- lineup fields obj
updates <- hcollapse `liftM` hsequenceK (hcliftA2 pu update values lenses)
return $ foldr (.) id updates
where
update :: forall b. UpdateFromJSON b
=> K (Maybe Value) b -> GLens (->) (->) a b -> K (Parser (a -> a)) b
update (K Nothing) _ = K $ return id
update (K (Just v)) l = K $ do f <- updateFromJSON v
return $ \a -> modify l (f, a)
lineup :: (Monad m, MonadPlus m', Eq a, Show a)
=> NP (K a) xs -> [(a, b)] -> m (NP (K (m' b)) xs)
lineup Nil [] = return Nil
lineup Nil vals = fail $ "Unexpected key(s): " ++ show (map fst vals)
lineup (K k :* ks) [] = do bs <- lineup ks [] ; return $ K (missingKey k) :* bs
lineup (K k :* ks) vs =
case remove ((== k) . fst) vs of
Nothing -> do bs <- lineup ks vs ; return $ K (missingKey k) :* bs
Just ((_, b), vs') -> do bs <- lineup ks vs' ; return $ K (return b) :* bs
missingKey :: (Monad m, Show a) => a -> m b
missingKey k = fail $ "missing key " ++ show k
remove :: (a -> Bool) -> [a] -> Maybe (a, [a])
remove _ [] = Nothing
remove f (x:xs) | f x = Just (x, xs)
| otherwise = do (y, ys) <- remove f xs ; return (y, x:ys)
tagValue :: Tag -> Value -> K Value a
tagValue NoTag v = K v
tagValue (Tag t) v = K $ Object $ HashMap.fromList [(Text.pack t, v)]
pt :: Proxy ToJSON
pt = Proxy
allpt :: Proxy (All ToJSON)
allpt = Proxy
pf :: Proxy FromJSON
pf = Proxy
allpf :: Proxy (All FromJSON)
allpf = Proxy
pu :: Proxy UpdateFromJSON
pu = Proxy
withObject :: Monad m => String -> ([(String, Value)] -> m a) -> Value -> m a
withObject _ f (Object obj) = f $ map (first Text.unpack) (HashMap.toList obj)
withObject expected _ v = typeMismatch expected v
withText :: Monad m => String -> (Text -> m a) -> Value -> m a
withText _ f (String txt) = f txt
withText expected _ v = typeMismatch expected v
withArray :: Monad m => String -> ([Value] -> m a) -> Value -> m a
withArray _ f (Array arr) = f $ Vector.toList arr
withArray expected _ v = typeMismatch expected v
typeMismatch :: Monad m
=> String
-> Value
-> m a
typeMismatch expected actual =
fail $ "when expecting a " ++ expected ++ ", encountered " ++ name ++
" instead"
where
name = case actual of
Object _ -> "Object"
Array _ -> "Array"
String _ -> "String"
Number _ -> "Number"
Bool _ -> "Boolean"
Null -> "Null"