ADPfusion 0.5.2.2 → 0.6.0.0

raw patch · 81 files changed

+4619/−3114 lines, 81 filesdep +deepseqdep +dump-coredep +ghc-primdep −criteriondep −fmlistdep ~DPutilsdep ~OrderedBitsdep ~PrimitiveArraynew-component:exe:SmithWatermanPVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq, dump-core, ghc-prim, singletons

Dependencies removed: criterion, fmlist

Dependency ranges changed: DPutils, OrderedBits, PrimitiveArray, QuickCheck, base, bits, primitive, strict, template-haskell, vector

API changes (from Hackage documentation)

Files

• ADP/Fusion/Core.hs +73/−33
• ADP/Fusion/Core/Apply.hs +1/−1
• ADP/Fusion/Core/Classes.hs +77/−68
• ADP/Fusion/Core/Multi.hs +109/−107
• ADP/Fusion/Core/Point.hs +0/−121
• ADP/Fusion/Core/SynVar/Array.hs +150/−0
• ADP/Fusion/Core/SynVar/Array/Type.hs +177/−0
• ADP/Fusion/Core/SynVar/Axiom.hs +20/−0
• ADP/Fusion/Core/SynVar/Backtrack.hs +28/−0
• ADP/Fusion/Core/SynVar/Fill.hs +442/−0
• ADP/Fusion/Core/SynVar/FillTyLvl.hs +324/−0
• ADP/Fusion/Core/SynVar/Indices.hs +140/−0
• ADP/Fusion/Core/SynVar/Recursive/Type.hs +131/−0
• ADP/Fusion/Core/SynVar/Split/Type.hs +200/−0
• ADP/Fusion/Core/SynVar/TableWrap.hs +15/−0
• ADP/Fusion/Core/TH/Backtrack.hs +1/−1
• ADP/Fusion/Core/Term/Chr.hs +62/−0
• ADP/Fusion/Core/Term/Deletion.hs +26/−0
• ADP/Fusion/Core/Term/Edge.hs +73/−0
• ADP/Fusion/Core/Term/Epsilon.hs +35/−0
• ADP/Fusion/Core/Term/MultiChr.hs +49/−0
• ADP/Fusion/Core/Term/PeekIndex.hs +30/−0
• ADP/Fusion/Core/Term/Str.hs +61/−0
• ADP/Fusion/Core/Term/Switch.hs +48/−0
• ADP/Fusion/Core/Term/Test.hs +60/−0
• ADP/Fusion/Core/TyLvlIx.hs +17/−14
• ADP/Fusion/Core/Unit.hs +0/−98
• ADP/Fusion/Point.hs +0/−25
• ADP/Fusion/PointL.hs +33/−0
• ADP/Fusion/PointL/Core.hs +191/−0
• ADP/Fusion/PointL/SynVar/Indices.hs +139/−0
• ADP/Fusion/PointL/Term/Chr.hs +81/−0
• ADP/Fusion/PointL/Term/Deletion.hs +85/−0
• ADP/Fusion/PointL/Term/Epsilon.hs +119/−0
• ADP/Fusion/PointL/Term/MultiChr.hs +85/−0
• ADP/Fusion/PointL/Term/Str.hs +87/−0
• ADP/Fusion/PointL/Term/Switch.hs +75/−0
• ADP/Fusion/PointR.hs +29/−0
• ADP/Fusion/PointR/Core.hs +121/−0
• ADP/Fusion/PointR/SynVar/Indices.hs +44/−0
• ADP/Fusion/PointR/Term/Chr.hs +72/−0
• ADP/Fusion/PointR/Term/Deletion.hs +69/−0
• ADP/Fusion/PointR/Term/Epsilon.hs +66/−0
• ADP/Fusion/PointR/Term/MultiChr.hs +77/−0
• ADP/Fusion/SynVar/Array.hs +0/−123
• ADP/Fusion/SynVar/Array/Type.hs +0/−146
• ADP/Fusion/SynVar/Axiom.hs +0/−14
• ADP/Fusion/SynVar/Backtrack.hs +0/−28
• ADP/Fusion/SynVar/Fill.hs +0/−319
• ADP/Fusion/SynVar/Indices/Classes.hs +0/−98
• ADP/Fusion/SynVar/Indices/Point.hs +0/−63
• ADP/Fusion/SynVar/Indices/Unit.hs +0/−50
• ADP/Fusion/SynVar/Recursive/Point.hs +0/−3
• ADP/Fusion/SynVar/Recursive/Type.hs +0/−123
• ADP/Fusion/SynVar/Split/Type.hs +0/−200
• ADP/Fusion/SynVar/TableWrap.hs +0/−11
• ADP/Fusion/Term/Chr/Point.hs +0/−74
• ADP/Fusion/Term/Chr/Type.hs +0/−62
• ADP/Fusion/Term/Deletion/Point.hs +0/−58
• ADP/Fusion/Term/Deletion/Type.hs +0/−26
• ADP/Fusion/Term/Deletion/Unit.hs +0/−55
• ADP/Fusion/Term/Edge/Type.hs +0/−39
• ADP/Fusion/Term/Epsilon/Point.hs +0/−58
• ADP/Fusion/Term/Epsilon/Type.hs +0/−26
• ADP/Fusion/Term/Epsilon/Unit.hs +0/−55
• ADP/Fusion/Term/PeekIndex/Type.hs +0/−30
• ADP/Fusion/Term/Strng/Point.hs +0/−96
• ADP/Fusion/Term/Strng/Type.hs +0/−55
• ADP/Fusion/Tutorial/NeedlemanWunsch.hs +0/−495
• ADP/Fusion/Unit.hs +6/−6
• ADP/Fusion/Unit/Core.hs +116/−0
• ADP/Fusion/Unit/SynVar/Indices.hs +70/−0
• ADP/Fusion/Unit/Term/Deletion.hs +47/−0
• ADP/Fusion/Unit/Term/Epsilon.hs +65/−0
• ADPfusion.cabal +182/−119
• README.md +2/−20
• changelog.md +14/−0
• src/NeedlemanWunsch.hs +93/−50
• src/SmithWaterman.hs +194/−0
• tests/BacktrackingStructures.hs +0/−76
• tests/QuickCheck/Point.hs +108/−68

@@ -1,4 +1,6 @@ +{-# Language MagicHash #-}+ -- | Generalized fusion system for grammars. -- -- This module re-exports only the core functionality.@@ -13,22 +15,23 @@   , module ADP.Fusion.Core.Apply   , module ADP.Fusion.Core.Classes   , module ADP.Fusion.Core.Multi+  , module ADP.Fusion.Core.SynVar.Array.Type+  , module ADP.Fusion.Core.SynVar.Axiom+  , module ADP.Fusion.Core.SynVar.Backtrack+  , module ADP.Fusion.Core.SynVar.FillTyLvl+  , module ADP.Fusion.Core.SynVar.Indices+  , module ADP.Fusion.Core.SynVar.Recursive.Type+  , module ADP.Fusion.Core.SynVar.Split.Type+  , module ADP.Fusion.Core.SynVar.TableWrap+  , module ADP.Fusion.Core.Term.Chr+  , module ADP.Fusion.Core.Term.Deletion+  , module ADP.Fusion.Core.Term.Edge+  , module ADP.Fusion.Core.Term.Epsilon+  , module ADP.Fusion.Core.Term.MultiChr+  , module ADP.Fusion.Core.Term.PeekIndex+  , module ADP.Fusion.Core.Term.Str   , module ADP.Fusion.Core.TH   , module ADP.Fusion.Core.TyLvlIx-  , module 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@@ -44,22 +47,23 @@ import           ADP.Fusion.Core.Apply import           ADP.Fusion.Core.Classes hiding (iIx) import           ADP.Fusion.Core.Multi hiding (iIx)+import           ADP.Fusion.Core.SynVar.Array.Type+import           ADP.Fusion.Core.SynVar.Axiom+import           ADP.Fusion.Core.SynVar.Backtrack+import           ADP.Fusion.Core.SynVar.FillTyLvl+import           ADP.Fusion.Core.SynVar.Indices+import           ADP.Fusion.Core.SynVar.Recursive.Type+import           ADP.Fusion.Core.SynVar.Split.Type+import           ADP.Fusion.Core.SynVar.TableWrap+import           ADP.Fusion.Core.Term.Chr+import           ADP.Fusion.Core.Term.Deletion+import           ADP.Fusion.Core.Term.Edge+import           ADP.Fusion.Core.Term.Epsilon+import           ADP.Fusion.Core.Term.MultiChr+import           ADP.Fusion.Core.Term.PeekIndex+import           ADP.Fusion.Core.Term.Str import           ADP.Fusion.Core.TH import           ADP.Fusion.Core.TyLvlIx-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   @@ -71,18 +75,54 @@ -- function 'f'.  infixl 8 <<<-(<<<) f xs = \lu ij -> S.map (apply (inline f) . getArg) . mkStream (build xs) (initialContext ij) lu $ ij+(<<<)+  ∷ forall k m initCtx symbols i b+  . ( Monad m+    , Build symbols+    , Element (Stack symbols) i+    , Apply (Arg (Stack symbols) → b)+    , initCtx ~ InitialContext i+    , MkStream m initCtx (Stack symbols) i+    )+  ⇒ (Fun (Arg (Stack symbols) → b))+  → symbols+  → (LimitType i → i → Stream m b)+(<<<) f xs+  = \lu ij+  → S.map (apply (inline f) . getArg)+  $ mkStream (Proxy ∷ Proxy initCtx) (build xs) 1# lu ij {-# INLINE (<<<) #-} -infixl 8 <<#-(<<#) f xs = \lu ij -> S.mapM (apply (inline f) . getArg) . mkStream (build xs) (initialContext ij) lu $ ij-{-# INLINE (<<#) #-}+--infixl 8 <<#+--(<<#) f xs = \lu ij -> S.mapM (apply (inline f) . getArg) $ mkStream Proxy (build xs) 1# lu ij+--{-# INLINE (<<#) #-}  -- | Combine two RHSs to give a choice between parses.  infixl 7 |||-(|||) xs ys = \lu ij -> xs lu ij S.++ ys lu ij+(|||) xs ys = \lu ij -> xs lu ij `streamappend` ys lu ij {-# INLINE (|||) #-}++data StreamAppend a b = SAL a | SAR b++streamappend :: Monad m => Stream m a -> Stream m a -> Stream m a+{-# Inline streamappend #-}+Stream stepa ta `streamappend` Stream stepb tb = Stream step (SAL ta)+  where+    {-# Inline [0] step #-}+    step (SAL   sa) = do+                        r <- stepa sa+                        case r of+                          S.Yield x sa' -> return $ S.Yield x (SAL sa')+                          S.Skip    sa' -> return $ S.Skip    (SAL sa')+                          S.Done        -> return $ S.Skip    (SAR tb)+    step (SAR   sb) = do+                        r <- stepb sb+                        case r of+                          S.Yield x sb' -> return $ S.Yield x (SAR sb')+                          S.Skip    sb' -> return $ S.Skip    (SAR sb')+                          S.Done        -> return $ S.Done+  -- | Applies the objective function 'h' to a stream 's'. The objective function -- reduces the stream to a single optimal value (or some vector of co-optimal

@@ -2,7 +2,7 @@ module ADP.Fusion.Core.Apply where  --import Data.Array.Repa.Index-import Data.PrimitiveArray (Z(..), (:.)(..))+import Data.PrimitiveArray.Index.Class (Z(..), (:.)(..))   

@@ -3,30 +3,49 @@  module ADP.Fusion.Core.Classes where +import           Control.DeepSeq import           Data.Proxy import           Data.Strict.Tuple import           GHC.Exts hiding (build)+import           GHC.Generics (Generic, Generic1) import qualified Data.Vector.Fusion.Stream.Monadic as S -import           Data.PrimitiveArray+import           Data.PrimitiveArray.Index.Class   +-- TODO Until I figure out how to use @InitialContext ∷ k@ instead of+-- @InitialContext ∷ *@ we need to live in @*@. Unfortunately, @(<<<)@ does not+-- like differently-kinded types.++{- data OutsideContext s   = OStatic     s   | ORightOf    s   | OFirstLeft  s   | OLeftOf     s   deriving (Show)+-}+data OStatic    s+data ORightOf   s+data OFirstLeft s+data OLeftOf    s +{- data InsideContext s   = IStatic   {iGetContext :: s}   | IVariable {iGetContext :: s}   deriving (Show)+-}+data IStatic   s+data IVariable s +{- data ComplementContext   = Complemented   deriving (Show)+-}+data Complement  -- | Needed for structures that have long-range interactions and "expand", -- like sets around edge boundaries: @set <edge> set@. requires the sets to@@ -36,37 +55,37 @@   = CStatic s   | CVariable s -class RuleContext i where-  type Context i :: *-  initialContext :: i -> Context i+-- | For each index type @ix@, @initialContext (Proxy ∷ ix)@ yields the initial+-- context from which to start up rules.+--+-- TODO turn into type family and make 'initialContext' a global function. +type family InitialContext ix ∷ *++{-+class RuleContext ix where+  type InitialContext ix ∷ *+  initialContext ∷ Proxy ix → Proxy (InitialContext ix)+--  default initialContext ∷ Proxy ix → Proxy (InitialContext ix ∷ k)+  initialContext Proxy = Proxy+  {-# Inline initialContext #-}+-}+ -- | While we ostensibly use an index of type @i@ we typically do not need -- every element of an @i@. For example, when looking at 'Subword's, we do -- not need both element of @j:.k@ but only @k@. -- Also, inside grammars do need fewer moving indices than outside -- grammars.------ 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 (Generic, NFData, Show) -deriving instance Show (RunningIndex Z)+data instance RunningIndex (is:.i) = !(RunningIndex is) :.: !(RunningIndex i)+  deriving (Generic) +deriving instance (NFData (RunningIndex is), NFData (RunningIndex i)) => NFData (RunningIndex (is:.i))  -- | During construction of the stream, we need to extract individual elements -- from symbols in production rules. An element in a stream is fixed by both,@@ -76,22 +95,41 @@ -- @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+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)+class (Monad m) ⇒ MkStream m pos sym ix where+  mkStream+    ∷ Proxy pos+    -- ^ Fix static/variable/... depending on position in r.h.s. of rule.+    → sym+    -- ^ the symbol type (syntactic variable with or with memoization, terminal types like char, string, etc)+    → Int#+    -- ^ guard system for stopping execution of rule+    → LimitType ix+    -- ^ upper limit of index @i@, using the specialized 'LimitType' for type @i@.+    → ix+    -- ^ the current index @i@+    → S.Stream m (Elm sym ix)+    -- ^ resulting stream of elements +-- | This type family yields for a given positional type @posty ∷ k@, the+-- current symbol type @symty@ and index type @ix@ the next-left positional+-- type within the same kind @k@ Keeping within the same kind should prevent+-- accidental switching from Inside to Outside or similar bugs.++type family LeftPosTy (pos ∷ *) sym ix ∷ *+ -- | Finally, we need to be able to correctly build together symbols on the -- right-hand side of the @(<<<)@ operator. --@@ -119,12 +157,12 @@ instance   (   ) => Element S i where-  data Elm S i = ElmS !(RunningIndex i)+  newtype Elm S i = ElmS (RunningIndex i)   type Arg S   = Z   getArg (ElmS _) = Z   getIdx (ElmS i) = i-  {-# Inline getArg #-}-  {-# Inline getIdx #-}+  {-# Inline [0] getArg #-}+  {-# Inline [0] getIdx #-}  deriving instance (Show (RunningIndex ix)) => Show (Elm S ix) @@ -132,7 +170,7 @@ -- 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+staticCheck !b (S.Stream step t) = S.Stream snew (CheckLeft b t) where   {-# Inline [0] snew #-}   snew (CheckLeft  False _) = return $ S.Done   snew (CheckLeft  True  s) = return $ S.Skip (CheckRight s)@@ -146,10 +184,10 @@ 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+staticCheck# b (S.Stream step t) = S.Stream snew (SL b t) where   {-# Inline [0] snew #-}-  snew (SL s k)-    | 1# <- k   = return $ S.Skip (SR s)+  snew (SL q s)+    | 1# <- q   = return $ S.Skip (SR s)     | otherwise = return $ S.Done   snew (SR s  ) = do r <- step s                      case r of@@ -159,22 +197,18 @@ {-# Inline staticCheck# #-}  -data SLR z = SL !z !Int# | SR !z+data SLR z = SL Int# z | SR z  -- | Constrains the behaviour of the memoizing tables. They may be 'EmptyOk' if -- @i==j@ is allowed (empty subwords or similar); or they may need 'NonEmpty' -- indices, or finally they can be 'OnlyZero' (only @i==j@ allowed) which is -- useful in multi-dimensional casese. ---data TableConstraint---  = EmptyOk---  | NonEmpty---  | OnlyZero---  deriving (Eq,Show)- data EmptyOk = EmptyOk+  deriving (Show)  data NonEmpty = NonEmpty+  deriving (Show)  class MinSize c where   minSize :: c -> Int@@ -187,13 +221,6 @@   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.@@ -203,22 +230,4 @@   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,4 +1,6 @@ +{-# Language MagicHash #-}+ module ADP.Fusion.Core.Multi where  import qualified Data.Vector.Fusion.Stream.Monadic as S@@ -6,8 +8,10 @@ import           Data.Strict.Tuple import           Data.Proxy import           Prelude hiding (map)+import           GHC.Exts+import           Debug.Trace -import           Data.PrimitiveArray hiding (map)+import           Data.PrimitiveArray.Index.Class hiding (map)  import           ADP.Fusion.Core.Classes import           ADP.Fusion.Core.TyLvlIx@@ -34,7 +38,7 @@  type family   TermArg x :: * type instance TermArg M                = Z-type instance TermArg (TermSymbol a b) = TermArg a :. TermArg b+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)@@ -46,121 +50,118 @@  deriving instance (Show i, Show (RunningIndex i), Show (TermArg (TermSymbol a b)), Show (Elm ls i)) => Show (Elm (ls :!: TermSymbol a b) i) +type instance LeftPosTy (ps :. p) (TermSymbol a b) (is:.i) = (LeftPosTy ps a is) :. (LeftPosTy p b i)+ instance   ( Monad m-  , MkStream m ls i+  , MkStream m posLeft 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+  , TermStaticVar pos (TermSymbol a b) i+  , TermStream m pos (TermSymbol a b) (Elm ls i) i+  , posLeft ~ LeftPosTy pos (TermSymbol a b) i+  ) => MkStream m pos (ls :!: TermSymbol a b) i where+  mkStream Proxy (ls :!: ts) grd lu i     = map (\(TState sS ii ee) -> ElmTS ee ii sS)-    . termStream ts sv lu i+    . termStream (Proxy ∷ Proxy pos) ts lu i     . map (\s -> TState s RiZ Z)-    $ mkStream ls (termStaticVar ts sv i) lu (termStreamIndex ts sv i)+    $ mkStream (Proxy ∷ Proxy posLeft)+               ls+               (termStaticCheck (Proxy ∷ Proxy pos) ts lu i grd)+               lu (termStreamIndex (Proxy ∷ Proxy pos) ts 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 #-}+type instance LeftPosTy Z M Z = Z +instance Monad m => MkStream m Z S Z where+  -- mkStream Proxy S grd ZZ Z = S.filter (const $ isTrue# grd) $ S.singleton $ ElmS RiZ+  mkStream Proxy S grd ZZ Z = staticCheck# grd $ S.singleton $ ElmS RiZ+  {-# Inline mkStream #-}+ -- | For multi-dimensional terminals we need to be able to calculate how the -- static/variable signal changes and if the index for the inner part needs to -- be modified. -class TermStaticVar t i where-  termStaticVar   :: t -> Context i -> i -> Context i-  termStreamIndex :: t -> Context i -> i -> i+class TermStaticVar pos sym ix where+--  termStaticVar   ∷ sym → Context i → i → Context i+  termStreamIndex ∷ Proxy pos → sym → ix → ix+  termStaticCheck ∷ Proxy pos → sym → LimitType ix → ix → Int# → Int# -instance TermStaticVar M Z where-  termStaticVar   _ _ _ = Z-  termStreamIndex _ _ _ = Z-  {-# INLINE [0] termStaticVar #-}+instance TermStaticVar pos M Z where+  termStreamIndex Proxy M Z = Z+  termStaticCheck Proxy M _ Z grd = grd   {-# INLINE [0] termStreamIndex #-}+  {-# INLINE [0] termStaticCheck #-}  instance-  ( TermStaticVar 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 #-}+  ( TermStaticVar ps ts is+  , TermStaticVar p  t  i+  ) => TermStaticVar (ps:.p) (TermSymbol ts t) (is:.i) where+  termStreamIndex Proxy (ts:|t) (is:.i) = termStreamIndex (Proxy ∷ Proxy ps) ts is :. termStreamIndex (Proxy ∷ Proxy p) t i+  termStaticCheck Proxy (ts:|t) (us:..u) (is:.i) grd = termStaticCheck (Proxy ∷ Proxy ps) ts us is (termStaticCheck (Proxy ∷ Proxy p) t u i grd)   {-# INLINE [0] termStreamIndex #-}----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 #-}+  {-# INLINE [0] termStaticCheck #-} ---toTerminalStream s = S5 s Z Z (getIdx s) (getOmx s)---{-# INLINE toTerminalStream #-}+--instance RuleContext Z where+type instance InitialContext Z = Z -instance RuleContext Z where-  type Context Z = Z-  initialContext _ = Z-  {-# INLINE initialContext #-}+--instance (RuleContext is, RuleContext i) => RuleContext (is:.i) where+type instance InitialContext (is:.i) = InitialContext is:.InitialContext i -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 pos minSize tableIx ix where+  tableStreamIndex+    ∷ Proxy pos+    -- ^ provide type-level information on if we are currently static/variable/+    -- etc+    → minSize+    -- ^ Information on the minimal size of the corresponding table.+    → LimitType tableIx+    -- ^ provide type-level information on the index structure of the table we+    -- are looking at. This index structure might well be different than the+    -- @ix@ index we use in the grammar.+    → ix+    -- ^ current right-most index+    → ix+    -- ^ right-most index for symbol to the left of us -class TableStaticVar u c i where-  tableStaticVar   :: Proxy u -> c -> Context i -> i -> Context i-  tableStreamIndex :: Proxy u -> c -> Context i -> i -> i+-- | Index "0" for multi-dimensional syntactic variables. -instance TableStaticVar c u Z where-  tableStaticVar   _ _ _ _ = Z-  tableStreamIndex _ _ _ _ = Z-  {-# INLINE [0] tableStaticVar   #-}+instance TableStaticVar pos Z tableIx Z where+  tableStreamIndex Proxy Z _ Z = Z   {-# 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   #-}+instance+  ( TableStaticVar ps cs us is+  , TableStaticVar p  c  u  i+  )+  ⇒ TableStaticVar (ps:.p) (cs:.c) (us:.u) (is:.i) where+  tableStreamIndex Proxy (cs:.c) (us:..u) (is:.i)+    =  tableStreamIndex (Proxy ∷ Proxy ps) cs us is+    :. tableStreamIndex (Proxy ∷ Proxy p ) c  u  i   {-# INLINE [0] tableStreamIndex #-}  - data TermState s i e = TState-  { tS  :: !s -- ^ state coming in from the left---  , 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+  { tS  :: !s+    -- ^ state coming in from the left+  , iIx :: !(RunningIndex i)+    -- ^ @I/C@ building up state to hand over to next symbol+  , eTS :: !e+    -- ^ element data   } ---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))+class TermStream m pos t s i where+  termStream+    ∷ Proxy pos+    → t+    → LimitType i+    → i+    → Stream m (TermState s Z Z)+    → Stream m (TermState s i (TermArg t)) -instance (Monad m) => TermStream m M s Z where-  termStream _ _ _ _ = id -- map (\(!s) -> s)+instance (Monad m) => TermStream m pos M s Z where+  termStream Proxy M ZZ Z = id   {-# Inline termStream #-}  -- |@@ -171,13 +172,19 @@ -- 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+  ∷ forall m pos t s i+  . ( Monad m+    , TermStream m (Z:.pos) (TermSymbol M t) (Elm (Term1 s) (Z:.i)) (Z:.i)+    )+  ⇒ Proxy pos+  → t+  → LimitType i+  → i+  → Stream m s+  → Stream m (s,TermArg t,RunningIndex i)+addTermStream1 Proxy t u i   = map (\(TState (ElmTerm1 sS) (RiZ:.:ii) (Z:.ee)) -> (sS,ee,ii))-  . termStream (M:|t) (Z:.c) (Z:.u) (Z:.i)+  . termStream (Proxy ∷ Proxy (Z:.pos)) (M:|t) (ZZ:..u) (Z:.i)   . map (\s -> TState (elmTerm1 s i) RiZ Z) {-# Inline addTermStream1 #-} @@ -193,27 +200,22 @@   {-# 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+--+-- TODO prepare for deletion ---type TstCtx1 m ts s sixty is i+--type TermMkStreamContext m (pos ∷ k) ls t i --  = ( Monad m---    , TermStream m ts s is---    , GetIndex (RunningIndex sixty) (RunningIndex (is:.i))---    , GetIx (RunningIndex sixty) (RunningIndex (is:.i)) ~ (RunningIndex i)+--    , MkStream m pos ls i+--    , TermStream m pos (TermSymbol M t) (Elm (Term1 (Elm ls i)) (Z:.i)) (Z:.i)+--    , Element ls i+--    , TermStaticVar pos t i --    ) -type TstCtx m ts s x0 sixty is i+-- | @Term TermStream@ context++type TermStreamContext m (pos ∷ k) ts s x0 sixty is i   = ( Monad m-    , TermStream m ts s is+    , TermStream m pos ts s is     , GetIndex (RunningIndex sixty) (RunningIndex (is:.i))     , GetIx (RunningIndex sixty) (RunningIndex (is:.i)) ~ (RunningIndex i)     , Element x0 sixty

@@ -1,121 +0,0 @@--{-# 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,150 @@++{-# Language MagicHash #-}++module ADP.Fusion.Core.SynVar.Array+  ( module ADP.Fusion.Core.SynVar.Array.Type+  , module ADP.Fusion.Core.SynVar.Array+  ) where+++import Data.Proxy+import Data.Strict.Tuple hiding (snd)+import Data.Vector.Fusion.Stream.Monadic+import GHC.Exts+import Prelude hiding (map,mapM)++import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi+import ADP.Fusion.Core.SynVar.Array.Type+import ADP.Fusion.Core.SynVar.Backtrack+import ADP.Fusion.Core.SynVar.Indices+import ADP.Fusion.Core.SynVar.TableWrap++++-- | Constraints needed to use @iTblStream@.++type ITblCx m pos ls arr x u c i =+  ( TableStaticVar pos c u i+  , Element ls i+  , AddIndexDense (Z:.pos) (Elm (SynVar1 (Elm ls i)) (Z:.i)) (Z:.c) (Z:.u) (Z:.i)+  , PrimArrayOps arr u x+  )++-- | General function for @ITbl@s with skalar indices.++iTblStream+  ∷ forall b s m pos posLeft ls arr x u c i+  . ( ITblCx m pos ls arr x u c i+    , posLeft ~ LeftPosTy pos (TwITbl b s m arr c u x) i+    , MkStream m posLeft ls i+    )+  ⇒ Proxy pos+  → Pair ls (TwITbl b s m arr c u x)+  → Int#+  → LimitType i+  → i+  → Stream m (Elm (ls :!: TwITbl b s m arr c u x) i)+iTblStream pos (ls :!: TW (ITbl c t) _) grd us is+  = map (\(s,tt,ii') -> ElmITbl (t!tt) ii' s)+  . addIndexDense1 pos c ub us is+  $ mkStream (Proxy ∷ Proxy posLeft) ls grd us (tableStreamIndex (Proxy :: Proxy pos) c ub is)+  where ub = upperBound t+{-# Inline iTblStream #-}++-- | General function for @Backtrack ITbl@s with skalar indices.++btITblStream+  ∷ forall b s mB mF pos posLeft ls arr x r u c i+  . ( ITblCx mB pos ls arr x u c i+    , posLeft ~ LeftPosTy pos (TwITblBt b s arr c u x mF mB r) i+    , MkStream mB posLeft ls i+    )+  ⇒ Proxy pos+  → Pair ls (TwITblBt b s arr c u x mF mB r)+  → Int#+  → LimitType i+  → i+  → Stream mB (Elm (ls :!: TwITblBt b s arr c u x mF mB r) i)+btITblStream pos (ls :!: TW (BtITbl c t) bt) grd us is+    = mapM (\(s,tt,ii') -> bt ub tt >>= \ ~bb -> return $ ElmBtITbl (t!tt) bb ii' s)+    . addIndexDense1 pos c ub us is+    $ mkStream (Proxy ∷ Proxy posLeft) ls grd us (tableStreamIndex (Proxy :: Proxy pos) c ub is)+    where ub = upperBound t+{-# Inline btITblStream #-}++++-- ** Instances++instance+  ( Monad m+  , ITblCx m pos ls arr x u c (i I)+  , MkStream m (LeftPosTy pos (TwITbl b s m arr c u x) (i I)) ls (i I)+  ) => MkStream m pos (ls :!: TwITbl b s m arr c u x) (i I) where+  mkStream = iTblStream+  {-# Inline mkStream #-}++instance+  ( Monad mB+  , ITblCx mB pos ls arr x u c (i I)+  , MkStream mB (LeftPosTy pos (TwITblBt b s arr c u x mF mB r) (i I)) ls (i I)+  )+  ⇒ MkStream mB pos (ls :!: TwITblBt b s arr c u x mF mB r) (i I) where+  mkStream = btITblStream+  {-# Inline mkStream #-}++instance+  ( Monad m+  , ITblCx m pos ls arr x u c (i O)+  , MkStream m (LeftPosTy pos (TwITbl b s m arr c u x) (i O)) ls (i O)+  ) => MkStream m pos (ls :!: TwITbl b s m arr c u x) (i O) where+  mkStream = iTblStream+  {-# Inline mkStream #-}++instance+  ( Monad mB+  , ITblCx mB pos ls arr x u c (i O)+  , MkStream mB (LeftPosTy pos (TwITblBt b s arr c u x mF mB r) (i O)) ls (i O)+  )+  ⇒ MkStream mB pos (ls :!: TwITblBt b s arr c u x mF mB r) (i O) where+  mkStream = btITblStream+  {-# Inline mkStream #-}++{-+instance+  ( Monad m+  , ITblCx m ls arr x u c (i C)+  ) => MkStream m (ls :!: TwITbl m arr c u x) (i C) where+  mkStream = iTblStream+  {-# Inline mkStream #-}++instance+  ( Monad mB+  , ITblCx mB ls arr x u c (i O)+  ) => MkStream mB (ls :!: TwITblBt arr c u x mF mB r) (i O) where+  mkStream = btITblStream+  {-# Inline mkStream #-}++instance+  ( Monad mB+  , ITblCx mB ls arr x u c (i C)+  ) => MkStream mB (ls :!: TwITblBt arr c u x mF mB r) (i C) where+  mkStream = btITblStream+  {-# Inline mkStream #-}++instance ModifyConstraint (TwITbl m arr EmptyOk i x) where+  type TNE (TwITbl m arr EmptyOk i x) = TwITbl m arr NonEmpty i x+  type TE  (TwITbl m arr EmptyOk i x) = TwITbl m arr EmptyOk  i x+  toNonEmpty (TW (ITbl b l _ arr) f) = TW (ITbl b l NonEmpty arr) f+  {-# Inline toNonEmpty #-}++instance ModifyConstraint (TwITblBt arr EmptyOk i x mF mB r) where+  type TNE (TwITblBt arr EmptyOk i x mF mB r) = TwITblBt arr NonEmpty i x mF mB r+  type TE  (TwITblBt arr EmptyOk i x mF mB r) = TwITblBt arr EmptyOk  i x mF mB r+  toNonEmpty (TW (BtITbl _ arr) bt) = TW (BtITbl NonEmpty arr) bt+  {-# Inline toNonEmpty #-}+-}+

@@ -0,0 +1,177 @@++{-# Language DataKinds #-}+{-# Language TypeOperators #-}++module ADP.Fusion.Core.SynVar.Array.Type where++import Data.Proxy+import Data.Strict.Tuple hiding (uncurry,snd)+import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..))+import Debug.Trace+import GHC.TypeNats+import Prelude hiding (map,head,mapM)++import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi+import ADP.Fusion.Core.SynVar.Axiom+import ADP.Fusion.Core.SynVar.Backtrack+import ADP.Fusion.Core.SynVar.Indices+import ADP.Fusion.Core.SynVar.TableWrap++++-- | Immutable table.+--+-- NOTE / TODO We can *NOT* move the little order into the type-level until we+-- have a fully working TH-based table filler.++data ITbl (bigorder ∷ Nat) (smallOrder ∷ Nat) arr c i x where+  ITbl ∷ { iTblConstraint  ∷ !c           -- TODO next to go?!+         , iTblArray       ∷ !(arr i x)+         } → ITbl bigOrder smallOrder arr c i x++instance (Show c, Show (arr i x)) ⇒ Show (ITbl bo so arr c i x) where+  show (ITbl c arr) = "ITbl " ++ " " ++ show c ++ " [" ++ show arr ++ "]"++type TwITbl (b ∷ Nat) (s ∷ Nat) (m ∷ * → *) arr c i x = TW (ITbl b s arr c i x) (LimitType i → i → m x)++type TwITblBt b s arr c i x mF mB r = TW (Backtrack (TwITbl b s mF arr c i x) mF mB) (LimitType i → i → mB [r])++instance Build (TwITbl b s m arr c i x)++instance Build (TwITblBt b s arr c i x mF mB r)++type instance TermArg (TwITbl b s m arr c i x) = x++type instance TermArg (TwITblBt b s arr c i x mF mB r) = (x,[r])++instance GenBacktrackTable (TwITbl b s mF arr c i x) mF mB where+  data Backtrack (TwITbl b s mF arr c i x) mF mB = BtITbl !c !(arr i x)+  type BacktrackIndex (TwITbl b s mF arr c i x) = i+  toBacktrack (TW (ITbl c arr) _) _ = BtITbl c arr+  {-# Inline toBacktrack #-}++++-- * axiom stuff++instance+  ( Monad m+  , PrimArrayOps arr i x+  , IndexStream i+  ) ⇒ Axiom (TwITbl b s m arr c i x) where+  type AxiomStream (TwITbl b s m arr c i x) = m x+  type AxiomIx     (TwITbl b s m arr c i x) = i+  axiom (TW (ITbl c arr) _) = do+    k ← head . streamDown zeroBound' $ upperBound arr+    return $ arr ! k+  {-# Inline axiom #-}+  axiomAt (TW (ITbl c arr) _) k = +    return $ arr ! k+  {-# Inline axiomAt #-}++-- | We need this somewhat annoying instance construction (@i ~ j@ and @m+-- ~ mB@) in order to force selection of this instance.++instance+  ( Monad mB+  , PrimArrayOps arr i x+  , IndexStream i+  , j ~ i+  , m ~ mB+  ) ⇒ Axiom (TW (Backtrack (TwITbl b s mF arr c i x) mF mB) (LimitType j → j → m [r])) where+  type AxiomStream (TW (Backtrack (TwITbl b s mF arr c i x) mF mB) (LimitType j → j → m [r])) = mB [r]+  type AxiomIx     (TW (Backtrack (TwITbl b s mF arr c i x) mF mB) (LimitType j → j → m [r])) = i+  axiom (TW (BtITbl c arr) bt) = do+    h ← head . streamDown zeroBound' $ upperBound arr+    bt (upperBound arr) h+  {-# Inline axiom #-}+  axiomAt (TW (BtITbl c arr) bt) k = do+    bt (upperBound arr) k+  {-# Inline axiomAt #-}++++-- * 'Element'++instance Element ls i ⇒ Element (ls :!: TwITbl b s m arr c j x) i where+  data Elm    (ls :!: TwITbl b s m arr c j x) i = ElmITbl !x !(RunningIndex i) !(Elm ls i)+  type Arg    (ls :!: TwITbl b s m arr c j x)   = Arg ls :. x+  type RecElm (ls :!: TwITbl b s m arr c j x) i = Elm ls i+  getArg (ElmITbl x _ ls) = getArg ls :. x+  getIdx (ElmITbl _ i _ ) = i+  getElm (ElmITbl _ _ ls) = ls+  {-# Inline getArg #-}+  {-# Inline getIdx #-}+  {-# Inline getElm #-}++deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i), Show x) => Show (Elm (ls :!: TwITbl b s m arr c j x) i)++instance Element ls i => Element (ls :!: TwITblBt b s arr c j x mF mB r) i where+  data Elm    (ls :!: TwITblBt b s arr c j x mF mB r) i = ElmBtITbl !x [r] !(RunningIndex i) !(Elm ls i)+  type Arg    (ls :!: TwITblBt b s arr c j x mF mB r)   = Arg ls :. (x, [r])+  type RecElm (ls :!: TwITblBt b s arr c j x mF mB r) i = Elm ls i+  getArg (ElmBtITbl x s _ ls) = getArg ls :. (x,s)+  getIdx (ElmBtITbl _ _ i _ ) = i+  getElm (ElmBtITbl _ _ _ ls) = ls+  {-# Inline getArg #-}+  {-# Inline getIdx #-}+  {-# Inline getElm #-}++instance (Show x, Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: TwITblBt b s arr c i x mF mB r) i) where+  show (ElmBtITbl x _ i s) = show (x,i) ++ " " ++ show s++++-- * Multi-dim extensions++type instance LeftPosTy Z (TwITbl b s m arr EmptyOk Z x) Z = Z+type instance LeftPosTy Z (TwITblBt b s arr EmptyOk Z x mF mB r) Z = Z++type instance LeftPosTy (ps:.p) (TwITbl b s m arr (eos:.EmptyOk) (us:.u) x) (is:.i)+  = (LeftPosTy ps (TwITbl b s m arr eos us x) is) :. (LeftPosTy p (TwITbl b s m arr EmptyOk u x) i)++type instance LeftPosTy (ps:.p) (TwITblBt b s arr (eos:.EmptyOk) (us:.u) x mF mB r) (is:.i)+  = (LeftPosTy ps (TwITblBt b s arr eos us x mF mB r) is) :. (LeftPosTy p (TwITblBt b s arr EmptyOk u x mF mB r) i)++type instance LeftPosTy Z (TwITbl b s m arr Z Z x) Z = Z+type instance LeftPosTy Z (TwITblBt b s arr Z Z x mF mB r) Z = Z+++instance+  forall b s l m pos ps p posLeft arr cs c us u x is i ls+  . ( Monad m+  , pos ~ (ps:.p)+  , posLeft ~ LeftPosTy pos (TwITbl b s m arr (cs:.c) (us:.u) x) (is:.i)+  , Element ls (is:.i)+  , TableStaticVar (ps:.p) (cs:.c) (us:.u) (is:.i)+  , AddIndexDense pos (Elm ls (is:.i)) (cs:.c) (us:.u) (is:.i)+  , MkStream m posLeft ls (is:.i)+  , PrimArrayOps arr (us:.u) x+  ) ⇒ MkStream m (ps:.p) (ls :!: TwITbl b s m arr (cs:.c) (us:.u) x) (is:.i) where+  mkStream Proxy (ls :!: TW (ITbl csc t) _) grd usu isi+    = map (\(s,tt,ii') -> ElmITbl (t!tt) ii' s)+    . addIndexDense (Proxy ∷ Proxy pos) csc ub usu isi+    $ mkStream (Proxy ∷ Proxy posLeft) ls grd usu (tableStreamIndex (Proxy ∷ Proxy pos) csc ub isi)+    where ub = upperBound t+  {-# Inline mkStream #-}++instance+  ( Monad mB+  , pos ~ (ps:.p)+  , posLeft ~ LeftPosTy pos (TwITblBt b s arr (cs:.c) (us:.u) x mF mB r) (is:.i)+  , Element ls (is:.i)+  , TableStaticVar (ps:.p) (cs:.c) (us:.u) (is:.i)+  , AddIndexDense pos (Elm ls (is:.i)) (cs:.c) (us:.u) (is:.i)+  , MkStream mB posLeft ls (is:.i)+  , PrimArrayOps arr (us:.u) x+  ) ⇒ MkStream mB (ps:.p) (ls :!: TwITblBt b s arr (cs:.c) (us:.u) x mF mB r) (is:.i) where+  mkStream Proxy (ls :!: TW (BtITbl csc t) bt) grd usu isi+    = mapM (\(s,tt,ii') -> bt ub tt >>= \ ~bb -> return $ ElmBtITbl (t!tt) bb ii' s)+    . addIndexDense (Proxy ∷ Proxy pos) csc ub usu isi+    $ mkStream (Proxy ∷ Proxy posLeft) ls grd usu (tableStreamIndex (Proxy :: Proxy pos) csc ub isi)+    where ub = upperBound t+  {-# Inline mkStream #-}+

@@ -0,0 +1,20 @@++-- | The 'axiom' runs a backtracking algebra. The name comes from Robert+-- Giegerichs @ADP@ where @axiom@ runs the fully formed algorithm.++module ADP.Fusion.Core.SynVar.Axiom where++-- | The Axiom type class++class Axiom t where+  -- | The corresponding stream being returned by 'axiom'+  type AxiomStream t ∷ *+  -- | Index type when running the axiom+  type AxiomIx t ∷ *+  -- | Given a table, run the axiom+  axiom ∷ t → AxiomStream t+  -- | Given a table and index, run the axiom from the index on. This is useful+  -- for scanning type algorithms that need to return all locally optimal+  -- structures, as a locally optimal may start at any given index.+  axiomAt ∷ t → AxiomIx t → AxiomStream t+

@@ -0,0 +1,28 @@++-- | Wrap forward tables in such a way as to allow backtracking via+-- algebras.++module ADP.Fusion.Core.SynVar.Backtrack where++import Data.Vector.Fusion.Stream.Monadic (Stream)++import ADP.Fusion.Core.SynVar.TableWrap++++-- |+--+-- TODO this should go into @ADP.Fusion.Table.Backtrack@, more than just+-- tabulated syntactic vars are going to use it.+--+-- NOTE You probably need to give the @monad morphism@ between @mF@ and+-- @mB@ so as to be able to extract forward results in the backtracking+-- phase.++class GenBacktrackTable t (mF :: * -> *) (mB :: * -> *) where+  data Backtrack t (mF :: * -> *) (mB :: * -> *) :: *+  type BacktrackIndex t :: *+  toBacktrack :: t -> (forall a . mF a -> mB a) {- -> (BacktrackIndex t -> BacktrackIndex t -> mB [r]) -} -> Backtrack t mF mB++-- instance Build (TW (Backtrack t mF mB) f)+

@@ -0,0 +1,442 @@++module ADP.Fusion.Core.SynVar.Fill where++import           Control.Monad+import           Control.Monad.Morph (hoist, MFunctor (..))+import           Control.Monad.Primitive+import           Control.Monad.ST+import           Control.Monad.Trans.Class (lift, MonadTrans (..))+import           Control.Monad (when,forM_)+import           Data.Dynamic+import           Data.List (nub,sort,group)+import           Data.Maybe (fromJust)+import           Data.Proxy+import           Data.Type.Equality+import           Data.Vector.Fusion.Util (Id(..))+import           Debug.Trace (traceShow)+import           GHC.Exts (inline)+import           GHC.TypeNats+import qualified Data.Data as D+import qualified Data.List as L+import qualified Data.Typeable as T+import qualified Data.Vector as V+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Mutable as VM+import qualified Data.Vector.Unboxed as VU+import qualified GHC.Generics as G+import           System.IO.Unsafe+import           System.CPUTime+import           GHC.Conc (pseq)++import           Data.PrimitiveArray++import           ADP.Fusion.Core.SynVar.Array -- TODO we want to keep only classes in here, move instances to the corresponding modules+import           ADP.Fusion.Core.SynVar.Recursive.Type+import           ADP.Fusion.Core.SynVar.TableWrap++import           Debug.Trace++++{-++-- | A vanilla context-free grammar++data CFG++-- | This grammar is a multi-cfg in a monotone setting++data MonotoneMCFG+++-- * Unsafely mutate 'ITbls' and similar tables in the forward phase.++-- | Mutate a cell in a stack of syntactic variables.+--+-- TODO generalize to monad morphism via @mmorph@ package. This will allow+-- more interesting @mrph@ functions that can, for example, track some+-- state in the forward phase. (Note that this can be dangerous, we do+-- /not/ want to have this state influence forward results, unless that can+-- be made deterministic, or we'll break Bellman)++class MutateCell (h ∷ *) (s ∷ *) (im ∷ * → *) i where+  mutateCell+    ∷ (Monad om, PrimMonad om)+    ⇒ Proxy h+    → Int+    → Int+    → (forall a . im a → om a)+    → s+    → LimitType i+    → i+    → om ()++-- |++class MutateTables (h :: *) (s :: *) (im :: * -> *) where+  mutateTables :: (Monad om, PrimMonad om) => Proxy h -> (forall a . im a -> om a) -> s -> om s++class TableOrder (s :: *) where+  tableLittleOrder :: s -> [Int]+  tableBigOrder :: s -> [Int]++instance TableOrder Z where+  tableLittleOrder Z = []+  tableBigOrder Z = []+  {-# Inline tableLittleOrder #-}+  {-# Inline tableBigOrder #-}++instance+  ( TableOrder ts+  , KnownNat bo+--  , KnownNat lo+  ) ⇒ TableOrder (ts:.TwITbl bo im arr c i x) where+  tableLittleOrder (ts:.TW (ITbl tlo _ _) _) =+    let -- tlo = fromIntegral $ natVal (Proxy ∷ Proxy lo)+    in  tlo : tableLittleOrder ts+  tableBigOrder    (ts:.TW (ITbl _ _ _) _) =+    let tbo = fromIntegral $ natVal (Proxy ∷ Proxy bo)+    in  tbo : tableBigOrder ts+  {-# Inline tableLittleOrder #-}+  {-# Inline tableBigOrder #-}++-- | @IRec@s do not need an order, given that they do not memoize.++instance (TableOrder ts) => TableOrder (ts:.TwIRec im c i x) where+  tableLittleOrder (ts:._) = tableLittleOrder ts+  tableBigOrder    (ts:._) = tableBigOrder ts+  {-# Inline tableLittleOrder #-}+  {-# Inline tableBigOrder #-}++-- ** individual instances for filling a *single cell*++instance+  (+  ) => MutateCell p Z im i where+  mutateCell _ _ _ _ Z _ _ = return ()+  {-# INLINE mutateCell #-}++instance+  ( MutateCell CFG ts im i+  ) => MutateCell CFG (ts:.TwIRec im c i x) im i where+  mutateCell h bo lo mrph (ts:._) lu i = do+    mutateCell h bo lo mrph ts lu i+  {-# Inline mutateCell #-}++instance+  ( PrimArrayOps  arr i x+  , MPrimArrayOps arr i x+  , MutateCell CFG ts im i+  , KnownNat bo+--  , KnownNat lo+  ) => MutateCell CFG (ts:.TwITbl bo im arr c i x) im i where+  mutateCell h bo lo mrph (ts:.TW (ITbl tlo c arr) f) lu i = do+    let tbo = fromIntegral $ natVal (Proxy ∷ Proxy bo)+--        tlo = fromIntegral $ natVal (Proxy ∷ Proxy lo)+    mutateCell h bo lo mrph ts lu i+    when (bo==tbo && lo==tlo) $ do+      marr <- unsafeThaw arr+      z <- (inline mrph) $ f lu i+      writeM marr i z+  {-# INLINE mutateCell #-}++{-+ - TODOThe following code goes into ADPfusionSubword!+ -+type ZS2 = Z:.Subword I:.Subword I++instance+  ( PrimArrayOps  arr ZS2 x+  , MPrimArrayOps arr ZS2 x+  , MutateCell MonotoneMCFG ts im ZS2+  ) => MutateCell MonotoneMCFG (ts:.TwITbl im arr c ZS2 x) im ZS2 where+  mutateCell h bo lo mrph (ts:.TW (ITbl tbo tlo c arr) f) lu iklj@(Z:.Subword (i:.k):.Subword(l:.j)) = do+    mutateCell h bo lo mrph ts lu iklj+    when (bo==tbo && lo==tlo && k<=l) $ do+      marr <- unsafeThaw arr+      z <- (inline mrph) $ f lu iklj+      writeM marr iklj z+  {-# INLINE mutateCell #-}++instance+  ( PrimArrayOps arr (Subword I) x+  , MPrimArrayOps arr (Subword I) x+  , MutateCell h ts im (Z:.Subword I:.Subword I)+  ) => MutateCell h (ts:.TwITbl im arr c (Subword I) x) im (Z:.Subword I:.Subword I) where+  mutateCell h bo lo mrph (ts:.TW (ITbl tbo tlo c arr) f) lu@(Z:.Subword (l:._):.Subword(_:.u)) ix@(Z:.Subword (i1:.j1):.Subword (i2:.j2)) = do+    mutateCell h bo lo mrph ts lu ix+    when (bo==tbo && lo==tlo && i1==i2 && j1==j2) $ do+      let i = i1+      let j = j1+      marr <- unsafeThaw arr+      z <- (inline mrph) $ f (subword l u) (subword i j)+      writeM marr (subword i j) z+  {-# Inline mutateCell #-}+-}+++-- ** individual instances for filling a complete table and extracting the+-- bounds++instance+  ( MutateCell h (ts:.TwITbl bo im arr c i x) im i+  , PrimArrayOps arr i x+  , Show i+  , IndexStream i+  , TableOrder (ts:.TwITbl bo im arr c i x)+  ) => MutateTables h (ts:.TwITbl bo im arr c i x) im where+  mutateTables h mrph tt@(_:.TW (ITbl lo _ arr) _) = do+    let to = upperBound arr+    -- TODO (1) find the set of orders for the synvars+    let !tbos = VU.fromList . nub . sort $ tableBigOrder tt+    let !tlos = VU.fromList . nub . sort $ tableLittleOrder tt+    VU.forM_ tbos $ \bo ->+      case (VU.length tlos) of+        1 -> let lo = VU.head tlos+             in  flip SM.mapM_ (streamUp zeroBound' to) $ \k ->+                  mutateCell h bo lo (inline mrph) tt to k+        -- TODO each big-order group should be allowed to have its own sets+        -- of bounds. within a group, it doesn't make a lot of sense to+        -- have different bounds? Is there a use case for that even?+        _ -> flip SM.mapM_ (streamUp zeroBound' to) $ \k ->+              VU.forM_ tlos $ \lo ->+                mutateCell h bo lo (inline mrph) tt to k+    return tt+  {-# INLINE mutateTables #-}++-- | Default table filling, assuming that the forward monad is just @IO@.+--+-- TODO generalize to @MonadIO@ or @MonadPrim@.++mutateTablesDefault :: MutateTables CFG t Id => t -> t+mutateTablesDefault t = unsafePerformIO $ mutateTables (Proxy :: Proxy CFG) (return . unId) t+{-# INLINE mutateTablesDefault #-}++-- | Mutate tables, but observe certain hints. We use this for monotone+-- mcfgs for now.++mutateTablesWithHints :: MutateTables h t Id => Proxy h -> t -> t+mutateTablesWithHints h t = unsafePerformIO $ mutateTables h (return . unId) t+++++++mutateTablesST t = runST $ mutateTablesNew t+{-# Inline mutateTablesST #-}++class CountNumberOfCells t where+  countNumberOfCells ∷ t → Integer++instance CountNumberOfCells Z where+  countNumberOfCells Z = 0++instance+  ( CountNumberOfCells ts+  , Index i+  , PrimArrayOps arr i x+  ) ⇒ CountNumberOfCells (ts:.TwITbl bo Id arr c i x) where+  countNumberOfCells (ts:.(TW (ITbl lo _ arr) fun)) =+    countNumberOfCells ts + (product . totalSize $ upperBound arr)++data PerfCounter = PerfCounter+  { picoSeconds   :: !Integer+  , seconds       :: !Double+  , numberOfCells :: !Integer+  }+  deriving (Eq,Ord,Show)++data Mutated ts = Mutated+  { mutatedTables ∷ !ts+  , perfCounter   ∷ !PerfCounter+  , eachBigPerfCounter  ∷ [PerfCounter]+  }++-- | +--+-- TODO new way how to do table filling. Because we now have heterogeneous+-- tables (i) group tables by @big order@ into different bins; (ii) check+-- that each bin has the same bounds (needed? -- could we have+-- smaller-sized tables once in a while); (iii) run each bin one after the+-- other+--+-- TODO measure performance penalty, if any. We might need liberal+-- INLINEABLE, and specialization. On the other hand, we can do the+-- freeze/unfreeze outside of table filling.++mutateTablesNew+  :: forall t m .+     ( TableOrder t+     , TSBO t+     , Monad m+     , PrimMonad m+     , CountNumberOfCells t+     )+  => t+  -> m (Mutated t)+mutateTablesNew ts = do+  -- sort the tables according to [bigorder,type,littleorder]. For each+  -- @bigorder@, we should have only one @type@ and can therefor do the+  -- following (i) get subset of the @ts@, (ii) use outermost of @ts@ to+  -- get bounds, (iii) fill these tables+  -- let !tbos = VU.fromList . nub . sort $ tableBigOrder ts+  let justOrder = L.map (\d → (qBigOrder d, qLittleOrder d))+  let ds = L.sort $ asDyn ts+  let goM ∷ (Monad m, PrimMonad m) ⇒ [Q] → [PerfCounter] → m [PerfCounter]+      goM [] ps = return $ reverse ps+      goM xs ps = do+        (ys,p) <- fillWithDyn xs ts+        goM ys (p:ps)+      {-# Inlinable goM #-}+  startTime ← unsafeIOToPrim getCPUTime+  ps ← goM ds []+  stopTime  ← unsafeIOToPrim getCPUTime+  let deltaTime = max 1 $ stopTime - startTime+  return $! Mutated+    { mutatedTables = ts+    , perfCounter   = PerfCounter+        { picoSeconds   = deltaTime+        , seconds       = 1e-12 * fromIntegral deltaTime+        , numberOfCells = countNumberOfCells ts+        }+    , eachBigPerfCounter = ps+    }+{-# Inline mutateTablesNew #-}++data Q = Q+  { qBigOrder     :: Int+  , qLittleOrder  :: Int+  , qTypeRep      :: T.TypeRep+  , qObject       :: Dynamic+  , qTable        :: Dynamic+  , qFunction     :: Dynamic+  }+  deriving (Show)++instance Eq Q where+  Q bo1 lo1 tr1 _ _ _ == Q bo2 lo2 tr2 _ _ _ = (bo1,tr1,lo1) == (bo2,tr2,lo2)++instance Ord Q where+  Q bo1 lo1 tr1 _ _ _ `compare` Q bo2 lo2 tr2 _ _ _ = (bo1,lo1,tr1) `compare` (bo2,lo2,tr2)++-- | Find the outermost table that has a certain big order and then fill+-- from there.++class TSBO t where+  asDyn :: t -> [Q]+  fillWithDyn :: (Monad m, PrimMonad m) => [Q] -> t -> m ([Q], PerfCounter)++instance TSBO Z where+  asDyn Z = []+  fillWithDyn qs Z = return (qs, PerfCounter 0 0 0)+  {-# Inlinable asDyn #-}+  {-# Inline fillWithDyn #-}++instance+ ( TSBO ts+ , Typeable arr+ , Typeable c+ , Typeable i+ , Typeable x+ , PrimArrayOps arr i x+ , MPrimArrayOps arr i x+ , IndexStream i+ , KnownNat bo+-- , KnownNat lo+ ) => TSBO (ts:.TwITbl bo Id arr c i x) where+  asDyn (ts:.t@(TW (ITbl lo _ arr) fun)) =+    let bo = fromIntegral $ natVal (Proxy ∷ Proxy bo)+--        lo = fromIntegral $ natVal (Proxy ∷ Proxy lo)+    in  Q bo lo (T.typeOf t) (toDyn t) (toDyn arr) (seq fun $ toDyn fun) : asDyn ts+  fillWithDyn qs (ts:.t@(TW (ITbl _ _ arrDirect) fDirect)) = do+    let to = upperBound arrDirect+        bo = fromIntegral $ natVal (Proxy ∷ Proxy bo)+--        lo = fromIntegral $ natVal (Proxy ∷ Proxy lo)+    -- @hs@ are all tables that can be filled here+    -- @ns@ are all tables we can't fill and need to process further down+    -- the line+    -- TODO FIXME FIXME FIXME why are the typereps different???+    let (hs,ns) = L.span (\Q{..} -> qBigOrder == bo) qs -- && qTypeRep == T.typeOf t) qs+    if null hs+      then fillWithDyn qs ts+      else do+        let ms = Prelude.map concreteTW hs+            af = Prelude.map concreteAF hs+            concreteTW  = (maybe (error "fromDynamic should not fail!")+                           (\x -> x `asTypeOf` t)+                          . fromDynamic . qObject)+            concreteAF q  = ( (`asTypeOf` arrDirect) . fromJust . fromDynamic $ qTable    q+                            , (`asTypeOf` fDirect)   . fromJust . fromDynamic $ qFunction q+                            )+        -- We have a single table and should short-circuit here+        --+        -- TODO we should specialize for tables of lengh @1..k@ for some+        -- small k. For @1@ and Needleman-Wunsch, we have a very nice @1.8@+        -- seconds down to @1.25@ seconds. :-)+        --+        -- TODO how about+        -- case ms of+        --   [a] -> bla+        --   [a,b] -> bla+        --   [a,b,c] -> bla+        --   [a:b:c:d:ms'] -> bla >> go ms'+        --   measure if this yields meaningful performance improvements+        --+        -- TODO also consider if we maybe just put marrfs into a vector+        --+        -- TODO we should use TH here.+        --+        -- (1) Have @Proxy @0@, say to set up big and small orders -- this+        -- gives us the order on the type level. @data One = One, data Two+        -- = Two, ...@ might be easier... maybe this is not too annoying to+        -- write using type equality+        -- +        -- (2) Then deconstruct the @ts:.t@ things with TH into the correct+        -- pieces.+        --+        -- (3) Finally generate fill code. This should yield to performance+        -- similar to what we have here with the @case of 1@ construction,+        -- because @fDirect@ is partially floated out.+        --+        marrfs <- V.fromList <$> Prelude.mapM (\(TW (ITbl _ _ arr) f) -> unsafeThaw arr >>= \marr -> return (marr,f)) ms+        startTime ← unsafeIOToPrim getCPUTime+        case (V.length marrfs) of+          1 -> do -- let (!marr,!f) = marrfs V.! 0   -- this takes 1.3 seconds for NeedlemanWunsch+                  -- marr <- unsafeThaw arrDirect  -- this takes 0.8 seconds for NeedlemanWunsch+                  marr <- unsafeThaw arrDirect -- (fst $ af!!0)  -- this takes 1.3 seconds for NeedlemanWunsch+                  let !ffff = fDirect --snd $ af!!0+                  flip SM.mapM_ (streamUp zeroBound' to) $ \k -> do+                    -- TODO @inline mrph@ ...+                    z <- (return . unId) $ fDirect to k+                    writeM marr k z+        -- We have more than one table in will work over the list of tables+          _ -> do flip SM.mapM_ (streamUp zeroBound' to) $ \k ->+                    V.forM_ marrfs $ \(marr,f) -> do+                      z <- (return . unId) $ f to k+                      writeM marr k z+        -- traceShow (hs,length ms) $+        stopTime ← unsafeIOToPrim getCPUTime+        let deltaTime = stopTime - startTime+        let perf = PerfCounter+              { picoSeconds   = deltaTime+              , seconds       = 1e-12 * fromIntegral deltaTime+              , numberOfCells = sum $ Prelude.map (\(TW t _) → product . totalSize . upperBound $ iTblArray t) ms+              }+        return (ns, perf)+  {-# Inline fillWithDyn #-}++-- We don't need to capture @IRec@ tables as no table-filling takes place+-- for those tables. @asDyn@ therefore just collects on the remaining @ts@,+-- while @fillWithDyn@ hands of to the next possible table.++instance+  ( TSBO ts+  ) => TSBO (ts:.TwIRec Id c i x) where+  asDyn (ts:.t@(TW (IRec _ _) _)) = asDyn ts+  fillWithDyn qs (ts:._) = fillWithDyn qs ts+  {-# Inlinable asDyn #-}+  {-# Inline fillWithDyn #-}++-}+

@@ -0,0 +1,324 @@++-- |+--+-- TODO Need to add additional type family instances as required.+--+-- TODO Need to have little order nats as well.++module ADP.Fusion.Core.SynVar.FillTyLvl where++import           Control.DeepSeq+import           Control.Monad.Primitive+import           Control.Monad.ST+import           Data.Proxy+import           Data.Singletons.Prelude.Bool+import           Data.Singletons.Prelude.Bool+import           Data.Singletons.Prelude.List+import           Data.Type.Equality+import           Data.Vector.Fusion.Util (Id(..))+import           GHC.Exts+import           GHC.Generics+import           GHC.TypeNats+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Unboxed as VU+import           System.CPUTime+import           Text.Printf++import           Data.PrimitiveArray++import           ADP.Fusion.Core.SynVar.TableWrap+import           ADP.Fusion.Core.SynVar.Array++++--  -- | Fill/mutate tables using @ST@.+--  +--  fillTablesST+--    ∷ forall bigOrder ts+--    . ( bigOrder ~ BigOrderNats ts+--      , EachBigOrder bigOrder ts+--      )+--    ⇒ ts+--    → ts+--  {-# Inline fillTablesST #-}+--  fillTablesST ts = runST $ fillTables ts++-- |++fillTables+--  ∷ Proxy (BigOrderNats ts)+--  -- ^ Proxy that provides the set of @BigOrder@ naturals+  ∷ forall bigOrder s ts+  . ( bigOrder ~ BigOrderNats ts+    , EachBigOrder bigOrder ts+    , CountNumberOfCells 0 ts+    )+  ⇒ ts+  -- ^ The tables+  → ST s (Mutated ts)+{-# Inline fillTables #-}+fillTables ts = do+  startTime ← unsafeIOToPrim getCPUTime+  ps ← eachBigOrder (Proxy ∷ Proxy bigOrder) ts+  stopTime  ← unsafeIOToPrim getCPUTime+  let deltaTime = max 1 $ stopTime - startTime+  return $! Mutated+    { mutatedTables = ts+    , perfCounter   = PerfCounter+        { picoSeconds   = deltaTime+        , seconds       = 1e-12 * fromIntegral deltaTime+        , numberOfCells = countNumberOfCells (Nothing ∷ Maybe (Proxy 0)) ts+        }+    , eachBigPerfCounter = ps+    }++-- | This type class instanciates to the specialized machinery for each+-- @BigOrder Natural@ number.++class EachBigOrder (boNats ∷ [Nat]) ts where+  eachBigOrder ∷ Proxy boNats → ts → ST s [PerfCounter]++-- | No more big orders to handle.++instance EachBigOrder '[] ts where+  {-# Inline eachBigOrder #-}+  eachBigOrder Proxy _ = return []++-- | handle this big order.++instance+  ( EachBigOrder ns ts+  , ThisBigOrder n (IsThisBigOrder n ts) ts+  , CountNumberOfCells n ts+  ) ⇒ EachBigOrder (n ': ns) ts where+  {-# Inline eachBigOrder #-}+  eachBigOrder Proxy ts = do+    startTime ← unsafeIOToPrim getCPUTime+    thisBigOrder (Proxy ∷ Proxy n) (Proxy ∷ Proxy (IsThisBigOrder n ts)) ts+    stopTime  ← unsafeIOToPrim getCPUTime+    let deltaTime = max 1 $ stopTime - startTime+    ps ← eachBigOrder (Proxy ∷ Proxy ns) ts+    let p = PerfCounter+              { picoSeconds   = deltaTime+              , seconds       = 1e-12 * fromIntegral deltaTime+              , numberOfCells = countNumberOfCells (Just (Proxy ∷ Proxy n)) ts+              }+    return $ p:ps++-- |++class ThisBigOrder (boNat ∷ Nat) (thisOrder ∷ Bool) ts where+  thisBigOrder ∷ Proxy boNat → Proxy thisOrder → ts → ST s ()+  getAllBounds ∷ Proxy boNat → Proxy thisOrder → ts → [()]++instance ThisBigOrder boNat anyOrder Z where+  {-# Inline thisBigOrder #-}+  thisBigOrder Proxy Proxy Z = return ()+  {-# Inline getAllBounds #-}+  getAllBounds Proxy Proxy Z = []++-- | We have found the first table for our big order. Extract the bounds and+-- hand over to small order. We do not need to check for another big order with+-- this nat, since all tables are now being filled by the small order.++instance+  ( smallOrder ~ SmallOrderNats (ts:.TwITbl bo so m arr c i x)+  , EachSmallOrder boNat smallOrder (ts:.TwITbl bo so m arr c i x) i+  , PrimArrayOps arr i x+  , IndexStream i+  ) ⇒ ThisBigOrder boNat True (ts:.TwITbl bo so m arr c i x) where+  {-# Inline thisBigOrder #-}+  thisBigOrder Proxy Proxy tst@(_:.TW (ITbl _ arr) _) = do+    let to = upperBound arr+    let allBounds = getAllBounds (Proxy ∷ Proxy boNat) (Proxy ∷ Proxy True) tst+    -- TODO check bounds+    flip SM.mapM_ (streamUp zeroBound' to) $ \k ->+      eachSmallOrder (Proxy ∷ Proxy boNat) (Proxy ∷ Proxy smallOrder) tst k+  {-# Inline getAllBounds #-}+  getAllBounds Proxy Proxy (ts:.t) = undefined++-- | Go down the tables until we find the first table for our big order.++instance+  ( ThisBigOrder n (IsThisBigOrder n ts) ts+  ) ⇒ ThisBigOrder n False (ts:.t) where+  {-# Inline thisBigOrder #-}+  thisBigOrder Proxy Proxy (ts:.t) =+    thisBigOrder (Proxy ∷ Proxy n) (Proxy ∷ Proxy (IsThisBigOrder n ts)) ts++-- |++class EachSmallOrder (bigOrder ∷ Nat) (smallOrders ∷ [Nat]) ts i where+  eachSmallOrder+    ∷ Proxy bigOrder+    -- ^ Only fill exactly this big order+    → Proxy smallOrders+    -- ^ These are all the small order to go through.+    → ts+    -- ^ set of tables.+    → i+    -- ^ index to update.+    → ST s ()++-- | Went through all tables, nothing more to do.++instance EachSmallOrder bigOrder '[] ts i where+  {-# Inline eachSmallOrder #-}+  eachSmallOrder Proxy Proxy ts i = return ()++-- | ++instance+  ( EachSmallOrder bigOrder so ts i+  , isThisBigOrder ~ IsThisBigOrder bigOrder ts+  , isThisSmallOrder ~ IsThisSmallOrder s ts+  , isThisOrder ~ (isThisBigOrder && isThisSmallOrder)+  , ThisSmallOrder bigOrder s isThisOrder ts i+  ) ⇒ EachSmallOrder bigOrder (s ': so) ts i where+  {-# Inline eachSmallOrder #-}+  eachSmallOrder Proxy Proxy ts i = do+    -- fill all tables that have the same big & small order+    thisSmallOrder (Proxy ∷ Proxy bigOrder) (Proxy ∷ Proxy s) (Proxy ∷ Proxy isThisOrder) ts i+    -- fill tables with the next small order+    eachSmallOrder (Proxy ∷ Proxy bigOrder) (Proxy ∷ Proxy so) ts i++-- |++class ThisSmallOrder (bigNat ∷ Nat) (smallNat ∷ Nat) (thisOrder ∷ Bool) ts i where+  thisSmallOrder ∷ Proxy bigNat → Proxy smallNat → Proxy thisOrder → ts → i → ST s ()++instance ThisSmallOrder b s any Z i where+  {-# Inline thisSmallOrder #-}+  thisSmallOrder _ _ _ _ _ = return ()++instance+  ( isThisBigOrder ~ IsThisBigOrder bigOrder ts+  , isThisSmallOrder ~ IsThisSmallOrder smallOrder ts+  , isThisOrder ~ (isThisBigOrder && isThisSmallOrder)+  , ThisSmallOrder bigOrder smallOrder isThisOrder ts i+  ) ⇒ ThisSmallOrder bigOrder smallOrder 'False (ts:.t) i where+  {-# Inline thisSmallOrder #-}+  thisSmallOrder Proxy Proxy Proxy (ts:.t) i =+    thisSmallOrder (Proxy ∷ Proxy bigOrder) (Proxy ∷ Proxy smallOrder) (Proxy ∷ Proxy isThisOrder) ts i++-- |+--+-- TODO generalize from @Id@ to any monad in a stack with a primitive base++instance+  ( PrimArrayOps arr i x+  , MPrimArrayOps arr i x+  , isThisBigOrder ~ IsThisBigOrder bigOrder ts+  , isThisSmallOrder ~ IsThisSmallOrder smallOrder ts+  , isThisOrder ~ (isThisBigOrder && isThisSmallOrder)+  , ThisSmallOrder bigOrder smallOrder isThisOrder ts i+  ) ⇒ ThisSmallOrder bigOrder smallOrder 'True (ts:.TwITbl bo so Id arr c i x) i where+  {-# Inline thisSmallOrder #-}+  thisSmallOrder Proxy Proxy Proxy (ts:.TW (ITbl _ arr) f) i = do+    let uB = upperBound arr+    marr <- unsafeThaw arr+    z ← return . unId $ (inline f) uB i+    writeM marr i z+    -- TODO need to write test case that checks that all tables are always filled+    thisSmallOrder (Proxy ∷ Proxy bigOrder) (Proxy ∷ Proxy smallOrder) (Proxy ∷ Proxy isThisOrder) ts i++-- | The set of arrays to fill is a tuple of the form @(Z:.a:.b:.c)@. Here, we+-- extract the big order @Nat@s. The set of @Nat@s being returned is already+-- ordered with the smallest @Nat@ up front.++type BigOrderNats arr = Nub (Sort (BigOrderNats' arr))++type family BigOrderNats' arr ∷ [Nat]++type instance BigOrderNats' Z = '[]++type instance BigOrderNats' (ts:.TwITbl bo so m arr c i x) = bo ': BigOrderNats' ts++++type family IsThisBigOrder (n ∷ Nat) arr ∷ Bool++type instance IsThisBigOrder n Z = 'False++type instance IsThisBigOrder n (ts:.TwITbl bo so m arr c i x) = n == bo++++type SmallOrderNats arr = Nub (Sort (SmallOrderNats' arr))++type family SmallOrderNats' arr ∷ [Nat]++type instance SmallOrderNats' Z = '[]++-- TODO fix small order++type instance SmallOrderNats' (ts:.TwITbl bo so m arr c i x) = so ': SmallOrderNats' ts++++type family IsThisSmallOrder (n ∷ Nat) arr ∷ Bool++type instance IsThisSmallOrder n Z = 'False++-- TODO fix small order comparision++type instance IsThisSmallOrder n (ts:.TwITbl bo so m arr c i x) = n == so++data Mutated ts = Mutated+  { mutatedTables ∷ !ts+  , perfCounter   ∷ !PerfCounter+  , eachBigPerfCounter  ∷ [PerfCounter]+  }+  deriving (Eq,Ord,Show,Generic)++instance NFData ts ⇒ NFData (Mutated ts)++data PerfCounter = PerfCounter+  { picoSeconds   :: !Integer+  , seconds       :: !Double+  , numberOfCells :: !Integer+  }+  deriving (Eq,Ord,Show,Generic)++instance NFData PerfCounter++showPerfCounter ∷ PerfCounter → String+{-# NoInline showPerfCounter #-}+showPerfCounter PerfCounter{..} =+  let cellsSecond = round $ fromIntegral numberOfCells / seconds+      m ∷ Integer = 1000000+  in  printf "%.4f seconds, %d,%06d cells @ %d,%06d cells/second"+             seconds+             (numberOfCells `div` m) (numberOfCells `mod` m)+             (cellsSecond `div` m) (cellsSecond `mod` m)++-- | Adding two 'PerfCounter's yields the time they take together.++instance Num PerfCounter where+  PerfCounter p1 s1 n1 + PerfCounter p2 s2 n2 = PerfCounter (p1+p2) (s1+s2) (n1+n2)+++class CountNumberOfCells (n ∷ Nat) t where+  countNumberOfCells ∷ Maybe (Proxy n) → t → Integer++instance CountNumberOfCells n Z where+  {-# NoInline countNumberOfCells #-}+  countNumberOfCells p Z = 0++instance+  ( CountNumberOfCells n ts+  , Index i+  , PrimArrayOps arr i x+  , KnownNat n+  , KnownNat bo+  ) ⇒ CountNumberOfCells n (ts:.TwITbl bo so Id arr c i x) where+  {-# NoInline countNumberOfCells #-}+  countNumberOfCells mayP (ts:.(TW (ITbl _ arr) fun)) =+    let n  = natVal (Proxy ∷ Proxy n)+        bo = natVal (Proxy ∷ Proxy bo)+        cs = countNumberOfCells mayP ts+        c  = product . totalSize $ upperBound arr+    in  case mayP of+      Nothing → cs + c+      Just _  → cs + if n==bo then c else 0+

@@ -0,0 +1,140 @@++-- | Classes that enumerate the index structure necessary for actually+-- performing the indexing.+--+-- TODO Currently, we only provide dense index generation.++module ADP.Fusion.Core.SynVar.Indices where++import Data.Proxy (Proxy(..))+import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,flatten,Step(..))+import Prelude hiding (map,head,mapM)++import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi+import ADP.Fusion.Core.TyLvlIx++++-- | This type classes enable enumeration both in single- and multi-dim+-- cases. The type @a@ is the type of the /full stack/ of indices, i.e. the+-- full multi-tape problem.+--+-- @pos@ is the positional information,+-- @s@ is the element type over the index @ix@,+-- @ minSize@ the minimal size or width to request from the syntactic variable,+-- @tableIx@ the index type of the table to walk over,+-- and @ix@ the actual index.++class AddIndexDense pos elm minSize tableIx ix where+  addIndexDenseGo+    ∷ (Monad m)+    ⇒ Proxy pos+    -- ^ Positional information in the rule (static/variable/etc)+    → minSize+    -- ^ Minimal size of the structure under consideration. We might want to+    -- constrain enumeration over syntactic variables to only consider at least+    -- "size>=1" cases. Normally, a syntactic variable may be of size 0 as+    -- well, but with rules like @X -> X X@, we don't want to have one of the+    -- @X@'s on the r.h.s. be of size 0.+    → LimitType tableIx+    -- ^ The upper limit imposed by the structure to traverse over.+    → LimitType ix+    -- ^ The upper limit imposed by the rule that traverses.+    → ix+    -- ^ The current index for the full rule.+    → Stream m (SvState elm Z Z)+    -- ^ Initial stream state with @Z@ero indices.+    → Stream m (SvState elm tableIx ix)+    -- ^ The type of the full stream.++instance AddIndexDense pos elm Z Z Z where+  addIndexDenseGo _ _ _ _ _ = id+  {-# Inline addIndexDenseGo #-}++-- | @SvState@ holds the state that is currently being built up by+-- @AddIndexDense@. We have both @tIx@ (and @tOx@) and @iIx@ (and @iOx@).+-- For most index structures, the indices will co-incide; however for some,+-- this will not be true -- herein for @Set@ index structures.++data SvState elm tableIx ix = SvS+  { sS  ∷ !elm+  -- ^ state coming in from the left+  , tx  ∷ !tableIx+  -- ^ @I/C@ building up state to index the @table@.+  , iIx ∷ !(RunningIndex ix)+  -- ^ @I/C@ building up state to hand over to next symbol+  }+++-- | Given an incoming stream with indices, this adds indices for the+-- current syntactic variable / symbol.++addIndexDense+  ∷ ( Monad m+    , AddIndexDense pos elm minSize tableIx ix+    , elm ~ Elm x0 i0+    , Element x0 i0+    )+  ⇒ Proxy pos+  → minSize+  → LimitType tableIx+  → LimitType ix+  → ix+  → Stream m elm+  → Stream m (elm,tableIx,RunningIndex ix)+addIndexDense pos minSize tableBound upperBound ix+  = map (\(SvS s z i') -> (s,z,i'))+  . addIndexDenseGo pos minSize tableBound upperBound ix+  . map (\s -> (SvS s Z RiZ))+{-# Inline addIndexDense #-}++-- | In case of 1-dim tables, we wrap the index creation in a multi-dim+-- system and remove the @Z@ later on. This allows us to have to write only+-- a single instance.++addIndexDense1+  ∷ forall m pos x0 a ix minSize tableIx elm+  . ( Monad m+    , AddIndexDense (Z:.pos) (Elm (SynVar1 (Elm x0 a)) (Z:.ix)) (Z:.minSize) (Z:.tableIx) (Z:.ix)+    , GetIndex (Z:.a) (Z:.ix)+    , elm ~ Elm x0 a+    , Element x0 a+    )+  ⇒ Proxy pos+  → minSize+  → LimitType tableIx+  → LimitType ix+  → ix+  → Stream m elm+  → Stream m (elm,tableIx,RunningIndex ix)+addIndexDense1 Proxy minSize tableBound upperBound ix+  = map (\(SvS (ElmSynVar1 s) (Z:.z) (RiZ:.:i')) -> (s,z,i'))+  . addIndexDenseGo (Proxy ∷ Proxy (Z:.pos)) (Z:.minSize) (ZZ:..tableBound) (ZZ:..upperBound) (Z:.ix)+  . map (\s -> (SvS (elmSynVar1 s ix) Z RiZ))+{-# Inline addIndexDense1 #-}++newtype SynVar1 s = SynVar1 s++elmSynVar1 :: s -> i -> Elm (SynVar1 s) (Z:.i)+elmSynVar1 s _ = ElmSynVar1 s+{-# Inline elmSynVar1 #-}++instance (s ~ Elm x0 i, Element x0 i) => Element (SynVar1 s) (Z:.i) where+  newtype Elm (SynVar1 s) (Z:.i) = ElmSynVar1 s+  getIdx (ElmSynVar1 s) = RiZ :.: getIdx s+  {-# Inline getIdx #-}+++-- | Instance headers, we typically need.++type AddIndexDenseContext pos elm x0 i0 minSizes minSize tableIxs tableIx ixs ix =+  ( AddIndexDense pos elm minSizes tableIxs ixs+  , GetIndex (RunningIndex i0) (RunningIndex (ixs:.ix))+  , GetIx (RunningIndex i0) (RunningIndex (ixs:.ix)) ~ (RunningIndex ix)+  , Element x0 i0+  , elm ~ Elm x0 i0+  )+

@@ -0,0 +1,131 @@++module ADP.Fusion.Core.SynVar.Recursive.Type where++import Control.Applicative (Applicative,(<$>),(<*>))+import Control.Monad.Morph+import Data.Proxy+import Data.Strict.Tuple+import Data.Vector.Fusion.Stream.Monadic (Stream,head,map,mapM)+import Prelude hiding (head,map,mapM)++import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi+import ADP.Fusion.Core.SynVar.Axiom+import ADP.Fusion.Core.SynVar.Backtrack+import ADP.Fusion.Core.SynVar.Indices+import ADP.Fusion.Core.SynVar.TableWrap++++-- | A syntactic variable that does not memoize but simplify recurses. One+-- needs to be somewhat careful when using this one. @ITbl@ performs+-- memoization to perform DP in polynomial time (roughly speaking). If the+-- rules for an @IRec@ are of a particular type, they will exponential+-- running time. Things like @X -> X X@ are, for example, rather bad. Rules+-- of the type @X -> Y, Y -> Z@ are ok, if @Y@ is an @IRec@ since we just+-- continue on. The same holds for @Y -> a Y@. Basically, things are safe+-- if there is only a (small) constant number of parses of an @IRec@+-- synvar.++data IRec c i x where+  IRec ∷ { iRecConstraint ∷ !c+         , iRecTo         ∷ !(LimitType i)+         } → IRec c i x++type TwIRec (m ∷ * → *) c i x = TW (IRec c i x) (LimitType i → i → m x)++type TwIRecBt c i x mF mB r = TW (Backtrack (TwIRec mF c i x) mF mB) (LimitType i → i → mB [r])++instance Build (TwIRec   m c i x)++instance Build (TwIRecBt c i x mF mB r)++type instance TermArg (TwIRec m c i x) = x++instance GenBacktrackTable (TwIRec mF c i x) mF mB where+  data Backtrack (TwIRec mF c i x) mF mB = BtIRec !c !(LimitType i) !(LimitType i → i → mB x)+  type BacktrackIndex (TwIRec mF c i x) = i+  toBacktrack (TW (IRec c iT) f) mrph = BtIRec c iT (\lu i -> mrph $ f lu i)+  {-# Inline toBacktrack #-}++++instance+  ( Monad m+  , IndexStream i+  ) ⇒ Axiom (TwIRec m c i x) where+  type AxiomStream (TwIRec m c i x) = m x+  axiom (TW (IRec _ h) fun) = do+    k ← head $ streamDown zeroBound' h+    fun h k+  {-# Inline axiom #-}++instance+  ( Monad mB+  , IndexStream i+  , i ~ j+  , m ~ mB+  ) ⇒ Axiom (TW (Backtrack (TwIRec mF c i x) mF mB) (LimitType j → j → m [r])) where+  type AxiomStream (TW (Backtrack (TwIRec mF c i x) mF mB) (LimitType j → j → m [r])) = mB [r]+  axiom (TW (BtIRec c h fun) btfun) = do+    k <- head $ streamDown zeroBound' h+    btfun h k+  {-# Inline axiom #-}++++instance Element ls i ⇒ Element (ls :!: TwIRec m c u x) i where+  data Elm (ls :!: TwIRec m c u x) i = ElmIRec !x !(RunningIndex i) !(Elm ls i)+  type Arg (ls :!: TwIRec m c u x)   = Arg ls :. x+  getArg (ElmIRec x _ ls) = getArg ls :. x+  getIdx (ElmIRec _ i _ ) = i+  {-# Inline getArg #-}+  {-# Inline getIdx #-}++instance Element ls i ⇒ Element (ls :!: TwIRecBt c u x mF mB r) i where+  data Elm (ls :!: (TwIRecBt c u x mF mB r)) i = ElmBtIRec !x [r] !(RunningIndex i) !(Elm ls i)+  type Arg (ls :!: (TwIRecBt c u x mF mB r))   = Arg ls :. (x, [r])+  getArg (ElmBtIRec x s _ ls) = getArg ls :. (x,s)+  getIdx (ElmBtIRec _ _ i _ ) = i+  {-# Inline getArg #-}+  {-# Inline getIdx #-}++instance+  ( Functor m+  , Monad m+  , pos ~ (ps:.p)+  , posLeft ~ LeftPosTy pos (TwIRec m (cs:.c) (us:.u) x) (is:.i)+  , Element ls (is:.i)+--  , TableStaticVar ps cs us is+--  , TableStaticVar p  c  u  i+  , TableStaticVar (ps:.p) (cs:.c) (us:.u) (is:.i)+  , AddIndexDense pos (Elm ls (is:.i)) (cs:.c) (us:.u) (is:.i)+  , MkStream m posLeft ls (is:.i)+  ) ⇒ MkStream m ('(:.) ps p) (ls :!: TwIRec m (cs:.c) (us:.u) x) (is:.i) where+  mkStream Proxy (ls :!: TW (IRec csc h) fun) grd usu isi+    = mapM (\(s,tt,ii) -> (\res -> ElmIRec res ii s) <$> fun h tt)+    . addIndexDense (Proxy ∷ Proxy pos) csc h usu isi+    $ mkStream (Proxy ∷ Proxy posLeft) ls grd usu (tableStreamIndex (Proxy ∷ Proxy pos) csc h isi)+  {-# Inline mkStream #-}++instance+  ( Applicative mB+  , Monad mB+  , pos ~ (ps :. p)+  , posLeft ~ LeftPosTy pos (TwIRecBt (cs:.c) (us:.u) x mF mB r) (is:.i)+  , Element ls (is:.i)+--  , TableStaticVar (us:.u) (cs:.c) (is:.i)+--  , TableStaticVar ps cs us is+--  , TableStaticVar p  c  u  i+  , TableStaticVar (ps:.p) (cs:.c) (us:.u) (is:.i)+  , AddIndexDense pos (Elm ls (is:.i)) (cs:.c) (us:.u) (is:.i)+  , MkStream mB posLeft ls (is:.i)+  ) => MkStream mB  ('(:.) ps p) (ls :!: TwIRecBt (cs:.c) (us:.u) x mF mB r) (is:.i) where+  mkStream Proxy (ls :!: TW (BtIRec csc h fun) bt) grd usu isi+    = mapM (\(s,tt,ii) -> (\res bb -> ElmBtIRec res bb ii s) <$> fun h tt <*> bt h tt)+    . addIndexDense (Proxy ∷ Proxy pos) csc h usu isi+    $ mkStream (Proxy ∷ Proxy posLeft) ls grd usu (tableStreamIndex (Proxy :: Proxy pos) csc h isi)+  {-# Inline mkStream #-}+

@@ -0,0 +1,200 @@++-- |+--+-- NOTE /highly experimental/++module ADP.Fusion.Core.SynVar.Split.Type+  ( module ADP.Fusion.Core.SynVar.Split.Type+  , Proxy (..)+  ) where++import Data.Proxy+import Data.Strict.Tuple+import Data.Vector.Fusion.Stream.Monadic+import Data.Vector.Fusion.Util (delay_inline)+import Debug.Trace+import GHC.TypeLits+import Prelude hiding (map,mapM)+import Data.Type.Equality++import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi+import ADP.Fusion.Core.SynVar.Array.Type+import ADP.Fusion.Core.SynVar.Backtrack+import ADP.Fusion.Core.SynVar.TableWrap++++data SplitType = Fragment | Final++-- | The @Arg synVar@ means that we probably need to rewrite the internal+-- type resolution now!++type family CalcSplitType splitType varTy where+  CalcSplitType Fragment varTy = ()+  CalcSplitType Final    varTy = varTy++-- | Should never fail?++type family ArgTy argTy where+--  ArgTy Z = Z+  ArgTy (z:.x) = x++-- | Wraps a normal non-terminal and attaches a type-level unique identier+-- and z-ordering (with the unused @Z@ at @0@).+--+-- TODO attach empty/non-empty stuff (or get from non-splitted synvar?)+--+-- TODO re-introduce z-ordering later (once we have a sort fun)++newtype Split (uId :: Symbol) {- (zOrder :: Nat) -} (splitType :: SplitType) synVar = Split { getSplit :: synVar }++-- |+--+-- TODO Here, we probably want to default to a @NonEmpty@ condition. Or at+-- least have different versions of @split@.++split :: Proxy (uId::Symbol) -> {- Proxy (zOrder::Nat) -> -} Proxy (splitType::SplitType) -> synVar -> Split uId splitType synVar+split _ _ = Split+{-# Inline split #-}++--splitNE :: (ModifyConstraint synVar) => Proxy (uId::Symbol) -> {- Proxy (zOrder::Nat) -> -} Proxy (splitType::SplitType) -> synVar -> Split uId splitType synVar+--splitNE _ _ = Split . toNonEmpty+--{-# Inline splitNE #-}++--type Spl uId zOrder splitType = forall synVar . Split uId zOrder splitType synVar++instance Build (Split uId splitType synVar)++instance+  ( Element ls i+  ) => Element (ls :!: Split uId splitType (TwITbl b s m arr c j x)) i where+  -- | @ElmSplitITbl@ carry one additional element of type @i@. We need+  -- those to be able to extract the full index via @collectIx@.+  data Elm     (ls :!: Split uId splitType (TwITbl b s m arr c j x)) i = ElmSplitITbl !(Proxy uId) !(CalcSplitType splitType x) !(RunningIndex i) !(Elm ls i) !i+  type Arg     (ls :!: Split uId splitType (TwITbl b s m arr c j x))   = Arg ls :. (CalcSplitType splitType x)+  type RecElm  (ls :!: Split uId splitType (TwITbl b s m arr c j x)) i = Elm ls i+  getArg (ElmSplitITbl _ x _ ls _) = getArg ls :. x+  getIdx (ElmSplitITbl _ _ i _  _) = i+  getElm (ElmSplitITbl _ _ _ ls _) = ls+  {-# Inline getArg #-}+  {-# Inline getIdx #-}+  {-# Inline getElm #-}++instance+  ( Element ls i+  ) => Element (ls :!: Split uId splitType (TwITblBt b s arr c j x mF mB r)) i where+  data Elm     (ls :!: Split uId splitType (TwITblBt b s arr c j x mF mB r)) i = ElmSplitBtITbl !(Proxy uId) !(CalcSplitType splitType (x, [r])) !(RunningIndex i) !(Elm ls i) !i+  type Arg     (ls :!: Split uId splitType (TwITblBt b s arr c j x mF mB r))   = Arg ls :. (CalcSplitType splitType (x,[r]))+  type RecElm  (ls :!: Split uId splitType (TwITblBt b s arr c j x mF mB r)) i = Elm ls i+  getArg (ElmSplitBtITbl _ xs _ ls _) = getArg ls :. xs+  getIdx (ElmSplitBtITbl _ _  i _  _) = i+  getElm (ElmSplitBtITbl _ _  _ ls _) = ls+  {-# Inline getArg #-}+  {-# Inline getIdx #-}+  {-# Inline getElm #-}++++-- | 'collectIx' gobbles up indices that are tagged with the same symbolic+-- identifier.++collectIx+  :: forall uId ls i .+     ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)+     )+  => Proxy uId -> Elm ls i -> SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)+collectIx p e = splitIxCol p (Proxy :: Proxy (SameSid uId (Elm ls i))) e++-- | Closed type family that gives us a (type) function for type symbol+-- equality.++type family SameSid uId elm :: Bool where+  SameSid uId (Elm (ls :!: Split sId splitType synVar) i) = uId == sId+  SameSid uId (Elm (ls :!: TermSymbol a b            ) i) = SameSid uId (TermSymbol a b)+  SameSid uId M                                           = False+  SameSid uId (TermSymbol a (Split sId splitType synVar)) = OR (uId == sId) (SameSid uId a)+  SameSid uId (Elm (ls :!: l                         ) i) = False++-- | Type-level @(||)@++type family OR a b where+  OR False False = False+  OR a     b     = True++-- | @x ++ y@ but for inductive tuples.+--+-- TODO move to PrimitiveArray++class Zconcat x y where+  type Zpp x y :: *+  zconcat :: x -> y -> Zpp x y++instance Zconcat x Z where+  type Zpp x Z = x+  zconcat x Z = x+  {-# Inline zconcat #-}++instance +  ( Zconcat x z+  ) => Zconcat x (z:.y) where+  type Zpp x (z:.y) = Zpp x z :. y+  zconcat x (z:.y) = zconcat x z :. y+  {-# Inline zconcat #-}++-- WORKS++-- | Actually collect split indices based on if we managed to find the+-- right @Split@ synvar (based on the right symbol).+--+-- TODO this is not completely right, or? Since we should consider+-- inside/outside?+--+-- TODO 'splitIxCol' will need the index type @i@ to combine running index+-- and index into the actual lookup part.++class SplitIxCol (uId::Symbol) (b::Bool) e where+  type SplitIxTy uId b e :: *+  splitIxCol :: Proxy uId -> Proxy b -> e -> SplitIxTy uId b e++++instance SplitIxCol uId b (Elm S i) where+  type SplitIxTy uId b (Elm S i) = Z+  splitIxCol p b (ElmS _) = Z+  {-# Inline splitIxCol #-}+++instance+  ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)+  , Element (ls :!: l) i+  , RecElm (ls :!: l) i ~ Elm ls i+  ) => SplitIxCol uId False (Elm (ls :!: l) i) where+  type SplitIxTy uId False (Elm (ls :!: l) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)+  splitIxCol p b e = collectIx p (getElm e)+  {-# Inline splitIxCol #-}++instance+  ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)+  ) => SplitIxCol   uId True (Elm (ls :!: Split sId splitType (TwITbl b s m arr c j x)) i) where+  type SplitIxTy uId True (Elm (ls :!: Split sId splitType (TwITbl b s m arr c j x)) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i) :. i+  splitIxCol p b (ElmSplitITbl _ _ i e ix) = collectIx p e :. ix+  {-# Inline splitIxCol #-}++instance+  ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)+  ) => SplitIxCol   uId True (Elm (ls :!: Split sId splitType (TwITblBt b s arr c j x mF mB r)) i) where+  type SplitIxTy uId True (Elm (ls :!: Split sId splitType (TwITblBt b s arr c j x mF mB r)) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i) :. i+  splitIxCol p b (ElmSplitBtITbl _ _ i e ix) = collectIx p e :. ix+  {-# Inline splitIxCol #-}++instance+  ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)+  , Zconcat (SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)) (SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b))+  ) => SplitIxCol uId True (Elm (ls :!: TermSymbol a b) i) where+  type SplitIxTy uId True (Elm (ls :!: TermSymbol a b) i) = Zpp (SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)) (SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b))+  splitIxCol p b (ElmTS t i e) = collectIx p e `zconcat` ((error "ElmTS / splitIxCol") {- p t -} :: SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b))+  {-# Inline splitIxCol #-}+

@@ -0,0 +1,15 @@++-- | Wrap the underlying table and the rules. Isomorphic to @(,)@.++module ADP.Fusion.Core.SynVar.TableWrap where++++-- | Wrap tables of type @t@. The tables are strict, the functions @f@ can+-- not be strict, because we need to build grammars recursively.++data TW t f = TW !t f++instance Show t ⇒ Show (TW t f) where+  show (TW t _) = "TW(" ++ show t ++ ")"+

@@ -24,7 +24,7 @@ import qualified Data.Vector.Mutable as VM import qualified Data.Set as S -import           Data.PrimitiveArray ( (:.)(..) , Z(..) )+import           Data.PrimitiveArray.Index.Class ( (:.)(..) , Z(..) )  import           ADP.Fusion.Core.TH.Common 

@@ -0,0 +1,62 @@++-- |+--+-- TODO Rename @Chr@ to @Vtx@, a vertex parser is a generalization of+-- a char parser. But this is only semantics, so not super important to do+-- now.++module ADP.Fusion.Core.Term.Chr where++import           Data.Strict.Tuple+import qualified Data.Vector.Generic as VG++import           Data.PrimitiveArray++import           ADP.Fusion.Core.Classes+import           ADP.Fusion.Core.Multi++++-- | A generic Character parser that reads a single character but allows+-- passing additional information.+--+--  'Chr' expects a function to retrieve @r@ at index position, followed by+--  the actual generic vector with data.++data Chr r x where+  Chr :: VG.Vector v x+      => (v x -> Int -> r)+      -> !(v x)+      -> Chr r x++-- | smart constructor for regular 1-character parsers++chr :: VG.Vector v x => v x -> Chr x x+chr = Chr VG.unsafeIndex+{-# Inline chr #-}++-- | Smart constructor for Maybe Peeking, followed by a character.++chrLeft xs = Chr f xs where+  f xs k = ( xs VG.!? (k-1)+           , VG.unsafeIndex xs k+           )+  {-# Inline [0] f #-}+{-# Inline chrLeft #-}++instance Build (Chr r x)++instance+  ( Element ls i+  ) => Element (ls :!: Chr r x) i where+    data Elm (ls :!: Chr r x) i = ElmChr !r !(RunningIndex i) !(Elm ls i)+    type Arg (ls :!: Chr r x)   = Arg ls :. r+    getArg (ElmChr x _ ls) = getArg ls :. x+    getIdx (ElmChr _ i _ ) = i+    {-# Inline getArg #-}+    {-# Inline getIdx #-}++deriving instance (Show i, Show (RunningIndex i), Show r, Show (Elm ls i)) => Show (Elm (ls :!: Chr r x) i)++type instance TermArg (Chr r x) = r+

@@ -0,0 +1,26 @@++module ADP.Fusion.Core.Term.Deletion where++import Data.Strict.Tuple++import Data.PrimitiveArray++import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi++++data Deletion = Deletion++instance Build Deletion++instance (Element ls i) => Element (ls :!: Deletion) i where+  data Elm (ls :!: Deletion) i = ElmDeletion !(RunningIndex i) !(Elm ls i)+  type Arg (ls :!: Deletion)   = Arg ls :. ()+  getArg (ElmDeletion _ l) = getArg l :. ()+  getIdx (ElmDeletion i _) = i+  {-# Inline getArg #-}+  {-# Inline getIdx #-}++type instance TermArg Deletion = ()+

@@ -0,0 +1,73 @@++module ADP.Fusion.Core.Term.Edge where++import Data.Strict.Tuple+import Data.Proxy++import Data.PrimitiveArray++import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi++++newtype From = From { getFrom :: Int }+  deriving (Eq,Ord,Show)++newtype To = To { getTo :: Int }+  deriving (Eq,Ord,Show)++-- | An edge in a graph. As a parsing symbol, it will provide (From:.To)+-- pairs.++data Edge = Edge++instance Build Edge++instance+  ( Element ls i+  ) => Element (ls :!: Edge) i where+    data Elm (ls :!: Edge) i = ElmEdge !(From:.To) !(RunningIndex i) !(Elm ls i)+    type Arg (ls :!: Edge)   = Arg ls :. (From:.To)+    getArg (ElmEdge e _ ls) = getArg ls :. e+    getIdx (ElmEdge _ i _ ) = i+    {-# Inline getArg #-}+    {-# Inline getIdx #-}++deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: Edge) i)++type instance TermArg Edge = (From:.To)++-- | 'edgeFromTo' creates a @(From:.To)@ structure for edges. How this is+-- filled depends on the @Proxy@. Possible are @Proxy First@ and @Proxy Last@.+-- @First@ denotes that @To@ is the first node to be visited. I.e. @First(From)+-- → Set(To)@. @Last@ on the other hand is @Set(From) → Last(To)@.++class EdgeFromTo k where+  edgeFromTo ∷ Proxy k → SetBoundary → NewBoundary → (From:.To)++newtype SetBoundary = SetBoundary Int++newtype NewBoundary = NewBoundary Int++-- | In case our sets have a @First@ boundary, then we always point from+-- the boundary "into" the set. Hence @SetNode == To@ and @NewNode ==+-- From@.+--+-- @{1,2,(3)} <- (4)@ yields @From 4 :. To 3@. Note the arrow direction @INTO@+-- the set.++instance EdgeFromTo First where+  edgeFromTo Proxy (SetBoundary to) (NewBoundary from) = From from :. To to+  {-# Inline edgeFromTo #-}++-- | And if the set has a @Last@ boundary, then we point from somewhere in+-- the set @To@ the @NewNode@, which is @Last@.+--+-- @{1,2,(3)} -> (4)@ yields @From 3 :. To 4@. Note the arrow direction @OUT+-- OF@ the set.++instance EdgeFromTo Last where+  edgeFromTo Proxy (SetBoundary from) (NewBoundary to) = From from :. To to+  {-# Inline edgeFromTo #-}+

@@ -0,0 +1,35 @@++-- | 'Epsilon' is a global or local starting (or ending, depending on the view)+-- point for a grammar.++module ADP.Fusion.Core.Term.Epsilon where++import Data.Data+import Data.Strict.Tuple+import Data.Typeable+import GHC.Generics(Generic)++import Data.PrimitiveArray++import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi++++data LocalGlobal = Local | Global+  deriving (Eq,Ord,Read,Show,Data,Typeable,Generic)++data Epsilon (lg ∷ LocalGlobal) = Epsilon++instance Build (Epsilon lg)++instance (Element ls i) => Element (ls :!: Epsilon lg) i where+  data Elm (ls :!: Epsilon lg) i = ElmEpsilon !(RunningIndex i) !(Elm ls i)+  type Arg (ls :!: Epsilon lg)   = Arg ls :. ()+  getArg (ElmEpsilon _ l) = getArg l :. ()+  getIdx (ElmEpsilon i _) = i+  {-# Inline getArg #-}+  {-# Inline getIdx #-}++type instance TermArg (Epsilon lg) = ()+

@@ -0,0 +1,49 @@++-- |+--+-- TODO Rename @Chr@ to @Vtx@, a vertex parser is a generalization of+-- a char parser. But this is only semantics, so not super important to do+-- now.++module ADP.Fusion.Core.Term.MultiChr where++import           Data.Strict.Tuple+import           GHC.TypeNats+import qualified Data.Vector.Generic as VG++import           Data.PrimitiveArray++import           ADP.Fusion.Core.Classes+import           ADP.Fusion.Core.Multi++++-- | A multi-character parser.++data MultiChr (c ∷ Nat) (v ∷ * → *) (x ∷ *) where+  MultiChr ∷ VG.Vector v x+           ⇒ !(v x)+           → MultiChr c v x++-- | smart constructor for regular 1-character parsers++multiChr :: VG.Vector v x => v x -> MultiChr c v x+multiChr = MultiChr+{-# Inline multiChr #-}++instance Build (MultiChr c v x)++instance+  ( Element ls i+  ) => Element (ls :!: MultiChr c v x) i where+    data Elm (ls :!: MultiChr c v x) i = ElmMultiChr !(v x) !(RunningIndex i) !(Elm ls i)+    type Arg (ls :!: MultiChr c v x)   = Arg ls :. v x+    getArg (ElmMultiChr x _ ls) = getArg ls :. x+    getIdx (ElmMultiChr _ i _ ) = i+    {-# Inline getArg #-}+    {-# Inline getIdx #-}++deriving instance (Show i, Show (RunningIndex i), Show (v x), Show (Elm ls i)) => Show (Elm (ls :!: MultiChr c v x) i)++type instance TermArg (MultiChr c v x) = v x+

@@ -0,0 +1,30 @@++module ADP.Fusion.Core.Term.PeekIndex where++import Data.Strict.Tuple++import Data.PrimitiveArray++import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi++++data PeekIndex i = PeekIndex++instance Build (PeekIndex i)++instance+  ( Element ls i+  ) => Element (ls :!: PeekIndex i) i where+    data Elm (ls :!: PeekIndex i) i = ElmPeekIndex !i !(RunningIndex i) !(Elm ls i)+    type Arg (ls :!: PeekIndex i)   = Arg ls :. i+    getArg (ElmPeekIndex x _  ls)    = getArg ls :. x+    getIdx (ElmPeekIndex _ i  _ )    = i+    {-# Inline getArg #-}+    {-# Inline getIdx #-}++deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: PeekIndex i) i)++type instance TermArg (PeekIndex i) = PeekIndex i+

@@ -0,0 +1,61 @@++module ADP.Fusion.Core.Term.Str where++import           Data.Strict.Tuple+import           GHC.TypeLits+import           GHC.TypeNats+import qualified Data.Vector.Generic as VG++import           Data.PrimitiveArray++import           ADP.Fusion.Core.Classes+import           ADP.Fusion.Core.Multi++++-- | A @Str@ wraps an input vector and provides type-level annotations on+-- linked @Str@'s, their minimal and maximal size.+--+-- If @linked ∷ Maybe Symbol@ is set to @Just aName@, then all @Str@'s that are+-- part of the same rule share their size information. This allows rules of the+-- kind @X -> a Y b@ where @a,b@ have a common maximal size.+--+-- @minSz@ and @maxSz@ provide minimal and maximal parser width, if set.+--+-- TODO consider if @maxSz@ could do with just @Nat@++data Str (linked ∷ Maybe Symbol) (minSz ∷ Nat) (maxSz ∷ Maybe Nat) v x where+  Str ∷ VG.Vector v x+      ⇒ !(v x)+      → Str linked minSz maxSz v x++-- | Construct string parsers with no special constraints.++manyV ∷ VG.Vector v x ⇒ v x → Str Nothing 0 Nothing v x+manyV = Str+{-# Inline manyV #-}++someV ∷ VG.Vector v x ⇒ v x → Str Nothing 1 Nothing v x+someV = Str+{-# Inline someV #-}++-- TODO really need to be able to remove this system. Forgetting @Build@ gives+-- very strange type errors.++instance Build (Str linked minSz maxSz v x)++instance+  ( Element ls i+  , VG.Vector v x+  ) => Element (ls :!: Str linked minSz maxSz v x) i where+    data Elm (ls :!: Str linked minSz maxSz v x) i = ElmStr !(v x) !(RunningIndex i) !(Elm ls i)+    type Arg (ls :!: Str linked minSz maxSz v x)   = Arg ls :. v x+    getArg (ElmStr x _ ls) = getArg ls :. x+    getIdx (ElmStr _ i _ ) = i+    {-# Inline getArg #-}+    {-# Inline getIdx #-}++deriving instance (Show i, Show (RunningIndex i), Show (v x), Show (Elm ls i)) => Show (Elm (ls :!: Str linked minSz maxSz v x) i)++type instance TermArg (Str linked minSz maxSz v x) = v x+

@@ -0,0 +1,48 @@++-- | 'Switch'es allow enabling and disabling individual rules on a global+-- level.+--+-- TODO Consider moving the switch status to the type level.+-- TODO Consider using patterns for the switch status and encode using @Int@s.++module ADP.Fusion.Core.Term.Switch where++import           Data.Strict.Tuple+import qualified Data.Vector.Generic as VG++import           Data.PrimitiveArray++import           ADP.Fusion.Core.Classes+import           ADP.Fusion.Core.Multi++++-- | Explicit naming of the status of the switch.++data SwitchStatus = Disabled | Enabled+  deriving (Eq,Ord,Show)++-- | Terminal for the switch. The switch status is not given to any function,+-- since processing of the rule already indicates that the switch is enabled --+-- if all other symbols parse successfully. Due to consistency, the type of+-- result is @()@.++data Switch where+  Switch ∷ !SwitchStatus → Switch++instance Build Switch++instance+  ( Element ls i+  ) => Element (ls :!: Switch) i where+    data Elm (ls :!: Switch) i = ElmSwitch !(RunningIndex i) !(Elm ls i)+    type Arg (ls :!: Switch)   = Arg ls :. ()+    getArg (ElmSwitch _ ls) = getArg ls :. ()+    getIdx (ElmSwitch i _ ) = i+    {-# Inline getArg #-}+    {-# Inline getIdx #-}++deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: Switch) i)++type instance TermArg Switch = ()+

@@ -0,0 +1,60 @@++module ADP.Fusion.Core.Term.Test where++import           Data.Strict.Tuple+import qualified Data.Vector.Generic as VG++import           Data.PrimitiveArray++import           ADP.Fusion.Core.Classes+import           ADP.Fusion.Core.Multi++++-- | 'Test' terminals return "strings", i.e. vectors of @Chr@s. They allow+-- the user to specify @[ 0 .. ]@ atoms to be parsed at once. It is+-- possible to both, limit the minimal and maximal number.+--+-- NOTE gadt comments are not parsed by haddock?++{-+data Test v x where+  Test :: VG.Vector v x+        => (Int -> Int -> v x -> v x)  -- @slice@ function+        -> Int                         -- minimal size+        -> Int                         -- maximal size (just use s.th. big if you don't want a limit)+        -> (v x)                       -- the actual vector+        -> Test v x++manyS :: VG.Vector v x => v x -> Test v x+manyS = \xs -> Test VG.unsafeSlice 0 (VG.length xs) xs+{-# Inline manyS #-}++someS :: VG.Vector v x => v x -> Test v x+someS = \xs -> Test VG.unsafeSlice 1 (VG.length xs) xs+{-# Inline someS #-}++strng :: VG.Vector v x => Int -> Int -> v x -> Test v x+strng = \minL maxL xs -> Test VG.unsafeSlice minL maxL xs+{-# Inline strng #-}+-}++data Test v x where+  Test :: VG.Vector v x => v x -> Test v x++instance Build (Test v x)++instance+  ( Element ls i+  ) => Element (ls :!: Test v x) i where+  data Elm (ls :!: Test v x) i = ElmTest !(v x) !(RunningIndex i) !(Elm ls i)+  type Arg (ls :!: Test v x)   = Arg ls :. v x+  getArg (ElmTest x _ ls) = getArg ls :. x+  getIdx (ElmTest _ i _ ) = i+  {-# Inline getArg #-}+  {-# Inline getIdx #-}++deriving instance (Show i, Show (RunningIndex i), Show (v x), Show (Elm ls i)) => Show (Elm (ls :!: Test v x) i)++type instance TermArg (Test v x) = v x+

@@ -1,12 +1,15 @@  -- | Type-level indexing functionality -module ADP.Fusion.Core.TyLvlIx where+module ADP.Fusion.Core.TyLvlIx+  ( module ADP.Fusion.Core.TyLvlIx+  , module GHC.TypeLits+  ) where  import Data.Proxy import GHC.TypeLits -import Data.PrimitiveArray hiding (map)+import Data.PrimitiveArray.Index.Class hiding (map)  import ADP.Fusion.Core.Classes (RunningIndex (..)) @@ -22,49 +25,49 @@  instance GetIndexGo (ix:.i) (my:.m) EQ where   type ResolvedIx (ix:.i) (my:.m) EQ = i-  getIndexGo (ix:.i) _ _ = i-  {-# Inline getIndexGo #-}+  getIndexGo (ix:.i) _ _ = seq ix $ i+  {-# Inline [0] getIndexGo #-}  instance (GetIndexGo ix (my:.m) (CmpNat (ToNat ix) (ToNat (my:.m)))) => GetIndexGo (ix:.i) (my:.m) GT where   type ResolvedIx (ix:.i) (my:.m) GT = ResolvedIx ix (my:.m) (CmpNat (ToNat ix) (ToNat (my:.m)))   getIndexGo (ix:._) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat ix) (ToNat (my:.m))))-  {-# Inline getIndexGo #-}+  {-# Inline [0] getIndexGo #-}  instance (GetIndexGo ix Z (CmpNat (ToNat ix) (ToNat Z))) => GetIndexGo (ix:.i) Z GT where   type ResolvedIx (ix:.i) Z GT = ResolvedIx ix Z (CmpNat (ToNat ix) (ToNat Z))   getIndexGo (ix:._) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat ix) (ToNat Z)))-  {-# Inline getIndexGo #-}+  {-# Inline [0] getIndexGo #-}  instance GetIndexGo Z Z EQ where   type ResolvedIx Z Z EQ = Z   getIndexGo _ _ _ = Z-  {-# Inline getIndexGo #-}+  {-# Inline [0] getIndexGo #-}    instance GetIndexGo (RunningIndex (ix:.i)) (RunningIndex (my:.m)) EQ where   type ResolvedIx (RunningIndex (ix:.i)) (RunningIndex (my:.m)) EQ = RunningIndex i-  getIndexGo (ix:.:i) _ _ = i-  {-# Inline getIndexGo #-}+  getIndexGo (ix:.:i) _ _ = seq ix i+  {-# Inline [0] getIndexGo #-}  instance   ( GetIndexGo (RunningIndex ix) (RunningIndex (my:.m)) (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex (my:.m))))   ) => GetIndexGo (RunningIndex (ix:.i)) (RunningIndex (my:.m)) GT where   type ResolvedIx (RunningIndex (ix:.i)) (RunningIndex (my:.m)) GT = ResolvedIx (RunningIndex ix) (RunningIndex (my:.m)) (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex (my:.m))))   getIndexGo (ix:.:_) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex (my:.m)))))-  {-# Inline getIndexGo #-}+  {-# Inline [0] getIndexGo #-}  instance   ( GetIndexGo (RunningIndex ix) (RunningIndex Z) (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex Z)))   ) => GetIndexGo (RunningIndex (ix:.i)) (RunningIndex Z) GT where   type ResolvedIx (RunningIndex (ix:.i)) (RunningIndex Z) GT = ResolvedIx (RunningIndex ix) (RunningIndex Z) (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex Z)))   getIndexGo (ix:.:_) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex Z))))-  {-# Inline getIndexGo #-}+  {-# Inline [0] getIndexGo #-}  instance GetIndexGo (RunningIndex Z) (RunningIndex Z) EQ where   type ResolvedIx (RunningIndex Z) (RunningIndex Z) EQ = RunningIndex Z-  getIndexGo _ _ _ = RiZ-  {-# Inline getIndexGo #-}+  getIndexGo riz _ _ = riz+  {-# Inline [0] getIndexGo #-}   @@ -83,7 +86,7 @@   -> Proxy myTy   -> GetIx ixTy myTy getIndex ixTy myTy = getIndexGo ixTy (Proxy :: Proxy myTy) (Proxy :: Proxy (CmpNat (ToNat ixTy) (ToNat myTy)))-{-# Inline getIndex #-}+{-# Inline [0] getIndex #-}   

@@ -1,98 +0,0 @@---- |------ 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 #-}--

@@ -1,25 +0,0 @@---- | 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-

@@ -0,0 +1,33 @@++-- | This exports everything needed for sequence-based alignment style+-- algorithms.+--+-- Here are some notes on implementation of the Inside and Outside +--+-- X_j     -> S_{j-1} X_{j-1} c_j+-- Y_{j-1} -> S_?     X_j     c_j+-- Y_j     -> S_{j+1} X_{j+1} c_{j+1}++module ADP.Fusion.PointL+  ( module ADP.Fusion.Core+  , module ADP.Fusion.PointL.Core+  , module ADP.Fusion.PointL.SynVar.Indices+--  , module ADP.Fusion.PointL.SynVar.Recursive+  , module ADP.Fusion.PointL.Term.Chr+  , module ADP.Fusion.PointL.Term.Deletion+  , module ADP.Fusion.PointL.Term.Epsilon+  , module ADP.Fusion.PointL.Term.MultiChr+  , module ADP.Fusion.PointL.Term.Str+  ) where++import ADP.Fusion.Core++import ADP.Fusion.PointL.Core+import ADP.Fusion.PointL.SynVar.Indices+--import ADP.Fusion.PointL.SynVar.Recursive+import ADP.Fusion.PointL.Term.Chr+import ADP.Fusion.PointL.Term.Deletion+import ADP.Fusion.PointL.Term.Epsilon+import ADP.Fusion.PointL.Term.MultiChr+import ADP.Fusion.PointL.Term.Str+

@@ -0,0 +1,191 @@++{-# Language MagicHash #-}++module ADP.Fusion.PointL.Core where++import GHC.Generics (Generic, Generic1)+import Control.DeepSeq+import Data.Proxy+import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..))+import Debug.Trace+import Prelude hiding (map,filter)+import GHC.Exts+import GHC.TypeLits++import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi++++-- * Contexts, and running indices.++type instance InitialContext (PointL I) = IStatic 0++type instance InitialContext (PointL O) = OStatic 0++type instance InitialContext (PointL C) = Complement++newtype instance RunningIndex (PointL I) = RiPlI Int+  deriving (Generic)++deriving instance NFData (RunningIndex (PointL I))++data instance RunningIndex (PointL O) = RiPlO !Int !Int+  deriving (Generic)++newtype instance RunningIndex (PointL C) = RiPlC Int+  deriving (Generic)++++-- * Inside++-- ** Single-tape+--+-- TODO should IStatic do these additional control of @I <=# d@? cf. Epsilon Local.++instance+  ( Monad m+  , KnownNat d+  )+  ⇒ MkStream m (IStatic d) S (PointL I) where+  mkStream Proxy S grd (LtPointL (I# u)) (PointL (I# i))+    = staticCheck# ( grd `andI#` (i >=# 0#) `andI#` (i <=# d) `andI#` (i <=# u) )+    . singleton . ElmS $ RiPlI 0+    where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d)+  {-# Inline mkStream #-}++instance+  ( Monad m+  , KnownNat d+  )+  ⇒ MkStream m (IVariable d) S (PointL I) where+  mkStream Proxy S grd (LtPointL (I# u)) (PointL (I# i))+    = staticCheck# (grd `andI#` (i >=# 0#) `andI#` (i <=# u) )+    . singleton . ElmS $ RiPlI 0+  {-# Inline mkStream #-}++-- ** Multi-tape++instance+  ( Monad m+  , MkStream m ps S is+  , KnownNat d+  ) ⇒ MkStream m (ps:.IStatic d) S (is:.PointL I) where+  mkStream Proxy S grd (lus:..LtPointL (I# u)) (is:.PointL (I# i))+    = map (\(ElmS e) -> ElmS $ e :.: RiPlI 0)+    $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#) `andI#` (i <=# d) `andI#` (i <=# u)) lus is+    --    $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#)) lus is+    -- NOTE we should optimize which parameters are actually required, the gain is about 10% on the+    -- NeedlemanWunsch algorithm+    where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d)+  {-# Inline mkStream #-}++instance+  ( Monad m+  , MkStream m ps S is+  , KnownNat d+  ) ⇒ MkStream m (ps:.IVariable d) S (is:.PointL I) where+  mkStream Proxy S grd (lus:..LtPointL (I# u)) (is:.PointL (I# i))+    = map (\(ElmS e) -> ElmS $ e :.: RiPlI 0)+    $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#) `andI#` (i <=# u)) lus is+    --    $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#)) lus is+  {-# Inline mkStream #-}++++-- * Outside++-- ** Single-tape++instance+  ( Monad m+  , KnownNat d+  ) ⇒ MkStream m (OStatic d) S (PointL O) where+  mkStream Proxy S grd (LtPointL (I# u)) (PointL (I# i))+    = staticCheck# (grd `andI#` (i >=# 0#) `andI#` (i +# d ==# u))+    -- ???  `andI#` (u ==# i)+    . singleton . ElmS $ RiPlO (I# i) (I# (i +# d))+    where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d)+  {-# Inline mkStream #-}++instance+  ( Monad m+  , KnownNat d+  ) ⇒ MkStream m (OFirstLeft d) S (PointL O) where+  mkStream Proxy s grd (LtPointL (I# u)) (PointL (I# i))+    = staticCheck# (grd `andI#` (i >=# 0#) `andI#` (i +# d <=# u))+    . singleton . ElmS $ RiPlO (I# i) (I# (i +# d))+    where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d)+  {-# Inline mkStream #-}++-- ** Multi-tape++instance+  ( Monad m+  , MkStream m ps S is+  , KnownNat d+  ) ⇒ MkStream m (ps:.OStatic d) S (is:.PointL O) where+  mkStream Proxy S grd (lus:..LtPointL (I# u)) (is:.PointL (I# i))+    = map (\(ElmS zi) -> ElmS $ zi :.: RiPlO (I# i) (I# (i +# d)))+    -- ???  `andI#` (u ==# i)+    $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#) `andI#` (i +# d ==# u)) lus is+    where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d)+  {-# Inline mkStream #-}++instance+  ( Monad m+  , MkStream m ps S is+  , KnownNat d+  ) ⇒ MkStream m (ps:.OFirstLeft d) S (is:.PointL O) where+  mkStream Proxy S grd (lus:..LtPointL (I# u)) (is:.PointL (I# i))+    = map (\(ElmS zi) -> ElmS $ zi :.: RiPlO (I# i) (I# (i +# d)))+    $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#) `andI#` (i +# d <=# u)) lus is+    where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d)+  {-# Inline mkStream #-}++++-- * Complemented++-- ** Single-tape++instance+  ( Monad m+  ) ⇒ MkStream m Complement S (PointL C) where+  mkStream Proxy S grd (LtPointL (I# u)) (PointL (I# i))+    = error "write me" -- staticCheck# (grd `andI#` (i >=# 0#) `andI#` (i <=# u)) . singleton . ElmS $ RiPlC (I# i)+  {-# Inline mkStream #-}++-- ** Multi-tape++instance+  ( Monad m+  , MkStream m ps S is+  ) ⇒ MkStream m (ps:.Complement) S (is:.PointL C) where+  mkStream Proxy S grd (lus:..LtPointL (I# u)) (is:.PointL (I# i))+    = error "write me"+    -- -- = map (\(ElmS zi) → ElmS $ zi :.: RiPlC (I# i))+    -- -- $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#) `andI#` (i <=# u)) lus is+  {-# Inline mkStream #-}++++-- * Table index modification++instance (MinSize minSize) ⇒ TableStaticVar pos minSize u (PointL I) where+  -- NOTE this code used to destroy fusion. If we inline tableStreamIndex+  -- very late (after 'mkStream', probably) then everything works out.+  tableStreamIndex Proxy minSz _upperBound (PointL j) = PointL $ j - minSize minSz+  {-# INLINE [0] tableStreamIndex #-}++instance (MinSize minSize) ⇒ TableStaticVar pos minSize u (PointL O) where+  tableStreamIndex Proxy minSz _upperBound (PointL j) = PointL $ j - minSize minSz+  {-# INLINE [0] tableStreamIndex #-}++instance (MinSize minSize) ⇒ TableStaticVar pos minSize u (PointL C) where+  tableStreamIndex Proxy minSz _upperBound (PointL k) = PointL $ k - minSize minSz+  {-# INLINE [0] tableStreamIndex #-}+

@@ -0,0 +1,139 @@++-- | Index movement for syntactic variables in linear @PointL@ grammars.+--+-- Syntactic variables for @PointL@ indices can be both, static and variable.+-- Static is the default, whenever we have @X -> X a@ where @a@ is a character+-- or similar. However, we can expect to see @a@ as a string as well. Then, @X@+-- on the r.h.s. is variable.++module ADP.Fusion.PointL.SynVar.Indices where++import Data.Proxy+import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..),flatten)+import Data.Vector.Fusion.Util (delay_inline)+import Debug.Trace+import Prelude hiding (map,head,mapM)++import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core+import ADP.Fusion.Core.SynVar.Indices+import ADP.Fusion.PointL.Core++++-- * type function for the type of the left position++-- ** Inside++type instance LeftPosTy (IStatic d) (TwITbl b s m arr EmptyOk (PointL I) x) (PointL I) = IVariable d+type instance LeftPosTy (IStatic d) (TwITblBt b s arr EmptyOk (PointL I) x mB mF r) (PointL I) = IVariable d++type instance LeftPosTy (IVariable d) (TwITbl b s m arr EmptyOk (PointL I) x) (PointL I) = IVariable d+type instance LeftPosTy (IVariable d) (TwITblBt b s arr EmptyOk (PointL I) x mB mF r) (PointL I) = IVariable d++-- ** Outside++type instance LeftPosTy (OStatic d) (TwITbl b s m arr EmptyOk (PointL O) x) (PointL O) = OFirstLeft d+type instance LeftPosTy (OStatic d) (TwITblBt b s arr EmptyOk (PointL O) x mB mF r) (PointL O) = OFirstLeft d++-- TODO @OLeftOf@++type instance LeftPosTy (OFirstLeft d) (TwITbl b s m arr EmptyOk (PointL O) x) (PointL O) = TypeError+  (Text "OFirstLeft is illegal for outside tables. Check your grammars for multiple Outside syntactic variable on the r.h.s!")+type instance LeftPosTy (OFirstLeft d) (TwITblBt b s arr EmptyOk (PointL O) x mB mF r) (PointL O) = TypeError+  (Text "OFirstLeft is illegal for outside tables. Check your grammars for multiple Outside syntactic variable on the r.h.s!")++type instance LeftPosTy (OLeftOf d) (TwITbl b s m arr EmptyOk (PointL O) x) (PointL O) = TypeError+  (Text "OLeftOf is illegal for outside tables. Check your grammars for multiple Outside syntactic variable on the r.h.s!")+type instance LeftPosTy (OLeftOf d) (TwITblBt s b arr EmptyOk (PointL O) x mB mF r) (PointL O) = TypeError+  (Text "OLeftOf is illegal for outside tables. Check your grammars for multiple Outside syntactic variable on the r.h.s!")++-- ** Complement. Note that @Complement@ joins inside and outside syntactic+-- variables.++type instance LeftPosTy Complement (TwITbl b s m arr EmptyOk (PointL I) x) (PointL C) = Complement+type instance LeftPosTy Complement (TwITblBt b s arr EmptyOk (PointL I) x mB mF r) (PointL C) = Complement++type instance LeftPosTy Complement (TwITbl b s m arr EmptyOk (PointL O) x) (PointL C) = Complement+type instance LeftPosTy Complement (TwITblBt b s arr EmptyOk (PointL O) x mB mF r) (PointL C) = Complement++++-- * 'AddIndexDense' instances++-- ** Inside++instance+  ( AddIndexDenseContext ps elm x0 i0 cs c us (PointL I) is (PointL I)+  , MinSize c+  )+  ⇒ AddIndexDense (ps:.IStatic d) elm (cs:.c) (us:.PointL I) (is:.PointL I) where+  addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i)+    = map (\(SvS s t y') → SvS s (t:.i) (y' :.: RiPlI (fromPointL i)))+    . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is+  {-# Inline addIndexDenseGo #-}++instance+  ( AddIndexDenseContext ps elm x0 i0 cs c us (PointL I) is (PointL I)+  , MinSize c+  )+  ⇒ AddIndexDense (ps:.IVariable d) elm (cs:.c) (us:.PointL I) (is:.PointL I) where+  addIndexDenseGo Proxy (cs:.c) (ubs:..ub) (us:..u) (is:.PointL i)+    = flatten mk step . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is+    where mk svS = let RiPlI k = getIndex (getIdx $ sS svS {- sIx svS -} ) (Proxy :: PRI is (PointL I))+                   in  return $ svS :. k+          step (svS@(SvS s t y') :. k)+            | k + csize > i = return $ Done+            | otherwise     = return $ Yield (SvS s (t:.PointL k) (y' :.: RiPlI k)) (svS :. k+1)+            where csize = minSize c+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  {-# Inline addIndexDenseGo #-}++++-- ** Outside++instance+  ( AddIndexDenseContext ps elm x0 i0 cs c us (PointL O) is (PointL O)+  , MinSize c+  ) ⇒ AddIndexDense (ps:.OStatic d) elm (cs:.c) (us:.PointL O) (is:.PointL O) where+  addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i)+    = map (\(SvS s t y') → let RiPlO oi oo = getIndex (getIdx s) (Proxy :: PRI is (PointL O))+                           in  SvS s (t:.PointL oo) (y' :.: RiPlO oi oo) )+    . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is+  {-# Inline addIndexDenseGo #-}++instance+  ( AddIndexDenseContext ps elm x0 i0 cs c us (PointL O) is (PointL O)+  , MinSize c+  ) ⇒ AddIndexDense (ps:.ORightOf d) elm (cs:.c) (us:.PointL O) (is:.PointL O) where+  addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i)+    = map (\(SvS s t y') → let RiPlO oi oo = getIndex (getIdx s) (Proxy :: PRI is (PointL O))+                           in  SvS s (t:.PointL oo) (y' :.: RiPlO oi oo) )+    . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is+  {-# Inline addIndexDenseGo #-}++++-- ** Complement++instance+  ( AddIndexDenseContext ps elm x0 i0 cs c us (PointL I) is (PointL C)+  ) ⇒ AddIndexDense (ps:.Complement) elm (cs:.c) (us:.PointL I) (is:.PointL C) where+  addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i)+    = map (\(SvS s t y) → let RiPlC k = getIndex (getIdx s) (Proxy :: PRI is (PointL C))+                          in  SvS s (t:.PointL k) (y :.: RiPlC k) )+    . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is+  {-# Inline addIndexDenseGo #-}++instance+  ( AddIndexDenseContext ps elm x0 i0 cs c us (PointL O) is (PointL C)+  ) ⇒ AddIndexDense (ps:.Complement) elm (cs:.c) (us:.PointL O) (is:.PointL C) where+  addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i)+    = map (\(SvS s t y) → let RiPlC k = getIndex (getIdx s) (Proxy :: PRI is (PointL C))+                          in  SvS s (t:.PointL k) (y:.:RiPlC k) )+    . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is+  {-# Inline addIndexDenseGo #-}+

@@ -0,0 +1,81 @@++module ADP.Fusion.PointL.Term.Chr where++import           Data.Proxy+import           Data.Strict.Tuple+import           Debug.Trace+import qualified Data.Vector.Fusion.Stream.Monadic as S+import qualified Data.Vector.Generic as VG+import           GHC.Exts++import           Data.PrimitiveArray++import           ADP.Fusion.Core+import           ADP.Fusion.Core.Term.Chr+import           ADP.Fusion.PointL.Core++++type instance LeftPosTy (IStatic d) (Chr r x) (PointL I) = IStatic d+--type instance LeftPosTy (IVariable d) (Chr r x) (PointL I) = IVariable d++type instance LeftPosTy (OStatic d) (Chr r x) (PointL O) = OStatic (d+1)++-- | First try in getting this right with a @termStream@.+--+-- TODO use @PointL i@ since this is probably the same for all single-tape+-- instances with @ElmChr@.+--+-- TODO it might even be possible to auto-generate this code via TH.++instance+  forall pos posLeft m ls r x i+  . ( TermStream m (Z:.pos) (TermSymbol M (Chr r x)) (Elm (Term1 (Elm ls (PointL i))) (Z :. PointL i)) (Z:.PointL i)+    , posLeft ~ LeftPosTy pos (Chr r x) (PointL i)+    , TermStaticVar pos (Chr r x) (PointL i)+    , MkStream m posLeft ls (PointL i)+    )+  ⇒ MkStream m pos (ls :!: Chr r x) (PointL i) where+  mkStream pos (ls :!: Chr f xs) grd us is+    = S.map (\(ss,ee,ii) -> ElmChr ee ii ss) -- recover ElmChr+    . addTermStream1 pos (Chr f xs) us is+    $ mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos (Chr f xs) us is grd) us (termStreamIndex pos (Chr f xs) is)+  {-# Inline mkStream #-}+++-- | ++instance+  ( TermStreamContext m ps ts s x0 i0 is (PointL I)+  ) => TermStream m (ps:.IStatic d) (TermSymbol ts (Chr r x)) s (is:.PointL I) where+  termStream Proxy (ts:|Chr f xs) (us:..LtPointL u) (is:.PointL i)+    -- NOTE changing from @f xs (i-1)@ to @f xs $! i-1@, forcing @i-1@ first,+    -- yielding 50% better performance in Needleman-Wunsch+    = S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:. (f xs $! i-1)))+    . termStream (Proxy ∷ Proxy ps) ts us is+  {-# Inline termStream #-}++instance+  ( TermStreamContext m ps ts s x0 i0 is (PointL O)+  ) => TermStream m (ps:.OStatic d) (TermSymbol ts (Chr r x)) s (is:.PointL O) where+  termStream Proxy (ts:|Chr f xs) (us:..LtPointL u) (is:.PointL i)+    = S.map (\(TState s ii ee) ->+                let RiPlO k o = getIndex (getIdx s) (Proxy :: PRI is (PointL O))+                in  TState s (ii:.: RiPlO (k+1) o) (ee:.f xs k))+    . termStream (Proxy ∷ Proxy ps) ts us is+  {-# Inline termStream #-}++++instance TermStaticVar (IStatic d) (Chr r x) (PointL I) where+  termStreamIndex Proxy (Chr f x) (PointL j) = PointL $! j-1+  termStaticCheck Proxy (Chr f x) _ (PointL j) grd = grd+  {-# Inline [0] termStreamIndex #-}+  {-# Inline [0] termStaticCheck #-}++instance TermStaticVar (OStatic d) (Chr r x) (PointL O) where+  termStreamIndex Proxy (Chr f x) (PointL j) = PointL $ j+  termStaticCheck Proxy (Chr f x) _ (PointL j) grd = grd+  {-# Inline [0] termStreamIndex #-}+  {-# Inline [0] termStaticCheck #-}+

@@ -0,0 +1,85 @@++module ADP.Fusion.PointL.Term.Deletion where++import           Data.Proxy+import           Data.Strict.Tuple+import qualified Data.Vector.Fusion.Stream.Monadic as S+import           GHC.Exts++import           Data.PrimitiveArray++import           ADP.Fusion.Core+import           ADP.Fusion.Core.Term.Deletion+import           ADP.Fusion.PointL.Core++++type instance LeftPosTy (IStatic   d) Deletion (PointL I) = IStatic d+type instance LeftPosTy (IVariable d) Deletion (PointL I) = IVariable d++type instance LeftPosTy (OStatic d) Deletion (PointL O) = OStatic d++instance+  forall pos posLeft m ls i+  . ( TermStream m (Z:.pos) (TermSymbol M Deletion) (Elm (Term1 (Elm ls (PointL i))) (Z :. PointL i)) (Z:.PointL i)+    , posLeft ~ LeftPosTy pos Deletion (PointL i)+    , TermStaticVar pos Deletion (PointL i)+    , MkStream m posLeft ls (PointL i)+    )+  ⇒ MkStream m pos (ls :!: Deletion) (PointL i) where+  mkStream pos (ls :!: Deletion) grd us is+    = S.map (\(ss,ee,ii) -> ElmDeletion ii ss)+    . addTermStream1 pos Deletion us is+    $ mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos Deletion us is grd) us (termStreamIndex pos Deletion is)+  {-# Inline mkStream #-}++++instance+  ( TermStreamContext m ps ts s x0 i0 is (PointL I)+  )+  ⇒ TermStream m (ps:.IStatic d) (TermSymbol ts Deletion) s (is:.PointL I) where+  termStream Proxy (ts:|Deletion) (us:..LtPointL u) (is:.PointL i)+    = S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:.()))+    . termStream (Proxy ∷ Proxy ps) ts us is+  {-# Inline termStream #-}++instance+  ( TermStreamContext m ps ts s x0 i0 is (PointL I)+  )+  ⇒ TermStream m (ps:.IVariable d) (TermSymbol ts Deletion) s (is:.PointL I) where+  termStream Proxy (ts:|Deletion) (us:..LtPointL u) (is:.PointL i)+    = S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:.()))+    . termStream (Proxy ∷ Proxy ps) ts us is+  {-# Inline termStream #-}++instance+  ( TermStreamContext m ps ts s x0 i0 is (PointL O)+  ) => TermStream m (ps:.OStatic d) (TermSymbol ts Deletion) s (is:.PointL O) where+  termStream Proxy (ts:|Deletion) (us:..LtPointL u) (is:.PointL i)+    = S.map (\(TState s ii ee) ->+                let io = getIndex (getIdx s) (Proxy :: PRI is (PointL O))+                in  TState s (ii:.: io) (ee:.()))+    . termStream (Proxy ∷ Proxy ps) ts us is+  {-# Inline termStream #-}++++instance TermStaticVar (IStatic d) Deletion (PointL I) where+  termStreamIndex Proxy Deletion (PointL j) = PointL j+  termStaticCheck Proxy Deletion _ (PointL j) grd = grd+  {-# Inline [0] termStreamIndex #-}+  {-# Inline [0] termStaticCheck #-}++instance TermStaticVar (IVariable d) Deletion (PointL I) where+  termStreamIndex Proxy Deletion (PointL j) = PointL j+  termStaticCheck Proxy Deletion _ (PointL j) grd = grd+  {-# Inline [0] termStreamIndex #-}+  {-# Inline [0] termStaticCheck #-}++instance TermStaticVar oAny Deletion (PointL O) where+  termStreamIndex Proxy Deletion (PointL j) = PointL j+  termStaticCheck Proxy Deletion _ (PointL j) grd = grd+  {-# Inline [0] termStreamIndex #-}+  {-# Inline [0] termStaticCheck #-}+

@@ -0,0 +1,119 @@++-- | Rules of the type @X → ε@ denote termination of parsing if @X@ is empty.++module ADP.Fusion.PointL.Term.Epsilon where++import           Data.Proxy+import           Data.Strict.Tuple+import qualified Data.Vector.Fusion.Stream.Monadic as S+import           GHC.Exts++import           Data.PrimitiveArray++import           ADP.Fusion.Core+import           ADP.Fusion.Core.Term.Epsilon+import           ADP.Fusion.PointL.Core++++type instance LeftPosTy (IStatic d) (Epsilon Global) (PointL I) = IStatic d+type instance LeftPosTy (IStatic d) (Epsilon Local) (PointL I) = IVariable d  -- to actually allow local epsilons to work, IStatic does additional static controls+--type instance LeftPosTy (IVariable d) Epsilon (PointL I) = IVariable d++type instance LeftPosTy (OStatic d) (Epsilon Global) (PointL O) = OStatic d++instance+  forall pos posLeft m ls i lg+  . ( TermStream m (Z:.pos) (TermSymbol M (Epsilon lg)) (Elm (Term1 (Elm ls (PointL i))) (Z :. PointL i)) (Z:.PointL i)+    , posLeft ~ LeftPosTy pos (Epsilon lg) (PointL i)+    , TermStaticVar pos (Epsilon lg) (PointL i)+    , MkStream m posLeft ls (PointL i)+    )+  ⇒ MkStream m pos (ls :!: (Epsilon lg)) (PointL i) where+  mkStream Proxy (ls :!: Epsilon) grd us is+    = S.map (\(ss,ee,ii) -> ElmEpsilon ii ss)+    . addTermStream1 (Proxy ∷ Proxy pos) (Epsilon @lg) us is+    $ mkStream (Proxy ∷ Proxy posLeft)+               ls+               (termStaticCheck (Proxy ∷ Proxy pos) (Epsilon @lg) us is grd)+               us+               (termStreamIndex (Proxy ∷ Proxy pos) (Epsilon @lg) is)+  {-# Inline mkStream #-}+++instance+  ( TermStreamContext m ps ts s x0 i0 is (PointL I)+  )+  ⇒ TermStream m (ps:.IStatic d) (TermSymbol ts (Epsilon lg)) s (is:.PointL I) where+  termStream Proxy (ts:|Epsilon) (us:..LtPointL u) (is:.PointL i)+    = S.map (\(TState s ii ee) ->+              let RiPlI k = getIndex (getIdx s) (Proxy :: PRI is (PointL I))+              in  TState s (ii:.:RiPlI k) (ee:.()))+    . termStream (Proxy ∷ Proxy ps) ts us is+  {-# Inline termStream #-}++{-+instance+  ( TermStreamContext m ps ts s x0 i0 is (PointL I)+  )+  ⇒ TermStream m (ps:.IVariable d) (TermSymbol ts Epsilon) s (is:.PointL I) where+  termStream Proxy (ts:|Epsilon) (us:..LtPointL u) (is:.PointL i)+    = S.map (\(TState s ii ee) ->+              let RiPlI k = getIndex (getIdx s) (Proxy :: PRI is (PointL I))+              in  TState s (ii:.:RiPlI k) (ee:.()))+    . termStream (Proxy ∷ Proxy ps) ts us is+  {-# Inline termStream #-}+-}++instance+  ( TermStreamContext m ps ts s x0 i0 is (PointL O)+  ) => TermStream m (ps:.OStatic d) (TermSymbol ts (Epsilon lg)) s (is:.PointL O) where+  termStream Proxy (ts:|Epsilon) (us:..LtPointL u) (is:.PointL i)+    = S.map (\(TState s ii ee) ->+                let io = getIndex (getIdx s) (Proxy :: PRI is (PointL O))+                in  TState s (ii:.:io) (ee:.()))+    . termStream (Proxy ∷ Proxy ps) ts us is+  {-# Inline termStream #-}++-- | We assume that @ε / Epsilon@ is ever only the single symbol (maybe apart+-- from @- / Deletion@) on a tape. Hence The instance is only active in+-- @IStatic 0@ cases.++instance TermStaticVar (IStatic 0) (Epsilon Global) (PointL I) where+  termStreamIndex Proxy Epsilon (PointL i     ) = PointL i+  termStaticCheck Proxy Epsilon _ (PointL (I# i)) grd = (i ==# 0#) `andI#` grd+  {-# Inline [0] termStreamIndex #-}+  {-# Inline [0] termStaticCheck #-}++instance TermStaticVar (IStatic 0) (Epsilon Local) (PointL I) where+  termStreamIndex Proxy Epsilon (PointL i     ) = PointL i+  -- | Local epsilons are *always* possible.+  termStaticCheck Proxy Epsilon _ (PointL (I# i)) grd = grd+  {-# Inline termStreamIndex #-}+  {-# Inline termStaticCheck #-}++instance TermStaticVar (OStatic 0) (Epsilon Global) (PointL O) where+  termStreamIndex Proxy Epsilon (PointL i     ) = PointL i+  -- |+  --+  -- TODO Consider this as a potential bug: we do *not* check that the upper+  -- bound @us@ (which we not even hand over to termStaticCheck but should) is+  -- equal to the current index @i@. HERE this ends up not being a bug because+  -- @Epsilon@ keeps the positional system at @OStatic@ and does not move to+  -- @ORightOf@ or anything, and in correct epsilon rules, everything is fine.+  --+  -- We even end up being correct with @X -> whatever epsilon@ because epsilon+  -- is neutral ...+  --+  -- TODO But we should probably statically assert that epsilon is the only+  -- symbol on the r.h.s. of whatever we write ...+  termStaticCheck Proxy Epsilon (LtPointL (I# u)) (PointL (I# i)) grd = (u ==# i) `andI#` grd+  {-# Inline [0] termStreamIndex #-}+  {-# Inline [0] termStaticCheck #-}++instance TermStaticVar (OStatic 0) (Epsilon Local) (PointL O) where+  termStreamIndex Proxy Epsilon (PointL i     ) = PointL i+  termStaticCheck Proxy Epsilon (LtPointL (I# u)) (PointL (I# i)) grd = grd+  {-# Inline [0] termStreamIndex #-}+  {-# Inline [0] termStaticCheck #-}+

@@ -0,0 +1,85 @@++module ADP.Fusion.PointL.Term.MultiChr where++import           Data.Proxy+import           Data.Strict.Tuple+import           Debug.Trace+import           GHC.Exts+--import           GHC.TypeNats+import qualified Data.Vector.Fusion.Stream.Monadic as S+import qualified Data.Vector.Generic as VG++import           Data.PrimitiveArray++import           ADP.Fusion.Core+import           ADP.Fusion.Core.Term.MultiChr+import           ADP.Fusion.PointL.Core++++type instance LeftPosTy (IStatic d) (MultiChr c v x) (PointL I) = IStatic d+--type instance LeftPosTy (IVariable d) (Chr r x) (PointL I) = IVariable d++type instance LeftPosTy (OStatic d) (MultiChr c v x) (PointL O) = OStatic (d + c)++-- | First try in getting this right with a @termStream@.+--+-- TODO use @PointL i@ since this is probably the same for all single-tape+-- instances with @ElmChr@.+--+-- TODO it might even be possible to auto-generate this code via TH.++instance+  forall pos posLeft m ls c v x i+  . ( TermStream m (Z:.pos) (TermSymbol M (MultiChr c v x)) (Elm (Term1 (Elm ls (PointL i))) (Z :. PointL i)) (Z:.PointL i)+    , posLeft ~ LeftPosTy pos (MultiChr c v x) (PointL i)+    , TermStaticVar pos (MultiChr c v x) (PointL i)+    , MkStream m posLeft ls (PointL i)+    )+  ⇒ MkStream m pos (ls :!: MultiChr c v x) (PointL i) where+  mkStream pos (ls :!: MultiChr xs) grd us is+    = S.map (\(ss,ee,ii) -> ElmMultiChr ee ii ss) -- recover ElmChr+    . addTermStream1 pos (MultiChr @v @x @c xs) us is+    $ mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos (MultiChr @v @x @c xs) us is grd) us (termStreamIndex pos (MultiChr @v @x @c xs) is)+  {-# Inline mkStream #-}+++-- | ++instance+  ( TermStreamContext m ps ts s x0 i0 is (PointL I)+  , KnownNat c+  ) => TermStream m (ps:.IStatic d) (TermSymbol ts (MultiChr c v x)) s (is:.PointL I) where+  termStream Proxy (ts:|MultiChr xs) (us:..LtPointL u) (is:.PointL i)+    = let !c = fromIntegral $ natVal (Proxy ∷ Proxy c) in+      S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:. VG.unsafeSlice (i-c) c xs))+    . termStream (Proxy ∷ Proxy ps) ts us is+  {-# Inline termStream #-}++instance+  ( TermStreamContext m ps ts s x0 i0 is (PointL O)+  , KnownNat c+  ) => TermStream m (ps:.OStatic d) (TermSymbol ts (MultiChr c v x)) s (is:.PointL O) where+  termStream Proxy (ts:|MultiChr xs) (us:..LtPointL u) (is:.PointL i)+    = S.map (\(TState s ii ee) ->+                let RiPlO k o = getIndex (getIdx s) (Proxy :: PRI is (PointL O))+                    c = fromIntegral $ natVal (Proxy ∷ Proxy c)+                in  TState s (ii:.: RiPlO (k+c) o) (ee:.VG.unsafeSlice k c xs))+    . termStream (Proxy ∷ Proxy ps) ts us is+  {-# Inline termStream #-}++++instance (KnownNat c) ⇒ TermStaticVar (IStatic d) (MultiChr c v x) (PointL I) where+  termStreamIndex Proxy (MultiChr x) (PointL j) = PointL $ j-(fromIntegral $ natVal (Proxy ∷ Proxy c))+  termStaticCheck Proxy (MultiChr x) _ (PointL j) grd = grd+  {-# Inline [0] termStreamIndex #-}+  {-# Inline [0] termStaticCheck #-}++instance TermStaticVar (OStatic d) (MultiChr c v x) (PointL O) where+  termStreamIndex Proxy (MultiChr x) (PointL j) = PointL $ j+  -- | TODO check if @c@ to the right goes out of bounds?+  termStaticCheck Proxy (MultiChr x) _ (PointL j) grd = grd+  {-# Inline [0] termStreamIndex #-}+  {-# Inline [0] termStaticCheck #-}+

@@ -0,0 +1,87 @@++module ADP.Fusion.PointL.Term.Str where++import           Data.Proxy+import           Data.Strict.Tuple+import           Debug.Trace+import           GHC.Exts+--import           GHC.TypeNats+import qualified Data.Vector.Fusion.Stream.Monadic as S+import qualified Data.Vector.Generic as VG++import           Data.PrimitiveArray++import           ADP.Fusion.Core+import           ADP.Fusion.Core.Term.Str+import           ADP.Fusion.PointL.Core++++-- minSz done via TermStaticVar ?!++type instance LeftPosTy (IStatic   d) (Str linked minSz maxSz v x) (PointL I) = IVariable d+type instance LeftPosTy (IVariable d) (Str linked minSz maxSz v x) (PointL I) = IVariable d++{-+type instance LeftPosTy (OStatic d) (Chr r x) (PointL O) = OStatic (d+1)+-}++-- | ++instance+  forall pos posLeft m ls linked minSz maxSz v x i+  . ( TermStream m (Z:.pos) (TermSymbol M (Str linked minSz maxSz v x))+                 (Elm (Term1 (Elm ls (PointL i))) (Z :. PointL i)) (Z:.PointL i)+    , posLeft ~ LeftPosTy pos (Str linked minSz maxSz v x) (PointL i)+    , TermStaticVar pos (Str linked minSz maxSz v x) (PointL i)+    , MkStream m posLeft ls (PointL i)+    )+  ⇒ MkStream m pos (ls :!: Str linked minSz maxSz v x) (PointL i) where+  mkStream pos (ls :!: Str xs) grd us is+    = S.map (\(ss,ee,ii) -> ElmStr ee ii ss) -- recover ElmChr+    . addTermStream1 pos (Str @v @x @linked @minSz @maxSz xs) us is+    $ mkStream (Proxy ∷ Proxy posLeft) ls+               (termStaticCheck pos (Str @v @x @linked @minSz @maxSz xs) us is grd)+               us (termStreamIndex pos (Str @v @x @linked @minSz @maxSz xs) is)+  {-# Inline mkStream #-}++-- | Note that the @minSz@ should automatically work out due to the encoding in+-- @d@.++instance+  ( TermStreamContext m ps ts s x0 i0 is (PointL I)+  ) ⇒ TermStream m (ps:.IStatic d) (TermSymbol ts (Str Nothing minSz Nothing v x)) s (is:.PointL I) where+  termStream Proxy (ts:|Str xs) (us:..LtPointL u) (is:.PointL i)+    = S.map (\(TState s ii ee) →+                let RiPlI k = getIndex (getIdx s) (Proxy ∷ PRI is (PointL I))+                in  TState s (ii:.:RiPlI i) (ee:.VG.slice k (i-k) xs))+    . termStream (Proxy ∷ Proxy ps) ts us is+  {-# Inline termStream #-}++{-+instance+  ( TermStreamContext m ps ts s x0 i0 is (PointL O)+  ) => TermStream m (ps:.OStatic d) (TermSymbol ts (Chr r x)) s (is:.PointL O) where+  termStream Proxy (ts:|Chr f xs) (us:..LtPointL u) (is:.PointL i)+    = S.map (\(TState s ii ee) ->+                let RiPlO k o = getIndex (getIdx s) (Proxy :: PRI is (PointL O))+                in  TState s (ii:.: RiPlO (k+1) o) (ee:.f xs k))+    . termStream (Proxy ∷ Proxy ps) ts us is+  {-# Inline termStream #-}+-}++instance (KnownNat minSz)+  ⇒ TermStaticVar (IStatic d) (Str Nothing minSz Nothing v x) (PointL I) where+  termStreamIndex Proxy (Str xs) (PointL j) = PointL $ j - fromIntegral (natVal (Proxy ∷ Proxy minSz))+  termStaticCheck Proxy (Str xs) _ (PointL j) grd = grd+  {-# Inline [0] termStreamIndex #-}+  {-# Inline [0] termStaticCheck #-}++{-+instance TermStaticVar (OStatic d) (Chr r x) (PointL O) where+  termStreamIndex Proxy (Chr f x) (PointL j) = PointL $ j+  termStaticCheck Proxy (Chr f x) (PointL j) = 1#+  {-# Inline [0] termStreamIndex #-}+  {-# Inline [0] termStaticCheck #-}+-}+

@@ -0,0 +1,75 @@++module ADP.Fusion.PointL.Term.Switch where++import           Data.Proxy+import           Data.Strict.Tuple+import           Debug.Trace+import qualified Data.Vector.Fusion.Stream.Monadic as S+import qualified Data.Vector.Generic as VG+import           GHC.Exts++import           Data.PrimitiveArray++import           ADP.Fusion.Core+import           ADP.Fusion.Core.Term.Switch+import           ADP.Fusion.PointL.Core++++type instance LeftPosTy (IStatic   d) Switch (PointL I) = IStatic   d+type instance LeftPosTy (IVariable d) Switch (PointL I) = IVariable d++type instance LeftPosTy (OStatic d) Switch (PointL O) = OStatic d++-- | ++instance+  forall pos posLeft m ls r x i+  . ( TermStream m (Z:.pos) (TermSymbol M Switch) (Elm (Term1 (Elm ls (PointL i))) (Z :. PointL i)) (Z:.PointL i)+    , posLeft ~ LeftPosTy pos Switch (PointL i)+    , TermStaticVar pos Switch (PointL i)+    , MkStream m posLeft ls (PointL i)+    )+  ⇒ MkStream m pos (ls :!: Switch) (PointL i) where+  mkStream pos (ls :!: Switch s) grd us is+    = S.map (\(ss,ee,ii) -> ElmSwitch ii ss) -- recover ElmChr+    . addTermStream1 pos (Switch s) us is+    $ mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos (Switch s) us is grd) us (termStreamIndex pos (Switch s) is)+  {-# Inline mkStream #-}+++-- | ++instance+  ( TermStreamContext m ps ts s x0 i0 is (PointL I)+  ) => TermStream m (ps:.IStatic d) (TermSymbol ts Switch) s (is:.PointL I) where+  termStream Proxy (ts:|Switch s) (us:..LtPointL u) (is:.PointL i)+    = S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:. ()))+    . termStream (Proxy ∷ Proxy ps) ts us is+  {-# Inline termStream #-}++instance+  ( TermStreamContext m ps ts s x0 i0 is (PointL O)+  ) => TermStream m (ps:.OStatic d) (TermSymbol ts Switch) s (is:.PointL O) where+  termStream Proxy (ts:|Switch s) (us:..LtPointL u) (is:.PointL i)+    = S.map (\(TState s ii ee) ->+                let ko = getIndex (getIdx s) (Proxy :: PRI is (PointL O))+                in  TState s (ii:.:ko) (ee:.()))+    . termStream (Proxy ∷ Proxy ps) ts us is+  {-# Inline termStream #-}++++instance TermStaticVar (IStatic d) Switch (PointL I) where+  termStreamIndex Proxy (Switch s) (PointL j) = PointL $ j+  -- TODO is trac #15696 a problem here?+  termStaticCheck Proxy (Switch s) _ (PointL j) grd = dataToTag# s `andI#` grd -- case s of {Enabled → grd; Disabled → 0# }+  {-# Inline [0] termStreamIndex #-}+  {-# Inline [0] termStaticCheck #-}++instance TermStaticVar (OStatic d) Switch (PointL O) where+  termStreamIndex Proxy (Switch s) (PointL j) = PointL $ j+  termStaticCheck Proxy (Switch s) _ (PointL j) grd = case s of {Enabled → grd; Disabled → 0# }+  {-# Inline [0] termStreamIndex #-}+  {-# Inline [0] termStaticCheck #-}+

@@ -0,0 +1,29 @@++-- | This exports everything needed for sequence-based alignment style+-- algorithms.+--+-- Here are some notes on implementation of the Inside and Outside +--+-- X_j     -> S_{j-1} X_{j-1} c_j+-- Y_{j-1} -> S_?     X_j     c_j+-- Y_j     -> S_{j+1} X_{j+1} c_{j+1}++module ADP.Fusion.PointR+  ( module ADP.Fusion.Core+  , module ADP.Fusion.PointR.Core+  , module ADP.Fusion.PointR.SynVar.Indices+  , module ADP.Fusion.PointR.Term.Chr+  , module ADP.Fusion.PointR.Term.Deletion+  , module ADP.Fusion.PointR.Term.Epsilon+  , module ADP.Fusion.PointR.Term.MultiChr+  ) where++import ADP.Fusion.Core++import ADP.Fusion.PointR.Core+import ADP.Fusion.PointR.SynVar.Indices+import ADP.Fusion.PointR.Term.Chr+import ADP.Fusion.PointR.Term.Deletion+import ADP.Fusion.PointR.Term.Epsilon+import ADP.Fusion.PointR.Term.MultiChr+

@@ -0,0 +1,121 @@++{-# Language MagicHash #-}++module ADP.Fusion.PointR.Core where++import GHC.Generics (Generic, Generic1)+import Control.DeepSeq+import Data.Proxy+import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..))+import Debug.Trace+import Prelude hiding (map,filter)+import GHC.Exts+import GHC.TypeLits++import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi++++-- * Contexts, and running indices.++type instance InitialContext (PointR I) = IStatic 0++type instance InitialContext (PointR O) = OStatic 0++type instance InitialContext (PointR C) = Complement++newtype instance RunningIndex (PointR I) = RiPrI Int+  deriving (Generic)++deriving instance NFData (RunningIndex (PointR I))++data instance RunningIndex (PointR O) = RiPrO !Int !Int+  deriving (Generic)++newtype instance RunningIndex (PointR C) = RiPrC Int+  deriving (Generic)++++-- * Inside++-- ** Single-tape++instance+  ( Monad m+  , KnownNat d+  )+  ⇒ MkStream m (IStatic d) S (PointR I) where+  mkStream Proxy S grd (LtPointR (I# u)) (PointR (I# i))+    = staticCheck# ( grd `andI#` (i >=# 0#) `andI#` (i +# d ==# u) )   -- TODO include @d@ correctly: i<=d+    . singleton . ElmS . RiPrI $ I# i+    where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d)+  {-# Inline mkStream #-}++instance+  ( Monad m+  , KnownNat d+  )+  ⇒ MkStream m (IVariable d) S (PointR I) where+  mkStream Proxy S grd (LtPointR (I# u)) (PointR (I# i))+    = staticCheck# (grd `andI#` (i >=# 0#) `andI#` (i +# d <=# u))+    . singleton . ElmS . RiPrI $ I# i+    where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d)+  {-# Inline mkStream #-}++++-- ** Multi-tape++instance+  ( Monad m+  , MkStream m ps S is+  , KnownNat d+  ) ⇒ MkStream m (ps:.IStatic d) S (is:.PointR I) where+  mkStream Proxy S grd (lus:..LtPointR (I# u)) (is:.PointR (I# i))+    = map (\(ElmS e) -> ElmS $ e :.: RiPrI (I# i))+    $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#) `andI#` (i +# d ==# u)) lus is+    where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d)+  {-# Inline mkStream #-}++instance+  ( Monad m+  , MkStream m ps S is+  , KnownNat d+  ) ⇒ MkStream m (ps:.IVariable d) S (is:.PointR I) where+  mkStream Proxy S grd (lus:..LtPointR (I# u)) (is:.PointR (I# i))+    = map (\(ElmS e) -> ElmS $ e :.: RiPrI (I# i))+    $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#) `andI#` (i +# d <=# u)) lus is+    where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d)+  {-# Inline mkStream #-}++++-- * Outside++-- ** Single-tape+++++-- * Complemented++-- ** Single-tape+++-- ** Multi-tape+++++-- * Table index modification++instance (MinSize minSize) ⇒ TableStaticVar pos minSize u (PointR I) where+  -- NOTE this code used to destroy fusion. If we inline tableStreamIndex+  -- very late (after 'mkStream', probably) then everything works out.+  tableStreamIndex Proxy minSz _upperBound (PointR j) = PointR $ j + minSize minSz+  {-# INLINE [0] tableStreamIndex #-}+

@@ -0,0 +1,44 @@++-- | Index movement for syntactic variables in linear @PointL@ grammars.+--+-- Syntactic variables for @PointL@ indices can be both, static and variable.+-- Static is the default, whenever we have @X -> X a@ where @a@ is a character+-- or similar. However, we can expect to see @a@ as a string as well. Then, @X@+-- on the r.h.s. is variable.++module ADP.Fusion.PointR.SynVar.Indices where++import Data.Proxy+import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..),flatten)+import Data.Vector.Fusion.Util (delay_inline)+import Debug.Trace+import Prelude hiding (map,head,mapM)++import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core+import ADP.Fusion.Core.SynVar.Indices+import ADP.Fusion.PointR.Core++++type instance LeftPosTy (IStatic d) (TwITbl b s m arr EmptyOk (PointR I) x) (PointR I) = IVariable d+type instance LeftPosTy (IStatic d) (TwITblBt b s arr EmptyOk (PointR I) x mB mF r) (PointR I) = IVariable d++type instance LeftPosTy (IVariable d) (TwITbl b s m arr EmptyOk (PointR I) x) (PointR I) = IVariable d+type instance LeftPosTy (IVariable d) (TwITblBt b s arr EmptyOk (PointR I) x mB mF r) (PointR I) = IVariable d++++instance+  ( AddIndexDenseContext ps elm x0 i0 cs c us (PointR I) is (PointR I)+  , MinSize c+  )+  ⇒ AddIndexDense (ps:.IStatic d) elm (cs:.c) (us:.PointR I) (is:.PointR I) where+  addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..LtPointR u) (is:.i)+    = map (\(SvS s t y') →+        let RiPrI k = getIndex (getIdx s) (Proxy ∷ PRI is (PointR I))+        in  SvS s (t:.PointR k) (y' :.: RiPrI  u))+    . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is+  {-# Inline addIndexDenseGo #-}+

@@ -0,0 +1,72 @@++module ADP.Fusion.PointR.Term.Chr where++import           Data.Proxy+import           Data.Strict.Tuple+import           Debug.Trace+import qualified Data.Vector.Fusion.Stream.Monadic as S+import qualified Data.Vector.Generic as VG+import           GHC.Exts++import           Data.PrimitiveArray++import           ADP.Fusion.Core+import           ADP.Fusion.Core.Term.Chr+import           ADP.Fusion.PointR.Core++++type instance LeftPosTy (IStatic   d) (Chr r x) (PointR I) = IStatic   (d+1)+type instance LeftPosTy (IVariable d) (Chr r x) (PointR I) = IVariable (d+1)++++instance+  forall pos posLeft m ls r x i+  . ( TermStream m (Z:.pos) (TermSymbol M (Chr r x)) (Elm (Term1 (Elm ls (PointR i))) (Z :. PointR i)) (Z:.PointR i)+    , posLeft ~ LeftPosTy pos (Chr r x) (PointR i)+    , TermStaticVar pos (Chr r x) (PointR i)+    , MkStream m posLeft ls (PointR i)+    )+  ⇒ MkStream m pos (ls :!: Chr r x) (PointR i) where+  {-# Inline mkStream #-}+  mkStream pos (ls :!: Chr f xs) grd us is+    = S.map (\(ss,ee,ii) -> ElmChr ee ii ss)+    . addTermStream1 pos (Chr f xs) us is+    $ mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos (Chr f xs) us is grd) us (termStreamIndex pos (Chr f xs) is)+++instance+  ( TermStreamContext m ps ts s x0 i0 is (PointR I)+  ) => TermStream m (ps:.IStatic d) (TermSymbol ts (Chr r x)) s (is:.PointR I) where+  {-# Inline termStream #-}+  termStream Proxy (ts:|Chr f xs) (us:..LtPointR u) (is:.PointR i)+    = S.map (\(TState s ii ee) →+        let RiPrI k = getIndex (getIdx s) (Proxy ∷ PRI is (PointR I))+        in  TState s (ii:.:RiPrI (k+1)) (ee:. f xs k))+    . termStream (Proxy ∷ Proxy ps) ts us is++instance+  ( TermStreamContext m ps ts s x0 i0 is (PointR I)+  ) => TermStream m (ps:.IVariable d) (TermSymbol ts (Chr r x)) s (is:.PointR I) where+  {-# Inline termStream #-}+  termStream Proxy (ts:|Chr f xs) (us:..LtPointR u) (is:.PointR i)+    = S.map (\(TState s ii ee) ->+        let RiPrI k = getIndex (getIdx s) (Proxy ∷ PRI is (PointR I))+        in  TState s (ii:.:RiPrI (k+1)) (ee:. f xs k))+    . termStream (Proxy ∷ Proxy ps) ts us is++++instance TermStaticVar (IStatic d) (Chr r x) (PointR I) where+  termStreamIndex Proxy (Chr f x) (PointR j) = PointR $ j+  termStaticCheck Proxy (Chr f x) (LtPointR _) (PointR j) grd = grd+  {-# Inline [0] termStreamIndex #-}+  {-# Inline [0] termStaticCheck #-}++instance TermStaticVar (IVariable d) (Chr r x) (PointR I) where+  termStreamIndex Proxy (Chr f x) (PointR j) = PointR $ j+  termStaticCheck Proxy (Chr f x) (LtPointR _) (PointR j) grd = grd+  {-# Inline [0] termStreamIndex #-}+  {-# Inline [0] termStaticCheck #-}+

@@ -0,0 +1,69 @@++module ADP.Fusion.PointR.Term.Deletion where++import           Data.Proxy+import           Data.Strict.Tuple+import qualified Data.Vector.Fusion.Stream.Monadic as S+import           GHC.Exts++import           Data.PrimitiveArray++import           ADP.Fusion.Core+import           ADP.Fusion.Core.Term.Deletion+import           ADP.Fusion.PointR.Core++++type instance LeftPosTy (IStatic   d) Deletion (PointR I) = IStatic d+type instance LeftPosTy (IVariable d) Deletion (PointR I) = IVariable d++++instance+  forall pos posLeft m ls i+  . ( TermStream m (Z:.pos) (TermSymbol M Deletion) (Elm (Term1 (Elm ls (PointR i))) (Z :. PointR i)) (Z:.PointR i)+    , posLeft ~ LeftPosTy pos Deletion (PointR i)+    , TermStaticVar pos Deletion (PointR i)+    , MkStream m posLeft ls (PointR i)+    )+  ⇒ MkStream m pos (ls :!: Deletion) (PointR i) where+  {-# Inline mkStream #-}+  mkStream pos (ls :!: Deletion) grd us is+    = S.map (\(ss,ee,ii) -> ElmDeletion ii ss)+    . addTermStream1 pos Deletion us is+    $ mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos Deletion us is grd) us (termStreamIndex pos Deletion is)++++instance+  ( TermStreamContext m ps ts s x0 i0 is (PointR I)+  )+  ⇒ TermStream m (ps:.IStatic d) (TermSymbol ts Deletion) s (is:.PointR I) where+  {-# Inline termStream #-}+  termStream Proxy (ts:|Deletion) (us:..LtPointR u) (is:.PointR i)+    = S.map (\(TState s ii ee) -> TState s (ii:.:RiPrI i) (ee:.()))+    . termStream (Proxy ∷ Proxy ps) ts us is++instance+  ( TermStreamContext m ps ts s x0 i0 is (PointR I)+  )+  ⇒ TermStream m (ps:.IVariable d) (TermSymbol ts Deletion) s (is:.PointR I) where+  {-# Inline termStream #-}+  termStream Proxy (ts:|Deletion) (us:..LtPointR u) (is:.PointR i)+    = S.map (\(TState s ii ee) -> TState s (ii:.:RiPrI i) (ee:.()))+    . termStream (Proxy ∷ Proxy ps) ts us is++++instance TermStaticVar (IStatic d) Deletion (PointR I) where+  termStreamIndex Proxy Deletion (PointR j) = PointR j+  termStaticCheck Proxy Deletion _ (PointR j) grd = grd+  {-# Inline [0] termStreamIndex #-}+  {-# Inline [0] termStaticCheck #-}++instance TermStaticVar (IVariable d) Deletion (PointR I) where+  termStreamIndex Proxy Deletion (PointR j) = PointR j+  termStaticCheck Proxy Deletion _ (PointR j) grd = grd+  {-# Inline [0] termStreamIndex #-}+  {-# Inline [0] termStaticCheck #-}+

@@ -0,0 +1,66 @@++-- | Rules of the type @X → ε@ denote termination of parsing if @X@ is empty.++module ADP.Fusion.PointR.Term.Epsilon where++import           Data.Proxy+import           Data.Strict.Tuple+import qualified Data.Vector.Fusion.Stream.Monadic as S+import           GHC.Exts++import           Data.PrimitiveArray++import           ADP.Fusion.Core+import           ADP.Fusion.Core.Term.Epsilon+import           ADP.Fusion.PointR.Core++++type instance LeftPosTy (IStatic d) (Epsilon Global) (PointR I) = IStatic d++instance+  forall pos posLeft m ls i lg+  . ( TermStream m (Z:.pos) (TermSymbol M (Epsilon lg)) (Elm (Term1 (Elm ls (PointR i))) (Z :. PointR i)) (Z:.PointR i)+    , posLeft ~ LeftPosTy pos (Epsilon lg) (PointR i)+    , TermStaticVar pos (Epsilon lg) (PointR i)+    , MkStream m posLeft ls (PointR i)+    )+  ⇒ MkStream m pos (ls :!: Epsilon lg) (PointR i) where+  mkStream Proxy (ls :!: Epsilon) grd us is+    = S.map (\(ss,ee,ii) -> ElmEpsilon ii ss)+    . addTermStream1 (Proxy ∷ Proxy pos) (Epsilon @lg) us is+    $ mkStream (Proxy ∷ Proxy posLeft)+               ls+               (termStaticCheck (Proxy ∷ Proxy pos) (Epsilon @lg) us is grd)+               us+               (termStreamIndex (Proxy ∷ Proxy pos) (Epsilon @lg) is)+  {-# Inline mkStream #-}+++instance+  ( TermStreamContext m ps ts s x0 i0 is (PointR I)+  )+  ⇒ TermStream m (ps:.IStatic d) (TermSymbol ts (Epsilon lg)) s (is:.PointR I) where+  termStream Proxy (ts:|Epsilon) (us:..LtPointR u) (is:.PointR i)+    = S.map (\(TState s ii ee) ->+              let RiPrI k = getIndex (getIdx s) (Proxy :: PRI is (PointR I))+              in  TState s (ii:.:RiPrI k) (ee:.()))+    . termStream (Proxy ∷ Proxy ps) ts us is+  {-# Inline termStream #-}++++-- TODO need upper bound in @termStaticCheck@ to be able to check against that!++instance TermStaticVar (IStatic 0) (Epsilon Global) (PointR I) where+  termStreamIndex Proxy Epsilon (PointR i     ) = PointR i+  termStaticCheck Proxy Epsilon (LtPointR (I# u)) (PointR (I# i)) grd = (i ==# u) `andI#` grd+  {-# Inline termStreamIndex #-}+  {-# Inline termStaticCheck #-}++instance TermStaticVar (IStatic 0) (Epsilon Local) (PointR I) where+  termStreamIndex Proxy Epsilon (PointR i     ) = PointR i+  termStaticCheck Proxy Epsilon (LtPointR (I# u)) (PointR (I# i)) grd = grd+  {-# Inline termStreamIndex #-}+  {-# Inline termStaticCheck #-}+

@@ -0,0 +1,77 @@++module ADP.Fusion.PointR.Term.MultiChr where++import           Data.Proxy+import           Data.Strict.Tuple+import           Debug.Trace+import           GHC.Exts+--import           GHC.TypeNats+import qualified Data.Vector.Fusion.Stream.Monadic as S+import qualified Data.Vector.Generic as VG++import           Data.PrimitiveArray++import           ADP.Fusion.Core+import           ADP.Fusion.Core.Term.MultiChr+import           ADP.Fusion.PointR.Core++++type instance LeftPosTy (IStatic d)   (MultiChr c v x) (PointR I) = IStatic (d+c)+type instance LeftPosTy (IVariable d) (MultiChr c v x) (PointR I) = IVariable (d+c)++++instance+  forall pos posLeft m ls c v x i+  . ( TermStream m (Z:.pos) (TermSymbol M (MultiChr c v x)) (Elm (Term1 (Elm ls (PointR i))) (Z :. PointR i)) (Z:.PointR i)+    , posLeft ~ LeftPosTy pos (MultiChr c v x) (PointR i)+    , TermStaticVar pos (MultiChr c v x) (PointR i)+    , MkStream m posLeft ls (PointR i)+    )+  ⇒ MkStream m pos (ls :!: MultiChr c v x) (PointR i) where+  mkStream pos (ls :!: MultiChr xs) grd us is+    = S.map (\(ss,ee,ii) -> ElmMultiChr ee ii ss) -- recover ElmChr+    . addTermStream1 pos (MultiChr @v @x @c xs) us is+    $ mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos (MultiChr @v @x @c xs) us is grd) us (termStreamIndex pos (MultiChr @v @x @c xs) is)+  {-# Inline mkStream #-}+++instance+  ( TermStreamContext m ps ts s x0 i0 is (PointR I)+  , KnownNat c+  ) => TermStream m (ps:.IStatic d) (TermSymbol ts (MultiChr c v x)) s (is:.PointR I) where+  termStream Proxy (ts:|MultiChr xs) (us:..LtPointR u) (is:.PointR i)+    = let !c = fromIntegral $ natVal (Proxy ∷ Proxy c) in+      S.map (\(TState s ii ee) ->+        let RiPrI k = getIndex (getIdx s) (Proxy ∷ PRI is (PointR I))+        in  TState s (ii:.:RiPrI (k+c)) (ee:. VG.unsafeSlice k c xs))+    . termStream (Proxy ∷ Proxy ps) ts us is+  {-# Inline termStream #-}++instance+  ( TermStreamContext m ps ts s x0 i0 is (PointR I)+  , KnownNat c+  ) => TermStream m (ps:.IVariable d) (TermSymbol ts (MultiChr c v x)) s (is:.PointR I) where+  termStream Proxy (ts:|MultiChr xs) (us:..LtPointR u) (is:.PointR i)+    = let !c = fromIntegral $ natVal (Proxy ∷ Proxy c) in+      S.map (\(TState s ii ee) ->+        let RiPrI k = getIndex (getIdx s) (Proxy ∷ PRI is (PointR I))+        in  TState s (ii:.:RiPrI (k+c)) (ee:. VG.unsafeSlice k c xs))+    . termStream (Proxy ∷ Proxy ps) ts us is+  {-# Inline termStream #-}++++instance (KnownNat c) ⇒ TermStaticVar (IStatic d) (MultiChr c v x) (PointR I) where+  termStreamIndex Proxy (MultiChr x) (PointR j) = PointR $ j+  termStaticCheck Proxy (MultiChr x) _ (PointR j) grd = grd+  {-# Inline [0] termStreamIndex #-}+  {-# Inline [0] termStaticCheck #-}++instance (KnownNat c) ⇒ TermStaticVar (IVariable d) (MultiChr c v x) (PointR I) where+  termStreamIndex Proxy (MultiChr x) (PointR j) = PointR $ j+  termStaticCheck Proxy (MultiChr x) _ (PointR j) grd = grd+  {-# Inline [0] termStreamIndex #-}+  {-# Inline [0] termStaticCheck #-}+

@@ -1,123 +0,0 @@--module ADP.Fusion.SynVar.Array-  ( module ADP.Fusion.SynVar.Array.Type-  , module ADP.Fusion.SynVar.Array-  ) where---import Data.Proxy-import Data.Strict.Tuple hiding (snd)-import Data.Vector.Fusion.Stream.Monadic-import Prelude hiding (map,mapM)--import Data.PrimitiveArray hiding (map)--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------ | Constraints needed to use @iTblStream@.--type ITblCx m ls arr x u c i =-  ( TableStaticVar u c i-  , MkStream m ls i-  , Element ls i-  , AddIndexDense (Elm (SynVar1 (Elm ls i)) (Z:.i)) (Z:.u) (Z:.c) (Z:.i)-  , PrimArrayOps arr u x-  )---- | General function for @ITbl@s with skalar indices.--iTblStream-  :: forall m ls arr x u c i . ITblCx m ls arr x u c i-  => Pair ls (TwITbl m arr c u x)-  -> Context i-  -> i-  -> i-  -> 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 lb ub us is-  $ mkStream ls (tableStaticVar (Proxy :: Proxy u) c vs is) us (tableStreamIndex (Proxy :: Proxy u) c vs is)-  where (lb,ub) = bounds t-{-# Inline iTblStream #-}---- | General function for @Backtrack ITbl@s with skalar indices.--btITblStream-  :: forall mB mF ls arr x r u c i . ITblCx mB ls arr x u c i-  => Pair ls (TwITblBt arr c u x mF mB r)-  -> Context i-  -> i-  -> i-  -> 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 ub tt >>= \ ~bb -> return $ ElmBtITbl (t!tt) bb ii' s)-    . addIndexDense1 c vs lb ub us is-    $ mkStream ls (tableStaticVar (Proxy :: Proxy u) c vs is) us (tableStreamIndex (Proxy :: Proxy u) c vs is)-    where (lb,ub) = bounds t-{-# Inline btITblStream #-}------ ** Instances--instance-  ( Monad m-  , ITblCx m ls arr x u c (i I)-  ) => 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 :!: 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 :!: 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 :!: 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 :!: TwITblBt arr c u x mF mB r) (i O) where-  mkStream = btITblStream-  {-# Inline mkStream #-}--instance-  ( Monad mB-  , ITblCx mB ls arr x u c (i C)-  ) => MkStream mB (ls :!: TwITblBt arr c u x mF mB r) (i C) where-  mkStream = btITblStream-  {-# Inline mkStream #-}--instance ModifyConstraint (TwITbl m arr EmptyOk i x) where-  type TNE (TwITbl m arr EmptyOk i x) = TwITbl m arr NonEmpty i x-  type TE  (TwITbl m arr EmptyOk i x) = TwITbl m arr EmptyOk  i x-  toNonEmpty (TW (ITbl b l _ arr) f) = TW (ITbl b l NonEmpty arr) f-  {-# Inline toNonEmpty #-}--instance ModifyConstraint (TwITblBt arr EmptyOk i x mF mB r) where-  type TNE (TwITblBt arr EmptyOk i x mF mB r) = TwITblBt arr NonEmpty i x mF mB r-  type TE  (TwITblBt arr EmptyOk i x mF mB r) = TwITblBt arr EmptyOk  i x mF mB r-  toNonEmpty (TW (BtITbl _ arr) bt) = TW (BtITbl NonEmpty arr) bt-  {-# Inline toNonEmpty #-}-

@@ -1,146 +0,0 @@--{-# Language DataKinds #-}-{-# Language TypeOperators #-}--module ADP.Fusion.SynVar.Array.Type where--import Data.Proxy-import Data.Strict.Tuple hiding (uncurry,snd)-import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..))-import Debug.Trace-import Prelude hiding (map,head,mapM)--import Data.PrimitiveArray hiding (map)--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.Classes-import ADP.Fusion.SynVar.TableWrap------ | Immutable table.--data ITbl arr c i x where-  ITbl :: { iTblBigOrder    :: {-# Unpack #-} !Int-          , iTblLittleOrder :: {-# Unpack #-} !Int-          , iTblConstraint  :: !c-          , iTblArray       :: !(arr i x)-          } -> ITbl arr c i x--type TwITbl m arr c i x = TW (ITbl arr c i x) (i -> i -> m 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 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 (TwITblBt arr c i x mF mB r) = (x,[r])------ * axiom stuff--instance-  ( Monad m-  , PrimArrayOps arr i x-  , IndexStream i-  ) => 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-  , 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 #-}------ * 'Element'--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-  {-# Inline getArg #-}-  {-# Inline getIdx #-}-  {-# Inline getElm #-}--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 :!: 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-  {-# Inline getArg #-}-  {-# Inline getIdx #-}-  {-# Inline getElm #-}--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------ * Multi-dim extensions--instance-  ( 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)-  , PrimArrayOps arr (us:.u) x-  ) => 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 lb ub us is-    $ mkStream ls (tableStaticVar (Proxy :: Proxy (us:.u)) c vs is) us (tableStreamIndex (Proxy :: Proxy (us:.u)) c vs is)-    where (lb,ub) = bounds t-  {-# Inline mkStream #-}--instance-  ( 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)-  , PrimArrayOps arr (us:.u) x-  ) => 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 ub tt >>= \ ~bb -> return $ ElmBtITbl (t!tt) bb ii' s)-    . addIndexDense c vs lb ub us is-    $ mkStream ls (tableStaticVar (Proxy :: Proxy (us:.u)) c vs is) us (tableStreamIndex (Proxy :: Proxy (us:.u)) c vs is)-    where (lb,ub) = bounds t-  {-# Inline mkStream #-}-

@@ -1,14 +0,0 @@---- | The 'axiom' runs a backtracking algebra. The name comes from Robert--- Giegerichs @ADP@ where @axiom@ runs the fully formed algorithm.--module ADP.Fusion.SynVar.Axiom where---- | The Axiom type class--class Axiom t where-  -- | The corresponding stream being returned by 'axiom'-  type AxiomStream t :: *-  -- | Given a table, run the axiom-  axiom :: t -> AxiomStream t-

@@ -1,28 +0,0 @@---- | Wrap forward tables in such a way as to allow backtracking via--- algebras.--module ADP.Fusion.SynVar.Backtrack where--import Data.Vector.Fusion.Stream.Monadic (Stream)--import ADP.Fusion.SynVar.TableWrap------ |------ TODO this should go into @ADP.Fusion.Table.Backtrack@, more than just--- tabulated syntactic vars are going to use it.------ NOTE You probably need to give the @monad morphism@ between @mF@ and--- @mB@ so as to be able to extract forward results in the backtracking--- phase.--class GenBacktrackTable t (mF :: * -> *) (mB :: * -> *) where-  data Backtrack t (mF :: * -> *) (mB :: * -> *) :: *-  type BacktrackIndex t :: *-  toBacktrack :: t -> (forall a . mF a -> mB a) {- -> (BacktrackIndex t -> BacktrackIndex t -> mB [r]) -} -> Backtrack t mF mB---- instance Build (TW (Backtrack t mF mB) f)-

@@ -1,319 +0,0 @@--module ADP.Fusion.SynVar.Fill where--import           Control.Monad-import           Control.Monad.Morph (hoist, MFunctor (..))-import           Control.Monad.Primitive (PrimMonad (..))-import           Control.Monad.ST-import           Control.Monad.Trans.Class (lift, MonadTrans (..))-import           Data.Vector.Fusion.Util (Id(..))-import           GHC.Exts (inline)-import qualified Data.Vector.Fusion.Stream.Monadic as SM-import           System.IO.Unsafe-import           Control.Monad (when,forM_)-import           Data.List (nub,sort,group)-import qualified Data.Vector.Unboxed as VU-import           Data.Proxy-import qualified GHC.Generics as G-import qualified Data.Typeable as T-import qualified Data.Data as D-import           Data.Dynamic-import           Data.Type.Equality-import qualified Data.List as L--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.Type-import           ADP.Fusion.SynVar.TableWrap--import           Debug.Trace------ | A vanilla context-free grammar--data CFG---- | This grammar is a multi-cfg in a monotone setting--data MonotoneMCFG----- * Unsafely mutate 'ITbls' and similar tables in the forward phase.---- | Mutate a cell in a stack of syntactic variables.------ TODO generalize to monad morphism via @mmorph@ package. This will allow--- more interesting @mrph@ functions that can, for example, track some--- state in the forward phase. (Note that this can be dangerous, we do--- /not/ want to have this state influence forward results, unless that can--- be made deterministic, or we'll break Bellman)--class MutateCell (h :: *) (s :: *) (im :: * -> *) i where-  mutateCell :: (Monad om, PrimMonad om) => Proxy h -> Int -> Int -> (forall a . im a -> om a) -> s -> i -> i -> om ()---- |--class MutateTables (h :: *) (s :: *) (im :: * -> *) where-  mutateTables :: (Monad om, PrimMonad om) => Proxy h -> (forall a . im a -> om a) -> s -> om s--class TableOrder (s :: *) where-  tableLittleOrder :: s -> [Int]-  tableBigOrder :: s -> [Int]--instance TableOrder Z where-  tableLittleOrder Z = []-  tableBigOrder Z = []-  {-# Inline tableLittleOrder #-}-  {-# Inline tableBigOrder #-}--instance (TableOrder ts) => 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:.TwIRec im c i x) where-  tableLittleOrder (ts:._) = tableLittleOrder ts-  tableBigOrder    (ts:._) = tableBigOrder ts-  {-# Inline tableLittleOrder #-}-  {-# Inline tableBigOrder #-}---- ** individual instances for filling a *single cell*--instance-  (-  ) => MutateCell p Z im i where-  mutateCell _ _ _ _ Z _ _ = return ()-  {-# INLINE mutateCell #-}--instance-  ( MutateCell CFG ts im i-  ) => MutateCell CFG (ts:.TwIRec im c i x) im i where-  mutateCell h bo lo mrph (ts:._) lu i = do-    mutateCell h bo lo mrph ts lu i-  {-# Inline mutateCell #-}--instance-  ( PrimArrayOps  arr i x-  , MPrimArrayOps arr i x-  , MutateCell CFG ts im i-  ) => MutateCell CFG (ts:.TwITbl im arr c i x) im 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-      z <- (inline mrph) $ f lu i-      writeM marr i z-  {-# INLINE mutateCell #-}--type ZS2 = Z:.Subword I:.Subword I--instance-  ( PrimArrayOps  arr ZS2 x-  , MPrimArrayOps arr ZS2 x-  , MutateCell MonotoneMCFG ts im ZS2-  ) => MutateCell MonotoneMCFG (ts:.TwITbl im arr c ZS2 x) im ZS2 where-  mutateCell h bo lo mrph (ts:.TW (ITbl tbo tlo c arr) f) lu iklj@(Z:.Subword (i:.k):.Subword(l:.j)) = do-    mutateCell h bo lo mrph ts lu iklj-    when (bo==tbo && lo==tlo && k<=l) $ do-      marr <- unsafeThaw arr-      z <- (inline mrph) $ f lu iklj-      writeM marr iklj z-  {-# INLINE mutateCell #-}--instance-  ( PrimArrayOps arr (Subword I) x-  , MPrimArrayOps arr (Subword I) x-  , MutateCell h ts im (Z:.Subword I:.Subword I)-  ) => MutateCell h (ts:.TwITbl im arr c (Subword I) x) im (Z:.Subword I:.Subword I) where-  mutateCell h bo lo mrph (ts:.TW (ITbl tbo tlo c arr) f) lu@(Z:.Subword (l:._):.Subword(_:.u)) ix@(Z:.Subword (i1:.j1):.Subword (i2:.j2)) = do-    mutateCell h bo lo mrph ts lu ix-    when (bo==tbo && lo==tlo && i1==i2 && j1==j2) $ do-      let i = i1-      let j = j1-      marr <- unsafeThaw arr-      z <- (inline mrph) $ f (subword l u) (subword i j)-      writeM marr (subword i j) z-  {-# Inline mutateCell #-}------ ** individual instances for filling a complete table and extracting the--- bounds--instance-  ( MutateCell h (ts:.TwITbl im arr c i x) im i-  , PrimArrayOps arr i x-  , Show i-  , IndexStream i-  , TableOrder (ts:.TwITbl im arr c i x)-  ) => MutateTables h (ts:.TwITbl im arr c i x) im 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-    let !tlos = VU.fromList . nub . sort $ tableLittleOrder tt-    VU.forM_ tbos $ \bo ->-      case (VU.length tlos) of-        1 -> let lo = VU.head tlos-             in  flip SM.mapM_ (streamUp from to) $ \k ->-                  mutateCell h bo lo (inline mrph) tt to k-        -- TODO each big-order group should be allowed to have its own sets-        -- of bounds. within a group, it doesn't make a lot of sense to-        -- have different bounds? Is there a use case for that even?-        _ -> flip SM.mapM_ (streamUp from to) $ \k ->-              VU.forM_ tlos $ \lo ->-                mutateCell h bo lo (inline mrph) tt to k-    return tt-  {-# INLINE mutateTables #-}---- | Default table filling, assuming that the forward monad is just @IO@.------ TODO generalize to @MonadIO@ or @MonadPrim@.--mutateTablesDefault :: MutateTables CFG t Id => t -> t-mutateTablesDefault t = unsafePerformIO $ mutateTables (Proxy :: Proxy CFG) (return . unId) t-{-# INLINE mutateTablesDefault #-}---- | Mutate tables, but observe certain hints. We use this for monotone--- mcfgs for now.--mutateTablesWithHints :: MutateTables h t Id => Proxy h -> t -> t-mutateTablesWithHints h t = unsafePerformIO $ mutateTables h (return . unId) t-------mutateTablesST t = runST $ mutateTablesNew t-{-# Inline mutateTablesST #-}---- | ------ TODO new way how to do table filling. Because we now have heterogeneous--- tables (i) group tables by @big order@ into different bins; (ii) check--- that each bin has the same bounds (needed? -- could we have--- smaller-sized tables once in a while); (iii) run each bin one after the--- other------ TODO measure performance penalty, if any. We might need liberal--- INLINEABLE, and specialization. On the other hand, we can do the--- freeze/unfreeze outside of table filling.--mutateTablesNew-  :: forall t m .-     ( TableOrder t-     , TSBO t-     , Monad m-     , PrimMonad m-     )-  => t-  -> m t-mutateTablesNew ts = do-  -- sort the tables according to [bigorder,type,littleorder]. For each-  -- @bigorder@, we should have only one @type@ and can therefor do the-  -- following (i) get subset of the @ts@, (ii) use outermost of @ts@ to-  -- get bounds, (iii) fill these tables-  let !tbos = VU.fromList . nub . sort $ tableBigOrder ts-  let ds = L.sort $ asDyn ts-  let goM :: (Monad m, PrimMonad m) => [Q] -> m ()-      goM [] = return ()-      goM xs = do-        ys <- fillWithDyn xs ts-        if null ys-          then return ()-          else goM ys-      {-# Inlinable goM #-}-  goM ds-  return ts-{-# Inline mutateTablesNew #-}--data Q = Q-  { qBigOrder     :: Int-  , qLittleOrder  :: Int-  , qTypeRep      :: T.TypeRep-  , qObject       :: Dynamic-  }-  deriving (Show)--instance Eq Q where-  Q bo1 lo1 tr1 _ == Q bo2 lo2 tr2 _ = (bo1,tr1,lo1) == (bo2,tr2,lo2)--instance Ord Q where-  Q bo1 lo1 tr1 _ `compare` Q bo2 lo2 tr2 _ = (bo1,tr1,lo1) `compare` (bo2,tr2,lo2)---- | Find the outermost table that has a certain big order and then fill--- from there.--class TSBO t where-  asDyn :: t -> [Q]-  fillWithDyn :: (Monad m, PrimMonad m) => [Q] -> t -> m [Q]--instance TSBO Z where-  asDyn Z = []-  fillWithDyn qs Z = return qs-  {-# Inlinable asDyn #-}-  {-# Inline fillWithDyn #-}--instance- ( TSBO ts- , Typeable arr- , Typeable c- , Typeable i- , Typeable x- , PrimArrayOps arr i x- , MPrimArrayOps arr i x- , IndexStream i- ) => TSBO (ts:.TwITbl Id arr c i x) where-  asDyn (ts:.t@(TW (ITbl bo lo _ _) _)) = Q bo lo (T.typeOf t) (toDyn t) : asDyn ts-  fillWithDyn qs (ts:.t@(TW (ITbl bo lo _ arr) f)) = do-    let (from,to) = bounds arr-    -- @hs@ are all tables that can be filled here-    -- @ns@ are all tables we can't fill and need to process further down-    -- the line-    let (hs,ns) = L.span (\Q{..} -> qBigOrder == bo && qTypeRep == T.typeOf t) qs-    if null hs-      then fillWithDyn qs ts-      else do-        let ms = Prelude.map concrete hs-            concrete  = (maybe (error "fromDynamic should not fail!")-                         (\x -> x `asTypeOf` t)-                        . fromDynamic . qObject)-        -- We have a single table and should short-circuit here-        ---        -- TODO we should specialize for tables of lengh @1..k@ for some-        -- small k. For @1@ and Needleman-Wunsch, we have a very nice @1.8@-        -- seconds down to @1.25@ seconds. :-)-        case (length ms) of-          1 -> do marr <- unsafeThaw arr-                  flip SM.mapM_ (streamUp from to) $ \k -> do-                    -- TODO @inline mrph@ ...-                    z <- (return . unId) $ f to k-                    writeM marr k z-        -- We have more than one table in will work over the list of tables-          _ -> do marrfs <- Prelude.mapM (\(TW (ITbl _ _ _ arr) f) -> unsafeThaw arr >>= \marr -> return (marr,f)) ms-                  flip SM.mapM_ (streamUp from to) $ \k ->-                    forM_ marrfs $ \(marr,f) -> do-                      z <- (return . unId) $ f to k-                      writeM marr k z-        -- traceShow (hs,length ms) $-        return ns-  {-# Inline fillWithDyn #-}---- We don't need to capture @IRec@ tables as no table-filling takes place--- for those tables. @asDyn@ therefore just collects on the remaining @ts@,--- while @fillWithDyn@ hands of to the next possible table.--instance-  ( TSBO ts-  ) => TSBO (ts:.TwIRec Id c i x) where-  asDyn (ts:.t@(TW (IRec _ _ _) _)) = asDyn ts-  fillWithDyn qs (ts:._) = fillWithDyn qs ts-  {-# Inlinable asDyn #-}-  {-# Inline fillWithDyn #-}-

@@ -1,98 +0,0 @@---- | Classes that enumerate the index structure necessary for actually--- performing the indexing.------ TODO Currently, we only provide dense index generation.--module ADP.Fusion.SynVar.Indices.Classes where--import Data.Proxy (Proxy(..))-import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,flatten,Step(..))-import Prelude hiding (map,head,mapM)--import Data.PrimitiveArray hiding (map)--import ADP.Fusion.Core.Classes-import ADP.Fusion.Core.Multi-import ADP.Fusion.Core.TyLvlIx------ | This type classes enable enumeration both in single- and multi-dim--- cases. The type @a@ is the type of the /full stack/ of indices, i.e. the--- full multi-tape problem.--class AddIndexDense s u c i where-  addIndexDenseGo-    :: (Monad m)-    => c -> Context i -> u -> u -> i -> i -> Stream m (SvState s a Z Z) -> Stream m (SvState s a u i)--instance AddIndexDense a Z Z Z where-  addIndexDenseGo _ _ _ _ _ _ = id-  {-# Inline addIndexDenseGo #-}---- | @SvState@ holds the state that is currently being built up by--- @AddIndexDense@. We have both @tIx@ (and @tOx@) and @iIx@ (and @iOx@).--- For most index structures, the indices will co-incide; however for some,--- this will not be true -- herein for @Set@ index structures.--data SvState s a u i = SvS-  { sS  :: !s -- ^ state coming in from the left---  , sIx :: !(RunningIndex a) --  @I/C@ index from @sS@-  , tx  :: !u -- ^ @I/C@ building up state to index the @table@.-  , iIx :: !(RunningIndex i) -- ^ @I/C@ building up state to hand over to next symbol-  }----- | Given an incoming stream with indices, this adds indices for the--- current syntactic variable / symbol.--addIndexDense-  :: ( Monad m-     , AddIndexDense s u c i-     , s ~ Elm x0 i0-     , Element x0 i0-     )-  => c -> Context i -> u -> u -> i -> i -> Stream m s -> Stream m (s,u,RunningIndex i)-addIndexDense t c lb ub u i = map (\(SvS s z i') -> (s,z,i')) . addIndexDenseGo t c lb ub u i . map (\s -> (SvS s Z RiZ))-{-# Inline addIndexDense #-}---- | In case of 1-dim tables, we wrap the index creation in a multi-dim--- system and remove the @Z@ later on. This allows us to have to write only--- a single instance.--addIndexDense1-  :: ( Monad m-     , AddIndexDense (Elm (SynVar1 (Elm x0 a)) (Z:.i)) (Z:.u) (Z:.c) (Z:.i)-     , GetIndex (Z:.a) (Z:.i)-     , s ~ Elm x0 a-     , Element x0 a-     )-  => c -> Context i -> u -> u -> i -> i -> Stream m s -> Stream m (s,u,RunningIndex i)-addIndexDense1 t c lb ub u i = map (\(SvS (ElmSynVar1 s) (Z:.z) (RiZ:.:i')) -> (s,z,i'))-                             . addIndexDenseGo (Z:.t) (Z:.c) (Z:.lb) (Z:.ub) (Z:.u) (Z:.i)-                             . map (\s -> (SvS (elmSynVar1 s i) Z RiZ))-{-# Inline addIndexDense1 #-}--newtype SynVar1 s = SynVar1 s--elmSynVar1 :: s -> i -> Elm (SynVar1 s) (Z:.i)-elmSynVar1 s _ = ElmSynVar1 s-{-# Inline elmSynVar1 #-}--instance (s ~ Elm x0 i, Element x0 i) => Element (SynVar1 s) (Z:.i) where-  newtype Elm (SynVar1 s) (Z:.i) = ElmSynVar1 s-  getIdx (ElmSynVar1 s) = RiZ :.: getIdx s-  {-# Inline getIdx #-}----- | Instance headers, we typically need.--type IndexHdr s x0 i0 us u cs c is i =-  ( AddIndexDense s us cs is-  , GetIndex (RunningIndex i0) (RunningIndex (is:.i))-  , GetIx (RunningIndex i0) (RunningIndex (is:.i)) ~ (RunningIndex i)-  , Element x0 i0-  , s ~ Elm x0 i0-  )-

@@ -1,63 +0,0 @@--module ADP.Fusion.SynVar.Indices.Point 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.PrimitiveArray hiding (map)--import ADP.Fusion.Core-import ADP.Fusion.Core.Point-import ADP.Fusion.SynVar.Indices.Classes----instance-  ( IndexHdr s x0 i0 us (PointL I) cs c is (PointL I)-  , MinSize c-  ) => AddIndexDense s (us:.PointL I) (cs:.c) (is:.PointL I) where-  addIndexDenseGo (cs:._) (vs:.IStatic d) (lbs:.lb) (ubs:.ub) (us:.u) (is:.i)-    = map (\(SvS s t y') -> SvS s (t:.i) (y' :.: RiPlI (fromPointL i)))-    . addIndexDenseGo cs vs lbs ubs us is-  addIndexDenseGo (cs:.c) (vs:.IVariable d) (lbs:.lb) (ubs:.ub) (us:.u) (is:.PointL i)-    = flatten mk step . addIndexDenseGo cs vs lbs ubs us is-    where mk svS = let RiPlI k = getIndex (getIdx $ sS svS {- sIx svS -} ) (Proxy :: PRI is (PointL I))-                   in  return $ svS :. k-          step (svS@(SvS s t y') :. k)-            | k + csize > i = return $ Done-            | otherwise     = return $ Yield (SvS s (t:.PointL k) (y' :.: RiPlI k)) (svS :. k+1)-            where csize = minSize c-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline addIndexDenseGo #-}--instance-  ( IndexHdr s x0 i0 us (PointL O) cs c is (PointL O)-  ) => AddIndexDense s (us:.PointL O) (cs:.c) (is:.PointL O) where-  addIndexDenseGo (cs:._) (vs:.OStatic d) (lbs:.lb) (ubs:.ub) (us:.u) (is:.i)-    = map (\(SvS s t y') -> let RiPlO oi oo = getIndex (getIdx s) (Proxy :: PRI is (PointL O))-                            in  SvS s (t:.PointL oo) (y' :.: RiPlO oi oo) )-    . addIndexDenseGo cs vs lbs ubs us is-  {-# Inline addIndexDenseGo #-}--instance-  ( IndexHdr s x0 i0 us (PointL I) cs c is (PointL C)-  ) => AddIndexDense s (us:.PointL I) (cs:.c) (is:.PointL C) where-  addIndexDenseGo (cs:._) (vs:.Complemented) (lbs:.lb) (ubs:.ub) (us:.u) (is:.i)-    = map (\(SvS s t y) -> let RiPlC k = getIndex (getIdx s) (Proxy :: PRI is (PointL C))-                           in  SvS s (t:.PointL k) (y :.: RiPlC k) )-    . addIndexDenseGo cs vs lbs ubs us is-  {-# Inline addIndexDenseGo #-}--instance-  ( IndexHdr s x0 i0 us (PointL O) cs c is (PointL C)-  ) => AddIndexDense s (us:.PointL O) (cs:.c) (is:.PointL C) where-  addIndexDenseGo (cs:._) (vs:.Complemented) (lbs:.lb) (ubs:.ub) (us:.u) (is:.i)-    = map (\(SvS s t y) -> let RiPlC k = getIndex (getIdx s) (Proxy :: PRI is (PointL C))-                           in  SvS s (t:.PointL k) (y:.:RiPlC k) )-    . addIndexDenseGo cs vs lbs ubs us is-  {-# Inline addIndexDenseGo #-}-

@@ -1,50 +0,0 @@---- | TODO if we have a table that has min-size @>0@ we need to immediately--- terminate @addIndexDenseGo@ !--module ADP.Fusion.SynVar.Indices.Unit where--import Data.Proxy-import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..))-import Data.Vector.Fusion.Util (delay_inline)-import Prelude hiding (map,head,mapM)--import Data.PrimitiveArray hiding (map)--import ADP.Fusion.Core-import ADP.Fusion.Core.Unit----instance-  ( IndexHdr s x0 i0 us (Unit I) cs c is (Unit I)-  ) => AddIndexDense s (us:.Unit I) (cs:.c) (is:.Unit I) where-  addIndexDenseGo (cs:._) (vs:.IStatic ()) (lbs:._) (ubs:._) (us:._) (is:._)-    = map (\(SvS s t y') -> SvS s (t:.Unit) (y':.:RiU))-    . addIndexDenseGo cs vs lbs ubs us is-  {-# Inline addIndexDenseGo #-}--instance-  ( IndexHdr s x0 i0 us (Unit O) cs c is (Unit O)-  ) => AddIndexDense s (us:.Unit O) (cs:.c) (is:.Unit O) where-  addIndexDenseGo (cs:._) (vs:.OStatic ()) (lbs:.lb) (ubs:.ub) (us:._) (is:._)-    = map (\(SvS s t y') -> SvS s (t:.Unit) (y':.:RiU))-    . addIndexDenseGo cs vs lbs ubs us is-  {-# Inline addIndexDenseGo #-}--instance-  ( IndexHdr s x0 i0 us (Unit I) cs c is (Unit C)-  ) => AddIndexDense s (us:.Unit I) (cs:.c) (is:.Unit C) where-  addIndexDenseGo (cs:._) (vs:.Complemented) (lbs:._) (ubs:._) (us:._) (is:._)-    = map (\(SvS s t y') -> SvS s (t:.Unit) (y':.:RiU))-    . addIndexDenseGo cs vs lbs ubs us is-  {-# Inline addIndexDenseGo #-}--instance-  ( IndexHdr s x0 i0 us (Unit O) cs c is (Unit C)-  ) => AddIndexDense s (us:.Unit O) (cs:.c) (is:.Unit C) where-  addIndexDenseGo (cs:._) (vs:.Complemented) (lbs:._) (ubs:._) (us:._) (is:._)-    = map (\(SvS s t y') -> SvS s (t:.Unit) (y':.:RiU))-    . addIndexDenseGo cs vs lbs ubs us is-  {-# Inline addIndexDenseGo #-}-

@@ -1,3 +0,0 @@--module ADP.Fusion.SynVar.Recursive.Point where-

@@ -1,123 +0,0 @@--module ADP.Fusion.SynVar.Recursive.Type where--import Control.Applicative (Applicative,(<$>),(<*>))-import Control.Monad.Morph-import Data.Proxy-import Data.Strict.Tuple-import Data.Vector.Fusion.Stream.Monadic (Stream,head,map,mapM)-import Prelude hiding (head,map,mapM)--import Data.PrimitiveArray hiding (map)--import ADP.Fusion.Core.Classes-import ADP.Fusion.Core.Multi-import ADP.Fusion.SynVar.Axiom-import ADP.Fusion.SynVar.Backtrack-import ADP.Fusion.SynVar.Indices.Classes-import ADP.Fusion.SynVar.TableWrap------ | A syntactic variable that does not memoize but simplify recurses. One--- needs to be somewhat careful when using this one. @ITbl@ performs--- memoization to perform DP in polynomial time (roughly speaking). If the--- rules for an @IRec@ are of a particular type, they will exponential--- running time. Things like @X -> X X@ are, for example, rather bad. Rules--- of the type @X -> Y, Y -> Z@ are ok, if @Y@ is an @IRec@ since we just--- continue on. The same holds for @Y -> a Y@. Basically, things are safe--- if there is only a (small) constant number of parses of an @IRec@--- synvar.--data IRec c i x where-  IRec :: { iRecConstraint  :: !c-          , iRecFrom        :: !i-          , iRecTo          :: !i-          } -> IRec c i x--type TwIRec m c i x = TW (IRec c i x) (i -> i -> m x)--type TwIRecBt c i x mF mB r = TW (Backtrack (TwIRec mF c i x) mF mB) (i -> i -> mB [r])--instance Build (TwIRec   m c i x)--instance Build (TwIRecBt c i x mF mB r)--type instance TermArg (TwIRec m c i x) = x--instance GenBacktrackTable (TwIRec mF c i x) mF mB where-  data Backtrack (TwIRec mF c i x) mF mB = BtIRec !c !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 #-}----instance-  ( Monad m-  , IndexStream i-  ) => 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 #-}--instance-  ( Monad mB-  , IndexStream i-  , 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 :!: TwIRec m c u x) i where-  data Elm (ls :!: TwIRec m c u x) i = ElmIRec !x !(RunningIndex i) !(Elm ls i)-  type Arg (ls :!: TwIRec m c u x)   = Arg ls :. x-  getArg (ElmIRec x _ ls) = getArg ls :. x-  getIdx (ElmIRec _ i _ ) = i-  {-# Inline getArg #-}-  {-# Inline getIdx #-}--instance Element ls i => Element (ls :!: TwIRecBt c u x mF mB r) i where-  data Elm (ls :!: (TwIRecBt c u x mF mB r)) i = ElmBtIRec !x [r] !(RunningIndex i) !(Elm ls i)-  type Arg (ls :!: (TwIRecBt c u x mF mB r))   = Arg ls :. (x, [r])-  getArg (ElmBtIRec x s _ ls) = getArg ls :. (x,s)-  getIdx (ElmBtIRec _ _ i _ ) = i-  {-# Inline getArg #-}-  {-# Inline getIdx #-}--instance-  ( Functor m-  , Monad m-  , 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 :!: 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 l h us is-    $ mkStream ls (tableStaticVar (Proxy :: Proxy (us:.u)) c vs is) us (tableStreamIndex (Proxy :: Proxy (us:.u)) c vs is)-  {-# Inline mkStream #-}--instance-  ( 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 :!: 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 l h us is-    $ mkStream ls (tableStaticVar (Proxy :: Proxy (us:.u)) c vs is) us (tableStreamIndex (Proxy :: Proxy (us:.u)) c vs is)-  {-# Inline mkStream #-}-

@@ -1,200 +0,0 @@---- |------ NOTE /highly experimental/--module ADP.Fusion.SynVar.Split.Type-  ( module ADP.Fusion.SynVar.Split.Type-  , Proxy (..)-  ) where--import Data.Proxy-import Data.Strict.Tuple-import Data.Vector.Fusion.Stream.Monadic-import Data.Vector.Fusion.Util (delay_inline)-import Debug.Trace-import GHC.TypeLits-import Prelude hiding (map,mapM)-import Data.Type.Equality--import Data.PrimitiveArray hiding (map)--import ADP.Fusion.Core.Classes-import ADP.Fusion.Core.Multi-import ADP.Fusion.SynVar.Array.Type-import ADP.Fusion.SynVar.Backtrack-import ADP.Fusion.SynVar.TableWrap----data SplitType = Fragment | Final---- | The @Arg synVar@ means that we probably need to rewrite the internal--- type resolution now!--type family CalcSplitType splitType varTy where-  CalcSplitType Fragment varTy = ()-  CalcSplitType Final    varTy = varTy---- | Should never fail?--type family ArgTy argTy where---  ArgTy Z = Z-  ArgTy (z:.x) = x---- | Wraps a normal non-terminal and attaches a type-level unique identier--- and z-ordering (with the unused @Z@ at @0@).------ TODO attach empty/non-empty stuff (or get from non-splitted synvar?)------ TODO re-introduce z-ordering later (once we have a sort fun)--newtype Split (uId :: Symbol) {- (zOrder :: Nat) -} (splitType :: SplitType) synVar = Split { getSplit :: synVar }---- |------ TODO Here, we probably want to default to a @NonEmpty@ condition. Or at--- least have different versions of @split@.--split :: Proxy (uId::Symbol) -> {- Proxy (zOrder::Nat) -> -} Proxy (splitType::SplitType) -> synVar -> Split uId splitType synVar-split _ _ = Split-{-# Inline split #-}----splitNE :: (ModifyConstraint synVar) => Proxy (uId::Symbol) -> {- Proxy (zOrder::Nat) -> -} Proxy (splitType::SplitType) -> synVar -> Split uId splitType synVar---splitNE _ _ = Split . toNonEmpty---{-# Inline splitNE #-}----type Spl uId zOrder splitType = forall synVar . Split uId zOrder splitType synVar--instance Build (Split uId splitType synVar)--instance-  ( Element ls i-  ) => Element (ls :!: Split uId splitType (TwITbl 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 (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 #-}------ | 'collectIx' gobbles up indices that are tagged with the same symbolic--- identifier.--collectIx-  :: forall uId ls i .-     ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)-     )-  => Proxy uId -> Elm ls i -> SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)-collectIx p e = splitIxCol p (Proxy :: Proxy (SameSid uId (Elm ls i))) e---- | Closed type family that gives us a (type) function for type symbol--- equality.--type family SameSid uId elm :: Bool where-  SameSid uId (Elm (ls :!: Split sId splitType synVar) i) = uId == sId-  SameSid uId (Elm (ls :!: TermSymbol a b            ) i) = SameSid uId (TermSymbol a b)-  SameSid uId M                                           = False-  SameSid uId (TermSymbol a (Split sId splitType synVar)) = OR (uId == sId) (SameSid uId a)-  SameSid uId (Elm (ls :!: l                         ) i) = False---- | Type-level @(||)@--type family OR a b where-  OR False False = False-  OR a     b     = True---- | @x ++ y@ but for inductive tuples.------ TODO move to PrimitiveArray--class Zconcat x y where-  type Zpp x y :: *-  zconcat :: x -> y -> Zpp x y--instance Zconcat x Z where-  type Zpp x Z = x-  zconcat x Z = x-  {-# Inline zconcat #-}--instance -  ( Zconcat x z-  ) => Zconcat x (z:.y) where-  type Zpp x (z:.y) = Zpp x z :. y-  zconcat x (z:.y) = zconcat x z :. y-  {-# Inline zconcat #-}---- WORKS---- | Actually collect split indices based on if we managed to find the--- right @Split@ synvar (based on the right symbol).------ TODO this is not completely right, or? Since we should consider--- inside/outside?------ TODO 'splitIxCol' will need the index type @i@ to combine running index--- and index into the actual lookup part.--class SplitIxCol (uId::Symbol) (b::Bool) e where-  type SplitIxTy uId b e :: *-  splitIxCol :: Proxy uId -> Proxy b -> e -> SplitIxTy uId b e----instance SplitIxCol uId b (Elm S i) where-  type SplitIxTy uId b (Elm S i) = Z-  splitIxCol p b (ElmS _) = Z-  {-# Inline splitIxCol #-}---instance-  ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)-  , Element (ls :!: l) i-  , RecElm (ls :!: l) i ~ Elm ls i-  ) => SplitIxCol uId False (Elm (ls :!: l) i) where-  type SplitIxTy uId False (Elm (ls :!: l) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)-  splitIxCol p b e = collectIx p (getElm e)-  {-# Inline splitIxCol #-}--instance-  ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)-  ) => SplitIxCol   uId True (Elm (ls :!: Split sId splitType (TwITbl 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 (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-  ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)-  , Zconcat (SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)) (SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b))-  ) => SplitIxCol uId True (Elm (ls :!: TermSymbol a b) i) where-  type SplitIxTy uId True (Elm (ls :!: TermSymbol a b) i) = Zpp (SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)) (SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b))-  splitIxCol p b (ElmTS t i e) = collectIx p e `zconcat` ((error "ElmTS / splitIxCol") {- p t -} :: SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b))-  {-# Inline splitIxCol #-}-

@@ -1,11 +0,0 @@---- | 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,74 +0,0 @@--module ADP.Fusion.Term.Chr.Point where--import           Data.Proxy-import           Data.Strict.Tuple-import           Debug.Trace-import qualified Data.Vector.Fusion.Stream.Monadic as S-import qualified Data.Vector.Generic as VG--import           Data.PrimitiveArray--import           ADP.Fusion.Core-import           ADP.Fusion.Core.Point-import           ADP.Fusion.Term.Chr.Type------ | First try in getting this right with a @termStream@.------ TODO use @PointL i@ since this is probably the same for all single-tape--- instances with @ElmChr@.------ TODO it might even be possible to auto-generate this code via TH.--instance-  ( TmkCtx1 m ls (Chr r x) (PointL i)-  ) => MkStream m (ls :!: Chr r x) (PointL i) where-  mkStream (ls :!: Chr f xs) sv us is-    = S.map (\(ss,ee,ii) -> ElmChr ee ii ss) -- recover ElmChr-    . addTermStream1 (Chr f xs) sv us is-    $ mkStream ls (termStaticVar (Chr f xs) sv is) us (termStreamIndex (Chr f xs) sv is)-  {-# Inline mkStream #-}------ | Current first try for using @TermStream@------ TODO what happens to fusion if @staticCheck@ happens before @S.map@?------ NOTE / TODO a bit faster with @seq xs@ ?--instance-  ( TstCtx m ts s x0 i0 is (PointL I)-  ) => TermStream m (TermSymbol ts (Chr r x)) s (is:.PointL I) where-  termStream (ts:|Chr f xs) (cs:.IStatic d) (us:.PointL u) (is:.PointL i)-    -- seq xs . staticCheck (i>0 && i<=u && i<= VG.length xs)-    = S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:. f xs (i-1)))-    . termStream ts cs us is-  {-# Inline termStream #-}--instance-  ( TstCtx m ts s x0 i0 is (PointL O)-  ) => TermStream m (TermSymbol ts (Chr r x)) s (is:.PointL O) where-  termStream (ts:|Chr f xs) (cs:.OStatic d) (us:.PointL u) (is:.PointL i)-    = S.map (\(TState s ii ee) ->-                let RiPlO k o = getIndex (getIdx s) (Proxy :: PRI is (PointL O))-                in  TState s (ii:.: RiPlO (k+1) o) (ee:.f xs k))-    . termStream ts cs us is-  {-# Inline termStream #-}----instance TermStaticVar (Chr r x) (PointL I) where-  termStaticVar   _ sv _                = sv-  termStreamIndex _ _  (PointL j) = PointL $ j-1-  {-# Inline [0] termStaticVar #-}-  {-# Inline [0] termStreamIndex #-}--instance TermStaticVar (Chr r x) (PointL O) where-  termStaticVar   _ (OStatic d) _ = OStatic (d+1)-  termStreamIndex _ _           j = j-  {-# Inline [0] termStaticVar #-}-  {-# Inline [0] termStreamIndex #-}-

@@ -1,62 +0,0 @@---- |------ TODO Rename @Chr@ to @Vtx@, a vertex parser is a generalization of--- a char parser. But this is only semantics, so not super important to do--- now.--module ADP.Fusion.Term.Chr.Type where--import           Data.Strict.Tuple-import qualified Data.Vector.Generic as VG--import           Data.PrimitiveArray--import           ADP.Fusion.Core.Classes-import           ADP.Fusion.Core.Multi------ | A generic Character parser that reads a single character but allows--- passing additional information.------  'Chr' expects a function to retrieve @r@ at index position, followed by---  the actual generic vector with data.--data Chr r x where-  Chr :: VG.Vector v x-      => (v x -> Int -> r)-      -> !(v x)-      -> Chr r x---- | smart constructor for regular 1-character parsers--chr :: VG.Vector v x => v x -> Chr x x-chr = Chr VG.unsafeIndex-{-# Inline chr #-}---- | Smart constructor for Maybe Peeking, followed by a character.--chrLeft xs = Chr f xs where-  f xs k = ( xs VG.!? (k-1)-           , VG.unsafeIndex xs k-           )-  {-# Inline [0] f #-}-{-# Inline chrLeft #-}--instance Build (Chr r x)--instance-  ( Element ls i-  ) => Element (ls :!: Chr r x) i where-    data Elm (ls :!: Chr r x) i = ElmChr !r !(RunningIndex i) !(Elm ls i)-    type Arg (ls :!: Chr r x)   = Arg ls :. r-    getArg (ElmChr x _ ls) = getArg ls :. x-    getIdx (ElmChr _ i _ ) = i-    {-# Inline getArg #-}-    {-# Inline getIdx #-}--deriving instance (Show i, Show (RunningIndex i), Show r, Show (Elm ls i)) => Show (Elm (ls :!: Chr r x) i)--type instance TermArg (Chr r x) = r-

@@ -1,58 +0,0 @@--module ADP.Fusion.Term.Deletion.Point where--import           Data.Proxy-import           Data.Strict.Tuple-import qualified Data.Vector.Fusion.Stream.Monadic as S--import           Data.PrimitiveArray--import           ADP.Fusion.Core-import           ADP.Fusion.Core.Point-import           ADP.Fusion.Term.Deletion.Type----instance-  ( TmkCtx1 m ls Deletion (PointL i)-  ) => MkStream m (ls :!: Deletion) (PointL i) where-  mkStream (ls :!: Deletion) sv us is-    = S.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 (PointL I)-  ) => TermStream m (TermSymbol ts Deletion) s (is:.PointL I) where-  termStream (ts:|Deletion) (cs:.IStatic d) (us:.PointL u) (is:.PointL i)-    = S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:.()))-    . termStream ts cs us is-  {-# Inline termStream #-}--instance-  ( TstCtx m ts s x0 i0 is (PointL O)-  ) => TermStream m (TermSymbol ts Deletion) s (is:.PointL O) where-  termStream (ts:|Deletion) (cs:.OStatic d) (us:.PointL u) (is:.PointL i)-    = S.map (\(TState s ii ee) ->-                let io = getIndex (getIdx s) (Proxy :: PRI is (PointL O))-                in  TState s (ii:.: io) (ee:.()))-    . termStream ts cs us is-  {-# Inline termStream #-}----instance TermStaticVar Deletion (PointL I) where-  termStaticVar _ sv _ = sv-  termStreamIndex _ _ (PointL j) = PointL j-  {-# Inline [0] termStaticVar #-}-  {-# Inline [0] termStreamIndex #-}--instance TermStaticVar Deletion (PointL O) where-  termStaticVar   _ (OStatic d) _ = OStatic d-  termStreamIndex _ _           j = j-  {-# Inline [0] termStaticVar #-}-  {-# Inline [0] termStreamIndex #-}-

@@ -1,26 +0,0 @@--module ADP.Fusion.Term.Deletion.Type where--import Data.Strict.Tuple--import Data.PrimitiveArray--import ADP.Fusion.Core.Classes-import ADP.Fusion.Core.Multi----data Deletion = Deletion--instance Build Deletion--instance (Element ls i) => Element (ls :!: Deletion) i where-  data Elm (ls :!: Deletion) i = ElmDeletion !(RunningIndex i) !(Elm ls i)-  type Arg (ls :!: Deletion)   = Arg ls :. ()-  getArg (ElmDeletion _ l) = getArg l :. ()-  getIdx (ElmDeletion i _) = i-  {-# Inline getArg #-}-  {-# Inline getIdx #-}--type instance TermArg Deletion = ()-

@@ -1,55 +0,0 @@--module ADP.Fusion.Term.Deletion.Unit where--import           Data.Proxy-import           Data.Strict.Tuple-import qualified Data.Vector.Fusion.Stream.Monadic as S--import           Data.PrimitiveArray--import           ADP.Fusion.Core-import           ADP.Fusion.Core.Unit----instance-  ( TmkCtx1 m ls Deletion (Unit i)-  ) => MkStream m (ls :!: Deletion) (Unit i) where-  mkStream (ls :!: Deletion) sv us is-    = S.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 (Unit I)-  ) => TermStream m (TermSymbol ts Deletion) s (is:.Unit I) where-  termStream (ts:|Deletion) (cs:.IStatic ()) (us:._) (is:._)-    = S.map (\(TState s ii ee) -> TState s (ii:.:RiU) (ee:.()))-    . termStream ts cs us is-  {-# Inline termStream #-}--instance-  ( TstCtx m ts s x0 i0 is (Unit O)-  ) => TermStream m (TermSymbol ts Deletion) s (is:.Unit O) where-  termStream (ts:|Deletion) (cs:.OStatic ()) (us:._) (is:._)-    = S.map (\(TState s ii ee) -> TState s (ii:.:RiU) (ee:.()))-    . termStream ts cs us is-  {-# Inline termStream #-}----instance TermStaticVar Deletion (Unit I) where-  termStaticVar _ _ _ = IStatic ()-  termStreamIndex _ _ _ = Unit-  {-# Inline [0] termStaticVar #-}-  {-# Inline [0] termStreamIndex #-}--instance TermStaticVar Deletion (Unit O) where-  termStaticVar _ _ _ = OStatic ()-  termStreamIndex _ _ _ = Unit-  {-# Inline [0] termStaticVar #-}-  {-# Inline [0] termStreamIndex #-}-

@@ -1,39 +0,0 @@--module ADP.Fusion.Term.Edge.Type where--import Data.Strict.Tuple--import Data.PrimitiveArray--import ADP.Fusion.Core.Classes-import ADP.Fusion.Core.Multi----newtype From = From { getFrom :: Int }-  deriving (Eq,Ord,Show)--newtype To = To { getTo :: Int }-  deriving (Eq,Ord,Show)---- | An edge in a graph. As a parsing symbol, it will provide (From:.To)--- pairs.--data Edge = Edge--instance Build Edge--instance-  ( Element ls i-  ) => Element (ls :!: Edge) i where-    data Elm (ls :!: Edge) i = ElmEdge !(From:.To) !(RunningIndex i) (Elm ls i)-    type Arg (ls :!: Edge)   = Arg ls :. (From:.To)-    getArg (ElmEdge e _ ls) = getArg ls :. e-    getIdx (ElmEdge _ i _ ) = i-    {-# Inline getArg #-}-    {-# Inline getIdx #-}--deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: Edge) i)--type instance TermArg Edge = (From:.To)-

@@ -1,58 +0,0 @@--module ADP.Fusion.Term.Epsilon.Point where--import           Data.Proxy-import           Data.Strict.Tuple-import qualified Data.Vector.Fusion.Stream.Monadic as S--import           Data.PrimitiveArray--import           ADP.Fusion.Core-import           ADP.Fusion.Core.Point-import           ADP.Fusion.Term.Epsilon.Type----instance-  ( TmkCtx1 m ls Epsilon (PointL i)-  ) => MkStream m (ls :!: Epsilon) (PointL i) where-  mkStream (ls :!: Epsilon) sv us is-    = S.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 (PointL I)-  ) => TermStream m (TermSymbol ts Epsilon) s (is:.PointL I) where-  termStream (ts:|Epsilon) (cs:.IStatic d) (us:.PointL u) (is:.PointL i)-    = S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:.()))-    . termStream ts cs us is-  {-# Inline termStream #-}--instance-  ( TstCtx m ts s x0 i0 is (PointL O)-  ) => TermStream m (TermSymbol ts Epsilon) s (is:.PointL O) where-  termStream (ts:|Epsilon) (cs:.OStatic d) (us:.PointL u) (is:.PointL i)-    = S.map (\(TState s ii ee) ->-                let io = getIndex (getIdx s) (Proxy :: PRI is (PointL O))-                in  TState s (ii:.:io) (ee:.()))-    . termStream ts cs us is-  {-# Inline termStream #-}----instance TermStaticVar Epsilon (PointL I) where-  termStaticVar _ sv _ = sv-  termStreamIndex _ _ (PointL j) = PointL j-  {-# Inline [0] termStaticVar #-}-  {-# Inline [0] termStreamIndex #-}--instance TermStaticVar Epsilon (PointL O) where-  termStaticVar   _ (OStatic d) _ = OStatic d-  termStreamIndex _ _           j = j-  {-# Inline [0] termStaticVar #-}-  {-# Inline [0] termStreamIndex #-}-

@@ -1,26 +0,0 @@--module ADP.Fusion.Term.Epsilon.Type where--import Data.Strict.Tuple--import Data.PrimitiveArray--import ADP.Fusion.Core.Classes-import ADP.Fusion.Core.Multi----data Epsilon = Epsilon--instance Build Epsilon--instance (Element ls i) => Element (ls :!: Epsilon) i where-  data Elm (ls :!: Epsilon) i = ElmEpsilon !(RunningIndex i) !(Elm ls i)-  type Arg (ls :!: Epsilon)   = Arg ls :. ()-  getArg (ElmEpsilon _ l) = getArg l :. ()-  getIdx (ElmEpsilon i _) = i-  {-# Inline getArg #-}-  {-# Inline getIdx #-}--type instance TermArg Epsilon = ()-

@@ -1,55 +0,0 @@--module ADP.Fusion.Term.Epsilon.Unit where--import           Data.Proxy-import           Data.Strict.Tuple-import qualified Data.Vector.Fusion.Stream.Monadic as S--import           Data.PrimitiveArray--import           ADP.Fusion.Core-import           ADP.Fusion.Core.Unit----instance-  ( TmkCtx1 m ls Epsilon (Unit i)-  ) => MkStream m (ls :!: Epsilon) (Unit i) where-  mkStream (ls :!: Epsilon) sv us is-    = S.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 (Unit I)-  ) => TermStream m (TermSymbol ts Epsilon) s (is:.Unit I) where-  termStream (ts:|Epsilon) (cs:.IStatic ()) (us:._) (is:._)-    = S.map (\(TState s ii ee) -> TState s (ii:.:RiU) (ee:.()))-    . termStream ts cs us is-  {-# Inline termStream #-}--instance-  ( TstCtx m ts s x0 i0 is (Unit O)-  ) => TermStream m (TermSymbol ts Epsilon) s (is:.Unit O) where-  termStream (ts:|Epsilon) (cs:.OStatic ()) (us:._) (is:._)-    = S.map (\(TState s ii ee) -> TState s (ii:.:RiU) (ee:.()))-    . termStream ts cs us is-  {-# Inline termStream #-}----instance TermStaticVar Epsilon (Unit I) where-  termStaticVar _ _ _ = IStatic ()-  termStreamIndex _ _ _ = Unit-  {-# Inline [0] termStaticVar #-}-  {-# Inline [0] termStreamIndex #-}--instance TermStaticVar Epsilon (Unit O) where-  termStaticVar _ _ _ = OStatic ()-  termStreamIndex _ _ _ = Unit-  {-# Inline [0] termStaticVar #-}-  {-# Inline [0] termStreamIndex #-}-

@@ -1,30 +0,0 @@--module ADP.Fusion.Term.PeekIndex.Type where--import Data.Strict.Tuple--import Data.PrimitiveArray--import ADP.Fusion.Core.Classes-import ADP.Fusion.Core.Multi----data PeekIndex i = PeekIndex--instance Build (PeekIndex i)--instance-  ( Element ls i-  ) => Element (ls :!: PeekIndex i) i where-    data Elm (ls :!: PeekIndex i) i = ElmPeekIndex !i !(RunningIndex i) !(Elm ls i)-    type Arg (ls :!: PeekIndex i)   = Arg ls :. i-    getArg (ElmPeekIndex x _  ls)    = getArg ls :. x-    getIdx (ElmPeekIndex _ i  _ )    = i-    {-# Inline getArg #-}-    {-# Inline getIdx #-}--deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: PeekIndex i) i)--type instance TermArg (PeekIndex i) = PeekIndex i-

@@ -1,96 +0,0 @@--module ADP.Fusion.Term.Strng.Point where--import           Data.Proxy-import           Data.Strict.Tuple-import           Debug.Trace-import qualified Data.Vector.Fusion.Stream.Monadic as S-import qualified Data.Vector.Generic as VG--import           Data.PrimitiveArray--import           ADP.Fusion.Core-import           ADP.Fusion.Core.Point-import           ADP.Fusion.Term.Strng.Type----instance-  ( TmkCtx1 m ls (Strng v x) (PointL i)-  ) => MkStream m (ls :!: Strng v x) (PointL i) where-  mkStream (ls :!: strng@(Strng _ minL maxL xs)) 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 (PointL I)-  ) => TermStream m (TermSymbol ts (Strng v x)) s (is:.PointL I) where-  ---  termStream (ts:|Strng f minL maxL v) (cs:.IStatic d) (us:.PointL u) (is:.PointL i)-    = S.map (\(TState s ii ee) ->-                let RiPlI k = getIndex (getIdx s) (Proxy :: PRI is (PointL I))-                in  TState s (ii:.:RiPlI i) (ee:.f k (i-k) v))-    . termStream ts cs us is-  ---  termStream (ts:|Strng f minL maxL v) (cs:.IVariable d) (us:.PointL u) (is:.PointL i)-    = S.flatten mk step . termStream ts cs us is-    where mk (tstate@(TState s ii ee)) =-              let RiPlI k = getIndex (getIdx s) (Proxy :: PRI is (PointL I))-              in  return (tstate, i-k-d-minL)-          step (tstate@(TState s ii ee), z)-            | z >= 0 && (l-k <= maxL) = return $ S.Yield (TState s (ii:.:RiPlI l) (ee:.f k (l-k+1) v)) (tstate, z-1)-            | otherwise = return $ S.Done-            where RiPlI k = getIndex (getIdx s) (Proxy :: PRI is (PointL I))-                  l        = i - z - d-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline termStream #-}--instance-  ( TstCtx m ts s x0 i0 is (PointL O)-  ) => TermStream m (TermSymbol ts (Strng v x)) s (is:.PointL O) where-  ---  termStream (ts:|Strng f minL maxL v) (cs:.OStatic d) (us:.PointL u) (is:.PointL i)-    = S.map (\(TState s ii ee) ->-                let RiPlO k o = getIndex (getIdx s) (Proxy :: PRI is (PointL O))-                in  TState s (ii:.:RiPlO (i-d+1) o) (ee:.f k (i-k) v)) -- @i-d+1 or k-d+1@ ?-    . termStream ts cs us is-  ---  termStream (ts:|Strng f minL maxL v) (cs:.ORightOf d) (us:.PointL u) (is:.PointL i)-    = S.flatten mk step . termStream ts cs us is-    where mk (tstate@(TState s ii ee)) =-              let RiPlO k _ = getIndex (getIdx s) (Proxy :: PRI is (PointL O))-              in  return (tstate, i-k-d-minL)-          step (tstate@(TState s ii ee), z)-            | z >= 0 && (l-k <= maxL) = return $ S.Yield (TState s (ii:.:RiPlO l o) (ee:.f k (l-k+1) v)) (tstate, z-1)-            | otherwise = return $ S.Done-            where RiPlO k o = getIndex (getIdx s) (Proxy :: PRI is (PointL O))-                  l         = i - z - d-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline termStream #-}----instance TermStaticVar (Strng v x) (PointL I) where-  termStaticVar (Strng _ minL maxL _) (IStatic   d) _ = IVariable $ d + maxL - minL-  termStaticVar _                     (IVariable d) _ = IVariable d -- TODO is this right?-  ---  termStreamIndex (Strng _ minL _ _) (IStatic d) (PointL j) = PointL $ j - minL-  ---  {-# Inline [0] termStaticVar   #-}-  {-# Inline [0] termStreamIndex #-}--instance TermStaticVar (Strng v x) (PointL O) where-  termStaticVar (Strng _ minL maxL _) (OStatic  d) _ = ORightOf $ d + maxL - minL-  termStaticVar _                     (ORightOf d) _ = ORightOf 0 -- TODO is this right?-  ---  termStreamIndex _ _ j = j-  ---  {-# Inline [0] termStaticVar   #-}-  {-# Inline [0] termStreamIndex #-}-

@@ -1,55 +0,0 @@--module ADP.Fusion.Term.Strng.Type where--import           Data.Strict.Tuple-import qualified Data.Vector.Generic as VG--import           Data.PrimitiveArray--import           ADP.Fusion.Core.Classes-import           ADP.Fusion.Core.Multi------ | 'Strng' terminals return "strings", i.e. vectors of @Chr@s. They allow--- the user to specify @[ 0 .. ]@ atoms to be parsed at once. It is--- possible to both, limit the minimal and maximal number.------ NOTE gadt comments are not parsed by haddock?--data Strng v x where-  Strng :: VG.Vector v x-        => (Int -> Int -> v x -> v x)  -- @slice@ function-        -> Int                         -- minimal size-        -> Int                         -- maximal size (just use s.th. big if you don't want a limit)-        -> (v x)                       -- the actual vector-        -> Strng v x--manyS :: VG.Vector v x => v x -> Strng v x-manyS = \xs -> Strng VG.unsafeSlice 0 (VG.length xs) xs-{-# Inline manyS #-}--someS :: VG.Vector v x => v x -> Strng v x-someS = \xs -> Strng VG.unsafeSlice 1 (VG.length xs) xs-{-# Inline someS #-}--strng :: VG.Vector v x => Int -> Int -> v x -> Strng v x-strng = \minL maxL xs -> Strng VG.unsafeSlice minL maxL xs-{-# Inline strng #-}--instance Build (Strng v x)--instance-  ( Element ls i-  ) => Element (ls :!: Strng v x) i where-  data Elm (ls :!: Strng v x) i = ElmStrng !(v x) !(RunningIndex i) !(Elm ls i)-  type Arg (ls :!: Strng v x)   = Arg ls :. v x-  getArg (ElmStrng x _ ls) = getArg ls :. x-  getIdx (ElmStrng _ i _ ) = i-  {-# Inline getArg #-}-  {-# Inline getIdx #-}--deriving instance (Show i, Show (RunningIndex i), Show (v x), Show (Elm ls i)) => Show (Elm (ls :!: Strng v x) i)--type instance TermArg (Strng v x) = v x-

@@ -1,495 +0,0 @@--{-# 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---}-