{-# 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)
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"
    [Name]
vnames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> Q Name
newName String
"a")
    let vtypes :: [Type]
vtypes    = (Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
vnames
    let tupleType :: Type
tupleType = (Type -> Type -> Type) -> [Type] -> Type
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]
ctx = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type -> Type
AppT (Name -> Type
ConT Name
cql)) [Type]
vtypes
    Clause
td <- Int -> Q Clause
tupleDecl Int
n
    Clause
sd <- Int -> Q Clause
storeDecl Int
n
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [Type]
ctx (String -> Type
tcon String
"PrivateTuple" Type -> Type -> Type
$: Type
tupleType)
            [ Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"count") [Int -> Clause
countDecl Int
n]
            , Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"check") [Exp -> [Name] -> Clause
taggedDecl (String -> Exp
var String
"typecheck") [Name]
vnames]
            , Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"tuple") [Clause
td]
            , Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"store") [Clause
sd]
            ]
        , Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [Type]
ctx (String -> Type
tcon String
"Tuple" Type -> Type -> Type
$: Type
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"
    [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
v, Pat
WildP] (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> Exp
body Name
v) ([Dec] -> Clause) -> Q [Dec] -> Q Clause
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Dec]
comb
  where
    body :: Name -> Exp
body Name
v = Exp -> Exp -> Exp -> Exp
UInfixE (String -> Exp
var String
"combine") (String -> Exp
var String
"<$>") ((Exp -> Exp -> Exp) -> [Exp] -> Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Exp -> Exp -> Exp
star (Name -> [Exp]
elts Name
v))
    elts :: Name -> [Exp]
elts Name
v = Int -> Exp -> [Exp]
forall a. Int -> a -> [a]
replicate Int
n (String -> Exp
var String
"element" Exp -> Exp -> Exp
$$ Name -> Exp
VarE Name
v 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
        [Name]
names <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> Q Name
newName String
"x")
        let f :: Body
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)
        [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"combine") [[Pat] -> Body -> [Dec] -> Clause
Clause ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
names) Body
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"
    [Name]
names <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> Q Name
newName String
"k")
    Clause -> Q Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
v, [Pat] -> Pat
TupP ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
names)] (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> [Name] -> Exp
body Name
v [Name]
names) []
  where
    body :: Name -> [Name] -> Exp
body Name
x [Name]
names = [Stmt] -> Exp
DoE (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)
    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)
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"
    [Name]
vnames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> Q Name
newName String
"a")
    let vtypes :: [Type]
vtypes    = (Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
vnames
    let tupleType :: Type
tupleType = (Type -> Type -> Type) -> [Type] -> Type
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]
ctx = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type -> Type
AppT (Name -> Type
ConT Name
cql)) [Type]
vtypes
    Clause
tocql   <- Q Clause
toCqlDecl
    Clause
fromcql <- Q Clause
fromCqlDecl
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [Type]
ctx (String -> Type
tcon String
"Cql" Type -> Type -> Type
$: Type
tupleType)
            [ Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"ctype")   [Exp -> [Name] -> Clause
taggedDecl (String -> Exp
con String
"TupleColumn") [Name]
vnames]
            , Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"toCql")   [Clause
tocql]
            , Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"fromCql") [Clause
fromcql]
            ]
        ]
  where
    toCqlDecl :: Q Clause
toCqlDecl = do
        [Name]
names <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> Q Name
newName String
"x")
        let tocql :: Name -> Exp
tocql Name
nme = String -> Exp
var String
"toCql" Exp -> Exp -> Exp
$$ Name -> Exp
VarE Name
nme
        Clause -> Q Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause
            [[Pat] -> Pat
TupP ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
names)]
            (Exp -> Body
NormalB (Exp -> Body) -> (Exp -> Exp) -> Exp -> Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp -> Exp
AppE (String -> Exp
con String
"CqlTuple") (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
ListE ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
tocql [Name]
names)
            []

    fromCqlDecl :: Q Clause
fromCqlDecl = do
        [Name]
names <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> Q Name
newName String
"x")
        [Pat] -> Body -> [Dec] -> Clause
Clause
            [Name -> Pat
VarP (String -> Name
mkName String
"t")]
            (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> [Match] -> Exp
CaseE (String -> Exp
var String
"t")
                [ Pat -> Body -> [Dec] -> Match
Match (Pat -> Pat
ParensP (Name -> [Pat] -> Pat
ConP (String -> Name
mkName String
"CqlTuple") [[Pat] -> Pat
ListP ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
names)]))
                        (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ [Name] -> Exp
body [Name]
names)
                        []
                , Pat -> Body -> [Dec] -> Match
Match Pat
WildP
                        (Exp -> Body
NormalB (String -> Exp
con String
"Left" Exp -> Exp -> Exp
$$ Exp
failure))
                        []
                ])
            ([Dec] -> Clause) -> Q [Dec] -> Q Clause
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Dec]
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 (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
            [Name]
names <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> Q Name
newName String
"x")
            let f :: Body
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)
            [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"combine") [[Pat] -> Body -> [Dec] -> Clause
Clause ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
names) Body
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 :: 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