module ADP.Fusion.TH.Backtrack where
import Data.List
import Data.Tuple.Select
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import qualified Data.Vector.Fusion.Stream.Monadic as SM
import qualified Data.Vector.Mutable as VM
import qualified Data.Vector.Generic.Mutable as VGM
import qualified Data.Vector as V
import qualified Data.Vector.Generic as VG
import Control.Monad.Primitive (PrimState, PrimMonad)
import Data.Vector.Fusion.Stream.Monadic (Stream(..))
import Debug.Trace
import ADP.Fusion.TH.Common
class BacktrackingProduct sigF sigB where
type SigR sigF sigB :: *
(<||) :: sigF -> sigB -> SigR sigF sigB
makeBacktrackingProductInstance :: Name -> Q [Dec]
makeBacktrackingProductInstance tyconName = do
t <- reify tyconName
case t of
TyConI (DataD ctx tyConName args cs d) -> do
let m = getMonadName args
case cs of
[RecC dataconName funs] -> do
let Just (h,m',x,r) = getObjectiveNames funs
mL <- newName "mL"
xL <- newName "xL"
mR <- newName "mR"
xR <- newName "xR"
rR <- newName "rR"
let lType = buildLeftType tyconName (m', x, r) (mL, xL) args
let rType = buildRightType tyconName (m', x, r) (mR, xR, rR) args
let sigRType = buildSigRType tyconName (m', x, r) xL (mR, xR, rR) args
let (fs,hs) = partition ((`notElem` [h]) . sel1) funs
Clause ps (NormalB b) ds <- genClauseBacktrack dataconName funs fs hs
i <- [d| instance (Monad $(varT mL), Monad $(varT mR), Eq $(varT xL), $(varT mL) ~ $(varT mR)) => BacktrackingProduct $(return lType) $(return rType) where
type SigR $(return lType) $(return rType) = $(return sigRType)
(<||) = $(return $ LamE ps $ LetE ds b)
|]
return i
getMonadName :: [TyVarBndr] -> Maybe Name
getMonadName = go
where go [] = Nothing
go (KindedTV m (AppT (AppT ArrowT StarT) StarT) : _) = Just m
go (_ : xs) = go xs
getObjectiveNames :: [VarStrictType] -> Maybe (Name,Name,Name,Name)
getObjectiveNames = go
where go [] = Nothing
go ( (hName , _ , (AppT (AppT ArrowT (AppT (AppT (ConT streamName) (VarT mS)) (VarT x))) (AppT (VarT mR) (VarT r)))) : xs)
| streamName == ''Stream && mS == mR = Just (hName,mS,x,r)
| otherwise = go xs
go ( _ : xs) = go xs
buildLeftType :: Name -> (Name, Name, Name) -> (Name, Name) -> [TyVarBndr] -> Type
buildLeftType tycon (m, x, r) (mL, xL) = foldl AppT (ConT tycon) . map (VarT . go)
where go (PlainTV z)
| z == m = mL
| z == x = xL
| z == r = xL
| otherwise = z
go (KindedTV z _) = go (PlainTV z)
buildRightType :: Name -> (Name, Name, Name) -> (Name, Name, Name) -> [TyVarBndr] -> Type
buildRightType tycon (m, x, r) (mR, xR, rR) = foldl AppT (ConT tycon) . map (VarT . go)
where go (PlainTV z)
| z == m = mR
| z == x = xR
| z == r = rR
| otherwise = z
go (KindedTV z _) = go (PlainTV z)
buildSigRType :: Name -> (Name, Name, Name) -> (Name) -> (Name, Name, Name) -> [TyVarBndr] -> Type
buildSigRType tycon (m, x, r) (xL) (mR, xR, rR) = foldl AppT (ConT tycon) . map go
where go (PlainTV z)
| z == m = VarT mR
| z == x = (AppT (AppT (TupleT 2) (VarT xL)) (AppT ListT (VarT xR)))
| z == r = VarT rR
| otherwise = VarT z
go (KindedTV z _) = go (PlainTV z)
genClauseBacktrack
:: Name
-> [VarStrictType]
-> [VarStrictType]
-> [VarStrictType]
-> Q Clause
genClauseBacktrack conName allFunNames evalFunNames choiceFunNames = do
let nonTermNames = nub . map getRuleResultType $ evalFunNames
nameL <- newName "l"
varL <- varP nameL
fnmsL <- sequence $ replicate (length allFunNames) (newName "fnamL")
nameR <- newName "r"
varR <- varP nameR
fnmsR <- sequence $ replicate (length allFunNames) (newName "fnamR")
whereL <- valD (conP conName (map varP fnmsL)) (normalB $ varE nameL) []
whereR <- valD (conP conName (map varP fnmsR)) (normalB $ varE nameR) []
rce <- recConE conName
$ zipWith3 (genChoiceFunction) (drop (length evalFunNames) fnmsL) (drop (length evalFunNames) fnmsR) choiceFunNames
++ zipWith3 (genAttributeFunction nonTermNames) fnmsL fnmsR evalFunNames
let cls = Clause [varL, varR] (NormalB rce) [whereL,whereR]
return cls
genChoiceFunction
:: Name
-> Name
-> VarStrictType
-> Q (Name,Exp)
genChoiceFunction hL hR (name,_,t) = do
exp <- buildBacktrackingChoice hL hR
return (name,exp)
genAttributeFunction
:: [Name]
-> Name
-> Name
-> VarStrictType
-> Q (Name,Exp)
genAttributeFunction nts fL fR (name,_,t) = do
(lamPat,funL,funR) <-recBuildLamPat nts fL fR (init $ getRuleSynVarNames t)
let exp = LamE lamPat $ TupE [funL,funR]
return (name,exp)
recBuildLamPat :: [Name] -> Name -> Name -> [Name] -> Q ([Pat], Exp, Exp)
recBuildLamPat nts fL' fR' ts = do
ps <- sequence [ if t `elem` nts then tupP [newName "x" >>= varP, newName "ys" >>= varP] else (newName "t" >>= varP) | t<-ts]
let buildLfun f (TupP [VarP v,_]) = appE f (varE v)
buildLfun f (VarP v ) = appE f (varE v)
lfun <- foldl buildLfun (varE fL') ps
rfun <- buildRns (VarE fR') ps
return (ps, lfun, rfun)
buildRns
:: Exp
-> [Pat]
-> ExpQ
buildRns f ps = do
ys <- sequence [ newName "y" | TupP [_,VarP v] <- ps ]
let vs = zipWith (\y v -> (BindS (VarP y) (VarE v))) ys [ v | TupP [_,VarP v] <- ps ]
let xs = go ps ys
ff <- noBindS $ foldl (\g z -> appE g (varE z)) (return f) xs
return $ CompE $ vs ++ [ff]
where go [] [] = []
go (VarP v : gs) ys = v : go gs ys
go (TupP _ : gs) (v:ys) = v : go gs ys
go as bs = error $ show ("not done?", as, bs)
buildBacktrackingChoice :: Name -> Name -> Q Exp
buildBacktrackingChoice hL' hR' =
[| \xs -> do
ysM <- streamToVector xs
hFres <- $(varE hL') $ SM.map fst $ vectorToStream ysM
$(varE hR') $ SM.concatMap (SM.fromList . snd) $ SM.filter ((hFres==) . fst) $ vectorToStream ysM
|]
streamToVector :: (Monad m) => SM.Stream m x -> m (V.Vector x)
streamToVector xs = do
l <- SM.toList xs
let v = V.fromList l
return v
vectorToStream :: (Monad m) => V.Vector x -> SM.Stream m x
vectorToStream = SM.fromList . V.toList
getRuleSynVarNames :: Type -> [Name]
getRuleSynVarNames t' = go t' where
go t
| VarT x <- t = [x]
| AppT (AppT ArrowT (VarT x )) y <- t = x : go y
| AppT (AppT ArrowT (AppT _ _)) y <- t = mkName "[]" : go y
| AppT (AppT ArrowT (TupleT 0)) y <- t = mkName "()" : go y
| otherwise = error $ "getRuleSynVarNames error: " ++ show t ++ " in: " ++ show t'