{-# 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.Accessor.Template (
   nameDeriveAccessors, deriveAccessors,
   ) where

import qualified Data.Accessor.Basic as Accessor

import Language.Haskell.TH.Syntax
  -- (Q, Exp(VarE), Pat(VarP), Dec(ValD), Name(Name), mkOccName, occString, reify, )

import Data.List.HT (viewR, )
import Data.Maybe (catMaybes, )
import Control.Monad (liftM, when, )



-- |@deriveAccessors 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 ending in an underscore
-- generates an accessor of the same name without the underscore.
--
-- It is "nameDeriveAccessors" 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
-- >                    }
--
-- @deriveAccessors@ will generate the following objects:
--
-- > p1Score :: Accessor Score Int
-- > p1Score = Accessor p1Score_ (\x s -> s { p1Score_ = x })
-- > p2Score :: Accessor Score Int
-- > p2Score = Accessor p2Score_ (\x s -> s { p2Score_ = x })
--
-- It is used with Template Haskell syntax like:
--
-- > $( deriveAccessors ''TypeName )
--
-- And will generate accessors when TypeName was declared
-- using @data@ or @newtype@.
deriveAccessors :: Name -> Q [Dec]
deriveAccessors n = nameDeriveAccessors n stripUnderscore

stripUnderscore :: String -> Maybe String
stripUnderscore s = do
    (stem,'_') <- viewR s
    return $ stem


-- |@nameDeriveAccessors 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.
nameDeriveAccessors :: Name -> (String -> Maybe String) -> Q [Dec]
nameDeriveAccessors t namer = do
    info <- reify t
    reified <- case info of
                    TyConI dec -> return dec
                    _ -> fail errmsg
    cons <- case reified of
                 DataD _ _ _ cons' _ -> return cons'
                 NewtypeD _ _ _ con' _ -> return [con']
                 _ -> fail errmsg
    decs <- liftM concat $ mapM makeAccs cons
    when (null decs) $ qReport False nodefmsg
    return decs

    where

    errmsg = "Cannot derive accessors for name " ++ show t ++ " because"
          ++ "\n    it is not a type declared with 'data' or 'newtype'"
          ++ "\n    Did you remember to double-tick the type as in"
          ++ "\n      $(deriveAccessors ''TheType)?"

    nodefmsg = "Warning: No accessors generated from the name " ++ show t
          ++ "\n    If you are using deriveAccessors rather than"
          ++ "\n    nameDeriveAccessors, remember accessors are"
          ++ "\n    only generated for fields ending with an underscore"

    makeAccs :: Con -> Q [Dec]
    makeAccs (RecC _ vars) =
        liftM (concat . catMaybes) $ mapM (\ (name,_,ftype) -> makeAccFromName name ftype) vars
    makeAccs (ForallC _ _ c) = makeAccs c
    makeAccs _ = return []

    transformName :: Name -> Maybe Name
    transformName (Name occ f) = do
        n <- namer (occString occ)
        return $ Name (mkOccName n) f

    makeAccFromName :: Name -> Type -> Q (Maybe [Dec])
    makeAccFromName name ftype = do
        case transformName name of
            Nothing -> return Nothing
            Just n -> liftM Just $ makeAcc name ftype n

    -- haddock doesn't grok TH
#ifndef __HADDOCK__

    makeAcc :: Name -> Type -> Name -> Q [Dec]
    makeAcc name ftype accName = do
        body <- [|
                 Accessor.fromSetGet
                    ( \x s ->
                        $( return $ RecUpdE (VarE 's) [(name, VarE 'x)] ) )
                    ( $( return $ VarE name ) )
                |]
        return
          [ SigD accName (AppT (AppT (ConT ''Accessor.T) (ConT t)) ftype)
          , ValD (VarP accName) (NormalB body) []
          ]

#endif