{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}

{- | Description : Automate some of the ways to make labels.

-}

module Data.HList.MakeLabels (
    makeLabels,
    makeLabels3,

    -- * labels using kind 'Symbol'
    makeLabels6,
    makeLabelable,
    ) where

import Data.Typeable
import Data.HList.FakePrelude
import Data.HList.Label3
import Data.HList.Labelable

import Language.Haskell.TH
import Data.Char
import Control.Monad

make_cname, make_dname :: String -> Name
make_cname :: String -> Name
make_cname (Char
x:String
xs) = String -> Name
mkName (String
"Label" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> Char
toUpper Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs)
make_cname String
_ = String -> Name
forall a. HasCallStack => String -> a
error String
"Data.HList.MakeLabels.make_cname: empty string"

make_dname :: String -> Name
make_dname (Char
x:String
xs) = String -> Name
mkName (Char -> Char
toLower Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs)
make_dname String
_ = String -> Name
forall a. HasCallStack => String -> a
error String
"Data.HList.MakeLabels.make_dname: empty string"

dcl :: String -> Q [Dec]
dcl :: String -> Q [Dec]
dcl String
n = let
    c :: Name
c = String -> Name
make_cname String
n
    d :: Name
d = String -> Name
make_dname String
n

    dd :: Q Dec
dd =
#if MIN_VERSION_template_haskell(2,12,0)
      Q Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Kind
-> [Q Con]
-> [Q DerivClause]
-> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Kind
-> [m Con]
-> [m DerivClause]
-> m Dec
dataD (Cxt -> Q Cxt
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []) Name
c [] Maybe Kind
forall a. Maybe a
Nothing [] [Maybe DerivStrategy -> [Q Kind] -> Q DerivClause
forall (m :: * -> *).
Quote m =>
Maybe DerivStrategy -> [m Kind] -> m DerivClause
derivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [ [t| Typeable |] ]]
#elif MIN_VERSION_template_haskell(2,11,0)
      dataD (return []) c [] Nothing [] (fmap (:[]) [t| Typeable |])
#else
      dataD (return []) c [] [] [''Typeable]
#endif

    labelSig :: Q Dec
labelSig = Name -> Q Kind -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
sigD Name
d [t| Label $(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
c) |]

    labelDec :: Q Dec
labelDec = Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD
                  (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
d)
                  (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| Label |])
                  []

    showInst :: Q Dec
showInst = Q Cxt -> Q Kind -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Kind -> [m Dec] -> m Dec
instanceD
            (Cxt -> Q Cxt
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [])
            [t| Show $(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
c) |]
            [Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP 'show)
                (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| \_ -> n |])
                [] ]

 in [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [
        Q Dec
labelSig,
        Q Dec
labelDec,

        Q Dec
dd,

        Q Dec
showInst ]


{- |

Labels like "Data.HList.Label5".

 The following TH declaration splice should be placed at top-level, before the
 created values are used. Enable @-XTemplateHaskell@ too.

>  makeLabels ["getX","getY","draw","X"]

should expand into the following declarations

> data LabelGetX deriving Typeable
> data LabelGetY deriving Typeable
> data LabelDraw deriving Typeable
> data LabelX deriving Typeable

> getX = Label :: Label LabelGetX
> getY = Label :: Label LabelGetY
> draw = Label :: Label LabelDraw
> x    = Label :: Label LabelX

-}
makeLabels :: [String] -> Q [Dec]
makeLabels :: [String] -> Q [Dec]
makeLabels = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec])
-> ([String] -> Q [[Dec]]) -> [String] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Q [Dec]) -> [String] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> Q [Dec]
dcl


-- | for "Data.HList.Label3"
makeLabels3 :: String -- ^ namespace
    -> [String] -- ^ labels
    -> Q [Dec]
makeLabels3 :: String -> [String] -> Q [Dec]
makeLabels3 String
ns (String
k:[String]
ks) =
    let pt1 :: Q [Dec]
pt1 = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Dec] -> [Dec]) -> [[Dec]] -> [Dec]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> [Dec] -> [Dec]
forall a. Int -> [a] -> [a]
drop Int
2)) (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (String -> Q [Dec]) -> [String] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> Q [Dec]
dcl (String
ns String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
k String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
ks)

        sq1 :: Q Dec
sq1 = Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
make_dname String
k))
                (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| firstLabel (undefined :: $(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT (String -> Name
make_cname String
ns)))
                                       (undefined :: $(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT (String -> Name
make_cname String
k))) |])
                []

        sqs :: [Q Dec]
sqs = [ Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
make_dname String
k2))
                (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| nextLabel $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
make_dname String
k1))
                                    (undefined :: $(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT (String -> Name
make_cname String
k2))) |])
                []

                | (String
k1,String
k2) <- [String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip (String
kString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
ks) [String]
ks ]

    in ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Q [Dec]
pt1, [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence (Q Dec
sq1 Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: [Q Dec]
sqs) ]
-- possibly there is a better option
makeLabels3 String
ns [] = String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"makeLabels3 "String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" []")

{- | for "Data.HList.Label6"

> makeLabels6 ["x","y"]

is a shortcut for

> x = Label :: Label "x"
> y = Label :: Label "y"

-}
makeLabels6 :: [String] -> Q [Dec]
makeLabels6 :: [String] -> Q [Dec]
makeLabels6 [String]
ns = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [String] -> (String -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
ns ((String -> Q [Dec]) -> Q [[Dec]])
-> (String -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \String
n -> [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
  [Name -> Q Kind -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
sigD (String -> Name
make_dname String
n) [t| Label $(Q TyLit -> Q Kind
forall (m :: * -> *). Quote m => m TyLit -> m Kind
litT (String -> Q TyLit
forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit String
n)) |],
   Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
make_dname String
n)) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| Label |]) []]


{- | @makeLabelable \"x y z\"@ expands out to

> x = hLens' (Label :: Label "x")
> y = hLens' (Label :: Label "y")
> z = hLens' (Label :: Label "z")

Refer to "Data.HList.Labelable" for usage.

-}
makeLabelable :: String -> Q [Dec]
makeLabelable :: String -> Q [Dec]
makeLabelable String
xs = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (String -> Q [Dec]) -> [String] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> Q [Dec]
forall {m :: * -> *}. Quote m => String -> m [Dec]
makeLabel1 (String -> [String]
words String
xs)
    where
        -- a bit indirect, ghc-7.6 TH is a bit too eager to reject
        -- mis-matched kind variables
        makeLabel1 :: String -> m [Dec]
makeLabel1 String
x = [m Dec] -> m [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
              [
                Name -> m Kind -> m Dec
forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
sigD (String -> Name
mkName String
x) m Kind
makeSig,
                m Pat -> m Body -> [m Dec] -> m Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
x)) (m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'hLens' m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` m Exp
lt))
                            []
                ]
            where lt :: m Exp
lt = [| Label :: $([t| Label $m Kind
l |]) |]
                  l :: m Kind
l = m TyLit -> m Kind
forall (m :: * -> *). Quote m => m TyLit -> m Kind
litT (String -> m TyLit
forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit String
x)

                  makeSig :: m Kind
makeSig = [t| forall r s t a b. (Labelable $m Kind
l r s t a b) =>
                              LabeledOptic $m Kind
l r s t a b
                              |]