{-# LANGUAGE CPP #-}
module Contravariant.Extras.TH where

import Contravariant.Extras.Prelude
import Data.Functor.Contravariant
import Data.Functor.Contravariant.Divisible
import Language.Haskell.TH.Syntax hiding (classP)
import qualified TemplateHaskell.Compat.V0208 as Compat


-- |
-- Generates declarations like the following:
-- 
-- @
-- tuple3 :: Monoid a => Op a b1 -> Op a b2 -> Op a b3 -> Op a ( b1 , b2 , b3 )
-- tuple3 ( Op op1 ) ( Op op2 ) ( Op op3 ) =
--   Op $ \( v1 , v2 , v3 ) -> mconcat [ op1 v1 , op2 v2 , op3 v3 ]
-- @
opContrazipDecs :: String -> Int -> [ Dec ]
opContrazipDecs :: String -> Int -> [Dec]
opContrazipDecs baseName :: String
baseName arity :: Int
arity =
  [ Dec
signature , Dec
value ]
  where
    name :: Name
name =
      String -> Name
mkName (String -> ShowS
showString String
baseName (Int -> String
forall a. Show a => a -> String
show Int
arity))
    signature :: Dec
signature =
      Name -> Type -> Dec
SigD Name
name Type
type_
      where
        type_ :: Type
type_ =
          [TyVarBndr] -> Cxt -> Type -> Type
ForallT [TyVarBndr]
vars Cxt
cxt Type
type_
          where
            vars :: [TyVarBndr]
vars =
              (String -> TyVarBndr) -> [String] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> TyVarBndr
PlainTV (Name -> TyVarBndr) -> (String -> Name) -> String -> TyVarBndr
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Name
mkName) ("a" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
bs)
              where
                bs :: [String]
bs =
                  (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
b (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo 1 Int
arity)
                  where
                    b :: a -> String
b index :: a
index =
                      String -> ShowS
showString "b" (a -> String
forall a. Show a => a -> String
show a
index)
            cxt :: Cxt
cxt =
              [ Type
pred ]
              where
                pred :: Type
pred =
                  Name -> Cxt -> Type
classP ''Monoid [ Type
a ]
                  where
                    a :: Type
a =
                      Name -> Type
VarT (String -> Name
mkName "a") 
            type_ :: Type
type_ =
              (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
appArrowT Type
result Cxt
params
              where
                appArrowT :: Type -> Type -> Type
appArrowT a :: Type
a b :: Type
b =
                  Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
ArrowT Type
a) Type
b
                a :: Type
a =
                  Name -> Type
VarT (String -> Name
mkName "a")
                result :: Type
result =
                  Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''Op) Type
a) Type
tuple
                  where
                    tuple :: Type
tuple =
                      (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Int -> Type
TupleT Int
arity) Cxt
params
                      where
                        params :: Cxt
params =
                          (Int -> Type) -> [Int] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Int -> Type
forall a. Show a => a -> Type
param (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo 1 Int
arity)
                          where
                            param :: a -> Type
param index :: a
index =
                              Name -> Type
VarT (String -> Name
mkName (String -> ShowS
showString "b" (a -> String
forall a. Show a => a -> String
show a
index)))
                params :: Cxt
params =
                  (Int -> Type) -> [Int] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Int -> Type
forall a. Show a => a -> Type
param (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo 1 Int
arity)
                  where
                    param :: a -> Type
param index :: a
index =
                      Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''Op) Type
a) Type
b
                      where
                        b :: Type
b =
                          Name -> Type
VarT (String -> Name
mkName (String -> ShowS
showString "b" (a -> String
forall a. Show a => a -> String
show a
index)))
    value :: Dec
value =
      Name -> [Clause] -> Dec
FunD Name
name [Clause]
clauses
      where
        clauses :: [Clause]
clauses =
          [ Clause
clause ]
          where
            clause :: Clause
clause =
              [Pat] -> Body -> [Dec] -> Clause
Clause [Pat]
pats Body
body []
              where
                pats :: [Pat]
pats =
                  (Int -> Pat) -> [Int] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Pat
forall a. Show a => a -> Pat
pat (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo 1 Int
arity)
                  where
                    pat :: a -> Pat
pat index :: a
index =
                      Name -> [Pat] -> Pat
ConP 'Op [Pat]
pats
                      where
                        pats :: [Pat]
pats =
                          [ Name -> Pat
VarP Name
name ]
                          where
                            name :: Name
name =
                              String -> Name
mkName (String -> ShowS
showString "op" (a -> String
forall a. Show a => a -> String
show a
index))
                body :: Body
body =
                  Exp -> Body
NormalB (Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Op) Exp
lambda)
                  where
                    lambda :: Exp
lambda =
                      [Pat] -> Exp -> Exp
LamE [Pat]
pats Exp
exp
                      where
                        pats :: [Pat]
pats =
                          [ [Pat] -> Pat
TupP [Pat]
pats ]
                          where
                            pats :: [Pat]
pats =
                              (Int -> Pat) -> [Int] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Pat
forall a. Show a => a -> Pat
pat (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo 1 Int
arity)
                              where
                                pat :: a -> Pat
pat index :: a
index =
                                  Name -> Pat
VarP (String -> Name
mkName (String -> ShowS
showString "v" (a -> String
forall a. Show a => a -> String
show a
index)))
                        exp :: Exp
exp =
                          Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'mconcat) ([Exp] -> Exp
ListE [Exp]
applications)
                          where
                            applications :: [Exp]
applications =
                              (Int -> Exp) -> [Int] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Exp
forall a. Show a => a -> Exp
application (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo 1 Int
arity)
                              where
                                application :: a -> Exp
application index :: a
index =
                                  Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
opName) (Name -> Exp
VarE Name
varName)
                                  where
                                    opName :: Name
opName =
                                      String -> Name
mkName (String -> ShowS
showString "op" (a -> String
forall a. Show a => a -> String
show a
index))
                                    varName :: Name
varName =
                                      String -> Name
mkName (String -> ShowS
showString "v" (a -> String
forall a. Show a => a -> String
show a
index))

-- |
-- Generates declarations in the spirit of the following:
-- 
-- @
-- contrazip4 :: Divisible f => f a1 -> f a2 -> f a3 -> f a4 -> f ( a1 , a2 , a3 , a4 )
-- contrazip4 f1 f2 f3 f4 =
--   divide $(TupleTH.splitTupleAt 4 1) f1 $
--   divide $(TupleTH.splitTupleAt 3 1) f2 $
--   divide $(TupleTH.splitTupleAt 2 1) f3 $
--   f4
-- @
divisibleContrazipDecs :: String -> Int -> [Dec]
divisibleContrazipDecs :: String -> Int -> [Dec]
divisibleContrazipDecs baseName :: String
baseName arity :: Int
arity =
  [Dec
signature, Dec
value]
  where
    name :: Name
name =
      String -> Name
mkName (String -> ShowS
showString String
baseName (Int -> String
forall a. Show a => a -> String
show Int
arity))
    signature :: Dec
signature =
      Name -> Type -> Dec
SigD Name
name Type
type_
      where
        type_ :: Type
type_ =
          [TyVarBndr] -> Cxt -> Type -> Type
ForallT [TyVarBndr]
vars Cxt
cxt Type
type_
          where
            fName :: Name
fName =
              String -> Name
mkName "f"
            aNames :: [Name]
aNames =
              (Int -> Name) -> [Int] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Name
forall a. Show a => a -> Name
aName (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo 1 Int
arity)
              where
                aName :: a -> Name
aName index :: a
index =
                  String -> Name
mkName (String -> ShowS
showString "a" (a -> String
forall a. Show a => a -> String
show a
index))
            vars :: [TyVarBndr]
vars =
              (Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
PlainTV (Name
fName Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
aNames)
            cxt :: Cxt
cxt =
              [Type
pred]
              where
                pred :: Type
pred =
                  Name -> Cxt -> Type
classP ''Divisible [Name -> Type
VarT Name
fName]
            type_ :: Type
type_ =
              (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
appArrowT Type
result Cxt
params
              where
                appArrowT :: Type -> Type -> Type
appArrowT a :: Type
a b :: Type
b =
                  Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
ArrowT Type
a) Type
b
                result :: Type
result =
                  Type -> Type -> Type
AppT (Name -> Type
VarT Name
fName) Type
tuple
                  where
                    tuple :: Type
tuple =
                      (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Int -> Type
TupleT Int
arity) ((Name -> Type) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
aNames)
                params :: Cxt
params =
                  (Name -> Type) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
param [Name]
aNames
                  where
                    param :: Name -> Type
param aName :: Name
aName =
                      Type -> Type -> Type
AppT (Name -> Type
VarT Name
fName) (Name -> Type
VarT Name
aName)
    value :: Dec
value =
      Name -> [Clause] -> Dec
FunD Name
name [Clause]
clauses
      where
        clauses :: [Clause]
clauses =
          [Clause
clause]
          where
            clause :: Clause
clause =
              [Pat] -> Body -> [Dec] -> Clause
Clause [Pat]
pats Body
body []
              where
                pats :: [Pat]
pats =
                  (Int -> Pat) -> [Int] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Pat
forall a. Show a => a -> Pat
pat (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo 1 Int
arity)
                  where
                    pat :: a -> Pat
pat index :: a
index =
                      Name -> Pat
VarP Name
name
                      where
                        name :: Name
name =
                          String -> Name
mkName (String -> ShowS
showString "f" (a -> String
forall a. Show a => a -> String
show a
index))
                body :: Body
body =
                  Exp -> Body
NormalB (Int -> Exp
exp Int
arity)
                  where
                    exp :: Int -> Exp
exp index :: Int
index =
                      case Int
index of
                        1 ->
                          Name -> Exp
VarE (String -> Name
mkName (String -> ShowS
showString "f" (Int -> String
forall a. Show a => a -> String
show Int
arity)))
                        _ ->
                          (Exp -> Exp -> Exp) -> [Exp] -> Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Exp -> Exp -> Exp
AppE
                          [
                            Name -> Exp
VarE 'divide
                            ,
                            Int -> Int -> Exp
splitTupleAtE Int
index 1
                            ,
                            Name -> Exp
VarE (String -> Name
mkName (String -> ShowS
showString "f" (Int -> String
forall a. Show a => a -> String
show (Int
arity Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
index Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1))))
                            ,
                            Int -> Exp
exp (Int -> Int
forall a. Enum a => a -> a
pred Int
index)
                          ]

splitTupleAtE :: Int -> Int -> Exp
splitTupleAtE :: Int -> Int -> Exp
splitTupleAtE arity :: Int
arity position :: Int
position =
  let
    nameByIndex :: a -> Name
nameByIndex index :: a
index = OccName -> NameFlavour -> Name
Name (String -> OccName
OccName ('_' Char -> ShowS
forall a. a -> [a] -> [a]
: a -> String
forall a. Show a => a -> String
show a
index)) NameFlavour
NameS
    names :: [Name]
names = Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo 0 (Int -> Int
forall a. Enum a => a -> a
pred Int
arity) [Int] -> ([Int] -> [Name]) -> [Name]
forall a b. a -> (a -> b) -> b
& (Int -> Name) -> [Int] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Name
forall a. Show a => a -> Name
nameByIndex
    pats :: [Pat]
pats = [Name]
names [Name] -> ([Name] -> [Pat]) -> [Pat]
forall a b. a -> (a -> b) -> b
& (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP
    pat :: Pat
pat = [Pat] -> Pat
TupP [Pat]
pats
    exps :: [Exp]
exps = [Name]
names [Name] -> ([Name] -> [Exp]) -> [Exp]
forall a b. a -> (a -> b) -> b
& (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE
    body :: Exp
body = Int -> [Exp] -> ([Exp], [Exp])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
position [Exp]
exps ([Exp], [Exp]) -> (([Exp], [Exp]) -> Exp) -> Exp
forall a b. a -> (a -> b) -> b
& \ (a :: [Exp]
a, b :: [Exp]
b) -> [Exp] -> Exp
Compat.tupE [[Exp] -> Exp
Compat.tupE [Exp]
a, [Exp] -> Exp
Compat.tupE [Exp]
b]
    in [Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
body

classP :: Name -> [Type] -> Pred
#if MIN_VERSION_template_haskell(2,10,0)
classP :: Name -> Cxt -> Type
classP n :: Name
n tl :: Cxt
tl = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
n) Cxt
tl
#else
classP = ClassP
#endif