packages feed

ADPfusion 0.1.0.0 → 0.6.0.0

raw patch · 68 files changed

Files

− ADP/Fusion.hs 
@@ -1,12 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}---- | Pure combinators along the lines of original ADP. We simply re-export the--- monadic interface without the monadic function application combinator.--module ADP.Fusion-  ( module ADP.Fusion.Monadic-  , module ADP.Fusion.Monadic.Internal-  ) where--import ADP.Fusion.Monadic hiding ((#<<))-import ADP.Fusion.Monadic.Internal (Scalar(..))
+ 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/GAPlike.hs 
@@ -1,571 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---- | ------ HINTS for writing your own (Non-) terminals:------ - ALWAYS provide types for local functions of 'mkStream' and--- 'mkStreamInner'. Otherwise stream-fusion gets confused and doesn't optimize.--- (Observable in core by looking for 'Left', 'RIght' constructors and 'SPEC'--- constructors.--module ADP.Fusion.GAPlike where--import Control.Monad.Primitive-import Data.Primitive.Types (Prim(..))-import Data.Vector.Fusion.Stream.Size-import GHC.Prim (Constraint)-import qualified Data.Vector.Fusion.Stream.Monadic as S-import qualified Data.Vector.Unboxed as VU--import Data.PrimitiveArray (PrimArrayOps(..), MPrimArrayOps(..))-import "PrimitiveArray" Data.Array.Repa.Index-import qualified Data.PrimitiveArray as PA-import qualified Data.PrimitiveArray.Zero.Unboxed as ZU------ * The required type classes. Each class does its own thing.---- | The 'Build' class. Combines the arguments into a stack before they are--- turned into a stream.------------ To use, simply write "instance Build MyDataCtor" as we have sensible default--- instances.--class Build x where-  -- | The stack of arguments we are building.-  type BuildStack x :: *-  -- | The default is for the left-most element.-  type BuildStack x = None :. x-  -- | Given an element, create the stack.-  build :: x -> BuildStack x-  -- | Default for the left-most element.-  default build :: (BuildStack x ~ (None :. x)) => x -> BuildStack x-  build x = None :. x-  {-# INLINE build #-}---- | The stream element. Creates a type-level recursive data type containing--- the extracted arguments.--class StreamElement x where-  -- | one element of the stream, recursively defined-  data StreamElm x :: *-  -- | top-most index of the stream -- typically int-  type StreamTopIdx  x :: *-  -- | complete, recursively defined argument of the stream-  type StreamArg  x :: *-  -- | Given a stream element, we extract the top-most idx-  getTopIdx :: StreamElm x -> StreamTopIdx x-  -- | extract the recursively defined argument in a well-defined way for 'apply'-  getArg :: StreamElm x -> StreamArg x---- | Given the arguments, creates a stream of 'StreamElement's.--class (StreamConstraint x) => MkStream m x where-  type StreamConstraint x :: Constraint-  type StreamConstraint x = ()-  mkStream      :: (StreamConstraint x) => x -> (Int,Int) -> S.Stream m (StreamElm x)-  mkStreamInner :: (StreamConstraint x) => x -> (Int,Int) -> S.Stream m (StreamElm x)------ * Terminates the stack of arguments---- | Very simple data ctor--data None = None---- | For CORE-language, we have our own Arg-terminator--data ArgZ = ArgZ--instance StreamElement None where-  data StreamElm None    = SeNone !Int-  type StreamTopIdx None = Int-  type StreamArg    None = ArgZ-  getTopIdx (SeNone k) = k-  getArg _ = ArgZ-  {-# INLINE getTopIdx #-}-  {-# INLINE getArg #-}--instance (Monad m) => MkStream m None where-  mkStream None (i,j) = S.unfoldr step i where-    step k-      | k<=j = Just (SeNone i, j+1)-      | otherwise = Nothing-    {-# INLINE step #-}-  {-# INLINE mkStream #-}-  mkStreamInner = mkStream-  {-# INLINE mkStreamInner #-}------ * A single character terminal. Using unboxed vector to hold the input. Note--- that "character" means parsing a scalar, not that the 'Chr' parser only--- accepts "Char"s.--data Chr e = Chr !(VU.Vector e)--instance Build (Chr e)--instance (StreamElement x) => StreamElement (x:.Chr e) where-  data StreamElm (x:.Chr e) = SeChr !(StreamElm x) !Int !e-  type StreamTopIdx (x:.Chr e) = Int-  type StreamArg (x:.Chr e) = StreamArg x :. e-  getTopIdx (SeChr _ k _) = k-  getArg (SeChr x _ e) = getArg x :. e-  {-# INLINE getTopIdx #-}-  {-# INLINE getArg #-}---- TODO I think, we can rewrite both versions to use S.map instead of S.flatten.--instance (Monad m, MkStream m x, StreamElement x, StreamTopIdx x ~ Int, VU.Unbox e) => MkStream m (x:.Chr e) where-  mkStream (x:.Chr es) (i,j) = S.flatten mk step Unknown $ mkStream x (i,j-1) where-    mk :: StreamElm x -> m (StreamElm x, Int)-    mk x = return (x, getTopIdx x)-    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.Chr e)))-    step (x,k)-      | k+1 == j = return $ S.Yield (SeChr x (k+1) (VU.unsafeIndex es k)) (x,j+1)-      | otherwise = return S.Done-    {-# INLINE mk #-}-    {-# INLINE step #-}-  {-# INLINE mkStream #-}-  mkStreamInner (x:.Chr es) (i,j) = S.flatten mk step Unknown $ mkStreamInner x (i,j-1) where-    mk :: StreamElm x -> m (StreamElm x, Int)-    mk x = return (x, getTopIdx x)-    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.Chr e)))-    step (x,k)-      | k < j     = return $ S.Yield (SeChr x (k+1) (VU.unsafeIndex es k)) (x,j+1)-      | otherwise = return $ S.Done-    {-# INLINE mk #-}-    {-# INLINE step #-}-  {-# INLINE mkStreamInner #-}------ * Empty and non-empty tables.------ TODO This will probably become more funny with triangular tables ...---- | empty subwords allowed--data E---- | only non-empty subwords--data N--class TransToN t where-  type TransTo t :: *-  transToN :: t -> TransTo t---- | Used by the instances below for index calculations.--class TblType tt where-  initDeltaIdx :: tt -> Int--instance TblType E where-  initDeltaIdx _ = 0-  {-# INLINE initDeltaIdx #-}--instance TblType N where-  initDeltaIdx _ = 1-  {-# INLINE initDeltaIdx #-}---- ** Immutable tables--data Tbl c es = Tbl !es--instance TransToN (Tbl c es) where-  type TransTo (Tbl c es) = Tbl N es-  transToN (Tbl es) = Tbl es-  {-# INLINE transToN #-}--instance Build (Tbl c es)--instance (StreamElement x, PrimArrayOps arr DIM2 e, TblType c) => StreamElement (x:.Tbl c (arr DIM2 e)) where-  data StreamElm    (x:.Tbl c (arr DIM2 e)) = SeTbl !(StreamElm x) !Int !e-  type StreamTopIdx (x:.Tbl c (arr DIM2 e)) = Int-  type StreamArg    (x:.Tbl c (arr DIM2 e)) = StreamArg x :. e-  getTopIdx (SeTbl _ k _) = k-  getArg    (SeTbl x _ e) = getArg x :. e-  {-# INLINE getTopIdx #-}-  {-# INLINE getArg #-}--instance (Monad m, MkStream m x, StreamElement x, StreamTopIdx x ~ Int, PrimArrayOps arr DIM2 e, TblType c) => MkStream m (x:.Tbl c (arr DIM2 e)) where-  -- | The outer stream function assumes that mkStreamInner generates a valid-  -- stream that does not need to be checked. (This should always be true!).-  -- The table entry to read is [k,j], as we supposedly are generating the-  -- outermost stream. Even more "outermost" streams will have changed 'j'-  -- beforehand. 'mkStream' should only ever be used if 'j' can be fixed.-  mkStream (x:.Tbl t) (i,j) = S.map step $ mkStreamInner x (i,j - initDeltaIdx (undefined :: c)) where-    step :: StreamElm x -> StreamElm (x:.Tbl c (arr DIM2 e))-    step x = let k = getTopIdx x in SeTbl x j (t PA.! (Z:.k:.j))-    {-# INLINE step #-}-  -- | The inner stream will, in each step, check if the current subword [k,l]-  -- (forall l>=k) is valid and terminate the stream once l>j.-  mkStreamInner (x:.Tbl t) (i,j) = S.flatten mk step Unknown $ mkStreamInner x (i,j) where-    mk :: StreamElm x -> m (StreamElm x, Int)-    mk x = return (x, getTopIdx x + initDeltaIdx (undefined :: c))-    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.Tbl c (arr DIM2 e))))-    step (x,l)-      | l<=j      = return $ S.Yield (SeTbl x l (t PA.! (Z:.k:.l))) (x,l+1)-      | otherwise = return $ S.Done-      where k = getTopIdx x-    {-# INLINE mk #-}-    {-# INLINE step #-}-  {-# INLINE mkStream #-}-  {-# INLINE mkStreamInner #-}---- ** Mutable tables in some monad.--data MTbl c es = MTbl !es--instance TransToN (MTbl c es) where-  type TransTo (MTbl c es) = MTbl N es-  transToN (MTbl es) = MTbl es-  {-# INLINE transToN #-}--mtblN :: es -> MTbl N es-mtblN es = MTbl es-{-# INLINE mtblN #-}--mtblE :: es -> MTbl E es-mtblE es = MTbl es-{-# INLINE mtblE #-}--instance Build (MTbl c es)--instance (StreamElement x, MPrimArrayOps marr DIM2 e, TblType c) => StreamElement (x:.MTbl c (marr s DIM2 e)) where-  data StreamElm    (x:.MTbl c (marr s DIM2 e)) = SeMTbl !(StreamElm x) !Int !e-  type StreamTopIdx (x:.MTbl c (marr s DIM2 e)) = Int-  type StreamArg    (x:.MTbl c (marr s DIM2 e)) = StreamArg x :. e-  getTopIdx (SeMTbl _ k _) = k-  getArg    (SeMTbl x _ e) = getArg x :. e-  {-# INLINE getTopIdx #-}-  {-# INLINE getArg #-}--instance-  ( Monad m-  , PrimMonad m-  , MkStream m x-  , StreamElement x-  , StreamTopIdx x ~ Int-  , MPrimArrayOps marr DIM2 e-  , TblType c-  , s ~ PrimState m-  ) => MkStream m (x:.MTbl c (marr s DIM2 e)) where-  -- | The outer stream function assumes that mkStreamInner generates a valid-  -- stream that does not need to be checked. (This should always be true!).-  -- The table entry to read is [k,j], as we supposedly are generating the-  -- outermost stream. Even more "outermost" streams will have changed 'j'-  -- beforehand. 'mkStream' should only ever be used if 'j' can be fixed.-  mkStream (x:.MTbl t) (i,j) = S.mapM step $ mkStreamInner x (i,j - initDeltaIdx (undefined :: c)) where-    step :: StreamElm x -> m (StreamElm (x:.MTbl c (marr s DIM2 e)))-    step x = let k = getTopIdx x in PA.readM t (Z:.k:.j) >>= \e -> return $ SeMTbl x j e-    {-# INLINE step #-}-  -- | The inner stream will, in each step, check if the current subword [k,l]-  -- (forall l>=k) is valid and terminate the stream once l>j.-  mkStreamInner (x:.MTbl t) (i,j) = S.flatten mk step Unknown $ mkStreamInner x (i,j) where-    mk :: StreamElm x -> m (StreamElm x, Int)-    mk x = return (x, getTopIdx x + initDeltaIdx (undefined :: c))-    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.MTbl c (marr s DIM2 e))))-    step (x,l)-      | l<=j      = readM t (Z:.k:.l) >>= \e -> return $ S.Yield (SeMTbl x l e) (x,l+1)-      | otherwise = return $ S.Done-      where k = getTopIdx x-    {-# INLINE mk #-}-    {-# INLINE step #-}-  {-# INLINE mkStream #-}-  {-# INLINE mkStreamInner #-}---- ** Some convenience functions.--tNtoE :: Tbl N x -> Tbl E x-tNtoE (Tbl x) = Tbl x-{-# INLINE tNtoE #-}--tEtoN :: Tbl E x -> Tbl N x-tEtoN (Tbl x) = Tbl x-{-# INLINE tEtoN #-}------ * Parses an empty subword.---- | The empty subword. Can not be part of a more complex RHS for obvious--- reasons: "S -> E S" doesn't make sense. Used in some grammars as the base--- case.--data Empty = Empty--instance Build Empty where-  type BuildStack Empty = Empty-  build c = c-  {-# INLINE build #-}--instance StreamElement (Empty) where-  data StreamElm    Empty = SeEmpty !Int-  type StreamTopIdx Empty = Int-  type StreamArg    Empty = ArgZ :. ()-  getTopIdx (SeEmpty k) = k-  getArg    (SeEmpty _) = ArgZ :. ()-  {-# INLINE getTopIdx #-}-  {-# INLINE getArg #-}--instance (Monad m) => MkStream m (Empty) where-  mkStream Empty (i,j) = S.unfoldr step i where-    step k-      | k==j      = Just (SeEmpty k, j+1)-      | otherwise = Nothing-    {-# INLINE step #-}-  mkStreamInner = error "undefined for Empty"-  {-# INLINE mkStream #-}-  {-# INLINE mkStreamInner #-}------ * Parsing subwords with restriced size. Both min- and max-size are given--- when binding input.--data RestrictedRegion e = RRegion !Int !Int !(VU.Vector e)--instance Build (RestrictedRegion e)--instance (StreamElement x) => StreamElement (x:.RestrictedRegion e) where-  data StreamElm (x:.RestrictedRegion e) = SeResRegion !(StreamElm x) !Int (VU.Vector e)-  type StreamTopIdx (x:.RestrictedRegion e) = Int-  type StreamArg (x:.RestrictedRegion e) = StreamArg x :. (VU.Vector e)-  getTopIdx (SeResRegion _ k _) = k-  getArg (SeResRegion x _ e) = getArg x :. e-  {-# INLINE getTopIdx #-}-  {-# INLINE getArg #-}--instance (Monad m, MkStream m x, StreamElement x, StreamTopIdx x ~ Int, VU.Unbox e) => MkStream m (x:.RestrictedRegion e) where-  mkStream (x:.RRegion minR maxR xs) (i,j) = S.flatten mk step Unknown $ mkStream x (i,j-1) where-    mk :: StreamElm x -> m (StreamElm x, Int)-    mk x = return (x, getTopIdx x)-    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.RestrictedRegion e)))-    step (x,k)-      | k+minR <= j && k+maxR >= j = return $ S.Yield (SeResRegion x k (VU.unsafeSlice k (max maxR (j-k)) xs)) (x,j+1)-      | otherwise = return S.Done-    {-# INLINE mk #-}-    {-# INLINE step #-}-  {-# INLINE mkStream #-}-  mkStreamInner (x:.RRegion minR maxR xs) (i,j) = S.flatten mk step Unknown $ mkStream x (i,j) where-    mk :: StreamElm x -> m (StreamElm x, Int)-    mk x = return (x, getTopIdx x + minR)-    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.RestrictedRegion e)))-    step (x,l)-      | l<=j && (l-k)<=maxR = return $ S.Yield (SeResRegion x l (VU.unsafeSlice k (l-k) xs)) (x,j+1)-      | otherwise           = return S.Done-      where k = getTopIdx x-    {-# INLINE mk #-}-    {-# INLINE step #-}-  {-# INLINE mkStreamInner #-}------ * Backtracking tables.------ Since we want the slow forward phase to be fast, in the backtracking phase,--- we need to keep track of additional things. The backtracking table 'BTtbl'--- requires the table and an additional backtracking function. You should use--- the same composed function as for the forward pahse creating the bound table--- in the first place.---- | The backtracking table 'BTtbl" captures a DP table and the function used--- to fill it.--data BTtbl c t g = BTtbl t g--instance TransToN (BTtbl c t g) where-  type TransTo (BTtbl c t g) = BTtbl N t g-  transToN (BTtbl t g) = BTtbl t g-  {-# INLINE transToN #-}--bttblN :: t -> g -> BTtbl N t g-bttblN t g = BTtbl t g-{-# INLINE bttblN #-}--bttblE :: t -> g -> BTtbl E t g-bttblE t g = BTtbl t g-{-# INLINE bttblE #-}--instance Build (BTtbl c t g)---- | The backtracking function, given our index pair, return a stream of--- backtracked results. (Return as in we are in a monad).------ TODO Should this be "(Int,Int) -> m (SM.Stream Id b)" or are there cases--- where we'd like to have monadic effects on the "b"s?--type BTfun m b = (Int,Int) -> m (S.Stream m b)--instance (Monad m, StreamElement x, TblType c) => StreamElement (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) where-  data StreamElm    (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) = SeBTtbl !(StreamElm x) !Int !e (m (S.Stream m b))-  type StreamTopIdx (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) = Int-  type StreamArg    (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) = StreamArg x :. (e, m (S.Stream m b))-  getTopIdx (SeBTtbl _ k _ _) = k-  getArg    (SeBTtbl x _ e g) = getArg x :. (e,g)-  {-# INLINE getTopIdx #-}-  {-# INLINE getArg #-}--instance-  ( Monad m-  , MkStream m x-  , StreamElement x-  , VU.Unbox e-  , StreamTopIdx x ~ Int-  , TblType c-  ) => MkStream m (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) where-  mkStream (x:.BTtbl t g) (i,j) = S.map step $ mkStreamInner x (i,j - initDeltaIdx (undefined :: c)) where-    step :: StreamElm x -> StreamElm (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b))-    step x = let k = getTopIdx x in SeBTtbl x j (t PA.! (Z:.k:.j)) (g (k,j))-    {-# INLINE step #-}-  mkStreamInner (x:.BTtbl t g) (i,j) = S.flatten mk step Unknown $ mkStreamInner x (i,j) where-    mk :: StreamElm x -> m (StreamElm x, Int)-    mk x = return (x, getTopIdx x + initDeltaIdx (undefined :: c))-    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b))))-    step (x,l)-      | l<=j      = return $ S.Yield (SeBTtbl x l (t PA.! (Z:.k:.l)) (g (k,l))) (x,l+1)-      | otherwise = return $ S.Done-      where k = getTopIdx x-    {-# INLINE mk #-}-    {-# INLINE step #-}-  {-# INLINE mkStream #-}-  {-# INLINE mkStreamInner #-}------ * Build complex stacks--instance Build x => Build (x,y) where-  type BuildStack (x,y) = BuildStack x :. y-  build (x,y) = build x :. y-  {-# INLINE build #-}------ * combinators--infixl 8 <<<-(<<<) f t ij = S.map (\s -> apply f $ getArg s) $ mkStream (build t) ij-{-# INLINE (<<<) #-}--infixl 7 |||-(|||) xs ys ij = xs ij S.++ ys ij-{-# INLINE (|||) #-}--infixl 6 ...-(...) s h ij = h $ s ij-{-# INLINE (...) #-}--infixl 6 ..@-(..@) s h ij = h ij $ s ij-{-# INLINE (..@) #-}--infixl 9 ~~-(~~) = (,)-{-# INLINE (~~) #-}--infixl 9 %-(%) = (,)-{-# INLINE (%) #-}------ * Apply function 'f' in '(<<<)'--class Apply x where-  type Fun x :: *-  apply :: Fun x -> x--instance Apply (ArgZ:.a -> res) where-  type Fun (ArgZ:.a -> res) = a -> res-  apply fun (ArgZ:.a) = fun a-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b -> res) where-  type Fun (ArgZ:.a:.b -> res) = a->b -> res-  apply fun (ArgZ:.a:.b) = fun a b-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c -> res) where-  type Fun (ArgZ:.a:.b:.c -> res) = a->b->c -> res-  apply fun (ArgZ:.a:.b:.c) = fun a b c-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d -> res) where-  type Fun (ArgZ:.a:.b:.c:.d -> res) = a->b->c->d -> res-  apply fun (ArgZ:.a:.b:.c:.d) = fun a b c d-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d:.e -> res) where-  type Fun (ArgZ:.a:.b:.c:.d:.e -> res) = a->b->c->d->e -> res-  apply fun (ArgZ:.a:.b:.c:.d:.e) = fun a b c d e-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d:.e:.f -> res) where-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f -> res) = a->b->c->d->e->f -> res-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f) = fun a b c d e f-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g -> res) where-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g -> res) = a->b->c->d->e->f->g -> res-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g) = fun a b c d e f g-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h -> res) where-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h -> res) = a->b->c->d->e->f->g->h -> res-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h) = fun a b c d e f g h-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) where-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) = a->b->c->d->e->f->g->h->i -> res-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i) = fun a b c d e f g h i-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) where-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) = a->b->c->d->e->f->g->h->i->j -> res-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j) = fun a b c d e f g h i j-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) where-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) = a->b->c->d->e->f->g->h->i->j->k -> res-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k) = fun a b c d e f g h i j k-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) where-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) = a->b->c->d->e->f->g->h->i->j->k->l -> res-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l) = fun a b c d e f g h i j k l-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) where-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m -> res-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m) = fun a b c d e f g h i j k l m-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) where-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n -> res-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n) = fun a b c d e f g h i j k l m n-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) where-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n->o -> res-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o) = fun a b c d e f g h i j k l m n o-  {-# INLINE apply #-}-
− ADP/Fusion/GAPlike/Criterion.hs 
@@ -1,179 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PackageImports #-}--module ADP.Fusion.GAPlike.Criterion where--import Control.Monad.ST-import Criterion.Main-import Data.Char-import qualified Data.Vector.Fusion.Stream.Monadic as S-import qualified Data.Vector.Fusion.Stream as SP--import Data.PrimitiveArray-import Data.PrimitiveArray.Unboxed.VectorZero as UVZ-import Data.PrimitiveArray.Unboxed.Zero as UZ-import "PrimitiveArray" Data.Array.Repa.Index-import "PrimitiveArray" Data.Array.Repa.Shape--import ADP.Fusion.GAPlike-import ADP.Fusion.GAPlike.DevelCommon----criterionMain = defaultMain-  [ bgroup "testTTT3"-    [ bench "  10" (whnf (testTTT 0)   10)-    , bench " 100" (whnf (testTTT 0)  100)-    , bench "1000" (whnf (testTTT 0) 1000)-    ]-  , bgroup "testTTTT4"-    [ bench "  10" (whnf (testTTTT 0)   10)-    , bench " 100" (whnf (testTTTT 0)  100)-    , bench "1000" (whnf (testTTTT 0) 1000)-    ]-  , bgroup "testTTTT4ga"-    [ bench "  10" (whnf (testTTTTga 0)   10)-    , bench " 100" (whnf (testTTTTga 0)  100)-    , bench "1000" (whnf (testTTTTga 0) 1000)-    ]-  , bgroup "testTTTT4gaPA"-    [ bench "  10" (whnf (testTTTTgaPA 0)   10)-    , bench " 100" (whnf (testTTTTgaPA 0)  100)-    , bench "1000" (whnf (testTTTTgaPA 0) 1000)-    ]-  , bgroup "testTTTT4gaImmu"-    [ bench "  10" (whnf (testTTTTgaImmu 0)   10)-    , bench " 100" (whnf (testTTTTgaImmu 0)  100)-    , bench "1000" (whnf (testTTTTgaImmu 0) 1000)-    ]-  , bgroup "testTTTT4gaImmuPA"-    [ bench "  10" (whnf (testTTTTgaImmuPA 0)   10)-    , bench " 100" (whnf (testTTTTgaImmuPA 0)  100)-    , bench "1000" (whnf (testTTTTgaImmuPA 0) 1000)-    ]-  ]------ * Criterion tests--testC :: Int -> Int -> Int-testC i j = runST doST where-  doST :: ST s Int-  doST = do-    let c = Chr dvu-    (gord1 <<< c ... ghsum) (i,j)-{-# NOINLINE testC #-}--gTestC (ord1,hsum) c =-  (ord1 <<< c ... hsum)--aTestC = (ord1,hsum) where-  ord1 = gord1-  hsum = ghsum--testCC :: Int -> Int -> Int-testCC i j = runST doST where-  doST :: ST s Int-  doST = do-    let c = Chr dvu-    let d = Chr dvu-    (gord2 <<< c % d ... ghsum) (i,j)-{-# NOINLINE testCC #-}--type TBL s = Tbl N (UVZ.MArr0 s DIM2 Int)--testT :: Int -> Int -> Int-testT i j = runST doST where-  doST :: ST s Int-  doST = do-    tbl :: TBL s <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) 1 []-    (id <<< tbl ... ghsum) (i,j)-{-# NOINLINE testT #-}--testTT :: Int -> Int -> Int-testTT i j = runST doST where-  doST :: ST s Int-  doST = do-    tbl :: TBL s <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) 1 []-    (gplus2 <<< tbl % tbl ... ghsum) (i,j)-  {-# INLINE doST #-}-{-# NOINLINE testTT #-}--testTTT :: Int -> Int -> Int-testTTT i j = runST doST where-  doST :: ST s Int-  doST = do-    tbl :: TBL s <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) 1 []-    (gplus3 <<< tbl % tbl % tbl ... ghsum) (i,j)-{-# NOINLINE testTTT #-}--testTTTT :: Int -> Int -> Int-testTTTT i j = runST doST where-  doST :: ST s Int-  doST = do-    tbl :: TBL s <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) (1::Int) []-    (gplus4 <<< tbl % tbl % tbl % tbl ... ghsum) (i,j)-  {-# INLINE doST #-}-{-# NOINLINE testTTTT #-}--testTTTTga :: Int -> Int -> Int-testTTTTga i j = runST doST where-  doST :: ST s Int-  doST = do-    tbl :: TBL s <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) (1::Int) []-    gTTTga aTTTga tbl (i,j)-  {-# INLINE doST #-}-{-# NOINLINE testTTTTga #-}--testTTTTgaPA :: Int -> Int -> Int-testTTTTgaPA i j = runST doST where-  doST :: ST s Int-  doST = do-    tbl :: Tbl N (UZ.MArr0 s DIM2 Int) <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) (1::Int) []-    gTTTga aTTTga tbl (i,j)-  {-# INLINE doST #-}-{-# NOINLINE testTTTTgaPA #-}--testTTTTgaImmu :: Int -> Int -> Int-testTTTTgaImmu i j =-    let tbl = (Tbl $ fromAssocs (Z:.0:.0) (Z:.j:.j) 1 []) :: Tbl N (UVZ.Arr0 DIM2 Int) -    in tbl `seq` gTTTga aTTTgaImmu tbl (i,j)-{-# NOINLINE testTTTTgaImmu #-}--testTTTTgaImmuPA :: Int -> Int -> Int-testTTTTgaImmuPA i j =-    let tbl = (Tbl $ fromAssocs (Z:.0:.0) (Z:.j:.j) 1 []) :: Tbl N (UZ.Arr0 DIM2 Int) -    in tbl `seq` gTTTga aTTTgaImmu tbl (i,j)-{-# NOINLINE testTTTTgaImmuPA #-}--gTTTga (plus4, hsum) tbl =-  (plus4 <<< tbl % tbl % tbl % tbl ... hsum)-{-# INLINE gTTTga #-}--aTTTga = (plus4, hsum) where-  plus4 = gplus4-  hsum = ghsum--aTTTgaImmu = (plus4, hsum) where-  plus4 = gplus4-  hsum = gihsum-{-# INLINE aTTTgaImmu #-}--gord1 a = ord a--gord2 a b = ord a + ord b--gord3 a b c = ord a + ord b + ord c--gplus2 a b = a+b--gplus3 a b c = a+b+c--gplus4 a b c d = a+b+c+d--ghsum :: S.Stream (ST s) Int -> ST s Int-ghsum = S.foldl' (+) 0--gihsum :: SP.Stream Int -> Int-gihsum = SP.foldl' (+) 0
− ADP/Fusion/GAPlike/DevelCommon.hs 
@@ -1,22 +0,0 @@-{-# LANGUAGE PackageImports #-}--module ADP.Fusion.GAPlike.DevelCommon where--import qualified Data.PrimitiveArray as PA-import qualified Data.Vector.Unboxed as VU--import Data.PrimitiveArray.Unboxed.VectorZero as UVZ-import Data.PrimitiveArray.Unboxed.Zero as UZ-import "PrimitiveArray" Data.Array.Repa.Index-import "PrimitiveArray" Data.Array.Repa.Shape----dvu = VU.fromList $ concat $ replicate 10 ['a'..'z']-{-# NOINLINE dvu #-}--type PAT = UVZ.Arr0 DIM2 Int-pat :: PAT-pat = PA.fromAssocs (Z:.0:.0) (Z:.1000:.1000) 0 [(Z:.i:.j,j-i) | i <-[0..1000], j<-[i..1000] ]-{-# NOINLINE pat #-}-
− ADP/Fusion/GAPlike/QuickCheck.hs 
@@ -1,57 +0,0 @@-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE TemplateHaskell #-}--module ADP.Fusion.GAPlike.QuickCheck where--import Test.QuickCheck-import Test.QuickCheck.All-import qualified Data.Vector.Fusion.Stream as SP-import qualified Data.Vector.Unboxed as VU--import "PrimitiveArray" Data.Array.Repa.Index-import "PrimitiveArray" Data.Array.Repa.Shape-import Data.PrimitiveArray--import ADP.Fusion.QuickCheck.Arbitrary-import ADP.Fusion.GAPlike.DevelCommon-import ADP.Fusion.GAPlike------ * QuickCheck--checkC_fusion (i,j) = id <<< Chr dvu ... SP.toList $ (i,j)-checkC_list   (i,j) = [dvu VU.! i | i+1==j]-prop_checkC = checkC_fusion === checkC_list--checkCC_fusion (i,j) = (,) <<< Chr dvu % Chr dvu ... SP.toList $ (i,j)-checkCC_list   (i,j) = [ (dvu VU.! i, dvu VU.! (i+1)) | i+2==j ]-prop_checkCC = checkCC_fusion === checkCC_list--checkP_fusion (i,j) = id <<< (Tbl pat :: Tbl E PAT)  ... SP.toList $ (i,j)-checkP_list   (i,j) = [ (pat!(Z:.i:.j)) | i<=j ]-prop_checkP = checkP_fusion === checkP_list--checkPP_fusion (i,j) = let tbl = Tbl pat :: Tbl E PAT-                       in  (,) <<< tbl % tbl ... SP.toList $ (i,j)-checkPP_list   (i,j) = [ (pat!(Z:.i:.k), pat!(Z:.k:.j)) | k<-[i..j] ]-prop_checkPP = checkPP_fusion === checkPP_list--checkCPC_fusion (i,j) = let tbl = Tbl pat :: Tbl E PAT-                        in  (,,) <<< Chr dvu % tbl % Chr dvu ... SP.toList $ (i,j)-checkCPC_list (i,j) = [ (dvu VU.! i, pat!(Z:.i+1:.j-1), dvu VU.! (j-1)) | i+2<=j ]-prop_checkCPC = checkCPC_fusion === checkCPC_list--checkNN_fusion (i,j) = let tbl = Tbl pat :: Tbl N PAT-                       in  (,) <<< tbl % tbl ... SP.toList $ (i,j)-checkNN_list   (i,j) = [ (pat!(Z:.i:.k), pat!(Z:.k:.j)) | k<-[i+1..j-1] ]-prop_checkNN = checkNN_fusion === checkNN_list----options = stdArgs {maxSuccess = 1000}--customCheck = quickCheckWithResult options--allProps = $forAllProperties customCheck-
− ADP/Fusion/Monadic.hs 
@@ -1,197 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE PackageImports #-}---- | Monadic combinators. Code like------ @f <<< xs ~~~ ys ... Stream.sum@------ will generate efficient GHC core for a dynamic program comparable to------ @sum [ f (xs!(i,k)) (ys!(k,j)) | k<-[i..j]]@.--module ADP.Fusion.Monadic where--import "PrimitiveArray" Data.Array.Repa.Index-import qualified Data.Vector.Fusion.Stream.Monadic as S--import ADP.Fusion.Monadic.Internal------ * Apply functions to arguments.---- | A monadic version of the function application combinator. Applies 'f'--- which has a monadic effect.--infixl 8 #<<-(#<<) f t ij = S.mapM (\(_,_,c) -> apply f c) $ streamGen t ij-{-# INLINE (#<<) #-}---- | Pure function application combinator. Applies 'f' which is pure. The--- arguments to 'f', meaning 't' can be monadic, however!--infixl 8 <<<-(<<<) f t ij = S.map (\(_,_,c) -> apply f c) $ streamGen t ij-{-# INLINE (<<<) #-}------ * Combine multiple right-hand sides of a non-terminal in a context-free--- grammar.---- | If both, 'xs' and 'ys' are streams of candidate answers, they can be--- combined here. The answer (or sort) type of 'xs' and 'ys' has to be the--- same. Works like @(++)@ for lists.--infixl 7 |||-(|||) xs ys ij = xs ij S.++ ys ij-{-# INLINE (|||) #-}------ * Reduce streams to single answers.------ NOTE "Single answers" can be of a vector-type! One is not constrained to--- scalar results. This allows for many exiting algorithms.---- | Reduces a streams of answers to the type of stored answers. The resulting--- type could be scalar, which it will be for highest-performance algorithms,--- or it could be a subset of answers stored in some kind of data structure.--infixl 6 ...-(...) stream h ij = h $ stream ij-{-# INLINE (...) #-}---- | Specialized version of choice function application, with a choice function--- that needs to know the subword index it is working on.--infixl 6 ..@-(..@) stream h ij = h ij $ stream ij-{-# INLINE (..@) #-}------ * Combinators to chain function arguments.------ ** General combinator creation.---- | General function to create combinators. The left-hand side @xs@ in @xs--- `comb` ys@ will have a size between @minL@ and @maxL@, while @ys@ and--- /everything to its right will be guaranteed @minR@ size.--makeLeft_MinRight (minL,maxL) minR = comb where-  {-# INLINE comb #-}-  comb xs ys = Box mk step xs ys-  {-# INLINE mk #-}-  mk (z:.k:.j,a,b) = return (z:.k:.k+minL:.j,a,b)-  {-# INLINE step #-}-  step (z:.k:.l:.j,a,b)-    | l<=j-minR && l<=k+maxL = return $ S.Yield (z:.k:.l:.j,a,b) (z:.k:.l+1:.j,a,b)-    | otherwise              = return $ S.Done-{-# INLINE makeLeft_MinRight #-}---- | Create combinators which are to be used in the right-most position of a--- chain. 1st, they make sure that the second to last region has a size of at--- least 'minL'. 2nd, they constrain the last argument to a size between 'minR'--- and 'maxR'.--makeMinLeft_Right minL (minR,maxR) = comb where-  {-# INLINE comb #-}-  comb xs ys = Box mk step xs ys-  {-# INLINE mk #-}-  mk (z:.k:.j,a,b) = let l = max (k+minL) (j-maxR) in return (z:.k:.l:.j,a,b)-  {-# INLINE step #-}-  step (z:.k:.l:.j,a,b)-    | l<=j-minR = return $ S.Yield (z:.k:.l:.j,a,b) (z:.k:.l+1:.j,a,b)-    | otherwise = return $ S.Done-{-# INLINE makeMinLeft_Right #-}------ ** A number of often-used combinators.--infixl 9 -~+, +~-, -~~, ~~---(-~+) = makeLeft_MinRight (1,1) 1-{-# INLINE (-~+) #-}--(+~-) = makeMinLeft_Right 1 (1,1)-{-# INLINE (+~-) #-}--(-~~) = makeLeft_MinRight (1,1) 0-{-# INLINE (-~~) #-}--(~~-) = makeMinLeft_Right 0 (1,1)-{-# INLINE (~~-) #-}--(+~--) = makeMinLeft_Right 1 (2,2)-{-# INLINE (+~--) #-}--infixl 9 ~~~-(~~~) xs ys = Box mk step xs ys where-  {-# INLINE mk #-}-  mk (z:.k:.j,vidx,vstack) = return $ (z:.k:.k:.j,vidx,vstack)-  {-# INLINE step #-}-  step (z:.k:.l:.j,vidx,vstack)-    | l<=j      = return $ S.Yield (z:.k:.l:.j,vidx,vstack) (z:.k:.l+1:.j,vidx,vstack)-    | otherwise = return $ S.Done-{-# INLINE (~~~) #-}---- | @xs +~+ ys@ with @xs@ and @ys@ non-empty. The non-emptyness constraint on--- @ys@ works only for two arguments. With three or more arguments, a--- left-leaning combinator to the right of @ys@ is required to establish--- non-emptyness.--infixl 9 +~+-(+~+) xs ys = Box mk step xs ys where-  {-# INLINE mk #-}-  mk (z:.k:.j,vidx,vstack) = return $ (z:.k:.k+1:.j,vidx,vstack)-  {-# INLINE step #-}-  step (z:.k:.l:.j,vidx,vstack)-    | l+1<=j    = return $ S.Yield (z:.k:.l:.j,vidx,vstack) (z:.k:.l+1:.j,vidx,vstack)-    | otherwise = return $ S.Done-{-# INLINE (+~+) #-}---- | @ls ~~~ xs !-~+ ys@ with xs having a size of one and @ls@ further to the--- left having a size of one or more.--infixl 9 !-~+-(!-~+) xs ys = Box mk step xs ys where-  {-# INLINE mk #-}-  mk (z:.k:.j,vidx,vstack)-    | k>0       = return $ (z:.k:.k+1:.j,vidx,vstack)-    | otherwise = return $ (z:.k:.j+1:.j,vidx,vstack)-  {-# INLINE step #-}-  step (z:.k:.l:.j,vidx,vstack)-    | l+1<=j    = return $ S.Yield (z:.k:.l:.j,vidx,vstack) (z:.k:.j+1:.j,vidx,vstack)-    | otherwise = return $ S.Done-{-# INLINE (!-~+) #-}---- | @xs +~-! ys ~~~ rs@ with @ys@ having a size of one and @rs@ further to the--- right having a size of one.--infixl 9 +~-!-(+~-!) xs ys = Box mk step xs ys where-  {-# INLINE mk #-}-  mk (z:.k:.j,vidx,vstack) = return $ (z:.k:.j-2:.j,vidx,vstack)-  {-# INLINE step #-}-  step (z:.k:.l:.j,vidx,vstack)-    | l+2==j    = return $ S.Yield (z:.k:.l:.j,vidx,vstack) (z:.k:.j+1:.j,vidx,vstack)-    | otherwise = return $ S.Done-{-# INLINE (+~-!) #-}---- | @xs -~- ys@ produces an answer only if both @xs@ and @ys@ have size one.--- The total size here then is two.--infixl 9 -~--(-~-) xs ys = Box mk step xs ys where-  {-# INLINE mk #-}-  mk (z:.k:.j,vidx,vstack) = return $ (z:.k:.k+1:.j,vidx,vstack)-  {-# INLINE step #-}-  step (z:.k:.l:.j,vidx,vstack)-    | k+1==l && l+1==j = return $ S.Yield (z:.k:.l:.j,vidx,vstack) (z:.k:.l+1:.j,vidx,vstack)-    | otherwise        = return $ S.Done-{-# INLINE (-~-) #-}-
− ADP/Fusion/Monadic/Internal.hs 
@@ -1,492 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--{-# OPTIONS_HADDOCK hide #-}---- | The internal working of ADPfusion. All combinator applications are turned--- into efficient code during compile time.------ If you have a data structure to be used as an argument in a combinator--- chain, derive an instance 'ExtractValue', 'StreamGen', and 'PreStreamGen'.------ NOTE: If this doesn't happen, it is a possible bug, or GHC changed its--- optimizer (like with GHC 7.2 -> 7.4).------ TODO If possible, instance generation will be using the Generics system in--- the future.--module ADP.Fusion.Monadic.Internal where--import Control.Monad.Primitive-import Control.Monad.ST-import Data.List (intersperse)-import Data.Primitive.Types-import Data.Vector.Fusion.Stream.Size-import "PrimitiveArray" Data.Array.Repa.Index-import "PrimitiveArray" Data.Array.Repa.Shape-import qualified Data.Vector.Fusion.Stream.Monadic as S-import qualified Data.Vector.Unboxed as VU-import Text.Printf--import qualified Data.PrimitiveArray as PA-import qualified Data.PrimitiveArray.Zero.Unboxed as ZU-import qualified Data.PrimitiveArray.Zero as Z------ * StreamGen---- | Generate stream from either one (DIM2 -> m cnt) or some combination of--- terminals derived from uses of nextTo.--class Monad m => StreamGen m t r | t -> r where-  streamGen :: t -> DIM2 -> S.Stream m r--#define mkStreamGen(cnt) \-instance (Monad m, ExtractValue m (cnt), Asor (cnt) ~ k, Elem (cnt) ~ elm) \-=> StreamGen m (cnt) (DIM2,Z:.k,Z:.elm) where { \-  {-# INLINE streamGen #-} \-;  streamGen x ij = extractStreamLast x $ preStreamGen x ij }--mkStreamGen(DIM2 -> Scalar elm)-mkStreamGen(DIM2 -> ScalarM elm)-mkStreamGen(DIM2 -> Vect elm)-mkStreamGen(DIM2 -> VectM elm)-mkStreamGen(ZU.MArr0 s sh elm)-mkStreamGen(ZU.Arr0 sh elm)--mkStreamGen(Z.MArr0 s sh (VU.Vector elm))-mkStreamGen(Z.Arr0 sh (VU.Vector elm))---- | two or more elements combined by NextTo (~~~), "xs" as anything, "ys" is--- monadic.--instance-  ( Monad m-  , ExtractValue m ys, Asor ys ~ cY, Elem ys ~ eY-  , PreStreamGen m (Box mk step xs ys) (idx:.Int,adx:.cX,arg:.eX)-  , Idx2 _idx ~ idx-  ) => StreamGen m (Box mk step xs ys) (idx:.Int,adx:.cX:.cY,arg:.eX:.eY) where-  streamGen (Box mk step xs ys) ij-    = extractStreamLast ys-    $ preStreamGen (Box mk step xs ys) ij-  {-# INLINE streamGen #-}------ * PreStreamGen---- | Required by most 'StreamGen' instances just before 'extractStreamLast' is--- called.--class Monad m => PreStreamGen m s q | s -> q where-  preStreamGen-    :: s      -- ^ the composite type of the arguments-    -> DIM2   -- ^ the original index @(Z:.i:.j)@-    -> S.Stream m q -- ^ the stream we get out of it---- | Creates the single step on the left which does nothing more then set the--- outermost indices to (i,j). This does not use the alpha/omega's--singlePreStreamGen ij = S.unfoldr step ij where-  {-# INLINE step #-}-  step (Z:.i:.j)-    | i<=j      = Just ((Z:.i:.j ,Z,Z), Z:.j+1:.j)-    | otherwise = Nothing-{-# INLINE singlePreStreamGen #-}--#define mkPreStreamGen(s) \-instance (Monad m) => PreStreamGen m (s) (DIM2,Z,Z) where { \-  {-# INLINE preStreamGen #-} \-;  preStreamGen _ = singlePreStreamGen }--mkPreStreamGen(DIM2 -> Scalar elm)-mkPreStreamGen(DIM2 -> ScalarM elm)-mkPreStreamGen(DIM2 -> Vect elm)-mkPreStreamGen(DIM2 -> VectM elm)-mkPreStreamGen(ZU.MArr0 s sh elm)-mkPreStreamGen(ZU.Arr0 sh elm)--mkPreStreamGen(Z.MArr0 s sh (VU.Vector elm))-mkPreStreamGen(Z.Arr0 sh (VU.Vector elm))---- | the first two arguments from nextTo, monadic xs.--instance ( Monad m-         , ExtractValue m xs, Asor xs ~ cX, Elem xs ~ eX-         , PreStreamGen m xs xsStack-         , (idxX,adxX,argX) ~ xsStack-         , (z0:.Int:.Int) ~ idxX-         , ((idxX,adxX,argX) -> m (idxX:.Int,adxX,argX)) ~ mk-         , ((idxX:.Int,adxX,argX) -> m (S.Step (idxX:.Int,adxX,argX) (idxX:.Int,adxX,argX))) ~ step-         ) => PreStreamGen m (Box mk step xs ys) (idxX:.Int,adxX:.cX,argX:.eX) where-  preStreamGen (Box mk step xs ys) ij-    = extractStream xs-    $ S.flatten mk step Unknown-    $ preStreamGen xs ij-  {-# INLINE preStreamGen #-}---- | Pre-stream generation for deeply nested boxes.--instance-  ( Monad m-  , ExtractValue m xs, Asor xs ~ cX, Elem xs ~ eX-  , PreStreamGen m (Box box2 box3 box1 xs) xsStack-  , (idxX,adxX,argX) ~ xsStack-  , (z0:.Int:.Int) ~ idxX-  , ((idxX,adxX,argX) -> m (idxX:.Int,adxX,argX)) ~ mk-  , ((idxX:.Int,adxX,argX) -> m (S.Step (idxX:.Int,adxX,argX) (idxX:.Int,adxX,argX))) ~ step-  ) => PreStreamGen m (Box mk step (Box box2 box3 box1 xs) ys) (idxX:.Int,adxX:.cX,argX:.eX) where-  preStreamGen (Box mk step box@(Box _ _ _ xs) ys) ij-    = extractStream xs-    $ S.flatten mk step Unknown-    $ preStreamGen box ij-  {-# INLINE preStreamGen #-}------ * ExtractValue: extract values from data structures.--class (Monad m) => ExtractValue m cnt where-  type Asor cnt :: *-  type Elem cnt :: *-  extractValue  :: ()-                => cnt-                -> DIM2-                -> Asor cnt-                -> m (Elem cnt)-  extractStream :: ()-                => cnt-                -> S.Stream m (Idx3 z,astack,vstack)-                -> S.Stream m (Idx3 z,astack:.Asor cnt,vstack:.Elem cnt)-  extractStreamLast :: ()-                    => cnt-                    -> S.Stream m (Idx2 z,astack,vstack)-                    -> S.Stream m (Idx2 z,astack:.Asor cnt,vstack:.Elem cnt)---- | Mutable arrays.--instance-  ( PrimMonad m-  , VU.Unbox elm-  , PrimState m ~ s-  , DIM2 ~ sh-  ) => ExtractValue m (ZU.MArr0 s sh elm) where-  type Asor (ZU.MArr0 s sh elm) = Z-  type Elem (ZU.MArr0 s sh elm) = elm-  extractValue cnt ij z = do-    x <- PA.readM cnt ij-    x `seq` return x-  extractStream cnt stream = S.mapM addElm stream where-    addElm (z:.k:.x:.l, astack, vstack) = do-      vadd <- PA.readM cnt (Z:.k:.x)-      vadd `seq` return (z:.k:.x:.l, astack:.Z, vstack :. vadd)-  extractStreamLast sngl stream = S.mapM addElm stream where-    addElm (z:.k:.x, astack, vstack) = do-      vadd <- PA.readM sngl (Z:.k:.x)-      vadd `seq` return (z:.k:.x, astack:.Z, vstack:.vadd)-  {-# INLINE extractValue #-}-  {-# INLINE extractStream #-}-  {-# INLINE extractStreamLast #-}---- | Immutable arrays.--instance-  ( Monad m-  , VU.Unbox elm-  , DIM2 ~ sh-  ) => ExtractValue m (ZU.Arr0 sh elm) where-  type Asor (ZU.Arr0 sh elm) = Z-  type Elem (ZU.Arr0 sh elm) = elm-  extractValue cnt ij z = do-    let x = PA.index cnt ij-    x `seq` return x-  extractStream cnt stream = S.map addElm stream where-    addElm (z:.k:.x:.l, astack, vstack) = let vadd = PA.index cnt (Z:.k:.x) in-      vadd `seq` (z:.k:.x:.l, astack:.Z, vstack :. vadd)-  extractStreamLast cnt stream = S.map addElm stream where-    addElm (z:.k:.x, astack, vstack) = let vadd = PA.index cnt (Z:.k:.x) in-      vadd `seq` (z:.k:.x, astack:.Z, vstack:.vadd)-  {-# INLINE extractValue #-}-  {-# INLINE extractStream #-}-  {-# INLINE extractStreamLast #-}---- | Function with 'Scalar' return value.--instance-  ( Monad m-  ) => ExtractValue m (DIM2 -> Scalar elm) where-  type Asor (DIM2 -> Scalar elm) = Z-  type Elem (DIM2 -> Scalar elm) = elm-  extractValue cnt ij z = do-    let Scalar x = cnt ij-    x `seq` return x-  extractStream cnt stream = S.map addElm stream where-    addElm (z:.k:.x:.l, astack, vstack) = let Scalar vadd = cnt (Z:.k:.x) in-      vadd `seq` (z:.k:.x:.l, astack:.Z, vstack :. vadd)-  extractStreamLast cnt stream = S.map addElm stream where-    addElm (z:.k:.x, astack, vstack) = let Scalar vadd = cnt (Z:.k:.x) in-      vadd `seq` (z:.k:.x, astack:.Z, vstack:.vadd)-  {-# INLINE extractValue #-}-  {-# INLINE extractStream #-}-  {-# INLINE extractStreamLast #-}---- | Function with monadic 'Scalar' return value.--instance-  ( Monad m-  ) => ExtractValue m (DIM2 -> ScalarM (m elm)) where-  type Asor (DIM2 -> ScalarM (m elm)) = Z-  type Elem (DIM2 -> ScalarM (m elm)) = elm-  extractValue cnt ij z = do-    let ScalarM x' = cnt ij-    x <- x'-    x `seq` return x-  extractStream cnt stream = S.mapM addElm stream where-    addElm (z:.k:.x:.l, astack, vstack) = do-      let ScalarM vadd' = cnt (Z:.k:.x)-      vadd <- vadd'-      vadd `seq` return (z:.k:.x:.l, astack:.Z, vstack :. vadd)-  extractStreamLast cnt stream = S.mapM addElm stream where-    addElm (z:.k:.x, astack, vstack) = do-      let ScalarM vadd' = cnt (Z:.k:.x)-      vadd <- vadd'-      vadd `seq` return (z:.k:.x, astack:.Z, vstack:.vadd)-  {-# INLINE extractValue #-}-  {-# INLINE extractStream #-}-  {-# INLINE extractStreamLast #-}---- | This instance is a bit crazy, since the accessor is the current stream--- itself. No idea how efficient this is (need to squint at CORE), but I plan--- to use it for backtracking only.------ TODO Using this instance tends to break to optimizer ;-) -- don't use it--- yet!--instance-  ( Monad m-  ) => ExtractValue m (DIM2 -> S.Stream m elm) where-  type Asor (DIM2 -> S.Stream m elm) = S.Stream m elm-  type Elem (DIM2 -> S.Stream m elm) = elm-  extractValue cnt ij z = error "this function is not well-defined for these streams"-  extractStream cnt stream = S.flatten mk step Unknown $ stream where-    mk (z:.k:.l:.j,as,vs) = do-      let strm = cnt (Z:.k:.l)-      return (z:.k:.l:.j,as:.strm,vs)-    step (idx,as:.strm,vs) = do-      isNull <- S.null strm-      if isNull-      then return $ S.Done-      else do hd <- S.head strm-              hd `seq` return $ S.Yield (idx,as:.strm,vs:.hd) (idx,as:.S.tail strm,vs)-  extractStreamLast cnt stream = S.flatten mk step Unknown $ stream where-    mk (z:.l:.j,as,vs) = do-      let strm = cnt (Z:.l:.j)-      return (z:.l:.j,as:.strm,vs)-    step (idx,as:.strm,vs) = do-      isNull <- S.null strm-      if isNull-      then return $ S.Done-      else do hd <- S.head strm-              hd `seq` return $ S.Yield (idx,as:.strm,vs:.hd) (idx,as:.S.tail strm,vs)-  {-# INLINE extractValue #-}-  {-# INLINE extractStream #-}-  {-# INLINE extractStreamLast #-}---- | Instance of boxed array with vector-valued cells. We assume that we want--- to store multiple results for each cell. If the intent is to store one--- scalar result, use the 'Scalar' wrapper.--instance-  ( PrimMonad m-  , Prim elm-  , VU.Unbox elm-  , PrimState m ~ s-  , DIM2 ~ sh-  ) => ExtractValue m (Z.MArr0 s sh (VU.Vector elm)) where-  type Asor (Z.MArr0 s sh (VU.Vector elm)) = Int-  type Elem (Z.MArr0 s sh (VU.Vector elm)) = elm-  extractValue cnt ij z = do-    x <- PA.readM cnt ij-    let y = x `VU.unsafeIndex` z-    y `seq` return y-  extractStream cnt stream = S.flatten mk step Unknown $ stream where-    mk (idx,as,vs) = return (idx,as:.0,vs)-    step (z:.k:.l:.j,as:.a,vs) = do-      x <- PA.readM cnt (Z:.k:.l)-      case (x VU.!? a) of-        Just v  -> v `seq` return $ S.Yield (z:.k:.l:.j,as:.a,vs:.v) (z:.k:.l:.j,as:.(a+1),vs)-        Nothing -> return $ S.Done-  extractStreamLast cnt stream = S.flatten mk step Unknown $ stream where-    mk (idx,as,vs) = return (idx,as:.0,vs)-    step (z:.l:.j,as:.a,vs) = do-      x <- PA.readM cnt (Z:.l:.j)-      case (x VU.!? a) of-        Just v  -> v `seq` return $ S.Yield (z:.l:.j,as:.a,vs:.v) (z:.l:.j,as:.(a+1),vs)-        Nothing -> return $ S.Done-  {-# INLINE extractValue #-}-  {-# INLINE extractStream #-}-  {-# INLINE extractStreamLast #-}---- | vector-based cells--instance-  ( Monad m-  , Prim elm-  , VU.Unbox elm-  , DIM2 ~ sh-  ) => ExtractValue m (Z.Arr0 sh (VU.Vector elm)) where-  type Asor (Z.Arr0 sh (VU.Vector elm)) = Int-  type Elem (Z.Arr0 sh (VU.Vector elm)) = elm-  extractValue cnt ij z = do-    let x = PA.index cnt ij-    let y = x `VU.unsafeIndex` z-    y `seq` return y-  extractStream cnt stream = S.flatten mk step Unknown $ stream where-    mk (idx,as,vs) = return (idx,as:.0,vs)-    step (z:.k:.l:.j,as:.a,vs) = do-      let x = PA.index cnt (Z:.k:.l)-      case (x VU.!? a) of-        Just v  -> v `seq` return $ S.Yield (z:.k:.l:.j,as:.a,vs:.v) (z:.k:.l:.j,as:.(a+1),vs)-        Nothing -> return $ S.Done-  extractStreamLast cnt stream = S.flatten mk step Unknown $ stream where-    mk (idx,as,vs) = return (idx,as:.0,vs)-    step (z:.l:.j,as:.a,vs) = do-      let x = PA.index cnt (Z:.l:.j)-      case (x VU.!? a) of-        Just v  -> v `seq` return $ S.Yield (z:.l:.j,as:.a,vs:.v) (z:.l:.j,as:.(a+1),vs)-        Nothing -> return $ S.Done-  {-# INLINE extractValue #-}-  {-# INLINE extractStream #-}-  {-# INLINE extractStreamLast #-}----- * Apply function 'f' with arguments on a stack 'x'.------ NOTE look at the end of this part for mkApply before writing instances by--- hand... ;-)--class Apply x where-  type Fun x :: *-  apply :: Fun x -> x--instance Apply (Z:.a -> res) where-  type Fun (Z:.a -> res) = a -> res-  apply fun (Z:.a) = fun a-  {-# INLINE apply #-}--instance Apply (Z:.a:.b -> res) where-  type Fun (Z:.a:.b -> res) = a->b -> res-  apply fun (Z:.a:.b) = fun a b-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c -> res) where-  type Fun (Z:.a:.b:.c -> res) = a->b->c -> res-  apply fun (Z:.a:.b:.c) = fun a b c-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d -> res) where-  type Fun (Z:.a:.b:.c:.d -> res) = a->b->c->d -> res-  apply fun (Z:.a:.b:.c:.d) = fun a b c d-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e -> res) where-  type Fun (Z:.a:.b:.c:.d:.e -> res) = a->b->c->d->e -> res-  apply fun (Z:.a:.b:.c:.d:.e) = fun a b c d e-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f -> res) = a->b->c->d->e->f -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f) = fun a b c d e f-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g -> res) = a->b->c->d->e->f->g -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g) = fun a b c d e f g-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h -> res) = a->b->c->d->e->f->g->h -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h) = fun a b c d e f g h-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) = a->b->c->d->e->f->g->h->i -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i) = fun a b c d e f g h i-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) = a->b->c->d->e->f->g->h->i->j -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j) = fun a b c d e f g h i j-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) = a->b->c->d->e->f->g->h->i->j->k -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k) = fun a b c d e f g h i j k-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) = a->b->c->d->e->f->g->h->i->j->k->l -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l) = fun a b c d e f g h i j k l-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m) = fun a b c d e f g h i j k l m-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n) = fun a b c d e f g h i j k l m n-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n->o -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o) = fun a b c d e f g h i j k l m n o-  {-# INLINE apply #-}--{--mkApply to = do-  let xs    = ['a' .. to]-  let args  = concat . (":.":) . intersperse ":." . map (:[]) $ xs-  let arga  = concat . intersperse "->" . map (:[]) $ xs-  let args' = intersperse ' ' xs-  printf "instance Apply (Z%s -> res) where\n" args-  printf "  type Fun (Z%s -> res) = %s -> res\n" args arga-  printf "  apply fun (Z%s) = fun %s\n" args args'-  printf "  {-# INLINE apply #-}\n"--}------ * helper stuff--data Box mk step xs ys = Box mk step xs ys--type Idx3 z = z:.Int:.Int:.Int--type Idx2 z = z:.Int:.Int------ * wrappers for functions instead of arrays as arguments. It can be much--- cheaper in terms of writing code to just provide a function @DIM2 -> Scalar--- a@ instead of writing instances for your data structure.--newtype Scalar a = Scalar {unScalar :: a}--newtype ScalarM a = ScalarM {unScalarM :: a}--newtype Vect a = Vect {unVect :: a}--newtype VectM a = VectM {unVectM :: a}
+ 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.hs 
@@ -1,185 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE TemplateHaskell #-}---- | QuickCheck properties for a number of ADPfusion combinators. Each test is--- once written using ADPfusion and once using list comprehensions. Typing--- @allProps@ in ghci will run all tests, prefixed @prop_@ with a thousand--- tests each.--module ADP.Fusion.QuickCheck where--import Data.List-import Data.Vector.Fusion.Stream.Size-import Data.Vector.Fusion.Util-import qualified Data.Vector.Fusion.Stream as S-import qualified Data.Vector.Unboxed as VU-import Test.QuickCheck-import Test.QuickCheck.All--import "PrimitiveArray" Data.Array.Repa.Index--import ADP.Fusion.QuickCheck.Arbitrary-import qualified ADP.Fusion as F-import qualified ADP.Fusion.Monadic as M-import qualified ADP.Fusion.Monadic.Internal as F----options = stdArgs {maxSuccess = 1000}--customCheck = quickCheckWithResult options--allProps = $forAllProperties customCheck------ * Some definitions:------ @O@ means one--- @M@ means many--- @P@ means one or more--- @ML_x_y@ is for a makeLeftCombinator with boundaries x and y---- ** @xs -~+ ys@, size @xs@ = 1, size @ys@ >= 1.--fOP (i,j) = S.toList $ (,) F.<<< fRegion F.-~+ fRegion F.... id $ Z:.i:.j--lOP (i,j) = [ ((i,i+1), (i+1,j)) | i+1<=j-1 ]--prop_OP = fOP === lOP---- ** @xs -~~ ys -~~ zs@, size @xs@ = 1, size @ys@ = 1, size @zs@ >= 0.--fOOP (i,j) = S.toList $ (,,) F.<<< fRegion F.-~~ fRegion F.-~~ fRegion F.... id $ Z:.i:.j--lOOP (i,j) = [ ( (i,i+1), (i+1,i+2), (i+2,j) ) | i+2<=j ]--prop_OOP = fOOP === lOOP---- ** @xs +~- ys@, size @xs@ >= 1, size @ys@ = 1.--fPO (i,j) = S.toList $ (,) F.<<< fRegion F.+~- fRegion F.... id $ Z:.i:.j--lPO (i,j) = [ ( (i,j-1), (j-1,j) ) | i+1<=j-1 ]--prop_PO (Small i, Small j) = fPO (i,j) == lPO (i,j)---- ** @xs -~+ ys +~- zs@, size @xs@ = 1, size @ys@ >= 1, size @zs@ = 1. This is--- a "hairpin" in RNA bioinformatics.--fOPO (i,j) = S.toList $ (,,) F.<<< fRegion F.-~+ fRegion F.+~- fRegion F.... id $ Z:.i:.j--lOPO (i,j) = [ ( (i,i+1), (i+1,j-1), (j-1,j) ) | i+2<=j, i+1<j-1 ]--prop_OPO = fOPO === lOPO---- ** The central region is non-empty, with two size-1 regions on each side.--- Will create @O(n)@ candidates, which will all fail, except for the last one--- (if @j-i@ is large enough).--fOOPOOslow (i,j) = S.toList $ (,,,,) F.<<< fRegion F.-~+ fRegion F.-~+ fRegion F.+~+ fRegion F.-~- fRegion F.... id $ Z:.i:.j--lOOPOO (i,j) = [ ( (i,i+1), (i+1,i+2), (i+2,j-2), (j-2,j-1), (j-1,j) ) | i+4<=j, i+2<j-2 ]--prop_OOPOOslow = fOOPOOslow === lOOPOO---- ** The above test can be sped up by the use of the @+~--@ combinator. It--- fixes the left and right side, by allowing only exactly size two on its--- right. Each combinator here will 'Yield' exactly once, then be 'Done'.--fOOPOOfast (i,j) = S.toList $ (,,,,) F.<<< fRegion F.-~+ fRegion F.-~+ fRegion F.+~-- fRegion F.-~- fRegion F.... id $ Z:.i:.j--prop_OOPOOfast = fOOPOOfast === lOOPOO---- ** A complex right-hand side which was problematic in 0.0.0.3 of ADPfusion.--- In original ADP @base -~~ weak ~~- base +~+ string@ we want the @base@ parts--- to have size 1, @weak@ of any size, and @string@ to be non-empty. In--- ADPfusion @as -~+ bs@ means that @as@ has size one, @bs@ size 1 or more.--fOPOP (i,j) = S.toList $ (,,,) F.<<< fRegion F.-~+ fRegion F.+~+ fRegion F.-~+ fRegion F.... id $ Z:.i:.j--lOPOP (i,j) = [ ( (i,i+1), (i+1,k), (k,k+1), (k+1,j) ) | k <- [i+1 .. j-2], i+1<k, k+1<j ]--prop_OPOP = fOPOP === lOPOP---- ** One more of those complex right-hand sides. This one is already rather--- complicated. We have @one -~+ one -~+ many +~+ one -~~ one -~+ plus@ where--- @one@ has size 1, many has size 0 to many, plus has size 1 to many. The last--- combinator @-~+@ again short-curcuits by being 'Done' once the left-hand--- side is larger than one.--fOOPOOP (i,j) = S.toList $ (,,,,,) F.<<< fRegion F.-~+ fRegion F.-~+ fRegion F.+~+ fRegion F.-~~ fRegion F.-~+ fRegion F.... id $ Z:.i:.j--lOOPOOP (i,j) = [ ( (i,i+1), (i+1,i+2), (i+2,k), (k,k+1), (k+1,k+2), (k+2,j) ) | k <- [i+2 .. j-3], i+2<k, k+2<j ]--prop_OOPOOP = fOOPOOP === lOOPOOP---- ** We now introduce two independently moving indices and size zero regions.--fMMM (i,j) = S.toList $ (,,) F.<<< fRegion F.~~~ fRegion F.~~~ fRegion F.... id $ Z:.i:.j--lMMM (i,j) = [ ( (i,k), (k,l), (l,j) ) | k <- [i..j], l<-[k..j] ]--prop_MMM = fMMM === lMMM---- ** Three independent regions, each one enclosed by two size-1 regions.--- Compile-time hog.--fOPOOPOOPO (i,j) = S.toList $ (,,,,,,,,) F.<<< fRegion F.-~+ fRegion F.+~+ fRegion F.-~+-                                          {--} fRegion F.-~+ fRegion F.+~+ fRegion F.-~+-                                          {--} fRegion F.-~+ fRegion F.+~- fRegion F.... id $ Z:.i:.j--lOPOOPOOPO (i,j) = [ ( (i,i+1), (i+1,k), (k,k+1), {--} (k+1,k+2), (k+2,l), (l,l+1), {--} (l+1,l+2), (l+2,j-1), (j-1,j) )-                   | k<-[i+1 .. j-5], l<-[k+2 .. j-3], i+1<k, k+2<l, l+2<j-1 ]--prop_OPOOPOOPO = fOPOOPOOPO === lOPOOPOOPO---- ** Two non-empty regions, the right one with single-size regions around it.--- (sorry about the name)--fPOPO (i,j) = S.toList $ (,,,) F.<<< fRegion F.+~+ fRegion F.-~+ fRegion F.+~- fRegion F.... id $ Z:.i:.j--lPOPO (i,j) = [ ( (i,k), (k,k+1), (k+1,j-1), (j-1,j) ) | k <- [i+1 .. j-3] ]--prop_POPO (Small i, Small j) = fPOPO (i,j) == lPOPO (i,j)---- ** Sanity-checking special constraints.--fOO (i,j) = S.toList $ (,) F.<<< fRegion F.-~- fRegion F.... id $ Z:.i:.j--lOO (i,j) = [ ( (i,i+1), (j-1,j) ) | i+2==j ]--prop_OO (Small i, Small j) = fOO (i,j) == lOO (i,j)---- ** Two non-empty regions--fPP (i,j) = S.toList $ (,) F.<<< fRegion F.+~+ fRegion F.... id $ Z:.i:.j--lPP (i,j) = [ ( (i,k), (k,j) ) | k<-[i+1 .. j-1] ]--prop_PP (Small i, Small j) = fPP (i,j) == lPP (i,j)---- ** using 'makeLeft_MinRight'--fML_1_4M (i,j) = S.toList $ (,) F.<<< fRegion `ml_1_4` fRegion F.... id $ Z:.i:.j where-  infixl 9 `ml_1_4`-  ml_1_4 = F.makeLeft_MinRight (1,4) 0--lML_1_4M (i,j) = [ ( (i,k), (k,j) ) | k <- [i+1 .. min (i+4) j] ]--prop_ML_1_4M = fML_1_4M === lML_1_4M---- ** using 'makeLeft_MinRight' and 'makeMinLeft_Right'. Inner regions fixed to--- be non-empty.--fML_1_4MMR_1_4 (i,j) = S.toList $ (,,) F.<<< fRegion `ml_1_4` fRegion `mr_1_4` fRegion F.... id $ Z:.i:.j where-  infixl 9 `ml_1_4`-  ml_1_4 = F.makeLeft_MinRight (1,4) 1-  infixl 9 `mr_1_4`-  mr_1_4 = F.makeMinLeft_Right 1 (1,4)--lML_1_4MMR_1_4 (i,j) = [ ( (i,k), (k,l), (l,j) ) | k<-[i+1 .. min (i+4) j], l <- [max k (j-4) .. j-1], k<l ]--prop_ML_1_4MMR_1_4 = fML_1_4MMR_1_4 === lML_1_4MMR_1_4-
− ADP/Fusion/QuickCheck/Arbitrary.hs 
@@ -1,39 +0,0 @@-{-# LANGUAGE PackageImports #-}--module ADP.Fusion.QuickCheck.Arbitrary where--import Test.QuickCheck-import Test.QuickCheck.All--import "PrimitiveArray" Data.Array.Repa.Index--import qualified ADP.Fusion.Monadic.Internal as F--lAchar (i,j) = [j | i+1 == j]---- |------ NOTE we have to add 1 to the i-index. Legacy ADP reads chars from an input--- array starting at "1", while ADPfusion starts arrays at "0".--fAchar :: DIM2 -> (F.Scalar Int)-fAchar (Z:.i:.j) = F.Scalar $ (i+1)--fRegion :: DIM2 -> (F.Scalar (Int,Int))-fRegion (Z:.i:.j) = F.Scalar $ (i,j)---- * quickcheck stuff--newtype Small = Small Int-  deriving (Show)--instance Arbitrary Small where-  arbitrary = Small `fmap` choose (0,50)-  shrink (Small x)-    | x>0       = [Small $ x-1]-    | otherwise = []--small x = x>=0 && x <=50--(===) f g (Small i, Small j) = f (i,j) == g (i,j)-
+ 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,171 +1,411 @@+cabal-version:  2.2 name:           ADPfusion-version:        0.1.0.0-author:         Christian Hoener zu Siederdissen, 2011-2012-copyright:      Christian Hoener zu Siederdissen, 2011-2012-homepage:       http://www.tbi.univie.ac.at/~choener/adpfusion-maintainer:     choener@tbi.univie.ac.at-category:       Algorithms, Data Structures, Bioinformatics-license:        BSD3+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:        BSD-3-Clause license-file:   LICENSE build-type:     Simple stability:      experimental-cabal-version:  >= 1.6.0-synopsis:-                Efficient, high-level dynamic programming.+tested-with:    GHC == 8.6.4+synopsis:       Efficient, high-level dynamic programming. description:-                ADPfusion combines stream-fusion (using the stream interface-                provided by the vector library) and type-level programming to-                provide highly efficient dynamic programming combinators.-                .-                From the programmers' viewpoint, ADPfusion behaves very much-                like the original ADP implementation-                <http://bibiserv.techfak.uni-bielefeld.de/adp/> developed by-                Robert Giegerich and colleagues, though both combinator-                semantics and backtracking are different.-                .-                The library internals, however, are designed not only to speed-                up ADP by a large margin (which this library does), but also to-                provide further runtime improvements by allowing the programmer-                to switch over to other kinds of data structures with better-                time and space behaviour. Most importantly, dynamic programming-                tables can be strict, removing indirections present in lazy,-                boxed tables.-                .-                As a simple benchmark, consider the Nussinov78 algorithm which-                translates to three nested for loops (for C). In the figure,-                four different approaches are compared using inputs with size-                100 characters to 1000 characters in increments of 100-                characters. "C" is an implementation ("./C/" directory) in "C"-                using "gcc -O3". "ADP" is the original ADP approach (see link-                above), while "GAPC" uses the "GAP" language-                (<http://gapc.eu/>).-                <<https://github.com/choener/ADPfusion/gaplike-performance.png>>-                .-                Please note that actual performance will depend much on table-                layout and data structures accessed during calculations, but in-                general performance is very good: close to C and better than-                other high-level approaches (that I know of).-                .-                .-                .-                Even complex ADP code tends to be completely optimized to loops-                that use only unboxed variables (Int# and others,-                indexIntArray# and others).-                .-                Completely novel (compared to ADP), is the idea of allowing-                efficient monadic combinators. This facilitates writing code-                that performs backtracking, or samples structures-                stochastically, among others things.-                .-                This version is still highly experimental and makes use of-                multiple recent improvements in GHC. This is particularly true-                for the monadic interface.-                .-                .-                .-                Newley added are the ADP.Fusion.GAPlike modules. These allow-                for writing grammars with only one (non)-terminal combinator.-                The logic for index manipulation is now moved into data types-                for terminals and non-terminals.-                .-                While this change leads to slightly more complicated instances-                for each new terminal or non-terminal, the overall code-                complexity is significantly lower. In addition, Constraint-                Kinds make complex interactions between (non)-terminals-                possible, while still managing to produce high-performance-                code.-                .-                The final goal would, of course, be to have no inter-terminal-                combinators anymore.-                .-                * GHC 7.6, LLVM, and -fnew-codegen recommended: gives a speedup-                  of x2 for GAPcriterion-                .-                .-                .-                .-                Long term goals: Outer indices with more than two dimensions,-                specialized table design, a combinator library, a library for-                computational biology.-                .-                Two algorithms from the realm of computational biology are-                provided as examples on how to write dynamic programming-                algorithms using this library:-                <http://hackage.haskell.org/package/Nussinov78> and-                <http://hackage.haskell.org/package/RNAFold>.-                .-                Changes since 0.0.1.2:-                .-                * require GHC 7.6-                .-                * ADP.Fusion.GAPlike module for (almost) combinator-less grammars-                .-                * ConstraintKinds for constrained parsers in GAPlike.-                .-                .+                <http://www.bioinf.uni-leipzig.de/Software/gADP/ generalized Algebraic Dynamic Programming>                 .-                Changes since 0.0.1.0:+                ADPfusion combines stream-fusion (using the stream interface provided by the vector+                library) and type-level programming to provide highly efficient dynamic programming+                combinators.                 .-                * compatibility with GHC 7.4+                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.                 .-                * note: still using fundeps & and TFs together. The TF-only version does not optimize as well (I know why but not yet how to fix it)+                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.                 .+                The homepage provides a number of tutorial-style examples, with linear and+                context-free grammars over sequence and set inputs.                 .-                Using the new code generator?+                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.                 .-                The new code generator is not official yet, but I recommend trying it out:-                <<https://github.com/choener/ADPfusion/gaplike-newcodegen.png>>+                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.    Extra-Source-Files:   README.md-  ADP/Fusion/QuickCheck.hs-  ADP/Fusion/QuickCheck/Arbitrary.hs+  changelog.md  -Flag devel-  description: build criterion benchmarks and pull in QuickCheck-  default: False +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 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++flag llvm+  description:  use llvm+  default:      False+  manual:       True++++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+  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+++ library-  build-depends:-    base >= 4 && < 5,-    ghc-prim,-    primitive      == 0.5.*   ,-    vector         == 0.10.*  ,-    PrimitiveArray == 0.4.*+  import:+    deps   exposed-modules:-    ADP.Fusion-    ADP.Fusion.Monadic-    ADP.Fusion.Monadic.Internal-    ADP.Fusion.GAPlike+    -- 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 +++test-suite properties+  import:+    deps+  type:+    exitcode-stdio-1.0+  main-is:+    properties.hs+  other-modules:+    QuickCheck.Common+    QuickCheck.Point   ghc-options:-    -O2 -funbox-strict-fields+    -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 -executable GAPcriterion-  buildable:-    False-  if flag(devel)+++-- Very simple two-sequence alignment.++executable NeedlemanWunsch++  if flag(examples)     buildable:       True-    build-depends:-      criterion  == 0.6.* ,-      QuickCheck == 2.5-  other-modules:-    ADP.Fusion.GAPlike.DevelCommon-    ADP.Fusion.GAPlike.Criterion-    ADP.Fusion.GAPlike.QuickCheck+    build-depends:  base+                 ,  ADPfusion+                 ,  primitive+                 ,  PrimitiveArray+                 ,  template-haskell+                 ,  vector+                 ,  DPutils+  else+    buildable:+      False+  hs-source-dirs:+    src   main-is:-    Tests/GAPcriterion.hs+    NeedlemanWunsch.hs+  default-language:+    Haskell2010+  default-extensions: BangPatterns+                    , DataKinds+                    , FlexibleContexts+                    , FlexibleInstances+                    , MultiParamTypeClasses+                    , PartialTypeSignatures+                    , PolyKinds+                    , RecordWildCards+                    , TemplateHaskell+                    , TypeApplications+                    , TypeFamilies+                    , TypeOperators+                    , UnicodeSyntax   ghc-options:-    -fllvm -O2 -funbox-strict-fields -optlo-O3 -optlo-std-compile-opts-  if impl(GHC > 7.4)+    -O2+    -funbox-strict-fields+    -- 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:-      -fnew-codegen+      -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 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:+    SmithWaterman.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+    -- 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++++-- Very simple two-sequence alignment.++executable spectest++  if flag(spectest)+    buildable:+      True+    build-depends:  base+                 ,  ADPfusion+                 ,  PrimitiveArray+                 ,  template-haskell+                 ,  vector+  else+    buildable:+      False+  hs-source-dirs:+    src+  main-is:+    SpecTest.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++   source-repository head
LICENSE view
@@ -1,4 +1,4 @@-Copyright Christian Hoener zu Siederdissen 2011-2012+Copyright Christian Hoener zu Siederdissen 2011-2015  All rights reserved.
README.md view
@@ -1,15 +1,38 @@+[![Build Status](https://travis-ci.org/choener/ADPfusion.svg?branch=master)](https://travis-ci.org/choener/ADPfusion) -ADPfusion-(c) 2012, Christian Hoener zu Siederdissen-University of Vienna, Vienna, Austria-choener@tbi.univie.ac.at-LICENSE: BSD3+# ADPfusion +[*generalized Algebraic Dynamic Programming Homepage*](http://www.bioinf.uni-leipzig.de/Software/gADP/) +Ideas implemented here are described in a couple of papers: -Introduction-============ ++1.  Christian Hoener zu Siederdissen  +    *Sneaking Around ConcatMap: Efficient Combinators for Dynamic Programming*  +    2012, Proceedings of the 17th ACM SIGPLAN international conference on Functional programming  +    [paper](http://doi.acm.org/10.1145/2364527.2364559) [preprint](http://www.tbi.univie.ac.at/newpapers/pdfs/TBI-p-2012-2.pdf)  +1.  Andrew Farmer, Christian Höner zu Siederdissen, and Andy Gill.  +    *The HERMIT in the stream: fusing stream fusion’s concatMap*  +    2014, Proceedings of the ACM SIGPLAN 2014 workshop on Partial evaluation and program manipulation.  +    [paper](http://dl.acm.org/citation.cfm?doid=2543728.2543736)  +1.  Christian Höner zu Siederdissen, Ivo L. Hofacker, and Peter F. Stadler.  +    *Product Grammars for Alignment and Folding*  +    2014, IEEE/ACM Transactions on Computational Biology and Bioinformatics. 99  +    [paper](http://ieeexplore.ieee.org/xpl/articleDetails.jsp?arnumber=6819790)  +1.  Christian Höner zu Siederdissen, Sonja J. Prohaska, and Peter F. Stadler  +    *Algebraic Dynamic Programming over General Data Structures*  +    2015, BMC Bioinformatics  +    [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*  +    2016, Theoretical Computer Science  +    [preprint](http://www.bioinf.uni-leipzig.de/Software/gADP/preprints/rie-hoe-2015.pdf)  ++++# Introduction+ ADPfusion combines stream-fusion (using the stream interface provided by the vector library) and type-level programming to provide highly efficient dynamic programming combinators.@@ -34,84 +57,23 @@ combinators. This facilitates writing code that performs backtracking, or samples structures stochastically, among others things. -This version is still highly experimental and makes use of multiple recent-improvements in GHC. This is particularly true for the monadic interface. -Long term goals: Outer indices with more than two dimensions, specialized table-design, a combinator library, a library for computational biology. -Two algorithms from the realm of computational biology are provided as examples-on how to write dynamic programming algorithms using this library:-<http://hackage.haskell.org/package/Nussinov78> and-<http://hackage.haskell.org/package/RNAfold>. --Installation-============--If GHC-7.2.2/GHC-7.4, LLVM and cabal-install are available, you should be all-set. I recommend using cabal-dev as it provides a very nice sandbox (replace-cabal-dev with cabal otherwise).--If you go with cabal-dev, no explicit installation is necessary and ADPfusion-will be installed in the sandbox together with the example algorithms or your-own.--For a more global installation, "cabal install ADPfusion" should do the trick.--To run the Quickcheck tests, do an additional "cabal-dev install QuickCheck",-then "cabal-dev ghci", ":l ADP/Fusion/QuickCheck.hs", and "allProps". Loading-the quickcheck module should take a bit due to compilation. "allProps" tests-all properties and should yield no errors.----Notes-=====--If you have problems, find bugs, or want to use this library to write your own-DP algorithms, please send me a mail. I'm very interested in hearing what is-missing.--One of the things I'll be integrating is an extension to higher dimensions-(more than two).+# Installation -Right now, I am not quite happy with the construction and destruction of the-"Box" representations. These will change soon. In addition, an analysis of the-actual combinators should remove the need for nested applications of objective-functions in many cases.+Follow the [gADP examples](http://www.bioinf.uni-leipzig.de/Software/gADP/index.html).   -VERSION HISTORY-===============+# Implementors Notes (if you want to extend ADPfusion) -- 0.0.0.3:-  - initial version, together with submitted paper+These have been moved to [HACKING.md](https://github.com/choener/ADPfusion/blob/master/HACKING.md). -- 0.0.0.4:-  - based most combinators on just two generalized Box creators-  - cleaned up and simplified RNAfold example-  - RNAfold execution now a bit slower. Simplified energy functions typically-    only have three arguments now, which can be of 'Primary' type. While this-    reduces speed because we will repeatedly ask for the same value, it is much-    easier to handle the different functions and ``play'' with fusion-    properties.-  - RNAfold compilation massively faster: execution/compilation tradoff is-    worth it for experimenting with ADPfusion; still faster than anything-    except RNAfold itself. We are now now 2.8x times slower, but 3.5x times-    slower-  - Quickcheck properties for many combinators-  - Unit tests for RNAfold functions-  - will soon split off RNAfold and Nussinov and publish three hackage-    libraries-  - this version was never available, after being done, a split into library-    and examples was performed.+#### Contact -- 0.0.1.0-  - providing just the library. Examples are found in different libraries.+Christian Hoener zu Siederdissen  +Leipzig University, Leipzig, Germany  +choener@bioinf.uni-leipzig.de  +<http://www.bioinf.uni-leipzig.de/~choener/>   -- 0.0.1.1-  - this version should be compatible with GHC-7.4, at least GHC-7,4.2-rc1.-  - a type family (TF) version has not been able to show the same performance-    as fundeps. This means that fundeps for Internal.hs stay alive, for now.
− Tests/GAPcriterion.hs 
@@ -1,9 +0,0 @@--module Main where--import ADP.Fusion.GAPlike2.Criterion----main = criterionMain-
+ changelog.md view
@@ -0,0 +1,106 @@+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+-------++- bugfix in Multitape Subword Index calculations (A.F.S.Indices.hs) [this one+  is quite spurious. I needed quickcheck to find a suitable minimal example+  where Pseudoknot.hs fails]++0.4.1.0+-------++- initial support for multi-context free grammars+- mcfgs allow for interleaved syntactic variables+- applications include: natural language modelling and pseudoknotted structures+  in RNA+- the simplest formal language that requires this is: a^i b^j a^i b^j+- the [GenussFold](http://hackage.haskell.org/package/GenussFold) library gives+  a simple example grammar++0.4.0.2+-------++- bugfixes++0.4.0.0+-------++- travic-ci integration+- forward phase now operates on immutable tables that are internally thawed+- resembles the behavior of Data.Vector.Generic.constructN+- Empty needs to be bound to input. We require this as certain index structures+  have no natural notion of and empty index -- unless one provides additional+  information in the index++0.3.0.0+-------++- simplified boundary checking: sometimes gives performance gain (!) due to one+  loop variable less+- optimized loop variable design following "The HERMIT in the Stream" (Farmer+  et al, 2014)+- somewhat nicer programmer interfaces+- automatic filling and freezing of tables+- multiple example algorithms (build with -fexamples switch):+  - Needleman-Wunsch global alignment+  - RNA secondary structure prediction using simple base pair maximization+- updated Table code to handle single-dim Subwords in a better way.+- simplified backtracking++0.2.x.x+-------++- Streamlined interface: access everything via ADP.Fusion+- /Multi-tape/ grammars can now be written and are fused+
+ src/NeedlemanWunsch.hs view
@@ -0,0 +1,399 @@++{-# 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.+--+-- 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.+--+-- We also need to import @ADP.Fusion@ to access the high-level code for+-- dynamic programs.+--+-- Don't forget to inline basically everything!+--+-- One note on performance: Needleman-Wunsch is actually one of the worst+-- cases for ADPfusion. Low-level implementations can get away with a very+-- small number of code steps for each cell to be filled. We can't /quite/+-- do this. The relative overhead for each cell to be written into goes+-- down with more complex grammars and algebras.++module Main (main) where++import           Control.Monad (forM_,when)+import           Control.Monad.Primitive+import           Control.Monad.ST+import           Data.Ord.Fast+import           Debug.Trace+import           System.Environment (getArgs)+import           Text.Printf++-- Streams of parses are the streams defined in the @vector@ package.++import qualified Data.Vector.Fusion.Stream.Monadic as SM++-- We use unboxed vectors to hold the input sequences to be aligned. The+-- terminal parses work with any vector in the @vector@ package.++import qualified Data.Vector.Unboxed as VU+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+-- set data structures are made available.++import           Data.PrimitiveArray as PA hiding (map)++-- @ADP.Fusion.Point@ exposes everything necessary for higher-level DP+-- algorithms. Depending on the type of DP algorithm, different top-level+-- modules can be imported. @.Point@ for linear grammars, and @.Core@ are+-- provided in this package. @.Core@ exports only the core modules required+-- to extend ADPfusion.++import           ADP.Fusion.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.+--+-- We take a close look at the type signatures. @step_step :: x ->+-- (Z:.c:.c) -> x@ tells us that @step_step@ requires the score from the+-- non-terminal, typed @x@ for the alignment up to @d@, then we get the two+-- characters with type @c@ and produce a new non-terminal typed score @x@.+-- For our simple alignment we'll later choose @Char@ for @c@ and @Int@ for+-- @x@.+--+-- The type of @h :: Stream m x -> m r@ is more interesting. We get+-- a @Stream@ of @x@'s and produce an @r@ monadically. The left part is+-- clear @Stream m x@ are the results from the four rules, but the right+-- part allows us to maybe not only return the best case, types @x == r@,+-- but maybe the two best cases @r == (x,x)@ or similar. While we do not+-- use this feature here, it makes ADPfusion fully "classified DP"+-- capable, which is a really cool feature for advanced algorithms.++data Signature m x r c = Signature+  { step_step ∷ x → (Z:.c :.c ) → x+  , step_loop ∷ x → (Z:.c :.()) → x+  , loop_step ∷ x → (Z:.():.c ) → x+  , nil_nil   ∷     (Z:.():.()) → x+  , h         ∷ Stream m x -> m r+  }++-- | We also want to be able to backtrace the optimal result. Given our+-- alignment, knowing that we get an alignment score of 29 doesn't help us+-- much. But with /algebra products/ we can ask for @(optimal <** pretty)@+-- and get the optimal result /and/ the parse for it.+--+-- The @(<**)@ operator is notoriously difficult to write, so we just+-- compute it ☺.+--+-- Note that haddock actually shows @(<**)@, while you just write+-- @makeAlgebraProductH ['h] ''Signature@ (the primes are TemplateHaskell!,+-- the only TemplateHaskell we need).++makeAlgebraProduct ''Signature++-- | This is the linear grammar in two dimensions describing the+-- "Needleman-Wunsch" search space. It will, in principle, enumerate the+-- exponential number of possible alignment, but due to memoization and the+-- choice function @h@, the calculation time is @O(N^2)@ and if only one+-- optimal alignment is requested, backtracking works in linear time.+--+-- The grammar first requires a 'Signature', we use @RecordWildCards@ as+-- a language extension to bind @step_step@ and friends. We also need+-- a variable for the single non-terminal (@a@), and have two inputs @i1@+-- and @i2@. Each grammar starts with a "base case" @Z:.@ followed by one+-- or more pairs of non-terminal plus rules. Here we have one pair @(a,+-- rules)@, where in @rules@ we combine the four different rules.+--+-- @step_step \<\<\< a % (M:>chr i1:>chr i2)@, for example, means that+-- @step_step@ first gets the non-terminal @a@, which will give the score+-- up to @d@ (see the ascii-art above), followed by @(%)@ the 2-dim+-- terminal for @i1@ and @i2@.+--+-- Multi-dimensional terminals are built up from the zero-dimension @M@,+-- separated by @:|@ symbols and just bind the input. In this case we want+-- individual characters from @i1@ and @i2@, so we write @chr i1@ or @chr+-- i2@.+--+-- Different rules are combined with @(|||)@ and the optimal case is+-- selected via @... h@. Rules can, of course, be co-recursive, each rule+-- can request all terminal and non-terminal symbols.+--+-- Due to the way @nil_nil@ works on @Epsilon@, @nil_nil@ is actually /only/+-- called once, when we start the alignment, not for every cell!+--+-- /However/, due to this being a high-performance library, we do not+-- provide a runtime scheme to detect misbehaving rules. Some debug-code is+-- in place that performs certain checks in non-optimized GHCI sessions,+-- but optimized code is built for raw speed, without any checks.+--+-- If you are a "conventional" DP programmer, you might miss the usual+-- indices. Just as in the spiritual father of @ADPfusion@, Robert+-- Giegerichs @ADP@, we hide the actual index calculations.++grammar Signature{..} !a' !i1 !i2 =+  let a = TW a' ( step_step <<< a % (M:|chr i1:|chr i2)     |||+                  step_loop <<< a % (M:|chr i1:|Deletion  ) |||+                  loop_step <<< a % (M:|Deletion  :|chr i2) |||+                  nil_nil   <<< (M:|Epsilon @Global:|Epsilon @Global)       ... h+                )+  in Z:.a+{-# INLINE grammar #-}++-- | A grammar alone is not enough, we also need to say what a @step_step@+-- means, or what an optimum is. Here, we do exactly that. We create an+-- instance of the 'Signature' from above. Since this is a simple example,+-- we just say that two aligned characters @a@ and @b@ yield a score of+-- @x+1@ (with @x@ the previous alignment score) if the characters are+-- identical. Otherwise we lower the score by 2. In/dels incur a cost of+-- @-1@, meaning that a mismatch is actually the same as two in/dels, one+-- in each dimension. The start of the alignment gives an initial score of+-- 0.+--+-- And the optimal choice, of course, is to start with a default of+-- @-999999@ and find the maximum of that score and the choices we are+-- given.++sScore ∷ Monad m ⇒ Signature m Int Int Char+sScore = Signature+  { step_step = \x (Z:.a:.b) → if a==b then x+7 else x-5+  , step_loop = \x _         → x-3+  , loop_step = \x _         → x-2+  , nil_nil   = const 0+  , h = SM.foldl' fastmax (-999999)+--  , h = SM.foldl1' fastmax+  }+{-# INLINE sScore #-}++-- | Scores alone are not enough, we also want to pretty-print alignments.+-- An alignment are basically two strings @[String 1, String 2]@, being+-- turned into a whole stream of alignments, using @Char@s for the+-- individual characters being aligned.+--+-- We follow the same theme as in 'sScore', but this time @h = return+-- . id@, that is the choice function @h@ does not (!) make choice but+-- rather returns all alignments. You already heard about @<**@, we'll use+-- it below.++sPretty ∷ Monad m ⇒ Signature m [String] [[String]] Char+sPretty = Signature+  { step_step = \[x,y] (Z:.a :.b ) → [a  :x, b  :y]+  , step_loop = \[x,y] (Z:.a :.()) → [a  :x, '-':y]+  , loop_step = \[x,y] (Z:.():.b ) → ['-':x, b  :y]+  , nil_nil   = const ["",""]+  , h = SM.toList+  }+{-# Inline sPretty #-}++-- | The inside grammar, with efficient table-filling (via+-- 'nwInsideForward') and backtracking. Requests @k@ co-optimal+-- backtrackings, given the inputs @i1@ and @i2@. The @fst@ element+-- returned is the score, the @snd@ are the co-optimal parses.++runNeedlemanWunsch+  ∷ Int+  → String+  → String+  → (Int,[[String]],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+  Mutated (Z:.t) perf eachPerf = nwInsideForward i1 i2+  d = unId $ axiom t+  bs = nwInsideBacktrack i1 i2 t+{-# Noinline runNeedlemanWunsch #-}++-- | The forward or table-filling phase. It is possible to inline this code+-- directly into 'runNeedlemanWunsch'. Here, this phase is separated. If+-- you use @ghc-core@ to examine the @GHC Core@ language, you can search+-- for @nwInsideForward@ and check wether the inside code is optimized+-- well. This is normally /not/ required, and only done here, because these+-- algorithms are used to gauge efficiency of the fusion framework as well.+--+-- For your own code, you can write as done here, or in the way of+-- 'runOutsideNeedlemanWunsch'.++nwInsideForward+  ∷ VU.Vector Char+  → VU.Vector Char+  → 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+  → [[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+-- outside grammar is identical to the inside grammar! This is not+-- generally the case, but here it is. Hence we may just use outside tables+-- and the grammar from above.++runOutsideNeedlemanWunsch+  ∷ Int+  → String+  → String+  → (Int,[[String]],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 #-}++-- | 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+  → 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 (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 ""+  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/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)++
+ 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/properties.hs view
@@ -0,0 +1,14 @@++-- | Test all properties automatically.++module Main where++import Test.Tasty++import QuickCheck.Point   (testgroup_point)++++main :: IO ()+main = defaultMain testgroup_point+