{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -Wno-type-defaults #-}
{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}
module Data.Registry.MessagePack.Decoder where
import Control.Monad.Fail
import Data.List (nub)
import Data.MessagePack as MP
import Data.Registry
import Data.Registry.MessagePack.Options
import Data.Registry.MessagePack.TH
import qualified Data.Vector as Vector
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Protolude hiding (Type)
import Prelude (String)
newtype Decoder a = Decoder {forall a. Decoder a -> Object -> Result a
decode :: Object -> MP.Result a}
instance Functor Decoder where
fmap :: forall a b. (a -> b) -> Decoder a -> Decoder b
fmap a -> b
f (Decoder Object -> Result a
d) = forall a. (Object -> Result a) -> Decoder a
Decoder (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Result a
d)
instance Applicative Decoder where
pure :: forall a. a -> Decoder a
pure a
a = forall a. (Object -> Result a) -> Decoder a
Decoder (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a))
Decoder (a -> b)
f <*> :: forall a b. Decoder (a -> b) -> Decoder a -> Decoder b
<*> Decoder a
a = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
($) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. Decoder a -> Decoder b -> Decoder (a, b)
decoderAp Decoder (a -> b)
f Decoder a
a
decoderAp :: Decoder a -> Decoder b -> Decoder (a, b)
decoderAp :: forall a b. Decoder a -> Decoder b -> Decoder (a, b)
decoderAp (Decoder Object -> Result a
da) (Decoder Object -> Result b
db) = forall a. (Object -> Result a) -> Decoder a
Decoder forall a b. (a -> b) -> a -> b
$ \case
o :: Object
o@(ObjectArray Vector Object
ls) ->
case forall a. [a] -> [a]
reverse (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Vector Object
ls) of
Object
b : [Object]
as -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Result a
da (Vector Object -> Object
ObjectArray forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Vector a
Vector.fromList forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Object]
as) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Result b
db Object
b
[] -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Result a
da Object
o forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Result b
db Object
o
Object
o -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Result a
da Object
o forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Result b
db Object
o
decodeByteString :: forall a. (Typeable a) => Decoder a -> ByteString -> Either Text a
decodeByteString :: forall a. Typeable a => Decoder a -> ByteString -> Either Text a
decodeByteString Decoder a
d ByteString
bs =
case forall a. MessagePack a => ByteString -> Either String a
unpack' ByteString
bs of
Left String
e -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"cannot unpack the bytestring as an Object: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show String
e forall a. Semigroup a => a -> a -> a
<> Text
". The bytestring is: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show ByteString
bs
Right Object
o ->
case forall a. Decoder a -> Object -> Either Text a
decodeObject Decoder a
d Object
o of
Right a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Left Text
e -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Error: " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertText a b => a -> b
toS Text
e forall a. Semigroup a => a -> a -> a
<> Text
". Cannot decode " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertText a b => a -> b
toS (forall a. Typeable a => String
showType @a) forall a. Semigroup a => a -> a -> a
<> Text
" from the Object: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Object
o
decodeObject :: Decoder a -> Object -> Either Text a
decodeObject :: forall a. Decoder a -> Object -> Either Text a
decodeObject (Decoder Object -> Result a
d) Object
object =
case Object -> Result a
d Object
object of
Success a
a -> forall a b. b -> Either a b
Right a
a
Error String
e -> forall a b. a -> Either a b
Left (forall a b. ConvertText a b => a -> b
toS String
e)
messagePackDecoder :: forall a. (MessagePack a, Typeable a) => Typed (Decoder a)
messagePackDecoder :: forall a. (MessagePack a, Typeable a) => Typed (Decoder a)
messagePackDecoder = forall a. Typeable a => a -> Typed a
fun (forall a. MessagePack a => Decoder a
messagePackDecoderOf @a)
messagePackDecoderOf :: MessagePack a => Decoder a
messagePackDecoderOf :: forall a. MessagePack a => Decoder a
messagePackDecoderOf = forall a. (Object -> Result a) -> Decoder a
Decoder forall a. MessagePack a => Object -> Result a
fromObject
readDecoder :: forall a. (Typeable a, Read a) => Typed (Decoder String -> Decoder a)
readDecoder :: forall a.
(Typeable a, Read a) =>
Typed (Decoder String -> Decoder a)
readDecoder = forall a. Typeable a => a -> Typed a
fun forall a. Read a => Decoder String -> Decoder a
readDecoderOf
readDecoderOf :: forall a. (Read a) => Decoder String -> Decoder a
readDecoderOf :: forall a. Read a => Decoder String -> Decoder a
readDecoderOf Decoder String
ds = forall a. (Object -> Result a) -> Decoder a
Decoder forall a b. (a -> b) -> a -> b
$ forall a. Decoder a -> Object -> Result a
decode Decoder String
ds forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. String -> Result a
Error forall a. a -> Result a
Success forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a e.
(Read a, StringConv String e, StringConv e String) =>
e -> Either e a
readEither)
decodeMaybeOf :: forall a. (Typeable a) => Typed (Decoder a -> Decoder (Maybe a))
decodeMaybeOf :: forall a. Typeable a => Typed (Decoder a -> Decoder (Maybe a))
decodeMaybeOf = forall a. Typeable a => a -> Typed a
fun (forall a. Decoder a -> Decoder (Maybe a)
maybeOfDecoder @a)
maybeOfDecoder :: forall a. Decoder a -> Decoder (Maybe a)
maybeOfDecoder :: forall a. Decoder a -> Decoder (Maybe a)
maybeOfDecoder (Decoder Object -> Result a
d) = forall a. (Object -> Result a) -> Decoder a
Decoder forall a b. (a -> b) -> a -> b
$ \case
Object
ObjectNil -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
Object
just -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Result a
d Object
just
decodePairOf :: forall a b. (Typeable a, Typeable b) => Typed (Decoder a -> Decoder b -> Decoder (a, b))
decodePairOf :: forall a b.
(Typeable a, Typeable b) =>
Typed (Decoder a -> Decoder b -> Decoder (a, b))
decodePairOf = forall a. Typeable a => a -> Typed a
fun (forall a b.
(Typeable a, Typeable b) =>
Decoder a -> Decoder b -> Decoder (a, b)
pairOfDecoder @a @b)
pairOfDecoder :: forall a b. (Typeable a, Typeable b) => Decoder a -> Decoder b -> Decoder (a, b)
pairOfDecoder :: forall a b.
(Typeable a, Typeable b) =>
Decoder a -> Decoder b -> Decoder (a, b)
pairOfDecoder (Decoder Object -> Result a
a) (Decoder Object -> Result b
b) = forall a. (Object -> Result a) -> Decoder a
Decoder forall a b. (a -> b) -> a -> b
$ \case
ObjectArray [Item (Vector Object)
oa, Item (Vector Object)
ob] -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Result a
a Item (Vector Object)
oa forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Result b
b Item (Vector Object)
ob
Object
other -> forall a. String -> Result a
Error forall a b. (a -> b) -> a -> b
$ String
"not a pair of " forall a. Semigroup a => a -> a -> a
<> forall a. Typeable a => String
showType @a forall a. Semigroup a => a -> a -> a
<> String
"," forall a. Semigroup a => a -> a -> a
<> forall a. Typeable a => String
showType @b forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Object
other
decodeTripleOf :: forall a b c. (Typeable a, Typeable b, Typeable c) => Typed (Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c))
decodeTripleOf :: forall a b c.
(Typeable a, Typeable b, Typeable c) =>
Typed (Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c))
decodeTripleOf = forall a. Typeable a => a -> Typed a
fun (forall a b c.
(Typeable a, Typeable b, Typeable c) =>
Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c)
tripleOfDecoder @a @b @c)
tripleOfDecoder :: forall a b c. (Typeable a, Typeable b, Typeable c) => Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c)
tripleOfDecoder :: forall a b c.
(Typeable a, Typeable b, Typeable c) =>
Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c)
tripleOfDecoder (Decoder Object -> Result a
a) (Decoder Object -> Result b
b) (Decoder Object -> Result c
c) = forall a. (Object -> Result a) -> Decoder a
Decoder forall a b. (a -> b) -> a -> b
$ \case
ObjectArray [Item (Vector Object)
oa, Item (Vector Object)
ob, Item (Vector Object)
oc] -> (,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Result a
a Item (Vector Object)
oa forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Result b
b Item (Vector Object)
ob forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Result c
c Item (Vector Object)
oc
Object
other -> forall a. String -> Result a
Error forall a b. (a -> b) -> a -> b
$ String
"not a triple of " forall a. Semigroup a => a -> a -> a
<> forall a. Typeable a => String
showType @a forall a. Semigroup a => a -> a -> a
<> String
"," forall a. Semigroup a => a -> a -> a
<> forall a. Typeable a => String
showType @b forall a. Semigroup a => a -> a -> a
<> String
"," forall a. Semigroup a => a -> a -> a
<> forall a. Typeable a => String
showType @c forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Object
other
decodeListOf :: forall a. (Typeable a) => Typed (Decoder a -> Decoder [a])
decodeListOf :: forall a. Typeable a => Typed (Decoder a -> Decoder [a])
decodeListOf = forall a. Typeable a => a -> Typed a
fun (forall a. Typeable a => Decoder a -> Decoder [a]
listOfDecoder @a)
listOfDecoder :: forall a. (Typeable a) => Decoder a -> Decoder [a]
listOfDecoder :: forall a. Typeable a => Decoder a -> Decoder [a]
listOfDecoder (Decoder Object -> Result a
a) = forall a. (Object -> Result a) -> Decoder a
Decoder forall a b. (a -> b) -> a -> b
$ \case
ObjectArray Vector Object
os -> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Vector Object
os) Object -> Result a
a
Object
other -> forall a. String -> Result a
Error forall a b. (a -> b) -> a -> b
$ String
"not a list of " forall a. Semigroup a => a -> a -> a
<> forall a. Typeable a => String
showType @a forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Object
other
decodeNonEmptyOf :: forall a. (Typeable a) => Typed (Decoder a -> Decoder (NonEmpty a))
decodeNonEmptyOf :: forall a. Typeable a => Typed (Decoder a -> Decoder (NonEmpty a))
decodeNonEmptyOf = forall a. Typeable a => a -> Typed a
fun (forall a. Typeable a => Decoder a -> Decoder (NonEmpty a)
nonEmptyOfDecoder @a)
nonEmptyOfDecoder :: forall a. (Typeable a) => Decoder a -> Decoder (NonEmpty a)
nonEmptyOfDecoder :: forall a. Typeable a => Decoder a -> Decoder (NonEmpty a)
nonEmptyOfDecoder (Decoder Object -> Result a
a) = forall a. (Object -> Result a) -> Decoder a
Decoder forall a b. (a -> b) -> a -> b
$ \case
ObjectArray Vector Object
values ->
case forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Vector Object
values of
[] -> forall a. String -> Result a
Error forall a b. (a -> b) -> a -> b
$ String
"expected a NonEmpty of " forall a. Semigroup a => a -> a -> a
<> forall a. Typeable a => String
showType @a
Object
o : [Object]
os -> forall a. a -> [a] -> NonEmpty a
(:|) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Result a
a Object
o forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Object]
os Object -> Result a
a
Object
other -> forall a. String -> Result a
Error forall a b. (a -> b) -> a -> b
$ String
"not a list of " forall a. Semigroup a => a -> a -> a
<> forall a. Typeable a => String
showType @a forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Object
other
showType :: forall a. (Typeable a) => String
showType :: forall a. Typeable a => String
showType = forall a b. (Show a, StringConv String b) => a -> b
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy a))
makeDecoder :: Name -> ExpQ
makeDecoder :: Name -> Q Exp
makeDecoder = Options -> Name -> Q Exp
makeDecoderWith Options
defaultOptions
makeDecoderQualified :: Name -> ExpQ
makeDecoderQualified :: Name -> Q Exp
makeDecoderQualified = Options -> Name -> Q Exp
makeDecoderWith ((Text -> Text) -> Options
Options forall a. a -> a
identity)
makeDecoderQualifiedLast :: Name -> ExpQ
makeDecoderQualifiedLast :: Name -> Q Exp
makeDecoderQualifiedLast = Options -> Name -> Q Exp
makeDecoderWith ((Text -> Text) -> Options
Options Text -> Text
qualifyWithLastName)
makeDecoderWith :: Options -> Name -> ExpQ
makeDecoderWith :: Options -> Name -> Q Exp
makeDecoderWith Options
options Name
typeName = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"fun") forall a b. (a -> b) -> a -> b
$ do
Info
info <- Name -> Q Info
reify Name
typeName
case Info
info of
TyConI (NewtypeD Cxt
_context Name
_name [TyVarBndr ()]
_typeVars Maybe Type
_kind (RecC Name
constructor [(Name
_, Bang
_, Type
other)]) [DerivClause]
_deriving) -> do
let cName :: Name
cName = String -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall a b. (Show a, StringConv String b) => a -> b
show forall a b. (a -> b) -> a -> b
$ Options -> Name -> Name
makeName Options
options Name
constructor
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (forall (m :: * -> *). Quote m => Name -> m Pat
varP forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"d") (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Decoder") (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
other))] (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"fmap") (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
cName)) (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"d"))
TyConI (NewtypeD Cxt
_context Name
_name [TyVarBndr ()]
_typeVars Maybe Type
_kind (NormalC Name
constructor [(Bang
_, Type
other)]) [DerivClause]
_deriving) -> do
let cName :: Name
cName = String -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall a b. (Show a, StringConv String b) => a -> b
show forall a b. (a -> b) -> a -> b
$ Options -> Name -> Name
makeName Options
options Name
constructor
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (forall (m :: * -> *). Quote m => Name -> m Pat
varP forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"d") (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Decoder") (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
other))] (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"fmap") (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
cName)) (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"d"))
TyConI (DataD Cxt
_context Name
_name [TyVarBndr ()]
_typeVars Maybe Type
_kind [Con]
constructors [DerivClause]
_deriving) -> do
case [Con]
constructors of
[] -> do
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True String
"can not make an Decoder for an empty data type"
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"decoders creation failed"
[Item [Con]
c] -> Options -> Name -> Con -> Q Exp
makeConstructorDecoder Options
options Name
typeName Item [Con]
c
[Con]
_ -> Options -> Name -> [Con] -> Q Exp
makeConstructorsDecoder Options
options Name
typeName [Con]
constructors
Info
other -> do
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"can only create decoders for an ADT, got: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Info
other)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"decoders creation failed"
makeConstructorDecoder :: Options -> Name -> Con -> ExpQ
makeConstructorDecoder :: Options -> Name -> Con -> Q Exp
makeConstructorDecoder Options
options Name
typeName Con
c = do
Cxt
ts <- Con -> Q Cxt
typesOf Con
c
Name
cName <- Options -> Name -> Name
makeName Options
options forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> Q Name
nameOf Con
c
let decoderParameters :: [Q Pat]
decoderParameters = (\(Type
t, Integer
n) -> forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"d" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Integer
n)) (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Decoder") (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. [a] -> [b] -> [(a, b)]
zip Cxt
ts [Integer
0 ..]
let paramP :: Q Pat
paramP = forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"o")
let paramE :: Q Exp
paramE = forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"o")
let paramsP :: [Q Pat]
paramsP = (\Int
n -> forall (m :: * -> *). Quote m => Name -> m Pat
varP forall a b. (a -> b) -> a -> b
$ String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"o" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int
n) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
0 .. forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
ts forall a. Num a => a -> a -> a
-Int
1]
let matchClause :: Q Match
matchClause =
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
(forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (String -> Name
mkName String
"ObjectArray") [forall (m :: * -> *). Quote m => m Exp -> m Pat -> m Pat
viewP (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"toList")) (forall (m :: * -> *). Quote m => [m Pat] -> m Pat
listP [Q Pat]
paramsP)])
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Name -> [Int] -> Q Exp
applyDecoder Name
cName [Int
0 .. forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
ts forall a. Num a => a -> a -> a
- Int
1]))
[]
let decoded :: Q Exp
decoded = forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE Q Exp
paramE [Q Match
matchClause, Options -> Name -> Q Match
makeErrorClause Options
options Name
typeName]
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Q Pat]
decoderParameters (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE (String -> Name
mkName String
"Decoder")) (forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Q Pat
paramP] Q Exp
decoded))
makeConstructorsDecoder :: Options -> Name -> [Con] -> ExpQ
makeConstructorsDecoder :: Options -> Name -> [Con] -> Q Exp
makeConstructorsDecoder Options
options Name
typeName [Con]
cs = do
Cxt
ts <- forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Con]
cs Con -> Q Cxt
typesOf
let decoderParameters :: [Q Pat]
decoderParameters = (\(Type
t, Integer
n) -> forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"d" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Integer
n)) (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Decoder") (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. [a] -> [b] -> [(a, b)]
zip Cxt
ts [Integer
0 ..]
let paramP :: Q Pat
paramP = forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"o")
let paramE :: Q Exp
paramE = forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"o")
let matchClauses :: [Q Match]
matchClauses = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Options -> Cxt -> Con -> Integer -> Q Match
makeMatchClause Options
options Cxt
ts) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. [a] -> [b] -> [(a, b)]
zip [Con]
cs [Integer
0 ..]
let errorClause :: Q Match
errorClause = Options -> Name -> Q Match
makeErrorClause Options
options Name
typeName
let decoded :: Q Exp
decoded = forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE Q Exp
paramE ([Q Match]
matchClauses forall a. Semigroup a => a -> a -> a
<> [Q Match
errorClause])
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Q Pat]
decoderParameters (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE (String -> Name
mkName String
"Decoder")) (forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Q Pat
paramP] Q Exp
decoded))
makeErrorClause :: Options -> Name -> MatchQ
makeErrorClause :: Options -> Name -> Q Match
makeErrorClause Options
options Name
typeName = do
let errorMessage :: Q Exp
errorMessage =
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"mconcat") forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE
[ forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
StringL String
"not a valid "),
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
StringL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Show a, StringConv String b) => a -> b
show forall a b. (a -> b) -> a -> b
$ Options -> Name -> Name
makeName Options
options Name
typeName),
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
StringL String
": "),
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"show") (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"_1")
]
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> m Pat
varP forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"_1") (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Error") Q Exp
errorMessage)) []
makeMatchClause :: Options -> [Type] -> Con -> Integer -> MatchQ
makeMatchClause :: Options -> Cxt -> Con -> Integer -> Q Match
makeMatchClause Options
options Cxt
allTypes Con
c Integer
constructorIndex = do
Cxt
ts <- Con -> Q Cxt
typesOf Con
c
[Int]
constructorTypes <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> Cxt -> Q [(Type, Int)]
indexConstructorTypes Cxt
allTypes Cxt
ts
Name
cName <- Options -> Name -> Name
makeName Options
options forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> Q Name
nameOf Con
c
let paramsP :: [Q Pat]
paramsP = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (String -> Name
mkName String
"ObjectInt") [forall (m :: * -> *). Quote m => Lit -> m Pat
litP (Integer -> Lit
IntegerL Integer
constructorIndex)] forall a. a -> [a] -> [a]
: ((\Int
n -> forall (m :: * -> *). Quote m => Name -> m Pat
varP forall a b. (a -> b) -> a -> b
$ String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"o" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int
n) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
constructorTypes)
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
(forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (String -> Name
mkName String
"ObjectArray") [forall (m :: * -> *). Quote m => m Exp -> m Pat -> m Pat
viewP (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"toList")) (forall (m :: * -> *). Quote m => [m Pat] -> m Pat
listP [Q Pat]
paramsP)])
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Name -> [Int] -> Q Exp
applyDecoder Name
cName [Int]
constructorTypes))
[]
applyDecoder :: Name -> [Int] -> ExpQ
applyDecoder :: Name -> [Int] -> Q Exp
applyDecoder Name
cName [] = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"pure") (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
cName)
applyDecoder Name
cName (Int
n : [Int]
ns) = do
let cons :: Q Exp
cons = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"pure") (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
cName)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Int
i Q Exp
r -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"ap")) Q Exp
r) forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a}. (Quote m, Show a) => a -> m Exp
decodeAt Int
i) (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"ap")) Q Exp
cons) forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a}. (Quote m, Show a) => a -> m Exp
decodeAt Int
n) (forall a. [a] -> [a]
reverse [Int]
ns)
where
decodeAt :: a -> m Exp
decodeAt a
i = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"decode") (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String
"d" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show a
i))) (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"o" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show a
i)