packages feed

ADPfusion 0.4.1.1 → 0.6.0.0

raw patch · 120 files changed

Files

− ADP/Fusion.hs 
@@ -1,80 +0,0 @@---- | Generalized fusion system for grammars.------ NOTE Symbols typically do not check bound data for consistency. If you, say,--- bind a terminal symbol to an input of length 0 and then run your grammar,--- you probably get errors, garbled data or random crashes. Such checks are--- done via asserts in non-production code.--module ADP.Fusion-  ( module ADP.Fusion-  , module ADP.Fusion.Apply-  , module ADP.Fusion.Base-  , module ADP.Fusion.Term-  , module ADP.Fusion.SynVar-  , module ADP.Fusion.TH-  ) where--import           Data.Strict.Tuple-import           GHC.Exts (inline)-import qualified Data.Vector.Fusion.Stream.Monadic as S--import           ADP.Fusion.Apply-import           ADP.Fusion.Base-import           ADP.Fusion.SynVar-import           ADP.Fusion.Term-import           ADP.Fusion.TH--import qualified Data.Vector.Unboxed as VU--import           Data.PrimitiveArray------ | Apply a function to symbols on the RHS of a production rule. Builds the--- stack of symbols from 'xs' using 'build', then hands this stack to--- 'mkStream' together with the initial 'iniT' telling 'mkStream' that we are--- in the "outer" position. Once the stream has been created, we 'S.map'--- 'getArg' to get just the arguments in the stack, and finally 'apply' the--- function 'f'.--infixl 8 <<<-(<<<) f xs = \lu ij -> S.map (apply (inline f) . getArg) . mkStream (build xs) (initialContext ij) lu $ ij-{-# INLINE (<<<) #-}--infixl 8 <<#-(<<#) f xs = \lu ij -> S.mapM (apply (inline f) . getArg) . mkStream (build xs) (initialContext ij) lu $ ij-{-# INLINE (<<#) #-}---- | Combine two RHSs to give a choice between parses.--infixl 7 |||-(|||) xs ys = \lu ij -> xs lu ij S.++ ys lu ij-{-# INLINE (|||) #-}---- | Applies the objective function 'h' to a stream 's'. The objective function--- reduces the stream to a single optimal value (or some vector of co-optimal--- things).--infixl 5 ...-(...) s h = \lu ij -> (inline h) $ s lu ij-{-# INLINE (...) #-}---- -- | Additional outer check with user-given check function--- --- infixl 6 `check`--- check xs f = \ij -> let chk = f ij in chk `seq` outerCheck chk (xs ij)--- {-# INLINE check #-}---- | Separator between RHS symbols.--infixl 9 ~~-(~~) = (:!:)-{-# INLINE (~~) #-}---- | This separator looks much paper "on paper" and is not widely used otherwise.--infixl 9 %-(%) = (:!:)-{-# INLINE (%) #-}-
− ADP/Fusion/Apply.hs 
@@ -1,89 +0,0 @@--module ADP.Fusion.Apply where----import Data.Array.Repa.Index-import Data.PrimitiveArray (Z(..), (:.)(..))------ * Apply function 'f' in '(<<<)'--class Apply x where-  type Fun x :: *-  apply :: Fun x -> x--instance Apply (Z:.a -> res) where-  type Fun (Z:.a -> res) = a -> res-  apply fun (Z:.a) = fun a-  {-# INLINE apply #-}--instance Apply (Z:.a:.b -> res) where-  type Fun (Z:.a:.b -> res) = a->b -> res-  apply fun (Z:.a:.b) = fun a b-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c -> res) where-  type Fun (Z:.a:.b:.c -> res) = a->b->c -> res-  apply fun (Z:.a:.b:.c) = fun a b c-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d -> res) where-  type Fun (Z:.a:.b:.c:.d -> res) = a->b->c->d -> res-  apply fun (Z:.a:.b:.c:.d) = fun a b c d-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e -> res) where-  type Fun (Z:.a:.b:.c:.d:.e -> res) = a->b->c->d->e -> res-  apply fun (Z:.a:.b:.c:.d:.e) = fun a b c d e-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f -> res) = a->b->c->d->e->f -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f) = fun a b c d e f-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g -> res) = a->b->c->d->e->f->g -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g) = fun a b c d e f g-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h -> res) = a->b->c->d->e->f->g->h -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h) = fun a b c d e f g h-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) = a->b->c->d->e->f->g->h->i -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i) = fun a b c d e f g h i-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) = a->b->c->d->e->f->g->h->i->j -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j) = fun a b c d e f g h i j-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) = a->b->c->d->e->f->g->h->i->j->k -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k) = fun a b c d e f g h i j k-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) = a->b->c->d->e->f->g->h->i->j->k->l -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l) = fun a b c d e f g h i j k l-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m) = fun a b c d e f g h i j k l m-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n) = fun a b c d e f g h i j k l m n-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n->o -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o) = fun a b c d e f g h i j k l m n o-  {-# INLINE apply #-}-
− ADP/Fusion/Base.hs 
@@ -1,15 +0,0 @@--module ADP.Fusion.Base-  ( module ADP.Fusion.Base.Classes-  , module ADP.Fusion.Base.Multi-  , module ADP.Fusion.Base.Point-  , module ADP.Fusion.Base.Set-  , module ADP.Fusion.Base.Subword-  ) where--import ADP.Fusion.Base.Classes-import ADP.Fusion.Base.Multi-import ADP.Fusion.Base.Point-import ADP.Fusion.Base.Set-import ADP.Fusion.Base.Subword-
− ADP/Fusion/Base/Classes.hs 
@@ -1,144 +0,0 @@--module ADP.Fusion.Base.Classes where--import           Data.Strict.Tuple-import           Data.Vector.Fusion.Stream.Size-import qualified Data.Vector.Fusion.Stream.Monadic as S--import           Data.PrimitiveArray----data OutsideContext s-  = OStatic     s-  | ORightOf    s-  | OFirstLeft  s-  | OLeftOf     s--data InsideContext s-  = IStatic   s-  | IVariable s--data ComplementContext-  = Complemented--class RuleContext i where-  type Context i :: *-  initialContext :: i -> Context i---- | During construction of the stream, we need to extract individual elements--- from symbols in production rules. An element in a stream is fixed by both,--- the type @x@ of the actual argument we want to grab (say individual--- characters we parse from an input) and the type of indices @i@ we use.------ @Elm@ data constructors are all eradicated during fusion and should never--- show up in CORE.--class Element x i where-  data Elm    x i :: *-  type RecElm x i :: *-  type Arg    x   :: *-  getArg :: Elm x i -> Arg x-  getIdx :: Elm x i -> i-  getOmx :: Elm x i -> i-  getElm :: Elm x i -> RecElm x i---- | @mkStream@ creates the actual stream of elements (@Elm@) that will be fed--- to functions on the left of the @(<<<)@ operator. Streams work over all--- monads and are specialized for each combination of arguments @x@ and indices--- @i@.--class (Monad m) => MkStream m x i where-  mkStream :: x -> Context i -> i -> i -> S.Stream m (Elm x i)---- | Finally, we need to be able to correctly build together symbols on the--- right-hand side of the @(<<<)@ operator.------ The default makes sure that the last (or only) argument left over is--- correctly assigned a @Z@ to terminate the symbol stack.--class Build x where-  type Stack x :: *-  type Stack x = S :!: x-  build :: x -> Stack x-  default build :: (Stack x ~ (S :!: x)) => x -> Stack x-  build x = S :!: x-  {-# Inline build #-}--instance Build x => Build (x:!:y) where-  type Stack (x:!:y) = Stack x :!: y-  build (x:!:y) = build x :!: y-  {-# Inline build #-}---- | Similar to 'Z', but terminates an argument stack.--data S = S-  deriving (Eq,Show)--instance-  (-  ) => Element S i where-  data Elm S i = ElmS !i !i-  type Arg S   = Z-  getArg (ElmS _ _) = Z-  getIdx (ElmS i _) = i-  getOmx (ElmS _ o) = o-  {-# Inline getArg #-}-  {-# Inline getIdx #-}-  {-# Inline getOmx #-}--deriving instance Show ix => Show (Elm S ix)---- | 'staticCheck' acts as a static filter. If 'b' is true, we keep all stream--- elements. If 'b' is false, we discard all stream elements.--staticCheck :: Monad m => Bool -> S.Stream m a -> S.Stream m a-staticCheck b (S.Stream step t n) = b `seq` S.Stream snew (CheckLeft (b:.t)) (toMax n) where-  {-# Inline [0] snew #-}-  snew (CheckLeft  (False:._)) = return $ S.Done-  snew (CheckLeft  (True :.s)) = return $ S.Skip (CheckRight s)-  snew (CheckRight s         ) = do r <- step s-                                    case r of-                                      S.Yield x s' -> return $ S.Yield x (CheckRight s')-                                      S.Skip    s' -> return $ S.Skip    (CheckRight s')-                                      S.Done       -> return $ S.Done-{-# INLINE staticCheck #-}--data StaticCheck a b = CheckLeft a | CheckRight b----- | Constrains the behaviour of the memoizing tables. They may be 'EmptyOk' if--- @i==j@ is allowed (empty subwords or similar); or they may need 'NonEmpty'--- indices, or finally they can be 'OnlyZero' (only @i==j@ allowed) which is--- useful in multi-dimensional casese.--data TableConstraint-  = EmptyOk-  | NonEmpty-  | OnlyZero-  deriving (Eq,Show)--minSize :: TableConstraint -> Int-minSize NonEmpty = 1-minSize _        = 0-{-# INLINE minSize #-}--class ModifyConstraint t where-  toNonEmpty :: t -> t-  toEmpty    :: t -> t---- |--type family   TblConstraint x       :: *--type instance TblConstraint (is:.i)        =  TblConstraint is :. TblConstraint i-type instance TblConstraint Z              = Z-type instance TblConstraint (Outside o)    = TblConstraint o-type instance TblConstraint (Complement o) = TblConstraint o---- TODO move into the sub-modules--type instance TblConstraint PointL      = TableConstraint-type instance TblConstraint PointR      = TableConstraint-type instance TblConstraint Subword     = TableConstraint-
− ADP/Fusion/Base/Multi.hs 
@@ -1,189 +0,0 @@--module ADP.Fusion.Base.Multi where--import qualified Data.Vector.Fusion.Stream.Monadic as S-import           Data.Strict.Tuple--import           Data.PrimitiveArray--import           ADP.Fusion.Base.Classes------ * Multi-dimensional extension---- | Terminates a multi-dimensional terminal symbol stack.--data M = M-  deriving (Eq,Show)--infixl 2 :|---- | Terminal symbols are stacked together with @a@ tails and @b@ head.--data TermSymbol a b = a :| b-  deriving (Eq,Show)--instance Build (TermSymbol a b)---- | Extracts the type of a multi-dimensional terminal argument.--type family   TermArg x :: *-type instance TermArg M                = Z--instance (Element ls i) => Element (ls :!: TermSymbol a b) i where-  data Elm (ls :!: TermSymbol a b) i = ElmTS !(TermArg (TermSymbol a b)) !i !i !(Elm ls i)-  type Arg (ls :!: TermSymbol a b)   = Arg ls :. TermArg (TermSymbol a b)-  getArg (ElmTS a _ _ ls) = getArg ls :. a-  getIdx (ElmTS _ i _ _ ) = i-  getOmx (ElmTS _ _ o _ ) = o-  {-# INLINE getArg #-}-  {-# INLINE getIdx #-}--deriving instance (Show i, Show (TermArg (TermSymbol a b)), Show (Elm ls i)) => Show (Elm (ls :!: TermSymbol a b) i)--instance-  ( Monad m-  , MkStream m ls i-  , Element ls i-  , TerminalStream m (TermSymbol a b) i-  , TermStaticVar (TermSymbol a b) i-  ) => MkStream m (ls :!: TermSymbol a b) i where-  mkStream (ls :!: ts) sv lu i-    = S.map fromTerminalStream-    . terminalStream ts sv i-    . S.map toTerminalStream-    $ mkStream ls (termStaticVar ts sv i) lu (termStreamIndex ts sv i)-  {-# Inline mkStream #-}---- | Handles each individual argument within a stack of terminal symbols.--class TerminalStream m t i where-  terminalStream :: t -> Context i -> i -> S.Stream m (S5 s j j i i) -> S.Stream m (S6 s j j i i (TermArg t))--iPackTerminalStream a sv    (ii:._)  = terminalStream a sv ii     . S.map (\(S5 s zi zo    (is:.i)     (os:.o) ) -> S5 s (zi:.i) (zo:.o)    is     os )-{-# Inline iPackTerminalStream #-}--oPackTerminalStream a sv (O (is:.i)) = terminalStream a sv (O is) . S.map (\(S5 s zi zo (O (is:.i)) (O (os:.o))) -> S5 s (zi:.i) (zo:.o) (O is) (O os))-{-# Inline oPackTerminalStream #-}--instance (Monad m) => TerminalStream m M Z where-  terminalStream M _ Z = S.map (\(S5 s j1 j2 Z Z) -> S6 s j1 j2 Z Z Z)-  {-# INLINE terminalStream #-}--instance (Monad m) => TerminalStream m M (Outside Z) where-  terminalStream M _ (O Z) = S.map (\(S5 s j1 j2 (O Z) (O Z)) -> S6 s j1 j2 (O Z) (O Z) Z)-  {-# INLINE terminalStream #-}--instance Monad m => MkStream m S Z where-  mkStream _ _ _ _ = S.singleton (ElmS Z Z)-  {-# INLINE mkStream #-}--instance Monad m => MkStream m S (Outside Z) where-  mkStream _ _ _ _ = S.singleton (ElmS (O Z) (O Z))-  {-# INLINE mkStream #-}---- | For multi-dimensional terminals we need to be able to calculate how the--- static/variable signal changes and if the index for the inner part needs to--- be modified.--class TermStaticVar t i where-  termStaticVar   :: t -> Context i -> i -> Context i-  termStreamIndex :: t -> Context i -> i -> i--instance TermStaticVar M Z where-  termStaticVar   _ _ _ = Z-  termStreamIndex _ _ _ = Z-  {-# INLINE termStaticVar #-}-  {-# INLINE termStreamIndex #-}--instance TermStaticVar M (Outside Z) where-  termStaticVar   _ _ _ = Z-  termStreamIndex _ _ _ = O Z-  {-# INLINE termStaticVar #-}-  {-# INLINE termStreamIndex #-}--instance-  ( TermStaticVar a is-  , TermStaticVar b i-  ) => TermStaticVar (TermSymbol a b) (is:.i) where-  termStaticVar   (a:|b) (vs:.v) (is:.i) = termStaticVar   a vs is :. termStaticVar   b v i-  termStreamIndex (a:|b) (vs:.v) (is:.i) = termStreamIndex a vs is :. termStreamIndex b v i-  {-# INLINE termStaticVar #-}-  {-# INLINE termStreamIndex #-}--instance-  ( TermStaticVar a (Outside is)-  , TermStaticVar b (Outside i)-  ) => TermStaticVar (TermSymbol a b) (Outside (is:.i)) where-  termStaticVar   (a:|b) (vs:.v) (O (is:.i)) = termStaticVar   a vs (O is) :. termStaticVar   b v (O i)-  termStreamIndex (a:|b) (vs:.v) (O (is:.i)) =-    let (O js) = termStreamIndex a vs (O is)-        (O j)  = termStreamIndex b v (O i)-    in O (js:.j)-  {-# INLINE termStaticVar #-}-  {-# INLINE termStreamIndex #-}--data S4 a b c d     = S4 !a !b !c !d--data S5 a b c d e   = S5 !a !b !c !d !e--data S6 a b c d e f = S6 !a !b !c !d !e !f--fromTerminalStream (S6 s Z Z i o e) = ElmTS e i o s-{-# INLINE fromTerminalStream #-}--toTerminalStream s = S5 s Z Z (getIdx s) (getOmx s)-{-# INLINE toTerminalStream #-}--instance RuleContext Z where-  type Context Z = Z-  initialContext _ = Z-  {-# INLINE initialContext #-}--instance RuleContext (Outside Z) where-  type Context (Outside Z) = Z-  initialContext _ = Z-  {-# INLINE initialContext #-}--instance (RuleContext is, RuleContext i) => RuleContext (is:.i) where-  type Context (is:.i) = Context is:.Context i-  initialContext (is:.i) = initialContext is:.initialContext i-  {-# INLINE initialContext #-}--instance (RuleContext (Outside is), RuleContext (Outside i)) => RuleContext (Outside (is:.i)) where-  type Context (Outside (is:.i)) = Context (Outside is):.Context (Outside i)-  initialContext (O (is:.i)) = initialContext (O is):.initialContext (O i)-  {-# INLINE initialContext #-}--class TableStaticVar i where-  tableStaticVar   ::                    Context i -> i -> Context i-  tableStreamIndex :: TblConstraint i -> Context i -> i -> i--instance TableStaticVar Z where-  tableStaticVar     _ _ = Z-  tableStreamIndex _ _ _ = Z-  {-# INLINE [0] tableStaticVar   #-}-  {-# INLINE [0] tableStreamIndex #-}--instance TableStaticVar (Outside Z) where-  tableStaticVar     _ _ = Z-  tableStreamIndex _ _ _ = O Z-  {-# INLINE [0] tableStaticVar   #-}-  {-# INLINE [0] tableStreamIndex #-}--instance (TableStaticVar is, TableStaticVar i) => TableStaticVar (is:.i) where-  tableStaticVar           (vs:.v) (is:.i) = tableStaticVar      vs is :. tableStaticVar     v i-  tableStreamIndex (cs:.c) (vs:.v) (is:.i) = tableStreamIndex cs vs is :. tableStreamIndex c v i-  {-# INLINE [0] tableStaticVar   #-}-  {-# INLINE [0] tableStreamIndex #-}--instance (TableStaticVar (Outside is), TableStaticVar (Outside i)) => TableStaticVar (Outside (is:.i)) where-  tableStaticVar           (vs:.v) (O (is:.i)) = tableStaticVar      vs (O is) :. tableStaticVar     v (O i)-  tableStreamIndex (cs:.c) (vs:.v) (O (is:.i)) =-    let (O js) = tableStreamIndex cs vs (O is)-        (O j)  = tableStreamIndex c  v  (O i)-    in O (js:.j)-  {-# INLINE [0] tableStaticVar   #-}-  {-# INLINE [0] tableStreamIndex #-}-
− ADP/Fusion/Base/Point.hs 
@@ -1,112 +0,0 @@--module ADP.Fusion.Base.Point where--import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..),flatten)-import Data.Vector.Fusion.Stream.Size-import Debug.Trace-import Prelude hiding (map,filter)--import Data.PrimitiveArray hiding (map)--import ADP.Fusion.Base.Classes-import ADP.Fusion.Base.Multi----instance RuleContext PointL where-  type Context PointL = InsideContext Int-  initialContext _ = IStatic 0-  {-# Inline initialContext #-}--instance RuleContext (Outside PointL) where-  type Context (Outside PointL) = OutsideContext Int-  initialContext _ = OStatic 0-  {-# Inline initialContext #-}--instance RuleContext (Complement PointL) where-  type Context (Complement PointL) = ComplementContext-  initialContext _ = Complemented-  {-# Inline initialContext #-}----instance (Monad m) => MkStream m S PointL where-  mkStream S (IStatic d) (PointL u) (PointL j)-    = staticCheck (j>=0 && j<=d) . singleton $ ElmS (PointL 0) (PointL 0)-  mkStream S (IVariable _) (PointL u) (PointL j)-    = staticCheck (0<=j) . singleton $ ElmS (PointL 0) (PointL 0)-  {-# Inline mkStream #-}--instance (Monad m) => MkStream m S (Outside PointL) where-  mkStream S (OStatic d) (O (PointL u)) (O (PointL i))-    = staticCheck (i>=0 && i+d<=u && u == i) . singleton $ ElmS (O $ PointL i) (O . PointL $ i+d)-  mkStream S (OFirstLeft d) (O (PointL u)) (O (PointL i))-    = staticCheck (i>=0 && i+d<=u) . singleton $ ElmS (O $ PointL i) (O . PointL $ i+d)-  {-# Inline mkStream #-}----instance-  ( Monad m-  , MkStream m S is-  , Context (is:.PointL) ~ (Context is:.(InsideContext Int))-  ) => MkStream m S (is:.PointL) where-  mkStream S (vs:.IStatic d) (lus:.PointL u) (is:.PointL i)-    = staticCheck (i>=0 && i<=d && i<=u)-    . map (\(ElmS zi zo) -> ElmS (zi:.PointL 0) (zo:.PointL 0))-    $ mkStream S vs lus is-  {--  mkStream S (vs:.IVariable ) (lus:.PointL u) (is:.PointL i)-    = flatten mk step Unknown $ mkStream S vs lus is-    where mk e = i `seq` return (e,i)-          step (ElmS zi zo,k )-            | k>=0 && k<=u = return $ Yield (ElmS (zi:.PointL k) (zo:.PointL 0)) (ElmS zi zo, -1)-            | otherwise    = return $ Done-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  -}-  -- TODO here, we have a problem in the interplay of @staticCheck@ or-  -- @flatten@ and how we modify @is@. Apparently, once we demand to know-  -- about @i@, fusion breaks down.-  mkStream S (vs:.IVariable d) (lus:.PointL u) (is:.PointL i)-    = staticCheck (i>=0 && i<=u)-    $ map (\(ElmS zi zo) -> ElmS (zi:.PointL 0) (zo:.PointL 0))-    $ mkStream S vs lus is-  {-# INLINE mkStream #-}--instance-  ( Monad m-  , MkStream m S (Outside is)-  , Context (Outside (is:.PointL)) ~ (Context (Outside is) :. OutsideContext Int)-  ) => MkStream m S (Outside (is:.PointL)) where-  mkStream S (vs:.OStatic d) (O (lus:.PointL u)) (O (is:.PointL i))-    = staticCheck (i>=0 && i+d == u)-    . map (\(ElmS (O zi) (O zo)) -> ElmS (O (zi:.PointL i)) (O (zo:.(PointL $ i+d))))-    $ mkStream S vs (O lus) (O is)-  mkStream S (vs:.OFirstLeft d) (O (us:.PointL u)) (O (is:.PointL i))-    = staticCheck (i>=0 && i+d<=u)-    . map (\(ElmS (O zi) (O zo)) -> ElmS (O (zi:.PointL i)) (O (zo:.(PointL $ i+d))))-    $ mkStream S vs (O us) (O is)-  {-# Inline mkStream #-}--instance TableStaticVar PointL where-  tableStaticVar (IStatic   d) _ = IVariable d-  tableStaticVar (IVariable d) _ = IVariable d-  -- NOTE this code used to destroy fusion. If we inline tableStreamIndex-  -- very late (after 'mkStream', probably) then everything works out.-  tableStreamIndex c _ (PointL j)-    | c==EmptyOk  = PointL j-    | c==NonEmpty = PointL $ j-1-    | c==OnlyZero = PointL j -- this should then actually request a size in 'tableStaticVar' ...-  {-# INLINE [0] tableStaticVar   #-}-  {-# INLINE [0] tableStreamIndex #-}--instance TableStaticVar (Outside PointL) where-  tableStaticVar     (OStatic d) _ = OFirstLeft d-  tableStreamIndex c _ (O (PointL j))-    | c==EmptyOk  = O (PointL j)-    | c==NonEmpty = O (PointL $ j-1)-    | c==OnlyZero = O (PointL j) -- this should then actually request a size in 'tableStaticVar' ...-  {-# INLINE [0] tableStaticVar   #-}-  {-# INLINE [0] tableStreamIndex #-}-
− ADP/Fusion/Base/Set.hs 
@@ -1,103 +0,0 @@---- | The @Context@ for a @BitSet@ is the number of bits we should reserve--- for the more right-most symbols, which request a number of reserved--- bits.--module ADP.Fusion.Base.Set where--import Data.Vector.Fusion.Stream.Monadic (singleton,filter,enumFromStepN,map,unfoldr)-import Data.Vector.Fusion.Stream.Size-import Debug.Trace-import Prelude hiding (map,filter)-import Data.Bits--import Data.PrimitiveArray--import ADP.Fusion.Base.Classes-import ADP.Fusion.Base.Multi----type instance TblConstraint BitSet                              = TableConstraint-type instance TblConstraint (BitSet:>Interface i:>Interface j)  = TableConstraint----instance RuleContext BitSet where-  type Context BitSet = InsideContext Int-  initialContext _ = IStatic 0-  {-# Inline initialContext #-}--instance RuleContext (Outside BitSet) where-  type Context (Outside BitSet) = OutsideContext ()-  initialContext _ = OStatic ()-  {-# Inline initialContext #-}--instance RuleContext (Complement BitSet) where-  type Context (Complement BitSet) = ComplementContext-  initialContext _ = Complemented-  {-# Inline initialContext #-}----instance RuleContext (BS2I First Last) where-  type Context (BS2I First Last) = InsideContext Int-  initialContext _ = IStatic 0-  {-# Inline initialContext #-}--instance RuleContext (Outside (BS2I First Last)) where-  type Context (Outside (BS2I First Last)) = OutsideContext ()-  initialContext _ = OStatic ()-  {-# Inline initialContext #-}--instance RuleContext (Complement (BS2I First Last)) where-  type Context (Complement (BS2I First Last)) = ComplementContext-  initialContext _ = Complemented-  {-# Inline initialContext #-}----instance-  ( Monad m-  ) => MkStream m S BitSet where-  mkStream S (IStatic c) u s-    = staticCheck (c <= popCount s) . singleton $ ElmS s 0-  mkStream S (IVariable c) u s-    = staticCheck (c <= popCount s) . singleton $ ElmS 0 0-  {-# Inline mkStream #-}----instance-  ( Monad m-  ) => MkStream m S (BS2I First Last) where-  mkStream S (IStatic rp) u sij@(s:>Iter i:>j)-    = staticCheck (popCount s == 0 && rp == 0) . singleton $ ElmS (0:>Iter i:>Iter i) undefbs2i-  mkStream S (IVariable rp) u sij@(s:>Iter i:>j)-    = staticCheck (popCount s >= rp) . singleton $ ElmS (0:>Iter i:>Iter i) undefbs2i-  {-# Inline mkStream #-}--instance-  ( Monad m-  ) => MkStream m S (Outside (BS2I First Last)) where--instance-  ( Monad m-  ) => MkStream m S (Complement (BS2I First Last)) where------ | An undefined bitset with 2 interfaces.--undefbs2i :: BS2I f l-undefbs2i = (-1) :> (-1) :> (-1)-{-# Inline undefbs2i #-}--undefi :: Interface i-undefi = (-1)-{-# Inline undefi #-}---- | We sometimes need --data ThisThatNaught a b = This a | That b | Naught-
− ADP/Fusion/Base/Subword.hs 
@@ -1,102 +0,0 @@---- | Instances to allow 'Subword's to be used as index structures in--- @ADPfusion@.--module ADP.Fusion.Base.Subword where--import Data.Vector.Fusion.Stream.Monadic (singleton,filter,enumFromStepN,map,unfoldr)-import Data.Vector.Fusion.Stream.Size-import Debug.Trace-import Prelude hiding (map,filter)--import Data.PrimitiveArray hiding (map)--import ADP.Fusion.Base.Classes-import ADP.Fusion.Base.Multi----instance RuleContext Subword where-  type Context Subword = InsideContext ()-  initialContext _ = IStatic ()-  {-# Inline initialContext #-}--instance RuleContext (Outside Subword) where-  type Context (Outside Subword) = OutsideContext (Int:.Int)-  initialContext _ = OStatic (0:.0)-  {-# Inline  initialContext #-}--instance RuleContext (Complement Subword) where-  type Context (Complement Subword) = ComplementContext-  initialContext _ = Complemented-  {-# Inline initialContext #-}---- TODO write instance---- instance RuleContext (Complement Subword)----instance (Monad m) => MkStream m S Subword where-  mkStream S (IStatic ()) (Subword (_:.h)) (Subword (i:.j))-    = staticCheck (i>=0 && i==j && j<=h) . singleton $ ElmS (subword i i) (subword 0 0)-  -- NOTE it seems that a static check within an @IVariable@ context-  -- destroys fusion; maybe because of the outer flatten? We don't actually-  -- need a static check anyway because the next flatten takes care of-  -- conditional checks. @filter@ on the other hand, does work.-  -- TODO test with and without filter using quickcheck-  mkStream S (IVariable ()) (Subword (_:.h)) (Subword (i:.j))-    = filter (const $ 0<=i && i<=j && j<=h) . singleton $ ElmS (subword i i) (subword 0 0)-  {-# Inline mkStream #-}--instance (Monad m) => MkStream m S (Outside Subword) where-  mkStream S (OStatic (di:.dj)) (O (Subword (_:.h))) (O (Subword (i:.j)))-    = staticCheck (i==0 && j+dj==h) . singleton $ ElmS (O $ subword i j) (O $ Subword (i:.j+dj))-  mkStream S (OFirstLeft (di:.dj)) (O (Subword (_:.h))) (O (Subword (i:.j)))-    = let i' = i-di-      in  staticCheck (0 <= i' && i<=j && j+dj<=h) . singleton $ ElmS (O $ subword i' i') (O $ subword i' i')-  mkStream S (OLeftOf (di:.dj)) (O (Subword (_:.h))) (O (Subword (i:.j)))-    = let i' = i-di-      in  staticCheck (0 <= i' && i<=j && j+dj<=h)-    $ map (\k -> ElmS (O $ subword 0 k) (O $ subword k j))-    $ enumFromStepN 0 1 (i'+1)-  {-# Inline mkStream #-}--instance (Monad m) => MkStream m S (Complement Subword) where-  mkStream S Complemented (C (Subword (_:.h))) (C (Subword (i:.j)))-    = map (\(k,l) -> ElmS (C $ subword k l) (C $ subword k l))-    $ unfoldr go (i,i)-    where go (k,l)-            | k >h || k >j = Nothing-            | l==h || l==j = Just ( (k,l) , (k+1,k+1) )-            | otherwise    = Just ( (k,l) , (k  ,l+1) )-          {-# Inline [0] go #-}-  {-# Inline mkStream #-}----instance-  ( Monad m-  , MkStream m S is-  , Context (is:.Subword) ~ (Context is:.(InsideContext ()))-  ) => MkStream m S (is:.Subword) where-  mkStream S (vs:.IStatic ()) (lus:.Subword (_:.h)) (ixs:.Subword(i:.j))-    = staticCheck (i>=0 && i==j && j<=h)-    . map (\(ElmS zi zo) -> ElmS (zi:.subword i i) (zo:.subword 0 0))-    $ mkStream S vs lus ixs-  mkStream S (vs:.IVariable ()) (lus:.Subword (_:.h)) (ixs:.Subword (i:.j))-    = map (\(ElmS zi zo) -> ElmS (zi:.subword i i) (zo:.subword 0 0))-    . filter (const $ 0<=i && i<=j && j<=h)-    $ mkStream S vs lus ixs-  {-# Inline mkStream #-}--instance TableStaticVar Subword where-  tableStaticVar (IStatic   d) _ = IVariable d-  tableStaticVar (IVariable d) _ = IVariable d-  tableStreamIndex c _ (Subword (i:.j))-    | c==EmptyOk  = subword i j-    | c==NonEmpty = subword i (j-1)-    | c==NonEmpty = error "A.F.B.Subword ???"-  {-# INLINE [0] tableStaticVar   #-}-  {-# INLINE [0] tableStreamIndex #-}-
+ ADP/Fusion/Core.hs view
@@ -0,0 +1,152 @@++{-# Language MagicHash #-}++-- | Generalized fusion system for grammars.+--+-- This module re-exports only the core functionality.+--+-- NOTE Symbols typically do not check bound data for consistency. If you, say,+-- bind a terminal symbol to an input of length 0 and then run your grammar,+-- you probably get errors, garbled data or random crashes. Such checks are+-- done via asserts in non-production code.++module ADP.Fusion.Core+  ( module ADP.Fusion.Core+  , module ADP.Fusion.Core.Apply+  , module ADP.Fusion.Core.Classes+  , module ADP.Fusion.Core.Multi+  , module ADP.Fusion.Core.SynVar.Array.Type+  , module ADP.Fusion.Core.SynVar.Axiom+  , module ADP.Fusion.Core.SynVar.Backtrack+  , module ADP.Fusion.Core.SynVar.FillTyLvl+  , module ADP.Fusion.Core.SynVar.Indices+  , module ADP.Fusion.Core.SynVar.Recursive.Type+  , module ADP.Fusion.Core.SynVar.Split.Type+  , module ADP.Fusion.Core.SynVar.TableWrap+  , module ADP.Fusion.Core.Term.Chr+  , module ADP.Fusion.Core.Term.Deletion+  , module ADP.Fusion.Core.Term.Edge+  , module ADP.Fusion.Core.Term.Epsilon+  , module ADP.Fusion.Core.Term.MultiChr+  , module ADP.Fusion.Core.Term.PeekIndex+  , module ADP.Fusion.Core.Term.Str+  , module ADP.Fusion.Core.TH+  , module ADP.Fusion.Core.TyLvlIx+  , module Data.Vector.Fusion.Stream.Monadic+  , module Data.Vector.Fusion.Util+  ) where++import           Data.Vector.Fusion.Stream.Monadic (Stream (..))+import           Data.Strict.Tuple+import           GHC.Exts (inline)+import qualified Data.Vector.Fusion.Stream.Monadic as S+import           Data.Vector.Fusion.Util (Id(..))++import           Data.PrimitiveArray++import           ADP.Fusion.Core.Apply+import           ADP.Fusion.Core.Classes hiding (iIx)+import           ADP.Fusion.Core.Multi hiding (iIx)+import           ADP.Fusion.Core.SynVar.Array.Type+import           ADP.Fusion.Core.SynVar.Axiom+import           ADP.Fusion.Core.SynVar.Backtrack+import           ADP.Fusion.Core.SynVar.FillTyLvl+import           ADP.Fusion.Core.SynVar.Indices+import           ADP.Fusion.Core.SynVar.Recursive.Type+import           ADP.Fusion.Core.SynVar.Split.Type+import           ADP.Fusion.Core.SynVar.TableWrap+import           ADP.Fusion.Core.Term.Chr+import           ADP.Fusion.Core.Term.Deletion+import           ADP.Fusion.Core.Term.Edge+import           ADP.Fusion.Core.Term.Epsilon+import           ADP.Fusion.Core.Term.MultiChr+import           ADP.Fusion.Core.Term.PeekIndex+import           ADP.Fusion.Core.Term.Str+import           ADP.Fusion.Core.TH+import           ADP.Fusion.Core.TyLvlIx++++-- | Apply a function to symbols on the RHS of a production rule. Builds the+-- stack of symbols from 'xs' using 'build', then hands this stack to+-- 'mkStream' together with the initial 'iniT' telling 'mkStream' that we are+-- in the "outer" position. Once the stream has been created, we 'S.map'+-- 'getArg' to get just the arguments in the stack, and finally 'apply' the+-- function 'f'.++infixl 8 <<<+(<<<)+  ∷ forall k m initCtx symbols i b+  . ( Monad m+    , Build symbols+    , Element (Stack symbols) i+    , Apply (Arg (Stack symbols) → b)+    , initCtx ~ InitialContext i+    , MkStream m initCtx (Stack symbols) i+    )+  ⇒ (Fun (Arg (Stack symbols) → b))+  → symbols+  → (LimitType i → i → Stream m b)+(<<<) f xs+  = \lu ij+  → S.map (apply (inline f) . getArg)+  $ mkStream (Proxy ∷ Proxy initCtx) (build xs) 1# lu ij+{-# INLINE (<<<) #-}++--infixl 8 <<#+--(<<#) f xs = \lu ij -> S.mapM (apply (inline f) . getArg) $ mkStream Proxy (build xs) 1# lu ij+--{-# INLINE (<<#) #-}++-- | Combine two RHSs to give a choice between parses.++infixl 7 |||+(|||) xs ys = \lu ij -> xs lu ij `streamappend` ys lu ij+{-# INLINE (|||) #-}++data StreamAppend a b = SAL a | SAR b++streamappend :: Monad m => Stream m a -> Stream m a -> Stream m a+{-# Inline streamappend #-}+Stream stepa ta `streamappend` Stream stepb tb = Stream step (SAL ta)+  where+    {-# Inline [0] step #-}+    step (SAL   sa) = do+                        r <- stepa sa+                        case r of+                          S.Yield x sa' -> return $ S.Yield x (SAL sa')+                          S.Skip    sa' -> return $ S.Skip    (SAL sa')+                          S.Done        -> return $ S.Skip    (SAR tb)+    step (SAR   sb) = do+                        r <- stepb sb+                        case r of+                          S.Yield x sb' -> return $ S.Yield x (SAR sb')+                          S.Skip    sb' -> return $ S.Skip    (SAR sb')+                          S.Done        -> return $ S.Done+++-- | Applies the objective function 'h' to a stream 's'. The objective function+-- reduces the stream to a single optimal value (or some vector of co-optimal+-- things).++infixl 5 ...+(...) s h = \lu ij -> (inline h) $ s lu ij+{-# INLINE (...) #-}++-- -- | Additional outer check with user-given check function+-- +-- infixl 6 `check`+-- check xs f = \ij -> let chk = f ij in chk `seq` outerCheck chk (xs ij)+-- {-# INLINE check #-}++-- | Separator between RHS symbols.++infixl 9 ~~+(~~) = (:!:)+{-# INLINE (~~) #-}++-- | This separator looks much paper "on paper" and is not widely used otherwise.++infixl 9 %+(%) = (:!:)+{-# INLINE (%) #-}+
+ ADP/Fusion/Core/Apply.hs view
@@ -0,0 +1,89 @@++module ADP.Fusion.Core.Apply where++--import Data.Array.Repa.Index+import Data.PrimitiveArray.Index.Class (Z(..), (:.)(..))++++-- * Apply function 'f' in '(<<<)'++class Apply x where+  type Fun x :: *+  apply :: Fun x -> x++instance Apply (Z:.a -> res) where+  type Fun (Z:.a -> res) = a -> res+  apply fun (Z:.a) = fun a+  {-# INLINE apply #-}++instance Apply (Z:.a:.b -> res) where+  type Fun (Z:.a:.b -> res) = a->b -> res+  apply fun (Z:.a:.b) = fun a b+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c -> res) where+  type Fun (Z:.a:.b:.c -> res) = a->b->c -> res+  apply fun (Z:.a:.b:.c) = fun a b c+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d -> res) where+  type Fun (Z:.a:.b:.c:.d -> res) = a->b->c->d -> res+  apply fun (Z:.a:.b:.c:.d) = fun a b c d+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d:.e -> res) where+  type Fun (Z:.a:.b:.c:.d:.e -> res) = a->b->c->d->e -> res+  apply fun (Z:.a:.b:.c:.d:.e) = fun a b c d e+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d:.e:.f -> res) where+  type Fun (Z:.a:.b:.c:.d:.e:.f -> res) = a->b->c->d->e->f -> res+  apply fun (Z:.a:.b:.c:.d:.e:.f) = fun a b c d e f+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d:.e:.f:.g -> res) where+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g -> res) = a->b->c->d->e->f->g -> res+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g) = fun a b c d e f g+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h -> res) where+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h -> res) = a->b->c->d->e->f->g->h -> res+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h) = fun a b c d e f g h+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) where+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) = a->b->c->d->e->f->g->h->i -> res+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i) = fun a b c d e f g h i+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) where+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) = a->b->c->d->e->f->g->h->i->j -> res+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j) = fun a b c d e f g h i j+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) where+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) = a->b->c->d->e->f->g->h->i->j->k -> res+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k) = fun a b c d e f g h i j k+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) where+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) = a->b->c->d->e->f->g->h->i->j->k->l -> res+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l) = fun a b c d e f g h i j k l+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) where+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m -> res+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m) = fun a b c d e f g h i j k l m+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) where+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n -> res+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n) = fun a b c d e f g h i j k l m n+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) where+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n->o -> res+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o) = fun a b c d e f g h i j k l m n o+  {-# INLINE apply #-}+
+ ADP/Fusion/Core/Classes.hs view
@@ -0,0 +1,233 @@++{-# Language MagicHash #-}++module ADP.Fusion.Core.Classes where++import           Control.DeepSeq+import           Data.Proxy+import           Data.Strict.Tuple+import           GHC.Exts hiding (build)+import           GHC.Generics (Generic, Generic1)+import qualified Data.Vector.Fusion.Stream.Monadic as S++import           Data.PrimitiveArray.Index.Class++++-- TODO Until I figure out how to use @InitialContext ∷ k@ instead of+-- @InitialContext ∷ *@ we need to live in @*@. Unfortunately, @(<<<)@ does not+-- like differently-kinded types.++{-+data OutsideContext s+  = OStatic     s+  | ORightOf    s+  | OFirstLeft  s+  | OLeftOf     s+  deriving (Show)+-}+data OStatic    s+data ORightOf   s+data OFirstLeft s+data OLeftOf    s++{-+data InsideContext s+  = IStatic   {iGetContext :: s}+  | IVariable {iGetContext :: s}+  deriving (Show)+-}+data IStatic   s+data IVariable s++{-+data ComplementContext+  = Complemented+  deriving (Show)+-}+data Complement++-- | Needed for structures that have long-range interactions and "expand",+-- like sets around edge boundaries: @set <edge> set@. requires the sets to+-- be connected.++data ExtComplementContext s+  = CStatic s+  | CVariable s++-- | For each index type @ix@, @initialContext (Proxy ∷ ix)@ yields the initial+-- context from which to start up rules.+--+-- TODO turn into type family and make 'initialContext' a global function.++type family InitialContext ix ∷ *++{-+class RuleContext ix where+  type InitialContext ix ∷ *+  initialContext ∷ Proxy ix → Proxy (InitialContext ix)+--  default initialContext ∷ Proxy ix → Proxy (InitialContext ix ∷ k)+  initialContext Proxy = Proxy+  {-# Inline initialContext #-}+-}++-- | While we ostensibly use an index of type @i@ we typically do not need+-- every element of an @i@. For example, when looking at 'Subword's, we do+-- not need both element of @j:.k@ but only @k@.+-- Also, inside grammars do need fewer moving indices than outside+-- grammars.++data family RunningIndex i :: *++data instance RunningIndex Z = RiZ+  deriving (Generic, NFData, Show)++data instance RunningIndex (is:.i) = !(RunningIndex is) :.: !(RunningIndex i)+  deriving (Generic)++deriving instance (NFData (RunningIndex is), NFData (RunningIndex i)) => NFData (RunningIndex (is:.i))++-- | During construction of the stream, we need to extract individual elements+-- from symbols in production rules. An element in a stream is fixed by both,+-- the type @x@ of the actual argument we want to grab (say individual+-- characters we parse from an input) and the type of indices @i@ we use.+--+-- @Elm@ data constructors are all eradicated during fusion and should never+-- show up in CORE.++class Element (x ∷ *) i where+  data Elm    x i ∷ *+  type RecElm x i ∷ *+  type Arg    x   ∷ *+  getArg ∷ Elm x i → Arg x+  getIdx ∷ Elm x i → RunningIndex i+  getElm ∷ Elm x i → RecElm x i++-- | @mkStream@ creates the actual stream of elements (@Elm@) that will be fed+-- to functions on the left of the @(<<<)@ operator. Streams work over all+-- monads and are specialized for each combination of arguments @x@ and indices+-- @i@.++class (Monad m) ⇒ MkStream m pos sym ix where+  mkStream+    ∷ Proxy pos+    -- ^ Fix static/variable/... depending on position in r.h.s. of rule.+    → sym+    -- ^ the symbol type (syntactic variable with or with memoization, terminal types like char, string, etc)+    → Int#+    -- ^ guard system for stopping execution of rule+    → LimitType ix+    -- ^ upper limit of index @i@, using the specialized 'LimitType' for type @i@.+    → ix+    -- ^ the current index @i@+    → S.Stream m (Elm sym ix)+    -- ^ resulting stream of elements++-- | This type family yields for a given positional type @posty ∷ k@, the+-- current symbol type @symty@ and index type @ix@ the next-left positional+-- type within the same kind @k@ Keeping within the same kind should prevent+-- accidental switching from Inside to Outside or similar bugs.++type family LeftPosTy (pos ∷ *) sym ix ∷ *++-- | Finally, we need to be able to correctly build together symbols on the+-- right-hand side of the @(<<<)@ operator.+--+-- The default makes sure that the last (or only) argument left over is+-- correctly assigned a @Z@ to terminate the symbol stack.++class Build x where+  type Stack x :: *+  type Stack x = S :!: x+  build :: x -> Stack x+  default build :: (Stack x ~ (S :!: x)) => x -> Stack x+  build x = S :!: x+  {-# Inline build #-}++instance Build x => Build (x:!:y) where+  type Stack (x:!:y) = Stack x :!: y+  build (x:!:y) = build x :!: y+  {-# Inline build #-}++-- | Similar to 'Z', but terminates an argument stack.++data S = S+  deriving (Eq,Show)++instance+  (+  ) => Element S i where+  newtype Elm S i = ElmS (RunningIndex i)+  type Arg S   = Z+  getArg (ElmS _) = Z+  getIdx (ElmS i) = i+  {-# Inline [0] getArg #-}+  {-# Inline [0] getIdx #-}++deriving instance (Show (RunningIndex ix)) => Show (Elm S ix)++-- | 'staticCheck' acts as a static filter. If 'b' is true, we keep all stream+-- elements. If 'b' is false, we discard all stream elements.++staticCheck :: Monad m => Bool -> S.Stream m a -> S.Stream m a+staticCheck !b (S.Stream step t) = S.Stream snew (CheckLeft b t) where+  {-# Inline [0] snew #-}+  snew (CheckLeft  False _) = return $ S.Done+  snew (CheckLeft  True  s) = return $ S.Skip (CheckRight s)+  snew (CheckRight s      ) = do r <- step s+                                 case r of+                                   S.Yield x s' -> return $ S.Yield x (CheckRight s')+                                   S.Skip    s' -> return $ S.Skip    (CheckRight s')+                                   S.Done       -> return $ S.Done+{-# INLINE staticCheck #-}++data StaticCheck a b = CheckLeft Bool a | CheckRight b++staticCheck# :: Monad m => Int# -> S.Stream m a -> S.Stream m a+staticCheck# b (S.Stream step t) = S.Stream snew (SL b t) where+  {-# Inline [0] snew #-}+  snew (SL q s)+    | 1# <- q   = return $ S.Skip (SR s)+    | otherwise = return $ S.Done+  snew (SR s  ) = do r <- step s+                     case r of+                       S.Yield x s' -> return $ S.Yield x (SR s')+                       S.Skip    s' -> return $ S.Skip    (SR s')+                       S.Done       -> return $ S.Done+{-# Inline staticCheck# #-}+++data SLR z = SL Int# z | SR z++-- | Constrains the behaviour of the memoizing tables. They may be 'EmptyOk' if+-- @i==j@ is allowed (empty subwords or similar); or they may need 'NonEmpty'+-- indices, or finally they can be 'OnlyZero' (only @i==j@ allowed) which is+-- useful in multi-dimensional casese.++data EmptyOk = EmptyOk+  deriving (Show)++data NonEmpty = NonEmpty+  deriving (Show)++class MinSize c where+  minSize :: c -> Int++instance MinSize EmptyOk where+  minSize EmptyOk = 0+  {-# Inline minSize #-}++instance MinSize NonEmpty where+  minSize NonEmpty = 1+  {-# Inline minSize #-}++-- |+--+-- TODO Rewrite to generalize easily over multi-dim cases.++class ModifyConstraint t where+  type TNE t :: *+  type TE  t :: *+  toNonEmpty :: t -> TNE t+  toEmpty    :: t -> TE  t+
+ ADP/Fusion/Core/Multi.hs view
@@ -0,0 +1,228 @@++{-# Language MagicHash #-}++module ADP.Fusion.Core.Multi where++import qualified Data.Vector.Fusion.Stream.Monadic as S+import           Data.Vector.Fusion.Stream.Monadic+import           Data.Strict.Tuple+import           Data.Proxy+import           Prelude hiding (map)+import           GHC.Exts+import           Debug.Trace++import           Data.PrimitiveArray.Index.Class hiding (map)++import           ADP.Fusion.Core.Classes+import           ADP.Fusion.Core.TyLvlIx++++-- * Multi-dimensional extension++-- | Terminates a multi-dimensional terminal symbol stack.++data M = M+  deriving (Eq,Show)++infixl 2 :|++-- | Terminal symbols are stacked together with @a@ tails and @b@ head.++data TermSymbol a b = a :| b+  deriving (Eq,Show)++instance Build (TermSymbol a b)++-- | Extracts the type of a multi-dimensional terminal argument.++type family   TermArg x :: *+type instance TermArg M                = Z+type instance TermArg (TermSymbol a b) = (TermArg a) :. (TermArg b)++instance (Element ls i) => Element (ls :!: TermSymbol a b) i where+  data Elm (ls :!: TermSymbol a b) i = ElmTS !(TermArg (TermSymbol a b)) !(RunningIndex i) !(Elm ls i)+  type Arg (ls :!: TermSymbol a b)   = Arg ls :. TermArg (TermSymbol a b)+  getArg (ElmTS a _ ls) = getArg ls :. a+  getIdx (ElmTS _ i _ ) = i+  {-# INLINE getArg #-}+  {-# INLINE getIdx #-}++deriving instance (Show i, Show (RunningIndex i), Show (TermArg (TermSymbol a b)), Show (Elm ls i)) => Show (Elm (ls :!: TermSymbol a b) i)++type instance LeftPosTy (ps :. p) (TermSymbol a b) (is:.i) = (LeftPosTy ps a is) :. (LeftPosTy p b i)++instance+  ( Monad m+  , MkStream m posLeft ls i+  , Element ls i+  , TermStaticVar pos (TermSymbol a b) i+  , TermStream m pos (TermSymbol a b) (Elm ls i) i+  , posLeft ~ LeftPosTy pos (TermSymbol a b) i+  ) => MkStream m pos (ls :!: TermSymbol a b) i where+  mkStream Proxy (ls :!: ts) grd lu i+    = map (\(TState sS ii ee) -> ElmTS ee ii sS)+    . termStream (Proxy ∷ Proxy pos) ts lu i+    . map (\s -> TState s RiZ Z)+    $ mkStream (Proxy ∷ Proxy posLeft)+               ls+               (termStaticCheck (Proxy ∷ Proxy pos) ts lu i grd)+               lu (termStreamIndex (Proxy ∷ Proxy pos) ts i)+  {-# Inline mkStream #-}++-- | ++type instance LeftPosTy Z M Z = Z++instance Monad m => MkStream m Z S Z where+  -- mkStream Proxy S grd ZZ Z = S.filter (const $ isTrue# grd) $ S.singleton $ ElmS RiZ+  mkStream Proxy S grd ZZ Z = staticCheck# grd $ S.singleton $ ElmS RiZ+  {-# Inline mkStream #-}++-- | For multi-dimensional terminals we need to be able to calculate how the+-- static/variable signal changes and if the index for the inner part needs to+-- be modified.++class TermStaticVar pos sym ix where+--  termStaticVar   ∷ sym → Context i → i → Context i+  termStreamIndex ∷ Proxy pos → sym → ix → ix+  termStaticCheck ∷ Proxy pos → sym → LimitType ix → ix → Int# → Int#++instance TermStaticVar pos M Z where+  termStreamIndex Proxy M Z = Z+  termStaticCheck Proxy M _ Z grd = grd+  {-# INLINE [0] termStreamIndex #-}+  {-# INLINE [0] termStaticCheck #-}++instance+  ( TermStaticVar ps ts is+  , TermStaticVar p  t  i+  ) => TermStaticVar (ps:.p) (TermSymbol ts t) (is:.i) where+  termStreamIndex Proxy (ts:|t) (is:.i) = termStreamIndex (Proxy ∷ Proxy ps) ts is :. termStreamIndex (Proxy ∷ Proxy p) t i+  termStaticCheck Proxy (ts:|t) (us:..u) (is:.i) grd = termStaticCheck (Proxy ∷ Proxy ps) ts us is (termStaticCheck (Proxy ∷ Proxy p) t u i grd)+  {-# INLINE [0] termStreamIndex #-}+  {-# INLINE [0] termStaticCheck #-}++--instance RuleContext Z where+type instance InitialContext Z = Z++--instance (RuleContext is, RuleContext i) => RuleContext (is:.i) where+type instance InitialContext (is:.i) = InitialContext is:.InitialContext i++class TableStaticVar pos minSize tableIx ix where+  tableStreamIndex+    ∷ Proxy pos+    -- ^ provide type-level information on if we are currently static/variable/+    -- etc+    → minSize+    -- ^ Information on the minimal size of the corresponding table.+    → LimitType tableIx+    -- ^ provide type-level information on the index structure of the table we+    -- are looking at. This index structure might well be different than the+    -- @ix@ index we use in the grammar.+    → ix+    -- ^ current right-most index+    → ix+    -- ^ right-most index for symbol to the left of us++-- | Index "0" for multi-dimensional syntactic variables.++instance TableStaticVar pos Z tableIx Z where+  tableStreamIndex Proxy Z _ Z = Z+  {-# INLINE [0] tableStreamIndex #-}++instance+  ( TableStaticVar ps cs us is+  , TableStaticVar p  c  u  i+  )+  ⇒ TableStaticVar (ps:.p) (cs:.c) (us:.u) (is:.i) where+  tableStreamIndex Proxy (cs:.c) (us:..u) (is:.i)+    =  tableStreamIndex (Proxy ∷ Proxy ps) cs us is+    :. tableStreamIndex (Proxy ∷ Proxy p ) c  u  i+  {-# INLINE [0] tableStreamIndex #-}+++data TermState s i e = TState+  { tS  :: !s+    -- ^ state coming in from the left+  , iIx :: !(RunningIndex i)+    -- ^ @I/C@ building up state to hand over to next symbol+  , eTS :: !e+    -- ^ element data+  }++class TermStream m pos t s i where+  termStream+    ∷ Proxy pos+    → t+    → LimitType i+    → i+    → Stream m (TermState s Z Z)+    → Stream m (TermState s i (TermArg t))++instance (Monad m) => TermStream m pos M s Z where+  termStream Proxy M ZZ Z = id+  {-# Inline termStream #-}++-- |+--+-- TODO need @t -> ElmType t@ type function+--+-- TODO need to actually return an @ElmType t@ can do that instead of+-- returning @u@ !!!++addTermStream1+  ∷ forall m pos t s i+  . ( Monad m+    , TermStream m (Z:.pos) (TermSymbol M t) (Elm (Term1 s) (Z:.i)) (Z:.i)+    )+  ⇒ Proxy pos+  → t+  → LimitType i+  → i+  → Stream m s+  → Stream m (s,TermArg t,RunningIndex i)+addTermStream1 Proxy t u i+  = map (\(TState (ElmTerm1 sS) (RiZ:.:ii) (Z:.ee)) -> (sS,ee,ii))+  . termStream (Proxy ∷ Proxy (Z:.pos)) (M:|t) (ZZ:..u) (Z:.i)+  . map (\s -> TState (elmTerm1 s i) RiZ Z)+{-# Inline addTermStream1 #-}++newtype Term1 s = Term1 s++elmTerm1 :: s -> i -> Elm (Term1 s) (Z:.i)+elmTerm1 s _ = ElmTerm1 s+{-# Inline elmTerm1 #-}++instance (s ~ Elm x0 i, Element x0 i) => Element (Term1 s) (Z:.i) where+  newtype Elm (Term1 s) (Z:.i) = ElmTerm1 s+  getIdx (ElmTerm1 s) = RiZ :.: getIdx s+  {-# Inline getIdx #-}++-- | @Term MkStream@ context+--+-- TODO prepare for deletion++--type TermMkStreamContext m (pos ∷ k) ls t i+--  = ( Monad m+--    , MkStream m pos ls i+--    , TermStream m pos (TermSymbol M t) (Elm (Term1 (Elm ls i)) (Z:.i)) (Z:.i)+--    , Element ls i+--    , TermStaticVar pos t i+--    )++-- | @Term TermStream@ context++type TermStreamContext m (pos ∷ k) ts s x0 sixty is i+  = ( Monad m+    , TermStream m pos ts s is+    , GetIndex (RunningIndex sixty) (RunningIndex (is:.i))+    , GetIx (RunningIndex sixty) (RunningIndex (is:.i)) ~ (RunningIndex i)+    , Element x0 sixty+    , s ~ Elm x0 sixty+    )++-- | Shorthand for proxifying @getIndex@++type PRI is i = Proxy (RunningIndex (is:.i))+
+ ADP/Fusion/Core/SynVar/Array.hs view
@@ -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 #-}+-}+
+ ADP/Fusion/Core/SynVar/Array/Type.hs view
@@ -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 #-}+
+ ADP/Fusion/Core/SynVar/Axiom.hs view
@@ -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+
+ ADP/Fusion/Core/SynVar/Backtrack.hs view
@@ -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)+
+ ADP/Fusion/Core/SynVar/Fill.hs view
@@ -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 #-}++-}+
+ ADP/Fusion/Core/SynVar/FillTyLvl.hs view
@@ -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+
+ ADP/Fusion/Core/SynVar/Indices.hs view
@@ -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+  )+
+ ADP/Fusion/Core/SynVar/Recursive/Type.hs view
@@ -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 #-}+
+ ADP/Fusion/Core/SynVar/Split/Type.hs view
@@ -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 #-}+
+ ADP/Fusion/Core/SynVar/TableWrap.hs view
@@ -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 ++ ")"+
+ ADP/Fusion/Core/TH.hs view
@@ -0,0 +1,77 @@++-- | The functions in here auto-create suitable algebra product functions from+-- a signature. Currently, functions @<**@ are supported which have scalar+-- results in the first variable.+--+-- TODO If we want to support classified DP, we shall also need @**<@+-- generating vector-results given a vector result, followed by a scalar+-- result.+--+-- TODO Then we also need @***@ handling the case of vector-to-vector results.+--+-- TODO note the comments in @buildBacktrackingChoice@++module ADP.Fusion.Core.TH+  ( makeAlgebraProduct+  , (<||)+  , (**>)+  ) where++import           Data.List+import           Data.Tuple.Select+import           Language.Haskell.TH+import           Language.Haskell.TH.Syntax+import qualified Data.Vector.Fusion.Stream.Monadic as SM++import           ADP.Fusion.Core.TH.Backtrack -- (makeBacktrackingProductInstance,(<||))+import           ADP.Fusion.Core.TH.Common (getRuleResultType)++++makeAlgebraProduct = makeProductInstances++{-+-- | Create the algebra product function from a signature type constructor.+--+-- TODO make the resulting function INLINE+--+-- TODO compare @synTypes@ with the stream argument types of all @hs@ (via their+-- @hns@ names). If there is a mismatch, then either not all non-terminal types+-- have a corresponding choice function or vice versa.++makeAlgebraProductH :: [Name] -> Name -> Q [Dec]+makeAlgebraProductH hns nm = do+  rnm <- reify nm+  case rnm of+    TyConI (DataD ctx tyConName args cs d) -> case cs of+      -- we analyze the accessor functions and look for the objective function+      -- accessor. It's stream parameter is the type of the non-terminal.+      -- Everything else in accessors are terminal parameters.+      [RecC dataConName fs'] -> do+        -- split @fs@ into functions applied to rule RHSs and choice functions (@hs@)+        let (fs,hs) = partition ((`notElem` hns) . sel1) fs'+        -- the result types of the @fs@ are the types of the non-terminal symbols+        let synTypes = nub . map getRuleResultType $ fs+--        funStream <- funD (mkName "<**") [genClauseStream dataConName fs' fs hs]+        funList   <- funD (mkName "<||") [genClauseBacktrack dataConName fs' fs hs]+        return+--          [ funStream+          [ funList+          , PragmaD $ InlineP (mkName "<||") Inline FunLike AllPhases+          ]+      _   -> fail "more than one data ctor"+    _          -> fail "unsupported data type"++-- | Creates a class for each type of product and instances for each+-- signature.++makeClassyProducts :: Name -> Q [Dec]+makeClassyProducts conName = do+  c <- lookupValueName "BacktrackingProduct"+  case c of+    Nothing -> error "need to create class now and add instance"+    Just cl -> error "add instance"+  return []+-}++
+ ADP/Fusion/Core/TH/Backtrack.hs view
@@ -0,0 +1,498 @@++-- | Backtracking which uses lists internally. The basic idea is to convert+-- each @Stream@ into a list. The consumer consumes the stream lazily, but+-- allows for fusion to happen. The hope is that this improves total+-- performance in those cases, where backtracking has significant costs.++module ADP.Fusion.Core.TH.Backtrack where++import           Control.Applicative ( (<$>) )+import           Control.Monad+import           Control.Monad.Primitive (PrimState, PrimMonad)+import           Data.List+import           Data.Tuple.Select+import           Data.Vector.Fusion.Stream.Monadic (Stream(..))+import           Debug.Trace+import           Language.Haskell.TH+import           Language.Haskell.TH.Instances+import           Language.Haskell.TH.Syntax+import qualified Data.Map.Strict as M+import qualified Data.Vector as V+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Generic.Mutable as VGM+import qualified Data.Vector.Mutable as VM+import qualified Data.Set as S++import           Data.PrimitiveArray.Index.Class ( (:.)(..) , Z(..) )++import           ADP.Fusion.Core.TH.Common++import Control.Monad.Reader++++-- | @Backtracking@ products of @f@ and @b@. Choice in @f@ needs to be+-- reduced to a scalar value. It is then compared to the @fst@ values+-- in @b@. From those, @choice b@ selects.++class ProductBacktracking sigF sigB where+  type SigBacktracking sigF sigB :: *+  (<||) :: sigF -> sigB -> SigBacktracking sigF sigB++-- | The ADP-established product operation. Returns a vector of results,+-- along the lines of what the ADP @f *** b@ provides.+--+-- @f **> g@ assumes a vector-to-vector function @f@, and+-- a vector-to-scalar function @g@.++class ProductCombining sigF sigB where+  type SigCombining sigF sigB :: *+  (**>) :: sigF -> sigB -> SigCombining sigF sigB++-- | Creates instances for all products given a signature data type.++makeProductInstances :: Name -> Q [Dec]+makeProductInstances tyconName = do+  t <- reify tyconName+  case t of+#if MIN_VERSION_template_haskell(2,11,0)+    TyConI (DataD ctx tyConName args maybeKind cs d) -> do+#else+    TyConI (DataD ctx tyConName args cs d) -> do+#endif+      let m = getMonadName args+      case cs of+        [RecC dataconName funs] -> do+          let Just (h,m',x,r) = getObjectiveNames funs+          mL <- newName "mL"+          xL <- newName "xL"+          rL <- newName "rL"+          mR <- newName "mR"+          xR <- newName "xR"+          rR <- newName "rR"+          let lType    = buildRightType tyconName (m', x, r) (mL, xL, rL)    args+          let rType    = buildRightType tyconName (m', x, r) (mR, xR, rR)    args+          let (fs,hs) = partition ((`notElem` [h]) . sel1) funs+          sigBType <- buildSigBacktrackingType  tyconName (m', x, r) xL (mR, xR, rR) args+          Clause psB (NormalB bB) dsB <- genAlgProdFunctions buildBacktrackingChoice dataconName funs fs hs+          iB <- [d| instance (Monad $(varT mL), Monad $(varT mR), Eq $(varT xL), $(varT mL) ~ $(varT mR), $(varT xL) ~ $(varT rL))+                      => ProductBacktracking $(return lType) $(return rType) where+                          type SigBacktracking $(return lType) $(return rType) = $(return sigBType)+                          (<||) = $(return $ LamE psB $ LetE dsB bB)+                          {-# Inline (<||) #-}+                |]+          -- TODO might well be that this doesn't work because we re-use+          -- type names ...+          vG <- newName "vG"+          sigPType <- buildSigCombiningType tyconName vG (m', x, r) (mL, xL, rL) (mR, xR, rR) args+          Clause psC (NormalB bC) dsC <- genAlgProdFunctions buildCombiningChoice    dataconName funs fs hs+          iC <- [d| instance (Monad $(varT mL), Monad $(varT mR), Eq $(varT xL), Ord $(varT xL), Ord $(varT xR), $(varT mL) ~ $(varT mR) ) -- , VG.Vector $(varT vG) ($(varT rL),$(varT rR)) )+                      => ProductCombining $(return lType) $(return rType) where+                          type SigCombining $(return lType) $(return rType) = $(return sigPType)+                          (**>) = $(return $ LamE psC $ LetE dsC bC)+                          {-# Inline (**>) #-}+                |]+          return $ iB ++ iC++-- | Returns the 'Name' of the monad variable.++getMonadName :: [TyVarBndr] -> Maybe Name+getMonadName = go+  where go [] = Nothing+        go (KindedTV m (AppT (AppT ArrowT StarT) StarT) : _) = Just m+        go (_ : xs) = go xs++-- | Returns the 'Name's of the objective function variables, as well as+-- the name of the objective function itself.++getObjectiveNames :: [VarStrictType] -> Maybe (Name,Name,Name,Name)+getObjectiveNames = go+  where go [] = Nothing+        go ( (hName , _ , (AppT (AppT ArrowT (AppT (AppT (ConT streamName) (VarT mS)) (VarT x))) (AppT (VarT mR) (VarT r)))) : xs)+          | streamName == ''Stream && mS == mR = Just (hName,mS,x,r)+          | otherwise             = go xs+        go ( _ : xs) = go xs++++-- * Constructions for the different algebra types.++-- | The left algebra type. Assumes that in @choice :: Stream m x -> m r@+-- we have that @x ~ r@.++buildLeftType :: Name -> (Name, Name, Name) -> (Name, Name) -> [TyVarBndr] -> Type+buildLeftType tycon (m, x, r) (mL, xL) = foldl AppT (ConT tycon) . map (VarT . go)+  where go (PlainTV z)+          | z == m        = mL  -- correct monad name+          | z == x        = xL  -- point to new x type+          | z == r        = xL  -- stream and return type are the same+          | otherwise     = z   -- everything else can stay as is+        go (KindedTV z _) = go (PlainTV z)++-- | Here, we do not set any restrictions on the types @m@ and @r@.++buildRightType :: Name -> (Name, Name, Name) -> (Name, Name, Name) -> [TyVarBndr] -> Type+buildRightType tycon (m, x, r) (mR, xR, rR) = foldl AppT (ConT tycon) . map (VarT . go)+  where go (PlainTV z)+          | z == m    = mR  -- have discovered a monadic type+          | z == x    = xR  -- have discovered a type that is equal to the stream type (and hence we have a synvar type)+          | z == r    = rR  -- have discovered a type that is equal to the result type (for @<||@) equal to the stream type, hence synvar+          | otherwise = z   -- this is a terminal or a terminal stack (we don't care)+        go (KindedTV z _) = go (PlainTV z)++-- | Build up the type for backtracking. We want laziness in the right+-- return type. Hence, we have @AppT ListT (VarT xR)@ ; i.e. we want to+-- return results in a list.++buildSigBacktrackingType :: Name -> (Name, Name, Name) -> (Name) -> (Name, Name, Name) -> [TyVarBndr] -> TypeQ+buildSigBacktrackingType tycon (m, x, r) (xL) (mR, xR, rR) = foldl appT (conT tycon) . map go+  where go (PlainTV z)+          | z == m    = varT mR+          | z == x    = [t| ($(varT xL) , [ $(varT xR) ] ) |]+          | z == r    = varT rR+          | otherwise = varT z+        go (KindedTV z _) = go (PlainTV z)++-- |+--+-- [1] we want a list for @[xR]@ because this will make it lazy here. At+-- least that was the reason for backtracking. For forward mode, we may not+-- want this. We will have to change the function combination then?++buildSigCombiningType :: Name -> Name -> (Name, Name, Name) -> (Name, Name, Name) -> (Name, Name, Name) -> [TyVarBndr] -> TypeQ+buildSigCombiningType tycon vG (m, x, r) (mL, xL, rL) (mR, xR, rR) = foldl appT (conT tycon) . map go+  where go (PlainTV z)+          | z == m    = varT mR+          | z == x    = [t| ($(varT xL) , [ $(varT xR) ] ) |]   -- [1]+          | z == r    = [t| V.Vector ($(varT rL) , $(varT rR)) |]+          | otherwise = varT z+        go (KindedTV z _) = go (PlainTV z)++++-- *++-- | Build up attribute and choice function. Here, we actually bind the+-- left and right algebra to @l@ and @r@.++genAlgProdFunctions+  :: Choice+  -> Name+  -> [VarStrictType]+  -> [VarStrictType]+  -> [VarStrictType]+  -> Q Clause+genAlgProdFunctions choice conName allFunNames evalFunNames choiceFunNames = do+  let nonTermNames = nub . map getRuleResultType $ evalFunNames+  -- bind the l'eft and r'ight variable of the two algebras we want to join,+  -- also create unique names for the function names we shall bind later.+  nameL <- newName "l"+  varL  <- varP nameL+  fnmsL <- sequence $ replicate (length allFunNames) (newName "fnamL")+  nameR <- newName "r"+  varR  <- varP nameR+  fnmsR <- sequence $ replicate (length allFunNames) (newName "fnamR")+  -- bind the individual variables in the where part+  whereL <- valD (conP conName (map varP fnmsL)) (normalB $ varE nameL) []+  whereR <- valD (conP conName (map varP fnmsR)) (normalB $ varE nameR) []+  rce <- recConE conName+          $  zipWith3 (genChoiceFunction choice) (drop (length evalFunNames) fnmsL) (drop (length evalFunNames) fnmsR) choiceFunNames+          ++ zipWith3 (genAttributeFunction nonTermNames) fnmsL fnmsR evalFunNames+  -- build the function pairs+  -- to keep our sanity, lets print this stuff+  let cls = Clause [varL, varR] (NormalB rce) [whereL,whereR]+  return cls++-- | Simple wrapper for creating the choice fun expression.++genChoiceFunction+  :: Choice+  -> Name+  -> Name+  -> VarStrictType+  -> Q (Name,Exp)+genChoiceFunction choice hL hR (name,_,t) = do+  exp <- choice hL hR+  return (name,exp)+++-- | We take the left and right function name for one attribute and build+-- up the combined attribute function. Mostly a wrapper around+-- 'recBuildLampat' which does the main work.+--+-- TODO need fun names from @l@ and @r@++genAttributeFunction+  :: [Name]+  -> Name+  -> Name+  -> VarStrictType+  -> Q (Name,Exp)+genAttributeFunction nts fL fR (name,_,t) = do+  (lamPat,funL,funR) <-recBuildLamPat nts fL fR (init $ getRuleSynVarNames nts t) -- @init@ since we don't want the result as a parameter+  let exp = LamE lamPat $ TupE [funL,funR]+  return (name,exp)++-- | Now things become trickly. We are given all non-terminal names (to+-- differentiate between a terminal (stack) and a syntactic variable; the+-- left and right function; and the arguments to this attribute function+-- (except the result parameter). We are given the latter as a result to an+-- earlier call to 'getRuleSynVarNames'.+--+-- We now look at each argument and determine wether it is a syntactic+-- variable. If so, then we actually have a tuple arguments @(x,ys)@ where+-- @x@ has to optimized value and @ys@ the backtracking list. The left+-- function receives just @x@ in this case. For the right function, things+-- are more complicated, since we have to flatten lists. See 'buildRns'.+--+-- Terminals are always given "as is" since we do not have a need for+-- tupled-up information as we have for syntactic variables.++recBuildLamPat+  :: [Name]   -- ^ all non-terminal names+  -> Name     -- ^ left attribute function+  -> Name     -- ^ right attribute function+  -> [ArgTy Name]  -- ^ all arguments to the attribute function+  -> Q ([Pat], Exp, Exp)+recBuildLamPat nts fL' fR' ts = do+  -- here we just run through all arguments, either creating an @x@ and+  -- a @ys@ for a non-term or a @t@ for a term.+  ps <- mapM argTyArgs ts+  lamPat <- buildLamPat ps+  lfun <- buildLns (VarE fL') ps -- foldl buildLfun (varE fL') ps+  rfun <- buildRns (VarE fR') ps+  return (lamPat, lfun, rfun)++buildLamPat :: [ArgTy Pat] -> Q [Pat]+buildLamPat = mapM go where+  go (SynVar      p ) = return p+  go (Term        p ) = return p+  go (StackedVars ps) = build ps+  build :: [ArgTy Pat] -> Q Pat+  build = foldl (\s v -> [p| $(s) :. $(return v) |]) [p|Z|] . map get+  get :: ArgTy Pat -> Pat+  get (SynVar p) = p+  get (Term   p) = p++-- | Look at the argument type and build the capturing variables. In+-- particular captures synvar arguments with a 2-tuple @(x,ys)@.++argTyArgs :: ArgTy Name -> Q (ArgTy Pat)+argTyArgs (SynVar n) = SynVar <$> tupP [newName "x" >>= varP , newName "ys" >>= varP]+argTyArgs (Term n)          = Term <$> (newName "t" >>= varP)+argTyArgs (StackedTerms _)  = Term <$> (newName "t" >>= varP) -- !!!+argTyArgs (StackedVars vs)  = StackedVars <$> mapM argTyArgs vs+argTyArgs NilVar            = Term <$> (newName "t" >>= varP)+argTyArgs (Result _)        = error "argTyArgs: should not receive @Result@"++buildLns+  :: Exp+  -> [ArgTy Pat]+  -> ExpQ+buildLns f' ps = foldl go (return f') ps+  where go :: ExpQ -> ArgTy Pat -> ExpQ+        go f (SynVar      (TupP [VarP v,_])) = appE f (varE v)+        go f (Term        (VarP v         )) = appE f (varE v)+        go f (StackedVars vs               ) = appE f (build vs)+        build :: [ArgTy Pat] -> ExpQ+        build = foldl (\s v -> [| $(s) :. $(varE v) |]) [|Z|] . map get+        get (SynVar (TupP [VarP v,_])) = v+        get (Term   (VarP t)         ) = t++-- | Build the right-hand side of a function combined in @f <|| g@. This+-- splits the paired synvars @(x,xs)@ such that we calculate @f x@ and @g+-- xs@.+--+-- NOTE If we want to write+--+-- @+-- [ f x | x <- xs ]+-- @+--+-- then in template haskell, this looks like this:+--+-- @+-- CompE [BindS (VarP x) (VarE xs), NoBindS (AppE (VarE f) (VarE x))]+-- @+--+-- The @NoBindS@ is the final binding of @f@ to the individual @x@'s, while+-- the prior @x <- xs@ comes from @BindS (VarP x) (VarE xs)@.+--+-- TODO This is where we might be able to improve performance if we can+-- optimize @[f x y | x <- xs, y <- ys]@ for @concatMap@ in @vector@.++buildRns+  :: Exp+--  -> [Name]+  -> [ArgTy Pat]+  -> ExpQ+buildRns f' ps = do+  -- get all synvars, shallow or deep and create a new name to bind+  -- individual parts to.+  sy :: M.Map Pat Name <- M.fromList <$> (mapM (\s -> newName "y" >>= \y -> return (s,y)) $ concatMap flattenSynVars ps)+  -- bind them for the right part of the list expression (even though they+  -- are left in @CompE@. We don't use @sy@ directly to keep the order in+  -- which the comprehensions run.+  let rs = map (\k@(TupP [_,VarP v]) -> BindS (VarP $ sy M.! k) (VarE v)) $ concatMap flattenSynVars ps+  let go :: ExpQ -> ArgTy Pat -> ExpQ+      go f (SynVar      k       ) = appE f (varE $ sy M.! k) -- needed like this, because we need the @y@ in @y <- ys@+      go f (Term        (VarP v)) = appE f (varE v)+      go f (StackedVars vs      ) = appE f (foldl build [|Z|] vs)+      build :: ExpQ -> ArgTy Pat -> ExpQ+      build s (SynVar k       ) = [| $(s) :. $(varE $ sy M.! k) |]+      build s (Term   (VarP v)) = [| $(s) :. $(varE v)          |]+  funApp <- foldl go (return f') ps+  return . CompE $ rs ++ [NoBindS funApp]+++-- | Type for backtracking functions.+--+-- Not too interesting, mostly to keep track of @choice@.++type Choice = Name -> Name -> Q Exp++-- | Build up the backtracking choice function. This choice function will+-- backtrack based on the first result, then return only the second.+--+-- TODO it should be (only?) this function we will need to modify to build+-- all algebra products.+--+-- @ysM@ can't be unboxed, as @snd@ of each element is a list, lazily+-- consumed. We build up @ysM@ as this makes fusion happen. Of course, this+-- is a boxed vector and not as efficient, but we gain the ability to have+-- lazily created backtracking from this!+--+-- This means strict optimization AND lazy backtracking+--+-- TODO in principle, we do more work than necessary. The line+-- @hFres <- ...@ evaluates the optimal choice from the @fst@ elements+-- again. As long as the cost is small compared to the evaluation of @snd@+-- (or the list-comprehension based creation of all parses), this won't+-- matter much.++buildBacktrackingChoice :: Choice+buildBacktrackingChoice hL' hR' =+  [| \xs -> do+      -- turn the stream into a list+      ysM <- SM.toList xs+      -- based only on the @fst@ elements, select optimal value+      hFres <- $(varE hL') $ SM.map fst $ SM.fromList ysM+      -- filter accordingly+      $(varE hR') $ SM.fromList $ concatMap snd $ filter ((hFres==) . fst) $ ysM+  |]++-- | We assume parses of type @(x,y)@ in a vector @<(x,y)>@. the function+-- acting on @x@ will produce a subset @<x>@ (in vector form). the function+-- acting on @y@ produces scalars @y@. We have @actFst :: <x> -> <x>@ and+-- @actSnd :: <y> -> y@. This in total should yield @<(x,y)> -> <(x,y)>@.+--+-- TODO This should create @generic@ vectors, that are specialized by the+-- table they are stored into.++buildCombiningChoice :: Choice+buildCombiningChoice hL' hR' =+  [| \xs -> do+      -- -- lets begin with the list of parses+      -- ys <- SM.toList xs+      -- -- but now, we actually get a list of co-optimals to keep. Yes,+      -- -- a @[fst]@ list.+      -- cooptFsts <- S.fromList <$> ( ( $(varE hL') $ SM.map fst $ SM.fromList ys ) >>= SM.toList )+      -- -- now we create a map with all the coopts, where we collect in the+      -- -- value parts the list of parses for each co-optimal @snd@ for+      -- -- a @fst@.+      -- let cooptMap = M.fromListWith (++) [ y | y <- ys, y `S.member` cooptFsts ]+      -- -- We now need to map @actSnd@ over the resulting intermediates+      -- actSnd <- mapM (\y -> $(varE hR') (SM.fromList y)) cooptMap+      -- -- a vector with co-optimals, each one associated with its optimal+      -- -- @snd@.+      -- return . VG.fromList . M.toList $ actSnd+      return undefined+  |]++-- | Turn a stream into a vector.+--+-- TODO need to be improved in terms of performance.++streamToVectorM :: (Monad m, VG.Vector v a) => SM.Stream m a -> m (v a)+streamToVectorM s = SM.toList s >>= return . VG.fromList+{-# Inline streamToVectorM #-}++-- | Gets the names used in the evaluation function. This returns one+-- 'Name' for each variable.+--+-- In case of @TupleT 0@ the type is @()@ and there isn't a name to go with+-- it. We just @mkName "()"@ a name, but this might be slightly dangerous?+-- (Not really sure if it indeed is)+--+-- With @AppT _ _@ we have a multidim terminal and produce another hackish+-- name to be consumed above.+--+-- @+-- AppT (AppT ArrowT (AppT (AppT (ConT Data.Array.Repa.Index.:.) (AppT (AppT (ConT Data.Array.Repa.Index.:.) (ConT Data.Array.Repa.Index.Z)) (VarT c_1627675270))) (VarT c_1627675270))) (VarT x_1627675265)+-- @++getRuleSynVarNames :: [Name]-> Type -> [ArgTy Name] -- [Name]+getRuleSynVarNames nts t' = go t' where+  go t+    | VarT x <- t                          = [Result x]+    | AppT (AppT ArrowT (VarT x)  ) y <- t = (if x `elem` nts then SynVar x else Term x) : go y+    | AppT (AppT ArrowT (TupleT 0)) y <- t = NilVar : go y+    | AppT (AppT ArrowT s         ) y <- t = stacked s : go y+    | otherwise                            = error $ "getRuleSynVarNames error: " ++ show t ++ "    in:    " ++ show t'+  stacked s = if null [ () | SynVar _ <- xs ] then StackedTerms xs else StackedVars xs+    where xs = reverse $ stckd s+          stckd (ConT z) | z == ''Z = []+          stckd (AppT a (TupleT 0)) = NilVar : stckd a+          stckd (AppT a (VarT x)  ) = (if x `elem` nts then SynVar x else Term x) : stckd a+          stckd (AppT (ConT c) a  ) | c == ''(:.) = stckd a+          stckd err = error $ "stckd" ++ show err++{-+(AppT (AppT (ConT Data.PrimitiveArray.Index.Class.:.)+            (AppT (AppT (ConT Data.PrimitiveArray.Index.Class.:.)+                        (ConT Data.PrimitiveArray.Index.Class.Z)+                  )+                  (VarT x_1627774371)+            )+      )+      (TupleT 0)+)+-}+++data ArgTy x+  -- | This @SynVar@ spans the full column of tapes; i.e. it is a normal+  -- syntactic variable.+  = SynVar { synVarName :: x }+  -- | We have just a single-tape grammar and as such just+  -- a single-dimensional terminal. We call this term, because+  -- @StackedTerms@ will be rewritten to just @Term@!+  | Term { termName :: x }+  -- | We have a multi-tape grammar with a stack of just terminals. We+  -- normally can ignore the contents in the functions above, but keep them+  -- anyway.+  | StackedTerms { stackedTerms :: [ArgTy x] }+  -- | We have a multi-tape grammar, but the stack contains a mixture of+  -- @ArgTy@s.+  | StackedVars { stackedVars :: [ArgTy x] }+  -- | A single-dim @()@ case+  | NilVar+  -- | The result type name+  | Result { result :: x }+  deriving (Show,Eq)++unpackArgTy :: Show x => ArgTy x -> x+unpackArgTy = go+  where go (SynVar x) = x+        go (Term   x) = x+        go (Result x) = x+        go err        = error $ "unpackArgTy " ++ show err++-- | Get all synvars, even if deep in a stack++flattenSynVars :: ArgTy x -> [x]+flattenSynVars (SynVar x)       = [x]+flattenSynVars (StackedVars xs) = concatMap flattenSynVars xs+flattenSynVars _                = []+
+ ADP/Fusion/Core/TH/Common.hs view
@@ -0,0 +1,19 @@++module ADP.Fusion.Core.TH.Common where++import           Data.Tuple.Select+import           Language.Haskell.TH+import           Language.Haskell.TH.Syntax++++-- | The last @Name@ of a rule is the name of the syntactic type of the+-- result.++getRuleResultType :: VarStrictType -> Name+getRuleResultType vst = go $ sel3 vst where+  go t+    | AppT _ (VarT x) <- t = x+    | AppT _ x        <- t = go x+    | otherwise            = error $ "undetermined error:" ++ show vst+
+ ADP/Fusion/Core/Term/Chr.hs view
@@ -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+
+ ADP/Fusion/Core/Term/Deletion.hs view
@@ -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 = ()+
+ ADP/Fusion/Core/Term/Edge.hs view
@@ -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 #-}+
+ ADP/Fusion/Core/Term/Epsilon.hs view
@@ -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) = ()+
+ ADP/Fusion/Core/Term/MultiChr.hs view
@@ -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+
+ ADP/Fusion/Core/Term/PeekIndex.hs view
@@ -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+
+ ADP/Fusion/Core/Term/Str.hs view
@@ -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+
+ ADP/Fusion/Core/Term/Switch.hs view
@@ -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 = ()+
+ ADP/Fusion/Core/Term/Test.hs view
@@ -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+
+ ADP/Fusion/Core/TyLvlIx.hs view
@@ -0,0 +1,112 @@++-- | Type-level indexing functionality++module ADP.Fusion.Core.TyLvlIx+  ( module ADP.Fusion.Core.TyLvlIx+  , module GHC.TypeLits+  ) where++import Data.Proxy+import GHC.TypeLits++import Data.PrimitiveArray.Index.Class hiding (map)++import ADP.Fusion.Core.Classes (RunningIndex (..))++++-- | Given some complete index list @ixTy@ and some lower-dimensional+-- version @myTy@, walk down along @ixTy@ until we have @is:.i ~ ms:.m@ and+-- return @m@.++class GetIndexGo ixTy myTy (cmp :: Ordering) where+  type ResolvedIx ixTy myTy cmp :: *+  getIndexGo :: ixTy -> (Proxy myTy) -> (Proxy cmp) -> ResolvedIx ixTy myTy cmp++instance GetIndexGo (ix:.i) (my:.m) EQ where+  type ResolvedIx (ix:.i) (my:.m) EQ = i+  getIndexGo (ix:.i) _ _ = seq ix $ i+  {-# Inline [0] getIndexGo #-}++instance (GetIndexGo ix (my:.m) (CmpNat (ToNat ix) (ToNat (my:.m)))) => GetIndexGo (ix:.i) (my:.m) GT where+  type ResolvedIx (ix:.i) (my:.m) GT = ResolvedIx ix (my:.m) (CmpNat (ToNat ix) (ToNat (my:.m)))+  getIndexGo (ix:._) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat ix) (ToNat (my:.m))))+  {-# Inline [0] getIndexGo #-}++instance (GetIndexGo ix Z (CmpNat (ToNat ix) (ToNat Z))) => GetIndexGo (ix:.i) Z GT where+  type ResolvedIx (ix:.i) Z GT = ResolvedIx ix Z (CmpNat (ToNat ix) (ToNat Z))+  getIndexGo (ix:._) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat ix) (ToNat Z)))+  {-# Inline [0] getIndexGo #-}++instance GetIndexGo Z Z EQ where+  type ResolvedIx Z Z EQ = Z+  getIndexGo _ _ _ = Z+  {-# Inline [0] getIndexGo #-}++++instance GetIndexGo (RunningIndex (ix:.i)) (RunningIndex (my:.m)) EQ where+  type ResolvedIx (RunningIndex (ix:.i)) (RunningIndex (my:.m)) EQ = RunningIndex i+  getIndexGo (ix:.:i) _ _ = seq ix i+  {-# Inline [0] getIndexGo #-}++instance+  ( GetIndexGo (RunningIndex ix) (RunningIndex (my:.m)) (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex (my:.m))))+  ) => GetIndexGo (RunningIndex (ix:.i)) (RunningIndex (my:.m)) GT where+  type ResolvedIx (RunningIndex (ix:.i)) (RunningIndex (my:.m)) GT = ResolvedIx (RunningIndex ix) (RunningIndex (my:.m)) (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex (my:.m))))+  getIndexGo (ix:.:_) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex (my:.m)))))+  {-# Inline [0] getIndexGo #-}++instance+  ( GetIndexGo (RunningIndex ix) (RunningIndex Z) (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex Z)))+  ) => GetIndexGo (RunningIndex (ix:.i)) (RunningIndex Z) GT where+  type ResolvedIx (RunningIndex (ix:.i)) (RunningIndex Z) GT = ResolvedIx (RunningIndex ix) (RunningIndex Z) (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex Z)))+  getIndexGo (ix:.:_) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex Z))))+  {-# Inline [0] getIndexGo #-}++instance GetIndexGo (RunningIndex Z) (RunningIndex Z) EQ where+  type ResolvedIx (RunningIndex Z) (RunningIndex Z) EQ = RunningIndex Z+  getIndexGo riz _ _ = riz+  {-# Inline [0] getIndexGo #-}++++-- | Wrap @GetIndexGo@ and the type-level shenanigans.++type GetIndex l r = GetIndexGo l r (CmpNat (ToNat l) (ToNat r))++type GetIx l r = ResolvedIx l r (CmpNat (ToNat l) (ToNat r))++-- | Simplifying wrapper around @getIndexGo@.++getIndex+  :: forall ixTy myTy+  .  GetIndex ixTy myTy+  => ixTy+  -> Proxy myTy+  -> GetIx ixTy myTy+getIndex ixTy myTy = getIndexGo ixTy (Proxy :: Proxy myTy) (Proxy :: Proxy (CmpNat (ToNat ixTy) (ToNat myTy)))+{-# Inline [0] getIndex #-}++++-- | Given some index structure @x@, return the dimensional number in+-- @Nat@s.++type family ToNat x :: Nat++type instance ToNat Z       = 0+type instance ToNat (is:.i) = ToNat is + 1+type instance ToNat (RunningIndex Z) = 0+type instance ToNat (RunningIndex (is:.i)) = ToNat (RunningIndex is) + 1++++{-++testggg :: (Z:.Int:.Char) -> Int+testggg ab = getIndex ab (Proxy :: Proxy (Z:.Int)) --  (Z:.(3::Int))+{-# NoInline testggg #-}++-}+
+ ADP/Fusion/PointL.hs view
@@ -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+
+ ADP/Fusion/PointL/Core.hs view
@@ -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 #-}+
+ ADP/Fusion/PointL/SynVar/Indices.hs view
@@ -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 #-}+
+ ADP/Fusion/PointL/Term/Chr.hs view
@@ -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 #-}+
+ ADP/Fusion/PointL/Term/Deletion.hs view
@@ -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 #-}+
+ ADP/Fusion/PointL/Term/Epsilon.hs view
@@ -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 #-}+
+ ADP/Fusion/PointL/Term/MultiChr.hs view
@@ -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 #-}+
+ ADP/Fusion/PointL/Term/Str.hs view
@@ -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 #-}+-}+
+ ADP/Fusion/PointL/Term/Switch.hs view
@@ -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 #-}+
+ ADP/Fusion/PointR.hs view
@@ -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+
+ ADP/Fusion/PointR/Core.hs view
@@ -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 #-}+
+ ADP/Fusion/PointR/SynVar/Indices.hs view
@@ -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 #-}+
+ ADP/Fusion/PointR/Term/Chr.hs view
@@ -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 #-}+
+ ADP/Fusion/PointR/Term/Deletion.hs view
@@ -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 #-}+
+ ADP/Fusion/PointR/Term/Epsilon.hs view
@@ -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 #-}+
+ ADP/Fusion/PointR/Term/MultiChr.hs view
@@ -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 #-}+
− ADP/Fusion/QuickCheck/Common.hs 
@@ -1,10 +0,0 @@--{-# Options_GHC -O0 #-}--module ADP.Fusion.QuickCheck.Common where--import Debug.Trace----tr zs ls b = traceShow (zs," ",ls,length zs,length ls) b
− ADP/Fusion/QuickCheck/Point.hs 
@@ -1,294 +0,0 @@--{-# Options_GHC -O0 #-}--module ADP.Fusion.QuickCheck.Point where--import           Control.Applicative-import           Control.Monad-import           Data.Strict.Tuple-import           Data.Vector.Fusion.Util-import           Debug.Trace-import qualified Data.Vector.Fusion.Stream as S-import qualified Data.Vector.Fusion.Stream.Monadic as SM-import qualified Data.Vector.Unboxed as VU-import           System.IO.Unsafe-import           Test.QuickCheck-import           Test.QuickCheck.All-import           Test.QuickCheck.Monadic--import           Data.PrimitiveArray--import ADP.Fusion------ * Epsilon cases--prop_Epsilon ix@(PointL j) = zs == ls where-  zs = (id <<< Epsilon ... S.toList) maxPL ix-  ls = [ () | j == 0 ]--prop_O_Epsilon ix@(O (PointL j)) = zs == ls where-  zs = (id <<< Epsilon ... S.toList) (O maxPL) ix-  ls = [ () | j == 100 ]--prop_ZEpsilon ix@(Z:.PointL j) = zs == ls where-  zs = (id <<< (M:|Epsilon) ... S.toList) (Z:.maxPL) ix-  ls = [ Z:.() | j == 0 ]--prop_O_ZEpsilon ix@(O (Z:.PointL j)) = zs == ls where-  zs = (id <<< (M:|Epsilon) ... S.toList) (O (Z:.maxPL)) ix-  ls = [ Z:.() | j == 100 ]--prop_O_ZEpsilonEpsilon ix@(O (Z:.PointL j:.PointL l)) = zs == ls where-  zs = (id <<< (M:|Epsilon:|Epsilon) ... S.toList) (O (Z:.maxPL:.maxPL)) ix-  ls = [ Z:.():.() | j == 100, l == 100 ]------ * Deletion cases--prop_O_ItNC ix@(O (PointL j)) = zs == ls where-  t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)-  zs = ((,,) <<< t % Deletion % chr xs ... S.toList) (O $ maxPL) ix-  ls = [ ( unsafeIndex xsPo (O $ PointL $ j+1)-         , ()-         , xs VU.! (j+0)-         ) | j >= 0, j <= 99 ]-{-# Noinline prop_O_ItNC #-}--prop_O_ZItNC ix@(O (Z:.PointL j)) = zs == ls where-  t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1)-  zs = ((,,) <<< t % (M:|Deletion) % (M:|chr xs) ... S.toList) (O (Z:.maxPL)) ix-  ls = [ ( unsafeIndex xsZPo (O (Z:.PointL (j+1)))-         , Z:.()-         , Z:.xs VU.! (j+0)-         ) | j >= 0, j <= 99 ]--prop_O_2dimIt_NC_CN ix@(O (Z:.PointL j:.PointL l)) = zs == ls where-  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPPo (\ _ _ -> Id 1)-  zs = ((,,) <<< t % (M:|Deletion:|chr xs) % (M:|chr xs:|Deletion) ... S.toList) (O (Z:.maxPL:.maxPL)) ix-  ls = [ ( unsafeIndex xsPPo (O (Z:.PointL (j+1):.PointL (l+1)))-         , Z:.()           :.xs VU.! (l+0)-         , Z:.xs VU.! (j+0):.()-         ) | j>=0, l>=0, j<=99, l<=99 ]--prop_2dimIt_NC_CN ix@(Z:.PointL j:.PointL l) = zs == ls where-  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPP (\ _ _ -> Id 1)-  zs = ((,,) <<< t % (M:|Deletion:|chr xs) % (M:|chr xs:|Deletion) ... S.toList) (Z:.maxPL:.maxPL) ix-  ls = [ ( unsafeIndex xsPP (Z:.PointL (j-1):.PointL (l-1))-         , Z:.()           :.xs VU.! (l-1)-         , Z:.xs VU.! (j-1):.()-         ) | j>=1, l>=1, j<=100, l<=100 ]------ * terminal cases---- | A single character terminal--prop_Tt ix@(Z:.PointL j) = zs == ls where-  zs = (id <<< (M:|chr xs) ... S.toList) (Z:.maxPL) ix-  ls = [ (Z:.xs VU.! (j-1)) | 1==j ]----prop_O_Tt ix@(Z:.O (PointL j)) = traceShow (j,zs,ls) $ zs == ls where---  zs = (id <<< (M:|chr xs) ... S.toList) (Z:.O maxPL) ix---  ls = [ (Z:.xs VU.! (j-1)) | 1==j ]---- | Two single-character terminals--prop_CC ix@(Z:.PointL i) = zs == ls where-  zs = ((,) <<< (M:|chr xs) % (M:|chr xs) ... S.toList) (Z:.maxPL) ix-  ls = [ (Z:.xs VU.! (i-2), Z:.xs VU.! (i-1)) | 2==i ]---- | Just a table--prop_It ix@(PointL j) = zs == ls where-  t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1)-  zs = (id <<< t ... S.toList) maxPL ix-  ls = [ unsafeIndex xsP ix | j>=0, j<=100 ]--prop_O_It ix@(O (PointL j)) = zs == ls where-  t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)-  zs = (id <<< t ... S.toList) (O maxPL) ix-  ls = [ unsafeIndex xsPo ix | j>=0, j<=100 ]--prop_ZIt ix@(Z:.PointL j) = zs == ls where-  t = ITbl 0 0 (Z:.EmptyOk) xsZP (\ _ _ -> Id 1)-  zs = (id <<< t ... S.toList) (Z:.maxPL) ix-  ls = [ unsafeIndex xsZP ix | j>=0, j<=100 ]--prop_O_ZIt ix@(O (Z:.PointL j)) = zs == ls where-  t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1)-  zs = (id <<< t ... S.toList) (O (Z:.maxPL)) ix-  ls = [ unsafeIndex xsZPo ix | j>=0, j<=100 ]---- | Table, then single terminal--prop_ItC ix@(PointL j) = zs == ls where-  t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1)-  zs = ((,) <<< t % chr xs ... S.toList) maxPL ix-  ls = [ ( unsafeIndex xsP (PointL $ j-1)-         , xs VU.! (j-1)-         ) | j>=1, j<=100 ]---- | @A^*_j -> A^*_{j+1} c_{j+1)@ !--prop_O_ItC ix@(O (PointL j)) = zs == ls where-  t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)-  zs = ((,) <<< t % chr xs ... S.toList) (O $ maxPL) ix-  ls = [ ( unsafeIndex xsPo (O $ PointL $ j+1)-         , xs VU.! (j+0)-         ) | j >= 0, j < 100 ]--prop_O_ItCC ix@(O (PointL j)) = zs == ls where-  t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)-  zs = ((,,) <<< t % chr xs % chr xs ... S.toList) (O $ maxPL) ix-  ls = [ ( unsafeIndex xsPo (O $ PointL $ j+2)-         , xs VU.! (j+0)-         , xs VU.! (j+1)-         ) | j >= 0, j <= 98 ]-{-# Noinline prop_O_ItCC #-}--prop_O_ZItCC ix@(O (Z:.PointL j)) = zs == ls where-  t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1)-  zs = ((,,) <<< t % (M:|chr xs) % (M:|chr xs) ... S.toList) (O (Z:.maxPL)) ix-  ls = [ ( unsafeIndex xsZPo (O (Z:.PointL (j+2)))-         , Z:.xs VU.! (j+0)-         , Z:.xs VU.! (j+1)-         ) | j >= 0, j <= 98 ]---- | synvar followed by a 2-tape character terminal--prop_2dimItCC ix@(Z:.PointL j:.PointL l) = zs == ls where-  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPP (\ _ _ -> Id 1)-  zs = ((,,) <<< t % (M:|chr xs:|chr xs) % (M:|chr xs:|chr xs) ... S.toList) (Z:.maxPL:.maxPL) ix-  ls = [ ( unsafeIndex xsPP (Z:.PointL (j-2):.PointL (l-2))-         , Z:.xs VU.! (j-2):.xs VU.! (l-2)-         , Z:.xs VU.! (j-1):.xs VU.! (l-1)-         ) | j>=2, l>=2, j<=100, l<=100 ]--prop_O_2dimItCC ix@(O (Z:.PointL j:.PointL l)) = zs == ls where-  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPPo (\ _ _ -> Id 1)-  zs = ((,,) <<< t % (M:|chr xs:|chr xs) % (M:|chr xs:|chr xs) ... S.toList) (O (Z:.maxPL:.maxPL)) ix-  ls = [ ( unsafeIndex xsPPo (O (Z:.PointL (j+2):.PointL (l+2)))-         , Z:.xs VU.! (j+0):.xs VU.! (l+0)-         , Z:.xs VU.! (j+1):.xs VU.! (l+1)-         ) | j>=0, l>=0, j<=98, l<=98 ]---- * direct index tests--xprop_O_ixZItCC ix@(O (Z:.PointL j)) = zs where-  t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1)-  zs = (id >>> t % (M:|chr xs) % (M:|chr xs) ... S.toList) (O (Z:.maxPL)) ix---- * 'Strng' tests---- ** Just the 'Strng' terminal--prop_ManyS ix@(PointL j) = zs == ls where-  zs = (id <<< manyS xs ... S.toList) maxPL ix-  ls = [ (VU.slice 0 j xs) ]--prop_SomeS ix@(PointL j) = zs == ls where-  zs = (id <<< someS xs ... S.toList) maxPL ix-  ls = [ (VU.slice 0 j xs) | j>0 ]--prop_2dim_ManyS_ManyS ix@(Z:.PointL i:.PointL j) = zs == ls where-  zs = (id <<< (M:|manyS xs:|manyS xs) ... S.toList) (Z:.maxPL:.maxPL) ix-  ls = [ (Z:.VU.slice 0 i xs:.VU.slice 0 j xs) ]--prop_2dim_SomeS_SomeS ix@(Z:.PointL i:.PointL j) = zs == ls where-  zs = (id <<< (M:|someS xs:|someS xs) ... S.toList) (Z:.maxPL:.maxPL) ix-  ls = [ (Z:.VU.slice 0 i xs:.VU.slice 0 j xs) | i > 0 && j > 0 ]---- ** Together with a syntactic variable.--prop_Itbl_ManyS ix@(PointL i) = zs == ls where-  t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1)-  zs = ((,) <<< t % manyS xs ... S.toList) maxPL ix-  ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i] ]--prop_Itbl_SomeS ix@(PointL i) = zs == ls where-  t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1)-  zs = ((,) <<< t % someS xs ... S.toList) maxPL ix-  ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i-1] ]--prop_1dim_Itbl_ManyS ix@(Z:.PointL i) = zs == ls where-  t = ITbl 0 0 (Z:.EmptyOk) xsZP (\ _ _ -> Id 1)-  zs = ((,) <<< t % (M:|manyS xs) ... S.toList) (Z:.maxPL) ix-  ls = [ (unsafeIndex xsZP (Z:.PointL k), Z:. VU.slice k (i-k) xs) | k <- [0..i] ]--prop_1dim_Itbl_SomeS ix@(Z:.PointL i) = zs == ls where-  t = ITbl 0 0 (Z:.EmptyOk) xsZP (\ _ _ -> Id 1)-  zs = ((,) <<< t % (M:|someS xs) ... S.toList) (Z:.maxPL) ix-  ls = [ (unsafeIndex xsZP (Z:.PointL k), Z:. VU.slice k (i-k) xs) | k <- [0..i-1] ]--prop_2dim_Itbl_ManyS_ManyS ix@(Z:.PointL i:.PointL j) = zs == ls where-  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPP (\ _ _ -> Id 1)-  zs = ((,) <<< t % (M:|manyS xs:|manyS xs) ... S.toList) (Z:.maxPL:.maxPL) ix-  ls = [ (unsafeIndex xsPP (Z:.PointL k:.PointL l), Z:. VU.slice k (i-k) xs :. VU.slice l (j-l) xs) | k <- [0..i], l <- [0..j] ]--prop_2dim_Itbl_SomeS_SomeS ix@(Z:.PointL i:.PointL j) = zs == ls where-  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPP (\ _ _ -> Id 1)-  zs = ((,) <<< t % (M:|someS xs:|someS xs) ... S.toList) (Z:.maxPL:.maxPL) ix-  ls = [ (unsafeIndex xsPP (Z:.PointL k:.PointL l), Z:. VU.slice k (i-k) xs :. VU.slice l (j-l) xs) | k <- [0..i-1], l <- [0..j-1] ]-----infixl 8 >>>-(>>>) f xs = \lu ij -> S.map f . mkStream (build xs) (initialContext ij) lu $ ij--class GetIxs x i where-  type R x i :: *-  getIxs :: Elm x i -> R x i--instance GetIxs S i where-  type R S i = Z:.(i,i)-  getIxs e = Z:.(getIdx e, getOmx e)--instance GetIxs ls i => GetIxs (ls :!: Chr a b) i where-  type R (ls :!: Chr a b) i = R ls i :. (i,i)-  getIxs (ElmChr _ i o s) = getIxs s :. (i,o)--instance GetIxs ls i => GetIxs (ls :!: ITbl m a i x) i where-  type R (ls :!: ITbl m a i x) i = R ls i :. (i,i)-  getIxs (ElmITbl _ i o s) = getIxs s :. (i,o)--xsP :: Unboxed (PointL) Int-xsP = fromList (PointL 0) maxPL [0 ..]--xsZP :: Unboxed (Z:.PointL) Int-xsZP = fromList (Z:.PointL 0) (Z:.maxPL) [0 ..]--xsPo :: Unboxed (Outside (PointL)) Int-xsPo = fromList (O $ PointL 0) (O $ maxPL) [0 ..]--xsZPo :: Unboxed (Outside (Z:.PointL)) Int-xsZPo = fromList (O (Z:.PointL 0)) (O (Z:.maxPL)) [0 ..]--xsPP :: Unboxed (Z:.PointL:.PointL) Int-xsPP = fromList (Z:.PointL 0:.PointL 0) (Z:.maxPL:.maxPL) [0 ..]--xsPPo :: Unboxed (Outside (Z:.PointL:.PointL)) Int-xsPPo = fromList (O (Z:.PointL 0:.PointL 0)) (O (Z:.maxPL:.maxPL)) [0 ..]--mxsPP = unsafePerformIO $ zzz where-  zzz :: IO (MutArr IO (Unboxed (Z:.PointL:.PointL) Int))-  zzz = fromListM (Z:.PointL 0:.PointL 0) (Z:.maxPL:.maxPL) [0 ..]--maxI = 100-maxPL = PointL maxI--xs = VU.fromList [0 .. maxI - 1 :: Int]---- * general quickcheck stuff--options = stdArgs {maxSuccess = 1000}--customCheck = quickCheckWithResult options--return []-allProps = $forAllProperties customCheck-
− ADP/Fusion/QuickCheck/Set.hs 
@@ -1,248 +0,0 @@--{-# Options_GHC -O0 #-}--module ADP.Fusion.QuickCheck.Set where--import           Data.Bits-import           Data.Vector.Fusion.Util-import           Debug.Trace-import qualified Data.List as L-import qualified Data.Vector.Fusion.Stream as S-import qualified Data.Vector.Unboxed as VU-import           Test.QuickCheck hiding (NonEmpty)-import           Test.QuickCheck.All-import           Test.QuickCheck.Monadic--import           Data.Bits.Ordered-import           Data.PrimitiveArray--import           ADP.Fusion-import           ADP.Fusion.QuickCheck.Common------ * BitSets without interfaces---- ** Inside checks--prop_b_ii ix@(BitSet _) = zs == ls where-  tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)-  tib = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)-  zs = ((,) <<< tia % tib ... S.toList) highestB ix-  ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) )-       | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ]-       , let kk = popShiftL ix (BitSet k)-       ]--prop_b_ii_nn ix@(BitSet _) = zs == ls where-  tia = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)-  tib = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)-  zs = ((,) <<< tia % tib ... S.toList) highestB ix-  ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) )-       | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ]-       , let kk = popShiftL ix (BitSet k)-       , popCount kk > 0-       , popCount (ix `xor` kk) > 0-       ]--prop_b_iii ix@(BitSet _) = zs == ls where-  tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)-  tib = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)-  tic = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)-  zs = ((,,) <<< tia % tib % tic ... S.toList) highestB ix-  ls = [ ( xsB ! kk , xsB ! ll , xsB ! mm )-       | k <- VU.toList . popCntSorted $ popCount ix-       , l <- VU.toList . popCntSorted $ popCount ix - popCount k-       , let kk = popShiftL ix          (BitSet k)-       , let ll = popShiftL (ix `xor` kk) (BitSet l)-       , let mm = (ix `xor` (kk .|. ll))-       ]--prop_b_iii_nnn ix@(BitSet _) = zs == ls where-  tia = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)-  tib = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)-  tic = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)-  zs = ((,,) <<< tia % tib % tic ... S.toList) highestB ix-  ls = [ ( xsB ! kk , xsB ! ll , xsB ! mm )-       | k <- VU.toList . popCntSorted $ popCount ix-       , l <- VU.toList . popCntSorted $ popCount ix - popCount k-       , let kk = popShiftL ix          (BitSet k)-       , let ll = popShiftL (ix `xor` kk) (BitSet l)-       , let mm = (ix `xor` (kk .|. ll))-       , popCount kk > 0, popCount ll > 0, popCount mm > 0-       ]----- * Outside checks--- These checks are very similar to those in the @Subword@ module. We just--- need to be a bit more careful, as indexed sets have overlap.---- ** Two non-terminals.------ @A_s -> B_(s\t) C_t    (s\t) ++ t == s@--- @s = 111 , s\t = 101, t = 010@------ with @Z@ the full set.--- @Z = 1111@---- @B*_Z\(s\t) -> A*_Z\s C_t@--- @Z\(s\t) = 1010, Z\s = 1000, t = 010@------- * BitSets with two interfaces---- ** Inside checks--prop_bii_i :: BS2I First Last -> Bool-prop_bii_i ix@(s:>i:>j) = zs == ls where-  tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)-  zs = (id <<< tia ... S.toList) highestBII ix-  ls = [ xsBII ! ix ]--prop_bii_i_n :: BS2I First Last -> Bool-prop_bii_i_n ix@(s:>i:>j) = zs == ls where-  tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)-  zs = (id <<< tia ... S.toList) highestBII ix-  ls = [ xsBII ! ix | popCount s > 0 ]---- | Edges should never work as a single terminal element.--prop_bii_e :: BS2I First Last -> Bool-prop_bii_e ix@(s:>Iter i:>Iter j) = zs == ls where-  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)-  zs = (id <<< e ... S.toList) highestBII ix-  ls = [] :: [ (Int,Int) ]---- | Edges extend only in cases where in @i -> j@, @i@ actually happens to--- be a true interface.--prop_bii_ie :: BS2I First Last -> Bool-prop_bii_ie ix@(s:>i:>Iter j) = zs == ls where-  tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)-  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)-  zs = ((,) <<< tia % e ... S.toList) highestBII ix-  ls = [ ( xsBII ! (t:>i:>(Iter k :: Interface Last)) , (k,j) )-       | let t = s `clearBit` j-       , k <- activeBitsL t ]--prop_bii_ie_n :: BS2I First Last -> Bool-prop_bii_ie_n ix@(s:>i:>Iter j) = zs == ls where-  tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)-  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)-  zs = ((,) <<< tia % e ... S.toList) highestBII ix-  ls = [ ( xsBII ! (t:>i:>(Iter k :: Interface Last)) , (k,j) )-       | let t = s `clearBit` j-       , popCount t >= 2-       , k <- activeBitsL t-       , k /= getIter i-       ]--prop_bii_iee :: BS2I First Last -> Bool-prop_bii_iee ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where-  tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)-  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)-  zs = ((,,) <<< tia % e % e ... S.toList) highestBII ix-  ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,j) )-       | let tmp = (s `clearBit` j)-       , l <- activeBitsL tmp-       , l /= getIter i-       , let t = tmp `clearBit` l-       , k <- activeBitsL t-       , let kk = Iter k-       ]--prop_bii_ieee :: BS2I First Last -> Bool-prop_bii_ieee ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where-  tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)-  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)-  zs = ((,,,) <<< tia % e % e % e ... S.toList) highestBII ix-  ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,m) , (m,j) )-       | let tmpM = (s `clearBit` j)-       , m <- activeBitsL tmpM-       , m /= getIter i-       , let tmpL = (tmpM `clearBit` m)-       , l <- activeBitsL tmpL-       , l /= getIter i-       , let t = tmpL `clearBit` l-       , k <- activeBitsL t-       , let kk = Iter k-       ]--prop_bii_iee_n :: BS2I First Last -> Bool-prop_bii_iee_n ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where-  tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)-  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)-  zs = ((,,) <<< tia % e % e ... S.toList) highestBII ix-  ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,j) )-       | let tmp = (s `clearBit` j)-       , l <- activeBitsL tmp-       , l /= getIter i-       , let t = tmp `clearBit` l-       , popCount t >= 2-       , k <- activeBitsL t-       , k /= getIter i-       , let kk = Iter k-       ]--prop_bii_ieee_n :: BS2I First Last -> Bool-prop_bii_ieee_n ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where-  tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)-  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)-  zs = ((,,,) <<< tia % e % e % e ... S.toList) highestBII ix-  ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,m) , (m,j) )-       | let tmpM = (s `clearBit` j)-       , m <- activeBitsL tmpM-       , m /= getIter i-       , let tmpL = (tmpM `clearBit` m)-       , l <- activeBitsL tmpL-       , l /= getIter i-       , let t = tmpL `clearBit` l-       , popCount t >= 2-       , k <- activeBitsL t-       , k /= getIter i-       , let kk = Iter k-       ]---- prop_bii_ii (ix@(s:>i:>j) :: (BitSet:>Interface First:>Interface Last)) = tr zs ls $ zs == ls where---   tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)---   tib = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)---   zs = ((,) <<< tia % tib ... S.toList) highestBII ix---   ls = [ ( xsBII ! kk , xsBII ! ll )---        | k  <- VU.toList . popCntSorted $ popCount s---        , ki <- if k==0 then [0] else activeBitsL k---        , kj <- if | k==0 -> [0] | popCount k==1 -> [ki] | otherwise -> activeBitsL (k `clearBit` ki)---        , let kk = (BitSet k:>Iter ki:>Iter kj)---        , let l  = s `xor` BitSet k---        , li <- if l==0 then [0] else activeBitsL l---        , lj <- if | l==0 -> [0] | popCount l==1 -> [li] | otherwise -> activeBitsL (l `clearBit` li)---        , let ll = (l:>Iter li:>Iter lj)---        ]------ * Helper functions--highBit = fromIntegral arbitraryBitSetMax -- should be the same as the highest bit in Index.Set.arbitrary-highestB = BitSet $ 2^(highBit+1) -1-highestBII = highestB :> Iter (highBit-1) :> Iter (highBit-1) -- assuming @highBit >= 1@--xsB :: Unboxed BitSet Int-xsB = fromList (BitSet 0) highestB [ 0 .. ]--xoB :: Unboxed (Outside BitSet) Int-xoB = fromList (O (BitSet 0)) (O highestB) [ 0 .. ]--xsBII :: Unboxed (BitSet:>Interface First:>Interface Last) Int-xsBII = fromList (BitSet 0:>Iter 0:>Iter 0) highestBII [ 0 .. ]---- * general quickcheck stuff--options = stdArgs {maxSuccess = 1000}--customCheck = quickCheckWithResult options--return []-allProps = $forAllProperties customCheck-
− ADP/Fusion/QuickCheck/Subword.hs 
@@ -1,225 +0,0 @@--{-# Options_GHC -O0 #-}---- |------ TODO need to carefully check all props against boundary errors!--- Especially the 2-dim cases!--module ADP.Fusion.QuickCheck.Subword where--import           Test.QuickCheck-import           Test.QuickCheck.All-import           Test.QuickCheck.Monadic-import qualified Data.Vector.Fusion.Stream as S-import           Data.Vector.Fusion.Util-import           Debug.Trace-import qualified Data.List as L-import qualified Data.Vector.Unboxed as VU--import           Data.PrimitiveArray--import           ADP.Fusion-import           ADP.Fusion.QuickCheck.Common------ * Outside checks---- ** two non-terminals on the r.h.s.------ A_ij -> B_ik C_kj------ B*_ik -> A*_ij C_kj--- C*_kj -> B_ik  A*_ij--prop_sv_OI ox@(O (Subword (i:.k))) = zs == ls where-  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))-  tic = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))-  zs = ((,) <<< toa % tic ... S.toList) (O $ subword 0 highest) ox-  ls = [ ( unsafeIndex xoS (O $ subword i j)-         , unsafeIndex xsS (    subword k j) )-       | j <- [ k .. highest ] ]--prop_sv_IO ox@(O (Subword (k:.j))) = zs == ls where-  tib = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))-  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))-  zs = ((,) <<< tib % toa ... S.toList) (O $ subword 0 highest) ox-  ls = [ ( unsafeIndex xsS (    subword i k)-         , unsafeIndex xoS (O $ subword i j) )-       | j <= highest, i <- [ 0 .. k ] ]---- ** three non-terminals on the r.h.s. (this provides situations where two--- syntactic terminals are on the same side)------ A_ij -> B_ik C_kl D_lj------ B*_ik -> A*_ij C_kl  D_lj--- C*_kl -> B_ik  A*_ij D_lj--- D*_lj -> B_ik  C_kl  A*_ij--prop_sv_OII ox@(O (Subword (i:.k))) = zs == ls where-  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))-  tic = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))-  tid = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))-  zs = ((,,) <<< toa % tic % tid ... S.toList) (O $ subword 0 highest) ox-  ls = [ ( unsafeIndex xoS (O $ subword i j)-         , unsafeIndex xsS (    subword k l)-         , unsafeIndex xsS (    subword l j) )-       | j <- [ k .. highest ], l <- [ k .. j ] ]--prop_sv_IOI ox@(O (Subword (k:.l))) = zs == ls where-  tib = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))-  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))-  tid = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))-  zs = ((,,) <<< tib % toa % tid ... S.toList) (O $ subword 0 highest) ox-  ls = [ ( unsafeIndex xsS (    subword i k)-         , unsafeIndex xoS (O $ subword i j)-         , unsafeIndex xsS (    subword l j) )-       | i <- [ 0 .. k ], j <- [ l .. highest ] ]--prop_sv_IIO ox@(O (Subword (l:.j))) = zs == ls where-  tib = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))-  tic = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))-  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))-  zs = ((,,) <<< tib % tic % toa ... S.toList) (O $ subword 0 highest) ox-  ls = [ ( unsafeIndex xsS (    subword i k)-         , unsafeIndex xsS (    subword k l)-         , unsafeIndex xoS (O $ subword i j) )-       | j <= highest, i <- [ 0 .. l ], k <- [ i .. l ] ]---- ** four non-terminals on the r.h.s. ?---- ** five non-terminals on the r.h.s. ?---- ** Non-terminal and terminal combinations--prop_cOc ox@(O( Subword (i:.j))) = zs == ls where-  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))-  zs  = ((,,) <<< chr csS % toa % chr csS ... S.toList) (O $ subword 0 highest) ox-  ls  = [ ( csS VU.! (i-1)-          , unsafeIndex xoS (O $ subword (i-1) (j+1))-          , csS VU.! (j  ) )-        | i > 0 && j < highest ]--prop_ccOcc ox@(O(Subword (i:.j))) = zs == ls where-  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))-  zs  = ((,,,,) <<< chr csS % chr csS % toa % chr csS % chr csS ... S.toList) (O $ subword 0 highest) ox-  ls  = [ ( csS VU.! (i-2)-          , csS VU.! (i-1)-          , unsafeIndex xoS (O $ subword (i-2) (j+2))-          , csS VU.! (j  )-          , csS VU.! (j+1) )-        | i > 1 && j < highest -1 ]--prop_cOccc ox@(O(Subword (i:.j))) = zs == ls where-  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))-  zs  = ((,,,,) <<< chr csS % toa % chr csS % chr csS % chr csS ... S.toList) (O $ subword 0 highest) ox-  ls  = [ ( csS VU.! (i-1)-          , unsafeIndex xoS (O $ subword (i-1) (j+3))-          , csS VU.! (j  )-          , csS VU.! (j+1)-          , csS VU.! (j+2) )-        | i > 0 && j < highest -2 ]---- ** Terminals, syntactic terminals, and non-terminals--prop_cOcIc ox@(O (Subword (i:.k))) = zs == ls where-  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))-  tic = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))-  zs = ((,,,,) <<< chr csS % toa % chr csS % tic % chr csS ... S.toList) (O $ subword 0 highest) ox-  ls = [ ( csS VU.! (i-1)-         , unsafeIndex xoS (O $ subword (i-1)  j    )-         , csS VU.! (k  )-         , unsafeIndex xsS (    subword (k+1) (j-1) )-         , csS VU.! (j-1) )-       | i > 0, j <- [ k+2 .. highest ] ]--prop_cIcOc ox@(O (Subword (k:.j))) = zs == ls where-  tib = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))-  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))-  zs = ((,,,,) <<< chr csS % tib % chr csS % toa % chr csS ... S.toList) (O $ subword 0 highest) ox-  ls = [ ( csS VU.! (i  )-         , unsafeIndex xsS (    subword (i+1) (k-1))-         , csS VU.! (k-1)-         , unsafeIndex xoS (O $ subword  i    (j+1))-         , csS VU.! (j  ) )-       | j+1 <= highest, k>1, i <- [ 0 .. k-2 ] ]---- ** Epsilonness--prop_Epsilon ox@(O (Subword (i:.j))) = zs == ls where-  zs = (id <<< Epsilon ... S.toList) (O $ subword 0 highest) ox-  ls = [ () | i==0 && j==highest ]----- ** Multi-tape cases--prop_2dimIt ix@(Z:.Subword (i:.j):.Subword (k:.l)) = zs == ls where-  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsSS (\ _ _ -> Id ((1,1),(1,1)))-  zs = (id <<< t ... S.toList) (Z:.subword 0 highest:.subword 0 highest) ix-  ls = [ ( unsafeIndex xsSS ix ) | j<=highest && l<=highest ]--{--xprop_2dimItIt ix@(Z:.Subword (i:.j):.Subword (k:.l)) = zs == ls where-  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsSS (\ _ _ -> Id (1,1))-  zs = ((,) <<< t % t ... S.toList) (Z:.subword 0 highest:.subword 0 highest) ix-  ls = [ ( unsafeIndex xsSS (Z:.subword i m:.subword k n)-         , unsafeIndex xsSS (Z:.subword m j:.subword n l) )-       | j<=highest && l<=highest-       , m <- [i..j]-       , n <- [k..l]-       ]--}--prop_2dimcIt ix@(Z:.Subword(i:.j):.Subword(k:.l)) = {- traceShow (zs,ls) $ -} zs == ls where-  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsSS (\ _ _ -> Id ((1,1),(1,1)))-  zs = ((,) <<< (M:|chr csS:|chr csS) % t ... S.toList) (Z:.subword 0 highest:.subword 0 highest) ix-  ls = [ ( Z :. (csS VU.! i) :. (csS VU.! k)-         , unsafeIndex xsSS (Z :. subword (i+1) j :. subword (k+1) l) )-       | j<=highest && l<=highest-       , i+1<=j && k+1<=l ]--prop_2dimItc ix@(Z:.Subword(i:.j):.Subword(k:.l)) = {- traceShow (zs,ls) $ -} zs == ls where-  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsSS (\ _ _ -> Id ((1,1),(1,1)))-  zs = ((,) <<< t % (M:|chr csS:|chr csS)  ... S.toList) (Z:.subword 0 highest:.subword 0 highest) ix-  ls = [ ( unsafeIndex xsSS (Z :. subword i (j-1) :. subword k (l-1))-         , Z :. (csS VU.! (j-1)) :. (csS VU.! (l-1)) )-       | j<=highest && l<=highest-       , i+1<=j && k+1<=l ]--prop_2dimcItc ix@(Z:.Subword(i:.j):.Subword(k:.l)) = {- traceShow (zs,ls) $ -} zs == ls where-  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsSS (\ _ _ -> Id ((1,1),(1,1)))-  zs = ((,,) <<< (M:|chr csS:|chr csS) % t % (M:|chr csS:| chr csS) ... S.toList) (Z:.subword 0 highest:.subword 0 highest) ix-  ls = [ ( Z :. (csS VU.! i) :. (csS VU.! k)-         , unsafeIndex xsSS (Z :. subword (i+1) (j-1) :. subword (k+1) (l-1))-         , Z :. (csS VU.! (j-1)) :. (csS VU.! (l-1)) )-       | j<=highest && l<=highest-       , i+2<=j && k+2<=l ]----highest = 10--csS :: VU.Vector (Int,Int)-csS = VU.fromList [ (i,i+1) | i <- [0 .. highest-1] ] -- this should be @highest -1@, we should die if we see @(highest,highest+1)@--xsS :: Unboxed Subword (Int,Int)-xsS = fromList (subword 0 0) (subword 0 highest) [ (i,j) | i <- [ 0 .. highest ] , j <- [ i .. highest ] ]--xoS :: Unboxed (Outside Subword) (Int,Int)-xoS = fromList (O $ subword 0 0) (O $ subword 0 highest) [ (i,j) | i <- [ 0 .. highest ] , j <- [ i .. highest ] ]--xsSS :: Unboxed (Z:.Subword:.Subword) ( (Int,Int) , (Int,Int) )-xsSS = fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 highest:.subword 0 highest) ((-1,-1),(-1,-1))-        $ Prelude.map (\((i,j),(k,l)) -> (Z:.subword i j:.subword k l, ((i,j),(k,l)) )) [ ((i,j) , (k,l)) | i <- [0 .. highest], j <-[i .. highest], k <- [0 .. highest], l <- [0 .. highest] ]---- * general quickcheck stuff--options = stdArgs {maxSuccess = 10000}--customCheck = quickCheckWithResult options--return []-allProps = $forAllProperties customCheck-
− ADP/Fusion/SynVar.hs 
@@ -1,19 +0,0 @@---- | This module re-exports all table types.--module ADP.Fusion.SynVar-  ( module ADP.Fusion.SynVar.Array-  , module ADP.Fusion.SynVar.Axiom-  , module ADP.Fusion.SynVar.Backtrack-  , module ADP.Fusion.SynVar.Fill-  , module ADP.Fusion.SynVar.Recursive-  , module ADP.Fusion.SynVar.Split-  ) where--import ADP.Fusion.SynVar.Array-import ADP.Fusion.SynVar.Axiom-import ADP.Fusion.SynVar.Backtrack-import ADP.Fusion.SynVar.Fill-import ADP.Fusion.SynVar.Recursive-import ADP.Fusion.SynVar.Split-
− ADP/Fusion/SynVar/Array.hs 
@@ -1,293 +0,0 @@--module ADP.Fusion.SynVar.Array-  ( module ADP.Fusion.SynVar.Array.Type-  , module ADP.Fusion.SynVar.Array.Point-  , module ADP.Fusion.SynVar.Array.Set-  , module ADP.Fusion.SynVar.Array.Subword-  ) where--import ADP.Fusion.SynVar.Array.Point-import ADP.Fusion.SynVar.Array.Set-import ADP.Fusion.SynVar.Array.Subword-import ADP.Fusion.SynVar.Array.TermSymbol-import ADP.Fusion.SynVar.Array.Type--{---{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE RankNTypes #-}--{-# LANGUAGE MagicHash #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE PatternGuards #-}---- | Tables in ADPfusion memoize results of parses. In the forward phase, table--- cells are filled by a table-filling method from @Data.PrimitiveArray@. In--- the backtracking phase, grammar rules are associated with tables to provide--- efficient backtracking.------ TODO multi-dim tables with 'OnlyZero' need a static check!------ TODO PointL , PointR need sanity checks for boundaries------ TODO the sanity checks are acutally a VERY BIG TODO since currently we do--- not protect against stupidity at all!------ TODO have boxed tables for top-down parsing.------ TODO combine forward and backward phases to simplify the external interface--- to the programmer.------ TODO include the notion of @interfaces@ into tables. With Outside--- grammars coming up now, we need this.--module ADP.Fusion.Table.Array---  ( MTbl      (..)---  , BtTbl     (..)-  ( ITbl      (..)---  , Backtrack (..)-  , ToBT (..)-  ) where--import           Control.Exception(assert)-import           Control.Monad.Primitive (PrimMonad)-import           Data.Vector.Fusion.Stream.Size (Size(Unknown))-import qualified Data.Vector as V-import qualified Data.Vector.Generic as VG-import qualified Data.Vector.Storable as VS-import qualified Data.Vector.Unboxed as VU-import           GHC.Exts-import           Data.Bits--import           Data.PrimitiveArray -- (Z(..), (:.)(..), Subword(..), subword, PointL(..), pointL, PointR(..), pointR,topmostIndex, Outside(..))-import qualified Data.PrimitiveArray as PA--import           ADP.Fusion.Classes-import           ADP.Fusion.Multi.Classes-import           ADP.Fusion.Table.Axiom-import           ADP.Fusion.Table.Backtrack-import           ADP.Fusion.Table.Indices--import           Debug.Trace------ ** Mutable fill-phase tables.---- | The backtracking version.-------- TODO empty table @ms@ stuff--instance-  ( Monad m-  , Element ls (BS2I First Last)-  , PA.PrimArrayOps arr (BS2I First Last) x-  , MkStream m ls (BS2I First Last)-  ) => MkStream m (ls :!: ITbl m arr (BS2I First Last) x) (BS2I First Last) where-  -- outermost case. Grab inner indices, calculate the remainder of the-  -- set, return value-  mkStream (ls :!: ITbl c t _) Static s (BitSet b:>Interface i:>Interface j)-    = S.map (\z -> let (BitSet zb:>_:>Interface zj) = getIdx z  -- the bitset we get from the guy before us-                       here = (BitSet (b `xor` zb .|. zj):>Interface zj:>Interface j) -- everything missing, set common interface-                   in  ElmITbl (t PA.! here) here z-            )-    $ mkStream ls (Variable Check Nothing) s (BitSet (clearBit b j):>Interface i:>Interface j)-  -- generate all possible subsets of the index. With A @Variable-  -- _ Nothing@, there is something to the right that will fill up the set.-  mkStream (ls :!: ITbl c t _) (Variable Check Nothing) full (BitSet b:>Interface i:>Interface j)-    = S.flatten mk step Unknown-    $ mkStream ls (Variable Check Nothing) full (BitSet b:>Interface i:>Interface j)-    where mk z = return (z,Just $ BitSet 0:>Interface 0:>Interface 0)-          step (_,Nothing) = return $ S.Done-          step (z,Just s ) = return $ S.Yield (ElmITbl (t PA.! s) s z) (z,succSet full s)-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  -- generate only those indices with the requested number of set bits-  {-# Inline mkStream #-}--instance-  ( Monad mB-  , Element ls (BS2I First Last)-  , PA.PrimArrayOps arr (BS2I First Last) x-  , MkStream mB ls (BS2I First Last)-  ) => MkStream mB (ls :!: BT (ITbl mF arr (BS2I First Last) x) mF mB r) (BS2I First Last) where-  mkStream (ls :!: BtITbl c arr bt) Static full (BitSet b:>Interface i:>Interface j)-    = S.map (\z -> let (BitSet zb:>Interface zi:>Interface zj) = getIdx z-                       here = BitSet (clearBit b j):>Interface i:>Interface zj-                       d = arr PA.! here-                   in ElmBtITbl' d (bt full here) here z)-    $ mkStream ls (Variable Check Nothing) full (BitSet (clearBit b j):>Interface i:>Interface (-1))-  mkStream (ls :!: BtITbl c arr bt) (Variable Check Nothing) full (BitSet b:>Interface i:>Interface j)-    = S.flatten mk step Unknown-    $ mkStream ls (Variable Check Nothing) full (BitSet b:>Interface i:>Interface j)-    where mk z = return (z,Just $ BitSet 0:>Interface 0:>Interface 0)-          step (_,Nothing) = return $ S.Done-          step (z,Just s ) = return $ S.Yield (ElmBtITbl' (arr PA.! s) (bt full s) s z) (z,succSet full s)-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline mkStream #-}--instance-  ( Monad m-  , Element ls (Outside PointL)-  , PA.PrimArrayOps arr (Outside PointL) x-  , MkStream m ls (Outside PointL)-  ) => MkStream m (ls :!: ITbl m arr (Outside PointL) x) (Outside PointL) where-  mkStream (ls :!: ITbl c t _) Static lu (O (PointL (i:.j)))-    = let ms = minSize c in seq ms $ seq t $-    S.mapM (\s -> let O (PointL (h:.k)) = getIdx s-                  in  return $ ElmITbl (t PA.! O (pointL k j)) (O $ pointL k j) s)-    $ mkStream ls (Variable Check Nothing) lu (O . pointL i $ j + ms)---  mkStream _ _ _ _ = error "mkStream / ITbl / Outside PointL not implemented"-  {-# INLINE mkStream #-}--instance-  ( Monad mB-  , Element ls (Outside PointL)-  , PA.PrimArrayOps arr (Outside PointL) x-  , MkStream mB ls (Outside PointL)-  ) => MkStream mB (ls :!: BT (ITbl mF arr (Outside PointL) x) mF mB r) (Outside PointL) where-  mkStream (ls :!: BtITbl c arr bt) Static lu (O (PointL (i:.j)))-    = let ms = minSize c in ms `seq`-    S.map (\s -> let O (PointL (h:.k)) = getIdx s-                     ix                = O $ pointL k j-                     d                 = arr PA.! ix-                 in ElmBtITbl' d (bt lu ix) ix s)-    $ mkStream ls (Variable Check Nothing) lu (O . pointL i $ j + ms)---  mkStream _ _ _ _ = error "mkStream / BT ITbl / Outside PointL not implemented"-  {-# INLINE mkStream #-}---- | TODO As soon as we don't do static checking on @EmptyOk/NonEmpty@--- anymore, this works! If we check @c@, we immediately have fusion--- breaking down!--{--instance-  ( Monad m-  , Element ls Subword-  , PA.PrimArrayOps arr Subword x-  , MkStream m ls Subword-  ) => MkStream m (ls :!: ITbl m arr Subword x) Subword where-  mkStream (ls :!: ITbl c t _) Static lu (Subword (i:.j))-    = let ms = minSize c in ms `seq`-      S.mapM (\s -> let Subword (_:.l) = getIdx s-                    in  return $ ElmITbl (t PA.! subword l j) (subword l j) s)-    $ mkStream ls (Variable Check Nothing) lu (subword i $ j - ms) -- - minSize c)-  mkStream (ls :!: ITbl c t _) (Variable _ Nothing) lu (Subword (i:.j))-    = let ms = minSize c-          {- data PBI a = PBI !a !(Int#)-          mk s = let (Subword (_:.l)) = getIdx s ; !(I# jlm) = j-l-ms in return $ PBI s jlm-          step !(PBI s z) | 1# <- z >=# 0# = do let (Subword (_:.k)) = getIdx s-                                                return $ S.Yield (ElmITbl (t PA.! subword k (j-(I# z))) (subword k $ j-(I# z)) s) (PBI s (z -# 1#))-                          | otherwise = return S.Done-          -}-          {--          mk s = let (Subword (_:.l)) = getIdx s in return (s :. j - l - ms)-          step (s:.z) | 1# <- z' >=# 0# = do let (Subword (_:.k)) = getIdx s-                                             return $ S.Yield (ElmITbl (t PA.! subword k (j-z)) (subword k $ j-z) s) (s:.z-1)-                      | otherwise = return S.Done-                      where !(I# z') = z-          -}-          mk s = let (Subword (_:.l)) = getIdx s in return (s :. j - l - ms)-          step (s:.z) | z>=0 = do let (Subword (_:.k)) = getIdx s-                                  return $ S.Yield (ElmITbl (t PA.! subword k (j-z)) (subword k $ j-z) s) (s:.z-1)-                      | otherwise = return S.Done-          {-# INLINE [1] mk #-}-          {-# INLINE [1] step #-}-      in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (subword i j)-  {-# INLINE mkStream #-}--}--{--instance-  ( Monad mB-  , Element ls Subword-  , MkStream mB ls Subword-  , PA.PrimArrayOps arr Subword x-  ) => MkStream mB (ls :!: BT (ITbl mF arr Subword x) mF mB r) Subword where-  mkStream (ls :!: BtITbl c arr bt)  Static lu (Subword (i:.j))-    = let ms = minSize c in ms `seq`-      S.map (\s -> let (Subword (_:.l)) = getIdx s-                       ix               = subword l j-                       d                = arr PA.! ix-                   in  ElmBtITbl' d (bt lu ix) ix s)-      $ mkStream ls (Variable Check Nothing) lu (subword i $ j - ms)-  mkStream (ls :!: BtITbl c arr bt) (Variable _ Nothing) lu (Subword (i:.j))-    = let ms = minSize c-          mk s = let (Subword (_:.l)) = getIdx s in return (s:.j-l-ms)-          step (s:.z)-            | z>=0      = do let (Subword (_:.k)) = getIdx s-                                 ix               = subword k (j-z)-                                 d                = arr PA.! ix-                             return $ S.Yield (ElmBtITbl' d (bt lu ix) ix s) (s:.z-1)-            | otherwise = return $ S.Done-          {-# INLINE [1] mk   #-}-          {-# INLINE [1] step #-}-      in  ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (subword i j)-  {-# INLINE mkStream #-}--}--{--instance-  ( Monad m-  , Element ls (Outside Subword)-  , PA.PrimArrayOps arr Subword x-  , MkStream m ls (Outside Subword)-  ) => MkStream m (ls :!: ITbl m arr Subword x) (Outside Subword) where-  mkStream (ls :!: ITbl c t _) Static lu (O (Subword (i:.j)))-    = let ms = minSize c in ms `seq`-      S.mapM (\s -> let (O (Subword (_:.l))) = getIdx s-                    in  return $ ElmITbl (t PA.! (subword l j)) (O $ subword l j) s)-    $ mkStream ls (Variable Check Nothing) lu (O $ subword i $ j - ms) -- - minSize c)-  mkStream (ls :!: ITbl c t _) (Variable _ Nothing) lu (O (Subword (i:.j)))-    = let ms = minSize c-          mk s = let (O( Subword (_:.l))) = getIdx s in return (s :. j - l - ms)-          step (s:.z) | z>=0 = do let (O (Subword (_:.k))) = getIdx s-                                  return $ S.Yield (ElmITbl (t PA.! (subword k (j-z))) (O . subword k $ j-z) s) (s:.z-1)-                      | otherwise = return S.Done-          {-# INLINE [1] mk #-}-          {-# INLINE [1] step #-}-      in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (O $ subword i j)-  {-# INLINE mkStream #-}--}--{--instance-  ( Monad m-  , Element ls (Outside Subword)-  , PA.PrimArrayOps arr (Outside Subword) x-  , MkStream m ls (Outside Subword)-  ) => MkStream m (ls :!: ITbl m arr (Outside Subword) x) (Outside Subword) where-  mkStream (ls :!: ITbl c t _) Static lu (O (Subword (i:.j)))-    = let ms = minSize c in ms `seq`-      S.mapM (\s -> let (O (Subword (_:.l))) = getIdx s-                    in  return $ ElmITbl (t PA.! (O $ subword l j)) (O $ subword l j) s)-    $ mkStream ls (Variable Check Nothing) lu (O $ subword i $ j - ms) -- - minSize c)-  mkStream (ls :!: ITbl c t _) (Variable _ Nothing) lu (O (Subword (i:.j)))-    = let ms = minSize c-          mk s = let (O( Subword (_:.l))) = getIdx s in return (s :. j - l - ms)-          step (s:.z) | z>=0 = do let (O (Subword (_:.k))) = getIdx s-                                  return $ S.Yield (ElmITbl (t PA.! (O $ subword k (j-z))) (O . subword k $ j-z) s) (s:.z-1)-                      | otherwise = return S.Done-          {-# INLINE [1] mk #-}-          {-# INLINE [1] step #-}-      in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (O $ subword i j)-  {-# INLINE mkStream #-}--}------- * Axiom for backtracking---}-
− ADP/Fusion/SynVar/Array/Point.hs 
@@ -1,79 +0,0 @@--module ADP.Fusion.SynVar.Array.Point where--import Data.Strict.Tuple-import Data.Vector.Fusion.Stream.Monadic-import Data.Vector.Fusion.Stream.Size-import Data.Vector.Fusion.Util (delay_inline)-import Debug.Trace-import Prelude hiding (map,mapM)---import qualified Data.Vector.Fusion.Stream.Monadic as S--import           Data.PrimitiveArray hiding (map)--import           ADP.Fusion.Base-import           ADP.Fusion.SynVar.Array.Type-import           ADP.Fusion.SynVar.Backtrack----instance-  ( Monad m-  , Element ls PointL-  , PrimArrayOps arr PointL x-  , MkStream m ls PointL-  ) => MkStream m (ls :!: ITbl m arr PointL x) PointL where-  mkStream (ls :!: ITbl _ _ c t _) (IStatic d) u j@(PointL pj)-    = let ms = minSize c in ms `seq`-    map (ElmITbl (t!j) j (PointL 0))-    $ mkStream ls (IVariable d) u (PointL $ pj - ms)-  -- We can't really make sure that this is the only time we access the-  -- ITbl, so the user should know what they are doing.-  mkStream (ls :!: ITbl _ _ c t _) (IVariable d) u j@(PointL pj)-    = flatten mk step Unknown $ mkStream ls (IVariable d) u (delay_inline PointL $! pj - ms)-    where mk s = let PointL k = getIdx s in return (s :. k)-          step (s :. k)-            | k+ms>pj   = return $ Done-            | otherwise = return $ Yield (ElmITbl (t!PointL k) (PointL k) (PointL 0) s) (s :. k+1)-          !ms = minSize c-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline mkStream #-}--instance-  ( Monad mB-  , Element ls PointL-  , PrimArrayOps arr PointL x-  , MkStream mB ls PointL-  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr PointL x) mF mB r) PointL where-  mkStream (ls :!: BtITbl c t bt) (IStatic d) u j@(PointL pj)-    = let ms = minSize c in ms `seq`-    mapM (\s -> bt u j >>= \bb -> return $ ElmBtITbl (t!j) (bb {-bt u j-}) j (PointL 0) s)-    $ mkStream ls (IVariable d) u (PointL $ pj - ms)-  {-# INLINE mkStream #-}--instance-  ( Monad m-  , Element ls (Outside PointL)-  , PrimArrayOps arr (Outside PointL) x-  , MkStream m ls (Outside PointL)-  ) => MkStream m (ls :!: ITbl m arr (Outside PointL) x) (Outside PointL) where-  mkStream (ls :!: ITbl _ _ c t _) (OStatic d) u (O (PointL pj))-    = let ms = minSize c in ms `seq`-    map (\z -> let o = getOmx z-                 in  ElmITbl (t ! o) o o z)-    $ mkStream ls (OFirstLeft d) u (O $ PointL $ pj - ms)-  {-# Inline mkStream #-}--instance-  ( Monad mB-  , Element ls (Outside PointL)-  , PrimArrayOps arr (Outside PointL) x-  , MkStream mB ls (Outside PointL)-  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (Outside PointL) x) mF mB r) (Outside PointL) where-  mkStream (ls :!: BtITbl c t bt) (OStatic d) u (O (PointL pj))-    = let ms = minSize c in ms `seq`-    mapM (\s -> let o = getOmx s in bt u o >>= \bb -> return $ ElmBtITbl (t!o) (bb{-bt u o-}) o o s)-    $ mkStream ls (OFirstLeft d) u (O $ PointL $ pj - ms)-  {-# INLINE mkStream #-}-
− ADP/Fusion/SynVar/Array/Set.hs 
@@ -1,164 +0,0 @@--module ADP.Fusion.SynVar.Array.Set where--import Data.Bits-import Data.Bits.Extras-import Data.Bits.Ordered-import Data.Strict.Tuple-import Data.Vector.Fusion.Stream.Monadic-import Data.Vector.Fusion.Stream.Size-import Data.Vector.Fusion.Util (delay_inline)-import Debug.Trace-import Prelude hiding (map)-import Control.Applicative ((<$>))--import Data.PrimitiveArray hiding (map)--import ADP.Fusion.Base-import ADP.Fusion.SynVar.Array.Type-import ADP.Fusion.SynVar.Backtrack------ * Bitsets without any interfaces.---- NOTE that we have to give as the filled index elements all bits that are--- set in total, not just those we set right here. Otherwise the next--- element will try a wrong set of indices.------ NOTE even in the @IStatic@ case, we need to use flatten. If a node--- requested a reserved bit, we need to free each reserved bit at least--- once.--instance-  ( Monad m-  , Element ls BitSet-  , PrimArrayOps arr BitSet x-  , MkStream m ls BitSet-  ) => MkStream m (ls :!: ITbl m arr BitSet x) BitSet where-  mkStream (ls :!: ITbl _ _ c t _) (IStatic rp) u s-    = flatten mk step Unknown $ mkStream ls (delay_inline IVariable $ rp - csize) u s-    where !csize | c==EmptyOk  = 0-                 | c==NonEmpty = 1-          mk z-            | cm < csize = return (z , mask , Nothing)-            | otherwise  = return (z , mask , Just k )-            where k  = (BitSet $ 2^cm-1)-                  cm = popCount mask - rp-                  mask = s `xor` (getIdx z)-          step (_,_,Nothing) = return $ Done-          step (z,mask,Just k)-            | pk > popCount s - rp = return $ Done-            | otherwise            = let kk = popShiftL mask k-                                     in  return $ Yield (ElmITbl (t!kk) (kk .|. getIdx z) (BitSet 0) z) (z,mask,setSucc (BitSet 0) (2^pk -1) k)-            where pk = popCount k-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  mkStream (ls :!: ITbl _ _ c t _) (IVariable rp) u s-    = flatten mk step Unknown $ mkStream ls (IVariable rp) u s-    where mk z-            | c==EmptyOk  = return (z , mask , cm , Just 0 )-            | cm == 0     = return (z , mask , cm , Nothing) -- we are non-empty but have no free bits left-            | c==NonEmpty = return (z , mask , cm , Just 1 )-            where mask = s `xor` (getIdx z) -- bits that are still free-                  cm   = popCount mask-          step (z,mask,cm,Nothing) = return $ Done-          step (z,mask,cm,Just k )-            | popCount s < popCount (kk .|. getIdx z) + rp = return $ Done-            | otherwise = return $ Yield (ElmITbl (t!kk) (kk .|. getIdx z) (BitSet 0) z) (z,mask,cm,setSucc (BitSet 0) (2^cm -1) k)-            where kk = popShiftL mask k-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline mkStream #-}------ * Bitsets with two interfaces.------ NOTE These are annoying to get right, if you also want to have good--- performance.--instance-  ( Monad m-  , Element ls (BS2I First Last)-  , PrimArrayOps arr (BS2I First Last) x-  , MkStream m ls (BS2I First Last)-  , Show x-  ) => MkStream m (ls :!: ITbl m arr (BS2I First Last) x) (BS2I First Last) where-  mkStream (ls :!: ITbl _ _ c t _) (IStatic rp) u sij@(s:>i:>j@(Iter jj))-    = flatten mk step Unknown $ mkStream ls (delay_inline IVariable rpn) u (delay_inline id $ tij)-          -- calculate new index. if we don't know the right-most interface-          -- anymore, than someone has taken it already. Also, if this-          -- synvar may be empty, do not modify the index. Otherwise, if-          -- @j@ is still known, remove it from the index set.-    where tij | jj == -1       = sij-              | c  == EmptyOk  = sij-              | c  == NonEmpty = s `clearBit` jj :> i :> Iter (-1)-          -- In case we do not know the rightmost interface, we instead-          -- increase the number of reserved bits.-          rpn | jj == -1-              && c == NonEmpty = rp+1-              | otherwise      = rp-          nec | c == NonEmpty = 1-              | c == EmptyOk  = 0-          mk z-            -- in case we have a non-empty synvar but not enough bits, we-            -- shall have nothing. We only need one extra mask bit, because-            -- @j@ is still known.-            | popCount mask < 1 && c == NonEmpty && j >= 0 = return $ Naught-            -- If @j@ is not known we need two bits to be non-empty.-            | popCount mask < 2 && c == NonEmpty && j <  0 = return $ Naught-            -- Not enough bits to reserve.-            | popCount mask - rp < 0                       = return $ Naught-            -- @j@ is still known, just create the sets ending in @j@-            | j >= 0                                       = return $ This (z,mask)-            -- @j@ is not known, we have a lot of work to do. Create the-            -- required @bits@ and prepare a @mask@ which will set the-            -- correct bits.-            | j <  0                                       = return $ That (z,mask,Just bits,maybeLsb bits)-            -- we somehow ended up with an improper state-            | otherwise                                    = error $ show (sij,mask,bits)-            where (zs:>_:>Iter zk) = getIdx z-                  mask             = s `xor` zs-                  bits             = BitSet $ 2 ^ (popCount mask - rp - nec) - 1-          step Naught          = return $ Done-          -- In case @j@ is known, we calculate the bits @msk@ that are not-          -- filled yet. We grab the previous right interface @zk@ and use-          -- it as the new left interface. We also use @j@ as the right-          -- interface. @ix@ holds everything that is now covered, withe-          -- the interface @i@ and @j@.-          step (This (z,mask)) = return $ Yield (ElmITbl (t!(msk:>k:>j)) ix undefbs2i z) Naught-            where (zs:>_:>zk) = getIdx z-                  k           = Iter $ getIter zk-                  ix          = (zs .|. msk) :> i :> j-                  msk         = if popCount mask == 0 then mask else mask `setBit` getIter k `setBit` jj-          -- whenever there is nothing more to do in the variable case.-          step (That (z,mask,Nothing,_)) = return $ Done-          -- We need to permute our population a bit. Once done, we grab-          -- the lowest significant bit.-          step (That (z,mask,Just bits,Nothing)) = return $ Skip (That (z,mask,nbts, maybeLsb =<< nbts))-            where nbts = popPermutation (popCount mask) bits-          -- The variable case.-          step (That (z,mask,Just bits,Just y))-            -- we do not have enough bits to be non-empty.-            |  popCount bb < 2 && c == NonEmpty-            -- our two interfaces are the same, but we are non-empty in-            -- which case this shouldn't happen.-            || getIter kk == getIter yy && c == NonEmpty-            -- our pop-count plus reserved count doesn't match up with the-            -- mask. We skip this as well.-            || popCount bb + rp /= popCount mask = return $ Skip (That (z,mask,Just bits, maybeNextActive y bits))-            -- finally, we can create the index for the current stuff-            -- @bb:>kk:>yy@ and prepare the full index, going from @i@ to-            -- @yy@, because someone grabbed @j@ already. Must have been-            -- an @Edge@ or s.th. similar.-            | otherwise = return $ Yield (ElmITbl (t!(bb:>kk:>yy)) ((zs .|. bb):>i:>yy) undefbs2i z)-                                                                 (That (z,mask,Just bits, maybeNextActive y bits))-            where (zs:>_:>zk) = getIdx z-                  kk          = Iter $ getIter zk-                  yy          = Iter . lsb $ popShiftL mask (bit y)-                  bb          = popShiftL mask bits `setBit` getIter kk `setBit` getIter yy-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline mkStream #-}-
− ADP/Fusion/SynVar/Array/Subword.hs 
@@ -1,318 +0,0 @@--{-# Language MagicHash #-}--module ADP.Fusion.SynVar.Array.Subword where--import Data.Strict.Tuple-import Data.Vector.Fusion.Stream.Size-import Data.Vector.Fusion.Util (delay_inline)-import Data.Vector.Fusion.Stream.Monadic-import Debug.Trace-import Prelude hiding (map,mapM)--import Data.PrimitiveArray hiding (map)--import ADP.Fusion.Base-import ADP.Fusion.SynVar.Array.Type-import ADP.Fusion.SynVar.Backtrack---- TODO think about what we are about to do-import GHC.Prim (reallyUnsafePtrEquality#)------- TODO delay inline @(subword i $ j - minSize c)@ or face fusion-breakage.--- Can we just have @Inline [0] subword@ to fix this?--instance-  ( Monad m-  , Element ls Subword-  , PrimArrayOps arr Subword x-  , MkStream m ls Subword-  ) => MkStream m (ls :!: ITbl m arr Subword x) Subword where-  mkStream (ls :!: ITbl _ _ c t _) (IStatic ()) hh (Subword (i:.j))-    = map (\s -> let (Subword (_:.l)) = getIdx s-                 in  ElmITbl (t ! subword l j) (subword l j) (subword 0 0) s)-    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))-  mkStream (ls :!: ITbl _ _ c t _) (IVariable ()) hh (Subword (i:.j))-    = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))-    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - minSize c)-          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s-                                        l              = j - z-                                        kl             = subword k l-                                    return $ Yield (ElmITbl (t ! kl) kl (subword 0 0) s) (s:. z-1)-                      | otherwise = return $ Done-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline mkStream #-}--instance-  ( Monad mB-  , Element ls Subword-  , MkStream mB ls Subword-  , PrimArrayOps arr Subword x-  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr Subword x) mF mB r) Subword where-  mkStream (ls :!: BtITbl c t bt) (IStatic ()) hh ij@(Subword (i:.j))-    = mapM (\s -> let Subword (_:.l) = getIdx s-                      lj             = subword l j-                  in  bt hh lj >>= \ ~bb -> return $ ElmBtITbl (t ! lj) (bb {-bt hh lj-}) lj (subword 0 0) s)-    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))-  mkStream (ls :!: BtITbl c t bt) (IVariable ()) hh ij@(Subword (i:.j))-    = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))-    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - minSize c)-          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s-                                        l              = j - z-                                        kl             = subword k l-                                    bt hh kl >>= \ ~bb -> return $ Yield (ElmBtITbl (t ! kl) (bb {-bt hh kl-}) kl (subword 0 0) s) (s:.z-1)-                      | otherwise = return $ Done-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline mkStream #-}---instance-  ( Monad m-  , Element ls (Outside Subword)-  , PrimArrayOps arr (Outside Subword) x-  , MkStream m ls (Outside Subword)-  ) => MkStream m (ls :!: ITbl m arr (Outside Subword) x) (Outside Subword) where-  -- TODO what about @c / minSize@-  mkStream (ls :!: ITbl _ _ c t _) (OStatic (di:.dj)) u ij@(O (Subword (i:.j)))-    = map (\s -> let O (Subword (k:._)) = getOmx s-                     kj = O $ Subword (k:.j+dj)-                 in  ElmITbl (t ! kj) (O $ Subword (i:.j+dj)) kj s) -- @ij@ or s.th. else shouldn't matter?-    $ mkStream ls (OFirstLeft (di:.dj)) u ij-  mkStream (ls :!: ITbl _ _ c t _) (ORightOf (di:.dj)) u@(O (Subword (_:.h))) ij@(O (Subword (i:.j)))-    = flatten mk step Unknown $ mkStream ls (OFirstLeft (di:.dj)) u ij-      where mk s = return (s:.j+dj)-            step (s:.l) | l <= h = do let (O (Subword (k:._))) = getIdx s-                                          kl = O $ Subword (k:.l)-                                      return $ Yield (ElmITbl (t ! kl) (O (Subword (j+dj:.j+dj))) kl s) (s:.l+1)-                        | otherwise = return $ Done-            {-# Inline [0] mk   #-}-            {-# Inline [0] step #-}-  mkStream (ls :!: ITbl _ _ c t _) (OFirstLeft d) u ij = error "Array/Outside Subword : OFirstLeft : should never be reached!"-  mkStream (ls :!: ITbl _ _ c t _) (OLeftOf d) u ij = error "Array/Outside Subword : OLeftOf : should never be reached!"-  {-# Inline mkStream #-}----instance-  ( Monad m-  , Element ls (Outside Subword)-  , PrimArrayOps arr Subword x-  , MkStream m ls (Outside Subword)-  ) => MkStream m (ls :!: ITbl m arr Subword x) (Outside Subword) where-  -- TODO what about @c / minSize@-  mkStream (ls :!: ITbl _ _ c t _) (OStatic (di:.dj)) u ij@(O (Subword (i:.j)))-    = map (\s -> let O (Subword (_:.k))     = getIdx s-                     o@(O (Subword (_:.l))) = getOmx s-                     kl = Subword (k-dj:.l-dj)-                 in ElmITbl (t ! kl) (O (Subword (k:.l))) o s)-    $ mkStream ls (ORightOf (di:.dj)) u ij-  mkStream (ls :!: ITbl _ _ c t _) (ORightOf d) u@(O (Subword (_:.h))) ij@(O (Subword (i:.j)))-    = flatten mk step Unknown $ mkStream ls (ORightOf d) u ij-    where mk s = let O (Subword (_:.l)) = getIdx s-                 in  return (s :.l:.l + minSize c)-          step (s:.k:.l)-            | let O (Subword (_:.o)) = getOmx s-            , l <= o = do let kl = Subword (k:.l)-                          return $ Yield (ElmITbl (t ! kl) (O kl) (getOmx s) s) (s:.k:.l+1)-            | otherwise = return $ Done-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  mkStream (ls :!: ITbl _ _ c t _) (OFirstLeft (di:.dj)) u ij@(O (Subword (i:.j)))-    = map (\s -> let O (Subword (l:._)) = getOmx s-                     O (Subword (_:.k)) = getIdx s-                     kl = Subword (k:.i-di)-                 in  ElmITbl (t ! kl) (O kl) (getOmx s) s)-    $ mkStream ls (OLeftOf (di:.dj)) u ij-  mkStream (ls :!: ITbl _ _ c t _) (OLeftOf d) u ij@(O (Subword (i:.j)))-    = flatten mk step Unknown $ mkStream ls (OLeftOf d) u ij-    where mk s = let O (Subword (_:.l)) = getIdx s in return (s:.l)-          step (s:.l) | l <= i = do let O (Subword (_:.k)) = getIdx s-                                        kl = Subword (k:.l)-                                    return $ Yield (ElmITbl (t ! kl) (O kl) (getOmx s) s) (s:.l+1)-                      | otherwise = return $ Done-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline mkStream #-}--instance-  ( Monad m-  , Element ls (Complement Subword)-  , PrimArrayOps arr Subword x-  , MkStream m ls (Complement Subword)-  ) => MkStream m (ls :!: ITbl m arr Subword x) (Complement Subword) where-  mkStream (ls :!: ITbl _ _ c t _) Complemented u ij-    = map (\s -> let (C ix) = getIdx s-                 in  ElmITbl (t ! ix) (C ix) (getOmx s) s)-    $ mkStream ls Complemented u ij-  {-# Inline mkStream #-}--instance-  ( Monad m-  , Element ls (Complement Subword)-  , PrimArrayOps arr (Outside Subword) x-  , MkStream m ls (Complement Subword)-  ) => MkStream m (ls :!: ITbl m arr (Outside Subword) x) (Complement Subword) where-  mkStream (ls :!: ITbl _ _ c t _) Complemented u ij-    = map (\s -> let (C ox) = getOmx s      -- TODO shouldn't this be @getIdx@ as well? on the count of everything being terminals in Complement?-                 in  ElmITbl (t ! (O ox)) (getIdx s) (C ox) s)-    $ mkStream ls Complemented u ij-  {-# Inline mkStream #-}----instance ModifyConstraint (ITbl m arr Subword x) where-  toNonEmpty (ITbl b l _ arr f) = ITbl b l NonEmpty arr f-  toEmpty    (ITbl b l _ arr f) = ITbl b l EmptyOk  arr f-  {-# Inline toNonEmpty #-}-  {-# Inline toEmpty #-}--instance ModifyConstraint (Backtrack (ITbl mF arr Subword x) mF mB r) where-  toNonEmpty (BtITbl _ arr bt) = BtITbl NonEmpty arr bt-  toEmpty    (BtITbl _ arr bt) = BtITbl EmptyOk  arr bt-  {-# Inline toNonEmpty #-}-  {-# Inline toEmpty #-}----instance-  ( Monad m-  , Element ls Subword -- (Z:.Subword:.Subword)-  , FirstSecond ls (arr (Z:.Subword:.Subword) x)-  , FirstSecondIdx ls (arr (Z:.Subword:.Subword) x) Subword-  , PrimArrayOps arr (Z:.Subword:.Subword) x-  , MkStream m ls Subword-  , Show x-  ) => MkStream m (ls :!: ITbl m arr (Z:.Subword:.Subword) x) Subword where-  mkStream (ls :!: ITbl _ _ c t elm) (IStatic ()) hh (Subword (i:.j))-    = map (\s -> let (Subword (_:.l)) = getIdx s-                     ab               = if greenLight ls t-                                          then greenIdx ls (undefined :: Subword) t s-                                          else subword 0 0-                 in  -- traceShow ("13",ab,subword l j,t!(Z:.ab:.subword l j)) $-                     ElmITbl (t ! (Z:.ab:.subword l j)) (subword l j) (subword 0 0) s)-    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - 0))-  mkStream (ls :!: ITbl _ _ c t elm) (IVariable ()) hh (Subword (i:.j))-    = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - 0))-    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - 0)-          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s-                                        l              = j - z-                                        kl             = subword k l-                                        ab             = if greenLight ls t-                                                           then greenIdx ls (undefined :: Subword) t s-                                                           else subword 0 0-                                    --traceShow ("02",ab,subword k l,t!(Z:.ab:.subword k l)) $-                                    return $ Yield (ElmITbl (t ! (Z:.ab:.kl)) kl (subword 0 0) s) (s:.z-1)-                      | otherwise = return $ Done-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline mkStream #-}--instance-  ( Monad mB-  , FirstSecond ls (arr (Z:.Subword:.Subword) x)-  , FirstSecondIdx ls (arr (Z:.Subword:.Subword) x) Subword-  , PrimArrayOps arr (Z:.Subword:.Subword) x-  , Element ls Subword-  , MkStream mB ls Subword-  , Show r-  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (Z:.Subword:.Subword) x) mF mB r) Subword where-  mkStream (ls :!: BtITbl c t bt) (IStatic ()) hh (Subword (i:.j))-    = mapM (\s -> let (Subword (_:.l)) = getIdx s-                      lj               = subword l j-                      light            = greenLight ls t-                      ab               = if light-                                           then greenIdx ls (undefined :: Subword) t s-                                           else lj -- subword 0 0-                      ablj             = if light-                                           then Z:.ab:.lj-                                           else Z:.subword 0 0:.subword 0 0 -- Z:.lj:.lj-                  in bt (Prelude.snd $ bounds t) ablj >>= \ ~bb -> {- traceShow (ab,lj,bb) $ -} return $ ElmBtITbl (t ! ablj) bb lj (subword 0 0) s)-    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - 0))-  mkStream (ls :!: BtITbl c t bt) (IVariable ()) hh (Subword (i:.j))-    = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - 0))-    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - 0)-          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s-                                        l              = j - z-                                        kl             = subword k l-                                        light          = greenLight ls t-                                        ab             = if light-                                                           then greenIdx ls (undefined :: Subword) t s-                                                           else kl -- subword 0 0-                                        abkl           = if light-                                                           then Z:.ab:.kl-                                                           else Z:.subword 0 0:.subword 0 0 -- Z:.kl:.kl-                                    bt (Prelude.snd $ bounds t) abkl >>= \ ~bb -> {- traceShow (ab,kl,bb) $ -} return $ Yield (ElmBtITbl (t!abkl) bb kl (subword 0 0) s) (s:.z-1)-                      | otherwise = return $ Done-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline mkStream #-}---- | Get the previous index; this should really be made generic!------ TODO This is probably a REALLY STUPID IDEA ;-)--class FirstSecond x k where-  greenLight :: x -> k -> Bool--class FirstSecondIdx x k i where-  greenIdx :: x -> i -> k -> Elm x i -> Subword--instance FirstSecond S k where-  greenLight S _ = False-  {-# Inline greenLight #-}----instance-  ( FirstSecond ls (arr (Z:.Subword:.Subword) x)-  ) => FirstSecond (ls :!: ITbl m arr (Z:.Subword:.Subword) x) (arr (Z:.Subword:.Subword) x) where-  greenLight (ls :!: ITbl _ _ _ t _) t' =-    case reallyUnsafePtrEquality# t t' of-      -- TODO speaking of stupid ideas!-      1# -> True-      _  -> greenLight ls t'-  {-# Inline greenLight #-}--instance-  ( FirstSecond ls (arr (Z:.Subword:.Subword) x)-  ) => FirstSecond (ls :!: Backtrack (ITbl mF arr (Z:.Subword:.Subword) x) mF mB r) (arr (Z:.Subword:.Subword) x) where-  greenLight (ls :!: BtITbl _ t _) t' =-    case reallyUnsafePtrEquality# t t' of-      -- TODO speaking of stupid ideas!-      1# -> True-      _  -> greenLight ls t'-  {-# Inline greenLight #-}----instance FirstSecondIdx S k i where-  greenIdx S _ _ _ = error "shouldn't arrive here!"-  {-# Inline greenIdx #-}--instance-  ( FirstSecondIdx ls (arr (Z:.Subword:.Subword) x) Subword-  , Elm ls Subword ~ RecElm (ls :!: ITbl m arr (Z:.Subword:.Subword) x) Subword-  , Element ls Subword-  ) => FirstSecondIdx (ls :!: ITbl m arr (Z:.Subword:.Subword) x) (arr (Z:.Subword:.Subword) x) Subword where-  greenIdx (ls :!: ITbl _ _ _ t _) _ t' e =-    case reallyUnsafePtrEquality# t t' of-      1# -> let ab = getIdx e in ab-      _  -> let g = getElm e in greenIdx ls (undefined :: Subword) t' g-  {-# Inline greenIdx   #-}--instance-  ( FirstSecondIdx ls (arr (Z:.Subword:.Subword) x) Subword-  , Elm ls Subword ~ RecElm (ls :!: Backtrack (ITbl mF arr (Z:.Subword:.Subword) x) mF mB r) Subword-  , Element ls Subword-  ) => FirstSecondIdx (ls :!: Backtrack (ITbl mF arr (Z:.Subword:.Subword) x) mF mB r) (arr (Z:.Subword:.Subword) x) Subword where-  greenIdx (ls :!: BtITbl _ t _) _ t' e =-    case reallyUnsafePtrEquality# t t' of-      1# -> let ab = getIdx e in ab-      _  -> let g = getElm e in greenIdx ls (undefined :: Subword) t' g-  {-# Inline greenIdx   #-}-
− ADP/Fusion/SynVar/Array/TermSymbol.hs 
@@ -1,110 +0,0 @@---- | TODO migrate instances to correct modules--module ADP.Fusion.SynVar.Array.TermSymbol where--import Data.Strict.Tuple hiding (snd)-import Data.Vector.Fusion.Stream.Size-import Data.Vector.Fusion.Util (delay_inline)-import Data.Vector.Fusion.Stream.Monadic-import Debug.Trace-import Prelude hiding (map,mapM)--import Data.PrimitiveArray hiding (map)--import ADP.Fusion.Base-import ADP.Fusion.SynVar.Array.Type-import ADP.Fusion.SynVar.Backtrack------ | TODO need to deal with @minSize@--instance-  ( Monad m-  , TerminalStream m a is-  , PrimArrayOps arr Subword x-  , Show x-  ) => TerminalStream m (TermSymbol a (ITbl m arr Subword x)) (is:.Subword) where-  terminalStream (a :| ITbl _ _ c t _) (sv:.IStatic _) (is:.ix@(Subword (i:.j)))-    = map (\ (S6 s (zi:.(Subword (a:.l))) (zo:._) is os e) ->-              let lj = subword l j-              in  {- traceShow (i,a,' ',l,j,t!lj) $ -} S6 s zi zo (is:.lj) (os:.subword 0 0) (e:.(t!lj)) )-    . iPackTerminalStream a sv (is:.ix)-  terminalStream (a :| ITbl _ _ c t _) (sv:.IVariable _) (is:.ix@(Subword (i:.j)))-    = flatten mk step Unknown . iPackTerminalStream a sv (is:.ix)-    where mk (S6 s (zi:.(Subword (_:.l))) (zo:._) is os e) = return (S6 s zi zo is os e :. l :. j - l) -- TODO minsize c !-          step (s6:.k:.z) | z >= 0 = do let S6 s zi zo is os e = s6-                                            l                  = j - z-                                            kl                 = subword k l-                                        return $ Yield (S6 s zi zo (is:.kl) (os:.subword 0 0) (e:.(t!kl))) (s6 :. k :. z-1)-                          | otherwise = return $ Done-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline terminalStream #-}--instance-  ( Monad mB-  , TerminalStream mB a is-  , PrimArrayOps arr Subword x-  ) => TerminalStream mB (TermSymbol a (Backtrack (ITbl mF arr Subword x) mF mB r)) (is:.Subword) where-  terminalStream (a :| BtITbl c t bt) (sv:.IStatic _) (is:.ix@(Subword (i:.j)))-    = mapM (\ (S6 s (zi:.(Subword (_:.l))) (zo:._) is os e) ->-              let lj = subword l j-                  hh = snd $ bounds t-              in  bt hh lj >>= \ ~bb -> return $ S6 s zi zo (is:.lj) (os:.subword 0 0) (e:.(t!lj, bb)) )-    . iPackTerminalStream a sv (is:.ix)-  terminalStream (a :| BtITbl c t bt) (sv:.IVariable _) (is:.ix@(Subword (i:.j)))-    = flatten mk step Unknown . iPackTerminalStream a sv (is:.ix)-    where mk (S6 s (zi:.(Subword (_:.l))) (zo:._) is os e) = return (S6 s zi zo is os e :. l :. j - l) -- TODO minsize c !-          step (s6:.k:.z) | z >= 0 = do let S6 s zi zo is os e = s6-                                            l                  = j - z-                                            kl                 = subword k l-                                            hh                 = snd $ bounds t-                                        bt hh kl >>= \ ~bb -> return $ Yield (S6 s zi zo (is:.kl) (os:.subword 0 0) (e:.(t!kl,bb))) (s6 :. k :. z-1)-                          | otherwise = return $ Done-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline terminalStream #-}---instance TermStaticVar (ITbl m arr Subword x) Subword where-  termStaticVar _ (IStatic   d) _ = IVariable d-  termStaticVar _ (IVariable d) _ = IVariable d-  termStreamIndex (ITbl _ _ _ _ _) (IStatic   d) (Subword (i:.j)) = subword i j -- TODO minSize handling !-  termStreamIndex (ITbl _ _ _ _ _) (IVariable d) (Subword (i:.j)) = subword i j -- TODO minsize handling-  {-# Inline [0] termStaticVar   #-}-  {-# Inline [0] termStreamIndex #-}--instance TermStaticVar (Backtrack (ITbl mF arr Subword x) mF mB r) Subword where-  termStaticVar _ (IStatic   d) _ = IVariable d-  termStaticVar _ (IVariable d) _ = IVariable d-  termStreamIndex (BtITbl _ _ _) (IStatic   d) (Subword (i:.j)) = subword i j -- TODO minSize handling !-  termStreamIndex (BtITbl _ _ _) (IVariable d) (Subword (i:.j)) = subword i j -- TODO minsize handling-  {-# Inline [0] termStaticVar   #-}-  {-# Inline [0] termStreamIndex #-}---{--  mkStream (ls :!: ITbl _ _ c t _) (IVariable ()) hh (Subword (i:.j))-    = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))-    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - minSize c)-          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s-                                        l              = j - z-                                        kl             = subword k l-                                    return $ Yield (ElmITbl (t ! kl) kl (subword 0 0) s) (s:. z-1)-                      | otherwise = return $ Done--  terminalStream (a:|Chr f v) (sv:.IVariable _) (is:.ix@(Subword (i:.j)))-    = S.map (\(S6 s (zi:.Subword (_:.l)) (zo:._) is os e) -> S6 s zi zo (is:.subword l (l+1)) (os:.subword 0 0) (e:.f v l))-    . iPackTerminalStream a sv (is:.ix)-  {-# Inline terminalStream #-}--instance TermStaticVar (Chr r x) Subword where-  termStaticVar _ sv _ = sv-  termStreamIndex _ _ (Subword (i:.j)) = subword i (j-1)-  {-# Inline [0] termStaticVar   #-}-  {-# Inline [0] termStreamIndex #-}---}-
− ADP/Fusion/SynVar/Array/Type.hs 
@@ -1,154 +0,0 @@--module ADP.Fusion.SynVar.Array.Type where--import Data.Strict.Tuple hiding (uncurry,snd)-import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM)-import Debug.Trace-import Prelude hiding (map,head,mapM)--import Data.PrimitiveArray hiding (map)--import ADP.Fusion.Base-import ADP.Fusion.SynVar.Backtrack-import ADP.Fusion.SynVar.Axiom-import ADP.Fusion.SynVar.Indices------ | Immutable table.--data ITbl m arr i x where-  ITbl :: { iTblBigOrder    :: !Int-          , iTblLittleOrder :: !Int-          , iTblConstraint  :: !(TblConstraint i)-          , iTblArray       :: !(arr i x)-          , iTblFun         :: !(i -> i -> m x)-          } -> ITbl m arr i x--instance Build (ITbl m arr i x)--type instance TermArg (TermSymbol a (ITbl m arr i x)) = TermArg a :. x--instance GenBacktrackTable (ITbl mF arr i x) mF mB r where-  data Backtrack (ITbl mF arr i x) mF mB r = BtITbl !(TblConstraint i) !(arr i x) (i -> i -> mB [r])-  type BacktrackIndex (ITbl mF arr i x) = i-  toBacktrack (ITbl _ _ c arr _) _ bt = BtITbl c arr bt-  {-# Inline toBacktrack #-}--type instance TermArg (TermSymbol a (Backtrack (ITbl mF arr i x) mF mB r)) = TermArg a :. (x,[r])--instance-  ( Monad m-  , PrimArrayOps arr i x-  , IndexStream i-  ) => Axiom (ITbl m arr i x) where-  type AxiomStream (ITbl m arr i x) = m x-  axiom (ITbl _ _ c arr _) = do-    k <- (head . uncurry streamDown) $ bounds arr-    return $ arr ! k-  {-# Inline axiom #-}--instance-  ( Monad mB-  , PrimArrayOps arr i x-  , IndexStream i-  ) => Axiom (Backtrack (ITbl mF arr i x) mF mB r) where-  type AxiomStream (Backtrack (ITbl mF arr i x) mF mB r) = mB [r]-  axiom (BtITbl c arr bt) = do-    h <- (head . uncurry streamDown) $ bounds arr-    bt (snd $ bounds arr) h-  {-# Inline axiom #-}--instance Element ls i => Element (ls :!: ITbl m arr j x) i where-  data Elm    (ls :!: ITbl m arr j x) i = ElmITbl !x !i !i !(Elm ls i)-  type Arg    (ls :!: ITbl m arr j x)   = Arg ls :. x-  type RecElm (ls :!: ITbl m arr j x) i = Elm ls i-  getArg (ElmITbl x _ _ ls) = getArg ls :. x-  getIdx (ElmITbl _ i _ _ ) = i-  getOmx (ElmITbl _ _ o _ ) = o-  getElm (ElmITbl _ _ _ ls) = ls-  {-# Inline getArg #-}-  {-# Inline getIdx #-}-  {-# Inline getOmx #-}-  {-# Inline getElm #-}--deriving instance (Show i, Show (Elm ls i), Show x) => Show (Elm (ls :!: ITbl m arr j x) i)--instance Element ls i => Element (ls :!: (Backtrack (ITbl mF arr j x) mF mB r)) i where-  data Elm    (ls :!: (Backtrack (ITbl mF arr j x) mF mB r)) i = ElmBtITbl !x [r] !i !i !(Elm ls i)-  type Arg    (ls :!: (Backtrack (ITbl mF arr j x) mF mB r))   = Arg ls :. (x, [r])-  type RecElm (ls :!: (Backtrack (ITbl mF arr j x) mF mB r)) i = Elm ls i-  getArg (ElmBtITbl x s _ _ ls) = getArg ls :. (x,s)-  getIdx (ElmBtITbl _ _ i _ _ ) = i-  getOmx (ElmBtITbl _ _ _ o _ ) = o-  getElm (ElmBtITbl _ _ _ _ ls) = ls-  {-# Inline getArg #-}-  {-# Inline getIdx #-}-  {-# Inline getOmx #-}-  {-# Inline getElm #-}--instance (Show x, Show i, Show (Elm ls i)) => Show (Elm (ls :!: (Backtrack (ITbl mF arr i x) mF mB r)) i) where-  show (ElmBtITbl x _ i o s) = show (x,i,o) ++ " " ++ show s--instance-  ( Monad m-  , Element ls (is:.i)-  , TableStaticVar (is:.i)-  , TableIndices (is:.i)-  , MkStream m ls (is:.i)-  , PrimArrayOps arr (is:.i) x-  ) => MkStream m (ls :!: ITbl m arr (is:.i) x) (is:.i) where-  mkStream (ls :!: ITbl _ _ c t _) vs lu is-    = map (\(S5 s _ _ i o) -> ElmITbl (t ! i) i o s)-    . tableIndices c vs is-    . map (\s -> S5 s Z Z (getIdx s) (getOmx s))-    $ mkStream ls (tableStaticVar vs is) lu (tableStreamIndex c vs is)-  {-# Inline mkStream #-}--instance-  ( Monad mB-  , Element ls (is:.i)-  , TableStaticVar (is:.i)-  , TableIndices (is:.i)-  , MkStream mB ls (is:.i)-  , PrimArrayOps arr (is:.i) x-  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (is:.i) x) mF mB r) (is:.i) where-  mkStream (ls :!: BtITbl c t bt) vs us is-    = mapM (\(S5 s _ _ i o) -> bt us i >>= \ ~bb -> return $ ElmBtITbl (t ! i) (bb {-bt us i-}) i o s)-    . tableIndices c vs is-    . map (\s -> S5 s Z Z (getIdx s) (getOmx s))-    $ mkStream ls (tableStaticVar vs is) us (tableStreamIndex c vs is)-  {-# Inline mkStream #-}--instance-  ( Monad m-  , Element ls (Outside (is:.i))-  , TableStaticVar (Outside (is:.i))-  , TableIndices (Outside (is:.i))-  , MkStream m ls (Outside (is:.i))-  , PrimArrayOps arr (Outside (is:.i)) x-  , Show (is:.i)-  ) => MkStream m (ls :!: ITbl m arr (Outside (is:.i)) x) (Outside (is:.i)) where-  mkStream (ls :!: ITbl _ _ c t _) vs lu is-    = map (\(S5 s _ _ i o) -> ElmITbl (t ! o) i o s)-    . tableIndices c vs is-    . map (\s -> S5 s Z Z (getIdx s) (getOmx s))-    $ mkStream ls (tableStaticVar vs is) lu (tableStreamIndex c vs is)-  {-# Inline mkStream #-}--instance-  ( Monad mB-  , Element ls (Outside (is:.i))-  , TableStaticVar (Outside (is:.i))-  , TableIndices (Outside (is:.i))-  , MkStream mB ls (Outside (is:.i))-  , PrimArrayOps arr (Outside (is:.i)) x-  , Show (is:.i)-  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (Outside (is:.i)) x) mF mB r) (Outside (is:.i)) where-  mkStream (ls :!: BtITbl c t bt) vs us is-    = mapM (\(S5 s _ _ i o) -> bt us o >>= \bb -> return $ ElmBtITbl (t ! o) (bb {-bt us o-}) i o s)-    . tableIndices c vs is-    . map (\s -> S5 s Z Z (getIdx s) (getOmx s))-    $ mkStream ls (tableStaticVar vs is) us (tableStreamIndex c vs is)-  {-# Inline mkStream #-}-
− ADP/Fusion/SynVar/Axiom.hs 
@@ -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-
− ADP/Fusion/SynVar/Backtrack.hs 
@@ -1,28 +0,0 @@---- | Wrap forward tables in such a way as to allow backtracking via--- algebras.--module ADP.Fusion.SynVar.Backtrack where--import Data.Vector.Fusion.Stream.Monadic (Stream)--import ADP.Fusion.Base------ |------ TODO this should go into @ADP.Fusion.Table.Backtrack@, more than just--- tabulated syntactic vars are going to use it.------ NOTE You probably need to give the @monad morphism@ between @mF@ and--- @mB@ so as to be able to extract forward results in the backtracking--- phase.--class GenBacktrackTable t (mF :: * -> *) (mB :: * -> *) r where-  data Backtrack t (mF :: * -> *) (mB :: * -> *) r :: *-  type BacktrackIndex t :: *-  toBacktrack :: t -> (forall a . mF a -> mB a) -> (BacktrackIndex t -> BacktrackIndex t -> mB [r]) -> Backtrack t mF mB r--instance Build (Backtrack t mF mB r)-
− ADP/Fusion/SynVar/Fill.hs 
@@ -1,197 +0,0 @@--module ADP.Fusion.SynVar.Fill where--import           Control.Monad.Morph (hoist, MFunctor (..))-import           Control.Monad.Primitive (PrimMonad (..))-import           Control.Monad.ST-import           Control.Monad.Trans.Class (lift, MonadTrans (..))-import           Data.Vector.Fusion.Util (Id(..))-import           GHC.Exts (inline)-import qualified Data.Vector.Fusion.Stream.Monadic as SM-import           System.IO.Unsafe-import           Control.Monad (when,forM_)-import           Data.List (nub,sort)-import qualified Data.Vector.Unboxed as VU-import           Data.Proxy--import           Data.PrimitiveArray--import           ADP.Fusion.SynVar.Array -- TODO we want to keep only classes in here, move instances to the corresponding modules--import           Debug.Trace------ * Specialized table-filling wrapper for 'MTbl's------ TODO table-filling does /not/ work for single-dimensional stuff---- | Run and freeze 'MTbl's. Since actually running the table-filling part--- is usually the last thing to do, we can freeze as well.--runFreezeMTbls ts = do-    unsafeRunFillTables $ expose ts-    freezeTables        $ onlyTables ts-{-# INLINE runFreezeMTbls #-}------ * Expose inner mutable tables---- | Expose the actual mutable table with an 'MTbl'. (Should be temporary--- until 'MTbl's get a more thorough treatment for auto-filling.--class ExposeTables t where-    type TableFun t   :: *-    type OnlyTables t :: *-    expose     :: t -> TableFun t-    onlyTables :: t -> OnlyTables t--instance ExposeTables Z where-    type TableFun Z   = Z-    type OnlyTables Z = Z-    expose     Z = Z-    onlyTables Z = Z-    {-# INLINE expose #-}-    {-# INLINE onlyTables #-}------ | A vanilla context-free grammar--data CFG---- | This grammar is a multi-cfg in a monotone setting--data MonotoneMCFG----- * Unsafely mutate 'ITbls' and similar tables in the forward phase.---- | Mutate a cell in a stack of syntactic variables.------ TODO generalize to monad morphism via @mmorph@ package. This will allow--- more interesting @mrph@ functions that can, for example, track some--- state in the forward phase. (Note that this can be dangerous, we do--- /not/ want to have this state influence forward results, unless that can--- be made deterministic, or we'll break Bellman)--class MutateCell (h :: *) (s :: *) (im :: * -> *) (om :: * -> *) i where-  mutateCell :: Proxy h -> Int -> Int -> (forall a . im a -> om a) -> s -> i -> i -> om ()---- |--class MutateTables (h :: *) (s :: *) (im :: * -> *) (om :: * -> *) where-  mutateTables :: Proxy h -> (forall a . im a -> om a) -> s -> om s--class TableOrder (s :: *) where-  tableLittleOrder :: s -> [Int]-  tableBigOrder :: s -> [Int]--instance TableOrder Z where-  tableLittleOrder Z = []-  tableBigOrder Z = []-  {-# Inline tableLittleOrder #-}-  {-# Inline tableBigOrder #-}--instance (TableOrder ts) => TableOrder (ts:.ITbl im arr i x) where-  tableLittleOrder (ts:.ITbl _ tlo _ _ _) = tlo : tableLittleOrder ts-  tableBigOrder    (ts:.ITbl tbo _ _ _ _) = tbo : tableBigOrder ts-  {-# Inline tableLittleOrder #-}-  {-# Inline tableBigOrder #-}---- ** individual instances for filling a *single cell*--instance-  ( PrimArrayOps  arr i x-  , MPrimArrayOps arr i x-  , MutateCell CFG ts im om i-  , PrimMonad om-  , Show x, Show i-  ) => MutateCell CFG (ts:.ITbl im arr i x) im om i where-  mutateCell h bo lo mrph (ts:.ITbl tbo tlo c arr f) lu i = do-    mutateCell h bo lo mrph ts lu i-    when (bo==tbo && lo==tlo) $ do-      marr <- unsafeThaw arr-      z <- (inline mrph) $ f lu i-      writeM marr i z-  {-# INLINE mutateCell #-}--type ZS2 = Z:.Subword:.Subword--instance-  ( PrimArrayOps  arr ZS2 x-  , MPrimArrayOps arr ZS2 x-  , MutateCell MonotoneMCFG ts im om ZS2-  , PrimMonad om-  ) => MutateCell MonotoneMCFG (ts:.ITbl im arr ZS2 x) im om ZS2 where-  mutateCell h bo lo mrph (ts:.ITbl tbo tlo c arr f) lu iklj@(Z:.Subword (i:.k):.Subword(l:.j)) = do-    mutateCell h bo lo mrph ts lu iklj-    when (bo==tbo && lo==tlo && k<=l) $ do-      marr <- unsafeThaw arr-      z <- (inline mrph) $ f lu iklj-      writeM marr iklj z-  {-# INLINE mutateCell #-}--instance-  ( PrimArrayOps arr Subword x-  , MPrimArrayOps arr Subword x-  , MutateCell h ts im om (Z:.Subword:.Subword)-  , PrimMonad om-  ) => MutateCell h (ts:.ITbl im arr Subword x) im om (Z:.Subword:.Subword) where-  mutateCell h bo lo mrph (ts:.ITbl tbo tlo c arr f) lu@(Z:.Subword (l:._):.Subword(_:.u)) ix@(Z:.Subword (i1:.j1):.Subword (i2:.j2)) = do-    mutateCell h bo lo mrph ts lu ix-    when (bo==tbo && lo==tlo && i1==i2 && j1==j2) $ do-      let i = i1-      let j = j1-      marr <- unsafeThaw arr-      z <- (inline mrph) $ f (subword l u) (subword i j)-      writeM marr (subword i j) z-  {-# Inline mutateCell #-}------ ** individual instances for filling a complete table and extracting the--- bounds--instance-  ( Monad om-  , MutateCell h (ts:.ITbl im arr i x) im om i-  , PrimArrayOps arr i x-  , Show i-  , IndexStream i-  , TableOrder (ts:.ITbl im arr i x)-  ) => MutateTables h (ts:.ITbl im arr i x) im om where-  mutateTables h mrph tt@(_:.ITbl _ _ _ arr _) = do-    let (from,to) = bounds arr-    -- TODO (1) find the set of orders for the synvars-    let !tbos = VU.fromList . nub . sort $ tableBigOrder tt-    let !tlos = VU.fromList . nub . sort $ tableLittleOrder tt-    VU.forM_ tbos $ \bo ->-      flip SM.mapM_ (streamUp from to) $ \k ->-        VU.forM_ tlos $ \lo ->-          --traceShow (bo,k,lo) $-          mutateCell h bo lo (inline mrph) tt to k-    return tt-  {-# INLINE mutateTables #-}--instance-  ( Monad om-  ) => MutateCell p Z im om i where-  mutateCell _ _ _ _ Z _ _ = return ()-  {-# INLINE mutateCell #-}---- | Default table filling, assuming that the forward monad is just @IO@.------ TODO generalize to @MonadIO@ or @MonadPrim@.--mutateTablesDefault :: MutateTables CFG t Id IO => t -> t-mutateTablesDefault t = unsafePerformIO $ mutateTables (Proxy :: Proxy CFG) (return . unId) t-{-# INLINE mutateTablesDefault #-}---- | Mutate tables, but observe certain hints. We use this for monotone--- mcfgs for now.--mutateTablesWithHints :: MutateTables h t Id IO => Proxy h -> t -> t-mutateTablesWithHints h t = unsafePerformIO $ mutateTables h (return . unId) t-
− ADP/Fusion/SynVar/Indices.hs 
@@ -1,144 +0,0 @@---- | With 'tableIndices' we create a stream of legal indices for this table. We--- need 'tableIndices' in multi-dimensional tables as the type of the--- multi-dimensional indices is generic.--module ADP.Fusion.SynVar.Indices where--import Data.Vector.Fusion.Stream.Size (Size(Unknown))-import Data.Vector.Fusion.Stream.Monadic (flatten,map,Stream, Step(..))-import Prelude hiding (map)--import Data.PrimitiveArray hiding (map)--import ADP.Fusion.Base----class TableIndices i where-  tableIndices :: (Monad m) => TblConstraint i -> Context i -> i -> Stream m (S5 z j j i i) -> Stream m (S5 z j j i i)--instance TableIndices Z where-  tableIndices _ _ _ = id-  {-# INLINE tableIndices #-}--instance TableIndices (Outside Z) where-  tableIndices _ _ _ = id-  {-# INLINE tableIndices #-}--instance TableIndices is => TableIndices (is:.Subword) where-  tableIndices (cs:._) (vs:.IStatic _) (ixs:.Subword (i:.j))-    = map (\(S5 s (zi:.Subword (_:.l)) (zo:._) is os) -> S5 s zi zo (is:.subword l j) (os:.subword 0 0))-    . tableIndices cs vs ixs-    . map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)-  -- TODO ? using the defns in TermSymbol.hs for Array syns?-  {--  tableIndices (cs:._) (vs:.IVariable _) (ixs:.Subword (i:.j))-    = map (\(S5 s (zi:.Subword (_:.l)) (zo:._) is os) -> S5 s zi zo (is:.subword l j) (os:.subword 0 0))-    . tableIndices cs vs ixs-    . map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)-  -}-  -- TODO minsize handling ? constraint handling?-  tableIndices (cs:._) (vs:.IVariable _) (ixs:.Subword (i:.j))-    = flatten mk step Unknown-    . tableIndices cs vs ixs-    . map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)-    where mk (S5 s (zi:.Subword (_:.l)) (zo:._) is os) = return (S5 s zi zo is os :. l :. j - l)-          step (s5:.k:.z) | z >= 0 = do let S5 s zi zo is os = s5-                                            l                = j - z-                                            kl               = subword k l-                                        return $ Yield (S5 s zi zo (is:.kl) (os:.subword 0 0)) (s5 :. k :. z-1)-                          | otherwise = return $ Done-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline tableIndices #-}--{--    where mk (S6 s (zi:.(Subword (_:.l))) (zo:._) is os e) = return (S6 s zi zo is os e :. l :. j - l) -- TODO minsize c !-          step (s6:.k:.z) | z >= 0 = do let S6 s zi zo is os e = s6-                                            l                  = j - z-                                            kl                 = subword k l-                                        return $ Yield (S6 s zi zo (is:.kl) (os:.subword 0 0) (e:.(t!kl))) (s6 :. k :. z-1)-                          | otherwise = return $ Done--}--{--  tableIndices (cs:.c) (vs:.Static) (is:.Subword (i:.j))-    = S.map (\(Tr s (x:.Subword (_:.l)) ys) -> Tr s x (is:.subword l j)) -- constraint handled: tableStreamIndex-    . tableIndices cs vs is-    . S.map moveIdxTr-  tableIndices (cs:.OnlyZero) _ _ = error "write me"-  tableIndices (cs:.c) (vs:.Variable _ Nothing) (is:.Subword (i:.j))-    = S.flatten mk step Unknown-    . tableIndices cs vs is-    . S.map moveIdxTr-    where mk (Tr s (y:.Subword (_:.l)) xs) = return $ Pn s y xs l (j-l-minSize c)-          step (Pn s y xs k z)-            | z>= 0     = return $ S.Yield (Tr s y (xs:.subword k (j-z))) (Pn s y xs k (z-1))-            | otherwise = return $ S.Done-          {-# INLINE [1] mk   #-}-          {-# INLINE [1] step #-}-  {-# INLINE tableIndices #-}--}---- | TODO I think we need to check @cs:.c@ here------ TODO yes, handle @Empty@ / @NonEmpty@ !!!--instance TableIndices is => TableIndices (is:.PointL) where-  tableIndices (cs:._) (vs:.IStatic _) (is:.PointL j)-    = map (\(S5 s (zi:.PointL _) (zo:.PointL _) is os) -> S5 s zi zo (is:.PointL j) (os:.PointL 0)) -- constraint handled: tableStreamIndex-    . tableIndices cs vs is-    . map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)-  tableIndices (cs:._) (vs:.IVariable d) (is:.PointL j)-    = flatten mk step Unknown-    . tableIndices cs vs is-    . map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)-    where mk s@(S5 _ (_:.PointL k) _ _ _) = return (s :. k)-          step (ss@(S5 s (zi:._) (zo:._) is os) :. k)-            | k > j     = return $ Done-            | otherwise = return $ Yield (S5 s zi zo (is:.PointL k) (os:.PointL 0)) (ss :. k+1)-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-  TODO re-add later-  tableIndices (cs:.OnlyZero) _ _ = error "write me"-  tableIndices (cs:.c) (vs:.IVariable) (is:.PointL j)-    = flatten mk step Unknown-    . tableIndices cs vs is-    . map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)-    where mk (S5 s (zi:.PointL l) (zo:._) is os) = return $ S6 s zi zo is os (j-l-minSize c)-          step (S6 s zi zo is os x)-            | x >= 0    = return $ Yield (S5 s zi zo (is:.PointL (j-x)) (os:.PointL 0)) (S6 s zi zo is os (x-1))-            | otherwise = return $ Done-          {-# Inline [1] mk   #-}-          {-# Inline [1] step #-}-  -}-  {-# Inline tableIndices #-}--instance TableIndices (Outside is) => TableIndices (Outside (is:.PointL)) where-  tableIndices (cs:.c) (vs:.OStatic d) (O (is:.PointL j))-    = map (\(S5 s (zi:.PointL i) (zo:.PointL o) (O is) (O os)) -> S5 s zi zo (O (is:.PointL i)) (O (os:.PointL o))) -- constraint handled: tableStreamIndex-    . tableIndices cs vs (O is)-    . map (\(S5 s zi zo (O (is:.i)) (O (os:.o))) -> S5 s (zi:.i) (zo:.o) (O is) (O os))-  {-# Inline tableIndices #-}--{--instance TableIndices is => TableIndices (is:.PointR) where-  tableIndices (cs:.c) (vs:.Static) (is:.PointR (i:.j))-    = S.map (\(Tr s (x:.PointR (_:.l)) ys) -> Tr s x (is:.pointR l j)) -- constraint handled: tableStreamIndex-    . tableIndices cs vs is-    . S.map moveIdxTr-  tableIndices (cs:.OnlyZero) _ _ = error "write me"-  tableIndices (cs:.c) (vs:.Variable _ Nothing) (is:.PointR (i:.j))-    = S.flatten mk step Unknown-    . tableIndices cs vs is-    . S.map moveIdxTr-    where mk (Tr s (y:.PointR (_:.l)) xs) = return $ Pn s y xs l (j-l-minSize c)-          step (Pn s y xs k z)-            | z>= 0     = return $ S.Yield (Tr s y (xs:.pointR k (j-z))) (Pn s y xs k (z-1))-            | otherwise = return $ S.Done-          {-# INLINE [1] mk   #-}-          {-# INLINE [1] step #-}-  {-# INLINE tableIndices #-}--}-
− ADP/Fusion/SynVar/Recursive.hs 
@@ -1,74 +0,0 @@--module ADP.Fusion.SynVar.Recursive-  ( module ADP.Fusion.SynVar.Recursive.Type-  , module ADP.Fusion.SynVar.Recursive.Point-  , module ADP.Fusion.SynVar.Recursive.Subword-  ) where--import ADP.Fusion.SynVar.Recursive.Point-import ADP.Fusion.SynVar.Recursive.Subword-import ADP.Fusion.SynVar.Recursive.Type---{------ * Instances--{--instance ModifyConstraint (IRec m Subword x) where-  toNonEmpty (IRec _ iF iT f) = IRec NonEmpty iF iT f-  toEmpty    (IRec _ iF iT f) = IRec EmptyOk  iF iT f-  {-# INLINE toNonEmpty #-}-  {-# INLINE toEmpty    #-}--instance-  ( Monad m-  , Element ls Subword-  , MkStream m ls Subword-  ) => MkStream m (ls :!: IRec m Subword x) Subword where-  mkStream (ls :!: IRec c _ _ f) Static lu (Subword (i:.j))-    = let ms = minSize c in ms `seq`-    S.mapM (\s -> let Subword (_:.l) = getIdx s-                    in  f lu (subword l j) >>= \z -> return $ ElmIRec z (subword l j) s)-    $ mkStream ls (Variable Check Nothing) lu (subword i $ j - ms)-  mkStream (ls :!: IRec c _ _ f) (Variable _ Nothing) lu (Subword (i:.j))-    = let ms = minSize c-          mk s = let (Subword (_:.l)) = getIdx s in return (s:.j-l-ms)-          step (s:.z)-            | z>=0      = do let (Subword (_:.k)) = getIdx s-                             y <- f lu (subword k (j-z))-                             return $ S.Yield (ElmIRec y (subword k $ j-z) s) (s:.z-1)-            | otherwise = return $ S.Done-          {-# INLINE [1] mk   #-}-          {-# INLINE [1] step #-}-      in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (subword i j)-  {-# INLINE mkStream #-}--instance-  ( Monad mB-  , Element ls Subword-  , MkStream mB ls Subword-  ) => MkStream mB (ls :!: BT (IRec mF Subword x) mF mB r) Subword where-  mkStream (ls :!: BtIRec c _ _ f bt) Static lu (Subword (i:.j))-    = let ms = minSize c in ms `seq`-      S.mapM (\s -> let (Subword (_:.l)) = getIdx s-                        ix               = subword l j-                    in  f lu ix >>= \fx -> return $ ElmBtIRec fx (bt lu ix) ix s)-      $ mkStream ls (Variable Check Nothing) lu (subword i $ j-ms)-  mkStream (ls :!: BtIRec c _ _ f bt) (Variable _ Nothing) lu (Subword (i:.j))-    = let ms = minSize c-          mk s = let Subword (_:.l) = getIdx s in return (s:.j-l-ms)-          step (s:.z)-            | z>=0      = do let Subword (_:.k) = getIdx s-                                 ix             = subword k (j-z)-                             f lu ix >>= \fx -> return $ S.Yield (ElmBtIRec fx (bt lu ix) ix s) (s:.z-1)-            | otherwise = return $ S.Done-          {-# INLINE [1] mk   #-}-          {-# INLINE [1] step #-}-      in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (subword i j)-  {-# INLINE mkStream #-}--}---}-
− ADP/Fusion/SynVar/Recursive/Point.hs 
@@ -1,3 +0,0 @@--module ADP.Fusion.SynVar.Recursive.Point where-
− ADP/Fusion/SynVar/Recursive/Subword.hs 
@@ -1,13 +0,0 @@--module ADP.Fusion.SynVar.Recursive.Subword where--import Data.Strict.Tuple-import Data.Vector.Fusion.Stream.Monadic-import Data.Vector.Fusion.Stream.Size-import Data.Vector.Fusion.Util (delay_inline)-import Debug.Trace-import Prelude hiding (map)--import ADP.Fusion.Base-import ADP.Fusion.SynVar.Recursive.Type-import ADP.Fusion.SynVar.Backtrack
− ADP/Fusion/SynVar/Recursive/Type.hs 
@@ -1,80 +0,0 @@--module ADP.Fusion.SynVar.Recursive.Type where--import Data.Strict.Tuple ((:!:)(..))-import Data.Vector.Fusion.Stream.Monadic (Stream,head)-import Prelude hiding (head)--import Data.PrimitiveArray hiding (map)--import ADP.Fusion.Base-import ADP.Fusion.SynVar.Backtrack-import ADP.Fusion.SynVar.Axiom----data IRec m i x where-  IRec :: { iRecConstraint  :: !(TblConstraint i)-          , iRecFrom        :: !i-          , iRecTo          :: !i-          , iRecFun         :: !(i -> i -> m x)-          } -> IRec m i x----instance Build (IRec m i x)--instance GenBacktrackTable (IRec mF i x) mF mB r where-  data Backtrack (IRec mF i x) mF mB r = BtIRec !(TblConstraint i) !i !i (i -> i -> mB x) (i -> i -> mB [r]) -- (Stream mB r))-  type BacktrackIndex (IRec mF i x)         = i-  toBacktrack (IRec c iF iT f) mrph bt = BtIRec c iF iT (\lu i -> mrph $ f lu i) bt-  {-# INLINE toBacktrack #-}----instance-  ( Monad m-  , IndexStream i-  ) => Axiom (IRec m i x) where-  type AxiomStream (IRec m i x) = m x-  axiom (IRec c l h fun) = do-    k <- (head . uncurry streamDown) (l,h)-    fun h k-  {-# Inline axiom #-}--instance-  ( Monad mB-  , IndexStream i-  ) => Axiom (Backtrack (IRec mF i x) mF mB r) where-  type AxiomStream (Backtrack (IRec mF i x) mF mB r) = mB [r] -- (Stream mB r)-  axiom (BtIRec c l h fun btfun) = do-    k <- (head . uncurry streamDown) (l,h)-    btfun h k-  {-# Inline axiom #-}----instance Element ls i => Element (ls :!: IRec m i x) i where-  data Elm (ls :!: IRec m i x) i = ElmIRec !x !i !i !(Elm ls i)-  type Arg (ls :!: IRec m i x)   = Arg ls :. x-  getArg (ElmIRec x _ _ ls) = getArg ls :. x-  getIdx (ElmIRec _ i _ _ ) = i-  getOmx (ElmIRec _ _ o _ ) = o-  {-# Inline getArg #-}-  {-# Inline getIdx #-}-  {-# Inline getOmx #-}--instance Element ls i => Element (ls :!: (Backtrack (IRec mF i x) mF mB r)) i where-  data Elm (ls :!: (Backtrack (IRec mF i x) mF mB r)) i = ElmBtIRec !x !(mB (Stream mB r)) !i !i !(Elm ls i)-  type Arg (ls :!: (Backtrack (IRec mF i x) mF mB r))   = Arg ls :. (x, mB (Stream mB r))-  getArg (ElmBtIRec x s _ _ ls) = getArg ls :. (x,s)-  getIdx (ElmBtIRec _ _ i _ _ ) = i-  getOmx (ElmBtIRec _ _ _ o _ ) = o-  {-# Inline getArg #-}-  {-# Inline getIdx #-}-  {-# Inline getOmx #-}------ TODO write multi-tape instances-
− ADP/Fusion/SynVar/Split.hs 
@@ -1,11 +0,0 @@---- | Split syntactic variables for multi-cfg dynamic programs.--module ADP.Fusion.SynVar.Split-  ( module ADP.Fusion.SynVar.Split.Type-  , module ADP.Fusion.SynVar.Split.Subword-  ) where--import ADP.Fusion.SynVar.Split.Subword-import ADP.Fusion.SynVar.Split.Type-
− ADP/Fusion/SynVar/Split/Subword.hs 
@@ -1,125 +0,0 @@--module ADP.Fusion.SynVar.Split.Subword where--import Data.Strict.Tuple-import Data.Proxy-import Data.Vector.Fusion.Stream.Monadic-import Data.Vector.Fusion.Stream.Size-import Data.Vector.Fusion.Util (delay_inline)-import Debug.Trace-import GHC.TypeLits-import Prelude hiding (map,mapM)-import Data.Type.Equality--import Data.PrimitiveArray hiding (map)--import ADP.Fusion.Base-import ADP.Fusion.SynVar.Array.Type-import ADP.Fusion.SynVar.Backtrack-import ADP.Fusion.SynVar.Split.Type------ * 'Fragment' and 'Final' instances for 'Split' / 'ITbl'.--instance-  ( Monad m-  , Element ls Subword-  , MkStream m ls Subword-  ) => MkStream m (ls :!: Split uId Fragment (ITbl m arr j x)) Subword where-  mkStream (ls :!: Split _) (IStatic ()) hh (Subword (i:.j))-    = map (\s -> let (Subword (_:.l)) = getIdx s-                 in  ElmSplitITbl Proxy () (subword l j) (subword 0 0) s)-    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO (see TODO in @Split@) - minSize c))-  mkStream (ls :!: Split _) (IVariable ()) hh (Subword (i:.j))-    = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO (see above) - minSize c))-    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l) -- TODO - minSize c)-          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s-                                        l              = j - z-                                        kl             = subword k l-                                    return $ Yield (ElmSplitITbl Proxy () kl (subword 0 0) s) (s:. z-1)-                      | otherwise = return $ Done-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline mkStream #-}--instance-  ( Monad m-  , Element ls Subword-  , MkStream m ls Subword-  , SplitIxCol uId (SameSid uId (Elm ls Subword)) (Elm ls Subword)-  , (SplitIxTy uId (SameSid uId (Elm ls Subword)) (Elm ls Subword) :. Subword) ~ mix-  ,  (PrimArrayOps arr (SplitIxTy uId (SameSid uId (Elm ls Subword)) (Elm ls Subword) :. Subword) x)-  ) => MkStream m (ls :!: Split uId Final (ITbl m arr mix x)) Subword where-  mkStream (ls :!: Split (ITbl _ _ c t elm)) (IStatic ()) hh (Subword (i:.j))-    = map (\s -> let (Subword (_:.l)) = getIdx s-                     fmbkm :: mix = collectIx (Proxy :: Proxy uId) s :. subword l j-                 in  ElmSplitITbl Proxy (t ! fmbkm) (subword l j) (subword 0 0) s)-    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO (see TODO in @Split@) - minSize c))-  mkStream (ls :!: Split (ITbl _ _ c t _)) (IVariable ()) hh (Subword (i:.j))-    = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO - minSize c))-    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l) -- TODO - minSize c)-          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s-                                        l              = j - z-                                        kl             = subword k l-                                        fmbkm :: mix   = collectIx (Proxy :: Proxy uId) s :. kl-                                    return $ Yield (ElmSplitITbl Proxy (t ! fmbkm) kl (subword 0 0) s) (s:. z-1)-                      | otherwise = return $ Done-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline mkStream #-}------ * 'Fragment' and 'Final' instances for 'Split' / @Backtrack@ 'ITbl'.--instance-  ( Monad mB-  , Element ls Subword-  , MkStream mB ls Subword-  ) => MkStream mB (ls :!: Split uId Fragment (Backtrack (ITbl mF arr j x) mF mB r)) Subword where-  mkStream (ls :!: Split _) (IStatic ()) hh (Subword (i:.j))-    = map (\s -> let (Subword (_:.l)) = getIdx s-                 in  ElmSplitBtITbl Proxy () (subword l j) (subword 0 0) s)-    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO (see TODO in @Split@) - minSize c))-  mkStream (ls :!: Split _) (IVariable ()) hh (Subword (i:.j))-    = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO (see above) - minSize c))-    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l) -- TODO - minSize c)-          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s-                                        l              = j - z-                                        kl             = subword k l-                                    return $ Yield (ElmSplitBtITbl Proxy () kl (subword 0 0) s) (s:. z-1)-                      | otherwise = return $ Done-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline mkStream #-}--instance-  ( Monad mB-  , Element ls Subword-  , MkStream mB ls Subword-  , SplitIxCol uId (SameSid uId (Elm ls Subword)) (Elm ls Subword)-  , (SplitIxTy uId (SameSid uId (Elm ls Subword)) (Elm ls Subword) :. Subword) ~ mix-  , (PrimArrayOps arr (SplitIxTy uId (SameSid uId (Elm ls Subword)) (Elm ls Subword) :. Subword) x)-  ) => MkStream mB (ls :!: Split uId Final (Backtrack (ITbl mF arr mix x) mF mB r)) Subword where-  mkStream (ls :!: Split (BtITbl c t bt)) (IStatic ()) hh (Subword (i:.j))-    = mapM (\s -> let (Subword (_:.l)) = getIdx s-                      lj               = subword l j-                      fmbkm :: mix     = collectIx (Proxy :: Proxy uId) s :. lj-                      (_,hhhh)         = bounds t -- This is an ugly hack, but we need a notation of higher bound from somewhere-                  in  bt hhhh fmbkm >>= \ ~bb -> return $ ElmSplitBtITbl Proxy (t ! fmbkm,bb) lj (subword 0 0) s)-    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO (see TODO in @Split@) - minSize c))-  mkStream (ls :!: Split (BtITbl c t bt)) (IVariable ()) hh (Subword (i:.j))-    = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO - minSize c))-    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l) -- TODO - minSize c)-          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s-                                        l              = j - z-                                        kl             = subword k l-                                        fmbkm :: mix   = collectIx (Proxy :: Proxy uId) s :. kl-                                        (_,hhhh)       = bounds t -- same ugly hack-                                    bt hhhh fmbkm >>= \ ~bb -> return $ Yield (ElmSplitBtITbl Proxy (t ! fmbkm,bb) kl (subword 0 0) s) (s:. z-1)-                      | otherwise = return $ Done-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline mkStream #-}-
− ADP/Fusion/SynVar/Split/Type.hs 
@@ -1,186 +0,0 @@---- |------ NOTE /highly experimental/--module ADP.Fusion.SynVar.Split.Type-  ( module ADP.Fusion.SynVar.Split.Type-  , Proxy (..)-  ) where--import Data.Proxy-import Data.Strict.Tuple-import Data.Vector.Fusion.Stream.Monadic-import Data.Vector.Fusion.Stream.Size-import Data.Vector.Fusion.Util (delay_inline)-import Debug.Trace-import GHC.TypeLits-import Prelude hiding (map,mapM)-import Data.Type.Equality--import Data.PrimitiveArray hiding (map)--import ADP.Fusion.Base-import ADP.Fusion.SynVar.Array.Type-import ADP.Fusion.SynVar.Backtrack----data SplitType = Fragment | Final---- | The @Arg synVar@ means that we probably need to rewrite the internal--- type resolution now!--type family CalcSplitType splitType varTy where-  CalcSplitType Fragment varTy = ()-  CalcSplitType Final    varTy = varTy---- | Should never fail?--type family ArgTy argTy where---  ArgTy Z = Z-  ArgTy (z:.x) = x---- | Wraps a normal non-terminal and attaches a type-level unique identier--- and z-ordering (with the unused @Z@ at @0@).------ TODO attach empty/non-empty stuff (or get from non-splitted synvar?)------ TODO re-introduce z-ordering later (once we have a sort fun)--newtype Split (uId :: Symbol) {- (zOrder :: Nat) -} (splitType :: SplitType) synVar = Split { getSplit :: synVar }--split :: Proxy (uId::Symbol) -> {- Proxy (zOrder::Nat) -> -} Proxy (splitType::SplitType) -> synVar -> Split uId splitType synVar-split _ _ = Split-{-# Inline split #-}----type Spl uId zOrder splitType = forall synVar . Split uId zOrder splitType synVar--instance Build (Split uId splitType synVar)--instance-  ( Element ls i-  ) => Element (ls :!: Split uId splitType (ITbl m arr j x)) i where-  data Elm     (ls :!: Split uId splitType (ITbl m arr j x)) i = ElmSplitITbl !(Proxy uId) !(CalcSplitType splitType x) !i !i !(Elm ls i)-  type Arg     (ls :!: Split uId splitType (ITbl m arr j x))   = Arg ls :. (CalcSplitType splitType x)-  type RecElm  (ls :!: Split uId splitType (ITbl m arr j x)) i = Elm ls i-  getArg (ElmSplitITbl _ x _ _ ls) = getArg ls :. x-  getIdx (ElmSplitITbl _ _ i _ _ ) = i-  getOmx (ElmSplitITbl _ _ _ o _ ) = o-  getElm (ElmSplitITbl _ _ _ _ ls) = ls-  {-# Inline getArg #-}-  {-# Inline getIdx #-}-  {-# Inline getOmx #-}-  {-# Inline getElm #-}--instance-  ( Element ls i-  ) => Element (ls :!: Split uId splitType (Backtrack (ITbl mF arr j x) mF mB r)) i where-  data Elm     (ls :!: Split uId splitType (Backtrack (ITbl mF arr j x) mF mB r)) i = ElmSplitBtITbl !(Proxy uId) !(CalcSplitType splitType (x, [r])) !i !i !(Elm ls i)-  type Arg     (ls :!: Split uId splitType (Backtrack (ITbl mF arr j x) mF mB r))   = Arg ls :. (CalcSplitType splitType (x,[r]))-  type RecElm  (ls :!: Split uId splitType (Backtrack (ITbl mF arr j x) mF mB r)) i = Elm ls i-  getArg (ElmSplitBtITbl _ xs _ _ ls) = getArg ls :. xs-  getIdx (ElmSplitBtITbl _ _ i _ _ ) = i-  getOmx (ElmSplitBtITbl _ _ _ o _ ) = o-  getElm (ElmSplitBtITbl _ _ _ _ ls) = ls-  {-# Inline getArg #-}-  {-# Inline getIdx #-}-  {-# Inline getOmx #-}-  {-# Inline getElm #-}------ | 'collectIx' gobbles up indices that are tagged with the same symbolic--- identifier.--collectIx-  :: forall uId ls i .-     ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)-     )-  => Proxy uId -> Elm ls i -> SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)-collectIx p e = splitIxCol p (Proxy :: Proxy (SameSid uId (Elm ls i))) e---- | Closed type family that gives us a (type) function for type symbol--- equality.--type family SameSid uId elm :: Bool where-  SameSid uId (Elm (ls :!: Split sId splitType synVar) i) = uId == sId-  SameSid uId (Elm (ls :!: TermSymbol a b            ) i) = SameSid uId (TermSymbol a b)-  SameSid uId M                                           = False-  SameSid uId (TermSymbol a (Split sId splitType synVar)) = OR (uId == sId) (SameSid uId a)-  SameSid uId (Elm (ls :!: l                         ) i) = False---- | Type-level @(||)@--type family OR a b where-  OR False False = False-  OR a     b     = True---- | @x ++ y@ but for inductive tuples.------ TODO move to PrimitiveArray--class Zconcat x y where-  type Zpp x y :: *-  zconcat :: x -> y -> Zpp x y--instance Zconcat x Z where-  type Zpp x Z = x-  zconcat x Z = x-  {-# Inline zconcat #-}--instance -  ( Zconcat x z-  ) => Zconcat x (z:.y) where-  type Zpp x (z:.y) = Zpp x z :. y-  zconcat x (z:.y) = zconcat x z :. y-  {-# Inline zconcat #-}---- WORKS---- | Actually collect split indices based on if we managed to find the--- right @Split@ synvar (based on the right symbol).--class SplitIxCol (uId::Symbol) (b::Bool) e where-  type SplitIxTy uId b e :: *-  splitIxCol :: Proxy uId -> Proxy b -> e -> SplitIxTy uId b e----instance SplitIxCol uId b (Elm S i) where-  type SplitIxTy uId b (Elm S i) = Z-  splitIxCol p b (ElmS _ _) = Z-  {-# Inline splitIxCol #-}---instance-  ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)-  , Element (ls :!: l) i-  , RecElm (ls :!: l) i ~ Elm ls i-  ) => SplitIxCol uId False (Elm (ls :!: l) i) where-  type SplitIxTy uId False (Elm (ls :!: l) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)-  splitIxCol p b e = collectIx p (getElm e)-  {-# Inline splitIxCol #-}--instance-  ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)-  ) => SplitIxCol   uId True (Elm (ls :!: Split sId splitType (ITbl m arr j x)) i) where-  type SplitIxTy uId True (Elm (ls :!: Split sId splitType (ITbl m arr j x)) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i) :. i-  splitIxCol p b (ElmSplitITbl _ _ i _ e) = collectIx p e :. i-  {-# Inline splitIxCol #-}--instance-  ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)-  ) => SplitIxCol   uId True (Elm (ls :!: Split sId splitType (Backtrack (ITbl mF arr j x) mF mB r)) i) where-  type SplitIxTy uId True (Elm (ls :!: Split sId splitType (Backtrack (ITbl mF arr j x) mF mB r)) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i) :. i-  splitIxCol p b (ElmSplitBtITbl _ _ i _ e) = collectIx p e :. i-  {-# Inline splitIxCol #-}--instance-  ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)-  , Zconcat (SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)) (SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b))-  ) => SplitIxCol uId True (Elm (ls :!: TermSymbol a b) i) where-  type SplitIxTy uId True (Elm (ls :!: TermSymbol a b) i) = Zpp (SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)) (SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b))-  splitIxCol p b (ElmTS t i _ e) = collectIx p e `zconcat` (undefined p t :: SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b))-  {-# Inline splitIxCol #-}-
− ADP/Fusion/TH.hs 
@@ -1,77 +0,0 @@---- | The functions in here auto-create suitable algebra product functions from--- a signature. Currently, functions @<**@ are supported which have scalar--- results in the first variable.------ TODO If we want to support classified DP, we shall also need @**<@--- generating vector-results given a vector result, followed by a scalar--- result.------ TODO Then we also need @***@ handling the case of vector-to-vector results.------ TODO note the comments in @buildBacktrackingChoice@--module ADP.Fusion.TH-  ( makeAlgebraProduct-  , (<||)-  , (***)-  ) where--import           Data.List-import           Data.Tuple.Select-import           Language.Haskell.TH-import           Language.Haskell.TH.Syntax-import qualified Data.Vector.Fusion.Stream.Monadic as SM--import           ADP.Fusion.TH.Backtrack -- (makeBacktrackingProductInstance,(<||))-import           ADP.Fusion.TH.Common (getRuleResultType)----makeAlgebraProduct = makeProductInstances--{---- | Create the algebra product function from a signature type constructor.------ TODO make the resulting function INLINE------ TODO compare @synTypes@ with the stream argument types of all @hs@ (via their--- @hns@ names). If there is a mismatch, then either not all non-terminal types--- have a corresponding choice function or vice versa.--makeAlgebraProductH :: [Name] -> Name -> Q [Dec]-makeAlgebraProductH hns nm = do-  rnm <- reify nm-  case rnm of-    TyConI (DataD ctx tyConName args cs d) -> case cs of-      -- we analyze the accessor functions and look for the objective function-      -- accessor. It's stream parameter is the type of the non-terminal.-      -- Everything else in accessors are terminal parameters.-      [RecC dataConName fs'] -> do-        -- split @fs@ into functions applied to rule RHSs and choice functions (@hs@)-        let (fs,hs) = partition ((`notElem` hns) . sel1) fs'-        -- the result types of the @fs@ are the types of the non-terminal symbols-        let synTypes = nub . map getRuleResultType $ fs---        funStream <- funD (mkName "<**") [genClauseStream dataConName fs' fs hs]-        funList   <- funD (mkName "<||") [genClauseBacktrack dataConName fs' fs hs]-        return---          [ funStream-          [ funList-          , PragmaD $ InlineP (mkName "<||") Inline FunLike AllPhases-          ]-      _   -> fail "more than one data ctor"-    _          -> fail "unsupported data type"---- | Creates a class for each type of product and instances for each--- signature.--makeClassyProducts :: Name -> Q [Dec]-makeClassyProducts conName = do-  c <- lookupValueName "BacktrackingProduct"-  case c of-    Nothing -> error "need to create class now and add instance"-    Just cl -> error "add instance"-  return []--}--
− ADP/Fusion/TH/Backtrack.hs 
@@ -1,524 +0,0 @@---- | Backtracking which uses lists internally. The basic idea is to convert--- each @Stream@ into a list. The consumer consumes the stream lazily, but--- allows for fusion to happen. The hope is that this improves total--- performance in those cases, where backtracking has significant costs.--module ADP.Fusion.TH.Backtrack where--import           Control.Applicative ( (<$>) )-import           Control.Monad-import           Control.Monad.Primitive (PrimState, PrimMonad)-import           Data.List-import           Data.Tuple.Select-import           Data.Vector.Fusion.Stream.Monadic (Stream(..))-import           Debug.Trace-import           Language.Haskell.TH-import           Language.Haskell.TH.Instances-import           Language.Haskell.TH.Syntax-import qualified Data.Map.Strict as M-import qualified Data.Vector as V-import qualified Data.Vector.Fusion.Stream.Monadic as SM-import qualified Data.Vector.Generic as VG-import qualified Data.Vector.Generic.Mutable as VGM-import qualified Data.Vector.Mutable as VM--import           Data.PrimitiveArray ( (:.)(..) , Z(..) )--import           ADP.Fusion.TH.Common------ | @Backtracking@ products of @f@ and @b@. Choice in @f@ needs to be--- reduced to a scalar value. It is then compared to the @fst@ values--- in @b@. From those, @choice b@ selects.--class ProductBacktracking sigF sigB where-  type SigBacktracking sigF sigB :: *-  (<||) :: sigF -> sigB -> SigBacktracking sigF sigB---- | The ADP-established product operation. Returns a vector of results,--- along the lines of what the ADP @f *** b@ provides.--class ProductCombining sigF sigB where-  type SigCombining sigF sigB :: *-  (***) :: sigF -> sigB -> SigCombining sigF sigB---- | Creates instances for all products given a signature data type.--makeProductInstances :: Name -> Q [Dec]-makeProductInstances tyconName = do-  t <- reify tyconName-  case t of-    TyConI (DataD ctx tyConName args cs d) -> do-      let m = getMonadName args-      case cs of-        [RecC dataconName funs] -> do-          let Just (h,m',x,r) = getObjectiveNames funs-          mL <- newName "mL"-          xL <- newName "xL"-          rL <- newName "rL"-          mR <- newName "mR"-          xR <- newName "xR"-          rR <- newName "rR"---          let lType    = buildLeftType  tyconName (m', x, r) (mL, xL)        args-          let lType    = buildRightType tyconName (m', x, r) (mL, xL, rL)    args-          let rType    = buildRightType tyconName (m', x, r) (mR, xR, rR)    args-          let (fs,hs) = partition ((`notElem` [h]) . sel1) funs-          let sigBType = buildSigBacktrackingType  tyconName (m', x, r) xL (mR, xR, rR) args-          Clause psB (NormalB bB) dsB <- genAlgProdFunctions buildBacktrackingChoice dataconName funs fs hs-          iB <- [d| instance (Monad $(varT mL), Monad $(varT mR), Eq $(varT xL), $(varT mL) ~ $(varT mR), $(varT xL) ~ $(varT rL))-                      => ProductBacktracking $(return lType) $(return rType) where-                          type SigBacktracking $(return lType) $(return rType) = $(return sigBType)-                          (<||) = $(return $ LamE psB $ LetE dsB bB)-                          {-# Inline (<||) #-}-                |]-          -- TODO might well be that this doesn't work because we re-use-          -- type names ...-          vG <- newName "vG"-          sigPType <- buildSigCombiningType tyconName vG (m', x, r) (mL, xL, rL) (mR, xR, rR) args-          Clause psC (NormalB bC) dsC <- genAlgProdFunctions buildCombiningChoice    dataconName funs fs hs-          iC <- [d| instance (Monad $(varT mL), Monad $(varT mR), Eq $(varT xL), $(varT mL) ~ $(varT mR) {- , VG.Vector $(varT vG) ($(varT rL),$(varT rR)) -} )-                      => ProductCombining $(return lType) $(return rType) where-                          type SigCombining $(return lType) $(return rType) = $(return sigPType)-                          (***) = undefined-                          {--                           - (***) = $(return $ LamE psC $ LetE dsC bC)-                           - -}-                          {-# Inline (***) #-}-                |]-          return $ iB -- ++ iC---- | Returns the 'Name' of the monad variable.--getMonadName :: [TyVarBndr] -> Maybe Name-getMonadName = go-  where go [] = Nothing-        go (KindedTV m (AppT (AppT ArrowT StarT) StarT) : _) = Just m-        go (_ : xs) = go xs---- | Returns the 'Name's of the objective function variables, as well as--- the name of the objective function itself.--getObjectiveNames :: [VarStrictType] -> Maybe (Name,Name,Name,Name)-getObjectiveNames = go-  where go [] = Nothing-        go ( (hName , _ , (AppT (AppT ArrowT (AppT (AppT (ConT streamName) (VarT mS)) (VarT x))) (AppT (VarT mR) (VarT r)))) : xs)-          | streamName == ''Stream && mS == mR = Just (hName,mS,x,r)-          | otherwise             = go xs-        go ( _ : xs) = go xs------ * Constructions for the different algebra types.---- | The left algebra type. Assumes that in @choice :: Stream m x -> m r@--- we have that @x ~ r@.--buildLeftType :: Name -> (Name, Name, Name) -> (Name, Name) -> [TyVarBndr] -> Type-buildLeftType tycon (m, x, r) (mL, xL) = foldl AppT (ConT tycon) . map (VarT . go)-  where go (PlainTV z)-          | z == m        = mL  -- correct monad name-          | z == x        = xL  -- point to new x type-          | z == r        = xL  -- stream and return type are the same-          | otherwise     = z   -- everything else can stay as is-        go (KindedTV z _) = go (PlainTV z)---- | Here, we do not set any restrictions on the types @m@ and @r@.--buildRightType :: Name -> (Name, Name, Name) -> (Name, Name, Name) -> [TyVarBndr] -> Type-buildRightType tycon (m, x, r) (mR, xR, rR) = foldl AppT (ConT tycon) . map (VarT . go)-  where go (PlainTV z)-          | z == m    = mR  -- have discovered a monadic type-          | z == x    = xR  -- have discovered a type that is equal to the stream type (and hence we have a synvar type)-          | z == r    = rR  -- have discovered a type that is equal to the result type (for @<||@) equal to the stream type, hence synvar-          | otherwise = z   -- this is a terminal or a terminal stack (we don't care)-        go (KindedTV z _) = go (PlainTV z)---- | Build up the type for backtracking. We want laziness in the right--- return type. Hence, we have @AppT ListT (VarT xR)@ ; i.e. we want to--- return results in a list.--buildSigBacktrackingType :: Name -> (Name, Name, Name) -> (Name) -> (Name, Name, Name) -> [TyVarBndr] -> Type-buildSigBacktrackingType tycon (m, x, r) (xL) (mR, xR, rR) = foldl AppT (ConT tycon) . map go-  where go (PlainTV z)-          | z == m    = VarT mR-          | z == x    = (AppT (AppT (TupleT 2) (VarT xL)) (AppT ListT (VarT xR)))-          | z == r    = VarT rR-          | otherwise = VarT z-        go (KindedTV z _) = go (PlainTV z)---- | Build up the type for backtracking. We want laziness in the right--- return type. Hence, we have @AppT ListT (VarT xR)@.--buildSigCombiningType :: Name -> Name -> (Name, Name, Name) -> (Name, Name, Name) -> (Name, Name, Name) -> [TyVarBndr] -> TypeQ-buildSigCombiningType tycon vG (m, x, r) (mL, xL, rL) (mR, xR, rR) = foldl appT (conT tycon) . map go-  where go (PlainTV z)-          | z == m    = varT mR-          | z == x    = [t| ($(varT xL) , $(varT xR)) |]-          | z == r    = [t| V.Vector ($(varT rL) , $(varT rR)) |]-          | otherwise = varT z-        go (KindedTV z _) = go (PlainTV z)------ *---- | Build up attribute and choice function. Here, we actually bind the--- left and right algebra to @l@ and @r@.--genAlgProdFunctions-  :: Choice-  -> Name-  -> [VarStrictType]-  -> [VarStrictType]-  -> [VarStrictType]-  -> Q Clause-genAlgProdFunctions choice conName allFunNames evalFunNames choiceFunNames = do-  let nonTermNames = nub . map getRuleResultType $ evalFunNames-  -- bind the l'eft and r'ight variable of the two algebras we want to join,-  -- also create unique names for the function names we shall bind later.-  nameL <- newName "l"-  varL  <- varP nameL-  fnmsL <- sequence $ replicate (length allFunNames) (newName "fnamL")-  nameR <- newName "r"-  varR  <- varP nameR-  fnmsR <- sequence $ replicate (length allFunNames) (newName "fnamR")-  -- bind the individual variables in the where part-  whereL <- valD (conP conName (map varP fnmsL)) (normalB $ varE nameL) []-  whereR <- valD (conP conName (map varP fnmsR)) (normalB $ varE nameR) []-  rce <- recConE conName-          $  zipWith3 (genChoiceFunction choice) (drop (length evalFunNames) fnmsL) (drop (length evalFunNames) fnmsR) choiceFunNames-          ++ zipWith3 (genAttributeFunction nonTermNames) fnmsL fnmsR evalFunNames-  -- build the function pairs-  -- to keep our sanity, lets print this stuff-  let cls = Clause [varL, varR] (NormalB rce) [whereL,whereR]-  return cls---- | Simple wrapper for creating the choice fun expression.--genChoiceFunction-  :: Choice-  -> Name-  -> Name-  -> VarStrictType-  -> Q (Name,Exp)-genChoiceFunction choice hL hR (name,_,t) = do-  exp <- choice hL hR-  return (name,exp)----- | We take the left and right function name for one attribute and build--- up the combined attribute function. Mostly a wrapper around--- 'recBuildLampat' which does the main work.------ TODO need fun names from @l@ and @r@--genAttributeFunction-  :: [Name]-  -> Name-  -> Name-  -> VarStrictType-  -> Q (Name,Exp)-genAttributeFunction nts fL fR (name,_,t) = do-  (lamPat,funL,funR) <-recBuildLamPat nts fL fR (init $ getRuleSynVarNames nts t) -- @init@ since we don't want the result as a parameter-  let exp = LamE lamPat $ TupE [funL,funR]-  return (name,exp)---- | Now things become trickly. We are given all non-terminal names (to--- differentiate between a terminal (stack) and a syntactic variable; the--- left and right function; and the arguments to this attribute function--- (except the result parameter). We are given the latter as a result to an--- earlier call to 'getRuleSynVarNames'.------ We now look at each argument and determine wether it is a syntactic--- variable. If so, then we actually have a tuple arguments @(x,ys)@ where--- @x@ has to optimized value and @ys@ the backtracking list. The left--- function receives just @x@ in this case. For the right function, things--- are more complicated, since we have to flatten lists. See 'buildRns'.------ Terminals are always given "as is" since we do not have a need for--- tupled-up information as we have for syntactic variables.--recBuildLamPat-  :: [Name]   -- ^ all non-terminal names-  -> Name     -- ^ left attribute function-  -> Name     -- ^ right attribute function-  -> [ArgTy Name]  -- ^ all arguments to the attribute function-  -> Q ([Pat], Exp, Exp)-recBuildLamPat nts fL' fR' ts = do-  -- here we just run through all arguments, either creating an @x@ and-  -- a @ys@ for a non-term or a @t@ for a term.-  -- ps <- sequence [ if t `elem` nts then tupP [newName "x" >>= varP, newName "ys" >>= varP] else (newName "t" >>= varP) | t<-ts]-  ps <- mapM argTyArgs ts-  {--  let buildLfun f (SynVar (TupP [VarP v,_])) = appE f (varE v)-      buildLfun f (Term   (VarP v         )) = appE f (varE v)-      buildLfun f (StackedVars vs) =-        let-        in  error "buildLfun: WRITE ME" -- appE f (varE $ mkName "foo")-  -}-  lamPat <- buildLamPat ps-  lfun <- buildLns (VarE fL') ps -- foldl buildLfun (varE fL') ps-  rfun <- buildRns (VarE fR') ps-  return (lamPat, lfun, rfun)--buildLamPat :: [ArgTy Pat] -> Q [Pat]-buildLamPat = mapM go where-  go (SynVar      p ) = return p-  go (Term        p ) = return p-  go (StackedVars ps) = build ps-  build :: [ArgTy Pat] -> Q Pat-  build = foldl (\s v -> [p| $(s) :. $(return v) |]) [p|Z|] . map get-  get :: ArgTy Pat -> Pat-  get (SynVar p) = p-  get (Term   p) = p---- | Look at the argument type and build the capturing variables. In--- particular captures synvar arguments with a 2-tuple @(x,ys)@.--argTyArgs :: ArgTy Name -> Q (ArgTy Pat)-argTyArgs (SynVar n) = SynVar <$> tupP [newName "x" >>= varP , newName "ys" >>= varP]-argTyArgs (Term n)          = Term <$> (newName "t" >>= varP)-argTyArgs (StackedTerms _)  = Term <$> (newName "t" >>= varP) -- !!!-argTyArgs (StackedVars vs)  = StackedVars <$> mapM argTyArgs vs-argTyArgs NilVar            = Term <$> (newName "t" >>= varP)-argTyArgs (Result _)        = error "argTyArgs: should not receive @Result@"--buildLns-  :: Exp-  -> [ArgTy Pat]-  -> ExpQ-buildLns f' ps = foldl go (return f') ps-  where go :: ExpQ -> ArgTy Pat -> ExpQ-        go f (SynVar      (TupP [VarP v,_])) = appE f (varE v)-        go f (Term        (VarP v         )) = appE f (varE v)-        go f (StackedVars vs               ) = appE f (build vs)-        build :: [ArgTy Pat] -> ExpQ-        build = foldl (\s v -> [| $(s) :. $(varE v) |]) [|Z|] . map get-        get (SynVar (TupP [VarP v,_])) = v-        get (Term   (VarP t)         ) = t---- |------ NOTE------ @--- [ f x | x <- xs ]--- CompE [BindS (VarP x) (VarE xs), NoBindS (AppE (VarE f) (VarE x))]--- @--buildRns-  :: Exp---  -> [Name]-  -> [ArgTy Pat]-  -> ExpQ-buildRns f' ps = do-  -- get all synvars, shallow or deep and create a new name to bind-  -- individual parts to.-  sy :: M.Map Pat Name <- M.fromList <$> (mapM (\s -> newName "y" >>= \y -> return (s,y)) $ concatMap flattenSynVars ps)-  -- bind them for the right part of the list expression (even though they-  -- are left in @CompE@. We don't use @sy@ directly to keep the order in-  -- which the comprehensions run.-  let rs = map (\k@(TupP [_,VarP v]) -> BindS (VarP $ sy M.! k) (VarE v)) $ concatMap flattenSynVars ps-  let go :: ExpQ -> ArgTy Pat -> ExpQ-      go f (SynVar      k       ) = appE f (varE $ sy M.! k) -- needed like this, because we need the @y@ in @y <- ys@-      go f (Term        (VarP v)) = appE f (varE v)-      go f (StackedVars vs      ) = appE f (foldl build [|Z|] vs)-      build :: ExpQ -> ArgTy Pat -> ExpQ-      build s (SynVar k       ) = [| $(s) :. $(varE $ sy M.! k) |]-      build s (Term   (VarP v)) = [| $(s) :. $(varE v)          |]-  funApp <- foldl go (return f') ps-  return . CompE $ rs ++ [NoBindS funApp]--{--  -- helper function for the argument build-up-  let go :: [ArgTy Pat] -> [Name]-      go [] = []-      go ((SynVar      k       ):ks) = sy M.! k  : go ks-      go ((Term        (VarP v)):ks) = v         : go ks -- should also cover StackedTerms, NilVar ! (because we build this earlier in @argTypArgs@)-      go ((StackedVars ls      ):ks) = (error "here") : go ks -- need to work more-  -- more verbose build-up of the arguments for @funApp@.-  let xs = go ps-  -- function application-  funApp <- noBindS $ foldl (\g z -> appE g (varE z)) (return f) xs-  return . CompE $ rs ++ [funApp]--}-{--buildRns f ps = do-  ys <- sequence [ newName "y" | TupP [_,VarP v] <- ps ]-  let vs = zipWith (\y v -> (BindS (VarP y) (VarE v))) ys [ v | TupP [_,VarP v] <- ps ]-  let xs = go ps ys-  ff <- noBindS $ foldl (\g z -> appE g (varE z)) (return f) xs-  return $ CompE $ vs ++ [ff]-  where go [] [] = []-        go (VarP v : gs) ys     = v : go gs ys  -- keep terminal binders-        go (TupP _ : gs) (v:ys) = v : go gs ys  -- insert new binders-        go as bs = error $ show ("not done?", as, bs)--}---- | Type for backtracking functions.------ Not too interesting, mostly to keep track of @choice@.--type Choice = Name -> Name -> Q Exp---- | Build up the backtracking choice function. This choice function will--- backtrack based on the first result, then return only the second.------ TODO it should be (only?) this function we will need to modify to build--- all algebra products.------ @ysM@ can't be unboxed, as @snd@ of each element is a list, lazily--- consumed. We build up @ysM@ as this makes fusion happen. Of course, this--- is a boxed vector and not as efficient, but we gain the ability to have--- lazily created backtracking from this!------ This means strict optimization AND lazy backtracking--buildBacktrackingChoice :: Choice-buildBacktrackingChoice hL' hR' =-  [| \xs -> do        -- first, create a boxed, mutable vector from the results-               ysM <- streamToVector xs -- VGM.unstream xs :: m (VM.MVector s (t1,[t2]))-                      -- apply first choice-               hFres <- $(varE hL') $ SM.map fst $ vectorToStream ysM-                     -- second choice on snd elements, then concat'ed up-                     -- TODO good candidate for rewriting into flatten-                     -- operation!-               {--                - $(varE hR') $ SM.concatMap (SM.fromList . snd) $ SM.filter ((hFres==) . fst) $ vectorToStream ysM-                -}-               $(varE hR') $ SM.fromList $ concatMap snd $ filter ((hFres==) . fst) $ V.toList ysM-  |]--buildCombiningChoice :: Choice-buildCombiningChoice hL' hR' =-  [| \xs -> do       -- first, create a boxed, mutable vector from the results-               --ys <- streamToVector xs-               --      -- apply first choice-               --fs <- $(varE hL') $ SM.map fst $ vectorToStream ys-               --      -- generate a vector of vectors, one for each-               --      -- surviving @f@-               --vs <- V.forM fs $ \f -> do-               --        -- keep only those @ys@ that have @f@-               --        let as = V.filter ((f==) . fst) ys-               --        -- apply @hR'@ to those, but only to the @snd@-               --        -- elements-               --        bs <- streamToVector =<< $(varE hR') $ SM.map snd $ vectorToStream $ as-               --        -- return the combined result, with @f@ attached.-               --        return $ V.map (\z -> (f,z)) bs-               undefined-               {--                - $ V.concat $ V.toList vs-                -}-               -- TODO we should return a @newtype Many x = forall (G.Vector v x) => Many { v x }-               -- Together with a closed type family, this gives us a good-               -- way to encode that we have classified DP-  |]---- | Transform a monadic stream monadically into a vector.------ TODO Improve code!--streamToVector :: (Monad m) => SM.Stream m x -> m (V.Vector x)-streamToVector xs = do-  l <- SM.toList xs-  let v = V.fromList l-  return v-{-# Inline streamToVector #-}---- | Transform a vector into a monadic stream.------ TODO improve code!--vectorToStream :: (Monad m) => V.Vector x -> SM.Stream m x-vectorToStream = SM.fromList . V.toList-{-# Inline vectorToStream #-}---- | Gets the names used in the evaluation function. This returns one--- 'Name' for each variable.------ In case of @TupleT 0@ the type is @()@ and there isn't a name to go with--- it. We just @mkName "()"@ a name, but this might be slightly dangerous?--- (Not really sure if it indeed is)------ With @AppT _ _@ we have a multidim terminal and produce another hackish--- name to be consumed above.------ @--- AppT (AppT ArrowT (AppT (AppT (ConT Data.Array.Repa.Index.:.) (AppT (AppT (ConT Data.Array.Repa.Index.:.) (ConT Data.Array.Repa.Index.Z)) (VarT c_1627675270))) (VarT c_1627675270))) (VarT x_1627675265)--- @--getRuleSynVarNames :: [Name]-> Type -> [ArgTy Name] -- [Name]-getRuleSynVarNames nts t' = go t' where-  go t-    | VarT x <- t                          = [Result x]-    | AppT (AppT ArrowT (VarT x)  ) y <- t = (if x `elem` nts then SynVar x else Term x) : go y-    | AppT (AppT ArrowT (TupleT 0)) y <- t = NilVar : go y-    | AppT (AppT ArrowT s         ) y <- t = stacked s : go y-    | otherwise                            = error $ "getRuleSynVarNames error: " ++ show t ++ "    in:    " ++ show t'-  stacked s = if null [ () | SynVar _ <- xs ] then StackedTerms xs else StackedVars xs-    where xs = reverse $ stckd s-          stckd (ConT z) | z == ''Z = []-          stckd (AppT a (TupleT 0)) = NilVar : stckd a-          stckd (AppT a (VarT x)  ) = (if x `elem` nts then SynVar x else Term x) : stckd a-          stckd (AppT (ConT c) a  ) | c == ''(:.) = stckd a-          stckd err = error $ "stckd" ++ show err--{--(AppT (AppT (ConT Data.PrimitiveArray.Index.Class.:.)-            (AppT (AppT (ConT Data.PrimitiveArray.Index.Class.:.)-                        (ConT Data.PrimitiveArray.Index.Class.Z)-                  )-                  (VarT x_1627774371)-            )-      )-      (TupleT 0)-)--}--{--getRuleSynVarNames nts t' = undefined where -- go t' where-  go t-    | VarT x <- t = [x]-    | AppT (AppT ArrowT (VarT x  )) y <- t = x : go y   -- this is a single-dim variable, return the name that the incoming data is bound to (not necessarily syntactic)-    | AppT (AppT ArrowT (AppT _ _)) y <- t = mkName "[]" : go y   -- this captures that we have a multi-dim terminal.-    | AppT (AppT ArrowT (TupleT 0)) y <- t = mkName "()" : go y   -- this case captures things like @nil :: () -> x@ for rules like @nil <<< Epsilon@.-    | otherwise            = error $ "getRuleSynVarNames error: " ++ show t ++ "    in:    " ++ show t'--}--data ArgTy x-  -- | This @SynVar@ spans the full column of tapes; i.e. it is a normal-  -- syntactic variable.-  = SynVar { synVarName :: x }-  -- | We have just a single-tape grammar and as such just-  -- a single-dimensional terminal. We call this term, because-  -- @StackedTerms@ will be rewritten to just @Term@!-  | Term { termName :: x }-  -- | We have a multi-tape grammar with a stack of just terminals. We-  -- normally can ignore the contents in the functions above, but keep them-  -- anyway.-  | StackedTerms { stackedTerms :: [ArgTy x] }-  -- | We have a multi-tape grammar, but the stack contains a mixture of-  -- @ArgTy@s.-  | StackedVars { stackedVars :: [ArgTy x] }-  -- | A single-dim @()@ case-  | NilVar-  -- | The result type name-  | Result { result :: x }-  deriving (Show,Eq)--unpackArgTy :: Show x => ArgTy x -> x-unpackArgTy = go-  where go (SynVar x) = x-        go (Term   x) = x-        go (Result x) = x-        go err        = error $ "unpackArgTy " ++ show err---- | Get all synvars, even if deep in a stack--flattenSynVars :: ArgTy x -> [x]-flattenSynVars (SynVar x)       = [x]-flattenSynVars (StackedVars xs) = concatMap flattenSynVars xs-flattenSynVars _                = []-
− ADP/Fusion/TH/Common.hs 
@@ -1,19 +0,0 @@--module ADP.Fusion.TH.Common where--import           Data.Tuple.Select-import           Language.Haskell.TH-import           Language.Haskell.TH.Syntax------ | The last @Name@ of a rule is the name of the syntactic type of the--- result.--getRuleResultType :: VarStrictType -> Name-getRuleResultType vst = go $ sel3 vst where-  go t-    | AppT _ (VarT x) <- t = x-    | AppT _ x        <- t = go x-    | otherwise            = error $ "undetermined error:" ++ show vst-
− ADP/Fusion/Term.hs 
@@ -1,17 +0,0 @@--module ADP.Fusion.Term-  ( module ADP.Fusion.Term.Chr-  , module ADP.Fusion.Term.Deletion-  , module ADP.Fusion.Term.Edge-  , module ADP.Fusion.Term.Epsilon-  , module ADP.Fusion.Term.PeekIndex-  , module ADP.Fusion.Term.Strng-  ) where--import           ADP.Fusion.Term.Chr-import           ADP.Fusion.Term.Deletion-import           ADP.Fusion.Term.Edge-import           ADP.Fusion.Term.Epsilon-import           ADP.Fusion.Term.PeekIndex-import           ADP.Fusion.Term.Strng-
− ADP/Fusion/Term/Chr.hs 
@@ -1,197 +0,0 @@--module ADP.Fusion.Term.Chr-  ( module ADP.Fusion.Term.Chr.Type-  , module ADP.Fusion.Term.Chr.Point-  , module ADP.Fusion.Term.Chr.Subword-  ) where--import ADP.Fusion.Term.Chr.Point-import ADP.Fusion.Term.Chr.Subword-import ADP.Fusion.Term.Chr.Type--------{---{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE UndecidableInstances #-}---- |------ TODO PointL , PointR need sanity checks for boundaries--module ADP.Fusion.Term.Chr where--import           Control.Exception(assert)-import qualified Data.Vector.Fusion.Stream.Monadic as S-import qualified Data.Vector.Unboxed as VU--import           Data.PrimitiveArray -- ((:.)(..), Subword(..), subword, PointL(..), pointL, PointR(..), pointR, Outside(..))---import Debug.Trace-------- ** @PointL@ single-dim instances--{--instance-  ( Monad m-  , Element ls PointL-  , MkStream m ls PointL-  ) => MkStream m (ls :!: Chr r x) PointL where-  mkStream (ls :!: Chr f xs) Static lu@(PointL (l:.u)) (PointL (i:.j))-    = staticCheck (j>l && j>0 && j<=u && j<= VG.length xs) $-      let !z = () -- f xs (j-1) -- let-floating leads to too early evaluation-      in  S.map (ElmChr (f xs $ j-1) (pointL (j-1) j))-          $ mkStream ls Static lu (pointL i $ j-1)---  mkStream _ _ _ _ = error "mkStream / Chr / PointL not implemented"-  {-# INLINE mkStream #-}--instance-  ( Monad m-  , Element ls (Outside PointL)-  , MkStream m ls (Outside PointL)-  ) => MkStream m (ls :!: Chr r x) (Outside PointL) where-  mkStream (ls :!: Chr f xs) Static lu@(O (PointL (l:.u))) (O (PointL (i:.j)))-    = staticCheck (j<u) $-      let !z = f xs j-      in  S.map (ElmChr z (O . pointL j $ j+1))-          $ mkStream ls Static lu (O . pointL i $ j+1)---  mkStream _ _ _ _ = error "mkStream / Chr / Outside PointL not implemented"-  {-# INLINE mkStream #-}--}----- ** @Subword@ single-dim instances--{--instance-  ( Monad m-  , Element ls Subword-  , MkStream m ls Subword-  ) => MkStream m (ls :!: Chr r x) Subword where-  mkStream (ls :!: Chr f xs) Static lu@(Subword (l:.u)) ij@(Subword (i:.j))-    -- We use a static check here as we can then pull out the @z@ character-    -- lookup. In the Nussinov example (X -> f <<< z1 t z2 t) this gives-    -- a 3x performance improvement. Note that this benchmark is a bit-    -- artificial.-    ---    -- The static part is called @right-most@, i.e. when only terminals with-    -- known fixed sizes are on the right of this terminal.-    = staticCheck (j>0 && j<=u) $-      let !z = f xs (j-1)-      in S.map (ElmChr z (subword (j-1) j))-         $ mkStream ls Static lu (subword i $ j-1)-  mkStream (ls :!: Chr f xs) v lu ij@(Subword (i:.j))-    -- This version is used when to right, we already had variable-size-    -- (non-)terminals to the right.-    = S.map (\s -> let Subword (k:.l) = getIdx s-                   in  ElmChr (f xs l) (subword l $ l+1) s-            )-    $ mkStream ls v lu (subword i $ j-1)-  {-# INLINE mkStream #-}--}---- Note how the indices grow to the outside!--{--instance-  ( Monad m-  , Element ls (Outside Subword)-  , MkStream m ls (Outside Subword)-  ) => MkStream m (ls :!: Chr r x) (Outside Subword) where-  -- For the static case, we move the @j@ index.-  mkStream (ls :!: Chr f xs) Static lu@(O (Subword (l:.u))) ij@(O (Subword (i:.j)))-    = staticCheck (j>=0 && j<u) $-      let !z = f xs j-      in S.map (ElmChr z (O $ subword j (j+1)))-         $ mkStream ls Static lu (O $ subword i $ j+1)-  -- In the variable case, (i) we set @i@ to @i-1@ going further down. (ii) On-  -- going back up, we extract the rightmost index of the left symbol @l@ ---  -- which could be @i-1@ but need not be.-  mkStream (ls :!: Chr f xs) v lu ij@(O (Subword (i:.j)))-    = S.map (\s -> let O (Subword (_:.l)) = getIdx s-                   in  ElmChr (f xs l) (O . subword l $ l+1) s-            )-    $ mkStream ls v lu (O $ subword (i-1) j)-  {-# INLINE mkStream #-}--}----{----- * Multi-dimensional stuff--{--instance TermStaticVar (Chr r x) Subword where-  termStaticVar   _ sv _                = sv-  termStreamIndex _ _  (Subword (i:.j)) = subword i $ j-1-  {-# INLINE termStaticVar #-}-  {-# INLINE termStreamIndex #-}--}--instance TermStaticVar (Chr r x) PointR where-  termStaticVar   _ sv _                = sv-  termStreamIndex _ _  (PointR (i:.j)) = pointR i $ j-1-  {-# INLINE termStaticVar #-}-  {-# INLINE termStreamIndex #-}---- TODO removed the static check since *in principle* the statics system down--- at the bottom of the stack should take care of it! Need to verify with--- QuickCheck, though.--{--instance-  ( Monad m-  , TerminalStream m a is-  ) => TerminalStream m (TermSymbol a (Chr r x)) (is:.Subword) where-  terminalStream (a:>Chr f (!v)) (sv:.Static) (is:.Subword (i:.j))-    = id -- staticCheck (j>0)-    . S.map (\(Qd s (z:._) is e) -> Qd s z (is:.subword (j-1) j) (e:.f v (j-1)))-    . terminalStream a sv is-    . S.map (\(Tr s z (is:.i)) -> Tr s (z:.i) is)-  terminalStream (a:>Chr f (!v)) (sv:._) (is:.Subword (i:.j))-    = S.map (\(Qd s (z:.Subword (k:.l)) is e) -> Qd s z (is:.subword l (l+1)) (e:.f v (l-1)))-    . terminalStream a sv is-    . S.map (\(Tr s z (is:.i)) -> Tr s (z:.i) is)-  {-# INLINE terminalStream #-}--}--{--instance-  ( Monad m-  , TerminalStream m a is-  ) => TerminalStream m (TermSymbol a (Chr r x)) (is:.PointR) where-  terminalStream (a:>Chr f (!v)) (sv:.Static) (is:.PointR (i:.j))-    = S.map (\(Qd s (z:._) is e) -> Qd s z (is:.pointR (j-1) j) (e:.f v (j-1)))-    . terminalStream a sv is-    . S.map (\(Tr s z (is:.i)) -> Tr s (z:.i) is)-  terminalStream (a:>Chr f (!v)) (sv:._) (is:.PointR (i:.j))-    = S.map (\(Qd s (z:.PointR (k:.l)) is e) -> Qd s z (is:.pointR l (l+1)) (e:.f v (l-1)))-    . terminalStream a sv is-    . S.map (\(Tr s z (is:.i)) -> Tr s (z:.i) is)-  {-# INLINE terminalStream #-}--}---}----}-
− ADP/Fusion/Term/Chr/Point.hs 
@@ -1,91 +0,0 @@--module ADP.Fusion.Term.Chr.Point where--import           Data.Strict.Tuple-import           Debug.Trace-import qualified Data.Vector.Fusion.Stream.Monadic as S-import qualified Data.Vector.Generic as VG--import           Data.PrimitiveArray--import           ADP.Fusion.Base-import           ADP.Fusion.Term.Chr.Type---instance-  ( Monad m-  , Element ls PointL-  , MkStream m ls PointL-  ) => MkStream m (ls :!: Chr r x) PointL where-  mkStream (ls :!: Chr f xs) (IStatic d) (PointL u) (PointL i)-    = staticCheck (i>0 && i<=u && i<= VG.length xs)-    $ S.map (ElmChr (f xs $ i-1) (PointL $ i) (PointL 0))-    $ mkStream ls (IStatic d) (PointL u) (PointL $ i-1)-  mkStream _ _ _ _ = error "mkStream / Chr / PointL can only be implemented for IStatic"-  {-# Inline mkStream #-}--instance-  ( Monad m-  , Element ls (Outside PointL)-  , MkStream m ls (Outside PointL)-  ) => MkStream m (ls :!: Chr r x) (Outside PointL) where-  mkStream (ls :!: Chr f xs) (OStatic d) (O (PointL u)) (O (PointL i))-    = S.map (\z -> let (O (PointL k)) = getOmx z in ElmChr (f xs $ k-d-1) (O . PointL $ k-d) (getOmx z) z)-    $ mkStream ls (OStatic $ d+1) (O $ PointL u) (O $ PointL i)-  mkStream _ _ _ _ = error "Chr.Point / mkStream / Chr / Outside.PointL can only be implemented for OStatic"-  {-# Inline mkStream #-}---- TODO @Inline [0]@ ???--instance TermStaticVar (Chr r x) PointL where-  termStaticVar   _ sv _                = sv-  termStreamIndex _ _  (PointL j) = PointL $ j-1-  {-# Inline termStaticVar #-}-  {-# Inline termStreamIndex #-}--instance TermStaticVar (Chr r x) (Outside PointL) where-  termStaticVar   _ (OStatic d) _ = OStatic (d+1) -  termStreamIndex _ _           j = j-  {-# Inline termStaticVar #-}-  {-# Inline termStreamIndex #-}--instance-  ( Monad m-  , TerminalStream m a is-  ) => TerminalStream m (TermSymbol a (Chr r x)) (is:.PointL) where-  terminalStream (a:|Chr f (!v)) (sv:.IStatic _) (is:.i@(PointL j))-    = S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.PointL j) (os:.PointL 0) (e:.f v (j-1)))-    . iPackTerminalStream a sv (is:.i)-    {--    . terminalStream a sv is-    . S.map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)-    -}-  terminalStream (a:|Chr f (!v)) (sv:._) (is:.i@(PointL _))-    = S.map (\(S6 s (zi:.PointL k) (zo:.PointL l) is os e) -> S6 s zi zo (is:.PointL (k+1)) (os:.PointL 0) (e:.f v (l-1))) -- TODO is the @l-1@ even right? is this part even called?-    . iPackTerminalStream a sv (is:.i)-    {--    . terminalStream a sv is-    . S.map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)-    -}-  {-# INLINE terminalStream #-}--instance-  ( Monad m-  , TerminalStream m a (Outside is)-  , Context (Outside (is:.PointL)) ~ (Context (Outside is) :. OutsideContext Int)-  ) => TerminalStream m (TermSymbol a (Chr r x)) (Outside (is:.PointL)) where-  terminalStream (a:|Chr f (!v)) (sv:.OStatic d) (O (is:.i))-    = S.map (\(S6 s (zi:._) (zo:.(PointL k)) (O is) (O os) e) -> S6 s zi zo (O (is:.(PointL $ k-d))) (O (os:.PointL k)) (e:.f v (k-d-1)))-    . oPackTerminalStream a sv (O (is:.i))-    {--    . terminalStream a sv (O is)-    . S.map (\(S5 s zi zo (O (is:.i)) (O (os:.o))) -> S5 s (zi:.i) (zo:.o) (O is) (O os))-    -}-  {--  terminalStream (a:|Chr f (!v)) (sv:._) (is:.PointL i)-    = S.map (\(S6 s (zi:.PointL k) (zo:.PointL l) is os e) -> S6 s zi zo (is:.PointL (k+1)) (os:.PointL 0) (e:.f v (l-1)))-    . terminalStream a sv is-    . S.map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)-  -}-  {-# INLINE terminalStream #-}-
− ADP/Fusion/Term/Chr/Subword.hs 
@@ -1,81 +0,0 @@--module ADP.Fusion.Term.Chr.Subword where--import           Data.Strict.Tuple-import           Data.Vector.Fusion.Util (delay_inline)-import           Debug.Trace-import           Data.Vector.Fusion.Stream.Monadic as S-import qualified Data.Vector.Generic as VG-import           Prelude hiding (map)--import           Data.PrimitiveArray hiding (map)--import           ADP.Fusion.Base-import           ADP.Fusion.Term.Chr.Type----instance-  ( Monad m-  , Element ls Subword-  , MkStream m ls Subword-  ) => MkStream m (ls :!: Chr r x) Subword where-  mkStream (ls :!: Chr f xs) (IStatic ()) hh (Subword (i:.j))-    = staticCheck (i>=0 && i<j && j<= VG.length xs)-    $ map (ElmChr (f xs $ j-1) (subword (j-1) j) (subword 0 0))-    $ mkStream ls (IStatic ()) hh (delay_inline Subword (i:.j-1))-  mkStream (ls :!: Chr f xs) (IVariable ()) hh (Subword (i:.j))-    = map (\s -> let Subword (_:.l) = getIdx s-                 in  ElmChr (f xs l) (subword l (l+1)) (subword 0 0) s)-    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j-1))-  {-# Inline mkStream #-}--instance-  ( Monad m-  , Element ls (Outside Subword)-  , MkStream m ls (Outside Subword)-  ) => MkStream m (ls :!: Chr r x) (Outside Subword) where-  mkStream (ls :!: Chr f xs) (OStatic (di:.dj)) u ij@(O (Subword (i:.j)))-    = id -- staticCheck ( j < h ) -- TODO any check possible?-    $ map (\s -> let (O (Subword (_:.k'))) = getIdx s-                     k = k'-dj-1-                 in  ElmChr (f xs k) (O $ subword (k'-1) k') (getOmx s) s)-    $ mkStream ls (OStatic (di:.dj+1)) u ij-  mkStream (ls :!: Chr f xs) (ORightOf (di:.dj)) u ij-    = map (\s -> let (O (Subword (_:.k'))) = getIdx s-                     k = k'-dj-1-                 in  ElmChr (f xs k) (O $ subword (k'-1) k') (getOmx s) s)-    $ mkStream ls (ORightOf (di:.dj+1)) u ij-  mkStream (ls :!: Chr f xs) (OFirstLeft (di:.dj)) u ij-    = id-    $ map (\s -> let (O (Subword (_:.k))) = getIdx s-                 in  ElmChr (f xs k) (O $ subword k (k+1)) (getOmx s) s)-    $ mkStream ls (OFirstLeft (di+1:.dj)) u ij-  mkStream (ls :!: Chr f xs) (OLeftOf (di:.dj)) u ij-    = map (\s -> let (O (Subword (_:.k))) = getIdx s-                 in  ElmChr (f xs k) (O $ subword k (k+1)) (getOmx s) s)-    $ mkStream ls (OLeftOf (di+1:.dj)) u ij-  {-# Inline mkStream #-}----instance-  ( Monad m-  , TerminalStream m a is-  ) => TerminalStream m (TermSymbol a (Chr r x)) (is:.Subword) where-  terminalStream (a:|Chr f v) (sv:.IStatic _) (is:.ix@(Subword (i:.j)))-    -- TODO check if 'staticCheck' breaks fusion!!!-    = staticCheck (i>=0 && i<j && j<=VG.length v)-    . S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.subword (j-1) j) (os:.subword 0 0) (e:.f v (j-1)))-    . iPackTerminalStream a sv (is:.ix)-  terminalStream (a:|Chr f v) (sv:.IVariable _) (is:.ix@(Subword (i:.j)))-    = S.map (\(S6 s (zi:.Subword (_:.l)) (zo:._) is os e) -> S6 s zi zo (is:.subword l (l+1)) (os:.subword 0 0) (e:.f v l))-    . iPackTerminalStream a sv (is:.ix)-  {-# Inline terminalStream #-}--instance TermStaticVar (Chr r x) Subword where-  termStaticVar _ sv _ = sv-  termStreamIndex _ _ (Subword (i:.j)) = subword i (j-1)-  {-# Inline [0] termStaticVar   #-}-  {-# Inline [0] termStreamIndex #-}-
− ADP/Fusion/Term/Chr/Type.hs 
@@ -1,56 +0,0 @@--module ADP.Fusion.Term.Chr.Type where--import           Data.Strict.Tuple-import qualified Data.Vector.Generic as VG--import           Data.PrimitiveArray--import           ADP.Fusion.Base----- | A generic Character parser that reads a single character but allows--- passing additional information.------  'Chr' expects a function to retrieve @r@ at index position, followed by---  the actual generic vector with data.--data Chr r x where-  Chr :: VG.Vector v x-      => (v x -> Int -> r)-      -> (v x)-      -> Chr r x---- | smart constructor for regular 1-character parsers--chr :: VG.Vector v x => v x -> Chr x x-chr = Chr VG.unsafeIndex-{-# Inline chr #-}---- | Smart constructor for Maybe Peeking, followed by a character.--chrLeft xs = Chr f xs where-  f xs k = ( xs VG.!? (k-1)-           , VG.unsafeIndex xs k-           )-  {-# Inline [0] f #-}-{-# Inline chrLeft #-}--instance Build (Chr r x)--instance-  ( Element ls i-  ) => Element (ls :!: Chr r x) i where-    data Elm (ls :!: Chr r x) i = ElmChr !r !i !i !(Elm ls i)-    type Arg (ls :!: Chr r x)   = Arg ls :. r-    getArg (ElmChr x _ _ ls) = getArg ls :. x-    getIdx (ElmChr _ i _ _ ) = i-    getOmx (ElmChr _ _ o _ ) = o-    {-# Inline getArg #-}-    {-# Inline getIdx #-}-    {-# Inline getOmx #-}--deriving instance (Show i, Show r, Show (Elm ls i)) => Show (Elm (ls :!: Chr r x) i)--type instance TermArg (TermSymbol a (Chr r x)) = TermArg a :. r-
− ADP/Fusion/Term/Deletion.hs 
@@ -1,78 +0,0 @@--module ADP.Fusion.Term.Deletion-  ( module ADP.Fusion.Term.Deletion.Type-  , module ADP.Fusion.Term.Deletion.Point-  , module ADP.Fusion.Term.Deletion.Subword-  ) where--import ADP.Fusion.Term.Deletion.Point-import ADP.Fusion.Term.Deletion.Subword-import ADP.Fusion.Term.Deletion.Type---{--import           Data.Strict.Maybe-import           Data.Strict.Tuple-import           Prelude hiding (Maybe(..))-import qualified Data.Vector.Fusion.Stream.Monadic as S--import           Data.PrimitiveArray -- (Z(..), (:.)(..), Subword(..), subword, PointL(..), pointL, PointR(..), pointR)--import           ADP.Fusion.Term.Classes-import           ADP.Fusion.Term.Multi.Classes-----none = None-{-# INLINE none #-}---- | Since 'None' doesn't really do anything for all indices, we just thread it--- through.--instance TermStaticVar None ix where-  termStaticVar   _ sv _  = sv-  termStreamIndex _ _  ij = ij-  {-# INLINE termStaticVar #-}-  {-# INLINE termStreamIndex #-}--instance-  ( Monad m-  , TerminalStream m a is-  ) => TerminalStream m (TermSymbol a None) (is:.PointL) where-  terminalStream (a:|None) (sv:._) (is:._)-    = S.map (\(Qd s (z:.i) is e) -> Qd s z (is:.i) (e:.()))-    . terminalStream a sv is-    . S.map moveIdxTr-  {-# INLINE terminalStream #-}------ * Single dimensional instances for 'None' are really weird--{--instance Element ls Subword => Element (ls :!: None) Subword where-  data Elm (ls :!: None) Subword = ElmNone !Subword !(Elm ls Subword)-  type Arg (ls :!: None)         = Arg ls :. ()-  getArg (ElmNone _ l) = getArg l :. ()-  getIdx (ElmNone i _) = i-  {-# INLINE getArg #-}-  {-# INLINE getIdx #-}--}---- | The instance does nothing (except insert @()@ into the argument--- stack).--{--instance-  ( Monad m-  , MkStream m ls Subword-  ) => MkStream m (ls :!: None) Subword where-  mkStream (ls :!: None) sv lu ij-    = S.map (ElmNone ij)-    $ mkStream ls sv lu ij-  {-# INLINE mkStream #-}--}---}-
− ADP/Fusion/Term/Deletion/Point.hs 
@@ -1,62 +0,0 @@--module ADP.Fusion.Term.Deletion.Point where--import           Data.Strict.Tuple-import qualified Data.Vector.Fusion.Stream.Monadic as S--import           Data.PrimitiveArray--import           ADP.Fusion.Base-import           ADP.Fusion.Term.Deletion.Type----instance-  ( Monad m-  , MkStream m ls PointL-  ) => MkStream m (ls :!: Deletion) PointL where-  mkStream (ls :!: Deletion) (IStatic d) (PointL u) (PointL i)-    = S.map (ElmDeletion (PointL i) (PointL 0))-    $ mkStream ls (IStatic d) (PointL u) (PointL i)-  {-# Inline mkStream #-}--instance-  ( Monad m-  , Element ls (Outside PointL)-  , MkStream m ls (Outside PointL)-  ) => MkStream m (ls :!: Deletion) (Outside PointL) where-  mkStream (ls :!: Deletion) (OStatic d) (O (PointL u)) (O (PointL i))-    = S.map (\z -> ElmDeletion (O $ PointL i) (getOmx z) z)-    $ mkStream ls (OStatic d) (O $ PointL u) (O $ PointL i)-  {-# Inline mkStream #-}--instance TermStaticVar Deletion PointL where-  termStaticVar _ sv _ = sv-  termStreamIndex _ _ (PointL j) = PointL j-  {-# Inline termStaticVar #-}-  {-# Inline termStreamIndex #-}--instance TermStaticVar Deletion (Outside PointL) where-  termStaticVar   _ (OStatic d) _ = OStatic d-  termStreamIndex _ _           j = j-  {-# Inline termStaticVar #-}-  {-# Inline termStreamIndex #-}--instance-  ( Monad m-  , TerminalStream m a is-  ) => TerminalStream m (TermSymbol a Deletion) (is:.PointL) where-  terminalStream (a:|Deletion) (sv:.IStatic _) (is:.i@(PointL j))-    = S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.PointL j) (os:.PointL 0) (e:.()))-    . iPackTerminalStream a sv (is:.i)-  {-# Inline terminalStream #-}--instance-  ( Monad m-  , TerminalStream m a (Outside is)-  ) => TerminalStream m (TermSymbol a Deletion) (Outside (is:.PointL)) where-  terminalStream (a:|Deletion) (sv:.OStatic d) (O (is:.i))-    = S.map (\(S6 s (zi:._) (zo:.PointL k) (O is) (O os) e) -> S6 s zi zo (O (is:.(PointL $ k-d))) (O (os:.PointL k)) (e:.()))-    . oPackTerminalStream a sv (O (is:.i))-  {-# Inline terminalStream #-}-
− ADP/Fusion/Term/Deletion/Subword.hs 
@@ -1,32 +0,0 @@--module ADP.Fusion.Term.Deletion.Subword where--import Data.Strict.Tuple-import Data.Vector.Fusion.Stream.Monadic as S-import Prelude hiding (map)--import Data.PrimitiveArray hiding (map)--import ADP.Fusion.Base-import ADP.Fusion.Term.Deletion.Type----instance-  ( Monad m-  , TerminalStream m a is-  ) => TerminalStream m (TermSymbol a Deletion) (is:.Subword) where-  terminalStream (a:|Deletion) (sv:.IStatic _) (is:.ij@(Subword (i:.j)))-    = S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.subword j j) (os:.subword 0 0) (e:.()))-    . iPackTerminalStream a sv (is:.ij)-  terminalStream (a:|Deletion) (sv:.IVariable _) (is:.ij@(Subword (i:.j)))-    = S.map (\(S6 s (zi:.Subword (_:.l)) (zo:._) is os e) -> S6 s zi zo (is:.subword l l) (os:.subword 0 0) (e:.()))-    . iPackTerminalStream a sv (is:.ij)-  {-# Inline terminalStream #-}--instance TermStaticVar Deletion Subword where-  termStaticVar _ sv _ = sv-  termStreamIndex _ _ ij = ij-  {-# Inline termStaticVar   #-}-  {-# Inline termStreamIndex #-}-
− ADP/Fusion/Term/Deletion/Type.hs 
@@ -1,27 +0,0 @@--module ADP.Fusion.Term.Deletion.Type where--import Data.Strict.Tuple--import Data.PrimitiveArray--import ADP.Fusion.Base----data Deletion = Deletion--instance Build Deletion--instance (Element ls i) => Element (ls :!: Deletion) i where-  data Elm (ls :!: Deletion) i = ElmDeletion !i !i !(Elm ls i)-  type Arg (ls :!: Deletion)   = Arg ls :. ()-  getArg (ElmDeletion _ _ l) = getArg l :. ()-  getIdx (ElmDeletion i _ _) = i-  getOmx (ElmDeletion _ o _) = o-  {-# Inline getArg #-}-  {-# Inline getIdx #-}-  {-# Inline getOmx #-}--type instance TermArg (TermSymbol a Deletion) = TermArg a :. ()-
− ADP/Fusion/Term/Edge.hs 
@@ -1,64 +0,0 @@--module ADP.Fusion.Term.Edge-  ( module ADP.Fusion.Term.Edge.Type-  , module ADP.Fusion.Term.Edge.Set-  ) where--import ADP.Fusion.Term.Edge.Set-import ADP.Fusion.Term.Edge.Type----{---- | An edge terminal returns the pair of indices forming the edge.--data Edge e where-  Edge  :: !(Int -> Int -> e) -> Edge e--edge = (,)-{-# Inline edge #-}--instance Build (Edge i)--instance-  (Element ls i-  ) => Element (ls :!: Edge e) i where-    data Elm (ls :!: Edge e) i = ElmEdge !e !i !(Elm ls i)-    type Arg (ls :!: Edge e)   = Arg ls :. e-    getArg (ElmEdge e _ ls) = getArg ls :. e-    getIdx (ElmEdge _ i _ ) = i-    {-# Inline getArg #-}-    {-# Inline getIdx #-}--instance-  ( Monad m-  , Element ls (BitSet:>Interface First:>Interface Last)-  , MkStream m ls (BitSet:>Interface First:>Interface Last)-  ) => MkStream m (ls :!: Edge e) (BitSet:>Interface First:>Interface Last) where-    -- encodes in the first index arg, what the previously set @Last@ was-    mkStream (ls :!: Edge f) Static s@(BitSet zb:>Interface zi:>Interface zj) (BitSet b:>Interface i:>Interface j)-      -- if we have @popCount b == 1@, then this is an initial node,-      -- creating the first node. Otherwise the edge just extends an-      -- existing node.-      -- TODO need to figure out this "first node" stuff here-      = S.map (\z -> let (BitSet zb:>_:>Interface zj) = getIdx z-                     in  ElmEdge (f zj j) (BitSet b:>Interface i:>Interface j) z-              )-      $ mkStream ls (Variable Check (Just (popCount b -1) )) s (BitSet (clearBit b j):>Interface i:>Interface j)-    -- in the variable case, the @Last@ point is unset and may move freely.-    -- @First@ is still fixed. In @k@, we have the number of bits from-    -- @BitSet b@ that we should set! The bit we set is also the @Last@-    -- interface bit.-    mkStream (ls :!: Edge f) (Variable Check (Just k)) s@(BitSet zb:>Interface zi:>Interface zj) c@(BitSet b:>Interface i:>_)-      = S.flatten mk step Unknown-      $ mkStream ls (Variable Check (Just $ k-1)) s c-      where mk z = let (BitSet z':>_:>_) = getIdx z ; a = b `xor` z' in return (z,a,lsbActive a)-            step (z,a,lsbA)-              | lsbA < 0  = return $ S.Done-              | otherwise = return $ S.Yield (ElmEdge (f cj lsbA) (BitSet (cs .|. bit lsbA):>Interface ci:>Interface lsbA) z) (z,a,nextActive lsbA a)-              where (BitSet cs:>Interface ci:>Interface cj) = getIdx z-            {-# Inline [0] mk   #-}-            {-# Inline [0] step #-}-    {-# Inline mkStream #-}--}-
− ADP/Fusion/Term/Edge/Set.hs 
@@ -1,73 +0,0 @@--module ADP.Fusion.Term.Edge.Set where--import Data.Bits-import Data.Strict.Tuple-import Data.Vector.Fusion.Stream.Monadic-import Data.Vector.Fusion.Stream.Size-import Debug.Trace-import Prelude hiding (map)--import Data.PrimitiveArray hiding (map)-import Data.Bits.Ordered--import ADP.Fusion.Base-import ADP.Fusion.Term.Edge.Type----instance-  ( Monad m-  , Element    ls (BS2I First Last)-  , MkStream m ls (BS2I First Last)-  ) => MkStream m (ls :!: Edge e) (BS2I First Last) where-  mkStream (ls :!: Edge f) (IStatic rp) u sij@(s:>i:>j)-    = flatten mk step Unknown $ mkStream ls (IStatic rpn) u tik-    where rpn | j >= 0    = rp-              | otherwise = rp+1-          tik | j >= 0    = s `clearBit` (getIter j) :> i :> undefi-              | otherwise = sij-          mk z-            | j >= 0 && popCount s >= 2 = return $ This z-            | j <  0 && popCount s >= 2 = return $ That (z,bits,maybeLsb bits)-            | popCount s <= max 1 rp    = return $ Naught-            | otherwise                 = error $ show ("Edge",s,i,j)-            where (zs:>_:>zk) = getIdx z-                  bits        = s `xor` zs-          step Naught   = return Done-          step (This z)-            | popCount zs == 0 = return $ Done-            | otherwise = return $ Yield (ElmEdge (f (getIter zk) (getIter j)) sij undefbs2i z) Naught-            where (zs:>_:>zk) = getIdx z-          step (That (z,bits,Nothing)) = return $ Done-          step (That (z,bits,Just j')) = let (zs:>_:>Iter zk) = getIdx z-                                             tij'            = (zs .|. bit j') :> Iter zk :> Iter j'-                                         in  return $ Yield (ElmEdge (f zk j') tij' undefbs2i z) (That (z,bits,maybeNextActive j' bits))-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline mkStream #-}----instance-  ( Monad m-  , Element ls    (Outside (BS2I First Last))-  , MkStream m ls (Outside (BS2I First Last))-  ) => MkStream m (ls :!: Edge f) (Outside (BS2I First Last)) where-  mkStream (ls :!: Edge f) (OStatic ()) u sij-    = map undefined-    $ mkStream ls (undefined) u sij-  {-# Inline mkStream #-}----instance-  ( Monad m-  , Element ls    (Complement (BS2I First Last))-  , MkStream m ls (Complement (BS2I First Last))-  ) => MkStream m (ls :!: Edge f) (Complement (BS2I First Last)) where-  mkStream (ls :!: Edge f) Complemented u sij-    = map undefined-    $ mkStream ls Complemented u sij-  {-# Inline mkStream #-}-
− ADP/Fusion/Term/Edge/Type.hs 
@@ -1,32 +0,0 @@--module ADP.Fusion.Term.Edge.Type where--import Data.Strict.Tuple--import Data.PrimitiveArray--import ADP.Fusion.Base----data Edge e where-  Edge :: (Int -> Int -> e) -> Edge e--instance Build (Edge e)--instance-  ( Element ls i-  ) => Element (ls :!: Edge e) i where-    data Elm (ls :!: Edge e) i = ElmEdge !e !i !i (Elm ls i)-    type Arg (ls :!: Edge e)   = Arg ls :. e-    getArg (ElmEdge e _ _ ls) = getArg ls :. e-    getIdx (ElmEdge _ i _ _ ) = i-    getOmx (ElmEdge _ _ o _ ) = o-    {-# Inline getArg #-}-    {-# Inline getIdx #-}-    {-# Inline getOmx #-}--deriving instance (Show i, Show e, Show (Elm ls i)) => Show (Elm (ls :!: Edge e) i)--type instance TermArg (TermSymbol a (Edge e)) = TermArg a :. e-
− ADP/Fusion/Term/Epsilon.hs 
@@ -1,116 +0,0 @@--module ADP.Fusion.Term.Epsilon-  ( module ADP.Fusion.Term.Epsilon.Type-  , module ADP.Fusion.Term.Epsilon.Point-  , module ADP.Fusion.Term.Epsilon.Subword-  ) where--import ADP.Fusion.Term.Epsilon.Point-import ADP.Fusion.Term.Epsilon.Subword-import ADP.Fusion.Term.Epsilon.Type--{---{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-}---- | The 'Empty' terminal symbol parses only the empty (sub-)input. @Empty@--- however, can mean different things.------ 'Empty' needs to be bound to the input. We require this as certain index--- structures have no natural notion of emptyness -- unless additional--- information is given.------ Consider, for example, linear grammars. Left-linear grammars can compare the--- index @i@ to zero, @i==0@ to test for emptyness, while for right-linear--- grammars, we need to test @i==N@ with @N@ the size of the input. Instead of--- carrying @N@ around in the index, we bind the input to @Empty@.------ This choice is currently a bit of a "hunch" but we do have algorithms in--- mind, where this could be useful.--module ADP.Fusion.Term.Empty where--import           Data.Strict.Maybe-import           Prelude hiding (Maybe(..))--import           Data.PrimitiveArray -- (Z(..), (:.)(..), Subword(..), subword, PointL(..), pointL, PointR(..), pointR, Outside(..))--import           ADP.Fusion.Term.Classes-import           ADP.Fusion.Term.Multi.Classes--import           Debug.Trace------ | Empty as an argument only makes sense if empty is static. We don't get to--- use 'staticCheck' as the underlying check for the bottom of the argument--- stack should take care of the @i==j@ check.--{--instance-  ( Monad m-  , MkStream m ls Subword-  ) => MkStream m (ls :!: Empty) Subword where-  mkStream (ls :!: Empty) Static lu (Subword (i:.j))-    = S.map (ElmEmpty (subword i j))-    $ mkStream ls Static lu (subword i j)-  mkStream _ _ _ _ = error "mkStream Empty/Subword called with illegal parameters"-  {-# INLINE mkStream #-}--instance-  ( Monad m-  , MkStream m ls (Outside Subword)-  ) => MkStream m (ls :!: Empty) (Outside Subword) where-  mkStream (ls :!: Empty) Static lu (O (Subword (i:.j)))-    = S.map (ElmEmpty (O $ subword i j))-    $ mkStream ls Static lu (O $ subword i j)-  mkStream _ _ _ _ = error "mkStream Empty/Subword called with illegal parameters"-  {-# INLINE mkStream #-}--}--type instance TermArg (TermSymbol a Empty) = TermArg a :. ()--instance TermStaticVar Empty PointL where-  termStaticVar   _ sv _  = sv-  termStreamIndex _ _  ij = ij-  {-# INLINE termStaticVar #-}-  {-# INLINE termStreamIndex #-}--{--instance TermStaticVar Empty Subword where-    termStaticVar = error "write me"-    termStreamIndex = error "write me"--}---- | Again, we assume that no 'staticCheck' is necessary and that @i==j@ is--- true.--instance-  ( Monad m-  , TerminalStream m a is-  ) => TerminalStream m (TermSymbol a Empty) (is:.PointL) where-  terminalStream (a:|Empty) (sv:.Static) (is:.PointL (i:.j))-    = S.map (\(Qd s (z:.i) is e) -> Qd s z (is:.i) (e:.()))-    . terminalStream a sv is-    . S.map moveIdxTr-  terminalStream _ _ _ = error "mkStream Empty/(is:.PointL) called with illegal parameters"-  {-# INLINE terminalStream #-}--{--instance-    ( Monad m-    , TerminalStream m a is-    ) => TerminalStream m (TermSymbol a Empty) (is:.Subword) where-      terminalStream (a:>Empty) (sv:.Static) (is:.Subword (i:.j))-        = S.map (\(Qd s (z:.i) is e) -> Qd s z (is:.i) (e:.()))-        . terminalStream a sv is-        . S.map moveIdxTr-      terminalStream _ _ _ = error "mkStream Empty/(is:.Subword) called with illegal parameters"-      {-# INLINE terminalStream #-}--}---}-
− ADP/Fusion/Term/Epsilon/Point.hs 
@@ -1,62 +0,0 @@--module ADP.Fusion.Term.Epsilon.Point where--import           Data.Strict.Tuple-import qualified Data.Vector.Fusion.Stream.Monadic as S--import           Data.PrimitiveArray--import           ADP.Fusion.Base-import           ADP.Fusion.Term.Epsilon.Type----instance-  ( Monad m-  , MkStream m ls PointL-  ) => MkStream m (ls :!: Epsilon) PointL where-  mkStream (ls :!: Epsilon) (IStatic d) (PointL u) (PointL i)-    = S.map (ElmEpsilon (PointL i) (PointL 0))-    $ mkStream ls (IStatic d) (PointL u) (PointL i)-  {-# Inline mkStream #-}--instance-  ( Monad m-  , Element ls (Outside PointL)-  , MkStream m ls (Outside PointL)-  ) => MkStream m (ls :!: Epsilon) (Outside PointL) where-  mkStream (ls :!: Epsilon) (OStatic d) (O (PointL u)) (O (PointL i))-    = S.map (\z -> ElmEpsilon (O $ PointL i) (getOmx z) z)-    $ mkStream ls (OStatic d) (O $ PointL u) (O $ PointL i)-  {-# Inline mkStream #-}--instance TermStaticVar Epsilon PointL where-  termStaticVar _ sv _ = sv-  termStreamIndex _ _ (PointL j) = PointL j-  {-# Inline termStaticVar #-}-  {-# Inline termStreamIndex #-}--instance TermStaticVar Epsilon (Outside PointL) where-  termStaticVar   _ (OStatic d) _ = OStatic d-  termStreamIndex _ _           j = j-  {-# Inline termStaticVar #-}-  {-# Inline termStreamIndex #-}--instance-  ( Monad m-  , TerminalStream m a is-  ) => TerminalStream m (TermSymbol a Epsilon) (is:.PointL) where-  terminalStream (a:|Epsilon) (sv:.IStatic _) (is:.i@(PointL j))-    = S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.PointL j) (os:.PointL 0) (e:.()))-    . iPackTerminalStream a sv (is:.i)-  {-# Inline terminalStream #-}--instance-  ( Monad m-  , TerminalStream m a (Outside is)-  ) => TerminalStream m (TermSymbol a Epsilon) (Outside (is:.PointL)) where-  terminalStream (a:|Epsilon) (sv:.OStatic d) (O (is:.i))-    = S.map (\(S6 s (zi:._) (zo:.PointL k) (O is) (O os) e) -> S6 s zi zo (O (is:.(PointL $ k-d))) (O (os:.PointL k)) (e:.()))-    . oPackTerminalStream a sv (O (is:.i))-  {-# Inline terminalStream #-}-
− ADP/Fusion/Term/Epsilon/Subword.hs 
@@ -1,53 +0,0 @@--module ADP.Fusion.Term.Epsilon.Subword where--import Data.Strict.Tuple-import Data.Vector.Fusion.Stream.Monadic as S-import Prelude hiding (map)--import Data.PrimitiveArray hiding (map)--import ADP.Fusion.Base-import ADP.Fusion.Term.Epsilon.Type----import Data.Vector.Fusion.Util----instance-  ( Monad m-  , MkStream m ls Subword-  ) => MkStream m (ls :!: Epsilon) Subword where-  mkStream (ls :!: Epsilon) (IStatic ()) hh ij@(Subword (i:.j))-    = staticCheck (i==j)-    $ map (ElmEpsilon (subword i j) (subword 0 0))-    $ mkStream ls (IStatic ()) hh ij-  {-# Inline mkStream #-}--instance-  ( Monad m-  , MkStream m ls (Outside Subword)-  ) => MkStream m (ls :!: Epsilon) (Outside Subword) where-  mkStream (ls :!: Epsilon) (OStatic d) u ij@(O (Subword (i:.j)))-    = map (ElmEpsilon (O $ subword i j) (O $ subword i j))-    $ mkStream ls (OStatic d) u ij-  {-# Inline mkStream #-}----instance-  ( Monad m-  , TerminalStream m a is-  ) => TerminalStream m (TermSymbol a Epsilon) (is:.Subword) where-  terminalStream (a:|Epsilon) (sv:.IStatic _) (is:.ij@(Subword (i:.j)))-    = S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.subword i j) (os:.subword 0 0) (e:.()))-    . iPackTerminalStream a sv (is:.ij)-  {-# Inline terminalStream #-}--instance TermStaticVar Epsilon Subword where-  termStaticVar _ sv _ = sv-  termStreamIndex _ _ ij = ij-  {-# Inline termStaticVar #-}-  {-# Inline termStreamIndex #-}--
− ADP/Fusion/Term/Epsilon/Type.hs 
@@ -1,27 +0,0 @@--module ADP.Fusion.Term.Epsilon.Type where--import Data.Strict.Tuple--import Data.PrimitiveArray--import ADP.Fusion.Base----data Epsilon = Epsilon--instance Build Epsilon--instance (Element ls i) => Element (ls :!: Epsilon) i where-  data Elm (ls :!: Epsilon) i = ElmEpsilon !i !i !(Elm ls i)-  type Arg (ls :!: Epsilon)   = Arg ls :. ()-  getArg (ElmEpsilon _ _ l) = getArg l :. ()-  getIdx (ElmEpsilon i _ _) = i-  getOmx (ElmEpsilon _ o _) = o-  {-# Inline getArg #-}-  {-# Inline getIdx #-}-  {-# Inline getOmx #-}--type instance TermArg (TermSymbol a Epsilon) = TermArg a :. ()-
− ADP/Fusion/Term/PeekIndex.hs 
@@ -1,8 +0,0 @@--module ADP.Fusion.Term.PeekIndex-  ( module ADP.Fusion.Term.PeekIndex.Type-  , module ADP.Fusion.Term.PeekIndex.Subword-  ) where--import ADP.Fusion.Term.PeekIndex.Subword-import ADP.Fusion.Term.PeekIndex.Type
− ADP/Fusion/Term/PeekIndex/Subword.hs 
@@ -1,24 +0,0 @@--module ADP.Fusion.Term.PeekIndex.Subword where--import Data.Strict.Tuple-import Data.Vector.Fusion.Stream.Monadic (map)-import Prelude hiding (map)--import Data.PrimitiveArray hiding (map)--import ADP.Fusion.Base-import ADP.Fusion.Term.PeekIndex.Type----instance-  ( Monad m-  , Element ls (Complement Subword)-  , MkStream m ls (Complement Subword)-  ) => MkStream m (ls :!: PeekIndex (Complement Subword)) (Complement Subword) where-  mkStream (ls :!: PeekIndex) Complemented h ij-    = map (\s -> ElmPeekIndex (getIdx s) (getOmx s) s)-    $ mkStream ls Complemented h ij-  {-# Inline mkStream #-}-
− ADP/Fusion/Term/PeekIndex/Type.hs 
@@ -1,31 +0,0 @@--module ADP.Fusion.Term.PeekIndex.Type where--import Data.Strict.Tuple--import Data.PrimitiveArray--import ADP.Fusion.Base----data PeekIndex i = PeekIndex--instance Build (PeekIndex i)--instance-  ( Element ls i-  ) => Element (ls :!: PeekIndex i) i where-    data Elm (ls :!: PeekIndex i) i = ElmPeekIndex !i !i !(Elm ls i)-    type Arg (ls :!: PeekIndex i)   = Arg ls :. (i :. i)-    getArg (ElmPeekIndex i o ls)    = getArg ls :. (i:.o)-    getIdx (ElmPeekIndex i _ _ )    = i-    getOmx (ElmPeekIndex _ o _ )    = o-    {-# Inline getArg #-}-    {-# Inline getIdx #-}-    {-# Inline getOmx #-}--deriving instance (Show i, Show (Elm ls i)) => Show (Elm (ls :!: PeekIndex i) i)--type instance TermArg (TermSymbol a (PeekIndex i)) = TermArg a :. PeekIndex i-
− ADP/Fusion/Term/Strng.hs 
@@ -1,13 +0,0 @@---- | A 'Strng' matches [0..] 'Chr's.--module ADP.Fusion.Term.Strng-  ( module ADP.Fusion.Term.Strng.Type-  , module ADP.Fusion.Term.Strng.Point-  , module ADP.Fusion.Term.Strng.Subword-  ) where--import ADP.Fusion.Term.Strng.Point-import ADP.Fusion.Term.Strng.Subword-import ADP.Fusion.Term.Strng.Type-
− ADP/Fusion/Term/Strng/Point.hs 
@@ -1,43 +0,0 @@--module ADP.Fusion.Term.Strng.Point where--import           Data.Strict.Tuple-import           Debug.Trace-import qualified Data.Vector.Fusion.Stream.Monadic as S-import qualified Data.Vector.Generic as VG--import           Data.PrimitiveArray--import           ADP.Fusion.Base-import           ADP.Fusion.Term.Strng.Type----instance-  ( Monad m-  , Element ls PointL-  , MkStream m ls PointL-  ) => MkStream m (ls :!: Strng v x) PointL where-  mkStream (ls :!: Strng f minL maxL xs) (IStatic d) (PointL u) (PointL i)-    = staticCheck (i - minL >= 0 && i <= u && minL <= maxL)-    $ S.map (\z -> let PointL j = getIdx z in ElmStrng (f j (i-j) xs) (PointL i) (PointL 0) z)-    $ mkStream ls (IVariable $ d + maxL - minL) (PointL u) (PointL $ i - minL)-  mkStream _ _ _ _ = error "mkStream / Strng / PointL / IVariable"-  {-# Inline mkStream #-}--instance TermStaticVar (Strng v x) PointL where-  termStaticVar _ (IStatic   d) _ = IVariable d-  termStaticVar _ (IVariable d) _ = IVariable d-  termStreamIndex (Strng _ minL _ _) (IStatic d) (PointL j) = PointL $ j - minL-  {-# Inline [0] termStaticVar   #-}-  {-# Inline [0] termStreamIndex #-}--instance-  ( Monad m-  , TerminalStream m a is-  ) => TerminalStream m (TermSymbol a (Strng v x)) (is:.PointL) where-  terminalStream (a:|Strng f minL maxL xs) (sv:.IStatic d) (is:.i@(PointL j))-    = S.map (\(S6 s (zi:.PointL pi) (zo:._) is os e) -> S6 s zi zo (is:.i) (os:.PointL 0) (e:.f pi (j-pi) xs))-    . iPackTerminalStream a sv (is:.i)-  {-# Inline terminalStream #-}-
− ADP/Fusion/Term/Strng/Subword.hs 
@@ -1,44 +0,0 @@--module ADP.Fusion.Term.Strng.Subword where---import           Data.Strict.Tuple-import           Data.Vector.Fusion.Stream.Size-import           Data.Vector.Fusion.Util (delay_inline)-import           Debug.Trace-import           Prelude hiding (map)-import qualified Data.Vector.Fusion.Stream.Monadic as S-import qualified Data.Vector.Generic as VG--import           Data.PrimitiveArray--import           ADP.Fusion.Base-import           ADP.Fusion.Term.Strng.Type------ | TODO If we use (IVariable mx) we might be able to request @exactly@--- the range we need!--instance-  ( Monad m-  , Element ls Subword-  , MkStream m ls Subword-  ) => MkStream m (ls :!: Strng v x) Subword where-  mkStream (ls :!: Strng slice mn mx v) (IStatic ()) hh (Subword (i:.j))-    = S.filter (\s -> let Subword (k:.l) = getIdx s in l-k <= mx)-    . S.map (\s -> let (Subword (_:.l)) = getIdx s-                   in  ElmStrng (slice l (j-l) v) (subword l j) (subword 0 0) s)-    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - mn))-  mkStream (ls :!: Strng slice mn mx v) (IVariable ()) hh (Subword (i:.j))-    = S.flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - mn))-    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - mn)-          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s-                                        l              = j - z-                                        kl             = subword k l-                                    return $ S.Yield (ElmStrng (slice k (l-k) v) kl (subword 0 0) s) (s:.z-1)-                      | otherwise = return $ S.Done-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline mkStream #-}-
− ADP/Fusion/Term/Strng/Type.hs 
@@ -1,56 +0,0 @@--module ADP.Fusion.Term.Strng.Type where--import           Data.Strict.Tuple-import qualified Data.Vector.Generic as VG--import           Data.PrimitiveArray--import           ADP.Fusion.Base------ | 'Strng' terminals return "strings", i.e. vectors of @Chr@s. They allow--- the user to specify @[ 0 .. ]@ atoms to be parsed at once. It is--- possible to both, limit the minimal and maximal number.------ NOTE gadt comments are not parsed by haddock?--data Strng v x where-  Strng :: VG.Vector v x-        => (Int -> Int -> v x -> v x)  -- @slice@ function-        -> Int                         -- minimal size-        -> Int                         -- maximal size (just use s.th. big if you don't want a limit)-        -> (v x)                       -- the actual vector-        -> Strng v x--manyS :: VG.Vector v x => v x -> Strng v x-manyS = \xs -> Strng VG.unsafeSlice 0 (VG.length xs) xs-{-# Inline manyS #-}--someS :: VG.Vector v x => v x -> Strng v x-someS = \xs -> Strng VG.unsafeSlice 1 (VG.length xs) xs-{-# Inline someS #-}--strng :: VG.Vector v x => Int -> Int -> v x -> Strng v x-strng = \minL maxL xs -> Strng VG.unsafeSlice minL maxL xs-{-# Inline strng #-}--instance Build (Strng v x)--instance-  ( Element ls i-  ) => Element (ls :!: Strng v x) i where-  data Elm (ls :!: Strng v x) i = ElmStrng !(v x) !i !i !(Elm ls i)-  type Arg (ls :!: Strng v x)   = Arg ls :. v x-  getArg (ElmStrng x _ _ ls) = getArg ls :. x-  getIdx (ElmStrng _ i _ _ ) = i-  getOmx (ElmStrng _ _ o _ ) = o-  {-# Inline getArg #-}-  {-# Inline getIdx #-}-  {-# Inline getOmx #-}--deriving instance (Show i, Show (v x), Show (Elm ls i)) => Show (Elm (ls :!: Strng v x) i)--type instance TermArg (TermSymbol a (Strng v x)) = TermArg a :. v x-
+ ADP/Fusion/Unit.hs view
@@ -0,0 +1,18 @@++-- | Unit indices have just a single element in their set. This is actually+-- *not* useless, since it can be used to "fold" from another index+-- structure into the single @()@ element.++module ADP.Fusion.Unit+  ( module ADP.Fusion.Core+  , module ADP.Fusion.Unit.SynVar.Indices+  , module ADP.Fusion.Unit.Term.Deletion+  , module ADP.Fusion.Unit.Term.Epsilon+  ) where++import ADP.Fusion.Core++import ADP.Fusion.Unit.SynVar.Indices+import ADP.Fusion.Unit.Term.Deletion+import ADP.Fusion.Unit.Term.Epsilon+
+ ADP/Fusion/Unit/Core.hs view
@@ -0,0 +1,116 @@++-- |+--+-- TODO the 'mkStream' instances here are probably wonky for everything that is+-- non-static.+--+-- TODO should @d@ in each case here be @d==0@? What is the exact meaning @d@+-- should convey?++module ADP.Fusion.Unit.Core where++import Data.Proxy+import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..))+import Debug.Trace+import Prelude hiding (map,filter)++import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi++++type instance InitialContext (Unit I) = IStatic 0++type instance InitialContext (Unit O) = OStatic 0++type instance InitialContext (Unit C) = Complement++data instance RunningIndex (Unit t) = RiUnit++++instance+  ( Monad m+  )+  ⇒ MkStream m (IStatic d) S (Unit I) where+  mkStream Proxy S grd LtUnit Unit+    = staticCheck# grd+    . singleton $ ElmS RiUnit+  {-# Inline mkStream #-}++instance+  ( Monad m+  )+  ⇒ MkStream m (IVariable d) S (Unit I) where+  mkStream Proxy S grd LtUnit Unit+    = staticCheck# grd+    . singleton $ ElmS RiUnit+  {-# Inline mkStream #-}++instance+  ( Monad m+  )+  ⇒ MkStream m (OStatic d) S (Unit O) where+  mkStream Proxy S grd LtUnit Unit+    = staticCheck# grd+    . singleton $ ElmS RiUnit+  {-# Inline mkStream #-}++instance+  ( Monad m+  )+  ⇒ MkStream m Complement S (Unit C) where+  mkStream Proxy S grd LtUnit Unit+    = staticCheck# grd+    . singleton $ ElmS RiUnit+  {-# Inline mkStream #-}++--instance+--  forall m ps p is+--  . ( Monad m+--    , MkStream m ps S is+--    )+--  ⇒ MkStream m ('(:.) ps p) S (is:.Unit I) where+--  mkStream Proxy S grd (us:.._) (is:._)+--    = map (\(ElmS zi) -> ElmS $ zi :.: RiU)+--    $ mkStream (Proxy ∷ Proxy ps) S grd us is+--  {-# Inline mkStream #-}+--+--instance+--  forall m ps p is+--  . ( Monad m+--    , MkStream m ps S is+--    )+--  ⇒ MkStream m ('(:.) ps p) S (is:.Unit O) where+--  mkStream Proxy S grd (us:.._) (is:._)+--    = map (\(ElmS zi) -> ElmS $ zi :.: RiU)+--    $ mkStream (Proxy ∷ Proxy ps) S grd us is+--  {-# Inline mkStream #-}+--+--instance+--  forall m ps p is+--  . ( Monad m+--    , MkStream m ps S is+--    )+--  ⇒ MkStream m ('(:.) ps p) S (is:.Unit C) where+--  mkStream Proxy S grd (us:.._) (is:._)+--    = map (\(ElmS zi) -> ElmS $ zi :.: RiU)+--    $ mkStream (Proxy ∷ Proxy ps) S grd us is+--  {-# Inline mkStream #-}+--+--+--+--instance TableStaticVar pos c u (Unit I) where+--  tableStreamIndex _ _ _ _ = Unit+--  {-# Inline [0] tableStreamIndex #-}+--+--instance TableStaticVar pos c u (Unit O) where+--  tableStreamIndex _ _ _ _ = Unit+--  {-# Inline [0] tableStreamIndex #-}+--+--instance TableStaticVar pos c u (Unit C) where+--  tableStreamIndex _ _ _ _ = Unit+--  {-# Inline [0] tableStreamIndex #-}+
+ ADP/Fusion/Unit/SynVar/Indices.hs view
@@ -0,0 +1,70 @@++-- | TODO if we have a table that has min-size @>0@ we need to immediately+-- terminate @addIndexDenseGo@ !++module ADP.Fusion.Unit.SynVar.Indices where++import Data.Proxy+import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..))+import Data.Vector.Fusion.Util (delay_inline)+import Prelude hiding (map,head,mapM)++import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core+import ADP.Fusion.Unit.Core++++type instance LeftPosTy (IStatic d) (TwITbl b s m arr EmptyOk (Unit I) x) (Unit I) = IStatic d+type instance LeftPosTy (IStatic d) (TwITblBt b s arr EmptyOk (Unit I) x mB mF r) (Unit I) = IStatic d++type instance LeftPosTy (OStatic d) (TwITbl b s m arr EmptyOk (Unit O) x) (Unit O) = OStatic d+type instance LeftPosTy (OStatic d) (TwITblBt b s arr EmptyOk (Unit O) x mB mF r) (Unit O) = OStatic d++type instance LeftPosTy Complement (TwITbl b s m arr EmptyOk (Unit I) x) (Unit C) = Complement+type instance LeftPosTy Complement (TwITblBt b s arr EmptyOk (Unit I) x mB mF r) (Unit C) = Complement++type instance LeftPosTy Complement (TwITbl b s m arr EmptyOk (Unit O) x) (Unit C) = Complement+type instance LeftPosTy Complement (TwITblBt b s arr EmptyOk (Unit O) x mB mF r) (Unit C) = Complement++instance+  ( AddIndexDenseContext ps elm x0 i0 cs c us (Unit I) is (Unit I)+  , MinSize c+  )+  ⇒ AddIndexDense (ps:.Unit d) elm (cs:.c) (us:.Unit I) (is:.Unit I) where+  addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i)+    = map (\(SvS s t y') → SvS s (t:.i) (y' :.: RiUnit))+    . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is+  {-# Inline addIndexDenseGo #-}++instance+  ( AddIndexDenseContext ps elm x0 i0 cs c us (Unit O) is (Unit O)+  , MinSize c+  )+  ⇒ AddIndexDense (ps:.Unit d) elm (cs:.c) (us:.Unit O) (is:.Unit O) where+  addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i)+    = map (\(SvS s t y') → SvS s (t:.i) (y' :.: RiUnit))+    . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is+  {-# Inline addIndexDenseGo #-}++instance+  ( AddIndexDenseContext ps elm x0 i0 cs c us (Unit I) is (Unit C)+  , MinSize c+  )+  ⇒ AddIndexDense (ps:.Unit d) elm (cs:.c) (us:.Unit I) (is:.Unit C) where+  addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i)+    = map (\(SvS s t y') → SvS s (t:.Unit) (y' :.: RiUnit))+    . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is+  {-# Inline addIndexDenseGo #-}++instance+  ( AddIndexDenseContext ps elm x0 i0 cs c us (Unit O) is (Unit C)+  , MinSize c+  )+  ⇒ AddIndexDense (ps:.Unit d) elm (cs:.c) (us:.Unit O) (is:.Unit C) where+  addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i)+    = map (\(SvS s t y') → SvS s (t:.Unit) (y' :.: RiUnit))+    . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is+  {-# Inline addIndexDenseGo #-}+
+ ADP/Fusion/Unit/Term/Deletion.hs view
@@ -0,0 +1,47 @@++module ADP.Fusion.Unit.Term.Deletion where++import           Data.Proxy+import           Data.Strict.Tuple+import qualified Data.Vector.Fusion.Stream.Monadic as S+import           GHC.Exts++import           Data.PrimitiveArray++import           ADP.Fusion.Core+import           ADP.Fusion.Unit.Core++++instance+  forall m pos posLeft ls i+  . ( TermStream m (Z:.pos) (TermSymbol M Deletion) (Elm (Term1 (Elm ls (Unit i))) (Z :. Unit i)) (Z:.Unit i)+    , posLeft ~ LeftPosTy pos Deletion (Unit i)+    , TermStaticVar pos Deletion (Unit i)+    , MkStream m posLeft ls (Unit i)+    )+  ⇒ MkStream m pos (ls :!: Deletion) (Unit i) where+  mkStream pos (ls :!: Deletion) grd us is+    = S.map (\(ss,ee,ii) -> ElmDeletion ii ss)+    . addTermStream1 pos Deletion us is+    . mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos Deletion us is grd) us+    $ (termStreamIndex pos Deletion is)+  {-# Inline mkStream #-}+++instance+  ( TermStreamContext m ps ts s x0 i0 is (Unit I)+  , Monad m+  , (TermStream m ps ts (Elm x0 i0) is)+  ) => TermStream m ('(:.) ps p) (TermSymbol ts Deletion) s (is:.Unit I) where+  termStream Proxy (ts:|Deletion) (us:.._) (is:._)+    = S.map (\(TState s ii ee) -> TState s (ii:.:RiUnit) (ee:.()))+    . termStream (Proxy ∷ Proxy ps) ts us is+  {-# Inline termStream #-}++instance TermStaticVar (IStatic d) Deletion (Unit I) where+  termStreamIndex Proxy Deletion Unit = Unit+  termStaticCheck Proxy Deletion _ Unit grd = grd+  {-# Inline [0] termStreamIndex #-}+  {-# Inline [0] termStaticCheck #-}+
+ ADP/Fusion/Unit/Term/Epsilon.hs view
@@ -0,0 +1,65 @@++module ADP.Fusion.Unit.Term.Epsilon where++import           Data.Proxy+import           Data.Strict.Tuple+import qualified Data.Vector.Fusion.Stream.Monadic as S+import           GHC.Exts++import           Data.PrimitiveArray++import           ADP.Fusion.Core+import           ADP.Fusion.Unit.Core++++instance+  forall m pos posLeft ls i lg+  . ( TermStream m (Z:.pos) (TermSymbol M (Epsilon lg)) (Elm (Term1 (Elm ls (Unit i))) (Z:.Unit i)) (Z:.Unit i)+    , posLeft ~ LeftPosTy pos (Epsilon lg) (Unit i)+    , TermStaticVar pos (Epsilon lg) (Unit i)+    , MkStream m posLeft ls (Unit i)+    )+  ⇒ MkStream m pos (ls :!: Epsilon lg) (Unit i) where+  mkStream pos (ls :!: Epsilon) grd us is+    = S.map (\(ss,ee,ii) -> ElmEpsilon ii ss)+    . addTermStream1 pos (Epsilon @lg) us is+    . mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos (Epsilon @lg) us is grd) us+    $ termStreamIndex pos (Epsilon @lg) is+  {-# Inline mkStream #-}++++--instance+--  ( TermStreamContext m ps ts s x0 i0 is (Unit I)+--  , TermStream m ps ts (Elm x0 i0) is+--  ) ⇒ TermStream m (TermSymbol ts Epsilon) s (is:.Unit I) where+--  termStream (ts:|Epsilon) (cs:.IStatic ()) (us:.._) (is:._)+--    = S.map (\(TState s ii ee) -> TState s (ii:.:RiU) (ee:.()))+--    . termStream ts cs us is+--  {-# Inline termStream #-}++{-+instance+  ( TstCtx m ts s x0 i0 is (Unit O)+  ) => TermStream m (TermSymbol ts Epsilon) s (is:.Unit O) where+  termStream (ts:|Epsilon) (cs:.OStatic ()) (us:.._) (is:._)+    = S.map (\(TState s ii ee) -> TState s (ii:.:RiU) (ee:.()))+    . termStream ts cs us is+  {-# Inline termStream #-}++++instance TermStaticVar Epsilon (Unit I) where+  termStaticVar _ _ _ = IStatic ()+  termStreamIndex _ _ _ = Unit+  {-# Inline [0] termStaticVar #-}+  {-# Inline [0] termStreamIndex #-}++instance TermStaticVar Epsilon (Unit O) where+  termStaticVar _ _ _ = OStatic ()+  termStreamIndex _ _ _ = Unit+  {-# Inline [0] termStaticVar #-}+  {-# Inline [0] termStreamIndex #-}+-}+
ADPfusion.cabal view
@@ -1,45 +1,46 @@+cabal-version:  2.2 name:           ADPfusion-version:        0.4.1.1-author:         Christian Hoener zu Siederdissen, 2011-2015-copyright:      Christian Hoener zu Siederdissen, 2011-2015+version:        0.6.0.0+author:         Christian Hoener zu Siederdissen, 2011-2019+copyright:      Christian Hoener zu Siederdissen, 2011-2019 homepage:       https://github.com/choener/ADPfusion bug-reports:    https://github.com/choener/ADPfusion/issues maintainer:     choener@bioinf.uni-leipzig.de category:       Algorithms, Data Structures, Bioinformatics, Formal Languages-license:        BSD3+license:        BSD-3-Clause license-file:   LICENSE build-type:     Simple stability:      experimental-cabal-version:  >= 1.10.0-tested-with:    GHC == 7.8.4, GHC == 7.10.1+tested-with:    GHC == 8.6.4 synopsis:       Efficient, high-level dynamic programming. description:                 <http://www.bioinf.uni-leipzig.de/Software/gADP/ generalized Algebraic Dynamic Programming>                 .-                ADPfusion combines stream-fusion (using the stream interface-                provided by the vector library) and type-level programming to-                provide highly efficient dynamic programming combinators.+                ADPfusion combines stream-fusion (using the stream interface provided by the vector+                library) and type-level programming to provide highly efficient dynamic programming+                combinators.                 .-                ADPfusion allows writing dynamic programs for single- and-                multi-tape problems. Inputs can be sequences, or sets. New-                input types can be defined, without having to rewrite this-                library thanks to the open-world assumption of ADPfusion.+                ADPfusion allows writing dynamic programs for single- and multi-tape problems.+                Inputs can be sequences, or sets. New input types can be defined, without having to+                rewrite this library thanks to the open-world assumption of ADPfusion.                 .-                The library provides the machinery for Outside and Ensemble-                algorithms as well. Ensemble algorithms combine Inside and-                Outside calculations.+                The library provides the machinery for Outside and Ensemble algorithms as well.+                Ensemble algorithms combine Inside and Outside calculations.                 .-                Starting with version 0.4.1 we support writing multiple-                context-free grammars (interleaved syntactic variables). Such-                grammars have applications in bioinformatics and linguistics.+                Starting with version 0.4.1 we support writing multiple context-free grammars+                (interleaved syntactic variables). Such grammars have applications in bioinformatics+                and linguistics.                 .-                The homepage provides a number of tutorial-style examples, with-                linear and context-free grammars over sequence and set inputs.+                The homepage provides a number of tutorial-style examples, with linear and+                context-free grammars over sequence and set inputs.                 .-                The formal background for generalized algebraic dynamic-                progrmaming and ADPfusion is described in a number of papers.-                These can be found on the gADP homepage and in the README.+                The formal background for generalized algebraic dynamic programming and ADPfusion is+                described in a number of papers. These can be found on the gADP homepage and in the+                README.                 .+                Note: The core @ADPfusion@ library only provides machinery for linear language over+                sequences. The add-ons @ADPfusionSubword@, @ADPfusionForest@, and others provide+                specialized machinery for other types of formal languages.   @@ -49,305 +50,285 @@   +flag debug+  description:  Enable bounds checking and various other debug operations at the cost of a significant performance penalty.+  default:      False+  manual:       True++flag debugoutput+  description:  Enable debug output, which spams the screen full of index information+  default:      False+  manual:       True++flag debugdump+  description:  Enable dumping intermediate / core files+  default:      False+  manual:       True++flag dump-core+  description: Dump HTML for the core generated by GHC during compilation+  default:     False+  manual:      True+ flag examples   description:  build the examples   default:      False   manual:       True -flag debug-  description:  dump intermediate Core files+flag spectest+  description:  build the spec-ctor test case   default:      False   manual:       True +flag devel+  description:  build additional tests+  default:      False+  manual:       True +flag btstruc+  description:  performance test for backtracking structures+  default:      False+  manual:       True -library--- ghc-prim: for reallyUnsafePtrEquality#-  build-depends: base               >= 4.7      && < 4.9-               , bits               >= 0.4      && < 0.5-               , containers-               , ghc-prim-               , mmorph             >= 1.0      && < 1.1-               , monad-primitive    >= 0.1      && < 0.2-               , mtl                >= 2.0      && < 2.3-               , OrderedBits        >= 0.0.0.1  && < 0.0.1-               , primitive          >= 0.5.4    && < 0.7-               , PrimitiveArray     >= 0.6.1    && < 0.6.2-               , QuickCheck         >= 2.7      && < 2.9-               , strict             >= 0.3      && < 0.4-               , template-haskell   >= 2.0      && < 3.0-               , th-orphans         >= 0.12     && < 0.13-               , transformers       >= 0.3      && < 0.5-               , tuple              >= 0.3      && < 0.4-               , vector             >= 0.10     && < 0.11+flag llvm+  description:  use llvm+  default:      False+  manual:       True -  exposed-modules:-    ADP.Fusion-    ADP.Fusion.Apply-    ADP.Fusion.Base-    ADP.Fusion.Base.Classes-    ADP.Fusion.Base.Multi-    ADP.Fusion.Base.Point-    ADP.Fusion.Base.Set-    ADP.Fusion.Base.Subword-    ADP.Fusion.QuickCheck.Common-    ADP.Fusion.QuickCheck.Point-    ADP.Fusion.QuickCheck.Set-    ADP.Fusion.QuickCheck.Subword-    ADP.Fusion.SynVar-    ADP.Fusion.SynVar.Array-    ADP.Fusion.SynVar.Array.Point-    ADP.Fusion.SynVar.Array.Set-    ADP.Fusion.SynVar.Array.Subword-    ADP.Fusion.SynVar.Array.TermSymbol-    ADP.Fusion.SynVar.Array.Type-    ADP.Fusion.SynVar.Axiom-    ADP.Fusion.SynVar.Backtrack-    ADP.Fusion.SynVar.Fill-    ADP.Fusion.SynVar.Indices-    ADP.Fusion.SynVar.Recursive-    ADP.Fusion.SynVar.Recursive.Point-    ADP.Fusion.SynVar.Recursive.Subword-    ADP.Fusion.SynVar.Recursive.Type-    ADP.Fusion.SynVar.Split-    ADP.Fusion.SynVar.Split.Subword-    ADP.Fusion.SynVar.Split.Type-    ADP.Fusion.Term-    ADP.Fusion.Term.Chr-    ADP.Fusion.Term.Chr.Point-    ADP.Fusion.Term.Chr.Subword-    ADP.Fusion.Term.Chr.Type-    ADP.Fusion.Term.Deletion-    ADP.Fusion.Term.Deletion.Point-    ADP.Fusion.Term.Deletion.Subword-    ADP.Fusion.Term.Deletion.Type-    ADP.Fusion.Term.Edge-    ADP.Fusion.Term.Edge.Set-    ADP.Fusion.Term.Edge.Type-    ADP.Fusion.Term.Epsilon-    ADP.Fusion.Term.Epsilon.Point-    ADP.Fusion.Term.Epsilon.Subword-    ADP.Fusion.Term.Epsilon.Type-    ADP.Fusion.Term.PeekIndex-    ADP.Fusion.Term.PeekIndex.Subword-    ADP.Fusion.Term.PeekIndex.Type-    ADP.Fusion.Term.Strng-    ADP.Fusion.Term.Strng.Point-    ADP.Fusion.Term.Strng.Subword-    ADP.Fusion.Term.Strng.Type-    ADP.Fusion.TH-    ADP.Fusion.TH.Backtrack-    ADP.Fusion.TH.Common ++common deps+  build-depends: base               >= 4.7    && < 5.0+               , bits               >= 0.4+               , containers+               , deepseq+               , ghc-prim+               , mmorph             >= 1.0+               , mtl                >= 2.0+               , primitive          >= 0.5.4+               , QuickCheck         >= 2.7+               , singletons         >= 2.4+               , strict             >= 0.3+               , template-haskell   >= 2.0+               , th-orphans         >= 0.12+               , transformers       >= 0.3+               , tuple              >= 0.3+               , vector             >= 0.11+               --+               , DPutils            == 0.1.0.*+               , OrderedBits        == 0.0.2.*+               , PrimitiveArray     == 0.10.0.*   default-extensions: BangPatterns+                    , ConstraintKinds+                    , CPP                     , DataKinds                     , DefaultSignatures+                    , DeriveAnyClass+                    , DeriveDataTypeable+                    , DeriveGeneric                     , FlexibleContexts                     , FlexibleInstances                     , GADTs                     , KindSignatures+                    , MagicHash                     , MultiParamTypeClasses+                    -- PolyKinds is very important to get GHC to pick up all+                    -- the instances correctly.+                    , PolyKinds                     , RankNTypes                     , RecordWildCards                     , ScopedTypeVariables                     , StandaloneDeriving                     , TemplateHaskell+                    , TupleSections+                    , TypeApplications                     , TypeFamilies                     , TypeOperators                     , TypeSynonymInstances                     , UndecidableInstances-+                    , UnicodeSyntax   default-language:     Haskell2010   ghc-options:     -O2 -funbox-strict-fields------ Very simple two-sequence alignment.--executable NeedlemanWunsch--  if flag(examples)-    buildable:-      True-    build-depends:  base-                 ,  ADPfusion-                 ,  PrimitiveArray-                 ,  template-haskell-                 ,  vector-  else-    buildable:-      False-  hs-source-dirs:-    src-  main-is:-    NeedlemanWunsch.hs-  default-language:-    Haskell2010-  default-extensions: BangPatterns-                    , FlexibleContexts-                    , FlexibleInstances-                    , MultiParamTypeClasses-                    , RecordWildCards-                    , TemplateHaskell-                    , TypeFamilies-                    , TypeOperators-  ghc-options:-    -O2-    -funbox-strict-fields-    -funfolding-use-threshold1000-    -funfolding-keeness-factor1000-  if flag(debug)+  if flag(debugdump)     ghc-options:       -ddump-to-file       -ddump-simpl       -dsuppress-all+  if flag(dump-core)+    build-depends: dump-core+    ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html   --- Basic RNA secondary structure folding+library+  import:+    deps+  exposed-modules:+    -- core system+    ADP.Fusion.Core+    ADP.Fusion.Core.Apply+    ADP.Fusion.Core.Classes+    ADP.Fusion.Core.Multi+    ADP.Fusion.Core.SynVar.Array+    ADP.Fusion.Core.SynVar.Array.Type+    ADP.Fusion.Core.SynVar.Axiom+    ADP.Fusion.Core.SynVar.Backtrack+    ADP.Fusion.Core.SynVar.Fill+    ADP.Fusion.Core.SynVar.FillTyLvl+    ADP.Fusion.Core.SynVar.Indices+    ADP.Fusion.Core.SynVar.Recursive.Type+    ADP.Fusion.Core.SynVar.Split.Type+    ADP.Fusion.Core.SynVar.TableWrap+    ADP.Fusion.Core.Term.Chr+    ADP.Fusion.Core.Term.Deletion+    ADP.Fusion.Core.Term.Edge+    ADP.Fusion.Core.Term.Epsilon+    ADP.Fusion.Core.Term.MultiChr+    ADP.Fusion.Core.Term.PeekIndex+    ADP.Fusion.Core.Term.Str+    ADP.Fusion.Core.Term.Switch+    ADP.Fusion.Core.Term.Test+    ADP.Fusion.Core.TH+    ADP.Fusion.Core.TH.Backtrack+    ADP.Fusion.Core.TH.Common+    ADP.Fusion.Core.TyLvlIx+--    -- Point L+    ADP.Fusion.PointL+    ADP.Fusion.PointL.Core+    ADP.Fusion.PointL.SynVar.Indices+--    ADP.Fusion.PointL.SynVar.Recursive+    ADP.Fusion.PointL.Term.Chr+    ADP.Fusion.PointL.Term.Deletion+    ADP.Fusion.PointL.Term.Epsilon+    ADP.Fusion.PointL.Term.MultiChr+    ADP.Fusion.PointL.Term.Str+    ADP.Fusion.PointL.Term.Switch+--    ADP.Fusion.PointL.Term.Test+--    -- Point R+    ADP.Fusion.PointR+    ADP.Fusion.PointR.Core+    ADP.Fusion.PointR.SynVar.Indices+    ADP.Fusion.PointR.Term.Chr+    ADP.Fusion.PointR.Term.Deletion+    ADP.Fusion.PointR.Term.Epsilon+    ADP.Fusion.PointR.Term.MultiChr+    -- Unit+    ADP.Fusion.Unit+    ADP.Fusion.Unit.Core+    ADP.Fusion.Unit.SynVar.Indices+    ADP.Fusion.Unit.Term.Deletion+    ADP.Fusion.Unit.Term.Epsilon+--    -- tutorials+--    ADP.Fusion.Tutorial.NeedlemanWunsch -executable Nussinov -  if flag(examples)-    buildable:-      True-    build-depends:  base-                 ,  ADPfusion-                 ,  PrimitiveArray-                 ,  template-haskell-                 ,  vector-  else-    buildable:-      False-  hs-source-dirs:-    src++test-suite properties+  import:+    deps+  type:+    exitcode-stdio-1.0   main-is:-    Nussinov.hs-  default-language:-    Haskell2010-  default-extensions: BangPatterns-                    , FlexibleContexts-                    , FlexibleInstances-                    , MultiParamTypeClasses-                    , RecordWildCards-                    , TemplateHaskell-                    , TypeFamilies-                    , TypeOperators-                    , UndecidableInstances+    properties.hs+  other-modules:+    QuickCheck.Common+    QuickCheck.Point   ghc-options:-    -O2-    -funbox-strict-fields-    -funfolding-use-threshold1000-    -funfolding-keeness-factor1000-  if flag(debug)-    ghc-options:-      -ddump-to-file-      -ddump-simpl-      -dsuppress-all+    -threaded -rtsopts -with-rtsopts=-N+  hs-source-dirs:+    tests+  cpp-options:+    -DADPFUSION_TEST_SUITE_PROPERTIES+  build-depends: ADPfusion+               , tasty                        >= 0.11+               , tasty-quickcheck             >= 0.8+               , tasty-th                     >= 0.1   --- Basic RNA secondary structure folding with partition function calculations+-- Very simple two-sequence alignment. -executable PartNussinov+executable NeedlemanWunsch    if flag(examples)     buildable:       True     build-depends:  base                  ,  ADPfusion-                 ,  log-domain        == 0.10.*+                 ,  primitive                  ,  PrimitiveArray                  ,  template-haskell                  ,  vector+                 ,  DPutils   else     buildable:       False   hs-source-dirs:     src   main-is:-    PartNussinov.hs+    NeedlemanWunsch.hs   default-language:     Haskell2010   default-extensions: BangPatterns+                    , DataKinds                     , FlexibleContexts                     , FlexibleInstances                     , MultiParamTypeClasses+                    , PartialTypeSignatures+                    , PolyKinds                     , RecordWildCards                     , TemplateHaskell+                    , TypeApplications                     , TypeFamilies                     , TypeOperators+                    , UnicodeSyntax   ghc-options:     -O2     -funbox-strict-fields-    -funfolding-use-threshold1000-    -funfolding-keeness-factor1000-  if flag(debug)+    -- these parameters do well enough with GHC 8.2+    -- for larger programs, we may have to increase the number of worker+    -- arguments.+    -flate-dmd-anal+    -fspec-constr-count=20+    -fspec-constr-keen+    -fspec-constr-recursive=20+    -fspec-constr-threshold=20+  if flag(debugdump)     ghc-options:       -ddump-to-file       -ddump-simpl       -dsuppress-all----executable Durbin-  if flag(examples)-    buildable:-      True-    build-depends:  base-                 ,  ADPfusion-                 ,  PrimitiveArray-                 ,  template-haskell-                 ,  vector-  else-    buildable:-      False-  hs-source-dirs:-    src-  main-is:-    Durbin.hs-  default-language:-    Haskell2010-  default-extensions: BangPatterns-                    , FlexibleContexts-                    , FlexibleInstances-                    , MultiParamTypeClasses-                    , RecordWildCards-                    , TemplateHaskell-                    , TypeFamilies-                    , TypeOperators-  ghc-options:-    -O2-    -fcpr-off-    -funbox-strict-fields-    -funfolding-use-threshold1000-    -funfolding-keeness-factor1000-  if flag(debug)+  if flag(llvm)     ghc-options:-      -ddump-to-file-      -ddump-simpl-      -dsuppress-all+      -fllvm+      -optlo-O3+  if flag(dump-core)+    build-depends: dump-core+    ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html   -executable Pseudoknot+executable SmithWaterman+   if flag(examples)     buildable:       True     build-depends:  base                  ,  ADPfusion+                 ,  primitive                  ,  PrimitiveArray                  ,  template-haskell                  ,  vector+                 ,  DPutils   else     buildable:       False   hs-source-dirs:     src   main-is:-    Pseudoknot.hs+    SmithWaterman.hs   default-language:     Haskell2010   default-extensions: BangPatterns@@ -355,64 +336,45 @@                     , FlexibleContexts                     , FlexibleInstances                     , MultiParamTypeClasses+                    , PartialTypeSignatures+                    , PolyKinds                     , RecordWildCards                     , TemplateHaskell+                    , TypeApplications                     , TypeFamilies                     , TypeOperators+                    , UnicodeSyntax   ghc-options:     -O2     -funbox-strict-fields-    -funfolding-use-threshold1000-    -funfolding-keeness-factor1000-  if flag(debug)+    -- these parameters do well enough with GHC 8.2+    -- for larger programs, we may have to increase the number of worker+    -- arguments.+    -flate-dmd-anal+    -fspec-constr-count=20+    -fspec-constr-keen+    -fspec-constr-recursive=20+    -fspec-constr-threshold=20+  if flag(debugdump)     ghc-options:       -ddump-to-file       -ddump-simpl       -dsuppress-all+  if flag(llvm)+    ghc-options:+      -fllvm+      -optlo-O3+  if flag(dump-core)+    build-depends: dump-core+    ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html   -executable OverlappingPalindromes-  if flag(examples)-    buildable:-      True-    build-depends:  base-                 ,  ADPfusion-                 ,  PrimitiveArray-                 ,  template-haskell-                 ,  vector-  else-    buildable:-      False-  hs-source-dirs:-    src-  main-is:-    OverlappingPalindromes.hs-  default-language:-    Haskell2010-  default-extensions: BangPatterns-                    , FlexibleContexts-                    , FlexibleInstances-                    , MultiParamTypeClasses-                    , RecordWildCards-                    , TemplateHaskell-                    , TypeFamilies-                    , TypeOperators-  ghc-options:-    -O2-    -funbox-strict-fields-    -funfolding-use-threshold1000-    -funfolding-keeness-factor1000-  if flag(debug)-    ghc-options:-      -ddump-to-file-      -ddump-simpl-      -dsuppress-all-+-- Very simple two-sequence alignment. +executable spectest -executable SplitTests-  if flag(examples)+  if flag(spectest)     buildable:       True     build-depends:  base@@ -426,7 +388,7 @@   hs-source-dirs:     src   main-is:-    SplitTests.hs+    SpecTest.hs   default-language:     Haskell2010   default-extensions: BangPatterns@@ -442,68 +404,7 @@     -funbox-strict-fields     -funfolding-use-threshold1000     -funfolding-keeness-factor1000-  if flag(debug)-    ghc-options:-      -ddump-to-file-      -ddump-simpl-      -dsuppress-all ---test-suite properties-  type:-    exitcode-stdio-1.0-  main-is:-    properties.hs-  ghc-options:-    -threaded -rtsopts -with-rtsopts=-N-  hs-source-dirs:-    tests-  default-language:-    Haskell2010-  default-extensions: TemplateHaskell-  build-depends: base-               , ADPfusion-               , QuickCheck-               , test-framework               >= 0.8  && < 0.9-               , test-framework-quickcheck2   >= 0.3  && < 0.4-               , test-framework-th            >= 0.2  && < 0.3----benchmark performance-  type:-    exitcode-stdio-1.0-  main-is:-    performance.hs-  ghc-options:-    -rtsopts -with-rtsopts=-N -with-rtsopts=-T-    -O2-    -funbox-strict-fields-    -funfolding-use-threshold1000-    -funfolding-keeness-factor1000-  if flag(debug)-    ghc-options:-      -ddump-to-file-      -ddump-simpl-      -dsuppress-all-  hs-source-dirs:-    tests-  default-language:-    Haskell2010-  default-extensions: BangPatterns-                    , FlexibleContexts-                    , TemplateHaskell-                    , RecordWildCards-                    , TypeFamilies-                    , TypeOperators-                    , StandaloneDeriving-                    , DeriveGeneric-  build-depends: base-               , ADPfusion-               , BenchmarkHistory   >= 0.0.0  && < 0.0.1-               , PrimitiveArray-               , vector
README.md view
@@ -26,7 +26,7 @@     [preprint](http://www.bioinf.uni-leipzig.de/Software/gADP/preprints/hoe-pro-2015.pdf)   1.  Maik Riechert, Christian Höner zu Siederdissen, and Peter F. Stadler       *Algebraic dynamic programming for multiple context-free languages*  -    2015, submitted  +    2016, Theoretical Computer Science       [preprint](http://www.bioinf.uni-leipzig.de/Software/gADP/preprints/rie-hoe-2015.pdf)    @@ -68,25 +68,7 @@  # Implementors Notes (if you want to extend ADPfusion) --- The general inlining scheme is: (i) mkStream is {-# INLINE mkStream #-},-  inner functions like mk, step, worker functions, and index-modifying-  functions get an {-# INLINE [0] funName #-}. Where there is no function to-  annotate, use delay_inline.--- If you implement a new kind of memoizing table, like the dense Table.Array-  ones, you will have to implement mkStream code. When you hand to the left,-  the (i,j) indices and modify their extend (by, say, having NonEmpty table-  constaints), you have to delay_inline this (until inliner phase 0). Otherwise-  you will break fusion for mkStream.--- Terminals that capture both, say indexing functions, and data should have no-  strictness annotations for the indexing function. This allows the code to be-  duplicated, then inlined. This improves performance a lot, because otherwise-  a function is created that performs these lookups, which has serious (50%-  slower or so) performance implications.--+These have been moved to [HACKING.md](https://github.com/choener/ADPfusion/blob/master/HACKING.md).  #### Contact
changelog.md view
@@ -1,3 +1,55 @@+0.6.0.0+-------++- major change as to how rule compilation proceeds (ctor spec -> type class instances)+- use new PrimitiveArray-0.9.0.0+- backtrace from any given index using 'axiomAt'+- Epsilon is tagged @Global or @Local, to allow local-alignment style algorithms++0.5.3.0+-------++- using unboxed Ints (primbool style) for rule guards. This nets a nice speedup+  of 30-50% for linear languages++0.5.2.2+-------++- Modified signature of Edge to make explicit the @From@ and @To@ nodes of the+  edge. Minor version bump, because @Edge@ is not official yet.+- optimized table filling yields large improvements for linear languages++0.5.2.1+-------++- removed upper bounds++0.5.2.0+-------++- table filling fully inlined in the forward algorithm+- experimental PrimBool operations+- note: these optimizations are mostly of interest for linear languages, where+  is rule (or function call) is comparatively expensive+- major re-arrangement of modules: import ADP.Fusion.Core for development of+  novel DP systems. Import ADP.Fusion.Point if you want to write a sequence+  alignment algorithm++0.5.1.0+-------++- improved table filling algorithm performance+- some optimizations to terminal symbols++0.5.0.0+-------++- complete re-design of Inside / Outside / Complement handling based on phantom+  types+- very liberal combination of multi-tape grammars+- simplified index generation system (both faster, and easier to write new+  symbol now)+ 0.4.1.1 -------
− src/Durbin.hs 
@@ -1,122 +0,0 @@---- | Nussinovs RNA secondary structure prediction algorithm via basepair--- maximization. Follow this file from top to bottom for a short tutorial--- on how to use @ADPfusion@.------ In general the task is the following: We are given a sequence of--- characters from the alphabet @ACGU@. There are 6 pairing rules (cf.--- 'pairs'), @A-U@, @C-G@, @G-C@, @G-U@, @U-A@, and @U-G@ can /pair/ with--- each other. Pairs, denoted by brackets @(@, @)@ may be juxtaposed--- @().()@ or enclosing @(())@. /Crossing/ pairs are not allowed: @([)]@ is--- forbidden, with @()@ and @[]@ pairing. Dots @.@ denote unpaired--- characters.------ As an example, the sequence @CACAAGGAUU@ admits the following--- dot-bracket string @(.)..((..))@.------ The algorithm below maximizes the number of legal brackets.--module Main where--import           Control.Applicative-import           Control.Monad-import           Control.Monad.ST-import           Data.Char (toUpper,toLower)-import           Data.List-import           Data.Vector.Fusion.Util-import           Language.Haskell.TH-import           Language.Haskell.TH.Syntax-import qualified Data.Vector.Fusion.Stream as S-import qualified Data.Vector.Fusion.Stream.Monadic as SM-import qualified Data.Vector.Unboxed as VU-import           System.Environment (getArgs)-import           Text.Printf---- Import PrimitiveArray for low-level tables and automatic table--- filling.--import           Data.PrimitiveArray as PA---- High-level ADPfusion stuff.--import           ADP.Fusion------ | All grammars require a signature.--data Durbin m c e x r = Durbin-  { nil :: e           -> x-  , lef :: c -> x      -> x-  , rig :: x -> c      -> x-  , pai :: c -> x -> c -> x-  , spl :: x -> x      -> x-  , h   :: SM.Stream m x -> m r-  }--makeAlgebraProduct ''Durbin--bpmax :: Monad m => Durbin m Char () Int Int-bpmax = Durbin-  { nil = \ ()    -> 0-  , lef = \ _  x  -> x-  , rig = \ x  _  -> x-  , pai = \ c x d -> if pairs c d then x+1 else -999999-  , spl = \ x y   -> x+y-  , h   = SM.foldl' max 0-  }-{-# INLINE bpmax #-}--pairs !c !d-  =  c=='A' && d=='U'-  || c=='C' && d=='G'-  || c=='G' && d=='C'-  || c=='G' && d=='U'-  || c=='U' && d=='A'-  || c=='U' && d=='G'-{-# INLINE pairs #-}--pretty :: Monad m => Durbin m Char () String [String]-pretty = Durbin-  { nil = \ ()      -> ""-  , lef = \ _  x    -> "." ++ x-  , rig = \ x  _    -> x ++ "."-  , pai = \ _  x  _ -> "(" ++ x ++ ")"-  , spl = \ x  y    -> x ++ y-  , h   = SM.toList-  }-{-# INLINE pretty #-}---- grammar :: Durbin m Char () x r -> c' -> t' -> (t', Subword -> m r)-grammar Durbin{..} c t' =-  let t = t'  ( nil <<< Epsilon     |||-                lef <<< c  % t      |||-                rig <<< t  % c      |||-                pai <<< c  % t  % c |||-                spl <<< tt % tt     ... h-              )-      tt = toNonEmpty t-  in (Z:.t)-{-# INLINE grammar #-}--runDurbin :: Int -> String -> (Int,[String])-runDurbin k inp = (d, take k . unId $ axiom b) where-  i = VU.fromList . Prelude.map toUpper $ inp-  n = VU.length i-  !(Z:.t) = mutateTablesDefault-          $ grammar bpmax-              (chr i)-              (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) [])) :: Z:.ITbl Id Unboxed Subword Int-  -- d = let (ITbl _ _ arr _) = t in arr PA.! subword 0 n-  d = iTblArray t PA.! subword 0 n-  !(Z:.b) = grammar (bpmax <|| pretty) (chr i) (toBacktrack t (undefined :: Id a -> Id a))--main = do-  as <- getArgs-  let k = if null as then 1 else read $ head as-  ls <- lines <$> getContents-  forM_ ls $ \l -> do-    putStrLn l-    let (s,xs) = runDurbin k l-    mapM_ (\x -> printf "%s %5d\n" x s) xs-
src/NeedlemanWunsch.hs view
@@ -1,9 +1,71 @@ +{-# Options_GHC -fforce-recomp #-}+{-# Options_GHC -Wno-partial-type-signatures #-}+ -- | The Needleman-Wunsch global alignment algorithm. This algorithm is -- extremely simple but provides a good showcase for what ADPfusion offers. ----- Follow the code from top to bottom for a tutorial on usage.+-- The Needleman-Wunsch algorithm aligns to strings @x = x_1 x_2 x_3 ...@+-- and @y = y_1 y_2 y_3 ...@ which may be of differing lengths. Assume that+-- @x_1 ... x_{i-1}@ and @y_1 ... y_{j-1}@ have already been optimally+-- aligned. We can match @x_i@ with @y_j@, or perform one of two possible+-- insert-deletion pairs. Either @x_i@ is aligned with @-@ or @-@ is+-- aligned with @y_j@. More general, in each DP step, either one or both+-- inputs are extended by one character. --+-- For the actual implementation, we assume however, that we work backward.+-- The entries @d@, @u@, and @l@ have already been calculated. Now we want+-- to compute the entry at @x@ in the lower right corner.+--+-- @+--  -----+--  |d|u|+--  -----+--  |l|x|+--  -----+-- @+--+-- We introduce a generic naming scheme for each possible move. If we move+-- in a direction, we call it a @step@. If we do not move, then we call it+-- a @loop@, because the index loops for this computation.+--+-- We can arrive from @d@, making a diagonal step, called @step_step@ as we+-- advance by one in both dimensions. This leads to an alignment of two+-- characters, one from each input, at @x@, which is combined with the+-- already calculated alignment at @d@.+--+-- We can also just step in the first dimension @step_loop@, going from @l@+-- to @x@. Which means that the first-dim character does not have+-- a partner, leading to an insert/deletion or in/del. We typically do not+-- care in which of the two dimensions the in/del happens, just that it+-- does.+--+-- The third case is an in/del in the other dimension, giving us+-- @loop_step@ or going from @u@ to @x@.+--+-- Of course, if @x@ happens to be the uppermost, leftmost cell, we have+-- nowhere to come from, so we need to inititialize (or terminate depending+-- on your view point) using the @nil_nil@ case. That one is the base case.+--+-- We also want to know which of the three cases is the best case (coming+-- from @d,l,u@), this requires a "choice" function or @h@.+--+--+-- We now implement this algorithm using the low-level ADPfusion library.+-- Follow the code from top to bottom for a tutorial on usage. The+-- Needleman-Wunsch tutorial for the @FormalGrammars@ library provides+-- a higher-level style of implementation.+--+-- <http://hackage.haskell.org/package/FormalGrammars/docs/FormalLanguage-Tutorial-NeedlemanWunsch.html>+--+-- We also provide an implementation based on grammar products, which+-- simplify the design of alignment-type algorithms. The corresponding+-- tutorial is here.+--+-- <http://hackage.haskell.org/package/GrammarProducts/docs/FormalLanguage-Tutorial-NeedlemanWunsch.html>+--+--+-- -- We start by importing a bunch of modules, including -- @Data.PrimitiveArray@ for low-level arrays and automated filling of the -- arrays or tables in the correct order.@@ -19,22 +81,26 @@ -- do this. The relative overhead for each cell to be written into goes -- down with more complex grammars and algebras. -module Main where+module Main (main) where -import           Control.Applicative-import           Control.Monad-import           Data.Vector.Fusion.Stream.Monadic (Stream (..))-import           Data.Vector.Fusion.Util+import           Control.Monad (forM_,when)+import           Control.Monad.Primitive+import           Control.Monad.ST+import           Data.Ord.Fast import           Debug.Trace-import qualified Control.Arrow as A-import qualified Data.Vector as V-import qualified Data.Vector.Fusion.Stream as S-import qualified Data.Vector.Fusion.Stream.Monadic as SM-import qualified Data.Vector.Unboxed as VU import           System.Environment (getArgs)-import           System.IO.Unsafe (unsafePerformIO) import           Text.Printf +-- Streams of parses are the streams defined in the @vector@ package.++import qualified Data.Vector.Fusion.Stream.Monadic as SM++-- We use unboxed vectors to hold the input sequences to be aligned. The+-- terminal parses work with any vector in the @vector@ package.++import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Storable as VS+ -- @Data.PrimitiveArray@ contains data structures, and index structures for -- dynamic programming. Notably, the primitive arrays holding the cell data -- with Boxed and Unboxed tables. In addition, linear, context-free, and@@ -42,50 +108,24 @@  import           Data.PrimitiveArray as PA hiding (map) --- @ADP.Fusion@ exposes everything necessary for higher-level DP--- algorithms.+-- @ADP.Fusion.Point@ exposes everything necessary for higher-level DP+-- algorithms. Depending on the type of DP algorithm, different top-level+-- modules can be imported. @.Point@ for linear grammars, and @.Core@ are+-- provided in this package. @.Core@ exports only the core modules required+-- to extend ADPfusion. -import           ADP.Fusion+import           ADP.Fusion.PointL +import           Data.Ord.Fast  + -- | A signature connects the types of all non-terminals and terminals with -- evaluation (or attribute) functions. In the grammar below, we not only -- want to create all possible parses of how two strings can be aligned but -- also evaluate each parse and choose the optimal one based on Bellman's -- principle of optimality. ----- Assume we are in the matrix and want to calculate @x@:------ @---  --------  |d|u|---  --------  |l|x|---  -------- @------ We can arrive from @d@, making a diagonal step, called @step_step@ as we--- advance by one in both dimensions. This leads to an alignment of two--- characters, one from each input, at @x@, which is combined with the--- already calculated alignment at @d@.------ We can also just step in the first dimension @step_loop@, going from @l@--- to @x@. Which means that the first-dim character does not have--- a partner, leading to an insert/deletion or in/del. We typically do not--- care in which of the two dimensions the in/del happens, just that it--- does.------ The third case is an in/del in the other dimension, giving us--- @loop_step@ or going from @u@ to @x@.------ Of course, if @x@ happens to be the uppermost, leftmost cell, we have--- nowhere to come from, so we need to inititialize (or terminate depending--- on your view point) using the @nil_nil@ case. That one is the base case.------ We also want to know which of the three cases is the best case (coming--- from @d,l,u@), this requires a "choice" function or @h@.--- -- We take a close look at the type signatures. @step_step :: x -> -- (Z:.c:.c) -> x@ tells us that @step_step@ requires the score from the -- non-terminal, typed @x@ for the alignment up to @d@, then we get the two@@ -102,11 +142,11 @@ -- capable, which is a really cool feature for advanced algorithms.  data Signature m x r c = Signature-  { step_step :: x -> (Z:.c :.c ) -> x-  , step_loop :: x -> (Z:.c :.()) -> x-  , loop_step :: x -> (Z:.():.c ) -> x-  , nil_nil   ::      (Z:.():.()) -> x-  , h         :: Stream m x -> m r+  { step_step ∷ x → (Z:.c :.c ) → x+  , step_loop ∷ x → (Z:.c :.()) → x+  , loop_step ∷ x → (Z:.():.c ) → x+  , nil_nil   ∷     (Z:.():.()) → x+  , h         ∷ Stream m x -> m r   }  -- | We also want to be able to backtrace the optimal result. Given our@@ -162,12 +202,12 @@ -- indices. Just as in the spiritual father of @ADPfusion@, Robert -- Giegerichs @ADP@, we hide the actual index calculations. -grammar Signature{..} a' i1 i2 =-  let a = a'  ( step_step <<< a % (M:|chr i1:|chr i2)     |||-                step_loop <<< a % (M:|chr i1:|Deletion  ) |||-                loop_step <<< a % (M:|Deletion  :|chr i2) |||-                nil_nil   <<< (M:|Epsilon:|Epsilon)       ... h-              )+grammar Signature{..} !a' !i1 !i2 =+  let a = TW a' ( step_step <<< a % (M:|chr i1:|chr i2)     |||+                  step_loop <<< a % (M:|chr i1:|Deletion  ) |||+                  loop_step <<< a % (M:|Deletion  :|chr i2) |||+                  nil_nil   <<< (M:|Epsilon @Global:|Epsilon @Global)       ... h+                )   in Z:.a {-# INLINE grammar #-} @@ -185,13 +225,14 @@ -- @-999999@ and find the maximum of that score and the choices we are -- given. -sScore :: Monad m => Signature m Int Int Char+sScore ∷ Monad m ⇒ Signature m Int Int Char sScore = Signature-  { step_step = \x (Z:.a:.b) -> if a==b then x+1 else x-2-  , step_loop = \x _         -> x-1-  , loop_step = \x _         -> x-1+  { step_step = \x (Z:.a:.b) → if a==b then x+7 else x-5+  , step_loop = \x _         → x-3+  , loop_step = \x _         → x-2   , nil_nil   = const 0-  , h = SM.foldl' max (-999999)+  , h = SM.foldl' fastmax (-999999)+--  , h = SM.foldl1' fastmax   } {-# INLINE sScore #-} @@ -205,11 +246,11 @@ -- rather returns all alignments. You already heard about @<**@, we'll use -- it below. -sPretty :: Monad m => Signature m [String] [[String]] Char+sPretty ∷ Monad m ⇒ Signature m [String] [[String]] Char sPretty = Signature-  { step_step = \[x,y] (Z:.a :.b ) -> [a  :x, b  :y]-  , step_loop = \[x,y] (Z:.a :.()) -> [a  :x, '-':y]-  , loop_step = \[x,y] (Z:.():.b ) -> ['-':x, b  :y]+  { step_step = \[x,y] (Z:.a :.b ) → [a  :x, b  :y]+  , step_loop = \[x,y] (Z:.a :.()) → [a  :x, '-':y]+  , loop_step = \[x,y] (Z:.():.b ) → ['-':x, b  :y]   , nil_nil   = const ["",""]   , h = SM.toList   }@@ -220,13 +261,17 @@ -- backtrackings, given the inputs @i1@ and @i2@. The @fst@ element -- returned is the score, the @snd@ are the co-optimal parses. -runNeedlemanWunsch :: Int -> String -> String -> (Int,[[String]])-runNeedlemanWunsch k i1' i2' = (d, take k bs) where+runNeedlemanWunsch+  ∷ Int+  → String+  → String+  → (Int,[[String]],PerfCounter)+runNeedlemanWunsch k i1' i2' = (d, take k bs,perf) where   i1 = VU.fromList i1'   i2 = VU.fromList i2'   n1 = VU.length i1   n2 = VU.length i2-  !(Z:.t) = nwInsideForward i1 i2+  Mutated (Z:.t) perf eachPerf = nwInsideForward i1 i2   d = unId $ axiom t   bs = nwInsideBacktrack i1 i2 t {-# Noinline runNeedlemanWunsch #-}@@ -241,18 +286,28 @@ -- For your own code, you can write as done here, or in the way of -- 'runOutsideNeedlemanWunsch'. -nwInsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.ITbl Id Unboxed (Z:.PointL:.PointL) Int-nwInsideForward i1 i2 = {-# SCC "nwInsideForward" #-} mutateTablesDefault $-                          grammar sScore-                          (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.PointL 0:.PointL 0) (Z:.PointL n1:.PointL n2) (-999999) []))-                          i1 i2-  where n1 = VU.length i1-        n2 = VU.length i2+nwInsideForward+  ∷ VU.Vector Char+  → VU.Vector Char+  → Mutated (Z:.TwITbl _ _ Id (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int)+nwInsideForward !i1 !i2 = {-# SCC "nwInsideForward" #-} runST $ do+  arr ← newWithPA (ZZ:..LtPointL n1:..LtPointL n2) (-999999)+  ts ← fillTables $ grammar sScore+                      (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk:.EmptyOk) arr)+                      i1 i2+  return ts+  where !n1 = VU.length i1+        !n2 = VU.length i2 {-# NoInline nwInsideForward #-} -nwInsideBacktrack :: VU.Vector Char -> VU.Vector Char -> ITbl Id Unboxed (Z:.PointL:.PointL) Int -> [[String]]+nwInsideBacktrack+  ∷ VU.Vector Char+  → VU.Vector Char+  → TwITbl _ _ Id (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int+  → [[String]] nwInsideBacktrack i1 i2 t = {-# SCC "nwInsideBacktrack" #-} unId $ axiom b   where !(Z:.b) = grammar (sScore <|| sPretty) (toBacktrack t (undefined :: Id a -> Id a)) i1 i2+                    :: Z:.TwITblBt _ _ (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int Id Id [String] {-# NoInline nwInsideBacktrack #-}  -- | The outside version of the Needleman-Wunsch alignment algorithm. The@@ -260,28 +315,39 @@ -- generally the case, but here it is. Hence we may just use outside tables -- and the grammar from above. -runOutsideNeedlemanWunsch :: Int -> String -> String -> (Int,[[String]])-runOutsideNeedlemanWunsch k i1' i2' = {-# SCC "runOutside" #-} (d, take k . unId $ axiom b) where -- . S.toList . unId $ axiom b) where -- ,gogo) where+runOutsideNeedlemanWunsch+  ∷ Int+  → String+  → String+  → (Int,[[String]],PerfCounter)+runOutsideNeedlemanWunsch k i1' i2' = {-# SCC "runOutside" #-} (d, take k . unId $ axiom b, perf) where   i1 = VU.fromList i1'   i2 = VU.fromList i2'   n1 = VU.length i1   n2 = VU.length i2-  !(Z:.t) = nwOutsideForward i1 i2-  -- d = let (ITbl _ _ arr _) = t in arr PA.! (O (Z:.PointL 0:.PointL 0))-  d = iTblArray t PA.! (O (Z:.PointL 0:.PointL 0))+  Mutated (Z:.t) perf eachPerf = nwOutsideForward i1 i2+  d = unId $ axiom t   !(Z:.b) = grammar (sScore <|| sPretty) (toBacktrack t (undefined :: Id a -> Id a)) i1 i2+              :: Z:.TwITblBt _ _ (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL O:.PointL O) Int Id Id [String] {-# Noinline runOutsideNeedlemanWunsch #-}  -- | Again, to be able to observe performance, we have extracted the -- outside-table-filling part.+--+-- The partial type signature is filled by GHC. -nwOutsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.ITbl Id Unboxed (Outside (Z:.PointL:.PointL)) Int-nwOutsideForward i1 i2 = {-# SCC "nwOutsideForward" #-} mutateTablesDefault $-                           grammar sScore-                           (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (O (Z:.PointL 0:.PointL 0)) (O (Z:.PointL n1:.PointL n2)) (-999999) []))-                           i1 i2-  where n1 = VU.length i1-        n2 = VU.length i2+nwOutsideForward+  ∷ VU.Vector Char+  → VU.Vector Char+  → Mutated (Z:.TwITbl _ _ Id (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL O:.PointL O) Int)+nwOutsideForward !i1 !i2 = {-# SCC "nwOutsideForward" #-} runST $ do+  arr ← newWithPA (ZZ:..LtPointL n1:..LtPointL n2) (-999999)+  ts ← fillTables $ grammar sScore+                      (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk:.EmptyOk) arr)+                      i1 i2+  return ts+  where !n1 = VU.length i1+        !n2 = VU.length i2 {-# Noinline nwOutsideForward #-}  -- | This wrapper takes a list of input sequences and aligns each odd@@ -298,15 +364,19 @@  align _ [] = return () align _ [c] = putStrLn "single last line"-align k (a:b:xs) = {-# SCC "align" #-} do+align (kI,kO) (a:b:xs) = {-# SCC "align" #-} do   putStrLn a   putStrLn b+  let (sI,rsI,perfI) = runNeedlemanWunsch kI a b+  let (sO,rsO,perfO) = runOutsideNeedlemanWunsch kO a b+  when (kI>=0) $ forM_ rsI $ \[u,l] -> printf "%s\n%s  %d\n\n" (reverse u) (reverse l) sI+  when (kO>=0) $ forM_ rsO $ \[u,l] -> printf "%s\n%s  %d\n\n" (id      u) (id      l) sO+  when (kI>=0) $ print sI+  when (kO>=0) $ print sO+  when (kI>=0) . putStrLn $ showPerfCounter perfI+  when (kO>=0) . putStrLn $ showPerfCounter perfO   putStrLn ""-  let (sI,rsI) = runNeedlemanWunsch k a b-  let (sO,rsO) = runOutsideNeedlemanWunsch k a b-  forM_ rsI $ \[u,l] -> printf "%s\n%s  %d\n\n" (reverse u) (reverse l) sI-  forM_ rsO $ \[u,l] -> printf "%s\n%s  %d\n\n" (id      u) (id      l) sO-  align k xs+  align (kI,kO) xs  -- | And finally have a minimal main that reads from stdio. --@@ -317,7 +387,13 @@  main = do   as <- getArgs-  let k = if null as then 1 else read $ head as+  let k = case as of+            [] -> (1,1)+            [x] -> let x' = read x+                   in (x',x')+            [x,y] -> let x' = read x; y' = read y+                     in  (x',y')+            args -> error $ "too many arguments"   ls <- lines <$> getContents   align k ls
− src/Nussinov.hs 
@@ -1,132 +0,0 @@---- | Nussinovs RNA secondary structure prediction algorithm via basepair--- maximization.--module Main where--import           Control.Applicative-import           Control.Monad-import           Control.Monad.ST-import           Data.Char (toUpper,toLower)-import           Data.List as L-import           Data.Vector.Fusion.Util-import           Debug.Trace-import           Language.Haskell.TH-import           Language.Haskell.TH.Syntax-import qualified Data.Vector.Fusion.Stream as S-import qualified Data.Vector.Fusion.Stream.Monadic as SM-import qualified Data.Vector.Unboxed as VU-import           System.Environment (getArgs)-import           Text.Printf--import           Data.PrimitiveArray as PA--import           ADP.Fusion----data Nussinov m x r c = Nussinov-  { unp :: x -> c -> x-  , jux :: x -> c -> x -> c -> x-  , nil :: () -> x-  , h   :: SM.Stream m x -> m r-  }--makeAlgebraProduct ''Nussinov--{-- - due to backtracking schemes, we need a bunch of combintors- -- - how to deal with sup-optimal backtracking, without having to use (*||) ?--(<||)   :: Single a -> List b   -> List b         -- co-optimal backtracking-(*||)   :: Vector a -> List b   -> List (a,b)     -- classified co-optimal backtracking-(***)   :: Single a -> Single b -> Vector (a,b)   -- classified DP---}--bpmax :: Monad m => Nussinov m Int Int Char-bpmax = Nussinov-  { unp = \ x c     -> x-  , jux = \ x c y d -> if c `pairs` d then x + y + 1 else -999999-  , nil = \ ()      -> 0-  , h   = SM.foldl' max (-999999)-  }-{-# INLINE bpmax #-}--prob :: Monad m => Nussinov m Double Double Char-prob = Nussinov-  { unp = \ x c     -> 0.3 * x-  , jux = \ x c y d -> 0.6 * if c `pairs` d then x * y else 0-  , nil = \ ()      -> 0.1-  , h   = SM.foldl' (+) 0-  }---- |--pairs !c !d-  =  c=='A' && d=='U'-  || c=='C' && d=='G'-  || c=='G' && d=='C'-  || c=='G' && d=='U'-  || c=='U' && d=='A'-  || c=='U' && d=='G'-{-# INLINE pairs #-}--pretty :: Monad m => Nussinov m String [String] Char -- (SM.Stream m String)-pretty = Nussinov-  { unp = \ x c     -> x ++ "."-  , jux = \ x c y d -> x ++ "(" ++ y ++ ")"-  , nil = \ ()      -> ""-  , h   = SM.toList -- return . id-  }-{-# INLINE pretty #-}--prettyL :: Monad m => Nussinov m String String Char-prettyL = Nussinov-  { unp = \ x c     -> x ++ "."-  , jux = \ x c y d -> x ++ "(" ++ y ++ ")"-  , nil = \ ()      -> ""-  , h   = SM.head -- return . id-  }-{-# INLINE prettyL #-}--grammar Nussinov{..} c t' =-  let t = t'  ( unp <<< t % c           |||-                jux <<< t % c % t % c   |||-                nil <<< Epsilon         ... h-              )-  in Z:.t-{-# INLINE grammar #-}--runNussinov :: Int -> String -> (Int,[String])-runNussinov k inp = (d, take k bs) where-  i = VU.fromList . Prelude.map toUpper $ inp-  n = VU.length i-  !(Z:.t) = runInsideForward i-  d = unId $ axiom t-  bs = runInsideBacktrack i t-{-# NOINLINE runNussinov #-}--runInsideForward :: VU.Vector Char -> Z:.ITbl Id Unboxed Subword Int-runInsideForward i = mutateTablesDefault-                   $ grammar bpmax-                       (chr i)-                       (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) []))-  where n = VU.length i-{-# NoInline runInsideForward #-}--runInsideBacktrack :: VU.Vector Char -> ITbl Id Unboxed Subword Int -> [String]-runInsideBacktrack i t = unId $ axiom b-  where !(Z:.b) = grammar (bpmax <|| pretty) (chr i) (toBacktrack t (undefined :: Id a -> Id a))-{-# NoInline runInsideBacktrack #-}--main = do-  as <- getArgs-  let k = if null as then 1 else read $ head as-  ls <- lines <$> getContents-  forM_ ls $ \l -> do-    putStrLn l-    let (s,xs) = runNussinov k l-    mapM_ (\x -> printf "%s %5d\n" x s) xs-
− src/OverlappingPalindromes.hs 
@@ -1,156 +0,0 @@--{-# Language DataKinds #-}-{-# Language KindSignatures #-}-{-# Language ScopedTypeVariables #-}-{-# Language DataKinds               #-}-{-# Language DefaultSignatures       #-}-{-# Language FlexibleContexts        #-}-{-# Language FlexibleInstances       #-}-{-# Language GADTs                   #-}-{-# Language KindSignatures          #-}-{-# Language MultiParamTypeClasses   #-}-{-# Language RankNTypes              #-}-{-# Language StandaloneDeriving      #-}-{-# Language TemplateHaskell         #-}-{-# Language TypeFamilies            #-}-{-# Language TypeOperators           #-}-{-# Language TypeSynonymInstances    #-}-{-# Language UndecidableInstances    #-}--module Main where--import           Control.Applicative-import           Control.Monad-import           Data.Vector.Fusion.Stream.Monadic (Stream (..))-import           Data.Vector.Fusion.Util-import           Debug.Trace-import qualified Control.Arrow as A-import qualified Data.Vector as V-import qualified Data.Vector.Fusion.Stream as S-import qualified Data.Vector.Fusion.Stream.Monadic as SM-import qualified Data.Vector.Unboxed as VU-import           System.Environment (getArgs)-import           System.IO.Unsafe (unsafePerformIO)-import           Text.Printf--import           Data.PrimitiveArray as PA hiding (map)--import           ADP.Fusion----data Signature m x r c = Signature-  { ovrlap :: () -> () -> x -> x -> () -> x -- TODO !!!-  , brckts :: (Z:.c:.()) -> x -> (Z:.():.c) -> x-  , braces :: (Z:.c:.()) -> x -> (Z:.():.c) -> x-  , nilnil :: (Z:.():.()) -> x-  , h :: Stream m x -> m r-  }--makeAlgebraProduct ''Signature------ |------ @--- 012345678--- [[((]]))--- @--grammar Signature{..} x' a' b' i =-  let x = x'  ( ovrlap <<< (split (Proxy :: Proxy "a") (Proxy :: Proxy Fragment) a)-                        %  (split (Proxy :: Proxy "b") (Proxy :: Proxy Fragment) b)-                        %  (split (Proxy :: Proxy "a") (Proxy :: Proxy Final   ) a)-                        %  (split (Proxy :: Proxy "b") (Proxy :: Proxy Final   ) b) -- ... h-                        %  (split (Proxy :: Proxy "c") (Proxy :: Proxy Fragment) b) ... h-              )-      a = a'  ( nilnil <<< (M:|Epsilon:|Epsilon)                           |||-                brckts <<< (M:|chr i:|Deletion) % a % (M:|Deletion:|chr i) ... h-              )-      b = b'  ( nilnil <<< (M:|Epsilon:|Epsilon)                           |||-                braces <<< (M:|chr i:|Deletion) % b % (M:|Deletion:|chr i) ... h-              )-  in Z:.x:.a:.b-{-# Inline grammar #-}----score :: Monad m => Signature m Int Int Char-score = Signature-  { ovrlap = \ a' b' a b _ -> {- if a>0 || b>0 then traceShow ("oo",a',b',a,b) $ a + b else -} a+b -- TODO !!!-  , brckts = \ (Z:.l:.()) a (Z:.():.r) -> {- traceShow ("[]",l,a,r) $ -} if l=='[' && r==']' then a+1 else -999999-  , braces = \ (Z:.l:.()) b (Z:.():.r) -> {- traceShow ("()",l,b,r) $ -} if l=='(' && r==')' then b+1 else -999999-  , nilnil = \ _ -> 0-  , h = SM.foldl' max (-999999)-  }-{-# Inline score #-}------ |------ TODO pretty shows in @ovrlap@ that we might want to introduce a second--- @h@ together with @Stream m y -> m s@?--pretty :: Monad m => Signature m [String] [[String]] Char-pretty = Signature-  { ovrlap = \ () () [a,a'] [b,b'] () -> [a ++ b ++ a' ++ b'] -- TODO !!!-  , brckts = \ (Z:.l:.()) [a,a'] (Z:.():.r) -> ["a"++a , a'++"A"]-  , braces = \ (Z:.l:.()) [b,b'] (Z:.():.r) -> ["b"++b , b'++"B"]-  , nilnil = \ _ -> ["",""]-  , h = SM.toList-  }-{-# Inline pretty #-}----overlappingPalindromes :: String -> (Int,[[String]])-overlappingPalindromes inp = (d,bs) where-  i  = VU.fromList inp-  n  = VU.length i-  d  = unId $ axiom x-  bs = unId $ axiom x'-  x :: X-  a :: T-  b :: T-  (Z:.x:.a:.b) = opForward i-  {--  (Z:.x:.a:.b) = mutateTablesDefault $-                   grammar score-                   (ITbl 1 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) []))-                   (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 n:.subword 0 n) (-999999) []))-                   (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 n:.subword 0 n) (-999999) []))-                   i-                   -}-  (Z:.x':.a':.b') = grammar (score <|| pretty)-                      (toBacktrack x (undefined :: Id a -> Id a))-                      (toBacktrack a (undefined :: Id a -> Id a))-                      (toBacktrack b (undefined :: Id a -> Id a))-                      i-{-# NoInline overlappingPalindromes #-}--opForward :: VU.Vector Char -> Z:.X:.T:.T-opForward i =-  let n = VU.length i-  in  mutateTablesDefault $-        grammar score-        (ITbl 1 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) []))-        (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 n:.subword 0 n) (-999999) []))-        (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 n:.subword 0 n) (-999999) []))-        i-{-# NoInline opForward #-}--type X = ITbl Id Unboxed Subword Int-type T = ITbl Id Unboxed (Z:.Subword:.Subword) Int---main :: IO ()-main = do-  xs <- fmap lines $ getContents-  forM_ xs $ \x -> do-    let (d,bs) = overlappingPalindromes x-    putStrLn x-    print d---    putStrLn $ head $ head bs-
− src/PartNussinov.hs 
@@ -1,275 +0,0 @@---- | Nussinovs RNA secondary structure prediction algorithm via basepair--- maximization.--module Main where--import           Control.Applicative-import           Control.Monad-import           Control.Monad.ST-import           Data.Char (toUpper,toLower)-import           Data.List-import           Data.Vector.Fusion.Util-import           Debug.Trace-import           Language.Haskell.TH-import           Language.Haskell.TH.Syntax-import           Numeric.Log as Log-import qualified Data.Vector.Fusion.Stream as S-import qualified Data.Vector.Fusion.Stream.Monadic as SM-import qualified Data.Vector.Unboxed as VU-import           System.Environment (getArgs)-import           Text.Printf--import           Data.PrimitiveArray as PA--import           ADP.Fusion------ * Inside and Outside grammar constructs--data Nussinov m c e x r = Nussinov-  { unp :: x -> c -> x-  , jux :: x -> x -> x-  , pai :: c -> x -> c -> x-  , nil :: e -> x-  , h   :: SM.Stream m x -> m r-  }--makeAlgebraProduct ''Nussinov--bpmax :: Monad m => Nussinov m Char () Int Int-bpmax = Nussinov-  { unp = \ x c   -> x-  , jux = \ x y   -> x + y-  , pai = \ c x d -> if c `pairs` d then x+1 else (-999999)-  , nil = \ ()    -> 0-  , h   = SM.foldl' max (-999999)-  }-{-# INLINE bpmax #-}--prob :: Monad m => Nussinov m Char () (Log Double) (Log Double)-prob = Nussinov-  { unp = \ x c     -> 0.1 * x                                -- 'any'-  , jux = \ x y     -> 0.9 * x * y                            -- 'any'-  , pai = \ c x d   -> 1.0 * if c `pairs` d then x else 0     -- 'paired'-  , nil = \ ()      -> 1.0                                    -- 'any'-  , h   = SM.foldl' (+) 0-  }-{-# Inline prob #-}---- |--pairs !c !d-  =  c=='A' && d=='U'-  || c=='C' && d=='G'-  || c=='G' && d=='C'-  || c=='G' && d=='U'-  || c=='U' && d=='A'-  || c=='U' && d=='G'-{-# INLINE pairs #-}--pretty :: Monad m => Nussinov m Char () String (SM.Stream m String)-pretty = Nussinov-  { unp = \ x c     -> x ++ "."-  , jux = \ x y     -> x ++ y-  , pai = \ c x d   -> "(" ++ x ++ ")"-  , nil = \ ()      -> ""-  , h   = return . id-  }-{-# INLINE pretty #-}---- | The inside grammar is:------ @--- A -> A c--- A -> A P--- A -> ε--- P -> c A c--- @---- insideGrammar :: Nussinov m Char () x r -> c' -> t' -> (t', Subword -> m r)-insideGrammar Nussinov{..} c a' p' =-  let a = a'  ( unp <<< a % c     |||-                jux <<< a % p     |||-                nil <<< Epsilon   ... h-              )-      p = p'  ( pai <<< c % a % c ... h-              )-  in Z:.p:.a-{-# INLINE insideGrammar #-}---- | Given the inside grammar, the outside grammar is:------ @--- B -> B c--- B -> B P--- B -> ε--- B -> c Q c--- Q -> A B--- @--outsideGrammar Nussinov{..} c a p b' q' =-  let b = b'  ( unp <<< b % c         |||-                jux <<< b % p         |||-                pai <<< c % q % c     |||-                nil <<< Epsilon       ... h-              )-      q = q'  ( jux <<< a % b         ... h-              )-  in Z:.b:.q-{-# INLINE outsideGrammar #-}------ * Ensemble collection constructs--data NussinovEnsemble m v ci x r = NussinovEnsemble-  { ens :: v -> ci -> v -> x-  , hhh :: SM.Stream m x -> m r-  }--ensemble-  :: Monad m-  => Log Double-  -> NussinovEnsemble-        m-        (Log Double)-        (Complement Subword:.(Complement Subword))-        (Subword, Log Double)-        [(Subword, Log Double)]-ensemble z = NussinovEnsemble-  { ens = \ x (C k:._) y -> ( k , x * y / z )-  , hhh = SM.toList-  }-{-# Inline ensemble #-}--ensembleGrammar NussinovEnsemble{..} i o v' =-  let v = v' ( ens <<< i % (PeekIndex :: PeekIndex (Complement Subword)) % o ... hhh )-  in  Z:.v-{-# Inline ensembleGrammar #-}---- makeAlgebraProductH ['hhh] ''NussinovEnsemble------ * Run different algorithm parts--runNussinov :: String -> ([(Subword, Log Double)], Log Double, [(Int,Int, Log Double, Log Double, Log Double, Log Double)])-runNussinov inp = (es,z,ys) where-  i = VU.fromList . Prelude.map toUpper $ inp-  n = VU.length i-  !(Z:.p:.a) = runInsideForward i-  !(Z:.b:.q) = runOutsideForward i a p-  es = runEnsembleForward z p q-  za = let (ITbl _ _ _ arr _) = a in arr PA.! subword 0 n-  zp = let (ITbl _ _ _ arr _) = p in arr PA.! subword 0 n-  z  = za-  e = let (ITbl _ _ _ arr _) = b in Log.sum [ arr PA.! (O $ subword k k) | k <- [0 .. n] ]-  ys =  [ ( k-          , l-          , fwda PA.! subword k l-          , fwdp PA.! subword k l-          , bwdb PA.! (O $ subword k l)-          , bwdq PA.! (O $ subword k l)-          )-        | let (ITbl _ _ _ fwda _) = a-        , let (ITbl _ _ _ fwdp _) = p-        , let (ITbl _ _ _ bwdb _) = b-        , let (ITbl _ _ _ bwdq _) = q-        , k <- [0 .. n]-        , l <- [k .. n]-        ]-{-# NOINLINE runNussinov #-}--neat :: String -> IO ()-neat i = do let (es,z,ys) = runNussinov i-            forM_ ys $ \ (k,_,_,_,_,_) -> printf " %6d" k-            putStrLn ""-            forM_ ys $ \ (_,l,_,_,_,_) -> printf " %6d" l-            putStrLn ""-            forM_ ys $ \ (_,_,a,_,_,_) -> printf " %0.4f" (exp $ ln a)-            putStrLn ""-            forM_ ys $ \ (_,_,_,p,_,_) -> printf " %0.4f" (exp $ ln p)-            putStrLn ""-            forM_ ys $ \ (_,_,_,_,b,_) -> printf " %0.4f" (exp $ ln b)-            putStrLn ""-            forM_ ys $ \ (_,_,_,_,_,q) -> printf " %0.4f" (exp $ ln q)-            putStrLn ""-            printf "%0.4f\n" $ exp $ ln z-            forM_ ys $ \ (_,_,_,p,_,q) -> printf " %0.4f" ((exp $ ln p) * (exp $ ln q) / (exp $ ln z))-            putStrLn ""-            putStrLn ""-            forM_ es $ \ (Subword (i:.j),v) -> printf "%3d %3d  %0.4f\n" i j (exp $ ln v)-            putStrLn ""--type TblI = ITbl Id Unboxed          Subword  (Log Double)-type TblO = ITbl Id Unboxed (Outside Subword) (Log Double)--runInsideForward :: VU.Vector Char -> Z:.TblI:.TblI-runInsideForward i = mutateTablesDefault-                   $ insideGrammar prob-                       (chr i)-                       (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) 0 []))-                       (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) 0 []))-  where n = VU.length i-{-# NoInline runInsideForward #-}--runOutsideForward :: VU.Vector Char -> TblI -> TblI -> Z:.TblO:.TblO-runOutsideForward i a p = mutateTablesDefault-                        $ outsideGrammar prob-                            (chr i)-                            a p-                            (ITbl 0 0 EmptyOk (PA.fromAssocs (O $ subword 0 0) (O $ subword 0 n) 0 []))-                            (ITbl 0 1 EmptyOk (PA.fromAssocs (O $ subword 0 0) (O $ subword 0 n) 0 []))-  where n = VU.length i-{-# NoInline runOutsideForward #-}--runEnsembleForward :: Log Double -> TblI -> TblO -> [ (Subword,Log Double) ]-runEnsembleForward z i o = unId $ axiom g-  where (Z:.g) = ensembleGrammar (ensemble z)-                   i o-                   (IRec EmptyOk (C l) (C h))-                 :: Z :. IRec Id (Complement Subword) [(Subword, Log Double)]-        (l,h) = let (ITbl _ _ _ arr _) = i in bounds arr-{-# NoInline runEnsembleForward #-}--{--runPartitionNussinov :: String -> [(Subword,Double,Double,Double)]-runPartitionNussinov inp-  = Data.List.map (\(sh,a) -> let b = iTblArray t PA.! (O sh)-                              in (sh, a, b, a*b/d)-                  ) (PA.assocs $ iTblArray s)-  where-  i = VU.fromList . Prelude.map toUpper $ inp-  n = VU.length i-  s :: ITbl Id Unboxed Subword Double-  !(Z:.s) = mutateTablesDefault-          $ grammar prob-              (chr i)-              (ITbl EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) 0 []))-              -  d = iTblArray s PA.! subword 0 n-  t :: ITbl Id Unboxed (Outside Subword) Double-  !(Z:.t) = mutateTablesDefault-          $ outsideGrammar prob-              (chr i)-              --(undefined :: ITbl Id Unboxed (Outside Subword) Double)-              s-              (ITbl EmptyOk (PA.fromAssocs (O $ subword 0 0) (O $ subword 0 n) (-1) []))-{-# NOINLINE runPartitionNussinov #-}--}--main :: IO ()-main = do-  return ()-  {--  as <- getArgs-  let k = if null as then 1 else read $ head as-  ls <- lines <$> getContents-  forM_ ls $ \l -> do-    putStrLn l-    let (s,xs) = runNussinov k l-    mapM_ (\x -> printf "%s %5d\n" x s) xs-  -}-
− src/Pseudoknot.hs 
@@ -1,148 +0,0 @@--module Main where--import           Control.Applicative-import           Control.Monad-import           Control.Monad.ST-import           Data.Char (toUpper,toLower)-import           Data.List as L-import           Data.Vector.Fusion.Util-import           Debug.Trace-import           Language.Haskell.TH-import           Language.Haskell.TH.Syntax-import qualified Data.Vector.Fusion.Stream as S-import qualified Data.Vector.Fusion.Stream.Monadic as SM-import qualified Data.Vector.Unboxed as VU-import           System.Environment (getArgs)-import           Text.Printf--import           Data.PrimitiveArray as PA--import           ADP.Fusion----data Nussinov m x r c = Nussinov-  { unp :: x -> c -> x-  , jux :: x -> c -> x -> c -> x-  , pse :: () -> () -> x -> x -> x-  , nil :: () -> x-  , pk1 :: (Z:.x:.()) -> (Z:.c:.()) -> x -> (Z:.():.x) -> (Z:.():.c) -> x-  , pk2 :: (Z:.x:.()) -> (Z:.c:.()) -> x -> (Z:.():.x) -> (Z:.():.c) -> x-  , nll :: (Z:.():.()) -> x-  , h   :: SM.Stream m x -> m r-  }--makeAlgebraProduct ''Nussinov---bpmax :: Monad m => Nussinov m Int Int Char-bpmax = Nussinov-  { unp = \ x c     -> x-  , jux = \ x c y d -> if c `pairs` d then x + y + 1 else -999999-  , pse = \ () () x y -> x + y-  , nil = \ ()      -> 0-  , pk1 = \ (Z:.x:.()) (Z:.a:.()) y (Z:.():.z) (Z:.():.b) -> if a `pairs` b then x + y + z + 1 else -888888-  , pk2 = \ (Z:.x:.()) (Z:.a:.()) y (Z:.():.z) (Z:.():.b) -> if a `pairs` b then x + y + z + 1 else -888888-  , nll = \ (Z:.():.()) -> 0-  , h   = SM.foldl' max (-999999)-  }-{-# INLINE bpmax #-}---- |--pairs !c !d-  =  c=='A' && d=='U'-  || c=='C' && d=='G'-  || c=='G' && d=='C'-  || c=='G' && d=='U'-  || c=='U' && d=='A'-  || c=='U' && d=='G'-{-# INLINE pairs #-}---- |------ TODO It could be beneficial to introduce--- @type Splitted = Either String (String,String)@--- or something isomorphic. While [String] works, it allows for too many--- possibilities here! ([] ist lightweight, on the other hand ...)--pretty :: Monad m => Nussinov m [String] [[String]] Char-pretty = Nussinov-  { unp = \ [x] c     -> [x ++ "."]-  , jux = \ [x] c [y] d -> [x ++ "(" ++ y ++ ")"]-  , pse = \ () () [x1,x2] [y1,y2] -> [x1 ++ y1 ++ x2 ++ y2]-  , nil = \ ()      -> [""]-  , pk1 = \ (Z:.[x]:.()) (Z:.a:.()) [y1,y2] (Z:.():.[z]) (Z:.():.b) -> [x ++ "[" ++ y1 , y2 ++ z ++ "]"]-  , pk2 = \ (Z:.[x]:.()) (Z:.a:.()) [y1,y2] (Z:.():.[z]) (Z:.():.b) -> [x ++ "{" ++ y1 , y2 ++ z ++ "}"]-  , nll = \ (Z:.():.()) -> ["",""]-  , h   = SM.toList-  }-{-# INLINE pretty #-}--grammar Nussinov{..} t' u' v' c =-  let t = t'  ( unp <<< t % c               |||-                jux <<< t % c % t % c   |||-                nil <<< Epsilon                 |||-                pse <<< (split (Proxy :: Proxy "U") (Proxy :: Proxy Fragment) u)-                     %  (split (Proxy :: Proxy "V") (Proxy :: Proxy Fragment) v)-                     %  (split (Proxy :: Proxy "U") (Proxy :: Proxy Final)    u)-                     %  (split (Proxy :: Proxy "V") (Proxy :: Proxy Final)    v)  ... h-              )-      u = u'  ( pk1 <<< (M:|t:|Deletion) % (M:|c:|Deletion) % u % (M:|Deletion:|t) % (M:|Deletion:|c) |||-                nll <<< (M:|Epsilon:|Epsilon)                                                                 ... h-              )-      v = v'  ( pk2 <<< (M:|t:|Deletion) % (M:|c:|Deletion) % v % (M:|Deletion:|t) % (M:|Deletion:|c) |||-                nll <<< (M:|Epsilon:|Epsilon)                                                                 ... h-              )-  in Z:.t:.u:.v-{-# INLINE grammar #-}--runPseudoknot :: Int -> String -> (Int,[[String]])-runPseudoknot k inp = (d, take k bs) where-  i = VU.fromList . Prelude.map toUpper $ inp-  n = VU.length i-  !(Z:.t:.u:.v) = runInsideForward i-  d = unId $ axiom t-  bs = {- let ITbl _ _ _ x _ = v in traceShow (filter (flip elem gives . fst) $ assocs x) $ -} runInsideBacktrack i (Z:.t:.u:.v)-  gives = [ Z:.subword 2 2 :. subword 3 3-          , Z:.subword 1 2 :. subword 3 5-          ]-  {--   -  u g a a c-   - 0 1 2 3 4 5-  -}-{-# NOINLINE runPseudoknot #-}--type X = ITbl Id Unboxed Subword Int-type T = ITbl Id Unboxed (Z:.Subword:.Subword) Int--runInsideForward :: VU.Vector Char -> Z:.X:.T:.T-runInsideForward i = mutateTablesWithHints (Proxy :: Proxy MonotoneMCFG)-                   $ grammar bpmax-                        (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-666999) []))-                        (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 n:.subword 0 n) (-777999) []))-                        (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 n:.subword 0 n) (-888999) []))-                        (chr i)-  where n = VU.length i-{-# NoInline runInsideForward #-}--runInsideBacktrack :: VU.Vector Char -> Z:.X:.T:.T -> [[String]]-runInsideBacktrack i (Z:.t:.u:.v) = unId $ axiom b-  where !(Z:.b:._:._) = grammar (bpmax <|| pretty)-                          (toBacktrack t (undefined :: Id a -> Id a))-                          (toBacktrack u (undefined :: Id a -> Id a))-                          (toBacktrack v (undefined :: Id a -> Id a))-                          (chr i)-{-# NoInline runInsideBacktrack #-}--main = do-  as <- getArgs-  let k = if null as then 1 else read $ head as-  ls <- lines <$> getContents-  forM_ ls $ \l -> do-    putStrLn l-    let (s,xs) = runPseudoknot k l-    print s-    mapM_ (\[x] -> printf "%s %5d\n" x s) xs-
+ src/SmithWaterman.hs view
@@ -0,0 +1,194 @@++{-# Options_GHC -fforce-recomp #-}+{-# Options_GHC -Wno-partial-type-signatures #-}++{-# Language MagicHash #-}+++module Main (main) where++import           Control.Monad (forM_,when)+import           Debug.Trace+import           System.Environment (getArgs)+import           Text.Printf+import           Control.Monad.Primitive+import           Control.Monad.ST+import           Data.Foldable (maximumBy)+import           Data.Ord (comparing)+import           Data.Ord.Fast+import           GHC.Exts++import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Unboxed as VU++import           Data.PrimitiveArray as PA hiding (map)++import           ADP.Fusion.PointL++++data Signature m x r c = Signature+  { step_step ∷ x → (Z:.c :.c ) → x+  , step_loop ∷ x → (Z:.c :.()) → x+  , loop_step ∷ x → (Z:.():.c ) → x+  , nil_nil   ∷     (Z:.():.()) → x+  , h         ∷ Stream m x -> m r+  }++makeAlgebraProduct ''Signature++grammar Signature{..} !a' !i1 !i2 =+  let a = TW a' ( step_step <<< a % (M:|chr i1:|chr i2)     |||+                  step_loop <<< a % (M:|chr i1:|Deletion  ) |||+                  loop_step <<< a % (M:|Deletion  :|chr i2) |||+                  nil_nil   <<< (M:|Epsilon @Local:|Epsilon @Local)       ... h+                )+  in Z:.a+{-# INLINE grammar #-}++fasteq ∷ Char → Char → Int → Int → Int+{-# Inline fasteq #-}+fasteq (C# a) (C# b) (I# x) (I# y) =+  let l = (eqChar# a b)+  in  I# ( (x *# l) +# (y *# (1# -# l)) )++sScore ∷ Monad m ⇒ Signature m Int Int Char+sScore = Signature+  -- { step_step = \x (Z:.a:.b) → if a==b then x + 1 else x-2+  { step_step = \x (Z:.a:.b) → fasteq a b (x+1) (x-2) -- if a==b then x + 1 else x-2+  , step_loop = \x _         → x-1+  , loop_step = \x _         → x-1+  , nil_nil   = const 0+  , h = SM.foldl' fastmax (-999999)+  }+{-# INLINE sScore #-}+++sPretty ∷ Monad m ⇒ Signature m [String] [[String]] Char+sPretty = Signature+  { step_step = \[x,y] (Z:.a :.b ) → [a  :x, b  :y]+  , step_loop = \[x,y] (Z:.a :.()) → [a  :x, '-':y]+  , loop_step = \[x,y] (Z:.():.b ) → ['-':x, b  :y]+  , nil_nil   = const ["",""]+  , h = SM.toList+  }+{-# Inline sPretty #-}+++runNeedlemanWunsch+  ∷ Int+  → String+  → String+  → ((Z:.PointL I:.PointL I),Int,[[String]],PerfCounter)+runNeedlemanWunsch k i1' i2' = (fst dlocal, snd dlocal, take k bs,perf) where+  i1 = VU.fromList i1'+  i2 = VU.fromList i2'+  n1 = VU.length i1+  n2 = VU.length i2+  Mutated (Z:.t) perf eachPerf = nwInsideForward i1 i2+  dlocal = let TW (ITbl _ t') _ = t+           in unId . SM.foldl' (\(ap,as) (p,s) → if s > as then (p,s) else (ap,as)) (Z:.PointL 0:.PointL 0,0) $ PA.assocsS t'+  bs = nwInsideBacktrack i1 i2 t (fst dlocal)+{-# Noinline runNeedlemanWunsch #-}+++nwInsideForward+  ∷ VU.Vector Char+  → VU.Vector Char+  → Mutated (Z:.TwITbl _ _ Id (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int)+nwInsideForward !i1 !i2 = {-# SCC "nwInsideForward" #-} runST $ do+  arr ← newWithPA (ZZ:..LtPointL n1:..LtPointL n2) (-999999)+  ts ← fillTables $ grammar sScore+                      (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk:.EmptyOk) arr)+                      i1 i2+  return ts+  where !n1 = VU.length i1+        !n2 = VU.length i2+{-# NoInline nwInsideForward #-}++nwInsideBacktrack+  ∷ VU.Vector Char+  → VU.Vector Char+  → TwITbl _ _ Id (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int+  → (Z:.PointL I:.PointL I)+  → [[String]]+nwInsideBacktrack i1 i2 t k = {-# SCC "nwInsideBacktrack" #-} unId $ axiomAt b k+  where !(Z:.b) = grammar (sScore <|| sPretty) (toBacktrack t (undefined :: Id a -> Id a)) i1 i2+                    :: Z:.TwITblBt _ _ (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int Id Id [String]+{-# NoInline nwInsideBacktrack #-}+++--runOutsideNeedlemanWunsch+--  ∷ Int+--  → String+--  → String+--  → (Int,[[String]],PerfCounter)+--runOutsideNeedlemanWunsch k i1' i2' = {-# SCC "runOutside" #-} (d, take k . unId $ axiom b, perf) where+--  i1 = VU.fromList i1'+--  i2 = VU.fromList i2'+--  n1 = VU.length i1+--  n2 = VU.length i2+--  Mutated (Z:.t) perf eachPerf = nwOutsideForward i1 i2+--  d = unId $ axiom t+--  !(Z:.b) = grammar (sScore <|| sPretty) (toBacktrack t (undefined :: Id a -> Id a)) i1 i2+--              :: Z:.TwITblBt _ _ (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL O:.PointL O) Int Id Id [String]+--{-# Noinline runOutsideNeedlemanWunsch #-}+--+--+--nwOutsideForward+--  ∷ VU.Vector Char+--  → VU.Vector Char+--  → Mutated (Z:.TwITbl _ _ Id (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL O:.PointL O) Int)+--nwOutsideForward !i1 !i2 = {-# SCC "nwOutsideForward" #-} runST $ do+--  arr ← newWithPA (ZZ:..LtPointL n1:..LtPointL n2) (-999999)+--  ts ← fillTables $ grammar sScore+--                      (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk:.EmptyOk) arr)+--                      i1 i2+--  return ts+--  where !n1 = VU.length i1+--        !n2 = VU.length i2+--{-# Noinline nwOutsideForward #-}++-- | This wrapper takes a list of input sequences and aligns each odd+-- sequence with the next even sequence. We want one alignment for each+-- such pair.+--+-- Since we use basic lists during backtracking, the resulting lists have+-- to be reversed for inside-backtracking. Note that because the Outside+-- grammar is quasi-right-linear, it does not require reversing the two+-- strings.+--+-- For real applications, consider using @Data.Sequence@ which has @O(1)@+-- append and prepend.++align _ [] = return ()+align _ [c] = putStrLn "single last line"+align (kI,kO) (a:b:xs) = {-# SCC "align" #-} do+  putStrLn a+  putStrLn b+  let (posI,sI,rsI,perfI) = runNeedlemanWunsch kI a b+  when (kI>=0) $ forM_ rsI $ \[u,l] -> printf "%s\n%s\n  %d   %s\n\n" (reverse u) (reverse l) (sI) (show posI)+  when (kI>=0) $ print sI+  when (kI>=0) . putStrLn $ showPerfCounter perfI+  putStrLn ""+  align (kI,kO) xs++-- | And finally have a minimal main that reads from stdio.+--+-- If you are brave enough then put this through @ghc-core@ and look for+-- @nwInsideForward@ or @nwOutsideForward@ in the CORE. Everything coming+-- from the forward phase should be beautifully optimized and the algorithm+-- should run quite fast.++main = do+  as <- getArgs+  let k = case as of+            [] -> (1,1)+            [x] -> let x' = read x+                   in (x',x')+            [x,y] -> let x' = read x; y' = read y+                     in  (x',y')+            args -> error $ "too many arguments"+  ls <- lines <$> getContents+  align k ls+
+ src/SpecTest.hs view
@@ -0,0 +1,116 @@++-- | Lets try to get a grip on what specconstr does to our code.++module Main (main) where++import           Control.Applicative+import           Control.Monad+import           Data.Vector.Fusion.Stream.Monadic (Stream (..))+import           Data.Vector.Fusion.Util+import           Debug.Trace+import qualified Control.Arrow as A+import qualified Data.Vector as V+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Unboxed as VU+import           System.Environment (getArgs)+import           System.IO.Unsafe (unsafePerformIO)+import           Text.Printf++import           Data.PrimitiveArray as PA hiding (map)++import           ADP.Fusion.Point+++++data Signature m x r c = Signature+  { step_step :: x -> (Z:.c :.c ) -> x+  , step_loop :: x -> (Z:.c :.()) -> x+  , loop_step :: x -> (Z:.():.c ) -> x+  , nil_nil   ::      (Z:.():.()) -> x+  , booboo    :: x -> (Z:.c:.c) -> (Z:.c:.c) -> (Z:.c:.c) -> (Z:.c:.c) -> x+  , h         :: Stream m x -> m r+  }++++grammar Signature{..} a' i1 i2 =+  let a = a'  ( --step_step <<< a % (M:|chr i1:|chr i2)     |||+--                step_loop <<< a % (M:|chr i1:|Deletion  ) |||+--                loop_step <<< a % (M:|Deletion  :|chr i2) |||+                step_step <<< a % (M:|chr i1:|chr i2)     |||+--                step_step <<< a % (M:|chr i1:|chr i2)     |||+--                step_step <<< a % (M:|chr i1:|chr i2)     |||+--                step_step <<< a % (M:|chr i1:|chr i2)     |||+--                step_step <<< a % (M:|chr i1:|chr i2)     |||+--                step_step <<< a % (M:|chr i1:|chr i2)     |||+--                step_step <<< a % (M:|chr i1:|chr i2)     |||+--                step_step <<< a % (M:|chr i1:|chr i2)     |||+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||+--                booboo    <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2)    |||+--                nil_nil   <<< (M:|Epsilon:|Epsilon)       |||+--                nil_nil   <<< (M:|Epsilon:|Epsilon)       |||+--                nil_nil   <<< (M:|Epsilon:|Epsilon)       |||+--                nil_nil   <<< (M:|Epsilon:|Epsilon)       |||+--                nil_nil   <<< (M:|Epsilon:|Epsilon)       |||+--                nil_nil   <<< (M:|Epsilon:|Epsilon)       |||+--                nil_nil   <<< (M:|Epsilon:|Epsilon)       |||+--                nil_nil   <<< (M:|Epsilon:|Epsilon)       |||+--                nil_nil   <<< (M:|Epsilon:|Epsilon)       |||+--                nil_nil   <<< (M:|Epsilon:|Epsilon)       |||+--                nil_nil   <<< (M:|Epsilon:|Epsilon)       |||+                nil_nil   <<< (M:|Epsilon:|Epsilon)       ... h+              )+  in Z:.a+{-# INLINE grammar #-}+++sScore :: Monad m => Signature m Int Int Char+sScore = Signature+  { step_step = \x (Z:.a:.b) -> if a==b then x+1 else x-2+  , step_loop = \x _         -> x-1+  , loop_step = \x _         -> x-1+  , nil_nil   = const 0+  , booboo    = \x _ _ _ _   -> x+  , h = SM.foldl' max (-999999)+  }+{-# INLINE sScore #-}+++runNeedlemanWunsch :: Int -> String -> String -> Int+runNeedlemanWunsch k i1' i2' = d where+  i1 = VU.fromList i1'+  i2 = VU.fromList i2'+  n1 = VU.length i1+  n2 = VU.length i2+  !(Z:.t) = nwInsideForward i1 i2+  d = unId $ axiom t+{-# Noinline runNeedlemanWunsch #-}++nwInsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.ITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int+nwInsideForward i1 i2 = {-# SCC "nwInsideForward" #-} mutateTablesDefault $+                          grammar sScore+                          (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.PointL 0:.PointL 0) (Z:.PointL n1:.PointL n2) (-999999) []))+                          i1 i2+  where n1 = VU.length i1+        n2 = VU.length i2+{-# NoInline nwInsideForward #-}++main = do+  ls <- lines <$> getContents+  print $ runNeedlemanWunsch 1 (ls!!0) (ls!!1)++
− src/SplitTests.hs 
@@ -1,136 +0,0 @@--{-# Language DataKinds #-}-{-# Language KindSignatures #-}-{-# Language ScopedTypeVariables #-}-{-# Language DataKinds               #-}-{-# Language DefaultSignatures       #-}-{-# Language FlexibleContexts        #-}-{-# Language FlexibleInstances       #-}-{-# Language GADTs                   #-}-{-# Language KindSignatures          #-}-{-# Language MultiParamTypeClasses   #-}-{-# Language RankNTypes              #-}-{-# Language StandaloneDeriving      #-}-{-# Language TemplateHaskell         #-}-{-# Language TypeFamilies            #-}-{-# Language TypeOperators           #-}-{-# Language TypeSynonymInstances    #-}-{-# Language UndecidableInstances    #-}--module Main where--import           Control.Applicative-import           Control.Monad-import           Data.Vector.Fusion.Stream.Monadic (Stream (..))-import           Data.Vector.Fusion.Util-import           Debug.Trace-import qualified Control.Arrow as A-import qualified Data.Vector as V-import qualified Data.Vector.Fusion.Stream as S-import qualified Data.Vector.Fusion.Stream.Monadic as SM-import qualified Data.Vector.Unboxed as VU-import           System.Environment (getArgs)-import           System.IO.Unsafe (unsafePerformIO)-import           Text.Printf--import           Data.PrimitiveArray as PA hiding (map)--import           ADP.Fusion----data Signature m x r c = Signature-  { ovrlap :: () -> x -> x-  , brckts :: (Z:.c:.()) -> x -> (Z:.():.c) -> x-  , nilnil :: (Z:.():.()) -> x-  , h :: Stream m x -> m r-  }--makeAlgebraProduct ''Signature------ |------ @--- 012345678--- [[((]]))--- @--grammar Signature{..} x' a' i =-  let x = x'  ( ovrlap <<< (split (Proxy :: Proxy "a") (Proxy :: Proxy Fragment) a)-                        %  (split (Proxy :: Proxy "a") (Proxy :: Proxy Final   ) a) ... h-              )-      a = a'  ( nilnil <<< (M:|Epsilon:|Epsilon)                           |||-                brckts <<< (M:|chr i:|Deletion) % a % (M:|Deletion:|chr i) ... h-              )-  in Z:.x:.a-{-# Inline grammar #-}----score :: Monad m => Signature m Int Int Char-score = Signature-  { ovrlap = \ a' a -> a + 4711-  , brckts = \ (Z:.l:.()) a (Z:.():.r) -> {- traceShow ("[]",l,a,r) $ -} if l=='[' && r==']' then a+1 else -999999-  , nilnil = \ _ -> 0-  , h = SM.foldl' max (-999999)-  }-{-# Inline score #-}------ |------ TODO pretty shows in @ovrlap@ that we might want to introduce a second--- @h@ together with @Stream m y -> m s@?--pretty :: Monad m => Signature m [String] [[String]] Char-pretty = Signature-  { ovrlap = \ () [a,a'] -> [a ++ a']-  , brckts = \ (Z:.l:.()) [a,a'] (Z:.():.r) -> ["a"++a , a'++"A"]-  , nilnil = \ _ -> ["",""]-  , h = SM.toList-  }-{-# Inline pretty #-}----overlappingPalindromes :: String -> (Int,[[String]])-overlappingPalindromes inp = (d,bs) where-  i  = VU.fromList inp-  n  = VU.length i-  d  = unId $ axiom x-  bs = unId $ axiom x'-  x :: X-  a :: T-  (Z:.x:.a) = opForward i-  (Z:.x':.a') = grammar (score <|| pretty)-                  (toBacktrack x (undefined :: Id a -> Id a))-                  (toBacktrack a (undefined :: Id a -> Id a))-                  i-{-# NoInline overlappingPalindromes #-}--opForward :: VU.Vector Char -> Z:.X:.T-opForward i =-  let n = VU.length i-  in  mutateTablesDefault $-        grammar score-        (ITbl 1 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) []))-        (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 n:.subword 0 n) (-999999) []))-        i-{-# NoInline opForward #-}--type X = ITbl Id Unboxed Subword Int-type T = ITbl Id Unboxed (Z:.Subword:.Subword) Int---main :: IO ()-main = do-  xs <- fmap lines $ getContents-  forM_ xs $ \x -> do-    let (d,bs) = overlappingPalindromes x-    putStrLn x-    print d---    putStrLn $ head $ head bs-
+ tests/QuickCheck/Common.hs view
@@ -0,0 +1,10 @@++{-# Options_GHC -O0 #-}++module QuickCheck.Common where++import Debug.Trace++++tr zs ls b = traceShow (zs," ",ls,length zs,length ls) b
+ tests/QuickCheck/Point.hs view
@@ -0,0 +1,328 @@++{-# Options_GHC -O0 #-}++module QuickCheck.Point where++import           Control.Applicative+import           Control.Monad+import           Data.Strict.Tuple+import           Data.Vector.Fusion.Util+import           Debug.Trace+--import           GHC.TypeNats+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Unboxed as VU+import           System.IO.Unsafe+import           Test.QuickCheck+import           Test.QuickCheck.All+import           Test.QuickCheck.Monadic+-- #ifdef ADPFUSION_TEST_SUITE_PROPERTIES+import           Test.Tasty.TH+import           Test.Tasty.QuickCheck+-- #endif++import           Data.PrimitiveArray++import           ADP.Fusion.PointL++++-- * Epsilon cases++prop_I_Epsilon ix@(PointL j) = zs == ls where+  zs = (id <<< Epsilon @Global ... stoList) maxPLi ix+  ls = [ () | j == 0 ]++prop_O_Epsilon ix@(PointL j) = zs == ls where+  zs = (id <<< Epsilon @Global ... stoList) maxPLo ix+  ls = [ () | j == maxI ]++prop_I_ZEpsilon ix@(Z:.PointL j) = zs == ls where+  zs = (id <<< (M:|Epsilon @Global) ... stoList) (ZZ:..maxPLi) ix+  ls = [ Z:.() | j == 0 ]++prop_O_ZEpsilon ix@(Z:.PointL j) = zs == ls where+  zs = (id <<< (M:|Epsilon @Global) ... stoList) (ZZ:..maxPLo) ix+  ls = [ Z:.() | j == maxI ]++prop_O_ZEpsilonEpsilon ix@(Z:.PointL j:.PointL l) = zs == ls where+  zs = (id <<< (M:|Epsilon @Global:|Epsilon @Global) ... stoList) (ZZ:..maxPLo:..maxPLo) ix+  ls = [ Z:.():.() | j == maxI, l == maxI ]++++-- * Deletion cases++prop_I_ItNC ix@(PointL j) = zs == ls where+  zs = ((,,) <<< tSI % Deletion % chr xs ... stoList) maxPLi ix+  ls = [ ( unsafeIndex xsP (PointL $ j-1)+         , ()+         , xs VU.! (j-1)+         ) | j >= 1, j <= (maxI) ]++prop_O_ItNC ix@(PointL j) = zs == ls where+  zs = ((,,) <<< tSO % Deletion % chr xs ... stoList) maxPLo ix+  ls = [ ( unsafeIndex xsPo (PointL $ j+1)+         , ()+         , xs VU.! (j+0)+         ) | j >= 0, j <= (maxI-1) ]+{-# Noinline prop_O_ItNC #-}++prop_O_ZItNC ix@(Z:.PointL j) = zs == ls where+  zs = ((,,) <<< tZ1O % (M:|Deletion) % (M:|chr xs) ... stoList) (ZZ:..maxPLo) ix+  ls = [ ( unsafeIndex xsZPo (Z:.PointL (j+1))+         , Z:.()+         , Z:.xs VU.! (j+0)+         ) | j >= 0, j <= (maxI-1) ]++prop_O_2dimIt_NC_CN ix@(Z:.PointL j:.PointL l) = zs == ls where+  zs = ((,,) <<< tZ2O % (M:|Deletion:|chr xs) % (M:|chr xs:|Deletion) ... stoList) (ZZ:..maxPLo:..maxPLo) ix+  ls = [ ( unsafeIndex xsPPo (Z:.PointL (j+1):.PointL (l+1))+         , Z:.()           :.xs VU.! (l+0)+         , Z:.xs VU.! (j+0):.()+         ) | j>=0, l>=0, j<=(maxI-1), l<=(maxI-1) ]++prop_I_2dimIt_NC_CN ix@(Z:.PointL j:.PointL l) = zs == ls where+  zs = ((,,) <<< tZ2I % (M:|Deletion:|chr xs) % (M:|chr xs:|Deletion) ... stoList) (ZZ:..maxPLi:..maxPLi) ix+  ls = [ ( unsafeIndex xsPP (Z:.PointL (j-1):.PointL (l-1))+         , Z:.()           :.xs VU.! (l-1)+         , Z:.xs VU.! (j-1):.()+         ) | j>=1, l>=1, j<=maxI, l<=maxI ]++++-- * terminal cases++-- | A single character terminal+--+-- X_j -> c_j || j==1++prop_I_Tt ix@(Z:.PointL j) = zs == ls where+  zs = (id <<< (M:|chr xs) ... stoList) (ZZ:..maxPLi) ix+  ls = [ (Z:.xs VU.! (j-1)) | 1==j ]++-- |+--+-- X_j     -> ε_{j-1} c_j   ||| j==1+-- E_{j-1} -> X_{j}   c_j+-- E_j     -> X_{j+1} c_{j+1}    ||| j-1==max ?!++prop_O_Tt ix@(Z:.(PointL j))+  | zs == ls  = True+  | otherwise = traceShow (j,zs,ls) False+  where+    zs = (id <<< (M:|chr xs) ... stoList) (ZZ:..maxPLo) ix+    ls = [ (Z:.xs VU.! j) | j==maxI-1 ]++-- | Two single-character terminals++prop_I_CC ix@(Z:.PointL i) = zs == ls where+  zs = ((,) <<< (M:|chr xs) % (M:|chr xs) ... stoList) (ZZ:..maxPLi) ix+  ls = [ (Z:.xs VU.! (i-2), Z:.xs VU.! (i-1)) | 2==i ]++-- | Just a table++prop_I_It ix@(PointL j) = zs == ls where+  zs = (id <<< tSI ... stoList) maxPLi ix+  ls = [ unsafeIndex xsP ix | j>=0, j<=maxI ]++prop_O_It ix@(PointL j) = zs == ls where+  zs = (id <<< tSO ... stoList) maxPLo ix+  ls = [ unsafeIndex xsPo ix | j>=0, j<=maxI ]++prop_I_ZIt ix@(Z:.PointL j) = zs == ls where+  zs = (id <<< tZ1I ... stoList) (ZZ:..maxPLi) ix+  ls = [ unsafeIndex xsZP ix | j>=0, j<=maxI ]++prop_I_2dimIt ix@(Z:.PointL i:.PointL j) = zs == ls where+  zs = (id <<< tZ2I ... stoList) (ZZ:..maxPLi:..maxPLi) ix+  ls = [ unsafeIndex xsPP ix | j>=0, j<=maxI ]++prop_O_ZIt ix@(Z:.PointL j) = zs == ls where+  zs = (id <<< tZ1O ... stoList) (ZZ:..maxPLo) ix+  ls = [ unsafeIndex xsZPo ix | j>=0, j<=maxI ]++-- | Table, then single terminal++prop_I_ItC ix@(PointL j) = zs == ls where+  zs = ((,) <<< tSI % chr xs ... stoList) maxPLi ix+  ls = [ ( unsafeIndex xsP (PointL $ j-1)+         , xs VU.! (j-1)+         ) | j>=1, j<=maxI ]++-- | @A^*_j -> A^*_{j+1} c_{j+1)@ !++prop_O_ItC ix@(PointL j)+  | zs == ls  = True+  | otherwise = traceShow (j,zs,ls) False+  where+    zs = ((,) <<< tSO % chr xs ... stoList) maxPLo ix+    ls = [ ( unsafeIndex xsPo (PointL $ j+1)+           , xs VU.! (j+0)  -- j-1 in inside, here moved one right!+           ) | j >= 0, j <= (maxI-1) ]++prop_O_ItCC ix@(PointL j) = zs == ls where+  zs = ((,,) <<< tSO % chr xs % chr xs ... stoList) maxPLo ix+  ls = [ ( unsafeIndex xsPo (PointL $ j+2)+         , xs VU.! (j+0)+         , xs VU.! (j+1)+         ) | j >= 0, j <= (maxI-2) ]++prop_O_ItCCC ix@(PointL j) = zs == ls where+  zs = ((,,,) <<< tSO % chr xs % chr xs % chr xs ... stoList) maxPLo ix+  ls = [ ( unsafeIndex xsPo (PointL $ j+3)+         , xs VU.! (j+0)+         , xs VU.! (j+1)+         , xs VU.! (j+2)+         ) | j >= 0, j <= (maxI-3) ]++prop_O_ZItCC ix@(Z:.PointL j) = zs == ls where+  zs = ((,,) <<< tZ1O % (M:|chr xs) % (M:|chr xs) ... stoList) (ZZ:..maxPLo) ix+  ls = [ ( unsafeIndex xsZPo (Z:.PointL (j+2))+         , Z:.xs VU.! (j+0)+         , Z:.xs VU.! (j+1)+         ) | j >= 0, j <= (maxI-2) ]++-- | synvar followed by a 2-tape character terminal++prop_I_2dimItCC ix@(Z:.PointL j:.PointL l) = zs == ls where+  zs = ((,,) <<< tZ2I % (M:|chr xs:|chr xs) % (M:|chr xs:|chr xs) ... stoList) (ZZ:..maxPLi:..maxPLi) ix+  ls = [ ( unsafeIndex xsPP (Z:.PointL (j-2):.PointL (l-2))+         , Z:.xs VU.! (j-2):.xs VU.! (l-2)+         , Z:.xs VU.! (j-1):.xs VU.! (l-1)+         ) | j>=2, l>=2, j<=maxI, l<=maxI ]++prop_O_2dimItCC ix@(Z:.PointL j:.PointL l) = zs == ls where+  zs = ((,,) <<< tZ2O % (M:|chr xs:|chr xs) % (M:|chr xs:|chr xs) ... stoList) (ZZ:..maxPLo:..maxPLo) ix+  ls = [ ( unsafeIndex xsPPo (Z:.PointL (j+2):.PointL (l+2))+         , Z:.xs VU.! (j+0):.xs VU.! (l+0)+         , Z:.xs VU.! (j+1):.xs VU.! (l+1)+         ) | j>=0, l>=0, j<=(maxI-2), l<=(maxI-2) ]++-- * 'Strng' tests++-- ** Just the 'Strng' terminal++prop_I_ManyV ix@(PointL j) = zs == ls where+  zs = (id <<< manyV xs ... stoList) maxPLi ix+  ls = [ (VU.slice 0 j xs) ]++prop_I_SomeV ix@(PointL j)+  | zs == ls  = True+  | otherwise = traceShow (ix,zs,ls) False+  where+  zs = (id <<< someV xs ... stoList) maxPLi ix+  ls = [ (VU.slice 0 j xs) | j>0 ]++prop_2dim_ManyV_ManyV ix@(Z:.PointL i:.PointL j) = zs == ls where+  zs = (id <<< (M:|manyV xs:|manyV xs) ... stoList) (ZZ:..maxPLi:..maxPLi) ix+  ls = [ (Z:.VU.slice 0 i xs:.VU.slice 0 j xs) ]++prop_2dim_SomeV_SomeV ix@(Z:.PointL i:.PointL j) = zs == ls where+  zs = (id <<< (M:|someV xs:|someV xs) ... stoList) (ZZ:..maxPLi:..maxPLi) ix+  ls = [ (Z:.VU.slice 0 i xs:.VU.slice 0 j xs) | i > 0 && j > 0 ]++-- ** Together with a syntactic variable.++prop_I_Itbl_ManyV ix@(PointL i) = zs == ls where+  zs = ((,) <<< tSI % manyV xs ... stoList) maxPLi ix+  ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i] ]++prop_I_Itbl_SomeV ix@(PointL i) = zs == ls where+  zs = ((,) <<< tSI % someV xs ... stoList) maxPLi ix+  ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i-1] ]++-- | NOTE Be aware of the needed match between the type-level and value-level+-- @13@s.++prop_I_Itbl_Str ix@(PointL i) = zs == ls where+  zs = ((,) <<< tSI % Str @_ @_ @Nothing @13 @Nothing xs ... stoList) maxPLi ix+  ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i-13] ]++-- | And now for some funny type-level shenanigans.++prop_I_Itbl_StrTyLvl (Positive bound', ix@(PointL i)) = let bound = bound' `mod` 23 in+  case (someNatVal bound) of+    Nothing → error "zzz"+    Just (SomeNat (Proxy ∷ Proxy b)) →+      let zs = ((,) <<< tSI % Str @_ @_ @Nothing @b @Nothing xs ... stoList) maxPLi ix+          ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i-bv] ]+          bv = fromIntegral $ natVal (Proxy ∷ Proxy b)+      in  zs == ls++prop_I_1dim_Itbl_ManyV ix@(Z:.PointL i) = zs == ls where+  zs = ((,) <<< tZ1I % (M:|manyV xs) ... stoList) (ZZ:..maxPLi) ix+  ls = [ (unsafeIndex xsZP (Z:.PointL k), Z:. VU.slice k (i-k) xs) | k <- [0..i] ]++prop_I_1dim_Itbl_SomeV ix@(Z:.PointL i) = zs == ls where+  zs = ((,) <<< tZ1I % (M:|someV xs) ... stoList) (ZZ:..maxPLi) ix+  ls = [ (unsafeIndex xsZP (Z:.PointL k), Z:. VU.slice k (i-k) xs) | k <- [0..i-1] ]++prop_I_2dim_Itbl_ManyV_ManyV ix@(Z:.PointL i:.PointL j) = zs == ls where+  zs = ((,) <<< tZ2I % (M:|manyV xs:|manyV xs) ... stoList) (ZZ:..maxPLi:..maxPLi) ix+  ls = [ (unsafeIndex xsPP (Z:.PointL k:.PointL l), Z:. VU.slice k (i-k) xs :. VU.slice l (j-l) xs) | k <- [0..i], l <- [0..j] ]++prop_I_2dim_Itbl_SomeV_SomeV ix@(Z:.PointL i:.PointL j) = zs == ls where+  zs = ((,) <<< tZ2I % (M:|someV xs:|someV xs) ... stoList) (ZZ:..maxPLi:..maxPLi) ix+  ls = [ (unsafeIndex xsPP (Z:.PointL k:.PointL l), Z:. VU.slice k (i-k) xs :. VU.slice l (j-l) xs) | k <- [0..i-1], l <- [0..j-1] ]++++stoList = unId . SM.toList++--infixl 8 >>>+--(>>>) f xs = \lu ij -> SM.map f . mkStream (build xs) (initialContext ij) lu $ ij++tSI  = TW (ITbl @_ @_ @_ @_ @0 @0 EmptyOk xsP)  (\ (_ :: LimitType (PointL I)) (_ :: PointL I) -> Id (1::Int))+tSO  = TW (ITbl @_ @_ @_ @_ @0 @0 EmptyOk xsPo) (\ (_ :: LimitType (PointL O)) (_ :: PointL O) -> Id (1::Int))+tZ1I = TW (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk) xsZP) (\ (_::LimitType (Z:.PointL I)) (_::Z:.PointL I) -> Id (1::Int))+tZ1O = TW (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk) xsZPo) (\ (_::LimitType (Z:.PointL O)) (_::Z:.PointL O) -> Id (1::Int))+tZ2I = TW (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk:.EmptyOk) xsPP) (\ (_::LimitType (Z:.PointL I:.PointL I)) (_::Z:.PointL I:.PointL I) -> Id (1::Int))+tZ2O = TW (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk:.EmptyOk) xsPPo) (\ (_::LimitType (Z:.PointL O:.PointL O)) (_::Z:.PointL O:.PointL O) -> Id (1::Int))++xsP :: Unboxed (PointL I) Int+xsP = fromList maxPLi [0 ..]++xsZP :: Unboxed (Z:.PointL I) Int+xsZP = fromList (ZZ:..maxPLi) [0 ..]++xsPo :: Unboxed (PointL O) Int+xsPo = fromList maxPLo [0 ..]++xsZPo :: Unboxed (Z:.PointL O) Int+xsZPo = fromList (ZZ:..maxPLo) [0 ..]++xsPP :: Unboxed (Z:.PointL I:.PointL I) Int+xsPP = fromList (ZZ:..maxPLi:..maxPLi) [0 ..]++xsPPo :: Unboxed (Z:.PointL O:.PointL O) Int+xsPPo = fromList (ZZ:..maxPLo:..maxPLo) [0 ..]++mxsPP = unsafePerformIO $ zzz where+  zzz :: IO (MutArr IO (Unboxed (Z:.PointL I:.PointL I) Int))+  zzz = fromListM (ZZ:..maxPLi:..maxPLi) [0 ..]++maxI =100++maxPLi :: LimitType (PointL I)+maxPLi = LtPointL maxI++maxPLo :: LimitType (PointL O)+maxPLo = LtPointL maxI++xs = VU.fromList [0 .. maxI - 1 :: Int]++-- * general quickcheck stuff++options = stdArgs {maxSuccess = 1000 } -- 0}++customCheck = quickCheckWithResult options++return []+allProps = $forAllProperties customCheck++++-- #ifdef ADPFUSION_TEST_SUITE_PROPERTIES+testgroup_point = $(testGroupGenerator)+-- #endif+
− tests/performance.hs 
@@ -1,89 +0,0 @@--module Main where--import           Data.Vector.Fusion.Util-import           GHC.Stats-import qualified Data.Vector.Fusion.Stream.Monadic as SM-import qualified Data.Vector.Unboxed as VU-import           System.Mem-import           System.Environment-import           GHC.Conc (pseq)-import           GHC.Generics-import qualified Data.Vector as V-import           Control.Arrow (second)-import           Data.Int(Int64)-import           System.Exit--import           ADP.Fusion hiding (Split)-import           Data.PrimitiveArray hiding (map)-import           BenchmarkHistory------ | All grammars require a signature.--data Split m x r = Split-  { nil :: ()  -> x-  , lef :: Int -> x -> x-  , spl :: x   -> x -> x-  , h   :: SM.Stream m x -> m r-  }---- makeAlgebraProduct ''Split--algMax :: Monad m => Split m Int Int-algMax = Split-  { nil = \ () -> 0-  , lef = \k x -> k+x-  , spl = \ x y   -> x+y-  , h   = SM.foldl' max 0-  }-{-# Inline algMax #-}--gLeft Split{..} c t' =-  let t = t'  ( lef <<< chr c % t   |||-                spl <<< t % t       |||-                nil <<< Epsilon     ... h-              )-  in Z:.t-{-# Inline gLeft #-}--mkArrs :: Int -> (VU.Vector Int, Unboxed Subword Int)-mkArrs n = ( VU.enumFromTo 1 n-           , fromAssocs (subword 0 0) (subword 0 n) (-999999) []-           )-{-# NoInline mkArrs #-}---- | WARNING: Multiple runs of @runLeft@ make use of the same @arr@. This--- is, of course, dangerous. Unless you know what you are doing.--runLeft :: (VU.Vector Int, Unboxed Subword Int) -> Int -> Int-runLeft (!i, !arr) k = seq k d where---  i   = VU.enumFromTo 1 k-  n   = VU.length i---  arr = fromAssocs (subword 0 0) (subword 0 n) (-999999) []-  (Z:.t) = runLeftForward i arr-  d = unId $ axiom t-{-# NoInline runLeft #-}--runLeftForward :: VU.Vector Int -> Unboxed Subword Int -> Z:.ITbl Id Unboxed Subword Int-runLeftForward !i !arr = mutateTablesDefault-               $ gLeft algMax-                   i-                   (ITbl 0 0 EmptyOk arr)-{-# NoInline runLeftForward #-}----main :: IO ()-main = do-  es <- sequence-    [ benchmark 10000 ("bench-0100.csv") mkArrs runLeft  100-    , benchmark    10 ("bench-1000.csv") mkArrs runLeft 1000-    , benchmark     1 ("bench-2000.csv") mkArrs runLeft 2000-    ]-  let ok = all (== ExitSuccess) es-  if ok-    then exitSuccess-    else exitFailure-
tests/properties.hs view
@@ -1,90 +1,14 @@ --- | Test all properties automatically. We keep the QC2 modules in the main--- library for now, as this allows for more efficient repl tests.+-- | Test all properties automatically.  module Main where -import Test.Framework.Providers.QuickCheck2-import Test.Framework.TH--import qualified ADP.Fusion.QuickCheck.Subword  as QSW-import qualified ADP.Fusion.QuickCheck.Set      as QS-import qualified ADP.Fusion.QuickCheck.Point    as QP-import ADP.Fusion.QuickCheck.Point---{--grep -o -e "^prop_[[:alnum:]_]*" ADP/Fusion/QuickCheck/Subword.hs | awk '{print $1"QSW", "=", "QSW."$1 }' | uniq-grep -o -e "^prop_[[:alnum:]_]*" ADP/Fusion/QuickCheck/Set.hs | awk '{print $1"QS", "=", "QS."$1 }' | uniq-grep -o -e "^prop_[[:alnum:]_]*" ADP/Fusion/QuickCheck/Point.hs | awk '{print $1"QP", "=", "QP."$1 }' | uniq--}---- subwords--prop_sv_OIQSW = QSW.prop_sv_OI-prop_sv_IOQSW = QSW.prop_sv_IO-prop_sv_OIIQSW = QSW.prop_sv_OII-prop_sv_IOIQSW = QSW.prop_sv_IOI-prop_sv_IIOQSW = QSW.prop_sv_IIO-prop_cOcQSW = QSW.prop_cOc-prop_ccOccQSW = QSW.prop_ccOcc-prop_cOcccQSW = QSW.prop_cOccc-prop_cOcIcQSW = QSW.prop_cOcIc-prop_cIcOcQSW = QSW.prop_cIcOc-prop_EpsilonQSW = QSW.prop_Epsilon---- sets--prop_b_iiQS = QS.prop_b_ii-prop_b_ii_nnQS = QS.prop_b_ii_nn-prop_b_iiiQS = QS.prop_b_iii-prop_b_iii_nnnQS = QS.prop_b_iii_nnn-prop_bii_iQS = QS.prop_bii_i-prop_bii_i_nQS = QS.prop_bii_i_n-prop_bii_eQS = QS.prop_bii_e-prop_bii_ieQS = QS.prop_bii_ie-prop_bii_ie_nQS = QS.prop_bii_ie_n-prop_bii_ieeQS = QS.prop_bii_iee-prop_bii_ieeeQS = QS.prop_bii_ieee-prop_bii_iee_nQS = QS.prop_bii_iee_n-prop_bii_ieee_nQS = QS.prop_bii_ieee_n---- points+import Test.Tasty -prop_EpsilonQP = QP.prop_Epsilon-prop_O_EpsilonQP = QP.prop_O_Epsilon-prop_ZEpsilonQP = QP.prop_ZEpsilon-prop_O_ZEpsilonQP = QP.prop_O_ZEpsilon-prop_O_ZEpsilonEpsilonQP = QP.prop_O_ZEpsilonEpsilon-prop_O_ItNCQP = QP.prop_O_ItNC-prop_O_ZItNCQP = QP.prop_O_ZItNC-prop_O_2dimIt_NC_CNQP = QP.prop_O_2dimIt_NC_CN-prop_2dimIt_NC_CNQP = QP.prop_2dimIt_NC_CN-prop_TtQP = QP.prop_Tt-prop_CCQP = QP.prop_CC-prop_ItQP = QP.prop_It-prop_O_ItQP = QP.prop_O_It-prop_ZItQP = QP.prop_ZIt-prop_O_ZItQP = QP.prop_O_ZIt-prop_ItCQP = QP.prop_ItC-prop_O_ItCQP = QP.prop_O_ItC-prop_O_ItCCQP = QP.prop_O_ItCC-prop_O_ZItCCQP = QP.prop_O_ZItCC-prop_2dimItCCQP = QP.prop_2dimItCC-prop_O_2dimItCCQP = QP.prop_O_2dimItCC-prop_ManySQP = QP.prop_ManyS-prop_SomeSQP = QP.prop_SomeS-prop_2dim_ManyS_ManySQP = QP.prop_2dim_ManyS_ManyS-prop_2dim_SomeS_SomeSQP = QP.prop_2dim_SomeS_SomeS-prop_Itbl_ManySQP = QP.prop_Itbl_ManyS-prop_Itbl_SomeSQP = QP.prop_Itbl_SomeS-prop_1dim_Itbl_ManySQP = QP.prop_1dim_Itbl_ManyS-prop_1dim_Itbl_SomeSQP = QP.prop_1dim_Itbl_SomeS-prop_2dim_Itbl_ManyS_ManySQP = QP.prop_2dim_Itbl_ManyS_ManyS-prop_2dim_Itbl_SomeS_SomeSQP = QP.prop_2dim_Itbl_SomeS_SomeS+import QuickCheck.Point   (testgroup_point)    main :: IO ()-main = $(defaultMainGenerator)+main = defaultMain testgroup_point