{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -Wno-type-defaults #-}
{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}

{-
  A Decoder is used to decode a MessagePack Object into a specific data type
  This module provides several functions to create decoders and assemble them into a registry of encoders.
-}
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)

-- * DECODER DATA TYPE

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

-- * DECODING

-- | Use a Decoder to decode a ByteString into the desired type
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

-- | Use a Decoder to decode an Object into the desired type
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)

-- * CREATING DECODERS

-- | Add a Decoder a to a registry of decoders when a MessagePack a instance exists
--   usage: decoders = messagePackDecoder @a <: otherDecoders
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

-- | Create a Decoder from a Read instance
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)

-- * COMBINATORS

-- | Add a Maybe (Decoder a) to a registry of decoders
--   usage: decoders = decodeMaybeOf @a <: otherDecoders
--   the list of otherDecoders must contain a Decoder a
--   otherwise there will be a compilation error
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

-- | Add a Maybe (a, b) to a registry of decoders
--   usage: decoders = decodePairOf @a @b <: otherDecoders
--   the list of otherDecoders must contain a Decoder a and a Decoder b
--   otherwise there will be a compilation error
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

-- | Add a Maybe (a, b, c) to a registry of decoders
--   usage: decoders = decodeTripleOf @a @b @c <: otherDecoders
--   the list of otherDecoders must contain a Decoder a, a Decoder b and a Decoder c
--   otherwise there will be a compilation error
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

-- | Add a Decoder [a] to a registry of decoders
--   usage: decoders = decodeListOf @a <: otherDecoders
--   the list of otherDecoders must contain a Decoder a
--   otherwise there will be a compilation error
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

-- | Add a Decoder (NonEmpty a) to a registry of decoders
--   usage: decoders = decodeNonEmptyOf @a <: otherDecoders
--   the list of otherDecoders must contain a Decoder a
--   otherwise there will be a compilation error
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))

-- * TEMPLATE HASKELL

-- | Make a Decoder for a given data type
--   Usage: $(makeDecoder ''MyDataType <: otherDecoders)
makeDecoder :: Name -> ExpQ
makeDecoder :: Name -> Q Exp
makeDecoder = Options -> Name -> Q Exp
makeDecoderWith Options
defaultOptions

-- | Make a Decoder for a given data type, where all constructors and decoded types are qualified
--   Usage: $(makeDecoderQualified ''MyDataType <: otherDecoders)
makeDecoderQualified :: Name -> ExpQ
makeDecoderQualified :: Name -> Q Exp
makeDecoderQualified = Options -> Name -> Q Exp
makeDecoderWith ((Text -> Text) -> Options
Options forall a. a -> a
identity)

-- | Make a Decoder for a given data type, where all constructors and decoded types are qualified
--   Usage: $(makeDecoderQualifiedLast ''MyDataType <: otherDecoders)
makeDecoderQualifiedLast :: Name -> ExpQ
makeDecoderQualifiedLast :: Name -> Q Exp
makeDecoderQualifiedLast = Options -> Name -> Q Exp
makeDecoderWith ((Text -> Text) -> Options
Options Text -> Text
qualifyWithLastName)

-- | Make a Decoder with a given set of options
--   Usage: $(makeDecoderWith (Options qualify) ''MyDataType <: otherDecoders)
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
      -- \(a::Decoder OldType) -> fmap NewType d
      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
      -- \(a::Decoder OldType) -> fmap NewType d
      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"

-- | Make a Decoder for a single Constructor, where each field of the constructor is encoded as an element of an ObjectArray
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]

  -- (\(d1::Decoder Type1) (d2::Decoder Type2) ... -> Decoder (\case
  --     ObjectArray (toList -> [o1, o2, ...]) -> Constructor <$> decode d1 o1 <*> decode d2 o2 ...))
  --     other -> Error ("not a valid " <> constructorType <> ": " <> show other)
  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))

-- | Make a Decoder for a each Constructor of a data type:
--     - each constructor is specified by an ObjectArray [ObjectInt n, o1, o2, ...]
--     - n specifies the number of the constructor
--     - each object in the array represents a constructor field
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])

  -- (\(d1::Decoder Type1) (d2::Decoder Type2) ... -> Decoder (\case
  --     ObjectArray (toList -> [ObjectInt n, o1, o2, ...]) -> Constructor <$> decode d1 o1 <*> decode d2 o2 ...))
  --     other -> Error ("not a valid " <> constructorType <> ": " <> show other)
  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))

-- | Return an error if an object is not an ObjectArray as expected
--   other -> Error (mconcat ["not a valid ", show typeName, ": ", show other])
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)) []

-- | Decode the nth constructor of a data type
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))
    []

-- ConstructorName <$> decode d1 o1 <*> decode d2 o2 ...
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)