module ADP.Fusion.Table where
import Control.Monad.Primitive
import Data.Array.Repa.Index
import Data.Array.Repa.Shape
import Data.Strict.Tuple
import Data.Vector.Fusion.Stream.Size
import qualified Data.Vector.Fusion.Stream.Monadic as S
import qualified Data.Vector.Unboxed as VU
import Data.Strict.Maybe
import Prelude hiding (Maybe(..))
import Data.Array.Repa.Index.Subword
import Data.Array.Repa.Index.Points
import Data.Array.Repa.ExtShape
import qualified Data.PrimitiveArray as PA
import qualified Data.PrimitiveArray.Zero as PA
import ADP.Fusion.Classes
import Debug.Trace
data MTbl i xs = MTbl !(ENZ i) !xs
mTblSw :: ENE -> PA.MutArr m (arr (Z:.Subword) x) -> MTbl Subword (PA.MutArr m (arr (Z:.Subword) x))
mTblSw = MTbl
mTbl :: ENZ i -> PA.MutArr m (arr i x) -> MTbl i (PA.MutArr m (arr i x))
mTbl = MTbl
class TableIndices i where
tableIndices :: Monad m => InOut i -> ENZ i -> i -> S.Stream m (ζ:!:α:!:i) -> S.Stream m (ζ:!:α:!:i)
instance TableIndices Z where
tableIndices Z Z Z = id
instance TableIndices Subword where
tableIndices _ ZeroT _ = error "TableIndices Subword/ZeroT does not make sense"
tableIndices Outer _ (Subword(i:.j)) = S.map (\(ζ:!:α:!:Subword(k:.l)) -> (ζ:!:α:!:subword l j))
tableIndices (Inner _ szd) ene (Subword(i:.j)) = S.flatten mk step Unknown where
mk (ζ:!:α:!:kl@(Subword(k:.l))) =
let le = l + case ene of { EmptyT -> 0 ; NonEmptyT -> 1 }
l' = case szd of { Nothing -> le ; Just z -> max le (jz) }
in return (ζ:!:α:!:l:!:l')
step (ζ:!:α:!:k:!:l)
| i>j = return S.Done
| otherwise = return $ S.Yield (ζ:!:α:!:subword k l) (ζ:!:α:!:k:!:l+1)
instance TableIndices is => TableIndices (is:.Subword) where
tableIndices (os:.Outer) (es:._) (is:.Subword(i:.j))
= S.map (\(ζ:!:(α:!:Subword(_:.l)):!:is) -> (ζ:!:α:!:(is:.subword l j)))
. tableIndices os es is
. S.map (\(ζ:!:α:!:(is:.i)) -> (ζ:!:(α:!:i):!:is))
tableIndices (os:.Inner _ szd) (es:.ZeroT) (is:.Subword(i:.j))
= S.map (\(ζ:!:(α:.Subword(k:.l)):!:is) -> (ζ:!:α:!:(is:.subword l l)))
. tableIndices os es is
. S.map (\(ζ:!:α:!:(is:.i)) -> (ζ:!:(α:.i):!:is))
tableIndices (os:.Inner _ szd) (es:.e) (is:.Subword(i:.j))
= S.flatten mk step Unknown
. tableIndices os es is
. S.map (\(ζ:!:α:!:(is:.i)) -> (ζ:!:(α:.i):!:is))
where mk (ζ:!:(α:.Subword (k:.l)):!:is) =
let le = l + case e of { EmptyT -> 0 ; NonEmptyT -> 1 }
l' = case szd of { Nothing -> le ; Just z -> max le (jz) }
in return (ζ:!:α:!:is:!:l:!:l')
step (ζ:!:α:!:is:!:k:!:l)
| l > j = return $ S.Done
| otherwise = return $ S.Yield (ζ:!:α:!:(is:.subword k l)) (ζ:!:α:!:is:!:k:!:l+1)
instance TableIndices is => TableIndices (is:.PointL) where
tableIndices (os:.Outer) (es:._) (is:.PointL(i:.j))
= S.map (\(ζ:!:(α:!:PointL(_:.l)):!:is) -> (ζ:!:α:!:(is:.pointL l j)))
. tableIndices os es is
. S.map (\(ζ:!:α:!:(is:.i)) -> (ζ:!:(α:!:i):!:is))
tableIndices (os:.Inner _ szd) (es:.ZeroT) (is:.PointL(i:.j))
= S.map (\(ζ:!:(α:.PointL(k:.l)):!:is) -> (ζ:!:α:!:(is:.pointL l l)))
. tableIndices os es is
. S.map (\(ζ:!:α:!:(is:.i)) -> (ζ:!:(α:.i):!:is))
tableIndices (os:.Inner _ szd) (es:.e) (is:.PointL(i:.j))
= S.flatten mk step Unknown
. tableIndices os es is
. S.map (\(ζ:!:α:!:(is:.i)) -> (ζ:!:(α:.i):!:is))
where mk (ζ:!:(α:.PointL (k:.l)):!:is) =
let le = l + case e of { EmptyT -> 0 ; NonEmptyT -> 1 }
l' = case szd of { Nothing -> le ; Just z -> max le (jz) }
in return (ζ:!:α:!:is:!:l:!:l')
step (ζ:!:α:!:is:!:k:!:l)
| l > j = return $ S.Done
| otherwise = return $ S.Yield (ζ:!:α:!:(is:.pointL k l)) (ζ:!:α:!:is:!:k:!:l+1)
instance Build (MTbl i x)
instance
( ValidIndex ls Subword
, Monad m
, PA.MPrimArrayOps arr (Z:.Subword) x
) => ValidIndex (ls:!:MTbl Subword (PA.MutArr m (arr (Z:.Subword) x))) Subword where
validIndex (_ :!: MTbl ZeroT _) _ _ = error "table with ZeroT found, there is no reason (actually: no implementation) for 1-dim ZeroT tables"
validIndex (ls :!: MTbl ene tbl) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =
let (_,Z:.Subword (0:.n)) = PA.boundsM tbl
minsize = max b (if ene==EmptyT then 0 else 1)
in i>=a && i+minsize<=j && j<=nc && validIndex ls abc ij
getParserRange (ls :!: MTbl ene _) ix = let (a:!:b:!:c) = getParserRange ls ix in if ene==EmptyT then (a:!:b:!:c) else (a:!:b+1:!:c)
instance
( Elms ls Subword
) => Elms (ls :!: MTbl Subword (PA.MutArr m (arr (Z:.Subword) x))) Subword where
data Elm (ls :!: MTbl Subword (PA.MutArr m (arr (Z:.Subword) x))) Subword = ElmMTblSw !(Elm ls Subword) !x !Subword
type Arg (ls :!: MTbl Subword (PA.MutArr m (arr (Z:.Subword) x))) = Arg ls :. x
getArg !(ElmMTblSw ls x _) = getArg ls :. x
getIdx !(ElmMTblSw _ _ i) = i
instance
( Monad m
, PrimMonad m
, Elms ls Subword
, MkStream m ls Subword
, PA.MPrimArrayOps arr (Z:.Subword) x
) => MkStream m (ls :!: MTbl Subword (PA.MutArr m (arr (Z:.Subword) x))) Subword where
mkStream !(ls:!:MTbl ene tbl) Outer !ij@(Subword (i:.j))
= S.mapM (\s -> let (Subword (_:.l)) = getIdx s in PA.readM tbl (Z:.subword l j) >>= \z -> return $ ElmMTblSw s z (subword l j))
$ mkStream ls (Inner Check Nothing) (subword i $ case ene of { EmptyT -> j ; NonEmptyT -> j1 })
mkStream !(ls:!:MTbl ene tbl) (Inner _ szd) !ij@(Subword (i:.j)) = S.flatten mk step Unknown $ mkStream ls (Inner NoCheck Nothing) ij where
mk !s = let (Subword (_:.l)) = getIdx s
le = l + case ene of { EmptyT -> 0 ; NonEmptyT -> 1}
l' = case szd of Nothing -> le
Just z -> max le (jz)
in return (s :!: l :!: l')
step !(s :!: k :!: l)
| l > j = return S.Done
| otherwise = PA.readM tbl (Z:.subword k l) >>= \z -> return $ S.Yield (ElmMTblSw s z (subword k l)) (s :!: k :!: l+1)
instance
( Elms ls (is:.i)
) => Elms (ls :!: MTbl (is:.i) (PA.MutArr m (arr (is:.i) x))) (is:.i) where
data Elm (ls :!: MTbl (is:.i) (PA.MutArr m (arr (is:.i) x))) (is:.i) = ElmMTbl !(Elm ls (is:.i)) !x !(is:.i)
type Arg (ls :!: MTbl (is:.i) (PA.MutArr m (arr (is:.i) x))) = Arg ls :. x
getArg !(ElmMTbl ls x _) = getArg ls :. x
getIdx !(ElmMTbl _ _ i) = i
instance
( Monad m
, PrimMonad m
, PA.MPrimArrayOps arr (is:.i) x
, Elms ls (is:.i)
, NonTermValidIndex (is:.i)
, TableIndices (is:.i)
, MkStream m ls (is:.i)
) => MkStream m (ls:!:MTbl (is:.i) (PA.MutArr m (arr (is:.i) x))) (is:.i) where
mkStream (ls :!: MTbl enz tbl) os is
= S.mapM (\(s:!:Z:!:β) -> PA.readM tbl β >>= \z -> return $ ElmMTbl s z β)
. tableIndices os enz is
. S.map (\s -> (s:!:Z:!:getIdx s))
$ mkStream ls (nonTermInnerOuter is os) (nonTermLeftIndex is os enz)
instance
( ValidIndex ls (is:.i)
, PA.MPrimArrayOps arr (is:.i) x
, NonTermValidIndex (is:.i)
) => ValidIndex (ls :!: MTbl (is:.i) (PA.MutArr m (arr (is:.i) x))) (is:.i) where
validIndex (ls :!: MTbl es tbl) abc isi =
let (_,rght) = PA.boundsM tbl
in nonTermValidIndex es rght abc isi && validIndex ls abc isi
getParserRange (ls :!: MTbl es _) ix = getNonTermParserRange es ix $ getParserRange ls ix
class NonTermValidIndex i where
nonTermValidIndex :: ENZ i -> i -> ParserRange i -> i -> Bool
getNonTermParserRange :: ENZ i -> i -> ParserRange i -> ParserRange i
nonTermInnerOuter :: i -> InOut i -> InOut i
nonTermLeftIndex :: i -> InOut i -> ENZ i -> i
instance NonTermValidIndex Z where
nonTermValidIndex Z Z Z Z = True
getNonTermParserRange Z Z Z = Z
nonTermInnerOuter Z Z = Z
nonTermLeftIndex Z Z Z = Z
instance NonTermValidIndex is => NonTermValidIndex (is:.Subword) where
nonTermValidIndex (es:.e) (ns:.Subword(_:.n)) (abc:.(a:!:b:!:c)) (is:.Subword(i:.j)) =
let minsize = max b (if e==EmptyT then 0 else 1)
in i>=a && i+minsize<=j && j<=nc && nonTermValidIndex es ns abc is
getNonTermParserRange (es:.e) (is:._) (abc:.(a:!:b:!:c)) =
let b' = b + if e==EmptyT then 0 else 1
in getNonTermParserRange es is abc :. (a:!:b':!:c)
nonTermInnerOuter (is:._) (os:.Outer) = nonTermInnerOuter is os :. Inner Check Nothing
nonTermInnerOuter (is:._) (os:.Inner _ _) = nonTermInnerOuter is os :. Inner NoCheck Nothing
nonTermLeftIndex (is:.Subword(i:.j)) (os:.o) (es:.e)
| o==Outer && e==NonEmptyT = nonTermLeftIndex is os es :. subword i (j1)
| otherwise = nonTermLeftIndex is os es :. subword i j
instance NonTermValidIndex is => NonTermValidIndex (is:.PointL) where
nonTermValidIndex (es:.e) (ns:.PointL(_:.n)) (abc:.(a:!:b:!:c)) (is:.PointL(i:.j)) =
let minsize = max b (if e==EmptyT then 0 else 1)
in i>=a && i+minsize<=j && j<=nc && nonTermValidIndex es ns abc is
getNonTermParserRange (es:.e) (is:._) (abc:.(a:!:b:!:c)) =
let b' = b + if e==EmptyT then 0 else 1
in getNonTermParserRange es is abc :. (a:!:b':!:c)
nonTermInnerOuter (is:._) (os:.Outer) = nonTermInnerOuter is os :. Inner Check Nothing
nonTermInnerOuter (is:._) (os:.Inner _ _) = nonTermInnerOuter is os :. Inner NoCheck Nothing
nonTermLeftIndex (is:.PointL(i:.j)) (os:.o) (es:.e)
| o==Outer && e==NonEmptyT = nonTermLeftIndex is os es :. pointL i (j1)
| otherwise = nonTermLeftIndex is os es :. pointL i j
data BtTbl i xs f = BtTbl !(ENZ i) !xs !f
btTbl :: ENZ i -> xs -> f -> BtTbl i xs f
btTbl = BtTbl
type DefBtTbl m isi x b = BtTbl isi (PA.Unboxed isi x) (isi -> m (S.Stream m b))
type SwBtTbl m x b = BtTbl Subword (PA.Unboxed (Z:.Subword) x) (Subword -> m (S.Stream m b))
instance Build (BtTbl i xs f)
instance
( Elms ls Subword
) => Elms (ls :!: SwBtTbl m x b) Subword where
data Elm (ls :!: SwBtTbl m x b) Subword = ElmSwBtTbl !(Elm ls Subword) !(x,m (S.Stream m b)) !Subword
type Arg (ls :!: SwBtTbl m x b) = Arg ls :. (x,m (S.Stream m b))
getArg !(ElmSwBtTbl ls x _) = getArg ls :. x
getIdx !(ElmSwBtTbl _ _ i) = i
instance
( Monad m
, Elms ls Subword
, VU.Unbox x
, MkStream m ls Subword
) => MkStream m (ls :!: SwBtTbl m x b) Subword where
mkStream !(ls:!:BtTbl ene tbl f) Outer !ij@(Subword (i:.j))
= S.mapM (\s -> let (Subword (_:.l)) = getIdx s in return $ ElmSwBtTbl s (tbl PA.! (Z:.subword l j), f $ subword l j) (subword l j))
$ mkStream ls (Inner Check Nothing) (subword i $ case ene of { EmptyT -> j ; NonEmptyT -> j1 })
mkStream !(ls:!:BtTbl ene tbl f) (Inner _ szd) !ij@(Subword (i:.j)) = S.flatten mk step Unknown $ mkStream ls (Inner NoCheck Nothing) ij where
mk !s = let (Subword (_:.l)) = getIdx s
le = l + case ene of { EmptyT -> 0 ; NonEmptyT -> 1}
l' = case szd of Nothing -> le
Just z -> max le (jz)
in return (s :!: l :!: l')
step !(s :!: k :!: l)
| l > j = return S.Done
| otherwise = return $ S.Yield (ElmSwBtTbl s (tbl PA.! (Z:.subword k l), f $ subword k l) (subword k l)) (s :!: k :!: l+1)
instance
( ValidIndex ls Subword
, VU.Unbox x
) => ValidIndex (ls :!: SwBtTbl m x b) Subword where
validIndex (_ :!: BtTbl ZeroT _ _) _ _ = error "table with ZeroT found, there is no reason (actually: no implementation) for 1-dim ZeroT tables"
validIndex (ls :!: BtTbl ene tbl _) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =
let (_,Z:.Subword (0:.n)) = PA.bounds tbl
minsize = max b (if ene==EmptyT then 0 else 1)
in i>=a && i+minsize<=j && j<=nc && validIndex ls abc ij
getParserRange (ls :!: BtTbl ene _ f) ix = let (a:!:b:!:c) = getParserRange ls ix in if ene==EmptyT then (a:!:b:!:c) else (a:!:b+1:!:c)
instance
( Elms ls (is:.i)
) => Elms (ls :!: DefBtTbl m (is:.i) x b) (is:.i) where
data Elm (ls :!: DefBtTbl m (is:.i) x b) (is:.i) = ElmBtTbl !(Elm ls (is:.i)) !(x,m (S.Stream m b)) !(is:.i)
type Arg (ls :!: DefBtTbl m (is:.i) x b) = Arg ls :. (x,m (S.Stream m b))
getArg !(ElmBtTbl ls x _) = getArg ls :. x
getIdx !(ElmBtTbl _ _ i) = i
instance
( Monad m
, Elms ls (is:.i)
, ExtShape (is:.i)
, Shape (is:.i)
, VU.Unbox x
, NonTermValidIndex (is:.i)
, TableIndices (is:.i)
, MkStream m ls (is:.i)
) => MkStream m (ls:!:DefBtTbl m (is:.i) x b) (is:.i) where
mkStream (ls :!: BtTbl enz tbl f) os is
= S.map (\(s:!:Z:!:β) -> ElmBtTbl s (tbl PA.! β,f β) β)
. tableIndices os enz is
. S.map (\s -> (s:!:Z:!:getIdx s))
$ mkStream ls (nonTermInnerOuter is os) (nonTermLeftIndex is os enz)
instance
( ValidIndex ls (is:.i)
, Shape (is:.i)
, ExtShape (is:.i)
, VU.Unbox x
, NonTermValidIndex (is:.i)
) => ValidIndex (ls :!: DefBtTbl m (is:.i) x b) (is:.i) where
validIndex (ls :!: BtTbl es tbl f) abc isi =
let (_,rght) = PA.bounds tbl
in nonTermValidIndex es rght abc isi && validIndex ls abc isi
getParserRange (ls :!: BtTbl es _ _) ix = getNonTermParserRange es ix $ getParserRange ls ix
class EmptyTable x where
toEmptyT :: x -> x
toNonEmptyT :: x -> x
instance (EmptyENZ (ENZ i)) => EmptyTable (MTbl i xs) where
toEmptyT (MTbl enz xs) = MTbl (toEmptyENZ enz) xs
toNonEmptyT (MTbl enz xs) = MTbl (toNonEmptyENZ enz) xs
instance (EmptyENZ (ENZ i)) => EmptyTable (BtTbl i xs f) where
toEmptyT (BtTbl enz xs f) = BtTbl (toEmptyENZ enz) xs f
toNonEmptyT (BtTbl enz xs f) = BtTbl (toNonEmptyENZ enz) xs f