ADPfusion 0.5.1.0 → 0.5.2.0

raw patch · 89 files changed

+2619/−6214 lines, 89 filesdep +DPutilsdep +criteriondep +fmlistdep −BenchmarkHistorydep −log-domaindep ~OrderedBitsdep ~PrimitiveArraydep ~QuickCheckPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: DPutils, criterion, fmlist

Dependencies removed: BenchmarkHistory, log-domain

Dependency ranges changed: OrderedBits, PrimitiveArray, QuickCheck, base, bits, mmorph, mtl, primitive, strict, template-haskell, th-orphans, transformers, tuple, vector

API changes (from Hackage documentation)

Files

• ADP/Fusion.hs +0/−80
• ADP/Fusion/Apply.hs +0/−89
• ADP/Fusion/Base.hs +0/−19
• ADP/Fusion/Base/Classes.hs +0/−198
• ADP/Fusion/Base/Multi.hs +0/−226
• ADP/Fusion/Base/Point.hs +0/−114
• ADP/Fusion/Base/Set.hs +0/−178
• ADP/Fusion/Base/Subword.hs +0/−162
• ADP/Fusion/Base/Term.hs +0/−55
• ADP/Fusion/Base/TyLvlIx.hs +0/−109
• ADP/Fusion/Base/Unit.hs +0/−98
• ADP/Fusion/Core.hs +112/−0
• ADP/Fusion/Core/Apply.hs +89/−0
• ADP/Fusion/Core/Classes.hs +216/−0
• ADP/Fusion/Core/Multi.hs +226/−0
• ADP/Fusion/Core/Point.hs +121/−0
• ADP/Fusion/Core/TH.hs +77/−0
• ADP/Fusion/Core/TH/Backtrack.hs +498/−0
• ADP/Fusion/Core/TH/Common.hs +19/−0
• ADP/Fusion/Core/TyLvlIx.hs +109/−0
• ADP/Fusion/Core/Unit.hs +98/−0
• ADP/Fusion/Point.hs +25/−0
• ADP/Fusion/SynVar.hs +0/−19
• ADP/Fusion/SynVar/Array.hs +25/−25
• ADP/Fusion/SynVar/Array/TermSymbol.hs +0/−172
• ADP/Fusion/SynVar/Array/Type.hs +46/−34
• ADP/Fusion/SynVar/Backtrack.hs +5/−5
• ADP/Fusion/SynVar/Fill.hs +17/−16
• ADP/Fusion/SynVar/Indices.hs +0/−164
• ADP/Fusion/SynVar/Indices/Classes.hs +3/−1
• ADP/Fusion/SynVar/Indices/Point.hs +2/−1
• ADP/Fusion/SynVar/Indices/Set0.hs +0/−157
• ADP/Fusion/SynVar/Indices/Subword.hs +0/−191
• ADP/Fusion/SynVar/Indices/Unit.hs +2/−2
• ADP/Fusion/SynVar/Recursive.hs +0/−74
• ADP/Fusion/SynVar/Recursive/Subword.hs +0/−12
• ADP/Fusion/SynVar/Recursive/Type.hs +41/−29
• ADP/Fusion/SynVar/Split.hs +0/−11
• ADP/Fusion/SynVar/Split/Subword.hs +0/−133
• ADP/Fusion/SynVar/Split/Type.hs +26/−22
• ADP/Fusion/SynVar/TableWrap.hs +11/−0
• ADP/Fusion/TH.hs +0/−77
• ADP/Fusion/TH/Backtrack.hs +0/−524
• ADP/Fusion/TH/Common.hs +0/−19
• ADP/Fusion/Term.hs +0/−17
• ADP/Fusion/Term/Chr.hs +0/−199
• ADP/Fusion/Term/Chr/Point.hs +2/−3
• ADP/Fusion/Term/Chr/Set0.hs +0/−65
• ADP/Fusion/Term/Chr/Subword.hs +0/−98
• ADP/Fusion/Term/Chr/Type.hs +3/−1
• ADP/Fusion/Term/Deletion.hs +0/−80
• ADP/Fusion/Term/Deletion/Point.hs +2/−1
• ADP/Fusion/Term/Deletion/Subword.hs +0/−91
• ADP/Fusion/Term/Deletion/Type.hs +2/−1
• ADP/Fusion/Term/Deletion/Unit.hs +2/−2
• ADP/Fusion/Term/Edge.hs +0/−64
• ADP/Fusion/Term/Edge/Set.hs +0/−72
• ADP/Fusion/Term/Edge/Type.hs +2/−1
• ADP/Fusion/Term/Epsilon.hs +0/−120
• ADP/Fusion/Term/Epsilon/Point.hs +2/−1
• ADP/Fusion/Term/Epsilon/Set.hs +0/−97
• ADP/Fusion/Term/Epsilon/Subword.hs +0/−61
• ADP/Fusion/Term/Epsilon/Type.hs +2/−1
• ADP/Fusion/Term/Epsilon/Unit.hs +2/−2
• ADP/Fusion/Term/PeekIndex.hs +0/−8
• ADP/Fusion/Term/PeekIndex/Subword.hs +0/−24
• ADP/Fusion/Term/PeekIndex/Type.hs +2/−1
• ADP/Fusion/Term/Strng.hs +0/−13
• ADP/Fusion/Term/Strng/Point.hs +2/−1
• ADP/Fusion/Term/Strng/Subword.hs +0/−84
• ADP/Fusion/Term/Strng/Type.hs +2/−1
• ADP/Fusion/Tutorial/NeedlemanWunsch.hs +495/−0
• ADP/Fusion/Unit.hs +18/−0
• ADPfusion.cabal +97/−349
• changelog.md +11/−0
• src/Durbin.hs +0/−136
• src/NeedlemanWunsch.hs +89/−57
• src/Nussinov.hs +0/−132
• src/OverlappingPalindromes.hs +0/−155
• src/PartNussinov.hs +0/−274
• src/Pseudoknot.hs +0/−149
• src/SpecTest.hs +1/−1
• src/SplitTests.hs +0/−135
• tests/BacktrackingStructures.hs +76/−0
• tests/QuickCheck/Point.hs +37/−61
• tests/QuickCheck/Set.hs +0/−314
• tests/QuickCheck/Subword.hs +0/−230
• tests/performance.hs +0/−89
• tests/properties.hs +2/−7

@@ -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 (%) #-}-

@@ -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 #-}-

@@ -1,19 +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-  , module ADP.Fusion.Base.TyLvlIx-  , module ADP.Fusion.Base.Unit-  ) 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-import ADP.Fusion.Base.TyLvlIx-import ADP.Fusion.Base.Unit-

@@ -1,198 +0,0 @@--module ADP.Fusion.Base.Classes where--import           Data.Proxy-import           Data.Strict.Tuple-import qualified Data.Vector.Fusion.Stream.Monadic as S--import           Data.PrimitiveArray----data OutsideContext s-  = OStatic     s-  | ORightOf    s-  | OFirstLeft  s-  | OLeftOf     s-  deriving (Show)--data InsideContext s-  = IStatic   s-  | IVariable s-  deriving (Show)--data ComplementContext-  = Complemented-  deriving (Show)--class RuleContext i where-  type Context i :: *-  initialContext :: i -> Context i---- | 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.------ TODO Sometimes, the actual RunningIndex ctors are not erased. This could--- be due to <https://ghc.haskell.org/trac/ghc/ticket/2289>. To test, we--- should transform RunningIndex into a type class to give us access to the--- left and right member, also we should create instances a la--- @RunningIndex (is :. Subword I) = RiSwI !(RunningIndex is) !Int@.--- Hopefully, these are completely erased.--{--class RunningIndexCl i where-  type RecursiveRl i :: *-  type ThisRI i :: *--}--data family RunningIndex i :: *--data instance RunningIndex (is:.i) = !(RunningIndex is) :.: !(RunningIndex i)--data instance RunningIndex Z = RiZ--deriving instance Show (RunningIndex Z)----- | 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 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 !(RunningIndex i)-  type Arg S   = Z-  getArg (ElmS _) = Z-  getIdx (ElmS i) = i-  {-# Inline getArg #-}-  {-# Inline 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) = b `seq` 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----- | 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)--data EmptyOk = EmptyOk--data NonEmpty = NonEmpty--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 #-}--{--minSize :: TableConstraint -> Int-minSize NonEmpty = 1-minSize _        = 0-{-# Inline [0] 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-------instance ModifyConstraint EmptyOk---  type TNE EmptyOk = NonEmpty---  type TE  EmptyOk = ---- |----type family   TblConstraint x       :: *------type instance TblConstraint (is:.i) =  TblConstraint is :. TblConstraint i---type instance TblConstraint Z       = Z-------- TODO move into the sub-modules------type instance TblConstraint (PointL  t) = TableConstraint---type instance TblConstraint (PointR  t) = TableConstraint---type instance TblConstraint (Subword t) = TableConstraint-

@@ -1,226 +0,0 @@--module ADP.Fusion.Base.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           Data.PrimitiveArray hiding (map)--import           ADP.Fusion.Base.Classes-import           ADP.Fusion.Base.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)--instance-  ( Monad m-  , MkStream m ls i-  , Element ls i-  , TermStaticVar (TermSymbol a b) i-  , TermStream m (TermSymbol a b) (Elm ls i) i-  ) => MkStream m (ls :!: TermSymbol a b) i where-  mkStream (ls :!: ts) sv lu i-    = map (\(TState sS ii ee) -> ElmTS ee ii sS)-    . termStream ts sv lu i-    . map (\s -> TState s RiZ Z)-    $ 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 #-}------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 => MkStream m S Z where-  mkStream _ _ _ _ = 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 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 [0] termStaticVar #-}-  {-# INLINE [0] 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 [0] termStaticVar #-}-  {-# INLINE [0] termStreamIndex #-}----data S3 a b c           = S3 !a !b !c------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------data S7 a b c d e f g   = S7 !a !b !c !d !e !f !g------data S8 a b c d e f g h = S8 !a !b !c !d !e !f !g !h----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 is, RuleContext i) => RuleContext (is:.i) where-  type Context (is:.i) = Context is:.Context i-  initialContext (is:.i) = initialContext is:.initialContext i-  {-# INLINE initialContext #-}--class TableStaticVar u c i where-  tableStaticVar   :: Proxy u -> c -> Context i -> i -> Context i-  tableStreamIndex :: Proxy u -> c -> Context i -> i -> i--instance TableStaticVar c u Z where-  tableStaticVar   _ _ _ _ = Z-  tableStreamIndex _ _ _ _ = Z-  {-# INLINE [0] tableStaticVar   #-}-  {-# INLINE [0] tableStreamIndex #-}--instance (TableStaticVar us cs is, TableStaticVar u c i) => TableStaticVar (us:.u) (cs:.c) (is:.i) where-  tableStaticVar   _ (cs:.c) (vs:.v) (is:.i) = tableStaticVar   (Proxy :: Proxy us) cs vs is :. tableStaticVar   (Proxy :: Proxy u) c v i-  tableStreamIndex _ (cs:.c) (vs:.v) (is:.i) = tableStreamIndex (Proxy :: Proxy us) cs vs is :. tableStreamIndex (Proxy :: Proxy u) c v i-  {-# INLINE [0] tableStaticVar   #-}-  {-# INLINE [0] tableStreamIndex #-}----data TermState s i e = TState-  { tS  :: !s -- ^ state coming in from the left---  , tIx :: !(RunningIndex a) --  @I/C@ index from @sS@-  , iIx :: !(RunningIndex i) -- ^ @I/C@ building up state to hand over to next symbol-  , eTS :: !e -- ^ element data-  }----getTIX :: (Element x0 a, s ~ Elm x0 a) => TermState s a i e -> RunningIndex a---getTIX (TState s a i e) = getIdx s---{-# Inline getTIX #-}--class TermStream m t s i where-  termStream :: t -> Context i -> i -> i -> Stream m (TermState s Z Z) -> Stream m (TermState s i (TermArg t))--instance (Monad m) => TermStream m M s Z where-  termStream _ _ _ _ = id -- map (\(!s) -> s)-  {-# 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-  :: ( Monad m-     , TermStream m (TermSymbol M t) (Elm (Term1 s) (Z:.i)) (Z:.i)-     )-  => t -> Context i -> i -> i -> Stream m s -> Stream m (s,TermArg t,RunningIndex i)-addTermStream1 t c u i-  = map (\(TState (ElmTerm1 sS) (RiZ:.:ii) (Z:.ee)) -> (sS,ee,ii))-  . termStream (M:|t) (Z:.c) (Z:.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--type TmkCtx1 m ls t i-  = ( Monad m-    , MkStream m ls i-    , TermStream m (TermSymbol M t) (Elm (Term1 (Elm ls i)) (Z:.i)) (Z:.i)-    , Element ls i-    , TermStaticVar t i-    )---- | @Term TermStream@ context----type TstCtx1 m ts s sixty is i---  = ( Monad m---    , TermStream m ts s is---    , GetIndex (RunningIndex sixty) (RunningIndex (is:.i))---    , GetIx (RunningIndex sixty) (RunningIndex (is:.i)) ~ (RunningIndex i)---    )--type TstCtx m ts s x0 sixty is i-  = ( Monad m-    , TermStream m 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))-

@@ -1,114 +0,0 @@--module ADP.Fusion.Base.Point 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.Base.Classes-import ADP.Fusion.Base.Multi----instance RuleContext (PointL I) where-  type Context (PointL I) = InsideContext Int-  initialContext _ = IStatic 0-  {-# Inline initialContext #-}--instance RuleContext (PointL O) where-  type Context (PointL O) = OutsideContext Int-  initialContext _ = OStatic 0-  {-# Inline initialContext #-}--instance RuleContext (PointL C) where-  type Context (PointL C) = ComplementContext-  initialContext _ = Complemented-  {-# Inline initialContext #-}--newtype instance RunningIndex (PointL I) = RiPlI Int--data instance RunningIndex (PointL O) = RiPlO !Int !Int--data instance RunningIndex (PointL C) = RiPlC !Int----instance (Monad m) => MkStream m S (PointL I) where-  mkStream S (IStatic d) (PointL u) (PointL i)-    = staticCheck (i>=0 && i<=d && i<=u)-    . singleton . ElmS $ RiPlI 0-  mkStream S (IVariable _) (PointL u) (PointL i)-    = staticCheck (i>=0 && i<=u)-    . singleton . ElmS $ RiPlI 0-  {-# Inline mkStream #-}--instance-  ( Monad m-  , MkStream m S is-  ) => MkStream m S (is:.PointL I) where-  mkStream S (vs:.IStatic d) (lus:.PointL u) (is:.PointL i)-    = map (\(ElmS zi) -> ElmS $ zi :.: RiPlI 0)-    . staticCheck (i>=0 && i<=d && i<=u)-    $ mkStream S vs lus is-  mkStream S (vs:.IVariable d) (lus:.PointL u) (is:.PointL i)-    = map (\(ElmS zi) -> ElmS $ zi :.: RiPlI 0)-    . staticCheck (i>=0 && i<=u)-    $ mkStream S vs lus is-  {-# INLINE mkStream #-}----instance (Monad m) => MkStream m S (PointL O) where-  mkStream S (OStatic d) (PointL u) (PointL i)-    = staticCheck (i>=0 && i+d<=u && u == i) . singleton . ElmS $ RiPlO i (i+d)-  mkStream S (OFirstLeft d) (PointL u) (PointL i)-    = staticCheck (i>=0 && i+d<=u) . singleton . ElmS $ RiPlO i (i+d)-  {-# Inline mkStream #-}--instance-  ( Monad m-  , MkStream m S is-  ) => MkStream m S (is:.PointL O) where-  mkStream S (vs:.OStatic d) (lus:.PointL u) (is:.PointL i)-    = staticCheck (i>=0 && i+d == u)-    . map (\(ElmS zi) -> ElmS $ zi :.: RiPlO i (i+d))-    $ mkStream S vs lus is-  mkStream S (vs:.OFirstLeft d) (us:.PointL u) (is:.PointL i)-    = staticCheck (i>=0 && i+d<=u)-    . map (\(ElmS zi) -> ElmS $ zi :.: RiPlO i (i+d))-    $ mkStream S vs us is-  {-# Inline mkStream #-}----instance (Monad m) => MkStream m S (PointL C) where-  mkStream S Complemented (PointL u) (PointL i)-    = staticCheck (i>=0 && i<=u) . singleton . ElmS $ RiPlC i-  {-# Inline mkStream #-}----instance (MinSize c) => TableStaticVar u c (PointL I) 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) = PointL $ j - minSize c-  {-# INLINE [0] tableStaticVar   #-}-  {-# INLINE [0] tableStreamIndex #-}--instance (MinSize c) => TableStaticVar u c (PointL O) where-  tableStaticVar   _ _ (OStatic d) _          = OFirstLeft d-  tableStreamIndex _ c _           (PointL j) = PointL $ j - minSize c-  {-# INLINE [0] tableStaticVar   #-}-  {-# INLINE [0] tableStreamIndex #-}--instance (MinSize c) => TableStaticVar u c (PointL C) where-  tableStaticVar   _ _ Complemented _          = Complemented-  tableStreamIndex _ c _            (PointL k) = PointL $ k - minSize c-  {-# INLINE [0] tableStaticVar   #-}-  {-# INLINE [0] tableStreamIndex #-}-

@@ -1,178 +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.Proxy-import Data.Vector.Fusion.Stream.Monadic (singleton,filter,enumFromStepN,map,unfoldr)-import Debug.Trace-import Prelude hiding (map,filter)-import Data.Bits-import Data.Bits.Ordered--import Data.PrimitiveArray hiding (map)--import ADP.Fusion.Base.Classes-import ADP.Fusion.Base.Multi------type instance TblConstraint (BitSet t)  = TableConstraint---type instance TblConstraint (BS2 i j t) = TableConstraint----instance RuleContext (BitSet I) where-  type Context (BitSet I) = InsideContext Int-  initialContext _ = IStatic 0-  {-# Inline initialContext #-}---- | The @Int@ in an @OutsideContext@ counts how many bits need to be fixed--- statically. I.e. if the bits @{1,2}@ are set in @X -> Y t@, and @t@ has--- size @1@, then @Y@ will have @{1,2,3}@, @{1,2,4}@ and so on, with @t@--- having @3, 4, ...@ as values.--instance RuleContext (BitSet O) where-  type Context (BitSet O) = OutsideContext Int-  initialContext _ = OStatic 0-  {-# Inline initialContext #-}--instance RuleContext (BitSet C) where-  type Context (BitSet C) = ComplementContext-  initialContext _ = Complemented-  {-# Inline initialContext #-}--newtype instance RunningIndex (BitSet I) = RiBsI (BitSet I)--data instance RunningIndex (BitSet O) = RiBsO !(BitSet O) !(BitSet O)--data instance RunningIndex (BitSet C) = RiBsC !(BitSet C) !(BitSet C)---instance RuleContext (BS2 First Last I) where-  type Context (BS2 First Last I) = InsideContext Int-  initialContext _ = IStatic 0-  {-# Inline initialContext #-}--instance RuleContext (BS2 First Last O) where-  type Context (BS2 First Last O) = OutsideContext ()-  initialContext _ = OStatic ()-  {-# Inline initialContext #-}--instance RuleContext (BS2 First Last C) where-  type Context (BS2 First Last C) = ComplementContext-  initialContext _ = Complemented-  {-# Inline initialContext #-}--newtype instance RunningIndex (BS2 First Last I) = RiBs2I (BS2 First Last I)--data instance RunningIndex (BS2 First Last O) = RiBs2O !(BS2 First Last O) !(BS2 First Last O)--data instance RunningIndex (BS2 First Last C) = RiBs2C !(BS2 First Last C) !(BS2 First Last C)----instance-  ( Monad m-  ) => MkStream m S (BitSet I) where-  -- | We enumerate all sets that have @popCount s - rb@ bits. Since we are-  -- @IStatic@ we only have static objects following. These will fill in-  -- the missing bits. Each object will fill a fixed number of bits, until-  -- @s@ has been recovered. Otherwise we would have an @IVariable@-  -- context.-  mkStream S (IStatic rb) u s-    = staticCheck (rb <= ps) . map (\k -> ElmS . RiBsI $ popShiftL s k) $ unfoldr go strt-    where strt = Just $ BitSet $ 2^(ps - rb) - 1-          ps   = popCount s-          go Nothing  = Nothing-          go (Just k) = Just $ (k, popPermutation ps k)-  -- | Once we are variable, we do not reserve any bits, just check that-  -- the total reservation (if any) works.-  mkStream S (IVariable rb) u s-    = staticCheck (rb <= popCount s) . singleton . ElmS $ RiBsI 0-  {-# Inline mkStream #-}---- | Initial index construction for outside Bitsets. Bits set to @0@--- indicate hole-space. The last bitset, the one accessed by @axiom@, is--- @BitSet 0@.------ We need to be careful with reserved bits! Reserved bits are @0@ bits--- that can be switched to @1@. This means that @rb@ + popCount s <=--- popCount u@.------ @OStatic@'s happen when we only have terminals on the r.h.s. That is,--- with @X -> end@.------ TODO test all of this via quickcheck!--instance-  ( Monad m-  ) => MkStream m S (BitSet O) where-  -- | Same argument as above for @BitSet O@ construction.-  mkStream S (OStatic rb) u s-    = staticCheck (rb + popCount s <= popCount u) . singleton . ElmS $ RiBsO s s-  mkStream S (ORightOf _) u s-    = error "ADP.Fusion.Base.Set: Entered ORightOf/BitSet (this is probably wrong because it means we have an outside cfg with only terminals on the r.h.s, and the terminals are not a single Outside-Epsilon)"-  mkStream S (OFirstLeft rb) u s-    = staticCheck (rb + popCount s <= popCount u) . singleton . ElmS $ RiBsO s s---  mkStream S (OLeftOf rp) u s---    = staticCheck (popCount s + rp <= popCount u) . singleton $ ElmS s s-  {-# Inline mkStream #-}--instance-  ( Monad m-  ) => MkStream m S (BitSet C) where--instance-  ( Monad m-  ) => MkStream m S (BS2 First Last I) where-  mkStream S (IStatic rp) u sij@(BS2 s (Iter i) _)-    = staticCheck (popCount s == 0 && rp == 0) . singleton . ElmS . RiBs2I $ BS2 0 (Iter i) (Iter i)-  mkStream S (IVariable rp) u sij@(BS2 s (Iter i) _)-    = staticCheck (popCount s >= rp) . singleton . ElmS . RiBs2I $ BS2 0 (Iter i) (Iter i)-  {-# Inline mkStream #-}--instance-  ( Monad m-  ) => MkStream m S (BS2 First Last O) where--instance-  ( Monad m-  ) => MkStream m S (BS2 First Last C) where------ | An undefined bitset with 2 interfaces.--undefbs2i :: BS2 f l t-undefbs2i = BS2 (-1)  (-1) (-1)-{-# Inline undefbs2i #-}--undefi :: Interface i-undefi = (-1)-{-# Inline undefi #-}--instance TableStaticVar (u O) c (BitSet O) where-  tableStaticVar _ _ (OStatic  d) _ = OFirstLeft d-  tableStaticVar _ _ (ORightOf d) _ = OFirstLeft d-  tableStreamIndex _ c _ bs = bs-  {-# INLINE [0] tableStaticVar   #-}-  {-# INLINE [0] tableStreamIndex #-}--instance TableStaticVar c (u I) (BitSet O) where--instance (MinSize c) => TableStaticVar u c (BitSet I) where-  tableStaticVar _ c (IStatic   d) _ = IVariable $ d - minSize c -- TODO rly?-  tableStaticVar _ _ (IVariable d) _ = IVariable $ d-  tableStreamIndex _ c _ bitSet = bitSet -- TODO rly?-  {-# INLINE [0] tableStaticVar   #-}-  {-# INLINE [0] tableStreamIndex #-}--instance TableStaticVar c u (BS2 i j I) where---- | We sometimes need --data ThisThatNaught a b = This a | That b | Naught-

@@ -1,162 +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 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 I) where-  type Context (Subword I) = InsideContext ()-  initialContext _ = IStatic ()-  {-# Inline initialContext #-}--instance RuleContext (Subword O) where-  type Context (Subword O) = OutsideContext (Int:.Int)-  initialContext _ = OStatic (0:.0)-  {-# Inline  initialContext #-}--instance RuleContext (Subword C) where-  type Context (Subword C) = ComplementContext-  initialContext _ = Complemented-  {-# Inline initialContext #-}---- | The moving index @k@ in @Subword (i:.k)@.--newtype instance RunningIndex (Subword I) = RiSwI Int---- | The moving indices @Inside (i:.j)@ and @Outside (k:.l)@ in order @i--- j k l@.------ TODO can we do with 2x Int?--data instance RunningIndex (Subword O) = RiSwO !Int !Int !Int !Int---- | The indices @Subword (i:.j)@ in order @i j@.--data instance RunningIndex (Subword C) = RiSwC !Int !Int------ | 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------ TODO shouldn't the new @staticCheck@ impl handle this?--instance (Monad m) => MkStream m S (Subword I) where-  mkStream S (IStatic ()) (Subword (_:.h)) (Subword (i:.j))-    -- = staticCheck (0<=i && i<=j)-    = filter (const $ 0<=i && i<=j)-    . singleton-    . ElmS $ RiSwI i-  mkStream S (IVariable ()) (Subword (_:.h)) (Subword (i:.j))-    -- = staticCheck (0<=i && i<=j)-    = filter (const $ 0<=i && i<=j && j<=h)-    . singleton-    . ElmS $ RiSwI i-  {-# Inline mkStream #-}--instance (Monad m) => MkStream m S (Subword O) where-  mkStream S (OStatic (di:.dj)) (Subword (_:.h)) (Subword (i:.j))-    = staticCheck (i==0 && j+dj==h) . singleton . ElmS $ RiSwO i j  i (j+dj)-  mkStream S (OFirstLeft (di:.dj)) (Subword (_:.h)) (Subword (i:.j))-    = let i' = i-di-      in  staticCheck (0 <= i' && i<=j && j+dj<=h) . singleton . ElmS $ RiSwO i' i' i' i'-  mkStream S (OLeftOf (di:.dj)) (Subword (_:.h)) (Subword (i:.j))-    = let i' = i-di-      in  staticCheck (0 <= i' && i<=j && j+dj<=h)-    $ map (\k -> ElmS $ RiSwO 0 k k j)-    $ enumFromStepN 0 1 (i'+1)-  mkStream S e _ _ = error $ show e ++ "maybe only inside syntactic terminals on the RHS of an outside rule?" -- TODO mostly because I'm not sure if that would be useful-  {-# Inline mkStream #-}---- | ------ TODO The @go@ here needs an explanation.--instance (Monad m) => MkStream m S (Subword C) where-  mkStream S Complemented (Subword (_:.h)) (Subword (i:.j))-    = map (\(k,l) -> ElmS $ RiSwC 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 I) where-  mkStream S (vs:.IStatic ()) (lus:.Subword (_:.h)) (ixs:.Subword(i:.j))-    = staticCheck (0<=i && i==j) -- && j<=h)-    . map (\(ElmS zi) -> ElmS (zi:.:RiSwI i))-    $ mkStream S vs lus ixs-  mkStream S (vs:.IVariable ()) (lus:.Subword (_:.h)) (ixs:.Subword (i:.j))-    = map (\(ElmS zi) -> ElmS (zi:.:RiSwI i))-    . staticCheck (0<=i && i<=j) -- filter (const $ 0<=i && i<=j && j<=h)-    $ mkStream S vs lus ixs-  {-# Inline mkStream #-}--instance (MinSize c) => TableStaticVar u c (Subword I) where-  tableStaticVar _ _ (IStatic   d) _ = IVariable d-  tableStaticVar _ _ (IVariable d) _ = IVariable d-  tableStreamIndex _ c _ (Subword (i:.j)) = subword i (j - minSize c)-  {-# INLINE [0] tableStaticVar   #-}-  {-# INLINE [0] tableStreamIndex #-}---- | This instance is chosen if we consider an outside table (i.e.--- a syntactic variable) in an outside index.------ TODO @tableStreamIndex@ needs to be fixed--instance TableStaticVar (u O) c (Subword O) where-  tableStaticVar _ _ (OStatic  d) _ = OFirstLeft d-  tableStaticVar _ _ (ORightOf d) _ = OFirstLeft d-  tableStreamIndex _ c _ (Subword (i:.j)) = subword i j-  {-# INLINE [0] tableStaticVar   #-}-  {-# INLINE [0] tableStreamIndex #-}---- | This instance is chosen if we consider an inside table (i.e.--- a terminal symbol!) in an outside index.------ TODO @tableStreamIndex@ needs to be fixed--instance TableStaticVar (u I) c (Subword O) where-  tableStaticVar _ _ (OStatic    d) _ = ORightOf d-  tableStaticVar _ _ (ORightOf   d) _ = ORightOf d-  tableStaticVar _ _ (OFirstLeft d) _ = OLeftOf d-  tableStaticVar _ _ (OLeftOf    d) _ = OLeftOf d-  tableStreamIndex _ c _ (Subword (i:.j)) = subword i j-  {-# INLINE [0] tableStaticVar   #-}-  {-# INLINE [0] tableStreamIndex #-}--instance TableStaticVar (u I) c (Subword C) where-  tableStaticVar _ _ _ _ = Complemented-  tableStreamIndex _ c _ (Subword (i:.j)) = subword i j-  {-# INLINE [0] tableStaticVar   #-}-  {-# INLINE [0] tableStreamIndex #-}--instance TableStaticVar (u O) c (Subword C) where-  tableStaticVar _ _ _ _ = Complemented-  tableStreamIndex _ c _ (Subword (i:.j)) = subword i j-  {-# INLINE [0] tableStaticVar   #-}-  {-# INLINE [0] tableStreamIndex #-}-

@@ -1,55 +0,0 @@--module ADP.Fusion.Base.Term where--{---import Data.Vector.Fusion.Stream.Monadic-import Prelude hiding (map)--import Data.PrimitiveArray hiding (map)--import ADP.Fusion.Base.Classes-import ADP.Fusion.Base.Multi----data TermState s a i e = TState-  { sS  :: !s -- | state coming in from the left-  , sIx :: !a -- | @I/C@ index from @sS@-  , sOx :: !a -- | @O@ index from @sS@---  , tt  :: !u -- | @I/C@ building up state to index the @table@.-  , iIx :: !i -- | @I/C@ building up state to hand over to next symbol-  , iOx :: !i -- | @O@ building up state to hand over to next symbol-  , eTS :: !e -- | element data-  }--class TermStream m t a i where-  termStream :: t -> Context i -> i -> i -> Stream m (TermState s a Z Z) -> Stream m (TermState s a i (TermArg t))--instance TermStream m M a Z where-  termStream _ _ _ _ = 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-  :: ( Monad m-     , TermStream m (TermSymbol M t) (Z:.a) (Z:.i)-     , s ~ Elm x0 a-     , Element x0 a-     )-  => t -> Context i -> i -> i -> Stream m s -> Stream m (s,TermArg t,i,i)-addTermStream1 t c u i-  = map (\(TState sS _ _ (Z:.ii) (Z:.oo) (Z:.ee)) -> (sS,ee,ii,oo))-  . termStream (M:|t) (Z:.c) (Z:.u) (Z:.i)-  . map (\s -> TState s (Z:.getIdx s) (Z:.getOmx s) Z Z Z)-{-# Inline addTermStream1 #-}----}-

@@ -1,109 +0,0 @@---- | Type-level indexing functionality--module ADP.Fusion.Base.TyLvlIx where--import Data.Proxy-import GHC.TypeLits--import Data.PrimitiveArray hiding (map)--import ADP.Fusion.Base.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) _ _ = i-  {-# Inline 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 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 getIndexGo #-}--instance GetIndexGo Z Z EQ where-  type ResolvedIx Z Z EQ = Z-  getIndexGo _ _ _ = Z-  {-# Inline 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) _ _ = i-  {-# Inline 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 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 getIndexGo #-}--instance GetIndexGo (RunningIndex Z) (RunningIndex Z) EQ where-  type ResolvedIx (RunningIndex Z) (RunningIndex Z) EQ = RunningIndex Z-  getIndexGo _ _ _ = RiZ-  {-# Inline 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 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 #-}---}-

@@ -1,98 +0,0 @@---- |------ TODO the 'mkStream' instances here are probably wonky for everything--- that is non-static.--module ADP.Fusion.Base.Unit where--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.Base.Classes-import ADP.Fusion.Base.Multi----instance RuleContext (Unit I) where-  type Context (Unit I) = InsideContext ()-  initialContext _ = IStatic ()-  {-# Inline initialContext #-}--instance RuleContext (Unit O) where-  type Context (Unit O) = OutsideContext ()-  initialContext _ = OStatic ()-  {-# Inline initialContext #-}--instance RuleContext (Unit C) where-  type Context (Unit C) = ComplementContext-  initialContext _ = Complemented-  {-# Inline initialContext #-}--data instance RunningIndex (Unit t) = RiU----instance (Monad m) => MkStream m S (Unit I) where-  mkStream S _ Unit Unit = singleton $ ElmS RiU-  {-# Inline mkStream #-}--instance (Monad m) => MkStream m S (Unit O) where-  mkStream S _ Unit Unit = singleton $ ElmS RiU-  {-# Inline mkStream #-}--instance (Monad m) => MkStream m S (Unit C) where-  mkStream S _ Unit Unit = singleton $ ElmS RiU-  {-# Inline mkStream #-}--instance-  ( Monad m-  , MkStream m S is-  ) => MkStream m S (is:.Unit I) where-  mkStream S (vs:._) (us:._) (is:._)-    = map (\(ElmS zi) -> ElmS $ zi :.: RiU)-    $ mkStream S vs us is-  {-# Inline mkStream #-}--instance-  ( Monad m-  , MkStream m S is-  ) => MkStream m S (is:.Unit O) where-  mkStream S (vs:._) (us:._) (is:._)-    = map (\(ElmS zi) -> ElmS $ zi :.: RiU)-    $ mkStream S vs us is-  {-# Inline mkStream #-}--instance-  ( Monad m-  , MkStream m S is-  ) => MkStream m S (is:.Unit C) where-  mkStream S (vs:._) (us:._) (is:._)-    = map (\(ElmS zi) -> ElmS $ zi :.: RiU)-    $ mkStream S vs us is-  {-# Inline mkStream #-}----instance TableStaticVar c u (Unit I) where-  tableStaticVar _ _ _ _ = IStatic ()-  tableStreamIndex _ _ _ _ = Unit-  {-# Inline [0] tableStaticVar #-}-  {-# Inline [0] tableStreamIndex #-}--instance TableStaticVar c u (Unit O) where-  tableStaticVar _ _ _ _ = OStatic ()-  tableStreamIndex _ _ _ _ = Unit-  {-# Inline [0] tableStaticVar #-}-  {-# Inline [0] tableStreamIndex #-}--instance TableStaticVar c u (Unit C) where-  tableStaticVar _ _ _ _ = Complemented-  tableStreamIndex _ _ _ _ = Unit-  {-# Inline [0] tableStaticVar #-}-  {-# Inline [0] tableStreamIndex #-}--

@@ -0,0 +1,112 @@++-- | 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.TH+  , module ADP.Fusion.Core.TyLvlIx+  , module ADP.Fusion.SynVar.Array.Type+  , module ADP.Fusion.SynVar.Axiom+  , module ADP.Fusion.SynVar.Backtrack+  , module ADP.Fusion.SynVar.Fill+  , module ADP.Fusion.SynVar.Indices.Classes+  , module ADP.Fusion.SynVar.Recursive.Type+  , module ADP.Fusion.SynVar.Split.Type+  , module ADP.Fusion.SynVar.TableWrap+  , module ADP.Fusion.Term.Chr.Type+  , module ADP.Fusion.Term.Deletion.Type+  , module ADP.Fusion.Term.Edge.Type+  , module ADP.Fusion.Term.Epsilon.Type+  , module ADP.Fusion.Term.PeekIndex.Type+  , module ADP.Fusion.Term.Strng.Type+  , 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.TH+import           ADP.Fusion.Core.TyLvlIx+import           ADP.Fusion.SynVar.Array.Type+import           ADP.Fusion.SynVar.Axiom+import           ADP.Fusion.SynVar.Backtrack+import           ADP.Fusion.SynVar.Fill+import           ADP.Fusion.SynVar.Indices.Classes+import           ADP.Fusion.SynVar.Recursive.Type+import           ADP.Fusion.SynVar.Split.Type+import           ADP.Fusion.SynVar.TableWrap+import           ADP.Fusion.Term.Chr.Type+import           ADP.Fusion.Term.Deletion.Type+import           ADP.Fusion.Term.Edge.Type+import           ADP.Fusion.Term.Epsilon.Type+import           ADP.Fusion.Term.PeekIndex.Type+import           ADP.Fusion.Term.Strng.Type++++-- | 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 (%) #-}+

@@ -0,0 +1,89 @@++module ADP.Fusion.Core.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 #-}+

@@ -0,0 +1,216 @@++{-# Language MagicHash #-}++module ADP.Fusion.Core.Classes where++import           Data.Proxy+import           Data.Strict.Tuple+import           GHC.Exts hiding (build)+import qualified Data.Vector.Fusion.Stream.Monadic as S++import           Data.PrimitiveArray++++data OutsideContext s+  = OStatic     s+  | ORightOf    s+  | OFirstLeft  s+  | OLeftOf     s+  deriving (Show)++data InsideContext s+  = IStatic   s+  | IVariable s+  deriving (Show)++data ComplementContext+  = Complemented+  deriving (Show)++class RuleContext i where+  type Context i :: *+  initialContext :: i -> Context i++-- | 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.+--+-- TODO Sometimes, the actual RunningIndex ctors are not erased. This could+-- be due to <https://ghc.haskell.org/trac/ghc/ticket/2289>. To test, we+-- should transform RunningIndex into a type class to give us access to the+-- left and right member, also we should create instances a la+-- @RunningIndex (is :. Subword I) = RiSwI !(RunningIndex is) !Int@.+-- Hopefully, these are completely erased.++{-+class RunningIndexCl i where+  type RecursiveRl i :: *+  type ThisRI i :: *+-}++data family RunningIndex i :: *++data instance RunningIndex (is:.i) = !(RunningIndex is) :.: !(RunningIndex i)++data instance RunningIndex Z = RiZ++deriving instance Show (RunningIndex Z)+++-- | 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 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 !(RunningIndex i)+  type Arg S   = Z+  getArg (ElmS _) = Z+  getIdx (ElmS i) = i+  {-# Inline getArg #-}+  {-# Inline 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) = b `seq` 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 t b) where+  {-# Inline [0] snew #-}+  snew (SL s k)+    | 1# <- k   = 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 !z !Int# | 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 TableConstraint+--  = EmptyOk+--  | NonEmpty+--  | OnlyZero+--  deriving (Eq,Show)++data EmptyOk = EmptyOk++data NonEmpty = NonEmpty++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 #-}++{-+minSize :: TableConstraint -> Int+minSize NonEmpty = 1+minSize _        = 0+{-# Inline [0] 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++--+--instance ModifyConstraint EmptyOk+--  type TNE EmptyOk = NonEmpty+--  type TE  EmptyOk = ++-- |++--type family   TblConstraint x       :: *+--+--type instance TblConstraint (is:.i) =  TblConstraint is :. TblConstraint i+--type instance TblConstraint Z       = Z+--+---- TODO move into the sub-modules+--+--type instance TblConstraint (PointL  t) = TableConstraint+--type instance TblConstraint (PointR  t) = TableConstraint+--type instance TblConstraint (Subword t) = TableConstraint+

@@ -0,0 +1,226 @@++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           Data.PrimitiveArray 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)++instance+  ( Monad m+  , MkStream m ls i+  , Element ls i+  , TermStaticVar (TermSymbol a b) i+  , TermStream m (TermSymbol a b) (Elm ls i) i+  ) => MkStream m (ls :!: TermSymbol a b) i where+  mkStream (ls :!: ts) sv lu i+    = map (\(TState sS ii ee) -> ElmTS ee ii sS)+    . termStream ts sv lu i+    . map (\s -> TState s RiZ Z)+    $ 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 #-}+--+--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 => MkStream m S Z where+  mkStream _ _ _ _ = 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 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 [0] termStaticVar #-}+  {-# INLINE [0] 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 [0] termStaticVar #-}+  {-# INLINE [0] termStreamIndex #-}++--data S3 a b c           = S3 !a !b !c+--+--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+--+--data S7 a b c d e f g   = S7 !a !b !c !d !e !f !g+--+--data S8 a b c d e f g h = S8 !a !b !c !d !e !f !g !h++--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 is, RuleContext i) => RuleContext (is:.i) where+  type Context (is:.i) = Context is:.Context i+  initialContext (is:.i) = initialContext is:.initialContext i+  {-# INLINE initialContext #-}++class TableStaticVar u c i where+  tableStaticVar   :: Proxy u -> c -> Context i -> i -> Context i+  tableStreamIndex :: Proxy u -> c -> Context i -> i -> i++instance TableStaticVar c u Z where+  tableStaticVar   _ _ _ _ = Z+  tableStreamIndex _ _ _ _ = Z+  {-# INLINE [0] tableStaticVar   #-}+  {-# INLINE [0] tableStreamIndex #-}++instance (TableStaticVar us cs is, TableStaticVar u c i) => TableStaticVar (us:.u) (cs:.c) (is:.i) where+  tableStaticVar   _ (cs:.c) (vs:.v) (is:.i) = tableStaticVar   (Proxy :: Proxy us) cs vs is :. tableStaticVar   (Proxy :: Proxy u) c v i+  tableStreamIndex _ (cs:.c) (vs:.v) (is:.i) = tableStreamIndex (Proxy :: Proxy us) cs vs is :. tableStreamIndex (Proxy :: Proxy u) c v i+  {-# INLINE [0] tableStaticVar   #-}+  {-# INLINE [0] tableStreamIndex #-}++++data TermState s i e = TState+  { tS  :: !s -- ^ state coming in from the left+--  , tIx :: !(RunningIndex a) --  @I/C@ index from @sS@+  , iIx :: !(RunningIndex i) -- ^ @I/C@ building up state to hand over to next symbol+  , eTS :: !e -- ^ element data+  }++--getTIX :: (Element x0 a, s ~ Elm x0 a) => TermState s a i e -> RunningIndex a+--getTIX (TState s a i e) = getIdx s+--{-# Inline getTIX #-}++class TermStream m t s i where+  termStream :: t -> Context i -> i -> i -> Stream m (TermState s Z Z) -> Stream m (TermState s i (TermArg t))++instance (Monad m) => TermStream m M s Z where+  termStream _ _ _ _ = id -- map (\(!s) -> s)+  {-# 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+  :: ( Monad m+     , TermStream m (TermSymbol M t) (Elm (Term1 s) (Z:.i)) (Z:.i)+     )+  => t -> Context i -> i -> i -> Stream m s -> Stream m (s,TermArg t,RunningIndex i)+addTermStream1 t c u i+  = map (\(TState (ElmTerm1 sS) (RiZ:.:ii) (Z:.ee)) -> (sS,ee,ii))+  . termStream (M:|t) (Z:.c) (Z:.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++type TmkCtx1 m ls t i+  = ( Monad m+    , MkStream m ls i+    , TermStream m (TermSymbol M t) (Elm (Term1 (Elm ls i)) (Z:.i)) (Z:.i)+    , Element ls i+    , TermStaticVar t i+    )++-- | @Term TermStream@ context++--type TstCtx1 m ts s sixty is i+--  = ( Monad m+--    , TermStream m ts s is+--    , GetIndex (RunningIndex sixty) (RunningIndex (is:.i))+--    , GetIx (RunningIndex sixty) (RunningIndex (is:.i)) ~ (RunningIndex i)+--    )++type TstCtx m ts s x0 sixty is i+  = ( Monad m+    , TermStream m 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))+

@@ -0,0 +1,121 @@++{-# Language MagicHash #-}++module ADP.Fusion.Core.Point where++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 Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi++++instance RuleContext (PointL I) where+  type Context (PointL I) = InsideContext Int+  initialContext _ = IStatic 0+  {-# Inline initialContext #-}++instance RuleContext (PointL O) where+  type Context (PointL O) = OutsideContext Int+  initialContext _ = OStatic 0+  {-# Inline initialContext #-}++instance RuleContext (PointL C) where+  type Context (PointL C) = ComplementContext+  initialContext _ = Complemented+  {-# Inline initialContext #-}++newtype instance RunningIndex (PointL I) = RiPlI Int++data instance RunningIndex (PointL O) = RiPlO !Int !Int++data instance RunningIndex (PointL C) = RiPlC !Int++++instance (Monad m) => MkStream m S (PointL I) where+  mkStream S (IStatic (I# d)) (PointL (I# u)) (PointL (I# i))+--    = staticCheck (isTrue# ( (i >=# 0#) `andI#` (i <=# d) `andI#` (i <=# d) ) ) -- (i>=0 && i<=d && i<=u)+    = staticCheck# ( (i >=# 0#) `andI#` (i <=# d) `andI#` (i <=# d) )+--    = filter (const (isTrue# ( (i >=# 0#) `andI#` (i <=# d) `andI#` (i <=# d) ) ))+    . singleton . ElmS $ RiPlI 0+  mkStream S (IVariable _) (PointL (I# u)) (PointL (I# i))+--    = staticCheck (isTrue# ( (i >=# 0#) `andI#` (i <=# u) ) ) -- (i>=0 && i<=u)+    = staticCheck# ( (i >=# 0#) `andI#` (i <=# u) )+--    = filter (const (isTrue# ( (i >=# 0#) `andI#` (i <=# u) ) ))+    . singleton . ElmS $ RiPlI 0+  {-# Inline mkStream #-}++instance+  ( Monad m+  , MkStream m S is+  ) => MkStream m S (is:.PointL I) where+  mkStream S (vs:.IStatic d) (lus:.PointL u) (is:.PointL i)+    = map (\(ElmS zi) -> ElmS $ zi :.: RiPlI 0)+    . staticCheck (i>=0 && i<=d && i<=u)+    $ mkStream S vs lus is+  mkStream S (vs:.IVariable d) (lus:.PointL u) (is:.PointL i)+    = map (\(ElmS zi) -> ElmS $ zi :.: RiPlI 0)+    . staticCheck (i>=0 && i<=u)+    $ mkStream S vs lus is+  {-# INLINE mkStream #-}++++instance (Monad m) => MkStream m S (PointL O) where+  mkStream S (OStatic d) (PointL u) (PointL i)+    = staticCheck (i>=0 && i+d<=u && u == i) . singleton . ElmS $ RiPlO i (i+d)+  mkStream S (OFirstLeft d) (PointL u) (PointL i)+    = staticCheck (i>=0 && i+d<=u) . singleton . ElmS $ RiPlO i (i+d)+  {-# Inline mkStream #-}++instance+  ( Monad m+  , MkStream m S is+  ) => MkStream m S (is:.PointL O) where+  mkStream S (vs:.OStatic d) (lus:.PointL u) (is:.PointL i)+    = staticCheck (i>=0 && i+d == u)+    . map (\(ElmS zi) -> ElmS $ zi :.: RiPlO i (i+d))+    $ mkStream S vs lus is+  mkStream S (vs:.OFirstLeft d) (us:.PointL u) (is:.PointL i)+    = staticCheck (i>=0 && i+d<=u)+    . map (\(ElmS zi) -> ElmS $ zi :.: RiPlO i (i+d))+    $ mkStream S vs us is+  {-# Inline mkStream #-}++++instance (Monad m) => MkStream m S (PointL C) where+  mkStream S Complemented (PointL u) (PointL i)+    = staticCheck (i>=0 && i<=u) . singleton . ElmS $ RiPlC i+  {-# Inline mkStream #-}++++instance (MinSize c) => TableStaticVar u c (PointL I) 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) = PointL $ j - minSize c+  {-# INLINE [0] tableStaticVar   #-}+  {-# INLINE [0] tableStreamIndex #-}++instance (MinSize c) => TableStaticVar u c (PointL O) where+  tableStaticVar   _ _ (OStatic d) _          = OFirstLeft d+  tableStreamIndex _ c _           (PointL j) = PointL $ j - minSize c+  {-# INLINE [0] tableStaticVar   #-}+  {-# INLINE [0] tableStreamIndex #-}++instance (MinSize c) => TableStaticVar u c (PointL C) where+  tableStaticVar   _ _ Complemented _          = Complemented+  tableStreamIndex _ c _            (PointL k) = PointL $ k - minSize c+  {-# INLINE [0] tableStaticVar   #-}+  {-# INLINE [0] tableStreamIndex #-}+

@@ -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 []+-}++

@@ -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 ( (:.)(..) , 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 _                = []+

@@ -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+

@@ -0,0 +1,109 @@++-- | Type-level indexing functionality++module ADP.Fusion.Core.TyLvlIx where++import Data.Proxy+import GHC.TypeLits++import Data.PrimitiveArray 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) _ _ = i+  {-# Inline 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 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 getIndexGo #-}++instance GetIndexGo Z Z EQ where+  type ResolvedIx Z Z EQ = Z+  getIndexGo _ _ _ = Z+  {-# Inline 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) _ _ = i+  {-# Inline 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 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 getIndexGo #-}++instance GetIndexGo (RunningIndex Z) (RunningIndex Z) EQ where+  type ResolvedIx (RunningIndex Z) (RunningIndex Z) EQ = RunningIndex Z+  getIndexGo _ _ _ = RiZ+  {-# Inline 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 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 #-}++-}+

@@ -0,0 +1,98 @@++-- |+--+-- TODO the 'mkStream' instances here are probably wonky for everything+-- that is non-static.++module ADP.Fusion.Core.Unit where++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++++instance RuleContext (Unit I) where+  type Context (Unit I) = InsideContext ()+  initialContext _ = IStatic ()+  {-# Inline initialContext #-}++instance RuleContext (Unit O) where+  type Context (Unit O) = OutsideContext ()+  initialContext _ = OStatic ()+  {-# Inline initialContext #-}++instance RuleContext (Unit C) where+  type Context (Unit C) = ComplementContext+  initialContext _ = Complemented+  {-# Inline initialContext #-}++data instance RunningIndex (Unit t) = RiU++++instance (Monad m) => MkStream m S (Unit I) where+  mkStream S _ Unit Unit = singleton $ ElmS RiU+  {-# Inline mkStream #-}++instance (Monad m) => MkStream m S (Unit O) where+  mkStream S _ Unit Unit = singleton $ ElmS RiU+  {-# Inline mkStream #-}++instance (Monad m) => MkStream m S (Unit C) where+  mkStream S _ Unit Unit = singleton $ ElmS RiU+  {-# Inline mkStream #-}++instance+  ( Monad m+  , MkStream m S is+  ) => MkStream m S (is:.Unit I) where+  mkStream S (vs:._) (us:._) (is:._)+    = map (\(ElmS zi) -> ElmS $ zi :.: RiU)+    $ mkStream S vs us is+  {-# Inline mkStream #-}++instance+  ( Monad m+  , MkStream m S is+  ) => MkStream m S (is:.Unit O) where+  mkStream S (vs:._) (us:._) (is:._)+    = map (\(ElmS zi) -> ElmS $ zi :.: RiU)+    $ mkStream S vs us is+  {-# Inline mkStream #-}++instance+  ( Monad m+  , MkStream m S is+  ) => MkStream m S (is:.Unit C) where+  mkStream S (vs:._) (us:._) (is:._)+    = map (\(ElmS zi) -> ElmS $ zi :.: RiU)+    $ mkStream S vs us is+  {-# Inline mkStream #-}++++instance TableStaticVar c u (Unit I) where+  tableStaticVar _ _ _ _ = IStatic ()+  tableStreamIndex _ _ _ _ = Unit+  {-# Inline [0] tableStaticVar #-}+  {-# Inline [0] tableStreamIndex #-}++instance TableStaticVar c u (Unit O) where+  tableStaticVar _ _ _ _ = OStatic ()+  tableStreamIndex _ _ _ _ = Unit+  {-# Inline [0] tableStaticVar #-}+  {-# Inline [0] tableStreamIndex #-}++instance TableStaticVar c u (Unit C) where+  tableStaticVar _ _ _ _ = Complemented+  tableStreamIndex _ _ _ _ = Unit+  {-# Inline [0] tableStaticVar #-}+  {-# Inline [0] tableStreamIndex #-}++

@@ -0,0 +1,25 @@++-- | This exports everything needed for sequence-based alignment style+-- algorithms.++module ADP.Fusion.Point+  ( module ADP.Fusion.Core+  , module ADP.Fusion.Core.Point+  , module ADP.Fusion.SynVar.Indices.Point+  , module ADP.Fusion.SynVar.Recursive.Point+  , module ADP.Fusion.Term.Chr.Point+  , module ADP.Fusion.Term.Deletion.Point+  , module ADP.Fusion.Term.Strng.Point+  , module ADP.Fusion.Term.Epsilon.Point+  ) where++import ADP.Fusion.Core++import ADP.Fusion.Core.Point+import ADP.Fusion.SynVar.Recursive.Point+import ADP.Fusion.Term.Chr.Point+import ADP.Fusion.Term.Deletion.Point+import ADP.Fusion.Term.Epsilon.Point+import ADP.Fusion.Term.Strng.Point+import ADP.Fusion.SynVar.Indices.Point+

@@ -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-

@@ -12,12 +12,12 @@  import Data.PrimitiveArray hiding (map) -import ADP.Fusion.Base-import ADP.Fusion.SynVar.Backtrack-import ADP.Fusion.SynVar.Indices--import ADP.Fusion.SynVar.Array.TermSymbol+import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi import ADP.Fusion.SynVar.Array.Type+import ADP.Fusion.SynVar.Backtrack+import ADP.Fusion.SynVar.Indices.Classes+import ADP.Fusion.SynVar.TableWrap   @@ -35,12 +35,12 @@  iTblStream   :: forall m ls arr x u c i . ITblCx m ls arr x u c i-  => Pair ls (ITbl m arr c u x)+  => Pair ls (TwITbl m arr c u x)   -> Context i   -> i   -> i-  -> Stream m (Elm (ls :!: ITbl m arr c u x) i)-iTblStream (ls :!: ITbl _ _ c t _) vs us is+  -> Stream m (Elm (ls :!: TwITbl m arr c u x) i)+iTblStream (ls :!: TW (ITbl _ _ c t) _) vs us is   = map (\(s,tt,ii') -> ElmITbl (t!tt) ii' s)   . addIndexDense1 c vs us is   $ mkStream ls (tableStaticVar (Proxy :: Proxy u) c vs is) us (tableStreamIndex (Proxy :: Proxy u) c vs is)@@ -50,12 +50,12 @@  btITblStream   :: forall mB mF ls arr x r u c i . ITblCx mB ls arr x u c i-  => Pair ls (Backtrack (ITbl mF arr c u x) mF mB r)+  => Pair ls (TwITblBt arr c u x mF mB r)   -> Context i   -> i   -> i-  -> Stream mB (Elm (ls :!: Backtrack (ITbl mF arr c u x) mF mB r) i)-btITblStream (ls :!: BtITbl c t bt) vs us is+  -> Stream mB (Elm (ls :!: TwITblBt arr c u x mF mB r) i)+btITblStream (ls :!: TW (BtITbl c t) bt) vs us is     = mapM (\(s,tt,ii') -> bt us' tt >>= \ ~bb -> return $ ElmBtITbl (t!tt) bb ii' s)     . addIndexDense1 c vs us is     $ mkStream ls (tableStaticVar (Proxy :: Proxy u) c vs is) us (tableStreamIndex (Proxy :: Proxy u) c vs is)@@ -69,54 +69,54 @@ instance   ( Monad m   , ITblCx m ls arr x u c (i I)-  ) => MkStream m (ls :!: ITbl m arr c u x) (i I) where+  ) => MkStream m (ls :!: TwITbl m arr c u x) (i I) where   mkStream = iTblStream   {-# Inline mkStream #-}  instance   ( Monad m   , ITblCx m ls arr x u c (i O)-  ) => MkStream m (ls :!: ITbl m arr c u x) (i O) where+  ) => MkStream m (ls :!: TwITbl m arr c u x) (i O) where   mkStream = iTblStream   {-# Inline mkStream #-}  instance   ( Monad m   , ITblCx m ls arr x u c (i C)-  ) => MkStream m (ls :!: ITbl m arr c u x) (i C) where+  ) => 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 I)-  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr c u x) mF mB r) (i I) where+  ) => MkStream mB (ls :!: TwITblBt arr c u x mF mB r) (i I) where   mkStream = btITblStream   {-# Inline mkStream #-}  instance   ( Monad mB   , ITblCx mB ls arr x u c (i O)-  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr c u x) mF mB r) (i O) where+  ) => 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 :!: Backtrack (ITbl mF arr c u x) mF mB r) (i C) where+  ) => MkStream mB (ls :!: TwITblBt arr c u x mF mB r) (i C) where   mkStream = btITblStream   {-# Inline mkStream #-} -instance ModifyConstraint (ITbl m arr EmptyOk i x) where-  type TNE (ITbl m arr EmptyOk i x) = ITbl m arr NonEmpty i x-  type TE  (ITbl m arr EmptyOk i x) = ITbl m arr EmptyOk  i x-  toNonEmpty (ITbl b l _ arr f) = ITbl b l NonEmpty arr f+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 (Backtrack (ITbl mF arr EmptyOk i x) mF mB r) where-  type TNE (Backtrack (ITbl mF arr EmptyOk i x) mF mB r) = Backtrack (ITbl mF arr NonEmpty i x) mF mB r-  type TE  (Backtrack (ITbl mF arr EmptyOk i x) mF mB r) = Backtrack (ITbl mF arr EmptyOk  i x) mF mB r-  toNonEmpty (BtITbl _ arr bt) = BtITbl NonEmpty arr bt+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 #-} 

@@ -1,172 +0,0 @@---- | TODO migrate instances to correct modules------ TODO need to find out if we can reduce the total number of instances--- required here. Probably not trivial since there are, in principle, @n*m@--- instances that we need to handle.--module ADP.Fusion.SynVar.Array.TermSymbol where--import Data.Proxy-import Data.Strict.Tuple hiding (snd)-import Data.Vector.Fusion.Util (delay_inline)-import Data.Vector.Fusion.Stream.Monadic hiding (flatten)-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 handle @minSize@ conditions!--instance-  ( TstCtx m ts s x0 i0 is (Subword I)-  , PrimArrayOps arr (Subword I) x-  ) => TermStream m (TermSymbol ts (ITbl m arr c (Subword I) x)) s (is:.Subword I) where-  ---  termStream (ts:|ITbl _ _ _ t _) (cs:.IStatic ()) (us:.u) (is:.Subword (i:.j))-    = map (\(TState s ii ee) ->-              let RiSwI l = getIndex (getIdx s) (Proxy :: PRI is (Subword I))-                  lj      = subword l j-              in  TState s (ii:.:RiSwI j) (ee:.t!lj) )-    . termStream ts cs us is-  ---  termStream (ts:|ITbl _ _ _ t _) (cs:.IVariable ()) (us:.u) (is:.Subword (i:.j))-    = flatten mk step . termStream ts cs us is-    where mk tstate@(TState s ii ee) =-              let RiSwI l = getIndex (getIdx s) (Proxy :: PRI is (Subword I))-              in  return (tstate, l, j - l)-          step (tstate@(TState s ii ee), k, z)-            | z >= 0 = do let l  = j - z-                              kl = subword k l-                          return $ Yield (TState s (ii:.:RiSwI l) (ee:.t!kl)) (tstate, k, z-1)-            | otherwise = return $ Done-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline termStream #-}---- |------ TODO can we combine the @ITbl@ and @BtITbl@ code again?--instance-  ( TstCtx mB ts s x0 i0 is (Subword I)-  , PrimArrayOps arr (Subword I) x-  ) => TermStream mB (TermSymbol ts (Backtrack (ITbl mF arr c (Subword I) x) mF mB r)) s (is:.Subword I) where-  termStream (ts:|BtITbl c t bt) (cs:.IStatic ()) (us:.u) (is:.Subword (i:.j))-    = mapM (\(TState s ii ee) ->-                let RiSwI l = getIndex (getIdx s) (Proxy :: PRI is (Subword I))-                    lj      = subword l j-                in  bt u lj >>= \ ~bb -> return $ TState s (ii:.:RiSwI j) (ee:.(t!lj,bb)) )-    . termStream ts cs us is-  termStream (ts:|BtITbl c t bt) (cs:.IVariable ()) (us:.u) (is:.Subword (i:.j))-    = flatten mk step . termStream ts cs us is-    where mk tstate@(TState s ii ee) =-              let RiSwI l = getIndex (getIdx s) (Proxy :: PRI is (Subword I))-              in  return (tstate, l, j - l)-          step (tstate@(TState s ii ee), k, z)-            | z >= 0 = do let l  = j - z-                              kl = subword k l-                          bt u kl >>= \ ~bb -> return $ Yield (TState s (ii:.:RiSwI l) (ee:.(t!kl,bb))) (tstate, k, z-1)-            | otherwise = return $ Done-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline termStream #-}---- | TODO need to deal with @minSize@----instance---  ( Monad m---  , TerminalStream m a is---  , PrimArrayOps arr (Subword I) x---  , Show x---  ) => TerminalStream m (TermSymbol a (ITbl m arr (Subword I) x)) (is:.Subword I) 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 . 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 I) x---  ) => TerminalStream mB (TermSymbol a (Backtrack (ITbl mF arr (Subword I) x) mF mB r)) (is:.Subword I) 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 . 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 c (Subword I) x) (Subword I) 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 c (Subword I) x) mF mB r) (Subword I) 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 #-}---}-

@@ -12,34 +12,41 @@  import Data.PrimitiveArray hiding (map) -import ADP.Fusion.Base+import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi import ADP.Fusion.SynVar.Axiom import ADP.Fusion.SynVar.Backtrack-import ADP.Fusion.SynVar.Indices+import ADP.Fusion.SynVar.Indices.Classes+import ADP.Fusion.SynVar.TableWrap    -- | Immutable table. -data ITbl m arr c i x where-  ITbl :: { iTblBigOrder    :: !Int-          , iTblLittleOrder :: !Int+data ITbl arr c i x where+  ITbl :: { iTblBigOrder    :: {-# Unpack #-} !Int+          , iTblLittleOrder :: {-# Unpack #-} !Int           , iTblConstraint  :: !c           , iTblArray       :: !(arr i x)-          , iTblFun         :: !(i -> i -> m x)-          } -> ITbl m arr c i x+          } -> ITbl arr c i x -instance Build (ITbl m arr c i x)+type TwITbl m arr c i x = TW (ITbl arr c i x) (i -> i -> m x) -type instance TermArg (ITbl m arr c i x) = x+type TwITblBt arr c i x mF mB r = TW (Backtrack (TwITbl mF arr c i x) mF mB) (i -> i -> mB [r]) -instance GenBacktrackTable (ITbl mF arr c i x) mF mB r where-  data Backtrack (ITbl mF arr c i x) mF mB r = BtITbl !c !(arr i x) !(i -> i -> mB [r])-  type BacktrackIndex (ITbl mF arr c i x) = i-  toBacktrack (ITbl _ _ c arr _) _ bt = BtITbl c arr bt+instance Build (TwITbl m arr c i x)++instance Build (TwITblBt arr c i x mF mB r)++type instance TermArg (TwITbl m arr c i x) = x++instance GenBacktrackTable (TwITbl mF arr c i x) mF mB where+  data Backtrack (TwITbl mF arr c i x) mF mB = BtITbl !c !(arr i x) -- !(i -> i -> mB [r])+  type BacktrackIndex (TwITbl mF arr c i x) = i+  toBacktrack (TW (ITbl _ _ c arr) _) _ = BtITbl c arr   {-# Inline toBacktrack #-} -type instance TermArg (Backtrack (ITbl mF arr c i x) mF mB r) = (x,[r])+type instance TermArg (TwITblBt arr c i x mF mB r) = (x,[r])   @@ -49,20 +56,25 @@   ( Monad m   , PrimArrayOps arr i x   , IndexStream i-  ) => Axiom (ITbl m arr c i x) where-  type AxiomStream (ITbl m arr c i x) = m x-  axiom (ITbl _ _ c arr _) = do+  ) => Axiom (TwITbl m arr c i x) where+  type AxiomStream (TwITbl m arr c i x) = m x+  axiom (TW (ITbl _ _ c arr) _) = do     k <- (head . uncurry streamDown) $ bounds arr     return $ arr ! k   {-# Inline axiom #-} +-- | 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-  ) => Axiom (Backtrack (ITbl mF arr c i x) mF mB r) where-  type AxiomStream (Backtrack (ITbl mF arr c i x) mF mB r) = mB [r]-  axiom (BtITbl c arr bt) = do+  , j ~ i+  , m ~ mB+  ) => Axiom (TW (Backtrack (TwITbl mF arr c i x) mF mB) (j -> j -> m [r])) where+  type AxiomStream (TW (Backtrack (TwITbl mF arr c i x) mF mB) (j -> j -> m [r])) = mB [r]+  axiom (TW (BtITbl c arr) bt) = do     h <- (head . uncurry streamDown) $ bounds arr     bt (snd $ bounds arr) h   {-# Inline axiom #-}@@ -71,10 +83,10 @@  -- * 'Element' -instance Element ls i => Element (ls :!: ITbl m arr c j x) i where-  data Elm    (ls :!: ITbl m arr c j x) i = ElmITbl !x !(RunningIndex i) !(Elm ls i)-  type Arg    (ls :!: ITbl m arr c j x)   = Arg ls :. x-  type RecElm (ls :!: ITbl m arr c j x) i = Elm ls i+instance Element ls i => Element (ls :!: TwITbl m arr c j x) i where+  data Elm    (ls :!: TwITbl m arr c j x) i = ElmITbl !x !(RunningIndex i) !(Elm ls i)+  type Arg    (ls :!: TwITbl m arr c j x)   = Arg ls :. x+  type RecElm (ls :!: TwITbl m arr c j x) i = Elm ls i   getArg (ElmITbl x _ ls) = getArg ls :. x   getIdx (ElmITbl _ i _ ) = i   getElm (ElmITbl _ _ ls) = ls@@ -82,12 +94,12 @@   {-# Inline getIdx #-}   {-# Inline getElm #-} -deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i), Show x) => Show (Elm (ls :!: ITbl m arr c j x) i)+deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i), Show x) => Show (Elm (ls :!: TwITbl m arr c j x) i) -instance Element ls i => Element (ls :!: (Backtrack (ITbl mF arr c j x) mF mB r)) i where-  data Elm    (ls :!: (Backtrack (ITbl mF arr c j x) mF mB r)) i = ElmBtITbl !x [r] !(RunningIndex i) !(Elm ls i)-  type Arg    (ls :!: (Backtrack (ITbl mF arr c j x) mF mB r))   = Arg ls :. (x, [r])-  type RecElm (ls :!: (Backtrack (ITbl mF arr c j x) mF mB r)) i = Elm ls i+instance Element ls i => Element (ls :!: TwITblBt arr c j x mF mB r) i where+  data Elm    (ls :!: TwITblBt arr c j x mF mB r) i = ElmBtITbl !x [r] !(RunningIndex i) !(Elm ls i)+  type Arg    (ls :!: TwITblBt arr c j x mF mB r)   = Arg ls :. (x, [r])+  type RecElm (ls :!: TwITblBt 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@@ -95,7 +107,7 @@   {-# Inline getIdx #-}   {-# Inline getElm #-} -instance (Show x, Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: (Backtrack (ITbl mF arr c i x) mF mB r)) i) where+instance (Show x, Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: TwITblBt arr c i x mF mB r) i) where   show (ElmBtITbl x _ i s) = show (x,i) ++ " " ++ show s  @@ -109,8 +121,8 @@   , AddIndexDense (Elm ls (is:.i)) (us:.u) (cs:.c) (is:.i)   , MkStream m ls (is:.i)   , PrimArrayOps arr (us:.u) x-  ) => MkStream m (ls :!: ITbl m arr (cs:.c) (us:.u) x) (is:.i) where-  mkStream (ls :!: ITbl _ _ c t _) vs us is+  ) => MkStream m (ls :!: TwITbl m arr (cs:.c) (us:.u) x) (is:.i) where+  mkStream (ls :!: TW (ITbl _ _ c t) _) vs us is     = map (\(s,tt,ii') -> ElmITbl (t!tt) ii' s)     . addIndexDense c vs us is     $ mkStream ls (tableStaticVar (Proxy :: Proxy (us:.u)) c vs is) us (tableStreamIndex (Proxy :: Proxy (us:.u)) c vs is)@@ -123,8 +135,8 @@   , AddIndexDense (Elm ls (is:.i)) (us:.u) (cs:.c) (is:.i)   , MkStream mB ls (is:.i)   , PrimArrayOps arr (us:.u) x-  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (cs:.c) (us:.u) x) mF mB r) (is:.i) where-  mkStream (ls :!: BtITbl c t bt) vs us is+  ) => MkStream mB (ls :!: TwITblBt arr (cs:.c) (us:.u) x mF mB r) (is:.i) where+  mkStream (ls :!: TW (BtITbl c t) bt) vs us is     = mapM (\(s,tt,ii') -> bt us' tt >>= \ ~bb -> return $ ElmBtITbl (t!tt) bb ii' s)     . addIndexDense c vs us is     $ mkStream ls (tableStaticVar (Proxy :: Proxy (us:.u)) c vs is) us (tableStreamIndex (Proxy :: Proxy (us:.u)) c vs is)

@@ -6,7 +6,7 @@  import Data.Vector.Fusion.Stream.Monadic (Stream) -import ADP.Fusion.Base+import ADP.Fusion.SynVar.TableWrap   @@ -19,10 +19,10 @@ -- @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 :: *+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 r+  toBacktrack :: t -> (forall a . mF a -> mB a) {- -> (BacktrackIndex t -> BacktrackIndex t -> mB [r]) -} -> Backtrack t mF mB -instance Build (Backtrack t mF mB r)+-- instance Build (TW (Backtrack t mF mB) f) 

@@ -17,7 +17,8 @@ import           Data.PrimitiveArray  import           ADP.Fusion.SynVar.Array -- TODO we want to keep only classes in here, move instances to the corresponding modules-import           ADP.Fusion.SynVar.Recursive+import           ADP.Fusion.SynVar.Recursive.Type+import           ADP.Fusion.SynVar.TableWrap  import           Debug.Trace @@ -95,15 +96,15 @@   {-# Inline tableLittleOrder #-}   {-# Inline tableBigOrder #-} -instance (TableOrder ts) => TableOrder (ts:.ITbl im arr c i x) where-  tableLittleOrder (ts:.ITbl _ tlo _ _ _) = tlo : tableLittleOrder ts-  tableBigOrder    (ts:.ITbl tbo _ _ _ _) = tbo : tableBigOrder ts+instance (TableOrder ts) => TableOrder (ts:.TwITbl im arr c i x) where+  tableLittleOrder (ts:.TW (ITbl _ tlo _ _) _) = tlo : tableLittleOrder ts+  tableBigOrder    (ts:.TW (ITbl tbo _ _ _) _) = 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:.IRec im c i x) where+instance (TableOrder ts) => TableOrder (ts:.TwIRec im c i x) where   tableLittleOrder (ts:._) = tableLittleOrder ts   tableBigOrder    (ts:._) = tableBigOrder ts   {-# Inline tableLittleOrder #-}@@ -120,7 +121,7 @@ instance   ( MutateCell CFG ts im om i   , PrimMonad om-  ) => MutateCell CFG (ts:.IRec im c i x) im om i where+  ) => MutateCell CFG (ts:.TwIRec im c i x) im om i where   mutateCell h bo lo mrph (ts:._) lu i = do     mutateCell h bo lo mrph ts lu i   {-# Inline mutateCell #-}@@ -130,8 +131,8 @@   , MPrimArrayOps arr i x   , MutateCell CFG ts im om i   , PrimMonad om-  ) => MutateCell CFG (ts:.ITbl im arr c i x) im om i where-  mutateCell h bo lo mrph (ts:.ITbl tbo tlo c arr f) lu i = do+  ) => MutateCell CFG (ts:.TwITbl im arr c i x) im om i where+  mutateCell h bo lo mrph (ts:.TW (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@@ -146,8 +147,8 @@   , MPrimArrayOps arr ZS2 x   , MutateCell MonotoneMCFG ts im om ZS2   , PrimMonad om-  ) => MutateCell MonotoneMCFG (ts:.ITbl im arr c 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 MonotoneMCFG (ts:.TwITbl im arr c ZS2 x) im om 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@@ -160,8 +161,8 @@   , MPrimArrayOps arr (Subword I) x   , MutateCell h ts im om (Z:.Subword I:.Subword I)   , PrimMonad om-  ) => MutateCell h (ts:.ITbl im arr c (Subword I) x) im om (Z:.Subword I:.Subword I) 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 (ts:.TwITbl im arr c (Subword I) x) im om (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@@ -178,13 +179,13 @@  instance   ( Monad om-  , MutateCell h (ts:.ITbl im arr c i x) im om i+  , MutateCell h (ts:.TwITbl im arr c i x) im om i   , PrimArrayOps arr i x   , Show i   , IndexStream i-  , TableOrder (ts:.ITbl im arr c i x)-  ) => MutateTables h (ts:.ITbl im arr c i x) im om where-  mutateTables h mrph tt@(_:.ITbl _ _ _ arr _) = do+  , TableOrder (ts:.TwITbl im arr c i x)+  ) => MutateTables h (ts:.TwITbl im arr c i x) im om where+  mutateTables h mrph tt@(_:.TW (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

@@ -1,164 +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-  ( module ADP.Fusion.SynVar.Indices.Classes-  , module ADP.Fusion.SynVar.Indices.Point-  , module ADP.Fusion.SynVar.Indices.Set0-  , module ADP.Fusion.SynVar.Indices.Subword-  , module ADP.Fusion.SynVar.Indices.Unit-  ) where--import ADP.Fusion.SynVar.Indices.Classes-import ADP.Fusion.SynVar.Indices.Point-import ADP.Fusion.SynVar.Indices.Set0-import ADP.Fusion.SynVar.Indices.Subword-import ADP.Fusion.SynVar.Indices.Unit---{--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 #-}--}-----}-

@@ -12,7 +12,9 @@  import Data.PrimitiveArray hiding (map) -import ADP.Fusion.Base+import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi+import ADP.Fusion.Core.TyLvlIx   

@@ -9,7 +9,8 @@  import Data.PrimitiveArray hiding (map) -import ADP.Fusion.Base+import ADP.Fusion.Core+import ADP.Fusion.Core.Point import ADP.Fusion.SynVar.Indices.Classes  

@@ -1,157 +0,0 @@---- | @Set0@ provides index movement for sets with no interfaces.------ TODO Sets with 1 and 2 interfaces will go into @Set1@ and @Set2@--- modules.--module ADP.Fusion.SynVar.Indices.Set0 where--import Data.Proxy-import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..))-import Data.Vector.Fusion.Util (delay_inline)-import Debug.Trace-import Prelude hiding (map,head,mapM)-import Data.Bits.Extras-import Data.Bits--import Data.PrimitiveArray hiding (map)-import Data.Bits.Ordered--import ADP.Fusion.Base-import ADP.Fusion.SynVar.Indices.Classes------ * Bitsets without any boundaries------ TODO outside and complement code--instance-  ( IndexHdr s x0 i0 us (BitSet I) cs c is (BitSet I)-  , MinSize c-  ) => AddIndexDense s (us:.BitSet I) (cs:.c) (is:.BitSet I) where-  addIndexDenseGo (cs:.c) (vs:.IStatic rb) (us:.u) (is:.i)-    = flatten mk step . addIndexDenseGo cs vs us is-          -- @mk@ builds up the index we start with. First we ask in @l@-          -- for the index from the previous symbol. Then we calculate the-          -- @mask@, the bits we can still set. This is @i@ minus the @l@-          -- bits. Then we calculate the population count. For this we ask-          -- for the @popCount mask@ and lower it by the constraint @rb@-          -- (why?). Finally, we set exactly popCount bits in @k@. These-          -- @k@ bits are *not* the bits from the @mask@ but rather the-          -- lowest bits.-          -- @rb@ should be set by more-right symbols in case they need to-          -- reserve some bits but otherwise are static.-    where mk svS-            | cm < csize = return $ Nothing-            | otherwise  = return $ Just (svS :. mask :. k)-            where k  = (BitSet $ 2^cm-1)-                  cm = popCount mask - rb-                  mask = i `xor` l-                  RiBsI l = getIndex (getIdx $ sS svS) (Proxy :: PRI is (BitSet I))-          step Nothing = return $ Done-          -- @step Just ...@ performs a non-trivial step. First we-          -- calculate the population count of the index for this symbol as-          -- @pk@. This will terminate once the popcount is higher than the-          -- index @i@ minus the reserved count @rb@.-          -- In case we don't terminate, we calculate the actual index @kk@-          -- by shifting the key @k@ around with our @mask@. The local-          -- index is given by @kk@, while the set of all active bits is-          -- @kk .|. aa@.-          ---          -- TODO is the stopping criterion actually right? Should'nd we-          -- look at all set bits? Also consider the comment above on @rb@.-          step (Just (svS@(SvS s t y') :. mask :. k))-            | pk > popCount i - rb = return $ Done-            | otherwise            = let kk = popShiftL mask k-                                         RiBsI aa = getIndex (getIdx s) (Proxy :: PRI is (BitSet I))-                                     in  return $ Yield (SvS s (t:.kk) (y' :.: RiBsI (kk.|.aa)))-                                                        ((svS :. mask :.) <$> setSucc 0 (2^pm -1) k)-            where pk = popCount k-                  pm = popCount mask-          !csize = minSize c  -- minimal set size via constraints-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  addIndexDenseGo (cs:.c) (vs:.IVariable rb) (us:.u) (is:.i)-    = flatten mk step . addIndexDenseGo cs vs us is-          -- @mk@ builds up the initially set population. In case of-          -- @EmptyOk@ no bits are set. Otherwise we check first if we have-          -- bits left. If @cm==0@ then we immediately quit. If not, we-          -- activate one bit.-    where mk svS-            | csize==0  = return $ Just (svS :. mask :. cm :. csize)-            | cm == 0   = return $ Nothing-            | csize==1  = return $ Just (svS :. mask :. cm :. csize)-            where mask = i `xor` l-                  cm   = popCount mask-                  RiBsI l = getIndex (getIdx $ sS svS) (Proxy :: PRI is (BitSet I))-                  csize = BitSet $ minSize c-          -- if the possible popcount in @i@ is less than the total-          -- popcount in @kk@ and @l@ and the reserved bits in @rb@, then-          -- we continue. This means returning @kk@ as the bitset for-          -- indexing; @kk.|.l@ as all set bits. @setSucc@ will rotate-          -- through all permutations for each popcount and mask.-          step Nothing = return $ Done-          step (Just (svS@(SvS s t y') :. mask :. cm :. k))-            | popCount i < popCount (kk .|. l) + rb = return $ Done-            | otherwise = return $ Yield (SvS s (t:.kk) (y' :.: RiBsI (kk.|.l)))-                                         ((svS :. mask :. cm :.) <$> setSucc 0 (2^cm -1) k)-            where kk = popShiftL mask k-                  RiBsI l  = getIndex (getIdx s) (Proxy :: PRI is (BitSet I))-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline addIndexDenseGo #-}---- | Outside / Outside synvar indices are either @OStatic@ or @ORightOf@.--- Of course, the single outside synvar is not to the right of itself, but--- it is the final @RightOf@ object before we have the @FirstLeft@ object.--instance-  ( IndexHdr s x0 i0 us (BitSet O) cs c is (BitSet O)-  , MinSize c-  ) => AddIndexDense s (us:.BitSet O) (cs:.c) (is:.BitSet O) where-  addIndexDenseGo (cs:.c) (vs:.OStatic rb) (us:.u) (is:.i)-    = flatten mk step . addIndexDenseGo cs vs us is-          -- We need to make the number of @0@s smaller, or make the number-          -- of @1@s larger. By an amount given by @rb@. -    where mk svS-            -- not enough free bits with reserved count-            | rb + popCount bso >= popCount u = return $ Nothing-            | otherwise  = return $ Just (svS :. mask :. k)-            where RiBsO bsi bso = getIndex (getIdx $ sS svS) (Proxy :: PRI is (BitSet O))-                  mask = u `xor` bso -- all bits available for permutations (upper bound, without already set bits)-                  k = BitSet $ 2 ^ rb - 1 -- the bits we want to trigger-          step Nothing = return $ Done-          -- | @step@ can now provide the outside index with @+rb@ more-          -- bits, while the inside index wont have those. The idea is that-          -- @outside@ provides the mask we can now plug additional-          -- @inside@ objects in -- but only in those plug-ports where @i@-          -- is zero.-          step (Just (svS@(SvS s t y') :. mask :. k))-            -- drawing the next bitset ends up over the limit-            | pk > rb   = return $ Done-            | otherwise =-                let RiBsO bsi bso = getIndex (getIdx s) (Proxy :: PRI is (BitSet O))-                    kk = popShiftL mask k-                    tt = kk .|. bso -- the (smaller, more @1@ bits) lookup index-                in  return $ Yield (SvS s (t:.tt) (y' :.: RiBsO bsi tt))-                                   ((svS :. mask :.) <$> setSucc 0 (2^rb -1) k)-            where pk = popCount k-          csize = minSize c-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  addIndexDenseGo (cs:.c) (vs:.ORightOf rb) (us:.u) (is:.i)-    = undefined-  {-# Inline addIndexDenseGo #-}---- |--instance-  ( AddIndexDense a us cs is-  , GetIndex a (is:.BitSet O)-  , GetIx a (is:.BitSet O) ~ (BitSet O)-  ) => AddIndexDense a (us:.BitSet I) (cs:.c) (is:.BitSet O) where---  addIndexDenseGo (cs:.c) (vs:.OFirstLeft rb) (us:.u) (is:.i)---    = error "ping"-  {-# Inline addIndexDenseGo #-}-

@@ -1,191 +0,0 @@---- | Instance code for @Inside@, @Outside@, and @Complement@ indices.------ TODO actual @Outside@ and @Complement@ code ...------ TODO we have quite a lot of @subword i j@ code where only the @type@--- is different; check if @coerce@ yields improved performance or if the--- compiler optimizes this out!--module ADP.Fusion.SynVar.Indices.Subword where--import Data.Proxy-import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..),filter)-import Data.Vector.Fusion.Util (delay_inline)-import Prelude hiding (map,head,mapM,filter)-import Debug.Trace--import Data.PrimitiveArray hiding (map)--import ADP.Fusion.Base-import ADP.Fusion.SynVar.Indices.Classes------ |--- @--- Table: Inside--- Grammar: Inside------ The minSize condition for @IStatic@ is guaranteed via the use of--- @tableStreamIndex@ (not here, in individual synvars), where @j@ is set--- to @j-1@ for the next-left symbol!--- @--instance-  ( IndexHdr s x0 i0 us (Subword I) cs c is (Subword I)-  , MinSize c-  ) => AddIndexDense s (us:.Subword I) (cs:.c) (is:.Subword I) where-  addIndexDenseGo (cs:._) (vs:.IStatic ()) (us:.Subword (_:.u)) (is:.Subword (i:.j))-    = id -- staticCheck (j<=u)-    . map (\(SvS s t y') -> let RiSwI l = getIndex (getIdx s) (Proxy :: PRI is (Subword I))-                                lj = subword l j-                            in  SvS s (t:.lj) (y' :.: RiSwI j) )-    . addIndexDenseGo cs vs us is-  addIndexDenseGo (cs:.c) (vs:.IVariable ()) (us:.Subword (_:.u)) (is:.Subword (i:.j))-    = seq csize . id --  staticCheck (j<=u)-    . flatten mk step . addIndexDenseGo cs vs us is-    where mk   svS = let RiSwI l = getIndex (getIdx $ sS svS) (Proxy :: PRI is (Subword I))-                     in  return $ svS :. (j - l - csize)-          step (svS@(SvS s t y') :. zz)-            | zz >= 0 = do let RiSwI k = getIndex (getIdx s) (Proxy :: PRI is (Subword I))-                               l = j - zz ; kl = subword k l-                           return $ Yield (SvS s (t:.kl) (y' :.: RiSwI l)) (svS :. zz-1)-            | otherwise =  return $ Done-          !csize = minSize c-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline addIndexDenseGo #-}---- |--- @--- Table: Outside--- Grammar: Outside--- @------ TODO Take care of @c@ in all cases to correctly handle @NonEmpty@ tables--- and the like.--instance-  ( IndexHdr s x0 i0 us (Subword O) cs c is (Subword O)-  ) => AddIndexDense s (us:.Subword O) (cs:.c) (is:.Subword O) where-  addIndexDenseGo (cs:.c) (vs:.OStatic (di:.dj)) (us:.u) (is:.Subword (i:.j))-    = map (\(SvS s t y') -> let RiSwO _ _ k _ = getIndex (getIdx s) (Proxy :: PRI is (Subword O))-                                kj = subword k (j+dj)-                            in  SvS s (t:.kj) (y' :.: RiSwO i j k (j+dj)) )-    . addIndexDenseGo cs vs us is-  addIndexDenseGo (cs:.c) (vs:.ORightOf (di:.dj)) (us:.Subword (_:.h)) (is:.Subword (i:.j))-    = flatten mk step . addIndexDenseGo cs vs us is-    where mk svS = return (svS :. j+dj)-          step (svS@(SvS s t y') :. l)-            | l <= h = let RiSwO k _ _ _ = getIndex (getIdx s) (Proxy :: PRI is (Subword O))-                           kl = subword k l-                           jdj = j+dj-                       in  return $ Yield (SvS s (t:.kl) (y' :.: RiSwO jdj jdj k l)) (svS :. l+1)-            | otherwise = return Done-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  addIndexDenseGo _ (_:.OFirstLeft _) _ _ = error "SynVar.Indices.Subword : OFirstLeft"-  addIndexDenseGo _ (_:.OLeftOf    _) _ _ = error "SynVar.Indices.Subword : LeftOf"-  {-# Inline addIndexDenseGo #-}---- |--- @--- Table: Inside--- Grammar: Outside--- @------ TODO take care of @c@--instance-  ( IndexHdr s x0 i0 us (Subword I) cs c is (Subword O)-  , MinSize c-  ) => AddIndexDense s (us:.Subword I) (cs:.c) (is:.Subword O) where-  addIndexDenseGo (cs:.c) (vs:.OStatic (di:.dj)) (us:.u) (is:.Subword (i:.j))-    = map (\(SvS s t y') -> let RiSwO _ k li l = getIndex (getIdx s) (Proxy :: PRI is (Subword O))-                                klI = subword (k-dj) (l-dj)-                            in  SvS s (t:.klI) (y':.:RiSwO (k-dj) (l-dj) li l))-    . addIndexDenseGo cs vs us is-  addIndexDenseGo (cs:.c) (vs:.ORightOf d) (us:.u) (is:.Subword (i:.j))-    = flatten mk step . addIndexDenseGo cs vs us is-    where mk svS = let RiSwO _ l _ _ = getIndex (getIdx $ sS svS) (Proxy :: PRI is (Subword O))-                   in  return (svS :. l :. l + csize)-          step (svS@(SvS s t y') :. k :. l)-            | l <= oj   = return $ Yield (SvS s (t:.klI) (y' :.: RiSwO k l oi oj))-                                         (svS :. k :. l+1)-            | otherwise = return $ Done-            where RiSwO _ _ oi oj = getIndex (getIdx s) (Proxy :: PRI is (Subword O))-                  klI = subword k l-          csize = minSize c-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  addIndexDenseGo (cs:.c) (vs:.OFirstLeft (di:.dj)) (us:.u) (is:.Subword (i:.j))-    = map (\(SvS s t y') -> let RiSwO _ k l lj = getIndex (getIdx s) (Proxy :: PRI is (Subword O))-                                klI = subword k $ i - di-                            in  SvS s (t:.klI) (y' :.: RiSwO k (i-di) l lj))-    . addIndexDenseGo cs vs us is-  addIndexDenseGo (cs:.c) (vs:.OLeftOf d) (us:.u) (is:.Subword (i:.j))-    = flatten mk step . addIndexDenseGo cs vs us is-    where mk svS = let RiSwO _ l _ _ = getIndex (getIdx $ sS svS) (Proxy :: PRI is (Subword O))-                   in  return $ svS :. l-          step (svS@(SvS s t y') :. l)-            | l <= i    = let RiSwO _ k oi oj = getIndex (getIdx s) (Proxy :: PRI is (Subword O))-                              klI = subword k l-                          in  return $ Yield (SvS s (t:.klI) (y' :.: RiSwO k l oi oj))-                                             (svS :. l+1)-            | otherwise = return $ Done-          csize = minSize c-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline addIndexDenseGo #-}------- TODO--- @--- Table: Inside--- Grammar: Complement--- @--instance-  ( IndexHdr s x0 i0 us (Subword I) cs c is (Subword C)-  ) => AddIndexDense s (us:.Subword I) (cs:.c) (is:.Subword C) where-  addIndexDenseGo (cs:.c) (vs:.Complemented) (us:.u) (is:.i)-    = map (\(SvS s t y') -> let kk@(RiSwC ki kj) = getIndex (getIdx s) (Proxy :: PRI is (Subword C))-                            in  SvS s (t:.subword ki kj) (y':.:kk))-    . addIndexDenseGo cs vs us is-  {-# Inline addIndexDenseGo #-}---- TODO--- @--- Table: Outside--- Grammar: Complement--- @--instance-  ( IndexHdr s x0 i0 us (Subword O) cs c is (Subword C)-  ) => AddIndexDense s (us:.Subword O) (cs:.c) (is:.Subword C) where-  addIndexDenseGo (cs:.c) (vs:.Complemented) (us:.u) (is:.i)-    = map (\(SvS s t y') -> let kk@(RiSwC ki kj) = getIndex (getIdx s) (Proxy :: PRI is (Subword C))-                            in  SvS s (t:.subword ki kj) (y':.:kk))-    . addIndexDenseGo cs vs us is-  {-# Inline addIndexDenseGo #-}---- |--- @--- Table: Complement--- Grammar: Complement--- @--instance-  ( IndexHdr s x0 i0 us (Subword C) cs c is (Subword C)-  ) => AddIndexDense s (us:.Subword C) (cs:.c) (is:.Subword C) where-  addIndexDenseGo (cs:.c) (vs:.Complemented) (us:.u) (is:.i)-    = map (\(SvS s t y') -> let k = getIndex (getIdx s) (Proxy :: PRI is (Subword C))-                                RiSwC ki kj = k-                              in  SvS s (t:.subword ki kj) (y':.:k))-    . addIndexDenseGo cs vs us is-  {-# Inline addIndexDenseGo #-}--

@@ -11,8 +11,8 @@  import Data.PrimitiveArray hiding (map) -import ADP.Fusion.Base-import ADP.Fusion.SynVar.Indices.Classes+import ADP.Fusion.Core+import ADP.Fusion.Core.Unit   

@@ -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 #-}--}---}-

@@ -1,12 +0,0 @@--module ADP.Fusion.SynVar.Recursive.Subword where--import Data.Strict.Tuple-import Data.Vector.Fusion.Stream.Monadic-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

@@ -1,6 +1,7 @@  module ADP.Fusion.SynVar.Recursive.Type where +import Control.Applicative (Applicative,(<$>),(<*>)) import Control.Monad.Morph import Data.Proxy import Data.Strict.Tuple@@ -9,10 +10,12 @@  import Data.PrimitiveArray hiding (map) -import ADP.Fusion.Base+import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi import ADP.Fusion.SynVar.Axiom import ADP.Fusion.SynVar.Backtrack-import ADP.Fusion.SynVar.Indices+import ADP.Fusion.SynVar.Indices.Classes+import ADP.Fusion.SynVar.TableWrap   @@ -26,21 +29,26 @@ -- if there is only a (small) constant number of parses of an @IRec@ -- synvar. -data IRec m c i x where+data IRec c i x where   IRec :: { iRecConstraint  :: !c           , iRecFrom        :: !i           , iRecTo          :: !i-          , iRecFun         :: !(i -> i -> m x)-          } -> IRec m c i x+          } -> IRec c i x -instance Build (IRec m c i x)+type TwIRec m c i x = TW (IRec c i x) (i -> i -> m x) -type instance TermArg (IRec m c i x) = x+type TwIRecBt c i x mF mB r = TW (Backtrack (TwIRec mF c i x) mF mB) (i -> i -> mB [r]) -instance GenBacktrackTable (IRec mF c i x) mF mB r where-  data Backtrack (IRec mF c i x) mF mB r = BtIRec !c !i !i !(i -> i -> mB x) !(i -> i -> mB [r])-  type BacktrackIndex (IRec mF c i x) = i-  toBacktrack (IRec c iF iT f) mrph bt = BtIRec c iF iT (\lu i -> mrph $ f lu i) bt+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 !i !i !(i -> i -> mB x) -- !(i -> i -> mB [r])+  type BacktrackIndex (TwIRec mF c i x) = i+  toBacktrack (TW (IRec c iF iT) f) mrph = BtIRec c iF iT (\lu i -> mrph $ f lu i)   {-# Inline toBacktrack #-}  @@ -48,9 +56,9 @@ instance   ( Monad m   , IndexStream i-  ) => Axiom (IRec m c i x) where-  type AxiomStream (IRec m c i x) = m x-  axiom (IRec _ l h fun) = do+  ) => Axiom (TwIRec m c i x) where+  type AxiomStream (TwIRec m c i x) = m x+  axiom (TW (IRec _ l h) fun) = do     k <- head $ streamDown l h     fun h k   {-# Inline axiom #-}@@ -58,52 +66,56 @@ instance   ( Monad mB   , IndexStream i-  ) => Axiom (Backtrack (IRec mF c i x) mF mB r) where-  type AxiomStream (Backtrack (IRec mF c i x) mF mB r) = mB [r]-  axiom (BtIRec c l h fun btfun) = do+  , i ~ j+  , m ~ mB+  ) => Axiom (TW (Backtrack (TwIRec mF c i x) mF mB) (j -> j -> m [r])) where+  type AxiomStream (TW (Backtrack (TwIRec mF c i x) mF mB) (j -> j -> m [r])) = mB [r]+  axiom (TW (BtIRec c l h fun) btfun) = do     k <- head $ streamDown l h     btfun h k   {-# Inline axiom #-}   -instance Element ls i => Element (ls :!: IRec m c u x) i where-  data Elm (ls :!: IRec m c u x) i = ElmIRec !x !(RunningIndex i) !(Elm ls i)-  type Arg (ls :!: IRec m c u x)   = Arg ls :. x+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 :!: (Backtrack (IRec mF c u x) mF mB r)) i where-  data Elm (ls :!: (Backtrack (IRec mF c u x) mF mB r)) i = ElmBtIRec !x [r] !(RunningIndex i) !(Elm ls i)-  type Arg (ls :!: (Backtrack (IRec mF c u x) mF mB r))   = Arg ls :. (x, [r])+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-  ( Monad m+  ( Functor m+  , Monad m   , Element ls (is:.i)   , TableStaticVar (us:.u) (cs:.c) (is:.i)   , AddIndexDense (Elm ls (is:.i)) (us:.u) (cs:.c) (is:.i)   , MkStream m ls (is:.i)-  ) => MkStream m (ls :!: IRec m (cs:.c) (us:.u) x) (is:.i) where-  mkStream (ls :!: IRec c l h fun) vs us is+  ) => MkStream m (ls :!: TwIRec m (cs:.c) (us:.u) x) (is:.i) where+  mkStream (ls :!: TW (IRec c l h) fun) vs us is     = mapM (\(s,tt,ii) -> (\res -> ElmIRec res ii s) <$> fun h tt)     . addIndexDense c vs us is     $ mkStream ls (tableStaticVar (Proxy :: Proxy (us:.u)) c vs is) us (tableStreamIndex (Proxy :: Proxy (us:.u)) c vs is)   {-# Inline mkStream #-}  instance-  ( Monad mB+  ( Applicative mB+  , Monad mB   , Element ls (is:.i)   , TableStaticVar (us:.u) (cs:.c) (is:.i)   , AddIndexDense (Elm ls (is:.i)) (us:.u) (cs:.c) (is:.i)   , MkStream mB ls (is:.i)-  ) => MkStream mB (ls :!: Backtrack (IRec mF (cs:.c) (us:.u) x) mF mB r) (is:.i) where-  mkStream (ls :!: BtIRec c l h fun bt) vs us is+  ) => MkStream mB (ls :!: TwIRecBt (cs:.c) (us:.u) x mF mB r) (is:.i) where+  mkStream (ls :!: TW (BtIRec c l h fun) bt) vs us is     = mapM (\(s,tt,ii) -> (\res bb -> ElmBtIRec res bb ii s) <$> fun h tt <*> bt h tt)     . addIndexDense c vs us is     $ mkStream ls (tableStaticVar (Proxy :: Proxy (us:.u)) c vs is) us (tableStreamIndex (Proxy :: Proxy (us:.u)) c vs is)

@@ -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-

@@ -1,133 +0,0 @@---- |------ TODO Rewrite to use the new index-generating system.------ TODO Take care of minsize constraints! These are somewhat tricky. We--- have one constraint for dimension in the table.--module ADP.Fusion.SynVar.Split.Subword where--import Data.Strict.Tuple-import Data.Proxy-import Data.Vector.Fusion.Stream.Monadic hiding (flatten)-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 I)-  , MkStream m ls (Subword I)-  ) => MkStream m (ls :!: Split uId Fragment (ITbl m arr c j x)) (Subword I) where-  mkStream (ls :!: Split _) (IStatic ()) hh (Subword (i:.j))-    = map (\s -> let RiSwI l = getIdx s-                 in  ElmSplitITbl Proxy () (RiSwI j) 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 $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO (see above) - minSize c))-    where mk s = let RiSwI l = getIdx s in return (s :. j - l) -- TODO - minSize c)-          step (s:.z) | z >= 0 = do let RiSwI k = getIdx s-                                        l       = j - z-                                        kl      = subword k l-                                    return $ Yield (ElmSplitITbl Proxy () (RiSwI l) s) (s:. z-1)-                      | otherwise = return $ Done-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline mkStream #-}--instance-  ( Monad m-  , Element ls (Subword I)-  , MkStream m ls (Subword I)-  , SplitIxCol uId (SameSid uId (Elm ls (Subword I))) (Elm ls (Subword I))-  , (SplitIxTy uId (SameSid uId (Elm ls (Subword I))) (Elm ls (Subword I)) :. Subword I) ~ mix-  , (PrimArrayOps arr (SplitIxTy uId (SameSid uId (Elm ls (Subword I))) (Elm ls (Subword I)) :. Subword I) x)-  , MinSize c-  ) => MkStream m (ls :!: Split uId Final (ITbl m arr (cs:.c) mix x)) (Subword I) where-  mkStream (ls :!: Split (ITbl _ _ (_:.c) t elm)) (IStatic ()) hh (Subword (i:.j))-    = map (\s -> let RiSwI l = getIdx s-                     fmbkm :: mix = collectIx (Proxy :: Proxy uId) s :. subword l j-                 in  ElmSplitITbl Proxy (t ! fmbkm) (RiSwI j) s)-    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))-  mkStream (ls :!: Split (ITbl _ _ (_:.c) t _)) (IVariable ()) hh (Subword (i:.j))-    = flatten mk step $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))-    where mk s = let RiSwI l = getIdx s in return (s :. (delay_inline id $ j - l - minSize c))-          step (s:.z) | z >= 0 = do let RiSwI k      = getIdx s-                                        l            = j - z-                                        kl           = subword k l-                                        fmbkm :: mix = collectIx (Proxy :: Proxy uId) s :. kl-                                    return $ Yield (ElmSplitITbl Proxy (t ! fmbkm) (RiSwI l) 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 I)-  , MkStream mB ls (Subword I)-  ) => MkStream mB (ls :!: Split uId Fragment (Backtrack (ITbl mF arr c j x) mF mB r)) (Subword I) where-  mkStream (ls :!: Split (BtITbl _ _ _)) (IStatic ()) hh (Subword (i:.j))-    = map (\s -> let RiSwI l = getIdx s-                 in  ElmSplitBtITbl Proxy () (RiSwI j) 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 $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO (see above) - minSize c))-    where mk s = let RiSwI l = getIdx s in return (s :. j - l) -- TODO - minSize c)-          step (s:.z) | z >= 0 = do let RiSwI k = getIdx s-                                        l       = j - z-                                        kl      = subword k l-                                    return $ Yield (ElmSplitBtITbl Proxy () (RiSwI l) s) (s:. z-1)-                      | otherwise = return $ Done-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline mkStream #-}--instance-  ( Monad mB-  , Element ls (Subword I)-  , MkStream mB ls (Subword I)-  , SplitIxCol uId (SameSid uId (Elm ls (Subword I))) (Elm ls (Subword I))-  , (SplitIxTy uId (SameSid uId (Elm ls (Subword I))) (Elm ls (Subword I)) :. Subword I) ~ mix-  , (PrimArrayOps arr (SplitIxTy uId (SameSid uId (Elm ls (Subword I))) (Elm ls (Subword I)) :. Subword I) x)-  , MinSize c-  ) => MkStream mB (ls :!: Split uId Final (Backtrack (ITbl mF arr (cs:.c) mix x) mF mB r)) (Subword I) where-  mkStream (ls :!: Split (BtITbl (_:.c) t bt)) (IStatic ()) hh (Subword (i:.j))-    = mapM (\s -> let RiSwI 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) (RiSwI j) s)-    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))-  mkStream (ls :!: Split (BtITbl (_:.c) t bt)) (IVariable ()) hh (Subword (i:.j))-    = flatten mk step $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j))-    where mk s = let RiSwI l = getIdx s in return (s :. (delay_inline id $ j - l - minSize c))-          step (s:.z) | z >= 0 = do let RiSwI 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) (RiSwI l) s) (s:. z-1)-                      | otherwise = return $ Done-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline mkStream #-}-

@@ -19,9 +19,11 @@  import Data.PrimitiveArray hiding (map) -import ADP.Fusion.Base+import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi import ADP.Fusion.SynVar.Array.Type import ADP.Fusion.SynVar.Backtrack+import ADP.Fusion.SynVar.TableWrap   @@ -68,26 +70,28 @@  instance   ( Element ls i-  ) => Element (ls :!: Split uId splitType (ITbl m arr c j x)) i where-  data Elm     (ls :!: Split uId splitType (ITbl m arr c j x)) i = ElmSplitITbl !(Proxy uId) !(CalcSplitType splitType x) !(RunningIndex i) !(Elm ls i)-  type Arg     (ls :!: Split uId splitType (ITbl m arr c j x))   = Arg ls :. (CalcSplitType splitType x)-  type RecElm  (ls :!: Split uId splitType (ITbl m arr c j x)) i = Elm ls i-  getArg (ElmSplitITbl _ x _ ls) = getArg ls :. x-  getIdx (ElmSplitITbl _ _ i _ ) = i-  getElm (ElmSplitITbl _ _ _ ls) = ls+  ) => Element (ls :!: Split uId splitType (TwITbl 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 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 m arr c j x))   = Arg ls :. (CalcSplitType splitType x)+  type RecElm  (ls :!: Split uId splitType (TwITbl 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 (Backtrack (ITbl mF arr c j x) mF mB r)) i where-  data Elm     (ls :!: Split uId splitType (Backtrack (ITbl mF arr c j x) mF mB r)) i = ElmSplitBtITbl !(Proxy uId) !(CalcSplitType splitType (x, [r])) !(RunningIndex i) !(Elm ls i)-  type Arg     (ls :!: Split uId splitType (Backtrack (ITbl mF arr c j x) mF mB r))   = Arg ls :. (CalcSplitType splitType (x,[r]))-  type RecElm  (ls :!: Split uId splitType (Backtrack (ITbl mF 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+  ) => Element (ls :!: Split uId splitType (TwITblBt arr c j x mF mB r)) i where+  data Elm     (ls :!: Split uId splitType (TwITblBt 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 arr c j x mF mB r))   = Arg ls :. (CalcSplitType splitType (x,[r]))+  type RecElm  (ls :!: Split uId splitType (TwITblBt 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 #-}@@ -174,16 +178,16 @@  instance   ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)-  ) => SplitIxCol   uId True (Elm (ls :!: Split sId splitType (ITbl m arr c j x)) i) where-  type SplitIxTy uId True (Elm (ls :!: Split sId splitType (ITbl m arr c j x)) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i) :. i-  splitIxCol p b (ElmSplitITbl _ _ i e) = collectIx p e :. (error "splitIxCol: RunningIndex i -> i conversion?") -- i+  ) => SplitIxCol   uId True (Elm (ls :!: Split sId splitType (TwITbl m arr c j x)) i) where+  type SplitIxTy uId True (Elm (ls :!: Split sId splitType (TwITbl 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 (Backtrack (ITbl mF arr c j x) mF mB r)) i) where-  type SplitIxTy uId True (Elm (ls :!: Split sId splitType (Backtrack (ITbl mF 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) = collectIx p e :. (error "splitIxCol: RunningIndex i -> i conversion?") -- i+  ) => SplitIxCol   uId True (Elm (ls :!: Split sId splitType (TwITblBt arr c j x mF mB r)) i) where+  type SplitIxTy uId True (Elm (ls :!: Split sId splitType (TwITblBt 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@@ -191,6 +195,6 @@   , 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))+  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 #-} 

@@ -0,0 +1,11 @@++-- | Wrap the underlying table and the rules. Isomorphic to @(,)@.++module ADP.Fusion.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

@@ -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 []--}--

@@ -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 _                = []-

@@ -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-

@@ -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-

@@ -1,199 +0,0 @@--module ADP.Fusion.Term.Chr-  ( module ADP.Fusion.Term.Chr.Type-  , module ADP.Fusion.Term.Chr.Point-  , module ADP.Fusion.Term.Chr.Set0-  , module ADP.Fusion.Term.Chr.Subword-  ) where--import ADP.Fusion.Term.Chr.Point-import ADP.Fusion.Term.Chr.Set0-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 #-}--}---}----}-

@@ -9,10 +9,9 @@  import           Data.PrimitiveArray -import           ADP.Fusion.Base+import           ADP.Fusion.Core+import           ADP.Fusion.Core.Point import           ADP.Fusion.Term.Chr.Type--import           ADP.Fusion.Base.Term   

@@ -1,65 +0,0 @@---- | @Chr@ on sets is equivalent to having a @Vertex@ symbol. Each bit--- denotes one vertex point.--module ADP.Fusion.Term.Chr.Set0 where--import           Data.Proxy-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.Bits-import           Data.Bits.Extras (msb,Ranked)-import           Data.Bits.Ordered--import           Data.PrimitiveArray hiding (map)--import           ADP.Fusion.Base-import           ADP.Fusion.Term.Chr.Type----instance-  ( TmkCtx1 m ls (Chr r x) (BitSet i)-  ) => MkStream m (ls :!: Chr r x) (BitSet i) where-  mkStream (ls :!: Chr f xs) sv us is-    = S.map (\(ss,ee,ii) -> ElmChr ee ii ss)-    . addTermStream1 (Chr f xs) sv us is-    $ mkStream ls (termStaticVar (Chr f xs) sv is) us (termStreamIndex (Chr f xs) sv is)-  {-# Inline mkStream #-}--instance-  ( TstCtx m ts s x0 i0 is (BitSet I)-  , Ranked (BitSet I)-  ) => TermStream m (TermSymbol ts (Chr r x)) s (is:.BitSet I) where-  termStream (ts:|Chr f xs) (cs:.IStatic rb) (us:.u) (is:.i)-    = staticCheck (rb <= popCount i && i <= u && VG.length xs > msb u)-    . S.flatten mk step . termStream ts cs us is-          -- we task all set bits @bs@ and also the index @i@ and calculate-          -- the non-set bits @mask@. The mask should have a popcount equal-          -- to @rb + 1@. We then active bit 0 and proceed with @step@.-    where mk svS = let RiBsI bs = getIndex (getIdx $ tS svS) (Proxy :: PRI is (BitSet I))-                       mask = i `xor` bs-                   in  return (svS :. mask :. lsbZ mask)-          -- In case we can still do a step via @k>=0@, we active bit @k@-          -- in @aa@.-          step (svS@(TState s ii ee) :. mask :. k )-            | k < 0 = return $ Done-            | otherwise =-            let RiBsI aa = getIndex (getIdx s) (Proxy :: PRI is (BitSet I))-            in  return $ Yield (TState s (ii:.: RiBsI (setBit aa k)) (ee:.f xs k))-                               (svS :. mask :. nextActiveZ k mask)-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline termStream #-}--instance TermStaticVar (Chr r x) (BitSet I) where-  termStaticVar _ (IStatic   rb) _ = IStatic   $ rb + 1-  termStaticVar _ (IVariable rb) _ = IVariable $ rb + 1-  termStreamIndex _ _ b = b-  {-# Inline [0] termStaticVar   #-}-  {-# Inline [0] termStreamIndex #-}-

@@ -1,98 +0,0 @@--module ADP.Fusion.Term.Chr.Subword where--import           Data.Proxy-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-  ( TmkCtx1 m ls (Chr r x) (Subword i)-  ) => MkStream m (ls :!: Chr r x) (Subword i) where-  mkStream (ls :!: Chr f xs) sv us is-    = S.map (\(ss,ee,ii) -> ElmChr ee ii ss)-    . addTermStream1 (Chr f xs) sv us is-    $ mkStream ls (termStaticVar (Chr f xs) sv is) us (termStreamIndex (Chr f xs) sv is)-  {-# Inline mkStream #-}------ |------ NOTE We do not run 'staticCheck'. Running @staticCheck@ costs about--- @10%@ performance and we assume that the frontend will take care of--- correct indices anyway.--instance-  ( TstCtx m ts s x0 i0 is (Subword I)-  ) => TermStream m (TermSymbol ts (Chr r x)) s (is:.Subword I) where-  termStream (ts:|Chr f xs) (cs:.IStatic ()) (us:.u) (is:.Subword (i:.j))-    = id -- staticCheck (i>=0 && i < j && j <= VG.length xs)-    . map (\(TState s ii ee) ->-              TState s (ii:.: RiSwI j) (ee:.f xs (j-1)) )-    . termStream ts cs us is-  ---  termStream (ts:|Chr f xs) (cs:.IVariable ()) (us:.u) (is:.Subword (i:.j))-    = map (\(TState s ii ee) ->-              let RiSwI l = getIndex (getIdx s) (Proxy :: PRI is (Subword I))-              in  TState s (ii:.:RiSwI (l+1)) (ee:.f xs l) )-    . termStream ts cs us is-  {-# Inline termStream #-}--instance-  ( TstCtx m ts s x0 i0 is (Subword O)-  ) => TermStream m (TermSymbol ts (Chr r x)) s (is:.Subword O) where-  termStream (ts:|Chr f xs) (cs:.OStatic (di:.dj)) (us:.u) (is:.Subword (i:.j))-    = map (\(TState s ii ee) ->-              let RiSwO _ k oi oj = getIndex (getIdx s) (Proxy :: PRI is (Subword O))-                  l              = k - dj-              in  TState s (ii:.: RiSwO k (k+1) oi oj) (ee:.f xs k) )-    . termStream ts cs us is-  ---  termStream (ts:|Chr f xs) (cs:.ORightOf (di:.dj)) (us:.u) (is:.i)-    = map (\(TState s ii ee) ->-              let RiSwO _ k oi oj = getIndex (getIdx s) (Proxy :: PRI is (Subword O))-                  l              = k - dj - 1-              in  TState s (ii:.:RiSwO (k-1) k oi oj) (ee:.f xs l) )-    . termStream ts cs us is-  ---  termStream (ts:|Chr f xs) (cs:.OFirstLeft (di:.dj)) (us:.u) (is:.i)-    = map (\(TState s ii ee) ->-              let RiSwO _ k oi oj = getIndex (getIdx s) (Proxy :: PRI is (Subword O))-              in  TState s (ii:.:RiSwO k (k+1) oi oj) (ee:.f xs k) )-    . termStream ts cs us is-  ---  termStream (ts:|Chr f xs) (cs:.OLeftOf (di:.dj)) (us:.u) (is:.i)-    = map (\(TState s ii ee) ->-              let RiSwO _ k oi oj = getIndex (getIdx s) (Proxy :: PRI is (Subword O))-              in  TState s (ii:.:RiSwO k (k+1) oi oj) (ee:.f xs k) )-    . termStream ts cs us is-  {-# Inline termStream #-}----instance TermStaticVar (Chr r x) (Subword I) where-  termStaticVar _ sv _ = sv-  termStreamIndex _ _ (Subword (i:.j)) = subword i (j-1)-  {-# Inline [0] termStaticVar   #-}-  {-# Inline [0] termStreamIndex #-}--instance TermStaticVar (Chr r x) (Subword O) where-  termStaticVar _ (OStatic    (di:.dj)) _ = OStatic    (di  :.dj+1)-  termStaticVar _ (ORightOf   (di:.dj)) _ = ORightOf   (di  :.dj+1)-  termStaticVar _ (OFirstLeft (di:.dj)) _ = OFirstLeft (di+1:.dj  )-  termStaticVar _ (OLeftOf    (di:.dj)) _ = OLeftOf    (di+1:.dj  )-  termStreamIndex _ _ sw = sw-  {-# Inline [0] termStaticVar   #-}-  {-# Inline [0] termStreamIndex #-}-

@@ -12,7 +12,9 @@  import           Data.PrimitiveArray -import           ADP.Fusion.Base+import           ADP.Fusion.Core.Classes+import           ADP.Fusion.Core.Multi+   -- | A generic Character parser that reads a single character but allows

@@ -1,80 +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-  , module ADP.Fusion.Term.Deletion.Unit-  ) where--import ADP.Fusion.Term.Deletion.Point-import ADP.Fusion.Term.Deletion.Subword-import ADP.Fusion.Term.Deletion.Type-import ADP.Fusion.Term.Deletion.Unit---{--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 #-}--}---}-

@@ -7,7 +7,8 @@  import           Data.PrimitiveArray -import           ADP.Fusion.Base+import           ADP.Fusion.Core+import           ADP.Fusion.Core.Point import           ADP.Fusion.Term.Deletion.Type  

@@ -1,91 +0,0 @@--module ADP.Fusion.Term.Deletion.Subword where--import Data.Proxy-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-  ( TmkCtx1 m ls Deletion (Subword i)-  ) => MkStream m (ls :!: Deletion) (Subword i) where-  mkStream (ls :!: Deletion) sv us is-    = map (\(ss,ee,ii) -> ElmDeletion ii ss)-    . addTermStream1 Deletion sv us is-    $ mkStream ls (termStaticVar Deletion sv is) us (termStreamIndex Deletion sv is)-  {-# Inline mkStream #-}----instance-  ( TstCtx m ts s x0 i0 is (Subword I)-  ) => TermStream m (TermSymbol ts Deletion) s (is:.Subword I) where-  termStream (ts:|Deletion) (cs:.IStatic d) (us:.u) (is:.Subword (i:.j))-    = S.map (\(TState s ii ee) -> TState s (ii:.:RiSwI j) (ee:.()) )-    . termStream ts cs us is-  termStream (ts:|Deletion) (cs:.IVariable d) (us:.u) (is:.Subword (i:.j))-    = S.map (\(TState s ii ee) ->-                let l = getIndex (getIdx s) (Proxy :: PRI is (Subword I))-                in  TState s (ii:.:l) (ee:.()) )-    . termStream ts cs us is-  {-# Inline termStream #-}--instance-  ( TstCtx m ts s x0 i0 is (Subword O)-  ) => TermStream m (TermSymbol ts Deletion) s (is:.Subword O) where-  -- X_ij  -> Y_ik  Z_kj  d_jj        0   i Y k Z j-j   N-  -- Y^_ik -> X^_ij Z_kj  d_jj        0 x i   k Z j-j x N-  -- Z^_kj -> Y_ik  X^_ij d_jj        0 x i Y k   j-j x N-  termStream (ts:|Deletion) (cs:._) (us:.u) (is:.Subword (i:.j))-    = S.map (\(TState s ii ee) ->-                let RiSwO _ k oi oj = getIndex (getIdx s) (Proxy :: PRI is (Subword O))-                in  TState s (ii:.:RiSwO k k oi oj) (ee:.()) )-    . termStream ts cs us is-  {--  termStream (ts:|Deletion) (cs:.OStatic (di:.dj)) (us:.u) (is:.Subword (i:.j))-    = S.map (\(TState s a ii ee) ->-                let RiSwO _ k oi oj = getIndex a (Proxy :: PRI is (Subword O))-                in  TState s a (ii:.:RiSwO k k oi oj) (ee:.()) )-    . termStream ts cs us is-  ---  termStream (ts:|Deletion) (cs:.ORightOf (di:.dj)) (us:.u) (is:.Subword (i:.j))-    = S.map (\(TState s a ii ee) ->-                let RiSwO _ k oi oj = getIndex a (Proxy :: PRI is (Subword O))-                in  TState s a (ii:.:RiSwO k k oi oj) (ee:.()) )-    . termStream ts cs us is-  ---  termStream (ts:|Deletion) (cs:.OFirstLeft (di:.dj)) (us:.u) (is:.Subword (i:.j))-    = S.map (\(TState s a ii ee) ->-                let RiSwO _ k oi oj = getIndex a (Proxy :: PRI is (Subword O))-                in  TState s a (ii:.:RiSwO k k oi oj) (ee:.()) )-    . termStream ts cs us is-  ---  termStream (ts:|Deletion) (cs:.OLeftOf (di:.dj)) (us:.u) (is:.Subword (i:.j))-    = S.map (\(TState s a ii ee) ->-                let RiSwO _ k oi oj = getIndex a (Proxy :: PRI is (Subword O))-                in  TState s a (ii:.: RiSwO k k oi oj) (ee:.()) )-    . termStream ts cs us is-  -}-  {-# Inline termStream #-}----instance TermStaticVar Deletion (Subword I) where-  termStaticVar _ sv _ = sv-  termStreamIndex _ _ ij = ij-  {-# Inline [0] termStaticVar   #-}-  {-# Inline [0] termStreamIndex #-}--instance TermStaticVar Deletion (Subword O) where-  termStaticVar _ sv _ = sv-  termStreamIndex _ _ ij = ij-  {-# Inline [0] termStaticVar   #-}-  {-# Inline [0] termStreamIndex #-}-

@@ -5,7 +5,8 @@  import Data.PrimitiveArray -import ADP.Fusion.Base+import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi   

@@ -7,8 +7,8 @@  import           Data.PrimitiveArray -import           ADP.Fusion.Base-import           ADP.Fusion.Term.Deletion.Type+import           ADP.Fusion.Core+import           ADP.Fusion.Core.Unit   

@@ -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 #-}--}-

@@ -1,72 +0,0 @@--module ADP.Fusion.Term.Edge.Set where--import Data.Bits-import Data.Strict.Tuple-import Data.Vector.Fusion.Stream.Monadic hiding (flatten)-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 (BS2 First Last I)-  , MkStream m ls (BS2 First Last I)-  ) => MkStream m (ls :!: Edge e) (BS2 First Last I) where-  mkStream (ls :!: Edge f) (IStatic rp) u sij@(BS2 s i j)-    = flatten mk step $ mkStream ls (IStatic rpn) u tik-    where rpn | j >= 0    = rp-              | otherwise = rp+1-          tik | j >= 0    = BS2 (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 RiBs2I (BS2 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)) (RiBs2I sij) z) Naught-            where RiBs2I (BS2 zs _ zk) = getIdx z-          step (That (z,bits,Nothing)) = return $ Done-          step (That (z,bits,Just j')) = let RiBs2I (BS2 zs _ (Iter zk)) = getIdx z-                                             tij'                        = BS2 (zs .|. bit j') (Iter zk) (Iter j')-                                         in  return $ Yield (ElmEdge (f zk j') (RiBs2I tij') z) (That (z,bits,maybeNextActive j' bits))-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline mkStream #-}----instance-  ( Monad m-  , Element ls    (BS2 First Last O)-  , MkStream m ls (BS2 First Last O)-  ) => MkStream m (ls :!: Edge f) (BS2 First Last O) where-  mkStream (ls :!: Edge f) (OStatic ()) u sij-    = map undefined-    $ mkStream ls (undefined) u sij-  {-# Inline mkStream #-}----instance-  ( Monad m-  , Element ls    (BS2 First Last C)-  , MkStream m ls (BS2 First Last C)-  ) => MkStream m (ls :!: Edge f) (BS2 First Last C) where-  mkStream (ls :!: Edge f) Complemented u sij-    = map undefined-    $ mkStream ls Complemented u sij-  {-# Inline mkStream #-}-

@@ -5,7 +5,8 @@  import Data.PrimitiveArray -import ADP.Fusion.Base+import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi   

@@ -1,120 +0,0 @@--module ADP.Fusion.Term.Epsilon-  ( module ADP.Fusion.Term.Epsilon.Type-  , module ADP.Fusion.Term.Epsilon.Point-  , module ADP.Fusion.Term.Epsilon.Set-  , module ADP.Fusion.Term.Epsilon.Subword-  , module ADP.Fusion.Term.Epsilon.Unit-  ) where--import ADP.Fusion.Term.Epsilon.Point-import ADP.Fusion.Term.Epsilon.Set-import ADP.Fusion.Term.Epsilon.Subword-import ADP.Fusion.Term.Epsilon.Type-import ADP.Fusion.Term.Epsilon.Unit--{---{-# 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 #-}--}---}-

@@ -7,7 +7,8 @@  import           Data.PrimitiveArray -import           ADP.Fusion.Base+import           ADP.Fusion.Core+import           ADP.Fusion.Core.Point import           ADP.Fusion.Term.Epsilon.Type  

@@ -1,97 +0,0 @@--module ADP.Fusion.Term.Epsilon.Set where--import Data.Proxy-import Data.Strict.Tuple-import Data.Vector.Fusion.Stream.Monadic as S-import Prelude hiding (map)--import Data.Bits.Ordered-import Data.PrimitiveArray hiding (map)--import ADP.Fusion.Base-import ADP.Fusion.Term.Epsilon.Type------ ** No boundaries--instance-  ( TmkCtx1 m ls Epsilon (BitSet i)-  ) => MkStream m (ls :!: Epsilon) (BitSet i) where-  mkStream (ls :!: Epsilon) sv us is-    = map (\(ss,ee,ii) -> ElmEpsilon ii ss)-    . addTermStream1 Epsilon sv us is-    $ mkStream ls (termStaticVar Epsilon sv is) us (termStreamIndex Epsilon sv is)-  {-# Inline mkStream #-}----instance-  ( TstCtx m ts s x0 i0 is (BitSet I)-  ) => TermStream m (TermSymbol ts Epsilon) s (is:.BitSet I) where-  termStream (ts:|Epsilon) (cs:.IStatic r) (us:.u) (is:.i)-    = staticCheck (i==0)-    . map (\(TState s ii ee) ->-              TState s (ii:.:RiBsI 0) (ee:.()) )-    . termStream ts cs us is-  {-# Inline termStream #-}--instance-  ( TstCtx m ts s x0 i0 is (BitSet O)-  ) => TermStream m (TermSymbol ts Epsilon) s (is:.BitSet O) where-  termStream (ts:|Epsilon) (cs:.OStatic r) (us:.u) (is:.i)-    = staticCheck (i==u)-    . map (\(TState s ii ee) ->-              TState s (ii:.:RiBsO u u) (ee:.()) )-    . termStream ts cs us is-  {-# Inline termStream #-}----instance TermStaticVar Epsilon (BitSet I) where-  termStaticVar _ sv _ = sv-  termStreamIndex _ _ b = b-  {-# Inline [0] termStaticVar #-}-  {-# Inline [0] termStreamIndex #-}--instance TermStaticVar Epsilon (BitSet O) where-  termStaticVar _ sv _ = sv-  termStreamIndex _ _ b = b-  {-# Inline [0] termStaticVar #-}-  {-# Inline [0] termStreamIndex #-}------ ** Two boundaries--instance-  ( TmkCtx1 m ls Epsilon (BS2 First Last i)-  ) => MkStream m (ls :!: Epsilon) (BS2 First Last i) where-  mkStream (ls :!: Epsilon) sv us is-    = map (\(ss,ee,ii) -> ElmEpsilon ii ss)-    . addTermStream1 Epsilon sv us is-    $ mkStream ls (termStaticVar Epsilon sv is) us (termStreamIndex Epsilon sv is)-  {-# Inline mkStream #-}--instance-  ( TstCtx m ts s x0 i0 is (BS2 First Last I)-  ) => TermStream m (TermSymbol ts Epsilon) s (is:.BS2 First Last I) where-  termStream (ts:|Epsilon) (cs:.IStatic r) (us:.u) (is:.BS2 bs _ _)-    = staticCheck (bs==0)-    . map (\(TState s ii ee) ->-              TState s (ii:.:RiBs2I (BS2 0 0 0)) (ee:.()) )-    . termStream ts cs us is-  {-# Inline termStream #-}--instance-  ( TstCtx m ts s x0 i0 is (BS2 First Last O)-  ) => TermStream m (TermSymbol ts Epsilon) s (is:.BS2 First Last O) where-  termStream (ts:|Epsilon) (cs:.OStatic r) (us:.BS2 ub uf ul) (is:.BS2 bs f l)-    = staticCheck (ub==bs)-    . map (\(TState s ii ee) ->-              let io = getIndex (getIdx s) (Proxy :: PRI is (BS2 First Last O))-              in  TState s (ii:.:io) (ee:.()) )-    . termStream ts cs us is-  {-# Inline termStream #-}-

@@ -1,61 +0,0 @@--module ADP.Fusion.Term.Epsilon.Subword where--import Data.Proxy-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----instance-  ( TmkCtx1 m ls Epsilon (Subword i)-  ) => MkStream m (ls :!: Epsilon) (Subword i) where-  mkStream (ls :!: Epsilon) sv us is-    = map (\(ss,ee,ii) -> ElmEpsilon ii ss)-    . addTermStream1 Epsilon sv us is-    $ mkStream ls (termStaticVar Epsilon sv is) us (termStreamIndex Epsilon sv is)-  {-# Inline mkStream #-}----instance-  ( TstCtx m ts s x0 i0 is (Subword I)-  ) => TermStream m (TermSymbol ts Epsilon) s (is:.Subword I) where-  termStream (ts:|Epsilon) (cs:.IStatic ()) (us:.u) (is:.Subword (i:.j))-    = map (\(TState s ii ee) ->-              TState s (ii:.:RiSwI j) (ee:.()) )-    . termStream ts cs us is-    . staticCheck (i==j)-  {-# Inline termStream #-}--instance-  ( TstCtx m ts s xi0 i0 is (Subword O)-  ) => TermStream m (TermSymbol ts Epsilon) s (is:.Subword O) where-  termStream (ts:|Epsilon) (cs:.OStatic d) (us:.Subword (ui:.uj)) (is:.Subword (i:.j))-    = staticCheck (ui == i && uj == j) -- TODO correct ?-    . map (\(TState s ii ee) ->-              let io = getIndex (getIdx s) (Proxy :: PRI is (Subword O))-              in  TState s (ii:.:io) (ee:.()) )-    . termStream ts cs us is-  {-# Inline termStream #-}----instance TermStaticVar Epsilon (Subword I) where-  termStaticVar _ sv _ = sv-  termStreamIndex _ _ ij = ij-  {-# Inline [0] termStaticVar #-}-  {-# Inline [0] termStreamIndex #-}--instance TermStaticVar Epsilon (Subword O) where-  termStaticVar _ sv _ = sv-  termStreamIndex _ _ ij = ij-  {-# Inline [0] termStaticVar #-}-  {-# Inline [0] termStreamIndex #-}-

@@ -5,7 +5,8 @@  import Data.PrimitiveArray -import ADP.Fusion.Base+import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi   

@@ -7,8 +7,8 @@  import           Data.PrimitiveArray -import           ADP.Fusion.Base-import           ADP.Fusion.Term.Epsilon.Type+import           ADP.Fusion.Core+import           ADP.Fusion.Core.Unit   

@@ -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

@@ -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 (Subword C)-  , MkStream m ls (Subword C)-  ) => MkStream m (ls :!: PeekIndex (Subword C)) (Subword C) where-  mkStream (ls :!: PeekIndex) Complemented h ij-    = map (\s -> let ri@(RiSwC k l) = getIdx s in ElmPeekIndex (subword k l) ri s)-    $ mkStream ls Complemented h ij-  {-# Inline mkStream #-}-

@@ -5,7 +5,8 @@  import Data.PrimitiveArray -import ADP.Fusion.Base+import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi   

@@ -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-

@@ -9,7 +9,8 @@  import           Data.PrimitiveArray -import           ADP.Fusion.Base+import           ADP.Fusion.Core+import           ADP.Fusion.Core.Point import           ADP.Fusion.Term.Strng.Type  

@@ -1,84 +0,0 @@--module ADP.Fusion.Term.Strng.Subword where--import           Data.Proxy-import           Data.Strict.Tuple-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----instance-  ( TmkCtx1 m ls (Strng v x) (Subword i)-  ) => MkStream m (ls :!: Strng v x) (Subword i) where-  mkStream (ls :!: strng) sv us is-    = S.map (\(ss,ee,ii) -> ElmStrng ee ii ss)-    . addTermStream1 strng sv us is-    $ mkStream ls (termStaticVar strng sv is) us (termStreamIndex strng sv is)-  {-# Inline mkStream #-}--instance-  ( TstCtx m ts s x0 i0 is (Subword I)-  ) => TermStream m (TermSymbol ts (Strng v x)) s (is:.Subword I) where-  ---  termStream (ts:|Strng f minL maxL v) (cs:.IStatic d) (us:.Subword (ui:.uj)) (is:.Subword (i:.j))-    = S.filter (\(TState s _ _) ->-                    -- let Subword (k:.l) = getIndex a (Proxy :: Proxy (is:.Subword I))-                    let RiSwI l = getIndex (getIdx s) (Proxy :: PRI is (Subword I))-                        -- RiSwI k = getIndex (getIdx $ getElm s) (Proxy :: PRI is (Subword I))-                        k = undefined-                    in l-k <= maxL)-    . S.map (\(TState s ii ee) ->-                --let Subword (_:.l) = getIndex a (Proxy :: Proxy (is:.Subword I))-                --    o              = getIndex b (Proxy :: Proxy (is:.Subword I))-                let RiSwI l = getIndex (getIdx s) (Proxy :: PRI is (Subword I))-                in  TState s (ii:.:RiSwI j) (ee:.f l (j-l) v) )-    . termStream ts cs us is-  ---  termStream (ts:|Strng f minL maxL v) (cs:.IVariable d) (us:._) (is:.Subword (i:.j))-    = S.flatten mk step . termStream ts cs us is-    where mk (tstate@(TState s ii ee)) =-            let RiSwI k = getIndex (getIdx s) (Proxy :: PRI is (Subword I))-            in  return (tstate, k+minL, min j (k+maxL))-          step = undefined-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline termStream #-}--{----- | TODO If we use (IVariable mx) we might be able to request @exactly@--- the range we need!--instance-  ( Monad m-  , Element ls (Subword I)-  , MkStream m ls (Subword I)-  ) => MkStream m (ls :!: Strng v x) (Subword I) 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 $ 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 #-}---}-

@@ -6,7 +6,8 @@  import           Data.PrimitiveArray -import           ADP.Fusion.Base+import           ADP.Fusion.Core.Classes+import           ADP.Fusion.Core.Multi   

@@ -0,0 +1,495 @@++{-# Options_GHC -fno-warn-unused-imports #-}++{-|++The Needleman-Wunsch global alignment algorithm. This algorithm is+extremely simple but provides a good showcase for what ADPfusion offers.++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>++++Don't forget to inline basically everything!++-}++module ADP.Fusion.Tutorial.NeedlemanWunsch+  (+  -- * Module Header+  -- $header++  -- * Signature+  -- $signature++  -- * Algebra Product+  -- $algebraproduct++  -- * Grammar+  -- $grammar++  -- * Scoring Algebra+  -- $algebrascore++  -- * Pretty-printing Algebra+  -- $algebrapretty++  -- * The @Inside@ version++  -- ** Table-filling for the @Inside@ version+  -- $insideforward++  -- ** Backtracking optimal results for the @Inside@ version+  -- $insidebacktrack++  -- ** Glueing the @Inside@ version parts together+  -- $runforward++  -- * The @Outside@ version++  -- ** Table-filling for the @Outside@ version+  -- $outsideforward++  -- ** Backtracking optimal results for the @Outside@ version+  -- $outsidebacktrack++  -- ** Glueing the @Outside@ version parts together+  -- $runoutside++  -- * Wrapping everything up++  -- ** Alignment wrapper+  -- $alignwrapper++  -- ** Main+  -- $main++  ) where++import ADP.Fusion.Point++{- $header++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.++We also need to import @ADP.Fusion@ to access the high-level code for+dynamic programs.+++> module Main where++> import           Control.Monad (forM_)+> import           System.Environment (getArgs)+> 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++@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 set+data structures are made available.++> import           Data.PrimitiveArray as PA hiding (map)++@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.Point++-}++++{- $signature++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.++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 characters with+type @c@ and produce a new non-terminal typed score @x@.  For our simple+alignment we'll later choose @Char@ for @c@ and @Int@ for @x@.++The type of @h :: Stream m x -> m r@ is more interesting. We get a @Stream@+of @x@'s and produce an @r@ monadically. The left part is clear @Stream+m x@ are the results from the four rules, but the right part allows us to+maybe not only return the best case, types @x == r@, but maybe the two best+cases @r == (x,x)@ or similar. While we do not use this feature here, it+makes ADPfusion fully "classified DP" 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+>   }++-}++++{- $algebraproduct++We also want to be able to backtrace the optimal result. Given our+alignment, knowing that we get an alignment score of 29 doesn't help us+much. But with /algebra products/ we can ask for @(optimal <** pretty)@ and+get the optimal result /and/ the parse for it.++The @(<**)@ operator is notoriously difficult to write, so we just compute+it ☺.++Note that haddock actually shows @(<**)@, while you just write+@makeAlgebraProductH ['h] ''Signature@ (the primes are TemplateHaskell,+the only TemplateHaskell we need).++> makeAlgebraProduct ''Signature++-}++++{- $grammar++This is the linear grammar in two dimensions describing the+"Needleman-Wunsch" search space. It will, in principle, enumerate the+exponential number of possible alignment, but due to memoization and the+choice function @h@, the calculation time is @O(N^2)@ and if only one+optimal alignment is requested, backtracking works in linear time.++The grammar first requires a 'Signature', we use @RecordWildCards@ as+a language extension to bind @step_step@ and friends. We also need+a variable for the single non-terminal (@a@), and have two inputs @i1@ and+@i2@. Each grammar starts with a "base case" @Z:.@ followed by one or more+pairs of non-terminal plus rules. Here we have one pair @(a, rules)@, where+in @rules@ we combine the four different rules.++@step_step \<\<\< a % (M:>chr i1:>chr i2)@, for example, means that+@step_step@ first gets the non-terminal @a@, which will give the score up+to @d@ (see the ascii-art above), followed by @(%)@ the 2-dim terminal for+@i1@ and @i2@.++Multi-dimensional terminals are built up from the zero-dimension @M@,+separated by @:|@ symbols and just bind the input. In this case we want+individual characters from @i1@ and @i2@, so we write @chr i1@ or @chr i2@.++Different rules are combined with @(|||)@ and the optimal case is selected+via @... h@. Rules can, of course, be co-recursive, each rule can request+all terminal and non-terminal symbols.++Due to the way @nil_nil@ works on @Epsilon@, @nil_nil@ is actually /only/+called once, when we start the alignment, not for every cell!++/However/, due to this being a high-performance library, we do not provide+a runtime scheme to detect misbehaving rules. Some debug-code is in place+that performs certain checks in non-optimized GHCI sessions, but optimized+code is built for raw speed, without any checks.++If you are a "conventional" DP programmer, you might miss the usual+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 = 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:|Epsilon)       ... h+>                 )+>   in Z:.a+@+\{\-\# INLINE grammar \#\-\}+@++-}++++{- $algebrascore++A grammar alone is not enough, we also need to say what a @step_step@+means, or what an optimum is. Here, we do exactly that. We create an+instance of the 'Signature' from above. Since this is a simple example, we+just say that two aligned characters @a@ and @b@ yield a score of @x+1@+(with @x@ the previous alignment score) if the characters are identical.+Otherwise we lower the score by 2. In/dels incur a cost of @-1@, meaning+that a mismatch is actually the same as two in/dels, one in each dimension.+The start of the alignment gives an initial score of 0.++And the optimal choice, of course, is to start with a default of @-999999@+and find the maximum of that score and the choices we are given.++> 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+>   , h = SM.foldl' max (-999999)+>   }+@+\{\-\# INLINE sScore \#\-\}+@++-}++++{- $algebrapretty++Scores alone are still not enough, we also want to pretty-print alignments.+An alignment are basically two strings @[String 1, String 2]@, being turned+into a whole stream of alignments, using @Char@s for the individual+characters being aligned.++We follow the same theme as in 'sScore', but this time @h = toList@, that+is the choice function @h@ does not (!) make choice but rather returns all+alignments. You already heard about @<**@, we'll use it below.++> 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 \#\-\}+@++-}++++{- $insideforward++The forward or table-filling phase. It is possible to inline this code+directly into 'runNeedlemanWunsch'. Here, this phase is separated. If you+use @ghc-core@ to examine the @GHC Core@ language, you can search for+@nwInsideForward@ and check wether the inside code is optimized well. This+is normally /not/ required, and only done here, because these algorithms+are used to gauge efficiency of the fusion framework as well.++For your own code, you can write as done here, or in the way of+'runOutsideNeedlemanWunsch'.++> nwInsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.TwITbl 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 \#\-\}+@++We normally do not want to inline a fully specified algorithm. Compilation+times are rather long, and in this way, we only compile once for the+library, not every time the algorithm is called.++-}++++{- $insidebacktrack++> nwInsideBacktrack :: VU.Vector Char -> VU.Vector Char -> TwITbl Id Unboxed (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 Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int Id Id [String]+@+\{\-\# NoInline nwInsideBacktrack \#\-\}+@++-}++++{- $runforward++The inside grammar, with efficient table-filling (via 'nwInsideForward')+and backtracking. Requests @k@ co-optimal 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+  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+  bs = nwInsideBacktrack i1 i2 t+@+\{\-\# Noinline runNeedlemanWunsch \#\-\}+@++-}++++{- $outsideforward++Again, to be able to observe performance, we have extracted the+outside-table-filling part.++> nwOutsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.TwITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL O:.PointL O) Int+> nwOutsideForward i1 i2 = {-# SCC "nwOutsideForward" #-} 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 nwOutsideForward \#\-\}+@++-}++++{- $runoutside++The outside version of the Needleman-Wunsch alignment algorithm. The+outside grammar is identical to the inside grammar! This is not 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+>   i1 = VU.fromList i1'+>   i2 = VU.fromList i2'+>   n1 = VU.length i1+>   n2 = VU.length i2+>   !(Z:.t) = nwOutsideForward i1 i2+>   d = unId $ axiom t+>   !(Z:.b) = grammar (sScore <|| sPretty) (toBacktrack t (undefined :: Id a -> Id a)) i1 i2+>               :: Z:.TwITblBt Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL O:.PointL O) Int Id Id [String]+@+\{\-\# Noinline runOutsideNeedlemanWunsch \#\-\}+@++-}++++{- $alignwrapper++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 k (a:b:xs) = {-# SCC "align" #-} do+>   putStrLn a+>   putStrLn b+>   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++-}++++{- $main++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 = if null as then 1 else read $ head as+>   ls <- lines <$> getContents+>   align k ls++-}+