{-# LANGUAGE CPP #-}
module Composite.TH
  ( withProxies
  , withLensesAndProxies
  , withPrismsAndProxies
  , withOpticsAndProxies
  ) where

import Composite.CoRecord (Field, fieldValPrism)
import Composite.Record ((:->), Record, rlens)
import Control.Lens (Prism', _1, _head, each, over, toListOf)
import Data.Char (toLower)
import Data.List (foldl')
import Data.Maybe (catMaybes)
import Data.Proxy (Proxy(Proxy))
import Data.Vinyl (RecApplicative)
import Data.Vinyl.Lens (type (∈))
import Language.Haskell.TH
  ( Q, newName, mkName, nameBase
  , Body(NormalB), cxt, Dec(PragmaD, SigD, ValD), Exp(VarE), Inline(Inlinable), Name, Pat(VarP), Phases(AllPhases), Pragma(InlineP), RuleMatch(FunLike)
  , Type(AppT, ConT, ForallT, VarT), TyVarBndr(PlainTV, KindedTV), varT
#if MIN_VERSION_template_haskell(2,17,0)
  , Specificity(SpecifiedSpec)
#endif
  )
import Language.Haskell.TH.Lens (_TySynD)

-- |Make 'Proxy' definitions for each of the @type@ synonyms in the given block of declarations. The proxies have the same names as the synonyms but with
-- the first letter lowercased.
--
-- For example:
--
-- @
--   withProxies [d|
--     type FFoo = "foo" :-> Int
--     |]
-- @
--
-- Is equivalent to:
--
-- @
--   type FFoo = "foo" :-> Int
--   fFoo :: Proxy FFoo
--   fFoo = Proxy
-- @
--
-- __Note:__ the trailing @|]@ of the quasi quote bracket has to be indented or a parse error will occur.
withProxies :: Q [Dec] -> Q [Dec]
withProxies :: Q [Dec] -> Q [Dec]
withProxies Q [Dec]
qDecs = do
  [Dec]
decs <- Q [Dec]
qDecs
  [[Dec]]
proxyDecs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {m :: * -> *}. Quote m => Name -> m [Dec]
proxyDecForName (forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf (forall s t a b. Each s t a b => Traversal s t a b
each forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' Dec (Name, [TyVarBndr ()], Type)
_TySynD forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1) [Dec]
decs)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Dec]
decs forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
proxyDecs
  where
    proxyDecForName :: Name -> m [Dec]
proxyDecForName Name
tySynName = do
      let tySynType :: m Type
tySynType = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
tySynName
          proxyName :: Name
proxyName = [Char] -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
nameBase forall a b. (a -> b) -> a -> b
$ Name
tySynName
      Type
proxyType <- [t|Proxy $tySynType|]
      Exp
proxyVal <- [|Proxy|]
      forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [ Pragma -> Dec
PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP Name
proxyName Inline
Inlinable RuleMatch
FunLike Phases
AllPhases)
        , Name -> Type -> Dec
SigD Name
proxyName Type
proxyType
        , Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
proxyName) (Exp -> Body
NormalB Exp
proxyVal) []
        ]

-- |Make 'rlens' and 'Proxy' definitions for each of the @type@ synonyms in the given block of declarations. The lenses have the same names as the synonyms
-- but with the first letter lowercased. The proxies have that name but with @_@ suffix.
--
-- For example:
--
-- @
--   withLensesAndProxies [d|
--     type FFoo = "foo" :-> Int
--     |]
-- @
--
-- Is equivalent to:
--
-- @
--   type FFoo = "foo" :-> Int
--   fFoo :: FFoo ∈ rs => Lens' (Record rs) Int
--   fFoo = rlens fFoo_
--   fFoo_ :: Proxy FFoo
--   fFoo_ = Proxy
-- @
--
-- __Note:__ the trailing @|]@ of the quasi quote bracket has to be indented or a parse error will occur.
--
-- This is equivalent to 'withOpticsAndProxies' but without the prisms.
withLensesAndProxies :: Q [Dec] -> Q [Dec]
withLensesAndProxies :: Q [Dec] -> Q [Dec]
withLensesAndProxies = Bool -> Bool -> Q [Dec] -> Q [Dec]
withBoilerplate Bool
True Bool
False

-- |Make 'fieldValPrism' and 'Proxy' definitions for each of the @type@ synonyms in the given block of declarations. The prisms have the same names as the
-- synonyms but prefixed with @_@. The proxies will have the same name as the synonym but with the first character lowercased and @_@ appended.
--
-- For example:
--
-- @
--   withPrismsAndProxies [d|
--     type FFoo = "foo" :-> Int
--     |]
-- @
--
-- Is equivalent to:
--
-- @
--   type FFoo = "foo" :-> Int
--   _FFoo :: FFoo ∈ rs => Prism' (Field rs) Int
--   _FFoo = fieldValPrism fFoo_
--   fFoo_ :: Proxy FFoo
--   fFoo_ = Proxy
-- @
--
-- __Note:__ the trailing @|]@ of the quasi quote bracket has to be indented or a parse error will occur.
--
-- This is equivalent to 'withOpticsAndProxies' but without the prisms.
withPrismsAndProxies :: Q [Dec] -> Q [Dec]
withPrismsAndProxies :: Q [Dec] -> Q [Dec]
withPrismsAndProxies = Bool -> Bool -> Q [Dec] -> Q [Dec]
withBoilerplate Bool
False Bool
True

-- |Make 'rlens', 'fieldValPrism', and 'Proxy' definitions for each of the @type@ synonyms in the given block of declarations.
-- The lenses have the same names as the synonyms but with the first letter lowercased, e.g. @FFoo@ becomes @fFoo@.
-- The prisms have the same names as the synonyms but with @_@ prepended, e.g. @FFoo@ becomes @_FFoo@.
-- The proxies have the same names as the synonyms but with the first letter lowercase and trailing @_@, e.g. @FFoo@ becomes @fFoo_@.
--
-- For example:
--
-- @
--   withOpticsAndProxies [d|
--     type FFoo = "foo" :-> Int
--     |]
-- @
--
-- Is equivalent to:
--
-- @
--   type FFoo = "foo" :-> Int
--   fFoo :: FFoo ∈ rs => Lens' (Record rs) Int
--   fFoo = rlens fFoo_
--   _FFoo :: FFoo ∈ rs => Prism' (Field rs) Int
--   _FFoo = fieldValPrism fFoo_
--   fFoo_ :: Proxy FFoo
--   fFoo_ = Proxy
-- @
--
-- __Note:__ the trailing @|]@ of the quasi quote bracket has to be indented or a parse error will occur.
withOpticsAndProxies :: Q [Dec] -> Q [Dec]
withOpticsAndProxies :: Q [Dec] -> Q [Dec]
withOpticsAndProxies = Bool -> Bool -> Q [Dec] -> Q [Dec]
withBoilerplate Bool
True Bool
True

#if MIN_VERSION_template_haskell(2,17,0)
tyUnitToSpec :: Specificity -> TyVarBndr () -> TyVarBndr Specificity
tyUnitToSpec :: Specificity -> TyVarBndr () -> TyVarBndr Specificity
tyUnitToSpec Specificity
x (PlainTV Name
n ()) = forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
n Specificity
x
tyUnitToSpec Specificity
x (KindedTV Name
n () Type
k) = forall flag. Name -> flag -> Type -> TyVarBndr flag
KindedTV Name
n Specificity
x Type
k

fieldDecUnitToSpec :: Specificity -> FieldDec () -> FieldDec Specificity
fieldDecUnitToSpec :: Specificity -> FieldDec () -> FieldDec Specificity
fieldDecUnitToSpec Specificity
x (FieldDec Name
n [TyVarBndr ()]
b Type
t Type
v) = forall a. Name -> [TyVarBndr a] -> Type -> Type -> FieldDec a
FieldDec Name
n (forall a b. (a -> b) -> [a] -> [b]
map (Specificity -> TyVarBndr () -> TyVarBndr Specificity
tyUnitToSpec Specificity
x) [TyVarBndr ()]
b) Type
t Type
v

data FieldDec a = FieldDec
#else
data FieldDec = FieldDec
#endif
  { forall a. FieldDec a -> Name
fieldName        :: Name
#if MIN_VERSION_template_haskell(2,17,0)
  , forall a. FieldDec a -> [TyVarBndr a]
fieldBinders     :: [TyVarBndr a]
#else
  , fieldBinders     :: [TyVarBndr]
#endif
  , forall a. FieldDec a -> Type
fieldTypeApplied :: Type
  , forall a. FieldDec a -> Type
fieldValueType   :: Type
  }

-- |TH splice which implements 'withLensesAndProxies', 'withPrismsAndProxies', and 'withOpticsAndProxies'
withBoilerplate :: Bool -> Bool -> Q [Dec] -> Q [Dec]
withBoilerplate :: Bool -> Bool -> Q [Dec] -> Q [Dec]
withBoilerplate Bool
generateLenses Bool
generatePrisms Q [Dec]
qDecs = do
  [Dec]
decs <- Q [Dec]
qDecs

  let fieldDecs :: [FieldDec ()]
fieldDecs = forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Name, [TyVarBndr ()], Type) -> Maybe (FieldDec ())
fieldDecMay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf (forall s t a b. Each s t a b => Traversal s t a b
each forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' Dec (Name, [TyVarBndr ()], Type)
_TySynD) forall a b. (a -> b) -> a -> b
$ [Dec]
decs
#if MIN_VERSION_template_haskell(2,17,0)
  let sFieldDecs :: [FieldDec Specificity]
sFieldDecs = forall a b. (a -> b) -> [a] -> [b]
map (Specificity -> FieldDec () -> FieldDec Specificity
fieldDecUnitToSpec Specificity
SpecifiedSpec) [FieldDec ()]
fieldDecs
#endif
  [[Dec]]
proxyDecs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FieldDec () -> Q [Dec]
proxyDecFor [FieldDec ()]
fieldDecs
#if MIN_VERSION_template_haskell(2,17,0)
  [[Dec]]
lensDecs  <- if Bool
generateLenses then forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FieldDec Specificity -> Q [Dec]
lensDecFor [FieldDec Specificity]
sFieldDecs else forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  [[Dec]]
prismDecs <- if Bool
generatePrisms then forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FieldDec Specificity -> Q [Dec]
prismDecFor [FieldDec Specificity]
sFieldDecs else forall (f :: * -> *) a. Applicative f => a -> f a
pure []
#else 
  lensDecs  <- if generateLenses then traverse lensDecFor fieldDecs else pure []
  prismDecs <- if generatePrisms then traverse prismDecFor fieldDecs else pure []
#endif
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Dec]
decs forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
proxyDecs forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
lensDecs forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
prismDecs

#if MIN_VERSION_template_haskell(2,17,0)
fieldDecMay :: (Name, [TyVarBndr ()], Type) -> Maybe (FieldDec ())
#else
fieldDecMay :: (Name, [TyVarBndr], Type) -> Maybe FieldDec
#endif
fieldDecMay :: (Name, [TyVarBndr ()], Type) -> Maybe (FieldDec ())
fieldDecMay (Name
fieldName, [TyVarBndr ()]
fieldBinders, Type
ty) = case Type
ty of
  AppT (AppT (ConT Name
n) Type
_) Type
fieldValueType | Name
n forall a. Eq a => a -> a -> Bool
== ''(:->) ->
    let fieldTypeApplied :: Type
fieldTypeApplied         = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Name -> Type
ConT Name
fieldName) (forall a b. (a -> b) -> [a] -> [b]
map forall {flag}. TyVarBndr flag -> Type
binderTy [TyVarBndr ()]
fieldBinders)
#if MIN_VERSION_template_haskell(2,17,0)
        binderTy :: TyVarBndr flag -> Type
binderTy (PlainTV Name
n' flag
_ )    = Name -> Type
VarT Name
n'
        binderTy (KindedTV Name
n' flag
_ Type
_) = Name -> Type
VarT Name
n'
#else
        binderTy (PlainTV n' )    = VarT n'
        binderTy (KindedTV n' _) = VarT n'
#endif
    in forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FieldDec {[TyVarBndr ()]
Type
Name
fieldTypeApplied :: Type
fieldValueType :: Type
fieldBinders :: [TyVarBndr ()]
fieldName :: Name
fieldValueType :: Type
fieldTypeApplied :: Type
fieldBinders :: [TyVarBndr ()]
fieldName :: Name
..}
  Type
_ ->
    forall a. Maybe a
Nothing

lensNameFor, prismNameFor, proxyNameFor :: Name -> Name
lensNameFor :: Name -> Name
lensNameFor  = [Char] -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
nameBase
prismNameFor :: Name -> Name
prismNameFor = [Char] -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"_" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
nameBase
proxyNameFor :: Name -> Name
proxyNameFor = [Char] -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ [Char]
"_") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
nameBase

#if MIN_VERSION_template_haskell(2,17,0)
proxyDecFor :: FieldDec () -> Q [Dec]
#else
proxyDecFor :: FieldDec -> Q [Dec]
#endif
proxyDecFor :: FieldDec () -> Q [Dec]
proxyDecFor (FieldDec { Name
fieldName :: Name
fieldName :: forall a. FieldDec a -> Name
fieldName, Type
fieldTypeApplied :: Type
fieldTypeApplied :: forall a. FieldDec a -> Type
fieldTypeApplied }) = do
  let proxyName :: Name
proxyName = Name -> Name
proxyNameFor Name
fieldName

  Type
proxyType <- [t|Proxy $(pure fieldTypeApplied)|]
  Exp
proxyVal <- [|Proxy|]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [ Pragma -> Dec
PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP Name
proxyName Inline
Inlinable RuleMatch
FunLike Phases
AllPhases)
    , Name -> Type -> Dec
SigD Name
proxyName Type
proxyType
    , Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
proxyName) (Exp -> Body
NormalB Exp
proxyVal) []
    ]

#if MIN_VERSION_template_haskell(2,17,0)
lensDecFor :: FieldDec Specificity -> Q [Dec]
#else
lensDecFor :: FieldDec -> Q [Dec]
#endif
lensDecFor :: FieldDec Specificity -> Q [Dec]
lensDecFor (FieldDec {[TyVarBndr Specificity]
Type
Name
fieldValueType :: Type
fieldTypeApplied :: Type
fieldBinders :: [TyVarBndr Specificity]
fieldName :: Name
fieldValueType :: forall a. FieldDec a -> Type
fieldTypeApplied :: forall a. FieldDec a -> Type
fieldBinders :: forall a. FieldDec a -> [TyVarBndr a]
fieldName :: forall a. FieldDec a -> Name
..}) = do
  Name
f  <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
  Name
rs <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"rs"

  let fTy :: Q Type
fTy                     = forall (m :: * -> *). Quote m => Name -> m Type
varT Name
f
      rsTy :: Q Type
rsTy                    = forall (m :: * -> *). Quote m => Name -> m Type
varT Name
rs
      proxyName :: Name
proxyName               = Name -> Name
proxyNameFor Name
fieldName
      lensName :: Name
lensName                = Name -> Name
lensNameFor Name
fieldName
      proxyVal :: Exp
proxyVal                = Name -> Exp
VarE Name
proxyName
#if MIN_VERSION_template_haskell(2,17,0)
      lensBinders :: [TyVarBndr Specificity]
lensBinders             = [TyVarBndr Specificity]
fieldBinders forall a. [a] -> [a] -> [a]
++ [forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
f Specificity
SpecifiedSpec, forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
rs Specificity
SpecifiedSpec]
#else
      lensBinders             = fieldBinders ++ [PlainTV f, PlainTV rs]
#endif

  Cxt
lensContext <- forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [ [t| Functor $fTy |], [t| $(pure fieldTypeApplied) ∈ $rsTy |] ]
  Type
lensType    <- [t| ($(pure fieldValueType) -> $fTy $(pure fieldValueType)) -> (Record $rsTy -> $fTy (Record $rsTy)) |]
  Exp
rlensVal    <- [| rlens $(pure proxyVal) |]

  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [ Pragma -> Dec
PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP Name
lensName Inline
Inlinable RuleMatch
FunLike Phases
AllPhases)
    , Name -> Type -> Dec
SigD Name
lensName ([TyVarBndr Specificity] -> Cxt -> Type -> Type
ForallT [TyVarBndr Specificity]
lensBinders Cxt
lensContext Type
lensType)
    , Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
lensName) (Exp -> Body
NormalB Exp
rlensVal) []
    ]

#if MIN_VERSION_template_haskell(2,17,0)
prismDecFor :: FieldDec Specificity -> Q [Dec]
#else
prismDecFor :: FieldDec -> Q [Dec]
#endif
prismDecFor :: FieldDec Specificity -> Q [Dec]
prismDecFor (FieldDec {[TyVarBndr Specificity]
Type
Name
fieldValueType :: Type
fieldTypeApplied :: Type
fieldBinders :: [TyVarBndr Specificity]
fieldName :: Name
fieldValueType :: forall a. FieldDec a -> Type
fieldTypeApplied :: forall a. FieldDec a -> Type
fieldBinders :: forall a. FieldDec a -> [TyVarBndr a]
fieldName :: forall a. FieldDec a -> Name
..}) = do
  Name
rs <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"rs"

  let rsTy :: Q Type
rsTy                    = forall (m :: * -> *). Quote m => Name -> m Type
varT Name
rs
      proxyName :: Name
proxyName               = Name -> Name
proxyNameFor Name
fieldName
      prismName :: Name
prismName               = Name -> Name
prismNameFor Name
fieldName
      proxyVal :: Exp
proxyVal                = Name -> Exp
VarE Name
proxyName
#if MIN_VERSION_template_haskell(2,17,0)
      prismBinders :: [TyVarBndr Specificity]
prismBinders            = [TyVarBndr Specificity]
fieldBinders forall a. [a] -> [a] -> [a]
++ [forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
rs Specificity
SpecifiedSpec]
#else
      prismBinders            = fieldBinders ++ [PlainTV rs]
#endif

  Cxt
prismContext  <- forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [ [t| RecApplicative $rsTy |], [t| $(pure fieldTypeApplied) ∈ $rsTy |] ]
  Type
prismType     <- [t| Prism' (Field $rsTy) $(pure fieldValueType) |]
  Exp
fieldPrismVal <- [| fieldValPrism $(pure proxyVal) |]

  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [ Pragma -> Dec
PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP Name
prismName Inline
Inlinable RuleMatch
FunLike Phases
AllPhases)
    , Name -> Type -> Dec
SigD Name
prismName ([TyVarBndr Specificity] -> Cxt -> Type -> Type
ForallT [TyVarBndr Specificity]
prismBinders Cxt
prismContext Type
prismType)
    , Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
prismName) (Exp -> Body
NormalB Exp
fieldPrismVal) []
    ]