{-# OPTIONS_GHC -Wno-type-defaults #-}

module Data.Registry.Aeson.TH.Decoder where

import Control.Monad.Fail
import Data.List (nub)
import Data.Registry.Aeson.TH.ThOptions
import Data.Registry.Aeson.TH.TH
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Protolude as P hiding (Type)

{-
  This module uses TemplateHaskell to extract enough type information to be able to
  build a Decoder based on configuration options
-}

-- | Make an Encoder for a given data type
--   Usage: $(makeDecoder ''MyDataType <: otherEncoders)
makeDecoder :: Name -> ExpQ
makeDecoder :: Name -> ExpQ
makeDecoder = ThOptions -> Name -> ExpQ
makeDecoderWith ThOptions
defaultThOptions

-- | Make an Encoder for a given data type, where all types names are qualified with their module full name
--    -- MyDataType is defined in X.Y.Z
--    import X.Y.Z qualified
--    $(makeDecoderQualified ''MyDataType <: otherEncoders)
makeDecoderQualified :: Name -> ExpQ
makeDecoderQualified :: Name -> ExpQ
makeDecoderQualified = ThOptions -> Name -> ExpQ
makeDecoderWith ((Text -> Text) -> ThOptions
ThOptions Text -> Text
qualified)

-- | Make an Encoder for a given data type, where all types names are qualified with their module name
--    -- MyDataType is defined in X.Y.Z
--    import X.Y.Z qualified as Z
--    $(makeDecoderQualifiedLast ''MyDataType <: otherEncoders)
makeDecoderQualifiedLast :: Name -> ExpQ
makeDecoderQualifiedLast :: Name -> ExpQ
makeDecoderQualifiedLast = ThOptions -> Name -> ExpQ
makeDecoderWith ((Text -> Text) -> ThOptions
ThOptions Text -> Text
qualifyWithLastName)

-- | Make a Decoder for a given data type and pass options to specify how names must be qualified
--   Usage: $(makeDecoderWith options ''MyDataType <: otherDecoders)
makeDecoderWith :: ThOptions -> Name -> ExpQ
makeDecoderWith :: ThOptions -> Name -> ExpQ
makeDecoderWith ThOptions
thOptions 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 Con
constructor [DerivClause]
_deriving) ->
      ThOptions -> Name -> [Con] -> ExpQ
makeConstructorsDecoder ThOptions
thOptions Name
typeName [Con
constructor]
    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"
        [Con]
_ -> ThOptions -> Name -> [Con] -> ExpQ
makeConstructorsDecoder ThOptions
thOptions 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
P.show Info
other)
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"decoders creation failed"

-- | Make a decoder for a given data type by extracting just enough metadata about the data type in order to be able
--   to parse a Value
--
--   For example for the data type:
--
--   data T = T1 {f1::Int, f2::Int} | T2 Int Int
--
--   we add this function to the registry:
--
--   \opts d1 d2 d3 -> Decoder $ \v ->
--     decodeFromDefinitions opts v $ \case
--       ToConstructor "T1" [v1, v2]-> T1 <$> d1 v1 <*> d2 v2 ...
--       ToConstructor "T2" [v1, v2]-> T2 <$> d1 v1 <*> d3 v2 ...
--       other -> Left ("cannot decode " <> valueToText v)
--
--   The \case function is the only one which needs to be generated in order to match the exact shape of the
--   constructors to instantiate
makeConstructorsDecoder :: ThOptions -> Name -> [Con] -> ExpQ
makeConstructorsDecoder :: ThOptions -> Name -> [Con] -> ExpQ
makeConstructorsDecoder ThOptions
thOptions 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 = forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"os")) (forall (m :: * -> *). Quote m => Name -> m Type
conT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Options") forall a. a -> [a] -> [a]
: forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"cd")) (forall (m :: * -> *). Quote m => Name -> m Type
conT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"ConstructorsDecoder") forall a. a -> [a] -> [a]
: ((\(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
P.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 ..])
  -- makeToConstructors os [Constructor "T1" ["f1", "f2"], Constructor "T2" []] v
  let paramP :: Q Pat
paramP = forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"v")
  [Exp]
constructorDefs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Con]
cs forall a b. (a -> b) -> a -> b
$ \Con
c -> do
    Name
cName <- ThOptions -> Name -> Name
makeName ThOptions
thOptions forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> Q Name
nameOf Con
c
    [ExpQ]
fields <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Show a, StringConv String b) => a -> b
P.show forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThOptions -> Name -> Name
makeName ThOptions
thOptions) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> Q [Name]
fieldsOf Con
c
    [ExpQ]
fieldTypes <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Show a, StringConv String b) => a -> b
P.show forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThOptions -> Type -> Name
getSimpleTypeName ThOptions
thOptions) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> Q Cxt
typesOf Con
c
    forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"makeConstructorDef") forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL forall a b. (a -> b) -> a -> b
$ forall a b. (Show a, StringConv String b) => a -> b
P.show Name
cName) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [ExpQ]
fields forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [ExpQ]
fieldTypes
  let matchClauses :: [Q Match]
matchClauses = ThOptions -> Name -> Cxt -> Con -> Q Match
makeMatchClause ThOptions
thOptions Name
typeName Cxt
ts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Con]
cs
  let matchFunction :: ExpQ
matchFunction = forall (m :: * -> *). Quote m => [m Match] -> m Exp
lamCaseE ([Q Match]
matchClauses forall a. Semigroup a => a -> a -> a
<> [Name -> Q Match
makeErrorClause Name
typeName])
  let resolveFunction :: ExpQ
resolveFunction = forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"decodeFromDefinitions") forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"os") forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"cd") forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Exp]
constructorDefs) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"v") forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
matchFunction
  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] ExpQ
resolveFunction))

-- | Decode the nth constructor of a data type
--    ToConstructor "T1" [v1, v2]-> T1 <$> d1 v1 <*> d2 v2 ...
makeMatchClause :: ThOptions -> Name -> [Type] -> Con -> MatchQ
makeMatchClause :: ThOptions -> Name -> Cxt -> Con -> Q Match
makeMatchClause ThOptions
thOptions Name
typeName Cxt
allTypes Con
c = do
  Cxt
ts <- Con -> Q Cxt
typesOf Con
c
  [(Int, Int)]
constructorTypes <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Type
_,Int
n,Int
k) -> (Int
n, Int
k)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> Cxt -> Q [(Type, Int, Int)]
indexConstructorTypes Cxt
allTypes Cxt
ts
  Name
cName <- ThOptions -> Name -> Name
makeName ThOptions
thOptions forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> Q Name
nameOf Con
c
  let fieldsP :: Q Pat
fieldsP = forall (m :: * -> *). Quote m => [m Pat] -> m Pat
listP forall a b. (a -> b) -> a -> b
$ (\(Int
n, Int
_) -> forall (m :: * -> *). Quote m => Name -> m Pat
varP forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String
"v" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
P.show Int
n)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, 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
"ToConstructor") [forall (m :: * -> *). Quote m => Lit -> m Pat
litP (String -> Lit
StringL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Show a, StringConv String b) => a -> b
P.show forall a b. (a -> b) -> a -> b
$ Name
cName), Q Pat
fieldsP])
    (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (ThOptions -> Name -> Name -> [(Int, Int)] -> ExpQ
applyDecoder ThOptions
thOptions Name
typeName Name
cName [(Int, Int)]
constructorTypes))
    []

-- | Return an error the json value cannot be decoded with a constructor name and some values
makeErrorClause :: Name -> MatchQ
makeErrorClause :: Name -> Q Match
makeErrorClause Name
typeName = do
  let errorMessage :: ExpQ
errorMessage =
        (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"<>") forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
StringL (String
"cannot use this constructor to create an instance of type '" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
P.show Name
typeName forall a. Semigroup a => a -> a -> a
<> String
"': ")))
          forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"show") forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE (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
"Left") ExpQ
errorMessage)) []

-- ConstructorName <$> decodeFieldValue d1 o1 <*> decodeFieldValue d2 o2 ...
applyDecoder :: ThOptions -> Name -> Name -> [(Int, Int)] -> ExpQ
applyDecoder :: ThOptions -> Name -> Name -> [(Int, Int)] -> ExpQ
applyDecoder ThOptions
_thOptions Name
_typeName 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 ThOptions
thOptions Name
typeName Name
cName ((Int, Int)
nk : [(Int, Int)]
nks) = do
  let cons :: ExpQ
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, Int)
i ExpQ
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")) ExpQ
r) forall a b. (a -> b) -> a -> b
$ (Int, Int) -> ExpQ
decodeAt (Int, 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")) ExpQ
cons) forall a b. (a -> b) -> a -> b
$ (Int, Int) -> ExpQ
decodeAt (Int, Int)
nk) (forall a. [a] -> [a]
reverse [(Int, Int)]
nks)
  where
    decodeAt :: (Int, Int) -> ExpQ
decodeAt (Int
n, Int
k) =
      forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"decodeFieldValue")
        forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName (String
"d" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
P.show Int
k))
        forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Show a, StringConv String b) => a -> b
P.show forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThOptions -> Name -> Name
makeName ThOptions
thOptions forall a b. (a -> b) -> a -> b
$ Name
typeName)
        forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Show a, StringConv String b) => a -> b
P.show forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThOptions -> Name -> Name
makeName ThOptions
thOptions forall a b. (a -> b) -> a -> b
$ Name
cName)
        forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName (String
"v" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
P.show Int
n))