{-# 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.Internal.Types
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 {Decoder a -> Object -> Result a
decode :: Object -> MP.Result a}

instance Functor Decoder where
  fmap :: (a -> b) -> Decoder a -> Decoder b
fmap a -> b
f (Decoder Object -> Result a
d) = (Object -> Result b) -> Decoder b
forall a. (Object -> Result a) -> Decoder a
Decoder ((a -> b) -> Result a -> Result b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Result a -> Result b)
-> (Object -> Result a) -> Object -> Result b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Result a
d)

instance Applicative Decoder where
  pure :: a -> Decoder a
pure a
a = (Object -> Result a) -> Decoder a
forall a. (Object -> Result a) -> Decoder a
Decoder (Result a -> Object -> Result a
forall a b. a -> b -> a
const (a -> Result a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a))
  Decoder (a -> b)
f <*> :: Decoder (a -> b) -> Decoder a -> Decoder b
<*> Decoder a
a = ((a -> b) -> a -> b) -> (a -> b, a) -> b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
($) ((a -> b, a) -> b) -> Decoder (a -> b, a) -> Decoder b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder (a -> b) -> Decoder a -> Decoder (a -> b, a)
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 :: Decoder a -> Decoder b -> Decoder (a, b)
decoderAp (Decoder Object -> Result a
da) (Decoder Object -> Result b
db) = (Object -> Result (a, b)) -> Decoder (a, b)
forall a. (Object -> Result a) -> Decoder a
Decoder ((Object -> Result (a, b)) -> Decoder (a, b))
-> (Object -> Result (a, b)) -> Decoder (a, b)
forall a b. (a -> b) -> a -> b
$ \case
  o :: Object
o@(ObjectArray Vector Object
ls) ->
    case [Object] -> [Object]
forall a. [a] -> [a]
reverse (Vector Object -> [Object]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Vector Object
ls) of
      Object
b : [Object]
as -> (,) (a -> b -> (a, b)) -> Result a -> Result (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Result a
da (Vector Object -> Object
ObjectArray (Vector Object -> Object) -> Vector Object -> Object
forall a b. (a -> b) -> a -> b
$ [Object] -> Vector Object
forall a. [a] -> Vector a
Vector.fromList ([Object] -> Vector Object) -> [Object] -> Vector Object
forall a b. (a -> b) -> a -> b
$ [Object] -> [Object]
forall a. [a] -> [a]
reverse [Object]
as) Result (b -> (a, b)) -> Result b -> Result (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Result b
db Object
b
      [] -> (,) (a -> b -> (a, b)) -> Result a -> Result (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Result a
da Object
o Result (b -> (a, b)) -> Result b -> Result (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Result b
db Object
o
  Object
o -> (,) (a -> b -> (a, b)) -> Result a -> Result (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Result a
da Object
o Result (b -> (a, b)) -> Result b -> Result (a, b)
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 :: Decoder a -> ByteString -> Either Text a
decodeByteString Decoder a
d ByteString
bs =
  case ByteString -> Either String Object
forall a. MessagePack a => ByteString -> Either String a
unpack' ByteString
bs of
    Left String
e -> Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text
"cannot unpack the bytestring as an Object: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show String
e Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". The bytestring is: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show ByteString
bs
    Right Object
o ->
      case Decoder a -> Object -> Either Text a
forall a. Decoder a -> Object -> Either Text a
decodeObject Decoder a
d Object
o of
        Right a
a -> a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
        Left Text
e -> Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text
"Error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a b. ConvertText a b => a -> b
toS Text
e Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Cannot decode " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertText a b => a -> b
toS (Typeable a => String
forall a. Typeable a => String
showType @a) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from the Object: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Object -> Text
forall a b. (Show a, ConvertText 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 :: 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 -> a -> Either Text a
forall a b. b -> Either a b
Right a
a
    Error String
e -> Text -> Either Text a
forall a b. a -> Either a b
Left (String -> Text
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 :: Typed (Decoder a)
messagePackDecoder = Decoder a -> Typed (Decoder a)
forall a. Typeable a => a -> Typed a
fun (MessagePack a => Decoder a
forall a. MessagePack a => Decoder a
messagePackDecoderOf @a)

messagePackDecoderOf :: MessagePack a => Decoder a
messagePackDecoderOf :: Decoder a
messagePackDecoderOf = (Object -> Result a) -> Decoder a
forall a. (Object -> Result a) -> Decoder a
Decoder Object -> Result a
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 :: Typed (Decoder String -> Decoder a)
readDecoder = (Decoder String -> Decoder a)
-> Typed (Decoder String -> Decoder a)
forall a. Typeable a => a -> Typed a
fun Decoder String -> Decoder a
forall a. Read a => Decoder String -> Decoder a
readDecoderOf

readDecoderOf :: forall a. (Read a) => Decoder String -> Decoder a
readDecoderOf :: Decoder String -> Decoder a
readDecoderOf Decoder String
ds = (Object -> Result a) -> Decoder a
forall a. (Object -> Result a) -> Decoder a
Decoder ((Object -> Result a) -> Decoder a)
-> (Object -> Result a) -> Decoder a
forall a b. (a -> b) -> a -> b
$ Decoder String -> Object -> Result String
forall a. Decoder a -> Object -> Result a
decode Decoder String
ds (Object -> Result String)
-> (String -> Result a) -> Object -> Result a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> ((String -> Result a)
-> (a -> Result a) -> Either String a -> Result a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Result a
forall a. String -> Result a
Error a -> Result a
forall a. a -> Result a
Success (Either String a -> Result a)
-> (String -> Either String a) -> String -> Result a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String a
forall a. Read a => String -> Either String 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 :: Typed (Decoder a -> Decoder (Maybe a))
decodeMaybeOf = (Decoder a -> Decoder (Maybe a))
-> Typed (Decoder a -> Decoder (Maybe a))
forall a. Typeable a => a -> Typed a
fun (Decoder a -> Decoder (Maybe a)
forall a. Decoder a -> Decoder (Maybe a)
maybeOfDecoder @a)

maybeOfDecoder :: forall a. Decoder a -> Decoder (Maybe a)
maybeOfDecoder :: Decoder a -> Decoder (Maybe a)
maybeOfDecoder (Decoder Object -> Result a
d) = (Object -> Result (Maybe a)) -> Decoder (Maybe a)
forall a. (Object -> Result a) -> Decoder a
Decoder ((Object -> Result (Maybe a)) -> Decoder (Maybe a))
-> (Object -> Result (Maybe a)) -> Decoder (Maybe a)
forall a b. (a -> b) -> a -> b
$ \case
  Object
ObjectNil -> Maybe a -> Result (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
  Object
just -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Result a -> Result (Maybe a)
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 :: Typed (Decoder a -> Decoder b -> Decoder (a, b))
decodePairOf = (Decoder a -> Decoder b -> Decoder (a, b))
-> Typed (Decoder a -> Decoder b -> Decoder (a, b))
forall a. Typeable a => a -> Typed a
fun ((Typeable a, Typeable b) =>
Decoder a -> Decoder b -> Decoder (a, b)
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 :: Decoder a -> Decoder b -> Decoder (a, b)
pairOfDecoder (Decoder Object -> Result a
a) (Decoder Object -> Result b
b) = (Object -> Result (a, b)) -> Decoder (a, b)
forall a. (Object -> Result a) -> Decoder a
Decoder ((Object -> Result (a, b)) -> Decoder (a, b))
-> (Object -> Result (a, b)) -> Decoder (a, b)
forall a b. (a -> b) -> a -> b
$ \case
  ObjectArray [Item (Vector Object)
oa, Item (Vector Object)
ob] -> (,) (a -> b -> (a, b)) -> Result a -> Result (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Result a
a Item (Vector Object)
Object
oa Result (b -> (a, b)) -> Result b -> Result (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Result b
b Item (Vector Object)
Object
ob
  Object
other -> String -> Result (a, b)
forall a. String -> Result a
Error (String -> Result (a, b)) -> String -> Result (a, b)
forall a b. (a -> b) -> a -> b
$ String
"not a pair of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Typeable a => String
forall a. Typeable a => String
showType @a String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"," String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Typeable b => String
forall a. Typeable a => String
showType @b String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Object -> String
forall a b. (Show a, ConvertText 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 :: Typed (Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c))
decodeTripleOf = (Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c))
-> Typed (Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c))
forall a. Typeable a => a -> Typed a
fun ((Typeable a, Typeable b, Typeable c) =>
Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c)
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 :: 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) = (Object -> Result (a, b, c)) -> Decoder (a, b, c)
forall a. (Object -> Result a) -> Decoder a
Decoder ((Object -> Result (a, b, c)) -> Decoder (a, b, c))
-> (Object -> Result (a, b, c)) -> Decoder (a, b, c)
forall a b. (a -> b) -> a -> b
$ \case
  ObjectArray [Item (Vector Object)
oa, Item (Vector Object)
ob, Item (Vector Object)
oc] -> (,,) (a -> b -> c -> (a, b, c))
-> Result a -> Result (b -> c -> (a, b, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Result a
a Item (Vector Object)
Object
oa Result (b -> c -> (a, b, c)) -> Result b -> Result (c -> (a, b, c))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Result b
b Item (Vector Object)
Object
ob Result (c -> (a, b, c)) -> Result c -> Result (a, b, c)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Result c
c Item (Vector Object)
Object
oc
  Object
other -> String -> Result (a, b, c)
forall a. String -> Result a
Error (String -> Result (a, b, c)) -> String -> Result (a, b, c)
forall a b. (a -> b) -> a -> b
$ String
"not a triple of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Typeable a => String
forall a. Typeable a => String
showType @a String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"," String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Typeable b => String
forall a. Typeable a => String
showType @b String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"," String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Typeable c => String
forall a. Typeable a => String
showType @c String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Object -> String
forall a b. (Show a, ConvertText 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 :: Typed (Decoder a -> Decoder [a])
decodeListOf = (Decoder a -> Decoder [a]) -> Typed (Decoder a -> Decoder [a])
forall a. Typeable a => a -> Typed a
fun (Typeable a => Decoder a -> Decoder [a]
forall a. Typeable a => Decoder a -> Decoder [a]
listOfDecoder @a)

listOfDecoder :: forall a. (Typeable a) => Decoder a -> Decoder [a]
listOfDecoder :: Decoder a -> Decoder [a]
listOfDecoder (Decoder Object -> Result a
a) = (Object -> Result [a]) -> Decoder [a]
forall a. (Object -> Result a) -> Decoder a
Decoder ((Object -> Result [a]) -> Decoder [a])
-> (Object -> Result [a]) -> Decoder [a]
forall a b. (a -> b) -> a -> b
$ \case
  ObjectArray Vector Object
os -> [Object] -> (Object -> Result a) -> Result [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Vector Object -> [Object]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Vector Object
os) Object -> Result a
a
  Object
other -> String -> Result [a]
forall a. String -> Result a
Error (String -> Result [a]) -> String -> Result [a]
forall a b. (a -> b) -> a -> b
$ String
"not a list of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Typeable a => String
forall a. Typeable a => String
showType @a String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Object -> String
forall a b. (Show a, ConvertText 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 :: Typed (Decoder a -> Decoder (NonEmpty a))
decodeNonEmptyOf = (Decoder a -> Decoder (NonEmpty a))
-> Typed (Decoder a -> Decoder (NonEmpty a))
forall a. Typeable a => a -> Typed a
fun (Typeable a => Decoder a -> Decoder (NonEmpty a)
forall a. Typeable a => Decoder a -> Decoder (NonEmpty a)
nonEmptyOfDecoder @a)

nonEmptyOfDecoder :: forall a. (Typeable a) => Decoder a -> Decoder (NonEmpty a)
nonEmptyOfDecoder :: Decoder a -> Decoder (NonEmpty a)
nonEmptyOfDecoder (Decoder Object -> Result a
a) = (Object -> Result (NonEmpty a)) -> Decoder (NonEmpty a)
forall a. (Object -> Result a) -> Decoder a
Decoder ((Object -> Result (NonEmpty a)) -> Decoder (NonEmpty a))
-> (Object -> Result (NonEmpty a)) -> Decoder (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ \case
  ObjectArray Vector Object
values ->
    case Vector Object -> [Object]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Vector Object
values of
      [] -> String -> Result (NonEmpty a)
forall a. String -> Result a
Error (String -> Result (NonEmpty a)) -> String -> Result (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ String
"expected a NonEmpty of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Typeable a => String
forall a. Typeable a => String
showType @a
      Object
o : [Object]
os -> a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
(:|) (a -> [a] -> NonEmpty a) -> Result a -> Result ([a] -> NonEmpty a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Result a
a Object
o Result ([a] -> NonEmpty a) -> Result [a] -> Result (NonEmpty a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Object] -> (Object -> Result a) -> Result [a]
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 -> String -> Result (NonEmpty a)
forall a. String -> Result a
Error (String -> Result (NonEmpty a)) -> String -> Result (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ String
"not a list of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Typeable a => String
forall a. Typeable a => String
showType @a String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Object -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Object
other

showType :: forall a. (Typeable a) => String
showType :: String
showType = TypeRep -> String
forall a b. (Show a, ConvertText String b) => a -> b
show (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
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 -> ExpQ
makeDecoder = Options -> Name -> ExpQ
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 -> ExpQ
makeDecoderQualified = Options -> Name -> ExpQ
makeDecoderWith ((Text -> Text) -> Options
Options Text -> Text
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 -> ExpQ
makeDecoderQualifiedLast = Options -> Name -> ExpQ
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 -> ExpQ
makeDecoderWith Options
options Name
typeName = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"fun") (ExpQ -> ExpQ) -> ExpQ -> ExpQ
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 Kind
_kind (RecC Name
constructor [(_, _, other)]) [DerivClause]
_deriving) -> do
      -- \(a::Decoder OldType) -> fmap NewType d
      let cName :: Name
cName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a b. (Show a, ConvertText String b) => a -> b
show (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ Options -> Name -> Name
makeName Options
options Name
constructor
      [PatQ] -> ExpQ -> ExpQ
lamE [PatQ -> TypeQ -> PatQ
sigP (Name -> PatQ
varP (Name -> PatQ) -> Name -> PatQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"d") (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Decoder") (Kind -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
other))] (ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"fmap") (Name -> ExpQ
conE Name
cName)) (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"d"))
    TyConI (NewtypeD Cxt
_context Name
_name [TyVarBndr]
_typeVars Maybe Kind
_kind (NormalC Name
constructor [(_, other)]) [DerivClause]
_deriving) -> do
      -- \(a::Decoder OldType) -> fmap NewType d
      let cName :: Name
cName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a b. (Show a, ConvertText String b) => a -> b
show (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ Options -> Name -> Name
makeName Options
options Name
constructor
      [PatQ] -> ExpQ -> ExpQ
lamE [PatQ -> TypeQ -> PatQ
sigP (Name -> PatQ
varP (Name -> PatQ) -> Name -> PatQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"d") (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Decoder") (Kind -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
other))] (ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"fmap") (Name -> ExpQ
conE Name
cName)) (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"d"))
    TyConI (DataD Cxt
_context Name
_name [TyVarBndr]
_typeVars Maybe Kind
_kind [Con]
constructors [DerivClause]
_deriving) -> do
      case [Con]
constructors of
        [] -> do
          Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True String
"can not make an Decoder for an empty data type"
          String -> ExpQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"decoders creation failed"
        [Item [Con]
c] -> Options -> Name -> Con -> ExpQ
makeConstructorDecoder Options
options Name
typeName Item [Con]
Con
c
        [Con]
_ -> Options -> Name -> [Con] -> ExpQ
makeConstructorsDecoder Options
options Name
typeName [Con]
constructors
    Info
other -> do
      Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"can only create decoders for an ADT, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Info -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Info
other)
      String -> ExpQ
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 -> ExpQ
makeConstructorDecoder Options
options Name
typeName Con
c = do
  Cxt
ts <- Con -> Q Cxt
typesOf Con
c
  Name
cName <- Options -> Name -> Name
makeName Options
options (Name -> Name) -> Q Name -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> Q Name
nameOf Con
c
  let decoderParameters :: [PatQ]
decoderParameters = (\(Kind
t, Integer
n) -> PatQ -> TypeQ -> PatQ
sigP (Name -> PatQ
varP (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"d" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Integer
n)) (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Decoder") (Kind -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t))) ((Kind, Integer) -> PatQ) -> [(Kind, Integer)] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> [Integer] -> [(Kind, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip Cxt
ts [Item [Integer]
0 ..]
  let paramP :: PatQ
paramP = Name -> PatQ
varP (String -> Name
mkName String
"o")
  let paramE :: ExpQ
paramE = Name -> ExpQ
varE (String -> Name
mkName String
"o")
  let paramsP :: [PatQ]
paramsP = (\Int
n -> Name -> PatQ
varP (Name -> PatQ) -> Name -> PatQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"o" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Int
n) (Int -> PatQ) -> [Int] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Item [Int]
0 .. Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
ts Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
  let matchClause :: MatchQ
matchClause =
        PatQ -> BodyQ -> [DecQ] -> MatchQ
match
          (Name -> [PatQ] -> PatQ
conP (String -> Name
mkName String
"ObjectArray") [ExpQ -> PatQ -> PatQ
viewP (Name -> ExpQ
varE (String -> Name
mkName String
"toList")) ([PatQ] -> PatQ
listP [PatQ]
paramsP)])
          (ExpQ -> BodyQ
normalB (Name -> [Int] -> ExpQ
applyDecoder Name
cName [Item [Int]
0 .. Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
ts Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]))
          []

  let decoded :: ExpQ
decoded = ExpQ -> [MatchQ] -> ExpQ
caseE ExpQ
paramE [MatchQ
Item [MatchQ]
matchClause, Options -> Name -> MatchQ
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)
  [PatQ] -> ExpQ -> ExpQ
lamE [PatQ]
decoderParameters (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE (String -> Name
mkName String
"Decoder")) ([PatQ] -> ExpQ -> ExpQ
lamE [PatQ
Item [PatQ]
paramP] ExpQ
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] -> ExpQ
makeConstructorsDecoder Options
options Name
typeName [Con]
cs = do
  Cxt
ts <- Cxt -> Cxt
forall a. Eq a => [a] -> [a]
nub (Cxt -> Cxt) -> ([Cxt] -> Cxt) -> [Cxt] -> Cxt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Cxt] -> Cxt
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([Cxt] -> Cxt) -> Q [Cxt] -> Q Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Con] -> (Con -> Q Cxt) -> Q [Cxt]
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 :: [PatQ]
decoderParameters = (\(Kind
t, Integer
n) -> PatQ -> TypeQ -> PatQ
sigP (Name -> PatQ
varP (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"d" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Integer
n)) (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Decoder") (Kind -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t))) ((Kind, Integer) -> PatQ) -> [(Kind, Integer)] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> [Integer] -> [(Kind, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip Cxt
ts [Item [Integer]
0 ..]
  let paramP :: PatQ
paramP = Name -> PatQ
varP (String -> Name
mkName String
"o")
  let paramE :: ExpQ
paramE = Name -> ExpQ
varE (String -> Name
mkName String
"o")
  let matchClauses :: [MatchQ]
matchClauses = (Con -> Integer -> MatchQ) -> (Con, Integer) -> MatchQ
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Options -> Cxt -> Con -> Integer -> MatchQ
makeMatchClause Options
options Cxt
ts) ((Con, Integer) -> MatchQ) -> [(Con, Integer)] -> [MatchQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Con] -> [Integer] -> [(Con, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Con]
cs [Item [Integer]
0 ..]
  let errorClause :: MatchQ
errorClause = Options -> Name -> MatchQ
makeErrorClause Options
options Name
typeName
  let decoded :: ExpQ
decoded = ExpQ -> [MatchQ] -> ExpQ
caseE ExpQ
paramE ([MatchQ]
matchClauses [MatchQ] -> [MatchQ] -> [MatchQ]
forall a. Semigroup a => a -> a -> a
<> [MatchQ
Item [MatchQ]
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)
  [PatQ] -> ExpQ -> ExpQ
lamE [PatQ]
decoderParameters (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE (String -> Name
mkName String
"Decoder")) ([PatQ] -> ExpQ -> ExpQ
lamE [PatQ
Item [PatQ]
paramP] ExpQ
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 -> MatchQ
makeErrorClause Options
options Name
typeName = do
  let errorMessage :: ExpQ
errorMessage =
        ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"mconcat") (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$
          [ExpQ] -> ExpQ
listE
            [ Lit -> ExpQ
litE (String -> Lit
StringL String
"not a valid "),
              Lit -> ExpQ
litE (String -> Lit
StringL (String -> Lit) -> (Name -> String) -> Name -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a b. (Show a, ConvertText String b) => a -> b
show (Name -> Lit) -> Name -> Lit
forall a b. (a -> b) -> a -> b
$ Options -> Name -> Name
makeName Options
options Name
typeName),
              Lit -> ExpQ
litE (String -> Lit
StringL String
": "),
              ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"show") (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"_1")
            ]
  PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Name -> PatQ
varP (Name -> PatQ) -> Name -> PatQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"_1") (ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Error") ExpQ
errorMessage)) []

-- | Decode the nth constructor of a data type
makeMatchClause :: Options -> [Type] -> Con -> Integer -> MatchQ
makeMatchClause :: Options -> Cxt -> Con -> Integer -> MatchQ
makeMatchClause Options
options Cxt
allTypes Con
c Integer
constructorIndex = do
  Cxt
ts <- Con -> Q Cxt
typesOf Con
c
  [Int]
constructorTypes <- ((Kind, Int) -> Int) -> [(Kind, Int)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Kind, Int) -> Int
forall a b. (a, b) -> b
snd ([(Kind, Int)] -> [Int]) -> Q [(Kind, Int)] -> Q [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> Cxt -> Q [(Kind, Int)]
indexConstructorTypes Cxt
allTypes Cxt
ts
  Name
cName <- Options -> Name -> Name
makeName Options
options (Name -> Name) -> Q Name -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> Q Name
nameOf Con
c
  let paramsP :: [PatQ]
paramsP = Name -> [PatQ] -> PatQ
conP (String -> Name
mkName String
"ObjectInt") [Lit -> PatQ
litP (Integer -> Lit
IntegerL Integer
constructorIndex)] PatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
: ((\Int
n -> Name -> PatQ
varP (Name -> PatQ) -> Name -> PatQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"o" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Int
n) (Int -> PatQ) -> [Int] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
constructorTypes)
  PatQ -> BodyQ -> [DecQ] -> MatchQ
match
    (Name -> [PatQ] -> PatQ
conP (String -> Name
mkName String
"ObjectArray") [ExpQ -> PatQ -> PatQ
viewP (Name -> ExpQ
varE (String -> Name
mkName String
"toList")) ([PatQ] -> PatQ
listP [PatQ]
paramsP)])
    (ExpQ -> BodyQ
normalB (Name -> [Int] -> ExpQ
applyDecoder Name
cName [Int]
constructorTypes))
    []

-- ConstructorName <$> decode d1 o1 <*> decode d2 o2 ...
applyDecoder :: Name -> [Int] -> ExpQ
applyDecoder :: Name -> [Int] -> ExpQ
applyDecoder Name
cName [] = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"pure") (Name -> ExpQ
conE Name
cName)
applyDecoder Name
cName (Int
n : [Int]
ns) = do
  let cons :: ExpQ
cons = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"pure") (Name -> ExpQ
conE Name
cName)
  (Int -> ExpQ -> ExpQ) -> ExpQ -> [Int] -> ExpQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Int
i ExpQ
r -> ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (String -> Name
mkName String
"ap")) ExpQ
r) (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ Int -> ExpQ
forall a. Show a => a -> ExpQ
decodeAt Int
i) (ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (String -> Name
mkName String
"ap")) ExpQ
cons) (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ Int -> ExpQ
forall a. Show a => a -> ExpQ
decodeAt Int
n) ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
ns)
  where
    decodeAt :: a -> ExpQ
decodeAt a
i = ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"decode") (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String
"d" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a b. (Show a, ConvertText String b) => a -> b
show a
i))) (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"o" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a b. (Show a, ConvertText String b) => a -> b
show a
i)