module ADP.Fusion.SynVar.Array.Subword where
import Data.Strict.Tuple
import Data.Vector.Fusion.Stream.Size
import Data.Vector.Fusion.Util (delay_inline)
import Data.Vector.Fusion.Stream.Monadic
import Debug.Trace
import Prelude hiding (map,mapM)
import Data.PrimitiveArray hiding (map)
import ADP.Fusion.Base
import ADP.Fusion.SynVar.Array.Type
import ADP.Fusion.SynVar.Backtrack
instance
( Monad m
, Element ls Subword
, PrimArrayOps arr Subword x
, MkStream m ls Subword
) => MkStream m (ls :!: ITbl m arr Subword x) Subword where
mkStream (ls :!: ITbl _ _ c t _) (IStatic ()) hh (Subword (i:.j))
= map (\s -> let (Subword (_:.l)) = getIdx s
in ElmITbl (t ! subword l j) (subword l j) (subword 0 0) s)
$ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j minSize c))
mkStream (ls :!: ITbl _ _ c t _) (IVariable ()) hh (Subword (i:.j))
= flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j minSize c))
where mk s = let Subword (_:.l) = getIdx s in return (s :. j l minSize c)
step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
l = j z
kl = subword k l
return $ Yield (ElmITbl (t ! kl) kl (subword 0 0) s) (s:. z1)
| otherwise = return $ Done
instance
( Monad mB
, Element ls Subword
, MkStream mB ls Subword
, PrimArrayOps arr Subword x
) => MkStream mB (ls :!: Backtrack (ITbl mF arr Subword x) mF mB r) Subword where
mkStream (ls :!: BtITbl c t bt) (IStatic ()) hh ij@(Subword (i:.j))
= mapM (\s -> let Subword (_:.l) = getIdx s
lj = subword l j
in bt hh lj >>= \ ~bb -> return $ ElmBtITbl (t ! lj) (bb ) lj (subword 0 0) s)
$ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j minSize c))
mkStream (ls :!: BtITbl c t bt) (IVariable ()) hh ij@(Subword (i:.j))
= flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j minSize c))
where mk s = let Subword (_:.l) = getIdx s in return (s :. j l minSize c)
step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
l = j z
kl = subword k l
bt hh kl >>= \ ~bb -> return $ Yield (ElmBtITbl (t ! kl) (bb ) kl (subword 0 0) s) (s:.z1)
| otherwise = return $ Done
instance
( Monad m
, Element ls (Outside Subword)
, PrimArrayOps arr (Outside Subword) x
, MkStream m ls (Outside Subword)
) => MkStream m (ls :!: ITbl m arr (Outside Subword) x) (Outside Subword) where
mkStream (ls :!: ITbl _ _ c t _) (OStatic (di:.dj)) u ij@(O (Subword (i:.j)))
= map (\s -> let O (Subword (k:._)) = getOmx s
kj = O $ Subword (k:.j+dj)
in ElmITbl (t ! kj) (O $ Subword (i:.j+dj)) kj s)
$ mkStream ls (OFirstLeft (di:.dj)) u ij
mkStream (ls :!: ITbl _ _ c t _) (ORightOf (di:.dj)) u@(O (Subword (_:.h))) ij@(O (Subword (i:.j)))
= flatten mk step Unknown $ mkStream ls (OFirstLeft (di:.dj)) u ij
where mk s = return (s:.j+dj)
step (s:.l) | l <= h = do let (O (Subword (k:._))) = getIdx s
kl = O $ Subword (k:.l)
return $ Yield (ElmITbl (t ! kl) (O (Subword (j+dj:.j+dj))) kl s) (s:.l+1)
| otherwise = return $ Done
mkStream (ls :!: ITbl _ _ c t _) (OFirstLeft d) u ij = error "Array/Outside Subword : OFirstLeft : should never be reached!"
mkStream (ls :!: ITbl _ _ c t _) (OLeftOf d) u ij = error "Array/Outside Subword : OLeftOf : should never be reached!"
instance
( Monad m
, Element ls (Outside Subword)
, PrimArrayOps arr Subword x
, MkStream m ls (Outside Subword)
) => MkStream m (ls :!: ITbl m arr Subword x) (Outside Subword) where
mkStream (ls :!: ITbl _ _ c t _) (OStatic (di:.dj)) u ij@(O (Subword (i:.j)))
= map (\s -> let O (Subword (_:.k)) = getIdx s
o@(O (Subword (_:.l))) = getOmx s
kl = Subword (kdj:.ldj)
in ElmITbl (t ! kl) (O (Subword (k:.l))) o s)
$ mkStream ls (ORightOf (di:.dj)) u ij
mkStream (ls :!: ITbl _ _ c t _) (ORightOf d) u@(O (Subword (_:.h))) ij@(O (Subword (i:.j)))
= flatten mk step Unknown $ mkStream ls (ORightOf d) u ij
where mk s = let O (Subword (_:.l)) = getIdx s
in return (s :.l:.l + minSize c)
step (s:.k:.l)
| let O (Subword (_:.o)) = getOmx s
, l <= o = do let kl = Subword (k:.l)
return $ Yield (ElmITbl (t ! kl) (O kl) (getOmx s) s) (s:.k:.l+1)
| otherwise = return $ Done
mkStream (ls :!: ITbl _ _ c t _) (OFirstLeft (di:.dj)) u ij@(O (Subword (i:.j)))
= map (\s -> let O (Subword (l:._)) = getOmx s
O (Subword (_:.k)) = getIdx s
kl = Subword (k:.idi)
in ElmITbl (t ! kl) (O kl) (getOmx s) s)
$ mkStream ls (OLeftOf (di:.dj)) u ij
mkStream (ls :!: ITbl _ _ c t _) (OLeftOf d) u ij@(O (Subword (i:.j)))
= flatten mk step Unknown $ mkStream ls (OLeftOf d) u ij
where mk s = let O (Subword (_:.l)) = getIdx s in return (s:.l)
step (s:.l) | l <= i = do let O (Subword (_:.k)) = getIdx s
kl = Subword (k:.l)
return $ Yield (ElmITbl (t ! kl) (O kl) (getOmx s) s) (s:.l+1)
| otherwise = return $ Done
instance
( Monad m
, Element ls (Complement Subword)
, PrimArrayOps arr Subword x
, MkStream m ls (Complement Subword)
) => MkStream m (ls :!: ITbl m arr Subword x) (Complement Subword) where
mkStream (ls :!: ITbl _ _ c t _) Complemented u ij
= map (\s -> let (C ix) = getIdx s
in ElmITbl (t ! ix) (C ix) (getOmx s) s)
$ mkStream ls Complemented u ij
instance
( Monad m
, Element ls (Complement Subword)
, PrimArrayOps arr (Outside Subword) x
, MkStream m ls (Complement Subword)
) => MkStream m (ls :!: ITbl m arr (Outside Subword) x) (Complement Subword) where
mkStream (ls :!: ITbl _ _ c t _) Complemented u ij
= map (\s -> let (C ox) = getOmx s
in ElmITbl (t ! (O ox)) (getIdx s) (C ox) s)
$ mkStream ls Complemented u ij
instance ModifyConstraint (ITbl m arr Subword x) where
toNonEmpty (ITbl b l _ arr f) = ITbl b l NonEmpty arr f
toEmpty (ITbl b l _ arr f) = ITbl b l EmptyOk arr f
instance ModifyConstraint (Backtrack (ITbl mF arr Subword x) mF mB r) where
toNonEmpty (BtITbl _ arr bt) = BtITbl NonEmpty arr bt
toEmpty (BtITbl _ arr bt) = BtITbl EmptyOk arr bt