{-# LANGUAGE CPP          #-}
{-# LANGUAGE TypeFamilies #-}

module Database.CQL.Protocol.Record
    ( Record    (..)
    , TupleType
    , recordInstance
    ) where

import Control.Monad
import Language.Haskell.TH
import Database.CQL.Protocol.Tuple.TH (mkTup)

typeSynDecl :: Name -> Type -> Type -> Dec
#if __GLASGOW_HASKELL__ < 808
typeSynDecl x y z = TySynInstD x (TySynEqn [y] z)
#else
typeSynDecl :: Name -> Type -> Type -> Dec
typeSynDecl Name
x Type
y Type
z = TySynEqn -> Dec
TySynInstD (Maybe [TyVarBndr] -> Type -> Type -> TySynEqn
TySynEqn Maybe [TyVarBndr]
forall a. Maybe a
Nothing (Type -> Type -> Type
AppT (Name -> Type
ConT Name
x) Type
y) Type
z)
#endif

type family TupleType a

-- | Record/Tuple conversion.
-- For example:
--
-- @
-- data Peer = Peer
--     { peerAddr :: IP
--     , peerRPC  :: IP
--     , peerDC   :: Text
--     , peerRack :: Text
--     } deriving Show
--
-- recordInstance ''Peer
--
-- map asRecord \<$\> performQuery "SELECT peer, rpc_address, data_center, rack FROM system.peers"
-- @
--
-- The generated type-class instance maps between record and tuple constructors:
--
-- @
-- type instance TupleType Peer = (IP, IP, Text, Text)
--
-- instance Record Peer where
--     asTuple (Peer a b c d) = (a, b, c, d)
--     asRecord (a, b, c, d)  = Peer a b c d
-- @
--
class Record a where
    asTuple  :: a -> TupleType a
    asRecord :: TupleType a -> a

recordInstance :: Name -> Q [Dec]
recordInstance :: Name -> Q [Dec]
recordInstance Name
n = do
    Info
i <- Name -> Q Info
reify Name
n
    case Info
i of
        TyConI Dec
d -> Dec -> Q [Dec]
start Dec
d
        Info
_        -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expecting record type"

start :: Dec -> Q [Dec]
start :: Dec -> Q [Dec]
start (DataD Cxt
_ Name
tname [TyVarBndr]
_ Maybe Type
_ [Con]
cons [DerivClause]
_) = do
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Con] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
cons Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
        String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expecting single data constructor"
    Type
tt <- Con -> Q Type
tupleType ([Con] -> Con
forall a. [a] -> a
head [Con]
cons)
    Clause
at <- Con -> Q Clause
asTupleDecl ([Con] -> Con
forall a. [a] -> a
head [Con]
cons)
    Clause
ar <- Con -> Q Clause
asRecrdDecl ([Con] -> Con
forall a. [a] -> a
head [Con]
cons)
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ Name -> Type -> Type -> Dec
typeSynDecl (String -> Name
mkName String
"TupleType") (Name -> Type
ConT Name
tname) Type
tt
        , Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] (Name -> Type
ConT (String -> Name
mkName String
"Record") Type -> Type -> Type
$: Name -> Type
ConT Name
tname)
            [ Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"asTuple")  [Clause
at]
            , Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"asRecord") [Clause
ar]
            ]
        ]
start Dec
_ = String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unsupported data type"

tupleType :: Con -> Q Type
tupleType :: Con -> Q Type
tupleType Con
c = do
    let tt :: Cxt
tt = Con -> Cxt
types Con
c
    Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Cxt -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Type -> Type -> Type
($:) (Int -> Type
TupleT (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tt) Type -> Cxt -> Cxt
forall a. a -> [a] -> [a]
: Con -> Cxt
types Con
c)
  where
    types :: Con -> Cxt
types (NormalC Name
_ [BangType]
tt) = (BangType -> Type) -> [BangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
forall a b. (a, b) -> b
snd [BangType]
tt
    types (RecC Name
_ [VarBangType]
tt)    = (VarBangType -> Type) -> [VarBangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
_, Bang
_, Type
t) -> Type
t) [VarBangType]
tt
    types Con
_              = String -> Cxt
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"record and normal constructors only"

asTupleDecl ::Con -> Q Clause
asTupleDecl :: Con -> Q Clause
asTupleDecl Con
c =
    case Con
c of
        (NormalC Name
n [BangType]
t) -> Name -> [BangType] -> Q Clause
forall (t :: * -> *) a. Foldable t => Name -> t a -> Q Clause
go Name
n [BangType]
t
        (RecC    Name
n [VarBangType]
t) -> Name -> [VarBangType] -> Q Clause
forall (t :: * -> *) a. Foldable t => Name -> t a -> Q Clause
go Name
n [VarBangType]
t
        Con
_             -> String -> Q Clause
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"record and normal constructors only"
  where
    go :: Name -> t a -> Q Clause
go Name
n t a
t = do
        [Name]
vars <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
t) (String -> Q Name
newName String
"a")
        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] -> Pat
ConP Name
n ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
vars)] ([Name] -> Body
body [Name]
vars) []
    body :: [Name] -> Body
body = Exp -> Body
NormalB (Exp -> Body) -> ([Name] -> Exp) -> [Name] -> Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Exp] -> Exp
mkTup ([Exp] -> Exp) -> ([Name] -> [Exp]) -> [Name] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE

asRecrdDecl ::Con -> Q Clause
asRecrdDecl :: Con -> Q Clause
asRecrdDecl Con
c =
    case Con
c of
        (NormalC Name
n [BangType]
t) -> Name -> [BangType] -> Q Clause
forall (t :: * -> *) a. Foldable t => Name -> t a -> Q Clause
go Name
n [BangType]
t
        (RecC    Name
n [VarBangType]
t) -> Name -> [VarBangType] -> Q Clause
forall (t :: * -> *) a. Foldable t => Name -> t a -> Q Clause
go Name
n [VarBangType]
t
        Con
_             -> String -> Q Clause
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"record and normal constructors only"
  where
    go :: Name -> t a -> Q Clause
go Name
n t a
t = do
        [Name]
vars <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
t) (String -> Q Name
newName String
"a")
        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]
vars)] (Name -> [Name] -> Body
body Name
n [Name]
vars) []
    body :: Name -> [Name] -> Body
body Name
n [Name]
v = Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> Exp) -> [Exp] -> Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Exp -> Exp -> Exp
($$) (Name -> Exp
ConE Name
n Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
v)

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

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