module TupleTH(
mapTuple, mapTuple', filterTuple, filterTuple', reindexTuple, reverseTuple, rotateTuple, subtuples, deleteAtTuple, takeTuple, dropTuple, safeDeleteTuple, updateAtN,
zipTuple, catTuples, uncatTuple, splitTupleAt,
zipTupleWith, zipTupleWith',
safeTupleFromList, tupleFromList, constTuple,
proj, proj', elemTuple, tupleToList, sumTuple,
findSuccessiveElementsSatisfying,
foldrTuple, foldrTuple',
foldr1Tuple, foldr1Tuple',
foldlTuple, foldlTuple',
foldl1Tuple, foldl1Tuple',
andTuple, orTuple,
anyTuple, anyTuple',
allTuple, allTuple',
sequenceTuple, sequenceATuple,
htuple,
) where
import Control.Applicative ( Applicative((<*>), pure) )
import Control.Exception ( assert )
import Control.Monad
import Data.Functor((<$>))
import Data.Maybe(fromMaybe)
import Data.Set(member)
import Language.Haskell.TH
import qualified Data.Set as Set
import Data.List
htuple :: Int -> TypeQ -> TypeQ
htuple n t = foldl appT (tupleT n) (replicate n t)
withxs :: Int -> (PatQ -> [ExpQ] -> Q b) -> Q b
withxs = withNames "_x"
withys :: Int -> (PatQ -> [ExpQ] -> Q b) -> Q b
withys = withNames "_y"
newNames :: String -> Int -> Q [Name]
newNames stem n = sequence [newName (stem++show i) | i <- [ 1::Int .. n ]]
withNames :: String -> Int -> (PatQ -> [ExpQ] -> Q a) -> Q a
withNames stem n body = withNames' stem n (body . tupP)
withNames' :: String -> Int -> ([PatQ] -> [ExpQ] -> Q a) -> Q a
withNames' _ n _ | n < 0 = fail ("Negative tuple size: "++show n)
withNames' stem n body = do
names <- newNames stem n
body (fmap varP names) (fmap varE names)
withNames2
:: String
-> String
-> Int
-> (PatQ -> [ExpQ] -> PatQ -> [ExpQ] -> Q a)
-> Q a
withNames2 stem1 stem2 n body =
withNames stem1 n (\xsp xes -> withNames stem2 n (body xsp xes))
appE2 :: ExpQ -> ExpQ -> ExpQ -> ExpQ
appE2 f x y = f `appE` x `appE` y
liftExpFun :: String -> (ExpQ -> ExpQ) -> Q Exp
liftExpFun argNameStem f = do
argName <- newName argNameStem
lam1E (varP argName) (f (varE argName))
zipTuple :: Int -> Q Exp
zipTuple n = zipTupleWith' n (conE (tupleDataName 2))
zipTupleWith :: Int -> ExpQ
zipTupleWith n = liftExpFun "f" (zipTupleWith' n)
zipTupleWith' :: Int -> ExpQ -> ExpQ
zipTupleWith' n f =
withNames2 "x" "y" n
(\xsp xes ysp yes ->
lamE [xsp,ysp] (tupE (zipWith (appE2 f) xes yes)))
proj :: Int
-> Int
-> ExpQ
proj n i = do
x <- newName "_x"
lam1E (tupP (replicate i wildP ++ [ varP x ] ++ replicate (ni1) wildP)) (varE x)
foldrTuple :: Int -> ExpQ
foldrTuple n = liftExpFun "c" (foldrTuple' n)
foldrTuple' :: Int -> ExpQ -> ExpQ
foldrTuple' n c = do
z <- newName "_z"
withxs n (\xsp xes -> lamE [varP z, xsp] (foldr (appE2 c) (varE z) xes))
foldr1Tuple :: Int -> ExpQ
foldr1Tuple n = liftExpFun "c" (foldr1Tuple' n)
foldr1Tuple' :: Int -> ExpQ -> Q Exp
foldr1Tuple' n c = withxs n (\xsp xes -> lam1E xsp (foldr1 (appE2 c) xes))
foldlTuple :: Int -> ExpQ
foldlTuple n = liftExpFun "c" (foldlTuple' n)
foldlTuple' :: Int -> ExpQ -> ExpQ
foldlTuple' n c = do
z <- newName "_z"
withxs n (\xsp xes -> lamE [varP z, xsp] (foldl (appE2 c) (varE z) xes))
foldl1Tuple :: Int -> ExpQ
foldl1Tuple n = liftExpFun "c" (foldl1Tuple' n)
foldl1Tuple' :: Int -> ExpQ -> Q Exp
foldl1Tuple' n c = withxs n (\xsp xes -> lam1E xsp (foldl1 (appE2 c) xes))
filterTuple :: Int -> ExpQ
filterTuple n = liftExpFun "p" (filterTuple' n)
filterTuple' :: Int -> ExpQ -> ExpQ
filterTuple' n p = withxs n (\xsp xes -> lamE [xsp] (go xes))
where
go [] = [| [] |]
go [x] = [| if $(p) $(x) then [$(x)] else [] |]
go (x:xs) = [| (if $(p) $(x) then ($(x) :) else id) $(go xs) |]
mapTuple :: Int -> ExpQ
mapTuple n = liftExpFun "f" (mapTuple' n)
mapTuple' :: Int -> ExpQ -> Q Exp
mapTuple' n f = withxs n (\xsp xes ->
lamE [xsp] (tupE [f `appE` x | x <- xes ]))
smatch :: PatQ -> ExpQ -> MatchQ
smatch p e = match p (normalB e) []
safeTupleFromList :: Int -> Q Exp
safeTupleFromList n = do
xns <- newNames "_x" n
let xps = varP <$> xns
xes = varE <$> xns
xs <- newName "_xs"
lam1E (varP xs) (caseE (varE xs)
[ smatch (listP xps) (conE 'Just `appE` (tupE xes))
, smatch wildP (conE 'Nothing)
])
tupleFromList :: Int -> Q Exp
tupleFromList n = [| \xs0 -> fromMaybe (error (msg ++ show (length xs0))) ( $(safeTupleFromList n) xs0 ) |]
where
msg = "tupleFromList "++show n++" called on a list of length "
orTuple :: Int -> Q Exp
orTuple 0 = [| False |]
orTuple n = foldl1Tuple' n [| (||) |]
andTuple :: Int -> Q Exp
andTuple 0 = [| True |]
andTuple n = foldl1Tuple' n [| (&&) |]
anyTuple :: Int -> Q Exp
anyTuple n = liftExpFun "p" (anyTuple' n)
allTuple :: Int -> Q Exp
allTuple n = liftExpFun "p" (allTuple' n)
anyTuple' :: Int -> Q Exp -> Q Exp
anyTuple' n p = [| $(orTuple n) . $(mapTuple' n p) |]
allTuple' :: Int -> Q Exp -> Q Exp
allTuple' n p = [| $(andTuple n) . $(mapTuple' n p) |]
elemTuple :: Int -> Q Exp
elemTuple n = do
z <- newName "_z"
lam1E (varP z) (anyTuple' n [| (== $(varE z)) |])
tupleToList :: Int -> Q Exp
tupleToList n = [| $(foldrTuple' n (conE '(:))) [] |]
catTuples :: Int -> Int -> Q Exp
catTuples n m = withxs n (\xsp xes -> withys m (\ysp yes ->
lamE [xsp,ysp] (tupE (xes ++ yes))))
uncatTuple :: Int -> Int -> Q Exp
uncatTuple n m = splitTupleAt (n+m) n
splitTupleAt :: Int -> Int -> Q Exp
splitTupleAt n i =
withxs n (\xsp xes ->
case splitAt i xes of
(l,r) -> lam1E xsp (tupE [tupE l, tupE r]))
reindexTuple :: Int -> [Int] -> Q Exp
reindexTuple n is = withNames' "x" n (\xps xes ->
let
iset = Set.fromList is
xsp' = fmap (\(p,i) -> if i `member` iset then p else wildP)
(zip xps [0..])
in
lam1E (tupP xsp') (tupE (fmap (xes !!) is)))
reverseTuple :: Int -> Q Exp
reverseTuple n = reindexTuple n (reverse [0..n1])
rotateTuple :: Int -> Int -> Q Exp
rotateTuple n k = reindexTuple n (fmap (`mod` n) [nk, nk+1 .. 2*nk1])
sumTuple :: Int -> Q Exp
sumTuple 0 = litE (integerL 0)
sumTuple n = foldl1Tuple' n (varE '(+))
constTuple :: Int -> Q Exp
constTuple n = reindexTuple 1 (replicate n 0)
sequenceTuple :: Int -> Q Exp
sequenceTuple 0 = [| return () |]
sequenceTuple 1 = [| id :: Monad m => m a -> m a |]
sequenceTuple n =
withxs n (\xsp xes ->
lam1E xsp (foldl (\x y -> [| $(x) `ap` $(y) |])
[| $(conE $ tupleDataName n) `liftM` $(head xes) |]
(tail xes)))
sequenceATuple :: Int -> Q Exp
sequenceATuple 0 = [| pure () |]
sequenceATuple 1 = [| id :: Applicative f => f a -> f a |]
sequenceATuple n =
withxs n (\xsp xes ->
lam1E xsp (foldl (\x y -> [| $(x) <*> $(y) |])
[| $(conE $ tupleDataName n) <$> $(head xes) |]
(tail xes)))
descendingMultiindices :: Int -> Int -> [[Int]]
descendingMultiindices _ 0 = [[]]
descendingMultiindices n 1 = fmap (:[]) [0..n1]
descendingMultiindices n k | k < 0 = error ("Internal error in tuple-th: descendingMultiindices "++show n++" "++show k)
descendingMultiindices n k = [ i:is | is <- descendingMultiindices (n1) (k1),
i <- [head is+1,head is+2 .. n1] ]
subtuples :: Int -> Int -> Q Exp
subtuples n k = withxs n (\xsp xes ->
let
subtupleE :: [Int] -> ExpQ
subtupleE = tupE . fmap (xes !!)
in
lam1E xsp (tupE (fmap (subtupleE . reverse) (descendingMultiindices n k))))
deleteAtTuple :: Int -> Q Exp
deleteAtTuple n = do
i <- newName "_i"
lam1E (varP i) $
withxs n (\xsp xes ->
let
matches0 = [ match
(litP (integerL j))
(normalB . tupE . deleteAt j $ xes)
[]
| j <- [0 .. fromIntegral n 1] ]
errmsg1 = "deleteAtTuple "++show n++" "
errmsg2 = ": index out of bounds"
matches = matches0 ++ [
match wildP (normalB
[| error (errmsg1 ++ show $(varE i) ++ errmsg2) |])
[] ]
in
lam1E xsp $ caseE (varE i) matches)
where
deleteAt 0 (_:xs) = xs
deleteAt i (x:xs) = x : deleteAt (i1) xs
deleteAt _ _ = assert False undefined
takeTuple :: Int -> Int -> Q Exp
takeTuple n i = reindexTuple n [0..i1]
dropTuple :: Int -> Int -> Q Exp
dropTuple n i = reindexTuple n [i..n1]
cond :: [Q (Guard, Exp)] -> ExpQ -> ExpQ
cond branches otherwiseE =
caseE [|()|] [match wildP (guardedB (branches ++ [normalGE [|otherwise|] otherwiseE])) []]
safeDeleteTuple :: Int -> Q Exp
safeDeleteTuple n = do
e <- newName "_deletee"
withxs n (\xsp xes ->
lamE [varP e, xsp] (
let
ixes = zip [0::Int ..] xes
ges = map (\(i,xe) ->
normalGE
[| $(varE e) == $(xe) |]
[| Just $((tupE . map snd . filter ((/= i) . fst)) ixes) |]
)
ixes
in
cond ges [|Nothing|]))
proj' :: Int -> Q Exp
proj' n = do
i <- newName "_i"
withxs n (\xsp xes ->
lamE [varP i,xsp]
(caseE (varE i)
([ smatch (litP . integerL . fromIntegral $ j) [| Just $(xes !! j) |]
| j <- [0..n1] ]
++ [smatch wildP [|Nothing|]])))
findSuccessiveElementsSatisfying :: Int -> Q Exp
findSuccessiveElementsSatisfying n = do
r <- newName "_r"
withxs n (\xsp xes ->
lamE [varP r, xsp]
(cond
[ normalGE [| $(varE r) $(x0) $(x1) |]
[| Just ($(litE . integerL $ i) :: Int) |]
|
(i,x0,x1) <- zip3 [0..] xes (drop 1 xes) ]
[|Nothing|]))
updateAtN :: Int
-> Int
-> Q Exp
updateAtN n element = do
mapFunction <- newName "_f"
withxs n (\xsp xes -> do
when (element < 0 || element >= n) $
fail ("updateAtN "++show n++" "++show element++": Element index out of range")
let
(start, x:xs) = splitAt element xes
results = start ++ appE (varE mapFunction) x : xs
lamE [varP mapFunction] ( lamE [ xsp ] $ tupE results ))