{-# 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 = [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> ([[Dec]] -> [Dec]) -> [[Dec]] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> Q [Dec]) -> ([Name] -> Q [[Dec]]) -> [Name] -> Q [Dec]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (Name -> Q [Dec]) -> [Name] -> Q [[Dec]]
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 [] = Maybe String
forall a. Maybe a
Nothing
stripUnderscore String
s 
   | String -> Char
forall a. [a] -> a
head String
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' = String -> Maybe String
forall a. a -> Maybe a
Just (String -> String
forall a. [a] -> [a]
tail String
s)
   | Bool
otherwise = Maybe String
forall a. Maybe a
Nothing

namedFields :: Con -> [VarStrictType]
namedFields :: Con -> [VarStrictType]
namedFields (RecC Name
_ [VarStrictType]
fs) = [VarStrictType]
fs
namedFields (ForallC [TyVarBndr]
_ 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 -> Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return Dec
dec
                    Info
_ -> String -> Q Dec
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Dec) -> String -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> String
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,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 Kind
_ [Con]
cons' [DerivClause]
_ -> ([TyVarBndr], [Con]) -> Q ([TyVarBndr], [Con])
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndr]
params, [Con]
cons')
                 NewtypeD Cxt
_ Name
_ [TyVarBndr]
params Maybe Kind
_ Con
con' [DerivClause]
_ -> ([TyVarBndr], [Con]) -> Q ([TyVarBndr], [Con])
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
_ -> String -> Q ([TyVarBndr], [Con])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ([TyVarBndr], [Con]))
-> String -> Q ([TyVarBndr], [Con])
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. Show a => a -> String
errmsg Name
t
    [Dec]
decs <- [TyVarBndr] -> [VarStrictType] -> Q [Dec]
makeAccs [TyVarBndr]
params ([VarStrictType] -> Q [Dec])
-> ([VarStrictType] -> [VarStrictType])
-> [VarStrictType]
-> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [VarStrictType] -> [VarStrictType]
forall a. Eq a => [a] -> [a]
nub ([VarStrictType] -> Q [Dec]) -> [VarStrictType] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (Con -> [VarStrictType]) -> [Con] -> [VarStrictType]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Con -> [VarStrictType]
namedFields [Con]
cons
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Dec] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Dec]
decs) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
False String
nodefmsg
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
decs

    where

    nodefmsg :: String
nodefmsg = String
"Warning: No accessors generated from the name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
t
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n If you are using makeLenses rather than"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n nameMakeLens, remember accessors are"
          String -> String -> String
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 =
        ([Maybe [Dec]] -> [Dec]) -> Q [Maybe [Dec]] -> Q [Dec]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec])
-> ([Maybe [Dec]] -> [[Dec]]) -> [Maybe [Dec]] -> [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe [Dec]] -> [[Dec]]
forall a. [Maybe a] -> [a]
catMaybes) (Q [Maybe [Dec]] -> Q [Dec]) -> Q [Maybe [Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (VarStrictType -> Q (Maybe [Dec]))
-> [VarStrictType] -> Q [Maybe [Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ (Name
name,Bang
_,Kind
ftype) -> Name -> [TyVarBndr] -> Kind -> Q (Maybe [Dec])
makeAccFromName Name
name [TyVarBndr]
params Kind
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)
        Name -> Maybe Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Maybe Name) -> Name -> Maybe Name
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] -> Kind -> Q (Maybe [Dec])
makeAccFromName Name
name [TyVarBndr]
params Kind
ftype =
        case Name -> Maybe Name
transformName Name
name of
            Maybe Name
Nothing -> Maybe [Dec] -> Q (Maybe [Dec])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Dec]
forall a. Maybe a
Nothing
            Just Name
n -> ([Dec] -> Maybe [Dec]) -> Q [Dec] -> Q (Maybe [Dec])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Dec] -> Maybe [Dec]
forall a. a -> Maybe a
Just (Q [Dec] -> Q (Maybe [Dec])) -> Q [Dec] -> Q (Maybe [Dec])
forall a b. (a -> b) -> a -> b
$ Name -> [TyVarBndr] -> Kind -> Name -> Q [Dec]
makeAcc Name
name [TyVarBndr]
params Kind
ftype Name
n

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

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