{-# LANGUAGE TemplateHaskell #-}

-- | Generate 'Syntactic' instances for tuples

module Language.Syntactic.Functional.Tuple.TH
  ( deriveSyntacticForTuples
  ) where



import Language.Haskell.TH

import Data.NestTuple
import Data.NestTuple.TH

import Language.Syntactic ((:<:), Syntactic (..))
import Language.Syntactic.TH



-- Make instances of the form
--
-- > instance
-- >     ( Syntactic a
-- >     , ...
-- >     , Syntactic x
-- >
-- >     , internalPred (Internal a)
-- >     , ...
-- >     , internalPred (Internal x)
-- >
-- >     , Tuple :<: sym
-- >     , Domain a ~ mkDomain sym
-- >
-- >     , Domain a ~ Domain b
-- >     , ...
-- >     , Domain a ~ Domain x
-- >     , extraConstraint
-- >     ) =>
-- >       Syntactic (a,...,x)
-- >   where
-- >     type Domain (a,...,x)   = Domain a
-- >     type Internal (a,...,x) = (Internal a ... Internal x)  -- nested pairs
-- >     desugar = desugar . nestTup  -- use pair instance
-- >     sugar   = unnestTup . sugar  -- use pair instance
--
-- Instances will be generated for width 3 and upwards. The existence of an
-- instance for pairs is assumed.
deriveSyntacticForTuples
    :: (Type -> Cxt)   -- ^ @internalPred@ (see above)
    -> (Type -> Type)  -- ^ @mkDomain@ (see above)
    -> Cxt             -- ^ @extraConstraint@ (see above)
    -> Int             -- ^ Max tuple width
    -> DecsQ
deriveSyntacticForTuples :: (Type -> Cxt) -> (Type -> Type) -> Cxt -> Int -> DecsQ
deriveSyntacticForTuples Type -> Cxt
internalPred Type -> Type
mkDomain Cxt
extraConstraint Int
n = [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> DecsQ) -> [Dec] -> DecsQ
forall a b. (a -> b) -> a -> b
$
    (Int -> Dec) -> [Int] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Dec
deriveSyntacticForTuple [Int
3..Int
n]
  where
    deriveSyntacticForTuple :: Int -> Dec
deriveSyntacticForTuple Int
w = Cxt -> Type -> [Dec] -> Dec
instD
        ( [Cxt] -> Cxt
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Name -> (Name -> Type) -> Cxt -> Type
classPred ''Syntactic Name -> Type
ConT (Cxt -> Type) -> (Type -> Cxt) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Cxt
forall (m :: * -> *) a. Monad m => a -> m a
return) Cxt
varsT
            , (Type -> Cxt) -> Cxt -> Cxt
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Type -> Cxt
internalPred (Cxt -> Cxt) -> Cxt -> Cxt
forall a b. (a -> b) -> a -> b
$ (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type -> Type
AppT (Name -> Type
ConT ''Internal)) Cxt
varsT
            , [Name -> (Name -> Type) -> Cxt -> Type
classPred ''(:<:) Name -> Type
ConT [Name -> Type
ConT (String -> Name
mkName String
"Tuple"), Name -> Type
VarT (String -> Name
mkName String
"sym")]]
            , [Type -> Type -> Type
eqPred Type
domainA (Type -> Type
mkDomain (Name -> Type
VarT (String -> Name
mkName String
"sym")))]
            , [Type -> Type -> Type
eqPred Type
domainA (Type -> Type -> Type
AppT (Name -> Type
ConT ''Domain) Type
b)
                | Type
b <- Cxt -> Cxt
forall a. [a] -> [a]
tail Cxt
varsT
              ]
            , Cxt
extraConstraint
            ]
        )
        (Type -> Type -> Type
AppT (Name -> Type
ConT ''Syntactic) Type
tupT)
        [ Name -> Cxt -> Type -> Dec
tySynInst ''Domain [Type
tupT] Type
domainA
        , Name -> Cxt -> Type -> Dec
tySynInst ''Internal [Type
tupT] Type
tupTI
        , Name -> [Clause] -> Dec
FunD 'desugar
            [ [Pat] -> Body -> [Dec] -> Clause
Clause
                []
                (Exp -> Body
NormalB ((Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
VarE '(.)) ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [String -> Name
mkName String
"desugar", 'nest]))
                []
            ]
        , Name -> [Clause] -> Dec
FunD 'sugar
            [ [Pat] -> Body -> [Dec] -> Clause
Clause
                []
                (Exp -> Body
NormalB ((Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
VarE '(.)) ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE ['unnest, String -> Name
mkName String
"sugar"]))
                []
            ]
        ]
      where
        varsT :: Cxt
varsT   = (Name -> Type) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT ([Name] -> Cxt) -> [Name] -> Cxt
forall a b. (a -> b) -> a -> b
$ Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
w [Name]
varSupply
        tupT :: Type
tupT    = (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
w) Cxt
varsT
        tupTI :: Type
tupTI   = (Type -> Type) -> (Type -> Type -> Type) -> Nest Type -> Type
forall a b. (a -> b) -> (b -> b -> b) -> Nest a -> b
foldNest Type -> Type
forall a. a -> a
id Type -> Type -> Type
mkPairT (Nest Type -> Type) -> Nest Type -> Type
forall a b. (a -> b) -> a -> b
$ Cxt -> Nest Type
forall a. [a] -> Nest a
toNest (Cxt -> Nest Type) -> Cxt -> Nest Type
forall a b. (a -> b) -> a -> b
$ (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type -> Type
AppT (Name -> Type
ConT ''Internal)) Cxt
varsT
        domainA :: Type
domainA = Type -> Type -> Type
AppT (Name -> Type
ConT ''Domain) (Name -> Type
VarT (String -> Name
mkName String
"a"))