diff --git a/ADP/Fusion.hs b/ADP/Fusion.hs
--- a/ADP/Fusion.hs
+++ b/ADP/Fusion.hs
@@ -1,12 +1,122 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
 
--- | Pure combinators along the lines of original ADP. We simply re-export the
--- monadic interface without the monadic function application combinator.
+-- | Generalized fusion system for grammars.
+--
+-- NOTE Symbols typically do not check bound data for consistency. If you, say,
+-- bind a terminal symbol to an input of length 0 and then run your grammar,
+-- you probably get errors, garbled data or random crashes. Such checks are
+-- done via asserts in non-production code.
+--
+-- TODO each combinator should come with a special outer check. Given some
+-- index (say (i,j), this can then check if i-const >= 0, or j+const<=n, or
+-- i+const<=j. That should speed up everything that uses GChr combinators.
+-- Separating out this check means that certain inner loops can run without any
+-- conditions and just jump.
 
 module ADP.Fusion
-  ( module ADP.Fusion.Monadic
-  , module ADP.Fusion.Monadic.Internal
+  -- basic combinators
+  ( (<<<)
+  , (<<#)
+  , (|||)
+  , (...)
+  , (~~)
+  , (%)
+  -- filters
+  , check
+  -- parsers
+  , chr
+  , chrLeft
+  , chrRight
+  , peekL
+  , peekR
+  , empty
+  , region
+  , sregion
+--  , Tbl (..)
+--  , BtTbl (..)
+  , MTbl (..)
+  , ENE (..)
+  , ENZ (..)
+  , None (..)
   ) where
 
-import ADP.Fusion.Monadic hiding ((#<<))
-import ADP.Fusion.Monadic.Internal (Scalar(..))
+import Data.Strict.Tuple
+import GHC.Exts (inline)
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+
+import ADP.Fusion.Apply
+import ADP.Fusion.Chr
+import ADP.Fusion.Classes
+import ADP.Fusion.Empty
+import ADP.Fusion.Region
+import ADP.Fusion.Table
+import ADP.Fusion.None
+
+
+
+-- | Apply a function to symbols on the RHS of a production rule. Builds the
+-- stack of symbols from 'xs' using 'build', then hands this stack to
+-- 'mkStream' together with the initial 'iniT' telling 'mkStream' that we are
+-- in the "outer" position. Once the stream has been created, we 'S.map'
+-- 'getArg' to get just the arguments in the stack, and finally 'apply' the
+-- function 'f'.
+
+infixl 8 <<<
+(<<<) f xs = \ij -> outerCheck (checkValidIndex (build xs) ij) . S.map (apply (inline f) . getArg) . mkStream (build xs) (outer ij) $ ij
+{-# INLINE (<<<) #-}
+
+infixl 8 <<#
+(<<#) f xs = \ij -> outerCheck (checkValidIndex (build xs) ij) . S.mapM (apply (inline f) . getArg) . mkStream (build xs) (outer ij) $ ij
+{-# INLINE (<<#) #-}
+
+-- | Combine two RHSs to give a choice between parses.
+
+infixl 7 |||
+(|||) xs ys = \ij -> xs ij S.++ ys ij
+{-# INLINE (|||) #-}
+
+-- | Applies the objective function 'h' to a stream 's'. The objective function
+-- reduces the stream to a single optimal value (or some vector of co-optimal
+-- things).
+
+infixl 5 ...
+(...) s h = h . s
+{-# INLINE (...) #-}
+
+-- | Additional outer check with user-given check function
+
+infixl 6 `check`
+check xs f = \ij -> let chk = f ij in chk `seq` outerCheck chk (xs ij)
+{-# INLINE check #-}
+
+-- | Separator between RHS symbols.
+
+infixl 9 ~~
+(~~) = (:!:)
+{-# INLINE (~~) #-}
+
+-- | This separator looks much paper "on paper" and is not widely used otherwise.
+
+infixl 9 %
+(%) = (:!:)
+{-# INLINE (%) #-}
+
+
+
+
+
+
+
+
diff --git a/ADP/Fusion/Apply.hs b/ADP/Fusion/Apply.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Apply.hs
@@ -0,0 +1,91 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module ADP.Fusion.Apply where
+
+import Data.Array.Repa.Index
+
+
+
+-- * Apply function 'f' in '(<<<)'
+
+class Apply x where
+  type Fun x :: *
+  apply :: Fun x -> x
+
+instance Apply (Z:.a -> res) where
+  type Fun (Z:.a -> res) = a -> res
+  apply fun (Z:.a) = fun a
+  {-# INLINE apply #-}
+
+instance Apply (Z:.a:.b -> res) where
+  type Fun (Z:.a:.b -> res) = a->b -> res
+  apply fun (Z:.a:.b) = fun a b
+  {-# INLINE apply #-}
+
+instance Apply (Z:.a:.b:.c -> res) where
+  type Fun (Z:.a:.b:.c -> res) = a->b->c -> res
+  apply fun (Z:.a:.b:.c) = fun a b c
+  {-# INLINE apply #-}
+
+instance Apply (Z:.a:.b:.c:.d -> res) where
+  type Fun (Z:.a:.b:.c:.d -> res) = a->b->c->d -> res
+  apply fun (Z:.a:.b:.c:.d) = fun a b c d
+  {-# INLINE apply #-}
+
+instance Apply (Z:.a:.b:.c:.d:.e -> res) where
+  type Fun (Z:.a:.b:.c:.d:.e -> res) = a->b->c->d->e -> res
+  apply fun (Z:.a:.b:.c:.d:.e) = fun a b c d e
+  {-# INLINE apply #-}
+
+instance Apply (Z:.a:.b:.c:.d:.e:.f -> res) where
+  type Fun (Z:.a:.b:.c:.d:.e:.f -> res) = a->b->c->d->e->f -> res
+  apply fun (Z:.a:.b:.c:.d:.e:.f) = fun a b c d e f
+  {-# INLINE apply #-}
+
+instance Apply (Z:.a:.b:.c:.d:.e:.f:.g -> res) where
+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g -> res) = a->b->c->d->e->f->g -> res
+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g) = fun a b c d e f g
+  {-# INLINE apply #-}
+
+instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h -> res) where
+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h -> res) = a->b->c->d->e->f->g->h -> res
+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h) = fun a b c d e f g h
+  {-# INLINE apply #-}
+
+instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) where
+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) = a->b->c->d->e->f->g->h->i -> res
+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i) = fun a b c d e f g h i
+  {-# INLINE apply #-}
+
+instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) where
+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) = a->b->c->d->e->f->g->h->i->j -> res
+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j) = fun a b c d e f g h i j
+  {-# INLINE apply #-}
+
+instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) where
+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) = a->b->c->d->e->f->g->h->i->j->k -> res
+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k) = fun a b c d e f g h i j k
+  {-# INLINE apply #-}
+
+instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) where
+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) = a->b->c->d->e->f->g->h->i->j->k->l -> res
+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l) = fun a b c d e f g h i j k l
+  {-# INLINE apply #-}
+
+instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) where
+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m -> res
+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m) = fun a b c d e f g h i j k l m
+  {-# INLINE apply #-}
+
+instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) where
+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n -> res
+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n) = fun a b c d e f g h i j k l m n
+  {-# INLINE apply #-}
+
+instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) where
+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n->o -> res
+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o) = fun a b c d e f g h i j k l m n o
+  {-# INLINE apply #-}
+
diff --git a/ADP/Fusion/Chr.hs b/ADP/Fusion/Chr.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Chr.hs
@@ -0,0 +1,306 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module ADP.Fusion.Chr where
+
+import Data.Array.Repa.Index
+import Data.Strict.Tuple
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+import qualified Data.Vector.Unboxed as VU
+import qualified Data.Vector.Generic as VG
+import Data.Strict.Maybe
+import Prelude hiding (Maybe(..))
+
+import Data.Array.Repa.Index.Subword
+
+import ADP.Fusion.Classes
+
+import Debug.Trace
+
+
+
+-- | Parses a single character.
+
+chr xs = GChr (VG.unsafeIndex) xs
+{-# INLINE chr #-}
+
+-- | Parses a single character and returns the character to the left in a
+-- strict Maybe.
+
+chrLeft xs = GChr f xs where
+  f xs k = ( xs VG.!? (k-1)
+           , VG.unsafeIndex xs k
+           )
+  {-# INLINE f #-}
+{-# INLINE chrLeft #-}
+
+-- With default character
+
+chrLeftD d xs = GChr f xs where
+  f xs k = ( Prelude.maybe d id $ xs VG.!? (k-1)
+           , VG.unsafeIndex xs k
+           )
+  {-# INLINE f #-}
+{-# INLINE chrLeftD #-}
+
+-- | Parses a single character and returns the character to the right in a
+-- strict Maybe.
+
+chrRight xs = GChr f xs where
+  f xs k = ( VG.unsafeIndex xs k
+           , xs VG.!? (k+1)
+           )
+  {-# INLINE f #-}
+{-# INLINE chrRight #-}
+
+-- | A generic Character parser that reads a single character but allows
+-- passing additional information.
+
+data GChr r x where -- = forall v . VG.Vector v x =>
+  GChr :: VG.Vector v x => !(v x -> Int -> r) -> !(v x) -> GChr r x
+
+instance Build (GChr r x)
+
+instance
+  ( ValidIndex ls Subword
+  ) => ValidIndex (ls :!: GChr r x) Subword where
+    validIndex (ls :!: GChr _ xs) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =
+      i>=a && j<=VG.length xs -c && i+b<=j && validIndex ls abc ij
+    {-# INLINE validIndex #-}
+    getParserRange (ls :!: GChr _ _) ix = let (a:!:b:!:c) = getParserRange ls ix in (a:!:b+1:!:max 0 (c-1))
+    {-# INLINE getParserRange #-}
+
+instance
+  ( Elms ls Subword
+  ) => Elms (ls :!: GChr r x) Subword where
+    data Elm (ls :!: GChr r x) Subword = ElmGChr !(Elm ls Subword) !r !Subword
+    type Arg (ls :!: GChr r x) = Arg ls :. r
+    getArg !(ElmGChr ls x _) = getArg ls :. x
+    getIdx !(ElmGChr _ _ idx) = idx
+    {-# INLINE getArg #-}
+    {-# INLINE getIdx #-}
+
+instance
+  ( Monad m
+  , Elms ls Subword
+  , MkStream m ls Subword
+  ) => MkStream m (ls :!: GChr r x) Subword where
+  mkStream !(ls :!: GChr f xs) Outer !ij@(Subword (i:.j)) =
+    let dta = f xs (j-1)
+    in  dta `seq` S.map (\s -> ElmGChr s dta (subword (j-1) j)) $ mkStream ls Outer (subword i $ j-1)
+  mkStream !(ls :!: GChr f xs) (Inner cnc szd) !ij@(Subword (i:.j))
+    = S.map (\s -> let Subword (k:.l) = getIdx s
+                   in  ElmGChr s (f xs l) (subword l $ l+1)
+            )
+    $ mkStream ls (Inner cnc szd) (subword i $ j-1)
+  {-# INLINE mkStream #-}
+
+-- | Wrapping a GChr to allow zero/one behaviour. Parses a character (or not)
+-- in a strict maybe.
+
+newtype ZeroOne r x = ZeroOne { unZeroOne :: GChr r x }
+
+zoLeft xs = ZeroOne $ chrLeft xs
+{-# INLINE zoLeft #-}
+
+
+
+-- | Generalized peek.
+
+data GPeek r x = GPeek !(VU.Vector x -> Int -> r) !(VU.Vector x) !(Int:!:Int)
+
+instance Build (GPeek r x)
+
+instance
+  ( ValidIndex ls Subword
+  , VU.Unbox x
+  ) => ValidIndex (ls :!: GPeek r x) Subword where
+    validIndex (ls :!: GPeek _ xs _) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =
+      i>=a && j<VU.length xs -c && i+b<=j && validIndex ls abc ij
+    {-# INLINE validIndex #-}
+    getParserRange (ls :!: GPeek _ _ (a':!:c')) ix =
+      let (a:!:b:!:c) = getParserRange ls ix in (a+a' :!: b :!: (c+c'))
+    {-# INLINE getParserRange #-}
+
+instance
+  ( Elms ls Subword
+  ) => Elms (ls :!: GPeek r x) Subword where
+    data Elm (ls :!: GPeek r x) Subword = ElmGPeek !(Elm ls Subword) !r !Subword
+    type Arg (ls :!: GPeek r x) = Arg ls :. r
+    getArg !(ElmGPeek ls x _) = getArg ls :. x
+    getIdx !(ElmGPeek _ _ idx) = idx
+    {-# INLINE getArg #-}
+    {-# INLINE getIdx #-}
+
+instance
+  ( Monad m
+  , VU.Unbox x
+  , Elms ls Subword
+  , MkStream m ls Subword
+  ) => MkStream m (ls :!: GPeek r x) Subword where
+  mkStream !(ls :!: GPeek f xs _) Outer !ij@(Subword (i:.j)) =
+    let dta = f xs (j-1)
+    in  dta `seq` S.map (\s -> ElmGPeek s dta (subword j j)) $ mkStream ls Outer ij
+  mkStream !(ls :!: GPeek f xs _) (Inner cnc szd) !ij@(Subword (i:.j))
+    = S.map (\s -> let (Subword (k:.l)) = getIdx s
+                   in  ElmGPeek s (f xs (l-1)) (subword l l)
+            )
+    $ mkStream ls (Inner cnc szd) ij
+  {-# INLINE mkStream #-}
+
+
+{-
+-- * Parse a single character.
+
+data Chr x = Chr !(VU.Vector x)
+
+--chr = Chr
+--{-# INLINE chr #-}
+
+instance
+  ( ValidIndex ls Subword
+  , VU.Unbox xs
+  ) => ValidIndex (ls :!: Chr xs) Subword where
+    validIndex (ls :!: Chr xs) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =
+      let
+      in  i>=a && j<VU.length xs -c && i+b<=j && validIndex ls abc ij
+    {-# INLINE validIndex #-}
+    getParserRange (ls :!: Chr xs) ix = let (a:!:b:!:c) = getParserRange ls ix in (a:!:b+1:!:max 0 (c-1))
+    {-# INLINE getParserRange #-}
+
+instance Build (Chr x)
+
+instance
+  ( Elms ls Subword
+  ) => Elms (ls :!: Chr x) Subword where
+  data Elm (ls :!: Chr x) Subword = ElmChr !(Elm ls Subword) !x !Subword
+  type Arg (ls :!: Chr x) = Arg ls :. x
+  getArg !(ElmChr ls x _) = getArg ls :. x
+  getIdx !(ElmChr _ _ idx) = idx
+  {-# INLINE getArg #-}
+  {-# INLINE getIdx #-}
+
+-- |
+--
+-- For 'Outer' cases, we extract the data, 'seq' it and then stream. This moves
+-- extraction out of the loop.
+
+instance
+  ( Monad m
+  , Elms ls Subword
+  , MkStream m ls Subword
+  ) => MkStream m (ls :!: Chr x) Subword where
+  mkStream !(ls :!: Chr xs) Outer !ij@(Subword(i:.j)) =
+    let dta = VG.unsafeIndex xs (j-1)
+    in  dta `seq` S.map (\s -> ElmChr s dta (subword (j-1) j)) $ mkStream ls Outer (subword i $ j-1)
+  mkStream !(ls :!: Chr xs) (Inner cnc szd) !ij@(Subword(i:.j))
+    = S.map (\s -> let (Subword (k:.l)) = getIdx s
+                   in  ElmChr s (VG.unsafeIndex xs l) (subword l $ l+1)
+            )
+    $ mkStream ls (Inner cnc szd) (subword i $ j-1)
+  {-# INLINE mkStream #-}
+-}
+
+
+
+-- * Peeking to the left
+
+data PeekL x = PeekL !(VU.Vector x)
+
+peekL = PeekL
+{-# INLINE peekL #-}
+
+instance Build (PeekL x)
+
+instance
+  ( ValidIndex ls Subword
+  , VU.Unbox x
+  ) => ValidIndex (ls :!: PeekL x) Subword where
+  validIndex (ls :!: PeekL xs) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =
+    i>=a && j<=VU.length xs -c && i+b<=j && validIndex ls abc ij
+  {-# INLINE validIndex #-}
+  getParserRange (ls :!: PeekL xs) ix = let (a:!:b:!:c) = getParserRange ls ix in if b==0 then (a+1:!:b:!:c) else (a:!:b:!:c)
+  {-# INLINE getParserRange #-}
+
+instance
+  ( Elms ls Subword
+  ) => Elms (ls :!: PeekL x) Subword where
+  data Elm (ls :!: PeekL x) Subword = ElmPeekL !(Elm ls Subword) !x !Subword
+  type Arg (ls :!: PeekL x) = Arg ls :. x
+  getArg !(ElmPeekL ls x _) = getArg ls :. x
+  getIdx !(ElmPeekL _ _ idx) = idx
+  {-# INLINE getArg #-}
+  {-# INLINE getIdx #-}
+
+instance
+  ( Monad m
+  , VU.Unbox x
+  , Elms ls Subword
+  , MkStream m ls Subword
+  ) => MkStream m (ls :!: PeekL x) Subword where
+  mkStream !(ls :!: PeekL xs) Outer !ij@(Subword(i:.j)) =
+    let dta = VU.unsafeIndex xs (j-1)
+    in  dta `seq` S.map (\s -> ElmPeekL s dta (subword j j)) $ mkStream ls Outer ij
+  mkStream !(ls :!: PeekL xs) (Inner cnc szd) !ij@(Subword(i:.j))
+    = S.map (\s -> let (Subword (k:.l)) = getIdx s
+                   in  ElmPeekL s (VU.unsafeIndex xs $ l-1) (subword l l)
+            )
+    $ mkStream ls (Inner cnc szd) ij
+  {-# INLINE mkStream #-}
+
+
+
+-- * Peeking to the right
+
+data PeekR x = PeekR !(VU.Vector x)
+
+peekR = PeekR
+{-# INLINE peekR #-}
+
+instance Build (PeekR x)
+
+instance
+  ( ValidIndex ls Subword
+  , VU.Unbox x
+  ) => ValidIndex (ls :!: PeekR x) Subword where
+  validIndex (ls :!: PeekR xs) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =
+    i>=a && j<=VU.length xs -c && i+b<=j && validIndex ls abc ij
+  {-# INLINE validIndex #-}
+  getParserRange (ls :!: PeekR xs) ix = let (a:!:b:!:c) = getParserRange ls ix in (a:!:b:!:c+1)
+  {-# INLINE getParserRange #-}
+
+instance
+  ( Elms ls Subword
+  ) => Elms (ls :!: PeekR x) Subword where
+  data Elm (ls :!: PeekR x) Subword = ElmPeekR !(Elm ls Subword) !x !Subword
+  type Arg (ls :!: PeekR x) = Arg ls :. x
+  getArg !(ElmPeekR ls x _) = getArg ls :. x
+  getIdx !(ElmPeekR _ _ idx) = idx
+  {-# INLINE getArg #-}
+  {-# INLINE getIdx #-}
+
+instance
+  ( Monad m
+  , VU.Unbox x
+  , Elms ls Subword
+  , MkStream m ls Subword
+  ) => MkStream m (ls :!: PeekR x) Subword where
+  mkStream !(ls :!: PeekR xs) Outer !ij@(Subword(i:.j)) =
+    let dta = VU.unsafeIndex xs j
+    in  dta `seq` S.map (\s -> ElmPeekR s dta (subword j j)) $ mkStream ls Outer ij
+  mkStream !(ls :!: PeekR xs) (Inner cnc szd) !ij@(Subword(i:.j))
+    = S.map (\s -> let (Subword (k:.l)) = getIdx s
+                   in  ElmPeekR s (VU.unsafeIndex xs l) (subword l l)
+            )
+    $ mkStream ls (Inner cnc szd) ij
+  {-# INLINE mkStream #-}
+
diff --git a/ADP/Fusion/Classes.hs b/ADP/Fusion/Classes.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Classes.hs
@@ -0,0 +1,396 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+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 and type constructors
+
+-- | The Inner/Outer handler. We encode three states. We are in 'Outer' or
+-- right-most position, or 'Inner' position. The 'Inner' position encodes if
+-- loop conditional 'CheckNoCheck' need to be performed.
+--
+-- In f <<< Z % table % table, the two tables already perform a conditional
+-- branch, so that Z/table does not have to check boundary conditions.
+--
+-- In f <<< Z % table % char, no check is performed in table/char, so Z/table
+-- needs to perform a boundary check.
+
+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)
+
+
+
+-- * Classes
+
+-- |
+
+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)
+
+-- | Build the stack using (%)
+
+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
+  {-# INLINE build #-}
+
+-- | 'ValidIndex', via 'validIndex' statically checks if an index 'i' is valid
+-- for a stack of terminals and non-terminals 'x'. 'validIndex' is used to
+-- short-circuit streams via 'outerCheck'.
+
+class (Index i) => ValidIndex x i where
+  validIndex :: x -> ParserRange i -> i -> Bool
+  getParserRange :: x -> i -> ParserRange i
+
+
+
+-- * Helper functions
+
+-- | Correct wrapping of 'validIndex' and 'getParserRange'.
+
+checkValidIndex x i = validIndex x (getParserRange x i) i
+{-# INLINE checkValidIndex #-}
+
+-- | 'outerCheck' acts as a static filter. If 'b' is true, we keep all stream
+-- elements. If 'b' is false, we discard all stream elements.
+
+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
+  {-# INLINE [1] snew #-}
+  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
+{-# INLINE outerCheck #-}
+
+
+
+-- * Instances
+
+
+
+-- ** Unsorted
+
+instance EmptyENZ ENE where
+  toEmptyENZ ene  | ene==NonEmptyT = EmptyT
+                  | otherwise      = ene
+  toNonEmptyENZ ene | ene==EmptyT  = NonEmptyT
+                    | otherwise    = ene
+  {-# INLINE toEmptyENZ #-}
+  {-# INLINE toNonEmptyENZ #-}
+
+
+
+-- ** PointL
+
+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
+  {-# INLINE outer #-}
+  {-# INLINE leftPartialIndex #-}
+  {-# INLINE rightPartialIndex #-}
+  {-# INLINE fromPartialIndices #-}
+
+instance ValidIndex Z PointL where
+  {-# INLINE validIndex #-}
+  {-# INLINE getParserRange #-}
+  validIndex _ _ _ = True
+  getParserRange _ _ = (0 :!: 0 :!: 0)
+
+
+
+-- ** 'Subword'
+
+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
+  {-# INLINE outer #-}
+  {-# INLINE leftPartialIndex #-}
+  {-# INLINE rightPartialIndex #-}
+  {-# INLINE fromPartialIndices #-}
+
+-- | The bottom of every stack of RHS arguments in a grammar.
+
+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
+  {-# INLINE mkStream #-}
+
+instance ValidIndex Z Subword where
+  {-# INLINE validIndex #-}
+  {-# INLINE getParserRange #-}
+  validIndex _ _ _ = True
+  getParserRange _ _ = (0 :!: 0 :!: 0)
+
+
+
+-- ** Outside
+
+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" -- i
+  rightPartialIndex (Outside (i:.j)) = error "outside: not sure yet" -- j
+  fromPartialIndices i j = error "outside: not sure yet" -- outside i j
+  {-# INLINE outer #-}
+  {-# INLINE leftPartialIndex #-}
+  {-# INLINE rightPartialIndex #-}
+  {-# INLINE fromPartialIndices #-}
+
+-- | The bottom of every stack of RHS arguments in a grammar.
+
+instance
+  ( Monad m
+  ) => MkStream m Z Outside where
+  {-
+  mkStream Z Outer !(Outside (i:.j)) = S.unfoldr step i where
+    step !k
+      | k==j      = P.Just $ (ElmZ (outside i i), j+1)
+      | otherwise = P.Nothing
+  mkStream Z (Inner NoCheck Nothing)  !(Outside (i:.j)) = S.singleton $ ElmZ $ outside i i
+  mkStream Z (Inner NoCheck (Just z)) !(Outside (i:.j)) = S.unfoldr step i where
+    step !k
+      | k<=j && k+z>=j = P.Just $ (ElmZ (outside i i), j+1)
+      | otherwise      = P.Nothing
+  mkStream Z (Inner Check Nothing)   !(Outside (i:.j)) = S.unfoldr step i where
+    step !k
+      | k<=j      = P.Just $ (ElmZ (outside i i), j+1)
+      | otherwise = P.Nothing
+  mkStream Z (Inner Check (Just z)) !(Outside (i:.j)) = S.unfoldr step i where
+    step !k
+      | k<=j && k+z>=j = P.Just $ (ElmZ (outside i i), j+1)
+      | otherwise      = P.Nothing
+  {-# INLINE mkStream #-}
+  -}
+
+instance ValidIndex Z Outside where
+  {-# INLINE validIndex #-}
+  {-# INLINE getParserRange #-}
+  validIndex _ _ _ = True
+  getParserRange _ _ = (0 :!: 0 :!: 0)
+
+
+
+-- ** 'Z'
+
+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
+  {-# INLINE outer #-}
+  {-# INLINE leftPartialIndex #-}
+  {-# INLINE rightPartialIndex #-}
+  {-# INLINE fromPartialIndices #-}
+
+instance EmptyENZ Z where
+  toEmptyENZ _ = Z
+  toNonEmptyENZ _ = Z
+  {-# INLINE toEmptyENZ #-}
+  {-# INLINE toNonEmptyENZ #-}
+
+instance
+  (
+  ) => Elms Z ix where
+  data Elm Z ix = ElmZ !ix
+  type Arg Z = Z
+  getArg !(ElmZ _) = Z
+  getIdx !(ElmZ ix) = ix
+  {-# INLINE getArg #-}
+  {-# INLINE getIdx #-}
+
+instance Monad m => MkStream m Z Z where
+  mkStream _ _ _ = S.singleton (ElmZ Z)
+  {-# INLINE mkStream #-}
+
+instance ValidIndex Z Z where
+  {-# INLINE validIndex #-}
+  {-# INLINE getParserRange #-}
+  validIndex _ _ _ = True
+  getParserRange _ _ = Z
+
+
+
+-- * Multi-dim instances
+
+-- ** '(is:.i)'
+
+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
+  {-# INLINE outer #-}
+  {-# INLINE leftPartialIndex #-}
+  {-# INLINE rightPartialIndex #-}
+  {-# INLINE fromPartialIndices #-}
+
+instance (EmptyENZ es, EmptyENZ e) => EmptyENZ (es:.e) where
+  toEmptyENZ (es:.e) = toEmptyENZ es :. toEmptyENZ e
+  toNonEmptyENZ (es:.e) = toNonEmptyENZ es :. toNonEmptyENZ e
+  {-# INLINE toEmptyENZ #-}
+  {-# INLINE toNonEmptyENZ #-}
+
+instance (ValidIndex Z is, ValidIndex Z i) => ValidIndex Z (is:.i) where
+  {-# INLINE validIndex #-}
+  {-# INLINE getParserRange #-}
+  validIndex _ _ _ = True
+  getParserRange Z (is:.i) = getParserRange Z is :. getParserRange Z i
+
+
+
+-- ** multi-dim with Subword
+
+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
+  {-# INLINE mkStream #-}
+
+
+
+-- ** multi-dim with PointL
+
+-- TODO automatically created, check correctness
+
+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
+  {-# INLINE mkStream #-}
+
+
+
+
+
+-- * Special instances
+
+instance Build x => Build (x:!:y) where
+  type Stack (x:!:y) = Stack x :!: y
+  build (x:!:y) = build x :!: y
+  {-# INLINE build #-}
+
diff --git a/ADP/Fusion/Empty.hs b/ADP/Fusion/Empty.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Empty.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module ADP.Fusion.Empty where
+
+import Data.Array.Repa.Index
+import Data.Strict.Maybe
+import Data.Strict.Tuple
+import Prelude hiding (Maybe(..))
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+
+import Data.Array.Repa.Index.Subword
+
+import ADP.Fusion.Classes
+
+
+
+data Empty = Empty
+
+empty = Empty
+{-# INLINE empty #-}
+
+instance
+  ( ValidIndex ls Subword
+  ) => ValidIndex (ls :!: Empty) Subword where
+    validIndex (ls:!:Empty) abc ij@(Subword (i:.j)) = i==j && validIndex ls abc ij
+    {-# INLINE validIndex #-}
+
+instance Build Empty
+
+instance
+  ( Elms ls Subword
+  ) => Elms (ls :!: Empty) Subword where
+  data Elm (ls :!: Empty) Subword = ElmEmpty !(Elm ls Subword) !() !Subword
+  type Arg (ls :!: Empty) = Arg ls :. ()
+  getArg !(ElmEmpty ls () _) = getArg ls :. ()
+  getIdx !(ElmEmpty _ _ i)   = i
+  {-# INLINE getArg #-}
+  {-# INLINE getIdx #-}
+
+instance
+  ( Monad m
+  , Elms ls Subword
+  , MkStream m ls Subword
+  ) => MkStream m (ls:!:Empty) Subword where
+  mkStream !(ls:!:Empty) Outer !ij@(Subword (i:.j))
+    = S.map (\s -> ElmEmpty s () (subword i j))
+    $ S.filter (\_ -> i==j)
+    $ mkStream ls Outer ij
+  {-# INLINE mkStream #-}
+
diff --git a/ADP/Fusion/Examples/Palindrome.hs b/ADP/Fusion/Examples/Palindrome.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Examples/Palindrome.hs
@@ -0,0 +1,118 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module ADP.Fusion.Examples.Palindrome where
+
+import Data.Vector.Fusion.Stream.Monadic (Stream (..))
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+import qualified Data.Vector.Unboxed as VU
+import qualified Data.Vector as V
+import Data.Array.Repa.Index
+import Control.Monad
+import Control.Monad.Trans.Class
+import qualified Control.Monad.Trans.Writer.Lazy as W
+import qualified Control.Arrow as A
+
+import Data.PrimitiveArray as PA
+import Data.PrimitiveArray.Zero as PA
+
+import ADP.Fusion hiding (empty)
+import ADP.Fusion.Empty hiding (empty)
+import ADP.Fusion.Chr
+import ADP.Fusion.Table
+import Data.Array.Repa.Index.Subword
+import ADP.Fusion.TH
+
+
+
+data SignatureT m x r = Signature
+  { pair  :: Char -> x -> Char -> x
+  , empty :: () -> x
+  , h     :: Stream m x -> m r
+  }
+
+-- makeAlgebraProduct ''SignatureT
+
+{-
+
+-- gPalindrome :: Signature m x -> Empty -> Char -> tbl -> (tbl, Subword -> m x)
+
+gPalindrome Signature{..} e c s =
+  ( s, (  empty <<< e         |||
+          pair  <<< c % s % c ... h
+       )
+  )
+{-# INLINE gPalindrome #-}
+
+
+
+aPair :: Monad m => Signature m Int Int
+aPair = Signature
+  { pair = \l x r -> if l==r then (x+4983) else -999999
+  , empty = \() -> 4711
+  , h = S.foldl' max (-888888)
+  }
+{-# INLINE aPair #-}
+
+aPretty :: Monad m => Signature m String (Stream m String)
+aPretty = Signature
+  { pair = \l x r -> "(" ++ x ++ ")"
+  , empty = \() -> ""
+  , h = return . id
+  }
+
+(<**) :: (Monad m, CombElem x' x) => Signature m x x' -> Signature m y y' -> Signature m (x,Stream m y) y'
+(<**) x y = Signature
+  { pair = \l (zx,zy) r -> (pair x l zx r, S.map (\z -> pair y l z r) zy)
+  , empty = \() -> (empty x (), S.singleton $ empty y ())
+  , h = \zs -> do hfst <- h x $ S.map fst zs
+                  h y $ S.concatMap snd . S.filter (combElem hfst . fst) $ zs
+  }
+{-# INLINE (<**) #-}
+
+(***) :: (Monad m) => Signature m x x' -> Signature m y y' -> Signature m (x,y) (x',y')
+(***) x y = Signature
+  { pair = \l (zx,zy) r -> (pair x l zx r, pair y l zy r)
+  , empty = \() -> (empty x (), empty y ())
+--  , h = \zs -> do hfst <- h x $ S.map fst zs
+--                  let phfs = S.concatMap snd . S.filter (combElem hfst . fst) $ zs
+--                  hsnd <- h y phfs
+  }
+{-# INLINE (***) #-}
+
+class CombElem x y where
+  combElem :: x -> y -> Bool
+
+instance (Eq x) => CombElem x x where
+  combElem = (==)
+
+instance (VU.Unbox x, Eq x) => CombElem (VU.Vector x) x where
+  combElem xs y = VU.elem y xs
+
+instance (Eq x) => CombElem (V.Vector x) x where
+  combElem xs y = V.elem y xs
+
+palindromeFill :: VU.Vector Char -> IO (PA.Unboxed (Z:.Subword) Int)
+palindromeFill inp = do
+  let n = VU.length inp
+  !t' <- newWithM (Z:.subword 0 0) (Z:.subword 0 n) 0
+  let t= mTblSw EmptyT t'
+  let b = chr inp
+  let e = Empty
+  fillTable $ gPalindrome aPair e b t
+  freeze t'
+{-# NOINLINE palindromeFill #-}
+
+fillTable (MTbl _ tbl, f) = do
+  let (_,Z:.Subword (0:.n)) = boundsM tbl
+  forM_ [n,n-1..0] $ \i -> forM_ [i..n] $ \j -> do
+    (f $ subword i j) >>= writeM tbl (Z:.subword i j)
+{-# INLINE fillTable #-}
+
+-}
+
diff --git a/ADP/Fusion/Examples/TwoDim.hs b/ADP/Fusion/Examples/TwoDim.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Examples/TwoDim.hs
@@ -0,0 +1,98 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- | This is not really a working example, but rather to check the GHC-Core for
+-- fusion.
+
+--module ADP.Fusion.Examples.TwoDim where
+module Main where
+
+import Data.Vector.Fusion.Stream.Monadic (Stream (..))
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+import qualified Data.Vector.Unboxed as VU
+import qualified Data.Vector as V
+import Data.Array.Repa.Index
+import Control.Monad
+import Control.Monad.Trans.Class
+import qualified Control.Monad.Trans.Writer.Lazy as W
+import qualified Control.Arrow as A
+import System.IO.Unsafe (unsafePerformIO)
+import Control.Applicative
+
+import Data.Array.Repa.Index.Points
+import Data.PrimitiveArray as PA
+import Data.PrimitiveArray.Zero as PA
+
+import ADP.Fusion hiding (empty)
+import ADP.Fusion.Empty hiding (empty)
+import ADP.Fusion.Chr
+import ADP.Fusion.Table
+import ADP.Fusion.Multi
+import Data.Array.Repa.Index.Subword
+import ADP.Fusion.TH
+
+
+
+main = do
+  ls <- lines <$> getContents
+  align ls
+
+align [] = return ()
+align [c] = error "single last line"
+align (a:b:xs) = do
+  putStrLn a
+  putStrLn b
+  print $ needlemanWunsch (VU.fromList a) (VU.fromList b)
+  align xs
+
+data Signature m x r c = Signature
+  { step_step :: x -> (Z:.c :.c ) -> x
+  , step_loop :: x -> (Z:.c :.()) -> x
+  , loop_step :: x -> (Z:.():.c ) -> x
+  , nil_nil   ::      (Z:.():.()) -> x
+  , h         :: Stream m x -> m r
+  }
+
+-- grammar :: Signature m x r c -> ???
+grammar Signature{..} a i1 i2 =
+  ( a, step_step <<< a % (T:!chr i1:!chr i2) |||
+       step_loop <<< a % (T:!chr i1:!None  ) |||
+       loop_step <<< a % (T:!None  :!chr i2) |||
+       nil_nil   <<< (T:!Empty:!Empty)       ... h
+  )
+{-# INLINE grammar #-}
+
+sScore :: Monad m => Signature m Int Int Char
+sScore = Signature
+  { step_step = \x (Z:.a:.b) -> if a==b then x+1 else x-1
+  , step_loop = \x _         -> x-1
+  , loop_step = \x _         -> x-1
+  , nil_nil   = const 0
+  , h = S.foldl' max 0
+  }
+{-# INLINE sScore #-}
+
+needlemanWunsch i1 i2 = (ws ! (Z:.pointL 0 n1:.pointL 0 n2), bt) where
+  ws = unsafePerformIO (forwardPhase i1 i2)
+  n1 = VU.length i1
+  n2 = VU.length i2
+  bt = [] :: String
+{-# NOINLINE needlemanWunsch #-}
+
+forwardPhase :: VU.Vector Char -> VU.Vector Char -> IO (PA.Unboxed (Z:.PointL:.PointL) Int)
+forwardPhase i1 i2 = do
+  let n1 = VU.length i1
+  let n2 = VU.length i2
+  !t' <- newWithM (Z:.pointL 0 0:.pointL 0 0) (Z:.pointL 0 n1:.pointL 0 n2) 0
+  let t= mTbl (Z:.EmptyT:.EmptyT) t'
+  fillTable $ grammar sScore t i1 i2
+  freeze t'
+{-# INLINE forwardPhase #-}
+
+fillTable (MTbl _ tbl, f) = do
+  let (_,Z:.PointL(0:.n1):.PointL(0:.n2)) = boundsM tbl
+  forM_ [0 .. n1] $ \k1 -> forM_ [0 .. n2] $ \k2 -> do
+    (f $ Z:.pointL 0 k1:.pointL 0 k2) >>= writeM tbl (Z:.pointL 0 k1:.pointL 0 k2)
+{-# INLINE fillTable #-}
+
diff --git a/ADP/Fusion/GAPlike.hs b/ADP/Fusion/GAPlike.hs
deleted file mode 100644
--- a/ADP/Fusion/GAPlike.hs
+++ /dev/null
@@ -1,571 +0,0 @@
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE EmptyDataDecls #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PackageImports #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-
--- | 
---
--- HINTS for writing your own (Non-) terminals:
---
--- - ALWAYS provide types for local functions of 'mkStream' and
--- 'mkStreamInner'. Otherwise stream-fusion gets confused and doesn't optimize.
--- (Observable in core by looking for 'Left', 'RIght' constructors and 'SPEC'
--- constructors.
-
-module ADP.Fusion.GAPlike where
-
-import Control.Monad.Primitive
-import Data.Primitive.Types (Prim(..))
-import Data.Vector.Fusion.Stream.Size
-import GHC.Prim (Constraint)
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-import qualified Data.Vector.Unboxed as VU
-
-import Data.PrimitiveArray (PrimArrayOps(..), MPrimArrayOps(..))
-import "PrimitiveArray" Data.Array.Repa.Index
-import qualified Data.PrimitiveArray as PA
-import qualified Data.PrimitiveArray.Zero.Unboxed as ZU
-
-
-
--- * The required type classes. Each class does its own thing.
-
--- | The 'Build' class. Combines the arguments into a stack before they are
--- turned into a stream.
---
---
---
--- To use, simply write "instance Build MyDataCtor" as we have sensible default
--- instances.
-
-class Build x where
-  -- | The stack of arguments we are building.
-  type BuildStack x :: *
-  -- | The default is for the left-most element.
-  type BuildStack x = None :. x
-  -- | Given an element, create the stack.
-  build :: x -> BuildStack x
-  -- | Default for the left-most element.
-  default build :: (BuildStack x ~ (None :. x)) => x -> BuildStack x
-  build x = None :. x
-  {-# INLINE build #-}
-
--- | The stream element. Creates a type-level recursive data type containing
--- the extracted arguments.
-
-class StreamElement x where
-  -- | one element of the stream, recursively defined
-  data StreamElm x :: *
-  -- | top-most index of the stream -- typically int
-  type StreamTopIdx  x :: *
-  -- | complete, recursively defined argument of the stream
-  type StreamArg  x :: *
-  -- | Given a stream element, we extract the top-most idx
-  getTopIdx :: StreamElm x -> StreamTopIdx x
-  -- | extract the recursively defined argument in a well-defined way for 'apply'
-  getArg :: StreamElm x -> StreamArg x
-
--- | Given the arguments, creates a stream of 'StreamElement's.
-
-class (StreamConstraint x) => MkStream m x where
-  type StreamConstraint x :: Constraint
-  type StreamConstraint x = ()
-  mkStream      :: (StreamConstraint x) => x -> (Int,Int) -> S.Stream m (StreamElm x)
-  mkStreamInner :: (StreamConstraint x) => x -> (Int,Int) -> S.Stream m (StreamElm x)
-
-
-
--- * Terminates the stack of arguments
-
--- | Very simple data ctor
-
-data None = None
-
--- | For CORE-language, we have our own Arg-terminator
-
-data ArgZ = ArgZ
-
-instance StreamElement None where
-  data StreamElm None    = SeNone !Int
-  type StreamTopIdx None = Int
-  type StreamArg    None = ArgZ
-  getTopIdx (SeNone k) = k
-  getArg _ = ArgZ
-  {-# INLINE getTopIdx #-}
-  {-# INLINE getArg #-}
-
-instance (Monad m) => MkStream m None where
-  mkStream None (i,j) = S.unfoldr step i where
-    step k
-      | k<=j = Just (SeNone i, j+1)
-      | otherwise = Nothing
-    {-# INLINE step #-}
-  {-# INLINE mkStream #-}
-  mkStreamInner = mkStream
-  {-# INLINE mkStreamInner #-}
-
-
-
--- * A single character terminal. Using unboxed vector to hold the input. Note
--- that "character" means parsing a scalar, not that the 'Chr' parser only
--- accepts "Char"s.
-
-data Chr e = Chr !(VU.Vector e)
-
-instance Build (Chr e)
-
-instance (StreamElement x) => StreamElement (x:.Chr e) where
-  data StreamElm (x:.Chr e) = SeChr !(StreamElm x) !Int !e
-  type StreamTopIdx (x:.Chr e) = Int
-  type StreamArg (x:.Chr e) = StreamArg x :. e
-  getTopIdx (SeChr _ k _) = k
-  getArg (SeChr x _ e) = getArg x :. e
-  {-# INLINE getTopIdx #-}
-  {-# INLINE getArg #-}
-
--- TODO I think, we can rewrite both versions to use S.map instead of S.flatten.
-
-instance (Monad m, MkStream m x, StreamElement x, StreamTopIdx x ~ Int, VU.Unbox e) => MkStream m (x:.Chr e) where
-  mkStream (x:.Chr es) (i,j) = S.flatten mk step Unknown $ mkStream x (i,j-1) where
-    mk :: StreamElm x -> m (StreamElm x, Int)
-    mk x = return (x, getTopIdx x)
-    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.Chr e)))
-    step (x,k)
-      | k+1 == j = return $ S.Yield (SeChr x (k+1) (VU.unsafeIndex es k)) (x,j+1)
-      | otherwise = return S.Done
-    {-# INLINE mk #-}
-    {-# INLINE step #-}
-  {-# INLINE mkStream #-}
-  mkStreamInner (x:.Chr es) (i,j) = S.flatten mk step Unknown $ mkStreamInner x (i,j-1) where
-    mk :: StreamElm x -> m (StreamElm x, Int)
-    mk x = return (x, getTopIdx x)
-    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.Chr e)))
-    step (x,k)
-      | k < j     = return $ S.Yield (SeChr x (k+1) (VU.unsafeIndex es k)) (x,j+1)
-      | otherwise = return $ S.Done
-    {-# INLINE mk #-}
-    {-# INLINE step #-}
-  {-# INLINE mkStreamInner #-}
-
-
-
--- * Empty and non-empty tables.
---
--- TODO This will probably become more funny with triangular tables ...
-
--- | empty subwords allowed
-
-data E
-
--- | only non-empty subwords
-
-data N
-
-class TransToN t where
-  type TransTo t :: *
-  transToN :: t -> TransTo t
-
--- | Used by the instances below for index calculations.
-
-class TblType tt where
-  initDeltaIdx :: tt -> Int
-
-instance TblType E where
-  initDeltaIdx _ = 0
-  {-# INLINE initDeltaIdx #-}
-
-instance TblType N where
-  initDeltaIdx _ = 1
-  {-# INLINE initDeltaIdx #-}
-
--- ** Immutable tables
-
-data Tbl c es = Tbl !es
-
-instance TransToN (Tbl c es) where
-  type TransTo (Tbl c es) = Tbl N es
-  transToN (Tbl es) = Tbl es
-  {-# INLINE transToN #-}
-
-instance Build (Tbl c es)
-
-instance (StreamElement x, PrimArrayOps arr DIM2 e, TblType c) => StreamElement (x:.Tbl c (arr DIM2 e)) where
-  data StreamElm    (x:.Tbl c (arr DIM2 e)) = SeTbl !(StreamElm x) !Int !e
-  type StreamTopIdx (x:.Tbl c (arr DIM2 e)) = Int
-  type StreamArg    (x:.Tbl c (arr DIM2 e)) = StreamArg x :. e
-  getTopIdx (SeTbl _ k _) = k
-  getArg    (SeTbl x _ e) = getArg x :. e
-  {-# INLINE getTopIdx #-}
-  {-# INLINE getArg #-}
-
-instance (Monad m, MkStream m x, StreamElement x, StreamTopIdx x ~ Int, PrimArrayOps arr DIM2 e, TblType c) => MkStream m (x:.Tbl c (arr DIM2 e)) where
-  -- | The outer stream function assumes that mkStreamInner generates a valid
-  -- stream that does not need to be checked. (This should always be true!).
-  -- The table entry to read is [k,j], as we supposedly are generating the
-  -- outermost stream. Even more "outermost" streams will have changed 'j'
-  -- beforehand. 'mkStream' should only ever be used if 'j' can be fixed.
-  mkStream (x:.Tbl t) (i,j) = S.map step $ mkStreamInner x (i,j - initDeltaIdx (undefined :: c)) where
-    step :: StreamElm x -> StreamElm (x:.Tbl c (arr DIM2 e))
-    step x = let k = getTopIdx x in SeTbl x j (t PA.! (Z:.k:.j))
-    {-# INLINE step #-}
-  -- | The inner stream will, in each step, check if the current subword [k,l]
-  -- (forall l>=k) is valid and terminate the stream once l>j.
-  mkStreamInner (x:.Tbl t) (i,j) = S.flatten mk step Unknown $ mkStreamInner x (i,j) where
-    mk :: StreamElm x -> m (StreamElm x, Int)
-    mk x = return (x, getTopIdx x + initDeltaIdx (undefined :: c))
-    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.Tbl c (arr DIM2 e))))
-    step (x,l)
-      | l<=j      = return $ S.Yield (SeTbl x l (t PA.! (Z:.k:.l))) (x,l+1)
-      | otherwise = return $ S.Done
-      where k = getTopIdx x
-    {-# INLINE mk #-}
-    {-# INLINE step #-}
-  {-# INLINE mkStream #-}
-  {-# INLINE mkStreamInner #-}
-
--- ** Mutable tables in some monad.
-
-data MTbl c es = MTbl !es
-
-instance TransToN (MTbl c es) where
-  type TransTo (MTbl c es) = MTbl N es
-  transToN (MTbl es) = MTbl es
-  {-# INLINE transToN #-}
-
-mtblN :: es -> MTbl N es
-mtblN es = MTbl es
-{-# INLINE mtblN #-}
-
-mtblE :: es -> MTbl E es
-mtblE es = MTbl es
-{-# INLINE mtblE #-}
-
-instance Build (MTbl c es)
-
-instance (StreamElement x, MPrimArrayOps marr DIM2 e, TblType c) => StreamElement (x:.MTbl c (marr s DIM2 e)) where
-  data StreamElm    (x:.MTbl c (marr s DIM2 e)) = SeMTbl !(StreamElm x) !Int !e
-  type StreamTopIdx (x:.MTbl c (marr s DIM2 e)) = Int
-  type StreamArg    (x:.MTbl c (marr s DIM2 e)) = StreamArg x :. e
-  getTopIdx (SeMTbl _ k _) = k
-  getArg    (SeMTbl x _ e) = getArg x :. e
-  {-# INLINE getTopIdx #-}
-  {-# INLINE getArg #-}
-
-instance
-  ( Monad m
-  , PrimMonad m
-  , MkStream m x
-  , StreamElement x
-  , StreamTopIdx x ~ Int
-  , MPrimArrayOps marr DIM2 e
-  , TblType c
-  , s ~ PrimState m
-  ) => MkStream m (x:.MTbl c (marr s DIM2 e)) where
-  -- | The outer stream function assumes that mkStreamInner generates a valid
-  -- stream that does not need to be checked. (This should always be true!).
-  -- The table entry to read is [k,j], as we supposedly are generating the
-  -- outermost stream. Even more "outermost" streams will have changed 'j'
-  -- beforehand. 'mkStream' should only ever be used if 'j' can be fixed.
-  mkStream (x:.MTbl t) (i,j) = S.mapM step $ mkStreamInner x (i,j - initDeltaIdx (undefined :: c)) where
-    step :: StreamElm x -> m (StreamElm (x:.MTbl c (marr s DIM2 e)))
-    step x = let k = getTopIdx x in PA.readM t (Z:.k:.j) >>= \e -> return $ SeMTbl x j e
-    {-# INLINE step #-}
-  -- | The inner stream will, in each step, check if the current subword [k,l]
-  -- (forall l>=k) is valid and terminate the stream once l>j.
-  mkStreamInner (x:.MTbl t) (i,j) = S.flatten mk step Unknown $ mkStreamInner x (i,j) where
-    mk :: StreamElm x -> m (StreamElm x, Int)
-    mk x = return (x, getTopIdx x + initDeltaIdx (undefined :: c))
-    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.MTbl c (marr s DIM2 e))))
-    step (x,l)
-      | l<=j      = readM t (Z:.k:.l) >>= \e -> return $ S.Yield (SeMTbl x l e) (x,l+1)
-      | otherwise = return $ S.Done
-      where k = getTopIdx x
-    {-# INLINE mk #-}
-    {-# INLINE step #-}
-  {-# INLINE mkStream #-}
-  {-# INLINE mkStreamInner #-}
-
--- ** Some convenience functions.
-
-tNtoE :: Tbl N x -> Tbl E x
-tNtoE (Tbl x) = Tbl x
-{-# INLINE tNtoE #-}
-
-tEtoN :: Tbl E x -> Tbl N x
-tEtoN (Tbl x) = Tbl x
-{-# INLINE tEtoN #-}
-
-
-
--- * Parses an empty subword.
-
--- | The empty subword. Can not be part of a more complex RHS for obvious
--- reasons: "S -> E S" doesn't make sense. Used in some grammars as the base
--- case.
-
-data Empty = Empty
-
-instance Build Empty where
-  type BuildStack Empty = Empty
-  build c = c
-  {-# INLINE build #-}
-
-instance StreamElement (Empty) where
-  data StreamElm    Empty = SeEmpty !Int
-  type StreamTopIdx Empty = Int
-  type StreamArg    Empty = ArgZ :. ()
-  getTopIdx (SeEmpty k) = k
-  getArg    (SeEmpty _) = ArgZ :. ()
-  {-# INLINE getTopIdx #-}
-  {-# INLINE getArg #-}
-
-instance (Monad m) => MkStream m (Empty) where
-  mkStream Empty (i,j) = S.unfoldr step i where
-    step k
-      | k==j      = Just (SeEmpty k, j+1)
-      | otherwise = Nothing
-    {-# INLINE step #-}
-  mkStreamInner = error "undefined for Empty"
-  {-# INLINE mkStream #-}
-  {-# INLINE mkStreamInner #-}
-
-
-
--- * Parsing subwords with restriced size. Both min- and max-size are given
--- when binding input.
-
-data RestrictedRegion e = RRegion !Int !Int !(VU.Vector e)
-
-instance Build (RestrictedRegion e)
-
-instance (StreamElement x) => StreamElement (x:.RestrictedRegion e) where
-  data StreamElm (x:.RestrictedRegion e) = SeResRegion !(StreamElm x) !Int (VU.Vector e)
-  type StreamTopIdx (x:.RestrictedRegion e) = Int
-  type StreamArg (x:.RestrictedRegion e) = StreamArg x :. (VU.Vector e)
-  getTopIdx (SeResRegion _ k _) = k
-  getArg (SeResRegion x _ e) = getArg x :. e
-  {-# INLINE getTopIdx #-}
-  {-# INLINE getArg #-}
-
-instance (Monad m, MkStream m x, StreamElement x, StreamTopIdx x ~ Int, VU.Unbox e) => MkStream m (x:.RestrictedRegion e) where
-  mkStream (x:.RRegion minR maxR xs) (i,j) = S.flatten mk step Unknown $ mkStream x (i,j-1) where
-    mk :: StreamElm x -> m (StreamElm x, Int)
-    mk x = return (x, getTopIdx x)
-    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.RestrictedRegion e)))
-    step (x,k)
-      | k+minR <= j && k+maxR >= j = return $ S.Yield (SeResRegion x k (VU.unsafeSlice k (max maxR (j-k)) xs)) (x,j+1)
-      | otherwise = return S.Done
-    {-# INLINE mk #-}
-    {-# INLINE step #-}
-  {-# INLINE mkStream #-}
-  mkStreamInner (x:.RRegion minR maxR xs) (i,j) = S.flatten mk step Unknown $ mkStream x (i,j) where
-    mk :: StreamElm x -> m (StreamElm x, Int)
-    mk x = return (x, getTopIdx x + minR)
-    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.RestrictedRegion e)))
-    step (x,l)
-      | l<=j && (l-k)<=maxR = return $ S.Yield (SeResRegion x l (VU.unsafeSlice k (l-k) xs)) (x,j+1)
-      | otherwise           = return S.Done
-      where k = getTopIdx x
-    {-# INLINE mk #-}
-    {-# INLINE step #-}
-  {-# INLINE mkStreamInner #-}
-
-
-
--- * Backtracking tables.
---
--- Since we want the slow forward phase to be fast, in the backtracking phase,
--- we need to keep track of additional things. The backtracking table 'BTtbl'
--- requires the table and an additional backtracking function. You should use
--- the same composed function as for the forward pahse creating the bound table
--- in the first place.
-
--- | The backtracking table 'BTtbl" captures a DP table and the function used
--- to fill it.
-
-data BTtbl c t g = BTtbl t g
-
-instance TransToN (BTtbl c t g) where
-  type TransTo (BTtbl c t g) = BTtbl N t g
-  transToN (BTtbl t g) = BTtbl t g
-  {-# INLINE transToN #-}
-
-bttblN :: t -> g -> BTtbl N t g
-bttblN t g = BTtbl t g
-{-# INLINE bttblN #-}
-
-bttblE :: t -> g -> BTtbl E t g
-bttblE t g = BTtbl t g
-{-# INLINE bttblE #-}
-
-instance Build (BTtbl c t g)
-
--- | The backtracking function, given our index pair, return a stream of
--- backtracked results. (Return as in we are in a monad).
---
--- TODO Should this be "(Int,Int) -> m (SM.Stream Id b)" or are there cases
--- where we'd like to have monadic effects on the "b"s?
-
-type BTfun m b = (Int,Int) -> m (S.Stream m b)
-
-instance (Monad m, StreamElement x, TblType c) => StreamElement (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) where
-  data StreamElm    (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) = SeBTtbl !(StreamElm x) !Int !e (m (S.Stream m b))
-  type StreamTopIdx (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) = Int
-  type StreamArg    (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) = StreamArg x :. (e, m (S.Stream m b))
-  getTopIdx (SeBTtbl _ k _ _) = k
-  getArg    (SeBTtbl x _ e g) = getArg x :. (e,g)
-  {-# INLINE getTopIdx #-}
-  {-# INLINE getArg #-}
-
-instance
-  ( Monad m
-  , MkStream m x
-  , StreamElement x
-  , VU.Unbox e
-  , StreamTopIdx x ~ Int
-  , TblType c
-  ) => MkStream m (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) where
-  mkStream (x:.BTtbl t g) (i,j) = S.map step $ mkStreamInner x (i,j - initDeltaIdx (undefined :: c)) where
-    step :: StreamElm x -> StreamElm (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b))
-    step x = let k = getTopIdx x in SeBTtbl x j (t PA.! (Z:.k:.j)) (g (k,j))
-    {-# INLINE step #-}
-  mkStreamInner (x:.BTtbl t g) (i,j) = S.flatten mk step Unknown $ mkStreamInner x (i,j) where
-    mk :: StreamElm x -> m (StreamElm x, Int)
-    mk x = return (x, getTopIdx x + initDeltaIdx (undefined :: c))
-    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b))))
-    step (x,l)
-      | l<=j      = return $ S.Yield (SeBTtbl x l (t PA.! (Z:.k:.l)) (g (k,l))) (x,l+1)
-      | otherwise = return $ S.Done
-      where k = getTopIdx x
-    {-# INLINE mk #-}
-    {-# INLINE step #-}
-  {-# INLINE mkStream #-}
-  {-# INLINE mkStreamInner #-}
-
-
-
--- * Build complex stacks
-
-instance Build x => Build (x,y) where
-  type BuildStack (x,y) = BuildStack x :. y
-  build (x,y) = build x :. y
-  {-# INLINE build #-}
-
-
-
--- * combinators
-
-infixl 8 <<<
-(<<<) f t ij = S.map (\s -> apply f $ getArg s) $ mkStream (build t) ij
-{-# INLINE (<<<) #-}
-
-infixl 7 |||
-(|||) xs ys ij = xs ij S.++ ys ij
-{-# INLINE (|||) #-}
-
-infixl 6 ...
-(...) s h ij = h $ s ij
-{-# INLINE (...) #-}
-
-infixl 6 ..@
-(..@) s h ij = h ij $ s ij
-{-# INLINE (..@) #-}
-
-infixl 9 ~~
-(~~) = (,)
-{-# INLINE (~~) #-}
-
-infixl 9 %
-(%) = (,)
-{-# INLINE (%) #-}
-
-
-
--- * Apply function 'f' in '(<<<)'
-
-class Apply x where
-  type Fun x :: *
-  apply :: Fun x -> x
-
-instance Apply (ArgZ:.a -> res) where
-  type Fun (ArgZ:.a -> res) = a -> res
-  apply fun (ArgZ:.a) = fun a
-  {-# INLINE apply #-}
-
-instance Apply (ArgZ:.a:.b -> res) where
-  type Fun (ArgZ:.a:.b -> res) = a->b -> res
-  apply fun (ArgZ:.a:.b) = fun a b
-  {-# INLINE apply #-}
-
-instance Apply (ArgZ:.a:.b:.c -> res) where
-  type Fun (ArgZ:.a:.b:.c -> res) = a->b->c -> res
-  apply fun (ArgZ:.a:.b:.c) = fun a b c
-  {-# INLINE apply #-}
-
-instance Apply (ArgZ:.a:.b:.c:.d -> res) where
-  type Fun (ArgZ:.a:.b:.c:.d -> res) = a->b->c->d -> res
-  apply fun (ArgZ:.a:.b:.c:.d) = fun a b c d
-  {-# INLINE apply #-}
-
-instance Apply (ArgZ:.a:.b:.c:.d:.e -> res) where
-  type Fun (ArgZ:.a:.b:.c:.d:.e -> res) = a->b->c->d->e -> res
-  apply fun (ArgZ:.a:.b:.c:.d:.e) = fun a b c d e
-  {-# INLINE apply #-}
-
-instance Apply (ArgZ:.a:.b:.c:.d:.e:.f -> res) where
-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f -> res) = a->b->c->d->e->f -> res
-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f) = fun a b c d e f
-  {-# INLINE apply #-}
-
-instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g -> res) where
-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g -> res) = a->b->c->d->e->f->g -> res
-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g) = fun a b c d e f g
-  {-# INLINE apply #-}
-
-instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h -> res) where
-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h -> res) = a->b->c->d->e->f->g->h -> res
-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h) = fun a b c d e f g h
-  {-# INLINE apply #-}
-
-instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) where
-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) = a->b->c->d->e->f->g->h->i -> res
-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i) = fun a b c d e f g h i
-  {-# INLINE apply #-}
-
-instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) where
-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) = a->b->c->d->e->f->g->h->i->j -> res
-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j) = fun a b c d e f g h i j
-  {-# INLINE apply #-}
-
-instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) where
-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) = a->b->c->d->e->f->g->h->i->j->k -> res
-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k) = fun a b c d e f g h i j k
-  {-# INLINE apply #-}
-
-instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) where
-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) = a->b->c->d->e->f->g->h->i->j->k->l -> res
-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l) = fun a b c d e f g h i j k l
-  {-# INLINE apply #-}
-
-instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) where
-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m -> res
-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m) = fun a b c d e f g h i j k l m
-  {-# INLINE apply #-}
-
-instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) where
-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n -> res
-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n) = fun a b c d e f g h i j k l m n
-  {-# INLINE apply #-}
-
-instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) where
-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n->o -> res
-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o) = fun a b c d e f g h i j k l m n o
-  {-# INLINE apply #-}
-
diff --git a/ADP/Fusion/GAPlike/Criterion.hs b/ADP/Fusion/GAPlike/Criterion.hs
deleted file mode 100644
--- a/ADP/Fusion/GAPlike/Criterion.hs
+++ /dev/null
@@ -1,179 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE PackageImports #-}
-
-module ADP.Fusion.GAPlike.Criterion where
-
-import Control.Monad.ST
-import Criterion.Main
-import Data.Char
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-import qualified Data.Vector.Fusion.Stream as SP
-
-import Data.PrimitiveArray
-import Data.PrimitiveArray.Unboxed.VectorZero as UVZ
-import Data.PrimitiveArray.Unboxed.Zero as UZ
-import "PrimitiveArray" Data.Array.Repa.Index
-import "PrimitiveArray" Data.Array.Repa.Shape
-
-import ADP.Fusion.GAPlike
-import ADP.Fusion.GAPlike.DevelCommon
-
-
-
-criterionMain = defaultMain
-  [ bgroup "testTTT3"
-    [ bench "  10" (whnf (testTTT 0)   10)
-    , bench " 100" (whnf (testTTT 0)  100)
-    , bench "1000" (whnf (testTTT 0) 1000)
-    ]
-  , bgroup "testTTTT4"
-    [ bench "  10" (whnf (testTTTT 0)   10)
-    , bench " 100" (whnf (testTTTT 0)  100)
-    , bench "1000" (whnf (testTTTT 0) 1000)
-    ]
-  , bgroup "testTTTT4ga"
-    [ bench "  10" (whnf (testTTTTga 0)   10)
-    , bench " 100" (whnf (testTTTTga 0)  100)
-    , bench "1000" (whnf (testTTTTga 0) 1000)
-    ]
-  , bgroup "testTTTT4gaPA"
-    [ bench "  10" (whnf (testTTTTgaPA 0)   10)
-    , bench " 100" (whnf (testTTTTgaPA 0)  100)
-    , bench "1000" (whnf (testTTTTgaPA 0) 1000)
-    ]
-  , bgroup "testTTTT4gaImmu"
-    [ bench "  10" (whnf (testTTTTgaImmu 0)   10)
-    , bench " 100" (whnf (testTTTTgaImmu 0)  100)
-    , bench "1000" (whnf (testTTTTgaImmu 0) 1000)
-    ]
-  , bgroup "testTTTT4gaImmuPA"
-    [ bench "  10" (whnf (testTTTTgaImmuPA 0)   10)
-    , bench " 100" (whnf (testTTTTgaImmuPA 0)  100)
-    , bench "1000" (whnf (testTTTTgaImmuPA 0) 1000)
-    ]
-  ]
-
-
-
--- * Criterion tests
-
-testC :: Int -> Int -> Int
-testC i j = runST doST where
-  doST :: ST s Int
-  doST = do
-    let c = Chr dvu
-    (gord1 <<< c ... ghsum) (i,j)
-{-# NOINLINE testC #-}
-
-gTestC (ord1,hsum) c =
-  (ord1 <<< c ... hsum)
-
-aTestC = (ord1,hsum) where
-  ord1 = gord1
-  hsum = ghsum
-
-testCC :: Int -> Int -> Int
-testCC i j = runST doST where
-  doST :: ST s Int
-  doST = do
-    let c = Chr dvu
-    let d = Chr dvu
-    (gord2 <<< c % d ... ghsum) (i,j)
-{-# NOINLINE testCC #-}
-
-type TBL s = Tbl N (UVZ.MArr0 s DIM2 Int)
-
-testT :: Int -> Int -> Int
-testT i j = runST doST where
-  doST :: ST s Int
-  doST = do
-    tbl :: TBL s <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) 1 []
-    (id <<< tbl ... ghsum) (i,j)
-{-# NOINLINE testT #-}
-
-testTT :: Int -> Int -> Int
-testTT i j = runST doST where
-  doST :: ST s Int
-  doST = do
-    tbl :: TBL s <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) 1 []
-    (gplus2 <<< tbl % tbl ... ghsum) (i,j)
-  {-# INLINE doST #-}
-{-# NOINLINE testTT #-}
-
-testTTT :: Int -> Int -> Int
-testTTT i j = runST doST where
-  doST :: ST s Int
-  doST = do
-    tbl :: TBL s <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) 1 []
-    (gplus3 <<< tbl % tbl % tbl ... ghsum) (i,j)
-{-# NOINLINE testTTT #-}
-
-testTTTT :: Int -> Int -> Int
-testTTTT i j = runST doST where
-  doST :: ST s Int
-  doST = do
-    tbl :: TBL s <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) (1::Int) []
-    (gplus4 <<< tbl % tbl % tbl % tbl ... ghsum) (i,j)
-  {-# INLINE doST #-}
-{-# NOINLINE testTTTT #-}
-
-testTTTTga :: Int -> Int -> Int
-testTTTTga i j = runST doST where
-  doST :: ST s Int
-  doST = do
-    tbl :: TBL s <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) (1::Int) []
-    gTTTga aTTTga tbl (i,j)
-  {-# INLINE doST #-}
-{-# NOINLINE testTTTTga #-}
-
-testTTTTgaPA :: Int -> Int -> Int
-testTTTTgaPA i j = runST doST where
-  doST :: ST s Int
-  doST = do
-    tbl :: Tbl N (UZ.MArr0 s DIM2 Int) <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) (1::Int) []
-    gTTTga aTTTga tbl (i,j)
-  {-# INLINE doST #-}
-{-# NOINLINE testTTTTgaPA #-}
-
-testTTTTgaImmu :: Int -> Int -> Int
-testTTTTgaImmu i j =
-    let tbl = (Tbl $ fromAssocs (Z:.0:.0) (Z:.j:.j) 1 []) :: Tbl N (UVZ.Arr0 DIM2 Int) 
-    in tbl `seq` gTTTga aTTTgaImmu tbl (i,j)
-{-# NOINLINE testTTTTgaImmu #-}
-
-testTTTTgaImmuPA :: Int -> Int -> Int
-testTTTTgaImmuPA i j =
-    let tbl = (Tbl $ fromAssocs (Z:.0:.0) (Z:.j:.j) 1 []) :: Tbl N (UZ.Arr0 DIM2 Int) 
-    in tbl `seq` gTTTga aTTTgaImmu tbl (i,j)
-{-# NOINLINE testTTTTgaImmuPA #-}
-
-gTTTga (plus4, hsum) tbl =
-  (plus4 <<< tbl % tbl % tbl % tbl ... hsum)
-{-# INLINE gTTTga #-}
-
-aTTTga = (plus4, hsum) where
-  plus4 = gplus4
-  hsum = ghsum
-
-aTTTgaImmu = (plus4, hsum) where
-  plus4 = gplus4
-  hsum = gihsum
-{-# INLINE aTTTgaImmu #-}
-
-gord1 a = ord a
-
-gord2 a b = ord a + ord b
-
-gord3 a b c = ord a + ord b + ord c
-
-gplus2 a b = a+b
-
-gplus3 a b c = a+b+c
-
-gplus4 a b c d = a+b+c+d
-
-ghsum :: S.Stream (ST s) Int -> ST s Int
-ghsum = S.foldl' (+) 0
-
-gihsum :: SP.Stream Int -> Int
-gihsum = SP.foldl' (+) 0
diff --git a/ADP/Fusion/GAPlike/DevelCommon.hs b/ADP/Fusion/GAPlike/DevelCommon.hs
deleted file mode 100644
--- a/ADP/Fusion/GAPlike/DevelCommon.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-{-# LANGUAGE PackageImports #-}
-
-module ADP.Fusion.GAPlike.DevelCommon where
-
-import qualified Data.PrimitiveArray as PA
-import qualified Data.Vector.Unboxed as VU
-
-import Data.PrimitiveArray.Unboxed.VectorZero as UVZ
-import Data.PrimitiveArray.Unboxed.Zero as UZ
-import "PrimitiveArray" Data.Array.Repa.Index
-import "PrimitiveArray" Data.Array.Repa.Shape
-
-
-
-dvu = VU.fromList $ concat $ replicate 10 ['a'..'z']
-{-# NOINLINE dvu #-}
-
-type PAT = UVZ.Arr0 DIM2 Int
-pat :: PAT
-pat = PA.fromAssocs (Z:.0:.0) (Z:.1000:.1000) 0 [(Z:.i:.j,j-i) | i <-[0..1000], j<-[i..1000] ]
-{-# NOINLINE pat #-}
-
diff --git a/ADP/Fusion/GAPlike/QuickCheck.hs b/ADP/Fusion/GAPlike/QuickCheck.hs
deleted file mode 100644
--- a/ADP/Fusion/GAPlike/QuickCheck.hs
+++ /dev/null
@@ -1,57 +0,0 @@
-{-# LANGUAGE PackageImports #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-module ADP.Fusion.GAPlike.QuickCheck where
-
-import Test.QuickCheck
-import Test.QuickCheck.All
-import qualified Data.Vector.Fusion.Stream as SP
-import qualified Data.Vector.Unboxed as VU
-
-import "PrimitiveArray" Data.Array.Repa.Index
-import "PrimitiveArray" Data.Array.Repa.Shape
-import Data.PrimitiveArray
-
-import ADP.Fusion.QuickCheck.Arbitrary
-import ADP.Fusion.GAPlike.DevelCommon
-import ADP.Fusion.GAPlike
-
-
-
--- * QuickCheck
-
-checkC_fusion (i,j) = id <<< Chr dvu ... SP.toList $ (i,j)
-checkC_list   (i,j) = [dvu VU.! i | i+1==j]
-prop_checkC = checkC_fusion === checkC_list
-
-checkCC_fusion (i,j) = (,) <<< Chr dvu % Chr dvu ... SP.toList $ (i,j)
-checkCC_list   (i,j) = [ (dvu VU.! i, dvu VU.! (i+1)) | i+2==j ]
-prop_checkCC = checkCC_fusion === checkCC_list
-
-checkP_fusion (i,j) = id <<< (Tbl pat :: Tbl E PAT)  ... SP.toList $ (i,j)
-checkP_list   (i,j) = [ (pat!(Z:.i:.j)) | i<=j ]
-prop_checkP = checkP_fusion === checkP_list
-
-checkPP_fusion (i,j) = let tbl = Tbl pat :: Tbl E PAT
-                       in  (,) <<< tbl % tbl ... SP.toList $ (i,j)
-checkPP_list   (i,j) = [ (pat!(Z:.i:.k), pat!(Z:.k:.j)) | k<-[i..j] ]
-prop_checkPP = checkPP_fusion === checkPP_list
-
-checkCPC_fusion (i,j) = let tbl = Tbl pat :: Tbl E PAT
-                        in  (,,) <<< Chr dvu % tbl % Chr dvu ... SP.toList $ (i,j)
-checkCPC_list (i,j) = [ (dvu VU.! i, pat!(Z:.i+1:.j-1), dvu VU.! (j-1)) | i+2<=j ]
-prop_checkCPC = checkCPC_fusion === checkCPC_list
-
-checkNN_fusion (i,j) = let tbl = Tbl pat :: Tbl N PAT
-                       in  (,) <<< tbl % tbl ... SP.toList $ (i,j)
-checkNN_list   (i,j) = [ (pat!(Z:.i:.k), pat!(Z:.k:.j)) | k<-[i+1..j-1] ]
-prop_checkNN = checkNN_fusion === checkNN_list
-
-
-
-options = stdArgs {maxSuccess = 1000}
-
-customCheck = quickCheckWithResult options
-
-allProps = $forAllProperties customCheck
-
diff --git a/ADP/Fusion/Monadic.hs b/ADP/Fusion/Monadic.hs
deleted file mode 100644
--- a/ADP/Fusion/Monadic.hs
+++ /dev/null
@@ -1,197 +0,0 @@
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE PackageImports #-}
-
--- | Monadic combinators. Code like
---
--- @f <<< xs ~~~ ys ... Stream.sum@
---
--- will generate efficient GHC core for a dynamic program comparable to
---
--- @sum [ f (xs!(i,k)) (ys!(k,j)) | k<-[i..j]]@.
-
-module ADP.Fusion.Monadic where
-
-import "PrimitiveArray" Data.Array.Repa.Index
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-
-import ADP.Fusion.Monadic.Internal
-
-
-
--- * Apply functions to arguments.
-
--- | A monadic version of the function application combinator. Applies 'f'
--- which has a monadic effect.
-
-infixl 8 #<<
-(#<<) f t ij = S.mapM (\(_,_,c) -> apply f c) $ streamGen t ij
-{-# INLINE (#<<) #-}
-
--- | Pure function application combinator. Applies 'f' which is pure. The
--- arguments to 'f', meaning 't' can be monadic, however!
-
-infixl 8 <<<
-(<<<) f t ij = S.map (\(_,_,c) -> apply f c) $ streamGen t ij
-{-# INLINE (<<<) #-}
-
-
-
--- * Combine multiple right-hand sides of a non-terminal in a context-free
--- grammar.
-
--- | If both, 'xs' and 'ys' are streams of candidate answers, they can be
--- combined here. The answer (or sort) type of 'xs' and 'ys' has to be the
--- same. Works like @(++)@ for lists.
-
-infixl 7 |||
-(|||) xs ys ij = xs ij S.++ ys ij
-{-# INLINE (|||) #-}
-
-
-
--- * Reduce streams to single answers.
---
--- NOTE "Single answers" can be of a vector-type! One is not constrained to
--- scalar results. This allows for many exiting algorithms.
-
--- | Reduces a streams of answers to the type of stored answers. The resulting
--- type could be scalar, which it will be for highest-performance algorithms,
--- or it could be a subset of answers stored in some kind of data structure.
-
-infixl 6 ...
-(...) stream h ij = h $ stream ij
-{-# INLINE (...) #-}
-
--- | Specialized version of choice function application, with a choice function
--- that needs to know the subword index it is working on.
-
-infixl 6 ..@
-(..@) stream h ij = h ij $ stream ij
-{-# INLINE (..@) #-}
-
-
-
--- * Combinators to chain function arguments.
-
-
-
--- ** General combinator creation.
-
--- | General function to create combinators. The left-hand side @xs@ in @xs
--- `comb` ys@ will have a size between @minL@ and @maxL@, while @ys@ and
--- /everything to its right will be guaranteed @minR@ size.
-
-makeLeft_MinRight (minL,maxL) minR = comb where
-  {-# INLINE comb #-}
-  comb xs ys = Box mk step xs ys
-  {-# INLINE mk #-}
-  mk (z:.k:.j,a,b) = return (z:.k:.k+minL:.j,a,b)
-  {-# INLINE step #-}
-  step (z:.k:.l:.j,a,b)
-    | l<=j-minR && l<=k+maxL = return $ S.Yield (z:.k:.l:.j,a,b) (z:.k:.l+1:.j,a,b)
-    | otherwise              = return $ S.Done
-{-# INLINE makeLeft_MinRight #-}
-
--- | Create combinators which are to be used in the right-most position of a
--- chain. 1st, they make sure that the second to last region has a size of at
--- least 'minL'. 2nd, they constrain the last argument to a size between 'minR'
--- and 'maxR'.
-
-makeMinLeft_Right minL (minR,maxR) = comb where
-  {-# INLINE comb #-}
-  comb xs ys = Box mk step xs ys
-  {-# INLINE mk #-}
-  mk (z:.k:.j,a,b) = let l = max (k+minL) (j-maxR) in return (z:.k:.l:.j,a,b)
-  {-# INLINE step #-}
-  step (z:.k:.l:.j,a,b)
-    | l<=j-minR = return $ S.Yield (z:.k:.l:.j,a,b) (z:.k:.l+1:.j,a,b)
-    | otherwise = return $ S.Done
-{-# INLINE makeMinLeft_Right #-}
-
-
-
--- ** A number of often-used combinators.
-
-infixl 9 -~+, +~-, -~~, ~~-
-
-(-~+) = makeLeft_MinRight (1,1) 1
-{-# INLINE (-~+) #-}
-
-(+~-) = makeMinLeft_Right 1 (1,1)
-{-# INLINE (+~-) #-}
-
-(-~~) = makeLeft_MinRight (1,1) 0
-{-# INLINE (-~~) #-}
-
-(~~-) = makeMinLeft_Right 0 (1,1)
-{-# INLINE (~~-) #-}
-
-(+~--) = makeMinLeft_Right 1 (2,2)
-{-# INLINE (+~--) #-}
-
-infixl 9 ~~~
-(~~~) xs ys = Box mk step xs ys where
-  {-# INLINE mk #-}
-  mk (z:.k:.j,vidx,vstack) = return $ (z:.k:.k:.j,vidx,vstack)
-  {-# INLINE step #-}
-  step (z:.k:.l:.j,vidx,vstack)
-    | l<=j      = return $ S.Yield (z:.k:.l:.j,vidx,vstack) (z:.k:.l+1:.j,vidx,vstack)
-    | otherwise = return $ S.Done
-{-# INLINE (~~~) #-}
-
--- | @xs +~+ ys@ with @xs@ and @ys@ non-empty. The non-emptyness constraint on
--- @ys@ works only for two arguments. With three or more arguments, a
--- left-leaning combinator to the right of @ys@ is required to establish
--- non-emptyness.
-
-infixl 9 +~+
-(+~+) xs ys = Box mk step xs ys where
-  {-# INLINE mk #-}
-  mk (z:.k:.j,vidx,vstack) = return $ (z:.k:.k+1:.j,vidx,vstack)
-  {-# INLINE step #-}
-  step (z:.k:.l:.j,vidx,vstack)
-    | l+1<=j    = return $ S.Yield (z:.k:.l:.j,vidx,vstack) (z:.k:.l+1:.j,vidx,vstack)
-    | otherwise = return $ S.Done
-{-# INLINE (+~+) #-}
-
--- | @ls ~~~ xs !-~+ ys@ with xs having a size of one and @ls@ further to the
--- left having a size of one or more.
-
-infixl 9 !-~+
-(!-~+) xs ys = Box mk step xs ys where
-  {-# INLINE mk #-}
-  mk (z:.k:.j,vidx,vstack)
-    | k>0       = return $ (z:.k:.k+1:.j,vidx,vstack)
-    | otherwise = return $ (z:.k:.j+1:.j,vidx,vstack)
-  {-# INLINE step #-}
-  step (z:.k:.l:.j,vidx,vstack)
-    | l+1<=j    = return $ S.Yield (z:.k:.l:.j,vidx,vstack) (z:.k:.j+1:.j,vidx,vstack)
-    | otherwise = return $ S.Done
-{-# INLINE (!-~+) #-}
-
--- | @xs +~-! ys ~~~ rs@ with @ys@ having a size of one and @rs@ further to the
--- right having a size of one.
-
-infixl 9 +~-!
-(+~-!) xs ys = Box mk step xs ys where
-  {-# INLINE mk #-}
-  mk (z:.k:.j,vidx,vstack) = return $ (z:.k:.j-2:.j,vidx,vstack)
-  {-# INLINE step #-}
-  step (z:.k:.l:.j,vidx,vstack)
-    | l+2==j    = return $ S.Yield (z:.k:.l:.j,vidx,vstack) (z:.k:.j+1:.j,vidx,vstack)
-    | otherwise = return $ S.Done
-{-# INLINE (+~-!) #-}
-
--- | @xs -~- ys@ produces an answer only if both @xs@ and @ys@ have size one.
--- The total size here then is two.
-
-infixl 9 -~-
-(-~-) xs ys = Box mk step xs ys where
-  {-# INLINE mk #-}
-  mk (z:.k:.j,vidx,vstack) = return $ (z:.k:.k+1:.j,vidx,vstack)
-  {-# INLINE step #-}
-  step (z:.k:.l:.j,vidx,vstack)
-    | k+1==l && l+1==j = return $ S.Yield (z:.k:.l:.j,vidx,vstack) (z:.k:.l+1:.j,vidx,vstack)
-    | otherwise        = return $ S.Done
-{-# INLINE (-~-) #-}
-
diff --git a/ADP/Fusion/Monadic/Internal.hs b/ADP/Fusion/Monadic/Internal.hs
deleted file mode 100644
--- a/ADP/Fusion/Monadic/Internal.hs
+++ /dev/null
@@ -1,492 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DoAndIfThenElse #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverlappingInstances #-}
-{-# LANGUAGE PackageImports #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-{-# OPTIONS_HADDOCK hide #-}
-
--- | The internal working of ADPfusion. All combinator applications are turned
--- into efficient code during compile time.
---
--- If you have a data structure to be used as an argument in a combinator
--- chain, derive an instance 'ExtractValue', 'StreamGen', and 'PreStreamGen'.
---
--- NOTE: If this doesn't happen, it is a possible bug, or GHC changed its
--- optimizer (like with GHC 7.2 -> 7.4).
---
--- TODO If possible, instance generation will be using the Generics system in
--- the future.
-
-module ADP.Fusion.Monadic.Internal where
-
-import Control.Monad.Primitive
-import Control.Monad.ST
-import Data.List (intersperse)
-import Data.Primitive.Types
-import Data.Vector.Fusion.Stream.Size
-import "PrimitiveArray" Data.Array.Repa.Index
-import "PrimitiveArray" Data.Array.Repa.Shape
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-import qualified Data.Vector.Unboxed as VU
-import Text.Printf
-
-import qualified Data.PrimitiveArray as PA
-import qualified Data.PrimitiveArray.Zero.Unboxed as ZU
-import qualified Data.PrimitiveArray.Zero as Z
-
-
-
--- * StreamGen
-
--- | Generate stream from either one (DIM2 -> m cnt) or some combination of
--- terminals derived from uses of nextTo.
-
-class Monad m => StreamGen m t r | t -> r where
-  streamGen :: t -> DIM2 -> S.Stream m r
-
-#define mkStreamGen(cnt) \
-instance (Monad m, ExtractValue m (cnt), Asor (cnt) ~ k, Elem (cnt) ~ elm) \
-=> StreamGen m (cnt) (DIM2,Z:.k,Z:.elm) where { \
-  {-# INLINE streamGen #-} \
-;  streamGen x ij = extractStreamLast x $ preStreamGen x ij }
-
-mkStreamGen(DIM2 -> Scalar elm)
-mkStreamGen(DIM2 -> ScalarM elm)
-mkStreamGen(DIM2 -> Vect elm)
-mkStreamGen(DIM2 -> VectM elm)
-mkStreamGen(ZU.MArr0 s sh elm)
-mkStreamGen(ZU.Arr0 sh elm)
-
-mkStreamGen(Z.MArr0 s sh (VU.Vector elm))
-mkStreamGen(Z.Arr0 sh (VU.Vector elm))
-
--- | two or more elements combined by NextTo (~~~), "xs" as anything, "ys" is
--- monadic.
-
-instance
-  ( Monad m
-  , ExtractValue m ys, Asor ys ~ cY, Elem ys ~ eY
-  , PreStreamGen m (Box mk step xs ys) (idx:.Int,adx:.cX,arg:.eX)
-  , Idx2 _idx ~ idx
-  ) => StreamGen m (Box mk step xs ys) (idx:.Int,adx:.cX:.cY,arg:.eX:.eY) where
-  streamGen (Box mk step xs ys) ij
-    = extractStreamLast ys
-    $ preStreamGen (Box mk step xs ys) ij
-  {-# INLINE streamGen #-}
-
-
-
--- * PreStreamGen
-
--- | Required by most 'StreamGen' instances just before 'extractStreamLast' is
--- called.
-
-class Monad m => PreStreamGen m s q | s -> q where
-  preStreamGen
-    :: s      -- ^ the composite type of the arguments
-    -> DIM2   -- ^ the original index @(Z:.i:.j)@
-    -> S.Stream m q -- ^ the stream we get out of it
-
--- | Creates the single step on the left which does nothing more then set the
--- outermost indices to (i,j). This does not use the alpha/omega's
-
-singlePreStreamGen ij = S.unfoldr step ij where
-  {-# INLINE step #-}
-  step (Z:.i:.j)
-    | i<=j      = Just ((Z:.i:.j ,Z,Z), Z:.j+1:.j)
-    | otherwise = Nothing
-{-# INLINE singlePreStreamGen #-}
-
-#define mkPreStreamGen(s) \
-instance (Monad m) => PreStreamGen m (s) (DIM2,Z,Z) where { \
-  {-# INLINE preStreamGen #-} \
-;  preStreamGen _ = singlePreStreamGen }
-
-mkPreStreamGen(DIM2 -> Scalar elm)
-mkPreStreamGen(DIM2 -> ScalarM elm)
-mkPreStreamGen(DIM2 -> Vect elm)
-mkPreStreamGen(DIM2 -> VectM elm)
-mkPreStreamGen(ZU.MArr0 s sh elm)
-mkPreStreamGen(ZU.Arr0 sh elm)
-
-mkPreStreamGen(Z.MArr0 s sh (VU.Vector elm))
-mkPreStreamGen(Z.Arr0 sh (VU.Vector elm))
-
--- | the first two arguments from nextTo, monadic xs.
-
-instance ( Monad m
-         , ExtractValue m xs, Asor xs ~ cX, Elem xs ~ eX
-         , PreStreamGen m xs xsStack
-         , (idxX,adxX,argX) ~ xsStack
-         , (z0:.Int:.Int) ~ idxX
-         , ((idxX,adxX,argX) -> m (idxX:.Int,adxX,argX)) ~ mk
-         , ((idxX:.Int,adxX,argX) -> m (S.Step (idxX:.Int,adxX,argX) (idxX:.Int,adxX,argX))) ~ step
-         ) => PreStreamGen m (Box mk step xs ys) (idxX:.Int,adxX:.cX,argX:.eX) where
-  preStreamGen (Box mk step xs ys) ij
-    = extractStream xs
-    $ S.flatten mk step Unknown
-    $ preStreamGen xs ij
-  {-# INLINE preStreamGen #-}
-
--- | Pre-stream generation for deeply nested boxes.
-
-instance
-  ( Monad m
-  , ExtractValue m xs, Asor xs ~ cX, Elem xs ~ eX
-  , PreStreamGen m (Box box2 box3 box1 xs) xsStack
-  , (idxX,adxX,argX) ~ xsStack
-  , (z0:.Int:.Int) ~ idxX
-  , ((idxX,adxX,argX) -> m (idxX:.Int,adxX,argX)) ~ mk
-  , ((idxX:.Int,adxX,argX) -> m (S.Step (idxX:.Int,adxX,argX) (idxX:.Int,adxX,argX))) ~ step
-  ) => PreStreamGen m (Box mk step (Box box2 box3 box1 xs) ys) (idxX:.Int,adxX:.cX,argX:.eX) where
-  preStreamGen (Box mk step box@(Box _ _ _ xs) ys) ij
-    = extractStream xs
-    $ S.flatten mk step Unknown
-    $ preStreamGen box ij
-  {-# INLINE preStreamGen #-}
-
-
-
--- * ExtractValue: extract values from data structures.
-
-class (Monad m) => ExtractValue m cnt where
-  type Asor cnt :: *
-  type Elem cnt :: *
-  extractValue  :: ()
-                => cnt
-                -> DIM2
-                -> Asor cnt
-                -> m (Elem cnt)
-  extractStream :: ()
-                => cnt
-                -> S.Stream m (Idx3 z,astack,vstack)
-                -> S.Stream m (Idx3 z,astack:.Asor cnt,vstack:.Elem cnt)
-  extractStreamLast :: ()
-                    => cnt
-                    -> S.Stream m (Idx2 z,astack,vstack)
-                    -> S.Stream m (Idx2 z,astack:.Asor cnt,vstack:.Elem cnt)
-
--- | Mutable arrays.
-
-instance
-  ( PrimMonad m
-  , VU.Unbox elm
-  , PrimState m ~ s
-  , DIM2 ~ sh
-  ) => ExtractValue m (ZU.MArr0 s sh elm) where
-  type Asor (ZU.MArr0 s sh elm) = Z
-  type Elem (ZU.MArr0 s sh elm) = elm
-  extractValue cnt ij z = do
-    x <- PA.readM cnt ij
-    x `seq` return x
-  extractStream cnt stream = S.mapM addElm stream where
-    addElm (z:.k:.x:.l, astack, vstack) = do
-      vadd <- PA.readM cnt (Z:.k:.x)
-      vadd `seq` return (z:.k:.x:.l, astack:.Z, vstack :. vadd)
-  extractStreamLast sngl stream = S.mapM addElm stream where
-    addElm (z:.k:.x, astack, vstack) = do
-      vadd <- PA.readM sngl (Z:.k:.x)
-      vadd `seq` return (z:.k:.x, astack:.Z, vstack:.vadd)
-  {-# INLINE extractValue #-}
-  {-# INLINE extractStream #-}
-  {-# INLINE extractStreamLast #-}
-
--- | Immutable arrays.
-
-instance
-  ( Monad m
-  , VU.Unbox elm
-  , DIM2 ~ sh
-  ) => ExtractValue m (ZU.Arr0 sh elm) where
-  type Asor (ZU.Arr0 sh elm) = Z
-  type Elem (ZU.Arr0 sh elm) = elm
-  extractValue cnt ij z = do
-    let x = PA.index cnt ij
-    x `seq` return x
-  extractStream cnt stream = S.map addElm stream where
-    addElm (z:.k:.x:.l, astack, vstack) = let vadd = PA.index cnt (Z:.k:.x) in
-      vadd `seq` (z:.k:.x:.l, astack:.Z, vstack :. vadd)
-  extractStreamLast cnt stream = S.map addElm stream where
-    addElm (z:.k:.x, astack, vstack) = let vadd = PA.index cnt (Z:.k:.x) in
-      vadd `seq` (z:.k:.x, astack:.Z, vstack:.vadd)
-  {-# INLINE extractValue #-}
-  {-# INLINE extractStream #-}
-  {-# INLINE extractStreamLast #-}
-
--- | Function with 'Scalar' return value.
-
-instance
-  ( Monad m
-  ) => ExtractValue m (DIM2 -> Scalar elm) where
-  type Asor (DIM2 -> Scalar elm) = Z
-  type Elem (DIM2 -> Scalar elm) = elm
-  extractValue cnt ij z = do
-    let Scalar x = cnt ij
-    x `seq` return x
-  extractStream cnt stream = S.map addElm stream where
-    addElm (z:.k:.x:.l, astack, vstack) = let Scalar vadd = cnt (Z:.k:.x) in
-      vadd `seq` (z:.k:.x:.l, astack:.Z, vstack :. vadd)
-  extractStreamLast cnt stream = S.map addElm stream where
-    addElm (z:.k:.x, astack, vstack) = let Scalar vadd = cnt (Z:.k:.x) in
-      vadd `seq` (z:.k:.x, astack:.Z, vstack:.vadd)
-  {-# INLINE extractValue #-}
-  {-# INLINE extractStream #-}
-  {-# INLINE extractStreamLast #-}
-
--- | Function with monadic 'Scalar' return value.
-
-instance
-  ( Monad m
-  ) => ExtractValue m (DIM2 -> ScalarM (m elm)) where
-  type Asor (DIM2 -> ScalarM (m elm)) = Z
-  type Elem (DIM2 -> ScalarM (m elm)) = elm
-  extractValue cnt ij z = do
-    let ScalarM x' = cnt ij
-    x <- x'
-    x `seq` return x
-  extractStream cnt stream = S.mapM addElm stream where
-    addElm (z:.k:.x:.l, astack, vstack) = do
-      let ScalarM vadd' = cnt (Z:.k:.x)
-      vadd <- vadd'
-      vadd `seq` return (z:.k:.x:.l, astack:.Z, vstack :. vadd)
-  extractStreamLast cnt stream = S.mapM addElm stream where
-    addElm (z:.k:.x, astack, vstack) = do
-      let ScalarM vadd' = cnt (Z:.k:.x)
-      vadd <- vadd'
-      vadd `seq` return (z:.k:.x, astack:.Z, vstack:.vadd)
-  {-# INLINE extractValue #-}
-  {-# INLINE extractStream #-}
-  {-# INLINE extractStreamLast #-}
-
--- | This instance is a bit crazy, since the accessor is the current stream
--- itself. No idea how efficient this is (need to squint at CORE), but I plan
--- to use it for backtracking only.
---
--- TODO Using this instance tends to break to optimizer ;-) -- don't use it
--- yet!
-
-instance
-  ( Monad m
-  ) => ExtractValue m (DIM2 -> S.Stream m elm) where
-  type Asor (DIM2 -> S.Stream m elm) = S.Stream m elm
-  type Elem (DIM2 -> S.Stream m elm) = elm
-  extractValue cnt ij z = error "this function is not well-defined for these streams"
-  extractStream cnt stream = S.flatten mk step Unknown $ stream where
-    mk (z:.k:.l:.j,as,vs) = do
-      let strm = cnt (Z:.k:.l)
-      return (z:.k:.l:.j,as:.strm,vs)
-    step (idx,as:.strm,vs) = do
-      isNull <- S.null strm
-      if isNull
-      then return $ S.Done
-      else do hd <- S.head strm
-              hd `seq` return $ S.Yield (idx,as:.strm,vs:.hd) (idx,as:.S.tail strm,vs)
-  extractStreamLast cnt stream = S.flatten mk step Unknown $ stream where
-    mk (z:.l:.j,as,vs) = do
-      let strm = cnt (Z:.l:.j)
-      return (z:.l:.j,as:.strm,vs)
-    step (idx,as:.strm,vs) = do
-      isNull <- S.null strm
-      if isNull
-      then return $ S.Done
-      else do hd <- S.head strm
-              hd `seq` return $ S.Yield (idx,as:.strm,vs:.hd) (idx,as:.S.tail strm,vs)
-  {-# INLINE extractValue #-}
-  {-# INLINE extractStream #-}
-  {-# INLINE extractStreamLast #-}
-
--- | Instance of boxed array with vector-valued cells. We assume that we want
--- to store multiple results for each cell. If the intent is to store one
--- scalar result, use the 'Scalar' wrapper.
-
-instance
-  ( PrimMonad m
-  , Prim elm
-  , VU.Unbox elm
-  , PrimState m ~ s
-  , DIM2 ~ sh
-  ) => ExtractValue m (Z.MArr0 s sh (VU.Vector elm)) where
-  type Asor (Z.MArr0 s sh (VU.Vector elm)) = Int
-  type Elem (Z.MArr0 s sh (VU.Vector elm)) = elm
-  extractValue cnt ij z = do
-    x <- PA.readM cnt ij
-    let y = x `VU.unsafeIndex` z
-    y `seq` return y
-  extractStream cnt stream = S.flatten mk step Unknown $ stream where
-    mk (idx,as,vs) = return (idx,as:.0,vs)
-    step (z:.k:.l:.j,as:.a,vs) = do
-      x <- PA.readM cnt (Z:.k:.l)
-      case (x VU.!? a) of
-        Just v  -> v `seq` return $ S.Yield (z:.k:.l:.j,as:.a,vs:.v) (z:.k:.l:.j,as:.(a+1),vs)
-        Nothing -> return $ S.Done
-  extractStreamLast cnt stream = S.flatten mk step Unknown $ stream where
-    mk (idx,as,vs) = return (idx,as:.0,vs)
-    step (z:.l:.j,as:.a,vs) = do
-      x <- PA.readM cnt (Z:.l:.j)
-      case (x VU.!? a) of
-        Just v  -> v `seq` return $ S.Yield (z:.l:.j,as:.a,vs:.v) (z:.l:.j,as:.(a+1),vs)
-        Nothing -> return $ S.Done
-  {-# INLINE extractValue #-}
-  {-# INLINE extractStream #-}
-  {-# INLINE extractStreamLast #-}
-
--- | vector-based cells
-
-instance
-  ( Monad m
-  , Prim elm
-  , VU.Unbox elm
-  , DIM2 ~ sh
-  ) => ExtractValue m (Z.Arr0 sh (VU.Vector elm)) where
-  type Asor (Z.Arr0 sh (VU.Vector elm)) = Int
-  type Elem (Z.Arr0 sh (VU.Vector elm)) = elm
-  extractValue cnt ij z = do
-    let x = PA.index cnt ij
-    let y = x `VU.unsafeIndex` z
-    y `seq` return y
-  extractStream cnt stream = S.flatten mk step Unknown $ stream where
-    mk (idx,as,vs) = return (idx,as:.0,vs)
-    step (z:.k:.l:.j,as:.a,vs) = do
-      let x = PA.index cnt (Z:.k:.l)
-      case (x VU.!? a) of
-        Just v  -> v `seq` return $ S.Yield (z:.k:.l:.j,as:.a,vs:.v) (z:.k:.l:.j,as:.(a+1),vs)
-        Nothing -> return $ S.Done
-  extractStreamLast cnt stream = S.flatten mk step Unknown $ stream where
-    mk (idx,as,vs) = return (idx,as:.0,vs)
-    step (z:.l:.j,as:.a,vs) = do
-      let x = PA.index cnt (Z:.l:.j)
-      case (x VU.!? a) of
-        Just v  -> v `seq` return $ S.Yield (z:.l:.j,as:.a,vs:.v) (z:.l:.j,as:.(a+1),vs)
-        Nothing -> return $ S.Done
-  {-# INLINE extractValue #-}
-  {-# INLINE extractStream #-}
-  {-# INLINE extractStreamLast #-}
-
-
--- * Apply function 'f' with arguments on a stack 'x'.
---
--- NOTE look at the end of this part for mkApply before writing instances by
--- hand... ;-)
-
-class Apply x where
-  type Fun x :: *
-  apply :: Fun x -> x
-
-instance Apply (Z:.a -> res) where
-  type Fun (Z:.a -> res) = a -> res
-  apply fun (Z:.a) = fun a
-  {-# INLINE apply #-}
-
-instance Apply (Z:.a:.b -> res) where
-  type Fun (Z:.a:.b -> res) = a->b -> res
-  apply fun (Z:.a:.b) = fun a b
-  {-# INLINE apply #-}
-
-instance Apply (Z:.a:.b:.c -> res) where
-  type Fun (Z:.a:.b:.c -> res) = a->b->c -> res
-  apply fun (Z:.a:.b:.c) = fun a b c
-  {-# INLINE apply #-}
-
-instance Apply (Z:.a:.b:.c:.d -> res) where
-  type Fun (Z:.a:.b:.c:.d -> res) = a->b->c->d -> res
-  apply fun (Z:.a:.b:.c:.d) = fun a b c d
-  {-# INLINE apply #-}
-
-instance Apply (Z:.a:.b:.c:.d:.e -> res) where
-  type Fun (Z:.a:.b:.c:.d:.e -> res) = a->b->c->d->e -> res
-  apply fun (Z:.a:.b:.c:.d:.e) = fun a b c d e
-  {-# INLINE apply #-}
-
-instance Apply (Z:.a:.b:.c:.d:.e:.f -> res) where
-  type Fun (Z:.a:.b:.c:.d:.e:.f -> res) = a->b->c->d->e->f -> res
-  apply fun (Z:.a:.b:.c:.d:.e:.f) = fun a b c d e f
-  {-# INLINE apply #-}
-
-instance Apply (Z:.a:.b:.c:.d:.e:.f:.g -> res) where
-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g -> res) = a->b->c->d->e->f->g -> res
-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g) = fun a b c d e f g
-  {-# INLINE apply #-}
-
-instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h -> res) where
-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h -> res) = a->b->c->d->e->f->g->h -> res
-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h) = fun a b c d e f g h
-  {-# INLINE apply #-}
-
-instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) where
-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) = a->b->c->d->e->f->g->h->i -> res
-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i) = fun a b c d e f g h i
-  {-# INLINE apply #-}
-
-instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) where
-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) = a->b->c->d->e->f->g->h->i->j -> res
-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j) = fun a b c d e f g h i j
-  {-# INLINE apply #-}
-
-instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) where
-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) = a->b->c->d->e->f->g->h->i->j->k -> res
-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k) = fun a b c d e f g h i j k
-  {-# INLINE apply #-}
-
-instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) where
-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) = a->b->c->d->e->f->g->h->i->j->k->l -> res
-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l) = fun a b c d e f g h i j k l
-  {-# INLINE apply #-}
-
-instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) where
-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m -> res
-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m) = fun a b c d e f g h i j k l m
-  {-# INLINE apply #-}
-
-instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) where
-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n -> res
-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n) = fun a b c d e f g h i j k l m n
-  {-# INLINE apply #-}
-
-instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) where
-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n->o -> res
-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o) = fun a b c d e f g h i j k l m n o
-  {-# INLINE apply #-}
-
-{-
-mkApply to = do
-  let xs    = ['a' .. to]
-  let args  = concat . (":.":) . intersperse ":." . map (:[]) $ xs
-  let arga  = concat . intersperse "->" . map (:[]) $ xs
-  let args' = intersperse ' ' xs
-  printf "instance Apply (Z%s -> res) where\n" args
-  printf "  type Fun (Z%s -> res) = %s -> res\n" args arga
-  printf "  apply fun (Z%s) = fun %s\n" args args'
-  printf "  {-# INLINE apply #-}\n"
--}
-
-
-
--- * helper stuff
-
-data Box mk step xs ys = Box mk step xs ys
-
-type Idx3 z = z:.Int:.Int:.Int
-
-type Idx2 z = z:.Int:.Int
-
-
-
--- * wrappers for functions instead of arrays as arguments. It can be much
--- cheaper in terms of writing code to just provide a function @DIM2 -> Scalar
--- a@ instead of writing instances for your data structure.
-
-newtype Scalar a = Scalar {unScalar :: a}
-
-newtype ScalarM a = ScalarM {unScalarM :: a}
-
-newtype Vect a = Vect {unVect :: a}
-
-newtype VectM a = VectM {unVectM :: a}
diff --git a/ADP/Fusion/Multi.hs b/ADP/Fusion/Multi.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Multi.hs
@@ -0,0 +1,70 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE UnicodeSyntax #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- | The multi-tape extension of ADPfusion. Just re-exports everything.
+
+module ADP.Fusion.Multi
+  ( module ADP.Fusion.Multi.Classes
+  , module ADP.Fusion.Multi.Empty
+  , module ADP.Fusion.Multi.GChr
+  , module ADP.Fusion.Multi.None
+  ) where
+
+import ADP.Fusion.Multi.Classes
+import ADP.Fusion.Multi.None
+import ADP.Fusion.Multi.GChr
+import ADP.Fusion.Multi.Empty
+
+
+
+{-
+type instance TermOf (Term ts (ZeroOne r xs)) = TermOf ts :. Maybe r
+
+instance
+  ( TermValidIndex ts is
+  ) => TermValidIndex (Term ts (ZeroOne r xs)) (is:.PointL) where
+  termDimensionsValid (ts:!ZeroOne (gchr)) = termDimensionsValid (ts:!gchr)
+  {-
+  getTermParserRange (ts:!
+  -}
+
+
+
+
+-- The experimental zero/one wrapper
+
+instance
+  ( Monad m
+  , TermElm m ts is
+  ) => TermElm m (Term ts (ZeroOne r xs)) (is:.PointL) where
+  termStream (ts:!(ZeroOne (GChr f xs))) (io:.o) (is:.ij@(PointL(i:.j)))
+    = doubleStream
+    . termStream (ts:!GChr f xs) (io:.o) (is:.ij)
+    where
+      {-# INLINE doubleStream #-}
+      doubleStream (S.Stream step sS n) = S.Stream sNew (Left sS) (2*n) where
+        {-# INLINE [1] sNew #-}
+        sNew (Left s) = do r <- step s
+                           case r of
+                             S.Yield (abc:!:(es:.e)) s' -> return $ S.Yield (abc:!:(es:.Just e)) (Right s')
+                             S.Skip                  s' -> return $ S.Skip                       (Left  s')
+                             S.Done                     -> return $ S.Done
+        sNew (Right s) = do r <- step s
+                            case r of
+                              S.Yield (abc:!:(es:.e)) s' -> return $ S.Yield (abc:!:(es:.Nothing)) (Left s')
+--                              S.Skip                  s' -> return $ S.Skip                        (Left s')
+--                              S.Done                     -> return $ S.Done
+  {-# INLINE termStream #-}
+-}
+
+
+-- Empty
+
diff --git a/ADP/Fusion/Multi/Classes.hs b/ADP/Fusion/Multi/Classes.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Multi/Classes.hs
@@ -0,0 +1,112 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module ADP.Fusion.Multi.Classes where
+
+import Data.Array.Repa.Index
+import Data.Strict.Tuple
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+
+import ADP.Fusion.Classes
+
+
+
+-- | The zero-th dimension of every terminal parser.
+
+data TermBase = T
+
+-- | Combine a terminal parser of dimension k in @a@ with a new 1-dim parser
+-- @b@ generating a parser of dimension k+1.
+
+data Term a b = a :! b
+
+-- | A 'termStream' extracts all terminal elements from a multi-dimensional
+-- terminal symbol.
+
+class
+  ( Monad m
+  ) => TermElm m t ix where
+  termStream :: t -> InOut ix -> ix -> S.Stream m (ze :!: zix :!: ix) -> S.Stream m (ze :!: zix :!: ix :!: TermOf t)
+
+-- |
+
+type family TermOf t :: *
+
+-- | To calculate parser ranges and index validity we need an additional type
+-- class that recurses over the individual 'Term' elements.
+
+class TermValidIndex t i where
+  termDimensionsValid :: t -> ParserRange i -> i -> Bool
+  getTermParserRange  :: t -> i -> ParserRange i -> ParserRange i
+  termInnerOuter :: t -> i -> InOut i -> InOut i
+  termLeftIndex :: t -> i -> i
+
+
+
+-- * The instance declarations for generic @Term a b@ data ctors.
+
+instance Build (Term a b)
+
+instance
+  ( ValidIndex ls ix
+  , TermValidIndex (Term a b) ix
+  , Show ix
+  , Show (ParserRange ix)
+  ) => ValidIndex (ls :!: Term a b) ix where
+  validIndex (ls :!: t) abc ix =
+    termDimensionsValid t abc ix && validIndex ls abc ix
+  {-# INLINE validIndex #-}
+  getParserRange (ls :!: t) ix = getTermParserRange t ix (getParserRange ls ix)
+  {-# INLINE getParserRange #-}
+
+instance
+  ( Elms ls ix
+  ) => Elms (ls :!: Term a b) ix where
+    data Elm (ls :!: Term a b) ix = ElmTerm !(Elm ls ix) !(TermOf (Term a b)) !ix
+    type Arg (ls :!: Term a b) = Arg ls :. (TermOf (Term a b))
+    getArg !(ElmTerm ls x _) = getArg ls :. x
+    getIdx !(ElmTerm _ _ idx) = idx
+    {-# INLINE getArg #-}
+    {-# INLINE getIdx #-}
+
+instance
+  ( Monad m
+  , Elms ls ix
+  , MkStream m ls ix
+  , TermElm m (Term a b) ix
+  , TermValidIndex (Term a b) ix
+  ) => MkStream m (ls :!: Term a b) ix where
+  mkStream !(ls :!: t) !io !ij
+    = S.map (\(s:!:Z:!:zij:!:e) -> ElmTerm s e zij)
+    $ termStream t io ij
+    $ S.map (\s -> (s :!: Z :!: getIdx s))
+    $ mkStream ls (termInnerOuter t ij io) (termLeftIndex t ij)
+  {-# INLINE mkStream #-}
+
+
+
+-- * Terminal stream of 'TermBase' with index 'Z'
+
+type instance TermOf TermBase = Z
+
+instance
+  ( Monad m
+  ) => TermElm m (TermBase) Z where
+  termStream T _ Z = S.map (\(zs:!:zix:!:Z) -> (zs:!:zix:!:Z:!:Z))
+  {-# INLINE termStream #-}
+
+instance TermValidIndex TermBase Z where
+  termDimensionsValid T Z Z = True
+  getTermParserRange  T Z Z = Z
+  termInnerOuter T Z Z = Z
+  termLeftIndex T Z = Z
+  {-# INLINE termDimensionsValid #-}
+  {-# INLINE getTermParserRange #-}
+  {-# INLINE termInnerOuter #-}
+  {-# INLINE termLeftIndex #-}
+
diff --git a/ADP/Fusion/Multi/Empty.hs b/ADP/Fusion/Multi/Empty.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Multi/Empty.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeOperators #-}
+
+module ADP.Fusion.Multi.Empty where
+
+import Data.Array.Repa.Index
+import Data.Strict.Tuple
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+
+import Data.Array.Repa.Index.Points
+
+import ADP.Fusion.Classes
+import ADP.Fusion.Empty
+import ADP.Fusion.Multi.Classes
+
+
+
+type instance TermOf (Term ts Empty) = TermOf ts :. ()
+
+instance
+  ( Monad m
+  , TermElm m ts is
+  ) => TermElm m (Term ts Empty) (is:.PointL) where
+  termStream (ts:!Empty) (io:.Outer) (is:.ij@(PointL(i:.j))) =
+    S.map (\(zs:!:(zix:.kl):!:zis:!:e) -> (zs:!:zix:!:(zis:.kl):!:(e:.())))
+    . termStream ts io is
+    . S.map (\(zs:!:zix:!:(zis:.kl)) -> (zs:!:(zix:.kl):!:zis))
+  {-# INLINE termStream #-}
+
+instance
+  ( TermValidIndex ts is
+  ) => TermValidIndex (Term ts Empty) (is:.PointL) where
+  termDimensionsValid (ts:!Empty) (prs:.(a:!:b:!:c)) (is:.PointL(i:.j))
+    = termDimensionsValid ts prs is
+  getTermParserRange (ts:!Empty) (is:._) (prs:.(a:!:b:!:c))
+    = getTermParserRange ts is prs :. (a:!:b:!:c)
+  termInnerOuter (ts:!_) (is:._) (ios:.io) = termInnerOuter ts is ios :. io
+  termLeftIndex  (ts:!_) (is:.ij) = termLeftIndex ts is :. ij
+  {-# INLINE termDimensionsValid #-}
+  {-# INLINE getTermParserRange #-}
+  {-# INLINE termInnerOuter #-}
+  {-# INLINE termLeftIndex #-}
+
diff --git a/ADP/Fusion/Multi/GChr.hs b/ADP/Fusion/Multi/GChr.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Multi/GChr.hs
@@ -0,0 +1,101 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeOperators #-}
+
+module ADP.Fusion.Multi.GChr where
+
+import Data.Array.Repa.Index
+import Data.Strict.Tuple
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+import qualified Data.Vector.Generic as VG
+
+import Data.Array.Repa.Index.Points
+import Data.Array.Repa.Index.Subword
+
+import ADP.Fusion.Chr
+import ADP.Fusion.Classes
+import ADP.Fusion.Multi.Classes
+
+
+type instance TermOf (Term ts (GChr r xs)) = TermOf ts :. r
+
+
+
+-- * Multi-dim 'Subword's.
+
+-- TODO we want to evaluate @f xs $ j-1@ just once before the stream is
+-- generated. Unfortunately, this will evaluate cases like index (-1) as well,
+-- which leads to crashes. The code below is safe but slower. We should
+-- incorporate a version that performs and @outerCheck@ in the code.
+
+instance
+  ( Monad m
+  , TermElm m ts is
+  ) => TermElm m (Term ts (GChr r xs)) (is:.Subword) where
+  termStream (ts :! GChr f xs) (io:.Outer) (is:.ij@(Subword(i:.j)))
+    = S.map (\(zs :!: (zix:.kl) :!: zis :!: e) -> (zs :!: zix :!: (zis:.subword (j-1) j) :!: (e:.(f xs $ j-1))))
+    . termStream ts io is
+    . S.map (\(zs :!: zix :!: (zis:.kl)) -> (zs :!: (zix:.kl) :!: zis))
+  termStream (ts :! GChr f xs) (io:.Inner _ _) (is:.ij)
+    = S.map (\(zs :!: (zix:.kl@(Subword(k:.l))) :!: zis :!: e) -> let dta = f xs l in dta `seq` (zs :!: zix :!: (zis:.subword l (l+1)) :!: (e:.dta)))
+    . termStream ts io is
+    . S.map (\(zs :!: zix :!: (zis:.kl)) -> (zs :!: (zix:.kl) :!: zis))
+  {-# INLINE termStream #-}
+
+instance
+  ( TermValidIndex ts is
+  ) => TermValidIndex (Term ts (GChr r xs)) (is:.Subword) where
+  termDimensionsValid (ts:!GChr _ xs) (prs:.(a:!:b:!:c)) (is:.Subword(i:.j))
+    = i>=a && j<=VG.length xs -c && i+b<=j && termDimensionsValid ts prs is
+  getTermParserRange (ts:!GChr _ _) (is:._) (prs:.(a:!:b:!:c))
+    = getTermParserRange ts is prs :. (a:!:b+1:!:max 0 (c-1))
+  termInnerOuter (ts:!_) (is:._) (ios:.io) = termInnerOuter ts is ios :. io
+  termLeftIndex  (ts:!_) (is:.Subword (i:.j)) = termLeftIndex ts is :. subword i (j-1)
+  {-# INLINE termDimensionsValid #-}
+  {-# INLINE getTermParserRange #-}
+  {-# INLINE termInnerOuter #-}
+  {-# INLINE termLeftIndex #-}
+
+
+
+-- * Multi-dim 'PointL's
+
+-- | NOTE This instance is currently the only one using an "inline outer
+-- check". If This behaves well, it could be possible to put checks for valid
+-- indices inside the outerCheck function. (Currently disabled, as the compiler
+-- chokes on four-way alignments).
+
+instance
+  ( Monad m
+  , TermElm m ts is
+  ) => TermElm m (Term ts (GChr r xs)) (is:.PointL) where
+  termStream (ts :! GChr f xs) (io:.Outer) (is:.ij@(PointL(i:.j)))
+    -- = outerCheck (j>0)
+    -- . let dta = (f xs $ j-1) in dta `seq` S.map (\(zs :!: (zix:.kl) :!: zis :!: e) -> (zs :!: zix :!: (zis:.pointL (j-1) j) :!: (e:.dta)))
+    = S.map (\(zs :!: (zix:.kl) :!: zis :!: e) -> (zs :!: zix :!: (zis:.pointL (j-1) j) :!: (e:.(f xs $ j-1))))
+    . termStream ts io is
+    . S.map (\(zs :!: zix :!: (zis:.kl)) -> (zs :!: (zix:.kl) :!: zis))
+  termStream (ts :! GChr f xs) (io:.Inner _ _) (is:.ij)
+    = S.map (\(zs :!: (zix:.kl@(PointL(k:.l))) :!: zis :!: e) -> let dta = f xs l in dta `seq` (zs :!: zix :!: (zis:.pointL l (l+1)) :!: (e:.dta)))
+    . termStream ts io is
+    . S.map (\(zs :!: zix :!: (zis:.kl)) -> (zs :!: (zix:.kl) :!: zis))
+  {-# INLINE termStream #-}
+
+-- TODO auto-generated, check correctness
+
+instance
+  ( TermValidIndex ts is
+  ) => TermValidIndex (Term ts (GChr r xs)) (is:.PointL) where
+  termDimensionsValid (ts:!GChr _ xs) (prs:.(a:!:b:!:c)) (is:.PointL(i:.j))
+    = {- i>=a && j<=VG.length xs -c && i+b<=j && -} termDimensionsValid ts prs is
+  getTermParserRange (ts:!GChr _ _) (is:._) (prs:.(a:!:b:!:c))
+    = getTermParserRange ts is prs :. (a:!:b+1:!:max 0 (c-1))
+  termInnerOuter (ts:!_) (is:._) (ios:.io) = termInnerOuter ts is ios :. io
+  termLeftIndex  (ts:!_) (is:.PointL (i:.j)) = termLeftIndex ts is :. pointL i (j-1)
+  {-# INLINE termDimensionsValid #-}
+  {-# INLINE getTermParserRange #-}
+  {-# INLINE termInnerOuter #-}
+  {-# INLINE termLeftIndex #-}
+
diff --git a/ADP/Fusion/Multi/None.hs b/ADP/Fusion/Multi/None.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Multi/None.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeOperators #-}
+
+module ADP.Fusion.Multi.None where
+
+import Data.Array.Repa.Index
+import Data.Strict.Tuple
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+
+import Data.Array.Repa.Index.Points
+
+import ADP.Fusion.Classes
+import ADP.Fusion.Multi.Classes
+import ADP.Fusion.None
+
+
+
+type instance TermOf (Term ts None) = TermOf ts :. ()
+
+instance
+  ( Monad m
+  , TermElm m ts is
+  ) => TermElm m (Term ts None) (is:.PointL) where
+  termStream (ts :! None) (io:.Outer) (is:.ij@(PointL(i:.j))) =
+    S.map (\(zs :!: (zix:.kl) :!: zis :!: e) -> (zs :!: zix :!: (zis:.kl) :!: (e:.())))
+    . termStream ts io is
+    . S.map (\(zs :!: zix :!: (zis:.kl)) -> (zs :!: (zix:.kl) :!: zis))
+  termStream (ts :! None) (io:.Inner _ _) (is:.ij)
+    = S.map (\(zs :!: (zix:.kl) :!: zis :!: e) -> (zs :!: zix :!: (zis:.kl) :!: (e:.())))
+    . termStream ts io is
+    . S.map (\(zs :!: zix :!: (zis:.kl)) -> (zs :!: (zix:.kl) :!: zis))
+  {-# INLINE termStream #-}
+
+-- TODO auto-gen'ed
+
+instance
+  ( TermValidIndex ts is
+  ) => TermValidIndex (Term ts None) (is:.PointL) where
+  termDimensionsValid (ts:!None) (prs:.(a:!:b:!:c)) (is:.PointL(i:.j))
+    = termDimensionsValid ts prs is
+  getTermParserRange (ts:!None) (is:._) (prs:.(a:!:b:!:c))
+    = getTermParserRange ts is prs :. (a:!:b:!:c)
+  termInnerOuter (ts:!_) (is:._) (ios:.io) = termInnerOuter ts is ios :. io
+  termLeftIndex  (ts:!_) (is:.ij) = termLeftIndex ts is :. ij
+  {-# INLINE termDimensionsValid #-}
+  {-# INLINE getTermParserRange #-}
+  {-# INLINE termInnerOuter #-}
+  {-# INLINE termLeftIndex #-}
+
diff --git a/ADP/Fusion/None.hs b/ADP/Fusion/None.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/None.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module ADP.Fusion.None where
+
+import Data.Array.Repa.Index
+import Data.Strict.Maybe
+import Data.Strict.Tuple
+import Prelude hiding (Maybe(..))
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+
+import Data.Array.Repa.Index.Subword
+
+import ADP.Fusion.Classes
+
+
+
+data None = None
+
+none = None
+{-# INLINE none #-}
+
+-- None is always valid
+
+instance
+  ( ValidIndex ls Subword
+  ) => ValidIndex (ls :!: None) Subword where
+    validIndex (ls:!:None) abc ij@(Subword (i:.j)) = validIndex ls abc ij
+    {-# INLINE validIndex #-}
+
+instance Build None
+
+instance
+  ( Elms ls Subword
+  ) => Elms (ls :!: None) Subword where
+  data Elm (ls :!: None) Subword = ElmNone !(Elm ls Subword) !() !Subword
+  type Arg (ls :!: None) = Arg ls :. ()
+  getArg !(ElmNone ls () _) = getArg ls :. ()
+  getIdx !(ElmNone _ _ i)   = i
+  {-# INLINE getArg #-}
+  {-# INLINE getIdx #-}
+
+instance
+  ( Monad m
+  , Elms ls Subword
+  , MkStream m ls Subword
+  ) => MkStream m (ls:!:None) Subword where
+  mkStream !(ls:!:None) Outer !ij@(Subword (i:.j))
+    = S.map (\s -> ElmNone s () (subword i j))
+    $ S.filter (\_ -> i==j)
+    $ mkStream ls Outer ij
+  {-# INLINE mkStream #-}
+
diff --git a/ADP/Fusion/QuickCheck.hs b/ADP/Fusion/QuickCheck.hs
--- a/ADP/Fusion/QuickCheck.hs
+++ b/ADP/Fusion/QuickCheck.hs
@@ -1,185 +1,531 @@
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 
--- | QuickCheck properties for a number of ADPfusion combinators. Each test is
--- once written using ADPfusion and once using list comprehensions. Typing
--- @allProps@ in ghci will run all tests, prefixed @prop_@ with a thousand
--- tests each.
-
 module ADP.Fusion.QuickCheck where
 
-import Data.List
-import Data.Vector.Fusion.Stream.Size
-import Data.Vector.Fusion.Util
+import Control.Monad
+import Control.Applicative
+import Data.Array.Repa.Index
+import Data.Array.Repa.Shape
+import Data.Array.Repa.Arbitrary
+import Debug.Trace
 import qualified Data.Vector.Fusion.Stream as S
+import qualified Data.Vector.Fusion.Stream.Monadic as SM
 import qualified Data.Vector.Unboxed as VU
 import Test.QuickCheck
 import Test.QuickCheck.All
+import Test.QuickCheck.Monadic
+import Data.List ((\\))
+import System.IO.Unsafe
 
-import "PrimitiveArray" Data.Array.Repa.Index
+import Data.Array.Repa.Index.Subword
+import Data.Array.Repa.Index.Point
+import Data.Array.Repa.Index.Points
+import qualified Data.PrimitiveArray as PA
+import qualified Data.PrimitiveArray.Zero as PA
 
-import ADP.Fusion.QuickCheck.Arbitrary
-import qualified ADP.Fusion as F
-import qualified ADP.Fusion.Monadic as M
-import qualified ADP.Fusion.Monadic.Internal as F
+import ADP.Fusion
+import ADP.Fusion.Table
+import ADP.Fusion.Multi
 
 
+-- | Check if a single region returns the correct result (namely a slice from
+-- the input).
 
-options = stdArgs {maxSuccess = 1000}
+prop_R sw@(Subword (i:.j)) = zs == ls where
+  zs = id <<< region xs ... S.toList $ sw
+  ls = [VU.slice i (j-i) xs | i>=0, j<=100]
 
-customCheck = quickCheckWithResult options
+-- | Two regions next to each other.
 
-allProps = $forAllProperties customCheck
+prop_RR sw@(Subword (i:.j)) = zs == ls where
+  zs = (,) <<< region xs % region xs ... S.toList $ sw
+  ls = [(VU.slice i (k-i) xs, VU.slice k (j-k) xs) | k <- [i..j]]
 
+-- | And finally, three regions (with smaller subword sizes only)
 
+prop_RRR sw@(Subword (i:.j)) = (j-i<=30) ==> zs == ls where
+  zs = (,,) <<< region xs % region xs % region xs ... S.toList $ sw
+  ls = [  ( VU.slice i (k-i) xs
+          , VU.slice k (l-k) xs
+          , VU.slice l (j-l) xs
+          ) | k <- [i..j], l <- [k..j]]
 
--- * Some definitions:
---
--- @O@ means one
--- @M@ means many
--- @P@ means one or more
--- @ML_x_y@ is for a makeLeftCombinator with boundaries x and y
+-- | Three sized regions (with smaller subword sizes only)
 
--- ** @xs -~+ ys@, size @xs@ = 1, size @ys@ >= 1.
+prop_SSS sw@(Subword (i:.j)) = zs == ls where
+  zs = (,,) <<< sregion 3 10 xs % sregion 3 10 xs % sregion 3 10 xs ... S.toList $ sw
+  ls = [  ( VU.slice i (k-i) xs
+          , VU.slice k (l-k) xs
+          , VU.slice l (j-l) xs
+          ) | k <- [i..j], l <- [k..j], minimum [k-i,l-k,j-l] >=3, maximum [k-i,l-k,j-l] <= 10]
 
-fOP (i,j) = S.toList $ (,) F.<<< fRegion F.-~+ fRegion F.... id $ Z:.i:.j
+-- | Single-character parser.
 
-lOP (i,j) = [ ((i,i+1), (i+1,j)) | i+1<=j-1 ]
+prop_C sw@(Subword (i:.j)) = zs == ls where
+  zs = id <<< chr xs ... S.toList $ sw
+  ls = [xs VU.! i | i+1==j, i>=0, j<=100]
 
-prop_OP = fOP === lOP
+-- | 2x Single-character parser.
 
--- ** @xs -~~ ys -~~ zs@, size @xs@ = 1, size @ys@ = 1, size @zs@ >= 0.
+prop_CC sw@(Subword (i:.j)) = zs == ls where
+  zs = (,) <<< chr xs % chr xs ... S.toList $ sw
+  ls = [(xs VU.! i, xs VU.! (i+1)) | i+2==j]
 
-fOOP (i,j) = S.toList $ (,,) F.<<< fRegion F.-~~ fRegion F.-~~ fRegion F.... id $ Z:.i:.j
+-- ** Single character plus peeking
 
-lOOP (i,j) = [ ( (i,i+1), (i+1,i+2), (i+2,j) ) | i+2<=j ]
+prop_PlC sw@(Subword (i:.j)) = zs == ls where
+  zs = (,) <<< peekL xs % chr xs ... S.toList $ sw
+  ls = [(xs VU.! (j-2), xs VU.! (j-1)) | j>1, i+1==j]
 
-prop_OOP = fOOP === lOOP
+prop_PrC sw@(Subword (i:.j)) = zs == ls where
+  zs = (,) <<< peekR xs % chr xs ... S.toList $ sw
+  ls = [(xs VU.! (j-1), xs VU.! (j-1)) | i+1==j]
 
--- ** @xs +~- ys@, size @xs@ >= 1, size @ys@ = 1.
+prop_CPr sw@(Subword (i:.j)) = zs == ls where
+  zs = (,) <<< chr xs % peekR xs ... S.toList $ sw
+  ls = [(xs VU.! (j-1), xs VU.! j) | i>=0, j<=99,i+1==j]
 
-fPO (i,j) = S.toList $ (,) F.<<< fRegion F.+~- fRegion F.... id $ Z:.i:.j
+prop_CPl sw@(Subword (i:.j)) = zs == ls where
+  zs = (,) <<< chr xs % peekL xs ... S.toList $ sw
+  ls = [(xs VU.! (j-1), xs VU.! (j-1)) | i+1==j]
 
-lPO (i,j) = [ ( (i,j-1), (j-1,j) ) | i+1<=j-1 ]
+-- | 2x Single-character parser bracketing a single region.
 
-prop_PO (Small i, Small j) = fPO (i,j) == lPO (i,j)
+prop_CRC sw@(Subword (i:.j)) = zs == ls
+  where
+    zs = (,,) <<< chr xs % region xs % chr xs ... S.toList $ sw
+    ls = [(xs VU.! i, VU.slice (i+1) (j-i-2) xs , xs VU.! (j-1)) |i+2<=j]
 
--- ** @xs -~+ ys +~- zs@, size @xs@ = 1, size @ys@ >= 1, size @zs@ = 1. This is
--- a "hairpin" in RNA bioinformatics.
+-- | 2x Single-character parser bracketing regions.
 
-fOPO (i,j) = S.toList $ (,,) F.<<< fRegion F.-~+ fRegion F.+~- fRegion F.... id $ Z:.i:.j
+prop_CRRC sw@(Subword (i:.j)) = zs == ls
+  where
+    zs = (,,,) <<< chr xs % region xs % region xs % chr xs ... S.toList $ sw
+    ls = [ ( xs VU.! i
+           , VU.slice (i+1) (k-i-1) xs
+           , VU.slice k (j-k-1) xs
+           , xs VU.! (j-1)
+           ) | k <- [i+1 .. j-1]]
 
-lOPO (i,j) = [ ( (i,i+1), (i+1,j-1), (j-1,j) ) | i+2<=j, i+1<j-1 ]
+-- | complex behaviour with characters and regions
 
-prop_OPO = fOPO === lOPO
+prop_CRCRC sw@(Subword (i:.j)) = zs == ls where
+  zs = (,,,,) <<< chr xs % region xs % chr xs % region xs % chr xs ... S.toList $ sw
+  ls = [ ( xs VU.! i
+         , VU.slice (i+1) (k-i-1) xs
+         , xs VU.! k
+         , VU.slice (k+1) (j-k-2) xs
+         , xs VU.! (j-1)
+         ) | k <- [i+1 .. j-2] ]
 
--- ** The central region is non-empty, with two size-1 regions on each side.
--- Will create @O(n)@ candidates, which will all fail, except for the last one
--- (if @j-i@ is large enough).
+-- | Interior-loop like structures.
 
-fOOPOOslow (i,j) = S.toList $ (,,,,) F.<<< fRegion F.-~+ fRegion F.-~+ fRegion F.+~+ fRegion F.-~- fRegion F.... id $ Z:.i:.j
+prop_Interior1 sw@(Subword (i:.j)) = zs == ls where
+  zs = (,,) <<< chr xs % peekR xs % sregion 1 5 xs ... S.toList $ sw
+  ls = [ ( xs VU.! i
+         , xs VU.! (i+1)
+         , VU.slice (i+1) (j-i-1) xs
+         ) | j-i>=2, j-i<=6
+       ]
 
-lOOPOO (i,j) = [ ( (i,i+1), (i+1,i+2), (i+2,j-2), (j-2,j-1), (j-1,j) ) | i+4<=j, i+2<j-2 ]
+prop_Interior2 sw@(Subword (i:.j)) = zs == ls where
+  zs = (,,,,) <<< chr xs % peekR xs % sregion 1 5 xs % peekR xs % sregion 2 5 xs ... S.toList $ sw
+  ls = [ ( xs VU.! i
+         , xs VU.! (i+1)
+         , VU.slice (i+1) (k-i-1) xs
+         , xs VU.! k
+         , VU.slice k (j-k) xs
+         ) | j-i>=4, j-i<=11, k <- [i+2 .. (min j $ i+6)], j-k>=2, j-k<=5
+       ]
 
-prop_OOPOOslow = fOOPOOslow === lOOPOO
+prop_Interior3 sw@(Subword (i:.j)) = zs == ls where
+  zs = (,,,,,,) <<< chr xs % peekR xs % sregion 1 5 xs % peekR xs % sregion 2 5 xs % peekL xs % sregion 1 5 xs ... S.toList $ sw
+  ls = [ ( xs VU.! i
+         , xs VU.! (i+1)
+         , VU.slice (i+1) (k-i-1) xs
+         , xs VU.! k
+         , VU.slice k (l-k) xs
+         , xs VU.! (l-1)
+         , VU.slice l (j-l) xs
+         ) | i>= 0
+           , j<= 100
+           , k <- [i..j]
+           , l <- [k..j]
+           , j-i>=5, j-i<=16
+           , k-i-1>=1, k-i-1<=5
+           , l-k>=2, l-k<=5
+           , j-l>=1, j-l<=5
+       ]
 
--- ** The above test can be sped up by the use of the @+~--@ combinator. It
--- fixes the left and right side, by allowing only exactly size two on its
--- right. Each combinator here will 'Yield' exactly once, then be 'Done'.
+prop_Interior4 sw@(Subword (i:.j)) = zs == ls where
+  zs = (,,,,,,,,) <<< chr xs % peekR xs % sregion 1 5 xs % peekR xs % sregion 2 5 xs % peekL xs % sregion 1 5 xs % peekL xs % chr xs ... S.toList $ sw
+  ls = [ ( xs VU.! i
+         , xs VU.! (i+1)
+         , VU.slice (i+1) (k-i-1) xs
+         , xs VU.! k
+         , VU.slice k (l-k) xs
+         , xs VU.! (l-1)
+         , VU.slice l (j-l-1) xs
+         , xs VU.! (j-2)
+         , xs VU.! (j-1)
+         ) | k <- [i..j]
+           , l <- [k..j]
+           , j-i>=6, j-i<=17
+           , k-i-1>=1, k-i-1<=5
+           , l-k>=2, l-k<=5
+           , j-l-1>=1, j-l-1<=5
+       ]
 
-fOOPOOfast (i,j) = S.toList $ (,,,,) F.<<< fRegion F.-~+ fRegion F.-~+ fRegion F.+~-- fRegion F.-~- fRegion F.... id $ Z:.i:.j
+prop_Interior5 sw@(Subword (i:.j)) = zs == ls where
+  zs = (,,,,,,,,,,) <<< peekL xs % chr xs % peekR xs % sregion 1 5 xs % peekR xs % sregion 2 5 xs % peekL xs % sregion 1 5 xs % peekL xs % chr xs % peekR xs ... S.toList $ sw
+  ls = [ ( xs VU.! (i-1)
+         , xs VU.! i
+         , xs VU.! (i+1)
+         , VU.slice (i+1) (k-i-1) xs
+         , xs VU.! k
+         , VU.slice k (l-k) xs
+         , xs VU.! (l-1)
+         , VU.slice l (j-l-1) xs
+         , xs VU.! (j-2)
+         , xs VU.! (j-1)
+         , xs VU.! j
+         ) | i>= 1
+           , j<= 99
+           , k <- [i..j]
+           , l <- [k..j]
+           , i>0, j-1 < VU.length xs
+           , j-i>=6, j-i<=17
+           , k-i-1>=1, k-i-1<=5
+           , l-k>=2, l-k<=5
+           , j-l-1>=1, j-l-1<=5
+       ]
 
-prop_OOPOOfast = fOOPOOfast === lOOPOO
+-- | A single mutable table should return one result.
 
--- ** A complex right-hand side which was problematic in 0.0.0.3 of ADPfusion.
--- In original ADP @base -~~ weak ~~- base +~+ string@ we want the @base@ parts
--- to have size 1, @weak@ of any size, and @string@ to be non-empty. In
--- ADPfusion @as -~+ bs@ means that @as@ has size one, @bs@ size 1 or more.
+prop_Mt sw@(Subword (i:.j)) = monadicIO $ do
+    mxs :: PA.MutArr IO (PA.Unboxed (Z:.Subword) Int) <- run $ PA.fromListM (Z:. Subword (0:.0)) (Z:. Subword (0:.100)) [0 .. ] -- (1 :: Int)
+    let mt = mTblSw EmptyT mxs
+    zs <- run $ id <<< mt ... SM.toList $ sw
+    ls <- run $ sequence $ [(PA.readM mxs (Z:.sw)) | i<=j]
+    assert $ zs == ls
 
-fOPOP (i,j) = S.toList $ (,,,) F.<<< fRegion F.-~+ fRegion F.+~+ fRegion F.-~+ fRegion F.... id $ Z:.i:.j
+-- | table, then character.
 
-lOPOP (i,j) = [ ( (i,i+1), (i+1,k), (k,k+1), (k+1,j) ) | k <- [i+1 .. j-2], i+1<k, k+1<j ]
+prop_MtC sw@(Subword (i:.j)) = monadicIO $ do
+    mxs :: (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int)) <- run $ PA.fromListM (Z:. Subword (0:.0)) (Z:. Subword (0:.100)) [0 .. ] -- (1 :: Int)
+    let mt = mTblSw EmptyT mxs
+    zs <- run $ (,) <<< mt % chr xs ... SM.toList $ sw
+    ls <- run $ sequence $ [(PA.readM mxs (Z:.subword i (j-1))) >>= \a -> return (a,xs VU.! (j-1)) | i<j]
+    assert $ zs == ls
 
-prop_OPOP = fOPOP === lOPOP
+-- | Character, then table.
 
--- ** One more of those complex right-hand sides. This one is already rather
--- complicated. We have @one -~+ one -~+ many +~+ one -~~ one -~+ plus@ where
--- @one@ has size 1, many has size 0 to many, plus has size 1 to many. The last
--- combinator @-~+@ again short-curcuits by being 'Done' once the left-hand
--- side is larger than one.
+prop_CMt sw@(Subword (i:.j)) = monadicIO $ do
+    mxs :: (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int)) <- run $ PA.fromListM (Z:. Subword (0:.0)) (Z:. Subword (0:.100)) [0 .. ] -- (1 :: Int)
+    let mt = mTblSw EmptyT mxs
+    zs <- run $ (,) <<< chr xs % mt ... SM.toList $ sw
+    ls <- run $ sequence $ [(PA.readM mxs (Z:.subword (i+1) j)) >>= \a -> return (xs VU.! i,a) | i<j]
+    assert $ zs == ls
 
-fOOPOOP (i,j) = S.toList $ (,,,,,) F.<<< fRegion F.-~+ fRegion F.-~+ fRegion F.+~+ fRegion F.-~~ fRegion F.-~+ fRegion F.... id $ Z:.i:.j
+-- | Two mutable tables. Basically like Region's.
 
-lOOPOOP (i,j) = [ ( (i,i+1), (i+1,i+2), (i+2,k), (k,k+1), (k+1,k+2), (k+2,j) ) | k <- [i+2 .. j-3], i+2<k, k+2<j ]
+prop_MtMt sw@(Subword (i:.j)) = monadicIO $ do
+    mxs :: (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int)) <- run $ PA.fromListM (Z:. Subword (0:.0)) (Z:. Subword (0:.100)) [0 .. ] -- (1 :: Int)
+    let mt = mTblSw EmptyT mxs
+    zs <- run $ (,) <<< mt % mt ... SM.toList $ sw
+    ls <- run $ sequence $ [(PA.readM mxs (Z:.subword i k)) >>= \a -> PA.readM mxs (Z:.subword k j) >>= \b -> return (a,b) | k <- [i..j]]
+    assert $ zs == ls
 
-prop_OOPOOP = fOOPOOP === lOOPOOP
+-- | Just to make it more interesting, sprinkle in some 'Chr' symbols.
 
--- ** We now introduce two independently moving indices and size zero regions.
+prop_CMtCMtC sw@(Subword (i:.j)) = monadicIO $ do
+    mxs :: (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int)) <- run $ PA.fromListM (Z:. Subword (0:.0)) (Z:. Subword (0:.100)) [0 .. ] -- (1 :: Int)
+    let mt = mTblSw EmptyT mxs
+    zs <- run $ (,,,,) <<< chr xs % mt % chr xs % mt % chr xs ... SM.toList $ sw
+    ls <- run $ sequence $ [ (PA.readM mxs (Z:.subword (i+1) k)) >>=
+                            \a -> PA.readM mxs (Z:.subword (k+1) (j-1)) >>=
+                            \b -> return ( xs VU.! i
+                                         , a
+                                         , xs VU.! k
+                                         , b
+                                         , xs VU.! (j-1)
+                                         )
+                           | k <- [i+1..j-2]]
+    assert $ zs == ls
 
-fMMM (i,j) = S.toList $ (,,) F.<<< fRegion F.~~~ fRegion F.~~~ fRegion F.... id $ Z:.i:.j
+-- | And now with non-empty tables.
 
-lMMM (i,j) = [ ( (i,k), (k,l), (l,j) ) | k <- [i..j], l<-[k..j] ]
+prop_CMnCMnC sw@(Subword (i:.j)) = monadicIO $ do
+    mxs :: (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int)) <- run $ PA.fromListM (Z:. Subword (0:.0)) (Z:. Subword (0:.100)) [0 .. ] -- (1 :: Int)
+    let mt = mTblSw NonEmptyT mxs
+    zs <- run $ (,,,,) <<< chr xs % mt % chr xs % mt % chr xs ... SM.toList $ sw
+    ls <- run $ sequence $ [ (PA.readM mxs (Z:.subword (i+1) k)) >>=
+                            \a -> PA.readM mxs (Z:.subword (k+1) (j-1)) >>=
+                            \b -> return ( xs VU.! i
+                                         , a
+                                         , xs VU.! k
+                                         , b
+                                         , xs VU.! (j-1)
+                                         )
+                           | k <- [i+2..j-3]]
+    assert $ zs == ls
 
-prop_MMM = fMMM === lMMM
+{-
+ - Currently not allowing 0-dim multi-tapes.
 
--- ** Three independent regions, each one enclosed by two size-1 regions.
--- Compile-time hog.
+prop_Tt ix@Z = zs == ls where
+  zs = id <<< T ... S.toList $ ix
+  ls = [ Z ]
+-}
 
-fOPOOPOOPO (i,j) = S.toList $ (,,,,,,,,) F.<<< fRegion F.-~+ fRegion F.+~+ fRegion F.-~+
-                                          {--} fRegion F.-~+ fRegion F.+~+ fRegion F.-~+
-                                          {--} fRegion F.-~+ fRegion F.+~- fRegion F.... id $ Z:.i:.j
+-- **
 
-lOPOOPOOPO (i,j) = [ ( (i,i+1), (i+1,k), (k,k+1), {--} (k+1,k+2), (k+2,l), (l,l+1), {--} (l+1,l+2), (l+2,j-1), (j-1,j) )
-                   | k<-[i+1 .. j-5], l<-[k+2 .. j-3], i+1<k, k+2<l, l+2<j-1 ]
+prop_Tc ix@(Z:.Subword(i:.j)) = zs == ls where
+  zs = id <<< (T:!chr xs) ... S.toList $ ix
+  ls = [ (Z:.xs VU.! i) | i>=0, j<= 100, i+1==j ]
 
-prop_OPOOPOOPO = fOPOOPOOPO === lOPOOPOOPO
+prop_Tcc ix@(Z:.Subword(i:.j):.Subword(k:.l)) = zs == ls where
+  zs = id <<< (T:!chr xs:!chr xs) ... S.toList $ ix
+  ls = [ (Z:.xs VU.! i:.xs VU.! k) | i>=0, j<=100, k>=0, j<=100, i+1==j, k+1==l ]
 
--- ** Two non-empty regions, the right one with single-size regions around it.
--- (sorry about the name)
+-- **
 
-fPOPO (i,j) = S.toList $ (,,,) F.<<< fRegion F.+~+ fRegion F.-~+ fRegion F.+~- fRegion F.... id $ Z:.i:.j
+prop_TcTc ix@(Z:.Subword(i:.j)) = zs == ls where
+  zs = (,) <<< (T:!chr xs) % (T:!chr xs) ... S.toList $ ix
+  ls = [ (Z:.xs VU.! i,Z:.xs VU.! (i+1)) | i>=0, j<= 100, i+2==j ]
 
-lPOPO (i,j) = [ ( (i,k), (k,k+1), (k+1,j-1), (j-1,j) ) | k <- [i+1 .. j-3] ]
+prop_TccTcc ix@(Z:.Subword(i:.j):.Subword(k:.l)) = zs == ls where
+  zs = (,) <<< (T:!chr xs:!chr xs) % (T:!chr xs:!chr xs) ... S.toList $ ix
+  ls = [ (Z:.xs VU.! i:.xs VU.! k, Z:.xs VU.! (i+1):.xs VU.! (k+1)) | i>=0, j<=100, k>=0, j<=100, i+2==j, k+2==l ]
 
-prop_POPO (Small i, Small j) = fPOPO (i,j) == lPOPO (i,j)
+-- **
 
--- ** Sanity-checking special constraints.
+prop_Mt2 ix@(Z:.Subword(i:.j)) = monadicIO $ do
+  mxs :: PA.MutArr IO (PA.Unboxed (Z:.Subword) Int) <- run $ PA.fromListM (Z:.subword 0 0) (Z:.subword 0 100) [0 ..]
+  let mt = mTbl (Z:.EmptyT) mxs -- :: MTbl (Z:.Subword) (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int))
+  zs <- run $ id <<< mt ... SM.toList $ ix
+  ls <- run $ sequence $ [ (PA.readM mxs (Z:.subword i j)) | i>=0, j<=100, i<=j ]
+  assert $ zs == ls
 
-fOO (i,j) = S.toList $ (,) F.<<< fRegion F.-~- fRegion F.... id $ Z:.i:.j
+prop_MtMt2 ix@(Z:.Subword(i:.j)) = monadicIO $ do
+  mxs :: PA.MutArr IO (PA.Unboxed (Z:.Subword) Int) <- run $ PA.fromListM (Z:.subword 0 0) (Z:.subword 0 100) [0 ..]
+  let mt = mTbl (Z:.EmptyT) mxs -- :: MTbl (Z:.Subword) (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int))
+  zs <- run $ (,) <<< mt % mt ... SM.toList $ ix
+  ls <- run $ sequence $ [ liftM2 (,) (PA.readM mxs (Z:.subword i k)) (PA.readM mxs (Z:.subword k j)) | i>=0, j<=100, k<-[i..j] ]
+  assert $ zs == ls
 
-lOO (i,j) = [ ( (i,i+1), (j-1,j) ) | i+2==j ]
+prop_MtMtMt2 ix@(Z:.Subword(i:.j)) = monadicIO $ do
+  mxs :: PA.MutArr IO (PA.Unboxed (Z:.Subword) Int) <- run $ PA.fromListM (Z:.subword 0 0) (Z:.subword 0 100) [0 ..]
+  let mt = mTbl (Z:.EmptyT) mxs -- :: MTbl (Z:.Subword) (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int))
+  zs <- run $ (,,) <<< mt % mt % mt ... SM.toList $ ix
+  ls <- run $ sequence $ [ liftM3 (,,) (PA.readM mxs (Z:.subword i k)) (PA.readM mxs (Z:.subword k l)) (PA.readM mxs (Z:.subword l j)) | i>=0, j<=100, k<-[i..j], l<-[k..j] ]
+  assert $ zs == ls
 
-prop_OO (Small i, Small j) = fOO (i,j) == lOO (i,j)
+prop_TcMtTc ix@(Z:.Subword(i:.j)) = monadicIO $ do
+  mxs :: PA.MutArr IO (PA.Unboxed (Z:.Subword) Int) <- run $ PA.fromListM (Z:.subword 0 0) (Z:.subword 0 100) [0 ..]
+  let mt = mTbl (Z:.EmptyT) mxs :: MTbl (Z:.Subword) (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int))
+  zs <- run $ (,,) <<< (T:!chr xs) % mt % (T:!chr xs) ... SM.toList $ ix
+  ls <- run $ sequence $ [ (PA.readM mxs (Z:.subword (i+1) (j-1)) >>= \z -> return (Z:.xs VU.! i,z,Z:.xs VU.! (j-1))) | i>=0, j<=100, i+2<=j ]
+  assert $ zs == ls
 
--- ** Two non-empty regions
+prop_2dim ix@(Z:.TinySubword(i:.j):.TinySubword(k:.l)) = monadicIO $ do
+  mxs <- run $ pure $ mxsSwSw
+  let mt = mTbl (Z:.EmptyT:.EmptyT) mxs
+  zs <- run $ (,) <<< mt % mt ... SM.toList $ Z:.subword i j:.subword k l
+  ls <- run $ sequence $ [ liftM2 (,) (PA.readM mxs (Z:.subword i a:.subword k b)) (PA.readM mxs (Z:.subword a j:.subword b l)) | i>=0, j<=100, k>=0, l<=100, a<-[i..j], b<-[k..l] ]
+  assert $ zs==ls
 
-fPP (i,j) = S.toList $ (,) F.<<< fRegion F.+~+ fRegion F.... id $ Z:.i:.j
+prop_2dimCMCMC ix@(Z:.TinySubword(i:.j):.TinySubword(k:.l)) = monadicIO $ do
+  mxs <- run $ pure $ mxsSwSw -- :: PA.MutArr IO (PA.Unboxed (Z:.Subword:.Subword) Int) <- run $ PA.fromListM (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 100:.subword 0 100) [0 ..]
+  let mt = mTbl (Z:.EmptyT:.EmptyT) mxs
+  zs <- run $ (,,,,) <<< (T:!chr xs:!chr xs) % mt % (T:!chr xs:!chr xs) % mt % (T:!chr xs:!chr xs) ... SM.toList $ Z:.subword i j:.subword k l
+  ls <- run $ sequence $ [ liftM5 (,,,,) (pure $ Z:.xs VU.! i:.xs VU.! k)
+                                         (PA.readM mxs (Z:.subword (i+1) a:.subword (k+1) b))
+                                         (pure $ Z:.xs VU.! a:.xs VU.! b)
+                                         (PA.readM mxs (Z:.subword (a+1) (j-1):.subword (b+1) (l-1)))
+                                         (pure $ Z:.xs VU.! (j-1):.xs VU.! (l-1))
+                         | j-i>=3, l-k>=3, i>=0, j<=100, k>=0, l<=100, a<-[i+1..j-2], b<-[k+1..l-2] ]
+  assert $ zs==ls
 
-lPP (i,j) = [ ( (i,k), (k,j) ) | k<-[i+1 .. j-1] ]
+-- * working on 'PointL's
 
-prop_PP (Small i, Small j) = fPP (i,j) == lPP (i,j)
+prop_P_Tt ix@(Z:.PointL (i:.j)) = zs == ls where
+  zs = id <<< (T:!chr xs) ... S.toList $ ix
+  ls = [ (Z:.xs VU.! i) | i+1==j ]
 
--- ** using 'makeLeft_MinRight'
+prop_P_CC ix@(Z:.PointL (i:.j)) = zs == ls where
+  zs = (,) <<< (T:!chr xs) % (T:!chr xs) ... S.toList $ ix
+  ls = [ (Z:.xs VU.! i, Z:.xs VU.! (i+1)) | i+2==j ]
 
-fML_1_4M (i,j) = S.toList $ (,) F.<<< fRegion `ml_1_4` fRegion F.... id $ Z:.i:.j where
-  infixl 9 `ml_1_4`
-  ml_1_4 = F.makeLeft_MinRight (1,4) 0
+prop_P_2dimCMCMC ix@(Z:.PointL(i:.j):.PointL(k:.l)) = monadicIO $ do
+  mxs <- run $ pure $ mxsPP
+  let mt = mTbl (Z:.EmptyT:.EmptyT) mxs
+  zs <- run $ (,,,,) <<< (T:!chr xs:!chr xs) % mt % (T:!chr xs:!chr xs) % mt % (T:!chr xs:!chr xs) ... SM.toList $ ix
+  ls <- run $ sequence $ [ liftM5 (,,,,) (pure $ Z:.xs VU.! i:.xs VU.! k)
+                                         (PA.readM mxs (Z:.pointL (i+1) a:.pointL (k+1) b))
+                                         (pure $ Z:.xs VU.! a:.xs VU.! b)
+                                         (PA.readM mxs (Z:.pointL (a+1) (j-1):.pointL (b+1) (l-1)))
+                                         (pure $ Z:.xs VU.! (j-1):.xs VU.! (l-1))
+                         | j-i>=3, l-k>=3, i>=0, j<=100, k>=0, l<=100, a<-[i+1..j-2], b<-[k+1..l-2] ]
+  assert $ zs==ls
 
-lML_1_4M (i,j) = [ ( (i,k), (k,j) ) | k <- [i+1 .. min (i+4) j] ]
+{-
+prop_TcTc ix@(Z:.Point i) = {- traceShow (zs,ls) $ -} zs == ls where
+  zs = (,) <<< Term (T:.Chr xs) % Term (T:.Chr xs) ... S.toList $ ix
+  ls = [ (Z:.xs VU.! (i-2), Z:.xs VU.! (i-1)) | i>1 ]
 
-prop_ML_1_4M = fML_1_4M === lML_1_4M
+-- deriving instance Show (Elm (None :. Term (T :. Chr Int)) (Z :. Point))
 
--- ** using 'makeLeft_MinRight' and 'makeMinLeft_Right'. Inner regions fixed to
--- be non-empty.
+prop_TpTc ix@(Z:.Point i) = {- traceShow (zs,ls) $ -} zs == ls where
+  zs = (,) <<< Term (T:.Peek (-1) xs) % Term (T:.Chr xs) ... S.toList $ ix
+  ls = [ (Z:.f i, Z:.xs VU.! (i-1)) | i>0 ]
+  f i = if i>1 then xs VU.! (i-2) else (-1)
 
-fML_1_4MMR_1_4 (i,j) = S.toList $ (,,) F.<<< fRegion `ml_1_4` fRegion `mr_1_4` fRegion F.... id $ Z:.i:.j where
-  infixl 9 `ml_1_4`
-  ml_1_4 = F.makeLeft_MinRight (1,4) 1
-  infixl 9 `mr_1_4`
-  mr_1_4 = F.makeMinLeft_Right 1 (1,4)
+prop_TcTpTc ix@(Z:.Point i) = {- traceShow (zs,ls) $ -} zs == ls where
+  zs = (,,) <<< Term (T:.Chr xs) % Term (T:.Peek (-1) xs) % Term (T:.Chr xs) ... S.toList $ ix
+  ls = [ (Z:.xs VU.! (i-2), Z:.f i, Z:.xs VU.! (i-1)) | i>1 ]
+  f i = if i>1 then xs VU.! (i-2) else (-1)
 
-lML_1_4MMR_1_4 (i,j) = [ ( (i,k), (k,l), (l,j) ) | k<-[i+1 .. min (i+4) j], l <- [max k (j-4) .. j-1], k<l ]
+{-
+prop_Mt_Tc ix@(Z:.Subword(i:.j)) = monadicIO $ do
+    mxs :: (PA.MU IO (Z:.Subword) Int) <- run $ PA.fromListM (Z:. Subword (0:.0)) (Z:. Subword (0:.100)) [0 .. ]
+    let mt = mtable mxs
+    zs <- run $ (,) <<< mt % Term (T:.Chr xs) ... SM.toList $ ix
+    ls <- run $ sequence $ [(PA.readM mxs (Z:.subword i (j-1))) >>= \a -> return (a,Z:.xs VU.! (j-1)) | i<j ]
+    assert $ zs == ls
+-}
 
-prop_ML_1_4MMR_1_4 = fML_1_4MMR_1_4 === lML_1_4MMR_1_4
+prop_P_Mt_Tt ix@(Z:.Point i) = monadicIO $ do
+    mxs :: (PA.MU IO (Z:.Point) Int) <- run $ PA.fromListM (Z:.Point 0) (Z:.Point 100) [0 .. ]
+    let mt = mtable mxs
+    zs <- run $ (,) <<< mt % Term (T:.Chr xs) ... SM.toList $ ix
+    ls <- run $ sequence $ [(PA.readM mxs (Z:.Point (i-1))) >>= \a -> return (a,Z:.xs VU.! (i-1)) | i>0 ]
+    assert $ zs == ls
+
+prop_P_Mt_TpTc ix@(Z:.Point i) = monadicIO $ do
+    mxs :: (PA.MU IO (Z:.Point) Int) <- run $ PA.fromListM (Z:.Point 0) (Z:.Point 100) [0 .. ]
+    let mt = mtable mxs
+    let f i = if i>1 then xs VU.! (i-2) else (-1)
+    zs <- run $ (,,) <<< mt % Term (T:.Peek (-1) xs) % Term (T:.Chr xs) ... SM.toList $ ix
+    ls <- run $ sequence $ [(PA.readM mxs (Z:.Point (i-1))) >>= \a -> return (a,Z:.f i,Z:.xs VU.! (i-1)) | i>0 ]
+    assert $ zs == ls
+
+-- | and with 2-tape grammars
+
+prop_Tcc ix@(Z:.Subword(i:.j):.Subword(k:.l)) = zs == ls where
+  zs = id <<< Term (T:.Chr xs:.Chr xs) ... S.toList $ ix
+  ls = [ (  Z
+         :. xs VU.! i
+         :. xs VU.! k
+         ) | i+1==j, k+1==l ]
+
+prop_Mt_Tcc (Z:.TinySubword (i:.j):.TinySubword (k:.l)) = monadicIO $ do
+    let ix = Z :. subword i j :. subword k l
+    mxs :: (PA.MU IO (Z:.Subword:.Subword) Int) <- run $ PA.fromListM (Z:. Subword (0:.0):.Subword(0:.0)) (Z:. Subword (0:.j+1):.Subword (0:.k+1)) [0 .. ]
+    let mt = mtable mxs
+    zs <- run $ (,) <<< mt % Term (T:.Chr xs:.Chr xs) ... SM.toList $ ix
+    ls <- run $ sequence $ [ (PA.readM mxs (Z:.subword i (j-1):.subword k (l-1))) >>= \a -> return (a,Z:.xs VU.! (j-1):.xs VU.! (l-1)) | i<j,k<l ]
+    assert $ zs == ls
+
+prop_P_Ttt ix@(Z:.Point i:.Point j) = zs == ls where
+  zs = id <<< Term (T:.Chr xs:.Chr xs) ... S.toList $ ix
+  ls = [ (Z:.xs VU.! (i-1):.xs VU.! (j-1)) | i>0, j>0 ]
+
+prop_P_Mt_Ttt ix@(Z:.Point i:.Point j) = monadicIO $ do
+    mxs :: (PA.MU IO (Z:.Point:.Point) Int) <- run $ PA.fromListM (Z:.Point 0:.Point 0) (Z:.Point 100:.Point 100) [0 .. ]
+    let mt = mtable mxs
+    zs <- run $ (,) <<< mt % Term (T:.Chr xs:.Chr xs) ... SM.toList $ ix
+    ls <- run $ sequence $ [(PA.readM mxs (Z:.Point (i-1):.Point (j-1))) >>= \a -> return (a,Z:.xs VU.! (i-1):.xs VU.! (j-1)) | i>0,j>0 ]
+    assert $ zs == ls
+
+prop_P_Mt_Tpp_Ttt ix@(Z:.Point i:.Point j) = monadicIO $ do
+    mxs :: (PA.MU IO (Z:.Point:.Point) Int) <- run $ PA.fromListM (Z:.Point 0:.Point 0) (Z:.Point 100:.Point 100) [0 .. ]
+    let mt = mtable mxs
+    let f i j = Z:. (if i>1 then xs VU.! (i-2) else (-1)) :. (if j>1 then xs VU.! (j-2) else (-1))
+    zs <- run $ (,,) <<< mt % Term (T:.Peek (-1) xs:.Peek (-1) xs) % Term (T:.Chr xs:.Chr xs) ... SM.toList $ ix
+    ls <- run $ sequence $ [(PA.readM mxs (Z:.Point (i-1):.Point (j-1))) >>= \a -> return (a,f i j,Z:.xs VU.! (i-1):.xs VU.! (j-1)) | i>0,j>0 ]
+    -- traceShow (zs,ls) $
+    assert $ zs == ls
+
+-- | and with 3-tape grammars
+
+prop_Tccc ix@(Z:.Subword(i:.j):.Subword(k:.l):.Subword(a:.b)) = zs == ls where
+  zs = id <<< Term (T:.Chr xs:.Chr xs:.Chr xs) ... S.toList $ ix
+  ls = [ (  Z
+         :. xs VU.! i
+         :. xs VU.! k
+         :. xs VU.! a
+         ) | i+1==j, k+1==l, a+1==b ]
+
+-- * helper functions and stuff
+
+-- | Helper function to create non-specialized regions
+
+region = Region Nothing Nothing
+
+-- |
+
+mtable xs = MTable Eall xs
+
+{-
+-- | A subword (i,j) should always produce an index in the allowed range
+
+prop_subwordIndex (Small n, Subword (i:.j)) = (n>j) ==> p where
+  p = n * (n+1) `div` 2 >= k
+  k = subwordIndex (subword 0 n) (subword i j)
+-}
+
+-}
+
+-- | data set. Can be made fixed as the maximal subword size is statically known!
+
+xs = VU.fromList [0 .. 99 :: Int]
+
+--
+--
+--TODO will break if PrimitiveArray assertions are active (need to fixe exact length of list)
+
+mxsSwSw = unsafePerformIO $ zzz where
+  zzz :: IO (PA.MutArr IO (PA.Unboxed (Z:.Subword:.Subword) Int))
+  zzz = PA.fromListM (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 100:.subword 0 100) [0 ..]
+
+mxsPP = unsafePerformIO $ zzz where
+  zzz :: IO (PA.MutArr IO (PA.Unboxed (Z:.PointL:.PointL) Int))
+  zzz = PA.fromListM (Z:.pointL 0 0:.pointL 0 0) (Z:.pointL 0 100:.pointL 0 100) [0 ..]
+
+-- * general quickcheck stuff
+
+options = stdArgs {maxSuccess = 1000}
+
+customCheck = quickCheckWithResult options
+
+allProps = $forAllProperties customCheck
+
+
+
+newtype Small = Small Int
+  deriving (Show)
+
+instance Arbitrary Small where
+  arbitrary = Small <$> choose (0,100)
+  shrink (Small i) = Small <$> shrink i
+
+newtype TinySubword = TinySubword (Int:.Int)
+  deriving (Show)
+
+instance Arbitrary TinySubword where
+  arbitrary = do a <- choose (0,20)
+                 b <- choose (0,20)
+                 return $ TinySubword $ min a b :. max a b
+  shrink (TinySubword (a:.b)) = [TinySubword (a:.b-1) | a<b]
+
+instance Arbitrary z => Arbitrary (z:.TinySubword) where
+  arbitrary = (:.) <$> arbitrary <*> arbitrary
+  shrink (z:.s) = (:.) <$> shrink z <*> shrink s
+
 
diff --git a/ADP/Fusion/QuickCheck/Arbitrary.hs b/ADP/Fusion/QuickCheck/Arbitrary.hs
deleted file mode 100644
--- a/ADP/Fusion/QuickCheck/Arbitrary.hs
+++ /dev/null
@@ -1,39 +0,0 @@
-{-# LANGUAGE PackageImports #-}
-
-module ADP.Fusion.QuickCheck.Arbitrary where
-
-import Test.QuickCheck
-import Test.QuickCheck.All
-
-import "PrimitiveArray" Data.Array.Repa.Index
-
-import qualified ADP.Fusion.Monadic.Internal as F
-
-lAchar (i,j) = [j | i+1 == j]
-
--- |
---
--- NOTE we have to add 1 to the i-index. Legacy ADP reads chars from an input
--- array starting at "1", while ADPfusion starts arrays at "0".
-
-fAchar :: DIM2 -> (F.Scalar Int)
-fAchar (Z:.i:.j) = F.Scalar $ (i+1)
-
-fRegion :: DIM2 -> (F.Scalar (Int,Int))
-fRegion (Z:.i:.j) = F.Scalar $ (i,j)
-
--- * quickcheck stuff
-
-newtype Small = Small Int
-  deriving (Show)
-
-instance Arbitrary Small where
-  arbitrary = Small `fmap` choose (0,50)
-  shrink (Small x)
-    | x>0       = [Small $ x-1]
-    | otherwise = []
-
-small x = x>=0 && x <=50
-
-(===) f g (Small i, Small j) = f (i,j) == g (i,j)
-
diff --git a/ADP/Fusion/Region.hs b/ADP/Fusion/Region.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Region.hs
@@ -0,0 +1,148 @@
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module ADP.Fusion.Region where
+
+import Data.Array.Repa.Index
+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 ADP.Fusion.Classes
+
+import Control.Exception (assert)
+import Debug.Trace
+
+
+
+-- * Regions of unlimited size
+
+data Region x = Region !(VU.Vector x)
+
+instance Build (Region x)
+
+instance
+  ( ValidIndex ls Subword
+  , VU.Unbox xs
+  ) => ValidIndex (ls :!: Region xs) Subword where
+  validIndex (ls :!: Region xs) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =
+    i>=a && j<=VU.length xs -c && i+b<=j && validIndex ls abc ij
+  {-# INLINE validIndex #-}
+  getParserRange (ls :!: Region xs) ix = let (a:!:b:!:c) = getParserRange ls ix in (a:!:b:!:c)
+  {-# INLINE getParserRange #-}
+
+instance
+  ( Elms ls Subword
+  ) => Elms (ls :!: Region x) Subword where
+  data Elm (ls :!: Region x) Subword = ElmRegion !(Elm ls Subword) !(VU.Vector x) !Subword
+  type Arg (ls :!: Region x)         = Arg ls :. VU.Vector x
+  getArg !(ElmRegion ls xs _) = getArg ls :. xs
+  getIdx !(ElmRegion _ _   i) = i
+  {-# INLINE getArg #-}
+  {-# INLINE getIdx #-}
+
+instance
+  ( Monad m
+  , VU.Unbox x
+  , Elms ls Subword
+  , MkStream m ls Subword
+  ) => MkStream m (ls:!:Region x) Subword where
+  mkStream !(ls:!:Region xs) Outer !ij@(Subword (i:.j))
+    = S.map (\s -> let (Subword (k:.l)) = getIdx s in ElmRegion s (VU.unsafeSlice l (j-l) xs) (subword l j))
+    $ mkStream ls (Inner Check Nothing) ij
+  mkStream !(ls:!:Region xs) (Inner _ szd) !ij@(Subword (i:.j)) = S.flatten mk step Unknown $ mkStream ls (Inner NoCheck Nothing) ij where
+      mk !s = let (Subword (k:.l)) = getIdx s
+                  l' = case szd of Nothing -> l
+                                   Just z  -> max l (j-z)
+              in  return (s :!: l :!: l')
+      step !(s :!: k :!: l)
+        | l > j     =  return S.Done
+        | otherwise = return $ S.Yield (ElmRegion s (VU.unsafeSlice k (l-k) xs) (subword k l)) (s :!: k :!: l+1)
+  {-# INLINE mkStream #-}
+
+region :: VU.Vector x -> Region x
+region = Region
+{-# INLINE region #-}
+
+
+
+-- * Regions of unlimited size
+
+data SRegion x = SRegion !Int !Int !(VU.Vector x)
+
+instance Build (SRegion x)
+
+instance
+  ( ValidIndex ls Subword
+  , VU.Unbox xs
+  ) => ValidIndex (ls :!: SRegion xs) Subword where
+  validIndex (ls :!: SRegion lb ub xs) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =
+    i>=a && j<=VU.length xs -c && i+b<=j && validIndex ls abc ij
+  {-# INLINE validIndex #-}
+  getParserRange (ls :!: SRegion lb ub xs) ix = let (a:!:b:!:c) = getParserRange ls ix in (a:!:b+lb:!:max 0 (c-lb))
+  {-# INLINE getParserRange #-}
+
+instance
+  ( Elms ls Subword
+  ) => Elms (ls :!: SRegion x) Subword where
+  data Elm (ls :!: SRegion x) Subword = ElmSRegion !(Elm ls Subword) !(VU.Vector x) !Subword
+  type Arg (ls :!: SRegion x)         = Arg ls :. VU.Vector x
+  getArg !(ElmSRegion ls xs _) = getArg ls :. xs
+  getIdx !(ElmSRegion _ _   i) = i
+  {-# INLINE getArg #-}
+  {-# INLINE getIdx #-}
+
+-- |
+--
+-- TODO Check that all inner / outer sized calculations are correct
+--
+-- NOTE mkStream/Inner gives a size hint of Nothing, as in purely inner cases,
+-- min/max boundaries are determined solely from the running rightmost index
+-- from the next inner component.
+--
+-- NOTE the filter in mkStream/Outer is still necessary to check for
+-- lowerbound>0 conditions. We /could/ send the lower bound down with another
+-- size hint, but this only makes sense if you have use cases, where the lower
+-- bound is a lot higher than "0". Otherwise the current code is simpler.
+--
+-- TODO use drop instead of filter: still condition, but large lower bounds are captured
+--
+-- TODO remove mkStream/Outer : filter and test if one condition less gives
+-- much better runtimes.
+
+instance
+  ( Monad m
+  , VU.Unbox x
+  , Elms ls Subword
+  , MkStream m ls Subword
+  ) => MkStream m (ls:!:SRegion x) Subword where
+  mkStream !(ls:!:SRegion lb ub xs) Outer !ij@(Subword (i:.j))
+    = S.map (\s -> let (Subword (k:.l)) = getIdx s in assert (l>=0 && j-i>=0) $ ElmSRegion s (VU.slice l (j-l) xs) (subword l j))
+    $ S.filter (\s -> let (Subword (k:.l)) = getIdx s in (j-l >= lb && j-l <= ub))
+    $ mkStream ls (Inner Check (Just ub)) ij
+  mkStream !(ls:!:SRegion lb ub xs) (Inner _ szd) !ij@(Subword (i:.j)) = S.flatten mk step Unknown $ mkStream ls (Inner NoCheck Nothing) ij where
+      mk !s = let (Subword (k:.l)) = getIdx s
+                  l' = case szd of Nothing -> l+lb
+                                   Just z  -> max (l+lb) (j-z)
+              in  return (s :!: l :!: l')
+      step !(s :!: k :!: l)
+        | l>j || l-k>ub =  return S.Done
+        | otherwise     = return $ assert (k>=0 && l-k>=0) $ S.Yield (ElmSRegion s (VU.slice k (l-k) xs) (subword k l)) (s :!: k :!: l+1)
+  {-# INLINE mkStream #-}
+
+-- |
+sregion :: Int -> Int -> VU.Vector x -> SRegion x
+sregion = SRegion
+{-# INLINE sregion #-}
+
diff --git a/ADP/Fusion/Table.hs b/ADP/Fusion/Table.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Table.hs
@@ -0,0 +1,563 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+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
+
+
+
+-- * Mutable table with adaptive storage.
+
+data MTbl i xs = MTbl !(ENZ i) !xs -- (PA.MutArr m (arr i x))
+
+mTblSw :: ENE -> PA.MutArr m (arr (Z:.Subword) x) -> MTbl Subword (PA.MutArr m (arr (Z:.Subword) x))
+mTblSw = MTbl
+{-# INLINE mTblSw #-}
+
+mTbl :: ENZ i -> PA.MutArr m (arr i x) -> MTbl i (PA.MutArr m (arr i x))
+mTbl = MTbl
+{-# INLINE mTbl #-}
+
+-- | Generate the list of indices for use in table lookup.
+--
+-- Don't touch stuff in greek! ζ is the interior stack of arguments, α the
+-- stack of saved indices
+
+class TableIndices i where
+  tableIndices :: Monad m => InOut i -> ENZ i -> i -> S.Stream m (ζ:!:α:!:i) -> S.Stream m (ζ:!:α:!:i)
+
+
+
+-- * Instances
+
+instance TableIndices Z where
+  tableIndices Z Z Z = id
+  {-# INLINE tableIndices #-}
+
+instance TableIndices Subword where
+  -- | These actually don't make sense in 1-dim settings, we keep the code as a
+  -- reminder how things should look like: @tableIndices Outer ZeroT
+  -- (Subword(i:.j)) = S.map (:!:subword j j)@
+  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 (j-z) }
+      in  return (ζ:!:α:!:l:!:l')
+    step (ζ:!:α:!:k:!:l)
+      | i>j = return S.Done
+      | otherwise = return $ S.Yield (ζ:!:α:!:subword k l) (ζ:!:α:!:k:!:l+1)
+  {-# INLINE tableIndices #-}
+
+instance TableIndices is => TableIndices (is:.Subword) where
+  tableIndices (os:.Outer) (es:._) (is:.Subword(i:.j))
+    = S.map (\(ζ:!:(α:!:Subword(_:.l)):!:is) -> (ζ:!:α:!:(is:.subword l j))) -- extend index to the end
+    . tableIndices os es is -- extend the @is@ part
+    . S.map (\(ζ:!:α:!:(is:.i)) -> (ζ:!:(α:!:i):!:is)) -- move topmost index to α for safekeeping
+  -- tables annotated with zero-width have zero width @l--l@
+  -- This also reduces the number of "running indices"
+  --
+  -- TODO consider returning "def"ault elements here, instead of data from
+  -- zero-length subword? Or does 'ZeroT' actually mean to extract (a/the)
+  -- zero-length subword?
+  --
+  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))
+  -- the default case, where we need to create indices
+  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 (j-z) }
+            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)
+  {-#  INLINE tableIndices #-}
+
+instance TableIndices is => TableIndices (is:.PointL) where
+  tableIndices (os:.Outer) (es:._) (is:.PointL(i:.j))
+    = S.map (\(ζ:!:(α:!:PointL(_:.l)):!:is) -> (ζ:!:α:!:(is:.pointL l j))) -- extend index to the end
+    . tableIndices os es is -- extend the @is@ part
+    . S.map (\(ζ:!:α:!:(is:.i)) -> (ζ:!:(α:!:i):!:is)) -- move topmost index to α for safekeeping
+  tableIndices (os:.Inner _ szd) (es:.ZeroT) (is:.PointL(i:.j))
+    = S.map (\(ζ:!:(α:.PointL(k:.l)):!:is) -> (ζ:!:α:!:(is:.pointL l l)))  -- does @l==lower bound@ have to be true here?
+    . tableIndices os es is
+    . S.map (\(ζ:!:α:!:(is:.i)) -> (ζ:!:(α:.i):!:is))
+  -- the default case, where we need to create indices
+  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 (j-z) }
+            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)
+  {-#  INLINE tableIndices #-}
+
+instance Build (MTbl i x)
+
+-- ** Subword
+
+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<=n-c && validIndex ls abc ij
+  {-# INLINE validIndex #-}
+  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)
+  {-# INLINE getParserRange #-}
+
+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 -- ElmBtTbl !(Elm ls Subword) !x !(m (S.Stream m b)) !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
+  {-# INLINE getArg #-}
+  {-# INLINE getIdx #-}
+
+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 -> j-1 })
+  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 (j-z)
+            in return (s :!: l :!: l')
+    {-# INLINE [0] mk #-}
+    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)
+    {-# INLINE [0] step #-}
+  {-# INLINE mkStream #-}
+
+-- ** multi-dim indices
+
+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
+  {-# INLINE getArg #-}
+  {-# INLINE getIdx #-}
+
+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 β) -- extract data using β index
+    . tableIndices os enz is -- generate indices for multiple dimensions
+    . S.map (\s -> (s:!:Z:!:getIdx s)) -- extract the right-most current index
+    $ mkStream ls (nonTermInnerOuter is os) (nonTermLeftIndex is os enz) -- TODO fix os is!
+  {-# INLINE mkStream #-}
+
+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
+  {-# INLINE validIndex #-}
+  {-# INLINE getParserRange #-}
+
+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
+  {-# INLINE nonTermValidIndex #-}
+  {-# INLINE getNonTermParserRange #-}
+  {-# INLINE nonTermInnerOuter #-}
+  {-# INLINE nonTermLeftIndex #-}
+
+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<=n-c && 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 (j-1)
+    | otherwise                = nonTermLeftIndex is os es :. subword i j
+  {-# INLINE nonTermValidIndex #-}
+  {-# INLINE getNonTermParserRange #-}
+  {-# INLINE nonTermInnerOuter #-}
+  {-# INLINE nonTermLeftIndex #-}
+
+-- TODO autogenerated, check correctness
+
+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<=n-c && 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 (j-1)
+    | otherwise                = nonTermLeftIndex is os es :. pointL i j
+  {-# INLINE nonTermValidIndex #-}
+  {-# INLINE getNonTermParserRange #-}
+  {-# INLINE nonTermInnerOuter #-}
+  {-# INLINE nonTermLeftIndex #-}
+
+
+
+data BtTbl i xs f = BtTbl !(ENZ i) !xs !f -- (i -> m (S.Stream m b))
+
+btTbl :: ENZ i -> xs -> f -> BtTbl i xs f --(i -> m (S.Stream m b)) -> BtTbl m i xs b
+btTbl = BtTbl
+{-# INLINE 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
+  {-# INLINE getArg #-}
+  {-# INLINE getIdx #-}
+
+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 -> j-1 })
+  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 (j-z)
+            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)
+  {-# INLINE mkStream #-}
+
+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<=n-c && validIndex ls abc ij
+  {-# INLINE validIndex #-}
+  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)
+  {-# INLINE getParserRange #-}
+
+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
+  {-# INLINE getArg #-}
+  {-# INLINE getIdx #-}
+
+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 β) β) -- extract data using β index
+    . tableIndices os enz is -- generate indices for multiple dimensions
+    . S.map (\s -> (s:!:Z:!:getIdx s)) -- extract the right-most current index
+    $ mkStream ls (nonTermInnerOuter is os) (nonTermLeftIndex is os enz) -- TODO fix os is!
+  {-# INLINE mkStream #-}
+
+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
+  {-# INLINE validIndex #-}
+  {-# INLINE getParserRange #-}
+
+
+
+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
+  {-# INLINE toEmptyT #-}
+  {-# INLINE toNonEmptyT #-}
+
+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
+  {-# INLINE toEmptyT #-}
+  {-# INLINE toNonEmptyT #-}
+
+
+
+
+{-
+
+-- * Backtracking tables.
+
+data BtTbl m x b = BtTbl ENE !(PA.Unboxed (Z:.Subword) x) !(Subword -> m (S.Stream m b))
+
+instance Build (BtTbl m x b)
+
+instance
+  ( Monad m
+  , Elms ls Subword
+  ) => Elms (ls :!: BtTbl m x b) Subword where
+  data Elm (ls :!: BtTbl m x b) Subword = ElmBtTbl !(Elm ls Subword) !x !(m (S.Stream m b)) !Subword
+  type Arg (ls :!: BtTbl m x b) = Arg ls :. (x,m (S.Stream m b))
+  getArg !(ElmBtTbl ls x b _) = getArg ls :. (x,b)
+  getIdx !(ElmBtTbl _  _ _ i) = i
+  {-# INLINE getArg #-}
+  {-# INLINE getIdx #-}
+
+instance
+  ( Monad m
+  , VU.Unbox x
+  , Elms ls Subword
+  , MkStream m ls Subword
+  ) => MkStream m (ls :!: BtTbl m x b) Subword where
+  mkStream !(ls:!:BtTbl ene xs f) Outer !ij@(Subword (i:.j))
+    = S.map (\s -> let (Subword (k:.l)) = getIdx s in ElmBtTbl s (xs PA.! (Z:.subword l j)) (f $ subword l j) (subword l j))
+    $ mkStream ls (Inner Check Nothing) (subword i $ case ene of { EmptyT -> j ; NoEmptyT -> j-1 })
+  mkStream !(ls:!:BtTbl ene xs f) (Inner _ szd) !ij@(Subword (i:.j)) = S.flatten mk step Unknown $ mkStream ls (Inner NoCheck Nothing) ij where
+    mk !s = let (Subword (k:.l)) = getIdx s
+                le = l + case ene of { EmptyT -> 0 ; NoEmptyT -> 1}
+                l' = case szd of Nothing -> le
+                                 Just z  -> max le (j-z)
+            in  return (s:!:l:!: l')
+    step !(s:!:k:!:l)
+      | l > j     = return $ S.Done
+      | otherwise = return $ S.Yield (ElmBtTbl s (xs PA.! (Z:.subword k l)) (f $ subword k l) (subword k l)) (s:!:k:!:l+1)
+  {-# INLINE mkStream #-}
+
+
+
+-- * Unboxed mutable table for the forward phase in one dimension.
+
+data MTbl xs = MTbl !ENE !xs
+
+instance
+  ( ValidIndex ls Subword
+  , Monad m
+  , PA.MPrimArrayOps arr (Z:.Subword) x
+  ) => ValidIndex (ls:!:MTbl (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<=n-c && validIndex ls abc ij
+  {-# INLINE validIndex #-}
+  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)
+  {-# INLINE getParserRange #-}
+
+instance Build (MTbl xs)
+
+instance
+  ( Monad m
+  , Elms ls Subword
+  ) => Elms (ls :!: MTbl (PA.MutArr m (arr (Z:.Subword) x))) Subword where
+  data Elm (ls :!: MTbl (PA.MutArr m (arr (Z:.Subword) x))) Subword = ElmMTbl !(Elm ls Subword) !x !Subword
+  type Arg (ls :!: MTbl (PA.MutArr m (arr (Z:.Subword) x))) = Arg ls :. x
+  getArg !(ElmMTbl ls x _) = getArg ls :. x
+  getIdx !(ElmMTbl _ _ i) = i
+  {-# INLINE getArg #-}
+  {-# INLINE getIdx #-}
+
+instance
+  ( PrimMonad m
+  , PA.MPrimArrayOps arr (Z:.Subword) x
+  , Elms ls Subword
+  , MkStream m ls Subword
+  ) => MkStream m (ls:!:MTbl (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 $ ElmMTbl s z (subword l j))
+    $ mkStream ls (Inner Check Nothing) (subword i $ case ene of { EmptyT -> j ; NoEmptyT -> j-1 })
+  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 ; NoEmptyT -> 1}
+                l' = case szd of Nothing -> le
+                                 Just z  -> max le (j-z)
+            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 (ElmMTbl s z (subword k l)) (s :!: k :!: l+1)
+  {-# INLINE mkStream #-}
+
+
+
+{-
+
+-- ** multi-tape generalization: empty / nonempty
+
+instance
+  ( ValidIndex ls (is:.i)
+  , Monad m
+  , PA.MPrimArrayOps arr (is:.i) x
+  ) => ValidIndex (ls :!: MTbl (PA.MutArr m (arr (is:.i) x))) (is:.i) where
+    validIndex (ls :!: MTbl ene tbl) (is:.i) =
+      let
+      in  undefined
+
+instance
+  ( Monad m
+  ) => Elms (ls :!: MTbl (PA.MutArr m (arr (is:.i) x))) (is:.i) where
+
+instance
+  ( Monad m
+  ) => MkStream m (ls:!: MTbl (PA.MutArr m (arr (is:.i) x))) (is:.i) where
+  mkStream !(ls:!:MTbl ene tbl) io is
+    = undefined
+
+
+
+{-
+data GMtbl i x = forall m . GMtbl (ENEdim i) (PA.MutArr m (Storage i x))
+
+-}
+
+-}
+
+-}
+
+
+{-
+
+-- * Immutable tables.
+
+data Tbl x = Tbl !(PA.Unboxed (Z:.Subword) x)
+
+instance Build (Tbl x)
+
+instance
+  ( Elms ls Subword
+  ) => Elms (ls :!: Tbl x) Subword where
+  data Elm (ls :!: Tbl x) Subword = ElmTbl !(Elm ls Subword) !x !Subword
+  type Arg (ls :!: Tbl x) = Arg ls :. x
+  getArg !(ElmTbl ls x _) = getArg ls :. x
+  getIdx !(ElmTbl _ _ idx) = idx
+  {-# INLINE getArg #-}
+  {-# INLINE getIdx #-}
+
+instance
+  ( Monad m
+  , VU.Unbox x
+  , Elms ls Subword
+  , MkStream m ls Subword
+  ) => MkStream m (ls:!:Tbl x) Subword where
+  mkStream !(ls:!:Tbl xs) Outer !ij@(Subword (i:.j)) = S.map (\s -> let (Subword (k:.l)) = getIdx s in ElmTbl s (xs PA.! (Z:.subword l j)) (subword l j)) $ mkStream ls (Inner Check Nothing) ij
+  mkStream !(ls:!:Tbl xs) (Inner _ szd) !ij@(Subword (i:.j)) = S.flatten mk step Unknown $ mkStream ls (Inner NoCheck Nothing) ij where
+    mk !s = let (Subword (k:.l)) = getIdx s
+                le = l -- TODO need to add ENE here ! -- + case ene of { EmptyT -> 0 ; NoEmptyT -> 1}
+                l' = case szd of Nothing -> le
+                                 Just z  -> max le (j-z)
+            in  return (s :!: l :!: l')
+    step !(s :!: k :!: l)
+      | l > j = return S.Done
+      | otherwise = return $ S.Yield (ElmTbl s (xs PA.! (Z:.subword k l)) (subword k l)) (s :!: k :!: l+1)
+  {-# INLINE mkStream #-}
+
+
+-}
+
+
diff --git a/ADPfusion.cabal b/ADPfusion.cabal
--- a/ADPfusion.cabal
+++ b/ADPfusion.cabal
@@ -1,7 +1,7 @@
 name:           ADPfusion
-version:        0.1.0.0
-author:         Christian Hoener zu Siederdissen, 2011-2012
-copyright:      Christian Hoener zu Siederdissen, 2011-2012
+version:        0.2.0.0
+author:         Christian Hoener zu Siederdissen, 2011-2013
+copyright:      Christian Hoener zu Siederdissen, 2011-2013
 homepage:       http://www.tbi.univie.ac.at/~choener/adpfusion
 maintainer:     choener@tbi.univie.ac.at
 category:       Algorithms, Data Structures, Bioinformatics
@@ -35,12 +35,13 @@
                 translates to three nested for loops (for C). In the figure,
                 four different approaches are compared using inputs with size
                 100 characters to 1000 characters in increments of 100
-                characters. "C" is an implementation ("./C/" directory) in "C"
+                characters. "C" is an implementation (@./C/@ directory) in "C"
                 using "gcc -O3". "ADP" is the original ADP approach (see link
                 above), while "GAPC" uses the "GAP" language
                 (<http://gapc.eu/>).
-                <<https://github.com/choener/ADPfusion/gaplike-performance.png>>
                 .
+                <<http://www.tbi.univie.ac.at/~choener/adpfusion/gaplike-nussinov-runtime.jpg>>
+                .
                 Please note that actual performance will depend much on table
                 layout and data structures accessed during calculations, but in
                 general performance is very good: close to C and better than
@@ -57,116 +58,65 @@
                 that performs backtracking, or samples structures
                 stochastically, among others things.
                 .
-                This version is still highly experimental and makes use of
-                multiple recent improvements in GHC. This is particularly true
-                for the monadic interface.
                 .
                 .
-                .
-                Newley added are the ADP.Fusion.GAPlike modules. These allow
-                for writing grammars with only one (non)-terminal combinator.
-                The logic for index manipulation is now moved into data types
-                for terminals and non-terminals.
-                .
-                While this change leads to slightly more complicated instances
-                for each new terminal or non-terminal, the overall code
-                complexity is significantly lower. In addition, Constraint
-                Kinds make complex interactions between (non)-terminals
-                possible, while still managing to produce high-performance
-                code.
-                .
-                The final goal would, of course, be to have no inter-terminal
-                combinators anymore.
-                .
-                * GHC 7.6, LLVM, and -fnew-codegen recommended: gives a speedup
-                  of x2 for GAPcriterion
-                .
-                .
-                .
-                .
-                Long term goals: Outer indices with more than two dimensions,
-                specialized table design, a combinator library, a library for
-                computational biology.
-                .
                 Two algorithms from the realm of computational biology are
                 provided as examples on how to write dynamic programming
                 algorithms using this library:
                 <http://hackage.haskell.org/package/Nussinov78> and
                 <http://hackage.haskell.org/package/RNAFold>.
-                .
-                Changes since 0.0.1.2:
-                .
-                * require GHC 7.6
-                .
-                * ADP.Fusion.GAPlike module for (almost) combinator-less grammars
-                .
-                * ConstraintKinds for constrained parsers in GAPlike.
-                .
-                .
-                .
-                Changes since 0.0.1.0:
-                .
-                * compatibility with GHC 7.4
-                .
-                * note: still using fundeps & and TFs together. The TF-only version does not optimize as well (I know why but not yet how to fix it)
-                .
-                .
-                .
-                Using the new code generator?
-                .
-                The new code generator is not official yet, but I recommend trying it out:
-                <<https://github.com/choener/ADPfusion/gaplike-newcodegen.png>>
 
 
 
 Extra-Source-Files:
   README.md
-  ADP/Fusion/QuickCheck.hs
-  ADP/Fusion/QuickCheck/Arbitrary.hs
 
 
-Flag devel
-  description: build criterion benchmarks and pull in QuickCheck
-  default: False
 
-
 library
   build-depends:
     base >= 4 && < 5,
-    ghc-prim,
-    primitive      == 0.5.*   ,
-    vector         == 0.10.*  ,
-    PrimitiveArray == 0.4.*
+    deepseq        >= 1.3     ,
+    ghc-prim                  ,
+    primitive      >= 0.5     ,
+    PrimitiveArray == 0.5.2.* ,
+    QuickCheck     >= 2.5     ,
+    repa           >= 3.2     ,
+    strict         >= 0.3.2   ,
+    template-haskell          ,
+    transformers              ,
+    vector         >= 0.10
   exposed-modules:
     ADP.Fusion
-    ADP.Fusion.Monadic
-    ADP.Fusion.Monadic.Internal
-    ADP.Fusion.GAPlike
+    ADP.Fusion.Apply
+    ADP.Fusion.Chr
+    ADP.Fusion.Classes
+    ADP.Fusion.Empty
+    ADP.Fusion.Examples.Palindrome
+    ADP.Fusion.Multi
+    ADP.Fusion.Multi.Classes
+    ADP.Fusion.Multi.Empty
+    ADP.Fusion.Multi.GChr
+    ADP.Fusion.Multi.None
+    ADP.Fusion.None
+    ADP.Fusion.QuickCheck
+    ADP.Fusion.Region
+    ADP.Fusion.Table
 
   ghc-options:
     -O2 -funbox-strict-fields
 
-executable GAPcriterion
-  buildable:
-    False
-  if flag(devel)
-    buildable:
-      True
-    build-depends:
-      criterion  == 0.6.* ,
-      QuickCheck == 2.5
-  other-modules:
-    ADP.Fusion.GAPlike.DevelCommon
-    ADP.Fusion.GAPlike.Criterion
-    ADP.Fusion.GAPlike.QuickCheck
+executable NeedlemanWunsch
   main-is:
-    Tests/GAPcriterion.hs
+    ADP/Fusion/Examples/TwoDim.hs
   ghc-options:
-    -fllvm -O2 -funbox-strict-fields -optlo-O3 -optlo-std-compile-opts
-  if impl(GHC > 7.4)
-    ghc-options:
-      -fnew-codegen
-
+    -Odph
+    -funbox-strict-fields
+    -funfolding-use-threshold1000
+    -funfolding-keeness-factor1000
+    -fllvm
+    -optlo-O3 -optlo-std-compile-opts
+    -fllvm-tbaa
 
 source-repository head
   type: git
diff --git a/Tests/GAPcriterion.hs b/Tests/GAPcriterion.hs
deleted file mode 100644
--- a/Tests/GAPcriterion.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-
-module Main where
-
-import ADP.Fusion.GAPlike2.Criterion
-
-
-
-main = criterionMain
-