module ADP.Fusion.Classes where
import Data.Array.Repa.Index
import Data.Strict.Maybe
import Data.Strict.Tuple
import Data.Vector.Fusion.Stream.Size
import Prelude hiding (Maybe(..))
import qualified Data.Vector.Fusion.Stream.Monadic as S
import qualified Prelude as P
import Data.Array.Repa.Index.Subword
import Data.Array.Repa.Index.Outside
import Data.Array.Repa.Index.Points
data CheckNoCheck
= Check
| NoCheck
deriving (Eq,Show)
data InnerOuter
= Inner !CheckNoCheck !(Maybe Int)
| Outer
deriving (Eq,Show)
data ENE
= EmptyT
| NonEmptyT
| ZeroT
deriving (Eq,Show)
class Elms x i where
data Elm x i :: *
type Arg x :: *
getArg :: Elm x i -> Arg x
getIdx :: Elm x i -> i
class Index i where
type InOut i :: *
type ENZ i :: *
type PartialIndex i :: *
type ParserRange i :: *
outer :: i -> InOut i
leftPartialIndex :: i -> PartialIndex i
rightPartialIndex :: i -> PartialIndex i
fromPartialIndices :: PartialIndex i -> PartialIndex i -> i
class EmptyENZ enz where
toEmptyENZ :: enz -> enz
toNonEmptyENZ :: enz -> enz
class (Monad m) => MkStream m x i where
mkStream :: x -> InOut i -> i -> S.Stream m (Elm x i)
class Build x where
type Stack x :: *
type Stack x = Z :!: x
build :: x -> Stack x
default build :: (Stack x ~ (Z :!: x)) => x -> Stack x
build x = Z :!: x
class (Index i) => ValidIndex x i where
validIndex :: x -> ParserRange i -> i -> Bool
getParserRange :: x -> i -> ParserRange i
checkValidIndex x i = validIndex x (getParserRange x i) i
outerCheck :: Monad m => Bool -> S.Stream m a -> S.Stream m a
outerCheck b (S.Stream step sS n) = b `seq` S.Stream snew (Left (b,sS)) Unknown where
snew (Left (False,s)) = return $ S.Done
snew (Left (True ,s)) = return $ S.Skip (Right s)
snew (Right s ) = do r <- step s
case r of
S.Yield x s' -> return $ S.Yield x (Right s')
S.Skip s' -> return $ S.Skip (Right s')
S.Done -> return $ S.Done
instance EmptyENZ ENE where
toEmptyENZ ene | ene==NonEmptyT = EmptyT
| otherwise = ene
toNonEmptyENZ ene | ene==EmptyT = NonEmptyT
| otherwise = ene
instance Index PointL where
type InOut PointL = InnerOuter
type ENZ PointL = ENE
type PartialIndex PointL = Int
type ParserRange PointL = (Int:!:Int:!:Int)
outer _ = Outer
leftPartialIndex (PointL (i:.j)) = i
rightPartialIndex (PointL (i:.j)) = j
fromPartialIndices i j = pointL i j
instance ValidIndex Z PointL where
validIndex _ _ _ = True
getParserRange _ _ = (0 :!: 0 :!: 0)
instance Index Subword where
type InOut Subword = InnerOuter
type ENZ Subword = ENE
type PartialIndex Subword = Int
type ParserRange Subword = (Int :!: Int :!: Int)
outer _ = Outer
leftPartialIndex (Subword (i:.j)) = i
rightPartialIndex (Subword (i:.j)) = j
fromPartialIndices i j = subword i j
instance
( Monad m
) => MkStream m Z Subword where
mkStream Z Outer !(Subword (i:.j)) = S.unfoldr step i where
step !k
| k==j = P.Just $ (ElmZ (subword i i), j+1)
| otherwise = P.Nothing
mkStream Z (Inner NoCheck Nothing) !(Subword (i:.j)) = S.singleton $ ElmZ $ subword i i
mkStream Z (Inner NoCheck (Just z)) !(Subword (i:.j)) = S.unfoldr step i where
step !k
| k<=j && k+z>=j = P.Just $ (ElmZ (subword i i), j+1)
| otherwise = P.Nothing
mkStream Z (Inner Check Nothing) !(Subword (i:.j)) = S.unfoldr step i where
step !k
| k<=j = P.Just $ (ElmZ (subword i i), j+1)
| otherwise = P.Nothing
mkStream Z (Inner Check (Just z)) !(Subword (i:.j)) = S.unfoldr step i where
step !k
| k<=j && k+z>=j = P.Just $ (ElmZ (subword i i), j+1)
| otherwise = P.Nothing
instance ValidIndex Z Subword where
validIndex _ _ _ = True
getParserRange _ _ = (0 :!: 0 :!: 0)
instance Index Outside where
type InOut Outside = InnerOuter
type ENZ Outside = ENE
type PartialIndex Outside = Int
type ParserRange Outside = (Int :!: Int :!: Int)
outer _ = Outer
leftPartialIndex (Outside (i:.j)) = error "outside: not sure yet"
rightPartialIndex (Outside (i:.j)) = error "outside: not sure yet"
fromPartialIndices i j = error "outside: not sure yet"
instance
( Monad m
) => MkStream m Z Outside where
instance ValidIndex Z Outside where
validIndex _ _ _ = True
getParserRange _ _ = (0 :!: 0 :!: 0)
instance Index Z where
type InOut Z = Z
type ENZ Z = Z
type PartialIndex Z = Z
type ParserRange Z = Z
outer Z = Z
leftPartialIndex Z = Z
rightPartialIndex Z = Z
fromPartialIndices Z Z = Z
instance EmptyENZ Z where
toEmptyENZ _ = Z
toNonEmptyENZ _ = Z
instance
(
) => Elms Z ix where
data Elm Z ix = ElmZ !ix
type Arg Z = Z
getArg !(ElmZ _) = Z
getIdx !(ElmZ ix) = ix
instance Monad m => MkStream m Z Z where
mkStream _ _ _ = S.singleton (ElmZ Z)
instance ValidIndex Z Z where
validIndex _ _ _ = True
getParserRange _ _ = Z
instance (Index is, Index i) => Index (is:.i) where
type InOut (is:.i) = InOut is :. InOut i
type ENZ (is:.i) = ENZ is :. ENZ i
type PartialIndex (is:.i) = PartialIndex is :. PartialIndex i
type ParserRange (is:.i) = ParserRange is :. ParserRange i
outer (is:.i) = outer is :. outer i
leftPartialIndex (is:.i) = leftPartialIndex is :. leftPartialIndex i
rightPartialIndex (is:.i) = rightPartialIndex is :. rightPartialIndex i
fromPartialIndices (is:.i) (js:.j) = fromPartialIndices is js :. fromPartialIndices i j
instance (EmptyENZ es, EmptyENZ e) => EmptyENZ (es:.e) where
toEmptyENZ (es:.e) = toEmptyENZ es :. toEmptyENZ e
toNonEmptyENZ (es:.e) = toNonEmptyENZ es :. toNonEmptyENZ e
instance (ValidIndex Z is, ValidIndex Z i) => ValidIndex Z (is:.i) where
validIndex _ _ _ = True
getParserRange Z (is:.i) = getParserRange Z is :. getParserRange Z i
instance
( Monad m
, MkStream m Z is
) => MkStream m Z (is:.Subword) where
mkStream Z (io:.Outer) (is:.Subword (i:.j))
= S.map (\(ElmZ jt) -> ElmZ (jt:.subword i i)) . S.filter (const $ i==j) $ mkStream Z io is
mkStream Z (io:.Inner NoCheck Nothing) (is:.Subword (i:.j))
= S.map (\(ElmZ jt) -> ElmZ (jt:.subword i i)) $ mkStream Z io is
mkStream Z (io:.Inner NoCheck (Just z)) (is:.Subword (i:.j))
= S.map (\(ElmZ jt) -> ElmZ (jt:.subword i i)) . S.filter (const $ i<=j && i+z>=j) $ mkStream Z io is
mkStream Z (io:.Inner Check Nothing) (is:.Subword (i:.j))
= S.map (\(ElmZ jt) -> ElmZ (jt:.subword i i)) . S.filter (const $ i<=j) $ mkStream Z io is
mkStream Z (io:.Inner Check (Just z)) (is:.Subword (i:.j))
= S.map (\(ElmZ jt) -> ElmZ (jt:.subword i i)) . S.filter (const $ i<=j && i+z>=j) $ mkStream Z io is
instance
( Monad m
, MkStream m Z is
) => MkStream m Z (is:.PointL) where
mkStream Z (io:.Outer) (is:.PointL (i:.j))
= S.map (\(ElmZ jt) -> ElmZ (jt:.pointL i i)) . S.filter (const $ i==j) $ mkStream Z io is
mkStream Z (io:.Inner NoCheck Nothing) (is:.PointL (i:.j))
= S.map (\(ElmZ jt) -> ElmZ (jt:.pointL i i)) $ mkStream Z io is
mkStream Z (io:.Inner NoCheck (Just z)) (is:.PointL (i:.j))
= S.map (\(ElmZ jt) -> ElmZ (jt:.pointL i i)) . S.filter (const $ i<=j && i+z>=j) $ mkStream Z io is
mkStream Z (io:.Inner Check Nothing) (is:.PointL (i:.j))
= S.map (\(ElmZ jt) -> ElmZ (jt:.pointL i i)) . S.filter (const $ i<=j) $ mkStream Z io is
mkStream Z (io:.Inner Check (Just z)) (is:.PointL (i:.j))
= S.map (\(ElmZ jt) -> ElmZ (jt:.pointL i i)) . S.filter (const $ i<=j && i+z>=j) $ mkStream Z io is
instance Build x => Build (x:!:y) where
type Stack (x:!:y) = Stack x :!: y
build (x:!:y) = build x :!: y