{-# 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.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 a Decoder for a given data type
--   Usage: $(makeDecoder ''MyDataType <: otherDecoders)
makeDecoder :: Name -> ExpQ
makeDecoder :: Name -> ExpQ
makeDecoder 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 Con
constructor [DerivClause]
_deriving) ->
      Name -> [Con] -> ExpQ
makeConstructorsDecoder Name
typeName [Con
constructor]
    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"
        [Con]
_ -> Name -> [Con] -> ExpQ
makeConstructorsDecoder 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, StringConv String b) => a -> b
P.show Info
other)
      String -> ExpQ
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 :: Name -> [Con] -> ExpQ
makeConstructorsDecoder :: Name -> [Con] -> ExpQ
makeConstructorsDecoder 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 = PatQ -> TypeQ -> PatQ
sigP (Name -> PatQ
varP (String -> Name
mkName String
"os")) (Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Options") PatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
: PatQ -> TypeQ -> PatQ
sigP (Name -> PatQ
varP (String -> Name
mkName String
"cd")) (Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"ConstructorsDecoder") PatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
: ((\(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, StringConv String b) => a -> b
P.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 [Integer
0 ..])
  -- makeToConstructors os [Constructor "T1" ["f1", "f2"], Constructor "T2" []] v
  let paramP :: PatQ
paramP = Name -> PatQ
varP (String -> Name
mkName String
"v")
  [Exp]
constructorDefs <- [Con] -> (Con -> ExpQ) -> Q [Exp]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Con]
cs ((Con -> ExpQ) -> Q [Exp]) -> (Con -> ExpQ) -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ \Con
c -> do
    Name
cName <- Name -> Name
dropQualified (Name -> Name) -> Q Name -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> Q Name
nameOf Con
c
    [ExpQ]
fields <- (Name -> ExpQ) -> [Name] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Lit -> ExpQ
litE (Lit -> ExpQ) -> (Name -> Lit) -> Name -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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, StringConv String b) => a -> b
P.show (Name -> String) -> (Name -> Name) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
dropQualified) ([Name] -> [ExpQ]) -> Q [Name] -> Q [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> Q [Name]
fieldsOf Con
c
    [ExpQ]
fieldTypes <- (Kind -> ExpQ) -> Cxt -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Lit -> ExpQ
litE (Lit -> ExpQ) -> (Kind -> Lit) -> Kind -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL (String -> Lit) -> (Kind -> String) -> Kind -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show (Name -> String) -> (Kind -> Name) -> Kind -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> Name
getSimpleTypeName) (Cxt -> [ExpQ]) -> Q Cxt -> Q [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> Q Cxt
typesOf Con
c
    Name -> ExpQ
varE (String -> Name
mkName String
"makeConstructorDef") ExpQ -> ExpQ -> ExpQ
`appE` (Lit -> ExpQ
litE (Lit -> ExpQ) -> (String -> Lit) -> String -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show Name
cName) ExpQ -> ExpQ -> ExpQ
`appE` [ExpQ] -> ExpQ
listE [ExpQ]
fields ExpQ -> ExpQ -> ExpQ
`appE` [ExpQ] -> ExpQ
listE [ExpQ]
fieldTypes
  let matchClauses :: [MatchQ]
matchClauses = Name -> Cxt -> Con -> MatchQ
makeMatchClause Name
typeName Cxt
ts (Con -> MatchQ) -> [Con] -> [MatchQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Con]
cs
  let matchFunction :: ExpQ
matchFunction = [MatchQ] -> ExpQ
lamCaseE ([MatchQ]
matchClauses [MatchQ] -> [MatchQ] -> [MatchQ]
forall a. Semigroup a => a -> a -> a
<> [Name -> MatchQ
makeErrorClause Name
typeName])
  let resolveFunction :: ExpQ
resolveFunction = Name -> ExpQ
varE (String -> Name
mkName String
"decodeFromDefinitions") ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE (String -> Name
mkName String
"os") ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE (String -> Name
mkName String
"cd") ExpQ -> ExpQ -> ExpQ
`appE` [ExpQ] -> ExpQ
listE (Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> ExpQ) -> [Exp] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Exp]
constructorDefs) ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE (String -> Name
mkName String
"v") ExpQ -> ExpQ -> ExpQ
`appE` ExpQ
matchFunction
  [PatQ] -> ExpQ -> ExpQ
lamE [PatQ]
decoderParameters (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE (String -> Name
mkName String
"Decoder")) ([PatQ] -> ExpQ -> ExpQ
lamE [PatQ
paramP] ExpQ
resolveFunction))

-- | Decode the nth constructor of a data type
--    ToConstructor "T1" [v1, v2]-> T1 <$> d1 v1 <*> d2 v2 ...
makeMatchClause :: Name -> [Type] -> Con -> MatchQ
makeMatchClause :: Name -> Cxt -> Con -> MatchQ
makeMatchClause Name
typeName Cxt
allTypes Con
c = 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 <- Name -> Name
dropQualified (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 fieldsP :: PatQ
fieldsP = [PatQ] -> PatQ
listP ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (\Int
i -> Name -> PatQ
varP (Name -> PatQ) -> Name -> PatQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String
"v" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show Int
i)) (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
"ToConstructor") [Lit -> PatQ
litP (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, StringConv String b) => a -> b
P.show (Name -> Lit) -> Name -> Lit
forall a b. (a -> b) -> a -> b
$ Name
cName), PatQ
fieldsP])
    (ExpQ -> BodyQ
normalB (Name -> Name -> [Int] -> ExpQ
applyDecoder Name
typeName Name
cName [Int]
constructorTypes))
    []

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

-- ConstructorName <$> decodeFieldValue d1 o1 <*> decodeFieldValue d2 o2 ...
applyDecoder :: Name -> Name -> [Int] -> ExpQ
applyDecoder :: Name -> Name -> [Int] -> ExpQ
applyDecoder Name
_typeName 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
typeName 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
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
decodeAt Int
n) ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
ns)
  where
    decodeAt :: Int -> ExpQ
decodeAt Int
i =
      Name -> ExpQ
varE (String -> Name
mkName String
"decodeFieldValue") ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE (String -> Name
mkName (String
"d" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show Int
i))
        ExpQ -> ExpQ -> ExpQ
`appE` (Lit -> ExpQ
litE (Lit -> ExpQ) -> (Name -> Lit) -> Name -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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, StringConv String b) => a -> b
P.show (Name -> String) -> (Name -> Name) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
dropQualified (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ Name
typeName)
        ExpQ -> ExpQ -> ExpQ
`appE` (Lit -> ExpQ
litE (Lit -> ExpQ) -> (Name -> Lit) -> Name -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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, StringConv String b) => a -> b
P.show (Name -> String) -> (Name -> Name) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
dropQualified (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ Name
cName)
        ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE (String -> Name
mkName (String
"v" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show Int
i))