{-# LANGUAGE TemplateHaskell, CPP #-}

{- |
This module provides an automatic Template Haskell
routine to scour data type definitions and generate
accessor objects for them automatically.
-}
module Data.Lens.Light.Template (
   nameMakeLens, makeLenses, makeLens
   ) where

import Language.Haskell.TH.Syntax
import Control.Monad (liftM, when, (<=<))
import Data.Maybe (catMaybes)
import Data.List (nub)
import Data.Lens.Light.Core

-- |@makeLenses n@ where @n@ is the name of a data type
-- declared with @data@ looks through all the declared fields
-- of the data type, and for each field beginning with an underscore
-- generates an accessor of the same name without the underscore.
--
-- It is "nameMakeLens" n f where @f@ satisfies
--
-- > f ('_' : s) = Just s
-- > f x = Nothing -- otherwise
--
-- For example, given the data type:
--
-- > data Score = Score {
-- >   _p1Score :: Int
-- > , _p2Score :: Int
-- > , rounds :: Int
-- > }
--
-- @makeLenses@ will generate the following objects:
--
-- > p1Score :: Lens Score Int
-- > p1Score = lens _p1Score (\x s -> s { _p1Score = x })
-- > p2Score :: Lens Score Int
-- > p2Score = lens _p2Score (\x s -> s { _p2Score = x })
--
-- It is used with Template Haskell syntax like:
--
-- > $( makeLenses [''TypeName] )
--
-- And will generate accessors when TypeName was declared
-- using @data@ or @newtype@.
makeLenses :: [Name] -> Q [Dec]
makeLenses :: [Name] -> Q [Dec]
makeLenses = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> Q [Dec]
makeLens

-- |
-- > makeLens a = makeLenses [a]
--
-- > $( makeLens ''TypeName )

makeLens :: Name -> Q [Dec]
makeLens :: Name -> Q [Dec]
makeLens Name
n = Name -> (String -> Maybe String) -> Q [Dec]
nameMakeLens Name
n String -> Maybe String
stripUnderscore

stripUnderscore :: String -> Maybe String
stripUnderscore :: String -> Maybe String
stripUnderscore (Char
'_':String
t) = forall a. a -> Maybe a
Just String
t
stripUnderscore String
_ = forall a. Maybe a
Nothing

namedFields :: Con -> [VarStrictType]
namedFields :: Con -> [VarStrictType]
namedFields (RecC Name
_ [VarStrictType]
fs) = [VarStrictType]
fs
namedFields (ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
c) = Con -> [VarStrictType]
namedFields Con
c
namedFields Con
_ = []

-- |@nameMakeLens n f@ where @n@ is the name of a data type
-- declared with @data@ and @f@ is a function from names of fields
-- in that data type to the name of the corresponding accessor. If
-- @f@ returns @Nothing@, then no accessor is generated for that
-- field.
nameMakeLens :: Name -> (String -> Maybe String) -> Q [Dec]
nameMakeLens :: Name -> (String -> Maybe String) -> Q [Dec]
nameMakeLens Name
t String -> Maybe String
namer = do
    Info
info <- Name -> Q Info
reify Name
t
    Dec
reified <- case Info
info of
                    TyConI Dec
dec -> forall (m :: * -> *) a. Monad m => a -> m a
return Dec
dec
                    Info
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
errmsg Name
t
    Name -> Dec -> (String -> Maybe String) -> Q [Dec]
decMakeLens Name
t Dec
reified String -> Maybe String
namer

#if MIN_VERSION_template_haskell(2,21,0)
type TyVarBndr' = TyVarBndr BndrVis
#elif MIN_VERSION_template_haskell(2,17,0)
type TyVarBndr' = TyVarBndr ()
#else
type TyVarBndr' = TyVarBndr
#endif

decMakeLens :: Name -> Dec -> (String -> Maybe String) -> Q [Dec]
decMakeLens :: Name -> Dec -> (String -> Maybe String) -> Q [Dec]
decMakeLens Name
t Dec
dec String -> Maybe String
namer = do
    ([TyVarBndr ()]
params, [Con]
cons) <- case Dec
dec of
#if MIN_VERSION_template_haskell(2,11,0)
                 -- https://github.com/feuerbach/data-lens-light/issues/7
                 DataD Cxt
_ Name
_ [TyVarBndr ()]
params Maybe Type
_ [Con]
cons' [DerivClause]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndr ()]
params, [Con]
cons')
                 NewtypeD Cxt
_ Name
_ [TyVarBndr ()]
params Maybe Type
_ Con
con' [DerivClause]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndr ()]
params, [Con
con'])
#else
                 DataD _ _ params cons' _ -> return (params, cons')
                 NewtypeD _ _ params con' _ -> return (params, [con'])
#endif
                 Dec
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
errmsg Name
t
    [Dec]
decs <- [TyVarBndr ()] -> [VarStrictType] -> Q [Dec]
makeAccs [TyVarBndr ()]
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Con -> [VarStrictType]
namedFields [Con]
cons
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Dec]
decs) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
False String
nodefmsg
    forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
decs

    where

    nodefmsg :: String
nodefmsg = String
"Warning: No accessors generated from the name " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
t
          forall a. [a] -> [a] -> [a]
++ String
"\n If you are using makeLenses rather than"
          forall a. [a] -> [a] -> [a]
++ String
"\n nameMakeLens, remember accessors are"
          forall a. [a] -> [a] -> [a]
++ String
"\n only generated for fields starting with an underscore"

    makeAccs :: [TyVarBndr'] -> [VarStrictType] -> Q [Dec]
    makeAccs :: [TyVarBndr ()] -> [VarStrictType] -> Q [Dec]
makeAccs [TyVarBndr ()]
params [VarStrictType]
vars =
        forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ (Name
name,Bang
_,Type
ftype) -> Name -> [TyVarBndr ()] -> Type -> Q (Maybe [Dec])
makeAccFromName Name
name [TyVarBndr ()]
params Type
ftype) [VarStrictType]
vars

    transformName :: Name -> Maybe Name
    transformName :: Name -> Maybe Name
transformName (Name OccName
occ NameFlavour
_) = do
        String
n <- String -> Maybe String
namer (OccName -> String
occString OccName
occ)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ OccName -> NameFlavour -> Name
Name (String -> OccName
mkOccName String
n) NameFlavour
NameS

    makeAccFromName :: Name -> [TyVarBndr'] -> Type -> Q (Maybe [Dec])
    makeAccFromName :: Name -> [TyVarBndr ()] -> Type -> Q (Maybe [Dec])
makeAccFromName Name
name [TyVarBndr ()]
params Type
ftype =
        case Name -> Maybe Name
transformName Name
name of
            Maybe Name
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Just Name
n -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> [TyVarBndr ()] -> Type -> Name -> Q [Dec]
makeAcc Name
name [TyVarBndr ()]
params Type
ftype Name
n

    makeAcc :: Name -> [TyVarBndr'] -> Type -> Name -> Q [Dec]
    makeAcc :: Name -> [TyVarBndr ()] -> Type -> Name -> Q [Dec]
makeAcc Name
name [TyVarBndr ()]
params Type
ftype Name
accName = do
#if MIN_VERSION_template_haskell(2,17,0)
        let params' :: [Name]
params' = forall a b. (a -> b) -> [a] -> [b]
map (\TyVarBndr ()
x -> case TyVarBndr ()
x of (PlainTV Name
n ()
_) -> Name
n; (KindedTV Name
n ()
_ Type
_) -> Name
n) [TyVarBndr ()]
params
#else
        let params' = map (\x -> case x of (PlainTV n) -> n; (KindedTV n _) -> n) params
#endif
        let appliedT :: Type
appliedT = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
t) (forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
params')
        Exp
body <- [|
                 lens
                    ( $( return $ VarE name ) )
                    ( \x s ->
                        $( return $ RecUpdE (VarE 's) [(name, VarE 'x)] ) )
                |]
        forall (m :: * -> *) a. Monad m => a -> m a
return
          [ Name -> Type -> Dec
SigD Name
accName ([TyVarBndr Specificity] -> Cxt -> Type -> Type
ForallT
              (forall a b. (a -> b) -> [a] -> [b]
map
#if MIN_VERSION_template_haskell(2,17,0)
                (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall flag. Name -> flag -> TyVarBndr flag
PlainTV Specificity
SpecifiedSpec)
#else
                PlainTV
#endif
                [Name]
params')
              []
              (Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''Lens) Type
appliedT) Type
ftype))
          , Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
accName) (Exp -> Body
NormalB Exp
body) []
          ]

errmsg :: Show a => a -> [Char]
errmsg :: forall a. Show a => a -> String
errmsg a
t = String
"Cannot derive accessors for name " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
t forall a. [a] -> [a] -> [a]
++ String
" because"
         forall a. [a] -> [a] -> [a]
++ String
"\n it is not a type declared with 'data' or 'newtype'"
         forall a. [a] -> [a] -> [a]
++ String
"\n Did you remember to double-tick the type as in"
         forall a. [a] -> [a] -> [a]
++ String
"\n $(makeLenses ''TheType)?"