{-# LANGUAGE TemplateHaskell #-}

-- | Generate 'ZipMatch' instances via @TemplateHaskell@
module Hyper.TH.ZipMatch
    ( makeZipMatch
    ) where

import Control.Lens (both)
import Hyper.Class.ZipMatch (ZipMatch (..))
import Hyper.TH.Internal.Utils
import Language.Haskell.TH
import Language.Haskell.TH.Datatype (ConstructorVariant)

import Hyper.Internal.Prelude

-- | Generate a 'ZipMatch' instance
makeZipMatch :: Name -> DecsQ
makeZipMatch :: Name -> DecsQ
makeZipMatch Name
typeName =
    do
        TypeInfo
info <- Name -> Q TypeInfo
makeTypeInfo Name
typeName
        -- (dst, var) <- parts info
        let ctrs :: [CtrCase]
ctrs = TypeInfo
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
tiConstructors TypeInfo
info forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Name, ConstructorVariant, [Either Type CtrTypePattern]) -> CtrCase
makeZipMatchCtr
        forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
            ([CtrCase]
ctrs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CtrCase -> [Q Type]
ccContext forall a b. a -> (a -> b) -> b
& forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Cxt -> Q Cxt
simplifyContext)
            (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT ''ZipMatch) (forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo -> Type
tiInstance TypeInfo
info)))
            [ Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP 'zipMatch Inline
Inline RuleMatch
FunLike Phases
AllPhases forall a b. a -> (a -> b) -> b
& Pragma -> Dec
PragmaD forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a. Applicative f => a -> f a
pure
            , forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'zipMatch (([CtrCase]
ctrs forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> CtrCase -> Q Clause
ccClause) forall a. Semigroup a => a -> a -> a
<> [Q Clause
tailClause])
            ]
            forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall a. a -> [a] -> [a]
: [])
    where
        tailClause :: Q Clause
tailClause = forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => m Pat
wildP] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|Nothing|]) []

data CtrCase = CtrCase
    { CtrCase -> Q Clause
ccClause :: Q Clause
    , CtrCase -> [Q Type]
ccContext :: [Q Pred]
    }

makeZipMatchCtr :: (Name, ConstructorVariant, [Either Type CtrTypePattern]) -> CtrCase
makeZipMatchCtr :: (Name, ConstructorVariant, [Either Type CtrTypePattern]) -> CtrCase
makeZipMatchCtr (Name
cName, ConstructorVariant
_, [Either Type CtrTypePattern]
cFields) =
    CtrCase
        { ccClause :: Q Clause
ccClause = forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [((Name, Name) -> Name) -> Q Pat
con forall a b. (a, b) -> a
fst, ((Name, Name) -> Name) -> Q Pat
con forall a b. (a, b) -> b
snd] Q Body
body []
        , ccContext :: [Q Type]
ccContext = [ZipMatchField]
fieldParts forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ZipMatchField -> [Q Type]
zmfContext
        }
    where
        con :: ((Name, Name) -> Name) -> Q Pat
con (Name, Name) -> Name
f = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
cName ([(Name, Name)]
cVars forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (m :: * -> *). Quote m => Name -> m Pat
varP forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Name) -> Name
f)
        cVars :: [(Name, Name)]
cVars =
            [Int
0 :: Int ..]
                forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\[Char]
n -> ([Char] -> Name
mkName (Char
'x' forall a. a -> [a] -> [a]
: [Char]
n), [Char] -> Name
mkName (Char
'y' forall a. a -> [a] -> [a]
: [Char]
n))) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show
                forall a b. a -> (a -> b) -> b
& forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either Type CtrTypePattern]
cFields)
        body :: Q Body
body
            | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Q Exp]
checks = forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
bodyExp
            | Bool
otherwise = forall (m :: * -> *). Quote m => [m (Guard, Exp)] -> m Body
guardedB [(,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => m Exp -> m Guard
normalG (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
mkAnd [Q Exp]
checks) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q Exp
bodyExp]
        checks :: [Q Exp]
checks = [ZipMatchField]
fieldParts forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ZipMatchField -> [Q Exp]
zmfConds
        mkAnd :: m Exp -> m Exp -> m Exp
mkAnd m Exp
x m Exp
y = [|$x && $y|]
        fieldParts :: [ZipMatchField]
fieldParts = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Q Exp, Q Exp) -> Either Type CtrTypePattern -> ZipMatchField
field ([(Name, Name)]
cVars forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall (m :: * -> *). Quote m => Name -> m Exp
varE) [Either Type CtrTypePattern]
cFields
        bodyExp :: Q Exp
bodyExp = Q Exp -> [Q Exp] -> Q Exp
applicativeStyle (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
cName) ([ZipMatchField]
fieldParts forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ZipMatchField -> Q Exp
zmfResult)
        field :: (Q Exp, Q Exp) -> Either Type CtrTypePattern -> ZipMatchField
field (Q Exp
x, Q Exp
y) (Right Node{}) =
            ZipMatchField
                { zmfResult :: Q Exp
zmfResult = [|Just ($x :*: $y)|]
                , zmfConds :: [Q Exp]
zmfConds = []
                , zmfContext :: [Q Type]
zmfContext = []
                }
        field (Q Exp
x, Q Exp
y) (Right (GenEmbed Type
t)) = Type -> Q Exp -> Q Exp -> ZipMatchField
embed Type
t Q Exp
x Q Exp
y
        field (Q Exp
x, Q Exp
y) (Right (FlatEmbed TypeInfo
t)) = Type -> Q Exp -> Q Exp -> ZipMatchField
embed (TypeInfo -> Type
tiInstance TypeInfo
t) Q Exp
x Q Exp
y
        field (Q Exp, Q Exp)
_ (Right InContainer{}) = forall a. HasCallStack => [Char] -> a
error [Char]
"TODO"
        field (Q Exp
x, Q Exp
y) (Left Type
t) =
            ZipMatchField
                { zmfResult :: Q Exp
zmfResult = [|Just $x|]
                , zmfConds :: [Q Exp]
zmfConds = [[|$x == $y|]]
                , zmfContext :: [Q Type]
zmfContext = [[t|Eq $(pure t)|]]
                }
        embed :: Type -> Q Exp -> Q Exp -> ZipMatchField
embed Type
t Q Exp
x Q Exp
y =
            ZipMatchField
                { zmfResult :: Q Exp
zmfResult = [|zipMatch $x $y|]
                , zmfConds :: [Q Exp]
zmfConds = []
                , zmfContext :: [Q Type]
zmfContext = [[t|ZipMatch $(pure t)|]]
                }

data ZipMatchField = ZipMatchField
    { ZipMatchField -> Q Exp
zmfResult :: Q Exp
    , ZipMatchField -> [Q Exp]
zmfConds :: [Q Exp]
    , ZipMatchField -> [Q Type]
zmfContext :: [Q Pred]
    }