diff --git a/ADP/Fusion.hs b/ADP/Fusion.hs
deleted file mode 100644
--- a/ADP/Fusion.hs
+++ /dev/null
@@ -1,80 +0,0 @@
-
--- | 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.
-
-module ADP.Fusion
-  ( module ADP.Fusion
-  , module ADP.Fusion.Apply
-  , module ADP.Fusion.Base
-  , module ADP.Fusion.Term
-  , module ADP.Fusion.SynVar
-  , module ADP.Fusion.TH
-  ) where
-
-import           Data.Strict.Tuple
-import           GHC.Exts (inline)
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-
-import           ADP.Fusion.Apply
-import           ADP.Fusion.Base
-import           ADP.Fusion.SynVar
-import           ADP.Fusion.Term
-import           ADP.Fusion.TH
-
-import qualified Data.Vector.Unboxed as VU
-
-import           Data.PrimitiveArray
-
-
-
--- | 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 = \lu ij -> S.map (apply (inline f) . getArg) . mkStream (build xs) (initialContext ij) lu $ ij
-{-# INLINE (<<<) #-}
-
-infixl 8 <<#
-(<<#) f xs = \lu ij -> S.mapM (apply (inline f) . getArg) . mkStream (build xs) (initialContext ij) lu $ ij
-{-# INLINE (<<#) #-}
-
--- | Combine two RHSs to give a choice between parses.
-
-infixl 7 |||
-(|||) xs ys = \lu ij -> xs lu ij S.++ ys lu 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 = \lu ij -> (inline h) $ s lu ij
-{-# 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
deleted file mode 100644
--- a/ADP/Fusion/Apply.hs
+++ /dev/null
@@ -1,89 +0,0 @@
-
-module ADP.Fusion.Apply where
-
---import Data.Array.Repa.Index
-import Data.PrimitiveArray (Z(..), (:.)(..))
-
-
-
--- * 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/Base.hs b/ADP/Fusion/Base.hs
deleted file mode 100644
--- a/ADP/Fusion/Base.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-
-module ADP.Fusion.Base
-  ( module ADP.Fusion.Base.Classes
-  , module ADP.Fusion.Base.Multi
-  , module ADP.Fusion.Base.Point
-  , module ADP.Fusion.Base.Set
-  , module ADP.Fusion.Base.Subword
-  ) where
-
-import ADP.Fusion.Base.Classes
-import ADP.Fusion.Base.Multi
-import ADP.Fusion.Base.Point
-import ADP.Fusion.Base.Set
-import ADP.Fusion.Base.Subword
-
diff --git a/ADP/Fusion/Base/Classes.hs b/ADP/Fusion/Base/Classes.hs
deleted file mode 100644
--- a/ADP/Fusion/Base/Classes.hs
+++ /dev/null
@@ -1,144 +0,0 @@
-
-module ADP.Fusion.Base.Classes where
-
-import           Data.Strict.Tuple
-import           Data.Vector.Fusion.Stream.Size
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-
-import           Data.PrimitiveArray
-
-
-
-data OutsideContext s
-  = OStatic     s
-  | ORightOf    s
-  | OFirstLeft  s
-  | OLeftOf     s
-
-data InsideContext s
-  = IStatic   s
-  | IVariable s
-
-data ComplementContext
-  = Complemented
-
-class RuleContext i where
-  type Context i :: *
-  initialContext :: i -> Context i
-
--- | During construction of the stream, we need to extract individual elements
--- from symbols in production rules. An element in a stream is fixed by both,
--- the type @x@ of the actual argument we want to grab (say individual
--- characters we parse from an input) and the type of indices @i@ we use.
---
--- @Elm@ data constructors are all eradicated during fusion and should never
--- show up in CORE.
-
-class Element x i where
-  data Elm    x i :: *
-  type RecElm x i :: *
-  type Arg    x   :: *
-  getArg :: Elm x i -> Arg x
-  getIdx :: Elm x i -> i
-  getOmx :: Elm x i -> i
-  getElm :: Elm x i -> RecElm x i
-
--- | @mkStream@ creates the actual stream of elements (@Elm@) that will be fed
--- to functions on the left of the @(<<<)@ operator. Streams work over all
--- monads and are specialized for each combination of arguments @x@ and indices
--- @i@.
-
-class (Monad m) => MkStream m x i where
-  mkStream :: x -> Context i -> i -> i -> S.Stream m (Elm x i)
-
--- | Finally, we need to be able to correctly build together symbols on the
--- right-hand side of the @(<<<)@ operator.
---
--- The default makes sure that the last (or only) argument left over is
--- correctly assigned a @Z@ to terminate the symbol stack.
-
-class Build x where
-  type Stack x :: *
-  type Stack x = S :!: x
-  build :: x -> Stack x
-  default build :: (Stack x ~ (S :!: x)) => x -> Stack x
-  build x = S :!: x
-  {-# Inline build #-}
-
-instance Build x => Build (x:!:y) where
-  type Stack (x:!:y) = Stack x :!: y
-  build (x:!:y) = build x :!: y
-  {-# Inline build #-}
-
--- | Similar to 'Z', but terminates an argument stack.
-
-data S = S
-  deriving (Eq,Show)
-
-instance
-  (
-  ) => Element S i where
-  data Elm S i = ElmS !i !i
-  type Arg S   = Z
-  getArg (ElmS _ _) = Z
-  getIdx (ElmS i _) = i
-  getOmx (ElmS _ o) = o
-  {-# Inline getArg #-}
-  {-# Inline getIdx #-}
-  {-# Inline getOmx #-}
-
-deriving instance Show ix => Show (Elm S ix)
-
--- | 'staticCheck' acts as a static filter. If 'b' is true, we keep all stream
--- elements. If 'b' is false, we discard all stream elements.
-
-staticCheck :: Monad m => Bool -> S.Stream m a -> S.Stream m a
-staticCheck b (S.Stream step t n) = b `seq` S.Stream snew (CheckLeft (b:.t)) (toMax n) where
-  {-# Inline [0] snew #-}
-  snew (CheckLeft  (False:._)) = return $ S.Done
-  snew (CheckLeft  (True :.s)) = return $ S.Skip (CheckRight s)
-  snew (CheckRight s         ) = do r <- step s
-                                    case r of
-                                      S.Yield x s' -> return $ S.Yield x (CheckRight s')
-                                      S.Skip    s' -> return $ S.Skip    (CheckRight s')
-                                      S.Done       -> return $ S.Done
-{-# INLINE staticCheck #-}
-
-data StaticCheck a b = CheckLeft a | CheckRight b
-
-
--- | Constrains the behaviour of the memoizing tables. They may be 'EmptyOk' if
--- @i==j@ is allowed (empty subwords or similar); or they may need 'NonEmpty'
--- indices, or finally they can be 'OnlyZero' (only @i==j@ allowed) which is
--- useful in multi-dimensional casese.
-
-data TableConstraint
-  = EmptyOk
-  | NonEmpty
-  | OnlyZero
-  deriving (Eq,Show)
-
-minSize :: TableConstraint -> Int
-minSize NonEmpty = 1
-minSize _        = 0
-{-# INLINE minSize #-}
-
-class ModifyConstraint t where
-  toNonEmpty :: t -> t
-  toEmpty    :: t -> t
-
--- |
-
-type family   TblConstraint x       :: *
-
-type instance TblConstraint (is:.i)        =  TblConstraint is :. TblConstraint i
-type instance TblConstraint Z              = Z
-type instance TblConstraint (Outside o)    = TblConstraint o
-type instance TblConstraint (Complement o) = TblConstraint o
-
--- TODO move into the sub-modules
-
-type instance TblConstraint PointL      = TableConstraint
-type instance TblConstraint PointR      = TableConstraint
-type instance TblConstraint Subword     = TableConstraint
-
diff --git a/ADP/Fusion/Base/Multi.hs b/ADP/Fusion/Base/Multi.hs
deleted file mode 100644
--- a/ADP/Fusion/Base/Multi.hs
+++ /dev/null
@@ -1,189 +0,0 @@
-
-module ADP.Fusion.Base.Multi where
-
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-import           Data.Strict.Tuple
-
-import           Data.PrimitiveArray
-
-import           ADP.Fusion.Base.Classes
-
-
-
--- * Multi-dimensional extension
-
--- | Terminates a multi-dimensional terminal symbol stack.
-
-data M = M
-  deriving (Eq,Show)
-
-infixl 2 :|
-
--- | Terminal symbols are stacked together with @a@ tails and @b@ head.
-
-data TermSymbol a b = a :| b
-  deriving (Eq,Show)
-
-instance Build (TermSymbol a b)
-
--- | Extracts the type of a multi-dimensional terminal argument.
-
-type family   TermArg x :: *
-type instance TermArg M                = Z
-
-instance (Element ls i) => Element (ls :!: TermSymbol a b) i where
-  data Elm (ls :!: TermSymbol a b) i = ElmTS !(TermArg (TermSymbol a b)) !i !i !(Elm ls i)
-  type Arg (ls :!: TermSymbol a b)   = Arg ls :. TermArg (TermSymbol a b)
-  getArg (ElmTS a _ _ ls) = getArg ls :. a
-  getIdx (ElmTS _ i _ _ ) = i
-  getOmx (ElmTS _ _ o _ ) = o
-  {-# INLINE getArg #-}
-  {-# INLINE getIdx #-}
-
-deriving instance (Show i, Show (TermArg (TermSymbol a b)), Show (Elm ls i)) => Show (Elm (ls :!: TermSymbol a b) i)
-
-instance
-  ( Monad m
-  , MkStream m ls i
-  , Element ls i
-  , TerminalStream m (TermSymbol a b) i
-  , TermStaticVar (TermSymbol a b) i
-  ) => MkStream m (ls :!: TermSymbol a b) i where
-  mkStream (ls :!: ts) sv lu i
-    = S.map fromTerminalStream
-    . terminalStream ts sv i
-    . S.map toTerminalStream
-    $ mkStream ls (termStaticVar ts sv i) lu (termStreamIndex ts sv i)
-  {-# Inline mkStream #-}
-
--- | Handles each individual argument within a stack of terminal symbols.
-
-class TerminalStream m t i where
-  terminalStream :: t -> Context i -> i -> S.Stream m (S5 s j j i i) -> S.Stream m (S6 s j j i i (TermArg t))
-
-iPackTerminalStream a sv    (ii:._)  = terminalStream a sv ii     . S.map (\(S5 s zi zo    (is:.i)     (os:.o) ) -> S5 s (zi:.i) (zo:.o)    is     os )
-{-# Inline iPackTerminalStream #-}
-
-oPackTerminalStream a sv (O (is:.i)) = terminalStream a sv (O is) . S.map (\(S5 s zi zo (O (is:.i)) (O (os:.o))) -> S5 s (zi:.i) (zo:.o) (O is) (O os))
-{-# Inline oPackTerminalStream #-}
-
-instance (Monad m) => TerminalStream m M Z where
-  terminalStream M _ Z = S.map (\(S5 s j1 j2 Z Z) -> S6 s j1 j2 Z Z Z)
-  {-# INLINE terminalStream #-}
-
-instance (Monad m) => TerminalStream m M (Outside Z) where
-  terminalStream M _ (O Z) = S.map (\(S5 s j1 j2 (O Z) (O Z)) -> S6 s j1 j2 (O Z) (O Z) Z)
-  {-# INLINE terminalStream #-}
-
-instance Monad m => MkStream m S Z where
-  mkStream _ _ _ _ = S.singleton (ElmS Z Z)
-  {-# INLINE mkStream #-}
-
-instance Monad m => MkStream m S (Outside Z) where
-  mkStream _ _ _ _ = S.singleton (ElmS (O Z) (O Z))
-  {-# INLINE mkStream #-}
-
--- | For multi-dimensional terminals we need to be able to calculate how the
--- static/variable signal changes and if the index for the inner part needs to
--- be modified.
-
-class TermStaticVar t i where
-  termStaticVar   :: t -> Context i -> i -> Context i
-  termStreamIndex :: t -> Context i -> i -> i
-
-instance TermStaticVar M Z where
-  termStaticVar   _ _ _ = Z
-  termStreamIndex _ _ _ = Z
-  {-# INLINE termStaticVar #-}
-  {-# INLINE termStreamIndex #-}
-
-instance TermStaticVar M (Outside Z) where
-  termStaticVar   _ _ _ = Z
-  termStreamIndex _ _ _ = O Z
-  {-# INLINE termStaticVar #-}
-  {-# INLINE termStreamIndex #-}
-
-instance
-  ( TermStaticVar a is
-  , TermStaticVar b i
-  ) => TermStaticVar (TermSymbol a b) (is:.i) where
-  termStaticVar   (a:|b) (vs:.v) (is:.i) = termStaticVar   a vs is :. termStaticVar   b v i
-  termStreamIndex (a:|b) (vs:.v) (is:.i) = termStreamIndex a vs is :. termStreamIndex b v i
-  {-# INLINE termStaticVar #-}
-  {-# INLINE termStreamIndex #-}
-
-instance
-  ( TermStaticVar a (Outside is)
-  , TermStaticVar b (Outside i)
-  ) => TermStaticVar (TermSymbol a b) (Outside (is:.i)) where
-  termStaticVar   (a:|b) (vs:.v) (O (is:.i)) = termStaticVar   a vs (O is) :. termStaticVar   b v (O i)
-  termStreamIndex (a:|b) (vs:.v) (O (is:.i)) =
-    let (O js) = termStreamIndex a vs (O is)
-        (O j)  = termStreamIndex b v (O i)
-    in O (js:.j)
-  {-# INLINE termStaticVar #-}
-  {-# INLINE termStreamIndex #-}
-
-data S4 a b c d     = S4 !a !b !c !d
-
-data S5 a b c d e   = S5 !a !b !c !d !e
-
-data S6 a b c d e f = S6 !a !b !c !d !e !f
-
-fromTerminalStream (S6 s Z Z i o e) = ElmTS e i o s
-{-# INLINE fromTerminalStream #-}
-
-toTerminalStream s = S5 s Z Z (getIdx s) (getOmx s)
-{-# INLINE toTerminalStream #-}
-
-instance RuleContext Z where
-  type Context Z = Z
-  initialContext _ = Z
-  {-# INLINE initialContext #-}
-
-instance RuleContext (Outside Z) where
-  type Context (Outside Z) = Z
-  initialContext _ = Z
-  {-# INLINE initialContext #-}
-
-instance (RuleContext is, RuleContext i) => RuleContext (is:.i) where
-  type Context (is:.i) = Context is:.Context i
-  initialContext (is:.i) = initialContext is:.initialContext i
-  {-# INLINE initialContext #-}
-
-instance (RuleContext (Outside is), RuleContext (Outside i)) => RuleContext (Outside (is:.i)) where
-  type Context (Outside (is:.i)) = Context (Outside is):.Context (Outside i)
-  initialContext (O (is:.i)) = initialContext (O is):.initialContext (O i)
-  {-# INLINE initialContext #-}
-
-class TableStaticVar i where
-  tableStaticVar   ::                    Context i -> i -> Context i
-  tableStreamIndex :: TblConstraint i -> Context i -> i -> i
-
-instance TableStaticVar Z where
-  tableStaticVar     _ _ = Z
-  tableStreamIndex _ _ _ = Z
-  {-# INLINE [0] tableStaticVar   #-}
-  {-# INLINE [0] tableStreamIndex #-}
-
-instance TableStaticVar (Outside Z) where
-  tableStaticVar     _ _ = Z
-  tableStreamIndex _ _ _ = O Z
-  {-# INLINE [0] tableStaticVar   #-}
-  {-# INLINE [0] tableStreamIndex #-}
-
-instance (TableStaticVar is, TableStaticVar i) => TableStaticVar (is:.i) where
-  tableStaticVar           (vs:.v) (is:.i) = tableStaticVar      vs is :. tableStaticVar     v i
-  tableStreamIndex (cs:.c) (vs:.v) (is:.i) = tableStreamIndex cs vs is :. tableStreamIndex c v i
-  {-# INLINE [0] tableStaticVar   #-}
-  {-# INLINE [0] tableStreamIndex #-}
-
-instance (TableStaticVar (Outside is), TableStaticVar (Outside i)) => TableStaticVar (Outside (is:.i)) where
-  tableStaticVar           (vs:.v) (O (is:.i)) = tableStaticVar      vs (O is) :. tableStaticVar     v (O i)
-  tableStreamIndex (cs:.c) (vs:.v) (O (is:.i)) =
-    let (O js) = tableStreamIndex cs vs (O is)
-        (O j)  = tableStreamIndex c  v  (O i)
-    in O (js:.j)
-  {-# INLINE [0] tableStaticVar   #-}
-  {-# INLINE [0] tableStreamIndex #-}
-
diff --git a/ADP/Fusion/Base/Point.hs b/ADP/Fusion/Base/Point.hs
deleted file mode 100644
--- a/ADP/Fusion/Base/Point.hs
+++ /dev/null
@@ -1,112 +0,0 @@
-
-module ADP.Fusion.Base.Point where
-
-import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..),flatten)
-import Data.Vector.Fusion.Stream.Size
-import Debug.Trace
-import Prelude hiding (map,filter)
-
-import Data.PrimitiveArray hiding (map)
-
-import ADP.Fusion.Base.Classes
-import ADP.Fusion.Base.Multi
-
-
-
-instance RuleContext PointL where
-  type Context PointL = InsideContext Int
-  initialContext _ = IStatic 0
-  {-# Inline initialContext #-}
-
-instance RuleContext (Outside PointL) where
-  type Context (Outside PointL) = OutsideContext Int
-  initialContext _ = OStatic 0
-  {-# Inline initialContext #-}
-
-instance RuleContext (Complement PointL) where
-  type Context (Complement PointL) = ComplementContext
-  initialContext _ = Complemented
-  {-# Inline initialContext #-}
-
-
-
-instance (Monad m) => MkStream m S PointL where
-  mkStream S (IStatic d) (PointL u) (PointL j)
-    = staticCheck (j>=0 && j<=d) . singleton $ ElmS (PointL 0) (PointL 0)
-  mkStream S (IVariable _) (PointL u) (PointL j)
-    = staticCheck (0<=j) . singleton $ ElmS (PointL 0) (PointL 0)
-  {-# Inline mkStream #-}
-
-instance (Monad m) => MkStream m S (Outside PointL) where
-  mkStream S (OStatic d) (O (PointL u)) (O (PointL i))
-    = staticCheck (i>=0 && i+d<=u && u == i) . singleton $ ElmS (O $ PointL i) (O . PointL $ i+d)
-  mkStream S (OFirstLeft d) (O (PointL u)) (O (PointL i))
-    = staticCheck (i>=0 && i+d<=u) . singleton $ ElmS (O $ PointL i) (O . PointL $ i+d)
-  {-# Inline mkStream #-}
-
-
-
-instance
-  ( Monad m
-  , MkStream m S is
-  , Context (is:.PointL) ~ (Context is:.(InsideContext Int))
-  ) => MkStream m S (is:.PointL) where
-  mkStream S (vs:.IStatic d) (lus:.PointL u) (is:.PointL i)
-    = staticCheck (i>=0 && i<=d && i<=u)
-    . map (\(ElmS zi zo) -> ElmS (zi:.PointL 0) (zo:.PointL 0))
-    $ mkStream S vs lus is
-  {-
-  mkStream S (vs:.IVariable ) (lus:.PointL u) (is:.PointL i)
-    = flatten mk step Unknown $ mkStream S vs lus is
-    where mk e = i `seq` return (e,i)
-          step (ElmS zi zo,k )
-            | k>=0 && k<=u = return $ Yield (ElmS (zi:.PointL k) (zo:.PointL 0)) (ElmS zi zo, -1)
-            | otherwise    = return $ Done
-          {-# Inline [0] mk   #-}
-          {-# Inline [0] step #-}
-  -}
-  -- TODO here, we have a problem in the interplay of @staticCheck@ or
-  -- @flatten@ and how we modify @is@. Apparently, once we demand to know
-  -- about @i@, fusion breaks down.
-  mkStream S (vs:.IVariable d) (lus:.PointL u) (is:.PointL i)
-    = staticCheck (i>=0 && i<=u)
-    $ map (\(ElmS zi zo) -> ElmS (zi:.PointL 0) (zo:.PointL 0))
-    $ mkStream S vs lus is
-  {-# INLINE mkStream #-}
-
-instance
-  ( Monad m
-  , MkStream m S (Outside is)
-  , Context (Outside (is:.PointL)) ~ (Context (Outside is) :. OutsideContext Int)
-  ) => MkStream m S (Outside (is:.PointL)) where
-  mkStream S (vs:.OStatic d) (O (lus:.PointL u)) (O (is:.PointL i))
-    = staticCheck (i>=0 && i+d == u)
-    . map (\(ElmS (O zi) (O zo)) -> ElmS (O (zi:.PointL i)) (O (zo:.(PointL $ i+d))))
-    $ mkStream S vs (O lus) (O is)
-  mkStream S (vs:.OFirstLeft d) (O (us:.PointL u)) (O (is:.PointL i))
-    = staticCheck (i>=0 && i+d<=u)
-    . map (\(ElmS (O zi) (O zo)) -> ElmS (O (zi:.PointL i)) (O (zo:.(PointL $ i+d))))
-    $ mkStream S vs (O us) (O is)
-  {-# Inline mkStream #-}
-
-instance TableStaticVar PointL where
-  tableStaticVar (IStatic   d) _ = IVariable d
-  tableStaticVar (IVariable d) _ = IVariable d
-  -- NOTE this code used to destroy fusion. If we inline tableStreamIndex
-  -- very late (after 'mkStream', probably) then everything works out.
-  tableStreamIndex c _ (PointL j)
-    | c==EmptyOk  = PointL j
-    | c==NonEmpty = PointL $ j-1
-    | c==OnlyZero = PointL j -- this should then actually request a size in 'tableStaticVar' ...
-  {-# INLINE [0] tableStaticVar   #-}
-  {-# INLINE [0] tableStreamIndex #-}
-
-instance TableStaticVar (Outside PointL) where
-  tableStaticVar     (OStatic d) _ = OFirstLeft d
-  tableStreamIndex c _ (O (PointL j))
-    | c==EmptyOk  = O (PointL j)
-    | c==NonEmpty = O (PointL $ j-1)
-    | c==OnlyZero = O (PointL j) -- this should then actually request a size in 'tableStaticVar' ...
-  {-# INLINE [0] tableStaticVar   #-}
-  {-# INLINE [0] tableStreamIndex #-}
-
diff --git a/ADP/Fusion/Base/Set.hs b/ADP/Fusion/Base/Set.hs
deleted file mode 100644
--- a/ADP/Fusion/Base/Set.hs
+++ /dev/null
@@ -1,103 +0,0 @@
-
--- | The @Context@ for a @BitSet@ is the number of bits we should reserve
--- for the more right-most symbols, which request a number of reserved
--- bits.
-
-module ADP.Fusion.Base.Set where
-
-import Data.Vector.Fusion.Stream.Monadic (singleton,filter,enumFromStepN,map,unfoldr)
-import Data.Vector.Fusion.Stream.Size
-import Debug.Trace
-import Prelude hiding (map,filter)
-import Data.Bits
-
-import Data.PrimitiveArray
-
-import ADP.Fusion.Base.Classes
-import ADP.Fusion.Base.Multi
-
-
-
-type instance TblConstraint BitSet                              = TableConstraint
-type instance TblConstraint (BitSet:>Interface i:>Interface j)  = TableConstraint
-
-
-
-instance RuleContext BitSet where
-  type Context BitSet = InsideContext Int
-  initialContext _ = IStatic 0
-  {-# Inline initialContext #-}
-
-instance RuleContext (Outside BitSet) where
-  type Context (Outside BitSet) = OutsideContext ()
-  initialContext _ = OStatic ()
-  {-# Inline initialContext #-}
-
-instance RuleContext (Complement BitSet) where
-  type Context (Complement BitSet) = ComplementContext
-  initialContext _ = Complemented
-  {-# Inline initialContext #-}
-
-
-
-instance RuleContext (BS2I First Last) where
-  type Context (BS2I First Last) = InsideContext Int
-  initialContext _ = IStatic 0
-  {-# Inline initialContext #-}
-
-instance RuleContext (Outside (BS2I First Last)) where
-  type Context (Outside (BS2I First Last)) = OutsideContext ()
-  initialContext _ = OStatic ()
-  {-# Inline initialContext #-}
-
-instance RuleContext (Complement (BS2I First Last)) where
-  type Context (Complement (BS2I First Last)) = ComplementContext
-  initialContext _ = Complemented
-  {-# Inline initialContext #-}
-
-
-
-instance
-  ( Monad m
-  ) => MkStream m S BitSet where
-  mkStream S (IStatic c) u s
-    = staticCheck (c <= popCount s) . singleton $ ElmS s 0
-  mkStream S (IVariable c) u s
-    = staticCheck (c <= popCount s) . singleton $ ElmS 0 0
-  {-# Inline mkStream #-}
-
-
-
-instance
-  ( Monad m
-  ) => MkStream m S (BS2I First Last) where
-  mkStream S (IStatic rp) u sij@(s:>Iter i:>j)
-    = staticCheck (popCount s == 0 && rp == 0) . singleton $ ElmS (0:>Iter i:>Iter i) undefbs2i
-  mkStream S (IVariable rp) u sij@(s:>Iter i:>j)
-    = staticCheck (popCount s >= rp) . singleton $ ElmS (0:>Iter i:>Iter i) undefbs2i
-  {-# Inline mkStream #-}
-
-instance
-  ( Monad m
-  ) => MkStream m S (Outside (BS2I First Last)) where
-
-instance
-  ( Monad m
-  ) => MkStream m S (Complement (BS2I First Last)) where
-
-
-
--- | An undefined bitset with 2 interfaces.
-
-undefbs2i :: BS2I f l
-undefbs2i = (-1) :> (-1) :> (-1)
-{-# Inline undefbs2i #-}
-
-undefi :: Interface i
-undefi = (-1)
-{-# Inline undefi #-}
-
--- | We sometimes need 
-
-data ThisThatNaught a b = This a | That b | Naught
-
diff --git a/ADP/Fusion/Base/Subword.hs b/ADP/Fusion/Base/Subword.hs
deleted file mode 100644
--- a/ADP/Fusion/Base/Subword.hs
+++ /dev/null
@@ -1,102 +0,0 @@
-
--- | Instances to allow 'Subword's to be used as index structures in
--- @ADPfusion@.
-
-module ADP.Fusion.Base.Subword where
-
-import Data.Vector.Fusion.Stream.Monadic (singleton,filter,enumFromStepN,map,unfoldr)
-import Data.Vector.Fusion.Stream.Size
-import Debug.Trace
-import Prelude hiding (map,filter)
-
-import Data.PrimitiveArray hiding (map)
-
-import ADP.Fusion.Base.Classes
-import ADP.Fusion.Base.Multi
-
-
-
-instance RuleContext Subword where
-  type Context Subword = InsideContext ()
-  initialContext _ = IStatic ()
-  {-# Inline initialContext #-}
-
-instance RuleContext (Outside Subword) where
-  type Context (Outside Subword) = OutsideContext (Int:.Int)
-  initialContext _ = OStatic (0:.0)
-  {-# Inline  initialContext #-}
-
-instance RuleContext (Complement Subword) where
-  type Context (Complement Subword) = ComplementContext
-  initialContext _ = Complemented
-  {-# Inline initialContext #-}
-
--- TODO write instance
-
--- instance RuleContext (Complement Subword)
-
-
-
-instance (Monad m) => MkStream m S Subword where
-  mkStream S (IStatic ()) (Subword (_:.h)) (Subword (i:.j))
-    = staticCheck (i>=0 && i==j && j<=h) . singleton $ ElmS (subword i i) (subword 0 0)
-  -- NOTE it seems that a static check within an @IVariable@ context
-  -- destroys fusion; maybe because of the outer flatten? We don't actually
-  -- need a static check anyway because the next flatten takes care of
-  -- conditional checks. @filter@ on the other hand, does work.
-  -- TODO test with and without filter using quickcheck
-  mkStream S (IVariable ()) (Subword (_:.h)) (Subword (i:.j))
-    = filter (const $ 0<=i && i<=j && j<=h) . singleton $ ElmS (subword i i) (subword 0 0)
-  {-# Inline mkStream #-}
-
-instance (Monad m) => MkStream m S (Outside Subword) where
-  mkStream S (OStatic (di:.dj)) (O (Subword (_:.h))) (O (Subword (i:.j)))
-    = staticCheck (i==0 && j+dj==h) . singleton $ ElmS (O $ subword i j) (O $ Subword (i:.j+dj))
-  mkStream S (OFirstLeft (di:.dj)) (O (Subword (_:.h))) (O (Subword (i:.j)))
-    = let i' = i-di
-      in  staticCheck (0 <= i' && i<=j && j+dj<=h) . singleton $ ElmS (O $ subword i' i') (O $ subword i' i')
-  mkStream S (OLeftOf (di:.dj)) (O (Subword (_:.h))) (O (Subword (i:.j)))
-    = let i' = i-di
-      in  staticCheck (0 <= i' && i<=j && j+dj<=h)
-    $ map (\k -> ElmS (O $ subword 0 k) (O $ subword k j))
-    $ enumFromStepN 0 1 (i'+1)
-  {-# Inline mkStream #-}
-
-instance (Monad m) => MkStream m S (Complement Subword) where
-  mkStream S Complemented (C (Subword (_:.h))) (C (Subword (i:.j)))
-    = map (\(k,l) -> ElmS (C $ subword k l) (C $ subword k l))
-    $ unfoldr go (i,i)
-    where go (k,l)
-            | k >h || k >j = Nothing
-            | l==h || l==j = Just ( (k,l) , (k+1,k+1) )
-            | otherwise    = Just ( (k,l) , (k  ,l+1) )
-          {-# Inline [0] go #-}
-  {-# Inline mkStream #-}
-
-
-
-instance
-  ( Monad m
-  , MkStream m S is
-  , Context (is:.Subword) ~ (Context is:.(InsideContext ()))
-  ) => MkStream m S (is:.Subword) where
-  mkStream S (vs:.IStatic ()) (lus:.Subword (_:.h)) (ixs:.Subword(i:.j))
-    = staticCheck (i>=0 && i==j && j<=h)
-    . map (\(ElmS zi zo) -> ElmS (zi:.subword i i) (zo:.subword 0 0))
-    $ mkStream S vs lus ixs
-  mkStream S (vs:.IVariable ()) (lus:.Subword (_:.h)) (ixs:.Subword (i:.j))
-    = map (\(ElmS zi zo) -> ElmS (zi:.subword i i) (zo:.subword 0 0))
-    . filter (const $ 0<=i && i<=j && j<=h)
-    $ mkStream S vs lus ixs
-  {-# Inline mkStream #-}
-
-instance TableStaticVar Subword where
-  tableStaticVar (IStatic   d) _ = IVariable d
-  tableStaticVar (IVariable d) _ = IVariable d
-  tableStreamIndex c _ (Subword (i:.j))
-    | c==EmptyOk  = subword i j
-    | c==NonEmpty = subword i (j-1)
-    | c==NonEmpty = error "A.F.B.Subword ???"
-  {-# INLINE [0] tableStaticVar   #-}
-  {-# INLINE [0] tableStreamIndex #-}
-
diff --git a/ADP/Fusion/Core.hs b/ADP/Fusion/Core.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core.hs
@@ -0,0 +1,152 @@
+
+{-# Language MagicHash #-}
+
+-- | Generalized fusion system for grammars.
+--
+-- This module re-exports only the core functionality.
+--
+-- 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.
+
+module ADP.Fusion.Core
+  ( module ADP.Fusion.Core
+  , module ADP.Fusion.Core.Apply
+  , module ADP.Fusion.Core.Classes
+  , module ADP.Fusion.Core.Multi
+  , module ADP.Fusion.Core.SynVar.Array.Type
+  , module ADP.Fusion.Core.SynVar.Axiom
+  , module ADP.Fusion.Core.SynVar.Backtrack
+  , module ADP.Fusion.Core.SynVar.FillTyLvl
+  , module ADP.Fusion.Core.SynVar.Indices
+  , module ADP.Fusion.Core.SynVar.Recursive.Type
+  , module ADP.Fusion.Core.SynVar.Split.Type
+  , module ADP.Fusion.Core.SynVar.TableWrap
+  , module ADP.Fusion.Core.Term.Chr
+  , module ADP.Fusion.Core.Term.Deletion
+  , module ADP.Fusion.Core.Term.Edge
+  , module ADP.Fusion.Core.Term.Epsilon
+  , module ADP.Fusion.Core.Term.MultiChr
+  , module ADP.Fusion.Core.Term.PeekIndex
+  , module ADP.Fusion.Core.Term.Str
+  , module ADP.Fusion.Core.TH
+  , module ADP.Fusion.Core.TyLvlIx
+  , module Data.Vector.Fusion.Stream.Monadic
+  , module Data.Vector.Fusion.Util
+  ) where
+
+import           Data.Vector.Fusion.Stream.Monadic (Stream (..))
+import           Data.Strict.Tuple
+import           GHC.Exts (inline)
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+import           Data.Vector.Fusion.Util (Id(..))
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Core.Apply
+import           ADP.Fusion.Core.Classes hiding (iIx)
+import           ADP.Fusion.Core.Multi hiding (iIx)
+import           ADP.Fusion.Core.SynVar.Array.Type
+import           ADP.Fusion.Core.SynVar.Axiom
+import           ADP.Fusion.Core.SynVar.Backtrack
+import           ADP.Fusion.Core.SynVar.FillTyLvl
+import           ADP.Fusion.Core.SynVar.Indices
+import           ADP.Fusion.Core.SynVar.Recursive.Type
+import           ADP.Fusion.Core.SynVar.Split.Type
+import           ADP.Fusion.Core.SynVar.TableWrap
+import           ADP.Fusion.Core.Term.Chr
+import           ADP.Fusion.Core.Term.Deletion
+import           ADP.Fusion.Core.Term.Edge
+import           ADP.Fusion.Core.Term.Epsilon
+import           ADP.Fusion.Core.Term.MultiChr
+import           ADP.Fusion.Core.Term.PeekIndex
+import           ADP.Fusion.Core.Term.Str
+import           ADP.Fusion.Core.TH
+import           ADP.Fusion.Core.TyLvlIx
+
+
+
+-- | 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 <<<
+(<<<)
+  ∷ forall k m initCtx symbols i b
+  . ( Monad m
+    , Build symbols
+    , Element (Stack symbols) i
+    , Apply (Arg (Stack symbols) → b)
+    , initCtx ~ InitialContext i
+    , MkStream m initCtx (Stack symbols) i
+    )
+  ⇒ (Fun (Arg (Stack symbols) → b))
+  → symbols
+  → (LimitType i → i → Stream m b)
+(<<<) f xs
+  = \lu ij
+  → S.map (apply (inline f) . getArg)
+  $ mkStream (Proxy ∷ Proxy initCtx) (build xs) 1# lu ij
+{-# INLINE (<<<) #-}
+
+--infixl 8 <<#
+--(<<#) f xs = \lu ij -> S.mapM (apply (inline f) . getArg) $ mkStream Proxy (build xs) 1# lu ij
+--{-# INLINE (<<#) #-}
+
+-- | Combine two RHSs to give a choice between parses.
+
+infixl 7 |||
+(|||) xs ys = \lu ij -> xs lu ij `streamappend` ys lu ij
+{-# INLINE (|||) #-}
+
+data StreamAppend a b = SAL a | SAR b
+
+streamappend :: Monad m => Stream m a -> Stream m a -> Stream m a
+{-# Inline streamappend #-}
+Stream stepa ta `streamappend` Stream stepb tb = Stream step (SAL ta)
+  where
+    {-# Inline [0] step #-}
+    step (SAL   sa) = do
+                        r <- stepa sa
+                        case r of
+                          S.Yield x sa' -> return $ S.Yield x (SAL sa')
+                          S.Skip    sa' -> return $ S.Skip    (SAL sa')
+                          S.Done        -> return $ S.Skip    (SAR tb)
+    step (SAR   sb) = do
+                        r <- stepb sb
+                        case r of
+                          S.Yield x sb' -> return $ S.Yield x (SAR sb')
+                          S.Skip    sb' -> return $ S.Skip    (SAR sb')
+                          S.Done        -> return $ S.Done
+
+
+-- | 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 = \lu ij -> (inline h) $ s lu ij
+{-# 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/Core/Apply.hs b/ADP/Fusion/Core/Apply.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/Apply.hs
@@ -0,0 +1,89 @@
+
+module ADP.Fusion.Core.Apply where
+
+--import Data.Array.Repa.Index
+import Data.PrimitiveArray.Index.Class (Z(..), (:.)(..))
+
+
+
+-- * 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/Core/Classes.hs b/ADP/Fusion/Core/Classes.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/Classes.hs
@@ -0,0 +1,233 @@
+
+{-# Language MagicHash #-}
+
+module ADP.Fusion.Core.Classes where
+
+import           Control.DeepSeq
+import           Data.Proxy
+import           Data.Strict.Tuple
+import           GHC.Exts hiding (build)
+import           GHC.Generics (Generic, Generic1)
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+
+import           Data.PrimitiveArray.Index.Class
+
+
+
+-- TODO Until I figure out how to use @InitialContext ∷ k@ instead of
+-- @InitialContext ∷ *@ we need to live in @*@. Unfortunately, @(<<<)@ does not
+-- like differently-kinded types.
+
+{-
+data OutsideContext s
+  = OStatic     s
+  | ORightOf    s
+  | OFirstLeft  s
+  | OLeftOf     s
+  deriving (Show)
+-}
+data OStatic    s
+data ORightOf   s
+data OFirstLeft s
+data OLeftOf    s
+
+{-
+data InsideContext s
+  = IStatic   {iGetContext :: s}
+  | IVariable {iGetContext :: s}
+  deriving (Show)
+-}
+data IStatic   s
+data IVariable s
+
+{-
+data ComplementContext
+  = Complemented
+  deriving (Show)
+-}
+data Complement
+
+-- | Needed for structures that have long-range interactions and "expand",
+-- like sets around edge boundaries: @set <edge> set@. requires the sets to
+-- be connected.
+
+data ExtComplementContext s
+  = CStatic s
+  | CVariable s
+
+-- | For each index type @ix@, @initialContext (Proxy ∷ ix)@ yields the initial
+-- context from which to start up rules.
+--
+-- TODO turn into type family and make 'initialContext' a global function.
+
+type family InitialContext ix ∷ *
+
+{-
+class RuleContext ix where
+  type InitialContext ix ∷ *
+  initialContext ∷ Proxy ix → Proxy (InitialContext ix)
+--  default initialContext ∷ Proxy ix → Proxy (InitialContext ix ∷ k)
+  initialContext Proxy = Proxy
+  {-# Inline initialContext #-}
+-}
+
+-- | While we ostensibly use an index of type @i@ we typically do not need
+-- every element of an @i@. For example, when looking at 'Subword's, we do
+-- not need both element of @j:.k@ but only @k@.
+-- Also, inside grammars do need fewer moving indices than outside
+-- grammars.
+
+data family RunningIndex i :: *
+
+data instance RunningIndex Z = RiZ
+  deriving (Generic, NFData, Show)
+
+data instance RunningIndex (is:.i) = !(RunningIndex is) :.: !(RunningIndex i)
+  deriving (Generic)
+
+deriving instance (NFData (RunningIndex is), NFData (RunningIndex i)) => NFData (RunningIndex (is:.i))
+
+-- | During construction of the stream, we need to extract individual elements
+-- from symbols in production rules. An element in a stream is fixed by both,
+-- the type @x@ of the actual argument we want to grab (say individual
+-- characters we parse from an input) and the type of indices @i@ we use.
+--
+-- @Elm@ data constructors are all eradicated during fusion and should never
+-- show up in CORE.
+
+class Element (x ∷ *) i where
+  data Elm    x i ∷ *
+  type RecElm x i ∷ *
+  type Arg    x   ∷ *
+  getArg ∷ Elm x i → Arg x
+  getIdx ∷ Elm x i → RunningIndex i
+  getElm ∷ Elm x i → RecElm x i
+
+-- | @mkStream@ creates the actual stream of elements (@Elm@) that will be fed
+-- to functions on the left of the @(<<<)@ operator. Streams work over all
+-- monads and are specialized for each combination of arguments @x@ and indices
+-- @i@.
+
+class (Monad m) ⇒ MkStream m pos sym ix where
+  mkStream
+    ∷ Proxy pos
+    -- ^ Fix static/variable/... depending on position in r.h.s. of rule.
+    → sym
+    -- ^ the symbol type (syntactic variable with or with memoization, terminal types like char, string, etc)
+    → Int#
+    -- ^ guard system for stopping execution of rule
+    → LimitType ix
+    -- ^ upper limit of index @i@, using the specialized 'LimitType' for type @i@.
+    → ix
+    -- ^ the current index @i@
+    → S.Stream m (Elm sym ix)
+    -- ^ resulting stream of elements
+
+-- | This type family yields for a given positional type @posty ∷ k@, the
+-- current symbol type @symty@ and index type @ix@ the next-left positional
+-- type within the same kind @k@ Keeping within the same kind should prevent
+-- accidental switching from Inside to Outside or similar bugs.
+
+type family LeftPosTy (pos ∷ *) sym ix ∷ *
+
+-- | Finally, we need to be able to correctly build together symbols on the
+-- right-hand side of the @(<<<)@ operator.
+--
+-- The default makes sure that the last (or only) argument left over is
+-- correctly assigned a @Z@ to terminate the symbol stack.
+
+class Build x where
+  type Stack x :: *
+  type Stack x = S :!: x
+  build :: x -> Stack x
+  default build :: (Stack x ~ (S :!: x)) => x -> Stack x
+  build x = S :!: x
+  {-# Inline build #-}
+
+instance Build x => Build (x:!:y) where
+  type Stack (x:!:y) = Stack x :!: y
+  build (x:!:y) = build x :!: y
+  {-# Inline build #-}
+
+-- | Similar to 'Z', but terminates an argument stack.
+
+data S = S
+  deriving (Eq,Show)
+
+instance
+  (
+  ) => Element S i where
+  newtype Elm S i = ElmS (RunningIndex i)
+  type Arg S   = Z
+  getArg (ElmS _) = Z
+  getIdx (ElmS i) = i
+  {-# Inline [0] getArg #-}
+  {-# Inline [0] getIdx #-}
+
+deriving instance (Show (RunningIndex ix)) => Show (Elm S ix)
+
+-- | 'staticCheck' acts as a static filter. If 'b' is true, we keep all stream
+-- elements. If 'b' is false, we discard all stream elements.
+
+staticCheck :: Monad m => Bool -> S.Stream m a -> S.Stream m a
+staticCheck !b (S.Stream step t) = S.Stream snew (CheckLeft b t) where
+  {-# Inline [0] snew #-}
+  snew (CheckLeft  False _) = return $ S.Done
+  snew (CheckLeft  True  s) = return $ S.Skip (CheckRight s)
+  snew (CheckRight s      ) = do r <- step s
+                                 case r of
+                                   S.Yield x s' -> return $ S.Yield x (CheckRight s')
+                                   S.Skip    s' -> return $ S.Skip    (CheckRight s')
+                                   S.Done       -> return $ S.Done
+{-# INLINE staticCheck #-}
+
+data StaticCheck a b = CheckLeft Bool a | CheckRight b
+
+staticCheck# :: Monad m => Int# -> S.Stream m a -> S.Stream m a
+staticCheck# b (S.Stream step t) = S.Stream snew (SL b t) where
+  {-# Inline [0] snew #-}
+  snew (SL q s)
+    | 1# <- q   = return $ S.Skip (SR s)
+    | otherwise = return $ S.Done
+  snew (SR s  ) = do r <- step s
+                     case r of
+                       S.Yield x s' -> return $ S.Yield x (SR s')
+                       S.Skip    s' -> return $ S.Skip    (SR s')
+                       S.Done       -> return $ S.Done
+{-# Inline staticCheck# #-}
+
+
+data SLR z = SL Int# z | SR z
+
+-- | Constrains the behaviour of the memoizing tables. They may be 'EmptyOk' if
+-- @i==j@ is allowed (empty subwords or similar); or they may need 'NonEmpty'
+-- indices, or finally they can be 'OnlyZero' (only @i==j@ allowed) which is
+-- useful in multi-dimensional casese.
+
+data EmptyOk = EmptyOk
+  deriving (Show)
+
+data NonEmpty = NonEmpty
+  deriving (Show)
+
+class MinSize c where
+  minSize :: c -> Int
+
+instance MinSize EmptyOk where
+  minSize EmptyOk = 0
+  {-# Inline minSize #-}
+
+instance MinSize NonEmpty where
+  minSize NonEmpty = 1
+  {-# Inline minSize #-}
+
+-- |
+--
+-- TODO Rewrite to generalize easily over multi-dim cases.
+
+class ModifyConstraint t where
+  type TNE t :: *
+  type TE  t :: *
+  toNonEmpty :: t -> TNE t
+  toEmpty    :: t -> TE  t
+
diff --git a/ADP/Fusion/Core/Multi.hs b/ADP/Fusion/Core/Multi.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/Multi.hs
@@ -0,0 +1,228 @@
+
+{-# Language MagicHash #-}
+
+module ADP.Fusion.Core.Multi where
+
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+import           Data.Vector.Fusion.Stream.Monadic
+import           Data.Strict.Tuple
+import           Data.Proxy
+import           Prelude hiding (map)
+import           GHC.Exts
+import           Debug.Trace
+
+import           Data.PrimitiveArray.Index.Class hiding (map)
+
+import           ADP.Fusion.Core.Classes
+import           ADP.Fusion.Core.TyLvlIx
+
+
+
+-- * Multi-dimensional extension
+
+-- | Terminates a multi-dimensional terminal symbol stack.
+
+data M = M
+  deriving (Eq,Show)
+
+infixl 2 :|
+
+-- | Terminal symbols are stacked together with @a@ tails and @b@ head.
+
+data TermSymbol a b = a :| b
+  deriving (Eq,Show)
+
+instance Build (TermSymbol a b)
+
+-- | Extracts the type of a multi-dimensional terminal argument.
+
+type family   TermArg x :: *
+type instance TermArg M                = Z
+type instance TermArg (TermSymbol a b) = (TermArg a) :. (TermArg b)
+
+instance (Element ls i) => Element (ls :!: TermSymbol a b) i where
+  data Elm (ls :!: TermSymbol a b) i = ElmTS !(TermArg (TermSymbol a b)) !(RunningIndex i) !(Elm ls i)
+  type Arg (ls :!: TermSymbol a b)   = Arg ls :. TermArg (TermSymbol a b)
+  getArg (ElmTS a _ ls) = getArg ls :. a
+  getIdx (ElmTS _ i _ ) = i
+  {-# INLINE getArg #-}
+  {-# INLINE getIdx #-}
+
+deriving instance (Show i, Show (RunningIndex i), Show (TermArg (TermSymbol a b)), Show (Elm ls i)) => Show (Elm (ls :!: TermSymbol a b) i)
+
+type instance LeftPosTy (ps :. p) (TermSymbol a b) (is:.i) = (LeftPosTy ps a is) :. (LeftPosTy p b i)
+
+instance
+  ( Monad m
+  , MkStream m posLeft ls i
+  , Element ls i
+  , TermStaticVar pos (TermSymbol a b) i
+  , TermStream m pos (TermSymbol a b) (Elm ls i) i
+  , posLeft ~ LeftPosTy pos (TermSymbol a b) i
+  ) => MkStream m pos (ls :!: TermSymbol a b) i where
+  mkStream Proxy (ls :!: ts) grd lu i
+    = map (\(TState sS ii ee) -> ElmTS ee ii sS)
+    . termStream (Proxy ∷ Proxy pos) ts lu i
+    . map (\s -> TState s RiZ Z)
+    $ mkStream (Proxy ∷ Proxy posLeft)
+               ls
+               (termStaticCheck (Proxy ∷ Proxy pos) ts lu i grd)
+               lu (termStreamIndex (Proxy ∷ Proxy pos) ts i)
+  {-# Inline mkStream #-}
+
+-- | 
+
+type instance LeftPosTy Z M Z = Z
+
+instance Monad m => MkStream m Z S Z where
+  -- mkStream Proxy S grd ZZ Z = S.filter (const $ isTrue# grd) $ S.singleton $ ElmS RiZ
+  mkStream Proxy S grd ZZ Z = staticCheck# grd $ S.singleton $ ElmS RiZ
+  {-# Inline mkStream #-}
+
+-- | For multi-dimensional terminals we need to be able to calculate how the
+-- static/variable signal changes and if the index for the inner part needs to
+-- be modified.
+
+class TermStaticVar pos sym ix where
+--  termStaticVar   ∷ sym → Context i → i → Context i
+  termStreamIndex ∷ Proxy pos → sym → ix → ix
+  termStaticCheck ∷ Proxy pos → sym → LimitType ix → ix → Int# → Int#
+
+instance TermStaticVar pos M Z where
+  termStreamIndex Proxy M Z = Z
+  termStaticCheck Proxy M _ Z grd = grd
+  {-# INLINE [0] termStreamIndex #-}
+  {-# INLINE [0] termStaticCheck #-}
+
+instance
+  ( TermStaticVar ps ts is
+  , TermStaticVar p  t  i
+  ) => TermStaticVar (ps:.p) (TermSymbol ts t) (is:.i) where
+  termStreamIndex Proxy (ts:|t) (is:.i) = termStreamIndex (Proxy ∷ Proxy ps) ts is :. termStreamIndex (Proxy ∷ Proxy p) t i
+  termStaticCheck Proxy (ts:|t) (us:..u) (is:.i) grd = termStaticCheck (Proxy ∷ Proxy ps) ts us is (termStaticCheck (Proxy ∷ Proxy p) t u i grd)
+  {-# INLINE [0] termStreamIndex #-}
+  {-# INLINE [0] termStaticCheck #-}
+
+--instance RuleContext Z where
+type instance InitialContext Z = Z
+
+--instance (RuleContext is, RuleContext i) => RuleContext (is:.i) where
+type instance InitialContext (is:.i) = InitialContext is:.InitialContext i
+
+class TableStaticVar pos minSize tableIx ix where
+  tableStreamIndex
+    ∷ Proxy pos
+    -- ^ provide type-level information on if we are currently static/variable/
+    -- etc
+    → minSize
+    -- ^ Information on the minimal size of the corresponding table.
+    → LimitType tableIx
+    -- ^ provide type-level information on the index structure of the table we
+    -- are looking at. This index structure might well be different than the
+    -- @ix@ index we use in the grammar.
+    → ix
+    -- ^ current right-most index
+    → ix
+    -- ^ right-most index for symbol to the left of us
+
+-- | Index "0" for multi-dimensional syntactic variables.
+
+instance TableStaticVar pos Z tableIx Z where
+  tableStreamIndex Proxy Z _ Z = Z
+  {-# INLINE [0] tableStreamIndex #-}
+
+instance
+  ( TableStaticVar ps cs us is
+  , TableStaticVar p  c  u  i
+  )
+  ⇒ TableStaticVar (ps:.p) (cs:.c) (us:.u) (is:.i) where
+  tableStreamIndex Proxy (cs:.c) (us:..u) (is:.i)
+    =  tableStreamIndex (Proxy ∷ Proxy ps) cs us is
+    :. tableStreamIndex (Proxy ∷ Proxy p ) c  u  i
+  {-# INLINE [0] tableStreamIndex #-}
+
+
+data TermState s i e = TState
+  { tS  :: !s
+    -- ^ state coming in from the left
+  , iIx :: !(RunningIndex i)
+    -- ^ @I/C@ building up state to hand over to next symbol
+  , eTS :: !e
+    -- ^ element data
+  }
+
+class TermStream m pos t s i where
+  termStream
+    ∷ Proxy pos
+    → t
+    → LimitType i
+    → i
+    → Stream m (TermState s Z Z)
+    → Stream m (TermState s i (TermArg t))
+
+instance (Monad m) => TermStream m pos M s Z where
+  termStream Proxy M ZZ Z = id
+  {-# Inline termStream #-}
+
+-- |
+--
+-- TODO need @t -> ElmType t@ type function
+--
+-- TODO need to actually return an @ElmType t@ can do that instead of
+-- returning @u@ !!!
+
+addTermStream1
+  ∷ forall m pos t s i
+  . ( Monad m
+    , TermStream m (Z:.pos) (TermSymbol M t) (Elm (Term1 s) (Z:.i)) (Z:.i)
+    )
+  ⇒ Proxy pos
+  → t
+  → LimitType i
+  → i
+  → Stream m s
+  → Stream m (s,TermArg t,RunningIndex i)
+addTermStream1 Proxy t u i
+  = map (\(TState (ElmTerm1 sS) (RiZ:.:ii) (Z:.ee)) -> (sS,ee,ii))
+  . termStream (Proxy ∷ Proxy (Z:.pos)) (M:|t) (ZZ:..u) (Z:.i)
+  . map (\s -> TState (elmTerm1 s i) RiZ Z)
+{-# Inline addTermStream1 #-}
+
+newtype Term1 s = Term1 s
+
+elmTerm1 :: s -> i -> Elm (Term1 s) (Z:.i)
+elmTerm1 s _ = ElmTerm1 s
+{-# Inline elmTerm1 #-}
+
+instance (s ~ Elm x0 i, Element x0 i) => Element (Term1 s) (Z:.i) where
+  newtype Elm (Term1 s) (Z:.i) = ElmTerm1 s
+  getIdx (ElmTerm1 s) = RiZ :.: getIdx s
+  {-# Inline getIdx #-}
+
+-- | @Term MkStream@ context
+--
+-- TODO prepare for deletion
+
+--type TermMkStreamContext m (pos ∷ k) ls t i
+--  = ( Monad m
+--    , MkStream m pos ls i
+--    , TermStream m pos (TermSymbol M t) (Elm (Term1 (Elm ls i)) (Z:.i)) (Z:.i)
+--    , Element ls i
+--    , TermStaticVar pos t i
+--    )
+
+-- | @Term TermStream@ context
+
+type TermStreamContext m (pos ∷ k) ts s x0 sixty is i
+  = ( Monad m
+    , TermStream m pos ts s is
+    , GetIndex (RunningIndex sixty) (RunningIndex (is:.i))
+    , GetIx (RunningIndex sixty) (RunningIndex (is:.i)) ~ (RunningIndex i)
+    , Element x0 sixty
+    , s ~ Elm x0 sixty
+    )
+
+-- | Shorthand for proxifying @getIndex@
+
+type PRI is i = Proxy (RunningIndex (is:.i))
+
diff --git a/ADP/Fusion/Core/SynVar/Array.hs b/ADP/Fusion/Core/SynVar/Array.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/SynVar/Array.hs
@@ -0,0 +1,150 @@
+
+{-# Language MagicHash #-}
+
+module ADP.Fusion.Core.SynVar.Array
+  ( module ADP.Fusion.Core.SynVar.Array.Type
+  , module ADP.Fusion.Core.SynVar.Array
+  ) where
+
+
+import Data.Proxy
+import Data.Strict.Tuple hiding (snd)
+import Data.Vector.Fusion.Stream.Monadic
+import GHC.Exts
+import Prelude hiding (map,mapM)
+
+import Data.PrimitiveArray hiding (map)
+
+import ADP.Fusion.Core.Classes
+import ADP.Fusion.Core.Multi
+import ADP.Fusion.Core.SynVar.Array.Type
+import ADP.Fusion.Core.SynVar.Backtrack
+import ADP.Fusion.Core.SynVar.Indices
+import ADP.Fusion.Core.SynVar.TableWrap
+
+
+
+-- | Constraints needed to use @iTblStream@.
+
+type ITblCx m pos ls arr x u c i =
+  ( TableStaticVar pos c u i
+  , Element ls i
+  , AddIndexDense (Z:.pos) (Elm (SynVar1 (Elm ls i)) (Z:.i)) (Z:.c) (Z:.u) (Z:.i)
+  , PrimArrayOps arr u x
+  )
+
+-- | General function for @ITbl@s with skalar indices.
+
+iTblStream
+  ∷ forall b s m pos posLeft ls arr x u c i
+  . ( ITblCx m pos ls arr x u c i
+    , posLeft ~ LeftPosTy pos (TwITbl b s m arr c u x) i
+    , MkStream m posLeft ls i
+    )
+  ⇒ Proxy pos
+  → Pair ls (TwITbl b s m arr c u x)
+  → Int#
+  → LimitType i
+  → i
+  → Stream m (Elm (ls :!: TwITbl b s m arr c u x) i)
+iTblStream pos (ls :!: TW (ITbl c t) _) grd us is
+  = map (\(s,tt,ii') -> ElmITbl (t!tt) ii' s)
+  . addIndexDense1 pos c ub us is
+  $ mkStream (Proxy ∷ Proxy posLeft) ls grd us (tableStreamIndex (Proxy :: Proxy pos) c ub is)
+  where ub = upperBound t
+{-# Inline iTblStream #-}
+
+-- | General function for @Backtrack ITbl@s with skalar indices.
+
+btITblStream
+  ∷ forall b s mB mF pos posLeft ls arr x r u c i
+  . ( ITblCx mB pos ls arr x u c i
+    , posLeft ~ LeftPosTy pos (TwITblBt b s arr c u x mF mB r) i
+    , MkStream mB posLeft ls i
+    )
+  ⇒ Proxy pos
+  → Pair ls (TwITblBt b s arr c u x mF mB r)
+  → Int#
+  → LimitType i
+  → i
+  → Stream mB (Elm (ls :!: TwITblBt b s arr c u x mF mB r) i)
+btITblStream pos (ls :!: TW (BtITbl c t) bt) grd us is
+    = mapM (\(s,tt,ii') -> bt ub tt >>= \ ~bb -> return $ ElmBtITbl (t!tt) bb ii' s)
+    . addIndexDense1 pos c ub us is
+    $ mkStream (Proxy ∷ Proxy posLeft) ls grd us (tableStreamIndex (Proxy :: Proxy pos) c ub is)
+    where ub = upperBound t
+{-# Inline btITblStream #-}
+
+
+
+-- ** Instances
+
+instance
+  ( Monad m
+  , ITblCx m pos ls arr x u c (i I)
+  , MkStream m (LeftPosTy pos (TwITbl b s m arr c u x) (i I)) ls (i I)
+  ) => MkStream m pos (ls :!: TwITbl b s m arr c u x) (i I) where
+  mkStream = iTblStream
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad mB
+  , ITblCx mB pos ls arr x u c (i I)
+  , MkStream mB (LeftPosTy pos (TwITblBt b s arr c u x mF mB r) (i I)) ls (i I)
+  )
+  ⇒ MkStream mB pos (ls :!: TwITblBt b s arr c u x mF mB r) (i I) where
+  mkStream = btITblStream
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad m
+  , ITblCx m pos ls arr x u c (i O)
+  , MkStream m (LeftPosTy pos (TwITbl b s m arr c u x) (i O)) ls (i O)
+  ) => MkStream m pos (ls :!: TwITbl b s m arr c u x) (i O) where
+  mkStream = iTblStream
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad mB
+  , ITblCx mB pos ls arr x u c (i O)
+  , MkStream mB (LeftPosTy pos (TwITblBt b s arr c u x mF mB r) (i O)) ls (i O)
+  )
+  ⇒ MkStream mB pos (ls :!: TwITblBt b s arr c u x mF mB r) (i O) where
+  mkStream = btITblStream
+  {-# Inline mkStream #-}
+
+{-
+instance
+  ( Monad m
+  , ITblCx m ls arr x u c (i C)
+  ) => MkStream m (ls :!: TwITbl m arr c u x) (i C) where
+  mkStream = iTblStream
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad mB
+  , ITblCx mB ls arr x u c (i O)
+  ) => MkStream mB (ls :!: TwITblBt arr c u x mF mB r) (i O) where
+  mkStream = btITblStream
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad mB
+  , ITblCx mB ls arr x u c (i C)
+  ) => MkStream mB (ls :!: TwITblBt arr c u x mF mB r) (i C) where
+  mkStream = btITblStream
+  {-# Inline mkStream #-}
+
+instance ModifyConstraint (TwITbl m arr EmptyOk i x) where
+  type TNE (TwITbl m arr EmptyOk i x) = TwITbl m arr NonEmpty i x
+  type TE  (TwITbl m arr EmptyOk i x) = TwITbl m arr EmptyOk  i x
+  toNonEmpty (TW (ITbl b l _ arr) f) = TW (ITbl b l NonEmpty arr) f
+  {-# Inline toNonEmpty #-}
+
+instance ModifyConstraint (TwITblBt arr EmptyOk i x mF mB r) where
+  type TNE (TwITblBt arr EmptyOk i x mF mB r) = TwITblBt arr NonEmpty i x mF mB r
+  type TE  (TwITblBt arr EmptyOk i x mF mB r) = TwITblBt arr EmptyOk  i x mF mB r
+  toNonEmpty (TW (BtITbl _ arr) bt) = TW (BtITbl NonEmpty arr) bt
+  {-# Inline toNonEmpty #-}
+-}
+
diff --git a/ADP/Fusion/Core/SynVar/Array/Type.hs b/ADP/Fusion/Core/SynVar/Array/Type.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/SynVar/Array/Type.hs
@@ -0,0 +1,177 @@
+
+{-# Language DataKinds #-}
+{-# Language TypeOperators #-}
+
+module ADP.Fusion.Core.SynVar.Array.Type where
+
+import Data.Proxy
+import Data.Strict.Tuple hiding (uncurry,snd)
+import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..))
+import Debug.Trace
+import GHC.TypeNats
+import Prelude hiding (map,head,mapM)
+
+import Data.PrimitiveArray hiding (map)
+
+import ADP.Fusion.Core.Classes
+import ADP.Fusion.Core.Multi
+import ADP.Fusion.Core.SynVar.Axiom
+import ADP.Fusion.Core.SynVar.Backtrack
+import ADP.Fusion.Core.SynVar.Indices
+import ADP.Fusion.Core.SynVar.TableWrap
+
+
+
+-- | Immutable table.
+--
+-- NOTE / TODO We can *NOT* move the little order into the type-level until we
+-- have a fully working TH-based table filler.
+
+data ITbl (bigorder ∷ Nat) (smallOrder ∷ Nat) arr c i x where
+  ITbl ∷ { iTblConstraint  ∷ !c           -- TODO next to go?!
+         , iTblArray       ∷ !(arr i x)
+         } → ITbl bigOrder smallOrder arr c i x
+
+instance (Show c, Show (arr i x)) ⇒ Show (ITbl bo so arr c i x) where
+  show (ITbl c arr) = "ITbl " ++ " " ++ show c ++ " [" ++ show arr ++ "]"
+
+type TwITbl (b ∷ Nat) (s ∷ Nat) (m ∷ * → *) arr c i x = TW (ITbl b s arr c i x) (LimitType i → i → m x)
+
+type TwITblBt b s arr c i x mF mB r = TW (Backtrack (TwITbl b s mF arr c i x) mF mB) (LimitType i → i → mB [r])
+
+instance Build (TwITbl b s m arr c i x)
+
+instance Build (TwITblBt b s arr c i x mF mB r)
+
+type instance TermArg (TwITbl b s m arr c i x) = x
+
+type instance TermArg (TwITblBt b s arr c i x mF mB r) = (x,[r])
+
+instance GenBacktrackTable (TwITbl b s mF arr c i x) mF mB where
+  data Backtrack (TwITbl b s mF arr c i x) mF mB = BtITbl !c !(arr i x)
+  type BacktrackIndex (TwITbl b s mF arr c i x) = i
+  toBacktrack (TW (ITbl c arr) _) _ = BtITbl c arr
+  {-# Inline toBacktrack #-}
+
+
+
+-- * axiom stuff
+
+instance
+  ( Monad m
+  , PrimArrayOps arr i x
+  , IndexStream i
+  ) ⇒ Axiom (TwITbl b s m arr c i x) where
+  type AxiomStream (TwITbl b s m arr c i x) = m x
+  type AxiomIx     (TwITbl b s m arr c i x) = i
+  axiom (TW (ITbl c arr) _) = do
+    k ← head . streamDown zeroBound' $ upperBound arr
+    return $ arr ! k
+  {-# Inline axiom #-}
+  axiomAt (TW (ITbl c arr) _) k = 
+    return $ arr ! k
+  {-# Inline axiomAt #-}
+
+-- | We need this somewhat annoying instance construction (@i ~ j@ and @m
+-- ~ mB@) in order to force selection of this instance.
+
+instance
+  ( Monad mB
+  , PrimArrayOps arr i x
+  , IndexStream i
+  , j ~ i
+  , m ~ mB
+  ) ⇒ Axiom (TW (Backtrack (TwITbl b s mF arr c i x) mF mB) (LimitType j → j → m [r])) where
+  type AxiomStream (TW (Backtrack (TwITbl b s mF arr c i x) mF mB) (LimitType j → j → m [r])) = mB [r]
+  type AxiomIx     (TW (Backtrack (TwITbl b s mF arr c i x) mF mB) (LimitType j → j → m [r])) = i
+  axiom (TW (BtITbl c arr) bt) = do
+    h ← head . streamDown zeroBound' $ upperBound arr
+    bt (upperBound arr) h
+  {-# Inline axiom #-}
+  axiomAt (TW (BtITbl c arr) bt) k = do
+    bt (upperBound arr) k
+  {-# Inline axiomAt #-}
+
+
+
+-- * 'Element'
+
+instance Element ls i ⇒ Element (ls :!: TwITbl b s m arr c j x) i where
+  data Elm    (ls :!: TwITbl b s m arr c j x) i = ElmITbl !x !(RunningIndex i) !(Elm ls i)
+  type Arg    (ls :!: TwITbl b s m arr c j x)   = Arg ls :. x
+  type RecElm (ls :!: TwITbl b s m arr c j x) i = Elm ls i
+  getArg (ElmITbl x _ ls) = getArg ls :. x
+  getIdx (ElmITbl _ i _ ) = i
+  getElm (ElmITbl _ _ ls) = ls
+  {-# Inline getArg #-}
+  {-# Inline getIdx #-}
+  {-# Inline getElm #-}
+
+deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i), Show x) => Show (Elm (ls :!: TwITbl b s m arr c j x) i)
+
+instance Element ls i => Element (ls :!: TwITblBt b s arr c j x mF mB r) i where
+  data Elm    (ls :!: TwITblBt b s arr c j x mF mB r) i = ElmBtITbl !x [r] !(RunningIndex i) !(Elm ls i)
+  type Arg    (ls :!: TwITblBt b s arr c j x mF mB r)   = Arg ls :. (x, [r])
+  type RecElm (ls :!: TwITblBt b s arr c j x mF mB r) i = Elm ls i
+  getArg (ElmBtITbl x s _ ls) = getArg ls :. (x,s)
+  getIdx (ElmBtITbl _ _ i _ ) = i
+  getElm (ElmBtITbl _ _ _ ls) = ls
+  {-# Inline getArg #-}
+  {-# Inline getIdx #-}
+  {-# Inline getElm #-}
+
+instance (Show x, Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: TwITblBt b s arr c i x mF mB r) i) where
+  show (ElmBtITbl x _ i s) = show (x,i) ++ " " ++ show s
+
+
+
+-- * Multi-dim extensions
+
+type instance LeftPosTy Z (TwITbl b s m arr EmptyOk Z x) Z = Z
+type instance LeftPosTy Z (TwITblBt b s arr EmptyOk Z x mF mB r) Z = Z
+
+type instance LeftPosTy (ps:.p) (TwITbl b s m arr (eos:.EmptyOk) (us:.u) x) (is:.i)
+  = (LeftPosTy ps (TwITbl b s m arr eos us x) is) :. (LeftPosTy p (TwITbl b s m arr EmptyOk u x) i)
+
+type instance LeftPosTy (ps:.p) (TwITblBt b s arr (eos:.EmptyOk) (us:.u) x mF mB r) (is:.i)
+  = (LeftPosTy ps (TwITblBt b s arr eos us x mF mB r) is) :. (LeftPosTy p (TwITblBt b s arr EmptyOk u x mF mB r) i)
+
+type instance LeftPosTy Z (TwITbl b s m arr Z Z x) Z = Z
+type instance LeftPosTy Z (TwITblBt b s arr Z Z x mF mB r) Z = Z
+
+
+instance
+  forall b s l m pos ps p posLeft arr cs c us u x is i ls
+  . ( Monad m
+  , pos ~ (ps:.p)
+  , posLeft ~ LeftPosTy pos (TwITbl b s m arr (cs:.c) (us:.u) x) (is:.i)
+  , Element ls (is:.i)
+  , TableStaticVar (ps:.p) (cs:.c) (us:.u) (is:.i)
+  , AddIndexDense pos (Elm ls (is:.i)) (cs:.c) (us:.u) (is:.i)
+  , MkStream m posLeft ls (is:.i)
+  , PrimArrayOps arr (us:.u) x
+  ) ⇒ MkStream m (ps:.p) (ls :!: TwITbl b s m arr (cs:.c) (us:.u) x) (is:.i) where
+  mkStream Proxy (ls :!: TW (ITbl csc t) _) grd usu isi
+    = map (\(s,tt,ii') -> ElmITbl (t!tt) ii' s)
+    . addIndexDense (Proxy ∷ Proxy pos) csc ub usu isi
+    $ mkStream (Proxy ∷ Proxy posLeft) ls grd usu (tableStreamIndex (Proxy ∷ Proxy pos) csc ub isi)
+    where ub = upperBound t
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad mB
+  , pos ~ (ps:.p)
+  , posLeft ~ LeftPosTy pos (TwITblBt b s arr (cs:.c) (us:.u) x mF mB r) (is:.i)
+  , Element ls (is:.i)
+  , TableStaticVar (ps:.p) (cs:.c) (us:.u) (is:.i)
+  , AddIndexDense pos (Elm ls (is:.i)) (cs:.c) (us:.u) (is:.i)
+  , MkStream mB posLeft ls (is:.i)
+  , PrimArrayOps arr (us:.u) x
+  ) ⇒ MkStream mB (ps:.p) (ls :!: TwITblBt b s arr (cs:.c) (us:.u) x mF mB r) (is:.i) where
+  mkStream Proxy (ls :!: TW (BtITbl csc t) bt) grd usu isi
+    = mapM (\(s,tt,ii') -> bt ub tt >>= \ ~bb -> return $ ElmBtITbl (t!tt) bb ii' s)
+    . addIndexDense (Proxy ∷ Proxy pos) csc ub usu isi
+    $ mkStream (Proxy ∷ Proxy posLeft) ls grd usu (tableStreamIndex (Proxy :: Proxy pos) csc ub isi)
+    where ub = upperBound t
+  {-# Inline mkStream #-}
+
diff --git a/ADP/Fusion/Core/SynVar/Axiom.hs b/ADP/Fusion/Core/SynVar/Axiom.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/SynVar/Axiom.hs
@@ -0,0 +1,20 @@
+
+-- | The 'axiom' runs a backtracking algebra. The name comes from Robert
+-- Giegerichs @ADP@ where @axiom@ runs the fully formed algorithm.
+
+module ADP.Fusion.Core.SynVar.Axiom where
+
+-- | The Axiom type class
+
+class Axiom t where
+  -- | The corresponding stream being returned by 'axiom'
+  type AxiomStream t ∷ *
+  -- | Index type when running the axiom
+  type AxiomIx t ∷ *
+  -- | Given a table, run the axiom
+  axiom ∷ t → AxiomStream t
+  -- | Given a table and index, run the axiom from the index on. This is useful
+  -- for scanning type algorithms that need to return all locally optimal
+  -- structures, as a locally optimal may start at any given index.
+  axiomAt ∷ t → AxiomIx t → AxiomStream t
+
diff --git a/ADP/Fusion/Core/SynVar/Backtrack.hs b/ADP/Fusion/Core/SynVar/Backtrack.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/SynVar/Backtrack.hs
@@ -0,0 +1,28 @@
+
+-- | Wrap forward tables in such a way as to allow backtracking via
+-- algebras.
+
+module ADP.Fusion.Core.SynVar.Backtrack where
+
+import Data.Vector.Fusion.Stream.Monadic (Stream)
+
+import ADP.Fusion.Core.SynVar.TableWrap
+
+
+
+-- |
+--
+-- TODO this should go into @ADP.Fusion.Table.Backtrack@, more than just
+-- tabulated syntactic vars are going to use it.
+--
+-- NOTE You probably need to give the @monad morphism@ between @mF@ and
+-- @mB@ so as to be able to extract forward results in the backtracking
+-- phase.
+
+class GenBacktrackTable t (mF :: * -> *) (mB :: * -> *) where
+  data Backtrack t (mF :: * -> *) (mB :: * -> *) :: *
+  type BacktrackIndex t :: *
+  toBacktrack :: t -> (forall a . mF a -> mB a) {- -> (BacktrackIndex t -> BacktrackIndex t -> mB [r]) -} -> Backtrack t mF mB
+
+-- instance Build (TW (Backtrack t mF mB) f)
+
diff --git a/ADP/Fusion/Core/SynVar/Fill.hs b/ADP/Fusion/Core/SynVar/Fill.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/SynVar/Fill.hs
@@ -0,0 +1,442 @@
+
+module ADP.Fusion.Core.SynVar.Fill where
+
+import           Control.Monad
+import           Control.Monad.Morph (hoist, MFunctor (..))
+import           Control.Monad.Primitive
+import           Control.Monad.ST
+import           Control.Monad.Trans.Class (lift, MonadTrans (..))
+import           Control.Monad (when,forM_)
+import           Data.Dynamic
+import           Data.List (nub,sort,group)
+import           Data.Maybe (fromJust)
+import           Data.Proxy
+import           Data.Type.Equality
+import           Data.Vector.Fusion.Util (Id(..))
+import           Debug.Trace (traceShow)
+import           GHC.Exts (inline)
+import           GHC.TypeNats
+import qualified Data.Data as D
+import qualified Data.List as L
+import qualified Data.Typeable as T
+import qualified Data.Vector as V
+import qualified Data.Vector.Fusion.Stream.Monadic as SM
+import qualified Data.Vector.Mutable as VM
+import qualified Data.Vector.Unboxed as VU
+import qualified GHC.Generics as G
+import           System.IO.Unsafe
+import           System.CPUTime
+import           GHC.Conc (pseq)
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Core.SynVar.Array -- TODO we want to keep only classes in here, move instances to the corresponding modules
+import           ADP.Fusion.Core.SynVar.Recursive.Type
+import           ADP.Fusion.Core.SynVar.TableWrap
+
+import           Debug.Trace
+
+
+
+{-
+
+-- | A vanilla context-free grammar
+
+data CFG
+
+-- | This grammar is a multi-cfg in a monotone setting
+
+data MonotoneMCFG
+
+
+-- * Unsafely mutate 'ITbls' and similar tables in the forward phase.
+
+-- | Mutate a cell in a stack of syntactic variables.
+--
+-- TODO generalize to monad morphism via @mmorph@ package. This will allow
+-- more interesting @mrph@ functions that can, for example, track some
+-- state in the forward phase. (Note that this can be dangerous, we do
+-- /not/ want to have this state influence forward results, unless that can
+-- be made deterministic, or we'll break Bellman)
+
+class MutateCell (h ∷ *) (s ∷ *) (im ∷ * → *) i where
+  mutateCell
+    ∷ (Monad om, PrimMonad om)
+    ⇒ Proxy h
+    → Int
+    → Int
+    → (forall a . im a → om a)
+    → s
+    → LimitType i
+    → i
+    → om ()
+
+-- |
+
+class MutateTables (h :: *) (s :: *) (im :: * -> *) where
+  mutateTables :: (Monad om, PrimMonad om) => Proxy h -> (forall a . im a -> om a) -> s -> om s
+
+class TableOrder (s :: *) where
+  tableLittleOrder :: s -> [Int]
+  tableBigOrder :: s -> [Int]
+
+instance TableOrder Z where
+  tableLittleOrder Z = []
+  tableBigOrder Z = []
+  {-# Inline tableLittleOrder #-}
+  {-# Inline tableBigOrder #-}
+
+instance
+  ( TableOrder ts
+  , KnownNat bo
+--  , KnownNat lo
+  ) ⇒ TableOrder (ts:.TwITbl bo im arr c i x) where
+  tableLittleOrder (ts:.TW (ITbl tlo _ _) _) =
+    let -- tlo = fromIntegral $ natVal (Proxy ∷ Proxy lo)
+    in  tlo : tableLittleOrder ts
+  tableBigOrder    (ts:.TW (ITbl _ _ _) _) =
+    let tbo = fromIntegral $ natVal (Proxy ∷ Proxy bo)
+    in  tbo : tableBigOrder ts
+  {-# Inline tableLittleOrder #-}
+  {-# Inline tableBigOrder #-}
+
+-- | @IRec@s do not need an order, given that they do not memoize.
+
+instance (TableOrder ts) => TableOrder (ts:.TwIRec im c i x) where
+  tableLittleOrder (ts:._) = tableLittleOrder ts
+  tableBigOrder    (ts:._) = tableBigOrder ts
+  {-# Inline tableLittleOrder #-}
+  {-# Inline tableBigOrder #-}
+
+-- ** individual instances for filling a *single cell*
+
+instance
+  (
+  ) => MutateCell p Z im i where
+  mutateCell _ _ _ _ Z _ _ = return ()
+  {-# INLINE mutateCell #-}
+
+instance
+  ( MutateCell CFG ts im i
+  ) => MutateCell CFG (ts:.TwIRec im c i x) im i where
+  mutateCell h bo lo mrph (ts:._) lu i = do
+    mutateCell h bo lo mrph ts lu i
+  {-# Inline mutateCell #-}
+
+instance
+  ( PrimArrayOps  arr i x
+  , MPrimArrayOps arr i x
+  , MutateCell CFG ts im i
+  , KnownNat bo
+--  , KnownNat lo
+  ) => MutateCell CFG (ts:.TwITbl bo im arr c i x) im i where
+  mutateCell h bo lo mrph (ts:.TW (ITbl tlo c arr) f) lu i = do
+    let tbo = fromIntegral $ natVal (Proxy ∷ Proxy bo)
+--        tlo = fromIntegral $ natVal (Proxy ∷ Proxy lo)
+    mutateCell h bo lo mrph ts lu i
+    when (bo==tbo && lo==tlo) $ do
+      marr <- unsafeThaw arr
+      z <- (inline mrph) $ f lu i
+      writeM marr i z
+  {-# INLINE mutateCell #-}
+
+{-
+ - TODOThe following code goes into ADPfusionSubword!
+ -
+type ZS2 = Z:.Subword I:.Subword I
+
+instance
+  ( PrimArrayOps  arr ZS2 x
+  , MPrimArrayOps arr ZS2 x
+  , MutateCell MonotoneMCFG ts im ZS2
+  ) => MutateCell MonotoneMCFG (ts:.TwITbl im arr c ZS2 x) im ZS2 where
+  mutateCell h bo lo mrph (ts:.TW (ITbl tbo tlo c arr) f) lu iklj@(Z:.Subword (i:.k):.Subword(l:.j)) = do
+    mutateCell h bo lo mrph ts lu iklj
+    when (bo==tbo && lo==tlo && k<=l) $ do
+      marr <- unsafeThaw arr
+      z <- (inline mrph) $ f lu iklj
+      writeM marr iklj z
+  {-# INLINE mutateCell #-}
+
+instance
+  ( PrimArrayOps arr (Subword I) x
+  , MPrimArrayOps arr (Subword I) x
+  , MutateCell h ts im (Z:.Subword I:.Subword I)
+  ) => MutateCell h (ts:.TwITbl im arr c (Subword I) x) im (Z:.Subword I:.Subword I) where
+  mutateCell h bo lo mrph (ts:.TW (ITbl tbo tlo c arr) f) lu@(Z:.Subword (l:._):.Subword(_:.u)) ix@(Z:.Subword (i1:.j1):.Subword (i2:.j2)) = do
+    mutateCell h bo lo mrph ts lu ix
+    when (bo==tbo && lo==tlo && i1==i2 && j1==j2) $ do
+      let i = i1
+      let j = j1
+      marr <- unsafeThaw arr
+      z <- (inline mrph) $ f (subword l u) (subword i j)
+      writeM marr (subword i j) z
+  {-# Inline mutateCell #-}
+-}
+
+
+-- ** individual instances for filling a complete table and extracting the
+-- bounds
+
+instance
+  ( MutateCell h (ts:.TwITbl bo im arr c i x) im i
+  , PrimArrayOps arr i x
+  , Show i
+  , IndexStream i
+  , TableOrder (ts:.TwITbl bo im arr c i x)
+  ) => MutateTables h (ts:.TwITbl bo im arr c i x) im where
+  mutateTables h mrph tt@(_:.TW (ITbl lo _ arr) _) = do
+    let to = upperBound arr
+    -- TODO (1) find the set of orders for the synvars
+    let !tbos = VU.fromList . nub . sort $ tableBigOrder tt
+    let !tlos = VU.fromList . nub . sort $ tableLittleOrder tt
+    VU.forM_ tbos $ \bo ->
+      case (VU.length tlos) of
+        1 -> let lo = VU.head tlos
+             in  flip SM.mapM_ (streamUp zeroBound' to) $ \k ->
+                  mutateCell h bo lo (inline mrph) tt to k
+        -- TODO each big-order group should be allowed to have its own sets
+        -- of bounds. within a group, it doesn't make a lot of sense to
+        -- have different bounds? Is there a use case for that even?
+        _ -> flip SM.mapM_ (streamUp zeroBound' to) $ \k ->
+              VU.forM_ tlos $ \lo ->
+                mutateCell h bo lo (inline mrph) tt to k
+    return tt
+  {-# INLINE mutateTables #-}
+
+-- | Default table filling, assuming that the forward monad is just @IO@.
+--
+-- TODO generalize to @MonadIO@ or @MonadPrim@.
+
+mutateTablesDefault :: MutateTables CFG t Id => t -> t
+mutateTablesDefault t = unsafePerformIO $ mutateTables (Proxy :: Proxy CFG) (return . unId) t
+{-# INLINE mutateTablesDefault #-}
+
+-- | Mutate tables, but observe certain hints. We use this for monotone
+-- mcfgs for now.
+
+mutateTablesWithHints :: MutateTables h t Id => Proxy h -> t -> t
+mutateTablesWithHints h t = unsafePerformIO $ mutateTables h (return . unId) t
+
+
+
+
+
+
+mutateTablesST t = runST $ mutateTablesNew t
+{-# Inline mutateTablesST #-}
+
+class CountNumberOfCells t where
+  countNumberOfCells ∷ t → Integer
+
+instance CountNumberOfCells Z where
+  countNumberOfCells Z = 0
+
+instance
+  ( CountNumberOfCells ts
+  , Index i
+  , PrimArrayOps arr i x
+  ) ⇒ CountNumberOfCells (ts:.TwITbl bo Id arr c i x) where
+  countNumberOfCells (ts:.(TW (ITbl lo _ arr) fun)) =
+    countNumberOfCells ts + (product . totalSize $ upperBound arr)
+
+data PerfCounter = PerfCounter
+  { picoSeconds   :: !Integer
+  , seconds       :: !Double
+  , numberOfCells :: !Integer
+  }
+  deriving (Eq,Ord,Show)
+
+data Mutated ts = Mutated
+  { mutatedTables ∷ !ts
+  , perfCounter   ∷ !PerfCounter
+  , eachBigPerfCounter  ∷ [PerfCounter]
+  }
+
+-- | 
+--
+-- TODO new way how to do table filling. Because we now have heterogeneous
+-- tables (i) group tables by @big order@ into different bins; (ii) check
+-- that each bin has the same bounds (needed? -- could we have
+-- smaller-sized tables once in a while); (iii) run each bin one after the
+-- other
+--
+-- TODO measure performance penalty, if any. We might need liberal
+-- INLINEABLE, and specialization. On the other hand, we can do the
+-- freeze/unfreeze outside of table filling.
+
+mutateTablesNew
+  :: forall t m .
+     ( TableOrder t
+     , TSBO t
+     , Monad m
+     , PrimMonad m
+     , CountNumberOfCells t
+     )
+  => t
+  -> m (Mutated t)
+mutateTablesNew ts = do
+  -- sort the tables according to [bigorder,type,littleorder]. For each
+  -- @bigorder@, we should have only one @type@ and can therefor do the
+  -- following (i) get subset of the @ts@, (ii) use outermost of @ts@ to
+  -- get bounds, (iii) fill these tables
+  -- let !tbos = VU.fromList . nub . sort $ tableBigOrder ts
+  let justOrder = L.map (\d → (qBigOrder d, qLittleOrder d))
+  let ds = L.sort $ asDyn ts
+  let goM ∷ (Monad m, PrimMonad m) ⇒ [Q] → [PerfCounter] → m [PerfCounter]
+      goM [] ps = return $ reverse ps
+      goM xs ps = do
+        (ys,p) <- fillWithDyn xs ts
+        goM ys (p:ps)
+      {-# Inlinable goM #-}
+  startTime ← unsafeIOToPrim getCPUTime
+  ps ← goM ds []
+  stopTime  ← unsafeIOToPrim getCPUTime
+  let deltaTime = max 1 $ stopTime - startTime
+  return $! Mutated
+    { mutatedTables = ts
+    , perfCounter   = PerfCounter
+        { picoSeconds   = deltaTime
+        , seconds       = 1e-12 * fromIntegral deltaTime
+        , numberOfCells = countNumberOfCells ts
+        }
+    , eachBigPerfCounter = ps
+    }
+{-# Inline mutateTablesNew #-}
+
+data Q = Q
+  { qBigOrder     :: Int
+  , qLittleOrder  :: Int
+  , qTypeRep      :: T.TypeRep
+  , qObject       :: Dynamic
+  , qTable        :: Dynamic
+  , qFunction     :: Dynamic
+  }
+  deriving (Show)
+
+instance Eq Q where
+  Q bo1 lo1 tr1 _ _ _ == Q bo2 lo2 tr2 _ _ _ = (bo1,tr1,lo1) == (bo2,tr2,lo2)
+
+instance Ord Q where
+  Q bo1 lo1 tr1 _ _ _ `compare` Q bo2 lo2 tr2 _ _ _ = (bo1,lo1,tr1) `compare` (bo2,lo2,tr2)
+
+-- | Find the outermost table that has a certain big order and then fill
+-- from there.
+
+class TSBO t where
+  asDyn :: t -> [Q]
+  fillWithDyn :: (Monad m, PrimMonad m) => [Q] -> t -> m ([Q], PerfCounter)
+
+instance TSBO Z where
+  asDyn Z = []
+  fillWithDyn qs Z = return (qs, PerfCounter 0 0 0)
+  {-# Inlinable asDyn #-}
+  {-# Inline fillWithDyn #-}
+
+instance
+ ( TSBO ts
+ , Typeable arr
+ , Typeable c
+ , Typeable i
+ , Typeable x
+ , PrimArrayOps arr i x
+ , MPrimArrayOps arr i x
+ , IndexStream i
+ , KnownNat bo
+-- , KnownNat lo
+ ) => TSBO (ts:.TwITbl bo Id arr c i x) where
+  asDyn (ts:.t@(TW (ITbl lo _ arr) fun)) =
+    let bo = fromIntegral $ natVal (Proxy ∷ Proxy bo)
+--        lo = fromIntegral $ natVal (Proxy ∷ Proxy lo)
+    in  Q bo lo (T.typeOf t) (toDyn t) (toDyn arr) (seq fun $ toDyn fun) : asDyn ts
+  fillWithDyn qs (ts:.t@(TW (ITbl _ _ arrDirect) fDirect)) = do
+    let to = upperBound arrDirect
+        bo = fromIntegral $ natVal (Proxy ∷ Proxy bo)
+--        lo = fromIntegral $ natVal (Proxy ∷ Proxy lo)
+    -- @hs@ are all tables that can be filled here
+    -- @ns@ are all tables we can't fill and need to process further down
+    -- the line
+    -- TODO FIXME FIXME FIXME why are the typereps different???
+    let (hs,ns) = L.span (\Q{..} -> qBigOrder == bo) qs -- && qTypeRep == T.typeOf t) qs
+    if null hs
+      then fillWithDyn qs ts
+      else do
+        let ms = Prelude.map concreteTW hs
+            af = Prelude.map concreteAF hs
+            concreteTW  = (maybe (error "fromDynamic should not fail!")
+                           (\x -> x `asTypeOf` t)
+                          . fromDynamic . qObject)
+            concreteAF q  = ( (`asTypeOf` arrDirect) . fromJust . fromDynamic $ qTable    q
+                            , (`asTypeOf` fDirect)   . fromJust . fromDynamic $ qFunction q
+                            )
+        -- We have a single table and should short-circuit here
+        --
+        -- TODO we should specialize for tables of lengh @1..k@ for some
+        -- small k. For @1@ and Needleman-Wunsch, we have a very nice @1.8@
+        -- seconds down to @1.25@ seconds. :-)
+        --
+        -- TODO how about
+        -- case ms of
+        --   [a] -> bla
+        --   [a,b] -> bla
+        --   [a,b,c] -> bla
+        --   [a:b:c:d:ms'] -> bla >> go ms'
+        --   measure if this yields meaningful performance improvements
+        --
+        -- TODO also consider if we maybe just put marrfs into a vector
+        --
+        -- TODO we should use TH here.
+        --
+        -- (1) Have @Proxy @0@, say to set up big and small orders -- this
+        -- gives us the order on the type level. @data One = One, data Two
+        -- = Two, ...@ might be easier... maybe this is not too annoying to
+        -- write using type equality
+        -- 
+        -- (2) Then deconstruct the @ts:.t@ things with TH into the correct
+        -- pieces.
+        --
+        -- (3) Finally generate fill code. This should yield to performance
+        -- similar to what we have here with the @case of 1@ construction,
+        -- because @fDirect@ is partially floated out.
+        --
+        marrfs <- V.fromList <$> Prelude.mapM (\(TW (ITbl _ _ arr) f) -> unsafeThaw arr >>= \marr -> return (marr,f)) ms
+        startTime ← unsafeIOToPrim getCPUTime
+        case (V.length marrfs) of
+          1 -> do -- let (!marr,!f) = marrfs V.! 0   -- this takes 1.3 seconds for NeedlemanWunsch
+                  -- marr <- unsafeThaw arrDirect  -- this takes 0.8 seconds for NeedlemanWunsch
+                  marr <- unsafeThaw arrDirect -- (fst $ af!!0)  -- this takes 1.3 seconds for NeedlemanWunsch
+                  let !ffff = fDirect --snd $ af!!0
+                  flip SM.mapM_ (streamUp zeroBound' to) $ \k -> do
+                    -- TODO @inline mrph@ ...
+                    z <- (return . unId) $ fDirect to k
+                    writeM marr k z
+        -- We have more than one table in will work over the list of tables
+          _ -> do flip SM.mapM_ (streamUp zeroBound' to) $ \k ->
+                    V.forM_ marrfs $ \(marr,f) -> do
+                      z <- (return . unId) $ f to k
+                      writeM marr k z
+        -- traceShow (hs,length ms) $
+        stopTime ← unsafeIOToPrim getCPUTime
+        let deltaTime = stopTime - startTime
+        let perf = PerfCounter
+              { picoSeconds   = deltaTime
+              , seconds       = 1e-12 * fromIntegral deltaTime
+              , numberOfCells = sum $ Prelude.map (\(TW t _) → product . totalSize . upperBound $ iTblArray t) ms
+              }
+        return (ns, perf)
+  {-# Inline fillWithDyn #-}
+
+-- We don't need to capture @IRec@ tables as no table-filling takes place
+-- for those tables. @asDyn@ therefore just collects on the remaining @ts@,
+-- while @fillWithDyn@ hands of to the next possible table.
+
+instance
+  ( TSBO ts
+  ) => TSBO (ts:.TwIRec Id c i x) where
+  asDyn (ts:.t@(TW (IRec _ _) _)) = asDyn ts
+  fillWithDyn qs (ts:._) = fillWithDyn qs ts
+  {-# Inlinable asDyn #-}
+  {-# Inline fillWithDyn #-}
+
+-}
+
diff --git a/ADP/Fusion/Core/SynVar/FillTyLvl.hs b/ADP/Fusion/Core/SynVar/FillTyLvl.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/SynVar/FillTyLvl.hs
@@ -0,0 +1,324 @@
+
+-- |
+--
+-- TODO Need to add additional type family instances as required.
+--
+-- TODO Need to have little order nats as well.
+
+module ADP.Fusion.Core.SynVar.FillTyLvl where
+
+import           Control.DeepSeq
+import           Control.Monad.Primitive
+import           Control.Monad.ST
+import           Data.Proxy
+import           Data.Singletons.Prelude.Bool
+import           Data.Singletons.Prelude.Bool
+import           Data.Singletons.Prelude.List
+import           Data.Type.Equality
+import           Data.Vector.Fusion.Util (Id(..))
+import           GHC.Exts
+import           GHC.Generics
+import           GHC.TypeNats
+import qualified Data.Vector.Fusion.Stream.Monadic as SM
+import qualified Data.Vector.Unboxed as VU
+import           System.CPUTime
+import           Text.Printf
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Core.SynVar.TableWrap
+import           ADP.Fusion.Core.SynVar.Array
+
+
+
+--  -- | Fill/mutate tables using @ST@.
+--  
+--  fillTablesST
+--    ∷ forall bigOrder ts
+--    . ( bigOrder ~ BigOrderNats ts
+--      , EachBigOrder bigOrder ts
+--      )
+--    ⇒ ts
+--    → ts
+--  {-# Inline fillTablesST #-}
+--  fillTablesST ts = runST $ fillTables ts
+
+-- |
+
+fillTables
+--  ∷ Proxy (BigOrderNats ts)
+--  -- ^ Proxy that provides the set of @BigOrder@ naturals
+  ∷ forall bigOrder s ts
+  . ( bigOrder ~ BigOrderNats ts
+    , EachBigOrder bigOrder ts
+    , CountNumberOfCells 0 ts
+    )
+  ⇒ ts
+  -- ^ The tables
+  → ST s (Mutated ts)
+{-# Inline fillTables #-}
+fillTables ts = do
+  startTime ← unsafeIOToPrim getCPUTime
+  ps ← eachBigOrder (Proxy ∷ Proxy bigOrder) ts
+  stopTime  ← unsafeIOToPrim getCPUTime
+  let deltaTime = max 1 $ stopTime - startTime
+  return $! Mutated
+    { mutatedTables = ts
+    , perfCounter   = PerfCounter
+        { picoSeconds   = deltaTime
+        , seconds       = 1e-12 * fromIntegral deltaTime
+        , numberOfCells = countNumberOfCells (Nothing ∷ Maybe (Proxy 0)) ts
+        }
+    , eachBigPerfCounter = ps
+    }
+
+-- | This type class instanciates to the specialized machinery for each
+-- @BigOrder Natural@ number.
+
+class EachBigOrder (boNats ∷ [Nat]) ts where
+  eachBigOrder ∷ Proxy boNats → ts → ST s [PerfCounter]
+
+-- | No more big orders to handle.
+
+instance EachBigOrder '[] ts where
+  {-# Inline eachBigOrder #-}
+  eachBigOrder Proxy _ = return []
+
+-- | handle this big order.
+
+instance
+  ( EachBigOrder ns ts
+  , ThisBigOrder n (IsThisBigOrder n ts) ts
+  , CountNumberOfCells n ts
+  ) ⇒ EachBigOrder (n ': ns) ts where
+  {-# Inline eachBigOrder #-}
+  eachBigOrder Proxy ts = do
+    startTime ← unsafeIOToPrim getCPUTime
+    thisBigOrder (Proxy ∷ Proxy n) (Proxy ∷ Proxy (IsThisBigOrder n ts)) ts
+    stopTime  ← unsafeIOToPrim getCPUTime
+    let deltaTime = max 1 $ stopTime - startTime
+    ps ← eachBigOrder (Proxy ∷ Proxy ns) ts
+    let p = PerfCounter
+              { picoSeconds   = deltaTime
+              , seconds       = 1e-12 * fromIntegral deltaTime
+              , numberOfCells = countNumberOfCells (Just (Proxy ∷ Proxy n)) ts
+              }
+    return $ p:ps
+
+-- |
+
+class ThisBigOrder (boNat ∷ Nat) (thisOrder ∷ Bool) ts where
+  thisBigOrder ∷ Proxy boNat → Proxy thisOrder → ts → ST s ()
+  getAllBounds ∷ Proxy boNat → Proxy thisOrder → ts → [()]
+
+instance ThisBigOrder boNat anyOrder Z where
+  {-# Inline thisBigOrder #-}
+  thisBigOrder Proxy Proxy Z = return ()
+  {-# Inline getAllBounds #-}
+  getAllBounds Proxy Proxy Z = []
+
+-- | We have found the first table for our big order. Extract the bounds and
+-- hand over to small order. We do not need to check for another big order with
+-- this nat, since all tables are now being filled by the small order.
+
+instance
+  ( smallOrder ~ SmallOrderNats (ts:.TwITbl bo so m arr c i x)
+  , EachSmallOrder boNat smallOrder (ts:.TwITbl bo so m arr c i x) i
+  , PrimArrayOps arr i x
+  , IndexStream i
+  ) ⇒ ThisBigOrder boNat True (ts:.TwITbl bo so m arr c i x) where
+  {-# Inline thisBigOrder #-}
+  thisBigOrder Proxy Proxy tst@(_:.TW (ITbl _ arr) _) = do
+    let to = upperBound arr
+    let allBounds = getAllBounds (Proxy ∷ Proxy boNat) (Proxy ∷ Proxy True) tst
+    -- TODO check bounds
+    flip SM.mapM_ (streamUp zeroBound' to) $ \k ->
+      eachSmallOrder (Proxy ∷ Proxy boNat) (Proxy ∷ Proxy smallOrder) tst k
+  {-# Inline getAllBounds #-}
+  getAllBounds Proxy Proxy (ts:.t) = undefined
+
+-- | Go down the tables until we find the first table for our big order.
+
+instance
+  ( ThisBigOrder n (IsThisBigOrder n ts) ts
+  ) ⇒ ThisBigOrder n False (ts:.t) where
+  {-# Inline thisBigOrder #-}
+  thisBigOrder Proxy Proxy (ts:.t) =
+    thisBigOrder (Proxy ∷ Proxy n) (Proxy ∷ Proxy (IsThisBigOrder n ts)) ts
+
+-- |
+
+class EachSmallOrder (bigOrder ∷ Nat) (smallOrders ∷ [Nat]) ts i where
+  eachSmallOrder
+    ∷ Proxy bigOrder
+    -- ^ Only fill exactly this big order
+    → Proxy smallOrders
+    -- ^ These are all the small order to go through.
+    → ts
+    -- ^ set of tables.
+    → i
+    -- ^ index to update.
+    → ST s ()
+
+-- | Went through all tables, nothing more to do.
+
+instance EachSmallOrder bigOrder '[] ts i where
+  {-# Inline eachSmallOrder #-}
+  eachSmallOrder Proxy Proxy ts i = return ()
+
+-- | 
+
+instance
+  ( EachSmallOrder bigOrder so ts i
+  , isThisBigOrder ~ IsThisBigOrder bigOrder ts
+  , isThisSmallOrder ~ IsThisSmallOrder s ts
+  , isThisOrder ~ (isThisBigOrder && isThisSmallOrder)
+  , ThisSmallOrder bigOrder s isThisOrder ts i
+  ) ⇒ EachSmallOrder bigOrder (s ': so) ts i where
+  {-# Inline eachSmallOrder #-}
+  eachSmallOrder Proxy Proxy ts i = do
+    -- fill all tables that have the same big & small order
+    thisSmallOrder (Proxy ∷ Proxy bigOrder) (Proxy ∷ Proxy s) (Proxy ∷ Proxy isThisOrder) ts i
+    -- fill tables with the next small order
+    eachSmallOrder (Proxy ∷ Proxy bigOrder) (Proxy ∷ Proxy so) ts i
+
+-- |
+
+class ThisSmallOrder (bigNat ∷ Nat) (smallNat ∷ Nat) (thisOrder ∷ Bool) ts i where
+  thisSmallOrder ∷ Proxy bigNat → Proxy smallNat → Proxy thisOrder → ts → i → ST s ()
+
+instance ThisSmallOrder b s any Z i where
+  {-# Inline thisSmallOrder #-}
+  thisSmallOrder _ _ _ _ _ = return ()
+
+instance
+  ( isThisBigOrder ~ IsThisBigOrder bigOrder ts
+  , isThisSmallOrder ~ IsThisSmallOrder smallOrder ts
+  , isThisOrder ~ (isThisBigOrder && isThisSmallOrder)
+  , ThisSmallOrder bigOrder smallOrder isThisOrder ts i
+  ) ⇒ ThisSmallOrder bigOrder smallOrder 'False (ts:.t) i where
+  {-# Inline thisSmallOrder #-}
+  thisSmallOrder Proxy Proxy Proxy (ts:.t) i =
+    thisSmallOrder (Proxy ∷ Proxy bigOrder) (Proxy ∷ Proxy smallOrder) (Proxy ∷ Proxy isThisOrder) ts i
+
+-- |
+--
+-- TODO generalize from @Id@ to any monad in a stack with a primitive base
+
+instance
+  ( PrimArrayOps arr i x
+  , MPrimArrayOps arr i x
+  , isThisBigOrder ~ IsThisBigOrder bigOrder ts
+  , isThisSmallOrder ~ IsThisSmallOrder smallOrder ts
+  , isThisOrder ~ (isThisBigOrder && isThisSmallOrder)
+  , ThisSmallOrder bigOrder smallOrder isThisOrder ts i
+  ) ⇒ ThisSmallOrder bigOrder smallOrder 'True (ts:.TwITbl bo so Id arr c i x) i where
+  {-# Inline thisSmallOrder #-}
+  thisSmallOrder Proxy Proxy Proxy (ts:.TW (ITbl _ arr) f) i = do
+    let uB = upperBound arr
+    marr <- unsafeThaw arr
+    z ← return . unId $ (inline f) uB i
+    writeM marr i z
+    -- TODO need to write test case that checks that all tables are always filled
+    thisSmallOrder (Proxy ∷ Proxy bigOrder) (Proxy ∷ Proxy smallOrder) (Proxy ∷ Proxy isThisOrder) ts i
+
+-- | The set of arrays to fill is a tuple of the form @(Z:.a:.b:.c)@. Here, we
+-- extract the big order @Nat@s. The set of @Nat@s being returned is already
+-- ordered with the smallest @Nat@ up front.
+
+type BigOrderNats arr = Nub (Sort (BigOrderNats' arr))
+
+type family BigOrderNats' arr ∷ [Nat]
+
+type instance BigOrderNats' Z = '[]
+
+type instance BigOrderNats' (ts:.TwITbl bo so m arr c i x) = bo ': BigOrderNats' ts
+
+
+
+type family IsThisBigOrder (n ∷ Nat) arr ∷ Bool
+
+type instance IsThisBigOrder n Z = 'False
+
+type instance IsThisBigOrder n (ts:.TwITbl bo so m arr c i x) = n == bo
+
+
+
+type SmallOrderNats arr = Nub (Sort (SmallOrderNats' arr))
+
+type family SmallOrderNats' arr ∷ [Nat]
+
+type instance SmallOrderNats' Z = '[]
+
+-- TODO fix small order
+
+type instance SmallOrderNats' (ts:.TwITbl bo so m arr c i x) = so ': SmallOrderNats' ts
+
+
+
+type family IsThisSmallOrder (n ∷ Nat) arr ∷ Bool
+
+type instance IsThisSmallOrder n Z = 'False
+
+-- TODO fix small order comparision
+
+type instance IsThisSmallOrder n (ts:.TwITbl bo so m arr c i x) = n == so
+
+data Mutated ts = Mutated
+  { mutatedTables ∷ !ts
+  , perfCounter   ∷ !PerfCounter
+  , eachBigPerfCounter  ∷ [PerfCounter]
+  }
+  deriving (Eq,Ord,Show,Generic)
+
+instance NFData ts ⇒ NFData (Mutated ts)
+
+data PerfCounter = PerfCounter
+  { picoSeconds   :: !Integer
+  , seconds       :: !Double
+  , numberOfCells :: !Integer
+  }
+  deriving (Eq,Ord,Show,Generic)
+
+instance NFData PerfCounter
+
+showPerfCounter ∷ PerfCounter → String
+{-# NoInline showPerfCounter #-}
+showPerfCounter PerfCounter{..} =
+  let cellsSecond = round $ fromIntegral numberOfCells / seconds
+      m ∷ Integer = 1000000
+  in  printf "%.4f seconds, %d,%06d cells @ %d,%06d cells/second"
+             seconds
+             (numberOfCells `div` m) (numberOfCells `mod` m)
+             (cellsSecond `div` m) (cellsSecond `mod` m)
+
+-- | Adding two 'PerfCounter's yields the time they take together.
+
+instance Num PerfCounter where
+  PerfCounter p1 s1 n1 + PerfCounter p2 s2 n2 = PerfCounter (p1+p2) (s1+s2) (n1+n2)
+
+
+class CountNumberOfCells (n ∷ Nat) t where
+  countNumberOfCells ∷ Maybe (Proxy n) → t → Integer
+
+instance CountNumberOfCells n Z where
+  {-# NoInline countNumberOfCells #-}
+  countNumberOfCells p Z = 0
+
+instance
+  ( CountNumberOfCells n ts
+  , Index i
+  , PrimArrayOps arr i x
+  , KnownNat n
+  , KnownNat bo
+  ) ⇒ CountNumberOfCells n (ts:.TwITbl bo so Id arr c i x) where
+  {-# NoInline countNumberOfCells #-}
+  countNumberOfCells mayP (ts:.(TW (ITbl _ arr) fun)) =
+    let n  = natVal (Proxy ∷ Proxy n)
+        bo = natVal (Proxy ∷ Proxy bo)
+        cs = countNumberOfCells mayP ts
+        c  = product . totalSize $ upperBound arr
+    in  case mayP of
+      Nothing → cs + c
+      Just _  → cs + if n==bo then c else 0
+
diff --git a/ADP/Fusion/Core/SynVar/Indices.hs b/ADP/Fusion/Core/SynVar/Indices.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/SynVar/Indices.hs
@@ -0,0 +1,140 @@
+
+-- | Classes that enumerate the index structure necessary for actually
+-- performing the indexing.
+--
+-- TODO Currently, we only provide dense index generation.
+
+module ADP.Fusion.Core.SynVar.Indices where
+
+import Data.Proxy (Proxy(..))
+import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,flatten,Step(..))
+import Prelude hiding (map,head,mapM)
+
+import Data.PrimitiveArray hiding (map)
+
+import ADP.Fusion.Core.Classes
+import ADP.Fusion.Core.Multi
+import ADP.Fusion.Core.TyLvlIx
+
+
+
+-- | This type classes enable enumeration both in single- and multi-dim
+-- cases. The type @a@ is the type of the /full stack/ of indices, i.e. the
+-- full multi-tape problem.
+--
+-- @pos@ is the positional information,
+-- @s@ is the element type over the index @ix@,
+-- @ minSize@ the minimal size or width to request from the syntactic variable,
+-- @tableIx@ the index type of the table to walk over,
+-- and @ix@ the actual index.
+
+class AddIndexDense pos elm minSize tableIx ix where
+  addIndexDenseGo
+    ∷ (Monad m)
+    ⇒ Proxy pos
+    -- ^ Positional information in the rule (static/variable/etc)
+    → minSize
+    -- ^ Minimal size of the structure under consideration. We might want to
+    -- constrain enumeration over syntactic variables to only consider at least
+    -- "size>=1" cases. Normally, a syntactic variable may be of size 0 as
+    -- well, but with rules like @X -> X X@, we don't want to have one of the
+    -- @X@'s on the r.h.s. be of size 0.
+    → LimitType tableIx
+    -- ^ The upper limit imposed by the structure to traverse over.
+    → LimitType ix
+    -- ^ The upper limit imposed by the rule that traverses.
+    → ix
+    -- ^ The current index for the full rule.
+    → Stream m (SvState elm Z Z)
+    -- ^ Initial stream state with @Z@ero indices.
+    → Stream m (SvState elm tableIx ix)
+    -- ^ The type of the full stream.
+
+instance AddIndexDense pos elm Z Z Z where
+  addIndexDenseGo _ _ _ _ _ = id
+  {-# Inline addIndexDenseGo #-}
+
+-- | @SvState@ holds the state that is currently being built up by
+-- @AddIndexDense@. We have both @tIx@ (and @tOx@) and @iIx@ (and @iOx@).
+-- For most index structures, the indices will co-incide; however for some,
+-- this will not be true -- herein for @Set@ index structures.
+
+data SvState elm tableIx ix = SvS
+  { sS  ∷ !elm
+  -- ^ state coming in from the left
+  , tx  ∷ !tableIx
+  -- ^ @I/C@ building up state to index the @table@.
+  , iIx ∷ !(RunningIndex ix)
+  -- ^ @I/C@ building up state to hand over to next symbol
+  }
+
+
+-- | Given an incoming stream with indices, this adds indices for the
+-- current syntactic variable / symbol.
+
+addIndexDense
+  ∷ ( Monad m
+    , AddIndexDense pos elm minSize tableIx ix
+    , elm ~ Elm x0 i0
+    , Element x0 i0
+    )
+  ⇒ Proxy pos
+  → minSize
+  → LimitType tableIx
+  → LimitType ix
+  → ix
+  → Stream m elm
+  → Stream m (elm,tableIx,RunningIndex ix)
+addIndexDense pos minSize tableBound upperBound ix
+  = map (\(SvS s z i') -> (s,z,i'))
+  . addIndexDenseGo pos minSize tableBound upperBound ix
+  . map (\s -> (SvS s Z RiZ))
+{-# Inline addIndexDense #-}
+
+-- | In case of 1-dim tables, we wrap the index creation in a multi-dim
+-- system and remove the @Z@ later on. This allows us to have to write only
+-- a single instance.
+
+addIndexDense1
+  ∷ forall m pos x0 a ix minSize tableIx elm
+  . ( Monad m
+    , AddIndexDense (Z:.pos) (Elm (SynVar1 (Elm x0 a)) (Z:.ix)) (Z:.minSize) (Z:.tableIx) (Z:.ix)
+    , GetIndex (Z:.a) (Z:.ix)
+    , elm ~ Elm x0 a
+    , Element x0 a
+    )
+  ⇒ Proxy pos
+  → minSize
+  → LimitType tableIx
+  → LimitType ix
+  → ix
+  → Stream m elm
+  → Stream m (elm,tableIx,RunningIndex ix)
+addIndexDense1 Proxy minSize tableBound upperBound ix
+  = map (\(SvS (ElmSynVar1 s) (Z:.z) (RiZ:.:i')) -> (s,z,i'))
+  . addIndexDenseGo (Proxy ∷ Proxy (Z:.pos)) (Z:.minSize) (ZZ:..tableBound) (ZZ:..upperBound) (Z:.ix)
+  . map (\s -> (SvS (elmSynVar1 s ix) Z RiZ))
+{-# Inline addIndexDense1 #-}
+
+newtype SynVar1 s = SynVar1 s
+
+elmSynVar1 :: s -> i -> Elm (SynVar1 s) (Z:.i)
+elmSynVar1 s _ = ElmSynVar1 s
+{-# Inline elmSynVar1 #-}
+
+instance (s ~ Elm x0 i, Element x0 i) => Element (SynVar1 s) (Z:.i) where
+  newtype Elm (SynVar1 s) (Z:.i) = ElmSynVar1 s
+  getIdx (ElmSynVar1 s) = RiZ :.: getIdx s
+  {-# Inline getIdx #-}
+
+
+-- | Instance headers, we typically need.
+
+type AddIndexDenseContext pos elm x0 i0 minSizes minSize tableIxs tableIx ixs ix =
+  ( AddIndexDense pos elm minSizes tableIxs ixs
+  , GetIndex (RunningIndex i0) (RunningIndex (ixs:.ix))
+  , GetIx (RunningIndex i0) (RunningIndex (ixs:.ix)) ~ (RunningIndex ix)
+  , Element x0 i0
+  , elm ~ Elm x0 i0
+  )
+
diff --git a/ADP/Fusion/Core/SynVar/Recursive/Type.hs b/ADP/Fusion/Core/SynVar/Recursive/Type.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/SynVar/Recursive/Type.hs
@@ -0,0 +1,131 @@
+
+module ADP.Fusion.Core.SynVar.Recursive.Type where
+
+import Control.Applicative (Applicative,(<$>),(<*>))
+import Control.Monad.Morph
+import Data.Proxy
+import Data.Strict.Tuple
+import Data.Vector.Fusion.Stream.Monadic (Stream,head,map,mapM)
+import Prelude hiding (head,map,mapM)
+
+import Data.PrimitiveArray hiding (map)
+
+import ADP.Fusion.Core.Classes
+import ADP.Fusion.Core.Multi
+import ADP.Fusion.Core.SynVar.Axiom
+import ADP.Fusion.Core.SynVar.Backtrack
+import ADP.Fusion.Core.SynVar.Indices
+import ADP.Fusion.Core.SynVar.TableWrap
+
+
+
+-- | A syntactic variable that does not memoize but simplify recurses. One
+-- needs to be somewhat careful when using this one. @ITbl@ performs
+-- memoization to perform DP in polynomial time (roughly speaking). If the
+-- rules for an @IRec@ are of a particular type, they will exponential
+-- running time. Things like @X -> X X@ are, for example, rather bad. Rules
+-- of the type @X -> Y, Y -> Z@ are ok, if @Y@ is an @IRec@ since we just
+-- continue on. The same holds for @Y -> a Y@. Basically, things are safe
+-- if there is only a (small) constant number of parses of an @IRec@
+-- synvar.
+
+data IRec c i x where
+  IRec ∷ { iRecConstraint ∷ !c
+         , iRecTo         ∷ !(LimitType i)
+         } → IRec c i x
+
+type TwIRec (m ∷ * → *) c i x = TW (IRec c i x) (LimitType i → i → m x)
+
+type TwIRecBt c i x mF mB r = TW (Backtrack (TwIRec mF c i x) mF mB) (LimitType i → i → mB [r])
+
+instance Build (TwIRec   m c i x)
+
+instance Build (TwIRecBt c i x mF mB r)
+
+type instance TermArg (TwIRec m c i x) = x
+
+instance GenBacktrackTable (TwIRec mF c i x) mF mB where
+  data Backtrack (TwIRec mF c i x) mF mB = BtIRec !c !(LimitType i) !(LimitType i → i → mB x)
+  type BacktrackIndex (TwIRec mF c i x) = i
+  toBacktrack (TW (IRec c iT) f) mrph = BtIRec c iT (\lu i -> mrph $ f lu i)
+  {-# Inline toBacktrack #-}
+
+
+
+instance
+  ( Monad m
+  , IndexStream i
+  ) ⇒ Axiom (TwIRec m c i x) where
+  type AxiomStream (TwIRec m c i x) = m x
+  axiom (TW (IRec _ h) fun) = do
+    k ← head $ streamDown zeroBound' h
+    fun h k
+  {-# Inline axiom #-}
+
+instance
+  ( Monad mB
+  , IndexStream i
+  , i ~ j
+  , m ~ mB
+  ) ⇒ Axiom (TW (Backtrack (TwIRec mF c i x) mF mB) (LimitType j → j → m [r])) where
+  type AxiomStream (TW (Backtrack (TwIRec mF c i x) mF mB) (LimitType j → j → m [r])) = mB [r]
+  axiom (TW (BtIRec c h fun) btfun) = do
+    k <- head $ streamDown zeroBound' h
+    btfun h k
+  {-# Inline axiom #-}
+
+
+
+instance Element ls i ⇒ Element (ls :!: TwIRec m c u x) i where
+  data Elm (ls :!: TwIRec m c u x) i = ElmIRec !x !(RunningIndex i) !(Elm ls i)
+  type Arg (ls :!: TwIRec m c u x)   = Arg ls :. x
+  getArg (ElmIRec x _ ls) = getArg ls :. x
+  getIdx (ElmIRec _ i _ ) = i
+  {-# Inline getArg #-}
+  {-# Inline getIdx #-}
+
+instance Element ls i ⇒ Element (ls :!: TwIRecBt c u x mF mB r) i where
+  data Elm (ls :!: (TwIRecBt c u x mF mB r)) i = ElmBtIRec !x [r] !(RunningIndex i) !(Elm ls i)
+  type Arg (ls :!: (TwIRecBt c u x mF mB r))   = Arg ls :. (x, [r])
+  getArg (ElmBtIRec x s _ ls) = getArg ls :. (x,s)
+  getIdx (ElmBtIRec _ _ i _ ) = i
+  {-# Inline getArg #-}
+  {-# Inline getIdx #-}
+
+instance
+  ( Functor m
+  , Monad m
+  , pos ~ (ps:.p)
+  , posLeft ~ LeftPosTy pos (TwIRec m (cs:.c) (us:.u) x) (is:.i)
+  , Element ls (is:.i)
+--  , TableStaticVar ps cs us is
+--  , TableStaticVar p  c  u  i
+  , TableStaticVar (ps:.p) (cs:.c) (us:.u) (is:.i)
+  , AddIndexDense pos (Elm ls (is:.i)) (cs:.c) (us:.u) (is:.i)
+  , MkStream m posLeft ls (is:.i)
+  ) ⇒ MkStream m ('(:.) ps p) (ls :!: TwIRec m (cs:.c) (us:.u) x) (is:.i) where
+  mkStream Proxy (ls :!: TW (IRec csc h) fun) grd usu isi
+    = mapM (\(s,tt,ii) -> (\res -> ElmIRec res ii s) <$> fun h tt)
+    . addIndexDense (Proxy ∷ Proxy pos) csc h usu isi
+    $ mkStream (Proxy ∷ Proxy posLeft) ls grd usu (tableStreamIndex (Proxy ∷ Proxy pos) csc h isi)
+  {-# Inline mkStream #-}
+
+instance
+  ( Applicative mB
+  , Monad mB
+  , pos ~ (ps :. p)
+  , posLeft ~ LeftPosTy pos (TwIRecBt (cs:.c) (us:.u) x mF mB r) (is:.i)
+  , Element ls (is:.i)
+--  , TableStaticVar (us:.u) (cs:.c) (is:.i)
+--  , TableStaticVar ps cs us is
+--  , TableStaticVar p  c  u  i
+  , TableStaticVar (ps:.p) (cs:.c) (us:.u) (is:.i)
+  , AddIndexDense pos (Elm ls (is:.i)) (cs:.c) (us:.u) (is:.i)
+  , MkStream mB posLeft ls (is:.i)
+  ) => MkStream mB  ('(:.) ps p) (ls :!: TwIRecBt (cs:.c) (us:.u) x mF mB r) (is:.i) where
+  mkStream Proxy (ls :!: TW (BtIRec csc h fun) bt) grd usu isi
+    = mapM (\(s,tt,ii) -> (\res bb -> ElmBtIRec res bb ii s) <$> fun h tt <*> bt h tt)
+    . addIndexDense (Proxy ∷ Proxy pos) csc h usu isi
+    $ mkStream (Proxy ∷ Proxy posLeft) ls grd usu (tableStreamIndex (Proxy :: Proxy pos) csc h isi)
+  {-# Inline mkStream #-}
+
diff --git a/ADP/Fusion/Core/SynVar/Split/Type.hs b/ADP/Fusion/Core/SynVar/Split/Type.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/SynVar/Split/Type.hs
@@ -0,0 +1,200 @@
+
+-- |
+--
+-- NOTE /highly experimental/
+
+module ADP.Fusion.Core.SynVar.Split.Type
+  ( module ADP.Fusion.Core.SynVar.Split.Type
+  , Proxy (..)
+  ) where
+
+import Data.Proxy
+import Data.Strict.Tuple
+import Data.Vector.Fusion.Stream.Monadic
+import Data.Vector.Fusion.Util (delay_inline)
+import Debug.Trace
+import GHC.TypeLits
+import Prelude hiding (map,mapM)
+import Data.Type.Equality
+
+import Data.PrimitiveArray hiding (map)
+
+import ADP.Fusion.Core.Classes
+import ADP.Fusion.Core.Multi
+import ADP.Fusion.Core.SynVar.Array.Type
+import ADP.Fusion.Core.SynVar.Backtrack
+import ADP.Fusion.Core.SynVar.TableWrap
+
+
+
+data SplitType = Fragment | Final
+
+-- | The @Arg synVar@ means that we probably need to rewrite the internal
+-- type resolution now!
+
+type family CalcSplitType splitType varTy where
+  CalcSplitType Fragment varTy = ()
+  CalcSplitType Final    varTy = varTy
+
+-- | Should never fail?
+
+type family ArgTy argTy where
+--  ArgTy Z = Z
+  ArgTy (z:.x) = x
+
+-- | Wraps a normal non-terminal and attaches a type-level unique identier
+-- and z-ordering (with the unused @Z@ at @0@).
+--
+-- TODO attach empty/non-empty stuff (or get from non-splitted synvar?)
+--
+-- TODO re-introduce z-ordering later (once we have a sort fun)
+
+newtype Split (uId :: Symbol) {- (zOrder :: Nat) -} (splitType :: SplitType) synVar = Split { getSplit :: synVar }
+
+-- |
+--
+-- TODO Here, we probably want to default to a @NonEmpty@ condition. Or at
+-- least have different versions of @split@.
+
+split :: Proxy (uId::Symbol) -> {- Proxy (zOrder::Nat) -> -} Proxy (splitType::SplitType) -> synVar -> Split uId splitType synVar
+split _ _ = Split
+{-# Inline split #-}
+
+--splitNE :: (ModifyConstraint synVar) => Proxy (uId::Symbol) -> {- Proxy (zOrder::Nat) -> -} Proxy (splitType::SplitType) -> synVar -> Split uId splitType synVar
+--splitNE _ _ = Split . toNonEmpty
+--{-# Inline splitNE #-}
+
+--type Spl uId zOrder splitType = forall synVar . Split uId zOrder splitType synVar
+
+instance Build (Split uId splitType synVar)
+
+instance
+  ( Element ls i
+  ) => Element (ls :!: Split uId splitType (TwITbl b s m arr c j x)) i where
+  -- | @ElmSplitITbl@ carry one additional element of type @i@. We need
+  -- those to be able to extract the full index via @collectIx@.
+  data Elm     (ls :!: Split uId splitType (TwITbl b s m arr c j x)) i = ElmSplitITbl !(Proxy uId) !(CalcSplitType splitType x) !(RunningIndex i) !(Elm ls i) !i
+  type Arg     (ls :!: Split uId splitType (TwITbl b s m arr c j x))   = Arg ls :. (CalcSplitType splitType x)
+  type RecElm  (ls :!: Split uId splitType (TwITbl b s m arr c j x)) i = Elm ls i
+  getArg (ElmSplitITbl _ x _ ls _) = getArg ls :. x
+  getIdx (ElmSplitITbl _ _ i _  _) = i
+  getElm (ElmSplitITbl _ _ _ ls _) = ls
+  {-# Inline getArg #-}
+  {-# Inline getIdx #-}
+  {-# Inline getElm #-}
+
+instance
+  ( Element ls i
+  ) => Element (ls :!: Split uId splitType (TwITblBt b s arr c j x mF mB r)) i where
+  data Elm     (ls :!: Split uId splitType (TwITblBt b s arr c j x mF mB r)) i = ElmSplitBtITbl !(Proxy uId) !(CalcSplitType splitType (x, [r])) !(RunningIndex i) !(Elm ls i) !i
+  type Arg     (ls :!: Split uId splitType (TwITblBt b s arr c j x mF mB r))   = Arg ls :. (CalcSplitType splitType (x,[r]))
+  type RecElm  (ls :!: Split uId splitType (TwITblBt b s arr c j x mF mB r)) i = Elm ls i
+  getArg (ElmSplitBtITbl _ xs _ ls _) = getArg ls :. xs
+  getIdx (ElmSplitBtITbl _ _  i _  _) = i
+  getElm (ElmSplitBtITbl _ _  _ ls _) = ls
+  {-# Inline getArg #-}
+  {-# Inline getIdx #-}
+  {-# Inline getElm #-}
+
+
+
+-- | 'collectIx' gobbles up indices that are tagged with the same symbolic
+-- identifier.
+
+collectIx
+  :: forall uId ls i .
+     ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)
+     )
+  => Proxy uId -> Elm ls i -> SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)
+collectIx p e = splitIxCol p (Proxy :: Proxy (SameSid uId (Elm ls i))) e
+
+-- | Closed type family that gives us a (type) function for type symbol
+-- equality.
+
+type family SameSid uId elm :: Bool where
+  SameSid uId (Elm (ls :!: Split sId splitType synVar) i) = uId == sId
+  SameSid uId (Elm (ls :!: TermSymbol a b            ) i) = SameSid uId (TermSymbol a b)
+  SameSid uId M                                           = False
+  SameSid uId (TermSymbol a (Split sId splitType synVar)) = OR (uId == sId) (SameSid uId a)
+  SameSid uId (Elm (ls :!: l                         ) i) = False
+
+-- | Type-level @(||)@
+
+type family OR a b where
+  OR False False = False
+  OR a     b     = True
+
+-- | @x ++ y@ but for inductive tuples.
+--
+-- TODO move to PrimitiveArray
+
+class Zconcat x y where
+  type Zpp x y :: *
+  zconcat :: x -> y -> Zpp x y
+
+instance Zconcat x Z where
+  type Zpp x Z = x
+  zconcat x Z = x
+  {-# Inline zconcat #-}
+
+instance 
+  ( Zconcat x z
+  ) => Zconcat x (z:.y) where
+  type Zpp x (z:.y) = Zpp x z :. y
+  zconcat x (z:.y) = zconcat x z :. y
+  {-# Inline zconcat #-}
+
+-- WORKS
+
+-- | Actually collect split indices based on if we managed to find the
+-- right @Split@ synvar (based on the right symbol).
+--
+-- TODO this is not completely right, or? Since we should consider
+-- inside/outside?
+--
+-- TODO 'splitIxCol' will need the index type @i@ to combine running index
+-- and index into the actual lookup part.
+
+class SplitIxCol (uId::Symbol) (b::Bool) e where
+  type SplitIxTy uId b e :: *
+  splitIxCol :: Proxy uId -> Proxy b -> e -> SplitIxTy uId b e
+
+
+
+instance SplitIxCol uId b (Elm S i) where
+  type SplitIxTy uId b (Elm S i) = Z
+  splitIxCol p b (ElmS _) = Z
+  {-# Inline splitIxCol #-}
+
+
+instance
+  ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)
+  , Element (ls :!: l) i
+  , RecElm (ls :!: l) i ~ Elm ls i
+  ) => SplitIxCol uId False (Elm (ls :!: l) i) where
+  type SplitIxTy uId False (Elm (ls :!: l) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)
+  splitIxCol p b e = collectIx p (getElm e)
+  {-# Inline splitIxCol #-}
+
+instance
+  ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)
+  ) => SplitIxCol   uId True (Elm (ls :!: Split sId splitType (TwITbl b s m arr c j x)) i) where
+  type SplitIxTy uId True (Elm (ls :!: Split sId splitType (TwITbl b s m arr c j x)) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i) :. i
+  splitIxCol p b (ElmSplitITbl _ _ i e ix) = collectIx p e :. ix
+  {-# Inline splitIxCol #-}
+
+instance
+  ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)
+  ) => SplitIxCol   uId True (Elm (ls :!: Split sId splitType (TwITblBt b s arr c j x mF mB r)) i) where
+  type SplitIxTy uId True (Elm (ls :!: Split sId splitType (TwITblBt b s arr c j x mF mB r)) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i) :. i
+  splitIxCol p b (ElmSplitBtITbl _ _ i e ix) = collectIx p e :. ix
+  {-# Inline splitIxCol #-}
+
+instance
+  ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)
+  , Zconcat (SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)) (SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b))
+  ) => SplitIxCol uId True (Elm (ls :!: TermSymbol a b) i) where
+  type SplitIxTy uId True (Elm (ls :!: TermSymbol a b) i) = Zpp (SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)) (SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b))
+  splitIxCol p b (ElmTS t i e) = collectIx p e `zconcat` ((error "ElmTS / splitIxCol") {- p t -} :: SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b))
+  {-# Inline splitIxCol #-}
+
diff --git a/ADP/Fusion/Core/SynVar/TableWrap.hs b/ADP/Fusion/Core/SynVar/TableWrap.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/SynVar/TableWrap.hs
@@ -0,0 +1,15 @@
+
+-- | Wrap the underlying table and the rules. Isomorphic to @(,)@.
+
+module ADP.Fusion.Core.SynVar.TableWrap where
+
+
+
+-- | Wrap tables of type @t@. The tables are strict, the functions @f@ can
+-- not be strict, because we need to build grammars recursively.
+
+data TW t f = TW !t f
+
+instance Show t ⇒ Show (TW t f) where
+  show (TW t _) = "TW(" ++ show t ++ ")"
+
diff --git a/ADP/Fusion/Core/TH.hs b/ADP/Fusion/Core/TH.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/TH.hs
@@ -0,0 +1,77 @@
+
+-- | The functions in here auto-create suitable algebra product functions from
+-- a signature. Currently, functions @<**@ are supported which have scalar
+-- results in the first variable.
+--
+-- TODO If we want to support classified DP, we shall also need @**<@
+-- generating vector-results given a vector result, followed by a scalar
+-- result.
+--
+-- TODO Then we also need @***@ handling the case of vector-to-vector results.
+--
+-- TODO note the comments in @buildBacktrackingChoice@
+
+module ADP.Fusion.Core.TH
+  ( makeAlgebraProduct
+  , (<||)
+  , (**>)
+  ) where
+
+import           Data.List
+import           Data.Tuple.Select
+import           Language.Haskell.TH
+import           Language.Haskell.TH.Syntax
+import qualified Data.Vector.Fusion.Stream.Monadic as SM
+
+import           ADP.Fusion.Core.TH.Backtrack -- (makeBacktrackingProductInstance,(<||))
+import           ADP.Fusion.Core.TH.Common (getRuleResultType)
+
+
+
+makeAlgebraProduct = makeProductInstances
+
+{-
+-- | Create the algebra product function from a signature type constructor.
+--
+-- TODO make the resulting function INLINE
+--
+-- TODO compare @synTypes@ with the stream argument types of all @hs@ (via their
+-- @hns@ names). If there is a mismatch, then either not all non-terminal types
+-- have a corresponding choice function or vice versa.
+
+makeAlgebraProductH :: [Name] -> Name -> Q [Dec]
+makeAlgebraProductH hns nm = do
+  rnm <- reify nm
+  case rnm of
+    TyConI (DataD ctx tyConName args cs d) -> case cs of
+      -- we analyze the accessor functions and look for the objective function
+      -- accessor. It's stream parameter is the type of the non-terminal.
+      -- Everything else in accessors are terminal parameters.
+      [RecC dataConName fs'] -> do
+        -- split @fs@ into functions applied to rule RHSs and choice functions (@hs@)
+        let (fs,hs) = partition ((`notElem` hns) . sel1) fs'
+        -- the result types of the @fs@ are the types of the non-terminal symbols
+        let synTypes = nub . map getRuleResultType $ fs
+--        funStream <- funD (mkName "<**") [genClauseStream dataConName fs' fs hs]
+        funList   <- funD (mkName "<||") [genClauseBacktrack dataConName fs' fs hs]
+        return
+--          [ funStream
+          [ funList
+          , PragmaD $ InlineP (mkName "<||") Inline FunLike AllPhases
+          ]
+      _   -> fail "more than one data ctor"
+    _          -> fail "unsupported data type"
+
+-- | Creates a class for each type of product and instances for each
+-- signature.
+
+makeClassyProducts :: Name -> Q [Dec]
+makeClassyProducts conName = do
+  c <- lookupValueName "BacktrackingProduct"
+  case c of
+    Nothing -> error "need to create class now and add instance"
+    Just cl -> error "add instance"
+  return []
+-}
+
+
diff --git a/ADP/Fusion/Core/TH/Backtrack.hs b/ADP/Fusion/Core/TH/Backtrack.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/TH/Backtrack.hs
@@ -0,0 +1,498 @@
+
+-- | Backtracking which uses lists internally. The basic idea is to convert
+-- each @Stream@ into a list. The consumer consumes the stream lazily, but
+-- allows for fusion to happen. The hope is that this improves total
+-- performance in those cases, where backtracking has significant costs.
+
+module ADP.Fusion.Core.TH.Backtrack where
+
+import           Control.Applicative ( (<$>) )
+import           Control.Monad
+import           Control.Monad.Primitive (PrimState, PrimMonad)
+import           Data.List
+import           Data.Tuple.Select
+import           Data.Vector.Fusion.Stream.Monadic (Stream(..))
+import           Debug.Trace
+import           Language.Haskell.TH
+import           Language.Haskell.TH.Instances
+import           Language.Haskell.TH.Syntax
+import qualified Data.Map.Strict as M
+import qualified Data.Vector as V
+import qualified Data.Vector.Fusion.Stream.Monadic as SM
+import qualified Data.Vector.Generic as VG
+import qualified Data.Vector.Generic.Mutable as VGM
+import qualified Data.Vector.Mutable as VM
+import qualified Data.Set as S
+
+import           Data.PrimitiveArray.Index.Class ( (:.)(..) , Z(..) )
+
+import           ADP.Fusion.Core.TH.Common
+
+import Control.Monad.Reader
+
+
+
+-- | @Backtracking@ products of @f@ and @b@. Choice in @f@ needs to be
+-- reduced to a scalar value. It is then compared to the @fst@ values
+-- in @b@. From those, @choice b@ selects.
+
+class ProductBacktracking sigF sigB where
+  type SigBacktracking sigF sigB :: *
+  (<||) :: sigF -> sigB -> SigBacktracking sigF sigB
+
+-- | The ADP-established product operation. Returns a vector of results,
+-- along the lines of what the ADP @f *** b@ provides.
+--
+-- @f **> g@ assumes a vector-to-vector function @f@, and
+-- a vector-to-scalar function @g@.
+
+class ProductCombining sigF sigB where
+  type SigCombining sigF sigB :: *
+  (**>) :: sigF -> sigB -> SigCombining sigF sigB
+
+-- | Creates instances for all products given a signature data type.
+
+makeProductInstances :: Name -> Q [Dec]
+makeProductInstances tyconName = do
+  t <- reify tyconName
+  case t of
+#if MIN_VERSION_template_haskell(2,11,0)
+    TyConI (DataD ctx tyConName args maybeKind cs d) -> do
+#else
+    TyConI (DataD ctx tyConName args cs d) -> do
+#endif
+      let m = getMonadName args
+      case cs of
+        [RecC dataconName funs] -> do
+          let Just (h,m',x,r) = getObjectiveNames funs
+          mL <- newName "mL"
+          xL <- newName "xL"
+          rL <- newName "rL"
+          mR <- newName "mR"
+          xR <- newName "xR"
+          rR <- newName "rR"
+          let lType    = buildRightType tyconName (m', x, r) (mL, xL, rL)    args
+          let rType    = buildRightType tyconName (m', x, r) (mR, xR, rR)    args
+          let (fs,hs) = partition ((`notElem` [h]) . sel1) funs
+          sigBType <- buildSigBacktrackingType  tyconName (m', x, r) xL (mR, xR, rR) args
+          Clause psB (NormalB bB) dsB <- genAlgProdFunctions buildBacktrackingChoice dataconName funs fs hs
+          iB <- [d| instance (Monad $(varT mL), Monad $(varT mR), Eq $(varT xL), $(varT mL) ~ $(varT mR), $(varT xL) ~ $(varT rL))
+                      => ProductBacktracking $(return lType) $(return rType) where
+                          type SigBacktracking $(return lType) $(return rType) = $(return sigBType)
+                          (<||) = $(return $ LamE psB $ LetE dsB bB)
+                          {-# Inline (<||) #-}
+                |]
+          -- TODO might well be that this doesn't work because we re-use
+          -- type names ...
+          vG <- newName "vG"
+          sigPType <- buildSigCombiningType tyconName vG (m', x, r) (mL, xL, rL) (mR, xR, rR) args
+          Clause psC (NormalB bC) dsC <- genAlgProdFunctions buildCombiningChoice    dataconName funs fs hs
+          iC <- [d| instance (Monad $(varT mL), Monad $(varT mR), Eq $(varT xL), Ord $(varT xL), Ord $(varT xR), $(varT mL) ~ $(varT mR) ) -- , VG.Vector $(varT vG) ($(varT rL),$(varT rR)) )
+                      => ProductCombining $(return lType) $(return rType) where
+                          type SigCombining $(return lType) $(return rType) = $(return sigPType)
+                          (**>) = $(return $ LamE psC $ LetE dsC bC)
+                          {-# Inline (**>) #-}
+                |]
+          return $ iB ++ iC
+
+-- | Returns the 'Name' of the monad variable.
+
+getMonadName :: [TyVarBndr] -> Maybe Name
+getMonadName = go
+  where go [] = Nothing
+        go (KindedTV m (AppT (AppT ArrowT StarT) StarT) : _) = Just m
+        go (_ : xs) = go xs
+
+-- | Returns the 'Name's of the objective function variables, as well as
+-- the name of the objective function itself.
+
+getObjectiveNames :: [VarStrictType] -> Maybe (Name,Name,Name,Name)
+getObjectiveNames = go
+  where go [] = Nothing
+        go ( (hName , _ , (AppT (AppT ArrowT (AppT (AppT (ConT streamName) (VarT mS)) (VarT x))) (AppT (VarT mR) (VarT r)))) : xs)
+          | streamName == ''Stream && mS == mR = Just (hName,mS,x,r)
+          | otherwise             = go xs
+        go ( _ : xs) = go xs
+
+
+
+-- * Constructions for the different algebra types.
+
+-- | The left algebra type. Assumes that in @choice :: Stream m x -> m r@
+-- we have that @x ~ r@.
+
+buildLeftType :: Name -> (Name, Name, Name) -> (Name, Name) -> [TyVarBndr] -> Type
+buildLeftType tycon (m, x, r) (mL, xL) = foldl AppT (ConT tycon) . map (VarT . go)
+  where go (PlainTV z)
+          | z == m        = mL  -- correct monad name
+          | z == x        = xL  -- point to new x type
+          | z == r        = xL  -- stream and return type are the same
+          | otherwise     = z   -- everything else can stay as is
+        go (KindedTV z _) = go (PlainTV z)
+
+-- | Here, we do not set any restrictions on the types @m@ and @r@.
+
+buildRightType :: Name -> (Name, Name, Name) -> (Name, Name, Name) -> [TyVarBndr] -> Type
+buildRightType tycon (m, x, r) (mR, xR, rR) = foldl AppT (ConT tycon) . map (VarT . go)
+  where go (PlainTV z)
+          | z == m    = mR  -- have discovered a monadic type
+          | z == x    = xR  -- have discovered a type that is equal to the stream type (and hence we have a synvar type)
+          | z == r    = rR  -- have discovered a type that is equal to the result type (for @<||@) equal to the stream type, hence synvar
+          | otherwise = z   -- this is a terminal or a terminal stack (we don't care)
+        go (KindedTV z _) = go (PlainTV z)
+
+-- | Build up the type for backtracking. We want laziness in the right
+-- return type. Hence, we have @AppT ListT (VarT xR)@ ; i.e. we want to
+-- return results in a list.
+
+buildSigBacktrackingType :: Name -> (Name, Name, Name) -> (Name) -> (Name, Name, Name) -> [TyVarBndr] -> TypeQ
+buildSigBacktrackingType tycon (m, x, r) (xL) (mR, xR, rR) = foldl appT (conT tycon) . map go
+  where go (PlainTV z)
+          | z == m    = varT mR
+          | z == x    = [t| ($(varT xL) , [ $(varT xR) ] ) |]
+          | z == r    = varT rR
+          | otherwise = varT z
+        go (KindedTV z _) = go (PlainTV z)
+
+-- |
+--
+-- [1] we want a list for @[xR]@ because this will make it lazy here. At
+-- least that was the reason for backtracking. For forward mode, we may not
+-- want this. We will have to change the function combination then?
+
+buildSigCombiningType :: Name -> Name -> (Name, Name, Name) -> (Name, Name, Name) -> (Name, Name, Name) -> [TyVarBndr] -> TypeQ
+buildSigCombiningType tycon vG (m, x, r) (mL, xL, rL) (mR, xR, rR) = foldl appT (conT tycon) . map go
+  where go (PlainTV z)
+          | z == m    = varT mR
+          | z == x    = [t| ($(varT xL) , [ $(varT xR) ] ) |]   -- [1]
+          | z == r    = [t| V.Vector ($(varT rL) , $(varT rR)) |]
+          | otherwise = varT z
+        go (KindedTV z _) = go (PlainTV z)
+
+
+
+-- *
+
+-- | Build up attribute and choice function. Here, we actually bind the
+-- left and right algebra to @l@ and @r@.
+
+genAlgProdFunctions
+  :: Choice
+  -> Name
+  -> [VarStrictType]
+  -> [VarStrictType]
+  -> [VarStrictType]
+  -> Q Clause
+genAlgProdFunctions choice conName allFunNames evalFunNames choiceFunNames = do
+  let nonTermNames = nub . map getRuleResultType $ evalFunNames
+  -- bind the l'eft and r'ight variable of the two algebras we want to join,
+  -- also create unique names for the function names we shall bind later.
+  nameL <- newName "l"
+  varL  <- varP nameL
+  fnmsL <- sequence $ replicate (length allFunNames) (newName "fnamL")
+  nameR <- newName "r"
+  varR  <- varP nameR
+  fnmsR <- sequence $ replicate (length allFunNames) (newName "fnamR")
+  -- bind the individual variables in the where part
+  whereL <- valD (conP conName (map varP fnmsL)) (normalB $ varE nameL) []
+  whereR <- valD (conP conName (map varP fnmsR)) (normalB $ varE nameR) []
+  rce <- recConE conName
+          $  zipWith3 (genChoiceFunction choice) (drop (length evalFunNames) fnmsL) (drop (length evalFunNames) fnmsR) choiceFunNames
+          ++ zipWith3 (genAttributeFunction nonTermNames) fnmsL fnmsR evalFunNames
+  -- build the function pairs
+  -- to keep our sanity, lets print this stuff
+  let cls = Clause [varL, varR] (NormalB rce) [whereL,whereR]
+  return cls
+
+-- | Simple wrapper for creating the choice fun expression.
+
+genChoiceFunction
+  :: Choice
+  -> Name
+  -> Name
+  -> VarStrictType
+  -> Q (Name,Exp)
+genChoiceFunction choice hL hR (name,_,t) = do
+  exp <- choice hL hR
+  return (name,exp)
+
+
+-- | We take the left and right function name for one attribute and build
+-- up the combined attribute function. Mostly a wrapper around
+-- 'recBuildLampat' which does the main work.
+--
+-- TODO need fun names from @l@ and @r@
+
+genAttributeFunction
+  :: [Name]
+  -> Name
+  -> Name
+  -> VarStrictType
+  -> Q (Name,Exp)
+genAttributeFunction nts fL fR (name,_,t) = do
+  (lamPat,funL,funR) <-recBuildLamPat nts fL fR (init $ getRuleSynVarNames nts t) -- @init@ since we don't want the result as a parameter
+  let exp = LamE lamPat $ TupE [funL,funR]
+  return (name,exp)
+
+-- | Now things become trickly. We are given all non-terminal names (to
+-- differentiate between a terminal (stack) and a syntactic variable; the
+-- left and right function; and the arguments to this attribute function
+-- (except the result parameter). We are given the latter as a result to an
+-- earlier call to 'getRuleSynVarNames'.
+--
+-- We now look at each argument and determine wether it is a syntactic
+-- variable. If so, then we actually have a tuple arguments @(x,ys)@ where
+-- @x@ has to optimized value and @ys@ the backtracking list. The left
+-- function receives just @x@ in this case. For the right function, things
+-- are more complicated, since we have to flatten lists. See 'buildRns'.
+--
+-- Terminals are always given "as is" since we do not have a need for
+-- tupled-up information as we have for syntactic variables.
+
+recBuildLamPat
+  :: [Name]   -- ^ all non-terminal names
+  -> Name     -- ^ left attribute function
+  -> Name     -- ^ right attribute function
+  -> [ArgTy Name]  -- ^ all arguments to the attribute function
+  -> Q ([Pat], Exp, Exp)
+recBuildLamPat nts fL' fR' ts = do
+  -- here we just run through all arguments, either creating an @x@ and
+  -- a @ys@ for a non-term or a @t@ for a term.
+  ps <- mapM argTyArgs ts
+  lamPat <- buildLamPat ps
+  lfun <- buildLns (VarE fL') ps -- foldl buildLfun (varE fL') ps
+  rfun <- buildRns (VarE fR') ps
+  return (lamPat, lfun, rfun)
+
+buildLamPat :: [ArgTy Pat] -> Q [Pat]
+buildLamPat = mapM go where
+  go (SynVar      p ) = return p
+  go (Term        p ) = return p
+  go (StackedVars ps) = build ps
+  build :: [ArgTy Pat] -> Q Pat
+  build = foldl (\s v -> [p| $(s) :. $(return v) |]) [p|Z|] . map get
+  get :: ArgTy Pat -> Pat
+  get (SynVar p) = p
+  get (Term   p) = p
+
+-- | Look at the argument type and build the capturing variables. In
+-- particular captures synvar arguments with a 2-tuple @(x,ys)@.
+
+argTyArgs :: ArgTy Name -> Q (ArgTy Pat)
+argTyArgs (SynVar n) = SynVar <$> tupP [newName "x" >>= varP , newName "ys" >>= varP]
+argTyArgs (Term n)          = Term <$> (newName "t" >>= varP)
+argTyArgs (StackedTerms _)  = Term <$> (newName "t" >>= varP) -- !!!
+argTyArgs (StackedVars vs)  = StackedVars <$> mapM argTyArgs vs
+argTyArgs NilVar            = Term <$> (newName "t" >>= varP)
+argTyArgs (Result _)        = error "argTyArgs: should not receive @Result@"
+
+buildLns
+  :: Exp
+  -> [ArgTy Pat]
+  -> ExpQ
+buildLns f' ps = foldl go (return f') ps
+  where go :: ExpQ -> ArgTy Pat -> ExpQ
+        go f (SynVar      (TupP [VarP v,_])) = appE f (varE v)
+        go f (Term        (VarP v         )) = appE f (varE v)
+        go f (StackedVars vs               ) = appE f (build vs)
+        build :: [ArgTy Pat] -> ExpQ
+        build = foldl (\s v -> [| $(s) :. $(varE v) |]) [|Z|] . map get
+        get (SynVar (TupP [VarP v,_])) = v
+        get (Term   (VarP t)         ) = t
+
+-- | Build the right-hand side of a function combined in @f <|| g@. This
+-- splits the paired synvars @(x,xs)@ such that we calculate @f x@ and @g
+-- xs@.
+--
+-- NOTE If we want to write
+--
+-- @
+-- [ f x | x <- xs ]
+-- @
+--
+-- then in template haskell, this looks like this:
+--
+-- @
+-- CompE [BindS (VarP x) (VarE xs), NoBindS (AppE (VarE f) (VarE x))]
+-- @
+--
+-- The @NoBindS@ is the final binding of @f@ to the individual @x@'s, while
+-- the prior @x <- xs@ comes from @BindS (VarP x) (VarE xs)@.
+--
+-- TODO This is where we might be able to improve performance if we can
+-- optimize @[f x y | x <- xs, y <- ys]@ for @concatMap@ in @vector@.
+
+buildRns
+  :: Exp
+--  -> [Name]
+  -> [ArgTy Pat]
+  -> ExpQ
+buildRns f' ps = do
+  -- get all synvars, shallow or deep and create a new name to bind
+  -- individual parts to.
+  sy :: M.Map Pat Name <- M.fromList <$> (mapM (\s -> newName "y" >>= \y -> return (s,y)) $ concatMap flattenSynVars ps)
+  -- bind them for the right part of the list expression (even though they
+  -- are left in @CompE@. We don't use @sy@ directly to keep the order in
+  -- which the comprehensions run.
+  let rs = map (\k@(TupP [_,VarP v]) -> BindS (VarP $ sy M.! k) (VarE v)) $ concatMap flattenSynVars ps
+  let go :: ExpQ -> ArgTy Pat -> ExpQ
+      go f (SynVar      k       ) = appE f (varE $ sy M.! k) -- needed like this, because we need the @y@ in @y <- ys@
+      go f (Term        (VarP v)) = appE f (varE v)
+      go f (StackedVars vs      ) = appE f (foldl build [|Z|] vs)
+      build :: ExpQ -> ArgTy Pat -> ExpQ
+      build s (SynVar k       ) = [| $(s) :. $(varE $ sy M.! k) |]
+      build s (Term   (VarP v)) = [| $(s) :. $(varE v)          |]
+  funApp <- foldl go (return f') ps
+  return . CompE $ rs ++ [NoBindS funApp]
+
+
+-- | Type for backtracking functions.
+--
+-- Not too interesting, mostly to keep track of @choice@.
+
+type Choice = Name -> Name -> Q Exp
+
+-- | Build up the backtracking choice function. This choice function will
+-- backtrack based on the first result, then return only the second.
+--
+-- TODO it should be (only?) this function we will need to modify to build
+-- all algebra products.
+--
+-- @ysM@ can't be unboxed, as @snd@ of each element is a list, lazily
+-- consumed. We build up @ysM@ as this makes fusion happen. Of course, this
+-- is a boxed vector and not as efficient, but we gain the ability to have
+-- lazily created backtracking from this!
+--
+-- This means strict optimization AND lazy backtracking
+--
+-- TODO in principle, we do more work than necessary. The line
+-- @hFres <- ...@ evaluates the optimal choice from the @fst@ elements
+-- again. As long as the cost is small compared to the evaluation of @snd@
+-- (or the list-comprehension based creation of all parses), this won't
+-- matter much.
+
+buildBacktrackingChoice :: Choice
+buildBacktrackingChoice hL' hR' =
+  [| \xs -> do
+      -- turn the stream into a list
+      ysM <- SM.toList xs
+      -- based only on the @fst@ elements, select optimal value
+      hFres <- $(varE hL') $ SM.map fst $ SM.fromList ysM
+      -- filter accordingly
+      $(varE hR') $ SM.fromList $ concatMap snd $ filter ((hFres==) . fst) $ ysM
+  |]
+
+-- | We assume parses of type @(x,y)@ in a vector @<(x,y)>@. the function
+-- acting on @x@ will produce a subset @<x>@ (in vector form). the function
+-- acting on @y@ produces scalars @y@. We have @actFst :: <x> -> <x>@ and
+-- @actSnd :: <y> -> y@. This in total should yield @<(x,y)> -> <(x,y)>@.
+--
+-- TODO This should create @generic@ vectors, that are specialized by the
+-- table they are stored into.
+
+buildCombiningChoice :: Choice
+buildCombiningChoice hL' hR' =
+  [| \xs -> do
+      -- -- lets begin with the list of parses
+      -- ys <- SM.toList xs
+      -- -- but now, we actually get a list of co-optimals to keep. Yes,
+      -- -- a @[fst]@ list.
+      -- cooptFsts <- S.fromList <$> ( ( $(varE hL') $ SM.map fst $ SM.fromList ys ) >>= SM.toList )
+      -- -- now we create a map with all the coopts, where we collect in the
+      -- -- value parts the list of parses for each co-optimal @snd@ for
+      -- -- a @fst@.
+      -- let cooptMap = M.fromListWith (++) [ y | y <- ys, y `S.member` cooptFsts ]
+      -- -- We now need to map @actSnd@ over the resulting intermediates
+      -- actSnd <- mapM (\y -> $(varE hR') (SM.fromList y)) cooptMap
+      -- -- a vector with co-optimals, each one associated with its optimal
+      -- -- @snd@.
+      -- return . VG.fromList . M.toList $ actSnd
+      return undefined
+  |]
+
+-- | Turn a stream into a vector.
+--
+-- TODO need to be improved in terms of performance.
+
+streamToVectorM :: (Monad m, VG.Vector v a) => SM.Stream m a -> m (v a)
+streamToVectorM s = SM.toList s >>= return . VG.fromList
+{-# Inline streamToVectorM #-}
+
+-- | Gets the names used in the evaluation function. This returns one
+-- 'Name' for each variable.
+--
+-- In case of @TupleT 0@ the type is @()@ and there isn't a name to go with
+-- it. We just @mkName "()"@ a name, but this might be slightly dangerous?
+-- (Not really sure if it indeed is)
+--
+-- With @AppT _ _@ we have a multidim terminal and produce another hackish
+-- name to be consumed above.
+--
+-- @
+-- AppT (AppT ArrowT (AppT (AppT (ConT Data.Array.Repa.Index.:.) (AppT (AppT (ConT Data.Array.Repa.Index.:.) (ConT Data.Array.Repa.Index.Z)) (VarT c_1627675270))) (VarT c_1627675270))) (VarT x_1627675265)
+-- @
+
+getRuleSynVarNames :: [Name]-> Type -> [ArgTy Name] -- [Name]
+getRuleSynVarNames nts t' = go t' where
+  go t
+    | VarT x <- t                          = [Result x]
+    | AppT (AppT ArrowT (VarT x)  ) y <- t = (if x `elem` nts then SynVar x else Term x) : go y
+    | AppT (AppT ArrowT (TupleT 0)) y <- t = NilVar : go y
+    | AppT (AppT ArrowT s         ) y <- t = stacked s : go y
+    | otherwise                            = error $ "getRuleSynVarNames error: " ++ show t ++ "    in:    " ++ show t'
+  stacked s = if null [ () | SynVar _ <- xs ] then StackedTerms xs else StackedVars xs
+    where xs = reverse $ stckd s
+          stckd (ConT z) | z == ''Z = []
+          stckd (AppT a (TupleT 0)) = NilVar : stckd a
+          stckd (AppT a (VarT x)  ) = (if x `elem` nts then SynVar x else Term x) : stckd a
+          stckd (AppT (ConT c) a  ) | c == ''(:.) = stckd a
+          stckd err = error $ "stckd" ++ show err
+
+{-
+(AppT (AppT (ConT Data.PrimitiveArray.Index.Class.:.)
+            (AppT (AppT (ConT Data.PrimitiveArray.Index.Class.:.)
+                        (ConT Data.PrimitiveArray.Index.Class.Z)
+                  )
+                  (VarT x_1627774371)
+            )
+      )
+      (TupleT 0)
+)
+-}
+
+
+data ArgTy x
+  -- | This @SynVar@ spans the full column of tapes; i.e. it is a normal
+  -- syntactic variable.
+  = SynVar { synVarName :: x }
+  -- | We have just a single-tape grammar and as such just
+  -- a single-dimensional terminal. We call this term, because
+  -- @StackedTerms@ will be rewritten to just @Term@!
+  | Term { termName :: x }
+  -- | We have a multi-tape grammar with a stack of just terminals. We
+  -- normally can ignore the contents in the functions above, but keep them
+  -- anyway.
+  | StackedTerms { stackedTerms :: [ArgTy x] }
+  -- | We have a multi-tape grammar, but the stack contains a mixture of
+  -- @ArgTy@s.
+  | StackedVars { stackedVars :: [ArgTy x] }
+  -- | A single-dim @()@ case
+  | NilVar
+  -- | The result type name
+  | Result { result :: x }
+  deriving (Show,Eq)
+
+unpackArgTy :: Show x => ArgTy x -> x
+unpackArgTy = go
+  where go (SynVar x) = x
+        go (Term   x) = x
+        go (Result x) = x
+        go err        = error $ "unpackArgTy " ++ show err
+
+-- | Get all synvars, even if deep in a stack
+
+flattenSynVars :: ArgTy x -> [x]
+flattenSynVars (SynVar x)       = [x]
+flattenSynVars (StackedVars xs) = concatMap flattenSynVars xs
+flattenSynVars _                = []
+
diff --git a/ADP/Fusion/Core/TH/Common.hs b/ADP/Fusion/Core/TH/Common.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/TH/Common.hs
@@ -0,0 +1,19 @@
+
+module ADP.Fusion.Core.TH.Common where
+
+import           Data.Tuple.Select
+import           Language.Haskell.TH
+import           Language.Haskell.TH.Syntax
+
+
+
+-- | The last @Name@ of a rule is the name of the syntactic type of the
+-- result.
+
+getRuleResultType :: VarStrictType -> Name
+getRuleResultType vst = go $ sel3 vst where
+  go t
+    | AppT _ (VarT x) <- t = x
+    | AppT _ x        <- t = go x
+    | otherwise            = error $ "undetermined error:" ++ show vst
+
diff --git a/ADP/Fusion/Core/Term/Chr.hs b/ADP/Fusion/Core/Term/Chr.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/Term/Chr.hs
@@ -0,0 +1,62 @@
+
+-- |
+--
+-- TODO Rename @Chr@ to @Vtx@, a vertex parser is a generalization of
+-- a char parser. But this is only semantics, so not super important to do
+-- now.
+
+module ADP.Fusion.Core.Term.Chr where
+
+import           Data.Strict.Tuple
+import qualified Data.Vector.Generic as VG
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Core.Classes
+import           ADP.Fusion.Core.Multi
+
+
+
+-- | A generic Character parser that reads a single character but allows
+-- passing additional information.
+--
+--  'Chr' expects a function to retrieve @r@ at index position, followed by
+--  the actual generic vector with data.
+
+data Chr r x where
+  Chr :: VG.Vector v x
+      => (v x -> Int -> r)
+      -> !(v x)
+      -> Chr r x
+
+-- | smart constructor for regular 1-character parsers
+
+chr :: VG.Vector v x => v x -> Chr x x
+chr = Chr VG.unsafeIndex
+{-# Inline chr #-}
+
+-- | Smart constructor for Maybe Peeking, followed by a character.
+
+chrLeft xs = Chr f xs where
+  f xs k = ( xs VG.!? (k-1)
+           , VG.unsafeIndex xs k
+           )
+  {-# Inline [0] f #-}
+{-# Inline chrLeft #-}
+
+instance Build (Chr r x)
+
+instance
+  ( Element ls i
+  ) => Element (ls :!: Chr r x) i where
+    data Elm (ls :!: Chr r x) i = ElmChr !r !(RunningIndex i) !(Elm ls i)
+    type Arg (ls :!: Chr r x)   = Arg ls :. r
+    getArg (ElmChr x _ ls) = getArg ls :. x
+    getIdx (ElmChr _ i _ ) = i
+    {-# Inline getArg #-}
+    {-# Inline getIdx #-}
+
+deriving instance (Show i, Show (RunningIndex i), Show r, Show (Elm ls i)) => Show (Elm (ls :!: Chr r x) i)
+
+type instance TermArg (Chr r x) = r
+
diff --git a/ADP/Fusion/Core/Term/Deletion.hs b/ADP/Fusion/Core/Term/Deletion.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/Term/Deletion.hs
@@ -0,0 +1,26 @@
+
+module ADP.Fusion.Core.Term.Deletion where
+
+import Data.Strict.Tuple
+
+import Data.PrimitiveArray
+
+import ADP.Fusion.Core.Classes
+import ADP.Fusion.Core.Multi
+
+
+
+data Deletion = Deletion
+
+instance Build Deletion
+
+instance (Element ls i) => Element (ls :!: Deletion) i where
+  data Elm (ls :!: Deletion) i = ElmDeletion !(RunningIndex i) !(Elm ls i)
+  type Arg (ls :!: Deletion)   = Arg ls :. ()
+  getArg (ElmDeletion _ l) = getArg l :. ()
+  getIdx (ElmDeletion i _) = i
+  {-# Inline getArg #-}
+  {-# Inline getIdx #-}
+
+type instance TermArg Deletion = ()
+
diff --git a/ADP/Fusion/Core/Term/Edge.hs b/ADP/Fusion/Core/Term/Edge.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/Term/Edge.hs
@@ -0,0 +1,73 @@
+
+module ADP.Fusion.Core.Term.Edge where
+
+import Data.Strict.Tuple
+import Data.Proxy
+
+import Data.PrimitiveArray
+
+import ADP.Fusion.Core.Classes
+import ADP.Fusion.Core.Multi
+
+
+
+newtype From = From { getFrom :: Int }
+  deriving (Eq,Ord,Show)
+
+newtype To = To { getTo :: Int }
+  deriving (Eq,Ord,Show)
+
+-- | An edge in a graph. As a parsing symbol, it will provide (From:.To)
+-- pairs.
+
+data Edge = Edge
+
+instance Build Edge
+
+instance
+  ( Element ls i
+  ) => Element (ls :!: Edge) i where
+    data Elm (ls :!: Edge) i = ElmEdge !(From:.To) !(RunningIndex i) !(Elm ls i)
+    type Arg (ls :!: Edge)   = Arg ls :. (From:.To)
+    getArg (ElmEdge e _ ls) = getArg ls :. e
+    getIdx (ElmEdge _ i _ ) = i
+    {-# Inline getArg #-}
+    {-# Inline getIdx #-}
+
+deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: Edge) i)
+
+type instance TermArg Edge = (From:.To)
+
+-- | 'edgeFromTo' creates a @(From:.To)@ structure for edges. How this is
+-- filled depends on the @Proxy@. Possible are @Proxy First@ and @Proxy Last@.
+-- @First@ denotes that @To@ is the first node to be visited. I.e. @First(From)
+-- → Set(To)@. @Last@ on the other hand is @Set(From) → Last(To)@.
+
+class EdgeFromTo k where
+  edgeFromTo ∷ Proxy k → SetBoundary → NewBoundary → (From:.To)
+
+newtype SetBoundary = SetBoundary Int
+
+newtype NewBoundary = NewBoundary Int
+
+-- | In case our sets have a @First@ boundary, then we always point from
+-- the boundary "into" the set. Hence @SetNode == To@ and @NewNode ==
+-- From@.
+--
+-- @{1,2,(3)} <- (4)@ yields @From 4 :. To 3@. Note the arrow direction @INTO@
+-- the set.
+
+instance EdgeFromTo First where
+  edgeFromTo Proxy (SetBoundary to) (NewBoundary from) = From from :. To to
+  {-# Inline edgeFromTo #-}
+
+-- | And if the set has a @Last@ boundary, then we point from somewhere in
+-- the set @To@ the @NewNode@, which is @Last@.
+--
+-- @{1,2,(3)} -> (4)@ yields @From 3 :. To 4@. Note the arrow direction @OUT
+-- OF@ the set.
+
+instance EdgeFromTo Last where
+  edgeFromTo Proxy (SetBoundary from) (NewBoundary to) = From from :. To to
+  {-# Inline edgeFromTo #-}
+
diff --git a/ADP/Fusion/Core/Term/Epsilon.hs b/ADP/Fusion/Core/Term/Epsilon.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/Term/Epsilon.hs
@@ -0,0 +1,35 @@
+
+-- | 'Epsilon' is a global or local starting (or ending, depending on the view)
+-- point for a grammar.
+
+module ADP.Fusion.Core.Term.Epsilon where
+
+import Data.Data
+import Data.Strict.Tuple
+import Data.Typeable
+import GHC.Generics(Generic)
+
+import Data.PrimitiveArray
+
+import ADP.Fusion.Core.Classes
+import ADP.Fusion.Core.Multi
+
+
+
+data LocalGlobal = Local | Global
+  deriving (Eq,Ord,Read,Show,Data,Typeable,Generic)
+
+data Epsilon (lg ∷ LocalGlobal) = Epsilon
+
+instance Build (Epsilon lg)
+
+instance (Element ls i) => Element (ls :!: Epsilon lg) i where
+  data Elm (ls :!: Epsilon lg) i = ElmEpsilon !(RunningIndex i) !(Elm ls i)
+  type Arg (ls :!: Epsilon lg)   = Arg ls :. ()
+  getArg (ElmEpsilon _ l) = getArg l :. ()
+  getIdx (ElmEpsilon i _) = i
+  {-# Inline getArg #-}
+  {-# Inline getIdx #-}
+
+type instance TermArg (Epsilon lg) = ()
+
diff --git a/ADP/Fusion/Core/Term/MultiChr.hs b/ADP/Fusion/Core/Term/MultiChr.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/Term/MultiChr.hs
@@ -0,0 +1,49 @@
+
+-- |
+--
+-- TODO Rename @Chr@ to @Vtx@, a vertex parser is a generalization of
+-- a char parser. But this is only semantics, so not super important to do
+-- now.
+
+module ADP.Fusion.Core.Term.MultiChr where
+
+import           Data.Strict.Tuple
+import           GHC.TypeNats
+import qualified Data.Vector.Generic as VG
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Core.Classes
+import           ADP.Fusion.Core.Multi
+
+
+
+-- | A multi-character parser.
+
+data MultiChr (c ∷ Nat) (v ∷ * → *) (x ∷ *) where
+  MultiChr ∷ VG.Vector v x
+           ⇒ !(v x)
+           → MultiChr c v x
+
+-- | smart constructor for regular 1-character parsers
+
+multiChr :: VG.Vector v x => v x -> MultiChr c v x
+multiChr = MultiChr
+{-# Inline multiChr #-}
+
+instance Build (MultiChr c v x)
+
+instance
+  ( Element ls i
+  ) => Element (ls :!: MultiChr c v x) i where
+    data Elm (ls :!: MultiChr c v x) i = ElmMultiChr !(v x) !(RunningIndex i) !(Elm ls i)
+    type Arg (ls :!: MultiChr c v x)   = Arg ls :. v x
+    getArg (ElmMultiChr x _ ls) = getArg ls :. x
+    getIdx (ElmMultiChr _ i _ ) = i
+    {-# Inline getArg #-}
+    {-# Inline getIdx #-}
+
+deriving instance (Show i, Show (RunningIndex i), Show (v x), Show (Elm ls i)) => Show (Elm (ls :!: MultiChr c v x) i)
+
+type instance TermArg (MultiChr c v x) = v x
+
diff --git a/ADP/Fusion/Core/Term/PeekIndex.hs b/ADP/Fusion/Core/Term/PeekIndex.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/Term/PeekIndex.hs
@@ -0,0 +1,30 @@
+
+module ADP.Fusion.Core.Term.PeekIndex where
+
+import Data.Strict.Tuple
+
+import Data.PrimitiveArray
+
+import ADP.Fusion.Core.Classes
+import ADP.Fusion.Core.Multi
+
+
+
+data PeekIndex i = PeekIndex
+
+instance Build (PeekIndex i)
+
+instance
+  ( Element ls i
+  ) => Element (ls :!: PeekIndex i) i where
+    data Elm (ls :!: PeekIndex i) i = ElmPeekIndex !i !(RunningIndex i) !(Elm ls i)
+    type Arg (ls :!: PeekIndex i)   = Arg ls :. i
+    getArg (ElmPeekIndex x _  ls)    = getArg ls :. x
+    getIdx (ElmPeekIndex _ i  _ )    = i
+    {-# Inline getArg #-}
+    {-# Inline getIdx #-}
+
+deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: PeekIndex i) i)
+
+type instance TermArg (PeekIndex i) = PeekIndex i
+
diff --git a/ADP/Fusion/Core/Term/Str.hs b/ADP/Fusion/Core/Term/Str.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/Term/Str.hs
@@ -0,0 +1,61 @@
+
+module ADP.Fusion.Core.Term.Str where
+
+import           Data.Strict.Tuple
+import           GHC.TypeLits
+import           GHC.TypeNats
+import qualified Data.Vector.Generic as VG
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Core.Classes
+import           ADP.Fusion.Core.Multi
+
+
+
+-- | A @Str@ wraps an input vector and provides type-level annotations on
+-- linked @Str@'s, their minimal and maximal size.
+--
+-- If @linked ∷ Maybe Symbol@ is set to @Just aName@, then all @Str@'s that are
+-- part of the same rule share their size information. This allows rules of the
+-- kind @X -> a Y b@ where @a,b@ have a common maximal size.
+--
+-- @minSz@ and @maxSz@ provide minimal and maximal parser width, if set.
+--
+-- TODO consider if @maxSz@ could do with just @Nat@
+
+data Str (linked ∷ Maybe Symbol) (minSz ∷ Nat) (maxSz ∷ Maybe Nat) v x where
+  Str ∷ VG.Vector v x
+      ⇒ !(v x)
+      → Str linked minSz maxSz v x
+
+-- | Construct string parsers with no special constraints.
+
+manyV ∷ VG.Vector v x ⇒ v x → Str Nothing 0 Nothing v x
+manyV = Str
+{-# Inline manyV #-}
+
+someV ∷ VG.Vector v x ⇒ v x → Str Nothing 1 Nothing v x
+someV = Str
+{-# Inline someV #-}
+
+-- TODO really need to be able to remove this system. Forgetting @Build@ gives
+-- very strange type errors.
+
+instance Build (Str linked minSz maxSz v x)
+
+instance
+  ( Element ls i
+  , VG.Vector v x
+  ) => Element (ls :!: Str linked minSz maxSz v x) i where
+    data Elm (ls :!: Str linked minSz maxSz v x) i = ElmStr !(v x) !(RunningIndex i) !(Elm ls i)
+    type Arg (ls :!: Str linked minSz maxSz v x)   = Arg ls :. v x
+    getArg (ElmStr x _ ls) = getArg ls :. x
+    getIdx (ElmStr _ i _ ) = i
+    {-# Inline getArg #-}
+    {-# Inline getIdx #-}
+
+deriving instance (Show i, Show (RunningIndex i), Show (v x), Show (Elm ls i)) => Show (Elm (ls :!: Str linked minSz maxSz v x) i)
+
+type instance TermArg (Str linked minSz maxSz v x) = v x
+
diff --git a/ADP/Fusion/Core/Term/Switch.hs b/ADP/Fusion/Core/Term/Switch.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/Term/Switch.hs
@@ -0,0 +1,48 @@
+
+-- | 'Switch'es allow enabling and disabling individual rules on a global
+-- level.
+--
+-- TODO Consider moving the switch status to the type level.
+-- TODO Consider using patterns for the switch status and encode using @Int@s.
+
+module ADP.Fusion.Core.Term.Switch where
+
+import           Data.Strict.Tuple
+import qualified Data.Vector.Generic as VG
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Core.Classes
+import           ADP.Fusion.Core.Multi
+
+
+
+-- | Explicit naming of the status of the switch.
+
+data SwitchStatus = Disabled | Enabled
+  deriving (Eq,Ord,Show)
+
+-- | Terminal for the switch. The switch status is not given to any function,
+-- since processing of the rule already indicates that the switch is enabled --
+-- if all other symbols parse successfully. Due to consistency, the type of
+-- result is @()@.
+
+data Switch where
+  Switch ∷ !SwitchStatus → Switch
+
+instance Build Switch
+
+instance
+  ( Element ls i
+  ) => Element (ls :!: Switch) i where
+    data Elm (ls :!: Switch) i = ElmSwitch !(RunningIndex i) !(Elm ls i)
+    type Arg (ls :!: Switch)   = Arg ls :. ()
+    getArg (ElmSwitch _ ls) = getArg ls :. ()
+    getIdx (ElmSwitch i _ ) = i
+    {-# Inline getArg #-}
+    {-# Inline getIdx #-}
+
+deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: Switch) i)
+
+type instance TermArg Switch = ()
+
diff --git a/ADP/Fusion/Core/Term/Test.hs b/ADP/Fusion/Core/Term/Test.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/Term/Test.hs
@@ -0,0 +1,60 @@
+
+module ADP.Fusion.Core.Term.Test where
+
+import           Data.Strict.Tuple
+import qualified Data.Vector.Generic as VG
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Core.Classes
+import           ADP.Fusion.Core.Multi
+
+
+
+-- | 'Test' terminals return "strings", i.e. vectors of @Chr@s. They allow
+-- the user to specify @[ 0 .. ]@ atoms to be parsed at once. It is
+-- possible to both, limit the minimal and maximal number.
+--
+-- NOTE gadt comments are not parsed by haddock?
+
+{-
+data Test v x where
+  Test :: VG.Vector v x
+        => (Int -> Int -> v x -> v x)  -- @slice@ function
+        -> Int                         -- minimal size
+        -> Int                         -- maximal size (just use s.th. big if you don't want a limit)
+        -> (v x)                       -- the actual vector
+        -> Test v x
+
+manyS :: VG.Vector v x => v x -> Test v x
+manyS = \xs -> Test VG.unsafeSlice 0 (VG.length xs) xs
+{-# Inline manyS #-}
+
+someS :: VG.Vector v x => v x -> Test v x
+someS = \xs -> Test VG.unsafeSlice 1 (VG.length xs) xs
+{-# Inline someS #-}
+
+strng :: VG.Vector v x => Int -> Int -> v x -> Test v x
+strng = \minL maxL xs -> Test VG.unsafeSlice minL maxL xs
+{-# Inline strng #-}
+-}
+
+data Test v x where
+  Test :: VG.Vector v x => v x -> Test v x
+
+instance Build (Test v x)
+
+instance
+  ( Element ls i
+  ) => Element (ls :!: Test v x) i where
+  data Elm (ls :!: Test v x) i = ElmTest !(v x) !(RunningIndex i) !(Elm ls i)
+  type Arg (ls :!: Test v x)   = Arg ls :. v x
+  getArg (ElmTest x _ ls) = getArg ls :. x
+  getIdx (ElmTest _ i _ ) = i
+  {-# Inline getArg #-}
+  {-# Inline getIdx #-}
+
+deriving instance (Show i, Show (RunningIndex i), Show (v x), Show (Elm ls i)) => Show (Elm (ls :!: Test v x) i)
+
+type instance TermArg (Test v x) = v x
+
diff --git a/ADP/Fusion/Core/TyLvlIx.hs b/ADP/Fusion/Core/TyLvlIx.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Core/TyLvlIx.hs
@@ -0,0 +1,112 @@
+
+-- | Type-level indexing functionality
+
+module ADP.Fusion.Core.TyLvlIx
+  ( module ADP.Fusion.Core.TyLvlIx
+  , module GHC.TypeLits
+  ) where
+
+import Data.Proxy
+import GHC.TypeLits
+
+import Data.PrimitiveArray.Index.Class hiding (map)
+
+import ADP.Fusion.Core.Classes (RunningIndex (..))
+
+
+
+-- | Given some complete index list @ixTy@ and some lower-dimensional
+-- version @myTy@, walk down along @ixTy@ until we have @is:.i ~ ms:.m@ and
+-- return @m@.
+
+class GetIndexGo ixTy myTy (cmp :: Ordering) where
+  type ResolvedIx ixTy myTy cmp :: *
+  getIndexGo :: ixTy -> (Proxy myTy) -> (Proxy cmp) -> ResolvedIx ixTy myTy cmp
+
+instance GetIndexGo (ix:.i) (my:.m) EQ where
+  type ResolvedIx (ix:.i) (my:.m) EQ = i
+  getIndexGo (ix:.i) _ _ = seq ix $ i
+  {-# Inline [0] getIndexGo #-}
+
+instance (GetIndexGo ix (my:.m) (CmpNat (ToNat ix) (ToNat (my:.m)))) => GetIndexGo (ix:.i) (my:.m) GT where
+  type ResolvedIx (ix:.i) (my:.m) GT = ResolvedIx ix (my:.m) (CmpNat (ToNat ix) (ToNat (my:.m)))
+  getIndexGo (ix:._) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat ix) (ToNat (my:.m))))
+  {-# Inline [0] getIndexGo #-}
+
+instance (GetIndexGo ix Z (CmpNat (ToNat ix) (ToNat Z))) => GetIndexGo (ix:.i) Z GT where
+  type ResolvedIx (ix:.i) Z GT = ResolvedIx ix Z (CmpNat (ToNat ix) (ToNat Z))
+  getIndexGo (ix:._) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat ix) (ToNat Z)))
+  {-# Inline [0] getIndexGo #-}
+
+instance GetIndexGo Z Z EQ where
+  type ResolvedIx Z Z EQ = Z
+  getIndexGo _ _ _ = Z
+  {-# Inline [0] getIndexGo #-}
+
+
+
+instance GetIndexGo (RunningIndex (ix:.i)) (RunningIndex (my:.m)) EQ where
+  type ResolvedIx (RunningIndex (ix:.i)) (RunningIndex (my:.m)) EQ = RunningIndex i
+  getIndexGo (ix:.:i) _ _ = seq ix i
+  {-# Inline [0] getIndexGo #-}
+
+instance
+  ( GetIndexGo (RunningIndex ix) (RunningIndex (my:.m)) (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex (my:.m))))
+  ) => GetIndexGo (RunningIndex (ix:.i)) (RunningIndex (my:.m)) GT where
+  type ResolvedIx (RunningIndex (ix:.i)) (RunningIndex (my:.m)) GT = ResolvedIx (RunningIndex ix) (RunningIndex (my:.m)) (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex (my:.m))))
+  getIndexGo (ix:.:_) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex (my:.m)))))
+  {-# Inline [0] getIndexGo #-}
+
+instance
+  ( GetIndexGo (RunningIndex ix) (RunningIndex Z) (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex Z)))
+  ) => GetIndexGo (RunningIndex (ix:.i)) (RunningIndex Z) GT where
+  type ResolvedIx (RunningIndex (ix:.i)) (RunningIndex Z) GT = ResolvedIx (RunningIndex ix) (RunningIndex Z) (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex Z)))
+  getIndexGo (ix:.:_) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex Z))))
+  {-# Inline [0] getIndexGo #-}
+
+instance GetIndexGo (RunningIndex Z) (RunningIndex Z) EQ where
+  type ResolvedIx (RunningIndex Z) (RunningIndex Z) EQ = RunningIndex Z
+  getIndexGo riz _ _ = riz
+  {-# Inline [0] getIndexGo #-}
+
+
+
+-- | Wrap @GetIndexGo@ and the type-level shenanigans.
+
+type GetIndex l r = GetIndexGo l r (CmpNat (ToNat l) (ToNat r))
+
+type GetIx l r = ResolvedIx l r (CmpNat (ToNat l) (ToNat r))
+
+-- | Simplifying wrapper around @getIndexGo@.
+
+getIndex
+  :: forall ixTy myTy
+  .  GetIndex ixTy myTy
+  => ixTy
+  -> Proxy myTy
+  -> GetIx ixTy myTy
+getIndex ixTy myTy = getIndexGo ixTy (Proxy :: Proxy myTy) (Proxy :: Proxy (CmpNat (ToNat ixTy) (ToNat myTy)))
+{-# Inline [0] getIndex #-}
+
+
+
+-- | Given some index structure @x@, return the dimensional number in
+-- @Nat@s.
+
+type family ToNat x :: Nat
+
+type instance ToNat Z       = 0
+type instance ToNat (is:.i) = ToNat is + 1
+type instance ToNat (RunningIndex Z) = 0
+type instance ToNat (RunningIndex (is:.i)) = ToNat (RunningIndex is) + 1
+
+
+
+{-
+
+testggg :: (Z:.Int:.Char) -> Int
+testggg ab = getIndex ab (Proxy :: Proxy (Z:.Int)) --  (Z:.(3::Int))
+{-# NoInline testggg #-}
+
+-}
+
diff --git a/ADP/Fusion/PointL.hs b/ADP/Fusion/PointL.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/PointL.hs
@@ -0,0 +1,33 @@
+
+-- | This exports everything needed for sequence-based alignment style
+-- algorithms.
+--
+-- Here are some notes on implementation of the Inside and Outside 
+--
+-- X_j     -> S_{j-1} X_{j-1} c_j
+-- Y_{j-1} -> S_?     X_j     c_j
+-- Y_j     -> S_{j+1} X_{j+1} c_{j+1}
+
+module ADP.Fusion.PointL
+  ( module ADP.Fusion.Core
+  , module ADP.Fusion.PointL.Core
+  , module ADP.Fusion.PointL.SynVar.Indices
+--  , module ADP.Fusion.PointL.SynVar.Recursive
+  , module ADP.Fusion.PointL.Term.Chr
+  , module ADP.Fusion.PointL.Term.Deletion
+  , module ADP.Fusion.PointL.Term.Epsilon
+  , module ADP.Fusion.PointL.Term.MultiChr
+  , module ADP.Fusion.PointL.Term.Str
+  ) where
+
+import ADP.Fusion.Core
+
+import ADP.Fusion.PointL.Core
+import ADP.Fusion.PointL.SynVar.Indices
+--import ADP.Fusion.PointL.SynVar.Recursive
+import ADP.Fusion.PointL.Term.Chr
+import ADP.Fusion.PointL.Term.Deletion
+import ADP.Fusion.PointL.Term.Epsilon
+import ADP.Fusion.PointL.Term.MultiChr
+import ADP.Fusion.PointL.Term.Str
+
diff --git a/ADP/Fusion/PointL/Core.hs b/ADP/Fusion/PointL/Core.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/PointL/Core.hs
@@ -0,0 +1,191 @@
+
+{-# Language MagicHash #-}
+
+module ADP.Fusion.PointL.Core where
+
+import GHC.Generics (Generic, Generic1)
+import Control.DeepSeq
+import Data.Proxy
+import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..))
+import Debug.Trace
+import Prelude hiding (map,filter)
+import GHC.Exts
+import GHC.TypeLits
+
+import Data.PrimitiveArray hiding (map)
+
+import ADP.Fusion.Core.Classes
+import ADP.Fusion.Core.Multi
+
+
+
+-- * Contexts, and running indices.
+
+type instance InitialContext (PointL I) = IStatic 0
+
+type instance InitialContext (PointL O) = OStatic 0
+
+type instance InitialContext (PointL C) = Complement
+
+newtype instance RunningIndex (PointL I) = RiPlI Int
+  deriving (Generic)
+
+deriving instance NFData (RunningIndex (PointL I))
+
+data instance RunningIndex (PointL O) = RiPlO !Int !Int
+  deriving (Generic)
+
+newtype instance RunningIndex (PointL C) = RiPlC Int
+  deriving (Generic)
+
+
+
+-- * Inside
+
+-- ** Single-tape
+--
+-- TODO should IStatic do these additional control of @I <=# d@? cf. Epsilon Local.
+
+instance
+  ( Monad m
+  , KnownNat d
+  )
+  ⇒ MkStream m (IStatic d) S (PointL I) where
+  mkStream Proxy S grd (LtPointL (I# u)) (PointL (I# i))
+    = staticCheck# ( grd `andI#` (i >=# 0#) `andI#` (i <=# d) `andI#` (i <=# u) )
+    . singleton . ElmS $ RiPlI 0
+    where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d)
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad m
+  , KnownNat d
+  )
+  ⇒ MkStream m (IVariable d) S (PointL I) where
+  mkStream Proxy S grd (LtPointL (I# u)) (PointL (I# i))
+    = staticCheck# (grd `andI#` (i >=# 0#) `andI#` (i <=# u) )
+    . singleton . ElmS $ RiPlI 0
+  {-# Inline mkStream #-}
+
+-- ** Multi-tape
+
+instance
+  ( Monad m
+  , MkStream m ps S is
+  , KnownNat d
+  ) ⇒ MkStream m (ps:.IStatic d) S (is:.PointL I) where
+  mkStream Proxy S grd (lus:..LtPointL (I# u)) (is:.PointL (I# i))
+    = map (\(ElmS e) -> ElmS $ e :.: RiPlI 0)
+    $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#) `andI#` (i <=# d) `andI#` (i <=# u)) lus is
+    --    $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#)) lus is
+    -- NOTE we should optimize which parameters are actually required, the gain is about 10% on the
+    -- NeedlemanWunsch algorithm
+    where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d)
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad m
+  , MkStream m ps S is
+  , KnownNat d
+  ) ⇒ MkStream m (ps:.IVariable d) S (is:.PointL I) where
+  mkStream Proxy S grd (lus:..LtPointL (I# u)) (is:.PointL (I# i))
+    = map (\(ElmS e) -> ElmS $ e :.: RiPlI 0)
+    $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#) `andI#` (i <=# u)) lus is
+    --    $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#)) lus is
+  {-# Inline mkStream #-}
+
+
+
+-- * Outside
+
+-- ** Single-tape
+
+instance
+  ( Monad m
+  , KnownNat d
+  ) ⇒ MkStream m (OStatic d) S (PointL O) where
+  mkStream Proxy S grd (LtPointL (I# u)) (PointL (I# i))
+    = staticCheck# (grd `andI#` (i >=# 0#) `andI#` (i +# d ==# u))
+    -- ???  `andI#` (u ==# i)
+    . singleton . ElmS $ RiPlO (I# i) (I# (i +# d))
+    where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d)
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad m
+  , KnownNat d
+  ) ⇒ MkStream m (OFirstLeft d) S (PointL O) where
+  mkStream Proxy s grd (LtPointL (I# u)) (PointL (I# i))
+    = staticCheck# (grd `andI#` (i >=# 0#) `andI#` (i +# d <=# u))
+    . singleton . ElmS $ RiPlO (I# i) (I# (i +# d))
+    where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d)
+  {-# Inline mkStream #-}
+
+-- ** Multi-tape
+
+instance
+  ( Monad m
+  , MkStream m ps S is
+  , KnownNat d
+  ) ⇒ MkStream m (ps:.OStatic d) S (is:.PointL O) where
+  mkStream Proxy S grd (lus:..LtPointL (I# u)) (is:.PointL (I# i))
+    = map (\(ElmS zi) -> ElmS $ zi :.: RiPlO (I# i) (I# (i +# d)))
+    -- ???  `andI#` (u ==# i)
+    $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#) `andI#` (i +# d ==# u)) lus is
+    where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d)
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad m
+  , MkStream m ps S is
+  , KnownNat d
+  ) ⇒ MkStream m (ps:.OFirstLeft d) S (is:.PointL O) where
+  mkStream Proxy S grd (lus:..LtPointL (I# u)) (is:.PointL (I# i))
+    = map (\(ElmS zi) -> ElmS $ zi :.: RiPlO (I# i) (I# (i +# d)))
+    $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#) `andI#` (i +# d <=# u)) lus is
+    where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d)
+  {-# Inline mkStream #-}
+
+
+
+-- * Complemented
+
+-- ** Single-tape
+
+instance
+  ( Monad m
+  ) ⇒ MkStream m Complement S (PointL C) where
+  mkStream Proxy S grd (LtPointL (I# u)) (PointL (I# i))
+    = error "write me" -- staticCheck# (grd `andI#` (i >=# 0#) `andI#` (i <=# u)) . singleton . ElmS $ RiPlC (I# i)
+  {-# Inline mkStream #-}
+
+-- ** Multi-tape
+
+instance
+  ( Monad m
+  , MkStream m ps S is
+  ) ⇒ MkStream m (ps:.Complement) S (is:.PointL C) where
+  mkStream Proxy S grd (lus:..LtPointL (I# u)) (is:.PointL (I# i))
+    = error "write me"
+    -- -- = map (\(ElmS zi) → ElmS $ zi :.: RiPlC (I# i))
+    -- -- $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#) `andI#` (i <=# u)) lus is
+  {-# Inline mkStream #-}
+
+
+
+-- * Table index modification
+
+instance (MinSize minSize) ⇒ TableStaticVar pos minSize u (PointL I) where
+  -- NOTE this code used to destroy fusion. If we inline tableStreamIndex
+  -- very late (after 'mkStream', probably) then everything works out.
+  tableStreamIndex Proxy minSz _upperBound (PointL j) = PointL $ j - minSize minSz
+  {-# INLINE [0] tableStreamIndex #-}
+
+instance (MinSize minSize) ⇒ TableStaticVar pos minSize u (PointL O) where
+  tableStreamIndex Proxy minSz _upperBound (PointL j) = PointL $ j - minSize minSz
+  {-# INLINE [0] tableStreamIndex #-}
+
+instance (MinSize minSize) ⇒ TableStaticVar pos minSize u (PointL C) where
+  tableStreamIndex Proxy minSz _upperBound (PointL k) = PointL $ k - minSize minSz
+  {-# INLINE [0] tableStreamIndex #-}
+
diff --git a/ADP/Fusion/PointL/SynVar/Indices.hs b/ADP/Fusion/PointL/SynVar/Indices.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/PointL/SynVar/Indices.hs
@@ -0,0 +1,139 @@
+
+-- | Index movement for syntactic variables in linear @PointL@ grammars.
+--
+-- Syntactic variables for @PointL@ indices can be both, static and variable.
+-- Static is the default, whenever we have @X -> X a@ where @a@ is a character
+-- or similar. However, we can expect to see @a@ as a string as well. Then, @X@
+-- on the r.h.s. is variable.
+
+module ADP.Fusion.PointL.SynVar.Indices where
+
+import Data.Proxy
+import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..),flatten)
+import Data.Vector.Fusion.Util (delay_inline)
+import Debug.Trace
+import Prelude hiding (map,head,mapM)
+
+import Data.PrimitiveArray hiding (map)
+
+import ADP.Fusion.Core
+import ADP.Fusion.Core.SynVar.Indices
+import ADP.Fusion.PointL.Core
+
+
+
+-- * type function for the type of the left position
+
+-- ** Inside
+
+type instance LeftPosTy (IStatic d) (TwITbl b s m arr EmptyOk (PointL I) x) (PointL I) = IVariable d
+type instance LeftPosTy (IStatic d) (TwITblBt b s arr EmptyOk (PointL I) x mB mF r) (PointL I) = IVariable d
+
+type instance LeftPosTy (IVariable d) (TwITbl b s m arr EmptyOk (PointL I) x) (PointL I) = IVariable d
+type instance LeftPosTy (IVariable d) (TwITblBt b s arr EmptyOk (PointL I) x mB mF r) (PointL I) = IVariable d
+
+-- ** Outside
+
+type instance LeftPosTy (OStatic d) (TwITbl b s m arr EmptyOk (PointL O) x) (PointL O) = OFirstLeft d
+type instance LeftPosTy (OStatic d) (TwITblBt b s arr EmptyOk (PointL O) x mB mF r) (PointL O) = OFirstLeft d
+
+-- TODO @OLeftOf@
+
+type instance LeftPosTy (OFirstLeft d) (TwITbl b s m arr EmptyOk (PointL O) x) (PointL O) = TypeError
+  (Text "OFirstLeft is illegal for outside tables. Check your grammars for multiple Outside syntactic variable on the r.h.s!")
+type instance LeftPosTy (OFirstLeft d) (TwITblBt b s arr EmptyOk (PointL O) x mB mF r) (PointL O) = TypeError
+  (Text "OFirstLeft is illegal for outside tables. Check your grammars for multiple Outside syntactic variable on the r.h.s!")
+
+type instance LeftPosTy (OLeftOf d) (TwITbl b s m arr EmptyOk (PointL O) x) (PointL O) = TypeError
+  (Text "OLeftOf is illegal for outside tables. Check your grammars for multiple Outside syntactic variable on the r.h.s!")
+type instance LeftPosTy (OLeftOf d) (TwITblBt s b arr EmptyOk (PointL O) x mB mF r) (PointL O) = TypeError
+  (Text "OLeftOf is illegal for outside tables. Check your grammars for multiple Outside syntactic variable on the r.h.s!")
+
+-- ** Complement. Note that @Complement@ joins inside and outside syntactic
+-- variables.
+
+type instance LeftPosTy Complement (TwITbl b s m arr EmptyOk (PointL I) x) (PointL C) = Complement
+type instance LeftPosTy Complement (TwITblBt b s arr EmptyOk (PointL I) x mB mF r) (PointL C) = Complement
+
+type instance LeftPosTy Complement (TwITbl b s m arr EmptyOk (PointL O) x) (PointL C) = Complement
+type instance LeftPosTy Complement (TwITblBt b s arr EmptyOk (PointL O) x mB mF r) (PointL C) = Complement
+
+
+
+-- * 'AddIndexDense' instances
+
+-- ** Inside
+
+instance
+  ( AddIndexDenseContext ps elm x0 i0 cs c us (PointL I) is (PointL I)
+  , MinSize c
+  )
+  ⇒ AddIndexDense (ps:.IStatic d) elm (cs:.c) (us:.PointL I) (is:.PointL I) where
+  addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i)
+    = map (\(SvS s t y') → SvS s (t:.i) (y' :.: RiPlI (fromPointL i)))
+    . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is
+  {-# Inline addIndexDenseGo #-}
+
+instance
+  ( AddIndexDenseContext ps elm x0 i0 cs c us (PointL I) is (PointL I)
+  , MinSize c
+  )
+  ⇒ AddIndexDense (ps:.IVariable d) elm (cs:.c) (us:.PointL I) (is:.PointL I) where
+  addIndexDenseGo Proxy (cs:.c) (ubs:..ub) (us:..u) (is:.PointL i)
+    = flatten mk step . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is
+    where mk svS = let RiPlI k = getIndex (getIdx $ sS svS {- sIx svS -} ) (Proxy :: PRI is (PointL I))
+                   in  return $ svS :. k
+          step (svS@(SvS s t y') :. k)
+            | k + csize > i = return $ Done
+            | otherwise     = return $ Yield (SvS s (t:.PointL k) (y' :.: RiPlI k)) (svS :. k+1)
+            where csize = minSize c
+          {-# Inline [0] mk   #-}
+          {-# Inline [0] step #-}
+  {-# Inline addIndexDenseGo #-}
+
+
+
+-- ** Outside
+
+instance
+  ( AddIndexDenseContext ps elm x0 i0 cs c us (PointL O) is (PointL O)
+  , MinSize c
+  ) ⇒ AddIndexDense (ps:.OStatic d) elm (cs:.c) (us:.PointL O) (is:.PointL O) where
+  addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i)
+    = map (\(SvS s t y') → let RiPlO oi oo = getIndex (getIdx s) (Proxy :: PRI is (PointL O))
+                           in  SvS s (t:.PointL oo) (y' :.: RiPlO oi oo) )
+    . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is
+  {-# Inline addIndexDenseGo #-}
+
+instance
+  ( AddIndexDenseContext ps elm x0 i0 cs c us (PointL O) is (PointL O)
+  , MinSize c
+  ) ⇒ AddIndexDense (ps:.ORightOf d) elm (cs:.c) (us:.PointL O) (is:.PointL O) where
+  addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i)
+    = map (\(SvS s t y') → let RiPlO oi oo = getIndex (getIdx s) (Proxy :: PRI is (PointL O))
+                           in  SvS s (t:.PointL oo) (y' :.: RiPlO oi oo) )
+    . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is
+  {-# Inline addIndexDenseGo #-}
+
+
+
+-- ** Complement
+
+instance
+  ( AddIndexDenseContext ps elm x0 i0 cs c us (PointL I) is (PointL C)
+  ) ⇒ AddIndexDense (ps:.Complement) elm (cs:.c) (us:.PointL I) (is:.PointL C) where
+  addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i)
+    = map (\(SvS s t y) → let RiPlC k = getIndex (getIdx s) (Proxy :: PRI is (PointL C))
+                          in  SvS s (t:.PointL k) (y :.: RiPlC k) )
+    . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is
+  {-# Inline addIndexDenseGo #-}
+
+instance
+  ( AddIndexDenseContext ps elm x0 i0 cs c us (PointL O) is (PointL C)
+  ) ⇒ AddIndexDense (ps:.Complement) elm (cs:.c) (us:.PointL O) (is:.PointL C) where
+  addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i)
+    = map (\(SvS s t y) → let RiPlC k = getIndex (getIdx s) (Proxy :: PRI is (PointL C))
+                          in  SvS s (t:.PointL k) (y:.:RiPlC k) )
+    . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is
+  {-# Inline addIndexDenseGo #-}
+
diff --git a/ADP/Fusion/PointL/Term/Chr.hs b/ADP/Fusion/PointL/Term/Chr.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/PointL/Term/Chr.hs
@@ -0,0 +1,81 @@
+
+module ADP.Fusion.PointL.Term.Chr where
+
+import           Data.Proxy
+import           Data.Strict.Tuple
+import           Debug.Trace
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+import qualified Data.Vector.Generic as VG
+import           GHC.Exts
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Core
+import           ADP.Fusion.Core.Term.Chr
+import           ADP.Fusion.PointL.Core
+
+
+
+type instance LeftPosTy (IStatic d) (Chr r x) (PointL I) = IStatic d
+--type instance LeftPosTy (IVariable d) (Chr r x) (PointL I) = IVariable d
+
+type instance LeftPosTy (OStatic d) (Chr r x) (PointL O) = OStatic (d+1)
+
+-- | First try in getting this right with a @termStream@.
+--
+-- TODO use @PointL i@ since this is probably the same for all single-tape
+-- instances with @ElmChr@.
+--
+-- TODO it might even be possible to auto-generate this code via TH.
+
+instance
+  forall pos posLeft m ls r x i
+  . ( TermStream m (Z:.pos) (TermSymbol M (Chr r x)) (Elm (Term1 (Elm ls (PointL i))) (Z :. PointL i)) (Z:.PointL i)
+    , posLeft ~ LeftPosTy pos (Chr r x) (PointL i)
+    , TermStaticVar pos (Chr r x) (PointL i)
+    , MkStream m posLeft ls (PointL i)
+    )
+  ⇒ MkStream m pos (ls :!: Chr r x) (PointL i) where
+  mkStream pos (ls :!: Chr f xs) grd us is
+    = S.map (\(ss,ee,ii) -> ElmChr ee ii ss) -- recover ElmChr
+    . addTermStream1 pos (Chr f xs) us is
+    $ mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos (Chr f xs) us is grd) us (termStreamIndex pos (Chr f xs) is)
+  {-# Inline mkStream #-}
+
+
+-- | 
+
+instance
+  ( TermStreamContext m ps ts s x0 i0 is (PointL I)
+  ) => TermStream m (ps:.IStatic d) (TermSymbol ts (Chr r x)) s (is:.PointL I) where
+  termStream Proxy (ts:|Chr f xs) (us:..LtPointL u) (is:.PointL i)
+    -- NOTE changing from @f xs (i-1)@ to @f xs $! i-1@, forcing @i-1@ first,
+    -- yielding 50% better performance in Needleman-Wunsch
+    = S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:. (f xs $! i-1)))
+    . termStream (Proxy ∷ Proxy ps) ts us is
+  {-# Inline termStream #-}
+
+instance
+  ( TermStreamContext m ps ts s x0 i0 is (PointL O)
+  ) => TermStream m (ps:.OStatic d) (TermSymbol ts (Chr r x)) s (is:.PointL O) where
+  termStream Proxy (ts:|Chr f xs) (us:..LtPointL u) (is:.PointL i)
+    = S.map (\(TState s ii ee) ->
+                let RiPlO k o = getIndex (getIdx s) (Proxy :: PRI is (PointL O))
+                in  TState s (ii:.: RiPlO (k+1) o) (ee:.f xs k))
+    . termStream (Proxy ∷ Proxy ps) ts us is
+  {-# Inline termStream #-}
+
+
+
+instance TermStaticVar (IStatic d) (Chr r x) (PointL I) where
+  termStreamIndex Proxy (Chr f x) (PointL j) = PointL $! j-1
+  termStaticCheck Proxy (Chr f x) _ (PointL j) grd = grd
+  {-# Inline [0] termStreamIndex #-}
+  {-# Inline [0] termStaticCheck #-}
+
+instance TermStaticVar (OStatic d) (Chr r x) (PointL O) where
+  termStreamIndex Proxy (Chr f x) (PointL j) = PointL $ j
+  termStaticCheck Proxy (Chr f x) _ (PointL j) grd = grd
+  {-# Inline [0] termStreamIndex #-}
+  {-# Inline [0] termStaticCheck #-}
+
diff --git a/ADP/Fusion/PointL/Term/Deletion.hs b/ADP/Fusion/PointL/Term/Deletion.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/PointL/Term/Deletion.hs
@@ -0,0 +1,85 @@
+
+module ADP.Fusion.PointL.Term.Deletion where
+
+import           Data.Proxy
+import           Data.Strict.Tuple
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+import           GHC.Exts
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Core
+import           ADP.Fusion.Core.Term.Deletion
+import           ADP.Fusion.PointL.Core
+
+
+
+type instance LeftPosTy (IStatic   d) Deletion (PointL I) = IStatic d
+type instance LeftPosTy (IVariable d) Deletion (PointL I) = IVariable d
+
+type instance LeftPosTy (OStatic d) Deletion (PointL O) = OStatic d
+
+instance
+  forall pos posLeft m ls i
+  . ( TermStream m (Z:.pos) (TermSymbol M Deletion) (Elm (Term1 (Elm ls (PointL i))) (Z :. PointL i)) (Z:.PointL i)
+    , posLeft ~ LeftPosTy pos Deletion (PointL i)
+    , TermStaticVar pos Deletion (PointL i)
+    , MkStream m posLeft ls (PointL i)
+    )
+  ⇒ MkStream m pos (ls :!: Deletion) (PointL i) where
+  mkStream pos (ls :!: Deletion) grd us is
+    = S.map (\(ss,ee,ii) -> ElmDeletion ii ss)
+    . addTermStream1 pos Deletion us is
+    $ mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos Deletion us is grd) us (termStreamIndex pos Deletion is)
+  {-# Inline mkStream #-}
+
+
+
+instance
+  ( TermStreamContext m ps ts s x0 i0 is (PointL I)
+  )
+  ⇒ TermStream m (ps:.IStatic d) (TermSymbol ts Deletion) s (is:.PointL I) where
+  termStream Proxy (ts:|Deletion) (us:..LtPointL u) (is:.PointL i)
+    = S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:.()))
+    . termStream (Proxy ∷ Proxy ps) ts us is
+  {-# Inline termStream #-}
+
+instance
+  ( TermStreamContext m ps ts s x0 i0 is (PointL I)
+  )
+  ⇒ TermStream m (ps:.IVariable d) (TermSymbol ts Deletion) s (is:.PointL I) where
+  termStream Proxy (ts:|Deletion) (us:..LtPointL u) (is:.PointL i)
+    = S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:.()))
+    . termStream (Proxy ∷ Proxy ps) ts us is
+  {-# Inline termStream #-}
+
+instance
+  ( TermStreamContext m ps ts s x0 i0 is (PointL O)
+  ) => TermStream m (ps:.OStatic d) (TermSymbol ts Deletion) s (is:.PointL O) where
+  termStream Proxy (ts:|Deletion) (us:..LtPointL u) (is:.PointL i)
+    = S.map (\(TState s ii ee) ->
+                let io = getIndex (getIdx s) (Proxy :: PRI is (PointL O))
+                in  TState s (ii:.: io) (ee:.()))
+    . termStream (Proxy ∷ Proxy ps) ts us is
+  {-# Inline termStream #-}
+
+
+
+instance TermStaticVar (IStatic d) Deletion (PointL I) where
+  termStreamIndex Proxy Deletion (PointL j) = PointL j
+  termStaticCheck Proxy Deletion _ (PointL j) grd = grd
+  {-# Inline [0] termStreamIndex #-}
+  {-# Inline [0] termStaticCheck #-}
+
+instance TermStaticVar (IVariable d) Deletion (PointL I) where
+  termStreamIndex Proxy Deletion (PointL j) = PointL j
+  termStaticCheck Proxy Deletion _ (PointL j) grd = grd
+  {-# Inline [0] termStreamIndex #-}
+  {-# Inline [0] termStaticCheck #-}
+
+instance TermStaticVar oAny Deletion (PointL O) where
+  termStreamIndex Proxy Deletion (PointL j) = PointL j
+  termStaticCheck Proxy Deletion _ (PointL j) grd = grd
+  {-# Inline [0] termStreamIndex #-}
+  {-# Inline [0] termStaticCheck #-}
+
diff --git a/ADP/Fusion/PointL/Term/Epsilon.hs b/ADP/Fusion/PointL/Term/Epsilon.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/PointL/Term/Epsilon.hs
@@ -0,0 +1,119 @@
+
+-- | Rules of the type @X → ε@ denote termination of parsing if @X@ is empty.
+
+module ADP.Fusion.PointL.Term.Epsilon where
+
+import           Data.Proxy
+import           Data.Strict.Tuple
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+import           GHC.Exts
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Core
+import           ADP.Fusion.Core.Term.Epsilon
+import           ADP.Fusion.PointL.Core
+
+
+
+type instance LeftPosTy (IStatic d) (Epsilon Global) (PointL I) = IStatic d
+type instance LeftPosTy (IStatic d) (Epsilon Local) (PointL I) = IVariable d  -- to actually allow local epsilons to work, IStatic does additional static controls
+--type instance LeftPosTy (IVariable d) Epsilon (PointL I) = IVariable d
+
+type instance LeftPosTy (OStatic d) (Epsilon Global) (PointL O) = OStatic d
+
+instance
+  forall pos posLeft m ls i lg
+  . ( TermStream m (Z:.pos) (TermSymbol M (Epsilon lg)) (Elm (Term1 (Elm ls (PointL i))) (Z :. PointL i)) (Z:.PointL i)
+    , posLeft ~ LeftPosTy pos (Epsilon lg) (PointL i)
+    , TermStaticVar pos (Epsilon lg) (PointL i)
+    , MkStream m posLeft ls (PointL i)
+    )
+  ⇒ MkStream m pos (ls :!: (Epsilon lg)) (PointL i) where
+  mkStream Proxy (ls :!: Epsilon) grd us is
+    = S.map (\(ss,ee,ii) -> ElmEpsilon ii ss)
+    . addTermStream1 (Proxy ∷ Proxy pos) (Epsilon @lg) us is
+    $ mkStream (Proxy ∷ Proxy posLeft)
+               ls
+               (termStaticCheck (Proxy ∷ Proxy pos) (Epsilon @lg) us is grd)
+               us
+               (termStreamIndex (Proxy ∷ Proxy pos) (Epsilon @lg) is)
+  {-# Inline mkStream #-}
+
+
+instance
+  ( TermStreamContext m ps ts s x0 i0 is (PointL I)
+  )
+  ⇒ TermStream m (ps:.IStatic d) (TermSymbol ts (Epsilon lg)) s (is:.PointL I) where
+  termStream Proxy (ts:|Epsilon) (us:..LtPointL u) (is:.PointL i)
+    = S.map (\(TState s ii ee) ->
+              let RiPlI k = getIndex (getIdx s) (Proxy :: PRI is (PointL I))
+              in  TState s (ii:.:RiPlI k) (ee:.()))
+    . termStream (Proxy ∷ Proxy ps) ts us is
+  {-# Inline termStream #-}
+
+{-
+instance
+  ( TermStreamContext m ps ts s x0 i0 is (PointL I)
+  )
+  ⇒ TermStream m (ps:.IVariable d) (TermSymbol ts Epsilon) s (is:.PointL I) where
+  termStream Proxy (ts:|Epsilon) (us:..LtPointL u) (is:.PointL i)
+    = S.map (\(TState s ii ee) ->
+              let RiPlI k = getIndex (getIdx s) (Proxy :: PRI is (PointL I))
+              in  TState s (ii:.:RiPlI k) (ee:.()))
+    . termStream (Proxy ∷ Proxy ps) ts us is
+  {-# Inline termStream #-}
+-}
+
+instance
+  ( TermStreamContext m ps ts s x0 i0 is (PointL O)
+  ) => TermStream m (ps:.OStatic d) (TermSymbol ts (Epsilon lg)) s (is:.PointL O) where
+  termStream Proxy (ts:|Epsilon) (us:..LtPointL u) (is:.PointL i)
+    = S.map (\(TState s ii ee) ->
+                let io = getIndex (getIdx s) (Proxy :: PRI is (PointL O))
+                in  TState s (ii:.:io) (ee:.()))
+    . termStream (Proxy ∷ Proxy ps) ts us is
+  {-# Inline termStream #-}
+
+-- | We assume that @ε / Epsilon@ is ever only the single symbol (maybe apart
+-- from @- / Deletion@) on a tape. Hence The instance is only active in
+-- @IStatic 0@ cases.
+
+instance TermStaticVar (IStatic 0) (Epsilon Global) (PointL I) where
+  termStreamIndex Proxy Epsilon (PointL i     ) = PointL i
+  termStaticCheck Proxy Epsilon _ (PointL (I# i)) grd = (i ==# 0#) `andI#` grd
+  {-# Inline [0] termStreamIndex #-}
+  {-# Inline [0] termStaticCheck #-}
+
+instance TermStaticVar (IStatic 0) (Epsilon Local) (PointL I) where
+  termStreamIndex Proxy Epsilon (PointL i     ) = PointL i
+  -- | Local epsilons are *always* possible.
+  termStaticCheck Proxy Epsilon _ (PointL (I# i)) grd = grd
+  {-# Inline termStreamIndex #-}
+  {-# Inline termStaticCheck #-}
+
+instance TermStaticVar (OStatic 0) (Epsilon Global) (PointL O) where
+  termStreamIndex Proxy Epsilon (PointL i     ) = PointL i
+  -- |
+  --
+  -- TODO Consider this as a potential bug: we do *not* check that the upper
+  -- bound @us@ (which we not even hand over to termStaticCheck but should) is
+  -- equal to the current index @i@. HERE this ends up not being a bug because
+  -- @Epsilon@ keeps the positional system at @OStatic@ and does not move to
+  -- @ORightOf@ or anything, and in correct epsilon rules, everything is fine.
+  --
+  -- We even end up being correct with @X -> whatever epsilon@ because epsilon
+  -- is neutral ...
+  --
+  -- TODO But we should probably statically assert that epsilon is the only
+  -- symbol on the r.h.s. of whatever we write ...
+  termStaticCheck Proxy Epsilon (LtPointL (I# u)) (PointL (I# i)) grd = (u ==# i) `andI#` grd
+  {-# Inline [0] termStreamIndex #-}
+  {-# Inline [0] termStaticCheck #-}
+
+instance TermStaticVar (OStatic 0) (Epsilon Local) (PointL O) where
+  termStreamIndex Proxy Epsilon (PointL i     ) = PointL i
+  termStaticCheck Proxy Epsilon (LtPointL (I# u)) (PointL (I# i)) grd = grd
+  {-# Inline [0] termStreamIndex #-}
+  {-# Inline [0] termStaticCheck #-}
+
diff --git a/ADP/Fusion/PointL/Term/MultiChr.hs b/ADP/Fusion/PointL/Term/MultiChr.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/PointL/Term/MultiChr.hs
@@ -0,0 +1,85 @@
+
+module ADP.Fusion.PointL.Term.MultiChr where
+
+import           Data.Proxy
+import           Data.Strict.Tuple
+import           Debug.Trace
+import           GHC.Exts
+--import           GHC.TypeNats
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+import qualified Data.Vector.Generic as VG
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Core
+import           ADP.Fusion.Core.Term.MultiChr
+import           ADP.Fusion.PointL.Core
+
+
+
+type instance LeftPosTy (IStatic d) (MultiChr c v x) (PointL I) = IStatic d
+--type instance LeftPosTy (IVariable d) (Chr r x) (PointL I) = IVariable d
+
+type instance LeftPosTy (OStatic d) (MultiChr c v x) (PointL O) = OStatic (d + c)
+
+-- | First try in getting this right with a @termStream@.
+--
+-- TODO use @PointL i@ since this is probably the same for all single-tape
+-- instances with @ElmChr@.
+--
+-- TODO it might even be possible to auto-generate this code via TH.
+
+instance
+  forall pos posLeft m ls c v x i
+  . ( TermStream m (Z:.pos) (TermSymbol M (MultiChr c v x)) (Elm (Term1 (Elm ls (PointL i))) (Z :. PointL i)) (Z:.PointL i)
+    , posLeft ~ LeftPosTy pos (MultiChr c v x) (PointL i)
+    , TermStaticVar pos (MultiChr c v x) (PointL i)
+    , MkStream m posLeft ls (PointL i)
+    )
+  ⇒ MkStream m pos (ls :!: MultiChr c v x) (PointL i) where
+  mkStream pos (ls :!: MultiChr xs) grd us is
+    = S.map (\(ss,ee,ii) -> ElmMultiChr ee ii ss) -- recover ElmChr
+    . addTermStream1 pos (MultiChr @v @x @c xs) us is
+    $ mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos (MultiChr @v @x @c xs) us is grd) us (termStreamIndex pos (MultiChr @v @x @c xs) is)
+  {-# Inline mkStream #-}
+
+
+-- | 
+
+instance
+  ( TermStreamContext m ps ts s x0 i0 is (PointL I)
+  , KnownNat c
+  ) => TermStream m (ps:.IStatic d) (TermSymbol ts (MultiChr c v x)) s (is:.PointL I) where
+  termStream Proxy (ts:|MultiChr xs) (us:..LtPointL u) (is:.PointL i)
+    = let !c = fromIntegral $ natVal (Proxy ∷ Proxy c) in
+      S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:. VG.unsafeSlice (i-c) c xs))
+    . termStream (Proxy ∷ Proxy ps) ts us is
+  {-# Inline termStream #-}
+
+instance
+  ( TermStreamContext m ps ts s x0 i0 is (PointL O)
+  , KnownNat c
+  ) => TermStream m (ps:.OStatic d) (TermSymbol ts (MultiChr c v x)) s (is:.PointL O) where
+  termStream Proxy (ts:|MultiChr xs) (us:..LtPointL u) (is:.PointL i)
+    = S.map (\(TState s ii ee) ->
+                let RiPlO k o = getIndex (getIdx s) (Proxy :: PRI is (PointL O))
+                    c = fromIntegral $ natVal (Proxy ∷ Proxy c)
+                in  TState s (ii:.: RiPlO (k+c) o) (ee:.VG.unsafeSlice k c xs))
+    . termStream (Proxy ∷ Proxy ps) ts us is
+  {-# Inline termStream #-}
+
+
+
+instance (KnownNat c) ⇒ TermStaticVar (IStatic d) (MultiChr c v x) (PointL I) where
+  termStreamIndex Proxy (MultiChr x) (PointL j) = PointL $ j-(fromIntegral $ natVal (Proxy ∷ Proxy c))
+  termStaticCheck Proxy (MultiChr x) _ (PointL j) grd = grd
+  {-# Inline [0] termStreamIndex #-}
+  {-# Inline [0] termStaticCheck #-}
+
+instance TermStaticVar (OStatic d) (MultiChr c v x) (PointL O) where
+  termStreamIndex Proxy (MultiChr x) (PointL j) = PointL $ j
+  -- | TODO check if @c@ to the right goes out of bounds?
+  termStaticCheck Proxy (MultiChr x) _ (PointL j) grd = grd
+  {-# Inline [0] termStreamIndex #-}
+  {-# Inline [0] termStaticCheck #-}
+
diff --git a/ADP/Fusion/PointL/Term/Str.hs b/ADP/Fusion/PointL/Term/Str.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/PointL/Term/Str.hs
@@ -0,0 +1,87 @@
+
+module ADP.Fusion.PointL.Term.Str where
+
+import           Data.Proxy
+import           Data.Strict.Tuple
+import           Debug.Trace
+import           GHC.Exts
+--import           GHC.TypeNats
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+import qualified Data.Vector.Generic as VG
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Core
+import           ADP.Fusion.Core.Term.Str
+import           ADP.Fusion.PointL.Core
+
+
+
+-- minSz done via TermStaticVar ?!
+
+type instance LeftPosTy (IStatic   d) (Str linked minSz maxSz v x) (PointL I) = IVariable d
+type instance LeftPosTy (IVariable d) (Str linked minSz maxSz v x) (PointL I) = IVariable d
+
+{-
+type instance LeftPosTy (OStatic d) (Chr r x) (PointL O) = OStatic (d+1)
+-}
+
+-- | 
+
+instance
+  forall pos posLeft m ls linked minSz maxSz v x i
+  . ( TermStream m (Z:.pos) (TermSymbol M (Str linked minSz maxSz v x))
+                 (Elm (Term1 (Elm ls (PointL i))) (Z :. PointL i)) (Z:.PointL i)
+    , posLeft ~ LeftPosTy pos (Str linked minSz maxSz v x) (PointL i)
+    , TermStaticVar pos (Str linked minSz maxSz v x) (PointL i)
+    , MkStream m posLeft ls (PointL i)
+    )
+  ⇒ MkStream m pos (ls :!: Str linked minSz maxSz v x) (PointL i) where
+  mkStream pos (ls :!: Str xs) grd us is
+    = S.map (\(ss,ee,ii) -> ElmStr ee ii ss) -- recover ElmChr
+    . addTermStream1 pos (Str @v @x @linked @minSz @maxSz xs) us is
+    $ mkStream (Proxy ∷ Proxy posLeft) ls
+               (termStaticCheck pos (Str @v @x @linked @minSz @maxSz xs) us is grd)
+               us (termStreamIndex pos (Str @v @x @linked @minSz @maxSz xs) is)
+  {-# Inline mkStream #-}
+
+-- | Note that the @minSz@ should automatically work out due to the encoding in
+-- @d@.
+
+instance
+  ( TermStreamContext m ps ts s x0 i0 is (PointL I)
+  ) ⇒ TermStream m (ps:.IStatic d) (TermSymbol ts (Str Nothing minSz Nothing v x)) s (is:.PointL I) where
+  termStream Proxy (ts:|Str xs) (us:..LtPointL u) (is:.PointL i)
+    = S.map (\(TState s ii ee) →
+                let RiPlI k = getIndex (getIdx s) (Proxy ∷ PRI is (PointL I))
+                in  TState s (ii:.:RiPlI i) (ee:.VG.slice k (i-k) xs))
+    . termStream (Proxy ∷ Proxy ps) ts us is
+  {-# Inline termStream #-}
+
+{-
+instance
+  ( TermStreamContext m ps ts s x0 i0 is (PointL O)
+  ) => TermStream m (ps:.OStatic d) (TermSymbol ts (Chr r x)) s (is:.PointL O) where
+  termStream Proxy (ts:|Chr f xs) (us:..LtPointL u) (is:.PointL i)
+    = S.map (\(TState s ii ee) ->
+                let RiPlO k o = getIndex (getIdx s) (Proxy :: PRI is (PointL O))
+                in  TState s (ii:.: RiPlO (k+1) o) (ee:.f xs k))
+    . termStream (Proxy ∷ Proxy ps) ts us is
+  {-# Inline termStream #-}
+-}
+
+instance (KnownNat minSz)
+  ⇒ TermStaticVar (IStatic d) (Str Nothing minSz Nothing v x) (PointL I) where
+  termStreamIndex Proxy (Str xs) (PointL j) = PointL $ j - fromIntegral (natVal (Proxy ∷ Proxy minSz))
+  termStaticCheck Proxy (Str xs) _ (PointL j) grd = grd
+  {-# Inline [0] termStreamIndex #-}
+  {-# Inline [0] termStaticCheck #-}
+
+{-
+instance TermStaticVar (OStatic d) (Chr r x) (PointL O) where
+  termStreamIndex Proxy (Chr f x) (PointL j) = PointL $ j
+  termStaticCheck Proxy (Chr f x) (PointL j) = 1#
+  {-# Inline [0] termStreamIndex #-}
+  {-# Inline [0] termStaticCheck #-}
+-}
+
diff --git a/ADP/Fusion/PointL/Term/Switch.hs b/ADP/Fusion/PointL/Term/Switch.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/PointL/Term/Switch.hs
@@ -0,0 +1,75 @@
+
+module ADP.Fusion.PointL.Term.Switch where
+
+import           Data.Proxy
+import           Data.Strict.Tuple
+import           Debug.Trace
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+import qualified Data.Vector.Generic as VG
+import           GHC.Exts
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Core
+import           ADP.Fusion.Core.Term.Switch
+import           ADP.Fusion.PointL.Core
+
+
+
+type instance LeftPosTy (IStatic   d) Switch (PointL I) = IStatic   d
+type instance LeftPosTy (IVariable d) Switch (PointL I) = IVariable d
+
+type instance LeftPosTy (OStatic d) Switch (PointL O) = OStatic d
+
+-- | 
+
+instance
+  forall pos posLeft m ls r x i
+  . ( TermStream m (Z:.pos) (TermSymbol M Switch) (Elm (Term1 (Elm ls (PointL i))) (Z :. PointL i)) (Z:.PointL i)
+    , posLeft ~ LeftPosTy pos Switch (PointL i)
+    , TermStaticVar pos Switch (PointL i)
+    , MkStream m posLeft ls (PointL i)
+    )
+  ⇒ MkStream m pos (ls :!: Switch) (PointL i) where
+  mkStream pos (ls :!: Switch s) grd us is
+    = S.map (\(ss,ee,ii) -> ElmSwitch ii ss) -- recover ElmChr
+    . addTermStream1 pos (Switch s) us is
+    $ mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos (Switch s) us is grd) us (termStreamIndex pos (Switch s) is)
+  {-# Inline mkStream #-}
+
+
+-- | 
+
+instance
+  ( TermStreamContext m ps ts s x0 i0 is (PointL I)
+  ) => TermStream m (ps:.IStatic d) (TermSymbol ts Switch) s (is:.PointL I) where
+  termStream Proxy (ts:|Switch s) (us:..LtPointL u) (is:.PointL i)
+    = S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:. ()))
+    . termStream (Proxy ∷ Proxy ps) ts us is
+  {-# Inline termStream #-}
+
+instance
+  ( TermStreamContext m ps ts s x0 i0 is (PointL O)
+  ) => TermStream m (ps:.OStatic d) (TermSymbol ts Switch) s (is:.PointL O) where
+  termStream Proxy (ts:|Switch s) (us:..LtPointL u) (is:.PointL i)
+    = S.map (\(TState s ii ee) ->
+                let ko = getIndex (getIdx s) (Proxy :: PRI is (PointL O))
+                in  TState s (ii:.:ko) (ee:.()))
+    . termStream (Proxy ∷ Proxy ps) ts us is
+  {-# Inline termStream #-}
+
+
+
+instance TermStaticVar (IStatic d) Switch (PointL I) where
+  termStreamIndex Proxy (Switch s) (PointL j) = PointL $ j
+  -- TODO is trac #15696 a problem here?
+  termStaticCheck Proxy (Switch s) _ (PointL j) grd = dataToTag# s `andI#` grd -- case s of {Enabled → grd; Disabled → 0# }
+  {-# Inline [0] termStreamIndex #-}
+  {-# Inline [0] termStaticCheck #-}
+
+instance TermStaticVar (OStatic d) Switch (PointL O) where
+  termStreamIndex Proxy (Switch s) (PointL j) = PointL $ j
+  termStaticCheck Proxy (Switch s) _ (PointL j) grd = case s of {Enabled → grd; Disabled → 0# }
+  {-# Inline [0] termStreamIndex #-}
+  {-# Inline [0] termStaticCheck #-}
+
diff --git a/ADP/Fusion/PointR.hs b/ADP/Fusion/PointR.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/PointR.hs
@@ -0,0 +1,29 @@
+
+-- | This exports everything needed for sequence-based alignment style
+-- algorithms.
+--
+-- Here are some notes on implementation of the Inside and Outside 
+--
+-- X_j     -> S_{j-1} X_{j-1} c_j
+-- Y_{j-1} -> S_?     X_j     c_j
+-- Y_j     -> S_{j+1} X_{j+1} c_{j+1}
+
+module ADP.Fusion.PointR
+  ( module ADP.Fusion.Core
+  , module ADP.Fusion.PointR.Core
+  , module ADP.Fusion.PointR.SynVar.Indices
+  , module ADP.Fusion.PointR.Term.Chr
+  , module ADP.Fusion.PointR.Term.Deletion
+  , module ADP.Fusion.PointR.Term.Epsilon
+  , module ADP.Fusion.PointR.Term.MultiChr
+  ) where
+
+import ADP.Fusion.Core
+
+import ADP.Fusion.PointR.Core
+import ADP.Fusion.PointR.SynVar.Indices
+import ADP.Fusion.PointR.Term.Chr
+import ADP.Fusion.PointR.Term.Deletion
+import ADP.Fusion.PointR.Term.Epsilon
+import ADP.Fusion.PointR.Term.MultiChr
+
diff --git a/ADP/Fusion/PointR/Core.hs b/ADP/Fusion/PointR/Core.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/PointR/Core.hs
@@ -0,0 +1,121 @@
+
+{-# Language MagicHash #-}
+
+module ADP.Fusion.PointR.Core where
+
+import GHC.Generics (Generic, Generic1)
+import Control.DeepSeq
+import Data.Proxy
+import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..))
+import Debug.Trace
+import Prelude hiding (map,filter)
+import GHC.Exts
+import GHC.TypeLits
+
+import Data.PrimitiveArray hiding (map)
+
+import ADP.Fusion.Core.Classes
+import ADP.Fusion.Core.Multi
+
+
+
+-- * Contexts, and running indices.
+
+type instance InitialContext (PointR I) = IStatic 0
+
+type instance InitialContext (PointR O) = OStatic 0
+
+type instance InitialContext (PointR C) = Complement
+
+newtype instance RunningIndex (PointR I) = RiPrI Int
+  deriving (Generic)
+
+deriving instance NFData (RunningIndex (PointR I))
+
+data instance RunningIndex (PointR O) = RiPrO !Int !Int
+  deriving (Generic)
+
+newtype instance RunningIndex (PointR C) = RiPrC Int
+  deriving (Generic)
+
+
+
+-- * Inside
+
+-- ** Single-tape
+
+instance
+  ( Monad m
+  , KnownNat d
+  )
+  ⇒ MkStream m (IStatic d) S (PointR I) where
+  mkStream Proxy S grd (LtPointR (I# u)) (PointR (I# i))
+    = staticCheck# ( grd `andI#` (i >=# 0#) `andI#` (i +# d ==# u) )   -- TODO include @d@ correctly: i<=d
+    . singleton . ElmS . RiPrI $ I# i
+    where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d)
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad m
+  , KnownNat d
+  )
+  ⇒ MkStream m (IVariable d) S (PointR I) where
+  mkStream Proxy S grd (LtPointR (I# u)) (PointR (I# i))
+    = staticCheck# (grd `andI#` (i >=# 0#) `andI#` (i +# d <=# u))
+    . singleton . ElmS . RiPrI $ I# i
+    where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d)
+  {-# Inline mkStream #-}
+
+
+
+-- ** Multi-tape
+
+instance
+  ( Monad m
+  , MkStream m ps S is
+  , KnownNat d
+  ) ⇒ MkStream m (ps:.IStatic d) S (is:.PointR I) where
+  mkStream Proxy S grd (lus:..LtPointR (I# u)) (is:.PointR (I# i))
+    = map (\(ElmS e) -> ElmS $ e :.: RiPrI (I# i))
+    $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#) `andI#` (i +# d ==# u)) lus is
+    where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d)
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad m
+  , MkStream m ps S is
+  , KnownNat d
+  ) ⇒ MkStream m (ps:.IVariable d) S (is:.PointR I) where
+  mkStream Proxy S grd (lus:..LtPointR (I# u)) (is:.PointR (I# i))
+    = map (\(ElmS e) -> ElmS $ e :.: RiPrI (I# i))
+    $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#) `andI#` (i +# d <=# u)) lus is
+    where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d)
+  {-# Inline mkStream #-}
+
+
+
+-- * Outside
+
+-- ** Single-tape
+
+
+
+
+-- * Complemented
+
+-- ** Single-tape
+
+
+-- ** Multi-tape
+
+
+
+
+-- * Table index modification
+
+instance (MinSize minSize) ⇒ TableStaticVar pos minSize u (PointR I) where
+  -- NOTE this code used to destroy fusion. If we inline tableStreamIndex
+  -- very late (after 'mkStream', probably) then everything works out.
+  tableStreamIndex Proxy minSz _upperBound (PointR j) = PointR $ j + minSize minSz
+  {-# INLINE [0] tableStreamIndex #-}
+
diff --git a/ADP/Fusion/PointR/SynVar/Indices.hs b/ADP/Fusion/PointR/SynVar/Indices.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/PointR/SynVar/Indices.hs
@@ -0,0 +1,44 @@
+
+-- | Index movement for syntactic variables in linear @PointL@ grammars.
+--
+-- Syntactic variables for @PointL@ indices can be both, static and variable.
+-- Static is the default, whenever we have @X -> X a@ where @a@ is a character
+-- or similar. However, we can expect to see @a@ as a string as well. Then, @X@
+-- on the r.h.s. is variable.
+
+module ADP.Fusion.PointR.SynVar.Indices where
+
+import Data.Proxy
+import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..),flatten)
+import Data.Vector.Fusion.Util (delay_inline)
+import Debug.Trace
+import Prelude hiding (map,head,mapM)
+
+import Data.PrimitiveArray hiding (map)
+
+import ADP.Fusion.Core
+import ADP.Fusion.Core.SynVar.Indices
+import ADP.Fusion.PointR.Core
+
+
+
+type instance LeftPosTy (IStatic d) (TwITbl b s m arr EmptyOk (PointR I) x) (PointR I) = IVariable d
+type instance LeftPosTy (IStatic d) (TwITblBt b s arr EmptyOk (PointR I) x mB mF r) (PointR I) = IVariable d
+
+type instance LeftPosTy (IVariable d) (TwITbl b s m arr EmptyOk (PointR I) x) (PointR I) = IVariable d
+type instance LeftPosTy (IVariable d) (TwITblBt b s arr EmptyOk (PointR I) x mB mF r) (PointR I) = IVariable d
+
+
+
+instance
+  ( AddIndexDenseContext ps elm x0 i0 cs c us (PointR I) is (PointR I)
+  , MinSize c
+  )
+  ⇒ AddIndexDense (ps:.IStatic d) elm (cs:.c) (us:.PointR I) (is:.PointR I) where
+  addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..LtPointR u) (is:.i)
+    = map (\(SvS s t y') →
+        let RiPrI k = getIndex (getIdx s) (Proxy ∷ PRI is (PointR I))
+        in  SvS s (t:.PointR k) (y' :.: RiPrI  u))
+    . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is
+  {-# Inline addIndexDenseGo #-}
+
diff --git a/ADP/Fusion/PointR/Term/Chr.hs b/ADP/Fusion/PointR/Term/Chr.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/PointR/Term/Chr.hs
@@ -0,0 +1,72 @@
+
+module ADP.Fusion.PointR.Term.Chr where
+
+import           Data.Proxy
+import           Data.Strict.Tuple
+import           Debug.Trace
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+import qualified Data.Vector.Generic as VG
+import           GHC.Exts
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Core
+import           ADP.Fusion.Core.Term.Chr
+import           ADP.Fusion.PointR.Core
+
+
+
+type instance LeftPosTy (IStatic   d) (Chr r x) (PointR I) = IStatic   (d+1)
+type instance LeftPosTy (IVariable d) (Chr r x) (PointR I) = IVariable (d+1)
+
+
+
+instance
+  forall pos posLeft m ls r x i
+  . ( TermStream m (Z:.pos) (TermSymbol M (Chr r x)) (Elm (Term1 (Elm ls (PointR i))) (Z :. PointR i)) (Z:.PointR i)
+    , posLeft ~ LeftPosTy pos (Chr r x) (PointR i)
+    , TermStaticVar pos (Chr r x) (PointR i)
+    , MkStream m posLeft ls (PointR i)
+    )
+  ⇒ MkStream m pos (ls :!: Chr r x) (PointR i) where
+  {-# Inline mkStream #-}
+  mkStream pos (ls :!: Chr f xs) grd us is
+    = S.map (\(ss,ee,ii) -> ElmChr ee ii ss)
+    . addTermStream1 pos (Chr f xs) us is
+    $ mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos (Chr f xs) us is grd) us (termStreamIndex pos (Chr f xs) is)
+
+
+instance
+  ( TermStreamContext m ps ts s x0 i0 is (PointR I)
+  ) => TermStream m (ps:.IStatic d) (TermSymbol ts (Chr r x)) s (is:.PointR I) where
+  {-# Inline termStream #-}
+  termStream Proxy (ts:|Chr f xs) (us:..LtPointR u) (is:.PointR i)
+    = S.map (\(TState s ii ee) →
+        let RiPrI k = getIndex (getIdx s) (Proxy ∷ PRI is (PointR I))
+        in  TState s (ii:.:RiPrI (k+1)) (ee:. f xs k))
+    . termStream (Proxy ∷ Proxy ps) ts us is
+
+instance
+  ( TermStreamContext m ps ts s x0 i0 is (PointR I)
+  ) => TermStream m (ps:.IVariable d) (TermSymbol ts (Chr r x)) s (is:.PointR I) where
+  {-# Inline termStream #-}
+  termStream Proxy (ts:|Chr f xs) (us:..LtPointR u) (is:.PointR i)
+    = S.map (\(TState s ii ee) ->
+        let RiPrI k = getIndex (getIdx s) (Proxy ∷ PRI is (PointR I))
+        in  TState s (ii:.:RiPrI (k+1)) (ee:. f xs k))
+    . termStream (Proxy ∷ Proxy ps) ts us is
+
+
+
+instance TermStaticVar (IStatic d) (Chr r x) (PointR I) where
+  termStreamIndex Proxy (Chr f x) (PointR j) = PointR $ j
+  termStaticCheck Proxy (Chr f x) (LtPointR _) (PointR j) grd = grd
+  {-# Inline [0] termStreamIndex #-}
+  {-# Inline [0] termStaticCheck #-}
+
+instance TermStaticVar (IVariable d) (Chr r x) (PointR I) where
+  termStreamIndex Proxy (Chr f x) (PointR j) = PointR $ j
+  termStaticCheck Proxy (Chr f x) (LtPointR _) (PointR j) grd = grd
+  {-# Inline [0] termStreamIndex #-}
+  {-# Inline [0] termStaticCheck #-}
+
diff --git a/ADP/Fusion/PointR/Term/Deletion.hs b/ADP/Fusion/PointR/Term/Deletion.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/PointR/Term/Deletion.hs
@@ -0,0 +1,69 @@
+
+module ADP.Fusion.PointR.Term.Deletion where
+
+import           Data.Proxy
+import           Data.Strict.Tuple
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+import           GHC.Exts
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Core
+import           ADP.Fusion.Core.Term.Deletion
+import           ADP.Fusion.PointR.Core
+
+
+
+type instance LeftPosTy (IStatic   d) Deletion (PointR I) = IStatic d
+type instance LeftPosTy (IVariable d) Deletion (PointR I) = IVariable d
+
+
+
+instance
+  forall pos posLeft m ls i
+  . ( TermStream m (Z:.pos) (TermSymbol M Deletion) (Elm (Term1 (Elm ls (PointR i))) (Z :. PointR i)) (Z:.PointR i)
+    , posLeft ~ LeftPosTy pos Deletion (PointR i)
+    , TermStaticVar pos Deletion (PointR i)
+    , MkStream m posLeft ls (PointR i)
+    )
+  ⇒ MkStream m pos (ls :!: Deletion) (PointR i) where
+  {-# Inline mkStream #-}
+  mkStream pos (ls :!: Deletion) grd us is
+    = S.map (\(ss,ee,ii) -> ElmDeletion ii ss)
+    . addTermStream1 pos Deletion us is
+    $ mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos Deletion us is grd) us (termStreamIndex pos Deletion is)
+
+
+
+instance
+  ( TermStreamContext m ps ts s x0 i0 is (PointR I)
+  )
+  ⇒ TermStream m (ps:.IStatic d) (TermSymbol ts Deletion) s (is:.PointR I) where
+  {-# Inline termStream #-}
+  termStream Proxy (ts:|Deletion) (us:..LtPointR u) (is:.PointR i)
+    = S.map (\(TState s ii ee) -> TState s (ii:.:RiPrI i) (ee:.()))
+    . termStream (Proxy ∷ Proxy ps) ts us is
+
+instance
+  ( TermStreamContext m ps ts s x0 i0 is (PointR I)
+  )
+  ⇒ TermStream m (ps:.IVariable d) (TermSymbol ts Deletion) s (is:.PointR I) where
+  {-# Inline termStream #-}
+  termStream Proxy (ts:|Deletion) (us:..LtPointR u) (is:.PointR i)
+    = S.map (\(TState s ii ee) -> TState s (ii:.:RiPrI i) (ee:.()))
+    . termStream (Proxy ∷ Proxy ps) ts us is
+
+
+
+instance TermStaticVar (IStatic d) Deletion (PointR I) where
+  termStreamIndex Proxy Deletion (PointR j) = PointR j
+  termStaticCheck Proxy Deletion _ (PointR j) grd = grd
+  {-# Inline [0] termStreamIndex #-}
+  {-# Inline [0] termStaticCheck #-}
+
+instance TermStaticVar (IVariable d) Deletion (PointR I) where
+  termStreamIndex Proxy Deletion (PointR j) = PointR j
+  termStaticCheck Proxy Deletion _ (PointR j) grd = grd
+  {-# Inline [0] termStreamIndex #-}
+  {-# Inline [0] termStaticCheck #-}
+
diff --git a/ADP/Fusion/PointR/Term/Epsilon.hs b/ADP/Fusion/PointR/Term/Epsilon.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/PointR/Term/Epsilon.hs
@@ -0,0 +1,66 @@
+
+-- | Rules of the type @X → ε@ denote termination of parsing if @X@ is empty.
+
+module ADP.Fusion.PointR.Term.Epsilon where
+
+import           Data.Proxy
+import           Data.Strict.Tuple
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+import           GHC.Exts
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Core
+import           ADP.Fusion.Core.Term.Epsilon
+import           ADP.Fusion.PointR.Core
+
+
+
+type instance LeftPosTy (IStatic d) (Epsilon Global) (PointR I) = IStatic d
+
+instance
+  forall pos posLeft m ls i lg
+  . ( TermStream m (Z:.pos) (TermSymbol M (Epsilon lg)) (Elm (Term1 (Elm ls (PointR i))) (Z :. PointR i)) (Z:.PointR i)
+    , posLeft ~ LeftPosTy pos (Epsilon lg) (PointR i)
+    , TermStaticVar pos (Epsilon lg) (PointR i)
+    , MkStream m posLeft ls (PointR i)
+    )
+  ⇒ MkStream m pos (ls :!: Epsilon lg) (PointR i) where
+  mkStream Proxy (ls :!: Epsilon) grd us is
+    = S.map (\(ss,ee,ii) -> ElmEpsilon ii ss)
+    . addTermStream1 (Proxy ∷ Proxy pos) (Epsilon @lg) us is
+    $ mkStream (Proxy ∷ Proxy posLeft)
+               ls
+               (termStaticCheck (Proxy ∷ Proxy pos) (Epsilon @lg) us is grd)
+               us
+               (termStreamIndex (Proxy ∷ Proxy pos) (Epsilon @lg) is)
+  {-# Inline mkStream #-}
+
+
+instance
+  ( TermStreamContext m ps ts s x0 i0 is (PointR I)
+  )
+  ⇒ TermStream m (ps:.IStatic d) (TermSymbol ts (Epsilon lg)) s (is:.PointR I) where
+  termStream Proxy (ts:|Epsilon) (us:..LtPointR u) (is:.PointR i)
+    = S.map (\(TState s ii ee) ->
+              let RiPrI k = getIndex (getIdx s) (Proxy :: PRI is (PointR I))
+              in  TState s (ii:.:RiPrI k) (ee:.()))
+    . termStream (Proxy ∷ Proxy ps) ts us is
+  {-# Inline termStream #-}
+
+
+
+-- TODO need upper bound in @termStaticCheck@ to be able to check against that!
+
+instance TermStaticVar (IStatic 0) (Epsilon Global) (PointR I) where
+  termStreamIndex Proxy Epsilon (PointR i     ) = PointR i
+  termStaticCheck Proxy Epsilon (LtPointR (I# u)) (PointR (I# i)) grd = (i ==# u) `andI#` grd
+  {-# Inline termStreamIndex #-}
+  {-# Inline termStaticCheck #-}
+
+instance TermStaticVar (IStatic 0) (Epsilon Local) (PointR I) where
+  termStreamIndex Proxy Epsilon (PointR i     ) = PointR i
+  termStaticCheck Proxy Epsilon (LtPointR (I# u)) (PointR (I# i)) grd = grd
+  {-# Inline termStreamIndex #-}
+  {-# Inline termStaticCheck #-}
+
diff --git a/ADP/Fusion/PointR/Term/MultiChr.hs b/ADP/Fusion/PointR/Term/MultiChr.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/PointR/Term/MultiChr.hs
@@ -0,0 +1,77 @@
+
+module ADP.Fusion.PointR.Term.MultiChr where
+
+import           Data.Proxy
+import           Data.Strict.Tuple
+import           Debug.Trace
+import           GHC.Exts
+--import           GHC.TypeNats
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+import qualified Data.Vector.Generic as VG
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Core
+import           ADP.Fusion.Core.Term.MultiChr
+import           ADP.Fusion.PointR.Core
+
+
+
+type instance LeftPosTy (IStatic d)   (MultiChr c v x) (PointR I) = IStatic (d+c)
+type instance LeftPosTy (IVariable d) (MultiChr c v x) (PointR I) = IVariable (d+c)
+
+
+
+instance
+  forall pos posLeft m ls c v x i
+  . ( TermStream m (Z:.pos) (TermSymbol M (MultiChr c v x)) (Elm (Term1 (Elm ls (PointR i))) (Z :. PointR i)) (Z:.PointR i)
+    , posLeft ~ LeftPosTy pos (MultiChr c v x) (PointR i)
+    , TermStaticVar pos (MultiChr c v x) (PointR i)
+    , MkStream m posLeft ls (PointR i)
+    )
+  ⇒ MkStream m pos (ls :!: MultiChr c v x) (PointR i) where
+  mkStream pos (ls :!: MultiChr xs) grd us is
+    = S.map (\(ss,ee,ii) -> ElmMultiChr ee ii ss) -- recover ElmChr
+    . addTermStream1 pos (MultiChr @v @x @c xs) us is
+    $ mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos (MultiChr @v @x @c xs) us is grd) us (termStreamIndex pos (MultiChr @v @x @c xs) is)
+  {-# Inline mkStream #-}
+
+
+instance
+  ( TermStreamContext m ps ts s x0 i0 is (PointR I)
+  , KnownNat c
+  ) => TermStream m (ps:.IStatic d) (TermSymbol ts (MultiChr c v x)) s (is:.PointR I) where
+  termStream Proxy (ts:|MultiChr xs) (us:..LtPointR u) (is:.PointR i)
+    = let !c = fromIntegral $ natVal (Proxy ∷ Proxy c) in
+      S.map (\(TState s ii ee) ->
+        let RiPrI k = getIndex (getIdx s) (Proxy ∷ PRI is (PointR I))
+        in  TState s (ii:.:RiPrI (k+c)) (ee:. VG.unsafeSlice k c xs))
+    . termStream (Proxy ∷ Proxy ps) ts us is
+  {-# Inline termStream #-}
+
+instance
+  ( TermStreamContext m ps ts s x0 i0 is (PointR I)
+  , KnownNat c
+  ) => TermStream m (ps:.IVariable d) (TermSymbol ts (MultiChr c v x)) s (is:.PointR I) where
+  termStream Proxy (ts:|MultiChr xs) (us:..LtPointR u) (is:.PointR i)
+    = let !c = fromIntegral $ natVal (Proxy ∷ Proxy c) in
+      S.map (\(TState s ii ee) ->
+        let RiPrI k = getIndex (getIdx s) (Proxy ∷ PRI is (PointR I))
+        in  TState s (ii:.:RiPrI (k+c)) (ee:. VG.unsafeSlice k c xs))
+    . termStream (Proxy ∷ Proxy ps) ts us is
+  {-# Inline termStream #-}
+
+
+
+instance (KnownNat c) ⇒ TermStaticVar (IStatic d) (MultiChr c v x) (PointR I) where
+  termStreamIndex Proxy (MultiChr x) (PointR j) = PointR $ j
+  termStaticCheck Proxy (MultiChr x) _ (PointR j) grd = grd
+  {-# Inline [0] termStreamIndex #-}
+  {-# Inline [0] termStaticCheck #-}
+
+instance (KnownNat c) ⇒ TermStaticVar (IVariable d) (MultiChr c v x) (PointR I) where
+  termStreamIndex Proxy (MultiChr x) (PointR j) = PointR $ j
+  termStaticCheck Proxy (MultiChr x) _ (PointR j) grd = grd
+  {-# Inline [0] termStreamIndex #-}
+  {-# Inline [0] termStaticCheck #-}
+
diff --git a/ADP/Fusion/QuickCheck/Common.hs b/ADP/Fusion/QuickCheck/Common.hs
deleted file mode 100644
--- a/ADP/Fusion/QuickCheck/Common.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-
-{-# Options_GHC -O0 #-}
-
-module ADP.Fusion.QuickCheck.Common where
-
-import Debug.Trace
-
-
-
-tr zs ls b = traceShow (zs," ",ls,length zs,length ls) b
diff --git a/ADP/Fusion/QuickCheck/Point.hs b/ADP/Fusion/QuickCheck/Point.hs
deleted file mode 100644
--- a/ADP/Fusion/QuickCheck/Point.hs
+++ /dev/null
@@ -1,294 +0,0 @@
-
-{-# Options_GHC -O0 #-}
-
-module ADP.Fusion.QuickCheck.Point where
-
-import           Control.Applicative
-import           Control.Monad
-import           Data.Strict.Tuple
-import           Data.Vector.Fusion.Util
-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           System.IO.Unsafe
-import           Test.QuickCheck
-import           Test.QuickCheck.All
-import           Test.QuickCheck.Monadic
-
-import           Data.PrimitiveArray
-
-import ADP.Fusion
-
-
-
--- * Epsilon cases
-
-prop_Epsilon ix@(PointL j) = zs == ls where
-  zs = (id <<< Epsilon ... S.toList) maxPL ix
-  ls = [ () | j == 0 ]
-
-prop_O_Epsilon ix@(O (PointL j)) = zs == ls where
-  zs = (id <<< Epsilon ... S.toList) (O maxPL) ix
-  ls = [ () | j == 100 ]
-
-prop_ZEpsilon ix@(Z:.PointL j) = zs == ls where
-  zs = (id <<< (M:|Epsilon) ... S.toList) (Z:.maxPL) ix
-  ls = [ Z:.() | j == 0 ]
-
-prop_O_ZEpsilon ix@(O (Z:.PointL j)) = zs == ls where
-  zs = (id <<< (M:|Epsilon) ... S.toList) (O (Z:.maxPL)) ix
-  ls = [ Z:.() | j == 100 ]
-
-prop_O_ZEpsilonEpsilon ix@(O (Z:.PointL j:.PointL l)) = zs == ls where
-  zs = (id <<< (M:|Epsilon:|Epsilon) ... S.toList) (O (Z:.maxPL:.maxPL)) ix
-  ls = [ Z:.():.() | j == 100, l == 100 ]
-
-
-
--- * Deletion cases
-
-prop_O_ItNC ix@(O (PointL j)) = zs == ls where
-  t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)
-  zs = ((,,) <<< t % Deletion % chr xs ... S.toList) (O $ maxPL) ix
-  ls = [ ( unsafeIndex xsPo (O $ PointL $ j+1)
-         , ()
-         , xs VU.! (j+0)
-         ) | j >= 0, j <= 99 ]
-{-# Noinline prop_O_ItNC #-}
-
-prop_O_ZItNC ix@(O (Z:.PointL j)) = zs == ls where
-  t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1)
-  zs = ((,,) <<< t % (M:|Deletion) % (M:|chr xs) ... S.toList) (O (Z:.maxPL)) ix
-  ls = [ ( unsafeIndex xsZPo (O (Z:.PointL (j+1)))
-         , Z:.()
-         , Z:.xs VU.! (j+0)
-         ) | j >= 0, j <= 99 ]
-
-prop_O_2dimIt_NC_CN ix@(O (Z:.PointL j:.PointL l)) = zs == ls where
-  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPPo (\ _ _ -> Id 1)
-  zs = ((,,) <<< t % (M:|Deletion:|chr xs) % (M:|chr xs:|Deletion) ... S.toList) (O (Z:.maxPL:.maxPL)) ix
-  ls = [ ( unsafeIndex xsPPo (O (Z:.PointL (j+1):.PointL (l+1)))
-         , Z:.()           :.xs VU.! (l+0)
-         , Z:.xs VU.! (j+0):.()
-         ) | j>=0, l>=0, j<=99, l<=99 ]
-
-prop_2dimIt_NC_CN ix@(Z:.PointL j:.PointL l) = zs == ls where
-  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPP (\ _ _ -> Id 1)
-  zs = ((,,) <<< t % (M:|Deletion:|chr xs) % (M:|chr xs:|Deletion) ... S.toList) (Z:.maxPL:.maxPL) ix
-  ls = [ ( unsafeIndex xsPP (Z:.PointL (j-1):.PointL (l-1))
-         , Z:.()           :.xs VU.! (l-1)
-         , Z:.xs VU.! (j-1):.()
-         ) | j>=1, l>=1, j<=100, l<=100 ]
-
-
-
--- * terminal cases
-
--- | A single character terminal
-
-prop_Tt ix@(Z:.PointL j) = zs == ls where
-  zs = (id <<< (M:|chr xs) ... S.toList) (Z:.maxPL) ix
-  ls = [ (Z:.xs VU.! (j-1)) | 1==j ]
-
---prop_O_Tt ix@(Z:.O (PointL j)) = traceShow (j,zs,ls) $ zs == ls where
---  zs = (id <<< (M:|chr xs) ... S.toList) (Z:.O maxPL) ix
---  ls = [ (Z:.xs VU.! (j-1)) | 1==j ]
-
--- | Two single-character terminals
-
-prop_CC ix@(Z:.PointL i) = zs == ls where
-  zs = ((,) <<< (M:|chr xs) % (M:|chr xs) ... S.toList) (Z:.maxPL) ix
-  ls = [ (Z:.xs VU.! (i-2), Z:.xs VU.! (i-1)) | 2==i ]
-
--- | Just a table
-
-prop_It ix@(PointL j) = zs == ls where
-  t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1)
-  zs = (id <<< t ... S.toList) maxPL ix
-  ls = [ unsafeIndex xsP ix | j>=0, j<=100 ]
-
-prop_O_It ix@(O (PointL j)) = zs == ls where
-  t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)
-  zs = (id <<< t ... S.toList) (O maxPL) ix
-  ls = [ unsafeIndex xsPo ix | j>=0, j<=100 ]
-
-prop_ZIt ix@(Z:.PointL j) = zs == ls where
-  t = ITbl 0 0 (Z:.EmptyOk) xsZP (\ _ _ -> Id 1)
-  zs = (id <<< t ... S.toList) (Z:.maxPL) ix
-  ls = [ unsafeIndex xsZP ix | j>=0, j<=100 ]
-
-prop_O_ZIt ix@(O (Z:.PointL j)) = zs == ls where
-  t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1)
-  zs = (id <<< t ... S.toList) (O (Z:.maxPL)) ix
-  ls = [ unsafeIndex xsZPo ix | j>=0, j<=100 ]
-
--- | Table, then single terminal
-
-prop_ItC ix@(PointL j) = zs == ls where
-  t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1)
-  zs = ((,) <<< t % chr xs ... S.toList) maxPL ix
-  ls = [ ( unsafeIndex xsP (PointL $ j-1)
-         , xs VU.! (j-1)
-         ) | j>=1, j<=100 ]
-
--- | @A^*_j -> A^*_{j+1} c_{j+1)@ !
-
-prop_O_ItC ix@(O (PointL j)) = zs == ls where
-  t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)
-  zs = ((,) <<< t % chr xs ... S.toList) (O $ maxPL) ix
-  ls = [ ( unsafeIndex xsPo (O $ PointL $ j+1)
-         , xs VU.! (j+0)
-         ) | j >= 0, j < 100 ]
-
-prop_O_ItCC ix@(O (PointL j)) = zs == ls where
-  t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)
-  zs = ((,,) <<< t % chr xs % chr xs ... S.toList) (O $ maxPL) ix
-  ls = [ ( unsafeIndex xsPo (O $ PointL $ j+2)
-         , xs VU.! (j+0)
-         , xs VU.! (j+1)
-         ) | j >= 0, j <= 98 ]
-{-# Noinline prop_O_ItCC #-}
-
-prop_O_ZItCC ix@(O (Z:.PointL j)) = zs == ls where
-  t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1)
-  zs = ((,,) <<< t % (M:|chr xs) % (M:|chr xs) ... S.toList) (O (Z:.maxPL)) ix
-  ls = [ ( unsafeIndex xsZPo (O (Z:.PointL (j+2)))
-         , Z:.xs VU.! (j+0)
-         , Z:.xs VU.! (j+1)
-         ) | j >= 0, j <= 98 ]
-
--- | synvar followed by a 2-tape character terminal
-
-prop_2dimItCC ix@(Z:.PointL j:.PointL l) = zs == ls where
-  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPP (\ _ _ -> Id 1)
-  zs = ((,,) <<< t % (M:|chr xs:|chr xs) % (M:|chr xs:|chr xs) ... S.toList) (Z:.maxPL:.maxPL) ix
-  ls = [ ( unsafeIndex xsPP (Z:.PointL (j-2):.PointL (l-2))
-         , Z:.xs VU.! (j-2):.xs VU.! (l-2)
-         , Z:.xs VU.! (j-1):.xs VU.! (l-1)
-         ) | j>=2, l>=2, j<=100, l<=100 ]
-
-prop_O_2dimItCC ix@(O (Z:.PointL j:.PointL l)) = zs == ls where
-  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPPo (\ _ _ -> Id 1)
-  zs = ((,,) <<< t % (M:|chr xs:|chr xs) % (M:|chr xs:|chr xs) ... S.toList) (O (Z:.maxPL:.maxPL)) ix
-  ls = [ ( unsafeIndex xsPPo (O (Z:.PointL (j+2):.PointL (l+2)))
-         , Z:.xs VU.! (j+0):.xs VU.! (l+0)
-         , Z:.xs VU.! (j+1):.xs VU.! (l+1)
-         ) | j>=0, l>=0, j<=98, l<=98 ]
-
--- * direct index tests
-
-xprop_O_ixZItCC ix@(O (Z:.PointL j)) = zs where
-  t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1)
-  zs = (id >>> t % (M:|chr xs) % (M:|chr xs) ... S.toList) (O (Z:.maxPL)) ix
-
--- * 'Strng' tests
-
--- ** Just the 'Strng' terminal
-
-prop_ManyS ix@(PointL j) = zs == ls where
-  zs = (id <<< manyS xs ... S.toList) maxPL ix
-  ls = [ (VU.slice 0 j xs) ]
-
-prop_SomeS ix@(PointL j) = zs == ls where
-  zs = (id <<< someS xs ... S.toList) maxPL ix
-  ls = [ (VU.slice 0 j xs) | j>0 ]
-
-prop_2dim_ManyS_ManyS ix@(Z:.PointL i:.PointL j) = zs == ls where
-  zs = (id <<< (M:|manyS xs:|manyS xs) ... S.toList) (Z:.maxPL:.maxPL) ix
-  ls = [ (Z:.VU.slice 0 i xs:.VU.slice 0 j xs) ]
-
-prop_2dim_SomeS_SomeS ix@(Z:.PointL i:.PointL j) = zs == ls where
-  zs = (id <<< (M:|someS xs:|someS xs) ... S.toList) (Z:.maxPL:.maxPL) ix
-  ls = [ (Z:.VU.slice 0 i xs:.VU.slice 0 j xs) | i > 0 && j > 0 ]
-
--- ** Together with a syntactic variable.
-
-prop_Itbl_ManyS ix@(PointL i) = zs == ls where
-  t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1)
-  zs = ((,) <<< t % manyS xs ... S.toList) maxPL ix
-  ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i] ]
-
-prop_Itbl_SomeS ix@(PointL i) = zs == ls where
-  t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1)
-  zs = ((,) <<< t % someS xs ... S.toList) maxPL ix
-  ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i-1] ]
-
-prop_1dim_Itbl_ManyS ix@(Z:.PointL i) = zs == ls where
-  t = ITbl 0 0 (Z:.EmptyOk) xsZP (\ _ _ -> Id 1)
-  zs = ((,) <<< t % (M:|manyS xs) ... S.toList) (Z:.maxPL) ix
-  ls = [ (unsafeIndex xsZP (Z:.PointL k), Z:. VU.slice k (i-k) xs) | k <- [0..i] ]
-
-prop_1dim_Itbl_SomeS ix@(Z:.PointL i) = zs == ls where
-  t = ITbl 0 0 (Z:.EmptyOk) xsZP (\ _ _ -> Id 1)
-  zs = ((,) <<< t % (M:|someS xs) ... S.toList) (Z:.maxPL) ix
-  ls = [ (unsafeIndex xsZP (Z:.PointL k), Z:. VU.slice k (i-k) xs) | k <- [0..i-1] ]
-
-prop_2dim_Itbl_ManyS_ManyS ix@(Z:.PointL i:.PointL j) = zs == ls where
-  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPP (\ _ _ -> Id 1)
-  zs = ((,) <<< t % (M:|manyS xs:|manyS xs) ... S.toList) (Z:.maxPL:.maxPL) ix
-  ls = [ (unsafeIndex xsPP (Z:.PointL k:.PointL l), Z:. VU.slice k (i-k) xs :. VU.slice l (j-l) xs) | k <- [0..i], l <- [0..j] ]
-
-prop_2dim_Itbl_SomeS_SomeS ix@(Z:.PointL i:.PointL j) = zs == ls where
-  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPP (\ _ _ -> Id 1)
-  zs = ((,) <<< t % (M:|someS xs:|someS xs) ... S.toList) (Z:.maxPL:.maxPL) ix
-  ls = [ (unsafeIndex xsPP (Z:.PointL k:.PointL l), Z:. VU.slice k (i-k) xs :. VU.slice l (j-l) xs) | k <- [0..i-1], l <- [0..j-1] ]
-
-
-
-
-infixl 8 >>>
-(>>>) f xs = \lu ij -> S.map f . mkStream (build xs) (initialContext ij) lu $ ij
-
-class GetIxs x i where
-  type R x i :: *
-  getIxs :: Elm x i -> R x i
-
-instance GetIxs S i where
-  type R S i = Z:.(i,i)
-  getIxs e = Z:.(getIdx e, getOmx e)
-
-instance GetIxs ls i => GetIxs (ls :!: Chr a b) i where
-  type R (ls :!: Chr a b) i = R ls i :. (i,i)
-  getIxs (ElmChr _ i o s) = getIxs s :. (i,o)
-
-instance GetIxs ls i => GetIxs (ls :!: ITbl m a i x) i where
-  type R (ls :!: ITbl m a i x) i = R ls i :. (i,i)
-  getIxs (ElmITbl _ i o s) = getIxs s :. (i,o)
-
-xsP :: Unboxed (PointL) Int
-xsP = fromList (PointL 0) maxPL [0 ..]
-
-xsZP :: Unboxed (Z:.PointL) Int
-xsZP = fromList (Z:.PointL 0) (Z:.maxPL) [0 ..]
-
-xsPo :: Unboxed (Outside (PointL)) Int
-xsPo = fromList (O $ PointL 0) (O $ maxPL) [0 ..]
-
-xsZPo :: Unboxed (Outside (Z:.PointL)) Int
-xsZPo = fromList (O (Z:.PointL 0)) (O (Z:.maxPL)) [0 ..]
-
-xsPP :: Unboxed (Z:.PointL:.PointL) Int
-xsPP = fromList (Z:.PointL 0:.PointL 0) (Z:.maxPL:.maxPL) [0 ..]
-
-xsPPo :: Unboxed (Outside (Z:.PointL:.PointL)) Int
-xsPPo = fromList (O (Z:.PointL 0:.PointL 0)) (O (Z:.maxPL:.maxPL)) [0 ..]
-
-mxsPP = unsafePerformIO $ zzz where
-  zzz :: IO (MutArr IO (Unboxed (Z:.PointL:.PointL) Int))
-  zzz = fromListM (Z:.PointL 0:.PointL 0) (Z:.maxPL:.maxPL) [0 ..]
-
-maxI = 100
-maxPL = PointL maxI
-
-xs = VU.fromList [0 .. maxI - 1 :: Int]
-
--- * general quickcheck stuff
-
-options = stdArgs {maxSuccess = 1000}
-
-customCheck = quickCheckWithResult options
-
-return []
-allProps = $forAllProperties customCheck
-
diff --git a/ADP/Fusion/QuickCheck/Set.hs b/ADP/Fusion/QuickCheck/Set.hs
deleted file mode 100644
--- a/ADP/Fusion/QuickCheck/Set.hs
+++ /dev/null
@@ -1,248 +0,0 @@
-
-{-# Options_GHC -O0 #-}
-
-module ADP.Fusion.QuickCheck.Set where
-
-import           Data.Bits
-import           Data.Vector.Fusion.Util
-import           Debug.Trace
-import qualified Data.List as L
-import qualified Data.Vector.Fusion.Stream as S
-import qualified Data.Vector.Unboxed as VU
-import           Test.QuickCheck hiding (NonEmpty)
-import           Test.QuickCheck.All
-import           Test.QuickCheck.Monadic
-
-import           Data.Bits.Ordered
-import           Data.PrimitiveArray
-
-import           ADP.Fusion
-import           ADP.Fusion.QuickCheck.Common
-
-
-
--- * BitSets without interfaces
-
--- ** Inside checks
-
-prop_b_ii ix@(BitSet _) = zs == ls where
-  tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
-  tib = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
-  zs = ((,) <<< tia % tib ... S.toList) highestB ix
-  ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) )
-       | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ]
-       , let kk = popShiftL ix (BitSet k)
-       ]
-
-prop_b_ii_nn ix@(BitSet _) = zs == ls where
-  tia = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)
-  tib = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)
-  zs = ((,) <<< tia % tib ... S.toList) highestB ix
-  ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) )
-       | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ]
-       , let kk = popShiftL ix (BitSet k)
-       , popCount kk > 0
-       , popCount (ix `xor` kk) > 0
-       ]
-
-prop_b_iii ix@(BitSet _) = zs == ls where
-  tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
-  tib = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
-  tic = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
-  zs = ((,,) <<< tia % tib % tic ... S.toList) highestB ix
-  ls = [ ( xsB ! kk , xsB ! ll , xsB ! mm )
-       | k <- VU.toList . popCntSorted $ popCount ix
-       , l <- VU.toList . popCntSorted $ popCount ix - popCount k
-       , let kk = popShiftL ix          (BitSet k)
-       , let ll = popShiftL (ix `xor` kk) (BitSet l)
-       , let mm = (ix `xor` (kk .|. ll))
-       ]
-
-prop_b_iii_nnn ix@(BitSet _) = zs == ls where
-  tia = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)
-  tib = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)
-  tic = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)
-  zs = ((,,) <<< tia % tib % tic ... S.toList) highestB ix
-  ls = [ ( xsB ! kk , xsB ! ll , xsB ! mm )
-       | k <- VU.toList . popCntSorted $ popCount ix
-       , l <- VU.toList . popCntSorted $ popCount ix - popCount k
-       , let kk = popShiftL ix          (BitSet k)
-       , let ll = popShiftL (ix `xor` kk) (BitSet l)
-       , let mm = (ix `xor` (kk .|. ll))
-       , popCount kk > 0, popCount ll > 0, popCount mm > 0
-       ]
-
-
--- * Outside checks
--- These checks are very similar to those in the @Subword@ module. We just
--- need to be a bit more careful, as indexed sets have overlap.
-
--- ** Two non-terminals.
---
--- @A_s -> B_(s\t) C_t    (s\t) ++ t == s@
--- @s = 111 , s\t = 101, t = 010@
---
--- with @Z@ the full set.
--- @Z = 1111@
-
--- @B*_Z\(s\t) -> A*_Z\s C_t@
--- @Z\(s\t) = 1010, Z\s = 1000, t = 010@
-
-
-
-
--- * BitSets with two interfaces
-
--- ** Inside checks
-
-prop_bii_i :: BS2I First Last -> Bool
-prop_bii_i ix@(s:>i:>j) = zs == ls where
-  tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
-  zs = (id <<< tia ... S.toList) highestBII ix
-  ls = [ xsBII ! ix ]
-
-prop_bii_i_n :: BS2I First Last -> Bool
-prop_bii_i_n ix@(s:>i:>j) = zs == ls where
-  tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)
-  zs = (id <<< tia ... S.toList) highestBII ix
-  ls = [ xsBII ! ix | popCount s > 0 ]
-
--- | Edges should never work as a single terminal element.
-
-prop_bii_e :: BS2I First Last -> Bool
-prop_bii_e ix@(s:>Iter i:>Iter j) = zs == ls where
-  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
-  zs = (id <<< e ... S.toList) highestBII ix
-  ls = [] :: [ (Int,Int) ]
-
--- | Edges extend only in cases where in @i -> j@, @i@ actually happens to
--- be a true interface.
-
-prop_bii_ie :: BS2I First Last -> Bool
-prop_bii_ie ix@(s:>i:>Iter j) = zs == ls where
-  tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
-  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
-  zs = ((,) <<< tia % e ... S.toList) highestBII ix
-  ls = [ ( xsBII ! (t:>i:>(Iter k :: Interface Last)) , (k,j) )
-       | let t = s `clearBit` j
-       , k <- activeBitsL t ]
-
-prop_bii_ie_n :: BS2I First Last -> Bool
-prop_bii_ie_n ix@(s:>i:>Iter j) = zs == ls where
-  tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)
-  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
-  zs = ((,) <<< tia % e ... S.toList) highestBII ix
-  ls = [ ( xsBII ! (t:>i:>(Iter k :: Interface Last)) , (k,j) )
-       | let t = s `clearBit` j
-       , popCount t >= 2
-       , k <- activeBitsL t
-       , k /= getIter i
-       ]
-
-prop_bii_iee :: BS2I First Last -> Bool
-prop_bii_iee ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where
-  tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
-  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
-  zs = ((,,) <<< tia % e % e ... S.toList) highestBII ix
-  ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,j) )
-       | let tmp = (s `clearBit` j)
-       , l <- activeBitsL tmp
-       , l /= getIter i
-       , let t = tmp `clearBit` l
-       , k <- activeBitsL t
-       , let kk = Iter k
-       ]
-
-prop_bii_ieee :: BS2I First Last -> Bool
-prop_bii_ieee ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where
-  tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
-  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
-  zs = ((,,,) <<< tia % e % e % e ... S.toList) highestBII ix
-  ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,m) , (m,j) )
-       | let tmpM = (s `clearBit` j)
-       , m <- activeBitsL tmpM
-       , m /= getIter i
-       , let tmpL = (tmpM `clearBit` m)
-       , l <- activeBitsL tmpL
-       , l /= getIter i
-       , let t = tmpL `clearBit` l
-       , k <- activeBitsL t
-       , let kk = Iter k
-       ]
-
-prop_bii_iee_n :: BS2I First Last -> Bool
-prop_bii_iee_n ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where
-  tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)
-  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
-  zs = ((,,) <<< tia % e % e ... S.toList) highestBII ix
-  ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,j) )
-       | let tmp = (s `clearBit` j)
-       , l <- activeBitsL tmp
-       , l /= getIter i
-       , let t = tmp `clearBit` l
-       , popCount t >= 2
-       , k <- activeBitsL t
-       , k /= getIter i
-       , let kk = Iter k
-       ]
-
-prop_bii_ieee_n :: BS2I First Last -> Bool
-prop_bii_ieee_n ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where
-  tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)
-  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
-  zs = ((,,,) <<< tia % e % e % e ... S.toList) highestBII ix
-  ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,m) , (m,j) )
-       | let tmpM = (s `clearBit` j)
-       , m <- activeBitsL tmpM
-       , m /= getIter i
-       , let tmpL = (tmpM `clearBit` m)
-       , l <- activeBitsL tmpL
-       , l /= getIter i
-       , let t = tmpL `clearBit` l
-       , popCount t >= 2
-       , k <- activeBitsL t
-       , k /= getIter i
-       , let kk = Iter k
-       ]
-
--- prop_bii_ii (ix@(s:>i:>j) :: (BitSet:>Interface First:>Interface Last)) = tr zs ls $ zs == ls where
---   tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
---   tib = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
---   zs = ((,) <<< tia % tib ... S.toList) highestBII ix
---   ls = [ ( xsBII ! kk , xsBII ! ll )
---        | k  <- VU.toList . popCntSorted $ popCount s
---        , ki <- if k==0 then [0] else activeBitsL k
---        , kj <- if | k==0 -> [0] | popCount k==1 -> [ki] | otherwise -> activeBitsL (k `clearBit` ki)
---        , let kk = (BitSet k:>Iter ki:>Iter kj)
---        , let l  = s `xor` BitSet k
---        , li <- if l==0 then [0] else activeBitsL l
---        , lj <- if | l==0 -> [0] | popCount l==1 -> [li] | otherwise -> activeBitsL (l `clearBit` li)
---        , let ll = (l:>Iter li:>Iter lj)
---        ]
-
-
-
--- * Helper functions
-
-highBit = fromIntegral arbitraryBitSetMax -- should be the same as the highest bit in Index.Set.arbitrary
-highestB = BitSet $ 2^(highBit+1) -1
-highestBII = highestB :> Iter (highBit-1) :> Iter (highBit-1) -- assuming @highBit >= 1@
-
-xsB :: Unboxed BitSet Int
-xsB = fromList (BitSet 0) highestB [ 0 .. ]
-
-xoB :: Unboxed (Outside BitSet) Int
-xoB = fromList (O (BitSet 0)) (O highestB) [ 0 .. ]
-
-xsBII :: Unboxed (BitSet:>Interface First:>Interface Last) Int
-xsBII = fromList (BitSet 0:>Iter 0:>Iter 0) highestBII [ 0 .. ]
-
--- * general quickcheck stuff
-
-options = stdArgs {maxSuccess = 1000}
-
-customCheck = quickCheckWithResult options
-
-return []
-allProps = $forAllProperties customCheck
-
diff --git a/ADP/Fusion/QuickCheck/Subword.hs b/ADP/Fusion/QuickCheck/Subword.hs
deleted file mode 100644
--- a/ADP/Fusion/QuickCheck/Subword.hs
+++ /dev/null
@@ -1,225 +0,0 @@
-
-{-# Options_GHC -O0 #-}
-
--- |
---
--- TODO need to carefully check all props against boundary errors!
--- Especially the 2-dim cases!
-
-module ADP.Fusion.QuickCheck.Subword where
-
-import           Test.QuickCheck
-import           Test.QuickCheck.All
-import           Test.QuickCheck.Monadic
-import qualified Data.Vector.Fusion.Stream as S
-import           Data.Vector.Fusion.Util
-import           Debug.Trace
-import qualified Data.List as L
-import qualified Data.Vector.Unboxed as VU
-
-import           Data.PrimitiveArray
-
-import           ADP.Fusion
-import           ADP.Fusion.QuickCheck.Common
-
-
-
--- * Outside checks
-
--- ** two non-terminals on the r.h.s.
---
--- A_ij -> B_ik C_kj
---
--- B*_ik -> A*_ij C_kj
--- C*_kj -> B_ik  A*_ij
-
-prop_sv_OI ox@(O (Subword (i:.k))) = zs == ls where
-  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
-  tic = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
-  zs = ((,) <<< toa % tic ... S.toList) (O $ subword 0 highest) ox
-  ls = [ ( unsafeIndex xoS (O $ subword i j)
-         , unsafeIndex xsS (    subword k j) )
-       | j <- [ k .. highest ] ]
-
-prop_sv_IO ox@(O (Subword (k:.j))) = zs == ls where
-  tib = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
-  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
-  zs = ((,) <<< tib % toa ... S.toList) (O $ subword 0 highest) ox
-  ls = [ ( unsafeIndex xsS (    subword i k)
-         , unsafeIndex xoS (O $ subword i j) )
-       | j <= highest, i <- [ 0 .. k ] ]
-
--- ** three non-terminals on the r.h.s. (this provides situations where two
--- syntactic terminals are on the same side)
---
--- A_ij -> B_ik C_kl D_lj
---
--- B*_ik -> A*_ij C_kl  D_lj
--- C*_kl -> B_ik  A*_ij D_lj
--- D*_lj -> B_ik  C_kl  A*_ij
-
-prop_sv_OII ox@(O (Subword (i:.k))) = zs == ls where
-  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
-  tic = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
-  tid = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
-  zs = ((,,) <<< toa % tic % tid ... S.toList) (O $ subword 0 highest) ox
-  ls = [ ( unsafeIndex xoS (O $ subword i j)
-         , unsafeIndex xsS (    subword k l)
-         , unsafeIndex xsS (    subword l j) )
-       | j <- [ k .. highest ], l <- [ k .. j ] ]
-
-prop_sv_IOI ox@(O (Subword (k:.l))) = zs == ls where
-  tib = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
-  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
-  tid = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
-  zs = ((,,) <<< tib % toa % tid ... S.toList) (O $ subword 0 highest) ox
-  ls = [ ( unsafeIndex xsS (    subword i k)
-         , unsafeIndex xoS (O $ subword i j)
-         , unsafeIndex xsS (    subword l j) )
-       | i <- [ 0 .. k ], j <- [ l .. highest ] ]
-
-prop_sv_IIO ox@(O (Subword (l:.j))) = zs == ls where
-  tib = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
-  tic = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
-  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
-  zs = ((,,) <<< tib % tic % toa ... S.toList) (O $ subword 0 highest) ox
-  ls = [ ( unsafeIndex xsS (    subword i k)
-         , unsafeIndex xsS (    subword k l)
-         , unsafeIndex xoS (O $ subword i j) )
-       | j <= highest, i <- [ 0 .. l ], k <- [ i .. l ] ]
-
--- ** four non-terminals on the r.h.s. ?
-
--- ** five non-terminals on the r.h.s. ?
-
--- ** Non-terminal and terminal combinations
-
-prop_cOc ox@(O( Subword (i:.j))) = zs == ls where
-  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
-  zs  = ((,,) <<< chr csS % toa % chr csS ... S.toList) (O $ subword 0 highest) ox
-  ls  = [ ( csS VU.! (i-1)
-          , unsafeIndex xoS (O $ subword (i-1) (j+1))
-          , csS VU.! (j  ) )
-        | i > 0 && j < highest ]
-
-prop_ccOcc ox@(O(Subword (i:.j))) = zs == ls where
-  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
-  zs  = ((,,,,) <<< chr csS % chr csS % toa % chr csS % chr csS ... S.toList) (O $ subword 0 highest) ox
-  ls  = [ ( csS VU.! (i-2)
-          , csS VU.! (i-1)
-          , unsafeIndex xoS (O $ subword (i-2) (j+2))
-          , csS VU.! (j  )
-          , csS VU.! (j+1) )
-        | i > 1 && j < highest -1 ]
-
-prop_cOccc ox@(O(Subword (i:.j))) = zs == ls where
-  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
-  zs  = ((,,,,) <<< chr csS % toa % chr csS % chr csS % chr csS ... S.toList) (O $ subword 0 highest) ox
-  ls  = [ ( csS VU.! (i-1)
-          , unsafeIndex xoS (O $ subword (i-1) (j+3))
-          , csS VU.! (j  )
-          , csS VU.! (j+1)
-          , csS VU.! (j+2) )
-        | i > 0 && j < highest -2 ]
-
--- ** Terminals, syntactic terminals, and non-terminals
-
-prop_cOcIc ox@(O (Subword (i:.k))) = zs == ls where
-  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
-  tic = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
-  zs = ((,,,,) <<< chr csS % toa % chr csS % tic % chr csS ... S.toList) (O $ subword 0 highest) ox
-  ls = [ ( csS VU.! (i-1)
-         , unsafeIndex xoS (O $ subword (i-1)  j    )
-         , csS VU.! (k  )
-         , unsafeIndex xsS (    subword (k+1) (j-1) )
-         , csS VU.! (j-1) )
-       | i > 0, j <- [ k+2 .. highest ] ]
-
-prop_cIcOc ox@(O (Subword (k:.j))) = zs == ls where
-  tib = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
-  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
-  zs = ((,,,,) <<< chr csS % tib % chr csS % toa % chr csS ... S.toList) (O $ subword 0 highest) ox
-  ls = [ ( csS VU.! (i  )
-         , unsafeIndex xsS (    subword (i+1) (k-1))
-         , csS VU.! (k-1)
-         , unsafeIndex xoS (O $ subword  i    (j+1))
-         , csS VU.! (j  ) )
-       | j+1 <= highest, k>1, i <- [ 0 .. k-2 ] ]
-
--- ** Epsilonness
-
-prop_Epsilon ox@(O (Subword (i:.j))) = zs == ls where
-  zs = (id <<< Epsilon ... S.toList) (O $ subword 0 highest) ox
-  ls = [ () | i==0 && j==highest ]
-
-
--- ** Multi-tape cases
-
-prop_2dimIt ix@(Z:.Subword (i:.j):.Subword (k:.l)) = zs == ls where
-  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsSS (\ _ _ -> Id ((1,1),(1,1)))
-  zs = (id <<< t ... S.toList) (Z:.subword 0 highest:.subword 0 highest) ix
-  ls = [ ( unsafeIndex xsSS ix ) | j<=highest && l<=highest ]
-
-{-
-xprop_2dimItIt ix@(Z:.Subword (i:.j):.Subword (k:.l)) = zs == ls where
-  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsSS (\ _ _ -> Id (1,1))
-  zs = ((,) <<< t % t ... S.toList) (Z:.subword 0 highest:.subword 0 highest) ix
-  ls = [ ( unsafeIndex xsSS (Z:.subword i m:.subword k n)
-         , unsafeIndex xsSS (Z:.subword m j:.subword n l) )
-       | j<=highest && l<=highest
-       , m <- [i..j]
-       , n <- [k..l]
-       ]
--}
-
-prop_2dimcIt ix@(Z:.Subword(i:.j):.Subword(k:.l)) = {- traceShow (zs,ls) $ -} zs == ls where
-  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsSS (\ _ _ -> Id ((1,1),(1,1)))
-  zs = ((,) <<< (M:|chr csS:|chr csS) % t ... S.toList) (Z:.subword 0 highest:.subword 0 highest) ix
-  ls = [ ( Z :. (csS VU.! i) :. (csS VU.! k)
-         , unsafeIndex xsSS (Z :. subword (i+1) j :. subword (k+1) l) )
-       | j<=highest && l<=highest
-       , i+1<=j && k+1<=l ]
-
-prop_2dimItc ix@(Z:.Subword(i:.j):.Subword(k:.l)) = {- traceShow (zs,ls) $ -} zs == ls where
-  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsSS (\ _ _ -> Id ((1,1),(1,1)))
-  zs = ((,) <<< t % (M:|chr csS:|chr csS)  ... S.toList) (Z:.subword 0 highest:.subword 0 highest) ix
-  ls = [ ( unsafeIndex xsSS (Z :. subword i (j-1) :. subword k (l-1))
-         , Z :. (csS VU.! (j-1)) :. (csS VU.! (l-1)) )
-       | j<=highest && l<=highest
-       , i+1<=j && k+1<=l ]
-
-prop_2dimcItc ix@(Z:.Subword(i:.j):.Subword(k:.l)) = {- traceShow (zs,ls) $ -} zs == ls where
-  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsSS (\ _ _ -> Id ((1,1),(1,1)))
-  zs = ((,,) <<< (M:|chr csS:|chr csS) % t % (M:|chr csS:| chr csS) ... S.toList) (Z:.subword 0 highest:.subword 0 highest) ix
-  ls = [ ( Z :. (csS VU.! i) :. (csS VU.! k)
-         , unsafeIndex xsSS (Z :. subword (i+1) (j-1) :. subword (k+1) (l-1))
-         , Z :. (csS VU.! (j-1)) :. (csS VU.! (l-1)) )
-       | j<=highest && l<=highest
-       , i+2<=j && k+2<=l ]
-
-
-
-highest = 10
-
-csS :: VU.Vector (Int,Int)
-csS = VU.fromList [ (i,i+1) | i <- [0 .. highest-1] ] -- this should be @highest -1@, we should die if we see @(highest,highest+1)@
-
-xsS :: Unboxed Subword (Int,Int)
-xsS = fromList (subword 0 0) (subword 0 highest) [ (i,j) | i <- [ 0 .. highest ] , j <- [ i .. highest ] ]
-
-xoS :: Unboxed (Outside Subword) (Int,Int)
-xoS = fromList (O $ subword 0 0) (O $ subword 0 highest) [ (i,j) | i <- [ 0 .. highest ] , j <- [ i .. highest ] ]
-
-xsSS :: Unboxed (Z:.Subword:.Subword) ( (Int,Int) , (Int,Int) )
-xsSS = fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 highest:.subword 0 highest) ((-1,-1),(-1,-1))
-        $ Prelude.map (\((i,j),(k,l)) -> (Z:.subword i j:.subword k l, ((i,j),(k,l)) )) [ ((i,j) , (k,l)) | i <- [0 .. highest], j <-[i .. highest], k <- [0 .. highest], l <- [0 .. highest] ]
-
--- * general quickcheck stuff
-
-options = stdArgs {maxSuccess = 10000}
-
-customCheck = quickCheckWithResult options
-
-return []
-allProps = $forAllProperties customCheck
-
diff --git a/ADP/Fusion/SynVar.hs b/ADP/Fusion/SynVar.hs
deleted file mode 100644
--- a/ADP/Fusion/SynVar.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-
--- | This module re-exports all table types.
-
-module ADP.Fusion.SynVar
-  ( module ADP.Fusion.SynVar.Array
-  , module ADP.Fusion.SynVar.Axiom
-  , module ADP.Fusion.SynVar.Backtrack
-  , module ADP.Fusion.SynVar.Fill
-  , module ADP.Fusion.SynVar.Recursive
-  , module ADP.Fusion.SynVar.Split
-  ) where
-
-import ADP.Fusion.SynVar.Array
-import ADP.Fusion.SynVar.Axiom
-import ADP.Fusion.SynVar.Backtrack
-import ADP.Fusion.SynVar.Fill
-import ADP.Fusion.SynVar.Recursive
-import ADP.Fusion.SynVar.Split
-
diff --git a/ADP/Fusion/SynVar/Array.hs b/ADP/Fusion/SynVar/Array.hs
deleted file mode 100644
--- a/ADP/Fusion/SynVar/Array.hs
+++ /dev/null
@@ -1,293 +0,0 @@
-
-module ADP.Fusion.SynVar.Array
-  ( module ADP.Fusion.SynVar.Array.Type
-  , module ADP.Fusion.SynVar.Array.Point
-  , module ADP.Fusion.SynVar.Array.Set
-  , module ADP.Fusion.SynVar.Array.Subword
-  ) where
-
-import ADP.Fusion.SynVar.Array.Point
-import ADP.Fusion.SynVar.Array.Set
-import ADP.Fusion.SynVar.Array.Subword
-import ADP.Fusion.SynVar.Array.TermSymbol
-import ADP.Fusion.SynVar.Array.Type
-
-{-
-
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE RankNTypes #-}
-
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE PatternGuards #-}
-
--- | Tables in ADPfusion memoize results of parses. In the forward phase, table
--- cells are filled by a table-filling method from @Data.PrimitiveArray@. In
--- the backtracking phase, grammar rules are associated with tables to provide
--- efficient backtracking.
---
--- TODO multi-dim tables with 'OnlyZero' need a static check!
---
--- TODO PointL , PointR need sanity checks for boundaries
---
--- TODO the sanity checks are acutally a VERY BIG TODO since currently we do
--- not protect against stupidity at all!
---
--- TODO have boxed tables for top-down parsing.
---
--- TODO combine forward and backward phases to simplify the external interface
--- to the programmer.
---
--- TODO include the notion of @interfaces@ into tables. With Outside
--- grammars coming up now, we need this.
-
-module ADP.Fusion.Table.Array
---  ( MTbl      (..)
---  , BtTbl     (..)
-  ( ITbl      (..)
---  , Backtrack (..)
-  , ToBT (..)
-  ) where
-
-import           Control.Exception(assert)
-import           Control.Monad.Primitive (PrimMonad)
-import           Data.Vector.Fusion.Stream.Size (Size(Unknown))
-import qualified Data.Vector as V
-import qualified Data.Vector.Generic as VG
-import qualified Data.Vector.Storable as VS
-import qualified Data.Vector.Unboxed as VU
-import           GHC.Exts
-import           Data.Bits
-
-import           Data.PrimitiveArray -- (Z(..), (:.)(..), Subword(..), subword, PointL(..), pointL, PointR(..), pointR,topmostIndex, Outside(..))
-import qualified Data.PrimitiveArray as PA
-
-import           ADP.Fusion.Classes
-import           ADP.Fusion.Multi.Classes
-import           ADP.Fusion.Table.Axiom
-import           ADP.Fusion.Table.Backtrack
-import           ADP.Fusion.Table.Indices
-
-import           Debug.Trace
-
-
-
--- ** Mutable fill-phase tables.
-
--- | The backtracking version.
-
-
-
-
-
--- TODO empty table @ms@ stuff
-
-instance
-  ( Monad m
-  , Element ls (BS2I First Last)
-  , PA.PrimArrayOps arr (BS2I First Last) x
-  , MkStream m ls (BS2I First Last)
-  ) => MkStream m (ls :!: ITbl m arr (BS2I First Last) x) (BS2I First Last) where
-  -- outermost case. Grab inner indices, calculate the remainder of the
-  -- set, return value
-  mkStream (ls :!: ITbl c t _) Static s (BitSet b:>Interface i:>Interface j)
-    = S.map (\z -> let (BitSet zb:>_:>Interface zj) = getIdx z  -- the bitset we get from the guy before us
-                       here = (BitSet (b `xor` zb .|. zj):>Interface zj:>Interface j) -- everything missing, set common interface
-                   in  ElmITbl (t PA.! here) here z
-            )
-    $ mkStream ls (Variable Check Nothing) s (BitSet (clearBit b j):>Interface i:>Interface j)
-  -- generate all possible subsets of the index. With A @Variable
-  -- _ Nothing@, there is something to the right that will fill up the set.
-  mkStream (ls :!: ITbl c t _) (Variable Check Nothing) full (BitSet b:>Interface i:>Interface j)
-    = S.flatten mk step Unknown
-    $ mkStream ls (Variable Check Nothing) full (BitSet b:>Interface i:>Interface j)
-    where mk z = return (z,Just $ BitSet 0:>Interface 0:>Interface 0)
-          step (_,Nothing) = return $ S.Done
-          step (z,Just s ) = return $ S.Yield (ElmITbl (t PA.! s) s z) (z,succSet full s)
-          {-# Inline [0] mk   #-}
-          {-# Inline [0] step #-}
-  -- generate only those indices with the requested number of set bits
-  {-# Inline mkStream #-}
-
-instance
-  ( Monad mB
-  , Element ls (BS2I First Last)
-  , PA.PrimArrayOps arr (BS2I First Last) x
-  , MkStream mB ls (BS2I First Last)
-  ) => MkStream mB (ls :!: BT (ITbl mF arr (BS2I First Last) x) mF mB r) (BS2I First Last) where
-  mkStream (ls :!: BtITbl c arr bt) Static full (BitSet b:>Interface i:>Interface j)
-    = S.map (\z -> let (BitSet zb:>Interface zi:>Interface zj) = getIdx z
-                       here = BitSet (clearBit b j):>Interface i:>Interface zj
-                       d = arr PA.! here
-                   in ElmBtITbl' d (bt full here) here z)
-    $ mkStream ls (Variable Check Nothing) full (BitSet (clearBit b j):>Interface i:>Interface (-1))
-  mkStream (ls :!: BtITbl c arr bt) (Variable Check Nothing) full (BitSet b:>Interface i:>Interface j)
-    = S.flatten mk step Unknown
-    $ mkStream ls (Variable Check Nothing) full (BitSet b:>Interface i:>Interface j)
-    where mk z = return (z,Just $ BitSet 0:>Interface 0:>Interface 0)
-          step (_,Nothing) = return $ S.Done
-          step (z,Just s ) = return $ S.Yield (ElmBtITbl' (arr PA.! s) (bt full s) s z) (z,succSet full s)
-          {-# Inline [0] mk   #-}
-          {-# Inline [0] step #-}
-  {-# Inline mkStream #-}
-
-instance
-  ( Monad m
-  , Element ls (Outside PointL)
-  , PA.PrimArrayOps arr (Outside PointL) x
-  , MkStream m ls (Outside PointL)
-  ) => MkStream m (ls :!: ITbl m arr (Outside PointL) x) (Outside PointL) where
-  mkStream (ls :!: ITbl c t _) Static lu (O (PointL (i:.j)))
-    = let ms = minSize c in seq ms $ seq t $
-    S.mapM (\s -> let O (PointL (h:.k)) = getIdx s
-                  in  return $ ElmITbl (t PA.! O (pointL k j)) (O $ pointL k j) s)
-    $ mkStream ls (Variable Check Nothing) lu (O . pointL i $ j + ms)
---  mkStream _ _ _ _ = error "mkStream / ITbl / Outside PointL not implemented"
-  {-# INLINE mkStream #-}
-
-instance
-  ( Monad mB
-  , Element ls (Outside PointL)
-  , PA.PrimArrayOps arr (Outside PointL) x
-  , MkStream mB ls (Outside PointL)
-  ) => MkStream mB (ls :!: BT (ITbl mF arr (Outside PointL) x) mF mB r) (Outside PointL) where
-  mkStream (ls :!: BtITbl c arr bt) Static lu (O (PointL (i:.j)))
-    = let ms = minSize c in ms `seq`
-    S.map (\s -> let O (PointL (h:.k)) = getIdx s
-                     ix                = O $ pointL k j
-                     d                 = arr PA.! ix
-                 in ElmBtITbl' d (bt lu ix) ix s)
-    $ mkStream ls (Variable Check Nothing) lu (O . pointL i $ j + ms)
---  mkStream _ _ _ _ = error "mkStream / BT ITbl / Outside PointL not implemented"
-  {-# INLINE mkStream #-}
-
--- | TODO As soon as we don't do static checking on @EmptyOk/NonEmpty@
--- anymore, this works! If we check @c@, we immediately have fusion
--- breaking down!
-
-{-
-instance
-  ( Monad m
-  , Element ls Subword
-  , PA.PrimArrayOps arr Subword x
-  , MkStream m ls Subword
-  ) => MkStream m (ls :!: ITbl m arr Subword x) Subword where
-  mkStream (ls :!: ITbl c t _) Static lu (Subword (i:.j))
-    = let ms = minSize c in ms `seq`
-      S.mapM (\s -> let Subword (_:.l) = getIdx s
-                    in  return $ ElmITbl (t PA.! subword l j) (subword l j) s)
-    $ mkStream ls (Variable Check Nothing) lu (subword i $ j - ms) -- - minSize c)
-  mkStream (ls :!: ITbl c t _) (Variable _ Nothing) lu (Subword (i:.j))
-    = let ms = minSize c
-          {- data PBI a = PBI !a !(Int#)
-          mk s = let (Subword (_:.l)) = getIdx s ; !(I# jlm) = j-l-ms in return $ PBI s jlm
-          step !(PBI s z) | 1# <- z >=# 0# = do let (Subword (_:.k)) = getIdx s
-                                                return $ S.Yield (ElmITbl (t PA.! subword k (j-(I# z))) (subword k $ j-(I# z)) s) (PBI s (z -# 1#))
-                          | otherwise = return S.Done
-          -}
-          {-
-          mk s = let (Subword (_:.l)) = getIdx s in return (s :. j - l - ms)
-          step (s:.z) | 1# <- z' >=# 0# = do let (Subword (_:.k)) = getIdx s
-                                             return $ S.Yield (ElmITbl (t PA.! subword k (j-z)) (subword k $ j-z) s) (s:.z-1)
-                      | otherwise = return S.Done
-                      where !(I# z') = z
-          -}
-          mk s = let (Subword (_:.l)) = getIdx s in return (s :. j - l - ms)
-          step (s:.z) | z>=0 = do let (Subword (_:.k)) = getIdx s
-                                  return $ S.Yield (ElmITbl (t PA.! subword k (j-z)) (subword k $ j-z) s) (s:.z-1)
-                      | otherwise = return S.Done
-          {-# INLINE [1] mk #-}
-          {-# INLINE [1] step #-}
-      in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (subword i j)
-  {-# INLINE mkStream #-}
--}
-
-{-
-instance
-  ( Monad mB
-  , Element ls Subword
-  , MkStream mB ls Subword
-  , PA.PrimArrayOps arr Subword x
-  ) => MkStream mB (ls :!: BT (ITbl mF arr Subword x) mF mB r) Subword where
-  mkStream (ls :!: BtITbl c arr bt)  Static lu (Subword (i:.j))
-    = let ms = minSize c in ms `seq`
-      S.map (\s -> let (Subword (_:.l)) = getIdx s
-                       ix               = subword l j
-                       d                = arr PA.! ix
-                   in  ElmBtITbl' d (bt lu ix) ix s)
-      $ mkStream ls (Variable Check Nothing) lu (subword i $ j - ms)
-  mkStream (ls :!: BtITbl c arr bt) (Variable _ Nothing) lu (Subword (i:.j))
-    = let ms = minSize c
-          mk s = let (Subword (_:.l)) = getIdx s in return (s:.j-l-ms)
-          step (s:.z)
-            | z>=0      = do let (Subword (_:.k)) = getIdx s
-                                 ix               = subword k (j-z)
-                                 d                = arr PA.! ix
-                             return $ S.Yield (ElmBtITbl' d (bt lu ix) ix s) (s:.z-1)
-            | otherwise = return $ S.Done
-          {-# INLINE [1] mk   #-}
-          {-# INLINE [1] step #-}
-      in  ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (subword i j)
-  {-# INLINE mkStream #-}
--}
-
-{-
-instance
-  ( Monad m
-  , Element ls (Outside Subword)
-  , PA.PrimArrayOps arr Subword x
-  , MkStream m ls (Outside Subword)
-  ) => MkStream m (ls :!: ITbl m arr Subword x) (Outside Subword) where
-  mkStream (ls :!: ITbl c t _) Static lu (O (Subword (i:.j)))
-    = let ms = minSize c in ms `seq`
-      S.mapM (\s -> let (O (Subword (_:.l))) = getIdx s
-                    in  return $ ElmITbl (t PA.! (subword l j)) (O $ subword l j) s)
-    $ mkStream ls (Variable Check Nothing) lu (O $ subword i $ j - ms) -- - minSize c)
-  mkStream (ls :!: ITbl c t _) (Variable _ Nothing) lu (O (Subword (i:.j)))
-    = let ms = minSize c
-          mk s = let (O( Subword (_:.l))) = getIdx s in return (s :. j - l - ms)
-          step (s:.z) | z>=0 = do let (O (Subword (_:.k))) = getIdx s
-                                  return $ S.Yield (ElmITbl (t PA.! (subword k (j-z))) (O . subword k $ j-z) s) (s:.z-1)
-                      | otherwise = return S.Done
-          {-# INLINE [1] mk #-}
-          {-# INLINE [1] step #-}
-      in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (O $ subword i j)
-  {-# INLINE mkStream #-}
--}
-
-{-
-instance
-  ( Monad m
-  , Element ls (Outside Subword)
-  , PA.PrimArrayOps arr (Outside Subword) x
-  , MkStream m ls (Outside Subword)
-  ) => MkStream m (ls :!: ITbl m arr (Outside Subword) x) (Outside Subword) where
-  mkStream (ls :!: ITbl c t _) Static lu (O (Subword (i:.j)))
-    = let ms = minSize c in ms `seq`
-      S.mapM (\s -> let (O (Subword (_:.l))) = getIdx s
-                    in  return $ ElmITbl (t PA.! (O $ subword l j)) (O $ subword l j) s)
-    $ mkStream ls (Variable Check Nothing) lu (O $ subword i $ j - ms) -- - minSize c)
-  mkStream (ls :!: ITbl c t _) (Variable _ Nothing) lu (O (Subword (i:.j)))
-    = let ms = minSize c
-          mk s = let (O( Subword (_:.l))) = getIdx s in return (s :. j - l - ms)
-          step (s:.z) | z>=0 = do let (O (Subword (_:.k))) = getIdx s
-                                  return $ S.Yield (ElmITbl (t PA.! (O $ subword k (j-z))) (O . subword k $ j-z) s) (s:.z-1)
-                      | otherwise = return S.Done
-          {-# INLINE [1] mk #-}
-          {-# INLINE [1] step #-}
-      in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (O $ subword i j)
-  {-# INLINE mkStream #-}
--}
-
-
-
-
--- * Axiom for backtracking
-
--}
-
diff --git a/ADP/Fusion/SynVar/Array/Point.hs b/ADP/Fusion/SynVar/Array/Point.hs
deleted file mode 100644
--- a/ADP/Fusion/SynVar/Array/Point.hs
+++ /dev/null
@@ -1,79 +0,0 @@
-
-module ADP.Fusion.SynVar.Array.Point where
-
-import Data.Strict.Tuple
-import Data.Vector.Fusion.Stream.Monadic
-import Data.Vector.Fusion.Stream.Size
-import Data.Vector.Fusion.Util (delay_inline)
-import Debug.Trace
-import Prelude hiding (map,mapM)
---import qualified Data.Vector.Fusion.Stream.Monadic as S
-
-import           Data.PrimitiveArray hiding (map)
-
-import           ADP.Fusion.Base
-import           ADP.Fusion.SynVar.Array.Type
-import           ADP.Fusion.SynVar.Backtrack
-
-
-
-instance
-  ( Monad m
-  , Element ls PointL
-  , PrimArrayOps arr PointL x
-  , MkStream m ls PointL
-  ) => MkStream m (ls :!: ITbl m arr PointL x) PointL where
-  mkStream (ls :!: ITbl _ _ c t _) (IStatic d) u j@(PointL pj)
-    = let ms = minSize c in ms `seq`
-    map (ElmITbl (t!j) j (PointL 0))
-    $ mkStream ls (IVariable d) u (PointL $ pj - ms)
-  -- We can't really make sure that this is the only time we access the
-  -- ITbl, so the user should know what they are doing.
-  mkStream (ls :!: ITbl _ _ c t _) (IVariable d) u j@(PointL pj)
-    = flatten mk step Unknown $ mkStream ls (IVariable d) u (delay_inline PointL $! pj - ms)
-    where mk s = let PointL k = getIdx s in return (s :. k)
-          step (s :. k)
-            | k+ms>pj   = return $ Done
-            | otherwise = return $ Yield (ElmITbl (t!PointL k) (PointL k) (PointL 0) s) (s :. k+1)
-          !ms = minSize c
-          {-# Inline [0] mk   #-}
-          {-# Inline [0] step #-}
-  {-# Inline mkStream #-}
-
-instance
-  ( Monad mB
-  , Element ls PointL
-  , PrimArrayOps arr PointL x
-  , MkStream mB ls PointL
-  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr PointL x) mF mB r) PointL where
-  mkStream (ls :!: BtITbl c t bt) (IStatic d) u j@(PointL pj)
-    = let ms = minSize c in ms `seq`
-    mapM (\s -> bt u j >>= \bb -> return $ ElmBtITbl (t!j) (bb {-bt u j-}) j (PointL 0) s)
-    $ mkStream ls (IVariable d) u (PointL $ pj - ms)
-  {-# INLINE mkStream #-}
-
-instance
-  ( Monad m
-  , Element ls (Outside PointL)
-  , PrimArrayOps arr (Outside PointL) x
-  , MkStream m ls (Outside PointL)
-  ) => MkStream m (ls :!: ITbl m arr (Outside PointL) x) (Outside PointL) where
-  mkStream (ls :!: ITbl _ _ c t _) (OStatic d) u (O (PointL pj))
-    = let ms = minSize c in ms `seq`
-    map (\z -> let o = getOmx z
-                 in  ElmITbl (t ! o) o o z)
-    $ mkStream ls (OFirstLeft d) u (O $ PointL $ pj - ms)
-  {-# Inline mkStream #-}
-
-instance
-  ( Monad mB
-  , Element ls (Outside PointL)
-  , PrimArrayOps arr (Outside PointL) x
-  , MkStream mB ls (Outside PointL)
-  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (Outside PointL) x) mF mB r) (Outside PointL) where
-  mkStream (ls :!: BtITbl c t bt) (OStatic d) u (O (PointL pj))
-    = let ms = minSize c in ms `seq`
-    mapM (\s -> let o = getOmx s in bt u o >>= \bb -> return $ ElmBtITbl (t!o) (bb{-bt u o-}) o o s)
-    $ mkStream ls (OFirstLeft d) u (O $ PointL $ pj - ms)
-  {-# INLINE mkStream #-}
-
diff --git a/ADP/Fusion/SynVar/Array/Set.hs b/ADP/Fusion/SynVar/Array/Set.hs
deleted file mode 100644
--- a/ADP/Fusion/SynVar/Array/Set.hs
+++ /dev/null
@@ -1,164 +0,0 @@
-
-module ADP.Fusion.SynVar.Array.Set where
-
-import Data.Bits
-import Data.Bits.Extras
-import Data.Bits.Ordered
-import Data.Strict.Tuple
-import Data.Vector.Fusion.Stream.Monadic
-import Data.Vector.Fusion.Stream.Size
-import Data.Vector.Fusion.Util (delay_inline)
-import Debug.Trace
-import Prelude hiding (map)
-import Control.Applicative ((<$>))
-
-import Data.PrimitiveArray hiding (map)
-
-import ADP.Fusion.Base
-import ADP.Fusion.SynVar.Array.Type
-import ADP.Fusion.SynVar.Backtrack
-
-
-
--- * Bitsets without any interfaces.
-
--- NOTE that we have to give as the filled index elements all bits that are
--- set in total, not just those we set right here. Otherwise the next
--- element will try a wrong set of indices.
---
--- NOTE even in the @IStatic@ case, we need to use flatten. If a node
--- requested a reserved bit, we need to free each reserved bit at least
--- once.
-
-instance
-  ( Monad m
-  , Element ls BitSet
-  , PrimArrayOps arr BitSet x
-  , MkStream m ls BitSet
-  ) => MkStream m (ls :!: ITbl m arr BitSet x) BitSet where
-  mkStream (ls :!: ITbl _ _ c t _) (IStatic rp) u s
-    = flatten mk step Unknown $ mkStream ls (delay_inline IVariable $ rp - csize) u s
-    where !csize | c==EmptyOk  = 0
-                 | c==NonEmpty = 1
-          mk z
-            | cm < csize = return (z , mask , Nothing)
-            | otherwise  = return (z , mask , Just k )
-            where k  = (BitSet $ 2^cm-1)
-                  cm = popCount mask - rp
-                  mask = s `xor` (getIdx z)
-          step (_,_,Nothing) = return $ Done
-          step (z,mask,Just k)
-            | pk > popCount s - rp = return $ Done
-            | otherwise            = let kk = popShiftL mask k
-                                     in  return $ Yield (ElmITbl (t!kk) (kk .|. getIdx z) (BitSet 0) z) (z,mask,setSucc (BitSet 0) (2^pk -1) k)
-            where pk = popCount k
-          {-# Inline [0] mk   #-}
-          {-# Inline [0] step #-}
-  mkStream (ls :!: ITbl _ _ c t _) (IVariable rp) u s
-    = flatten mk step Unknown $ mkStream ls (IVariable rp) u s
-    where mk z
-            | c==EmptyOk  = return (z , mask , cm , Just 0 )
-            | cm == 0     = return (z , mask , cm , Nothing) -- we are non-empty but have no free bits left
-            | c==NonEmpty = return (z , mask , cm , Just 1 )
-            where mask = s `xor` (getIdx z) -- bits that are still free
-                  cm   = popCount mask
-          step (z,mask,cm,Nothing) = return $ Done
-          step (z,mask,cm,Just k )
-            | popCount s < popCount (kk .|. getIdx z) + rp = return $ Done
-            | otherwise = return $ Yield (ElmITbl (t!kk) (kk .|. getIdx z) (BitSet 0) z) (z,mask,cm,setSucc (BitSet 0) (2^cm -1) k)
-            where kk = popShiftL mask k
-          {-# Inline [0] mk   #-}
-          {-# Inline [0] step #-}
-  {-# Inline mkStream #-}
-
-
-
--- * Bitsets with two interfaces.
---
--- NOTE These are annoying to get right, if you also want to have good
--- performance.
-
-instance
-  ( Monad m
-  , Element ls (BS2I First Last)
-  , PrimArrayOps arr (BS2I First Last) x
-  , MkStream m ls (BS2I First Last)
-  , Show x
-  ) => MkStream m (ls :!: ITbl m arr (BS2I First Last) x) (BS2I First Last) where
-  mkStream (ls :!: ITbl _ _ c t _) (IStatic rp) u sij@(s:>i:>j@(Iter jj))
-    = flatten mk step Unknown $ mkStream ls (delay_inline IVariable rpn) u (delay_inline id $ tij)
-          -- calculate new index. if we don't know the right-most interface
-          -- anymore, than someone has taken it already. Also, if this
-          -- synvar may be empty, do not modify the index. Otherwise, if
-          -- @j@ is still known, remove it from the index set.
-    where tij | jj == -1       = sij
-              | c  == EmptyOk  = sij
-              | c  == NonEmpty = s `clearBit` jj :> i :> Iter (-1)
-          -- In case we do not know the rightmost interface, we instead
-          -- increase the number of reserved bits.
-          rpn | jj == -1
-              && c == NonEmpty = rp+1
-              | otherwise      = rp
-          nec | c == NonEmpty = 1
-              | c == EmptyOk  = 0
-          mk z
-            -- in case we have a non-empty synvar but not enough bits, we
-            -- shall have nothing. We only need one extra mask bit, because
-            -- @j@ is still known.
-            | popCount mask < 1 && c == NonEmpty && j >= 0 = return $ Naught
-            -- If @j@ is not known we need two bits to be non-empty.
-            | popCount mask < 2 && c == NonEmpty && j <  0 = return $ Naught
-            -- Not enough bits to reserve.
-            | popCount mask - rp < 0                       = return $ Naught
-            -- @j@ is still known, just create the sets ending in @j@
-            | j >= 0                                       = return $ This (z,mask)
-            -- @j@ is not known, we have a lot of work to do. Create the
-            -- required @bits@ and prepare a @mask@ which will set the
-            -- correct bits.
-            | j <  0                                       = return $ That (z,mask,Just bits,maybeLsb bits)
-            -- we somehow ended up with an improper state
-            | otherwise                                    = error $ show (sij,mask,bits)
-            where (zs:>_:>Iter zk) = getIdx z
-                  mask             = s `xor` zs
-                  bits             = BitSet $ 2 ^ (popCount mask - rp - nec) - 1
-          step Naught          = return $ Done
-          -- In case @j@ is known, we calculate the bits @msk@ that are not
-          -- filled yet. We grab the previous right interface @zk@ and use
-          -- it as the new left interface. We also use @j@ as the right
-          -- interface. @ix@ holds everything that is now covered, withe
-          -- the interface @i@ and @j@.
-          step (This (z,mask)) = return $ Yield (ElmITbl (t!(msk:>k:>j)) ix undefbs2i z) Naught
-            where (zs:>_:>zk) = getIdx z
-                  k           = Iter $ getIter zk
-                  ix          = (zs .|. msk) :> i :> j
-                  msk         = if popCount mask == 0 then mask else mask `setBit` getIter k `setBit` jj
-          -- whenever there is nothing more to do in the variable case.
-          step (That (z,mask,Nothing,_)) = return $ Done
-          -- We need to permute our population a bit. Once done, we grab
-          -- the lowest significant bit.
-          step (That (z,mask,Just bits,Nothing)) = return $ Skip (That (z,mask,nbts, maybeLsb =<< nbts))
-            where nbts = popPermutation (popCount mask) bits
-          -- The variable case.
-          step (That (z,mask,Just bits,Just y))
-            -- we do not have enough bits to be non-empty.
-            |  popCount bb < 2 && c == NonEmpty
-            -- our two interfaces are the same, but we are non-empty in
-            -- which case this shouldn't happen.
-            || getIter kk == getIter yy && c == NonEmpty
-            -- our pop-count plus reserved count doesn't match up with the
-            -- mask. We skip this as well.
-            || popCount bb + rp /= popCount mask = return $ Skip (That (z,mask,Just bits, maybeNextActive y bits))
-            -- finally, we can create the index for the current stuff
-            -- @bb:>kk:>yy@ and prepare the full index, going from @i@ to
-            -- @yy@, because someone grabbed @j@ already. Must have been
-            -- an @Edge@ or s.th. similar.
-            | otherwise = return $ Yield (ElmITbl (t!(bb:>kk:>yy)) ((zs .|. bb):>i:>yy) undefbs2i z)
-                                                                 (That (z,mask,Just bits, maybeNextActive y bits))
-            where (zs:>_:>zk) = getIdx z
-                  kk          = Iter $ getIter zk
-                  yy          = Iter . lsb $ popShiftL mask (bit y)
-                  bb          = popShiftL mask bits `setBit` getIter kk `setBit` getIter yy
-          {-# Inline [0] mk   #-}
-          {-# Inline [0] step #-}
-  {-# Inline mkStream #-}
-
diff --git a/ADP/Fusion/SynVar/Array/Subword.hs b/ADP/Fusion/SynVar/Array/Subword.hs
deleted file mode 100644
--- a/ADP/Fusion/SynVar/Array/Subword.hs
+++ /dev/null
@@ -1,318 +0,0 @@
-
-{-# Language MagicHash #-}
-
-module ADP.Fusion.SynVar.Array.Subword where
-
-import Data.Strict.Tuple
-import Data.Vector.Fusion.Stream.Size
-import Data.Vector.Fusion.Util (delay_inline)
-import Data.Vector.Fusion.Stream.Monadic
-import Debug.Trace
-import Prelude hiding (map,mapM)
-
-import Data.PrimitiveArray hiding (map)
-
-import ADP.Fusion.Base
-import ADP.Fusion.SynVar.Array.Type
-import ADP.Fusion.SynVar.Backtrack
-
--- TODO think about what we are about to do
-import GHC.Prim (reallyUnsafePtrEquality#)
-
-
-
-
--- TODO delay inline @(subword i $ j - minSize c)@ or face fusion-breakage.
--- Can we just have @Inline [0] subword@ to fix this?
-
-instance
-  ( Monad m
-  , Element ls Subword
-  , PrimArrayOps arr Subword x
-  , MkStream m ls Subword
-  ) => MkStream m (ls :!: ITbl m arr Subword x) Subword where
-  mkStream (ls :!: ITbl _ _ c t _) (IStatic ()) hh (Subword (i:.j))
-    = map (\s -> let (Subword (_:.l)) = getIdx s
-                 in  ElmITbl (t ! subword l j) (subword l j) (subword 0 0) s)
-    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))
-  mkStream (ls :!: ITbl _ _ c t _) (IVariable ()) hh (Subword (i:.j))
-    = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))
-    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - minSize c)
-          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
-                                        l              = j - z
-                                        kl             = subword k l
-                                    return $ Yield (ElmITbl (t ! kl) kl (subword 0 0) s) (s:. z-1)
-                      | otherwise = return $ Done
-          {-# Inline [0] mk   #-}
-          {-# Inline [0] step #-}
-  {-# Inline mkStream #-}
-
-instance
-  ( Monad mB
-  , Element ls Subword
-  , MkStream mB ls Subword
-  , PrimArrayOps arr Subword x
-  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr Subword x) mF mB r) Subword where
-  mkStream (ls :!: BtITbl c t bt) (IStatic ()) hh ij@(Subword (i:.j))
-    = mapM (\s -> let Subword (_:.l) = getIdx s
-                      lj             = subword l j
-                  in  bt hh lj >>= \ ~bb -> return $ ElmBtITbl (t ! lj) (bb {-bt hh lj-}) lj (subword 0 0) s)
-    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))
-  mkStream (ls :!: BtITbl c t bt) (IVariable ()) hh ij@(Subword (i:.j))
-    = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))
-    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - minSize c)
-          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
-                                        l              = j - z
-                                        kl             = subword k l
-                                    bt hh kl >>= \ ~bb -> return $ Yield (ElmBtITbl (t ! kl) (bb {-bt hh kl-}) kl (subword 0 0) s) (s:.z-1)
-                      | otherwise = return $ Done
-          {-# Inline [0] mk   #-}
-          {-# Inline [0] step #-}
-  {-# Inline mkStream #-}
-
-
-instance
-  ( Monad m
-  , Element ls (Outside Subword)
-  , PrimArrayOps arr (Outside Subword) x
-  , MkStream m ls (Outside Subword)
-  ) => MkStream m (ls :!: ITbl m arr (Outside Subword) x) (Outside Subword) where
-  -- TODO what about @c / minSize@
-  mkStream (ls :!: ITbl _ _ c t _) (OStatic (di:.dj)) u ij@(O (Subword (i:.j)))
-    = map (\s -> let O (Subword (k:._)) = getOmx s
-                     kj = O $ Subword (k:.j+dj)
-                 in  ElmITbl (t ! kj) (O $ Subword (i:.j+dj)) kj s) -- @ij@ or s.th. else shouldn't matter?
-    $ mkStream ls (OFirstLeft (di:.dj)) u ij
-  mkStream (ls :!: ITbl _ _ c t _) (ORightOf (di:.dj)) u@(O (Subword (_:.h))) ij@(O (Subword (i:.j)))
-    = flatten mk step Unknown $ mkStream ls (OFirstLeft (di:.dj)) u ij
-      where mk s = return (s:.j+dj)
-            step (s:.l) | l <= h = do let (O (Subword (k:._))) = getIdx s
-                                          kl = O $ Subword (k:.l)
-                                      return $ Yield (ElmITbl (t ! kl) (O (Subword (j+dj:.j+dj))) kl s) (s:.l+1)
-                        | otherwise = return $ Done
-            {-# Inline [0] mk   #-}
-            {-# Inline [0] step #-}
-  mkStream (ls :!: ITbl _ _ c t _) (OFirstLeft d) u ij = error "Array/Outside Subword : OFirstLeft : should never be reached!"
-  mkStream (ls :!: ITbl _ _ c t _) (OLeftOf d) u ij = error "Array/Outside Subword : OLeftOf : should never be reached!"
-  {-# Inline mkStream #-}
-
-
-
-instance
-  ( Monad m
-  , Element ls (Outside Subword)
-  , PrimArrayOps arr Subword x
-  , MkStream m ls (Outside Subword)
-  ) => MkStream m (ls :!: ITbl m arr Subword x) (Outside Subword) where
-  -- TODO what about @c / minSize@
-  mkStream (ls :!: ITbl _ _ c t _) (OStatic (di:.dj)) u ij@(O (Subword (i:.j)))
-    = map (\s -> let O (Subword (_:.k))     = getIdx s
-                     o@(O (Subword (_:.l))) = getOmx s
-                     kl = Subword (k-dj:.l-dj)
-                 in ElmITbl (t ! kl) (O (Subword (k:.l))) o s)
-    $ mkStream ls (ORightOf (di:.dj)) u ij
-  mkStream (ls :!: ITbl _ _ c t _) (ORightOf d) u@(O (Subword (_:.h))) ij@(O (Subword (i:.j)))
-    = flatten mk step Unknown $ mkStream ls (ORightOf d) u ij
-    where mk s = let O (Subword (_:.l)) = getIdx s
-                 in  return (s :.l:.l + minSize c)
-          step (s:.k:.l)
-            | let O (Subword (_:.o)) = getOmx s
-            , l <= o = do let kl = Subword (k:.l)
-                          return $ Yield (ElmITbl (t ! kl) (O kl) (getOmx s) s) (s:.k:.l+1)
-            | otherwise = return $ Done
-          {-# Inline [0] mk   #-}
-          {-# Inline [0] step #-}
-  mkStream (ls :!: ITbl _ _ c t _) (OFirstLeft (di:.dj)) u ij@(O (Subword (i:.j)))
-    = map (\s -> let O (Subword (l:._)) = getOmx s
-                     O (Subword (_:.k)) = getIdx s
-                     kl = Subword (k:.i-di)
-                 in  ElmITbl (t ! kl) (O kl) (getOmx s) s)
-    $ mkStream ls (OLeftOf (di:.dj)) u ij
-  mkStream (ls :!: ITbl _ _ c t _) (OLeftOf d) u ij@(O (Subword (i:.j)))
-    = flatten mk step Unknown $ mkStream ls (OLeftOf d) u ij
-    where mk s = let O (Subword (_:.l)) = getIdx s in return (s:.l)
-          step (s:.l) | l <= i = do let O (Subword (_:.k)) = getIdx s
-                                        kl = Subword (k:.l)
-                                    return $ Yield (ElmITbl (t ! kl) (O kl) (getOmx s) s) (s:.l+1)
-                      | otherwise = return $ Done
-          {-# Inline [0] mk   #-}
-          {-# Inline [0] step #-}
-  {-# Inline mkStream #-}
-
-instance
-  ( Monad m
-  , Element ls (Complement Subword)
-  , PrimArrayOps arr Subword x
-  , MkStream m ls (Complement Subword)
-  ) => MkStream m (ls :!: ITbl m arr Subword x) (Complement Subword) where
-  mkStream (ls :!: ITbl _ _ c t _) Complemented u ij
-    = map (\s -> let (C ix) = getIdx s
-                 in  ElmITbl (t ! ix) (C ix) (getOmx s) s)
-    $ mkStream ls Complemented u ij
-  {-# Inline mkStream #-}
-
-instance
-  ( Monad m
-  , Element ls (Complement Subword)
-  , PrimArrayOps arr (Outside Subword) x
-  , MkStream m ls (Complement Subword)
-  ) => MkStream m (ls :!: ITbl m arr (Outside Subword) x) (Complement Subword) where
-  mkStream (ls :!: ITbl _ _ c t _) Complemented u ij
-    = map (\s -> let (C ox) = getOmx s      -- TODO shouldn't this be @getIdx@ as well? on the count of everything being terminals in Complement?
-                 in  ElmITbl (t ! (O ox)) (getIdx s) (C ox) s)
-    $ mkStream ls Complemented u ij
-  {-# Inline mkStream #-}
-
-
-
-instance ModifyConstraint (ITbl m arr Subword x) where
-  toNonEmpty (ITbl b l _ arr f) = ITbl b l NonEmpty arr f
-  toEmpty    (ITbl b l _ arr f) = ITbl b l EmptyOk  arr f
-  {-# Inline toNonEmpty #-}
-  {-# Inline toEmpty #-}
-
-instance ModifyConstraint (Backtrack (ITbl mF arr Subword x) mF mB r) where
-  toNonEmpty (BtITbl _ arr bt) = BtITbl NonEmpty arr bt
-  toEmpty    (BtITbl _ arr bt) = BtITbl EmptyOk  arr bt
-  {-# Inline toNonEmpty #-}
-  {-# Inline toEmpty #-}
-
-
-
-instance
-  ( Monad m
-  , Element ls Subword -- (Z:.Subword:.Subword)
-  , FirstSecond ls (arr (Z:.Subword:.Subword) x)
-  , FirstSecondIdx ls (arr (Z:.Subword:.Subword) x) Subword
-  , PrimArrayOps arr (Z:.Subword:.Subword) x
-  , MkStream m ls Subword
-  , Show x
-  ) => MkStream m (ls :!: ITbl m arr (Z:.Subword:.Subword) x) Subword where
-  mkStream (ls :!: ITbl _ _ c t elm) (IStatic ()) hh (Subword (i:.j))
-    = map (\s -> let (Subword (_:.l)) = getIdx s
-                     ab               = if greenLight ls t
-                                          then greenIdx ls (undefined :: Subword) t s
-                                          else subword 0 0
-                 in  -- traceShow ("13",ab,subword l j,t!(Z:.ab:.subword l j)) $
-                     ElmITbl (t ! (Z:.ab:.subword l j)) (subword l j) (subword 0 0) s)
-    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - 0))
-  mkStream (ls :!: ITbl _ _ c t elm) (IVariable ()) hh (Subword (i:.j))
-    = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - 0))
-    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - 0)
-          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
-                                        l              = j - z
-                                        kl             = subword k l
-                                        ab             = if greenLight ls t
-                                                           then greenIdx ls (undefined :: Subword) t s
-                                                           else subword 0 0
-                                    --traceShow ("02",ab,subword k l,t!(Z:.ab:.subword k l)) $
-                                    return $ Yield (ElmITbl (t ! (Z:.ab:.kl)) kl (subword 0 0) s) (s:.z-1)
-                      | otherwise = return $ Done
-          {-# Inline [0] mk   #-}
-          {-# Inline [0] step #-}
-  {-# Inline mkStream #-}
-
-instance
-  ( Monad mB
-  , FirstSecond ls (arr (Z:.Subword:.Subword) x)
-  , FirstSecondIdx ls (arr (Z:.Subword:.Subword) x) Subword
-  , PrimArrayOps arr (Z:.Subword:.Subword) x
-  , Element ls Subword
-  , MkStream mB ls Subword
-  , Show r
-  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (Z:.Subword:.Subword) x) mF mB r) Subword where
-  mkStream (ls :!: BtITbl c t bt) (IStatic ()) hh (Subword (i:.j))
-    = mapM (\s -> let (Subword (_:.l)) = getIdx s
-                      lj               = subword l j
-                      light            = greenLight ls t
-                      ab               = if light
-                                           then greenIdx ls (undefined :: Subword) t s
-                                           else lj -- subword 0 0
-                      ablj             = if light
-                                           then Z:.ab:.lj
-                                           else Z:.subword 0 0:.subword 0 0 -- Z:.lj:.lj
-                  in bt (Prelude.snd $ bounds t) ablj >>= \ ~bb -> {- traceShow (ab,lj,bb) $ -} return $ ElmBtITbl (t ! ablj) bb lj (subword 0 0) s)
-    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - 0))
-  mkStream (ls :!: BtITbl c t bt) (IVariable ()) hh (Subword (i:.j))
-    = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - 0))
-    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - 0)
-          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
-                                        l              = j - z
-                                        kl             = subword k l
-                                        light          = greenLight ls t
-                                        ab             = if light
-                                                           then greenIdx ls (undefined :: Subword) t s
-                                                           else kl -- subword 0 0
-                                        abkl           = if light
-                                                           then Z:.ab:.kl
-                                                           else Z:.subword 0 0:.subword 0 0 -- Z:.kl:.kl
-                                    bt (Prelude.snd $ bounds t) abkl >>= \ ~bb -> {- traceShow (ab,kl,bb) $ -} return $ Yield (ElmBtITbl (t!abkl) bb kl (subword 0 0) s) (s:.z-1)
-                      | otherwise = return $ Done
-          {-# Inline [0] mk   #-}
-          {-# Inline [0] step #-}
-  {-# Inline mkStream #-}
-
--- | Get the previous index; this should really be made generic!
---
--- TODO This is probably a REALLY STUPID IDEA ;-)
-
-class FirstSecond x k where
-  greenLight :: x -> k -> Bool
-
-class FirstSecondIdx x k i where
-  greenIdx :: x -> i -> k -> Elm x i -> Subword
-
-instance FirstSecond S k where
-  greenLight S _ = False
-  {-# Inline greenLight #-}
-
-
-
-instance
-  ( FirstSecond ls (arr (Z:.Subword:.Subword) x)
-  ) => FirstSecond (ls :!: ITbl m arr (Z:.Subword:.Subword) x) (arr (Z:.Subword:.Subword) x) where
-  greenLight (ls :!: ITbl _ _ _ t _) t' =
-    case reallyUnsafePtrEquality# t t' of
-      -- TODO speaking of stupid ideas!
-      1# -> True
-      _  -> greenLight ls t'
-  {-# Inline greenLight #-}
-
-instance
-  ( FirstSecond ls (arr (Z:.Subword:.Subword) x)
-  ) => FirstSecond (ls :!: Backtrack (ITbl mF arr (Z:.Subword:.Subword) x) mF mB r) (arr (Z:.Subword:.Subword) x) where
-  greenLight (ls :!: BtITbl _ t _) t' =
-    case reallyUnsafePtrEquality# t t' of
-      -- TODO speaking of stupid ideas!
-      1# -> True
-      _  -> greenLight ls t'
-  {-# Inline greenLight #-}
-
-
-
-instance FirstSecondIdx S k i where
-  greenIdx S _ _ _ = error "shouldn't arrive here!"
-  {-# Inline greenIdx #-}
-
-instance
-  ( FirstSecondIdx ls (arr (Z:.Subword:.Subword) x) Subword
-  , Elm ls Subword ~ RecElm (ls :!: ITbl m arr (Z:.Subword:.Subword) x) Subword
-  , Element ls Subword
-  ) => FirstSecondIdx (ls :!: ITbl m arr (Z:.Subword:.Subword) x) (arr (Z:.Subword:.Subword) x) Subword where
-  greenIdx (ls :!: ITbl _ _ _ t _) _ t' e =
-    case reallyUnsafePtrEquality# t t' of
-      1# -> let ab = getIdx e in ab
-      _  -> let g = getElm e in greenIdx ls (undefined :: Subword) t' g
-  {-# Inline greenIdx   #-}
-
-instance
-  ( FirstSecondIdx ls (arr (Z:.Subword:.Subword) x) Subword
-  , Elm ls Subword ~ RecElm (ls :!: Backtrack (ITbl mF arr (Z:.Subword:.Subword) x) mF mB r) Subword
-  , Element ls Subword
-  ) => FirstSecondIdx (ls :!: Backtrack (ITbl mF arr (Z:.Subword:.Subword) x) mF mB r) (arr (Z:.Subword:.Subword) x) Subword where
-  greenIdx (ls :!: BtITbl _ t _) _ t' e =
-    case reallyUnsafePtrEquality# t t' of
-      1# -> let ab = getIdx e in ab
-      _  -> let g = getElm e in greenIdx ls (undefined :: Subword) t' g
-  {-# Inline greenIdx   #-}
-
diff --git a/ADP/Fusion/SynVar/Array/TermSymbol.hs b/ADP/Fusion/SynVar/Array/TermSymbol.hs
deleted file mode 100644
--- a/ADP/Fusion/SynVar/Array/TermSymbol.hs
+++ /dev/null
@@ -1,110 +0,0 @@
-
--- | TODO migrate instances to correct modules
-
-module ADP.Fusion.SynVar.Array.TermSymbol where
-
-import Data.Strict.Tuple hiding (snd)
-import Data.Vector.Fusion.Stream.Size
-import Data.Vector.Fusion.Util (delay_inline)
-import Data.Vector.Fusion.Stream.Monadic
-import Debug.Trace
-import Prelude hiding (map,mapM)
-
-import Data.PrimitiveArray hiding (map)
-
-import ADP.Fusion.Base
-import ADP.Fusion.SynVar.Array.Type
-import ADP.Fusion.SynVar.Backtrack
-
-
-
--- | TODO need to deal with @minSize@
-
-instance
-  ( Monad m
-  , TerminalStream m a is
-  , PrimArrayOps arr Subword x
-  , Show x
-  ) => TerminalStream m (TermSymbol a (ITbl m arr Subword x)) (is:.Subword) where
-  terminalStream (a :| ITbl _ _ c t _) (sv:.IStatic _) (is:.ix@(Subword (i:.j)))
-    = map (\ (S6 s (zi:.(Subword (a:.l))) (zo:._) is os e) ->
-              let lj = subword l j
-              in  {- traceShow (i,a,' ',l,j,t!lj) $ -} S6 s zi zo (is:.lj) (os:.subword 0 0) (e:.(t!lj)) )
-    . iPackTerminalStream a sv (is:.ix)
-  terminalStream (a :| ITbl _ _ c t _) (sv:.IVariable _) (is:.ix@(Subword (i:.j)))
-    = flatten mk step Unknown . iPackTerminalStream a sv (is:.ix)
-    where mk (S6 s (zi:.(Subword (_:.l))) (zo:._) is os e) = return (S6 s zi zo is os e :. l :. j - l) -- TODO minsize c !
-          step (s6:.k:.z) | z >= 0 = do let S6 s zi zo is os e = s6
-                                            l                  = j - z
-                                            kl                 = subword k l
-                                        return $ Yield (S6 s zi zo (is:.kl) (os:.subword 0 0) (e:.(t!kl))) (s6 :. k :. z-1)
-                          | otherwise = return $ Done
-          {-# Inline [0] mk   #-}
-          {-# Inline [0] step #-}
-  {-# Inline terminalStream #-}
-
-instance
-  ( Monad mB
-  , TerminalStream mB a is
-  , PrimArrayOps arr Subword x
-  ) => TerminalStream mB (TermSymbol a (Backtrack (ITbl mF arr Subword x) mF mB r)) (is:.Subword) where
-  terminalStream (a :| BtITbl c t bt) (sv:.IStatic _) (is:.ix@(Subword (i:.j)))
-    = mapM (\ (S6 s (zi:.(Subword (_:.l))) (zo:._) is os e) ->
-              let lj = subword l j
-                  hh = snd $ bounds t
-              in  bt hh lj >>= \ ~bb -> return $ S6 s zi zo (is:.lj) (os:.subword 0 0) (e:.(t!lj, bb)) )
-    . iPackTerminalStream a sv (is:.ix)
-  terminalStream (a :| BtITbl c t bt) (sv:.IVariable _) (is:.ix@(Subword (i:.j)))
-    = flatten mk step Unknown . iPackTerminalStream a sv (is:.ix)
-    where mk (S6 s (zi:.(Subword (_:.l))) (zo:._) is os e) = return (S6 s zi zo is os e :. l :. j - l) -- TODO minsize c !
-          step (s6:.k:.z) | z >= 0 = do let S6 s zi zo is os e = s6
-                                            l                  = j - z
-                                            kl                 = subword k l
-                                            hh                 = snd $ bounds t
-                                        bt hh kl >>= \ ~bb -> return $ Yield (S6 s zi zo (is:.kl) (os:.subword 0 0) (e:.(t!kl,bb))) (s6 :. k :. z-1)
-                          | otherwise = return $ Done
-          {-# Inline [0] mk   #-}
-          {-# Inline [0] step #-}
-  {-# Inline terminalStream #-}
-
-
-instance TermStaticVar (ITbl m arr Subword x) Subword where
-  termStaticVar _ (IStatic   d) _ = IVariable d
-  termStaticVar _ (IVariable d) _ = IVariable d
-  termStreamIndex (ITbl _ _ _ _ _) (IStatic   d) (Subword (i:.j)) = subword i j -- TODO minSize handling !
-  termStreamIndex (ITbl _ _ _ _ _) (IVariable d) (Subword (i:.j)) = subword i j -- TODO minsize handling
-  {-# Inline [0] termStaticVar   #-}
-  {-# Inline [0] termStreamIndex #-}
-
-instance TermStaticVar (Backtrack (ITbl mF arr Subword x) mF mB r) Subword where
-  termStaticVar _ (IStatic   d) _ = IVariable d
-  termStaticVar _ (IVariable d) _ = IVariable d
-  termStreamIndex (BtITbl _ _ _) (IStatic   d) (Subword (i:.j)) = subword i j -- TODO minSize handling !
-  termStreamIndex (BtITbl _ _ _) (IVariable d) (Subword (i:.j)) = subword i j -- TODO minsize handling
-  {-# Inline [0] termStaticVar   #-}
-  {-# Inline [0] termStreamIndex #-}
-
-
-{-
-  mkStream (ls :!: ITbl _ _ c t _) (IVariable ()) hh (Subword (i:.j))
-    = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))
-    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - minSize c)
-          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
-                                        l              = j - z
-                                        kl             = subword k l
-                                    return $ Yield (ElmITbl (t ! kl) kl (subword 0 0) s) (s:. z-1)
-                      | otherwise = return $ Done
-
-  terminalStream (a:|Chr f v) (sv:.IVariable _) (is:.ix@(Subword (i:.j)))
-    = S.map (\(S6 s (zi:.Subword (_:.l)) (zo:._) is os e) -> S6 s zi zo (is:.subword l (l+1)) (os:.subword 0 0) (e:.f v l))
-    . iPackTerminalStream a sv (is:.ix)
-  {-# Inline terminalStream #-}
-
-instance TermStaticVar (Chr r x) Subword where
-  termStaticVar _ sv _ = sv
-  termStreamIndex _ _ (Subword (i:.j)) = subword i (j-1)
-  {-# Inline [0] termStaticVar   #-}
-  {-# Inline [0] termStreamIndex #-}
-
--}
-
diff --git a/ADP/Fusion/SynVar/Array/Type.hs b/ADP/Fusion/SynVar/Array/Type.hs
deleted file mode 100644
--- a/ADP/Fusion/SynVar/Array/Type.hs
+++ /dev/null
@@ -1,154 +0,0 @@
-
-module ADP.Fusion.SynVar.Array.Type where
-
-import Data.Strict.Tuple hiding (uncurry,snd)
-import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM)
-import Debug.Trace
-import Prelude hiding (map,head,mapM)
-
-import Data.PrimitiveArray hiding (map)
-
-import ADP.Fusion.Base
-import ADP.Fusion.SynVar.Backtrack
-import ADP.Fusion.SynVar.Axiom
-import ADP.Fusion.SynVar.Indices
-
-
-
--- | Immutable table.
-
-data ITbl m arr i x where
-  ITbl :: { iTblBigOrder    :: !Int
-          , iTblLittleOrder :: !Int
-          , iTblConstraint  :: !(TblConstraint i)
-          , iTblArray       :: !(arr i x)
-          , iTblFun         :: !(i -> i -> m x)
-          } -> ITbl m arr i x
-
-instance Build (ITbl m arr i x)
-
-type instance TermArg (TermSymbol a (ITbl m arr i x)) = TermArg a :. x
-
-instance GenBacktrackTable (ITbl mF arr i x) mF mB r where
-  data Backtrack (ITbl mF arr i x) mF mB r = BtITbl !(TblConstraint i) !(arr i x) (i -> i -> mB [r])
-  type BacktrackIndex (ITbl mF arr i x) = i
-  toBacktrack (ITbl _ _ c arr _) _ bt = BtITbl c arr bt
-  {-# Inline toBacktrack #-}
-
-type instance TermArg (TermSymbol a (Backtrack (ITbl mF arr i x) mF mB r)) = TermArg a :. (x,[r])
-
-instance
-  ( Monad m
-  , PrimArrayOps arr i x
-  , IndexStream i
-  ) => Axiom (ITbl m arr i x) where
-  type AxiomStream (ITbl m arr i x) = m x
-  axiom (ITbl _ _ c arr _) = do
-    k <- (head . uncurry streamDown) $ bounds arr
-    return $ arr ! k
-  {-# Inline axiom #-}
-
-instance
-  ( Monad mB
-  , PrimArrayOps arr i x
-  , IndexStream i
-  ) => Axiom (Backtrack (ITbl mF arr i x) mF mB r) where
-  type AxiomStream (Backtrack (ITbl mF arr i x) mF mB r) = mB [r]
-  axiom (BtITbl c arr bt) = do
-    h <- (head . uncurry streamDown) $ bounds arr
-    bt (snd $ bounds arr) h
-  {-# Inline axiom #-}
-
-instance Element ls i => Element (ls :!: ITbl m arr j x) i where
-  data Elm    (ls :!: ITbl m arr j x) i = ElmITbl !x !i !i !(Elm ls i)
-  type Arg    (ls :!: ITbl m arr j x)   = Arg ls :. x
-  type RecElm (ls :!: ITbl m arr j x) i = Elm ls i
-  getArg (ElmITbl x _ _ ls) = getArg ls :. x
-  getIdx (ElmITbl _ i _ _ ) = i
-  getOmx (ElmITbl _ _ o _ ) = o
-  getElm (ElmITbl _ _ _ ls) = ls
-  {-# Inline getArg #-}
-  {-# Inline getIdx #-}
-  {-# Inline getOmx #-}
-  {-# Inline getElm #-}
-
-deriving instance (Show i, Show (Elm ls i), Show x) => Show (Elm (ls :!: ITbl m arr j x) i)
-
-instance Element ls i => Element (ls :!: (Backtrack (ITbl mF arr j x) mF mB r)) i where
-  data Elm    (ls :!: (Backtrack (ITbl mF arr j x) mF mB r)) i = ElmBtITbl !x [r] !i !i !(Elm ls i)
-  type Arg    (ls :!: (Backtrack (ITbl mF arr j x) mF mB r))   = Arg ls :. (x, [r])
-  type RecElm (ls :!: (Backtrack (ITbl mF arr j x) mF mB r)) i = Elm ls i
-  getArg (ElmBtITbl x s _ _ ls) = getArg ls :. (x,s)
-  getIdx (ElmBtITbl _ _ i _ _ ) = i
-  getOmx (ElmBtITbl _ _ _ o _ ) = o
-  getElm (ElmBtITbl _ _ _ _ ls) = ls
-  {-# Inline getArg #-}
-  {-# Inline getIdx #-}
-  {-# Inline getOmx #-}
-  {-# Inline getElm #-}
-
-instance (Show x, Show i, Show (Elm ls i)) => Show (Elm (ls :!: (Backtrack (ITbl mF arr i x) mF mB r)) i) where
-  show (ElmBtITbl x _ i o s) = show (x,i,o) ++ " " ++ show s
-
-instance
-  ( Monad m
-  , Element ls (is:.i)
-  , TableStaticVar (is:.i)
-  , TableIndices (is:.i)
-  , MkStream m ls (is:.i)
-  , PrimArrayOps arr (is:.i) x
-  ) => MkStream m (ls :!: ITbl m arr (is:.i) x) (is:.i) where
-  mkStream (ls :!: ITbl _ _ c t _) vs lu is
-    = map (\(S5 s _ _ i o) -> ElmITbl (t ! i) i o s)
-    . tableIndices c vs is
-    . map (\s -> S5 s Z Z (getIdx s) (getOmx s))
-    $ mkStream ls (tableStaticVar vs is) lu (tableStreamIndex c vs is)
-  {-# Inline mkStream #-}
-
-instance
-  ( Monad mB
-  , Element ls (is:.i)
-  , TableStaticVar (is:.i)
-  , TableIndices (is:.i)
-  , MkStream mB ls (is:.i)
-  , PrimArrayOps arr (is:.i) x
-  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (is:.i) x) mF mB r) (is:.i) where
-  mkStream (ls :!: BtITbl c t bt) vs us is
-    = mapM (\(S5 s _ _ i o) -> bt us i >>= \ ~bb -> return $ ElmBtITbl (t ! i) (bb {-bt us i-}) i o s)
-    . tableIndices c vs is
-    . map (\s -> S5 s Z Z (getIdx s) (getOmx s))
-    $ mkStream ls (tableStaticVar vs is) us (tableStreamIndex c vs is)
-  {-# Inline mkStream #-}
-
-instance
-  ( Monad m
-  , Element ls (Outside (is:.i))
-  , TableStaticVar (Outside (is:.i))
-  , TableIndices (Outside (is:.i))
-  , MkStream m ls (Outside (is:.i))
-  , PrimArrayOps arr (Outside (is:.i)) x
-  , Show (is:.i)
-  ) => MkStream m (ls :!: ITbl m arr (Outside (is:.i)) x) (Outside (is:.i)) where
-  mkStream (ls :!: ITbl _ _ c t _) vs lu is
-    = map (\(S5 s _ _ i o) -> ElmITbl (t ! o) i o s)
-    . tableIndices c vs is
-    . map (\s -> S5 s Z Z (getIdx s) (getOmx s))
-    $ mkStream ls (tableStaticVar vs is) lu (tableStreamIndex c vs is)
-  {-# Inline mkStream #-}
-
-instance
-  ( Monad mB
-  , Element ls (Outside (is:.i))
-  , TableStaticVar (Outside (is:.i))
-  , TableIndices (Outside (is:.i))
-  , MkStream mB ls (Outside (is:.i))
-  , PrimArrayOps arr (Outside (is:.i)) x
-  , Show (is:.i)
-  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (Outside (is:.i)) x) mF mB r) (Outside (is:.i)) where
-  mkStream (ls :!: BtITbl c t bt) vs us is
-    = mapM (\(S5 s _ _ i o) -> bt us o >>= \bb -> return $ ElmBtITbl (t ! o) (bb {-bt us o-}) i o s)
-    . tableIndices c vs is
-    . map (\s -> S5 s Z Z (getIdx s) (getOmx s))
-    $ mkStream ls (tableStaticVar vs is) us (tableStreamIndex c vs is)
-  {-# Inline mkStream #-}
-
diff --git a/ADP/Fusion/SynVar/Axiom.hs b/ADP/Fusion/SynVar/Axiom.hs
deleted file mode 100644
--- a/ADP/Fusion/SynVar/Axiom.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-
--- | The 'axiom' runs a backtracking algebra. The name comes from Robert
--- Giegerichs @ADP@ where @axiom@ runs the fully formed algorithm.
-
-module ADP.Fusion.SynVar.Axiom where
-
--- | The Axiom type class
-
-class Axiom t where
-  -- | The corresponding stream being returned by 'axiom'
-  type AxiomStream t :: *
-  -- | Given a table, run the axiom
-  axiom :: t -> AxiomStream t
-
diff --git a/ADP/Fusion/SynVar/Backtrack.hs b/ADP/Fusion/SynVar/Backtrack.hs
deleted file mode 100644
--- a/ADP/Fusion/SynVar/Backtrack.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-
--- | Wrap forward tables in such a way as to allow backtracking via
--- algebras.
-
-module ADP.Fusion.SynVar.Backtrack where
-
-import Data.Vector.Fusion.Stream.Monadic (Stream)
-
-import ADP.Fusion.Base
-
-
-
--- |
---
--- TODO this should go into @ADP.Fusion.Table.Backtrack@, more than just
--- tabulated syntactic vars are going to use it.
---
--- NOTE You probably need to give the @monad morphism@ between @mF@ and
--- @mB@ so as to be able to extract forward results in the backtracking
--- phase.
-
-class GenBacktrackTable t (mF :: * -> *) (mB :: * -> *) r where
-  data Backtrack t (mF :: * -> *) (mB :: * -> *) r :: *
-  type BacktrackIndex t :: *
-  toBacktrack :: t -> (forall a . mF a -> mB a) -> (BacktrackIndex t -> BacktrackIndex t -> mB [r]) -> Backtrack t mF mB r
-
-instance Build (Backtrack t mF mB r)
-
diff --git a/ADP/Fusion/SynVar/Fill.hs b/ADP/Fusion/SynVar/Fill.hs
deleted file mode 100644
--- a/ADP/Fusion/SynVar/Fill.hs
+++ /dev/null
@@ -1,197 +0,0 @@
-
-module ADP.Fusion.SynVar.Fill where
-
-import           Control.Monad.Morph (hoist, MFunctor (..))
-import           Control.Monad.Primitive (PrimMonad (..))
-import           Control.Monad.ST
-import           Control.Monad.Trans.Class (lift, MonadTrans (..))
-import           Data.Vector.Fusion.Util (Id(..))
-import           GHC.Exts (inline)
-import qualified Data.Vector.Fusion.Stream.Monadic as SM
-import           System.IO.Unsafe
-import           Control.Monad (when,forM_)
-import           Data.List (nub,sort)
-import qualified Data.Vector.Unboxed as VU
-import           Data.Proxy
-
-import           Data.PrimitiveArray
-
-import           ADP.Fusion.SynVar.Array -- TODO we want to keep only classes in here, move instances to the corresponding modules
-
-import           Debug.Trace
-
-
-
--- * Specialized table-filling wrapper for 'MTbl's
---
--- TODO table-filling does /not/ work for single-dimensional stuff
-
--- | Run and freeze 'MTbl's. Since actually running the table-filling part
--- is usually the last thing to do, we can freeze as well.
-
-runFreezeMTbls ts = do
-    unsafeRunFillTables $ expose ts
-    freezeTables        $ onlyTables ts
-{-# INLINE runFreezeMTbls #-}
-
-
-
--- * Expose inner mutable tables
-
--- | Expose the actual mutable table with an 'MTbl'. (Should be temporary
--- until 'MTbl's get a more thorough treatment for auto-filling.
-
-class ExposeTables t where
-    type TableFun t   :: *
-    type OnlyTables t :: *
-    expose     :: t -> TableFun t
-    onlyTables :: t -> OnlyTables t
-
-instance ExposeTables Z where
-    type TableFun Z   = Z
-    type OnlyTables Z = Z
-    expose     Z = Z
-    onlyTables Z = Z
-    {-# INLINE expose #-}
-    {-# INLINE onlyTables #-}
-
-
-
--- | A vanilla context-free grammar
-
-data CFG
-
--- | This grammar is a multi-cfg in a monotone setting
-
-data MonotoneMCFG
-
-
--- * Unsafely mutate 'ITbls' and similar tables in the forward phase.
-
--- | Mutate a cell in a stack of syntactic variables.
---
--- TODO generalize to monad morphism via @mmorph@ package. This will allow
--- more interesting @mrph@ functions that can, for example, track some
--- state in the forward phase. (Note that this can be dangerous, we do
--- /not/ want to have this state influence forward results, unless that can
--- be made deterministic, or we'll break Bellman)
-
-class MutateCell (h :: *) (s :: *) (im :: * -> *) (om :: * -> *) i where
-  mutateCell :: Proxy h -> Int -> Int -> (forall a . im a -> om a) -> s -> i -> i -> om ()
-
--- |
-
-class MutateTables (h :: *) (s :: *) (im :: * -> *) (om :: * -> *) where
-  mutateTables :: Proxy h -> (forall a . im a -> om a) -> s -> om s
-
-class TableOrder (s :: *) where
-  tableLittleOrder :: s -> [Int]
-  tableBigOrder :: s -> [Int]
-
-instance TableOrder Z where
-  tableLittleOrder Z = []
-  tableBigOrder Z = []
-  {-# Inline tableLittleOrder #-}
-  {-# Inline tableBigOrder #-}
-
-instance (TableOrder ts) => TableOrder (ts:.ITbl im arr i x) where
-  tableLittleOrder (ts:.ITbl _ tlo _ _ _) = tlo : tableLittleOrder ts
-  tableBigOrder    (ts:.ITbl tbo _ _ _ _) = tbo : tableBigOrder ts
-  {-# Inline tableLittleOrder #-}
-  {-# Inline tableBigOrder #-}
-
--- ** individual instances for filling a *single cell*
-
-instance
-  ( PrimArrayOps  arr i x
-  , MPrimArrayOps arr i x
-  , MutateCell CFG ts im om i
-  , PrimMonad om
-  , Show x, Show i
-  ) => MutateCell CFG (ts:.ITbl im arr i x) im om i where
-  mutateCell h bo lo mrph (ts:.ITbl tbo tlo c arr f) lu i = do
-    mutateCell h bo lo mrph ts lu i
-    when (bo==tbo && lo==tlo) $ do
-      marr <- unsafeThaw arr
-      z <- (inline mrph) $ f lu i
-      writeM marr i z
-  {-# INLINE mutateCell #-}
-
-type ZS2 = Z:.Subword:.Subword
-
-instance
-  ( PrimArrayOps  arr ZS2 x
-  , MPrimArrayOps arr ZS2 x
-  , MutateCell MonotoneMCFG ts im om ZS2
-  , PrimMonad om
-  ) => MutateCell MonotoneMCFG (ts:.ITbl im arr ZS2 x) im om ZS2 where
-  mutateCell h bo lo mrph (ts:.ITbl tbo tlo c arr f) lu iklj@(Z:.Subword (i:.k):.Subword(l:.j)) = do
-    mutateCell h bo lo mrph ts lu iklj
-    when (bo==tbo && lo==tlo && k<=l) $ do
-      marr <- unsafeThaw arr
-      z <- (inline mrph) $ f lu iklj
-      writeM marr iklj z
-  {-# INLINE mutateCell #-}
-
-instance
-  ( PrimArrayOps arr Subword x
-  , MPrimArrayOps arr Subword x
-  , MutateCell h ts im om (Z:.Subword:.Subword)
-  , PrimMonad om
-  ) => MutateCell h (ts:.ITbl im arr Subword x) im om (Z:.Subword:.Subword) where
-  mutateCell h bo lo mrph (ts:.ITbl tbo tlo c arr f) lu@(Z:.Subword (l:._):.Subword(_:.u)) ix@(Z:.Subword (i1:.j1):.Subword (i2:.j2)) = do
-    mutateCell h bo lo mrph ts lu ix
-    when (bo==tbo && lo==tlo && i1==i2 && j1==j2) $ do
-      let i = i1
-      let j = j1
-      marr <- unsafeThaw arr
-      z <- (inline mrph) $ f (subword l u) (subword i j)
-      writeM marr (subword i j) z
-  {-# Inline mutateCell #-}
-
-
-
--- ** individual instances for filling a complete table and extracting the
--- bounds
-
-instance
-  ( Monad om
-  , MutateCell h (ts:.ITbl im arr i x) im om i
-  , PrimArrayOps arr i x
-  , Show i
-  , IndexStream i
-  , TableOrder (ts:.ITbl im arr i x)
-  ) => MutateTables h (ts:.ITbl im arr i x) im om where
-  mutateTables h mrph tt@(_:.ITbl _ _ _ arr _) = do
-    let (from,to) = bounds arr
-    -- TODO (1) find the set of orders for the synvars
-    let !tbos = VU.fromList . nub . sort $ tableBigOrder tt
-    let !tlos = VU.fromList . nub . sort $ tableLittleOrder tt
-    VU.forM_ tbos $ \bo ->
-      flip SM.mapM_ (streamUp from to) $ \k ->
-        VU.forM_ tlos $ \lo ->
-          --traceShow (bo,k,lo) $
-          mutateCell h bo lo (inline mrph) tt to k
-    return tt
-  {-# INLINE mutateTables #-}
-
-instance
-  ( Monad om
-  ) => MutateCell p Z im om i where
-  mutateCell _ _ _ _ Z _ _ = return ()
-  {-# INLINE mutateCell #-}
-
--- | Default table filling, assuming that the forward monad is just @IO@.
---
--- TODO generalize to @MonadIO@ or @MonadPrim@.
-
-mutateTablesDefault :: MutateTables CFG t Id IO => t -> t
-mutateTablesDefault t = unsafePerformIO $ mutateTables (Proxy :: Proxy CFG) (return . unId) t
-{-# INLINE mutateTablesDefault #-}
-
--- | Mutate tables, but observe certain hints. We use this for monotone
--- mcfgs for now.
-
-mutateTablesWithHints :: MutateTables h t Id IO => Proxy h -> t -> t
-mutateTablesWithHints h t = unsafePerformIO $ mutateTables h (return . unId) t
-
diff --git a/ADP/Fusion/SynVar/Indices.hs b/ADP/Fusion/SynVar/Indices.hs
deleted file mode 100644
--- a/ADP/Fusion/SynVar/Indices.hs
+++ /dev/null
@@ -1,144 +0,0 @@
-
--- | With 'tableIndices' we create a stream of legal indices for this table. We
--- need 'tableIndices' in multi-dimensional tables as the type of the
--- multi-dimensional indices is generic.
-
-module ADP.Fusion.SynVar.Indices where
-
-import Data.Vector.Fusion.Stream.Size (Size(Unknown))
-import Data.Vector.Fusion.Stream.Monadic (flatten,map,Stream, Step(..))
-import Prelude hiding (map)
-
-import Data.PrimitiveArray hiding (map)
-
-import ADP.Fusion.Base
-
-
-
-class TableIndices i where
-  tableIndices :: (Monad m) => TblConstraint i -> Context i -> i -> Stream m (S5 z j j i i) -> Stream m (S5 z j j i i)
-
-instance TableIndices Z where
-  tableIndices _ _ _ = id
-  {-# INLINE tableIndices #-}
-
-instance TableIndices (Outside Z) where
-  tableIndices _ _ _ = id
-  {-# INLINE tableIndices #-}
-
-instance TableIndices is => TableIndices (is:.Subword) where
-  tableIndices (cs:._) (vs:.IStatic _) (ixs:.Subword (i:.j))
-    = map (\(S5 s (zi:.Subword (_:.l)) (zo:._) is os) -> S5 s zi zo (is:.subword l j) (os:.subword 0 0))
-    . tableIndices cs vs ixs
-    . map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)
-  -- TODO ? using the defns in TermSymbol.hs for Array syns?
-  {-
-  tableIndices (cs:._) (vs:.IVariable _) (ixs:.Subword (i:.j))
-    = map (\(S5 s (zi:.Subword (_:.l)) (zo:._) is os) -> S5 s zi zo (is:.subword l j) (os:.subword 0 0))
-    . tableIndices cs vs ixs
-    . map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)
-  -}
-  -- TODO minsize handling ? constraint handling?
-  tableIndices (cs:._) (vs:.IVariable _) (ixs:.Subword (i:.j))
-    = flatten mk step Unknown
-    . tableIndices cs vs ixs
-    . map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)
-    where mk (S5 s (zi:.Subword (_:.l)) (zo:._) is os) = return (S5 s zi zo is os :. l :. j - l)
-          step (s5:.k:.z) | z >= 0 = do let S5 s zi zo is os = s5
-                                            l                = j - z
-                                            kl               = subword k l
-                                        return $ Yield (S5 s zi zo (is:.kl) (os:.subword 0 0)) (s5 :. k :. z-1)
-                          | otherwise = return $ Done
-          {-# Inline [0] mk   #-}
-          {-# Inline [0] step #-}
-  {-# Inline tableIndices #-}
-
-{-
-    where mk (S6 s (zi:.(Subword (_:.l))) (zo:._) is os e) = return (S6 s zi zo is os e :. l :. j - l) -- TODO minsize c !
-          step (s6:.k:.z) | z >= 0 = do let S6 s zi zo is os e = s6
-                                            l                  = j - z
-                                            kl                 = subword k l
-                                        return $ Yield (S6 s zi zo (is:.kl) (os:.subword 0 0) (e:.(t!kl))) (s6 :. k :. z-1)
-                          | otherwise = return $ Done
--}
-
-{-
-  tableIndices (cs:.c) (vs:.Static) (is:.Subword (i:.j))
-    = S.map (\(Tr s (x:.Subword (_:.l)) ys) -> Tr s x (is:.subword l j)) -- constraint handled: tableStreamIndex
-    . tableIndices cs vs is
-    . S.map moveIdxTr
-  tableIndices (cs:.OnlyZero) _ _ = error "write me"
-  tableIndices (cs:.c) (vs:.Variable _ Nothing) (is:.Subword (i:.j))
-    = S.flatten mk step Unknown
-    . tableIndices cs vs is
-    . S.map moveIdxTr
-    where mk (Tr s (y:.Subword (_:.l)) xs) = return $ Pn s y xs l (j-l-minSize c)
-          step (Pn s y xs k z)
-            | z>= 0     = return $ S.Yield (Tr s y (xs:.subword k (j-z))) (Pn s y xs k (z-1))
-            | otherwise = return $ S.Done
-          {-# INLINE [1] mk   #-}
-          {-# INLINE [1] step #-}
-  {-# INLINE tableIndices #-}
--}
-
--- | TODO I think we need to check @cs:.c@ here
---
--- TODO yes, handle @Empty@ / @NonEmpty@ !!!
-
-instance TableIndices is => TableIndices (is:.PointL) where
-  tableIndices (cs:._) (vs:.IStatic _) (is:.PointL j)
-    = map (\(S5 s (zi:.PointL _) (zo:.PointL _) is os) -> S5 s zi zo (is:.PointL j) (os:.PointL 0)) -- constraint handled: tableStreamIndex
-    . tableIndices cs vs is
-    . map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)
-  tableIndices (cs:._) (vs:.IVariable d) (is:.PointL j)
-    = flatten mk step Unknown
-    . tableIndices cs vs is
-    . map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)
-    where mk s@(S5 _ (_:.PointL k) _ _ _) = return (s :. k)
-          step (ss@(S5 s (zi:._) (zo:._) is os) :. k)
-            | k > j     = return $ Done
-            | otherwise = return $ Yield (S5 s zi zo (is:.PointL k) (os:.PointL 0)) (ss :. k+1)
-          {-# Inline [0] mk   #-}
-          {-# Inline [0] step #-}
-  {-  TODO re-add later
-  tableIndices (cs:.OnlyZero) _ _ = error "write me"
-  tableIndices (cs:.c) (vs:.IVariable) (is:.PointL j)
-    = flatten mk step Unknown
-    . tableIndices cs vs is
-    . map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)
-    where mk (S5 s (zi:.PointL l) (zo:._) is os) = return $ S6 s zi zo is os (j-l-minSize c)
-          step (S6 s zi zo is os x)
-            | x >= 0    = return $ Yield (S5 s zi zo (is:.PointL (j-x)) (os:.PointL 0)) (S6 s zi zo is os (x-1))
-            | otherwise = return $ Done
-          {-# Inline [1] mk   #-}
-          {-# Inline [1] step #-}
-  -}
-  {-# Inline tableIndices #-}
-
-instance TableIndices (Outside is) => TableIndices (Outside (is:.PointL)) where
-  tableIndices (cs:.c) (vs:.OStatic d) (O (is:.PointL j))
-    = map (\(S5 s (zi:.PointL i) (zo:.PointL o) (O is) (O os)) -> S5 s zi zo (O (is:.PointL i)) (O (os:.PointL o))) -- constraint handled: tableStreamIndex
-    . tableIndices cs vs (O is)
-    . map (\(S5 s zi zo (O (is:.i)) (O (os:.o))) -> S5 s (zi:.i) (zo:.o) (O is) (O os))
-  {-# Inline tableIndices #-}
-
-{-
-instance TableIndices is => TableIndices (is:.PointR) where
-  tableIndices (cs:.c) (vs:.Static) (is:.PointR (i:.j))
-    = S.map (\(Tr s (x:.PointR (_:.l)) ys) -> Tr s x (is:.pointR l j)) -- constraint handled: tableStreamIndex
-    . tableIndices cs vs is
-    . S.map moveIdxTr
-  tableIndices (cs:.OnlyZero) _ _ = error "write me"
-  tableIndices (cs:.c) (vs:.Variable _ Nothing) (is:.PointR (i:.j))
-    = S.flatten mk step Unknown
-    . tableIndices cs vs is
-    . S.map moveIdxTr
-    where mk (Tr s (y:.PointR (_:.l)) xs) = return $ Pn s y xs l (j-l-minSize c)
-          step (Pn s y xs k z)
-            | z>= 0     = return $ S.Yield (Tr s y (xs:.pointR k (j-z))) (Pn s y xs k (z-1))
-            | otherwise = return $ S.Done
-          {-# INLINE [1] mk   #-}
-          {-# INLINE [1] step #-}
-  {-# INLINE tableIndices #-}
--}
-
diff --git a/ADP/Fusion/SynVar/Recursive.hs b/ADP/Fusion/SynVar/Recursive.hs
deleted file mode 100644
--- a/ADP/Fusion/SynVar/Recursive.hs
+++ /dev/null
@@ -1,74 +0,0 @@
-
-module ADP.Fusion.SynVar.Recursive
-  ( module ADP.Fusion.SynVar.Recursive.Type
-  , module ADP.Fusion.SynVar.Recursive.Point
-  , module ADP.Fusion.SynVar.Recursive.Subword
-  ) where
-
-import ADP.Fusion.SynVar.Recursive.Point
-import ADP.Fusion.SynVar.Recursive.Subword
-import ADP.Fusion.SynVar.Recursive.Type
-
-
-{-
-
-
--- * Instances
-
-{-
-instance ModifyConstraint (IRec m Subword x) where
-  toNonEmpty (IRec _ iF iT f) = IRec NonEmpty iF iT f
-  toEmpty    (IRec _ iF iT f) = IRec EmptyOk  iF iT f
-  {-# INLINE toNonEmpty #-}
-  {-# INLINE toEmpty    #-}
-
-instance
-  ( Monad m
-  , Element ls Subword
-  , MkStream m ls Subword
-  ) => MkStream m (ls :!: IRec m Subword x) Subword where
-  mkStream (ls :!: IRec c _ _ f) Static lu (Subword (i:.j))
-    = let ms = minSize c in ms `seq`
-    S.mapM (\s -> let Subword (_:.l) = getIdx s
-                    in  f lu (subword l j) >>= \z -> return $ ElmIRec z (subword l j) s)
-    $ mkStream ls (Variable Check Nothing) lu (subword i $ j - ms)
-  mkStream (ls :!: IRec c _ _ f) (Variable _ Nothing) lu (Subword (i:.j))
-    = let ms = minSize c
-          mk s = let (Subword (_:.l)) = getIdx s in return (s:.j-l-ms)
-          step (s:.z)
-            | z>=0      = do let (Subword (_:.k)) = getIdx s
-                             y <- f lu (subword k (j-z))
-                             return $ S.Yield (ElmIRec y (subword k $ j-z) s) (s:.z-1)
-            | otherwise = return $ S.Done
-          {-# INLINE [1] mk   #-}
-          {-# INLINE [1] step #-}
-      in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (subword i j)
-  {-# INLINE mkStream #-}
-
-instance
-  ( Monad mB
-  , Element ls Subword
-  , MkStream mB ls Subword
-  ) => MkStream mB (ls :!: BT (IRec mF Subword x) mF mB r) Subword where
-  mkStream (ls :!: BtIRec c _ _ f bt) Static lu (Subword (i:.j))
-    = let ms = minSize c in ms `seq`
-      S.mapM (\s -> let (Subword (_:.l)) = getIdx s
-                        ix               = subword l j
-                    in  f lu ix >>= \fx -> return $ ElmBtIRec fx (bt lu ix) ix s)
-      $ mkStream ls (Variable Check Nothing) lu (subword i $ j-ms)
-  mkStream (ls :!: BtIRec c _ _ f bt) (Variable _ Nothing) lu (Subword (i:.j))
-    = let ms = minSize c
-          mk s = let Subword (_:.l) = getIdx s in return (s:.j-l-ms)
-          step (s:.z)
-            | z>=0      = do let Subword (_:.k) = getIdx s
-                                 ix             = subword k (j-z)
-                             f lu ix >>= \fx -> return $ S.Yield (ElmBtIRec fx (bt lu ix) ix s) (s:.z-1)
-            | otherwise = return $ S.Done
-          {-# INLINE [1] mk   #-}
-          {-# INLINE [1] step #-}
-      in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (subword i j)
-  {-# INLINE mkStream #-}
--}
-
--}
-
diff --git a/ADP/Fusion/SynVar/Recursive/Point.hs b/ADP/Fusion/SynVar/Recursive/Point.hs
deleted file mode 100644
--- a/ADP/Fusion/SynVar/Recursive/Point.hs
+++ /dev/null
@@ -1,3 +0,0 @@
-
-module ADP.Fusion.SynVar.Recursive.Point where
-
diff --git a/ADP/Fusion/SynVar/Recursive/Subword.hs b/ADP/Fusion/SynVar/Recursive/Subword.hs
deleted file mode 100644
--- a/ADP/Fusion/SynVar/Recursive/Subword.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-
-module ADP.Fusion.SynVar.Recursive.Subword where
-
-import Data.Strict.Tuple
-import Data.Vector.Fusion.Stream.Monadic
-import Data.Vector.Fusion.Stream.Size
-import Data.Vector.Fusion.Util (delay_inline)
-import Debug.Trace
-import Prelude hiding (map)
-
-import ADP.Fusion.Base
-import ADP.Fusion.SynVar.Recursive.Type
-import ADP.Fusion.SynVar.Backtrack
diff --git a/ADP/Fusion/SynVar/Recursive/Type.hs b/ADP/Fusion/SynVar/Recursive/Type.hs
deleted file mode 100644
--- a/ADP/Fusion/SynVar/Recursive/Type.hs
+++ /dev/null
@@ -1,80 +0,0 @@
-
-module ADP.Fusion.SynVar.Recursive.Type where
-
-import Data.Strict.Tuple ((:!:)(..))
-import Data.Vector.Fusion.Stream.Monadic (Stream,head)
-import Prelude hiding (head)
-
-import Data.PrimitiveArray hiding (map)
-
-import ADP.Fusion.Base
-import ADP.Fusion.SynVar.Backtrack
-import ADP.Fusion.SynVar.Axiom
-
-
-
-data IRec m i x where
-  IRec :: { iRecConstraint  :: !(TblConstraint i)
-          , iRecFrom        :: !i
-          , iRecTo          :: !i
-          , iRecFun         :: !(i -> i -> m x)
-          } -> IRec m i x
-
-
-
-instance Build (IRec m i x)
-
-instance GenBacktrackTable (IRec mF i x) mF mB r where
-  data Backtrack (IRec mF i x) mF mB r = BtIRec !(TblConstraint i) !i !i (i -> i -> mB x) (i -> i -> mB [r]) -- (Stream mB r))
-  type BacktrackIndex (IRec mF i x)         = i
-  toBacktrack (IRec c iF iT f) mrph bt = BtIRec c iF iT (\lu i -> mrph $ f lu i) bt
-  {-# INLINE toBacktrack #-}
-
-
-
-instance
-  ( Monad m
-  , IndexStream i
-  ) => Axiom (IRec m i x) where
-  type AxiomStream (IRec m i x) = m x
-  axiom (IRec c l h fun) = do
-    k <- (head . uncurry streamDown) (l,h)
-    fun h k
-  {-# Inline axiom #-}
-
-instance
-  ( Monad mB
-  , IndexStream i
-  ) => Axiom (Backtrack (IRec mF i x) mF mB r) where
-  type AxiomStream (Backtrack (IRec mF i x) mF mB r) = mB [r] -- (Stream mB r)
-  axiom (BtIRec c l h fun btfun) = do
-    k <- (head . uncurry streamDown) (l,h)
-    btfun h k
-  {-# Inline axiom #-}
-
-
-
-instance Element ls i => Element (ls :!: IRec m i x) i where
-  data Elm (ls :!: IRec m i x) i = ElmIRec !x !i !i !(Elm ls i)
-  type Arg (ls :!: IRec m i x)   = Arg ls :. x
-  getArg (ElmIRec x _ _ ls) = getArg ls :. x
-  getIdx (ElmIRec _ i _ _ ) = i
-  getOmx (ElmIRec _ _ o _ ) = o
-  {-# Inline getArg #-}
-  {-# Inline getIdx #-}
-  {-# Inline getOmx #-}
-
-instance Element ls i => Element (ls :!: (Backtrack (IRec mF i x) mF mB r)) i where
-  data Elm (ls :!: (Backtrack (IRec mF i x) mF mB r)) i = ElmBtIRec !x !(mB (Stream mB r)) !i !i !(Elm ls i)
-  type Arg (ls :!: (Backtrack (IRec mF i x) mF mB r))   = Arg ls :. (x, mB (Stream mB r))
-  getArg (ElmBtIRec x s _ _ ls) = getArg ls :. (x,s)
-  getIdx (ElmBtIRec _ _ i _ _ ) = i
-  getOmx (ElmBtIRec _ _ _ o _ ) = o
-  {-# Inline getArg #-}
-  {-# Inline getIdx #-}
-  {-# Inline getOmx #-}
-
-
-
--- TODO write multi-tape instances
-
diff --git a/ADP/Fusion/SynVar/Split.hs b/ADP/Fusion/SynVar/Split.hs
deleted file mode 100644
--- a/ADP/Fusion/SynVar/Split.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-
--- | Split syntactic variables for multi-cfg dynamic programs.
-
-module ADP.Fusion.SynVar.Split
-  ( module ADP.Fusion.SynVar.Split.Type
-  , module ADP.Fusion.SynVar.Split.Subword
-  ) where
-
-import ADP.Fusion.SynVar.Split.Subword
-import ADP.Fusion.SynVar.Split.Type
-
diff --git a/ADP/Fusion/SynVar/Split/Subword.hs b/ADP/Fusion/SynVar/Split/Subword.hs
deleted file mode 100644
--- a/ADP/Fusion/SynVar/Split/Subword.hs
+++ /dev/null
@@ -1,125 +0,0 @@
-
-module ADP.Fusion.SynVar.Split.Subword where
-
-import Data.Strict.Tuple
-import Data.Proxy
-import Data.Vector.Fusion.Stream.Monadic
-import Data.Vector.Fusion.Stream.Size
-import Data.Vector.Fusion.Util (delay_inline)
-import Debug.Trace
-import GHC.TypeLits
-import Prelude hiding (map,mapM)
-import Data.Type.Equality
-
-import Data.PrimitiveArray hiding (map)
-
-import ADP.Fusion.Base
-import ADP.Fusion.SynVar.Array.Type
-import ADP.Fusion.SynVar.Backtrack
-import ADP.Fusion.SynVar.Split.Type
-
-
-
--- * 'Fragment' and 'Final' instances for 'Split' / 'ITbl'.
-
-instance
-  ( Monad m
-  , Element ls Subword
-  , MkStream m ls Subword
-  ) => MkStream m (ls :!: Split uId Fragment (ITbl m arr j x)) Subword where
-  mkStream (ls :!: Split _) (IStatic ()) hh (Subword (i:.j))
-    = map (\s -> let (Subword (_:.l)) = getIdx s
-                 in  ElmSplitITbl Proxy () (subword l j) (subword 0 0) s)
-    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO (see TODO in @Split@) - minSize c))
-  mkStream (ls :!: Split _) (IVariable ()) hh (Subword (i:.j))
-    = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO (see above) - minSize c))
-    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l) -- TODO - minSize c)
-          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
-                                        l              = j - z
-                                        kl             = subword k l
-                                    return $ Yield (ElmSplitITbl Proxy () kl (subword 0 0) s) (s:. z-1)
-                      | otherwise = return $ Done
-          {-# Inline [0] mk   #-}
-          {-# Inline [0] step #-}
-  {-# Inline mkStream #-}
-
-instance
-  ( Monad m
-  , Element ls Subword
-  , MkStream m ls Subword
-  , SplitIxCol uId (SameSid uId (Elm ls Subword)) (Elm ls Subword)
-  , (SplitIxTy uId (SameSid uId (Elm ls Subword)) (Elm ls Subword) :. Subword) ~ mix
-  ,  (PrimArrayOps arr (SplitIxTy uId (SameSid uId (Elm ls Subword)) (Elm ls Subword) :. Subword) x)
-  ) => MkStream m (ls :!: Split uId Final (ITbl m arr mix x)) Subword where
-  mkStream (ls :!: Split (ITbl _ _ c t elm)) (IStatic ()) hh (Subword (i:.j))
-    = map (\s -> let (Subword (_:.l)) = getIdx s
-                     fmbkm :: mix = collectIx (Proxy :: Proxy uId) s :. subword l j
-                 in  ElmSplitITbl Proxy (t ! fmbkm) (subword l j) (subword 0 0) s)
-    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO (see TODO in @Split@) - minSize c))
-  mkStream (ls :!: Split (ITbl _ _ c t _)) (IVariable ()) hh (Subword (i:.j))
-    = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO - minSize c))
-    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l) -- TODO - minSize c)
-          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
-                                        l              = j - z
-                                        kl             = subword k l
-                                        fmbkm :: mix   = collectIx (Proxy :: Proxy uId) s :. kl
-                                    return $ Yield (ElmSplitITbl Proxy (t ! fmbkm) kl (subword 0 0) s) (s:. z-1)
-                      | otherwise = return $ Done
-          {-# Inline [0] mk   #-}
-          {-# Inline [0] step #-}
-  {-# Inline mkStream #-}
-
-
-
--- * 'Fragment' and 'Final' instances for 'Split' / @Backtrack@ 'ITbl'.
-
-instance
-  ( Monad mB
-  , Element ls Subword
-  , MkStream mB ls Subword
-  ) => MkStream mB (ls :!: Split uId Fragment (Backtrack (ITbl mF arr j x) mF mB r)) Subword where
-  mkStream (ls :!: Split _) (IStatic ()) hh (Subword (i:.j))
-    = map (\s -> let (Subword (_:.l)) = getIdx s
-                 in  ElmSplitBtITbl Proxy () (subword l j) (subword 0 0) s)
-    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO (see TODO in @Split@) - minSize c))
-  mkStream (ls :!: Split _) (IVariable ()) hh (Subword (i:.j))
-    = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO (see above) - minSize c))
-    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l) -- TODO - minSize c)
-          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
-                                        l              = j - z
-                                        kl             = subword k l
-                                    return $ Yield (ElmSplitBtITbl Proxy () kl (subword 0 0) s) (s:. z-1)
-                      | otherwise = return $ Done
-          {-# Inline [0] mk   #-}
-          {-# Inline [0] step #-}
-  {-# Inline mkStream #-}
-
-instance
-  ( Monad mB
-  , Element ls Subword
-  , MkStream mB ls Subword
-  , SplitIxCol uId (SameSid uId (Elm ls Subword)) (Elm ls Subword)
-  , (SplitIxTy uId (SameSid uId (Elm ls Subword)) (Elm ls Subword) :. Subword) ~ mix
-  , (PrimArrayOps arr (SplitIxTy uId (SameSid uId (Elm ls Subword)) (Elm ls Subword) :. Subword) x)
-  ) => MkStream mB (ls :!: Split uId Final (Backtrack (ITbl mF arr mix x) mF mB r)) Subword where
-  mkStream (ls :!: Split (BtITbl c t bt)) (IStatic ()) hh (Subword (i:.j))
-    = mapM (\s -> let (Subword (_:.l)) = getIdx s
-                      lj               = subword l j
-                      fmbkm :: mix     = collectIx (Proxy :: Proxy uId) s :. lj
-                      (_,hhhh)         = bounds t -- This is an ugly hack, but we need a notation of higher bound from somewhere
-                  in  bt hhhh fmbkm >>= \ ~bb -> return $ ElmSplitBtITbl Proxy (t ! fmbkm,bb) lj (subword 0 0) s)
-    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO (see TODO in @Split@) - minSize c))
-  mkStream (ls :!: Split (BtITbl c t bt)) (IVariable ()) hh (Subword (i:.j))
-    = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO - minSize c))
-    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l) -- TODO - minSize c)
-          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
-                                        l              = j - z
-                                        kl             = subword k l
-                                        fmbkm :: mix   = collectIx (Proxy :: Proxy uId) s :. kl
-                                        (_,hhhh)       = bounds t -- same ugly hack
-                                    bt hhhh fmbkm >>= \ ~bb -> return $ Yield (ElmSplitBtITbl Proxy (t ! fmbkm,bb) kl (subword 0 0) s) (s:. z-1)
-                      | otherwise = return $ Done
-          {-# Inline [0] mk   #-}
-          {-# Inline [0] step #-}
-  {-# Inline mkStream #-}
-
diff --git a/ADP/Fusion/SynVar/Split/Type.hs b/ADP/Fusion/SynVar/Split/Type.hs
deleted file mode 100644
--- a/ADP/Fusion/SynVar/Split/Type.hs
+++ /dev/null
@@ -1,186 +0,0 @@
-
--- |
---
--- NOTE /highly experimental/
-
-module ADP.Fusion.SynVar.Split.Type
-  ( module ADP.Fusion.SynVar.Split.Type
-  , Proxy (..)
-  ) where
-
-import Data.Proxy
-import Data.Strict.Tuple
-import Data.Vector.Fusion.Stream.Monadic
-import Data.Vector.Fusion.Stream.Size
-import Data.Vector.Fusion.Util (delay_inline)
-import Debug.Trace
-import GHC.TypeLits
-import Prelude hiding (map,mapM)
-import Data.Type.Equality
-
-import Data.PrimitiveArray hiding (map)
-
-import ADP.Fusion.Base
-import ADP.Fusion.SynVar.Array.Type
-import ADP.Fusion.SynVar.Backtrack
-
-
-
-data SplitType = Fragment | Final
-
--- | The @Arg synVar@ means that we probably need to rewrite the internal
--- type resolution now!
-
-type family CalcSplitType splitType varTy where
-  CalcSplitType Fragment varTy = ()
-  CalcSplitType Final    varTy = varTy
-
--- | Should never fail?
-
-type family ArgTy argTy where
---  ArgTy Z = Z
-  ArgTy (z:.x) = x
-
--- | Wraps a normal non-terminal and attaches a type-level unique identier
--- and z-ordering (with the unused @Z@ at @0@).
---
--- TODO attach empty/non-empty stuff (or get from non-splitted synvar?)
---
--- TODO re-introduce z-ordering later (once we have a sort fun)
-
-newtype Split (uId :: Symbol) {- (zOrder :: Nat) -} (splitType :: SplitType) synVar = Split { getSplit :: synVar }
-
-split :: Proxy (uId::Symbol) -> {- Proxy (zOrder::Nat) -> -} Proxy (splitType::SplitType) -> synVar -> Split uId splitType synVar
-split _ _ = Split
-{-# Inline split #-}
-
---type Spl uId zOrder splitType = forall synVar . Split uId zOrder splitType synVar
-
-instance Build (Split uId splitType synVar)
-
-instance
-  ( Element ls i
-  ) => Element (ls :!: Split uId splitType (ITbl m arr j x)) i where
-  data Elm     (ls :!: Split uId splitType (ITbl m arr j x)) i = ElmSplitITbl !(Proxy uId) !(CalcSplitType splitType x) !i !i !(Elm ls i)
-  type Arg     (ls :!: Split uId splitType (ITbl m arr j x))   = Arg ls :. (CalcSplitType splitType x)
-  type RecElm  (ls :!: Split uId splitType (ITbl m arr j x)) i = Elm ls i
-  getArg (ElmSplitITbl _ x _ _ ls) = getArg ls :. x
-  getIdx (ElmSplitITbl _ _ i _ _ ) = i
-  getOmx (ElmSplitITbl _ _ _ o _ ) = o
-  getElm (ElmSplitITbl _ _ _ _ ls) = ls
-  {-# Inline getArg #-}
-  {-# Inline getIdx #-}
-  {-# Inline getOmx #-}
-  {-# Inline getElm #-}
-
-instance
-  ( Element ls i
-  ) => Element (ls :!: Split uId splitType (Backtrack (ITbl mF arr j x) mF mB r)) i where
-  data Elm     (ls :!: Split uId splitType (Backtrack (ITbl mF arr j x) mF mB r)) i = ElmSplitBtITbl !(Proxy uId) !(CalcSplitType splitType (x, [r])) !i !i !(Elm ls i)
-  type Arg     (ls :!: Split uId splitType (Backtrack (ITbl mF arr j x) mF mB r))   = Arg ls :. (CalcSplitType splitType (x,[r]))
-  type RecElm  (ls :!: Split uId splitType (Backtrack (ITbl mF arr j x) mF mB r)) i = Elm ls i
-  getArg (ElmSplitBtITbl _ xs _ _ ls) = getArg ls :. xs
-  getIdx (ElmSplitBtITbl _ _ i _ _ ) = i
-  getOmx (ElmSplitBtITbl _ _ _ o _ ) = o
-  getElm (ElmSplitBtITbl _ _ _ _ ls) = ls
-  {-# Inline getArg #-}
-  {-# Inline getIdx #-}
-  {-# Inline getOmx #-}
-  {-# Inline getElm #-}
-
-
-
--- | 'collectIx' gobbles up indices that are tagged with the same symbolic
--- identifier.
-
-collectIx
-  :: forall uId ls i .
-     ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)
-     )
-  => Proxy uId -> Elm ls i -> SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)
-collectIx p e = splitIxCol p (Proxy :: Proxy (SameSid uId (Elm ls i))) e
-
--- | Closed type family that gives us a (type) function for type symbol
--- equality.
-
-type family SameSid uId elm :: Bool where
-  SameSid uId (Elm (ls :!: Split sId splitType synVar) i) = uId == sId
-  SameSid uId (Elm (ls :!: TermSymbol a b            ) i) = SameSid uId (TermSymbol a b)
-  SameSid uId M                                           = False
-  SameSid uId (TermSymbol a (Split sId splitType synVar)) = OR (uId == sId) (SameSid uId a)
-  SameSid uId (Elm (ls :!: l                         ) i) = False
-
--- | Type-level @(||)@
-
-type family OR a b where
-  OR False False = False
-  OR a     b     = True
-
--- | @x ++ y@ but for inductive tuples.
---
--- TODO move to PrimitiveArray
-
-class Zconcat x y where
-  type Zpp x y :: *
-  zconcat :: x -> y -> Zpp x y
-
-instance Zconcat x Z where
-  type Zpp x Z = x
-  zconcat x Z = x
-  {-# Inline zconcat #-}
-
-instance 
-  ( Zconcat x z
-  ) => Zconcat x (z:.y) where
-  type Zpp x (z:.y) = Zpp x z :. y
-  zconcat x (z:.y) = zconcat x z :. y
-  {-# Inline zconcat #-}
-
--- WORKS
-
--- | Actually collect split indices based on if we managed to find the
--- right @Split@ synvar (based on the right symbol).
-
-class SplitIxCol (uId::Symbol) (b::Bool) e where
-  type SplitIxTy uId b e :: *
-  splitIxCol :: Proxy uId -> Proxy b -> e -> SplitIxTy uId b e
-
-
-
-instance SplitIxCol uId b (Elm S i) where
-  type SplitIxTy uId b (Elm S i) = Z
-  splitIxCol p b (ElmS _ _) = Z
-  {-# Inline splitIxCol #-}
-
-
-instance
-  ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)
-  , Element (ls :!: l) i
-  , RecElm (ls :!: l) i ~ Elm ls i
-  ) => SplitIxCol uId False (Elm (ls :!: l) i) where
-  type SplitIxTy uId False (Elm (ls :!: l) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)
-  splitIxCol p b e = collectIx p (getElm e)
-  {-# Inline splitIxCol #-}
-
-instance
-  ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)
-  ) => SplitIxCol   uId True (Elm (ls :!: Split sId splitType (ITbl m arr j x)) i) where
-  type SplitIxTy uId True (Elm (ls :!: Split sId splitType (ITbl m arr j x)) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i) :. i
-  splitIxCol p b (ElmSplitITbl _ _ i _ e) = collectIx p e :. i
-  {-# Inline splitIxCol #-}
-
-instance
-  ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)
-  ) => SplitIxCol   uId True (Elm (ls :!: Split sId splitType (Backtrack (ITbl mF arr j x) mF mB r)) i) where
-  type SplitIxTy uId True (Elm (ls :!: Split sId splitType (Backtrack (ITbl mF arr j x) mF mB r)) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i) :. i
-  splitIxCol p b (ElmSplitBtITbl _ _ i _ e) = collectIx p e :. i
-  {-# Inline splitIxCol #-}
-
-instance
-  ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)
-  , Zconcat (SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)) (SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b))
-  ) => SplitIxCol uId True (Elm (ls :!: TermSymbol a b) i) where
-  type SplitIxTy uId True (Elm (ls :!: TermSymbol a b) i) = Zpp (SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)) (SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b))
-  splitIxCol p b (ElmTS t i _ e) = collectIx p e `zconcat` (undefined p t :: SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b))
-  {-# Inline splitIxCol #-}
-
diff --git a/ADP/Fusion/TH.hs b/ADP/Fusion/TH.hs
deleted file mode 100644
--- a/ADP/Fusion/TH.hs
+++ /dev/null
@@ -1,77 +0,0 @@
-
--- | The functions in here auto-create suitable algebra product functions from
--- a signature. Currently, functions @<**@ are supported which have scalar
--- results in the first variable.
---
--- TODO If we want to support classified DP, we shall also need @**<@
--- generating vector-results given a vector result, followed by a scalar
--- result.
---
--- TODO Then we also need @***@ handling the case of vector-to-vector results.
---
--- TODO note the comments in @buildBacktrackingChoice@
-
-module ADP.Fusion.TH
-  ( makeAlgebraProduct
-  , (<||)
-  , (***)
-  ) where
-
-import           Data.List
-import           Data.Tuple.Select
-import           Language.Haskell.TH
-import           Language.Haskell.TH.Syntax
-import qualified Data.Vector.Fusion.Stream.Monadic as SM
-
-import           ADP.Fusion.TH.Backtrack -- (makeBacktrackingProductInstance,(<||))
-import           ADP.Fusion.TH.Common (getRuleResultType)
-
-
-
-makeAlgebraProduct = makeProductInstances
-
-{-
--- | Create the algebra product function from a signature type constructor.
---
--- TODO make the resulting function INLINE
---
--- TODO compare @synTypes@ with the stream argument types of all @hs@ (via their
--- @hns@ names). If there is a mismatch, then either not all non-terminal types
--- have a corresponding choice function or vice versa.
-
-makeAlgebraProductH :: [Name] -> Name -> Q [Dec]
-makeAlgebraProductH hns nm = do
-  rnm <- reify nm
-  case rnm of
-    TyConI (DataD ctx tyConName args cs d) -> case cs of
-      -- we analyze the accessor functions and look for the objective function
-      -- accessor. It's stream parameter is the type of the non-terminal.
-      -- Everything else in accessors are terminal parameters.
-      [RecC dataConName fs'] -> do
-        -- split @fs@ into functions applied to rule RHSs and choice functions (@hs@)
-        let (fs,hs) = partition ((`notElem` hns) . sel1) fs'
-        -- the result types of the @fs@ are the types of the non-terminal symbols
-        let synTypes = nub . map getRuleResultType $ fs
---        funStream <- funD (mkName "<**") [genClauseStream dataConName fs' fs hs]
-        funList   <- funD (mkName "<||") [genClauseBacktrack dataConName fs' fs hs]
-        return
---          [ funStream
-          [ funList
-          , PragmaD $ InlineP (mkName "<||") Inline FunLike AllPhases
-          ]
-      _   -> fail "more than one data ctor"
-    _          -> fail "unsupported data type"
-
--- | Creates a class for each type of product and instances for each
--- signature.
-
-makeClassyProducts :: Name -> Q [Dec]
-makeClassyProducts conName = do
-  c <- lookupValueName "BacktrackingProduct"
-  case c of
-    Nothing -> error "need to create class now and add instance"
-    Just cl -> error "add instance"
-  return []
--}
-
-
diff --git a/ADP/Fusion/TH/Backtrack.hs b/ADP/Fusion/TH/Backtrack.hs
deleted file mode 100644
--- a/ADP/Fusion/TH/Backtrack.hs
+++ /dev/null
@@ -1,524 +0,0 @@
-
--- | Backtracking which uses lists internally. The basic idea is to convert
--- each @Stream@ into a list. The consumer consumes the stream lazily, but
--- allows for fusion to happen. The hope is that this improves total
--- performance in those cases, where backtracking has significant costs.
-
-module ADP.Fusion.TH.Backtrack where
-
-import           Control.Applicative ( (<$>) )
-import           Control.Monad
-import           Control.Monad.Primitive (PrimState, PrimMonad)
-import           Data.List
-import           Data.Tuple.Select
-import           Data.Vector.Fusion.Stream.Monadic (Stream(..))
-import           Debug.Trace
-import           Language.Haskell.TH
-import           Language.Haskell.TH.Instances
-import           Language.Haskell.TH.Syntax
-import qualified Data.Map.Strict as M
-import qualified Data.Vector as V
-import qualified Data.Vector.Fusion.Stream.Monadic as SM
-import qualified Data.Vector.Generic as VG
-import qualified Data.Vector.Generic.Mutable as VGM
-import qualified Data.Vector.Mutable as VM
-
-import           Data.PrimitiveArray ( (:.)(..) , Z(..) )
-
-import           ADP.Fusion.TH.Common
-
-
-
--- | @Backtracking@ products of @f@ and @b@. Choice in @f@ needs to be
--- reduced to a scalar value. It is then compared to the @fst@ values
--- in @b@. From those, @choice b@ selects.
-
-class ProductBacktracking sigF sigB where
-  type SigBacktracking sigF sigB :: *
-  (<||) :: sigF -> sigB -> SigBacktracking sigF sigB
-
--- | The ADP-established product operation. Returns a vector of results,
--- along the lines of what the ADP @f *** b@ provides.
-
-class ProductCombining sigF sigB where
-  type SigCombining sigF sigB :: *
-  (***) :: sigF -> sigB -> SigCombining sigF sigB
-
--- | Creates instances for all products given a signature data type.
-
-makeProductInstances :: Name -> Q [Dec]
-makeProductInstances tyconName = do
-  t <- reify tyconName
-  case t of
-    TyConI (DataD ctx tyConName args cs d) -> do
-      let m = getMonadName args
-      case cs of
-        [RecC dataconName funs] -> do
-          let Just (h,m',x,r) = getObjectiveNames funs
-          mL <- newName "mL"
-          xL <- newName "xL"
-          rL <- newName "rL"
-          mR <- newName "mR"
-          xR <- newName "xR"
-          rR <- newName "rR"
---          let lType    = buildLeftType  tyconName (m', x, r) (mL, xL)        args
-          let lType    = buildRightType tyconName (m', x, r) (mL, xL, rL)    args
-          let rType    = buildRightType tyconName (m', x, r) (mR, xR, rR)    args
-          let (fs,hs) = partition ((`notElem` [h]) . sel1) funs
-          let sigBType = buildSigBacktrackingType  tyconName (m', x, r) xL (mR, xR, rR) args
-          Clause psB (NormalB bB) dsB <- genAlgProdFunctions buildBacktrackingChoice dataconName funs fs hs
-          iB <- [d| instance (Monad $(varT mL), Monad $(varT mR), Eq $(varT xL), $(varT mL) ~ $(varT mR), $(varT xL) ~ $(varT rL))
-                      => ProductBacktracking $(return lType) $(return rType) where
-                          type SigBacktracking $(return lType) $(return rType) = $(return sigBType)
-                          (<||) = $(return $ LamE psB $ LetE dsB bB)
-                          {-# Inline (<||) #-}
-                |]
-          -- TODO might well be that this doesn't work because we re-use
-          -- type names ...
-          vG <- newName "vG"
-          sigPType <- buildSigCombiningType tyconName vG (m', x, r) (mL, xL, rL) (mR, xR, rR) args
-          Clause psC (NormalB bC) dsC <- genAlgProdFunctions buildCombiningChoice    dataconName funs fs hs
-          iC <- [d| instance (Monad $(varT mL), Monad $(varT mR), Eq $(varT xL), $(varT mL) ~ $(varT mR) {- , VG.Vector $(varT vG) ($(varT rL),$(varT rR)) -} )
-                      => ProductCombining $(return lType) $(return rType) where
-                          type SigCombining $(return lType) $(return rType) = $(return sigPType)
-                          (***) = undefined
-                          {-
-                           - (***) = $(return $ LamE psC $ LetE dsC bC)
-                           - -}
-                          {-# Inline (***) #-}
-                |]
-          return $ iB -- ++ iC
-
--- | Returns the 'Name' of the monad variable.
-
-getMonadName :: [TyVarBndr] -> Maybe Name
-getMonadName = go
-  where go [] = Nothing
-        go (KindedTV m (AppT (AppT ArrowT StarT) StarT) : _) = Just m
-        go (_ : xs) = go xs
-
--- | Returns the 'Name's of the objective function variables, as well as
--- the name of the objective function itself.
-
-getObjectiveNames :: [VarStrictType] -> Maybe (Name,Name,Name,Name)
-getObjectiveNames = go
-  where go [] = Nothing
-        go ( (hName , _ , (AppT (AppT ArrowT (AppT (AppT (ConT streamName) (VarT mS)) (VarT x))) (AppT (VarT mR) (VarT r)))) : xs)
-          | streamName == ''Stream && mS == mR = Just (hName,mS,x,r)
-          | otherwise             = go xs
-        go ( _ : xs) = go xs
-
-
-
--- * Constructions for the different algebra types.
-
--- | The left algebra type. Assumes that in @choice :: Stream m x -> m r@
--- we have that @x ~ r@.
-
-buildLeftType :: Name -> (Name, Name, Name) -> (Name, Name) -> [TyVarBndr] -> Type
-buildLeftType tycon (m, x, r) (mL, xL) = foldl AppT (ConT tycon) . map (VarT . go)
-  where go (PlainTV z)
-          | z == m        = mL  -- correct monad name
-          | z == x        = xL  -- point to new x type
-          | z == r        = xL  -- stream and return type are the same
-          | otherwise     = z   -- everything else can stay as is
-        go (KindedTV z _) = go (PlainTV z)
-
--- | Here, we do not set any restrictions on the types @m@ and @r@.
-
-buildRightType :: Name -> (Name, Name, Name) -> (Name, Name, Name) -> [TyVarBndr] -> Type
-buildRightType tycon (m, x, r) (mR, xR, rR) = foldl AppT (ConT tycon) . map (VarT . go)
-  where go (PlainTV z)
-          | z == m    = mR  -- have discovered a monadic type
-          | z == x    = xR  -- have discovered a type that is equal to the stream type (and hence we have a synvar type)
-          | z == r    = rR  -- have discovered a type that is equal to the result type (for @<||@) equal to the stream type, hence synvar
-          | otherwise = z   -- this is a terminal or a terminal stack (we don't care)
-        go (KindedTV z _) = go (PlainTV z)
-
--- | Build up the type for backtracking. We want laziness in the right
--- return type. Hence, we have @AppT ListT (VarT xR)@ ; i.e. we want to
--- return results in a list.
-
-buildSigBacktrackingType :: Name -> (Name, Name, Name) -> (Name) -> (Name, Name, Name) -> [TyVarBndr] -> Type
-buildSigBacktrackingType tycon (m, x, r) (xL) (mR, xR, rR) = foldl AppT (ConT tycon) . map go
-  where go (PlainTV z)
-          | z == m    = VarT mR
-          | z == x    = (AppT (AppT (TupleT 2) (VarT xL)) (AppT ListT (VarT xR)))
-          | z == r    = VarT rR
-          | otherwise = VarT z
-        go (KindedTV z _) = go (PlainTV z)
-
--- | Build up the type for backtracking. We want laziness in the right
--- return type. Hence, we have @AppT ListT (VarT xR)@.
-
-buildSigCombiningType :: Name -> Name -> (Name, Name, Name) -> (Name, Name, Name) -> (Name, Name, Name) -> [TyVarBndr] -> TypeQ
-buildSigCombiningType tycon vG (m, x, r) (mL, xL, rL) (mR, xR, rR) = foldl appT (conT tycon) . map go
-  where go (PlainTV z)
-          | z == m    = varT mR
-          | z == x    = [t| ($(varT xL) , $(varT xR)) |]
-          | z == r    = [t| V.Vector ($(varT rL) , $(varT rR)) |]
-          | otherwise = varT z
-        go (KindedTV z _) = go (PlainTV z)
-
-
-
--- *
-
--- | Build up attribute and choice function. Here, we actually bind the
--- left and right algebra to @l@ and @r@.
-
-genAlgProdFunctions
-  :: Choice
-  -> Name
-  -> [VarStrictType]
-  -> [VarStrictType]
-  -> [VarStrictType]
-  -> Q Clause
-genAlgProdFunctions choice conName allFunNames evalFunNames choiceFunNames = do
-  let nonTermNames = nub . map getRuleResultType $ evalFunNames
-  -- bind the l'eft and r'ight variable of the two algebras we want to join,
-  -- also create unique names for the function names we shall bind later.
-  nameL <- newName "l"
-  varL  <- varP nameL
-  fnmsL <- sequence $ replicate (length allFunNames) (newName "fnamL")
-  nameR <- newName "r"
-  varR  <- varP nameR
-  fnmsR <- sequence $ replicate (length allFunNames) (newName "fnamR")
-  -- bind the individual variables in the where part
-  whereL <- valD (conP conName (map varP fnmsL)) (normalB $ varE nameL) []
-  whereR <- valD (conP conName (map varP fnmsR)) (normalB $ varE nameR) []
-  rce <- recConE conName
-          $  zipWith3 (genChoiceFunction choice) (drop (length evalFunNames) fnmsL) (drop (length evalFunNames) fnmsR) choiceFunNames
-          ++ zipWith3 (genAttributeFunction nonTermNames) fnmsL fnmsR evalFunNames
-  -- build the function pairs
-  -- to keep our sanity, lets print this stuff
-  let cls = Clause [varL, varR] (NormalB rce) [whereL,whereR]
-  return cls
-
--- | Simple wrapper for creating the choice fun expression.
-
-genChoiceFunction
-  :: Choice
-  -> Name
-  -> Name
-  -> VarStrictType
-  -> Q (Name,Exp)
-genChoiceFunction choice hL hR (name,_,t) = do
-  exp <- choice hL hR
-  return (name,exp)
-
-
--- | We take the left and right function name for one attribute and build
--- up the combined attribute function. Mostly a wrapper around
--- 'recBuildLampat' which does the main work.
---
--- TODO need fun names from @l@ and @r@
-
-genAttributeFunction
-  :: [Name]
-  -> Name
-  -> Name
-  -> VarStrictType
-  -> Q (Name,Exp)
-genAttributeFunction nts fL fR (name,_,t) = do
-  (lamPat,funL,funR) <-recBuildLamPat nts fL fR (init $ getRuleSynVarNames nts t) -- @init@ since we don't want the result as a parameter
-  let exp = LamE lamPat $ TupE [funL,funR]
-  return (name,exp)
-
--- | Now things become trickly. We are given all non-terminal names (to
--- differentiate between a terminal (stack) and a syntactic variable; the
--- left and right function; and the arguments to this attribute function
--- (except the result parameter). We are given the latter as a result to an
--- earlier call to 'getRuleSynVarNames'.
---
--- We now look at each argument and determine wether it is a syntactic
--- variable. If so, then we actually have a tuple arguments @(x,ys)@ where
--- @x@ has to optimized value and @ys@ the backtracking list. The left
--- function receives just @x@ in this case. For the right function, things
--- are more complicated, since we have to flatten lists. See 'buildRns'.
---
--- Terminals are always given "as is" since we do not have a need for
--- tupled-up information as we have for syntactic variables.
-
-recBuildLamPat
-  :: [Name]   -- ^ all non-terminal names
-  -> Name     -- ^ left attribute function
-  -> Name     -- ^ right attribute function
-  -> [ArgTy Name]  -- ^ all arguments to the attribute function
-  -> Q ([Pat], Exp, Exp)
-recBuildLamPat nts fL' fR' ts = do
-  -- here we just run through all arguments, either creating an @x@ and
-  -- a @ys@ for a non-term or a @t@ for a term.
-  -- ps <- sequence [ if t `elem` nts then tupP [newName "x" >>= varP, newName "ys" >>= varP] else (newName "t" >>= varP) | t<-ts]
-  ps <- mapM argTyArgs ts
-  {-
-  let buildLfun f (SynVar (TupP [VarP v,_])) = appE f (varE v)
-      buildLfun f (Term   (VarP v         )) = appE f (varE v)
-      buildLfun f (StackedVars vs) =
-        let
-        in  error "buildLfun: WRITE ME" -- appE f (varE $ mkName "foo")
-  -}
-  lamPat <- buildLamPat ps
-  lfun <- buildLns (VarE fL') ps -- foldl buildLfun (varE fL') ps
-  rfun <- buildRns (VarE fR') ps
-  return (lamPat, lfun, rfun)
-
-buildLamPat :: [ArgTy Pat] -> Q [Pat]
-buildLamPat = mapM go where
-  go (SynVar      p ) = return p
-  go (Term        p ) = return p
-  go (StackedVars ps) = build ps
-  build :: [ArgTy Pat] -> Q Pat
-  build = foldl (\s v -> [p| $(s) :. $(return v) |]) [p|Z|] . map get
-  get :: ArgTy Pat -> Pat
-  get (SynVar p) = p
-  get (Term   p) = p
-
--- | Look at the argument type and build the capturing variables. In
--- particular captures synvar arguments with a 2-tuple @(x,ys)@.
-
-argTyArgs :: ArgTy Name -> Q (ArgTy Pat)
-argTyArgs (SynVar n) = SynVar <$> tupP [newName "x" >>= varP , newName "ys" >>= varP]
-argTyArgs (Term n)          = Term <$> (newName "t" >>= varP)
-argTyArgs (StackedTerms _)  = Term <$> (newName "t" >>= varP) -- !!!
-argTyArgs (StackedVars vs)  = StackedVars <$> mapM argTyArgs vs
-argTyArgs NilVar            = Term <$> (newName "t" >>= varP)
-argTyArgs (Result _)        = error "argTyArgs: should not receive @Result@"
-
-buildLns
-  :: Exp
-  -> [ArgTy Pat]
-  -> ExpQ
-buildLns f' ps = foldl go (return f') ps
-  where go :: ExpQ -> ArgTy Pat -> ExpQ
-        go f (SynVar      (TupP [VarP v,_])) = appE f (varE v)
-        go f (Term        (VarP v         )) = appE f (varE v)
-        go f (StackedVars vs               ) = appE f (build vs)
-        build :: [ArgTy Pat] -> ExpQ
-        build = foldl (\s v -> [| $(s) :. $(varE v) |]) [|Z|] . map get
-        get (SynVar (TupP [VarP v,_])) = v
-        get (Term   (VarP t)         ) = t
-
--- |
---
--- NOTE
---
--- @
--- [ f x | x <- xs ]
--- CompE [BindS (VarP x) (VarE xs), NoBindS (AppE (VarE f) (VarE x))]
--- @
-
-buildRns
-  :: Exp
---  -> [Name]
-  -> [ArgTy Pat]
-  -> ExpQ
-buildRns f' ps = do
-  -- get all synvars, shallow or deep and create a new name to bind
-  -- individual parts to.
-  sy :: M.Map Pat Name <- M.fromList <$> (mapM (\s -> newName "y" >>= \y -> return (s,y)) $ concatMap flattenSynVars ps)
-  -- bind them for the right part of the list expression (even though they
-  -- are left in @CompE@. We don't use @sy@ directly to keep the order in
-  -- which the comprehensions run.
-  let rs = map (\k@(TupP [_,VarP v]) -> BindS (VarP $ sy M.! k) (VarE v)) $ concatMap flattenSynVars ps
-  let go :: ExpQ -> ArgTy Pat -> ExpQ
-      go f (SynVar      k       ) = appE f (varE $ sy M.! k) -- needed like this, because we need the @y@ in @y <- ys@
-      go f (Term        (VarP v)) = appE f (varE v)
-      go f (StackedVars vs      ) = appE f (foldl build [|Z|] vs)
-      build :: ExpQ -> ArgTy Pat -> ExpQ
-      build s (SynVar k       ) = [| $(s) :. $(varE $ sy M.! k) |]
-      build s (Term   (VarP v)) = [| $(s) :. $(varE v)          |]
-  funApp <- foldl go (return f') ps
-  return . CompE $ rs ++ [NoBindS funApp]
-
-{-
-  -- helper function for the argument build-up
-  let go :: [ArgTy Pat] -> [Name]
-      go [] = []
-      go ((SynVar      k       ):ks) = sy M.! k  : go ks
-      go ((Term        (VarP v)):ks) = v         : go ks -- should also cover StackedTerms, NilVar ! (because we build this earlier in @argTypArgs@)
-      go ((StackedVars ls      ):ks) = (error "here") : go ks -- need to work more
-  -- more verbose build-up of the arguments for @funApp@.
-  let xs = go ps
-  -- function application
-  funApp <- noBindS $ foldl (\g z -> appE g (varE z)) (return f) xs
-  return . CompE $ rs ++ [funApp]
--}
-{-
-buildRns f ps = do
-  ys <- sequence [ newName "y" | TupP [_,VarP v] <- ps ]
-  let vs = zipWith (\y v -> (BindS (VarP y) (VarE v))) ys [ v | TupP [_,VarP v] <- ps ]
-  let xs = go ps ys
-  ff <- noBindS $ foldl (\g z -> appE g (varE z)) (return f) xs
-  return $ CompE $ vs ++ [ff]
-  where go [] [] = []
-        go (VarP v : gs) ys     = v : go gs ys  -- keep terminal binders
-        go (TupP _ : gs) (v:ys) = v : go gs ys  -- insert new binders
-        go as bs = error $ show ("not done?", as, bs)
--}
-
--- | Type for backtracking functions.
---
--- Not too interesting, mostly to keep track of @choice@.
-
-type Choice = Name -> Name -> Q Exp
-
--- | Build up the backtracking choice function. This choice function will
--- backtrack based on the first result, then return only the second.
---
--- TODO it should be (only?) this function we will need to modify to build
--- all algebra products.
---
--- @ysM@ can't be unboxed, as @snd@ of each element is a list, lazily
--- consumed. We build up @ysM@ as this makes fusion happen. Of course, this
--- is a boxed vector and not as efficient, but we gain the ability to have
--- lazily created backtracking from this!
---
--- This means strict optimization AND lazy backtracking
-
-buildBacktrackingChoice :: Choice
-buildBacktrackingChoice hL' hR' =
-  [| \xs -> do        -- first, create a boxed, mutable vector from the results
-               ysM <- streamToVector xs -- VGM.unstream xs :: m (VM.MVector s (t1,[t2]))
-                      -- apply first choice
-               hFres <- $(varE hL') $ SM.map fst $ vectorToStream ysM
-                     -- second choice on snd elements, then concat'ed up
-                     -- TODO good candidate for rewriting into flatten
-                     -- operation!
-               {-
-                - $(varE hR') $ SM.concatMap (SM.fromList . snd) $ SM.filter ((hFres==) . fst) $ vectorToStream ysM
-                -}
-               $(varE hR') $ SM.fromList $ concatMap snd $ filter ((hFres==) . fst) $ V.toList ysM
-  |]
-
-buildCombiningChoice :: Choice
-buildCombiningChoice hL' hR' =
-  [| \xs -> do       -- first, create a boxed, mutable vector from the results
-               --ys <- streamToVector xs
-               --      -- apply first choice
-               --fs <- $(varE hL') $ SM.map fst $ vectorToStream ys
-               --      -- generate a vector of vectors, one for each
-               --      -- surviving @f@
-               --vs <- V.forM fs $ \f -> do
-               --        -- keep only those @ys@ that have @f@
-               --        let as = V.filter ((f==) . fst) ys
-               --        -- apply @hR'@ to those, but only to the @snd@
-               --        -- elements
-               --        bs <- streamToVector =<< $(varE hR') $ SM.map snd $ vectorToStream $ as
-               --        -- return the combined result, with @f@ attached.
-               --        return $ V.map (\z -> (f,z)) bs
-               undefined
-               {-
-                - $ V.concat $ V.toList vs
-                -}
-               -- TODO we should return a @newtype Many x = forall (G.Vector v x) => Many { v x }
-               -- Together with a closed type family, this gives us a good
-               -- way to encode that we have classified DP
-  |]
-
--- | Transform a monadic stream monadically into a vector.
---
--- TODO Improve code!
-
-streamToVector :: (Monad m) => SM.Stream m x -> m (V.Vector x)
-streamToVector xs = do
-  l <- SM.toList xs
-  let v = V.fromList l
-  return v
-{-# Inline streamToVector #-}
-
--- | Transform a vector into a monadic stream.
---
--- TODO improve code!
-
-vectorToStream :: (Monad m) => V.Vector x -> SM.Stream m x
-vectorToStream = SM.fromList . V.toList
-{-# Inline vectorToStream #-}
-
--- | Gets the names used in the evaluation function. This returns one
--- 'Name' for each variable.
---
--- In case of @TupleT 0@ the type is @()@ and there isn't a name to go with
--- it. We just @mkName "()"@ a name, but this might be slightly dangerous?
--- (Not really sure if it indeed is)
---
--- With @AppT _ _@ we have a multidim terminal and produce another hackish
--- name to be consumed above.
---
--- @
--- AppT (AppT ArrowT (AppT (AppT (ConT Data.Array.Repa.Index.:.) (AppT (AppT (ConT Data.Array.Repa.Index.:.) (ConT Data.Array.Repa.Index.Z)) (VarT c_1627675270))) (VarT c_1627675270))) (VarT x_1627675265)
--- @
-
-getRuleSynVarNames :: [Name]-> Type -> [ArgTy Name] -- [Name]
-getRuleSynVarNames nts t' = go t' where
-  go t
-    | VarT x <- t                          = [Result x]
-    | AppT (AppT ArrowT (VarT x)  ) y <- t = (if x `elem` nts then SynVar x else Term x) : go y
-    | AppT (AppT ArrowT (TupleT 0)) y <- t = NilVar : go y
-    | AppT (AppT ArrowT s         ) y <- t = stacked s : go y
-    | otherwise                            = error $ "getRuleSynVarNames error: " ++ show t ++ "    in:    " ++ show t'
-  stacked s = if null [ () | SynVar _ <- xs ] then StackedTerms xs else StackedVars xs
-    where xs = reverse $ stckd s
-          stckd (ConT z) | z == ''Z = []
-          stckd (AppT a (TupleT 0)) = NilVar : stckd a
-          stckd (AppT a (VarT x)  ) = (if x `elem` nts then SynVar x else Term x) : stckd a
-          stckd (AppT (ConT c) a  ) | c == ''(:.) = stckd a
-          stckd err = error $ "stckd" ++ show err
-
-{-
-(AppT (AppT (ConT Data.PrimitiveArray.Index.Class.:.)
-            (AppT (AppT (ConT Data.PrimitiveArray.Index.Class.:.)
-                        (ConT Data.PrimitiveArray.Index.Class.Z)
-                  )
-                  (VarT x_1627774371)
-            )
-      )
-      (TupleT 0)
-)
--}
-
-{-
-getRuleSynVarNames nts t' = undefined where -- go t' where
-  go t
-    | VarT x <- t = [x]
-    | AppT (AppT ArrowT (VarT x  )) y <- t = x : go y   -- this is a single-dim variable, return the name that the incoming data is bound to (not necessarily syntactic)
-    | AppT (AppT ArrowT (AppT _ _)) y <- t = mkName "[]" : go y   -- this captures that we have a multi-dim terminal.
-    | AppT (AppT ArrowT (TupleT 0)) y <- t = mkName "()" : go y   -- this case captures things like @nil :: () -> x@ for rules like @nil <<< Epsilon@.
-    | otherwise            = error $ "getRuleSynVarNames error: " ++ show t ++ "    in:    " ++ show t'
--}
-
-data ArgTy x
-  -- | This @SynVar@ spans the full column of tapes; i.e. it is a normal
-  -- syntactic variable.
-  = SynVar { synVarName :: x }
-  -- | We have just a single-tape grammar and as such just
-  -- a single-dimensional terminal. We call this term, because
-  -- @StackedTerms@ will be rewritten to just @Term@!
-  | Term { termName :: x }
-  -- | We have a multi-tape grammar with a stack of just terminals. We
-  -- normally can ignore the contents in the functions above, but keep them
-  -- anyway.
-  | StackedTerms { stackedTerms :: [ArgTy x] }
-  -- | We have a multi-tape grammar, but the stack contains a mixture of
-  -- @ArgTy@s.
-  | StackedVars { stackedVars :: [ArgTy x] }
-  -- | A single-dim @()@ case
-  | NilVar
-  -- | The result type name
-  | Result { result :: x }
-  deriving (Show,Eq)
-
-unpackArgTy :: Show x => ArgTy x -> x
-unpackArgTy = go
-  where go (SynVar x) = x
-        go (Term   x) = x
-        go (Result x) = x
-        go err        = error $ "unpackArgTy " ++ show err
-
--- | Get all synvars, even if deep in a stack
-
-flattenSynVars :: ArgTy x -> [x]
-flattenSynVars (SynVar x)       = [x]
-flattenSynVars (StackedVars xs) = concatMap flattenSynVars xs
-flattenSynVars _                = []
-
diff --git a/ADP/Fusion/TH/Common.hs b/ADP/Fusion/TH/Common.hs
deleted file mode 100644
--- a/ADP/Fusion/TH/Common.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-
-module ADP.Fusion.TH.Common where
-
-import           Data.Tuple.Select
-import           Language.Haskell.TH
-import           Language.Haskell.TH.Syntax
-
-
-
--- | The last @Name@ of a rule is the name of the syntactic type of the
--- result.
-
-getRuleResultType :: VarStrictType -> Name
-getRuleResultType vst = go $ sel3 vst where
-  go t
-    | AppT _ (VarT x) <- t = x
-    | AppT _ x        <- t = go x
-    | otherwise            = error $ "undetermined error:" ++ show vst
-
diff --git a/ADP/Fusion/Term.hs b/ADP/Fusion/Term.hs
deleted file mode 100644
--- a/ADP/Fusion/Term.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-
-module ADP.Fusion.Term
-  ( module ADP.Fusion.Term.Chr
-  , module ADP.Fusion.Term.Deletion
-  , module ADP.Fusion.Term.Edge
-  , module ADP.Fusion.Term.Epsilon
-  , module ADP.Fusion.Term.PeekIndex
-  , module ADP.Fusion.Term.Strng
-  ) where
-
-import           ADP.Fusion.Term.Chr
-import           ADP.Fusion.Term.Deletion
-import           ADP.Fusion.Term.Edge
-import           ADP.Fusion.Term.Epsilon
-import           ADP.Fusion.Term.PeekIndex
-import           ADP.Fusion.Term.Strng
-
diff --git a/ADP/Fusion/Term/Chr.hs b/ADP/Fusion/Term/Chr.hs
deleted file mode 100644
--- a/ADP/Fusion/Term/Chr.hs
+++ /dev/null
@@ -1,197 +0,0 @@
-
-module ADP.Fusion.Term.Chr
-  ( module ADP.Fusion.Term.Chr.Type
-  , module ADP.Fusion.Term.Chr.Point
-  , module ADP.Fusion.Term.Chr.Subword
-  ) where
-
-import ADP.Fusion.Term.Chr.Point
-import ADP.Fusion.Term.Chr.Subword
-import ADP.Fusion.Term.Chr.Type
-
-
-
-
-
-
-
-{-
-
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
-
--- |
---
--- TODO PointL , PointR need sanity checks for boundaries
-
-module ADP.Fusion.Term.Chr where
-
-import           Control.Exception(assert)
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-import qualified Data.Vector.Unboxed as VU
-
-import           Data.PrimitiveArray -- ((:.)(..), Subword(..), subword, PointL(..), pointL, PointR(..), pointR, Outside(..))
-
-
-import Debug.Trace
-
-
-
-
-
--- ** @PointL@ single-dim instances
-
-{-
-instance
-  ( Monad m
-  , Element ls PointL
-  , MkStream m ls PointL
-  ) => MkStream m (ls :!: Chr r x) PointL where
-  mkStream (ls :!: Chr f xs) Static lu@(PointL (l:.u)) (PointL (i:.j))
-    = staticCheck (j>l && j>0 && j<=u && j<= VG.length xs) $
-      let !z = () -- f xs (j-1) -- let-floating leads to too early evaluation
-      in  S.map (ElmChr (f xs $ j-1) (pointL (j-1) j))
-          $ mkStream ls Static lu (pointL i $ j-1)
---  mkStream _ _ _ _ = error "mkStream / Chr / PointL not implemented"
-  {-# INLINE mkStream #-}
-
-instance
-  ( Monad m
-  , Element ls (Outside PointL)
-  , MkStream m ls (Outside PointL)
-  ) => MkStream m (ls :!: Chr r x) (Outside PointL) where
-  mkStream (ls :!: Chr f xs) Static lu@(O (PointL (l:.u))) (O (PointL (i:.j)))
-    = staticCheck (j<u) $
-      let !z = f xs j
-      in  S.map (ElmChr z (O . pointL j $ j+1))
-          $ mkStream ls Static lu (O . pointL i $ j+1)
---  mkStream _ _ _ _ = error "mkStream / Chr / Outside PointL not implemented"
-  {-# INLINE mkStream #-}
--}
-
-
--- ** @Subword@ single-dim instances
-
-{-
-instance
-  ( Monad m
-  , Element ls Subword
-  , MkStream m ls Subword
-  ) => MkStream m (ls :!: Chr r x) Subword where
-  mkStream (ls :!: Chr f xs) Static lu@(Subword (l:.u)) ij@(Subword (i:.j))
-    -- We use a static check here as we can then pull out the @z@ character
-    -- lookup. In the Nussinov example (X -> f <<< z1 t z2 t) this gives
-    -- a 3x performance improvement. Note that this benchmark is a bit
-    -- artificial.
-    --
-    -- The static part is called @right-most@, i.e. when only terminals with
-    -- known fixed sizes are on the right of this terminal.
-    = staticCheck (j>0 && j<=u) $
-      let !z = f xs (j-1)
-      in S.map (ElmChr z (subword (j-1) j))
-         $ mkStream ls Static lu (subword i $ j-1)
-  mkStream (ls :!: Chr f xs) v lu ij@(Subword (i:.j))
-    -- This version is used when to right, we already had variable-size
-    -- (non-)terminals to the right.
-    = S.map (\s -> let Subword (k:.l) = getIdx s
-                   in  ElmChr (f xs l) (subword l $ l+1) s
-            )
-    $ mkStream ls v lu (subword i $ j-1)
-  {-# INLINE mkStream #-}
--}
-
--- Note how the indices grow to the outside!
-
-{-
-instance
-  ( Monad m
-  , Element ls (Outside Subword)
-  , MkStream m ls (Outside Subword)
-  ) => MkStream m (ls :!: Chr r x) (Outside Subword) where
-  -- For the static case, we move the @j@ index.
-  mkStream (ls :!: Chr f xs) Static lu@(O (Subword (l:.u))) ij@(O (Subword (i:.j)))
-    = staticCheck (j>=0 && j<u) $
-      let !z = f xs j
-      in S.map (ElmChr z (O $ subword j (j+1)))
-         $ mkStream ls Static lu (O $ subword i $ j+1)
-  -- In the variable case, (i) we set @i@ to @i-1@ going further down. (ii) On
-  -- going back up, we extract the rightmost index of the left symbol @l@ --
-  -- which could be @i-1@ but need not be.
-  mkStream (ls :!: Chr f xs) v lu ij@(O (Subword (i:.j)))
-    = S.map (\s -> let O (Subword (_:.l)) = getIdx s
-                   in  ElmChr (f xs l) (O . subword l $ l+1) s
-            )
-    $ mkStream ls v lu (O $ subword (i-1) j)
-  {-# INLINE mkStream #-}
--}
-
-
-
-{-
-
--- * Multi-dimensional stuff
-
-{-
-instance TermStaticVar (Chr r x) Subword where
-  termStaticVar   _ sv _                = sv
-  termStreamIndex _ _  (Subword (i:.j)) = subword i $ j-1
-  {-# INLINE termStaticVar #-}
-  {-# INLINE termStreamIndex #-}
--}
-
-instance TermStaticVar (Chr r x) PointR where
-  termStaticVar   _ sv _                = sv
-  termStreamIndex _ _  (PointR (i:.j)) = pointR i $ j-1
-  {-# INLINE termStaticVar #-}
-  {-# INLINE termStreamIndex #-}
-
--- TODO removed the static check since *in principle* the statics system down
--- at the bottom of the stack should take care of it! Need to verify with
--- QuickCheck, though.
-
-{-
-instance
-  ( Monad m
-  , TerminalStream m a is
-  ) => TerminalStream m (TermSymbol a (Chr r x)) (is:.Subword) where
-  terminalStream (a:>Chr f (!v)) (sv:.Static) (is:.Subword (i:.j))
-    = id -- staticCheck (j>0)
-    . S.map (\(Qd s (z:._) is e) -> Qd s z (is:.subword (j-1) j) (e:.f v (j-1)))
-    . terminalStream a sv is
-    . S.map (\(Tr s z (is:.i)) -> Tr s (z:.i) is)
-  terminalStream (a:>Chr f (!v)) (sv:._) (is:.Subword (i:.j))
-    = S.map (\(Qd s (z:.Subword (k:.l)) is e) -> Qd s z (is:.subword l (l+1)) (e:.f v (l-1)))
-    . terminalStream a sv is
-    . S.map (\(Tr s z (is:.i)) -> Tr s (z:.i) is)
-  {-# INLINE terminalStream #-}
--}
-
-{-
-instance
-  ( Monad m
-  , TerminalStream m a is
-  ) => TerminalStream m (TermSymbol a (Chr r x)) (is:.PointR) where
-  terminalStream (a:>Chr f (!v)) (sv:.Static) (is:.PointR (i:.j))
-    = S.map (\(Qd s (z:._) is e) -> Qd s z (is:.pointR (j-1) j) (e:.f v (j-1)))
-    . terminalStream a sv is
-    . S.map (\(Tr s z (is:.i)) -> Tr s (z:.i) is)
-  terminalStream (a:>Chr f (!v)) (sv:._) (is:.PointR (i:.j))
-    = S.map (\(Qd s (z:.PointR (k:.l)) is e) -> Qd s z (is:.pointR l (l+1)) (e:.f v (l-1)))
-    . terminalStream a sv is
-    . S.map (\(Tr s z (is:.i)) -> Tr s (z:.i) is)
-  {-# INLINE terminalStream #-}
--}
-
--}
-
-
--}
-
diff --git a/ADP/Fusion/Term/Chr/Point.hs b/ADP/Fusion/Term/Chr/Point.hs
deleted file mode 100644
--- a/ADP/Fusion/Term/Chr/Point.hs
+++ /dev/null
@@ -1,91 +0,0 @@
-
-module ADP.Fusion.Term.Chr.Point where
-
-import           Data.Strict.Tuple
-import           Debug.Trace
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-import qualified Data.Vector.Generic as VG
-
-import           Data.PrimitiveArray
-
-import           ADP.Fusion.Base
-import           ADP.Fusion.Term.Chr.Type
-
-
-instance
-  ( Monad m
-  , Element ls PointL
-  , MkStream m ls PointL
-  ) => MkStream m (ls :!: Chr r x) PointL where
-  mkStream (ls :!: Chr f xs) (IStatic d) (PointL u) (PointL i)
-    = staticCheck (i>0 && i<=u && i<= VG.length xs)
-    $ S.map (ElmChr (f xs $ i-1) (PointL $ i) (PointL 0))
-    $ mkStream ls (IStatic d) (PointL u) (PointL $ i-1)
-  mkStream _ _ _ _ = error "mkStream / Chr / PointL can only be implemented for IStatic"
-  {-# Inline mkStream #-}
-
-instance
-  ( Monad m
-  , Element ls (Outside PointL)
-  , MkStream m ls (Outside PointL)
-  ) => MkStream m (ls :!: Chr r x) (Outside PointL) where
-  mkStream (ls :!: Chr f xs) (OStatic d) (O (PointL u)) (O (PointL i))
-    = S.map (\z -> let (O (PointL k)) = getOmx z in ElmChr (f xs $ k-d-1) (O . PointL $ k-d) (getOmx z) z)
-    $ mkStream ls (OStatic $ d+1) (O $ PointL u) (O $ PointL i)
-  mkStream _ _ _ _ = error "Chr.Point / mkStream / Chr / Outside.PointL can only be implemented for OStatic"
-  {-# Inline mkStream #-}
-
--- TODO @Inline [0]@ ???
-
-instance TermStaticVar (Chr r x) PointL where
-  termStaticVar   _ sv _                = sv
-  termStreamIndex _ _  (PointL j) = PointL $ j-1
-  {-# Inline termStaticVar #-}
-  {-# Inline termStreamIndex #-}
-
-instance TermStaticVar (Chr r x) (Outside PointL) where
-  termStaticVar   _ (OStatic d) _ = OStatic (d+1) 
-  termStreamIndex _ _           j = j
-  {-# Inline termStaticVar #-}
-  {-# Inline termStreamIndex #-}
-
-instance
-  ( Monad m
-  , TerminalStream m a is
-  ) => TerminalStream m (TermSymbol a (Chr r x)) (is:.PointL) where
-  terminalStream (a:|Chr f (!v)) (sv:.IStatic _) (is:.i@(PointL j))
-    = S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.PointL j) (os:.PointL 0) (e:.f v (j-1)))
-    . iPackTerminalStream a sv (is:.i)
-    {-
-    . terminalStream a sv is
-    . S.map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)
-    -}
-  terminalStream (a:|Chr f (!v)) (sv:._) (is:.i@(PointL _))
-    = S.map (\(S6 s (zi:.PointL k) (zo:.PointL l) is os e) -> S6 s zi zo (is:.PointL (k+1)) (os:.PointL 0) (e:.f v (l-1))) -- TODO is the @l-1@ even right? is this part even called?
-    . iPackTerminalStream a sv (is:.i)
-    {-
-    . terminalStream a sv is
-    . S.map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)
-    -}
-  {-# INLINE terminalStream #-}
-
-instance
-  ( Monad m
-  , TerminalStream m a (Outside is)
-  , Context (Outside (is:.PointL)) ~ (Context (Outside is) :. OutsideContext Int)
-  ) => TerminalStream m (TermSymbol a (Chr r x)) (Outside (is:.PointL)) where
-  terminalStream (a:|Chr f (!v)) (sv:.OStatic d) (O (is:.i))
-    = S.map (\(S6 s (zi:._) (zo:.(PointL k)) (O is) (O os) e) -> S6 s zi zo (O (is:.(PointL $ k-d))) (O (os:.PointL k)) (e:.f v (k-d-1)))
-    . oPackTerminalStream a sv (O (is:.i))
-    {-
-    . terminalStream a sv (O is)
-    . S.map (\(S5 s zi zo (O (is:.i)) (O (os:.o))) -> S5 s (zi:.i) (zo:.o) (O is) (O os))
-    -}
-  {-
-  terminalStream (a:|Chr f (!v)) (sv:._) (is:.PointL i)
-    = S.map (\(S6 s (zi:.PointL k) (zo:.PointL l) is os e) -> S6 s zi zo (is:.PointL (k+1)) (os:.PointL 0) (e:.f v (l-1)))
-    . terminalStream a sv is
-    . S.map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)
-  -}
-  {-# INLINE terminalStream #-}
-
diff --git a/ADP/Fusion/Term/Chr/Subword.hs b/ADP/Fusion/Term/Chr/Subword.hs
deleted file mode 100644
--- a/ADP/Fusion/Term/Chr/Subword.hs
+++ /dev/null
@@ -1,81 +0,0 @@
-
-module ADP.Fusion.Term.Chr.Subword where
-
-import           Data.Strict.Tuple
-import           Data.Vector.Fusion.Util (delay_inline)
-import           Debug.Trace
-import           Data.Vector.Fusion.Stream.Monadic as S
-import qualified Data.Vector.Generic as VG
-import           Prelude hiding (map)
-
-import           Data.PrimitiveArray hiding (map)
-
-import           ADP.Fusion.Base
-import           ADP.Fusion.Term.Chr.Type
-
-
-
-instance
-  ( Monad m
-  , Element ls Subword
-  , MkStream m ls Subword
-  ) => MkStream m (ls :!: Chr r x) Subword where
-  mkStream (ls :!: Chr f xs) (IStatic ()) hh (Subword (i:.j))
-    = staticCheck (i>=0 && i<j && j<= VG.length xs)
-    $ map (ElmChr (f xs $ j-1) (subword (j-1) j) (subword 0 0))
-    $ mkStream ls (IStatic ()) hh (delay_inline Subword (i:.j-1))
-  mkStream (ls :!: Chr f xs) (IVariable ()) hh (Subword (i:.j))
-    = map (\s -> let Subword (_:.l) = getIdx s
-                 in  ElmChr (f xs l) (subword l (l+1)) (subword 0 0) s)
-    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j-1))
-  {-# Inline mkStream #-}
-
-instance
-  ( Monad m
-  , Element ls (Outside Subword)
-  , MkStream m ls (Outside Subword)
-  ) => MkStream m (ls :!: Chr r x) (Outside Subword) where
-  mkStream (ls :!: Chr f xs) (OStatic (di:.dj)) u ij@(O (Subword (i:.j)))
-    = id -- staticCheck ( j < h ) -- TODO any check possible?
-    $ map (\s -> let (O (Subword (_:.k'))) = getIdx s
-                     k = k'-dj-1
-                 in  ElmChr (f xs k) (O $ subword (k'-1) k') (getOmx s) s)
-    $ mkStream ls (OStatic (di:.dj+1)) u ij
-  mkStream (ls :!: Chr f xs) (ORightOf (di:.dj)) u ij
-    = map (\s -> let (O (Subword (_:.k'))) = getIdx s
-                     k = k'-dj-1
-                 in  ElmChr (f xs k) (O $ subword (k'-1) k') (getOmx s) s)
-    $ mkStream ls (ORightOf (di:.dj+1)) u ij
-  mkStream (ls :!: Chr f xs) (OFirstLeft (di:.dj)) u ij
-    = id
-    $ map (\s -> let (O (Subword (_:.k))) = getIdx s
-                 in  ElmChr (f xs k) (O $ subword k (k+1)) (getOmx s) s)
-    $ mkStream ls (OFirstLeft (di+1:.dj)) u ij
-  mkStream (ls :!: Chr f xs) (OLeftOf (di:.dj)) u ij
-    = map (\s -> let (O (Subword (_:.k))) = getIdx s
-                 in  ElmChr (f xs k) (O $ subword k (k+1)) (getOmx s) s)
-    $ mkStream ls (OLeftOf (di+1:.dj)) u ij
-  {-# Inline mkStream #-}
-
-
-
-instance
-  ( Monad m
-  , TerminalStream m a is
-  ) => TerminalStream m (TermSymbol a (Chr r x)) (is:.Subword) where
-  terminalStream (a:|Chr f v) (sv:.IStatic _) (is:.ix@(Subword (i:.j)))
-    -- TODO check if 'staticCheck' breaks fusion!!!
-    = staticCheck (i>=0 && i<j && j<=VG.length v)
-    . S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.subword (j-1) j) (os:.subword 0 0) (e:.f v (j-1)))
-    . iPackTerminalStream a sv (is:.ix)
-  terminalStream (a:|Chr f v) (sv:.IVariable _) (is:.ix@(Subword (i:.j)))
-    = S.map (\(S6 s (zi:.Subword (_:.l)) (zo:._) is os e) -> S6 s zi zo (is:.subword l (l+1)) (os:.subword 0 0) (e:.f v l))
-    . iPackTerminalStream a sv (is:.ix)
-  {-# Inline terminalStream #-}
-
-instance TermStaticVar (Chr r x) Subword where
-  termStaticVar _ sv _ = sv
-  termStreamIndex _ _ (Subword (i:.j)) = subword i (j-1)
-  {-# Inline [0] termStaticVar   #-}
-  {-# Inline [0] termStreamIndex #-}
-
diff --git a/ADP/Fusion/Term/Chr/Type.hs b/ADP/Fusion/Term/Chr/Type.hs
deleted file mode 100644
--- a/ADP/Fusion/Term/Chr/Type.hs
+++ /dev/null
@@ -1,56 +0,0 @@
-
-module ADP.Fusion.Term.Chr.Type where
-
-import           Data.Strict.Tuple
-import qualified Data.Vector.Generic as VG
-
-import           Data.PrimitiveArray
-
-import           ADP.Fusion.Base
-
-
--- | A generic Character parser that reads a single character but allows
--- passing additional information.
---
---  'Chr' expects a function to retrieve @r@ at index position, followed by
---  the actual generic vector with data.
-
-data Chr r x where
-  Chr :: VG.Vector v x
-      => (v x -> Int -> r)
-      -> (v x)
-      -> Chr r x
-
--- | smart constructor for regular 1-character parsers
-
-chr :: VG.Vector v x => v x -> Chr x x
-chr = Chr VG.unsafeIndex
-{-# Inline chr #-}
-
--- | Smart constructor for Maybe Peeking, followed by a character.
-
-chrLeft xs = Chr f xs where
-  f xs k = ( xs VG.!? (k-1)
-           , VG.unsafeIndex xs k
-           )
-  {-# Inline [0] f #-}
-{-# Inline chrLeft #-}
-
-instance Build (Chr r x)
-
-instance
-  ( Element ls i
-  ) => Element (ls :!: Chr r x) i where
-    data Elm (ls :!: Chr r x) i = ElmChr !r !i !i !(Elm ls i)
-    type Arg (ls :!: Chr r x)   = Arg ls :. r
-    getArg (ElmChr x _ _ ls) = getArg ls :. x
-    getIdx (ElmChr _ i _ _ ) = i
-    getOmx (ElmChr _ _ o _ ) = o
-    {-# Inline getArg #-}
-    {-# Inline getIdx #-}
-    {-# Inline getOmx #-}
-
-deriving instance (Show i, Show r, Show (Elm ls i)) => Show (Elm (ls :!: Chr r x) i)
-
-type instance TermArg (TermSymbol a (Chr r x)) = TermArg a :. r
-
diff --git a/ADP/Fusion/Term/Deletion.hs b/ADP/Fusion/Term/Deletion.hs
deleted file mode 100644
--- a/ADP/Fusion/Term/Deletion.hs
+++ /dev/null
@@ -1,78 +0,0 @@
-
-module ADP.Fusion.Term.Deletion
-  ( module ADP.Fusion.Term.Deletion.Type
-  , module ADP.Fusion.Term.Deletion.Point
-  , module ADP.Fusion.Term.Deletion.Subword
-  ) where
-
-import ADP.Fusion.Term.Deletion.Point
-import ADP.Fusion.Term.Deletion.Subword
-import ADP.Fusion.Term.Deletion.Type
-
-
-{-
-import           Data.Strict.Maybe
-import           Data.Strict.Tuple
-import           Prelude hiding (Maybe(..))
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-
-import           Data.PrimitiveArray -- (Z(..), (:.)(..), Subword(..), subword, PointL(..), pointL, PointR(..), pointR)
-
-import           ADP.Fusion.Term.Classes
-import           ADP.Fusion.Term.Multi.Classes
-
-
-
-
-none = None
-{-# INLINE none #-}
-
--- | Since 'None' doesn't really do anything for all indices, we just thread it
--- through.
-
-instance TermStaticVar None ix where
-  termStaticVar   _ sv _  = sv
-  termStreamIndex _ _  ij = ij
-  {-# INLINE termStaticVar #-}
-  {-# INLINE termStreamIndex #-}
-
-instance
-  ( Monad m
-  , TerminalStream m a is
-  ) => TerminalStream m (TermSymbol a None) (is:.PointL) where
-  terminalStream (a:|None) (sv:._) (is:._)
-    = S.map (\(Qd s (z:.i) is e) -> Qd s z (is:.i) (e:.()))
-    . terminalStream a sv is
-    . S.map moveIdxTr
-  {-# INLINE terminalStream #-}
-
-
-
--- * Single dimensional instances for 'None' are really weird
-
-{-
-instance Element ls Subword => Element (ls :!: None) Subword where
-  data Elm (ls :!: None) Subword = ElmNone !Subword !(Elm ls Subword)
-  type Arg (ls :!: None)         = Arg ls :. ()
-  getArg (ElmNone _ l) = getArg l :. ()
-  getIdx (ElmNone i _) = i
-  {-# INLINE getArg #-}
-  {-# INLINE getIdx #-}
--}
-
--- | The instance does nothing (except insert @()@ into the argument
--- stack).
-
-{-
-instance
-  ( Monad m
-  , MkStream m ls Subword
-  ) => MkStream m (ls :!: None) Subword where
-  mkStream (ls :!: None) sv lu ij
-    = S.map (ElmNone ij)
-    $ mkStream ls sv lu ij
-  {-# INLINE mkStream #-}
--}
-
--}
-
diff --git a/ADP/Fusion/Term/Deletion/Point.hs b/ADP/Fusion/Term/Deletion/Point.hs
deleted file mode 100644
--- a/ADP/Fusion/Term/Deletion/Point.hs
+++ /dev/null
@@ -1,62 +0,0 @@
-
-module ADP.Fusion.Term.Deletion.Point where
-
-import           Data.Strict.Tuple
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-
-import           Data.PrimitiveArray
-
-import           ADP.Fusion.Base
-import           ADP.Fusion.Term.Deletion.Type
-
-
-
-instance
-  ( Monad m
-  , MkStream m ls PointL
-  ) => MkStream m (ls :!: Deletion) PointL where
-  mkStream (ls :!: Deletion) (IStatic d) (PointL u) (PointL i)
-    = S.map (ElmDeletion (PointL i) (PointL 0))
-    $ mkStream ls (IStatic d) (PointL u) (PointL i)
-  {-# Inline mkStream #-}
-
-instance
-  ( Monad m
-  , Element ls (Outside PointL)
-  , MkStream m ls (Outside PointL)
-  ) => MkStream m (ls :!: Deletion) (Outside PointL) where
-  mkStream (ls :!: Deletion) (OStatic d) (O (PointL u)) (O (PointL i))
-    = S.map (\z -> ElmDeletion (O $ PointL i) (getOmx z) z)
-    $ mkStream ls (OStatic d) (O $ PointL u) (O $ PointL i)
-  {-# Inline mkStream #-}
-
-instance TermStaticVar Deletion PointL where
-  termStaticVar _ sv _ = sv
-  termStreamIndex _ _ (PointL j) = PointL j
-  {-# Inline termStaticVar #-}
-  {-# Inline termStreamIndex #-}
-
-instance TermStaticVar Deletion (Outside PointL) where
-  termStaticVar   _ (OStatic d) _ = OStatic d
-  termStreamIndex _ _           j = j
-  {-# Inline termStaticVar #-}
-  {-# Inline termStreamIndex #-}
-
-instance
-  ( Monad m
-  , TerminalStream m a is
-  ) => TerminalStream m (TermSymbol a Deletion) (is:.PointL) where
-  terminalStream (a:|Deletion) (sv:.IStatic _) (is:.i@(PointL j))
-    = S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.PointL j) (os:.PointL 0) (e:.()))
-    . iPackTerminalStream a sv (is:.i)
-  {-# Inline terminalStream #-}
-
-instance
-  ( Monad m
-  , TerminalStream m a (Outside is)
-  ) => TerminalStream m (TermSymbol a Deletion) (Outside (is:.PointL)) where
-  terminalStream (a:|Deletion) (sv:.OStatic d) (O (is:.i))
-    = S.map (\(S6 s (zi:._) (zo:.PointL k) (O is) (O os) e) -> S6 s zi zo (O (is:.(PointL $ k-d))) (O (os:.PointL k)) (e:.()))
-    . oPackTerminalStream a sv (O (is:.i))
-  {-# Inline terminalStream #-}
-
diff --git a/ADP/Fusion/Term/Deletion/Subword.hs b/ADP/Fusion/Term/Deletion/Subword.hs
deleted file mode 100644
--- a/ADP/Fusion/Term/Deletion/Subword.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-
-module ADP.Fusion.Term.Deletion.Subword where
-
-import Data.Strict.Tuple
-import Data.Vector.Fusion.Stream.Monadic as S
-import Prelude hiding (map)
-
-import Data.PrimitiveArray hiding (map)
-
-import ADP.Fusion.Base
-import ADP.Fusion.Term.Deletion.Type
-
-
-
-instance
-  ( Monad m
-  , TerminalStream m a is
-  ) => TerminalStream m (TermSymbol a Deletion) (is:.Subword) where
-  terminalStream (a:|Deletion) (sv:.IStatic _) (is:.ij@(Subword (i:.j)))
-    = S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.subword j j) (os:.subword 0 0) (e:.()))
-    . iPackTerminalStream a sv (is:.ij)
-  terminalStream (a:|Deletion) (sv:.IVariable _) (is:.ij@(Subword (i:.j)))
-    = S.map (\(S6 s (zi:.Subword (_:.l)) (zo:._) is os e) -> S6 s zi zo (is:.subword l l) (os:.subword 0 0) (e:.()))
-    . iPackTerminalStream a sv (is:.ij)
-  {-# Inline terminalStream #-}
-
-instance TermStaticVar Deletion Subword where
-  termStaticVar _ sv _ = sv
-  termStreamIndex _ _ ij = ij
-  {-# Inline termStaticVar   #-}
-  {-# Inline termStreamIndex #-}
-
diff --git a/ADP/Fusion/Term/Deletion/Type.hs b/ADP/Fusion/Term/Deletion/Type.hs
deleted file mode 100644
--- a/ADP/Fusion/Term/Deletion/Type.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-
-module ADP.Fusion.Term.Deletion.Type where
-
-import Data.Strict.Tuple
-
-import Data.PrimitiveArray
-
-import ADP.Fusion.Base
-
-
-
-data Deletion = Deletion
-
-instance Build Deletion
-
-instance (Element ls i) => Element (ls :!: Deletion) i where
-  data Elm (ls :!: Deletion) i = ElmDeletion !i !i !(Elm ls i)
-  type Arg (ls :!: Deletion)   = Arg ls :. ()
-  getArg (ElmDeletion _ _ l) = getArg l :. ()
-  getIdx (ElmDeletion i _ _) = i
-  getOmx (ElmDeletion _ o _) = o
-  {-# Inline getArg #-}
-  {-# Inline getIdx #-}
-  {-# Inline getOmx #-}
-
-type instance TermArg (TermSymbol a Deletion) = TermArg a :. ()
-
diff --git a/ADP/Fusion/Term/Edge.hs b/ADP/Fusion/Term/Edge.hs
deleted file mode 100644
--- a/ADP/Fusion/Term/Edge.hs
+++ /dev/null
@@ -1,64 +0,0 @@
-
-module ADP.Fusion.Term.Edge
-  ( module ADP.Fusion.Term.Edge.Type
-  , module ADP.Fusion.Term.Edge.Set
-  ) where
-
-import ADP.Fusion.Term.Edge.Set
-import ADP.Fusion.Term.Edge.Type
-
-
-
-{-
--- | An edge terminal returns the pair of indices forming the edge.
-
-data Edge e where
-  Edge  :: !(Int -> Int -> e) -> Edge e
-
-edge = (,)
-{-# Inline edge #-}
-
-instance Build (Edge i)
-
-instance
-  (Element ls i
-  ) => Element (ls :!: Edge e) i where
-    data Elm (ls :!: Edge e) i = ElmEdge !e !i !(Elm ls i)
-    type Arg (ls :!: Edge e)   = Arg ls :. e
-    getArg (ElmEdge e _ ls) = getArg ls :. e
-    getIdx (ElmEdge _ i _ ) = i
-    {-# Inline getArg #-}
-    {-# Inline getIdx #-}
-
-instance
-  ( Monad m
-  , Element ls (BitSet:>Interface First:>Interface Last)
-  , MkStream m ls (BitSet:>Interface First:>Interface Last)
-  ) => MkStream m (ls :!: Edge e) (BitSet:>Interface First:>Interface Last) where
-    -- encodes in the first index arg, what the previously set @Last@ was
-    mkStream (ls :!: Edge f) Static s@(BitSet zb:>Interface zi:>Interface zj) (BitSet b:>Interface i:>Interface j)
-      -- if we have @popCount b == 1@, then this is an initial node,
-      -- creating the first node. Otherwise the edge just extends an
-      -- existing node.
-      -- TODO need to figure out this "first node" stuff here
-      = S.map (\z -> let (BitSet zb:>_:>Interface zj) = getIdx z
-                     in  ElmEdge (f zj j) (BitSet b:>Interface i:>Interface j) z
-              )
-      $ mkStream ls (Variable Check (Just (popCount b -1) )) s (BitSet (clearBit b j):>Interface i:>Interface j)
-    -- in the variable case, the @Last@ point is unset and may move freely.
-    -- @First@ is still fixed. In @k@, we have the number of bits from
-    -- @BitSet b@ that we should set! The bit we set is also the @Last@
-    -- interface bit.
-    mkStream (ls :!: Edge f) (Variable Check (Just k)) s@(BitSet zb:>Interface zi:>Interface zj) c@(BitSet b:>Interface i:>_)
-      = S.flatten mk step Unknown
-      $ mkStream ls (Variable Check (Just $ k-1)) s c
-      where mk z = let (BitSet z':>_:>_) = getIdx z ; a = b `xor` z' in return (z,a,lsbActive a)
-            step (z,a,lsbA)
-              | lsbA < 0  = return $ S.Done
-              | otherwise = return $ S.Yield (ElmEdge (f cj lsbA) (BitSet (cs .|. bit lsbA):>Interface ci:>Interface lsbA) z) (z,a,nextActive lsbA a)
-              where (BitSet cs:>Interface ci:>Interface cj) = getIdx z
-            {-# Inline [0] mk   #-}
-            {-# Inline [0] step #-}
-    {-# Inline mkStream #-}
--}
-
diff --git a/ADP/Fusion/Term/Edge/Set.hs b/ADP/Fusion/Term/Edge/Set.hs
deleted file mode 100644
--- a/ADP/Fusion/Term/Edge/Set.hs
+++ /dev/null
@@ -1,73 +0,0 @@
-
-module ADP.Fusion.Term.Edge.Set where
-
-import Data.Bits
-import Data.Strict.Tuple
-import Data.Vector.Fusion.Stream.Monadic
-import Data.Vector.Fusion.Stream.Size
-import Debug.Trace
-import Prelude hiding (map)
-
-import Data.PrimitiveArray hiding (map)
-import Data.Bits.Ordered
-
-import ADP.Fusion.Base
-import ADP.Fusion.Term.Edge.Type
-
-
-
-instance
-  ( Monad m
-  , Element    ls (BS2I First Last)
-  , MkStream m ls (BS2I First Last)
-  ) => MkStream m (ls :!: Edge e) (BS2I First Last) where
-  mkStream (ls :!: Edge f) (IStatic rp) u sij@(s:>i:>j)
-    = flatten mk step Unknown $ mkStream ls (IStatic rpn) u tik
-    where rpn | j >= 0    = rp
-              | otherwise = rp+1
-          tik | j >= 0    = s `clearBit` (getIter j) :> i :> undefi
-              | otherwise = sij
-          mk z
-            | j >= 0 && popCount s >= 2 = return $ This z
-            | j <  0 && popCount s >= 2 = return $ That (z,bits,maybeLsb bits)
-            | popCount s <= max 1 rp    = return $ Naught
-            | otherwise                 = error $ show ("Edge",s,i,j)
-            where (zs:>_:>zk) = getIdx z
-                  bits        = s `xor` zs
-          step Naught   = return Done
-          step (This z)
-            | popCount zs == 0 = return $ Done
-            | otherwise = return $ Yield (ElmEdge (f (getIter zk) (getIter j)) sij undefbs2i z) Naught
-            where (zs:>_:>zk) = getIdx z
-          step (That (z,bits,Nothing)) = return $ Done
-          step (That (z,bits,Just j')) = let (zs:>_:>Iter zk) = getIdx z
-                                             tij'            = (zs .|. bit j') :> Iter zk :> Iter j'
-                                         in  return $ Yield (ElmEdge (f zk j') tij' undefbs2i z) (That (z,bits,maybeNextActive j' bits))
-          {-# Inline [0] mk   #-}
-          {-# Inline [0] step #-}
-  {-# Inline mkStream #-}
-
-
-
-instance
-  ( Monad m
-  , Element ls    (Outside (BS2I First Last))
-  , MkStream m ls (Outside (BS2I First Last))
-  ) => MkStream m (ls :!: Edge f) (Outside (BS2I First Last)) where
-  mkStream (ls :!: Edge f) (OStatic ()) u sij
-    = map undefined
-    $ mkStream ls (undefined) u sij
-  {-# Inline mkStream #-}
-
-
-
-instance
-  ( Monad m
-  , Element ls    (Complement (BS2I First Last))
-  , MkStream m ls (Complement (BS2I First Last))
-  ) => MkStream m (ls :!: Edge f) (Complement (BS2I First Last)) where
-  mkStream (ls :!: Edge f) Complemented u sij
-    = map undefined
-    $ mkStream ls Complemented u sij
-  {-# Inline mkStream #-}
-
diff --git a/ADP/Fusion/Term/Edge/Type.hs b/ADP/Fusion/Term/Edge/Type.hs
deleted file mode 100644
--- a/ADP/Fusion/Term/Edge/Type.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-
-module ADP.Fusion.Term.Edge.Type where
-
-import Data.Strict.Tuple
-
-import Data.PrimitiveArray
-
-import ADP.Fusion.Base
-
-
-
-data Edge e where
-  Edge :: (Int -> Int -> e) -> Edge e
-
-instance Build (Edge e)
-
-instance
-  ( Element ls i
-  ) => Element (ls :!: Edge e) i where
-    data Elm (ls :!: Edge e) i = ElmEdge !e !i !i (Elm ls i)
-    type Arg (ls :!: Edge e)   = Arg ls :. e
-    getArg (ElmEdge e _ _ ls) = getArg ls :. e
-    getIdx (ElmEdge _ i _ _ ) = i
-    getOmx (ElmEdge _ _ o _ ) = o
-    {-# Inline getArg #-}
-    {-# Inline getIdx #-}
-    {-# Inline getOmx #-}
-
-deriving instance (Show i, Show e, Show (Elm ls i)) => Show (Elm (ls :!: Edge e) i)
-
-type instance TermArg (TermSymbol a (Edge e)) = TermArg a :. e
-
diff --git a/ADP/Fusion/Term/Epsilon.hs b/ADP/Fusion/Term/Epsilon.hs
deleted file mode 100644
--- a/ADP/Fusion/Term/Epsilon.hs
+++ /dev/null
@@ -1,116 +0,0 @@
-
-module ADP.Fusion.Term.Epsilon
-  ( module ADP.Fusion.Term.Epsilon.Type
-  , module ADP.Fusion.Term.Epsilon.Point
-  , module ADP.Fusion.Term.Epsilon.Subword
-  ) where
-
-import ADP.Fusion.Term.Epsilon.Point
-import ADP.Fusion.Term.Epsilon.Subword
-import ADP.Fusion.Term.Epsilon.Type
-
-{-
-
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-
--- | The 'Empty' terminal symbol parses only the empty (sub-)input. @Empty@
--- however, can mean different things.
---
--- 'Empty' needs to be bound to the input. We require this as certain index
--- structures have no natural notion of emptyness -- unless additional
--- information is given.
---
--- Consider, for example, linear grammars. Left-linear grammars can compare the
--- index @i@ to zero, @i==0@ to test for emptyness, while for right-linear
--- grammars, we need to test @i==N@ with @N@ the size of the input. Instead of
--- carrying @N@ around in the index, we bind the input to @Empty@.
---
--- This choice is currently a bit of a "hunch" but we do have algorithms in
--- mind, where this could be useful.
-
-module ADP.Fusion.Term.Empty where
-
-import           Data.Strict.Maybe
-import           Prelude hiding (Maybe(..))
-
-import           Data.PrimitiveArray -- (Z(..), (:.)(..), Subword(..), subword, PointL(..), pointL, PointR(..), pointR, Outside(..))
-
-import           ADP.Fusion.Term.Classes
-import           ADP.Fusion.Term.Multi.Classes
-
-import           Debug.Trace
-
-
-
--- | Empty as an argument only makes sense if empty is static. We don't get to
--- use 'staticCheck' as the underlying check for the bottom of the argument
--- stack should take care of the @i==j@ check.
-
-{-
-instance
-  ( Monad m
-  , MkStream m ls Subword
-  ) => MkStream m (ls :!: Empty) Subword where
-  mkStream (ls :!: Empty) Static lu (Subword (i:.j))
-    = S.map (ElmEmpty (subword i j))
-    $ mkStream ls Static lu (subword i j)
-  mkStream _ _ _ _ = error "mkStream Empty/Subword called with illegal parameters"
-  {-# INLINE mkStream #-}
-
-instance
-  ( Monad m
-  , MkStream m ls (Outside Subword)
-  ) => MkStream m (ls :!: Empty) (Outside Subword) where
-  mkStream (ls :!: Empty) Static lu (O (Subword (i:.j)))
-    = S.map (ElmEmpty (O $ subword i j))
-    $ mkStream ls Static lu (O $ subword i j)
-  mkStream _ _ _ _ = error "mkStream Empty/Subword called with illegal parameters"
-  {-# INLINE mkStream #-}
--}
-
-type instance TermArg (TermSymbol a Empty) = TermArg a :. ()
-
-instance TermStaticVar Empty PointL where
-  termStaticVar   _ sv _  = sv
-  termStreamIndex _ _  ij = ij
-  {-# INLINE termStaticVar #-}
-  {-# INLINE termStreamIndex #-}
-
-{-
-instance TermStaticVar Empty Subword where
-    termStaticVar = error "write me"
-    termStreamIndex = error "write me"
--}
-
--- | Again, we assume that no 'staticCheck' is necessary and that @i==j@ is
--- true.
-
-instance
-  ( Monad m
-  , TerminalStream m a is
-  ) => TerminalStream m (TermSymbol a Empty) (is:.PointL) where
-  terminalStream (a:|Empty) (sv:.Static) (is:.PointL (i:.j))
-    = S.map (\(Qd s (z:.i) is e) -> Qd s z (is:.i) (e:.()))
-    . terminalStream a sv is
-    . S.map moveIdxTr
-  terminalStream _ _ _ = error "mkStream Empty/(is:.PointL) called with illegal parameters"
-  {-# INLINE terminalStream #-}
-
-{-
-instance
-    ( Monad m
-    , TerminalStream m a is
-    ) => TerminalStream m (TermSymbol a Empty) (is:.Subword) where
-      terminalStream (a:>Empty) (sv:.Static) (is:.Subword (i:.j))
-        = S.map (\(Qd s (z:.i) is e) -> Qd s z (is:.i) (e:.()))
-        . terminalStream a sv is
-        . S.map moveIdxTr
-      terminalStream _ _ _ = error "mkStream Empty/(is:.Subword) called with illegal parameters"
-      {-# INLINE terminalStream #-}
--}
-
--}
-
diff --git a/ADP/Fusion/Term/Epsilon/Point.hs b/ADP/Fusion/Term/Epsilon/Point.hs
deleted file mode 100644
--- a/ADP/Fusion/Term/Epsilon/Point.hs
+++ /dev/null
@@ -1,62 +0,0 @@
-
-module ADP.Fusion.Term.Epsilon.Point where
-
-import           Data.Strict.Tuple
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-
-import           Data.PrimitiveArray
-
-import           ADP.Fusion.Base
-import           ADP.Fusion.Term.Epsilon.Type
-
-
-
-instance
-  ( Monad m
-  , MkStream m ls PointL
-  ) => MkStream m (ls :!: Epsilon) PointL where
-  mkStream (ls :!: Epsilon) (IStatic d) (PointL u) (PointL i)
-    = S.map (ElmEpsilon (PointL i) (PointL 0))
-    $ mkStream ls (IStatic d) (PointL u) (PointL i)
-  {-# Inline mkStream #-}
-
-instance
-  ( Monad m
-  , Element ls (Outside PointL)
-  , MkStream m ls (Outside PointL)
-  ) => MkStream m (ls :!: Epsilon) (Outside PointL) where
-  mkStream (ls :!: Epsilon) (OStatic d) (O (PointL u)) (O (PointL i))
-    = S.map (\z -> ElmEpsilon (O $ PointL i) (getOmx z) z)
-    $ mkStream ls (OStatic d) (O $ PointL u) (O $ PointL i)
-  {-# Inline mkStream #-}
-
-instance TermStaticVar Epsilon PointL where
-  termStaticVar _ sv _ = sv
-  termStreamIndex _ _ (PointL j) = PointL j
-  {-# Inline termStaticVar #-}
-  {-# Inline termStreamIndex #-}
-
-instance TermStaticVar Epsilon (Outside PointL) where
-  termStaticVar   _ (OStatic d) _ = OStatic d
-  termStreamIndex _ _           j = j
-  {-# Inline termStaticVar #-}
-  {-# Inline termStreamIndex #-}
-
-instance
-  ( Monad m
-  , TerminalStream m a is
-  ) => TerminalStream m (TermSymbol a Epsilon) (is:.PointL) where
-  terminalStream (a:|Epsilon) (sv:.IStatic _) (is:.i@(PointL j))
-    = S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.PointL j) (os:.PointL 0) (e:.()))
-    . iPackTerminalStream a sv (is:.i)
-  {-# Inline terminalStream #-}
-
-instance
-  ( Monad m
-  , TerminalStream m a (Outside is)
-  ) => TerminalStream m (TermSymbol a Epsilon) (Outside (is:.PointL)) where
-  terminalStream (a:|Epsilon) (sv:.OStatic d) (O (is:.i))
-    = S.map (\(S6 s (zi:._) (zo:.PointL k) (O is) (O os) e) -> S6 s zi zo (O (is:.(PointL $ k-d))) (O (os:.PointL k)) (e:.()))
-    . oPackTerminalStream a sv (O (is:.i))
-  {-# Inline terminalStream #-}
-
diff --git a/ADP/Fusion/Term/Epsilon/Subword.hs b/ADP/Fusion/Term/Epsilon/Subword.hs
deleted file mode 100644
--- a/ADP/Fusion/Term/Epsilon/Subword.hs
+++ /dev/null
@@ -1,53 +0,0 @@
-
-module ADP.Fusion.Term.Epsilon.Subword where
-
-import Data.Strict.Tuple
-import Data.Vector.Fusion.Stream.Monadic as S
-import Prelude hiding (map)
-
-import Data.PrimitiveArray hiding (map)
-
-import ADP.Fusion.Base
-import ADP.Fusion.Term.Epsilon.Type
-
---import Data.Vector.Fusion.Util
-
-
-
-instance
-  ( Monad m
-  , MkStream m ls Subword
-  ) => MkStream m (ls :!: Epsilon) Subword where
-  mkStream (ls :!: Epsilon) (IStatic ()) hh ij@(Subword (i:.j))
-    = staticCheck (i==j)
-    $ map (ElmEpsilon (subword i j) (subword 0 0))
-    $ mkStream ls (IStatic ()) hh ij
-  {-# Inline mkStream #-}
-
-instance
-  ( Monad m
-  , MkStream m ls (Outside Subword)
-  ) => MkStream m (ls :!: Epsilon) (Outside Subword) where
-  mkStream (ls :!: Epsilon) (OStatic d) u ij@(O (Subword (i:.j)))
-    = map (ElmEpsilon (O $ subword i j) (O $ subword i j))
-    $ mkStream ls (OStatic d) u ij
-  {-# Inline mkStream #-}
-
-
-
-instance
-  ( Monad m
-  , TerminalStream m a is
-  ) => TerminalStream m (TermSymbol a Epsilon) (is:.Subword) where
-  terminalStream (a:|Epsilon) (sv:.IStatic _) (is:.ij@(Subword (i:.j)))
-    = S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.subword i j) (os:.subword 0 0) (e:.()))
-    . iPackTerminalStream a sv (is:.ij)
-  {-# Inline terminalStream #-}
-
-instance TermStaticVar Epsilon Subword where
-  termStaticVar _ sv _ = sv
-  termStreamIndex _ _ ij = ij
-  {-# Inline termStaticVar #-}
-  {-# Inline termStreamIndex #-}
-
-
diff --git a/ADP/Fusion/Term/Epsilon/Type.hs b/ADP/Fusion/Term/Epsilon/Type.hs
deleted file mode 100644
--- a/ADP/Fusion/Term/Epsilon/Type.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-
-module ADP.Fusion.Term.Epsilon.Type where
-
-import Data.Strict.Tuple
-
-import Data.PrimitiveArray
-
-import ADP.Fusion.Base
-
-
-
-data Epsilon = Epsilon
-
-instance Build Epsilon
-
-instance (Element ls i) => Element (ls :!: Epsilon) i where
-  data Elm (ls :!: Epsilon) i = ElmEpsilon !i !i !(Elm ls i)
-  type Arg (ls :!: Epsilon)   = Arg ls :. ()
-  getArg (ElmEpsilon _ _ l) = getArg l :. ()
-  getIdx (ElmEpsilon i _ _) = i
-  getOmx (ElmEpsilon _ o _) = o
-  {-# Inline getArg #-}
-  {-# Inline getIdx #-}
-  {-# Inline getOmx #-}
-
-type instance TermArg (TermSymbol a Epsilon) = TermArg a :. ()
-
diff --git a/ADP/Fusion/Term/PeekIndex.hs b/ADP/Fusion/Term/PeekIndex.hs
deleted file mode 100644
--- a/ADP/Fusion/Term/PeekIndex.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-
-module ADP.Fusion.Term.PeekIndex
-  ( module ADP.Fusion.Term.PeekIndex.Type
-  , module ADP.Fusion.Term.PeekIndex.Subword
-  ) where
-
-import ADP.Fusion.Term.PeekIndex.Subword
-import ADP.Fusion.Term.PeekIndex.Type
diff --git a/ADP/Fusion/Term/PeekIndex/Subword.hs b/ADP/Fusion/Term/PeekIndex/Subword.hs
deleted file mode 100644
--- a/ADP/Fusion/Term/PeekIndex/Subword.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-
-module ADP.Fusion.Term.PeekIndex.Subword where
-
-import Data.Strict.Tuple
-import Data.Vector.Fusion.Stream.Monadic (map)
-import Prelude hiding (map)
-
-import Data.PrimitiveArray hiding (map)
-
-import ADP.Fusion.Base
-import ADP.Fusion.Term.PeekIndex.Type
-
-
-
-instance
-  ( Monad m
-  , Element ls (Complement Subword)
-  , MkStream m ls (Complement Subword)
-  ) => MkStream m (ls :!: PeekIndex (Complement Subword)) (Complement Subword) where
-  mkStream (ls :!: PeekIndex) Complemented h ij
-    = map (\s -> ElmPeekIndex (getIdx s) (getOmx s) s)
-    $ mkStream ls Complemented h ij
-  {-# Inline mkStream #-}
-
diff --git a/ADP/Fusion/Term/PeekIndex/Type.hs b/ADP/Fusion/Term/PeekIndex/Type.hs
deleted file mode 100644
--- a/ADP/Fusion/Term/PeekIndex/Type.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-
-module ADP.Fusion.Term.PeekIndex.Type where
-
-import Data.Strict.Tuple
-
-import Data.PrimitiveArray
-
-import ADP.Fusion.Base
-
-
-
-data PeekIndex i = PeekIndex
-
-instance Build (PeekIndex i)
-
-instance
-  ( Element ls i
-  ) => Element (ls :!: PeekIndex i) i where
-    data Elm (ls :!: PeekIndex i) i = ElmPeekIndex !i !i !(Elm ls i)
-    type Arg (ls :!: PeekIndex i)   = Arg ls :. (i :. i)
-    getArg (ElmPeekIndex i o ls)    = getArg ls :. (i:.o)
-    getIdx (ElmPeekIndex i _ _ )    = i
-    getOmx (ElmPeekIndex _ o _ )    = o
-    {-# Inline getArg #-}
-    {-# Inline getIdx #-}
-    {-# Inline getOmx #-}
-
-deriving instance (Show i, Show (Elm ls i)) => Show (Elm (ls :!: PeekIndex i) i)
-
-type instance TermArg (TermSymbol a (PeekIndex i)) = TermArg a :. PeekIndex i
-
diff --git a/ADP/Fusion/Term/Strng.hs b/ADP/Fusion/Term/Strng.hs
deleted file mode 100644
--- a/ADP/Fusion/Term/Strng.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-
--- | A 'Strng' matches [0..] 'Chr's.
-
-module ADP.Fusion.Term.Strng
-  ( module ADP.Fusion.Term.Strng.Type
-  , module ADP.Fusion.Term.Strng.Point
-  , module ADP.Fusion.Term.Strng.Subword
-  ) where
-
-import ADP.Fusion.Term.Strng.Point
-import ADP.Fusion.Term.Strng.Subword
-import ADP.Fusion.Term.Strng.Type
-
diff --git a/ADP/Fusion/Term/Strng/Point.hs b/ADP/Fusion/Term/Strng/Point.hs
deleted file mode 100644
--- a/ADP/Fusion/Term/Strng/Point.hs
+++ /dev/null
@@ -1,43 +0,0 @@
-
-module ADP.Fusion.Term.Strng.Point where
-
-import           Data.Strict.Tuple
-import           Debug.Trace
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-import qualified Data.Vector.Generic as VG
-
-import           Data.PrimitiveArray
-
-import           ADP.Fusion.Base
-import           ADP.Fusion.Term.Strng.Type
-
-
-
-instance
-  ( Monad m
-  , Element ls PointL
-  , MkStream m ls PointL
-  ) => MkStream m (ls :!: Strng v x) PointL where
-  mkStream (ls :!: Strng f minL maxL xs) (IStatic d) (PointL u) (PointL i)
-    = staticCheck (i - minL >= 0 && i <= u && minL <= maxL)
-    $ S.map (\z -> let PointL j = getIdx z in ElmStrng (f j (i-j) xs) (PointL i) (PointL 0) z)
-    $ mkStream ls (IVariable $ d + maxL - minL) (PointL u) (PointL $ i - minL)
-  mkStream _ _ _ _ = error "mkStream / Strng / PointL / IVariable"
-  {-# Inline mkStream #-}
-
-instance TermStaticVar (Strng v x) PointL where
-  termStaticVar _ (IStatic   d) _ = IVariable d
-  termStaticVar _ (IVariable d) _ = IVariable d
-  termStreamIndex (Strng _ minL _ _) (IStatic d) (PointL j) = PointL $ j - minL
-  {-# Inline [0] termStaticVar   #-}
-  {-# Inline [0] termStreamIndex #-}
-
-instance
-  ( Monad m
-  , TerminalStream m a is
-  ) => TerminalStream m (TermSymbol a (Strng v x)) (is:.PointL) where
-  terminalStream (a:|Strng f minL maxL xs) (sv:.IStatic d) (is:.i@(PointL j))
-    = S.map (\(S6 s (zi:.PointL pi) (zo:._) is os e) -> S6 s zi zo (is:.i) (os:.PointL 0) (e:.f pi (j-pi) xs))
-    . iPackTerminalStream a sv (is:.i)
-  {-# Inline terminalStream #-}
-
diff --git a/ADP/Fusion/Term/Strng/Subword.hs b/ADP/Fusion/Term/Strng/Subword.hs
deleted file mode 100644
--- a/ADP/Fusion/Term/Strng/Subword.hs
+++ /dev/null
@@ -1,44 +0,0 @@
-
-module ADP.Fusion.Term.Strng.Subword where
-
-
-import           Data.Strict.Tuple
-import           Data.Vector.Fusion.Stream.Size
-import           Data.Vector.Fusion.Util (delay_inline)
-import           Debug.Trace
-import           Prelude hiding (map)
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-import qualified Data.Vector.Generic as VG
-
-import           Data.PrimitiveArray
-
-import           ADP.Fusion.Base
-import           ADP.Fusion.Term.Strng.Type
-
-
-
--- | TODO If we use (IVariable mx) we might be able to request @exactly@
--- the range we need!
-
-instance
-  ( Monad m
-  , Element ls Subword
-  , MkStream m ls Subword
-  ) => MkStream m (ls :!: Strng v x) Subword where
-  mkStream (ls :!: Strng slice mn mx v) (IStatic ()) hh (Subword (i:.j))
-    = S.filter (\s -> let Subword (k:.l) = getIdx s in l-k <= mx)
-    . S.map (\s -> let (Subword (_:.l)) = getIdx s
-                   in  ElmStrng (slice l (j-l) v) (subword l j) (subword 0 0) s)
-    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - mn))
-  mkStream (ls :!: Strng slice mn mx v) (IVariable ()) hh (Subword (i:.j))
-    = S.flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - mn))
-    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - mn)
-          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
-                                        l              = j - z
-                                        kl             = subword k l
-                                    return $ S.Yield (ElmStrng (slice k (l-k) v) kl (subword 0 0) s) (s:.z-1)
-                      | otherwise = return $ S.Done
-          {-# Inline [0] mk   #-}
-          {-# Inline [0] step #-}
-  {-# Inline mkStream #-}
-
diff --git a/ADP/Fusion/Term/Strng/Type.hs b/ADP/Fusion/Term/Strng/Type.hs
deleted file mode 100644
--- a/ADP/Fusion/Term/Strng/Type.hs
+++ /dev/null
@@ -1,56 +0,0 @@
-
-module ADP.Fusion.Term.Strng.Type where
-
-import           Data.Strict.Tuple
-import qualified Data.Vector.Generic as VG
-
-import           Data.PrimitiveArray
-
-import           ADP.Fusion.Base
-
-
-
--- | 'Strng' terminals return "strings", i.e. vectors of @Chr@s. They allow
--- the user to specify @[ 0 .. ]@ atoms to be parsed at once. It is
--- possible to both, limit the minimal and maximal number.
---
--- NOTE gadt comments are not parsed by haddock?
-
-data Strng v x where
-  Strng :: VG.Vector v x
-        => (Int -> Int -> v x -> v x)  -- @slice@ function
-        -> Int                         -- minimal size
-        -> Int                         -- maximal size (just use s.th. big if you don't want a limit)
-        -> (v x)                       -- the actual vector
-        -> Strng v x
-
-manyS :: VG.Vector v x => v x -> Strng v x
-manyS = \xs -> Strng VG.unsafeSlice 0 (VG.length xs) xs
-{-# Inline manyS #-}
-
-someS :: VG.Vector v x => v x -> Strng v x
-someS = \xs -> Strng VG.unsafeSlice 1 (VG.length xs) xs
-{-# Inline someS #-}
-
-strng :: VG.Vector v x => Int -> Int -> v x -> Strng v x
-strng = \minL maxL xs -> Strng VG.unsafeSlice minL maxL xs
-{-# Inline strng #-}
-
-instance Build (Strng v x)
-
-instance
-  ( Element ls i
-  ) => Element (ls :!: Strng v x) i where
-  data Elm (ls :!: Strng v x) i = ElmStrng !(v x) !i !i !(Elm ls i)
-  type Arg (ls :!: Strng v x)   = Arg ls :. v x
-  getArg (ElmStrng x _ _ ls) = getArg ls :. x
-  getIdx (ElmStrng _ i _ _ ) = i
-  getOmx (ElmStrng _ _ o _ ) = o
-  {-# Inline getArg #-}
-  {-# Inline getIdx #-}
-  {-# Inline getOmx #-}
-
-deriving instance (Show i, Show (v x), Show (Elm ls i)) => Show (Elm (ls :!: Strng v x) i)
-
-type instance TermArg (TermSymbol a (Strng v x)) = TermArg a :. v x
-
diff --git a/ADP/Fusion/Unit.hs b/ADP/Fusion/Unit.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Unit.hs
@@ -0,0 +1,18 @@
+
+-- | Unit indices have just a single element in their set. This is actually
+-- *not* useless, since it can be used to "fold" from another index
+-- structure into the single @()@ element.
+
+module ADP.Fusion.Unit
+  ( module ADP.Fusion.Core
+  , module ADP.Fusion.Unit.SynVar.Indices
+  , module ADP.Fusion.Unit.Term.Deletion
+  , module ADP.Fusion.Unit.Term.Epsilon
+  ) where
+
+import ADP.Fusion.Core
+
+import ADP.Fusion.Unit.SynVar.Indices
+import ADP.Fusion.Unit.Term.Deletion
+import ADP.Fusion.Unit.Term.Epsilon
+
diff --git a/ADP/Fusion/Unit/Core.hs b/ADP/Fusion/Unit/Core.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Unit/Core.hs
@@ -0,0 +1,116 @@
+
+-- |
+--
+-- TODO the 'mkStream' instances here are probably wonky for everything that is
+-- non-static.
+--
+-- TODO should @d@ in each case here be @d==0@? What is the exact meaning @d@
+-- should convey?
+
+module ADP.Fusion.Unit.Core where
+
+import Data.Proxy
+import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..))
+import Debug.Trace
+import Prelude hiding (map,filter)
+
+import Data.PrimitiveArray hiding (map)
+
+import ADP.Fusion.Core.Classes
+import ADP.Fusion.Core.Multi
+
+
+
+type instance InitialContext (Unit I) = IStatic 0
+
+type instance InitialContext (Unit O) = OStatic 0
+
+type instance InitialContext (Unit C) = Complement
+
+data instance RunningIndex (Unit t) = RiUnit
+
+
+
+instance
+  ( Monad m
+  )
+  ⇒ MkStream m (IStatic d) S (Unit I) where
+  mkStream Proxy S grd LtUnit Unit
+    = staticCheck# grd
+    . singleton $ ElmS RiUnit
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad m
+  )
+  ⇒ MkStream m (IVariable d) S (Unit I) where
+  mkStream Proxy S grd LtUnit Unit
+    = staticCheck# grd
+    . singleton $ ElmS RiUnit
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad m
+  )
+  ⇒ MkStream m (OStatic d) S (Unit O) where
+  mkStream Proxy S grd LtUnit Unit
+    = staticCheck# grd
+    . singleton $ ElmS RiUnit
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad m
+  )
+  ⇒ MkStream m Complement S (Unit C) where
+  mkStream Proxy S grd LtUnit Unit
+    = staticCheck# grd
+    . singleton $ ElmS RiUnit
+  {-# Inline mkStream #-}
+
+--instance
+--  forall m ps p is
+--  . ( Monad m
+--    , MkStream m ps S is
+--    )
+--  ⇒ MkStream m ('(:.) ps p) S (is:.Unit I) where
+--  mkStream Proxy S grd (us:.._) (is:._)
+--    = map (\(ElmS zi) -> ElmS $ zi :.: RiU)
+--    $ mkStream (Proxy ∷ Proxy ps) S grd us is
+--  {-# Inline mkStream #-}
+--
+--instance
+--  forall m ps p is
+--  . ( Monad m
+--    , MkStream m ps S is
+--    )
+--  ⇒ MkStream m ('(:.) ps p) S (is:.Unit O) where
+--  mkStream Proxy S grd (us:.._) (is:._)
+--    = map (\(ElmS zi) -> ElmS $ zi :.: RiU)
+--    $ mkStream (Proxy ∷ Proxy ps) S grd us is
+--  {-# Inline mkStream #-}
+--
+--instance
+--  forall m ps p is
+--  . ( Monad m
+--    , MkStream m ps S is
+--    )
+--  ⇒ MkStream m ('(:.) ps p) S (is:.Unit C) where
+--  mkStream Proxy S grd (us:.._) (is:._)
+--    = map (\(ElmS zi) -> ElmS $ zi :.: RiU)
+--    $ mkStream (Proxy ∷ Proxy ps) S grd us is
+--  {-# Inline mkStream #-}
+--
+--
+--
+--instance TableStaticVar pos c u (Unit I) where
+--  tableStreamIndex _ _ _ _ = Unit
+--  {-# Inline [0] tableStreamIndex #-}
+--
+--instance TableStaticVar pos c u (Unit O) where
+--  tableStreamIndex _ _ _ _ = Unit
+--  {-# Inline [0] tableStreamIndex #-}
+--
+--instance TableStaticVar pos c u (Unit C) where
+--  tableStreamIndex _ _ _ _ = Unit
+--  {-# Inline [0] tableStreamIndex #-}
+
diff --git a/ADP/Fusion/Unit/SynVar/Indices.hs b/ADP/Fusion/Unit/SynVar/Indices.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Unit/SynVar/Indices.hs
@@ -0,0 +1,70 @@
+
+-- | TODO if we have a table that has min-size @>0@ we need to immediately
+-- terminate @addIndexDenseGo@ !
+
+module ADP.Fusion.Unit.SynVar.Indices where
+
+import Data.Proxy
+import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..))
+import Data.Vector.Fusion.Util (delay_inline)
+import Prelude hiding (map,head,mapM)
+
+import Data.PrimitiveArray hiding (map)
+
+import ADP.Fusion.Core
+import ADP.Fusion.Unit.Core
+
+
+
+type instance LeftPosTy (IStatic d) (TwITbl b s m arr EmptyOk (Unit I) x) (Unit I) = IStatic d
+type instance LeftPosTy (IStatic d) (TwITblBt b s arr EmptyOk (Unit I) x mB mF r) (Unit I) = IStatic d
+
+type instance LeftPosTy (OStatic d) (TwITbl b s m arr EmptyOk (Unit O) x) (Unit O) = OStatic d
+type instance LeftPosTy (OStatic d) (TwITblBt b s arr EmptyOk (Unit O) x mB mF r) (Unit O) = OStatic d
+
+type instance LeftPosTy Complement (TwITbl b s m arr EmptyOk (Unit I) x) (Unit C) = Complement
+type instance LeftPosTy Complement (TwITblBt b s arr EmptyOk (Unit I) x mB mF r) (Unit C) = Complement
+
+type instance LeftPosTy Complement (TwITbl b s m arr EmptyOk (Unit O) x) (Unit C) = Complement
+type instance LeftPosTy Complement (TwITblBt b s arr EmptyOk (Unit O) x mB mF r) (Unit C) = Complement
+
+instance
+  ( AddIndexDenseContext ps elm x0 i0 cs c us (Unit I) is (Unit I)
+  , MinSize c
+  )
+  ⇒ AddIndexDense (ps:.Unit d) elm (cs:.c) (us:.Unit I) (is:.Unit I) where
+  addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i)
+    = map (\(SvS s t y') → SvS s (t:.i) (y' :.: RiUnit))
+    . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is
+  {-# Inline addIndexDenseGo #-}
+
+instance
+  ( AddIndexDenseContext ps elm x0 i0 cs c us (Unit O) is (Unit O)
+  , MinSize c
+  )
+  ⇒ AddIndexDense (ps:.Unit d) elm (cs:.c) (us:.Unit O) (is:.Unit O) where
+  addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i)
+    = map (\(SvS s t y') → SvS s (t:.i) (y' :.: RiUnit))
+    . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is
+  {-# Inline addIndexDenseGo #-}
+
+instance
+  ( AddIndexDenseContext ps elm x0 i0 cs c us (Unit I) is (Unit C)
+  , MinSize c
+  )
+  ⇒ AddIndexDense (ps:.Unit d) elm (cs:.c) (us:.Unit I) (is:.Unit C) where
+  addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i)
+    = map (\(SvS s t y') → SvS s (t:.Unit) (y' :.: RiUnit))
+    . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is
+  {-# Inline addIndexDenseGo #-}
+
+instance
+  ( AddIndexDenseContext ps elm x0 i0 cs c us (Unit O) is (Unit C)
+  , MinSize c
+  )
+  ⇒ AddIndexDense (ps:.Unit d) elm (cs:.c) (us:.Unit O) (is:.Unit C) where
+  addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i)
+    = map (\(SvS s t y') → SvS s (t:.Unit) (y' :.: RiUnit))
+    . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is
+  {-# Inline addIndexDenseGo #-}
+
diff --git a/ADP/Fusion/Unit/Term/Deletion.hs b/ADP/Fusion/Unit/Term/Deletion.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Unit/Term/Deletion.hs
@@ -0,0 +1,47 @@
+
+module ADP.Fusion.Unit.Term.Deletion where
+
+import           Data.Proxy
+import           Data.Strict.Tuple
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+import           GHC.Exts
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Core
+import           ADP.Fusion.Unit.Core
+
+
+
+instance
+  forall m pos posLeft ls i
+  . ( TermStream m (Z:.pos) (TermSymbol M Deletion) (Elm (Term1 (Elm ls (Unit i))) (Z :. Unit i)) (Z:.Unit i)
+    , posLeft ~ LeftPosTy pos Deletion (Unit i)
+    , TermStaticVar pos Deletion (Unit i)
+    , MkStream m posLeft ls (Unit i)
+    )
+  ⇒ MkStream m pos (ls :!: Deletion) (Unit i) where
+  mkStream pos (ls :!: Deletion) grd us is
+    = S.map (\(ss,ee,ii) -> ElmDeletion ii ss)
+    . addTermStream1 pos Deletion us is
+    . mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos Deletion us is grd) us
+    $ (termStreamIndex pos Deletion is)
+  {-# Inline mkStream #-}
+
+
+instance
+  ( TermStreamContext m ps ts s x0 i0 is (Unit I)
+  , Monad m
+  , (TermStream m ps ts (Elm x0 i0) is)
+  ) => TermStream m ('(:.) ps p) (TermSymbol ts Deletion) s (is:.Unit I) where
+  termStream Proxy (ts:|Deletion) (us:.._) (is:._)
+    = S.map (\(TState s ii ee) -> TState s (ii:.:RiUnit) (ee:.()))
+    . termStream (Proxy ∷ Proxy ps) ts us is
+  {-# Inline termStream #-}
+
+instance TermStaticVar (IStatic d) Deletion (Unit I) where
+  termStreamIndex Proxy Deletion Unit = Unit
+  termStaticCheck Proxy Deletion _ Unit grd = grd
+  {-# Inline [0] termStreamIndex #-}
+  {-# Inline [0] termStaticCheck #-}
+
diff --git a/ADP/Fusion/Unit/Term/Epsilon.hs b/ADP/Fusion/Unit/Term/Epsilon.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Unit/Term/Epsilon.hs
@@ -0,0 +1,65 @@
+
+module ADP.Fusion.Unit.Term.Epsilon where
+
+import           Data.Proxy
+import           Data.Strict.Tuple
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+import           GHC.Exts
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Core
+import           ADP.Fusion.Unit.Core
+
+
+
+instance
+  forall m pos posLeft ls i lg
+  . ( TermStream m (Z:.pos) (TermSymbol M (Epsilon lg)) (Elm (Term1 (Elm ls (Unit i))) (Z:.Unit i)) (Z:.Unit i)
+    , posLeft ~ LeftPosTy pos (Epsilon lg) (Unit i)
+    , TermStaticVar pos (Epsilon lg) (Unit i)
+    , MkStream m posLeft ls (Unit i)
+    )
+  ⇒ MkStream m pos (ls :!: Epsilon lg) (Unit i) where
+  mkStream pos (ls :!: Epsilon) grd us is
+    = S.map (\(ss,ee,ii) -> ElmEpsilon ii ss)
+    . addTermStream1 pos (Epsilon @lg) us is
+    . mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos (Epsilon @lg) us is grd) us
+    $ termStreamIndex pos (Epsilon @lg) is
+  {-# Inline mkStream #-}
+
+
+
+--instance
+--  ( TermStreamContext m ps ts s x0 i0 is (Unit I)
+--  , TermStream m ps ts (Elm x0 i0) is
+--  ) ⇒ TermStream m (TermSymbol ts Epsilon) s (is:.Unit I) where
+--  termStream (ts:|Epsilon) (cs:.IStatic ()) (us:.._) (is:._)
+--    = S.map (\(TState s ii ee) -> TState s (ii:.:RiU) (ee:.()))
+--    . termStream ts cs us is
+--  {-# Inline termStream #-}
+
+{-
+instance
+  ( TstCtx m ts s x0 i0 is (Unit O)
+  ) => TermStream m (TermSymbol ts Epsilon) s (is:.Unit O) where
+  termStream (ts:|Epsilon) (cs:.OStatic ()) (us:.._) (is:._)
+    = S.map (\(TState s ii ee) -> TState s (ii:.:RiU) (ee:.()))
+    . termStream ts cs us is
+  {-# Inline termStream #-}
+
+
+
+instance TermStaticVar Epsilon (Unit I) where
+  termStaticVar _ _ _ = IStatic ()
+  termStreamIndex _ _ _ = Unit
+  {-# Inline [0] termStaticVar #-}
+  {-# Inline [0] termStreamIndex #-}
+
+instance TermStaticVar Epsilon (Unit O) where
+  termStaticVar _ _ _ = OStatic ()
+  termStreamIndex _ _ _ = Unit
+  {-# Inline [0] termStaticVar #-}
+  {-# Inline [0] termStreamIndex #-}
+-}
+
diff --git a/ADPfusion.cabal b/ADPfusion.cabal
--- a/ADPfusion.cabal
+++ b/ADPfusion.cabal
@@ -1,45 +1,46 @@
+cabal-version:  2.2
 name:           ADPfusion
-version:        0.4.1.1
-author:         Christian Hoener zu Siederdissen, 2011-2015
-copyright:      Christian Hoener zu Siederdissen, 2011-2015
+version:        0.6.0.0
+author:         Christian Hoener zu Siederdissen, 2011-2019
+copyright:      Christian Hoener zu Siederdissen, 2011-2019
 homepage:       https://github.com/choener/ADPfusion
 bug-reports:    https://github.com/choener/ADPfusion/issues
 maintainer:     choener@bioinf.uni-leipzig.de
 category:       Algorithms, Data Structures, Bioinformatics, Formal Languages
-license:        BSD3
+license:        BSD-3-Clause
 license-file:   LICENSE
 build-type:     Simple
 stability:      experimental
-cabal-version:  >= 1.10.0
-tested-with:    GHC == 7.8.4, GHC == 7.10.1
+tested-with:    GHC == 8.6.4
 synopsis:       Efficient, high-level dynamic programming.
 description:
                 <http://www.bioinf.uni-leipzig.de/Software/gADP/ generalized Algebraic Dynamic Programming>
                 .
-                ADPfusion combines stream-fusion (using the stream interface
-                provided by the vector library) and type-level programming to
-                provide highly efficient dynamic programming combinators.
+                ADPfusion combines stream-fusion (using the stream interface provided by the vector
+                library) and type-level programming to provide highly efficient dynamic programming
+                combinators.
                 .
-                ADPfusion allows writing dynamic programs for single- and
-                multi-tape problems. Inputs can be sequences, or sets. New
-                input types can be defined, without having to rewrite this
-                library thanks to the open-world assumption of ADPfusion.
+                ADPfusion allows writing dynamic programs for single- and multi-tape problems.
+                Inputs can be sequences, or sets. New input types can be defined, without having to
+                rewrite this library thanks to the open-world assumption of ADPfusion.
                 .
-                The library provides the machinery for Outside and Ensemble
-                algorithms as well. Ensemble algorithms combine Inside and
-                Outside calculations.
+                The library provides the machinery for Outside and Ensemble algorithms as well.
+                Ensemble algorithms combine Inside and Outside calculations.
                 .
-                Starting with version 0.4.1 we support writing multiple
-                context-free grammars (interleaved syntactic variables). Such
-                grammars have applications in bioinformatics and linguistics.
+                Starting with version 0.4.1 we support writing multiple context-free grammars
+                (interleaved syntactic variables). Such grammars have applications in bioinformatics
+                and linguistics.
                 .
-                The homepage provides a number of tutorial-style examples, with
-                linear and context-free grammars over sequence and set inputs.
+                The homepage provides a number of tutorial-style examples, with linear and
+                context-free grammars over sequence and set inputs.
                 .
-                The formal background for generalized algebraic dynamic
-                progrmaming and ADPfusion is described in a number of papers.
-                These can be found on the gADP homepage and in the README.
+                The formal background for generalized algebraic dynamic programming and ADPfusion is
+                described in a number of papers. These can be found on the gADP homepage and in the
+                README.
                 .
+                Note: The core @ADPfusion@ library only provides machinery for linear language over
+                sequences. The add-ons @ADPfusionSubword@, @ADPfusionForest@, and others provide
+                specialized machinery for other types of formal languages.
 
 
 
@@ -49,305 +50,285 @@
 
 
 
+flag debug
+  description:  Enable bounds checking and various other debug operations at the cost of a significant performance penalty.
+  default:      False
+  manual:       True
+
+flag debugoutput
+  description:  Enable debug output, which spams the screen full of index information
+  default:      False
+  manual:       True
+
+flag debugdump
+  description:  Enable dumping intermediate / core files
+  default:      False
+  manual:       True
+
+flag dump-core
+  description: Dump HTML for the core generated by GHC during compilation
+  default:     False
+  manual:      True
+
 flag examples
   description:  build the examples
   default:      False
   manual:       True
 
-flag debug
-  description:  dump intermediate Core files
+flag spectest
+  description:  build the spec-ctor test case
   default:      False
   manual:       True
 
+flag devel
+  description:  build additional tests
+  default:      False
+  manual:       True
 
+flag btstruc
+  description:  performance test for backtracking structures
+  default:      False
+  manual:       True
 
-library
--- ghc-prim: for reallyUnsafePtrEquality#
-  build-depends: base               >= 4.7      && < 4.9
-               , bits               >= 0.4      && < 0.5
-               , containers
-               , ghc-prim
-               , mmorph             >= 1.0      && < 1.1
-               , monad-primitive    >= 0.1      && < 0.2
-               , mtl                >= 2.0      && < 2.3
-               , OrderedBits        >= 0.0.0.1  && < 0.0.1
-               , primitive          >= 0.5.4    && < 0.7
-               , PrimitiveArray     >= 0.6.1    && < 0.6.2
-               , QuickCheck         >= 2.7      && < 2.9
-               , strict             >= 0.3      && < 0.4
-               , template-haskell   >= 2.0      && < 3.0
-               , th-orphans         >= 0.12     && < 0.13
-               , transformers       >= 0.3      && < 0.5
-               , tuple              >= 0.3      && < 0.4
-               , vector             >= 0.10     && < 0.11
+flag llvm
+  description:  use llvm
+  default:      False
+  manual:       True
 
-  exposed-modules:
-    ADP.Fusion
-    ADP.Fusion.Apply
-    ADP.Fusion.Base
-    ADP.Fusion.Base.Classes
-    ADP.Fusion.Base.Multi
-    ADP.Fusion.Base.Point
-    ADP.Fusion.Base.Set
-    ADP.Fusion.Base.Subword
-    ADP.Fusion.QuickCheck.Common
-    ADP.Fusion.QuickCheck.Point
-    ADP.Fusion.QuickCheck.Set
-    ADP.Fusion.QuickCheck.Subword
-    ADP.Fusion.SynVar
-    ADP.Fusion.SynVar.Array
-    ADP.Fusion.SynVar.Array.Point
-    ADP.Fusion.SynVar.Array.Set
-    ADP.Fusion.SynVar.Array.Subword
-    ADP.Fusion.SynVar.Array.TermSymbol
-    ADP.Fusion.SynVar.Array.Type
-    ADP.Fusion.SynVar.Axiom
-    ADP.Fusion.SynVar.Backtrack
-    ADP.Fusion.SynVar.Fill
-    ADP.Fusion.SynVar.Indices
-    ADP.Fusion.SynVar.Recursive
-    ADP.Fusion.SynVar.Recursive.Point
-    ADP.Fusion.SynVar.Recursive.Subword
-    ADP.Fusion.SynVar.Recursive.Type
-    ADP.Fusion.SynVar.Split
-    ADP.Fusion.SynVar.Split.Subword
-    ADP.Fusion.SynVar.Split.Type
-    ADP.Fusion.Term
-    ADP.Fusion.Term.Chr
-    ADP.Fusion.Term.Chr.Point
-    ADP.Fusion.Term.Chr.Subword
-    ADP.Fusion.Term.Chr.Type
-    ADP.Fusion.Term.Deletion
-    ADP.Fusion.Term.Deletion.Point
-    ADP.Fusion.Term.Deletion.Subword
-    ADP.Fusion.Term.Deletion.Type
-    ADP.Fusion.Term.Edge
-    ADP.Fusion.Term.Edge.Set
-    ADP.Fusion.Term.Edge.Type
-    ADP.Fusion.Term.Epsilon
-    ADP.Fusion.Term.Epsilon.Point
-    ADP.Fusion.Term.Epsilon.Subword
-    ADP.Fusion.Term.Epsilon.Type
-    ADP.Fusion.Term.PeekIndex
-    ADP.Fusion.Term.PeekIndex.Subword
-    ADP.Fusion.Term.PeekIndex.Type
-    ADP.Fusion.Term.Strng
-    ADP.Fusion.Term.Strng.Point
-    ADP.Fusion.Term.Strng.Subword
-    ADP.Fusion.Term.Strng.Type
-    ADP.Fusion.TH
-    ADP.Fusion.TH.Backtrack
-    ADP.Fusion.TH.Common
 
+
+common deps
+  build-depends: base               >= 4.7    && < 5.0
+               , bits               >= 0.4
+               , containers
+               , deepseq
+               , ghc-prim
+               , mmorph             >= 1.0
+               , mtl                >= 2.0
+               , primitive          >= 0.5.4
+               , QuickCheck         >= 2.7
+               , singletons         >= 2.4
+               , strict             >= 0.3
+               , template-haskell   >= 2.0
+               , th-orphans         >= 0.12
+               , transformers       >= 0.3
+               , tuple              >= 0.3
+               , vector             >= 0.11
+               --
+               , DPutils            == 0.1.0.*
+               , OrderedBits        == 0.0.2.*
+               , PrimitiveArray     == 0.10.0.*
   default-extensions: BangPatterns
+                    , ConstraintKinds
+                    , CPP
                     , DataKinds
                     , DefaultSignatures
+                    , DeriveAnyClass
+                    , DeriveDataTypeable
+                    , DeriveGeneric
                     , FlexibleContexts
                     , FlexibleInstances
                     , GADTs
                     , KindSignatures
+                    , MagicHash
                     , MultiParamTypeClasses
+                    -- PolyKinds is very important to get GHC to pick up all
+                    -- the instances correctly.
+                    , PolyKinds
                     , RankNTypes
                     , RecordWildCards
                     , ScopedTypeVariables
                     , StandaloneDeriving
                     , TemplateHaskell
+                    , TupleSections
+                    , TypeApplications
                     , TypeFamilies
                     , TypeOperators
                     , TypeSynonymInstances
                     , UndecidableInstances
-
+                    , UnicodeSyntax
   default-language:
     Haskell2010
   ghc-options:
     -O2 -funbox-strict-fields
-
-
-
--- Very simple two-sequence alignment.
-
-executable NeedlemanWunsch
-
-  if flag(examples)
-    buildable:
-      True
-    build-depends:  base
-                 ,  ADPfusion
-                 ,  PrimitiveArray
-                 ,  template-haskell
-                 ,  vector
-  else
-    buildable:
-      False
-  hs-source-dirs:
-    src
-  main-is:
-    NeedlemanWunsch.hs
-  default-language:
-    Haskell2010
-  default-extensions: BangPatterns
-                    , FlexibleContexts
-                    , FlexibleInstances
-                    , MultiParamTypeClasses
-                    , RecordWildCards
-                    , TemplateHaskell
-                    , TypeFamilies
-                    , TypeOperators
-  ghc-options:
-    -O2
-    -funbox-strict-fields
-    -funfolding-use-threshold1000
-    -funfolding-keeness-factor1000
-  if flag(debug)
+  if flag(debugdump)
     ghc-options:
       -ddump-to-file
       -ddump-simpl
       -dsuppress-all
+  if flag(dump-core)
+    build-depends: dump-core
+    ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
 
 
 
--- Basic RNA secondary structure folding
+library
+  import:
+    deps
+  exposed-modules:
+    -- core system
+    ADP.Fusion.Core
+    ADP.Fusion.Core.Apply
+    ADP.Fusion.Core.Classes
+    ADP.Fusion.Core.Multi
+    ADP.Fusion.Core.SynVar.Array
+    ADP.Fusion.Core.SynVar.Array.Type
+    ADP.Fusion.Core.SynVar.Axiom
+    ADP.Fusion.Core.SynVar.Backtrack
+    ADP.Fusion.Core.SynVar.Fill
+    ADP.Fusion.Core.SynVar.FillTyLvl
+    ADP.Fusion.Core.SynVar.Indices
+    ADP.Fusion.Core.SynVar.Recursive.Type
+    ADP.Fusion.Core.SynVar.Split.Type
+    ADP.Fusion.Core.SynVar.TableWrap
+    ADP.Fusion.Core.Term.Chr
+    ADP.Fusion.Core.Term.Deletion
+    ADP.Fusion.Core.Term.Edge
+    ADP.Fusion.Core.Term.Epsilon
+    ADP.Fusion.Core.Term.MultiChr
+    ADP.Fusion.Core.Term.PeekIndex
+    ADP.Fusion.Core.Term.Str
+    ADP.Fusion.Core.Term.Switch
+    ADP.Fusion.Core.Term.Test
+    ADP.Fusion.Core.TH
+    ADP.Fusion.Core.TH.Backtrack
+    ADP.Fusion.Core.TH.Common
+    ADP.Fusion.Core.TyLvlIx
+--    -- Point L
+    ADP.Fusion.PointL
+    ADP.Fusion.PointL.Core
+    ADP.Fusion.PointL.SynVar.Indices
+--    ADP.Fusion.PointL.SynVar.Recursive
+    ADP.Fusion.PointL.Term.Chr
+    ADP.Fusion.PointL.Term.Deletion
+    ADP.Fusion.PointL.Term.Epsilon
+    ADP.Fusion.PointL.Term.MultiChr
+    ADP.Fusion.PointL.Term.Str
+    ADP.Fusion.PointL.Term.Switch
+--    ADP.Fusion.PointL.Term.Test
+--    -- Point R
+    ADP.Fusion.PointR
+    ADP.Fusion.PointR.Core
+    ADP.Fusion.PointR.SynVar.Indices
+    ADP.Fusion.PointR.Term.Chr
+    ADP.Fusion.PointR.Term.Deletion
+    ADP.Fusion.PointR.Term.Epsilon
+    ADP.Fusion.PointR.Term.MultiChr
+    -- Unit
+    ADP.Fusion.Unit
+    ADP.Fusion.Unit.Core
+    ADP.Fusion.Unit.SynVar.Indices
+    ADP.Fusion.Unit.Term.Deletion
+    ADP.Fusion.Unit.Term.Epsilon
+--    -- tutorials
+--    ADP.Fusion.Tutorial.NeedlemanWunsch
 
-executable Nussinov
 
-  if flag(examples)
-    buildable:
-      True
-    build-depends:  base
-                 ,  ADPfusion
-                 ,  PrimitiveArray
-                 ,  template-haskell
-                 ,  vector
-  else
-    buildable:
-      False
-  hs-source-dirs:
-    src
+
+test-suite properties
+  import:
+    deps
+  type:
+    exitcode-stdio-1.0
   main-is:
-    Nussinov.hs
-  default-language:
-    Haskell2010
-  default-extensions: BangPatterns
-                    , FlexibleContexts
-                    , FlexibleInstances
-                    , MultiParamTypeClasses
-                    , RecordWildCards
-                    , TemplateHaskell
-                    , TypeFamilies
-                    , TypeOperators
-                    , UndecidableInstances
+    properties.hs
+  other-modules:
+    QuickCheck.Common
+    QuickCheck.Point
   ghc-options:
-    -O2
-    -funbox-strict-fields
-    -funfolding-use-threshold1000
-    -funfolding-keeness-factor1000
-  if flag(debug)
-    ghc-options:
-      -ddump-to-file
-      -ddump-simpl
-      -dsuppress-all
+    -threaded -rtsopts -with-rtsopts=-N
+  hs-source-dirs:
+    tests
+  cpp-options:
+    -DADPFUSION_TEST_SUITE_PROPERTIES
+  build-depends: ADPfusion
+               , tasty                        >= 0.11
+               , tasty-quickcheck             >= 0.8
+               , tasty-th                     >= 0.1
 
 
 
--- Basic RNA secondary structure folding with partition function calculations
+-- Very simple two-sequence alignment.
 
-executable PartNussinov
+executable NeedlemanWunsch
 
   if flag(examples)
     buildable:
       True
     build-depends:  base
                  ,  ADPfusion
-                 ,  log-domain        == 0.10.*
+                 ,  primitive
                  ,  PrimitiveArray
                  ,  template-haskell
                  ,  vector
+                 ,  DPutils
   else
     buildable:
       False
   hs-source-dirs:
     src
   main-is:
-    PartNussinov.hs
+    NeedlemanWunsch.hs
   default-language:
     Haskell2010
   default-extensions: BangPatterns
+                    , DataKinds
                     , FlexibleContexts
                     , FlexibleInstances
                     , MultiParamTypeClasses
+                    , PartialTypeSignatures
+                    , PolyKinds
                     , RecordWildCards
                     , TemplateHaskell
+                    , TypeApplications
                     , TypeFamilies
                     , TypeOperators
+                    , UnicodeSyntax
   ghc-options:
     -O2
     -funbox-strict-fields
-    -funfolding-use-threshold1000
-    -funfolding-keeness-factor1000
-  if flag(debug)
+    -- these parameters do well enough with GHC 8.2
+    -- for larger programs, we may have to increase the number of worker
+    -- arguments.
+    -flate-dmd-anal
+    -fspec-constr-count=20
+    -fspec-constr-keen
+    -fspec-constr-recursive=20
+    -fspec-constr-threshold=20
+  if flag(debugdump)
     ghc-options:
       -ddump-to-file
       -ddump-simpl
       -dsuppress-all
-
-
-
-executable Durbin
-  if flag(examples)
-    buildable:
-      True
-    build-depends:  base
-                 ,  ADPfusion
-                 ,  PrimitiveArray
-                 ,  template-haskell
-                 ,  vector
-  else
-    buildable:
-      False
-  hs-source-dirs:
-    src
-  main-is:
-    Durbin.hs
-  default-language:
-    Haskell2010
-  default-extensions: BangPatterns
-                    , FlexibleContexts
-                    , FlexibleInstances
-                    , MultiParamTypeClasses
-                    , RecordWildCards
-                    , TemplateHaskell
-                    , TypeFamilies
-                    , TypeOperators
-  ghc-options:
-    -O2
-    -fcpr-off
-    -funbox-strict-fields
-    -funfolding-use-threshold1000
-    -funfolding-keeness-factor1000
-  if flag(debug)
+  if flag(llvm)
     ghc-options:
-      -ddump-to-file
-      -ddump-simpl
-      -dsuppress-all
+      -fllvm
+      -optlo-O3
+  if flag(dump-core)
+    build-depends: dump-core
+    ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
 
 
 
-executable Pseudoknot
+executable SmithWaterman
+
   if flag(examples)
     buildable:
       True
     build-depends:  base
                  ,  ADPfusion
+                 ,  primitive
                  ,  PrimitiveArray
                  ,  template-haskell
                  ,  vector
+                 ,  DPutils
   else
     buildable:
       False
   hs-source-dirs:
     src
   main-is:
-    Pseudoknot.hs
+    SmithWaterman.hs
   default-language:
     Haskell2010
   default-extensions: BangPatterns
@@ -355,64 +336,45 @@
                     , FlexibleContexts
                     , FlexibleInstances
                     , MultiParamTypeClasses
+                    , PartialTypeSignatures
+                    , PolyKinds
                     , RecordWildCards
                     , TemplateHaskell
+                    , TypeApplications
                     , TypeFamilies
                     , TypeOperators
+                    , UnicodeSyntax
   ghc-options:
     -O2
     -funbox-strict-fields
-    -funfolding-use-threshold1000
-    -funfolding-keeness-factor1000
-  if flag(debug)
+    -- these parameters do well enough with GHC 8.2
+    -- for larger programs, we may have to increase the number of worker
+    -- arguments.
+    -flate-dmd-anal
+    -fspec-constr-count=20
+    -fspec-constr-keen
+    -fspec-constr-recursive=20
+    -fspec-constr-threshold=20
+  if flag(debugdump)
     ghc-options:
       -ddump-to-file
       -ddump-simpl
       -dsuppress-all
+  if flag(llvm)
+    ghc-options:
+      -fllvm
+      -optlo-O3
+  if flag(dump-core)
+    build-depends: dump-core
+    ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
 
 
 
-executable OverlappingPalindromes
-  if flag(examples)
-    buildable:
-      True
-    build-depends:  base
-                 ,  ADPfusion
-                 ,  PrimitiveArray
-                 ,  template-haskell
-                 ,  vector
-  else
-    buildable:
-      False
-  hs-source-dirs:
-    src
-  main-is:
-    OverlappingPalindromes.hs
-  default-language:
-    Haskell2010
-  default-extensions: BangPatterns
-                    , FlexibleContexts
-                    , FlexibleInstances
-                    , MultiParamTypeClasses
-                    , RecordWildCards
-                    , TemplateHaskell
-                    , TypeFamilies
-                    , TypeOperators
-  ghc-options:
-    -O2
-    -funbox-strict-fields
-    -funfolding-use-threshold1000
-    -funfolding-keeness-factor1000
-  if flag(debug)
-    ghc-options:
-      -ddump-to-file
-      -ddump-simpl
-      -dsuppress-all
-
+-- Very simple two-sequence alignment.
 
+executable spectest
 
-executable SplitTests
-  if flag(examples)
+  if flag(spectest)
     buildable:
       True
     build-depends:  base
@@ -426,7 +388,7 @@
   hs-source-dirs:
     src
   main-is:
-    SplitTests.hs
+    SpecTest.hs
   default-language:
     Haskell2010
   default-extensions: BangPatterns
@@ -442,68 +404,7 @@
     -funbox-strict-fields
     -funfolding-use-threshold1000
     -funfolding-keeness-factor1000
-  if flag(debug)
-    ghc-options:
-      -ddump-to-file
-      -ddump-simpl
-      -dsuppress-all
 
-
-
-test-suite properties
-  type:
-    exitcode-stdio-1.0
-  main-is:
-    properties.hs
-  ghc-options:
-    -threaded -rtsopts -with-rtsopts=-N
-  hs-source-dirs:
-    tests
-  default-language:
-    Haskell2010
-  default-extensions: TemplateHaskell
-  build-depends: base
-               , ADPfusion
-               , QuickCheck
-               , test-framework               >= 0.8  && < 0.9
-               , test-framework-quickcheck2   >= 0.3  && < 0.4
-               , test-framework-th            >= 0.2  && < 0.3
-
-
-
-benchmark performance
-  type:
-    exitcode-stdio-1.0
-  main-is:
-    performance.hs
-  ghc-options:
-    -rtsopts -with-rtsopts=-N -with-rtsopts=-T
-    -O2
-    -funbox-strict-fields
-    -funfolding-use-threshold1000
-    -funfolding-keeness-factor1000
-  if flag(debug)
-    ghc-options:
-      -ddump-to-file
-      -ddump-simpl
-      -dsuppress-all
-  hs-source-dirs:
-    tests
-  default-language:
-    Haskell2010
-  default-extensions: BangPatterns
-                    , FlexibleContexts
-                    , TemplateHaskell
-                    , RecordWildCards
-                    , TypeFamilies
-                    , TypeOperators
-                    , StandaloneDeriving
-                    , DeriveGeneric
-  build-depends: base
-               , ADPfusion
-               , BenchmarkHistory   >= 0.0.0  && < 0.0.1
-               , PrimitiveArray
-               , vector
 
 
 
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -26,7 +26,7 @@
     [preprint](http://www.bioinf.uni-leipzig.de/Software/gADP/preprints/hoe-pro-2015.pdf)  
 1.  Maik Riechert, Christian Höner zu Siederdissen, and Peter F. Stadler  
     *Algebraic dynamic programming for multiple context-free languages*  
-    2015, submitted  
+    2016, Theoretical Computer Science  
     [preprint](http://www.bioinf.uni-leipzig.de/Software/gADP/preprints/rie-hoe-2015.pdf)  
 
 
@@ -68,25 +68,7 @@
 
 # Implementors Notes (if you want to extend ADPfusion)
 
-
-- The general inlining scheme is: (i) mkStream is {-# INLINE mkStream #-},
-  inner functions like mk, step, worker functions, and index-modifying
-  functions get an {-# INLINE [0] funName #-}. Where there is no function to
-  annotate, use delay_inline.
-
-- If you implement a new kind of memoizing table, like the dense Table.Array
-  ones, you will have to implement mkStream code. When you hand to the left,
-  the (i,j) indices and modify their extend (by, say, having NonEmpty table
-  constaints), you have to delay_inline this (until inliner phase 0). Otherwise
-  you will break fusion for mkStream.
-
-- Terminals that capture both, say indexing functions, and data should have no
-  strictness annotations for the indexing function. This allows the code to be
-  duplicated, then inlined. This improves performance a lot, because otherwise
-  a function is created that performs these lookups, which has serious (50%
-  slower or so) performance implications.
-
-
+These have been moved to [HACKING.md](https://github.com/choener/ADPfusion/blob/master/HACKING.md).
 
 #### Contact
 
diff --git a/changelog.md b/changelog.md
--- a/changelog.md
+++ b/changelog.md
@@ -1,3 +1,55 @@
+0.6.0.0
+-------
+
+- major change as to how rule compilation proceeds (ctor spec -> type class instances)
+- use new PrimitiveArray-0.9.0.0
+- backtrace from any given index using 'axiomAt'
+- Epsilon is tagged @Global or @Local, to allow local-alignment style algorithms
+
+0.5.3.0
+-------
+
+- using unboxed Ints (primbool style) for rule guards. This nets a nice speedup
+  of 30-50% for linear languages
+
+0.5.2.2
+-------
+
+- Modified signature of Edge to make explicit the @From@ and @To@ nodes of the
+  edge. Minor version bump, because @Edge@ is not official yet.
+- optimized table filling yields large improvements for linear languages
+
+0.5.2.1
+-------
+
+- removed upper bounds
+
+0.5.2.0
+-------
+
+- table filling fully inlined in the forward algorithm
+- experimental PrimBool operations
+- note: these optimizations are mostly of interest for linear languages, where
+  is rule (or function call) is comparatively expensive
+- major re-arrangement of modules: import ADP.Fusion.Core for development of
+  novel DP systems. Import ADP.Fusion.Point if you want to write a sequence
+  alignment algorithm
+
+0.5.1.0
+-------
+
+- improved table filling algorithm performance
+- some optimizations to terminal symbols
+
+0.5.0.0
+-------
+
+- complete re-design of Inside / Outside / Complement handling based on phantom
+  types
+- very liberal combination of multi-tape grammars
+- simplified index generation system (both faster, and easier to write new
+  symbol now)
+
 0.4.1.1
 -------
 
diff --git a/src/Durbin.hs b/src/Durbin.hs
deleted file mode 100644
--- a/src/Durbin.hs
+++ /dev/null
@@ -1,122 +0,0 @@
-
--- | Nussinovs RNA secondary structure prediction algorithm via basepair
--- maximization. Follow this file from top to bottom for a short tutorial
--- on how to use @ADPfusion@.
---
--- In general the task is the following: We are given a sequence of
--- characters from the alphabet @ACGU@. There are 6 pairing rules (cf.
--- 'pairs'), @A-U@, @C-G@, @G-C@, @G-U@, @U-A@, and @U-G@ can /pair/ with
--- each other. Pairs, denoted by brackets @(@, @)@ may be juxtaposed
--- @().()@ or enclosing @(())@. /Crossing/ pairs are not allowed: @([)]@ is
--- forbidden, with @()@ and @[]@ pairing. Dots @.@ denote unpaired
--- characters.
---
--- As an example, the sequence @CACAAGGAUU@ admits the following
--- dot-bracket string @(.)..((..))@.
---
--- The algorithm below maximizes the number of legal brackets.
-
-module Main where
-
-import           Control.Applicative
-import           Control.Monad
-import           Control.Monad.ST
-import           Data.Char (toUpper,toLower)
-import           Data.List
-import           Data.Vector.Fusion.Util
-import           Language.Haskell.TH
-import           Language.Haskell.TH.Syntax
-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           System.Environment (getArgs)
-import           Text.Printf
-
--- Import PrimitiveArray for low-level tables and automatic table
--- filling.
-
-import           Data.PrimitiveArray as PA
-
--- High-level ADPfusion stuff.
-
-import           ADP.Fusion
-
-
-
--- | All grammars require a signature.
-
-data Durbin m c e x r = Durbin
-  { nil :: e           -> x
-  , lef :: c -> x      -> x
-  , rig :: x -> c      -> x
-  , pai :: c -> x -> c -> x
-  , spl :: x -> x      -> x
-  , h   :: SM.Stream m x -> m r
-  }
-
-makeAlgebraProduct ''Durbin
-
-bpmax :: Monad m => Durbin m Char () Int Int
-bpmax = Durbin
-  { nil = \ ()    -> 0
-  , lef = \ _  x  -> x
-  , rig = \ x  _  -> x
-  , pai = \ c x d -> if pairs c d then x+1 else -999999
-  , spl = \ x y   -> x+y
-  , h   = SM.foldl' max 0
-  }
-{-# INLINE bpmax #-}
-
-pairs !c !d
-  =  c=='A' && d=='U'
-  || c=='C' && d=='G'
-  || c=='G' && d=='C'
-  || c=='G' && d=='U'
-  || c=='U' && d=='A'
-  || c=='U' && d=='G'
-{-# INLINE pairs #-}
-
-pretty :: Monad m => Durbin m Char () String [String]
-pretty = Durbin
-  { nil = \ ()      -> ""
-  , lef = \ _  x    -> "." ++ x
-  , rig = \ x  _    -> x ++ "."
-  , pai = \ _  x  _ -> "(" ++ x ++ ")"
-  , spl = \ x  y    -> x ++ y
-  , h   = SM.toList
-  }
-{-# INLINE pretty #-}
-
--- grammar :: Durbin m Char () x r -> c' -> t' -> (t', Subword -> m r)
-grammar Durbin{..} c t' =
-  let t = t'  ( nil <<< Epsilon     |||
-                lef <<< c  % t      |||
-                rig <<< t  % c      |||
-                pai <<< c  % t  % c |||
-                spl <<< tt % tt     ... h
-              )
-      tt = toNonEmpty t
-  in (Z:.t)
-{-# INLINE grammar #-}
-
-runDurbin :: Int -> String -> (Int,[String])
-runDurbin k inp = (d, take k . unId $ axiom b) where
-  i = VU.fromList . Prelude.map toUpper $ inp
-  n = VU.length i
-  !(Z:.t) = mutateTablesDefault
-          $ grammar bpmax
-              (chr i)
-              (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) [])) :: Z:.ITbl Id Unboxed Subword Int
-  -- d = let (ITbl _ _ arr _) = t in arr PA.! subword 0 n
-  d = iTblArray t PA.! subword 0 n
-  !(Z:.b) = grammar (bpmax <|| pretty) (chr i) (toBacktrack t (undefined :: Id a -> Id a))
-
-main = do
-  as <- getArgs
-  let k = if null as then 1 else read $ head as
-  ls <- lines <$> getContents
-  forM_ ls $ \l -> do
-    putStrLn l
-    let (s,xs) = runDurbin k l
-    mapM_ (\x -> printf "%s %5d\n" x s) xs
-
diff --git a/src/NeedlemanWunsch.hs b/src/NeedlemanWunsch.hs
--- a/src/NeedlemanWunsch.hs
+++ b/src/NeedlemanWunsch.hs
@@ -1,9 +1,71 @@
 
+{-# Options_GHC -fforce-recomp #-}
+{-# Options_GHC -Wno-partial-type-signatures #-}
+
 -- | The Needleman-Wunsch global alignment algorithm. This algorithm is
 -- extremely simple but provides a good showcase for what ADPfusion offers.
 --
--- Follow the code from top to bottom for a tutorial on usage.
+-- The Needleman-Wunsch algorithm aligns to strings @x = x_1 x_2 x_3 ...@
+-- and @y = y_1 y_2 y_3 ...@ which may be of differing lengths. Assume that
+-- @x_1 ... x_{i-1}@ and @y_1 ... y_{j-1}@ have already been optimally
+-- aligned. We can match @x_i@ with @y_j@, or perform one of two possible
+-- insert-deletion pairs. Either @x_i@ is aligned with @-@ or @-@ is
+-- aligned with @y_j@. More general, in each DP step, either one or both
+-- inputs are extended by one character.
 --
+-- For the actual implementation, we assume however, that we work backward.
+-- The entries @d@, @u@, and @l@ have already been calculated. Now we want
+-- to compute the entry at @x@ in the lower right corner.
+--
+-- @
+--  -----
+--  |d|u|
+--  -----
+--  |l|x|
+--  -----
+-- @
+--
+-- We introduce a generic naming scheme for each possible move. If we move
+-- in a direction, we call it a @step@. If we do not move, then we call it
+-- a @loop@, because the index loops for this computation.
+--
+-- We can arrive from @d@, making a diagonal step, called @step_step@ as we
+-- advance by one in both dimensions. This leads to an alignment of two
+-- characters, one from each input, at @x@, which is combined with the
+-- already calculated alignment at @d@.
+--
+-- We can also just step in the first dimension @step_loop@, going from @l@
+-- to @x@. Which means that the first-dim character does not have
+-- a partner, leading to an insert/deletion or in/del. We typically do not
+-- care in which of the two dimensions the in/del happens, just that it
+-- does.
+--
+-- The third case is an in/del in the other dimension, giving us
+-- @loop_step@ or going from @u@ to @x@.
+--
+-- Of course, if @x@ happens to be the uppermost, leftmost cell, we have
+-- nowhere to come from, so we need to inititialize (or terminate depending
+-- on your view point) using the @nil_nil@ case. That one is the base case.
+--
+-- We also want to know which of the three cases is the best case (coming
+-- from @d,l,u@), this requires a "choice" function or @h@.
+--
+--
+-- We now implement this algorithm using the low-level ADPfusion library.
+-- Follow the code from top to bottom for a tutorial on usage. The
+-- Needleman-Wunsch tutorial for the @FormalGrammars@ library provides
+-- a higher-level style of implementation.
+--
+-- <http://hackage.haskell.org/package/FormalGrammars/docs/FormalLanguage-Tutorial-NeedlemanWunsch.html>
+--
+-- We also provide an implementation based on grammar products, which
+-- simplify the design of alignment-type algorithms. The corresponding
+-- tutorial is here.
+--
+-- <http://hackage.haskell.org/package/GrammarProducts/docs/FormalLanguage-Tutorial-NeedlemanWunsch.html>
+--
+--
+--
 -- We start by importing a bunch of modules, including
 -- @Data.PrimitiveArray@ for low-level arrays and automated filling of the
 -- arrays or tables in the correct order.
@@ -19,22 +81,26 @@
 -- do this. The relative overhead for each cell to be written into goes
 -- down with more complex grammars and algebras.
 
-module Main where
+module Main (main) where
 
-import           Control.Applicative
-import           Control.Monad
-import           Data.Vector.Fusion.Stream.Monadic (Stream (..))
-import           Data.Vector.Fusion.Util
+import           Control.Monad (forM_,when)
+import           Control.Monad.Primitive
+import           Control.Monad.ST
+import           Data.Ord.Fast
 import           Debug.Trace
-import qualified Control.Arrow as A
-import qualified Data.Vector as V
-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           System.Environment (getArgs)
-import           System.IO.Unsafe (unsafePerformIO)
 import           Text.Printf
 
+-- Streams of parses are the streams defined in the @vector@ package.
+
+import qualified Data.Vector.Fusion.Stream.Monadic as SM
+
+-- We use unboxed vectors to hold the input sequences to be aligned. The
+-- terminal parses work with any vector in the @vector@ package.
+
+import qualified Data.Vector.Unboxed as VU
+import qualified Data.Vector.Storable as VS
+
 -- @Data.PrimitiveArray@ contains data structures, and index structures for
 -- dynamic programming. Notably, the primitive arrays holding the cell data
 -- with Boxed and Unboxed tables. In addition, linear, context-free, and
@@ -42,50 +108,24 @@
 
 import           Data.PrimitiveArray as PA hiding (map)
 
--- @ADP.Fusion@ exposes everything necessary for higher-level DP
--- algorithms.
+-- @ADP.Fusion.Point@ exposes everything necessary for higher-level DP
+-- algorithms. Depending on the type of DP algorithm, different top-level
+-- modules can be imported. @.Point@ for linear grammars, and @.Core@ are
+-- provided in this package. @.Core@ exports only the core modules required
+-- to extend ADPfusion.
 
-import           ADP.Fusion
+import           ADP.Fusion.PointL
 
+import           Data.Ord.Fast
 
 
+
 -- | A signature connects the types of all non-terminals and terminals with
 -- evaluation (or attribute) functions. In the grammar below, we not only
 -- want to create all possible parses of how two strings can be aligned but
 -- also evaluate each parse and choose the optimal one based on Bellman's
 -- principle of optimality.
 --
--- Assume we are in the matrix and want to calculate @x@:
---
--- @
---  -----
---  |d|u|
---  -----
---  |l|x|
---  -----
--- @
---
--- We can arrive from @d@, making a diagonal step, called @step_step@ as we
--- advance by one in both dimensions. This leads to an alignment of two
--- characters, one from each input, at @x@, which is combined with the
--- already calculated alignment at @d@.
---
--- We can also just step in the first dimension @step_loop@, going from @l@
--- to @x@. Which means that the first-dim character does not have
--- a partner, leading to an insert/deletion or in/del. We typically do not
--- care in which of the two dimensions the in/del happens, just that it
--- does.
---
--- The third case is an in/del in the other dimension, giving us
--- @loop_step@ or going from @u@ to @x@.
---
--- Of course, if @x@ happens to be the uppermost, leftmost cell, we have
--- nowhere to come from, so we need to inititialize (or terminate depending
--- on your view point) using the @nil_nil@ case. That one is the base case.
---
--- We also want to know which of the three cases is the best case (coming
--- from @d,l,u@), this requires a "choice" function or @h@.
---
 -- We take a close look at the type signatures. @step_step :: x ->
 -- (Z:.c:.c) -> x@ tells us that @step_step@ requires the score from the
 -- non-terminal, typed @x@ for the alignment up to @d@, then we get the two
@@ -102,11 +142,11 @@
 -- capable, which is a really cool feature for advanced algorithms.
 
 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
+  { 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
   }
 
 -- | We also want to be able to backtrace the optimal result. Given our
@@ -162,12 +202,12 @@
 -- indices. Just as in the spiritual father of @ADPfusion@, Robert
 -- Giegerichs @ADP@, we hide the actual index calculations.
 
-grammar Signature{..} a' i1 i2 =
-  let a = a'  ( step_step <<< a % (M:|chr i1:|chr i2)     |||
-                step_loop <<< a % (M:|chr i1:|Deletion  ) |||
-                loop_step <<< a % (M:|Deletion  :|chr i2) |||
-                nil_nil   <<< (M:|Epsilon:|Epsilon)       ... h
-              )
+grammar Signature{..} !a' !i1 !i2 =
+  let a = TW a' ( step_step <<< a % (M:|chr i1:|chr i2)     |||
+                  step_loop <<< a % (M:|chr i1:|Deletion  ) |||
+                  loop_step <<< a % (M:|Deletion  :|chr i2) |||
+                  nil_nil   <<< (M:|Epsilon @Global:|Epsilon @Global)       ... h
+                )
   in Z:.a
 {-# INLINE grammar #-}
 
@@ -185,13 +225,14 @@
 -- @-999999@ and find the maximum of that score and the choices we are
 -- given.
 
-sScore :: Monad m => Signature m Int Int Char
+sScore ∷ Monad m ⇒ Signature m Int Int Char
 sScore = Signature
-  { step_step = \x (Z:.a:.b) -> if a==b then x+1 else x-2
-  , step_loop = \x _         -> x-1
-  , loop_step = \x _         -> x-1
+  { step_step = \x (Z:.a:.b) → if a==b then x+7 else x-5
+  , step_loop = \x _         → x-3
+  , loop_step = \x _         → x-2
   , nil_nil   = const 0
-  , h = SM.foldl' max (-999999)
+  , h = SM.foldl' fastmax (-999999)
+--  , h = SM.foldl1' fastmax
   }
 {-# INLINE sScore #-}
 
@@ -205,11 +246,11 @@
 -- rather returns all alignments. You already heard about @<**@, we'll use
 -- it below.
 
-sPretty :: Monad m => Signature m [String] [[String]] Char
+sPretty ∷ Monad m ⇒ Signature m [String] [[String]] Char
 sPretty = Signature
-  { step_step = \[x,y] (Z:.a :.b ) -> [a  :x, b  :y]
-  , step_loop = \[x,y] (Z:.a :.()) -> [a  :x, '-':y]
-  , loop_step = \[x,y] (Z:.():.b ) -> ['-':x, b  :y]
+  { step_step = \[x,y] (Z:.a :.b ) → [a  :x, b  :y]
+  , step_loop = \[x,y] (Z:.a :.()) → [a  :x, '-':y]
+  , loop_step = \[x,y] (Z:.():.b ) → ['-':x, b  :y]
   , nil_nil   = const ["",""]
   , h = SM.toList
   }
@@ -220,13 +261,17 @@
 -- backtrackings, given the inputs @i1@ and @i2@. The @fst@ element
 -- returned is the score, the @snd@ are the co-optimal parses.
 
-runNeedlemanWunsch :: Int -> String -> String -> (Int,[[String]])
-runNeedlemanWunsch k i1' i2' = (d, take k bs) where
+runNeedlemanWunsch
+  ∷ Int
+  → String
+  → String
+  → (Int,[[String]],PerfCounter)
+runNeedlemanWunsch k i1' i2' = (d, take k bs,perf) where
   i1 = VU.fromList i1'
   i2 = VU.fromList i2'
   n1 = VU.length i1
   n2 = VU.length i2
-  !(Z:.t) = nwInsideForward i1 i2
+  Mutated (Z:.t) perf eachPerf = nwInsideForward i1 i2
   d = unId $ axiom t
   bs = nwInsideBacktrack i1 i2 t
 {-# Noinline runNeedlemanWunsch #-}
@@ -241,18 +286,28 @@
 -- For your own code, you can write as done here, or in the way of
 -- 'runOutsideNeedlemanWunsch'.
 
-nwInsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.ITbl Id Unboxed (Z:.PointL:.PointL) Int
-nwInsideForward i1 i2 = {-# SCC "nwInsideForward" #-} mutateTablesDefault $
-                          grammar sScore
-                          (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.PointL 0:.PointL 0) (Z:.PointL n1:.PointL n2) (-999999) []))
-                          i1 i2
-  where n1 = VU.length i1
-        n2 = VU.length i2
+nwInsideForward
+  ∷ VU.Vector Char
+  → VU.Vector Char
+  → Mutated (Z:.TwITbl _ _ Id (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int)
+nwInsideForward !i1 !i2 = {-# SCC "nwInsideForward" #-} runST $ do
+  arr ← newWithPA (ZZ:..LtPointL n1:..LtPointL n2) (-999999)
+  ts ← fillTables $ grammar sScore
+                      (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk:.EmptyOk) arr)
+                      i1 i2
+  return ts
+  where !n1 = VU.length i1
+        !n2 = VU.length i2
 {-# NoInline nwInsideForward #-}
 
-nwInsideBacktrack :: VU.Vector Char -> VU.Vector Char -> ITbl Id Unboxed (Z:.PointL:.PointL) Int -> [[String]]
+nwInsideBacktrack
+  ∷ VU.Vector Char
+  → VU.Vector Char
+  → TwITbl _ _ Id (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int
+  → [[String]]
 nwInsideBacktrack i1 i2 t = {-# SCC "nwInsideBacktrack" #-} unId $ axiom b
   where !(Z:.b) = grammar (sScore <|| sPretty) (toBacktrack t (undefined :: Id a -> Id a)) i1 i2
+                    :: Z:.TwITblBt _ _ (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int Id Id [String]
 {-# NoInline nwInsideBacktrack #-}
 
 -- | The outside version of the Needleman-Wunsch alignment algorithm. The
@@ -260,28 +315,39 @@
 -- generally the case, but here it is. Hence we may just use outside tables
 -- and the grammar from above.
 
-runOutsideNeedlemanWunsch :: Int -> String -> String -> (Int,[[String]])
-runOutsideNeedlemanWunsch k i1' i2' = {-# SCC "runOutside" #-} (d, take k . unId $ axiom b) where -- . S.toList . unId $ axiom b) where -- ,gogo) where
+runOutsideNeedlemanWunsch
+  ∷ Int
+  → String
+  → String
+  → (Int,[[String]],PerfCounter)
+runOutsideNeedlemanWunsch k i1' i2' = {-# SCC "runOutside" #-} (d, take k . unId $ axiom b, perf) where
   i1 = VU.fromList i1'
   i2 = VU.fromList i2'
   n1 = VU.length i1
   n2 = VU.length i2
-  !(Z:.t) = nwOutsideForward i1 i2
-  -- d = let (ITbl _ _ arr _) = t in arr PA.! (O (Z:.PointL 0:.PointL 0))
-  d = iTblArray t PA.! (O (Z:.PointL 0:.PointL 0))
+  Mutated (Z:.t) perf eachPerf = nwOutsideForward i1 i2
+  d = unId $ axiom t
   !(Z:.b) = grammar (sScore <|| sPretty) (toBacktrack t (undefined :: Id a -> Id a)) i1 i2
+              :: Z:.TwITblBt _ _ (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL O:.PointL O) Int Id Id [String]
 {-# Noinline runOutsideNeedlemanWunsch #-}
 
 -- | Again, to be able to observe performance, we have extracted the
 -- outside-table-filling part.
+--
+-- The partial type signature is filled by GHC.
 
-nwOutsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.ITbl Id Unboxed (Outside (Z:.PointL:.PointL)) Int
-nwOutsideForward i1 i2 = {-# SCC "nwOutsideForward" #-} mutateTablesDefault $
-                           grammar sScore
-                           (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (O (Z:.PointL 0:.PointL 0)) (O (Z:.PointL n1:.PointL n2)) (-999999) []))
-                           i1 i2
-  where n1 = VU.length i1
-        n2 = VU.length i2
+nwOutsideForward
+  ∷ VU.Vector Char
+  → VU.Vector Char
+  → Mutated (Z:.TwITbl _ _ Id (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL O:.PointL O) Int)
+nwOutsideForward !i1 !i2 = {-# SCC "nwOutsideForward" #-} runST $ do
+  arr ← newWithPA (ZZ:..LtPointL n1:..LtPointL n2) (-999999)
+  ts ← fillTables $ grammar sScore
+                      (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk:.EmptyOk) arr)
+                      i1 i2
+  return ts
+  where !n1 = VU.length i1
+        !n2 = VU.length i2
 {-# Noinline nwOutsideForward #-}
 
 -- | This wrapper takes a list of input sequences and aligns each odd
@@ -298,15 +364,19 @@
 
 align _ [] = return ()
 align _ [c] = putStrLn "single last line"
-align k (a:b:xs) = {-# SCC "align" #-} do
+align (kI,kO) (a:b:xs) = {-# SCC "align" #-} do
   putStrLn a
   putStrLn b
+  let (sI,rsI,perfI) = runNeedlemanWunsch kI a b
+  let (sO,rsO,perfO) = runOutsideNeedlemanWunsch kO a b
+  when (kI>=0) $ forM_ rsI $ \[u,l] -> printf "%s\n%s  %d\n\n" (reverse u) (reverse l) sI
+  when (kO>=0) $ forM_ rsO $ \[u,l] -> printf "%s\n%s  %d\n\n" (id      u) (id      l) sO
+  when (kI>=0) $ print sI
+  when (kO>=0) $ print sO
+  when (kI>=0) . putStrLn $ showPerfCounter perfI
+  when (kO>=0) . putStrLn $ showPerfCounter perfO
   putStrLn ""
-  let (sI,rsI) = runNeedlemanWunsch k a b
-  let (sO,rsO) = runOutsideNeedlemanWunsch k a b
-  forM_ rsI $ \[u,l] -> printf "%s\n%s  %d\n\n" (reverse u) (reverse l) sI
-  forM_ rsO $ \[u,l] -> printf "%s\n%s  %d\n\n" (id      u) (id      l) sO
-  align k xs
+  align (kI,kO) xs
 
 -- | And finally have a minimal main that reads from stdio.
 --
@@ -317,7 +387,13 @@
 
 main = do
   as <- getArgs
-  let k = if null as then 1 else read $ head as
+  let k = case as of
+            [] -> (1,1)
+            [x] -> let x' = read x
+                   in (x',x')
+            [x,y] -> let x' = read x; y' = read y
+                     in  (x',y')
+            args -> error $ "too many arguments"
   ls <- lines <$> getContents
   align k ls
 
diff --git a/src/Nussinov.hs b/src/Nussinov.hs
deleted file mode 100644
--- a/src/Nussinov.hs
+++ /dev/null
@@ -1,132 +0,0 @@
-
--- | Nussinovs RNA secondary structure prediction algorithm via basepair
--- maximization.
-
-module Main where
-
-import           Control.Applicative
-import           Control.Monad
-import           Control.Monad.ST
-import           Data.Char (toUpper,toLower)
-import           Data.List as L
-import           Data.Vector.Fusion.Util
-import           Debug.Trace
-import           Language.Haskell.TH
-import           Language.Haskell.TH.Syntax
-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           System.Environment (getArgs)
-import           Text.Printf
-
-import           Data.PrimitiveArray as PA
-
-import           ADP.Fusion
-
-
-
-data Nussinov m x r c = Nussinov
-  { unp :: x -> c -> x
-  , jux :: x -> c -> x -> c -> x
-  , nil :: () -> x
-  , h   :: SM.Stream m x -> m r
-  }
-
-makeAlgebraProduct ''Nussinov
-
-{-
- - due to backtracking schemes, we need a bunch of combintors
- -
- - how to deal with sup-optimal backtracking, without having to use (*||) ?
-
-(<||)   :: Single a -> List b   -> List b         -- co-optimal backtracking
-(*||)   :: Vector a -> List b   -> List (a,b)     -- classified co-optimal backtracking
-(***)   :: Single a -> Single b -> Vector (a,b)   -- classified DP
-
--}
-
-bpmax :: Monad m => Nussinov m Int Int Char
-bpmax = Nussinov
-  { unp = \ x c     -> x
-  , jux = \ x c y d -> if c `pairs` d then x + y + 1 else -999999
-  , nil = \ ()      -> 0
-  , h   = SM.foldl' max (-999999)
-  }
-{-# INLINE bpmax #-}
-
-prob :: Monad m => Nussinov m Double Double Char
-prob = Nussinov
-  { unp = \ x c     -> 0.3 * x
-  , jux = \ x c y d -> 0.6 * if c `pairs` d then x * y else 0
-  , nil = \ ()      -> 0.1
-  , h   = SM.foldl' (+) 0
-  }
-
--- |
-
-pairs !c !d
-  =  c=='A' && d=='U'
-  || c=='C' && d=='G'
-  || c=='G' && d=='C'
-  || c=='G' && d=='U'
-  || c=='U' && d=='A'
-  || c=='U' && d=='G'
-{-# INLINE pairs #-}
-
-pretty :: Monad m => Nussinov m String [String] Char -- (SM.Stream m String)
-pretty = Nussinov
-  { unp = \ x c     -> x ++ "."
-  , jux = \ x c y d -> x ++ "(" ++ y ++ ")"
-  , nil = \ ()      -> ""
-  , h   = SM.toList -- return . id
-  }
-{-# INLINE pretty #-}
-
-prettyL :: Monad m => Nussinov m String String Char
-prettyL = Nussinov
-  { unp = \ x c     -> x ++ "."
-  , jux = \ x c y d -> x ++ "(" ++ y ++ ")"
-  , nil = \ ()      -> ""
-  , h   = SM.head -- return . id
-  }
-{-# INLINE prettyL #-}
-
-grammar Nussinov{..} c t' =
-  let t = t'  ( unp <<< t % c           |||
-                jux <<< t % c % t % c   |||
-                nil <<< Epsilon         ... h
-              )
-  in Z:.t
-{-# INLINE grammar #-}
-
-runNussinov :: Int -> String -> (Int,[String])
-runNussinov k inp = (d, take k bs) where
-  i = VU.fromList . Prelude.map toUpper $ inp
-  n = VU.length i
-  !(Z:.t) = runInsideForward i
-  d = unId $ axiom t
-  bs = runInsideBacktrack i t
-{-# NOINLINE runNussinov #-}
-
-runInsideForward :: VU.Vector Char -> Z:.ITbl Id Unboxed Subword Int
-runInsideForward i = mutateTablesDefault
-                   $ grammar bpmax
-                       (chr i)
-                       (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) []))
-  where n = VU.length i
-{-# NoInline runInsideForward #-}
-
-runInsideBacktrack :: VU.Vector Char -> ITbl Id Unboxed Subword Int -> [String]
-runInsideBacktrack i t = unId $ axiom b
-  where !(Z:.b) = grammar (bpmax <|| pretty) (chr i) (toBacktrack t (undefined :: Id a -> Id a))
-{-# NoInline runInsideBacktrack #-}
-
-main = do
-  as <- getArgs
-  let k = if null as then 1 else read $ head as
-  ls <- lines <$> getContents
-  forM_ ls $ \l -> do
-    putStrLn l
-    let (s,xs) = runNussinov k l
-    mapM_ (\x -> printf "%s %5d\n" x s) xs
-
diff --git a/src/OverlappingPalindromes.hs b/src/OverlappingPalindromes.hs
deleted file mode 100644
--- a/src/OverlappingPalindromes.hs
+++ /dev/null
@@ -1,156 +0,0 @@
-
-{-# Language DataKinds #-}
-{-# Language KindSignatures #-}
-{-# Language ScopedTypeVariables #-}
-{-# Language DataKinds               #-}
-{-# Language DefaultSignatures       #-}
-{-# Language FlexibleContexts        #-}
-{-# Language FlexibleInstances       #-}
-{-# Language GADTs                   #-}
-{-# Language KindSignatures          #-}
-{-# Language MultiParamTypeClasses   #-}
-{-# Language RankNTypes              #-}
-{-# Language StandaloneDeriving      #-}
-{-# Language TemplateHaskell         #-}
-{-# Language TypeFamilies            #-}
-{-# Language TypeOperators           #-}
-{-# Language TypeSynonymInstances    #-}
-{-# Language UndecidableInstances    #-}
-
-module Main where
-
-import           Control.Applicative
-import           Control.Monad
-import           Data.Vector.Fusion.Stream.Monadic (Stream (..))
-import           Data.Vector.Fusion.Util
-import           Debug.Trace
-import qualified Control.Arrow as A
-import qualified Data.Vector as V
-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           System.Environment (getArgs)
-import           System.IO.Unsafe (unsafePerformIO)
-import           Text.Printf
-
-import           Data.PrimitiveArray as PA hiding (map)
-
-import           ADP.Fusion
-
-
-
-data Signature m x r c = Signature
-  { ovrlap :: () -> () -> x -> x -> () -> x -- TODO !!!
-  , brckts :: (Z:.c:.()) -> x -> (Z:.():.c) -> x
-  , braces :: (Z:.c:.()) -> x -> (Z:.():.c) -> x
-  , nilnil :: (Z:.():.()) -> x
-  , h :: Stream m x -> m r
-  }
-
-makeAlgebraProduct ''Signature
-
-
-
--- |
---
--- @
--- 012345678
--- [[((]]))
--- @
-
-grammar Signature{..} x' a' b' i =
-  let x = x'  ( ovrlap <<< (split (Proxy :: Proxy "a") (Proxy :: Proxy Fragment) a)
-                        %  (split (Proxy :: Proxy "b") (Proxy :: Proxy Fragment) b)
-                        %  (split (Proxy :: Proxy "a") (Proxy :: Proxy Final   ) a)
-                        %  (split (Proxy :: Proxy "b") (Proxy :: Proxy Final   ) b) -- ... h
-                        %  (split (Proxy :: Proxy "c") (Proxy :: Proxy Fragment) b) ... h
-              )
-      a = a'  ( nilnil <<< (M:|Epsilon:|Epsilon)                           |||
-                brckts <<< (M:|chr i:|Deletion) % a % (M:|Deletion:|chr i) ... h
-              )
-      b = b'  ( nilnil <<< (M:|Epsilon:|Epsilon)                           |||
-                braces <<< (M:|chr i:|Deletion) % b % (M:|Deletion:|chr i) ... h
-              )
-  in Z:.x:.a:.b
-{-# Inline grammar #-}
-
-
-
-score :: Monad m => Signature m Int Int Char
-score = Signature
-  { ovrlap = \ a' b' a b _ -> {- if a>0 || b>0 then traceShow ("oo",a',b',a,b) $ a + b else -} a+b -- TODO !!!
-  , brckts = \ (Z:.l:.()) a (Z:.():.r) -> {- traceShow ("[]",l,a,r) $ -} if l=='[' && r==']' then a+1 else -999999
-  , braces = \ (Z:.l:.()) b (Z:.():.r) -> {- traceShow ("()",l,b,r) $ -} if l=='(' && r==')' then b+1 else -999999
-  , nilnil = \ _ -> 0
-  , h = SM.foldl' max (-999999)
-  }
-{-# Inline score #-}
-
-
-
--- |
---
--- TODO pretty shows in @ovrlap@ that we might want to introduce a second
--- @h@ together with @Stream m y -> m s@?
-
-pretty :: Monad m => Signature m [String] [[String]] Char
-pretty = Signature
-  { ovrlap = \ () () [a,a'] [b,b'] () -> [a ++ b ++ a' ++ b'] -- TODO !!!
-  , brckts = \ (Z:.l:.()) [a,a'] (Z:.():.r) -> ["a"++a , a'++"A"]
-  , braces = \ (Z:.l:.()) [b,b'] (Z:.():.r) -> ["b"++b , b'++"B"]
-  , nilnil = \ _ -> ["",""]
-  , h = SM.toList
-  }
-{-# Inline pretty #-}
-
-
-
-overlappingPalindromes :: String -> (Int,[[String]])
-overlappingPalindromes inp = (d,bs) where
-  i  = VU.fromList inp
-  n  = VU.length i
-  d  = unId $ axiom x
-  bs = unId $ axiom x'
-  x :: X
-  a :: T
-  b :: T
-  (Z:.x:.a:.b) = opForward i
-  {-
-  (Z:.x:.a:.b) = mutateTablesDefault $
-                   grammar score
-                   (ITbl 1 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) []))
-                   (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 n:.subword 0 n) (-999999) []))
-                   (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 n:.subword 0 n) (-999999) []))
-                   i
-                   -}
-  (Z:.x':.a':.b') = grammar (score <|| pretty)
-                      (toBacktrack x (undefined :: Id a -> Id a))
-                      (toBacktrack a (undefined :: Id a -> Id a))
-                      (toBacktrack b (undefined :: Id a -> Id a))
-                      i
-{-# NoInline overlappingPalindromes #-}
-
-opForward :: VU.Vector Char -> Z:.X:.T:.T
-opForward i =
-  let n = VU.length i
-  in  mutateTablesDefault $
-        grammar score
-        (ITbl 1 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) []))
-        (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 n:.subword 0 n) (-999999) []))
-        (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 n:.subword 0 n) (-999999) []))
-        i
-{-# NoInline opForward #-}
-
-type X = ITbl Id Unboxed Subword Int
-type T = ITbl Id Unboxed (Z:.Subword:.Subword) Int
-
-
-main :: IO ()
-main = do
-  xs <- fmap lines $ getContents
-  forM_ xs $ \x -> do
-    let (d,bs) = overlappingPalindromes x
-    putStrLn x
-    print d
---    putStrLn $ head $ head bs
-
diff --git a/src/PartNussinov.hs b/src/PartNussinov.hs
deleted file mode 100644
--- a/src/PartNussinov.hs
+++ /dev/null
@@ -1,275 +0,0 @@
-
--- | Nussinovs RNA secondary structure prediction algorithm via basepair
--- maximization.
-
-module Main where
-
-import           Control.Applicative
-import           Control.Monad
-import           Control.Monad.ST
-import           Data.Char (toUpper,toLower)
-import           Data.List
-import           Data.Vector.Fusion.Util
-import           Debug.Trace
-import           Language.Haskell.TH
-import           Language.Haskell.TH.Syntax
-import           Numeric.Log as Log
-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           System.Environment (getArgs)
-import           Text.Printf
-
-import           Data.PrimitiveArray as PA
-
-import           ADP.Fusion
-
-
-
--- * Inside and Outside grammar constructs
-
-data Nussinov m c e x r = Nussinov
-  { unp :: x -> c -> x
-  , jux :: x -> x -> x
-  , pai :: c -> x -> c -> x
-  , nil :: e -> x
-  , h   :: SM.Stream m x -> m r
-  }
-
-makeAlgebraProduct ''Nussinov
-
-bpmax :: Monad m => Nussinov m Char () Int Int
-bpmax = Nussinov
-  { unp = \ x c   -> x
-  , jux = \ x y   -> x + y
-  , pai = \ c x d -> if c `pairs` d then x+1 else (-999999)
-  , nil = \ ()    -> 0
-  , h   = SM.foldl' max (-999999)
-  }
-{-# INLINE bpmax #-}
-
-prob :: Monad m => Nussinov m Char () (Log Double) (Log Double)
-prob = Nussinov
-  { unp = \ x c     -> 0.1 * x                                -- 'any'
-  , jux = \ x y     -> 0.9 * x * y                            -- 'any'
-  , pai = \ c x d   -> 1.0 * if c `pairs` d then x else 0     -- 'paired'
-  , nil = \ ()      -> 1.0                                    -- 'any'
-  , h   = SM.foldl' (+) 0
-  }
-{-# Inline prob #-}
-
--- |
-
-pairs !c !d
-  =  c=='A' && d=='U'
-  || c=='C' && d=='G'
-  || c=='G' && d=='C'
-  || c=='G' && d=='U'
-  || c=='U' && d=='A'
-  || c=='U' && d=='G'
-{-# INLINE pairs #-}
-
-pretty :: Monad m => Nussinov m Char () String (SM.Stream m String)
-pretty = Nussinov
-  { unp = \ x c     -> x ++ "."
-  , jux = \ x y     -> x ++ y
-  , pai = \ c x d   -> "(" ++ x ++ ")"
-  , nil = \ ()      -> ""
-  , h   = return . id
-  }
-{-# INLINE pretty #-}
-
--- | The inside grammar is:
---
--- @
--- A -> A c
--- A -> A P
--- A -> ε
--- P -> c A c
--- @
-
--- insideGrammar :: Nussinov m Char () x r -> c' -> t' -> (t', Subword -> m r)
-insideGrammar Nussinov{..} c a' p' =
-  let a = a'  ( unp <<< a % c     |||
-                jux <<< a % p     |||
-                nil <<< Epsilon   ... h
-              )
-      p = p'  ( pai <<< c % a % c ... h
-              )
-  in Z:.p:.a
-{-# INLINE insideGrammar #-}
-
--- | Given the inside grammar, the outside grammar is:
---
--- @
--- B -> B c
--- B -> B P
--- B -> ε
--- B -> c Q c
--- Q -> A B
--- @
-
-outsideGrammar Nussinov{..} c a p b' q' =
-  let b = b'  ( unp <<< b % c         |||
-                jux <<< b % p         |||
-                pai <<< c % q % c     |||
-                nil <<< Epsilon       ... h
-              )
-      q = q'  ( jux <<< a % b         ... h
-              )
-  in Z:.b:.q
-{-# INLINE outsideGrammar #-}
-
-
-
--- * Ensemble collection constructs
-
-data NussinovEnsemble m v ci x r = NussinovEnsemble
-  { ens :: v -> ci -> v -> x
-  , hhh :: SM.Stream m x -> m r
-  }
-
-ensemble
-  :: Monad m
-  => Log Double
-  -> NussinovEnsemble
-        m
-        (Log Double)
-        (Complement Subword:.(Complement Subword))
-        (Subword, Log Double)
-        [(Subword, Log Double)]
-ensemble z = NussinovEnsemble
-  { ens = \ x (C k:._) y -> ( k , x * y / z )
-  , hhh = SM.toList
-  }
-{-# Inline ensemble #-}
-
-ensembleGrammar NussinovEnsemble{..} i o v' =
-  let v = v' ( ens <<< i % (PeekIndex :: PeekIndex (Complement Subword)) % o ... hhh )
-  in  Z:.v
-{-# Inline ensembleGrammar #-}
-
--- makeAlgebraProductH ['hhh] ''NussinovEnsemble
-
-
-
--- * Run different algorithm parts
-
-runNussinov :: String -> ([(Subword, Log Double)], Log Double, [(Int,Int, Log Double, Log Double, Log Double, Log Double)])
-runNussinov inp = (es,z,ys) where
-  i = VU.fromList . Prelude.map toUpper $ inp
-  n = VU.length i
-  !(Z:.p:.a) = runInsideForward i
-  !(Z:.b:.q) = runOutsideForward i a p
-  es = runEnsembleForward z p q
-  za = let (ITbl _ _ _ arr _) = a in arr PA.! subword 0 n
-  zp = let (ITbl _ _ _ arr _) = p in arr PA.! subword 0 n
-  z  = za
-  e = let (ITbl _ _ _ arr _) = b in Log.sum [ arr PA.! (O $ subword k k) | k <- [0 .. n] ]
-  ys =  [ ( k
-          , l
-          , fwda PA.! subword k l
-          , fwdp PA.! subword k l
-          , bwdb PA.! (O $ subword k l)
-          , bwdq PA.! (O $ subword k l)
-          )
-        | let (ITbl _ _ _ fwda _) = a
-        , let (ITbl _ _ _ fwdp _) = p
-        , let (ITbl _ _ _ bwdb _) = b
-        , let (ITbl _ _ _ bwdq _) = q
-        , k <- [0 .. n]
-        , l <- [k .. n]
-        ]
-{-# NOINLINE runNussinov #-}
-
-neat :: String -> IO ()
-neat i = do let (es,z,ys) = runNussinov i
-            forM_ ys $ \ (k,_,_,_,_,_) -> printf " %6d" k
-            putStrLn ""
-            forM_ ys $ \ (_,l,_,_,_,_) -> printf " %6d" l
-            putStrLn ""
-            forM_ ys $ \ (_,_,a,_,_,_) -> printf " %0.4f" (exp $ ln a)
-            putStrLn ""
-            forM_ ys $ \ (_,_,_,p,_,_) -> printf " %0.4f" (exp $ ln p)
-            putStrLn ""
-            forM_ ys $ \ (_,_,_,_,b,_) -> printf " %0.4f" (exp $ ln b)
-            putStrLn ""
-            forM_ ys $ \ (_,_,_,_,_,q) -> printf " %0.4f" (exp $ ln q)
-            putStrLn ""
-            printf "%0.4f\n" $ exp $ ln z
-            forM_ ys $ \ (_,_,_,p,_,q) -> printf " %0.4f" ((exp $ ln p) * (exp $ ln q) / (exp $ ln z))
-            putStrLn ""
-            putStrLn ""
-            forM_ es $ \ (Subword (i:.j),v) -> printf "%3d %3d  %0.4f\n" i j (exp $ ln v)
-            putStrLn ""
-
-type TblI = ITbl Id Unboxed          Subword  (Log Double)
-type TblO = ITbl Id Unboxed (Outside Subword) (Log Double)
-
-runInsideForward :: VU.Vector Char -> Z:.TblI:.TblI
-runInsideForward i = mutateTablesDefault
-                   $ insideGrammar prob
-                       (chr i)
-                       (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) 0 []))
-                       (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) 0 []))
-  where n = VU.length i
-{-# NoInline runInsideForward #-}
-
-runOutsideForward :: VU.Vector Char -> TblI -> TblI -> Z:.TblO:.TblO
-runOutsideForward i a p = mutateTablesDefault
-                        $ outsideGrammar prob
-                            (chr i)
-                            a p
-                            (ITbl 0 0 EmptyOk (PA.fromAssocs (O $ subword 0 0) (O $ subword 0 n) 0 []))
-                            (ITbl 0 1 EmptyOk (PA.fromAssocs (O $ subword 0 0) (O $ subword 0 n) 0 []))
-  where n = VU.length i
-{-# NoInline runOutsideForward #-}
-
-runEnsembleForward :: Log Double -> TblI -> TblO -> [ (Subword,Log Double) ]
-runEnsembleForward z i o = unId $ axiom g
-  where (Z:.g) = ensembleGrammar (ensemble z)
-                   i o
-                   (IRec EmptyOk (C l) (C h))
-                 :: Z :. IRec Id (Complement Subword) [(Subword, Log Double)]
-        (l,h) = let (ITbl _ _ _ arr _) = i in bounds arr
-{-# NoInline runEnsembleForward #-}
-
-{-
-runPartitionNussinov :: String -> [(Subword,Double,Double,Double)]
-runPartitionNussinov inp
-  = Data.List.map (\(sh,a) -> let b = iTblArray t PA.! (O sh)
-                              in (sh, a, b, a*b/d)
-                  ) (PA.assocs $ iTblArray s)
-  where
-  i = VU.fromList . Prelude.map toUpper $ inp
-  n = VU.length i
-  s :: ITbl Id Unboxed Subword Double
-  !(Z:.s) = mutateTablesDefault
-          $ grammar prob
-              (chr i)
-              (ITbl EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) 0 []))
-              
-  d = iTblArray s PA.! subword 0 n
-  t :: ITbl Id Unboxed (Outside Subword) Double
-  !(Z:.t) = mutateTablesDefault
-          $ outsideGrammar prob
-              (chr i)
-              --(undefined :: ITbl Id Unboxed (Outside Subword) Double)
-              s
-              (ITbl EmptyOk (PA.fromAssocs (O $ subword 0 0) (O $ subword 0 n) (-1) []))
-{-# NOINLINE runPartitionNussinov #-}
--}
-
-main :: IO ()
-main = do
-  return ()
-  {-
-  as <- getArgs
-  let k = if null as then 1 else read $ head as
-  ls <- lines <$> getContents
-  forM_ ls $ \l -> do
-    putStrLn l
-    let (s,xs) = runNussinov k l
-    mapM_ (\x -> printf "%s %5d\n" x s) xs
-  -}
-
diff --git a/src/Pseudoknot.hs b/src/Pseudoknot.hs
deleted file mode 100644
--- a/src/Pseudoknot.hs
+++ /dev/null
@@ -1,148 +0,0 @@
-
-module Main where
-
-import           Control.Applicative
-import           Control.Monad
-import           Control.Monad.ST
-import           Data.Char (toUpper,toLower)
-import           Data.List as L
-import           Data.Vector.Fusion.Util
-import           Debug.Trace
-import           Language.Haskell.TH
-import           Language.Haskell.TH.Syntax
-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           System.Environment (getArgs)
-import           Text.Printf
-
-import           Data.PrimitiveArray as PA
-
-import           ADP.Fusion
-
-
-
-data Nussinov m x r c = Nussinov
-  { unp :: x -> c -> x
-  , jux :: x -> c -> x -> c -> x
-  , pse :: () -> () -> x -> x -> x
-  , nil :: () -> x
-  , pk1 :: (Z:.x:.()) -> (Z:.c:.()) -> x -> (Z:.():.x) -> (Z:.():.c) -> x
-  , pk2 :: (Z:.x:.()) -> (Z:.c:.()) -> x -> (Z:.():.x) -> (Z:.():.c) -> x
-  , nll :: (Z:.():.()) -> x
-  , h   :: SM.Stream m x -> m r
-  }
-
-makeAlgebraProduct ''Nussinov
-
-
-bpmax :: Monad m => Nussinov m Int Int Char
-bpmax = Nussinov
-  { unp = \ x c     -> x
-  , jux = \ x c y d -> if c `pairs` d then x + y + 1 else -999999
-  , pse = \ () () x y -> x + y
-  , nil = \ ()      -> 0
-  , pk1 = \ (Z:.x:.()) (Z:.a:.()) y (Z:.():.z) (Z:.():.b) -> if a `pairs` b then x + y + z + 1 else -888888
-  , pk2 = \ (Z:.x:.()) (Z:.a:.()) y (Z:.():.z) (Z:.():.b) -> if a `pairs` b then x + y + z + 1 else -888888
-  , nll = \ (Z:.():.()) -> 0
-  , h   = SM.foldl' max (-999999)
-  }
-{-# INLINE bpmax #-}
-
--- |
-
-pairs !c !d
-  =  c=='A' && d=='U'
-  || c=='C' && d=='G'
-  || c=='G' && d=='C'
-  || c=='G' && d=='U'
-  || c=='U' && d=='A'
-  || c=='U' && d=='G'
-{-# INLINE pairs #-}
-
--- |
---
--- TODO It could be beneficial to introduce
--- @type Splitted = Either String (String,String)@
--- or something isomorphic. While [String] works, it allows for too many
--- possibilities here! ([] ist lightweight, on the other hand ...)
-
-pretty :: Monad m => Nussinov m [String] [[String]] Char
-pretty = Nussinov
-  { unp = \ [x] c     -> [x ++ "."]
-  , jux = \ [x] c [y] d -> [x ++ "(" ++ y ++ ")"]
-  , pse = \ () () [x1,x2] [y1,y2] -> [x1 ++ y1 ++ x2 ++ y2]
-  , nil = \ ()      -> [""]
-  , pk1 = \ (Z:.[x]:.()) (Z:.a:.()) [y1,y2] (Z:.():.[z]) (Z:.():.b) -> [x ++ "[" ++ y1 , y2 ++ z ++ "]"]
-  , pk2 = \ (Z:.[x]:.()) (Z:.a:.()) [y1,y2] (Z:.():.[z]) (Z:.():.b) -> [x ++ "{" ++ y1 , y2 ++ z ++ "}"]
-  , nll = \ (Z:.():.()) -> ["",""]
-  , h   = SM.toList
-  }
-{-# INLINE pretty #-}
-
-grammar Nussinov{..} t' u' v' c =
-  let t = t'  ( unp <<< t % c               |||
-                jux <<< t % c % t % c   |||
-                nil <<< Epsilon                 |||
-                pse <<< (split (Proxy :: Proxy "U") (Proxy :: Proxy Fragment) u)
-                     %  (split (Proxy :: Proxy "V") (Proxy :: Proxy Fragment) v)
-                     %  (split (Proxy :: Proxy "U") (Proxy :: Proxy Final)    u)
-                     %  (split (Proxy :: Proxy "V") (Proxy :: Proxy Final)    v)  ... h
-              )
-      u = u'  ( pk1 <<< (M:|t:|Deletion) % (M:|c:|Deletion) % u % (M:|Deletion:|t) % (M:|Deletion:|c) |||
-                nll <<< (M:|Epsilon:|Epsilon)                                                                 ... h
-              )
-      v = v'  ( pk2 <<< (M:|t:|Deletion) % (M:|c:|Deletion) % v % (M:|Deletion:|t) % (M:|Deletion:|c) |||
-                nll <<< (M:|Epsilon:|Epsilon)                                                                 ... h
-              )
-  in Z:.t:.u:.v
-{-# INLINE grammar #-}
-
-runPseudoknot :: Int -> String -> (Int,[[String]])
-runPseudoknot k inp = (d, take k bs) where
-  i = VU.fromList . Prelude.map toUpper $ inp
-  n = VU.length i
-  !(Z:.t:.u:.v) = runInsideForward i
-  d = unId $ axiom t
-  bs = {- let ITbl _ _ _ x _ = v in traceShow (filter (flip elem gives . fst) $ assocs x) $ -} runInsideBacktrack i (Z:.t:.u:.v)
-  gives = [ Z:.subword 2 2 :. subword 3 3
-          , Z:.subword 1 2 :. subword 3 5
-          ]
-  {-
-   -  u g a a c
-   - 0 1 2 3 4 5
-  -}
-{-# NOINLINE runPseudoknot #-}
-
-type X = ITbl Id Unboxed Subword Int
-type T = ITbl Id Unboxed (Z:.Subword:.Subword) Int
-
-runInsideForward :: VU.Vector Char -> Z:.X:.T:.T
-runInsideForward i = mutateTablesWithHints (Proxy :: Proxy MonotoneMCFG)
-                   $ grammar bpmax
-                        (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-666999) []))
-                        (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 n:.subword 0 n) (-777999) []))
-                        (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 n:.subword 0 n) (-888999) []))
-                        (chr i)
-  where n = VU.length i
-{-# NoInline runInsideForward #-}
-
-runInsideBacktrack :: VU.Vector Char -> Z:.X:.T:.T -> [[String]]
-runInsideBacktrack i (Z:.t:.u:.v) = unId $ axiom b
-  where !(Z:.b:._:._) = grammar (bpmax <|| pretty)
-                          (toBacktrack t (undefined :: Id a -> Id a))
-                          (toBacktrack u (undefined :: Id a -> Id a))
-                          (toBacktrack v (undefined :: Id a -> Id a))
-                          (chr i)
-{-# NoInline runInsideBacktrack #-}
-
-main = do
-  as <- getArgs
-  let k = if null as then 1 else read $ head as
-  ls <- lines <$> getContents
-  forM_ ls $ \l -> do
-    putStrLn l
-    let (s,xs) = runPseudoknot k l
-    print s
-    mapM_ (\[x] -> printf "%s %5d\n" x s) xs
-
diff --git a/src/SmithWaterman.hs b/src/SmithWaterman.hs
new file mode 100644
--- /dev/null
+++ b/src/SmithWaterman.hs
@@ -0,0 +1,194 @@
+
+{-# Options_GHC -fforce-recomp #-}
+{-# Options_GHC -Wno-partial-type-signatures #-}
+
+{-# Language MagicHash #-}
+
+
+module Main (main) where
+
+import           Control.Monad (forM_,when)
+import           Debug.Trace
+import           System.Environment (getArgs)
+import           Text.Printf
+import           Control.Monad.Primitive
+import           Control.Monad.ST
+import           Data.Foldable (maximumBy)
+import           Data.Ord (comparing)
+import           Data.Ord.Fast
+import           GHC.Exts
+
+import qualified Data.Vector.Fusion.Stream.Monadic as SM
+import qualified Data.Vector.Unboxed as VU
+
+import           Data.PrimitiveArray as PA hiding (map)
+
+import           ADP.Fusion.PointL
+
+
+
+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
+  }
+
+makeAlgebraProduct ''Signature
+
+grammar Signature{..} !a' !i1 !i2 =
+  let a = TW a' ( step_step <<< a % (M:|chr i1:|chr i2)     |||
+                  step_loop <<< a % (M:|chr i1:|Deletion  ) |||
+                  loop_step <<< a % (M:|Deletion  :|chr i2) |||
+                  nil_nil   <<< (M:|Epsilon @Local:|Epsilon @Local)       ... h
+                )
+  in Z:.a
+{-# INLINE grammar #-}
+
+fasteq ∷ Char → Char → Int → Int → Int
+{-# Inline fasteq #-}
+fasteq (C# a) (C# b) (I# x) (I# y) =
+  let l = (eqChar# a b)
+  in  I# ( (x *# l) +# (y *# (1# -# l)) )
+
+sScore ∷ Monad m ⇒ Signature m Int Int Char
+sScore = Signature
+  -- { step_step = \x (Z:.a:.b) → if a==b then x + 1 else x-2
+  { step_step = \x (Z:.a:.b) → fasteq a b (x+1) (x-2) -- if a==b then x + 1 else x-2
+  , step_loop = \x _         → x-1
+  , loop_step = \x _         → x-1
+  , nil_nil   = const 0
+  , h = SM.foldl' fastmax (-999999)
+  }
+{-# INLINE sScore #-}
+
+
+sPretty ∷ Monad m ⇒ Signature m [String] [[String]] Char
+sPretty = Signature
+  { step_step = \[x,y] (Z:.a :.b ) → [a  :x, b  :y]
+  , step_loop = \[x,y] (Z:.a :.()) → [a  :x, '-':y]
+  , loop_step = \[x,y] (Z:.():.b ) → ['-':x, b  :y]
+  , nil_nil   = const ["",""]
+  , h = SM.toList
+  }
+{-# Inline sPretty #-}
+
+
+runNeedlemanWunsch
+  ∷ Int
+  → String
+  → String
+  → ((Z:.PointL I:.PointL I),Int,[[String]],PerfCounter)
+runNeedlemanWunsch k i1' i2' = (fst dlocal, snd dlocal, take k bs,perf) where
+  i1 = VU.fromList i1'
+  i2 = VU.fromList i2'
+  n1 = VU.length i1
+  n2 = VU.length i2
+  Mutated (Z:.t) perf eachPerf = nwInsideForward i1 i2
+  dlocal = let TW (ITbl _ t') _ = t
+           in unId . SM.foldl' (\(ap,as) (p,s) → if s > as then (p,s) else (ap,as)) (Z:.PointL 0:.PointL 0,0) $ PA.assocsS t'
+  bs = nwInsideBacktrack i1 i2 t (fst dlocal)
+{-# Noinline runNeedlemanWunsch #-}
+
+
+nwInsideForward
+  ∷ VU.Vector Char
+  → VU.Vector Char
+  → Mutated (Z:.TwITbl _ _ Id (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int)
+nwInsideForward !i1 !i2 = {-# SCC "nwInsideForward" #-} runST $ do
+  arr ← newWithPA (ZZ:..LtPointL n1:..LtPointL n2) (-999999)
+  ts ← fillTables $ grammar sScore
+                      (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk:.EmptyOk) arr)
+                      i1 i2
+  return ts
+  where !n1 = VU.length i1
+        !n2 = VU.length i2
+{-# NoInline nwInsideForward #-}
+
+nwInsideBacktrack
+  ∷ VU.Vector Char
+  → VU.Vector Char
+  → TwITbl _ _ Id (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int
+  → (Z:.PointL I:.PointL I)
+  → [[String]]
+nwInsideBacktrack i1 i2 t k = {-# SCC "nwInsideBacktrack" #-} unId $ axiomAt b k
+  where !(Z:.b) = grammar (sScore <|| sPretty) (toBacktrack t (undefined :: Id a -> Id a)) i1 i2
+                    :: Z:.TwITblBt _ _ (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int Id Id [String]
+{-# NoInline nwInsideBacktrack #-}
+
+
+--runOutsideNeedlemanWunsch
+--  ∷ Int
+--  → String
+--  → String
+--  → (Int,[[String]],PerfCounter)
+--runOutsideNeedlemanWunsch k i1' i2' = {-# SCC "runOutside" #-} (d, take k . unId $ axiom b, perf) where
+--  i1 = VU.fromList i1'
+--  i2 = VU.fromList i2'
+--  n1 = VU.length i1
+--  n2 = VU.length i2
+--  Mutated (Z:.t) perf eachPerf = nwOutsideForward i1 i2
+--  d = unId $ axiom t
+--  !(Z:.b) = grammar (sScore <|| sPretty) (toBacktrack t (undefined :: Id a -> Id a)) i1 i2
+--              :: Z:.TwITblBt _ _ (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL O:.PointL O) Int Id Id [String]
+--{-# Noinline runOutsideNeedlemanWunsch #-}
+--
+--
+--nwOutsideForward
+--  ∷ VU.Vector Char
+--  → VU.Vector Char
+--  → Mutated (Z:.TwITbl _ _ Id (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL O:.PointL O) Int)
+--nwOutsideForward !i1 !i2 = {-# SCC "nwOutsideForward" #-} runST $ do
+--  arr ← newWithPA (ZZ:..LtPointL n1:..LtPointL n2) (-999999)
+--  ts ← fillTables $ grammar sScore
+--                      (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk:.EmptyOk) arr)
+--                      i1 i2
+--  return ts
+--  where !n1 = VU.length i1
+--        !n2 = VU.length i2
+--{-# Noinline nwOutsideForward #-}
+
+-- | This wrapper takes a list of input sequences and aligns each odd
+-- sequence with the next even sequence. We want one alignment for each
+-- such pair.
+--
+-- Since we use basic lists during backtracking, the resulting lists have
+-- to be reversed for inside-backtracking. Note that because the Outside
+-- grammar is quasi-right-linear, it does not require reversing the two
+-- strings.
+--
+-- For real applications, consider using @Data.Sequence@ which has @O(1)@
+-- append and prepend.
+
+align _ [] = return ()
+align _ [c] = putStrLn "single last line"
+align (kI,kO) (a:b:xs) = {-# SCC "align" #-} do
+  putStrLn a
+  putStrLn b
+  let (posI,sI,rsI,perfI) = runNeedlemanWunsch kI a b
+  when (kI>=0) $ forM_ rsI $ \[u,l] -> printf "%s\n%s\n  %d   %s\n\n" (reverse u) (reverse l) (sI) (show posI)
+  when (kI>=0) $ print sI
+  when (kI>=0) . putStrLn $ showPerfCounter perfI
+  putStrLn ""
+  align (kI,kO) xs
+
+-- | And finally have a minimal main that reads from stdio.
+--
+-- If you are brave enough then put this through @ghc-core@ and look for
+-- @nwInsideForward@ or @nwOutsideForward@ in the CORE. Everything coming
+-- from the forward phase should be beautifully optimized and the algorithm
+-- should run quite fast.
+
+main = do
+  as <- getArgs
+  let k = case as of
+            [] -> (1,1)
+            [x] -> let x' = read x
+                   in (x',x')
+            [x,y] -> let x' = read x; y' = read y
+                     in  (x',y')
+            args -> error $ "too many arguments"
+  ls <- lines <$> getContents
+  align k ls
+
diff --git a/src/SpecTest.hs b/src/SpecTest.hs
new file mode 100644
--- /dev/null
+++ b/src/SpecTest.hs
@@ -0,0 +1,116 @@
+
+-- | Lets try to get a grip on what specconstr does to our code.
+
+module Main (main) where
+
+import           Control.Applicative
+import           Control.Monad
+import           Data.Vector.Fusion.Stream.Monadic (Stream (..))
+import           Data.Vector.Fusion.Util
+import           Debug.Trace
+import qualified Control.Arrow as A
+import qualified Data.Vector as V
+import qualified Data.Vector.Fusion.Stream.Monadic as SM
+import qualified Data.Vector.Unboxed as VU
+import           System.Environment (getArgs)
+import           System.IO.Unsafe (unsafePerformIO)
+import           Text.Printf
+
+import           Data.PrimitiveArray as PA hiding (map)
+
+import           ADP.Fusion.Point
+
+
+
+
+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
+  , booboo    :: x -> (Z:.c:.c) -> (Z:.c:.c) -> (Z:.c:.c) -> (Z:.c:.c) -> x
+  , h         :: Stream m x -> m r
+  }
+
+
+
+grammar Signature{..} a' i1 i2 =
+  let a = a'  ( --step_step <<< a % (M:|chr i1:|chr i2)     |||
+--                step_loop <<< a % (M:|chr i1:|Deletion  ) |||
+--                loop_step <<< a % (M:|Deletion  :|chr i2) |||
+                step_step <<< a % (M:|chr i1:|chr i2)     |||
+--                step_step <<< a % (M:|chr i1:|chr i2)     |||
+--                step_step <<< a % (M:|chr i1:|chr i2)     |||
+--                step_step <<< a % (M:|chr i1:|chr i2)     |||
+--                step_step <<< a % (M:|chr i1:|chr i2)     |||
+--                step_step <<< a % (M:|chr i1:|chr i2)     |||
+--                step_step <<< a % (M:|chr i1:|chr i2)     |||
+--                step_step <<< a % (M:|chr i1:|chr i2)     |||
+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||
+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||
+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||
+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||
+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||
+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||
+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||
+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||
+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||
+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||
+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||
+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||
+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||
+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||
+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||
+--                nil_nil   <<< (M:|Epsilon:|Epsilon)       |||
+--                nil_nil   <<< (M:|Epsilon:|Epsilon)       |||
+--                nil_nil   <<< (M:|Epsilon:|Epsilon)       |||
+--                nil_nil   <<< (M:|Epsilon:|Epsilon)       |||
+--                nil_nil   <<< (M:|Epsilon:|Epsilon)       |||
+--                nil_nil   <<< (M:|Epsilon:|Epsilon)       |||
+--                nil_nil   <<< (M:|Epsilon:|Epsilon)       |||
+--                nil_nil   <<< (M:|Epsilon:|Epsilon)       |||
+--                nil_nil   <<< (M:|Epsilon:|Epsilon)       |||
+--                nil_nil   <<< (M:|Epsilon:|Epsilon)       |||
+--                nil_nil   <<< (M:|Epsilon:|Epsilon)       |||
+                nil_nil   <<< (M:|Epsilon:|Epsilon)       ... h
+              )
+  in Z:.a
+{-# 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-2
+  , step_loop = \x _         -> x-1
+  , loop_step = \x _         -> x-1
+  , nil_nil   = const 0
+  , booboo    = \x _ _ _ _   -> x
+  , h = SM.foldl' max (-999999)
+  }
+{-# INLINE sScore #-}
+
+
+runNeedlemanWunsch :: Int -> String -> String -> Int
+runNeedlemanWunsch k i1' i2' = d where
+  i1 = VU.fromList i1'
+  i2 = VU.fromList i2'
+  n1 = VU.length i1
+  n2 = VU.length i2
+  !(Z:.t) = nwInsideForward i1 i2
+  d = unId $ axiom t
+{-# Noinline runNeedlemanWunsch #-}
+
+nwInsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.ITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int
+nwInsideForward i1 i2 = {-# SCC "nwInsideForward" #-} mutateTablesDefault $
+                          grammar sScore
+                          (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.PointL 0:.PointL 0) (Z:.PointL n1:.PointL n2) (-999999) []))
+                          i1 i2
+  where n1 = VU.length i1
+        n2 = VU.length i2
+{-# NoInline nwInsideForward #-}
+
+main = do
+  ls <- lines <$> getContents
+  print $ runNeedlemanWunsch 1 (ls!!0) (ls!!1)
+
+
diff --git a/src/SplitTests.hs b/src/SplitTests.hs
deleted file mode 100644
--- a/src/SplitTests.hs
+++ /dev/null
@@ -1,136 +0,0 @@
-
-{-# Language DataKinds #-}
-{-# Language KindSignatures #-}
-{-# Language ScopedTypeVariables #-}
-{-# Language DataKinds               #-}
-{-# Language DefaultSignatures       #-}
-{-# Language FlexibleContexts        #-}
-{-# Language FlexibleInstances       #-}
-{-# Language GADTs                   #-}
-{-# Language KindSignatures          #-}
-{-# Language MultiParamTypeClasses   #-}
-{-# Language RankNTypes              #-}
-{-# Language StandaloneDeriving      #-}
-{-# Language TemplateHaskell         #-}
-{-# Language TypeFamilies            #-}
-{-# Language TypeOperators           #-}
-{-# Language TypeSynonymInstances    #-}
-{-# Language UndecidableInstances    #-}
-
-module Main where
-
-import           Control.Applicative
-import           Control.Monad
-import           Data.Vector.Fusion.Stream.Monadic (Stream (..))
-import           Data.Vector.Fusion.Util
-import           Debug.Trace
-import qualified Control.Arrow as A
-import qualified Data.Vector as V
-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           System.Environment (getArgs)
-import           System.IO.Unsafe (unsafePerformIO)
-import           Text.Printf
-
-import           Data.PrimitiveArray as PA hiding (map)
-
-import           ADP.Fusion
-
-
-
-data Signature m x r c = Signature
-  { ovrlap :: () -> x -> x
-  , brckts :: (Z:.c:.()) -> x -> (Z:.():.c) -> x
-  , nilnil :: (Z:.():.()) -> x
-  , h :: Stream m x -> m r
-  }
-
-makeAlgebraProduct ''Signature
-
-
-
--- |
---
--- @
--- 012345678
--- [[((]]))
--- @
-
-grammar Signature{..} x' a' i =
-  let x = x'  ( ovrlap <<< (split (Proxy :: Proxy "a") (Proxy :: Proxy Fragment) a)
-                        %  (split (Proxy :: Proxy "a") (Proxy :: Proxy Final   ) a) ... h
-              )
-      a = a'  ( nilnil <<< (M:|Epsilon:|Epsilon)                           |||
-                brckts <<< (M:|chr i:|Deletion) % a % (M:|Deletion:|chr i) ... h
-              )
-  in Z:.x:.a
-{-# Inline grammar #-}
-
-
-
-score :: Monad m => Signature m Int Int Char
-score = Signature
-  { ovrlap = \ a' a -> a + 4711
-  , brckts = \ (Z:.l:.()) a (Z:.():.r) -> {- traceShow ("[]",l,a,r) $ -} if l=='[' && r==']' then a+1 else -999999
-  , nilnil = \ _ -> 0
-  , h = SM.foldl' max (-999999)
-  }
-{-# Inline score #-}
-
-
-
--- |
---
--- TODO pretty shows in @ovrlap@ that we might want to introduce a second
--- @h@ together with @Stream m y -> m s@?
-
-pretty :: Monad m => Signature m [String] [[String]] Char
-pretty = Signature
-  { ovrlap = \ () [a,a'] -> [a ++ a']
-  , brckts = \ (Z:.l:.()) [a,a'] (Z:.():.r) -> ["a"++a , a'++"A"]
-  , nilnil = \ _ -> ["",""]
-  , h = SM.toList
-  }
-{-# Inline pretty #-}
-
-
-
-overlappingPalindromes :: String -> (Int,[[String]])
-overlappingPalindromes inp = (d,bs) where
-  i  = VU.fromList inp
-  n  = VU.length i
-  d  = unId $ axiom x
-  bs = unId $ axiom x'
-  x :: X
-  a :: T
-  (Z:.x:.a) = opForward i
-  (Z:.x':.a') = grammar (score <|| pretty)
-                  (toBacktrack x (undefined :: Id a -> Id a))
-                  (toBacktrack a (undefined :: Id a -> Id a))
-                  i
-{-# NoInline overlappingPalindromes #-}
-
-opForward :: VU.Vector Char -> Z:.X:.T
-opForward i =
-  let n = VU.length i
-  in  mutateTablesDefault $
-        grammar score
-        (ITbl 1 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) []))
-        (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 n:.subword 0 n) (-999999) []))
-        i
-{-# NoInline opForward #-}
-
-type X = ITbl Id Unboxed Subword Int
-type T = ITbl Id Unboxed (Z:.Subword:.Subword) Int
-
-
-main :: IO ()
-main = do
-  xs <- fmap lines $ getContents
-  forM_ xs $ \x -> do
-    let (d,bs) = overlappingPalindromes x
-    putStrLn x
-    print d
---    putStrLn $ head $ head bs
-
diff --git a/tests/QuickCheck/Common.hs b/tests/QuickCheck/Common.hs
new file mode 100644
--- /dev/null
+++ b/tests/QuickCheck/Common.hs
@@ -0,0 +1,10 @@
+
+{-# Options_GHC -O0 #-}
+
+module QuickCheck.Common where
+
+import Debug.Trace
+
+
+
+tr zs ls b = traceShow (zs," ",ls,length zs,length ls) b
diff --git a/tests/QuickCheck/Point.hs b/tests/QuickCheck/Point.hs
new file mode 100644
--- /dev/null
+++ b/tests/QuickCheck/Point.hs
@@ -0,0 +1,328 @@
+
+{-# Options_GHC -O0 #-}
+
+module QuickCheck.Point where
+
+import           Control.Applicative
+import           Control.Monad
+import           Data.Strict.Tuple
+import           Data.Vector.Fusion.Util
+import           Debug.Trace
+--import           GHC.TypeNats
+import qualified Data.Vector.Fusion.Stream.Monadic as SM
+import qualified Data.Vector.Unboxed as VU
+import           System.IO.Unsafe
+import           Test.QuickCheck
+import           Test.QuickCheck.All
+import           Test.QuickCheck.Monadic
+-- #ifdef ADPFUSION_TEST_SUITE_PROPERTIES
+import           Test.Tasty.TH
+import           Test.Tasty.QuickCheck
+-- #endif
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.PointL
+
+
+
+-- * Epsilon cases
+
+prop_I_Epsilon ix@(PointL j) = zs == ls where
+  zs = (id <<< Epsilon @Global ... stoList) maxPLi ix
+  ls = [ () | j == 0 ]
+
+prop_O_Epsilon ix@(PointL j) = zs == ls where
+  zs = (id <<< Epsilon @Global ... stoList) maxPLo ix
+  ls = [ () | j == maxI ]
+
+prop_I_ZEpsilon ix@(Z:.PointL j) = zs == ls where
+  zs = (id <<< (M:|Epsilon @Global) ... stoList) (ZZ:..maxPLi) ix
+  ls = [ Z:.() | j == 0 ]
+
+prop_O_ZEpsilon ix@(Z:.PointL j) = zs == ls where
+  zs = (id <<< (M:|Epsilon @Global) ... stoList) (ZZ:..maxPLo) ix
+  ls = [ Z:.() | j == maxI ]
+
+prop_O_ZEpsilonEpsilon ix@(Z:.PointL j:.PointL l) = zs == ls where
+  zs = (id <<< (M:|Epsilon @Global:|Epsilon @Global) ... stoList) (ZZ:..maxPLo:..maxPLo) ix
+  ls = [ Z:.():.() | j == maxI, l == maxI ]
+
+
+
+-- * Deletion cases
+
+prop_I_ItNC ix@(PointL j) = zs == ls where
+  zs = ((,,) <<< tSI % Deletion % chr xs ... stoList) maxPLi ix
+  ls = [ ( unsafeIndex xsP (PointL $ j-1)
+         , ()
+         , xs VU.! (j-1)
+         ) | j >= 1, j <= (maxI) ]
+
+prop_O_ItNC ix@(PointL j) = zs == ls where
+  zs = ((,,) <<< tSO % Deletion % chr xs ... stoList) maxPLo ix
+  ls = [ ( unsafeIndex xsPo (PointL $ j+1)
+         , ()
+         , xs VU.! (j+0)
+         ) | j >= 0, j <= (maxI-1) ]
+{-# Noinline prop_O_ItNC #-}
+
+prop_O_ZItNC ix@(Z:.PointL j) = zs == ls where
+  zs = ((,,) <<< tZ1O % (M:|Deletion) % (M:|chr xs) ... stoList) (ZZ:..maxPLo) ix
+  ls = [ ( unsafeIndex xsZPo (Z:.PointL (j+1))
+         , Z:.()
+         , Z:.xs VU.! (j+0)
+         ) | j >= 0, j <= (maxI-1) ]
+
+prop_O_2dimIt_NC_CN ix@(Z:.PointL j:.PointL l) = zs == ls where
+  zs = ((,,) <<< tZ2O % (M:|Deletion:|chr xs) % (M:|chr xs:|Deletion) ... stoList) (ZZ:..maxPLo:..maxPLo) ix
+  ls = [ ( unsafeIndex xsPPo (Z:.PointL (j+1):.PointL (l+1))
+         , Z:.()           :.xs VU.! (l+0)
+         , Z:.xs VU.! (j+0):.()
+         ) | j>=0, l>=0, j<=(maxI-1), l<=(maxI-1) ]
+
+prop_I_2dimIt_NC_CN ix@(Z:.PointL j:.PointL l) = zs == ls where
+  zs = ((,,) <<< tZ2I % (M:|Deletion:|chr xs) % (M:|chr xs:|Deletion) ... stoList) (ZZ:..maxPLi:..maxPLi) ix
+  ls = [ ( unsafeIndex xsPP (Z:.PointL (j-1):.PointL (l-1))
+         , Z:.()           :.xs VU.! (l-1)
+         , Z:.xs VU.! (j-1):.()
+         ) | j>=1, l>=1, j<=maxI, l<=maxI ]
+
+
+
+-- * terminal cases
+
+-- | A single character terminal
+--
+-- X_j -> c_j || j==1
+
+prop_I_Tt ix@(Z:.PointL j) = zs == ls where
+  zs = (id <<< (M:|chr xs) ... stoList) (ZZ:..maxPLi) ix
+  ls = [ (Z:.xs VU.! (j-1)) | 1==j ]
+
+-- |
+--
+-- X_j     -> ε_{j-1} c_j   ||| j==1
+-- E_{j-1} -> X_{j}   c_j
+-- E_j     -> X_{j+1} c_{j+1}    ||| j-1==max ?!
+
+prop_O_Tt ix@(Z:.(PointL j))
+  | zs == ls  = True
+  | otherwise = traceShow (j,zs,ls) False
+  where
+    zs = (id <<< (M:|chr xs) ... stoList) (ZZ:..maxPLo) ix
+    ls = [ (Z:.xs VU.! j) | j==maxI-1 ]
+
+-- | Two single-character terminals
+
+prop_I_CC ix@(Z:.PointL i) = zs == ls where
+  zs = ((,) <<< (M:|chr xs) % (M:|chr xs) ... stoList) (ZZ:..maxPLi) ix
+  ls = [ (Z:.xs VU.! (i-2), Z:.xs VU.! (i-1)) | 2==i ]
+
+-- | Just a table
+
+prop_I_It ix@(PointL j) = zs == ls where
+  zs = (id <<< tSI ... stoList) maxPLi ix
+  ls = [ unsafeIndex xsP ix | j>=0, j<=maxI ]
+
+prop_O_It ix@(PointL j) = zs == ls where
+  zs = (id <<< tSO ... stoList) maxPLo ix
+  ls = [ unsafeIndex xsPo ix | j>=0, j<=maxI ]
+
+prop_I_ZIt ix@(Z:.PointL j) = zs == ls where
+  zs = (id <<< tZ1I ... stoList) (ZZ:..maxPLi) ix
+  ls = [ unsafeIndex xsZP ix | j>=0, j<=maxI ]
+
+prop_I_2dimIt ix@(Z:.PointL i:.PointL j) = zs == ls where
+  zs = (id <<< tZ2I ... stoList) (ZZ:..maxPLi:..maxPLi) ix
+  ls = [ unsafeIndex xsPP ix | j>=0, j<=maxI ]
+
+prop_O_ZIt ix@(Z:.PointL j) = zs == ls where
+  zs = (id <<< tZ1O ... stoList) (ZZ:..maxPLo) ix
+  ls = [ unsafeIndex xsZPo ix | j>=0, j<=maxI ]
+
+-- | Table, then single terminal
+
+prop_I_ItC ix@(PointL j) = zs == ls where
+  zs = ((,) <<< tSI % chr xs ... stoList) maxPLi ix
+  ls = [ ( unsafeIndex xsP (PointL $ j-1)
+         , xs VU.! (j-1)
+         ) | j>=1, j<=maxI ]
+
+-- | @A^*_j -> A^*_{j+1} c_{j+1)@ !
+
+prop_O_ItC ix@(PointL j)
+  | zs == ls  = True
+  | otherwise = traceShow (j,zs,ls) False
+  where
+    zs = ((,) <<< tSO % chr xs ... stoList) maxPLo ix
+    ls = [ ( unsafeIndex xsPo (PointL $ j+1)
+           , xs VU.! (j+0)  -- j-1 in inside, here moved one right!
+           ) | j >= 0, j <= (maxI-1) ]
+
+prop_O_ItCC ix@(PointL j) = zs == ls where
+  zs = ((,,) <<< tSO % chr xs % chr xs ... stoList) maxPLo ix
+  ls = [ ( unsafeIndex xsPo (PointL $ j+2)
+         , xs VU.! (j+0)
+         , xs VU.! (j+1)
+         ) | j >= 0, j <= (maxI-2) ]
+
+prop_O_ItCCC ix@(PointL j) = zs == ls where
+  zs = ((,,,) <<< tSO % chr xs % chr xs % chr xs ... stoList) maxPLo ix
+  ls = [ ( unsafeIndex xsPo (PointL $ j+3)
+         , xs VU.! (j+0)
+         , xs VU.! (j+1)
+         , xs VU.! (j+2)
+         ) | j >= 0, j <= (maxI-3) ]
+
+prop_O_ZItCC ix@(Z:.PointL j) = zs == ls where
+  zs = ((,,) <<< tZ1O % (M:|chr xs) % (M:|chr xs) ... stoList) (ZZ:..maxPLo) ix
+  ls = [ ( unsafeIndex xsZPo (Z:.PointL (j+2))
+         , Z:.xs VU.! (j+0)
+         , Z:.xs VU.! (j+1)
+         ) | j >= 0, j <= (maxI-2) ]
+
+-- | synvar followed by a 2-tape character terminal
+
+prop_I_2dimItCC ix@(Z:.PointL j:.PointL l) = zs == ls where
+  zs = ((,,) <<< tZ2I % (M:|chr xs:|chr xs) % (M:|chr xs:|chr xs) ... stoList) (ZZ:..maxPLi:..maxPLi) ix
+  ls = [ ( unsafeIndex xsPP (Z:.PointL (j-2):.PointL (l-2))
+         , Z:.xs VU.! (j-2):.xs VU.! (l-2)
+         , Z:.xs VU.! (j-1):.xs VU.! (l-1)
+         ) | j>=2, l>=2, j<=maxI, l<=maxI ]
+
+prop_O_2dimItCC ix@(Z:.PointL j:.PointL l) = zs == ls where
+  zs = ((,,) <<< tZ2O % (M:|chr xs:|chr xs) % (M:|chr xs:|chr xs) ... stoList) (ZZ:..maxPLo:..maxPLo) ix
+  ls = [ ( unsafeIndex xsPPo (Z:.PointL (j+2):.PointL (l+2))
+         , Z:.xs VU.! (j+0):.xs VU.! (l+0)
+         , Z:.xs VU.! (j+1):.xs VU.! (l+1)
+         ) | j>=0, l>=0, j<=(maxI-2), l<=(maxI-2) ]
+
+-- * 'Strng' tests
+
+-- ** Just the 'Strng' terminal
+
+prop_I_ManyV ix@(PointL j) = zs == ls where
+  zs = (id <<< manyV xs ... stoList) maxPLi ix
+  ls = [ (VU.slice 0 j xs) ]
+
+prop_I_SomeV ix@(PointL j)
+  | zs == ls  = True
+  | otherwise = traceShow (ix,zs,ls) False
+  where
+  zs = (id <<< someV xs ... stoList) maxPLi ix
+  ls = [ (VU.slice 0 j xs) | j>0 ]
+
+prop_2dim_ManyV_ManyV ix@(Z:.PointL i:.PointL j) = zs == ls where
+  zs = (id <<< (M:|manyV xs:|manyV xs) ... stoList) (ZZ:..maxPLi:..maxPLi) ix
+  ls = [ (Z:.VU.slice 0 i xs:.VU.slice 0 j xs) ]
+
+prop_2dim_SomeV_SomeV ix@(Z:.PointL i:.PointL j) = zs == ls where
+  zs = (id <<< (M:|someV xs:|someV xs) ... stoList) (ZZ:..maxPLi:..maxPLi) ix
+  ls = [ (Z:.VU.slice 0 i xs:.VU.slice 0 j xs) | i > 0 && j > 0 ]
+
+-- ** Together with a syntactic variable.
+
+prop_I_Itbl_ManyV ix@(PointL i) = zs == ls where
+  zs = ((,) <<< tSI % manyV xs ... stoList) maxPLi ix
+  ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i] ]
+
+prop_I_Itbl_SomeV ix@(PointL i) = zs == ls where
+  zs = ((,) <<< tSI % someV xs ... stoList) maxPLi ix
+  ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i-1] ]
+
+-- | NOTE Be aware of the needed match between the type-level and value-level
+-- @13@s.
+
+prop_I_Itbl_Str ix@(PointL i) = zs == ls where
+  zs = ((,) <<< tSI % Str @_ @_ @Nothing @13 @Nothing xs ... stoList) maxPLi ix
+  ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i-13] ]
+
+-- | And now for some funny type-level shenanigans.
+
+prop_I_Itbl_StrTyLvl (Positive bound', ix@(PointL i)) = let bound = bound' `mod` 23 in
+  case (someNatVal bound) of
+    Nothing → error "zzz"
+    Just (SomeNat (Proxy ∷ Proxy b)) →
+      let zs = ((,) <<< tSI % Str @_ @_ @Nothing @b @Nothing xs ... stoList) maxPLi ix
+          ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i-bv] ]
+          bv = fromIntegral $ natVal (Proxy ∷ Proxy b)
+      in  zs == ls
+
+prop_I_1dim_Itbl_ManyV ix@(Z:.PointL i) = zs == ls where
+  zs = ((,) <<< tZ1I % (M:|manyV xs) ... stoList) (ZZ:..maxPLi) ix
+  ls = [ (unsafeIndex xsZP (Z:.PointL k), Z:. VU.slice k (i-k) xs) | k <- [0..i] ]
+
+prop_I_1dim_Itbl_SomeV ix@(Z:.PointL i) = zs == ls where
+  zs = ((,) <<< tZ1I % (M:|someV xs) ... stoList) (ZZ:..maxPLi) ix
+  ls = [ (unsafeIndex xsZP (Z:.PointL k), Z:. VU.slice k (i-k) xs) | k <- [0..i-1] ]
+
+prop_I_2dim_Itbl_ManyV_ManyV ix@(Z:.PointL i:.PointL j) = zs == ls where
+  zs = ((,) <<< tZ2I % (M:|manyV xs:|manyV xs) ... stoList) (ZZ:..maxPLi:..maxPLi) ix
+  ls = [ (unsafeIndex xsPP (Z:.PointL k:.PointL l), Z:. VU.slice k (i-k) xs :. VU.slice l (j-l) xs) | k <- [0..i], l <- [0..j] ]
+
+prop_I_2dim_Itbl_SomeV_SomeV ix@(Z:.PointL i:.PointL j) = zs == ls where
+  zs = ((,) <<< tZ2I % (M:|someV xs:|someV xs) ... stoList) (ZZ:..maxPLi:..maxPLi) ix
+  ls = [ (unsafeIndex xsPP (Z:.PointL k:.PointL l), Z:. VU.slice k (i-k) xs :. VU.slice l (j-l) xs) | k <- [0..i-1], l <- [0..j-1] ]
+
+
+
+stoList = unId . SM.toList
+
+--infixl 8 >>>
+--(>>>) f xs = \lu ij -> SM.map f . mkStream (build xs) (initialContext ij) lu $ ij
+
+tSI  = TW (ITbl @_ @_ @_ @_ @0 @0 EmptyOk xsP)  (\ (_ :: LimitType (PointL I)) (_ :: PointL I) -> Id (1::Int))
+tSO  = TW (ITbl @_ @_ @_ @_ @0 @0 EmptyOk xsPo) (\ (_ :: LimitType (PointL O)) (_ :: PointL O) -> Id (1::Int))
+tZ1I = TW (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk) xsZP) (\ (_::LimitType (Z:.PointL I)) (_::Z:.PointL I) -> Id (1::Int))
+tZ1O = TW (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk) xsZPo) (\ (_::LimitType (Z:.PointL O)) (_::Z:.PointL O) -> Id (1::Int))
+tZ2I = TW (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk:.EmptyOk) xsPP) (\ (_::LimitType (Z:.PointL I:.PointL I)) (_::Z:.PointL I:.PointL I) -> Id (1::Int))
+tZ2O = TW (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk:.EmptyOk) xsPPo) (\ (_::LimitType (Z:.PointL O:.PointL O)) (_::Z:.PointL O:.PointL O) -> Id (1::Int))
+
+xsP :: Unboxed (PointL I) Int
+xsP = fromList maxPLi [0 ..]
+
+xsZP :: Unboxed (Z:.PointL I) Int
+xsZP = fromList (ZZ:..maxPLi) [0 ..]
+
+xsPo :: Unboxed (PointL O) Int
+xsPo = fromList maxPLo [0 ..]
+
+xsZPo :: Unboxed (Z:.PointL O) Int
+xsZPo = fromList (ZZ:..maxPLo) [0 ..]
+
+xsPP :: Unboxed (Z:.PointL I:.PointL I) Int
+xsPP = fromList (ZZ:..maxPLi:..maxPLi) [0 ..]
+
+xsPPo :: Unboxed (Z:.PointL O:.PointL O) Int
+xsPPo = fromList (ZZ:..maxPLo:..maxPLo) [0 ..]
+
+mxsPP = unsafePerformIO $ zzz where
+  zzz :: IO (MutArr IO (Unboxed (Z:.PointL I:.PointL I) Int))
+  zzz = fromListM (ZZ:..maxPLi:..maxPLi) [0 ..]
+
+maxI =100
+
+maxPLi :: LimitType (PointL I)
+maxPLi = LtPointL maxI
+
+maxPLo :: LimitType (PointL O)
+maxPLo = LtPointL maxI
+
+xs = VU.fromList [0 .. maxI - 1 :: Int]
+
+-- * general quickcheck stuff
+
+options = stdArgs {maxSuccess = 1000 } -- 0}
+
+customCheck = quickCheckWithResult options
+
+return []
+allProps = $forAllProperties customCheck
+
+
+
+-- #ifdef ADPFUSION_TEST_SUITE_PROPERTIES
+testgroup_point = $(testGroupGenerator)
+-- #endif
+
diff --git a/tests/performance.hs b/tests/performance.hs
deleted file mode 100644
--- a/tests/performance.hs
+++ /dev/null
@@ -1,89 +0,0 @@
-
-module Main where
-
-import           Data.Vector.Fusion.Util
-import           GHC.Stats
-import qualified Data.Vector.Fusion.Stream.Monadic as SM
-import qualified Data.Vector.Unboxed as VU
-import           System.Mem
-import           System.Environment
-import           GHC.Conc (pseq)
-import           GHC.Generics
-import qualified Data.Vector as V
-import           Control.Arrow (second)
-import           Data.Int(Int64)
-import           System.Exit
-
-import           ADP.Fusion hiding (Split)
-import           Data.PrimitiveArray hiding (map)
-import           BenchmarkHistory
-
-
-
--- | All grammars require a signature.
-
-data Split m x r = Split
-  { nil :: ()  -> x
-  , lef :: Int -> x -> x
-  , spl :: x   -> x -> x
-  , h   :: SM.Stream m x -> m r
-  }
-
--- makeAlgebraProduct ''Split
-
-algMax :: Monad m => Split m Int Int
-algMax = Split
-  { nil = \ () -> 0
-  , lef = \k x -> k+x
-  , spl = \ x y   -> x+y
-  , h   = SM.foldl' max 0
-  }
-{-# Inline algMax #-}
-
-gLeft Split{..} c t' =
-  let t = t'  ( lef <<< chr c % t   |||
-                spl <<< t % t       |||
-                nil <<< Epsilon     ... h
-              )
-  in Z:.t
-{-# Inline gLeft #-}
-
-mkArrs :: Int -> (VU.Vector Int, Unboxed Subword Int)
-mkArrs n = ( VU.enumFromTo 1 n
-           , fromAssocs (subword 0 0) (subword 0 n) (-999999) []
-           )
-{-# NoInline mkArrs #-}
-
--- | WARNING: Multiple runs of @runLeft@ make use of the same @arr@. This
--- is, of course, dangerous. Unless you know what you are doing.
-
-runLeft :: (VU.Vector Int, Unboxed Subword Int) -> Int -> Int
-runLeft (!i, !arr) k = seq k d where
---  i   = VU.enumFromTo 1 k
-  n   = VU.length i
---  arr = fromAssocs (subword 0 0) (subword 0 n) (-999999) []
-  (Z:.t) = runLeftForward i arr
-  d = unId $ axiom t
-{-# NoInline runLeft #-}
-
-runLeftForward :: VU.Vector Int -> Unboxed Subword Int -> Z:.ITbl Id Unboxed Subword Int
-runLeftForward !i !arr = mutateTablesDefault
-               $ gLeft algMax
-                   i
-                   (ITbl 0 0 EmptyOk arr)
-{-# NoInline runLeftForward #-}
-
-
-
-main :: IO ()
-main = do
-  es <- sequence
-    [ benchmark 10000 ("bench-0100.csv") mkArrs runLeft  100
-    , benchmark    10 ("bench-1000.csv") mkArrs runLeft 1000
-    , benchmark     1 ("bench-2000.csv") mkArrs runLeft 2000
-    ]
-  let ok = all (== ExitSuccess) es
-  if ok
-    then exitSuccess
-    else exitFailure
-
diff --git a/tests/properties.hs b/tests/properties.hs
--- a/tests/properties.hs
+++ b/tests/properties.hs
@@ -1,90 +1,14 @@
 
--- | Test all properties automatically. We keep the QC2 modules in the main
--- library for now, as this allows for more efficient repl tests.
+-- | Test all properties automatically.
 
 module Main where
 
-import Test.Framework.Providers.QuickCheck2
-import Test.Framework.TH
-
-import qualified ADP.Fusion.QuickCheck.Subword  as QSW
-import qualified ADP.Fusion.QuickCheck.Set      as QS
-import qualified ADP.Fusion.QuickCheck.Point    as QP
-import ADP.Fusion.QuickCheck.Point
-
-
-{-
-grep -o -e "^prop_[[:alnum:]_]*" ADP/Fusion/QuickCheck/Subword.hs | awk '{print $1"QSW", "=", "QSW."$1 }' | uniq
-grep -o -e "^prop_[[:alnum:]_]*" ADP/Fusion/QuickCheck/Set.hs | awk '{print $1"QS", "=", "QS."$1 }' | uniq
-grep -o -e "^prop_[[:alnum:]_]*" ADP/Fusion/QuickCheck/Point.hs | awk '{print $1"QP", "=", "QP."$1 }' | uniq
--}
-
--- subwords
-
-prop_sv_OIQSW = QSW.prop_sv_OI
-prop_sv_IOQSW = QSW.prop_sv_IO
-prop_sv_OIIQSW = QSW.prop_sv_OII
-prop_sv_IOIQSW = QSW.prop_sv_IOI
-prop_sv_IIOQSW = QSW.prop_sv_IIO
-prop_cOcQSW = QSW.prop_cOc
-prop_ccOccQSW = QSW.prop_ccOcc
-prop_cOcccQSW = QSW.prop_cOccc
-prop_cOcIcQSW = QSW.prop_cOcIc
-prop_cIcOcQSW = QSW.prop_cIcOc
-prop_EpsilonQSW = QSW.prop_Epsilon
-
--- sets
-
-prop_b_iiQS = QS.prop_b_ii
-prop_b_ii_nnQS = QS.prop_b_ii_nn
-prop_b_iiiQS = QS.prop_b_iii
-prop_b_iii_nnnQS = QS.prop_b_iii_nnn
-prop_bii_iQS = QS.prop_bii_i
-prop_bii_i_nQS = QS.prop_bii_i_n
-prop_bii_eQS = QS.prop_bii_e
-prop_bii_ieQS = QS.prop_bii_ie
-prop_bii_ie_nQS = QS.prop_bii_ie_n
-prop_bii_ieeQS = QS.prop_bii_iee
-prop_bii_ieeeQS = QS.prop_bii_ieee
-prop_bii_iee_nQS = QS.prop_bii_iee_n
-prop_bii_ieee_nQS = QS.prop_bii_ieee_n
-
--- points
+import Test.Tasty
 
-prop_EpsilonQP = QP.prop_Epsilon
-prop_O_EpsilonQP = QP.prop_O_Epsilon
-prop_ZEpsilonQP = QP.prop_ZEpsilon
-prop_O_ZEpsilonQP = QP.prop_O_ZEpsilon
-prop_O_ZEpsilonEpsilonQP = QP.prop_O_ZEpsilonEpsilon
-prop_O_ItNCQP = QP.prop_O_ItNC
-prop_O_ZItNCQP = QP.prop_O_ZItNC
-prop_O_2dimIt_NC_CNQP = QP.prop_O_2dimIt_NC_CN
-prop_2dimIt_NC_CNQP = QP.prop_2dimIt_NC_CN
-prop_TtQP = QP.prop_Tt
-prop_CCQP = QP.prop_CC
-prop_ItQP = QP.prop_It
-prop_O_ItQP = QP.prop_O_It
-prop_ZItQP = QP.prop_ZIt
-prop_O_ZItQP = QP.prop_O_ZIt
-prop_ItCQP = QP.prop_ItC
-prop_O_ItCQP = QP.prop_O_ItC
-prop_O_ItCCQP = QP.prop_O_ItCC
-prop_O_ZItCCQP = QP.prop_O_ZItCC
-prop_2dimItCCQP = QP.prop_2dimItCC
-prop_O_2dimItCCQP = QP.prop_O_2dimItCC
-prop_ManySQP = QP.prop_ManyS
-prop_SomeSQP = QP.prop_SomeS
-prop_2dim_ManyS_ManySQP = QP.prop_2dim_ManyS_ManyS
-prop_2dim_SomeS_SomeSQP = QP.prop_2dim_SomeS_SomeS
-prop_Itbl_ManySQP = QP.prop_Itbl_ManyS
-prop_Itbl_SomeSQP = QP.prop_Itbl_SomeS
-prop_1dim_Itbl_ManySQP = QP.prop_1dim_Itbl_ManyS
-prop_1dim_Itbl_SomeSQP = QP.prop_1dim_Itbl_SomeS
-prop_2dim_Itbl_ManyS_ManySQP = QP.prop_2dim_Itbl_ManyS_ManyS
-prop_2dim_Itbl_SomeS_SomeSQP = QP.prop_2dim_Itbl_SomeS_SomeS
+import QuickCheck.Point   (testgroup_point)
 
 
 
 main :: IO ()
-main = $(defaultMainGenerator)
+main = defaultMain testgroup_point