{-# 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 [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
-> ((Name, ConstructorVariant, [Either Type CtrTypePattern])
    -> CtrCase)
-> [CtrCase]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Name, ConstructorVariant, [Either Type CtrTypePattern]) -> CtrCase
makeZipMatchCtr
        CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD
            ([CtrCase]
ctrs [CtrCase] -> (CtrCase -> [TypeQ]) -> [TypeQ]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CtrCase -> [TypeQ]
ccContext [TypeQ] -> ([TypeQ] -> CxtQ) -> CxtQ
forall a b. a -> (a -> b) -> b
& [TypeQ] -> CxtQ
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA CxtQ -> ([Type] -> CxtQ) -> CxtQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Type] -> CxtQ
simplifyContext)
            (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT ''ZipMatch) (Type -> TypeQ
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 Pragma -> (Pragma -> Dec) -> Dec
forall a b. a -> (a -> b) -> b
& Pragma -> Dec
PragmaD Dec -> (Dec -> DecQ) -> DecQ
forall a b. a -> (a -> b) -> b
& Dec -> DecQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            , Name -> [ClauseQ] -> DecQ
funD 'zipMatch (([CtrCase]
ctrs [CtrCase] -> (CtrCase -> ClauseQ) -> [ClauseQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> CtrCase -> ClauseQ
ccClause) [ClauseQ] -> [ClauseQ] -> [ClauseQ]
forall a. Semigroup a => a -> a -> a
<> [ClauseQ
tailClause])
            ]
            DecQ -> (Dec -> [Dec]) -> DecsQ
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[])
    where
        tailClause :: ClauseQ
tailClause = [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [PatQ
wildP, PatQ
wildP] (ExpQ -> BodyQ
normalB [|Nothing|]) []

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

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