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
import GHC.Prim (reallyUnsafePtrEquality#)
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
instance
( Monad m
, Element ls Subword
, FirstSecond ls (arr (Z:.Subword:.Subword) x)
, FirstSecondIdx ls (arr (Z:.Subword:.Subword) x) Subword
, PrimArrayOps arr (Z:.Subword:.Subword) x
, MkStream m ls Subword
, Show x
) => MkStream m (ls :!: ITbl m arr (Z:.Subword:.Subword) x) Subword where
mkStream (ls :!: ITbl _ _ c t elm) (IStatic ()) hh (Subword (i:.j))
= map (\s -> let (Subword (_:.l)) = getIdx s
ab = if greenLight ls t
then greenIdx ls (undefined :: Subword) t s
else subword 0 0
in
ElmITbl (t ! (Z:.ab:.subword l j)) (subword l j) (subword 0 0) s)
$ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j 0))
mkStream (ls :!: ITbl _ _ c t elm) (IVariable ()) hh (Subword (i:.j))
= flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j 0))
where mk s = let Subword (_:.l) = getIdx s in return (s :. j l 0)
step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
l = j z
kl = subword k l
ab = if greenLight ls t
then greenIdx ls (undefined :: Subword) t s
else subword 0 0
return $ Yield (ElmITbl (t ! (Z:.ab:.kl)) kl (subword 0 0) s) (s:.z1)
| otherwise = return $ Done
instance
( Monad mB
, FirstSecond ls (arr (Z:.Subword:.Subword) x)
, FirstSecondIdx ls (arr (Z:.Subword:.Subword) x) Subword
, PrimArrayOps arr (Z:.Subword:.Subword) x
, Element ls Subword
, MkStream mB ls Subword
, Show r
) => MkStream mB (ls :!: Backtrack (ITbl mF arr (Z:.Subword:.Subword) x) mF mB r) Subword where
mkStream (ls :!: BtITbl c t bt) (IStatic ()) hh (Subword (i:.j))
= mapM (\s -> let (Subword (_:.l)) = getIdx s
lj = subword l j
light = greenLight ls t
ab = if light
then greenIdx ls (undefined :: Subword) t s
else lj
ablj = if light
then Z:.ab:.lj
else Z:.subword 0 0:.subword 0 0
in bt (Prelude.snd $ bounds t) ablj >>= \ ~bb -> return $ ElmBtITbl (t ! ablj) bb lj (subword 0 0) s)
$ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j 0))
mkStream (ls :!: BtITbl c t bt) (IVariable ()) hh (Subword (i:.j))
= flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j 0))
where mk s = let Subword (_:.l) = getIdx s in return (s :. j l 0)
step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
l = j z
kl = subword k l
light = greenLight ls t
ab = if light
then greenIdx ls (undefined :: Subword) t s
else kl
abkl = if light
then Z:.ab:.kl
else Z:.subword 0 0:.subword 0 0
bt (Prelude.snd $ bounds t) abkl >>= \ ~bb -> return $ Yield (ElmBtITbl (t!abkl) bb kl (subword 0 0) s) (s:.z1)
| otherwise = return $ Done
class FirstSecond x k where
greenLight :: x -> k -> Bool
class FirstSecondIdx x k i where
greenIdx :: x -> i -> k -> Elm x i -> Subword
instance FirstSecond S k where
greenLight S _ = False
instance
( FirstSecond ls (arr (Z:.Subword:.Subword) x)
) => FirstSecond (ls :!: ITbl m arr (Z:.Subword:.Subword) x) (arr (Z:.Subword:.Subword) x) where
greenLight (ls :!: ITbl _ _ _ t _) t' =
case reallyUnsafePtrEquality# t t' of
1# -> True
_ -> greenLight ls t'
instance
( FirstSecond ls (arr (Z:.Subword:.Subword) x)
) => FirstSecond (ls :!: Backtrack (ITbl mF arr (Z:.Subword:.Subword) x) mF mB r) (arr (Z:.Subword:.Subword) x) where
greenLight (ls :!: BtITbl _ t _) t' =
case reallyUnsafePtrEquality# t t' of
1# -> True
_ -> greenLight ls t'
instance FirstSecondIdx S k i where
greenIdx S _ _ _ = error "shouldn't arrive here!"
instance
( FirstSecondIdx ls (arr (Z:.Subword:.Subword) x) Subword
, Elm ls Subword ~ RecElm (ls :!: ITbl m arr (Z:.Subword:.Subword) x) Subword
, Element ls Subword
) => FirstSecondIdx (ls :!: ITbl m arr (Z:.Subword:.Subword) x) (arr (Z:.Subword:.Subword) x) Subword where
greenIdx (ls :!: ITbl _ _ _ t _) _ t' e =
case reallyUnsafePtrEquality# t t' of
1# -> let ab = getIdx e in ab
_ -> let g = getElm e in greenIdx ls (undefined :: Subword) t' g
instance
( FirstSecondIdx ls (arr (Z:.Subword:.Subword) x) Subword
, Elm ls Subword ~ RecElm (ls :!: Backtrack (ITbl mF arr (Z:.Subword:.Subword) x) mF mB r) Subword
, Element ls Subword
) => FirstSecondIdx (ls :!: Backtrack (ITbl mF arr (Z:.Subword:.Subword) x) mF mB r) (arr (Z:.Subword:.Subword) x) Subword where
greenIdx (ls :!: BtITbl _ t _) _ t' e =
case reallyUnsafePtrEquality# t t' of
1# -> let ab = getIdx e in ab
_ -> let g = getElm e in greenIdx ls (undefined :: Subword) t' g