{-# 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" forall a. [a] -> [a] -> [a]
++ Char -> Char
toUpper Char
x forall a. a -> [a] -> [a]
: String
xs)
make_cname String
_ = 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 forall a. a -> [a] -> [a]
: String
xs)
make_dname String
_ = 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)
      forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Kind
-> [m Con]
-> [m DerivClause]
-> m Dec
dataD (forall (m :: * -> *) a. Monad m => a -> m a
return []) Name
c [] forall a. Maybe a
Nothing [] [forall (m :: * -> *).
Quote m =>
Maybe DerivStrategy -> [m Kind] -> m DerivClause
derivClause 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 = forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
sigD Name
d [t| Label $(conT c) |]

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

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

 in forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. Int -> [a] -> [a]
drop Int
2)) 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 String -> Q [Dec]
dcl (String
ns forall a. a -> [a] -> [a]
: String
k forall a. a -> [a] -> [a]
: [String]
ks)

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

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

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

    in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Q [Dec]
pt1, forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Q Dec
sq1 forall a. a -> [a] -> [a]
: [Q Dec]
sqs) ]
-- possibly there is a better option
makeLabels3 String
ns [] = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"makeLabels3 "forall a. [a] -> [a] -> [a]
++ String
ns 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
ns forall a b. (a -> b) -> a -> b
$ \String
n -> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
  [forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
sigD (String -> Name
make_dname String
n) [t| Label $(litT (strTyLit n)) |],
   forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
make_dname String
n)) (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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat 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 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 = forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
              [
                forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
sigD (String -> Name
mkName String
x) m Kind
makeSig,
                forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
x)) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'hLens' forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` m Exp
lt))
                            []
                ]
            where lt :: m Exp
lt = [| Label :: $([t| Label $l |]) |]
                  l :: m Kind
l = forall (m :: * -> *). Quote m => m TyLit -> m Kind
litT (forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit String
x)

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