{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

-- |
-- Module : Control.Env.Hierarchical.TH
-- Description:
-- License: BSD-3
-- Maintainer: autotaker@gmail.com
-- Stability: experimental
module Control.Env.Hierarchical.TH (deriveEnv) where

import Control.Env.Hierarchical.Internal
  ( Environment (Fields, Fields1, Super, superL),
    Extends,
    Field (fieldL),
    Root,
    rootL,
  )
import Control.Monad (filterM, guard, zipWithM)
import Data.Function ((&))
import Language.Haskell.TH
  ( Dec (TySynD),
    DecQ,
    Info (TyConI),
    Inline (Inline),
    Name,
    Phases (AllPhases),
    Q,
    RuleMatch (FunLike),
    TyVarBndr,
    Type (AppT, ConT),
    TypeQ,
    appE,
    appT,
    clause,
    conE,
    conP,
    conT,
    cxt,
    funD,
    instanceD,
    lam1E,
    mkName,
    normalB,
    pprint,
    pragInlD,
    promotedConsT,
    promotedNilT,
    reify,
    reportError,
    reportWarning,
    tySynEqn,
    tySynInstD,
    valD,
    varE,
    varP,
  )
import qualified Language.Haskell.TH.Datatype as D
import Language.Haskell.TH.Ppr (commaSep)

deriveEnv :: Name -> Q [Dec]
deriveEnv :: Name -> Q [Dec]
deriveEnv Name
envName = do
  DatatypeInfo
envInfo <- Name -> Q DatatypeInfo
D.reifyDatatype Name
envName
  ConstructorInfo
consInfo <- case DatatypeInfo -> [ConstructorInfo]
D.datatypeCons DatatypeInfo
envInfo of
    [ConstructorInfo
consInfo] -> ConstructorInfo -> Q ConstructorInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstructorInfo
consInfo
    [ConstructorInfo]
_ -> String -> Q ConstructorInfo
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Multiple costructors"
  let envType :: Type
envType = DatatypeInfo -> Type
D.datatypeType DatatypeInfo
envInfo
      tyVars :: [TyVarBndrUnit]
tyVars = DatatypeInfo -> [TyVarBndrUnit]
D.datatypeVars DatatypeInfo
envInfo
      fields :: [Type]
fields = ConstructorInfo -> [Type]
D.constructorFields ConstructorInfo
consInfo
  Dec
dec <- (Type, ConstructorInfo, [TyVarBndrUnit]) -> DecQ
envInstance (Type
envType, ConstructorInfo
consInfo, [TyVarBndrUnit]
tyVars)
  [Dec]
decs <-
    (Type -> Int -> DecQ) -> [Type] -> [Int] -> Q [Dec]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM
      ((ConstructorInfo, Type) -> Type -> Int -> DecQ
deriveField (ConstructorInfo
consInfo, Type
envType))
      [Type]
fields
      [Int
0 ..]
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec
dec Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
decs)

-- instance Field $ty $env where
--   $(deriveLens ...)
deriveField :: (D.ConstructorInfo, Type) -> Type -> Int -> Q Dec
deriveField :: (ConstructorInfo, Type) -> Type -> Int -> DecQ
deriveField (ConstructorInfo
conInfo, Type
envType) Type
fieldType Int
fieldIdx =
  CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([TypeQ] -> CxtQ
cxt []) TypeQ
fieldInstType [DecQ
inlineDec, DecQ
dec]
  where
    fieldInstType :: TypeQ
fieldInstType =
      Name -> TypeQ
conT ''Field TypeQ -> TypeQ -> TypeQ
`appT` Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
fieldType TypeQ -> TypeQ -> TypeQ
`appT` Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
envType
    -- fieldL = l where $(makeLensesFor ...)
    inlineDec :: DecQ
inlineDec = Name -> Inline -> RuleMatch -> Phases -> DecQ
pragInlD 'fieldL Inline
Inline RuleMatch
FunLike Phases
AllPhases
    dec :: DecQ
dec = ConstructorInfo -> Name -> Int -> DecQ
deriveLens ConstructorInfo
conInfo 'fieldL Int
fieldIdx

-- $lname f ($con x_1 ... x_n)= fmap (\y_$idx -> $con x_1 ... y_idx ... x_n) (f x_$idx)

deriveLens :: D.ConstructorInfo -> Name -> Int -> Q Dec
deriveLens :: ConstructorInfo -> Name -> Int -> DecQ
deriveLens ConstructorInfo
conInfo Name
lname Int
idx = Name -> [ClauseQ] -> DecQ
funD Name
lname [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [PatQ]
argsP (ExpQ -> BodyQ
normalB ExpQ
bodyE) []]
  where
    argsP :: [PatQ]
argsP = [Name -> PatQ
varP Name
f, Name -> [PatQ] -> PatQ
conP Name
conName [PatQ]
conArgsP]
    conName :: Name
conName = ConstructorInfo -> Name
D.constructorName ConstructorInfo
conInfo
    conArgsP :: [PatQ]
conArgsP = (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
args
    bodyE :: ExpQ
bodyE = Name -> ExpQ
varE 'fmap ExpQ -> ExpQ -> ExpQ
`appE` ExpQ
setterE ExpQ -> ExpQ -> ExpQ
`appE` ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
f) (Name -> ExpQ
varE Name
x_idx)
    setterE :: ExpQ
setterE = PatQ -> ExpQ -> ExpQ
lam1E (Name -> PatQ
varP Name
y) ((ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE Name
conName) [ExpQ]
argsE)
    argsE :: [ExpQ]
argsE = [Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
idx then Name
y else Name
x | (Name
x, Int
i) <- [Name] -> [Int] -> [(Name, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
args [Int
0 ..]]
    f :: Name
f = String -> Name
mkName String
"f"
    y :: Name
y = String -> Name
mkName String
"y"
    x_idx :: Name
x_idx = [Name]
args [Name] -> Int -> Name
forall a. [a] -> Int -> a
!! Int
idx
    args :: [Name]
args = [String -> Name
mkName (String
"x_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i) | Int
i <- [Int
1 .. Int
arity]]
    arity :: Int
arity = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Type] -> Int) -> [Type] -> Int
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> [Type]
D.constructorFields ConstructorInfo
conInfo

envInstance :: (Type, D.ConstructorInfo, [TyVarBndr]) -> DecQ
envInstance :: (Type, ConstructorInfo, [TyVarBndrUnit]) -> DecQ
envInstance (Type
envType, ConstructorInfo
consInfo, [TyVarBndrUnit]
tyVars) =
  CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([TypeQ] -> CxtQ
cxt []) TypeQ
envInstType [DecQ]
decs
  where
    -- instance Environment $envName where
    --   $decs
    envInstType :: TypeQ
envInstType = Name -> TypeQ
conT ''Environment TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
envTypeQ
    envTypeQ :: TypeQ
envTypeQ = Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
envType
    -- envType = D.datatypeType info
    decs :: [DecQ]
    decs :: [DecQ]
decs = [DecQ
fieldsDec, DecQ
fields1Dec, DecQ
superDec] [DecQ] -> [DecQ] -> [DecQ]
forall a. [a] -> [a] -> [a]
++ [DecQ
superLDec | [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
extendsT]
    -- tyVars = D.datatypeVars info
    -- type Fields ($envName $typeVars) = '[$field1 ... $field2]
    fieldsDec :: DecQ
fieldsDec = TySynEqnQ -> DecQ
tySynInstD (Maybe [TyVarBndrUnit] -> TypeQ -> TypeQ -> TySynEqnQ
tySynEqn ([TyVarBndrUnit] -> Maybe [TyVarBndrUnit]
forall a. a -> Maybe a
Just [TyVarBndrUnit]
tyVars) TypeQ
lhs TypeQ
rhs)
      where
        lhs :: TypeQ
lhs = Name -> TypeQ
conT ''Fields TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
envTypeQ
        rhs :: TypeQ
rhs = [Type] -> TypeQ
promotedListT (Type
envType Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: ConstructorInfo -> [Type]
D.constructorFields ConstructorInfo
consInfo)
    -- type Fields1 ($envName $typeVars) = '[$obj1 ... $obj2]
    fields1Dec :: DecQ
fields1Dec = TySynEqnQ -> DecQ
tySynInstD (Maybe [TyVarBndrUnit] -> TypeQ -> TypeQ -> TySynEqnQ
tySynEqn ([TyVarBndrUnit] -> Maybe [TyVarBndrUnit]
forall a. a -> Maybe a
Just [TyVarBndrUnit]
tyVars) TypeQ
lhs TypeQ
rhs)
      where
        lhs :: TypeQ
lhs = Name -> TypeQ
conT ''Fields1 TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
envTypeQ
        rhs :: TypeQ
rhs = [Type] -> TypeQ
promotedListT ([Type] -> TypeQ) -> CxtQ -> TypeQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> ConstructorInfo -> CxtQ
fields1 Type
envType ConstructorInfo
consInfo

    -- Super ($envName $typeVars) = $t
    -- where @$Extends $t@ is a field of the environment
    superDec :: DecQ
superDec = TySynEqnQ -> DecQ
tySynInstD (Maybe [TyVarBndrUnit] -> TypeQ -> TypeQ -> TySynEqnQ
tySynEqn ([TyVarBndrUnit] -> Maybe [TyVarBndrUnit]
forall a. a -> Maybe a
Just [TyVarBndrUnit]
tyVars) TypeQ
lhs TypeQ
rhs)
      where
        lhs :: TypeQ
lhs = Name -> TypeQ
conT ''Super TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
envTypeQ
        rhs :: TypeQ
rhs = case [Type]
extendsT of
          [Type
t] -> Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
          [] -> Name -> TypeQ
conT ''Root
          ts :: [Type]
ts@(Type
t : [Type]
_) -> do
            String -> Q ()
reportError (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Multiple inheritance is not allowed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Doc -> String
forall a. Show a => a -> String
show ([Type] -> Doc
forall a. Ppr a => [a] -> Doc
commaSep [Type]
ts)
            Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
    extendsT :: [Type]
    extendsT :: [Type]
extendsT = do
      AppT (ConT Name
conName) Type
t <- ConstructorInfo -> [Type]
D.constructorFields ConstructorInfo
consInfo
      Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Name
conName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Extends
      Type -> [Type]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t

    -- superL = rootL (only if @Super ($envName $typeVars) = Root@)
    superLDec :: DecQ
superLDec = PatQ -> BodyQ -> [DecQ] -> DecQ
valD (Name -> PatQ
varP 'superL) (ExpQ -> BodyQ
normalB (Name -> ExpQ
varE 'rootL)) []

fields1 :: Type -> D.ConstructorInfo -> Q [Type]
fields1 :: Type -> ConstructorInfo -> CxtQ
fields1 Type
ty ConstructorInfo
consInfo =
  [Type
f | AppT Type
f Type
x <- ConstructorInfo -> [Type]
D.constructorFields ConstructorInfo
consInfo, Type
x Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
ty]
    [Type] -> ([Type] -> CxtQ) -> CxtQ
forall a b. a -> (a -> b) -> b
& (Type -> Q Bool) -> [Type] -> CxtQ
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Type -> Q Bool
headIsNotTypeSynonym
  where
    headIsNotTypeSynonym :: Type -> Q Bool
headIsNotTypeSynonym Type
_ty = Type -> Q Bool
go Type
_ty
      where
        go :: Type -> Q Bool
go (AppT Type
ty' Type
_) = Type -> Q Bool
go Type
ty'
        go (ConT Name
name) = do
          Info
r <- Name -> Q Info
reify Name
name
          case Info
r of
            TyConI TySynD {} -> do
              String -> Q ()
reportWarning (String
"Skipping type synonym field1: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
_ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". Please use newtype")
              Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
            Info
_ -> Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        go Type
_ = Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

promotedListT :: [Type] -> TypeQ
promotedListT :: [Type] -> TypeQ
promotedListT =
  (Type -> TypeQ -> TypeQ) -> TypeQ -> [Type] -> TypeQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TypeQ -> TypeQ -> TypeQ
appT (TypeQ -> TypeQ -> TypeQ)
-> (Type -> TypeQ) -> Type -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeQ -> TypeQ -> TypeQ
appT TypeQ
promotedConsT (TypeQ -> TypeQ) -> (Type -> TypeQ) -> Type -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure) TypeQ
promotedNilT

-- type Fields ($envName $typeVars) = $fields