{-# 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 :: DecQ
dd =
#if MIN_VERSION_template_haskell(2,12,0)
      CxtQ
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> [ConQ]
-> [DerivClauseQ]
-> DecQ
dataD ([Kind] -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return []) Name
c [] Maybe Kind
forall a. Maybe a
Nothing [] [Maybe DerivStrategy -> [PredQ] -> DerivClauseQ
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 :: DecQ
labelSig = Name -> PredQ -> DecQ
sigD Name
d [t| Label $(conT c) |]

    labelDec :: DecQ
labelDec = PatQ -> BodyQ -> [DecQ] -> DecQ
valD
                  (Name -> PatQ
varP Name
d)
                  (ExpQ -> BodyQ
normalB [| Label |])
                  []

    showInst :: DecQ
showInst = CxtQ -> PredQ -> [DecQ] -> DecQ
instanceD
            ([Kind] -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return [])
            [t| Show $(conT c) |]
            [PatQ -> BodyQ -> [DecQ] -> DecQ
valD (Name -> PatQ
varP 'show)
                (ExpQ -> BodyQ
normalB [| \_ -> n |])
                [] ]

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

        DecQ
dd,

        DecQ
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 (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)
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 (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)
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 :: DecQ
sq1 = PatQ -> BodyQ -> [DecQ] -> DecQ
valD (Name -> PatQ
varP (String -> Name
make_dname String
k))
                (ExpQ -> BodyQ
normalB [| firstLabel (undefined :: $(conT (make_cname ns)))
                                       (undefined :: $(conT (make_cname k))) |])
                []

        sqs :: [DecQ]
sqs = [ PatQ -> BodyQ -> [DecQ] -> DecQ
valD (Name -> PatQ
varP (String -> Name
make_dname String
k2))
                (ExpQ -> BodyQ
normalB [| nextLabel $(varE (make_dname k1))
                                    (undefined :: $(conT (make_cname 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 (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)
sequence [ Q [Dec]
pt1, [DecQ] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (DecQ
sq1 DecQ -> [DecQ] -> [DecQ]
forall a. a -> [a] -> [a]
: [DecQ]
sqs) ]
-- possibly there is a better option
makeLabels3 String
ns [] = String -> Q [Dec]
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 (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 -> [DecQ] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
  [Name -> PredQ -> DecQ
sigD (String -> Name
make_dname String
n) [t| Label $(litT (strTyLit n)) |],
   PatQ -> BodyQ -> [DecQ] -> DecQ
valD (Name -> PatQ
varP (String -> Name
make_dname String
n)) (ExpQ -> BodyQ
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 (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)
mapM String -> Q [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 -> Q [Dec]
makeLabel1 String
x = [DecQ] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
              [
                Name -> PredQ -> DecQ
sigD (String -> Name
mkName String
x) PredQ
makeSig,
                PatQ -> BodyQ -> [DecQ] -> DecQ
valD (Name -> PatQ
varP (String -> Name
mkName String
x)) (ExpQ -> BodyQ
normalB (Name -> ExpQ
varE 'hLens' ExpQ -> ExpQ -> ExpQ
`appE` ExpQ
lt))
                            []
                ]
            where lt :: ExpQ
lt = [| Label :: $([t| Label $l |]) |]
                  l :: PredQ
l = TyLitQ -> PredQ
litT (String -> TyLitQ
strTyLit String
x)

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