module Database.DSH.TH
(
deriveTupleQA
, generateDeriveTupleQARange
, deriveTupleTA
, generateDeriveTupleTARange
, deriveTupleView
, generateDeriveTupleViewRange
, deriveQAForRecord
, deriveQAForRecord'
, deriveViewForRecord
, deriveViewForRecord'
, deriveTAForRecord
, deriveTAForRecord'
, generateDatabaseRecordInstances
, generateTableRecordInstances
, generateRecordInstances
, generateTableDeclarations
) where
import Database.DSH.Data
import Database.DSH.Impossible
import Control.Applicative
import Control.Monad
import Data.Convertible
import Data.Char
import Data.List
import Database.HDBC
import Data.Text (Text)
import GHC.Exts
import Language.Haskell.TH hiding (Q, TupleT, tupleT, AppE, VarE, reify, Type, ListT)
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Syntax (sequenceQ)
arrowChainT :: [TypeQ] -> TypeQ
arrowChainT [] = $impossible
arrowChainT as = foldr1 (\a b -> arrowT `appT` a `appT` b) as
applyChainT :: TypeQ -> [TypeQ] -> TypeQ
applyChainT t ts = foldl' appT t ts
applyChainE :: ExpQ -> [ExpQ] -> ExpQ
applyChainE e es = foldl' appE e es
applyChainTupleP :: [PatQ] -> PatQ
applyChainTupleP = foldr1 (\p1 p2 -> conP 'TupleN [p1,p2,wildP])
applyChainTupleE :: Name -> [ExpQ] -> ExpQ
applyChainTupleE n = foldr1 (\e1 e2 -> appE (appE (conE n) e1) e2)
deriveTupleQA :: Int -> TH.Q [Dec]
deriveTupleQA l
| l < 2 = $impossible
| otherwise = pure `fmap` instanceD qaCxts
qaType
qaDecs
where
names@(a:b:rest) = [ mkName $ "a" ++ show i | i <- [1..l] ]
qaCxts = return [ ClassP ''QA [VarT n] | n <- names ]
qaType = conT ''QA `appT` applyChainT (TH.tupleT l) (map varT names)
qaDecs = [ reifyDec
, fromNormDec
, toNormDec
]
reifyDec = funD 'reify [reifyClause]
reifyClause = clause [ wildP ]
( normalB $ applyChainTupleE 'TupleT [ [| reify (undefined :: $_n) |] | _n <- map varT names ] )
[]
fromNormDec = funD 'fromNorm [fromNormClause, clause [TH.wildP] (normalB [| $impossible |]) [] ]
fromNormClause = clause [applyChainTupleP (map varP names)]
(normalB $ TH.tupE [ [| fromNorm $(varE n) |] | n <- names ])
[]
toNormDec = funD 'toNorm [toNormClause]
toNormClause = clause [ toNormClausePattern ] (normalB $ fst $ toNormClauseBody $ [ varE n | n <- names ]) []
toNormClausePattern = tupP [ varP n | n <- names ]
toNormClauseBody [a1,b1] =
let t1 = [| TupleT (reify $a1) (reify $b1) |]
e1 = [| TupleN (toNorm $a1) (toNorm $b1) ($t1) |]
in (e1,t1)
toNormClauseBody (a1 : as1) =
let (e1,t1) = toNormClauseBody as1
t2 = [| TupleT (reify $a1) ($t1) |]
e2 = [| TupleN (toNorm $a1) ($e1) ($t2) |]
in (e2,t2)
toNormClauseBody _ = $impossible
generateDeriveTupleQARange :: Int -> Int -> TH.Q [Dec]
generateDeriveTupleQARange from to =
concat `fmap` sequenceQ [ deriveTupleQA n | n <- reverse [from..to] ]
deriveTupleTA :: Int -> TH.Q [Dec]
deriveTupleTA l
| l < 2 = $impossible
| otherwise = pure `fmap` instanceD taCxts
taType
taDecs
where
names = [ mkName $ "a" ++ show i | i <- [1..l] ]
taCxts = return $ concat [ [ClassP ''QA [VarT n], ClassP ''BasicType [VarT n]] | n <- names ]
taType = conT ''TA `appT` applyChainT (TH.tupleT l) (map varT names)
taDecs = []
generateDeriveTupleTARange :: Int -> Int -> TH.Q [Dec]
generateDeriveTupleTARange from to =
concat `fmap` sequenceQ [ deriveTupleTA n | n <- reverse [from..to] ]
deriveTupleView :: Int -> TH.Q [Dec]
deriveTupleView l
| l < 2 = $impossible
| otherwise = pure `fmap` instanceD viewCxts
viewType
viewDecs
where
names = [ mkName $ "a" ++ show i | i <- [1..l] ]
a = mkName "a"
first p = [| AppE1 Fst $p (typeTupleFst (typeExp $p)) |]
second p = [| AppE1 Snd $p (typeTupleSnd (typeExp $p)) |]
viewCxts = return [ ClassP ''QA [VarT n] | n <- names ]
viewType = conT ''View `appT` (conT ''Q `appT` applyChainT (TH.tupleT l) (map varT names))
`appT` applyChainT (TH.tupleT l) [ conT ''Q `appT` varT n | n <- names ]
viewDecs = [ viewDec, fromViewDec ]
viewDec = funD 'view [viewClause]
viewClause = clause [ conP 'Q [varP a] ]
( normalB $ TH.tupE [ if pos == l then [| Q $(f (varE a)) |] else [| Q $(first (f (varE a))) |]
| pos <- [1..l]
, let f = foldr (.) id (replicate (pos 1) second)
])
[]
fromViewDec = funD 'fromView [fromViewClause]
fromViewClause = clause [ fromViewClausePattern ]
( normalB [| Q $(fst $ fromViewClauseBody (map varE names)) |] )
[]
fromViewClausePattern = tupP (map (\n -> conP 'Q [varP n]) names)
fromViewClauseBody [a1,b1] =
let t1 = [| TupleT (typeExp $a1) (typeExp $b1) |]
e1 = [| TupleE ($a1) ($b1) ($t1) |]
in (e1,t1)
fromViewClauseBody (a1 : as1) =
let (e1,t1) = fromViewClauseBody as1
t2 = [| TupleT (typeExp $a1) ($t1) |]
e2 = [| TupleE ($a1) ($e1) ($t2) |]
in (e2,t2)
fromViewClauseBody _ = $impossible
generateDeriveTupleViewRange :: Int -> Int -> TH.Q [Dec]
generateDeriveTupleViewRange from to =
concat `fmap` sequenceQ [ deriveTupleView n | n <- reverse [from..to] ]
deriveQAForRecord :: TH.Q [Dec] -> TH.Q [Dec]
deriveQAForRecord q = do
records <- q
instances <- deriveQAForRecord' q
return (records ++ instances)
deriveQAForRecord' :: TH.Q [Dec] -> TH.Q [Dec]
deriveQAForRecord' q = do
d <- q
mapM addInst d
where
addInst d@(DataD [] dName [] [RecC rName rVar@(_:_)] _) | dName == rName = do
let rCxt = return []
rType = conT ''QA `appT` conT dName
rDec = [ reifyDec
, toNormDec
, fromNormDec
]
reifyDec = funD 'reify [reifyClause]
reifyClause = clause [ wildP ]
( normalB $ applyChainTupleE 'TupleT [ [| reify (undefined :: $(return _t)) |] | (_,_,_t) <- rVar] )
[]
names = [ mkName $ "a" ++ show i | i <- [1..length rVar] ]
fromNormDec = funD 'fromNorm [fromNormClause, failClause]
fromNormClause = clause [ applyChainTupleP (map varP names) ]
( normalB $ (conE dName) `applyChainE` [ [| fromNorm $(varE n) |]
| n <- names
]
)
[]
failClause = clause [ wildP ]
( do loc <- location
let pos = show (TH.loc_filename loc, fst (TH.loc_start loc), snd (TH.loc_start loc))
normalB [| error $ "ferry: Impossible `fromNorm' at location " ++ pos |]
)
[]
toNormDec = funD 'toNorm [toNormClause]
toNormClause = clause [ conP dName (map varP names) ]
( normalB $ fst $ toNormClauseBody $ [ varE n | n <- names ] )
[]
toNormClauseBody [a1,b1] =
let t1 = [| TupleT (reify $a1) (reify $b1) |]
e1 = [| TupleN (toNorm $a1) (toNorm $b1) ($t1) |]
in (e1,t1)
toNormClauseBody (a1 : as1) =
let (e1,t1) = toNormClauseBody as1
t2 = [| TupleT (reify $a1) ($t1) |]
e2 = [| TupleN (toNorm $a1) ($e1) ($t2) |]
in (e2,t2)
toNormClauseBody _ = $impossible
instanceD rCxt
rType
rDec
addInst _ = error "ferry: Failed to derive 'QA' - Invalid record definition"
deriveViewForRecord :: TH.Q [Dec] -> TH.Q [Dec]
deriveViewForRecord q = do
recrods <- q
instances <- deriveViewForRecord' q
return (recrods ++ instances)
deriveViewForRecord' :: TH.Q [Dec] -> TH.Q [Dec]
deriveViewForRecord' q = do
d <- q
concat `fmap` mapM addView d
where
addView (DataD [] dName [] [RecC rName rVar@(_:_)] dNames) | dName == rName = do
let vName = mkName $ nameBase dName ++ "V"
vRec = recC vName [ return (prefixV n, s, makeQ t) | (n,s,t) <- rVar ]
prefixV :: Name -> Name
prefixV n = mkName $ nameBase n ++ "V"
makeQ :: TH.Type -> TH.Type
makeQ t = ConT ''Q `AppT` t
vNames = [] --dNames
v <- dataD (return [])
vName
[]
[vRec]
vNames
let rCxt = return []
rType = conT ''View `appT` (conT ''Q `appT` conT dName)
`appT` (conT vName)
rDec = [ viewDec
, fromViewDec
]
a = mkName "a"
first p = [| AppE1 Fst $p (typeTupleFst (typeExp $p)) |]
second p = [| AppE1 Snd $p (typeTupleSnd (typeExp $p)) |]
viewDec = funD 'view [viewClause]
viewClause = clause [ conP 'Q [varP a] ]
( normalB $ applyChainE (conE vName)
$ map (appE (conE 'Q))
$ [ if pos == length rVar then (f (varE a)) else (first (f (varE a)))
| pos <- [1 .. length rVar]
, let f = foldr (.) id (replicate (pos 1) second)
] )
[]
qs = [ mkName $ "q" ++ show i | i <- [1.. length rVar] ]
fromViewDec = funD 'fromView [fromViewClause]
fromViewClause = clause [ conP vName [ conP 'Q [varP q1] | q1 <- qs ] ]
( normalB [| Q $(fst $ fromViewClauseBody (map varE qs)) |] )
[]
fromViewClauseBody [a1,b1] =
let t1 = [| TupleT (typeExp $a1) (typeExp $b1) |]
e1 = [| TupleE ($a1) ($b1) ($t1) |]
in (e1,t1)
fromViewClauseBody (a1 : as1) =
let (e1,t1) = fromViewClauseBody as1
t2 = [| TupleT (typeExp $a1) ($t1) |]
e2 = [| TupleE ($a1) ($e1) ($t2) |]
in (e2,t2)
fromViewClauseBody _ = $impossible
failClause = clause [ wildP ]
( do loc <- location
let pos = show (TH.loc_filename loc, fst (TH.loc_start loc), snd (TH.loc_start loc))
normalB [| error $ "ferry: Impossible `fromView' at location " ++ pos |]
)
[]
i <- instanceD rCxt
rType
rDec
return [v,i]
addView _ = error "ferry: Failed to derive 'View' - Invalid record definition"
deriveTAForRecord :: TH.Q [Dec] -> TH.Q [Dec]
deriveTAForRecord q = do
records <- q
instances <- deriveTAForRecord' q
return (records ++ instances)
deriveTAForRecord' :: TH.Q [Dec] -> TH.Q [Dec]
deriveTAForRecord' q = q >>= mapM addTA
where
addTA (DataD [] dName [] [RecC rName (_:_)] _) | dName == rName =
let taCxt = return []
taType = conT ''TA `appT` conT dName
taDec = [ ]
in instanceD taCxt
taType
taDec
addTA _ = error "ferry: Failed to derive 'TA' - Invalid record definition"
recordQSelectors :: TH.Q [Dec] -> TH.Q [Dec]
recordQSelectors q = do
recrods <- q
selectors <- recordQSelectors' q
return (recrods ++ selectors)
recordQSelectors' :: TH.Q [Dec] -> TH.Q [Dec]
recordQSelectors' q = q >>= fmap join . mapM addSel
where
addSel :: Dec -> TH.Q [Dec]
addSel (DataD [] dName [] [RecC rName vst] _) | dName == rName && not (null vst) =
let namesAndTypes = [ (n, t')
| (n, _, t) <- vst
, let t' = arrowChainT [ conT ''Q `appT` conT dName
, conT ''Q `appT` return t
]
]
addFunD (n,t) = let qn = mkName $ nameBase n ++ "Q"
vn = mkName $ nameBase n ++ "V"
in sequenceQ [ sigD qn t
, funD qn [ clause []
(normalB [| $(varE vn) . view |])
[]
]
]
in if null namesAndTypes
then error "woot?"
else concat `fmap` mapM addFunD namesAndTypes
addSel _ = error "ferry: Failed to create record selectors - Invalid record definition"
generateTableDeclarations :: (IConnection conn)
=> (IO conn)
-> TH.Q [Dec]
generateTableDeclarations conn = do
tables <- runIO $ do c <- conn
r <- getTables c
disconnect c
return r
declss <- mapM generateTableDeclaration tables
return (concat declss)
generateTableDeclaration :: String -> TH.Q [Dec]
generateTableDeclaration s = return
[ TH.SigD (mkName s) (TH.AppT (TH.ConT ''Q) (TH.AppT TH.ListT (TH.ConT (mkName (dataTypeName s)))))
, TH.FunD (mkName s) [TH.Clause [] (TH.NormalB (TH.AppE (TH.VarE (mkName "table")) (TH.LitE (TH.StringL s)))) []]
]
generateDatabaseRecordInstances :: (IConnection conn)
=> (IO conn)
-> TH.Q [Dec]
generateDatabaseRecordInstances conn = do
tables <- runIO $ do c <- conn
r <- getTables c
disconnect c
return r
decss <- mapM (\t -> generateTableRecordInstances conn t (dataTypeName t) [''Show,''Eq]) tables
return (concat decss)
dataTypeName :: String -> String
dataTypeName [] = []
dataTypeName [c] = map toUpper (cleanUnderscores [c])
dataTypeName (c : cs) = toUpper c : cleanUnderscores (init cs)
cleanUnderscores :: String -> String
cleanUnderscores [] = []
cleanUnderscores ['_'] = []
cleanUnderscores ('_' : c : cs) = toUpper c : cleanUnderscores cs
cleanUnderscores (c : cs) = c : cleanUnderscores cs
generateTableRecordInstances :: (IConnection conn)
=> (IO conn)
-> String
-> String
-> [Name]
-> TH.Q [Dec]
generateTableRecordInstances conn t dname dnames = do
tdesc <- runIO $ do c <- conn
r <- describeTable c t
disconnect c
return r
generateRecordInstances (createDataType (sortWith fst tdesc))
where
createDataType :: [(String, SqlColDesc)] -> TH.Q [Dec]
createDataType [] = error "ferry: Empty table description"
createDataType ds = pure `fmap` dataD dCxt
dName
[]
[dCon ds]
dNames
dName = mkName dname
dNames = dnames
dCxt = return []
dCon desc = recC dName (map toVarStrictType desc)
toVarStrictType (n,SqlColDesc { colType = ty, colNullable = _ }) =
let t' = case convert ty of
IntegerT -> ConT ''Integer
BoolT -> ConT ''Bool
CharT -> ConT ''Char
DoubleT -> ConT ''Double
TextT -> ConT ''Text
_ -> $impossible
in return (mkName n, NotStrict, t')
generateRecordInstances :: TH.Q [Dec] -> TH.Q [Dec]
generateRecordInstances q = do
d <- q
qa <- deriveQAForRecord' q
v <- deriveViewForRecord' q
ta <- deriveTAForRecord' q
rs <- recordQSelectors' q
return (d ++ qa ++ v ++ ta ++ rs)