{-# LANGUAGE CPP                 #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Database.CQL.Protocol.Tuple.TH where

import Control.Applicative
import Control.Monad
import Language.Haskell.TH
import Prelude

-- Templated instances ------------------------------------------------------

genInstances :: Int -> Q [Dec]
genInstances :: Int -> Q [Dec]
genInstances Int
n = [[Dec]] -> [Dec]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Q [Dec]) -> [Int] -> 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 Int -> Q [Dec]
tupleInstance [Int
2 .. Int
n]

tupleInstance :: Int -> Q [Dec]
tupleInstance :: Int -> Q [Dec]
tupleInstance Int
n = do
    let cql :: Name
cql = String -> Name
mkName String
"Cql"
    vnames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"a")
    let vtypes    = (Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
vnames
    let tupleType = (Type -> Type -> Type) -> [Type] -> Type
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Type -> Type -> Type
($:) (Int -> Type
TupleT Int
n Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
vtypes)
    let ctx = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type -> Type
AppT (Name -> Type
ConT Name
cql)) [Type]
vtypes
    td <- tupleDecl n
    sd <- storeDecl n
    return
        [ InstanceD Nothing ctx (tcon "PrivateTuple" $: tupleType)
            [ FunD (mkName "count") [countDecl n]
            , FunD (mkName "check") [taggedDecl (var "typecheck") vnames]
            , FunD (mkName "tuple") [td]
            , FunD (mkName "store") [sd]
            ]
        , InstanceD Nothing ctx (tcon "Tuple" $: tupleType) []
        ]

countDecl :: Int -> Clause
countDecl :: Int -> Clause
countDecl Int
n = [Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
body) []
  where
    body :: Exp
body = String -> Exp
con String
"Tagged" Exp -> Exp -> Exp
$$ Int -> Exp
forall i. Integral i => i -> Exp
litInt Int
n

-- Tagged $ ident
--    [ untag (ctype :: Tagged x ColumnType)
--    , untag (ctype :: Tagged y ColumnType)
--    , ...
--    ])
taggedDecl :: Exp -> [Name] -> Clause
taggedDecl :: Exp -> [Name] -> Clause
taggedDecl Exp
ident [Name]
names = [Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
body) []
  where
    body :: Exp
body  = String -> Exp
con String
"Tagged" Exp -> Exp -> Exp
$$ (Exp
ident Exp -> Exp -> Exp
$$ [Exp] -> Exp
ListE ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
fn [Name]
names))
    fn :: Name -> Exp
fn Name
n  = String -> Exp
var String
"untag" Exp -> Exp -> Exp
$$ Exp -> Type -> Exp
SigE (String -> Exp
var String
"ctype") (Name -> Type
tty Name
n)
    tty :: Name -> Type
tty Name
n = String -> Type
tcon String
"Tagged" Type -> Type -> Type
$: Name -> Type
VarT Name
n Type -> Type -> Type
$: String -> Type
tcon String
"ColumnType"

-- tuple v = (,)  <$> element v ctype <*> element v ctype
-- tuple v = (,,) <$> element v ctype <*> element v ctype <*> element v ctype
-- ...
tupleDecl :: Int -> Q Clause
tupleDecl :: Int -> Q Clause
tupleDecl Int
n = do
    let v :: Name
v = String -> Name
mkName String
"v"
    let cs :: Name
cs = String -> Name
mkName String
"cs"
    [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
v, Name -> Pat
VarP Name
cs] (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Exp
body Name
v Name
cs) ([Dec] -> Clause) -> Q [Dec] -> Q Clause
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Dec]
comb
  where
    body :: Name -> Name -> Exp
body Name
v Name
cs = Exp -> Exp -> Exp -> Exp
UInfixE (String -> Exp
var String
"combine") (String -> Exp
var String
"<$>") ((Exp -> Exp -> Exp) -> [Exp] -> Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Exp -> Exp -> Exp
star (Name -> Name -> [Exp]
elts Name
v Name
cs))
    elts :: Name -> Name -> [Exp]
elts Name
v Name
cs = ((Int -> Exp) -> [Int] -> [Exp]) -> [Int] -> (Int -> Exp) -> [Exp]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> Exp) -> [Int] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] (\Int
i -> String -> Exp
var String
"element" Exp -> Exp -> Exp
$$ Name -> Exp
VarE Name
v Exp -> Exp -> Exp
$$ Name -> Exp
VarE Name
cs Exp -> Exp -> Exp
$$ Lit -> Exp
LitE (Integer -> Lit
IntegerL (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)) Exp -> Exp -> Exp
$$ String -> Exp
var String
"ctype")
    star :: Exp -> Exp -> Exp
star   = (Exp -> Exp -> Exp -> Exp) -> Exp -> Exp -> Exp -> Exp
forall a b c. (a -> b -> c) -> b -> a -> c
flip Exp -> Exp -> Exp -> Exp
UInfixE (String -> Exp
var String
"<*>")
    comb :: Q [Dec]
comb   = do
        names <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
        let f = Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
mkTup ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
names)
        return [ FunD (mkName "combine") [Clause (map VarP names) f []] ]

-- store v (a, b) = put (2 :: Word16) >> putValue v (toCql a) >> putValue v (toCql b)
storeDecl :: Int -> Q Clause
storeDecl :: Int -> Q Clause
storeDecl Int
n = do
    let v :: Name
v = String -> Name
mkName String
"v"
    names <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"k")
    return $ Clause [VarP v, TupP (map VarP names)] (NormalB $ body v names) []
  where
#if MIN_VERSION_template_haskell(2,17,0)
    body :: Name -> [Name] -> Exp
body Name
x [Name]
names = Maybe ModName -> [Stmt] -> Exp
DoE Maybe ModName
forall a. Maybe a
Nothing (Exp -> Stmt
NoBindS Exp
size Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: (Name -> Stmt) -> [Name] -> [Stmt]
forall a b. (a -> b) -> [a] -> [b]
map (Exp -> Stmt
NoBindS (Exp -> Stmt) -> (Name -> Exp) -> Name -> Stmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name -> Exp
value Name
x) [Name]
names)
#else
    body x names = DoE (NoBindS size : map (NoBindS . value x) names)
#endif
    size :: Exp
size         = String -> Exp
var String
"put" Exp -> Exp -> Exp
$$ Exp -> Type -> Exp
SigE (Int -> Exp
forall i. Integral i => i -> Exp
litInt Int
n) (String -> Type
tcon String
"Word16")
    value :: Name -> Name -> Exp
value Name
x Name
v    = String -> Exp
var String
"putValue" Exp -> Exp -> Exp
$$ Name -> Exp
VarE Name
x Exp -> Exp -> Exp
$$ (String -> Exp
var String
"toCql" Exp -> Exp -> Exp
$$ Name -> Exp
VarE Name
v)

genCqlInstances :: Int -> Q [Dec]
genCqlInstances :: Int -> Q [Dec]
genCqlInstances Int
n = [[Dec]] -> [Dec]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Q [Dec]) -> [Int] -> 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 Int -> Q [Dec]
cqlInstances [Int
2 .. Int
n]

-- instance (Cql a, Cql b) => Cql (a, b) where
--     ctype = Tagged $ TupleColumn
--         [ untag (ctype :: Tagged a ColumnType)
--         , untag (ctype :: Tagged b ColumnType)
--         ]
--     toCql (a, b) = CqlTuple [toCql a, toCql b]
--     fromCql (CqlTuple [a, b]) = (,) <$> fromCql a <*> fromCql b
--     fromCql _                 = Left "Expected CqlTuple with 2 elements."
cqlInstances :: Int -> Q [Dec]
cqlInstances :: Int -> Q [Dec]
cqlInstances Int
n = do
    let cql :: Name
cql = String -> Name
mkName String
"Cql"
    vnames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"a")
    let vtypes    = (Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
vnames
    let tupleType = (Type -> Type -> Type) -> [Type] -> Type
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Type -> Type -> Type
($:) (Int -> Type
TupleT Int
n Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
vtypes)
    let ctx = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type -> Type
AppT (Name -> Type
ConT Name
cql)) [Type]
vtypes
    tocql   <- toCqlDecl
    fromcql <- fromCqlDecl
    return
        [ InstanceD Nothing ctx (tcon "Cql" $: tupleType)
            [ FunD (mkName "ctype")   [taggedDecl (con "TupleColumn") vnames]
            , FunD (mkName "toCql")   [tocql]
            , FunD (mkName "fromCql") [fromcql]
            ]
        ]
  where
    toCqlDecl :: Q Clause
toCqlDecl = do
        names <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
        let tocql Name
nme = String -> Exp
var String
"toCql" Exp -> Exp -> Exp
$$ Name -> Exp
VarE Name
nme
        return $ Clause
            [TupP (map VarP names)]
            (NormalB . AppE (con "CqlTuple") $ ListE $ map tocql names)
            []

    fromCqlDecl :: Q Clause
fromCqlDecl = do
        names <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
        Clause
            [VarP (mkName "t")]
            (NormalB $ CaseE (var "t")
#if MIN_VERSION_template_haskell(2,18,0)
                [ Match (ParensP (ConP (mkName "CqlTuple") [] [ListP (map VarP names)]))
#else
                [ Match (ParensP (ConP (mkName "CqlTuple") [ListP (map VarP names)]))
#endif
                        (NormalB $ body names)
                        []
                , Match WildP
                        (NormalB (con "Left" $$ failure))
                        []
                ])
            <$> combine
      where
        body :: [Name] -> Exp
body [Name]
names = Exp -> Exp -> Exp -> Exp
UInfixE (String -> Exp
var String
"combine") (String -> Exp
var String
"<$>") ((Exp -> Exp -> Exp) -> [Exp] -> Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Exp -> Exp -> Exp
star ([Name] -> [Exp]
fn [Name]
names))
        star :: Exp -> Exp -> Exp
star Exp
a Exp
b   = Exp -> Exp -> Exp -> Exp
UInfixE Exp
a (String -> Exp
var String
"<*>") Exp
b
        fn :: [Name] -> [Exp]
fn [Name]
names   = (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Exp -> Exp -> Exp
AppE (String -> Exp
var String
"fromCql") (Exp -> Exp) -> (Name -> Exp) -> Name -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) [Name]
names
        combine :: Q [Dec]
combine    = do
            names <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
            let f = Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
mkTup ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
names)
            return [ FunD (mkName "combine") [Clause (map VarP names) f []] ]
        failure :: Exp
failure = Lit -> Exp
LitE (String -> Lit
StringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ String
"Expected CqlTuple with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" elements")

------------------------------------------------------------------------------
-- Helpers

litInt :: Integral i => i -> Exp
litInt :: forall i. Integral i => i -> Exp
litInt = Lit -> Exp
LitE (Lit -> Exp) -> (i -> Lit) -> i -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
IntegerL (Integer -> Lit) -> (i -> Integer) -> i -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral

var, con :: String -> Exp
var :: String -> Exp
var = Name -> Exp
VarE (Name -> Exp) -> (String -> Name) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName
con :: String -> Exp
con = Name -> Exp
ConE (Name -> Exp) -> (String -> Name) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName

tcon :: String -> Type
tcon :: String -> Type
tcon = Name -> Type
ConT (Name -> Type) -> (String -> Name) -> String -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName

($$) :: Exp -> Exp -> Exp
$$ :: Exp -> Exp -> Exp
($$) = Exp -> Exp -> Exp
AppE

($:) :: Type -> Type -> Type
$: :: Type -> Type -> Type
($:) = Type -> Type -> Type
AppT

mkTup :: [Exp] -> Exp
#if MIN_VERSION_template_haskell(2,16,0)
mkTup :: [Exp] -> Exp
mkTup = [Maybe Exp] -> Exp
TupE ([Maybe Exp] -> Exp) -> ([Exp] -> [Maybe Exp]) -> [Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> Maybe Exp) -> [Exp] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Maybe Exp
forall a. a -> Maybe a
Just
#else
mkTup = TupE
#endif