packages feed

ADPfusion 0.2.1.0 → 0.4.0.0

raw patch · 73 files changed

+5601/−2885 lines, 73 filesdep +ADPfusiondep +OrderedBitsdep +bitsdep −deepseqdep −ghc-primdep −repadep ~PrimitiveArraydep ~QuickCheckdep ~basenew-component:exe:Durbinnew-component:exe:Nussinovnew-component:exe:PartNussinov

Dependencies added: ADPfusion, OrderedBits, bits, log-domain, mmorph, monad-primitive, mtl, test-framework, test-framework-quickcheck2, test-framework-th, tuple

Dependencies removed: deepseq, ghc-prim, repa

Dependency ranges changed: PrimitiveArray, QuickCheck, base, primitive, strict, template-haskell, transformers, vector

Files

ADP/Fusion.hs view
@@ -1,16 +1,3 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}  -- | Generalized fusion system for grammars. --@@ -18,54 +5,32 @@ -- 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.------ TODO each combinator should come with a special outer check. Given some--- index (say (i,j), this can then check if i-const >= 0, or j+const<=n, or--- i+const<=j. That should speed up everything that uses GChr combinators.--- Separating out this check means that certain inner loops can run without any--- conditions and just jump.  module ADP.Fusion-  -- basic combinators-  ( (<<<)-  , (<<#)-  , (|||)-  , (...)-  , (~~)-  , (%)-  -- filters-  , check-  -- parsers-  , chr-  , chrLeft-  , chrRight-  , peekL-  , peekR-  , empty-  , region-  , sregion---  , Tbl (..)---  , BtTbl (..)-  , MTbl (..)-  , ENE (..)-  , ENZ (..)-  , None (..)+  ( module ADP.Fusion+  , module ADP.Fusion.Apply+  , module ADP.Fusion.Base+  , module ADP.Fusion.Term+  , module ADP.Fusion.SynVar+  , module ADP.Fusion.TH   ) where -import Data.Strict.Tuple-import GHC.Exts (inline)+import           Data.Strict.Tuple+import           GHC.Exts (inline) import qualified Data.Vector.Fusion.Stream.Monadic as S -import ADP.Fusion.Apply-import ADP.Fusion.Chr-import ADP.Fusion.Classes-import ADP.Fusion.Empty-import ADP.Fusion.Region-import ADP.Fusion.Table-import ADP.Fusion.None+import           ADP.Fusion.Apply+import           ADP.Fusion.Base+import           ADP.Fusion.SynVar+import           ADP.Fusion.Term+import           ADP.Fusion.TH +import qualified Data.Vector.Unboxed as VU +import           Data.PrimitiveArray ++ -- | Apply a function to symbols on the RHS of a production rule. Builds the -- stack of symbols from 'xs' using 'build', then hands this stack to -- 'mkStream' together with the initial 'iniT' telling 'mkStream' that we are@@ -74,17 +39,17 @@ -- function 'f'.  infixl 8 <<<-(<<<) f xs = \ij -> outerCheck (checkValidIndex (build xs) ij) . S.map (apply (inline f) . getArg) . mkStream (build xs) (outer ij) $ ij+(<<<) f xs = \lu ij -> S.map (apply (inline f) . getArg) . mkStream (build xs) (initialContext ij) lu $ ij {-# INLINE (<<<) #-}  infixl 8 <<#-(<<#) f xs = \ij -> outerCheck (checkValidIndex (build xs) ij) . S.mapM (apply (inline f) . getArg) . mkStream (build xs) (outer ij) $ ij+(<<#) f xs = \lu ij -> S.mapM (apply (inline f) . getArg) . mkStream (build xs) (initialContext ij) lu $ ij {-# INLINE (<<#) #-}  -- | Combine two RHSs to give a choice between parses.  infixl 7 |||-(|||) xs ys = \ij -> xs ij S.++ ys ij+(|||) xs ys = \lu ij -> xs lu ij S.++ ys lu ij {-# INLINE (|||) #-}  -- | Applies the objective function 'h' to a stream 's'. The objective function@@ -92,14 +57,14 @@ -- things).  infixl 5 ...-(...) s h = h . s+(...) 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 #-}+-- -- | 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. @@ -112,11 +77,4 @@ infixl 9 % (%) = (:!:) {-# INLINE (%) #-}-------
ADP/Fusion/Apply.hs view
@@ -1,10 +1,8 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}  module ADP.Fusion.Apply where -import Data.Array.Repa.Index+--import Data.Array.Repa.Index+import Data.PrimitiveArray (Z(..), (:.)(..))
+ ADP/Fusion/Base.hs view
@@ -0,0 +1,15 @@++module ADP.Fusion.Base+  ( module ADP.Fusion.Base.Classes+  , module ADP.Fusion.Base.Multi+  , module ADP.Fusion.Base.Point+  , module ADP.Fusion.Base.Set+  , module ADP.Fusion.Base.Subword+  ) where++import ADP.Fusion.Base.Classes+import ADP.Fusion.Base.Multi+import ADP.Fusion.Base.Point+import ADP.Fusion.Base.Set+import ADP.Fusion.Base.Subword+
+ ADP/Fusion/Base/Classes.hs view
@@ -0,0 +1,142 @@++module ADP.Fusion.Base.Classes where++import           Data.Strict.Tuple+import           Data.Vector.Fusion.Stream.Size+import qualified Data.Vector.Fusion.Stream.Monadic as S++import           Data.PrimitiveArray++++data OutsideContext s+  = OStatic     s+  | ORightOf    s+  | OFirstLeft  s+  | OLeftOf     s++data InsideContext s+  = IStatic   s+  | IVariable s++data ComplementContext+  = Complemented++class RuleContext i where+  type Context i :: *+  initialContext :: i -> Context i++-- | During construction of the stream, we need to extract individual elements+-- from symbols in production rules. An element in a stream is fixed by both,+-- the type @x@ of the actual argument we want to grab (say individual+-- characters we parse from an input) and the type of indices @i@ we use.+--+-- @Elm@ data constructors are all eradicated during fusion and should never+-- show up in CORE.++class Element x i where+  data Elm x i :: *+  type Arg x :: *+  getArg :: Elm x i -> Arg x+  getIdx :: Elm x i -> i+  getOmx :: Elm x i -> i++-- | @mkStream@ creates the actual stream of elements (@Elm@) that will be fed+-- to functions on the left of the @(<<<)@ operator. Streams work over all+-- monads and are specialized for each combination of arguments @x@ and indices+-- @i@.++class (Monad m) => MkStream m x i where+  mkStream :: x -> Context i -> i -> i -> S.Stream m (Elm x i)++-- | Finally, we need to be able to correctly build together symbols on the+-- right-hand side of the @(<<<)@ operator.+--+-- The default makes sure that the last (or only) argument left over is+-- correctly assigned a @Z@ to terminate the symbol stack.++class Build x where+  type Stack x :: *+  type Stack x = S :!: x+  build :: x -> Stack x+  default build :: (Stack x ~ (S :!: x)) => x -> Stack x+  build x = S :!: x+  {-# Inline build #-}++instance Build x => Build (x:!:y) where+  type Stack (x:!:y) = Stack x :!: y+  build (x:!:y) = build x :!: y+  {-# Inline build #-}++-- | Similar to 'Z', but terminates an argument stack.++data S = S+  deriving (Eq,Show)++instance+  (+  ) => Element S i where+  data Elm S i = ElmS !i !i+  type Arg S   = Z+  getArg (ElmS _ _) = Z+  getIdx (ElmS i _) = i+  getOmx (ElmS _ o) = o+  {-# Inline getArg #-}+  {-# Inline getIdx #-}+  {-# Inline getOmx #-}++deriving instance Show ix => Show (Elm S ix)++-- | 'staticCheck' acts as a static filter. If 'b' is true, we keep all stream+-- elements. If 'b' is false, we discard all stream elements.++staticCheck :: Monad m => Bool -> S.Stream m a -> S.Stream m a+staticCheck b (S.Stream step t n) = b `seq` S.Stream snew (CheckLeft (b:.t)) (toMax n) where+  {-# Inline [0] snew #-}+  snew (CheckLeft  (False:._)) = return $ S.Done+  snew (CheckLeft  (True :.s)) = return $ S.Skip (CheckRight s)+  snew (CheckRight s         ) = do r <- step s+                                    case r of+                                      S.Yield x s' -> return $ S.Yield x (CheckRight s')+                                      S.Skip    s' -> return $ S.Skip    (CheckRight s')+                                      S.Done       -> return $ S.Done+{-# INLINE staticCheck #-}++data StaticCheck a b = CheckLeft a | CheckRight b+++-- | Constrains the behaviour of the memoizing tables. They may be 'EmptyOk' if+-- @i==j@ is allowed (empty subwords or similar); or they may need 'NonEmpty'+-- indices, or finally they can be 'OnlyZero' (only @i==j@ allowed) which is+-- useful in multi-dimensional casese.++data TableConstraint+  = EmptyOk+  | NonEmpty+  | OnlyZero+  deriving (Eq,Show)++minSize :: TableConstraint -> Int+minSize NonEmpty = 1+minSize _        = 0+{-# INLINE minSize #-}++class ModifyConstraint t where+  toNonEmpty :: t -> t+  toEmpty    :: t -> t++-- |++type family   TblConstraint x       :: *++type instance TblConstraint (is:.i)        =  TblConstraint is :. TblConstraint i+type instance TblConstraint Z              = Z+type instance TblConstraint (Outside o)    = TblConstraint o+type instance TblConstraint (Complement o) = TblConstraint o++-- TODO move into the sub-modules++type instance TblConstraint PointL      = TableConstraint+type instance TblConstraint PointR      = TableConstraint+type instance TblConstraint Subword     = TableConstraint+
+ ADP/Fusion/Base/Multi.hs view
@@ -0,0 +1,189 @@++module ADP.Fusion.Base.Multi where++import qualified Data.Vector.Fusion.Stream.Monadic as S+import           Data.Strict.Tuple++import           Data.PrimitiveArray++import           ADP.Fusion.Base.Classes++++-- * Multi-dimensional extension++-- | Terminates a multi-dimensional terminal symbol stack.++data M = M+  deriving (Eq,Show)++infixl 2 :|++-- | Terminal symbols are stacked together with @a@ tails and @b@ head.++data TermSymbol a b = a :| b+  deriving (Eq,Show)++instance Build (TermSymbol a b)++-- | Extracts the type of a multi-dimensional terminal argument.++type family   TermArg x :: *+type instance TermArg M                = Z++instance (Element ls i) => Element (ls :!: TermSymbol a b) i where+  data Elm (ls :!: TermSymbol a b) i = ElmTS !(TermArg (TermSymbol a b)) !i !i !(Elm ls i)+  type Arg (ls :!: TermSymbol a b)   = Arg ls :. TermArg (TermSymbol a b)+  getArg (ElmTS a _ _ ls) = getArg ls :. a+  getIdx (ElmTS _ i _ _ ) = i+  getOmx (ElmTS _ _ o _ ) = o+  {-# INLINE getArg #-}+  {-# INLINE getIdx #-}++deriving instance (Show i, Show (TermArg (TermSymbol a b)), Show (Elm ls i)) => Show (Elm (ls :!: TermSymbol a b) i)++instance+  ( Monad m+  , MkStream m ls i+  , Element ls i+  , TerminalStream m (TermSymbol a b) i+  , TermStaticVar (TermSymbol a b) i+  ) => MkStream m (ls :!: TermSymbol a b) i where+  mkStream (ls :!: ts) sv lu i+    = S.map fromTerminalStream+    . terminalStream ts sv i+    . S.map toTerminalStream+    $ mkStream ls (termStaticVar ts sv i) lu (termStreamIndex ts sv i)+  {-# Inline mkStream #-}++-- | Handles each individual argument within a stack of terminal symbols.++class TerminalStream m t i where+  terminalStream :: t -> Context i -> i -> S.Stream m (S5 s j j i i) -> S.Stream m (S6 s j j i i (TermArg t))++iPackTerminalStream a sv    (ii:._)  = terminalStream a sv ii     . S.map (\(S5 s zi zo    (is:.i)     (os:.o) ) -> S5 s (zi:.i) (zo:.o)    is     os )+{-# Inline iPackTerminalStream #-}++oPackTerminalStream a sv (O (is:.i)) = terminalStream a sv (O is) . S.map (\(S5 s zi zo (O (is:.i)) (O (os:.o))) -> S5 s (zi:.i) (zo:.o) (O is) (O os))+{-# Inline oPackTerminalStream #-}++instance (Monad m) => TerminalStream m M Z where+  terminalStream M _ Z = S.map (\(S5 s j1 j2 Z Z) -> S6 s j1 j2 Z Z Z)+  {-# INLINE terminalStream #-}++instance (Monad m) => TerminalStream m M (Outside Z) where+  terminalStream M _ (O Z) = S.map (\(S5 s j1 j2 (O Z) (O Z)) -> S6 s j1 j2 (O Z) (O Z) Z)+  {-# INLINE terminalStream #-}++instance Monad m => MkStream m S Z where+  mkStream _ _ _ _ = S.singleton (ElmS Z Z)+  {-# INLINE mkStream #-}++instance Monad m => MkStream m S (Outside Z) where+  mkStream _ _ _ _ = S.singleton (ElmS (O Z) (O Z))+  {-# INLINE mkStream #-}++-- | For multi-dimensional terminals we need to be able to calculate how the+-- static/variable signal changes and if the index for the inner part needs to+-- be modified.++class TermStaticVar t i where+  termStaticVar   :: t -> Context i -> i -> Context i+  termStreamIndex :: t -> Context i -> i -> i++instance TermStaticVar M Z where+  termStaticVar   _ _ _ = Z+  termStreamIndex _ _ _ = Z+  {-# INLINE termStaticVar #-}+  {-# INLINE termStreamIndex #-}++instance TermStaticVar M (Outside Z) where+  termStaticVar   _ _ _ = Z+  termStreamIndex _ _ _ = O Z+  {-# INLINE termStaticVar #-}+  {-# INLINE termStreamIndex #-}++instance+  ( TermStaticVar a is+  , TermStaticVar b i+  ) => TermStaticVar (TermSymbol a b) (is:.i) where+  termStaticVar   (a:|b) (vs:.v) (is:.i) = termStaticVar   a vs is :. termStaticVar   b v i+  termStreamIndex (a:|b) (vs:.v) (is:.i) = termStreamIndex a vs is :. termStreamIndex b v i+  {-# INLINE termStaticVar #-}+  {-# INLINE termStreamIndex #-}++instance+  ( TermStaticVar a (Outside is)+  , TermStaticVar b (Outside i)+  ) => TermStaticVar (TermSymbol a b) (Outside (is:.i)) where+  termStaticVar   (a:|b) (vs:.v) (O (is:.i)) = termStaticVar   a vs (O is) :. termStaticVar   b v (O i)+  termStreamIndex (a:|b) (vs:.v) (O (is:.i)) =+    let (O js) = termStreamIndex a vs (O is)+        (O j)  = termStreamIndex b v (O i)+    in O (js:.j)+  {-# INLINE termStaticVar #-}+  {-# INLINE termStreamIndex #-}++data S4 a b c d     = S4 !a !b !c !d++data S5 a b c d e   = S5 !a !b !c !d !e++data S6 a b c d e f = S6 !a !b !c !d !e !f++fromTerminalStream (S6 s Z Z i o e) = ElmTS e i o s+{-# INLINE fromTerminalStream #-}++toTerminalStream s = S5 s Z Z (getIdx s) (getOmx s)+{-# INLINE toTerminalStream #-}++instance RuleContext Z where+  type Context Z = Z+  initialContext _ = Z+  {-# INLINE initialContext #-}++instance RuleContext (Outside Z) where+  type Context (Outside Z) = Z+  initialContext _ = Z+  {-# INLINE initialContext #-}++instance (RuleContext is, RuleContext i) => RuleContext (is:.i) where+  type Context (is:.i) = Context is:.Context i+  initialContext (is:.i) = initialContext is:.initialContext i+  {-# INLINE initialContext #-}++instance (RuleContext (Outside is), RuleContext (Outside i)) => RuleContext (Outside (is:.i)) where+  type Context (Outside (is:.i)) = Context (Outside is):.Context (Outside i)+  initialContext (O (is:.i)) = initialContext (O is):.initialContext (O i)+  {-# INLINE initialContext #-}++class TableStaticVar i where+  tableStaticVar   ::                    Context i -> i -> Context i+  tableStreamIndex :: TblConstraint i -> Context i -> i -> i++instance TableStaticVar Z where+  tableStaticVar     _ _ = Z+  tableStreamIndex _ _ _ = Z+  {-# INLINE [0] tableStaticVar   #-}+  {-# INLINE [0] tableStreamIndex #-}++instance TableStaticVar (Outside Z) where+  tableStaticVar     _ _ = Z+  tableStreamIndex _ _ _ = O Z+  {-# INLINE [0] tableStaticVar   #-}+  {-# INLINE [0] tableStreamIndex #-}++instance (TableStaticVar is, TableStaticVar i) => TableStaticVar (is:.i) where+  tableStaticVar           (vs:.v) (is:.i) = tableStaticVar      vs is :. tableStaticVar     v i+  tableStreamIndex (cs:.c) (vs:.v) (is:.i) = tableStreamIndex cs vs is :. tableStreamIndex c v i+  {-# INLINE [0] tableStaticVar   #-}+  {-# INLINE [0] tableStreamIndex #-}++instance (TableStaticVar (Outside is), TableStaticVar (Outside i)) => TableStaticVar (Outside (is:.i)) where+  tableStaticVar           (vs:.v) (O (is:.i)) = tableStaticVar      vs (O is) :. tableStaticVar     v (O i)+  tableStreamIndex (cs:.c) (vs:.v) (O (is:.i)) =+    let (O js) = tableStreamIndex cs vs (O is)+        (O j)  = tableStreamIndex c  v  (O i)+    in O (js:.j)+  {-# INLINE [0] tableStaticVar   #-}+  {-# INLINE [0] tableStreamIndex #-}+
+ ADP/Fusion/Base/Point.hs view
@@ -0,0 +1,112 @@++module ADP.Fusion.Base.Point where++import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..),flatten)+import Data.Vector.Fusion.Stream.Size+import Debug.Trace+import Prelude hiding (map,filter)++import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Base.Classes+import ADP.Fusion.Base.Multi++++instance RuleContext PointL where+  type Context PointL = InsideContext Int+  initialContext _ = IStatic 0+  {-# Inline initialContext #-}++instance RuleContext (Outside PointL) where+  type Context (Outside PointL) = OutsideContext Int+  initialContext _ = OStatic 0+  {-# Inline initialContext #-}++instance RuleContext (Complement PointL) where+  type Context (Complement PointL) = ComplementContext+  initialContext _ = Complemented+  {-# Inline initialContext #-}++++instance (Monad m) => MkStream m S PointL where+  mkStream S (IStatic d) (PointL u) (PointL j)+    = staticCheck (j>=0 && j<=d) . singleton $ ElmS (PointL 0) (PointL 0)+  mkStream S (IVariable _) (PointL u) (PointL j)+    = staticCheck (0<=j) . singleton $ ElmS (PointL 0) (PointL 0)+  {-# Inline mkStream #-}++instance (Monad m) => MkStream m S (Outside PointL) where+  mkStream S (OStatic d) (O (PointL u)) (O (PointL i))+    = staticCheck (i>=0 && i+d<=u && u == i) . singleton $ ElmS (O $ PointL i) (O . PointL $ i+d)+  mkStream S (OFirstLeft d) (O (PointL u)) (O (PointL i))+    = staticCheck (i>=0 && i+d<=u) . singleton $ ElmS (O $ PointL i) (O . PointL $ i+d)+  {-# Inline mkStream #-}++++instance+  ( Monad m+  , MkStream m S is+  , Context (is:.PointL) ~ (Context is:.(InsideContext Int))+  ) => MkStream m S (is:.PointL) where+  mkStream S (vs:.IStatic d) (lus:.PointL u) (is:.PointL i)+    = staticCheck (i>=0 && i<=d && i<=u)+    . map (\(ElmS zi zo) -> ElmS (zi:.PointL 0) (zo:.PointL 0))+    $ mkStream S vs lus is+  {-+  mkStream S (vs:.IVariable ) (lus:.PointL u) (is:.PointL i)+    = flatten mk step Unknown $ mkStream S vs lus is+    where mk e = i `seq` return (e,i)+          step (ElmS zi zo,k )+            | k>=0 && k<=u = return $ Yield (ElmS (zi:.PointL k) (zo:.PointL 0)) (ElmS zi zo, -1)+            | otherwise    = return $ Done+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  -}+  -- TODO here, we have a problem in the interplay of @staticCheck@ or+  -- @flatten@ and how we modify @is@. Apparently, once we demand to know+  -- about @i@, fusion breaks down.+  mkStream S (vs:.IVariable d) (lus:.PointL u) (is:.PointL i)+    = staticCheck (i>=0 && i<=u)+    $ map (\(ElmS zi zo) -> ElmS (zi:.PointL 0) (zo:.PointL 0))+    $ mkStream S vs lus is+  {-# INLINE mkStream #-}++instance+  ( Monad m+  , MkStream m S (Outside is)+  , Context (Outside (is:.PointL)) ~ (Context (Outside is) :. OutsideContext Int)+  ) => MkStream m S (Outside (is:.PointL)) where+  mkStream S (vs:.OStatic d) (O (lus:.PointL u)) (O (is:.PointL i))+    = staticCheck (i>=0 && i+d == u)+    . map (\(ElmS (O zi) (O zo)) -> ElmS (O (zi:.PointL i)) (O (zo:.(PointL $ i+d))))+    $ mkStream S vs (O lus) (O is)+  mkStream S (vs:.OFirstLeft d) (O (us:.PointL u)) (O (is:.PointL i))+    = staticCheck (i>=0 && i+d<=u)+    . map (\(ElmS (O zi) (O zo)) -> ElmS (O (zi:.PointL i)) (O (zo:.(PointL $ i+d))))+    $ mkStream S vs (O us) (O is)+  {-# Inline mkStream #-}++instance TableStaticVar PointL where+  tableStaticVar (IStatic   d) _ = IVariable d+  tableStaticVar (IVariable d) _ = IVariable d+  -- NOTE this code used to destroy fusion. If we inline tableStreamIndex+  -- very late (after 'mkStream', probably) then everything works out.+  tableStreamIndex c _ (PointL j)+    | c==EmptyOk  = PointL j+    | c==NonEmpty = PointL $ j-1+    | c==OnlyZero = PointL j -- this should then actually request a size in 'tableStaticVar' ...+  {-# INLINE [0] tableStaticVar   #-}+  {-# INLINE [0] tableStreamIndex #-}++instance TableStaticVar (Outside PointL) where+  tableStaticVar     (OStatic d) _ = OFirstLeft d+  tableStreamIndex c _ (O (PointL j))+    | c==EmptyOk  = O (PointL j)+    | c==NonEmpty = O (PointL $ j-1)+    | c==OnlyZero = O (PointL j) -- this should then actually request a size in 'tableStaticVar' ...+  {-# INLINE [0] tableStaticVar   #-}+  {-# INLINE [0] tableStreamIndex #-}+
+ ADP/Fusion/Base/Set.hs view
@@ -0,0 +1,103 @@++-- | The @Context@ for a @BitSet@ is the number of bits we should reserve+-- for the more right-most symbols, which request a number of reserved+-- bits.++module ADP.Fusion.Base.Set where++import Data.Vector.Fusion.Stream.Monadic (singleton,filter,enumFromStepN,map,unfoldr)+import Data.Vector.Fusion.Stream.Size+import Debug.Trace+import Prelude hiding (map,filter)+import Data.Bits++import Data.PrimitiveArray++import ADP.Fusion.Base.Classes+import ADP.Fusion.Base.Multi++++type instance TblConstraint BitSet                              = TableConstraint+type instance TblConstraint (BitSet:>Interface i:>Interface j)  = TableConstraint++++instance RuleContext BitSet where+  type Context BitSet = InsideContext Int+  initialContext _ = IStatic 0+  {-# Inline initialContext #-}++instance RuleContext (Outside BitSet) where+  type Context (Outside BitSet) = OutsideContext ()+  initialContext _ = OStatic ()+  {-# Inline initialContext #-}++instance RuleContext (Complement BitSet) where+  type Context (Complement BitSet) = ComplementContext+  initialContext _ = Complemented+  {-# Inline initialContext #-}++++instance RuleContext (BS2I First Last) where+  type Context (BS2I First Last) = InsideContext Int+  initialContext _ = IStatic 0+  {-# Inline initialContext #-}++instance RuleContext (Outside (BS2I First Last)) where+  type Context (Outside (BS2I First Last)) = OutsideContext ()+  initialContext _ = OStatic ()+  {-# Inline initialContext #-}++instance RuleContext (Complement (BS2I First Last)) where+  type Context (Complement (BS2I First Last)) = ComplementContext+  initialContext _ = Complemented+  {-# Inline initialContext #-}++++instance+  ( Monad m+  ) => MkStream m S BitSet where+  mkStream S (IStatic c) u s+    = staticCheck (c <= popCount s) . singleton $ ElmS s 0+  mkStream S (IVariable c) u s+    = staticCheck (c <= popCount s) . singleton $ ElmS 0 0+  {-# Inline mkStream #-}++++instance+  ( Monad m+  ) => MkStream m S (BS2I First Last) where+  mkStream S (IStatic rp) u sij@(s:>Iter i:>j)+    = staticCheck (popCount s == 0 && rp == 0) . singleton $ ElmS (0:>Iter i:>Iter i) undefbs2i+  mkStream S (IVariable rp) u sij@(s:>Iter i:>j)+    = staticCheck (popCount s >= rp) . singleton $ ElmS (0:>Iter i:>Iter i) undefbs2i+  {-# Inline mkStream #-}++instance+  ( Monad m+  ) => MkStream m S (Outside (BS2I First Last)) where++instance+  ( Monad m+  ) => MkStream m S (Complement (BS2I First Last)) where++++-- | An undefined bitset with 2 interfaces.++undefbs2i :: BS2I f l+undefbs2i = (-1) :> (-1) :> (-1)+{-# Inline undefbs2i #-}++undefi :: Interface i+undefi = (-1)+{-# Inline undefi #-}++-- | We sometimes need ++data ThisThatNaught a b = This a | That b | Naught+
+ ADP/Fusion/Base/Subword.hs view
@@ -0,0 +1,75 @@++-- | Instances to allow 'Subword's to be used as index structures in+-- @ADPfusion@.++module ADP.Fusion.Base.Subword where++import Data.Vector.Fusion.Stream.Monadic (singleton,filter,enumFromStepN,map,unfoldr)+import Data.Vector.Fusion.Stream.Size+import Debug.Trace+import Prelude hiding (map,filter)++import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Base.Classes+import ADP.Fusion.Base.Multi++++instance RuleContext Subword where+  type Context Subword = InsideContext ()+  initialContext _ = IStatic ()+  {-# Inline initialContext #-}++instance RuleContext (Outside Subword) where+  type Context (Outside Subword) = OutsideContext (Int:.Int)+  initialContext _ = OStatic (0:.0)+  {-# Inline  initialContext #-}++instance RuleContext (Complement Subword) where+  type Context (Complement Subword) = ComplementContext+  initialContext _ = Complemented+  {-# Inline initialContext #-}++-- TODO write instance++-- instance RuleContext (Complement Subword)++++instance (Monad m) => MkStream m S Subword where+  mkStream S (IStatic ()) (Subword (_:.h)) (Subword (i:.j))+    = staticCheck (i>=0 && i==j && j<=h) . singleton $ ElmS (subword i i) (subword 0 0)+  -- NOTE it seems that a static check within an @IVariable@ context+  -- destroys fusion; maybe because of the outer flatten? We don't actually+  -- need a static check anyway because the next flatten takes care of+  -- conditional checks. @filter@ on the other hand, does work.+  -- TODO test with and without filter using quickcheck+  mkStream S (IVariable ()) (Subword (_:.h)) (Subword (i:.j))+    = filter (const $ 0<=i && i<=j && j<=h) . singleton $ ElmS (subword i i) (subword 0 0)+  {-# Inline mkStream #-}++instance (Monad m) => MkStream m S (Outside Subword) where+  mkStream S (OStatic (di:.dj)) (O (Subword (_:.h))) (O (Subword (i:.j)))+    = staticCheck (i==0 && j+dj==h) . singleton $ ElmS (O $ subword i j) (O $ Subword (i:.j+dj))+  mkStream S (OFirstLeft (di:.dj)) (O (Subword (_:.h))) (O (Subword (i:.j)))+    = let i' = i-di+      in  staticCheck (0 <= i' && i<=j && j+dj<=h) . singleton $ ElmS (O $ subword i' i') (O $ subword i' i')+  mkStream S (OLeftOf (di:.dj)) (O (Subword (_:.h))) (O (Subword (i:.j)))+    = let i' = i-di+      in  staticCheck (0 <= i' && i<=j && j+dj<=h)+    $ map (\k -> ElmS (O $ subword 0 k) (O $ subword k j))+    $ enumFromStepN 0 1 (i'+1)+  {-# Inline mkStream #-}++instance (Monad m) => MkStream m S (Complement Subword) where+  mkStream S Complemented (C (Subword (_:.h))) (C (Subword (i:.j)))+    = map (\(k,l) -> ElmS (C $ subword k l) (C $ subword k l))+    $ unfoldr go (i,i)+    where go (k,l)+            | k >h || k >j = Nothing+            | l==h || l==j = Just ( (k,l) , (k+1,k+1) )+            | otherwise    = Just ( (k,l) , (k  ,l+1) )+          {-# Inline [0] go #-}+  {-# Inline mkStream #-}+
− ADP/Fusion/Chr.hs 
@@ -1,306 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-}--module ADP.Fusion.Chr where--import Data.Array.Repa.Index-import Data.Strict.Tuple-import qualified Data.Vector.Fusion.Stream.Monadic as S-import qualified Data.Vector.Unboxed as VU-import qualified Data.Vector.Generic as VG-import Data.Strict.Maybe-import Prelude hiding (Maybe(..))--import Data.Array.Repa.Index.Subword--import ADP.Fusion.Classes--import Debug.Trace------ | Parses a single character.--chr xs = GChr (VG.unsafeIndex) xs-{-# INLINE chr #-}---- | Parses a single character and returns the character to the left in a--- strict Maybe.--chrLeft xs = GChr f xs where-  f xs k = ( xs VG.!? (k-1)-           , VG.unsafeIndex xs k-           )-  {-# INLINE f #-}-{-# INLINE chrLeft #-}---- With default character--chrLeftD d xs = GChr f xs where-  f xs k = ( Prelude.maybe d id $ xs VG.!? (k-1)-           , VG.unsafeIndex xs k-           )-  {-# INLINE f #-}-{-# INLINE chrLeftD #-}---- | Parses a single character and returns the character to the right in a--- strict Maybe.--chrRight xs = GChr f xs where-  f xs k = ( VG.unsafeIndex xs k-           , xs VG.!? (k+1)-           )-  {-# INLINE f #-}-{-# INLINE chrRight #-}---- | A generic Character parser that reads a single character but allows--- passing additional information.--data GChr r x where -- = forall v . VG.Vector v x =>-  GChr :: VG.Vector v x => !(v x -> Int -> r) -> !(v x) -> GChr r x--instance Build (GChr r x)--instance-  ( ValidIndex ls Subword-  ) => ValidIndex (ls :!: GChr r x) Subword where-    validIndex (ls :!: GChr _ xs) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =-      i>=a && j<=VG.length xs -c && i+b<=j && validIndex ls abc ij-    {-# INLINE validIndex #-}-    getParserRange (ls :!: GChr _ _) ix = let (a:!:b:!:c) = getParserRange ls ix in (a:!:b+1:!:max 0 (c-1))-    {-# INLINE getParserRange #-}--instance-  ( Elms ls Subword-  ) => Elms (ls :!: GChr r x) Subword where-    data Elm (ls :!: GChr r x) Subword = ElmGChr !(Elm ls Subword) !r !Subword-    type Arg (ls :!: GChr r x) = Arg ls :. r-    getArg !(ElmGChr ls x _) = getArg ls :. x-    getIdx !(ElmGChr _ _ idx) = idx-    {-# INLINE getArg #-}-    {-# INLINE getIdx #-}--instance-  ( Monad m-  , Elms ls Subword-  , MkStream m ls Subword-  ) => MkStream m (ls :!: GChr r x) Subword where-  mkStream !(ls :!: GChr f xs) Outer !ij@(Subword (i:.j)) =-    let dta = f xs (j-1)-    in  dta `seq` S.map (\s -> ElmGChr s dta (subword (j-1) j)) $ mkStream ls Outer (subword i $ j-1)-  mkStream !(ls :!: GChr f xs) (Inner cnc szd) !ij@(Subword (i:.j))-    = S.map (\s -> let Subword (k:.l) = getIdx s-                   in  ElmGChr s (f xs l) (subword l $ l+1)-            )-    $ mkStream ls (Inner cnc szd) (subword i $ j-1)-  {-# INLINE mkStream #-}---- | Wrapping a GChr to allow zero/one behaviour. Parses a character (or not)--- in a strict maybe.--newtype ZeroOne r x = ZeroOne { unZeroOne :: GChr r x }--zoLeft xs = ZeroOne $ chrLeft xs-{-# INLINE zoLeft #-}------ | Generalized peek.--data GPeek r x = GPeek !(VU.Vector x -> Int -> r) !(VU.Vector x) !(Int:!:Int)--instance Build (GPeek r x)--instance-  ( ValidIndex ls Subword-  , VU.Unbox x-  ) => ValidIndex (ls :!: GPeek r x) Subword where-    validIndex (ls :!: GPeek _ xs _) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =-      i>=a && j<VU.length xs -c && i+b<=j && validIndex ls abc ij-    {-# INLINE validIndex #-}-    getParserRange (ls :!: GPeek _ _ (a':!:c')) ix =-      let (a:!:b:!:c) = getParserRange ls ix in (a+a' :!: b :!: (c+c'))-    {-# INLINE getParserRange #-}--instance-  ( Elms ls Subword-  ) => Elms (ls :!: GPeek r x) Subword where-    data Elm (ls :!: GPeek r x) Subword = ElmGPeek !(Elm ls Subword) !r !Subword-    type Arg (ls :!: GPeek r x) = Arg ls :. r-    getArg !(ElmGPeek ls x _) = getArg ls :. x-    getIdx !(ElmGPeek _ _ idx) = idx-    {-# INLINE getArg #-}-    {-# INLINE getIdx #-}--instance-  ( Monad m-  , VU.Unbox x-  , Elms ls Subword-  , MkStream m ls Subword-  ) => MkStream m (ls :!: GPeek r x) Subword where-  mkStream !(ls :!: GPeek f xs _) Outer !ij@(Subword (i:.j)) =-    let dta = f xs (j-1)-    in  dta `seq` S.map (\s -> ElmGPeek s dta (subword j j)) $ mkStream ls Outer ij-  mkStream !(ls :!: GPeek f xs _) (Inner cnc szd) !ij@(Subword (i:.j))-    = S.map (\s -> let (Subword (k:.l)) = getIdx s-                   in  ElmGPeek s (f xs (l-1)) (subword l l)-            )-    $ mkStream ls (Inner cnc szd) ij-  {-# INLINE mkStream #-}---{---- * Parse a single character.--data Chr x = Chr !(VU.Vector x)----chr = Chr---{-# INLINE chr #-}--instance-  ( ValidIndex ls Subword-  , VU.Unbox xs-  ) => ValidIndex (ls :!: Chr xs) Subword where-    validIndex (ls :!: Chr xs) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =-      let-      in  i>=a && j<VU.length xs -c && i+b<=j && validIndex ls abc ij-    {-# INLINE validIndex #-}-    getParserRange (ls :!: Chr xs) ix = let (a:!:b:!:c) = getParserRange ls ix in (a:!:b+1:!:max 0 (c-1))-    {-# INLINE getParserRange #-}--instance Build (Chr x)--instance-  ( Elms ls Subword-  ) => Elms (ls :!: Chr x) Subword where-  data Elm (ls :!: Chr x) Subword = ElmChr !(Elm ls Subword) !x !Subword-  type Arg (ls :!: Chr x) = Arg ls :. x-  getArg !(ElmChr ls x _) = getArg ls :. x-  getIdx !(ElmChr _ _ idx) = idx-  {-# INLINE getArg #-}-  {-# INLINE getIdx #-}---- |------ For 'Outer' cases, we extract the data, 'seq' it and then stream. This moves--- extraction out of the loop.--instance-  ( Monad m-  , Elms ls Subword-  , MkStream m ls Subword-  ) => MkStream m (ls :!: Chr x) Subword where-  mkStream !(ls :!: Chr xs) Outer !ij@(Subword(i:.j)) =-    let dta = VG.unsafeIndex xs (j-1)-    in  dta `seq` S.map (\s -> ElmChr s dta (subword (j-1) j)) $ mkStream ls Outer (subword i $ j-1)-  mkStream !(ls :!: Chr xs) (Inner cnc szd) !ij@(Subword(i:.j))-    = S.map (\s -> let (Subword (k:.l)) = getIdx s-                   in  ElmChr s (VG.unsafeIndex xs l) (subword l $ l+1)-            )-    $ mkStream ls (Inner cnc szd) (subword i $ j-1)-  {-# INLINE mkStream #-}--}------ * Peeking to the left--data PeekL x = PeekL !(VU.Vector x)--peekL = PeekL-{-# INLINE peekL #-}--instance Build (PeekL x)--instance-  ( ValidIndex ls Subword-  , VU.Unbox x-  ) => ValidIndex (ls :!: PeekL x) Subword where-  validIndex (ls :!: PeekL xs) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =-    i>=a && j<=VU.length xs -c && i+b<=j && validIndex ls abc ij-  {-# INLINE validIndex #-}-  getParserRange (ls :!: PeekL xs) ix = let (a:!:b:!:c) = getParserRange ls ix in if b==0 then (a+1:!:b:!:c) else (a:!:b:!:c)-  {-# INLINE getParserRange #-}--instance-  ( Elms ls Subword-  ) => Elms (ls :!: PeekL x) Subword where-  data Elm (ls :!: PeekL x) Subword = ElmPeekL !(Elm ls Subword) !x !Subword-  type Arg (ls :!: PeekL x) = Arg ls :. x-  getArg !(ElmPeekL ls x _) = getArg ls :. x-  getIdx !(ElmPeekL _ _ idx) = idx-  {-# INLINE getArg #-}-  {-# INLINE getIdx #-}--instance-  ( Monad m-  , VU.Unbox x-  , Elms ls Subword-  , MkStream m ls Subword-  ) => MkStream m (ls :!: PeekL x) Subword where-  mkStream !(ls :!: PeekL xs) Outer !ij@(Subword(i:.j)) =-    let dta = VU.unsafeIndex xs (j-1)-    in  dta `seq` S.map (\s -> ElmPeekL s dta (subword j j)) $ mkStream ls Outer ij-  mkStream !(ls :!: PeekL xs) (Inner cnc szd) !ij@(Subword(i:.j))-    = S.map (\s -> let (Subword (k:.l)) = getIdx s-                   in  ElmPeekL s (VU.unsafeIndex xs $ l-1) (subword l l)-            )-    $ mkStream ls (Inner cnc szd) ij-  {-# INLINE mkStream #-}------ * Peeking to the right--data PeekR x = PeekR !(VU.Vector x)--peekR = PeekR-{-# INLINE peekR #-}--instance Build (PeekR x)--instance-  ( ValidIndex ls Subword-  , VU.Unbox x-  ) => ValidIndex (ls :!: PeekR x) Subword where-  validIndex (ls :!: PeekR xs) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =-    i>=a && j<=VU.length xs -c && i+b<=j && validIndex ls abc ij-  {-# INLINE validIndex #-}-  getParserRange (ls :!: PeekR xs) ix = let (a:!:b:!:c) = getParserRange ls ix in (a:!:b:!:c+1)-  {-# INLINE getParserRange #-}--instance-  ( Elms ls Subword-  ) => Elms (ls :!: PeekR x) Subword where-  data Elm (ls :!: PeekR x) Subword = ElmPeekR !(Elm ls Subword) !x !Subword-  type Arg (ls :!: PeekR x) = Arg ls :. x-  getArg !(ElmPeekR ls x _) = getArg ls :. x-  getIdx !(ElmPeekR _ _ idx) = idx-  {-# INLINE getArg #-}-  {-# INLINE getIdx #-}--instance-  ( Monad m-  , VU.Unbox x-  , Elms ls Subword-  , MkStream m ls Subword-  ) => MkStream m (ls :!: PeekR x) Subword where-  mkStream !(ls :!: PeekR xs) Outer !ij@(Subword(i:.j)) =-    let dta = VU.unsafeIndex xs j-    in  dta `seq` S.map (\s -> ElmPeekR s dta (subword j j)) $ mkStream ls Outer ij-  mkStream !(ls :!: PeekR xs) (Inner cnc szd) !ij@(Subword(i:.j))-    = S.map (\s -> let (Subword (k:.l)) = getIdx s-                   in  ElmPeekR s (VU.unsafeIndex xs l) (subword l l)-            )-    $ mkStream ls (Inner cnc szd) ij-  {-# INLINE mkStream #-}-
− ADP/Fusion/Classes.hs 
@@ -1,396 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-}--module ADP.Fusion.Classes where--import Data.Array.Repa.Index-import Data.Strict.Maybe-import Data.Strict.Tuple-import Data.Vector.Fusion.Stream.Size-import Prelude hiding (Maybe(..))-import qualified Data.Vector.Fusion.Stream.Monadic as S-import qualified Prelude as P--import Data.Array.Repa.Index.Subword-import Data.Array.Repa.Index.Outside-import Data.Array.Repa.Index.Points------ * Data and type constructors---- | The Inner/Outer handler. We encode three states. We are in 'Outer' or--- right-most position, or 'Inner' position. The 'Inner' position encodes if--- loop conditional 'CheckNoCheck' need to be performed.------ In f <<< Z % table % table, the two tables already perform a conditional--- branch, so that Z/table does not have to check boundary conditions.------ In f <<< Z % table % char, no check is performed in table/char, so Z/table--- needs to perform a boundary check.--data CheckNoCheck-  = Check-  | NoCheck-  deriving (Eq,Show)--data InnerOuter-  = Inner !CheckNoCheck !(Maybe Int)-  | Outer-  deriving (Eq,Show)--data ENE-  = EmptyT-  | NonEmptyT-  | ZeroT-  deriving (Eq,Show)------ * Classes---- |--class Elms x i where-  data Elm x i :: *-  type Arg x :: *-  getArg :: Elm x i -> Arg x-  getIdx :: Elm x i -> i---- |--class Index i where-  type InOut  i :: *-  type ENZ    i :: *-  type PartialIndex i :: *-  type ParserRange i :: *-  outer :: i -> InOut i-  leftPartialIndex  :: i -> PartialIndex i-  rightPartialIndex :: i -> PartialIndex i-  fromPartialIndices :: PartialIndex i -> PartialIndex i -> i--class EmptyENZ enz where-  toEmptyENZ    :: enz -> enz-  toNonEmptyENZ :: enz -> enz---- |--class (Monad m) => MkStream m x i where-  mkStream :: x -> InOut i -> i -> S.Stream m (Elm x i)---- | Build the stack using (%)--class Build x where-  type Stack x :: *-  type Stack x = Z :!: x-  build :: x -> Stack x-  default build :: (Stack x ~ (Z :!: x)) => x -> Stack x-  build x = Z :!: x-  {-# INLINE build #-}---- | 'ValidIndex', via 'validIndex' statically checks if an index 'i' is valid--- for a stack of terminals and non-terminals 'x'. 'validIndex' is used to--- short-circuit streams via 'outerCheck'.--class (Index i) => ValidIndex x i where-  validIndex :: x -> ParserRange i -> i -> Bool-  getParserRange :: x -> i -> ParserRange i------ * Helper functions---- | Correct wrapping of 'validIndex' and 'getParserRange'.--checkValidIndex x i = validIndex x (getParserRange x i) i-{-# INLINE checkValidIndex #-}---- | 'outerCheck' acts as a static filter. If 'b' is true, we keep all stream--- elements. If 'b' is false, we discard all stream elements.--outerCheck :: Monad m => Bool -> S.Stream m a -> S.Stream m a-outerCheck b (S.Stream step sS n) = b `seq` S.Stream snew (Left (b,sS)) Unknown where-  {-# INLINE [1] snew #-}-  snew (Left  (False,s)) = return $ S.Done-  snew (Left  (True ,s)) = return $ S.Skip (Right s)-  snew (Right s        ) = do r <- step s-                              case r of-                                S.Yield x s' -> return $ S.Yield x (Right s')-                                S.Skip    s' -> return $ S.Skip    (Right s')-                                S.Done       -> return $ S.Done-{-# INLINE outerCheck #-}------ * Instances------ ** Unsorted--instance EmptyENZ ENE where-  toEmptyENZ ene  | ene==NonEmptyT = EmptyT-                  | otherwise      = ene-  toNonEmptyENZ ene | ene==EmptyT  = NonEmptyT-                    | otherwise    = ene-  {-# INLINE toEmptyENZ #-}-  {-# INLINE toNonEmptyENZ #-}------ ** PointL--instance Index PointL where-  type InOut PointL = InnerOuter-  type ENZ   PointL = ENE-  type PartialIndex PointL = Int-  type ParserRange  PointL = (Int:!:Int:!:Int)-  outer _ = Outer-  leftPartialIndex (PointL (i:.j)) = i-  rightPartialIndex (PointL (i:.j)) = j-  fromPartialIndices i j = pointL i j-  {-# INLINE outer #-}-  {-# INLINE leftPartialIndex #-}-  {-# INLINE rightPartialIndex #-}-  {-# INLINE fromPartialIndices #-}--instance ValidIndex Z PointL where-  {-# INLINE validIndex #-}-  {-# INLINE getParserRange #-}-  validIndex _ _ _ = True-  getParserRange _ _ = (0 :!: 0 :!: 0)------ ** 'Subword'--instance Index Subword where-  type InOut Subword = InnerOuter-  type ENZ   Subword = ENE-  type PartialIndex Subword = Int-  type ParserRange Subword = (Int :!: Int :!: Int)-  outer _ = Outer-  leftPartialIndex (Subword (i:.j)) = i-  rightPartialIndex (Subword (i:.j)) = j-  fromPartialIndices i j = subword i j-  {-# INLINE outer #-}-  {-# INLINE leftPartialIndex #-}-  {-# INLINE rightPartialIndex #-}-  {-# INLINE fromPartialIndices #-}---- | The bottom of every stack of RHS arguments in a grammar.--instance-  ( Monad m-  ) => MkStream m Z Subword where-  mkStream Z Outer !(Subword (i:.j)) = S.unfoldr step i where-    step !k-      | k==j      = P.Just $ (ElmZ (subword i i), j+1)-      | otherwise = P.Nothing-  mkStream Z (Inner NoCheck Nothing)  !(Subword (i:.j)) = S.singleton $ ElmZ $ subword i i-  mkStream Z (Inner NoCheck (Just z)) !(Subword (i:.j)) = S.unfoldr step i where-    step !k-      | k<=j && k+z>=j = P.Just $ (ElmZ (subword i i), j+1)-      | otherwise      = P.Nothing-  mkStream Z (Inner Check Nothing)   !(Subword (i:.j)) = S.unfoldr step i where-    step !k-      | k<=j      = P.Just $ (ElmZ (subword i i), j+1)-      | otherwise = P.Nothing-  mkStream Z (Inner Check (Just z)) !(Subword (i:.j)) = S.unfoldr step i where-    step !k-      | k<=j && k+z>=j = P.Just $ (ElmZ (subword i i), j+1)-      | otherwise      = P.Nothing-  {-# INLINE mkStream #-}--instance ValidIndex Z Subword where-  {-# INLINE validIndex #-}-  {-# INLINE getParserRange #-}-  validIndex _ _ _ = True-  getParserRange _ _ = (0 :!: 0 :!: 0)------ ** Outside--instance Index Outside where-  type InOut Outside = InnerOuter-  type ENZ   Outside = ENE-  type PartialIndex Outside = Int-  type ParserRange Outside = (Int :!: Int :!: Int)-  outer _ = Outer-  leftPartialIndex (Outside (i:.j)) = error "outside: not sure yet" -- i-  rightPartialIndex (Outside (i:.j)) = error "outside: not sure yet" -- j-  fromPartialIndices i j = error "outside: not sure yet" -- outside i j-  {-# INLINE outer #-}-  {-# INLINE leftPartialIndex #-}-  {-# INLINE rightPartialIndex #-}-  {-# INLINE fromPartialIndices #-}---- | The bottom of every stack of RHS arguments in a grammar.--instance-  ( Monad m-  ) => MkStream m Z Outside where-  {--  mkStream Z Outer !(Outside (i:.j)) = S.unfoldr step i where-    step !k-      | k==j      = P.Just $ (ElmZ (outside i i), j+1)-      | otherwise = P.Nothing-  mkStream Z (Inner NoCheck Nothing)  !(Outside (i:.j)) = S.singleton $ ElmZ $ outside i i-  mkStream Z (Inner NoCheck (Just z)) !(Outside (i:.j)) = S.unfoldr step i where-    step !k-      | k<=j && k+z>=j = P.Just $ (ElmZ (outside i i), j+1)-      | otherwise      = P.Nothing-  mkStream Z (Inner Check Nothing)   !(Outside (i:.j)) = S.unfoldr step i where-    step !k-      | k<=j      = P.Just $ (ElmZ (outside i i), j+1)-      | otherwise = P.Nothing-  mkStream Z (Inner Check (Just z)) !(Outside (i:.j)) = S.unfoldr step i where-    step !k-      | k<=j && k+z>=j = P.Just $ (ElmZ (outside i i), j+1)-      | otherwise      = P.Nothing-  {-# INLINE mkStream #-}-  -}--instance ValidIndex Z Outside where-  {-# INLINE validIndex #-}-  {-# INLINE getParserRange #-}-  validIndex _ _ _ = True-  getParserRange _ _ = (0 :!: 0 :!: 0)------ ** 'Z'--instance Index Z where-  type InOut Z = Z-  type ENZ   Z = Z-  type PartialIndex Z = Z-  type ParserRange Z = Z-  outer Z = Z-  leftPartialIndex Z = Z-  rightPartialIndex Z = Z-  fromPartialIndices Z Z = Z-  {-# INLINE outer #-}-  {-# INLINE leftPartialIndex #-}-  {-# INLINE rightPartialIndex #-}-  {-# INLINE fromPartialIndices #-}--instance EmptyENZ Z where-  toEmptyENZ _ = Z-  toNonEmptyENZ _ = Z-  {-# INLINE toEmptyENZ #-}-  {-# INLINE toNonEmptyENZ #-}--instance-  (-  ) => Elms Z ix where-  data Elm Z ix = ElmZ !ix-  type Arg Z = Z-  getArg !(ElmZ _) = Z-  getIdx !(ElmZ ix) = ix-  {-# INLINE getArg #-}-  {-# INLINE getIdx #-}--instance Monad m => MkStream m Z Z where-  mkStream _ _ _ = S.singleton (ElmZ Z)-  {-# INLINE mkStream #-}--instance ValidIndex Z Z where-  {-# INLINE validIndex #-}-  {-# INLINE getParserRange #-}-  validIndex _ _ _ = True-  getParserRange _ _ = Z------ * Multi-dim instances---- ** '(is:.i)'--instance (Index is, Index i) => Index (is:.i) where-  type InOut (is:.i) = InOut is :. InOut i-  type ENZ   (is:.i) = ENZ   is :. ENZ i-  type PartialIndex (is:.i) = PartialIndex is :. PartialIndex i-  type ParserRange (is:.i) = ParserRange is :. ParserRange i-  outer (is:.i) = outer is :. outer i-  leftPartialIndex (is:.i) = leftPartialIndex is :. leftPartialIndex i-  rightPartialIndex (is:.i) = rightPartialIndex is :. rightPartialIndex i-  fromPartialIndices (is:.i) (js:.j) = fromPartialIndices is js :. fromPartialIndices i j-  {-# INLINE outer #-}-  {-# INLINE leftPartialIndex #-}-  {-# INLINE rightPartialIndex #-}-  {-# INLINE fromPartialIndices #-}--instance (EmptyENZ es, EmptyENZ e) => EmptyENZ (es:.e) where-  toEmptyENZ (es:.e) = toEmptyENZ es :. toEmptyENZ e-  toNonEmptyENZ (es:.e) = toNonEmptyENZ es :. toNonEmptyENZ e-  {-# INLINE toEmptyENZ #-}-  {-# INLINE toNonEmptyENZ #-}--instance (ValidIndex Z is, ValidIndex Z i) => ValidIndex Z (is:.i) where-  {-# INLINE validIndex #-}-  {-# INLINE getParserRange #-}-  validIndex _ _ _ = True-  getParserRange Z (is:.i) = getParserRange Z is :. getParserRange Z i------ ** multi-dim with Subword--instance-  ( Monad m-  , MkStream m Z is-  ) => MkStream m Z (is:.Subword) where-  mkStream Z (io:.Outer) (is:.Subword (i:.j))-    = S.map (\(ElmZ jt) -> ElmZ (jt:.subword i i)) . S.filter (const $ i==j) $ mkStream Z io is-  mkStream Z (io:.Inner NoCheck Nothing) (is:.Subword (i:.j))-    = S.map (\(ElmZ jt) -> ElmZ (jt:.subword i i)) $ mkStream Z io is-  mkStream Z (io:.Inner NoCheck (Just z)) (is:.Subword (i:.j))-    = S.map (\(ElmZ jt) -> ElmZ (jt:.subword i i)) . S.filter (const $ i<=j && i+z>=j) $ mkStream Z io is-  mkStream Z (io:.Inner Check Nothing) (is:.Subword (i:.j))-    = S.map (\(ElmZ jt) -> ElmZ (jt:.subword i i)) . S.filter (const $ i<=j) $ mkStream Z io is-  mkStream Z (io:.Inner Check (Just z)) (is:.Subword (i:.j))-    = S.map (\(ElmZ jt) -> ElmZ (jt:.subword i i)) . S.filter (const $ i<=j && i+z>=j) $ mkStream Z io is-  {-# INLINE mkStream #-}------ ** multi-dim with PointL---- TODO automatically created, check correctness--instance-  ( Monad m-  , MkStream m Z is-  ) => MkStream m Z (is:.PointL) where-  mkStream Z (io:.Outer) (is:.PointL (i:.j))-    = S.map (\(ElmZ jt) -> ElmZ (jt:.pointL i i)) . S.filter (const $ i==j) $ mkStream Z io is-  mkStream Z (io:.Inner NoCheck Nothing) (is:.PointL (i:.j))-    = S.map (\(ElmZ jt) -> ElmZ (jt:.pointL i i)) $ mkStream Z io is-  mkStream Z (io:.Inner NoCheck (Just z)) (is:.PointL (i:.j))-    = S.map (\(ElmZ jt) -> ElmZ (jt:.pointL i i)) . S.filter (const $ i<=j && i+z>=j) $ mkStream Z io is-  mkStream Z (io:.Inner Check Nothing) (is:.PointL (i:.j))-    = S.map (\(ElmZ jt) -> ElmZ (jt:.pointL i i)) . S.filter (const $ i<=j) $ mkStream Z io is-  mkStream Z (io:.Inner Check (Just z)) (is:.PointL (i:.j))-    = S.map (\(ElmZ jt) -> ElmZ (jt:.pointL i i)) . S.filter (const $ i<=j && i+z>=j) $ mkStream Z io is-  {-# INLINE mkStream #-}-------- * Special instances--instance Build x => Build (x:!:y) where-  type Stack (x:!:y) = Stack x :!: y-  build (x:!:y) = build x :!: y-  {-# INLINE build #-}-
− ADP/Fusion/Empty.hs 
@@ -1,56 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-}--module ADP.Fusion.Empty where--import Data.Array.Repa.Index-import Data.Strict.Maybe-import Data.Strict.Tuple-import Prelude hiding (Maybe(..))-import qualified Data.Vector.Fusion.Stream.Monadic as S--import Data.Array.Repa.Index.Subword--import ADP.Fusion.Classes----data Empty = Empty--empty = Empty-{-# INLINE empty #-}--instance-  ( ValidIndex ls Subword-  ) => ValidIndex (ls :!: Empty) Subword where-    validIndex (ls:!:Empty) abc ij@(Subword (i:.j)) = i==j && validIndex ls abc ij-    {-# INLINE validIndex #-}--instance Build Empty--instance-  ( Elms ls Subword-  ) => Elms (ls :!: Empty) Subword where-  data Elm (ls :!: Empty) Subword = ElmEmpty !(Elm ls Subword) !() !Subword-  type Arg (ls :!: Empty) = Arg ls :. ()-  getArg !(ElmEmpty ls () _) = getArg ls :. ()-  getIdx !(ElmEmpty _ _ i)   = i-  {-# INLINE getArg #-}-  {-# INLINE getIdx #-}--instance-  ( Monad m-  , Elms ls Subword-  , MkStream m ls Subword-  ) => MkStream m (ls:!:Empty) Subword where-  mkStream !(ls:!:Empty) Outer !ij@(Subword (i:.j))-    = S.map (\s -> ElmEmpty s () (subword i j))-    $ S.filter (\_ -> i==j)-    $ mkStream ls Outer ij-  {-# INLINE mkStream #-}-
− ADP/Fusion/Examples/Palindrome.hs 
@@ -1,118 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE RecordWildCards #-}--module ADP.Fusion.Examples.Palindrome where--import Data.Vector.Fusion.Stream.Monadic (Stream (..))-import qualified Data.Vector.Fusion.Stream.Monadic as S-import qualified Data.Vector.Unboxed as VU-import qualified Data.Vector as V-import Data.Array.Repa.Index-import Control.Monad-import Control.Monad.Trans.Class-import qualified Control.Monad.Trans.Writer.Lazy as W-import qualified Control.Arrow as A--import Data.PrimitiveArray as PA-import Data.PrimitiveArray.Zero as PA--import ADP.Fusion hiding (empty)-import ADP.Fusion.Empty hiding (empty)-import ADP.Fusion.Chr-import ADP.Fusion.Table-import Data.Array.Repa.Index.Subword-import ADP.Fusion.TH----data SignatureT m x r = Signature-  { pair  :: Char -> x -> Char -> x-  , empty :: () -> x-  , h     :: Stream m x -> m r-  }---- makeAlgebraProduct ''SignatureT--{----- gPalindrome :: Signature m x -> Empty -> Char -> tbl -> (tbl, Subword -> m x)--gPalindrome Signature{..} e c s =-  ( s, (  empty <<< e         |||-          pair  <<< c % s % c ... h-       )-  )-{-# INLINE gPalindrome #-}----aPair :: Monad m => Signature m Int Int-aPair = Signature-  { pair = \l x r -> if l==r then (x+4983) else -999999-  , empty = \() -> 4711-  , h = S.foldl' max (-888888)-  }-{-# INLINE aPair #-}--aPretty :: Monad m => Signature m String (Stream m String)-aPretty = Signature-  { pair = \l x r -> "(" ++ x ++ ")"-  , empty = \() -> ""-  , h = return . id-  }--(<**) :: (Monad m, CombElem x' x) => Signature m x x' -> Signature m y y' -> Signature m (x,Stream m y) y'-(<**) x y = Signature-  { pair = \l (zx,zy) r -> (pair x l zx r, S.map (\z -> pair y l z r) zy)-  , empty = \() -> (empty x (), S.singleton $ empty y ())-  , h = \zs -> do hfst <- h x $ S.map fst zs-                  h y $ S.concatMap snd . S.filter (combElem hfst . fst) $ zs-  }-{-# INLINE (<**) #-}--(***) :: (Monad m) => Signature m x x' -> Signature m y y' -> Signature m (x,y) (x',y')-(***) x y = Signature-  { pair = \l (zx,zy) r -> (pair x l zx r, pair y l zy r)-  , empty = \() -> (empty x (), empty y ())---  , h = \zs -> do hfst <- h x $ S.map fst zs---                  let phfs = S.concatMap snd . S.filter (combElem hfst . fst) $ zs---                  hsnd <- h y phfs-  }-{-# INLINE (***) #-}--class CombElem x y where-  combElem :: x -> y -> Bool--instance (Eq x) => CombElem x x where-  combElem = (==)--instance (VU.Unbox x, Eq x) => CombElem (VU.Vector x) x where-  combElem xs y = VU.elem y xs--instance (Eq x) => CombElem (V.Vector x) x where-  combElem xs y = V.elem y xs--palindromeFill :: VU.Vector Char -> IO (PA.Unboxed (Z:.Subword) Int)-palindromeFill inp = do-  let n = VU.length inp-  !t' <- newWithM (Z:.subword 0 0) (Z:.subword 0 n) 0-  let t= mTblSw EmptyT t'-  let b = chr inp-  let e = Empty-  fillTable $ gPalindrome aPair e b t-  freeze t'-{-# NOINLINE palindromeFill #-}--fillTable (MTbl _ tbl, f) = do-  let (_,Z:.Subword (0:.n)) = boundsM tbl-  forM_ [n,n-1..0] $ \i -> forM_ [i..n] $ \j -> do-    (f $ subword i j) >>= writeM tbl (Z:.subword i j)-{-# INLINE fillTable #-}---}-
− ADP/Fusion/Examples/TwoDim.hs 
@@ -1,98 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeOperators #-}---- | This is not really a working example, but rather to check the GHC-Core for--- fusion.----module ADP.Fusion.Examples.TwoDim where-module Main where--import Data.Vector.Fusion.Stream.Monadic (Stream (..))-import qualified Data.Vector.Fusion.Stream.Monadic as S-import qualified Data.Vector.Unboxed as VU-import qualified Data.Vector as V-import Data.Array.Repa.Index-import Control.Monad-import Control.Monad.Trans.Class-import qualified Control.Monad.Trans.Writer.Lazy as W-import qualified Control.Arrow as A-import System.IO.Unsafe (unsafePerformIO)-import Control.Applicative--import Data.Array.Repa.Index.Points-import Data.PrimitiveArray as PA-import Data.PrimitiveArray.Zero as PA--import ADP.Fusion hiding (empty)-import ADP.Fusion.Empty hiding (empty)-import ADP.Fusion.Chr-import ADP.Fusion.Table-import ADP.Fusion.Multi-import Data.Array.Repa.Index.Subword-import ADP.Fusion.TH----main = do-  ls <- lines <$> getContents-  align ls--align [] = return ()-align [c] = error "single last line"-align (a:b:xs) = do-  putStrLn a-  putStrLn b-  print $ needlemanWunsch (VU.fromList a) (VU.fromList b)-  align xs--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-  }---- grammar :: Signature m x r c -> ???-grammar Signature{..} a i1 i2 =-  ( a, step_step <<< a % (T:!chr i1:!chr i2) |||-       step_loop <<< a % (T:!chr i1:!None  ) |||-       loop_step <<< a % (T:!None  :!chr i2) |||-       nil_nil   <<< (T:!Empty:!Empty)       ... h-  )-{-# 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-1-  , step_loop = \x _         -> x-1-  , loop_step = \x _         -> x-1-  , nil_nil   = const 0-  , h = S.foldl' max 0-  }-{-# INLINE sScore #-}--needlemanWunsch i1 i2 = (ws ! (Z:.pointL 0 n1:.pointL 0 n2), bt) where-  ws = unsafePerformIO (forwardPhase i1 i2)-  n1 = VU.length i1-  n2 = VU.length i2-  bt = [] :: String-{-# NOINLINE needlemanWunsch #-}--forwardPhase :: VU.Vector Char -> VU.Vector Char -> IO (PA.Unboxed (Z:.PointL:.PointL) Int)-forwardPhase i1 i2 = do-  let n1 = VU.length i1-  let n2 = VU.length i2-  !t' <- newWithM (Z:.pointL 0 0:.pointL 0 0) (Z:.pointL 0 n1:.pointL 0 n2) 0-  let t= mTbl (Z:.EmptyT:.EmptyT) t'-  fillTable $ grammar sScore t i1 i2-  freeze t'-{-# INLINE forwardPhase #-}--fillTable (MTbl _ tbl, f) = do-  let (_,Z:.PointL(0:.n1):.PointL(0:.n2)) = boundsM tbl-  forM_ [0 .. n1] $ \k1 -> forM_ [0 .. n2] $ \k2 -> do-    (f $ Z:.pointL 0 k1:.pointL 0 k2) >>= writeM tbl (Z:.pointL 0 k1:.pointL 0 k2)-{-# INLINE fillTable #-}-
− ADP/Fusion/Multi.hs 
@@ -1,70 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE UnicodeSyntax #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeOperators #-}---- | The multi-tape extension of ADPfusion. Just re-exports everything.--module ADP.Fusion.Multi-  ( module ADP.Fusion.Multi.Classes-  , module ADP.Fusion.Multi.Empty-  , module ADP.Fusion.Multi.GChr-  , module ADP.Fusion.Multi.None-  ) where--import ADP.Fusion.Multi.Classes-import ADP.Fusion.Multi.None-import ADP.Fusion.Multi.GChr-import ADP.Fusion.Multi.Empty----{--type instance TermOf (Term ts (ZeroOne r xs)) = TermOf ts :. Maybe r--instance-  ( TermValidIndex ts is-  ) => TermValidIndex (Term ts (ZeroOne r xs)) (is:.PointL) where-  termDimensionsValid (ts:!ZeroOne (gchr)) = termDimensionsValid (ts:!gchr)-  {--  getTermParserRange (ts:!-  -}------- The experimental zero/one wrapper--instance-  ( Monad m-  , TermElm m ts is-  ) => TermElm m (Term ts (ZeroOne r xs)) (is:.PointL) where-  termStream (ts:!(ZeroOne (GChr f xs))) (io:.o) (is:.ij@(PointL(i:.j)))-    = doubleStream-    . termStream (ts:!GChr f xs) (io:.o) (is:.ij)-    where-      {-# INLINE doubleStream #-}-      doubleStream (S.Stream step sS n) = S.Stream sNew (Left sS) (2*n) where-        {-# INLINE [1] sNew #-}-        sNew (Left s) = do r <- step s-                           case r of-                             S.Yield (abc:!:(es:.e)) s' -> return $ S.Yield (abc:!:(es:.Just e)) (Right s')-                             S.Skip                  s' -> return $ S.Skip                       (Left  s')-                             S.Done                     -> return $ S.Done-        sNew (Right s) = do r <- step s-                            case r of-                              S.Yield (abc:!:(es:.e)) s' -> return $ S.Yield (abc:!:(es:.Nothing)) (Left s')---                              S.Skip                  s' -> return $ S.Skip                        (Left s')---                              S.Done                     -> return $ S.Done-  {-# INLINE termStream #-}--}----- Empty-
− ADP/Fusion/Multi/Classes.hs 
@@ -1,112 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeFamilies #-}--module ADP.Fusion.Multi.Classes where--import Data.Array.Repa.Index-import Data.Strict.Tuple-import qualified Data.Vector.Fusion.Stream.Monadic as S--import ADP.Fusion.Classes------ | The zero-th dimension of every terminal parser.--data TermBase = T---- | Combine a terminal parser of dimension k in @a@ with a new 1-dim parser--- @b@ generating a parser of dimension k+1.--data Term a b = a :! b---- | A 'termStream' extracts all terminal elements from a multi-dimensional--- terminal symbol.--class-  ( Monad m-  ) => TermElm m t ix where-  termStream :: t -> InOut ix -> ix -> S.Stream m (ze :!: zix :!: ix) -> S.Stream m (ze :!: zix :!: ix :!: TermOf t)---- |--type family TermOf t :: *---- | To calculate parser ranges and index validity we need an additional type--- class that recurses over the individual 'Term' elements.--class TermValidIndex t i where-  termDimensionsValid :: t -> ParserRange i -> i -> Bool-  getTermParserRange  :: t -> i -> ParserRange i -> ParserRange i-  termInnerOuter :: t -> i -> InOut i -> InOut i-  termLeftIndex :: t -> i -> i------ * The instance declarations for generic @Term a b@ data ctors.--instance Build (Term a b)--instance-  ( ValidIndex ls ix-  , TermValidIndex (Term a b) ix-  , Show ix-  , Show (ParserRange ix)-  ) => ValidIndex (ls :!: Term a b) ix where-  validIndex (ls :!: t) abc ix =-    termDimensionsValid t abc ix && validIndex ls abc ix-  {-# INLINE validIndex #-}-  getParserRange (ls :!: t) ix = getTermParserRange t ix (getParserRange ls ix)-  {-# INLINE getParserRange #-}--instance-  ( Elms ls ix-  ) => Elms (ls :!: Term a b) ix where-    data Elm (ls :!: Term a b) ix = ElmTerm !(Elm ls ix) !(TermOf (Term a b)) !ix-    type Arg (ls :!: Term a b) = Arg ls :. (TermOf (Term a b))-    getArg !(ElmTerm ls x _) = getArg ls :. x-    getIdx !(ElmTerm _ _ idx) = idx-    {-# INLINE getArg #-}-    {-# INLINE getIdx #-}--instance-  ( Monad m-  , Elms ls ix-  , MkStream m ls ix-  , TermElm m (Term a b) ix-  , TermValidIndex (Term a b) ix-  ) => MkStream m (ls :!: Term a b) ix where-  mkStream !(ls :!: t) !io !ij-    = S.map (\(s:!:Z:!:zij:!:e) -> ElmTerm s e zij)-    $ termStream t io ij-    $ S.map (\s -> (s :!: Z :!: getIdx s))-    $ mkStream ls (termInnerOuter t ij io) (termLeftIndex t ij)-  {-# INLINE mkStream #-}------ * Terminal stream of 'TermBase' with index 'Z'--type instance TermOf TermBase = Z--instance-  ( Monad m-  ) => TermElm m (TermBase) Z where-  termStream T _ Z = S.map (\(zs:!:zix:!:Z) -> (zs:!:zix:!:Z:!:Z))-  {-# INLINE termStream #-}--instance TermValidIndex TermBase Z where-  termDimensionsValid T Z Z = True-  getTermParserRange  T Z Z = Z-  termInnerOuter T Z Z = Z-  termLeftIndex T Z = Z-  {-# INLINE termDimensionsValid #-}-  {-# INLINE getTermParserRange #-}-  {-# INLINE termInnerOuter #-}-  {-# INLINE termLeftIndex #-}-
− ADP/Fusion/Multi/Empty.hs 
@@ -1,47 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeOperators #-}--module ADP.Fusion.Multi.Empty where--import Data.Array.Repa.Index-import Data.Strict.Tuple-import qualified Data.Vector.Fusion.Stream.Monadic as S--import Data.Array.Repa.Index.Points--import ADP.Fusion.Classes-import ADP.Fusion.Empty-import ADP.Fusion.Multi.Classes----type instance TermOf (Term ts Empty) = TermOf ts :. ()--instance-  ( Monad m-  , TermElm m ts is-  ) => TermElm m (Term ts Empty) (is:.PointL) where-  termStream (ts:!Empty) (io:.Outer) (is:.ij@(PointL(i:.j))) =-    S.map (\(zs:!:(zix:.kl):!:zis:!:e) -> (zs:!:zix:!:(zis:.kl):!:(e:.())))-    . S.filter (const (i==j))-    . termStream ts io is-    . S.map (\(zs:!:zix:!:(zis:.kl)) -> (zs:!:(zix:.kl):!:zis))-  {-# INLINE termStream #-}--instance-  ( TermValidIndex ts is-  ) => TermValidIndex (Term ts Empty) (is:.PointL) where-  termDimensionsValid (ts:!Empty) (prs:.(a:!:b:!:c)) (is:.PointL(i:.j))-    = termDimensionsValid ts prs is-  getTermParserRange (ts:!Empty) (is:._) (prs:.(a:!:b:!:c))-    = getTermParserRange ts is prs :. (a:!:b:!:c)-  termInnerOuter (ts:!_) (is:._) (ios:.io) = termInnerOuter ts is ios :. io-  termLeftIndex  (ts:!_) (is:.ij) = termLeftIndex ts is :. ij-  {-# INLINE termDimensionsValid #-}-  {-# INLINE getTermParserRange #-}-  {-# INLINE termInnerOuter #-}-  {-# INLINE termLeftIndex #-}-
− ADP/Fusion/Multi/GChr.hs 
@@ -1,101 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeOperators #-}--module ADP.Fusion.Multi.GChr where--import Data.Array.Repa.Index-import Data.Strict.Tuple-import qualified Data.Vector.Fusion.Stream.Monadic as S-import qualified Data.Vector.Generic as VG--import Data.Array.Repa.Index.Points-import Data.Array.Repa.Index.Subword--import ADP.Fusion.Chr-import ADP.Fusion.Classes-import ADP.Fusion.Multi.Classes---type instance TermOf (Term ts (GChr r xs)) = TermOf ts :. r------ * Multi-dim 'Subword's.---- TODO we want to evaluate @f xs $ j-1@ just once before the stream is--- generated. Unfortunately, this will evaluate cases like index (-1) as well,--- which leads to crashes. The code below is safe but slower. We should--- incorporate a version that performs and @outerCheck@ in the code.--instance-  ( Monad m-  , TermElm m ts is-  ) => TermElm m (Term ts (GChr r xs)) (is:.Subword) where-  termStream (ts :! GChr f xs) (io:.Outer) (is:.ij@(Subword(i:.j)))-    = S.map (\(zs :!: (zix:.kl) :!: zis :!: e) -> (zs :!: zix :!: (zis:.subword (j-1) j) :!: (e:.(f xs $ j-1))))-    . termStream ts io is-    . S.map (\(zs :!: zix :!: (zis:.kl)) -> (zs :!: (zix:.kl) :!: zis))-  termStream (ts :! GChr f xs) (io:.Inner _ _) (is:.ij)-    = S.map (\(zs :!: (zix:.kl@(Subword(k:.l))) :!: zis :!: e) -> let dta = f xs l in dta `seq` (zs :!: zix :!: (zis:.subword l (l+1)) :!: (e:.dta)))-    . termStream ts io is-    . S.map (\(zs :!: zix :!: (zis:.kl)) -> (zs :!: (zix:.kl) :!: zis))-  {-# INLINE termStream #-}--instance-  ( TermValidIndex ts is-  ) => TermValidIndex (Term ts (GChr r xs)) (is:.Subword) where-  termDimensionsValid (ts:!GChr _ xs) (prs:.(a:!:b:!:c)) (is:.Subword(i:.j))-    = i>=a && j<=VG.length xs -c && i+b<=j && termDimensionsValid ts prs is-  getTermParserRange (ts:!GChr _ _) (is:._) (prs:.(a:!:b:!:c))-    = getTermParserRange ts is prs :. (a:!:b+1:!:max 0 (c-1))-  termInnerOuter (ts:!_) (is:._) (ios:.io) = termInnerOuter ts is ios :. io-  termLeftIndex  (ts:!_) (is:.Subword (i:.j)) = termLeftIndex ts is :. subword i (j-1)-  {-# INLINE termDimensionsValid #-}-  {-# INLINE getTermParserRange #-}-  {-# INLINE termInnerOuter #-}-  {-# INLINE termLeftIndex #-}------ * Multi-dim 'PointL's---- | NOTE This instance is currently the only one using an "inline outer--- check". If This behaves well, it could be possible to put checks for valid--- indices inside the outerCheck function. (Currently disabled, as the compiler--- chokes on four-way alignments).--instance-  ( Monad m-  , TermElm m ts is-  ) => TermElm m (Term ts (GChr r xs)) (is:.PointL) where-  termStream (ts :! GChr f xs) (io:.Outer) (is:.ij@(PointL(i:.j)))-    -- = outerCheck (j>0)-    -- . let dta = (f xs $ j-1) in dta `seq` S.map (\(zs :!: (zix:.kl) :!: zis :!: e) -> (zs :!: zix :!: (zis:.pointL (j-1) j) :!: (e:.dta)))-    = S.map (\(zs :!: (zix:.kl) :!: zis :!: e) -> (zs :!: zix :!: (zis:.pointL (j-1) j) :!: (e:.(f xs $ j-1))))-    . termStream ts io is-    . S.map (\(zs :!: zix :!: (zis:.kl)) -> (zs :!: (zix:.kl) :!: zis))-  termStream (ts :! GChr f xs) (io:.Inner _ _) (is:.ij)-    = S.map (\(zs :!: (zix:.kl@(PointL(k:.l))) :!: zis :!: e) -> let dta = f xs l in dta `seq` (zs :!: zix :!: (zis:.pointL l (l+1)) :!: (e:.dta)))-    . termStream ts io is-    . S.map (\(zs :!: zix :!: (zis:.kl)) -> (zs :!: (zix:.kl) :!: zis))-  {-# INLINE termStream #-}---- TODO auto-generated, check correctness--instance-  ( TermValidIndex ts is-  ) => TermValidIndex (Term ts (GChr r xs)) (is:.PointL) where-  termDimensionsValid (ts:!GChr _ xs) (prs:.(a:!:b:!:c)) (is:.PointL(i:.j))-    = {- i>=a && j<=VG.length xs -c && i+b<=j && -} termDimensionsValid ts prs is-  getTermParserRange (ts:!GChr _ _) (is:._) (prs:.(a:!:b:!:c))-    = getTermParserRange ts is prs :. (a:!:b+1:!:max 0 (c-1))-  termInnerOuter (ts:!_) (is:._) (ios:.io) = termInnerOuter ts is ios :. io-  termLeftIndex  (ts:!_) (is:.PointL (i:.j)) = termLeftIndex ts is :. pointL i (j-1)-  {-# INLINE termDimensionsValid #-}-  {-# INLINE getTermParserRange #-}-  {-# INLINE termInnerOuter #-}-  {-# INLINE termLeftIndex #-}-
− ADP/Fusion/Multi/None.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeOperators #-}--module ADP.Fusion.Multi.None where--import Data.Array.Repa.Index-import Data.Strict.Tuple-import qualified Data.Vector.Fusion.Stream.Monadic as S--import Data.Array.Repa.Index.Points--import ADP.Fusion.Classes-import ADP.Fusion.Multi.Classes-import ADP.Fusion.None----type instance TermOf (Term ts None) = TermOf ts :. ()--instance-  ( Monad m-  , TermElm m ts is-  ) => TermElm m (Term ts None) (is:.PointL) where-  termStream (ts :! None) (io:.Outer) (is:.ij@(PointL(i:.j))) =-    S.map (\(zs :!: (zix:.kl) :!: zis :!: e) -> (zs :!: zix :!: (zis:.kl) :!: (e:.())))-    . termStream ts io is-    . S.map (\(zs :!: zix :!: (zis:.kl)) -> (zs :!: (zix:.kl) :!: zis))-  termStream (ts :! None) (io:.Inner _ _) (is:.ij)-    = S.map (\(zs :!: (zix:.kl) :!: zis :!: e) -> (zs :!: zix :!: (zis:.kl) :!: (e:.())))-    . termStream ts io is-    . S.map (\(zs :!: zix :!: (zis:.kl)) -> (zs :!: (zix:.kl) :!: zis))-  {-# INLINE termStream #-}---- TODO auto-gen'ed--instance-  ( TermValidIndex ts is-  ) => TermValidIndex (Term ts None) (is:.PointL) where-  termDimensionsValid (ts:!None) (prs:.(a:!:b:!:c)) (is:.PointL(i:.j))-    = termDimensionsValid ts prs is-  getTermParserRange (ts:!None) (is:._) (prs:.(a:!:b:!:c))-    = getTermParserRange ts is prs :. (a:!:b:!:c)-  termInnerOuter (ts:!_) (is:._) (ios:.io) = termInnerOuter ts is ios :. io-  termLeftIndex  (ts:!_) (is:.ij) = termLeftIndex ts is :. ij-  {-# INLINE termDimensionsValid #-}-  {-# INLINE getTermParserRange #-}-  {-# INLINE termInnerOuter #-}-  {-# INLINE termLeftIndex #-}-
− ADP/Fusion/None.hs 
@@ -1,58 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-}--module ADP.Fusion.None where--import Data.Array.Repa.Index-import Data.Strict.Maybe-import Data.Strict.Tuple-import Prelude hiding (Maybe(..))-import qualified Data.Vector.Fusion.Stream.Monadic as S--import Data.Array.Repa.Index.Subword--import ADP.Fusion.Classes----data None = None--none = None-{-# INLINE none #-}---- None is always valid--instance-  ( ValidIndex ls Subword-  ) => ValidIndex (ls :!: None) Subword where-    validIndex (ls:!:None) abc ij@(Subword (i:.j)) = validIndex ls abc ij-    {-# INLINE validIndex #-}--instance Build None--instance-  ( Elms ls Subword-  ) => Elms (ls :!: None) Subword where-  data Elm (ls :!: None) Subword = ElmNone !(Elm ls Subword) !() !Subword-  type Arg (ls :!: None) = Arg ls :. ()-  getArg !(ElmNone ls () _) = getArg ls :. ()-  getIdx !(ElmNone _ _ i)   = i-  {-# INLINE getArg #-}-  {-# INLINE getIdx #-}--instance-  ( Monad m-  , Elms ls Subword-  , MkStream m ls Subword-  ) => MkStream m (ls:!:None) Subword where-  mkStream !(ls:!:None) Outer !ij@(Subword (i:.j))-    = S.map (\s -> ElmNone s () (subword i j))-    $ S.filter (\_ -> i==j)-    $ mkStream ls Outer ij-  {-# INLINE mkStream #-}-
− ADP/Fusion/QuickCheck.hs 
@@ -1,531 +0,0 @@-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}--module ADP.Fusion.QuickCheck where--import Control.Monad-import Control.Applicative-import Data.Array.Repa.Index-import Data.Array.Repa.Shape-import Data.Array.Repa.Arbitrary-import Debug.Trace-import qualified Data.Vector.Fusion.Stream as S-import qualified Data.Vector.Fusion.Stream.Monadic as SM-import qualified Data.Vector.Unboxed as VU-import Test.QuickCheck-import Test.QuickCheck.All-import Test.QuickCheck.Monadic-import Data.List ((\\))-import System.IO.Unsafe--import Data.Array.Repa.Index.Subword-import Data.Array.Repa.Index.Point-import Data.Array.Repa.Index.Points-import qualified Data.PrimitiveArray as PA-import qualified Data.PrimitiveArray.Zero as PA--import ADP.Fusion-import ADP.Fusion.Table-import ADP.Fusion.Multi----- | Check if a single region returns the correct result (namely a slice from--- the input).--prop_R sw@(Subword (i:.j)) = zs == ls where-  zs = id <<< region xs ... S.toList $ sw-  ls = [VU.slice i (j-i) xs | i>=0, j<=100]---- | Two regions next to each other.--prop_RR sw@(Subword (i:.j)) = zs == ls where-  zs = (,) <<< region xs % region xs ... S.toList $ sw-  ls = [(VU.slice i (k-i) xs, VU.slice k (j-k) xs) | k <- [i..j]]---- | And finally, three regions (with smaller subword sizes only)--prop_RRR sw@(Subword (i:.j)) = (j-i<=30) ==> zs == ls where-  zs = (,,) <<< region xs % region xs % region xs ... S.toList $ sw-  ls = [  ( VU.slice i (k-i) xs-          , VU.slice k (l-k) xs-          , VU.slice l (j-l) xs-          ) | k <- [i..j], l <- [k..j]]---- | Three sized regions (with smaller subword sizes only)--prop_SSS sw@(Subword (i:.j)) = zs == ls where-  zs = (,,) <<< sregion 3 10 xs % sregion 3 10 xs % sregion 3 10 xs ... S.toList $ sw-  ls = [  ( VU.slice i (k-i) xs-          , VU.slice k (l-k) xs-          , VU.slice l (j-l) xs-          ) | k <- [i..j], l <- [k..j], minimum [k-i,l-k,j-l] >=3, maximum [k-i,l-k,j-l] <= 10]---- | Single-character parser.--prop_C sw@(Subword (i:.j)) = zs == ls where-  zs = id <<< chr xs ... S.toList $ sw-  ls = [xs VU.! i | i+1==j, i>=0, j<=100]---- | 2x Single-character parser.--prop_CC sw@(Subword (i:.j)) = zs == ls where-  zs = (,) <<< chr xs % chr xs ... S.toList $ sw-  ls = [(xs VU.! i, xs VU.! (i+1)) | i+2==j]---- ** Single character plus peeking--prop_PlC sw@(Subword (i:.j)) = zs == ls where-  zs = (,) <<< peekL xs % chr xs ... S.toList $ sw-  ls = [(xs VU.! (j-2), xs VU.! (j-1)) | j>1, i+1==j]--prop_PrC sw@(Subword (i:.j)) = zs == ls where-  zs = (,) <<< peekR xs % chr xs ... S.toList $ sw-  ls = [(xs VU.! (j-1), xs VU.! (j-1)) | i+1==j]--prop_CPr sw@(Subword (i:.j)) = zs == ls where-  zs = (,) <<< chr xs % peekR xs ... S.toList $ sw-  ls = [(xs VU.! (j-1), xs VU.! j) | i>=0, j<=99,i+1==j]--prop_CPl sw@(Subword (i:.j)) = zs == ls where-  zs = (,) <<< chr xs % peekL xs ... S.toList $ sw-  ls = [(xs VU.! (j-1), xs VU.! (j-1)) | i+1==j]---- | 2x Single-character parser bracketing a single region.--prop_CRC sw@(Subword (i:.j)) = zs == ls-  where-    zs = (,,) <<< chr xs % region xs % chr xs ... S.toList $ sw-    ls = [(xs VU.! i, VU.slice (i+1) (j-i-2) xs , xs VU.! (j-1)) |i+2<=j]---- | 2x Single-character parser bracketing regions.--prop_CRRC sw@(Subword (i:.j)) = zs == ls-  where-    zs = (,,,) <<< chr xs % region xs % region xs % chr xs ... S.toList $ sw-    ls = [ ( xs VU.! i-           , VU.slice (i+1) (k-i-1) xs-           , VU.slice k (j-k-1) xs-           , xs VU.! (j-1)-           ) | k <- [i+1 .. j-1]]---- | complex behaviour with characters and regions--prop_CRCRC sw@(Subword (i:.j)) = zs == ls where-  zs = (,,,,) <<< chr xs % region xs % chr xs % region xs % chr xs ... S.toList $ sw-  ls = [ ( xs VU.! i-         , VU.slice (i+1) (k-i-1) xs-         , xs VU.! k-         , VU.slice (k+1) (j-k-2) xs-         , xs VU.! (j-1)-         ) | k <- [i+1 .. j-2] ]---- | Interior-loop like structures.--prop_Interior1 sw@(Subword (i:.j)) = zs == ls where-  zs = (,,) <<< chr xs % peekR xs % sregion 1 5 xs ... S.toList $ sw-  ls = [ ( xs VU.! i-         , xs VU.! (i+1)-         , VU.slice (i+1) (j-i-1) xs-         ) | j-i>=2, j-i<=6-       ]--prop_Interior2 sw@(Subword (i:.j)) = zs == ls where-  zs = (,,,,) <<< chr xs % peekR xs % sregion 1 5 xs % peekR xs % sregion 2 5 xs ... S.toList $ sw-  ls = [ ( xs VU.! i-         , xs VU.! (i+1)-         , VU.slice (i+1) (k-i-1) xs-         , xs VU.! k-         , VU.slice k (j-k) xs-         ) | j-i>=4, j-i<=11, k <- [i+2 .. (min j $ i+6)], j-k>=2, j-k<=5-       ]--prop_Interior3 sw@(Subword (i:.j)) = zs == ls where-  zs = (,,,,,,) <<< chr xs % peekR xs % sregion 1 5 xs % peekR xs % sregion 2 5 xs % peekL xs % sregion 1 5 xs ... S.toList $ sw-  ls = [ ( xs VU.! i-         , xs VU.! (i+1)-         , VU.slice (i+1) (k-i-1) xs-         , xs VU.! k-         , VU.slice k (l-k) xs-         , xs VU.! (l-1)-         , VU.slice l (j-l) xs-         ) | i>= 0-           , j<= 100-           , k <- [i..j]-           , l <- [k..j]-           , j-i>=5, j-i<=16-           , k-i-1>=1, k-i-1<=5-           , l-k>=2, l-k<=5-           , j-l>=1, j-l<=5-       ]--prop_Interior4 sw@(Subword (i:.j)) = zs == ls where-  zs = (,,,,,,,,) <<< chr xs % peekR xs % sregion 1 5 xs % peekR xs % sregion 2 5 xs % peekL xs % sregion 1 5 xs % peekL xs % chr xs ... S.toList $ sw-  ls = [ ( xs VU.! i-         , xs VU.! (i+1)-         , VU.slice (i+1) (k-i-1) xs-         , xs VU.! k-         , VU.slice k (l-k) xs-         , xs VU.! (l-1)-         , VU.slice l (j-l-1) xs-         , xs VU.! (j-2)-         , xs VU.! (j-1)-         ) | k <- [i..j]-           , l <- [k..j]-           , j-i>=6, j-i<=17-           , k-i-1>=1, k-i-1<=5-           , l-k>=2, l-k<=5-           , j-l-1>=1, j-l-1<=5-       ]--prop_Interior5 sw@(Subword (i:.j)) = zs == ls where-  zs = (,,,,,,,,,,) <<< peekL xs % chr xs % peekR xs % sregion 1 5 xs % peekR xs % sregion 2 5 xs % peekL xs % sregion 1 5 xs % peekL xs % chr xs % peekR xs ... S.toList $ sw-  ls = [ ( xs VU.! (i-1)-         , xs VU.! i-         , xs VU.! (i+1)-         , VU.slice (i+1) (k-i-1) xs-         , xs VU.! k-         , VU.slice k (l-k) xs-         , xs VU.! (l-1)-         , VU.slice l (j-l-1) xs-         , xs VU.! (j-2)-         , xs VU.! (j-1)-         , xs VU.! j-         ) | i>= 1-           , j<= 99-           , k <- [i..j]-           , l <- [k..j]-           , i>0, j-1 < VU.length xs-           , j-i>=6, j-i<=17-           , k-i-1>=1, k-i-1<=5-           , l-k>=2, l-k<=5-           , j-l-1>=1, j-l-1<=5-       ]---- | A single mutable table should return one result.--prop_Mt sw@(Subword (i:.j)) = monadicIO $ do-    mxs :: PA.MutArr IO (PA.Unboxed (Z:.Subword) Int) <- run $ PA.fromListM (Z:. Subword (0:.0)) (Z:. Subword (0:.100)) [0 .. ] -- (1 :: Int)-    let mt = mTblSw EmptyT mxs-    zs <- run $ id <<< mt ... SM.toList $ sw-    ls <- run $ sequence $ [(PA.readM mxs (Z:.sw)) | i<=j]-    assert $ zs == ls---- | table, then character.--prop_MtC sw@(Subword (i:.j)) = monadicIO $ do-    mxs :: (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int)) <- run $ PA.fromListM (Z:. Subword (0:.0)) (Z:. Subword (0:.100)) [0 .. ] -- (1 :: Int)-    let mt = mTblSw EmptyT mxs-    zs <- run $ (,) <<< mt % chr xs ... SM.toList $ sw-    ls <- run $ sequence $ [(PA.readM mxs (Z:.subword i (j-1))) >>= \a -> return (a,xs VU.! (j-1)) | i<j]-    assert $ zs == ls---- | Character, then table.--prop_CMt sw@(Subword (i:.j)) = monadicIO $ do-    mxs :: (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int)) <- run $ PA.fromListM (Z:. Subword (0:.0)) (Z:. Subword (0:.100)) [0 .. ] -- (1 :: Int)-    let mt = mTblSw EmptyT mxs-    zs <- run $ (,) <<< chr xs % mt ... SM.toList $ sw-    ls <- run $ sequence $ [(PA.readM mxs (Z:.subword (i+1) j)) >>= \a -> return (xs VU.! i,a) | i<j]-    assert $ zs == ls---- | Two mutable tables. Basically like Region's.--prop_MtMt sw@(Subword (i:.j)) = monadicIO $ do-    mxs :: (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int)) <- run $ PA.fromListM (Z:. Subword (0:.0)) (Z:. Subword (0:.100)) [0 .. ] -- (1 :: Int)-    let mt = mTblSw EmptyT mxs-    zs <- run $ (,) <<< mt % mt ... SM.toList $ sw-    ls <- run $ sequence $ [(PA.readM mxs (Z:.subword i k)) >>= \a -> PA.readM mxs (Z:.subword k j) >>= \b -> return (a,b) | k <- [i..j]]-    assert $ zs == ls---- | Just to make it more interesting, sprinkle in some 'Chr' symbols.--prop_CMtCMtC sw@(Subword (i:.j)) = monadicIO $ do-    mxs :: (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int)) <- run $ PA.fromListM (Z:. Subword (0:.0)) (Z:. Subword (0:.100)) [0 .. ] -- (1 :: Int)-    let mt = mTblSw EmptyT mxs-    zs <- run $ (,,,,) <<< chr xs % mt % chr xs % mt % chr xs ... SM.toList $ sw-    ls <- run $ sequence $ [ (PA.readM mxs (Z:.subword (i+1) k)) >>=-                            \a -> PA.readM mxs (Z:.subword (k+1) (j-1)) >>=-                            \b -> return ( xs VU.! i-                                         , a-                                         , xs VU.! k-                                         , b-                                         , xs VU.! (j-1)-                                         )-                           | k <- [i+1..j-2]]-    assert $ zs == ls---- | And now with non-empty tables.--prop_CMnCMnC sw@(Subword (i:.j)) = monadicIO $ do-    mxs :: (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int)) <- run $ PA.fromListM (Z:. Subword (0:.0)) (Z:. Subword (0:.100)) [0 .. ] -- (1 :: Int)-    let mt = mTblSw NonEmptyT mxs-    zs <- run $ (,,,,) <<< chr xs % mt % chr xs % mt % chr xs ... SM.toList $ sw-    ls <- run $ sequence $ [ (PA.readM mxs (Z:.subword (i+1) k)) >>=-                            \a -> PA.readM mxs (Z:.subword (k+1) (j-1)) >>=-                            \b -> return ( xs VU.! i-                                         , a-                                         , xs VU.! k-                                         , b-                                         , xs VU.! (j-1)-                                         )-                           | k <- [i+2..j-3]]-    assert $ zs == ls--{-- - Currently not allowing 0-dim multi-tapes.--prop_Tt ix@Z = zs == ls where-  zs = id <<< T ... S.toList $ ix-  ls = [ Z ]--}---- **--prop_Tc ix@(Z:.Subword(i:.j)) = zs == ls where-  zs = id <<< (T:!chr xs) ... S.toList $ ix-  ls = [ (Z:.xs VU.! i) | i>=0, j<= 100, i+1==j ]--prop_Tcc ix@(Z:.Subword(i:.j):.Subword(k:.l)) = zs == ls where-  zs = id <<< (T:!chr xs:!chr xs) ... S.toList $ ix-  ls = [ (Z:.xs VU.! i:.xs VU.! k) | i>=0, j<=100, k>=0, j<=100, i+1==j, k+1==l ]---- **--prop_TcTc ix@(Z:.Subword(i:.j)) = zs == ls where-  zs = (,) <<< (T:!chr xs) % (T:!chr xs) ... S.toList $ ix-  ls = [ (Z:.xs VU.! i,Z:.xs VU.! (i+1)) | i>=0, j<= 100, i+2==j ]--prop_TccTcc ix@(Z:.Subword(i:.j):.Subword(k:.l)) = zs == ls where-  zs = (,) <<< (T:!chr xs:!chr xs) % (T:!chr xs:!chr xs) ... S.toList $ ix-  ls = [ (Z:.xs VU.! i:.xs VU.! k, Z:.xs VU.! (i+1):.xs VU.! (k+1)) | i>=0, j<=100, k>=0, j<=100, i+2==j, k+2==l ]---- **--prop_Mt2 ix@(Z:.Subword(i:.j)) = monadicIO $ do-  mxs :: PA.MutArr IO (PA.Unboxed (Z:.Subword) Int) <- run $ PA.fromListM (Z:.subword 0 0) (Z:.subword 0 100) [0 ..]-  let mt = mTbl (Z:.EmptyT) mxs -- :: MTbl (Z:.Subword) (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int))-  zs <- run $ id <<< mt ... SM.toList $ ix-  ls <- run $ sequence $ [ (PA.readM mxs (Z:.subword i j)) | i>=0, j<=100, i<=j ]-  assert $ zs == ls--prop_MtMt2 ix@(Z:.Subword(i:.j)) = monadicIO $ do-  mxs :: PA.MutArr IO (PA.Unboxed (Z:.Subword) Int) <- run $ PA.fromListM (Z:.subword 0 0) (Z:.subword 0 100) [0 ..]-  let mt = mTbl (Z:.EmptyT) mxs -- :: MTbl (Z:.Subword) (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int))-  zs <- run $ (,) <<< mt % mt ... SM.toList $ ix-  ls <- run $ sequence $ [ liftM2 (,) (PA.readM mxs (Z:.subword i k)) (PA.readM mxs (Z:.subword k j)) | i>=0, j<=100, k<-[i..j] ]-  assert $ zs == ls--prop_MtMtMt2 ix@(Z:.Subword(i:.j)) = monadicIO $ do-  mxs :: PA.MutArr IO (PA.Unboxed (Z:.Subword) Int) <- run $ PA.fromListM (Z:.subword 0 0) (Z:.subword 0 100) [0 ..]-  let mt = mTbl (Z:.EmptyT) mxs -- :: MTbl (Z:.Subword) (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int))-  zs <- run $ (,,) <<< mt % mt % mt ... SM.toList $ ix-  ls <- run $ sequence $ [ liftM3 (,,) (PA.readM mxs (Z:.subword i k)) (PA.readM mxs (Z:.subword k l)) (PA.readM mxs (Z:.subword l j)) | i>=0, j<=100, k<-[i..j], l<-[k..j] ]-  assert $ zs == ls--prop_TcMtTc ix@(Z:.Subword(i:.j)) = monadicIO $ do-  mxs :: PA.MutArr IO (PA.Unboxed (Z:.Subword) Int) <- run $ PA.fromListM (Z:.subword 0 0) (Z:.subword 0 100) [0 ..]-  let mt = mTbl (Z:.EmptyT) mxs :: MTbl (Z:.Subword) (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int))-  zs <- run $ (,,) <<< (T:!chr xs) % mt % (T:!chr xs) ... SM.toList $ ix-  ls <- run $ sequence $ [ (PA.readM mxs (Z:.subword (i+1) (j-1)) >>= \z -> return (Z:.xs VU.! i,z,Z:.xs VU.! (j-1))) | i>=0, j<=100, i+2<=j ]-  assert $ zs == ls--prop_2dim ix@(Z:.TinySubword(i:.j):.TinySubword(k:.l)) = monadicIO $ do-  mxs <- run $ pure $ mxsSwSw-  let mt = mTbl (Z:.EmptyT:.EmptyT) mxs-  zs <- run $ (,) <<< mt % mt ... SM.toList $ Z:.subword i j:.subword k l-  ls <- run $ sequence $ [ liftM2 (,) (PA.readM mxs (Z:.subword i a:.subword k b)) (PA.readM mxs (Z:.subword a j:.subword b l)) | i>=0, j<=100, k>=0, l<=100, a<-[i..j], b<-[k..l] ]-  assert $ zs==ls--prop_2dimCMCMC ix@(Z:.TinySubword(i:.j):.TinySubword(k:.l)) = monadicIO $ do-  mxs <- run $ pure $ mxsSwSw -- :: PA.MutArr IO (PA.Unboxed (Z:.Subword:.Subword) Int) <- run $ PA.fromListM (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 100:.subword 0 100) [0 ..]-  let mt = mTbl (Z:.EmptyT:.EmptyT) mxs-  zs <- run $ (,,,,) <<< (T:!chr xs:!chr xs) % mt % (T:!chr xs:!chr xs) % mt % (T:!chr xs:!chr xs) ... SM.toList $ Z:.subword i j:.subword k l-  ls <- run $ sequence $ [ liftM5 (,,,,) (pure $ Z:.xs VU.! i:.xs VU.! k)-                                         (PA.readM mxs (Z:.subword (i+1) a:.subword (k+1) b))-                                         (pure $ Z:.xs VU.! a:.xs VU.! b)-                                         (PA.readM mxs (Z:.subword (a+1) (j-1):.subword (b+1) (l-1)))-                                         (pure $ Z:.xs VU.! (j-1):.xs VU.! (l-1))-                         | j-i>=3, l-k>=3, i>=0, j<=100, k>=0, l<=100, a<-[i+1..j-2], b<-[k+1..l-2] ]-  assert $ zs==ls---- * working on 'PointL's--prop_P_Tt ix@(Z:.PointL (i:.j)) = zs == ls where-  zs = id <<< (T:!chr xs) ... S.toList $ ix-  ls = [ (Z:.xs VU.! i) | i+1==j ]--prop_P_CC ix@(Z:.PointL (i:.j)) = zs == ls where-  zs = (,) <<< (T:!chr xs) % (T:!chr xs) ... S.toList $ ix-  ls = [ (Z:.xs VU.! i, Z:.xs VU.! (i+1)) | i+2==j ]--prop_P_2dimCMCMC ix@(Z:.PointL(i:.j):.PointL(k:.l)) = monadicIO $ do-  mxs <- run $ pure $ mxsPP-  let mt = mTbl (Z:.EmptyT:.EmptyT) mxs-  zs <- run $ (,,,,) <<< (T:!chr xs:!chr xs) % mt % (T:!chr xs:!chr xs) % mt % (T:!chr xs:!chr xs) ... SM.toList $ ix-  ls <- run $ sequence $ [ liftM5 (,,,,) (pure $ Z:.xs VU.! i:.xs VU.! k)-                                         (PA.readM mxs (Z:.pointL (i+1) a:.pointL (k+1) b))-                                         (pure $ Z:.xs VU.! a:.xs VU.! b)-                                         (PA.readM mxs (Z:.pointL (a+1) (j-1):.pointL (b+1) (l-1)))-                                         (pure $ Z:.xs VU.! (j-1):.xs VU.! (l-1))-                         | j-i>=3, l-k>=3, i>=0, j<=100, k>=0, l<=100, a<-[i+1..j-2], b<-[k+1..l-2] ]-  assert $ zs==ls--{--prop_TcTc ix@(Z:.Point i) = {- traceShow (zs,ls) $ -} zs == ls where-  zs = (,) <<< Term (T:.Chr xs) % Term (T:.Chr xs) ... S.toList $ ix-  ls = [ (Z:.xs VU.! (i-2), Z:.xs VU.! (i-1)) | i>1 ]---- deriving instance Show (Elm (None :. Term (T :. Chr Int)) (Z :. Point))--prop_TpTc ix@(Z:.Point i) = {- traceShow (zs,ls) $ -} zs == ls where-  zs = (,) <<< Term (T:.Peek (-1) xs) % Term (T:.Chr xs) ... S.toList $ ix-  ls = [ (Z:.f i, Z:.xs VU.! (i-1)) | i>0 ]-  f i = if i>1 then xs VU.! (i-2) else (-1)--prop_TcTpTc ix@(Z:.Point i) = {- traceShow (zs,ls) $ -} zs == ls where-  zs = (,,) <<< Term (T:.Chr xs) % Term (T:.Peek (-1) xs) % Term (T:.Chr xs) ... S.toList $ ix-  ls = [ (Z:.xs VU.! (i-2), Z:.f i, Z:.xs VU.! (i-1)) | i>1 ]-  f i = if i>1 then xs VU.! (i-2) else (-1)--{--prop_Mt_Tc ix@(Z:.Subword(i:.j)) = monadicIO $ do-    mxs :: (PA.MU IO (Z:.Subword) Int) <- run $ PA.fromListM (Z:. Subword (0:.0)) (Z:. Subword (0:.100)) [0 .. ]-    let mt = mtable mxs-    zs <- run $ (,) <<< mt % Term (T:.Chr xs) ... SM.toList $ ix-    ls <- run $ sequence $ [(PA.readM mxs (Z:.subword i (j-1))) >>= \a -> return (a,Z:.xs VU.! (j-1)) | i<j ]-    assert $ zs == ls--}--prop_P_Mt_Tt ix@(Z:.Point i) = monadicIO $ do-    mxs :: (PA.MU IO (Z:.Point) Int) <- run $ PA.fromListM (Z:.Point 0) (Z:.Point 100) [0 .. ]-    let mt = mtable mxs-    zs <- run $ (,) <<< mt % Term (T:.Chr xs) ... SM.toList $ ix-    ls <- run $ sequence $ [(PA.readM mxs (Z:.Point (i-1))) >>= \a -> return (a,Z:.xs VU.! (i-1)) | i>0 ]-    assert $ zs == ls--prop_P_Mt_TpTc ix@(Z:.Point i) = monadicIO $ do-    mxs :: (PA.MU IO (Z:.Point) Int) <- run $ PA.fromListM (Z:.Point 0) (Z:.Point 100) [0 .. ]-    let mt = mtable mxs-    let f i = if i>1 then xs VU.! (i-2) else (-1)-    zs <- run $ (,,) <<< mt % Term (T:.Peek (-1) xs) % Term (T:.Chr xs) ... SM.toList $ ix-    ls <- run $ sequence $ [(PA.readM mxs (Z:.Point (i-1))) >>= \a -> return (a,Z:.f i,Z:.xs VU.! (i-1)) | i>0 ]-    assert $ zs == ls---- | and with 2-tape grammars--prop_Tcc ix@(Z:.Subword(i:.j):.Subword(k:.l)) = zs == ls where-  zs = id <<< Term (T:.Chr xs:.Chr xs) ... S.toList $ ix-  ls = [ (  Z-         :. xs VU.! i-         :. xs VU.! k-         ) | i+1==j, k+1==l ]--prop_Mt_Tcc (Z:.TinySubword (i:.j):.TinySubword (k:.l)) = monadicIO $ do-    let ix = Z :. subword i j :. subword k l-    mxs :: (PA.MU IO (Z:.Subword:.Subword) Int) <- run $ PA.fromListM (Z:. Subword (0:.0):.Subword(0:.0)) (Z:. Subword (0:.j+1):.Subword (0:.k+1)) [0 .. ]-    let mt = mtable mxs-    zs <- run $ (,) <<< mt % Term (T:.Chr xs:.Chr xs) ... SM.toList $ ix-    ls <- run $ sequence $ [ (PA.readM mxs (Z:.subword i (j-1):.subword k (l-1))) >>= \a -> return (a,Z:.xs VU.! (j-1):.xs VU.! (l-1)) | i<j,k<l ]-    assert $ zs == ls--prop_P_Ttt ix@(Z:.Point i:.Point j) = zs == ls where-  zs = id <<< Term (T:.Chr xs:.Chr xs) ... S.toList $ ix-  ls = [ (Z:.xs VU.! (i-1):.xs VU.! (j-1)) | i>0, j>0 ]--prop_P_Mt_Ttt ix@(Z:.Point i:.Point j) = monadicIO $ do-    mxs :: (PA.MU IO (Z:.Point:.Point) Int) <- run $ PA.fromListM (Z:.Point 0:.Point 0) (Z:.Point 100:.Point 100) [0 .. ]-    let mt = mtable mxs-    zs <- run $ (,) <<< mt % Term (T:.Chr xs:.Chr xs) ... SM.toList $ ix-    ls <- run $ sequence $ [(PA.readM mxs (Z:.Point (i-1):.Point (j-1))) >>= \a -> return (a,Z:.xs VU.! (i-1):.xs VU.! (j-1)) | i>0,j>0 ]-    assert $ zs == ls--prop_P_Mt_Tpp_Ttt ix@(Z:.Point i:.Point j) = monadicIO $ do-    mxs :: (PA.MU IO (Z:.Point:.Point) Int) <- run $ PA.fromListM (Z:.Point 0:.Point 0) (Z:.Point 100:.Point 100) [0 .. ]-    let mt = mtable mxs-    let f i j = Z:. (if i>1 then xs VU.! (i-2) else (-1)) :. (if j>1 then xs VU.! (j-2) else (-1))-    zs <- run $ (,,) <<< mt % Term (T:.Peek (-1) xs:.Peek (-1) xs) % Term (T:.Chr xs:.Chr xs) ... SM.toList $ ix-    ls <- run $ sequence $ [(PA.readM mxs (Z:.Point (i-1):.Point (j-1))) >>= \a -> return (a,f i j,Z:.xs VU.! (i-1):.xs VU.! (j-1)) | i>0,j>0 ]-    -- traceShow (zs,ls) $-    assert $ zs == ls---- | and with 3-tape grammars--prop_Tccc ix@(Z:.Subword(i:.j):.Subword(k:.l):.Subword(a:.b)) = zs == ls where-  zs = id <<< Term (T:.Chr xs:.Chr xs:.Chr xs) ... S.toList $ ix-  ls = [ (  Z-         :. xs VU.! i-         :. xs VU.! k-         :. xs VU.! a-         ) | i+1==j, k+1==l, a+1==b ]---- * helper functions and stuff---- | Helper function to create non-specialized regions--region = Region Nothing Nothing---- |--mtable xs = MTable Eall xs--{---- | A subword (i,j) should always produce an index in the allowed range--prop_subwordIndex (Small n, Subword (i:.j)) = (n>j) ==> p where-  p = n * (n+1) `div` 2 >= k-  k = subwordIndex (subword 0 n) (subword i j)--}---}---- | data set. Can be made fixed as the maximal subword size is statically known!--xs = VU.fromList [0 .. 99 :: Int]----------TODO will break if PrimitiveArray assertions are active (need to fixe exact length of list)--mxsSwSw = unsafePerformIO $ zzz where-  zzz :: IO (PA.MutArr IO (PA.Unboxed (Z:.Subword:.Subword) Int))-  zzz = PA.fromListM (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 100:.subword 0 100) [0 ..]--mxsPP = unsafePerformIO $ zzz where-  zzz :: IO (PA.MutArr IO (PA.Unboxed (Z:.PointL:.PointL) Int))-  zzz = PA.fromListM (Z:.pointL 0 0:.pointL 0 0) (Z:.pointL 0 100:.pointL 0 100) [0 ..]---- * general quickcheck stuff--options = stdArgs {maxSuccess = 1000}--customCheck = quickCheckWithResult options--allProps = $forAllProperties customCheck----newtype Small = Small Int-  deriving (Show)--instance Arbitrary Small where-  arbitrary = Small <$> choose (0,100)-  shrink (Small i) = Small <$> shrink i--newtype TinySubword = TinySubword (Int:.Int)-  deriving (Show)--instance Arbitrary TinySubword where-  arbitrary = do a <- choose (0,20)-                 b <- choose (0,20)-                 return $ TinySubword $ min a b :. max a b-  shrink (TinySubword (a:.b)) = [TinySubword (a:.b-1) | a<b]--instance Arbitrary z => Arbitrary (z:.TinySubword) where-  arbitrary = (:.) <$> arbitrary <*> arbitrary-  shrink (z:.s) = (:.) <$> shrink z <*> shrink s--
+ ADP/Fusion/QuickCheck/Common.hs view
@@ -0,0 +1,10 @@++{-# Options_GHC -O0 #-}++module ADP.Fusion.QuickCheck.Common where++import Debug.Trace++++tr zs ls b = traceShow (zs," ",ls,length zs,length ls) b
+ ADP/Fusion/QuickCheck/Point.hs view
@@ -0,0 +1,293 @@++{-# Options_GHC -O0 #-}++module ADP.Fusion.QuickCheck.Point where++import           Control.Applicative+import           Control.Monad+import           Data.Strict.Tuple+import           Data.Vector.Fusion.Util+import           Debug.Trace+import qualified Data.Vector.Fusion.Stream as S+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Unboxed as VU+import           System.IO.Unsafe+import           Test.QuickCheck+import           Test.QuickCheck.All+import           Test.QuickCheck.Monadic++import           Data.PrimitiveArray++import ADP.Fusion++++-- * Epsilon cases++prop_Epsilon ix@(PointL j) = zs == ls where+  zs = (id <<< Epsilon ... S.toList) maxPL ix+  ls = [ () | j == 0 ]++prop_O_Epsilon ix@(O (PointL j)) = zs == ls where+  zs = (id <<< Epsilon ... S.toList) (O maxPL) ix+  ls = [ () | j == 100 ]++prop_ZEpsilon ix@(Z:.PointL j) = zs == ls where+  zs = (id <<< (M:|Epsilon) ... S.toList) (Z:.maxPL) ix+  ls = [ Z:.() | j == 0 ]++prop_O_ZEpsilon ix@(O (Z:.PointL j)) = zs == ls where+  zs = (id <<< (M:|Epsilon) ... S.toList) (O (Z:.maxPL)) ix+  ls = [ Z:.() | j == 100 ]++prop_O_ZEpsilonEpsilon ix@(O (Z:.PointL j:.PointL l)) = zs == ls where+  zs = (id <<< (M:|Epsilon:|Epsilon) ... S.toList) (O (Z:.maxPL:.maxPL)) ix+  ls = [ Z:.():.() | j == 100, l == 100 ]++++-- * Deletion cases++prop_O_ItNC ix@(O (PointL j)) = zs == ls where+  t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)+  zs = ((,,) <<< t % Deletion % chr xs ... S.toList) (O $ maxPL) ix+  ls = [ ( unsafeIndex xsPo (O $ PointL $ j+1)+         , ()+         , xs VU.! (j+0)+         ) | j >= 0, j <= 99 ]+{-# Noinline prop_O_ItNC #-}++prop_O_ZItNC ix@(O (Z:.PointL j)) = zs == ls where+  t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1)+  zs = ((,,) <<< t % (M:|Deletion) % (M:|chr xs) ... S.toList) (O (Z:.maxPL)) ix+  ls = [ ( unsafeIndex xsZPo (O (Z:.PointL (j+1)))+         , Z:.()+         , Z:.xs VU.! (j+0)+         ) | j >= 0, j <= 99 ]++prop_O_2dimIt_NC_CN ix@(O (Z:.PointL j:.PointL l)) = zs == ls where+  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPPo (\ _ _ -> Id 1)+  zs = ((,,) <<< t % (M:|Deletion:|chr xs) % (M:|chr xs:|Deletion) ... S.toList) (O (Z:.maxPL:.maxPL)) ix+  ls = [ ( unsafeIndex xsPPo (O (Z:.PointL (j+1):.PointL (l+1)))+         , Z:.()           :.xs VU.! (l+0)+         , Z:.xs VU.! (j+0):.()+         ) | j>=0, l>=0, j<=99, l<=99 ]++prop_2dimIt_NC_CN ix@(Z:.PointL j:.PointL l) = zs == ls where+  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPP (\ _ _ -> Id 1)+  zs = ((,,) <<< t % (M:|Deletion:|chr xs) % (M:|chr xs:|Deletion) ... S.toList) (Z:.maxPL:.maxPL) ix+  ls = [ ( unsafeIndex xsPP (Z:.PointL (j-1):.PointL (l-1))+         , Z:.()           :.xs VU.! (l-1)+         , Z:.xs VU.! (j-1):.()+         ) | j>=1, l>=1, j<=100, l<=100 ]++++-- * terminal cases++-- | A single character terminal++prop_Tt ix@(Z:.PointL j) = zs == ls where+  zs = (id <<< (M:|chr xs) ... S.toList) (Z:.maxPL) ix+  ls = [ (Z:.xs VU.! (j-1)) | 1==j ]++--prop_O_Tt ix@(Z:.O (PointL j)) = traceShow (j,zs,ls) $ zs == ls where+--  zs = (id <<< (M:|chr xs) ... S.toList) (Z:.O maxPL) ix+--  ls = [ (Z:.xs VU.! (j-1)) | 1==j ]++-- | Two single-character terminals++prop_CC ix@(Z:.PointL i) = zs == ls where+  zs = ((,) <<< (M:|chr xs) % (M:|chr xs) ... S.toList) (Z:.maxPL) ix+  ls = [ (Z:.xs VU.! (i-2), Z:.xs VU.! (i-1)) | 2==i ]++-- | Just a table++prop_It ix@(PointL j) = zs == ls where+  t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1)+  zs = (id <<< t ... S.toList) maxPL ix+  ls = [ unsafeIndex xsP ix | j>=0, j<=100 ]++prop_O_It ix@(O (PointL j)) = zs == ls where+  t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)+  zs = (id <<< t ... S.toList) (O maxPL) ix+  ls = [ unsafeIndex xsPo ix | j>=0, j<=100 ]++prop_ZIt ix@(Z:.PointL j) = zs == ls where+  t = ITbl 0 0 (Z:.EmptyOk) xsZP (\ _ _ -> Id 1)+  zs = (id <<< t ... S.toList) (Z:.maxPL) ix+  ls = [ unsafeIndex xsZP ix | j>=0, j<=100 ]++prop_O_ZIt ix@(O (Z:.PointL j)) = zs == ls where+  t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1)+  zs = (id <<< t ... S.toList) (O (Z:.maxPL)) ix+  ls = [ unsafeIndex xsZPo ix | j>=0, j<=100 ]++-- | Table, then single terminal++prop_ItC ix@(PointL j) = zs == ls where+  t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1)+  zs = ((,) <<< t % chr xs ... S.toList) maxPL ix+  ls = [ ( unsafeIndex xsP (PointL $ j-1)+         , xs VU.! (j-1)+         ) | j>=1, j<=100 ]++-- | @A^*_j -> A^*_{j+1} c_{j+1)@ !++prop_O_ItC ix@(O (PointL j)) = zs == ls where+  t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)+  zs = ((,) <<< t % chr xs ... S.toList) (O $ maxPL) ix+  ls = [ ( unsafeIndex xsPo (O $ PointL $ j+1)+         , xs VU.! (j+0)+         ) | j >= 0, j < 100 ]++prop_O_ItCC ix@(O (PointL j)) = zs == ls where+  t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)+  zs = ((,,) <<< t % chr xs % chr xs ... S.toList) (O $ maxPL) ix+  ls = [ ( unsafeIndex xsPo (O $ PointL $ j+2)+         , xs VU.! (j+0)+         , xs VU.! (j+1)+         ) | j >= 0, j <= 98 ]+{-# Noinline prop_O_ItCC #-}++prop_O_ZItCC ix@(O (Z:.PointL j)) = zs == ls where+  t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1)+  zs = ((,,) <<< t % (M:|chr xs) % (M:|chr xs) ... S.toList) (O (Z:.maxPL)) ix+  ls = [ ( unsafeIndex xsZPo (O (Z:.PointL (j+2)))+         , Z:.xs VU.! (j+0)+         , Z:.xs VU.! (j+1)+         ) | j >= 0, j <= 98 ]++-- | synvar followed by a 2-tape character terminal++prop_2dimItCC ix@(Z:.PointL j:.PointL l) = zs == ls where+  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPP (\ _ _ -> Id 1)+  zs = ((,,) <<< t % (M:|chr xs:|chr xs) % (M:|chr xs:|chr xs) ... S.toList) (Z:.maxPL:.maxPL) ix+  ls = [ ( unsafeIndex xsPP (Z:.PointL (j-2):.PointL (l-2))+         , Z:.xs VU.! (j-2):.xs VU.! (l-2)+         , Z:.xs VU.! (j-1):.xs VU.! (l-1)+         ) | j>=2, l>=2, j<=100, l<=100 ]++prop_O_2dimItCC ix@(O (Z:.PointL j:.PointL l)) = zs == ls where+  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPPo (\ _ _ -> Id 1)+  zs = ((,,) <<< t % (M:|chr xs:|chr xs) % (M:|chr xs:|chr xs) ... S.toList) (O (Z:.maxPL:.maxPL)) ix+  ls = [ ( unsafeIndex xsPPo (O (Z:.PointL (j+2):.PointL (l+2)))+         , Z:.xs VU.! (j+0):.xs VU.! (l+0)+         , Z:.xs VU.! (j+1):.xs VU.! (l+1)+         ) | j>=0, l>=0, j<=98, l<=98 ]++-- * direct index tests++xprop_O_ixZItCC ix@(O (Z:.PointL j)) = zs where+  t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1)+  zs = (id >>> t % (M:|chr xs) % (M:|chr xs) ... S.toList) (O (Z:.maxPL)) ix++-- * 'Strng' tests++-- ** Just the 'Strng' terminal++prop_ManyS ix@(PointL j) = zs == ls where+  zs = (id <<< manyS xs ... S.toList) maxPL ix+  ls = [ (VU.slice 0 j xs) ]++prop_SomeS ix@(PointL j) = zs == ls where+  zs = (id <<< someS xs ... S.toList) maxPL ix+  ls = [ (VU.slice 0 j xs) | j>0 ]++prop_2dim_ManyS_ManyS ix@(Z:.PointL i:.PointL j) = zs == ls where+  zs = (id <<< (M:|manyS xs:|manyS xs) ... S.toList) (Z:.maxPL:.maxPL) ix+  ls = [ (Z:.VU.slice 0 i xs:.VU.slice 0 j xs) ]++prop_2dim_SomeS_SomeS ix@(Z:.PointL i:.PointL j) = zs == ls where+  zs = (id <<< (M:|someS xs:|someS xs) ... S.toList) (Z:.maxPL:.maxPL) ix+  ls = [ (Z:.VU.slice 0 i xs:.VU.slice 0 j xs) | i > 0 && j > 0 ]++-- ** Together with a syntactic variable.++prop_Itbl_ManyS ix@(PointL i) = zs == ls where+  t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1)+  zs = ((,) <<< t % manyS xs ... S.toList) maxPL ix+  ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i] ]++prop_Itbl_SomeS ix@(PointL i) = zs == ls where+  t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1)+  zs = ((,) <<< t % someS xs ... S.toList) maxPL ix+  ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i-1] ]++prop_1dim_Itbl_ManyS ix@(Z:.PointL i) = zs == ls where+  t = ITbl 0 0 (Z:.EmptyOk) xsZP (\ _ _ -> Id 1)+  zs = ((,) <<< t % (M:|manyS xs) ... S.toList) (Z:.maxPL) ix+  ls = [ (unsafeIndex xsZP (Z:.PointL k), Z:. VU.slice k (i-k) xs) | k <- [0..i] ]++prop_1dim_Itbl_SomeS ix@(Z:.PointL i) = zs == ls where+  t = ITbl 0 0 (Z:.EmptyOk) xsZP (\ _ _ -> Id 1)+  zs = ((,) <<< t % (M:|someS xs) ... S.toList) (Z:.maxPL) ix+  ls = [ (unsafeIndex xsZP (Z:.PointL k), Z:. VU.slice k (i-k) xs) | k <- [0..i-1] ]++prop_2dim_Itbl_ManyS_ManyS ix@(Z:.PointL i:.PointL j) = zs == ls where+  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPP (\ _ _ -> Id 1)+  zs = ((,) <<< t % (M:|manyS xs:|manyS xs) ... S.toList) (Z:.maxPL:.maxPL) ix+  ls = [ (unsafeIndex xsPP (Z:.PointL k:.PointL l), Z:. VU.slice k (i-k) xs :. VU.slice l (j-l) xs) | k <- [0..i], l <- [0..j] ]++prop_2dim_Itbl_SomeS_SomeS ix@(Z:.PointL i:.PointL j) = zs == ls where+  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPP (\ _ _ -> Id 1)+  zs = ((,) <<< t % (M:|someS xs:|someS xs) ... S.toList) (Z:.maxPL:.maxPL) ix+  ls = [ (unsafeIndex xsPP (Z:.PointL k:.PointL l), Z:. VU.slice k (i-k) xs :. VU.slice l (j-l) xs) | k <- [0..i-1], l <- [0..j-1] ]+++++infixl 8 >>>+(>>>) f xs = \lu ij -> S.map f . mkStream (build xs) (initialContext ij) lu $ ij++class GetIxs x i where+  type R x i :: *+  getIxs :: Elm x i -> R x i++instance GetIxs S i where+  type R S i = Z:.(i,i)+  getIxs e = Z:.(getIdx e, getOmx e)++instance GetIxs ls i => GetIxs (ls :!: Chr a b) i where+  type R (ls :!: Chr a b) i = R ls i :. (i,i)+  getIxs (ElmChr _ i o s) = getIxs s :. (i,o)++instance GetIxs ls i => GetIxs (ls :!: ITbl m a i x) i where+  type R (ls :!: ITbl m a i x) i = R ls i :. (i,i)+  getIxs (ElmITbl _ i o s) = getIxs s :. (i,o)++xsP :: Unboxed (PointL) Int+xsP = fromList (PointL 0) maxPL [0 ..]++xsZP :: Unboxed (Z:.PointL) Int+xsZP = fromList (Z:.PointL 0) (Z:.maxPL) [0 ..]++xsPo :: Unboxed (Outside (PointL)) Int+xsPo = fromList (O $ PointL 0) (O $ maxPL) [0 ..]++xsZPo :: Unboxed (Outside (Z:.PointL)) Int+xsZPo = fromList (O (Z:.PointL 0)) (O (Z:.maxPL)) [0 ..]++xsPP :: Unboxed (Z:.PointL:.PointL) Int+xsPP = fromList (Z:.PointL 0:.PointL 0) (Z:.maxPL:.maxPL) [0 ..]++xsPPo :: Unboxed (Outside (Z:.PointL:.PointL)) Int+xsPPo = fromList (O (Z:.PointL 0:.PointL 0)) (O (Z:.maxPL:.maxPL)) [0 ..]++mxsPP = unsafePerformIO $ zzz where+  zzz :: IO (MutArr IO (Unboxed (Z:.PointL:.PointL) Int))+  zzz = fromListM (Z:.PointL 0:.PointL 0) (Z:.maxPL:.maxPL) [0 ..]++maxPL = PointL 100++xs = VU.fromList [0 .. 99 :: Int]++-- * general quickcheck stuff++options = stdArgs {maxSuccess = 1000}++customCheck = quickCheckWithResult options++return []+allProps = $forAllProperties customCheck+
+ ADP/Fusion/QuickCheck/Set.hs view
@@ -0,0 +1,248 @@++{-# Options_GHC -O0 #-}++module ADP.Fusion.QuickCheck.Set where++import           Data.Bits+import           Data.Vector.Fusion.Util+import           Debug.Trace+import qualified Data.List as L+import qualified Data.Vector.Fusion.Stream as S+import qualified Data.Vector.Unboxed as VU+import           Test.QuickCheck hiding (NonEmpty)+import           Test.QuickCheck.All+import           Test.QuickCheck.Monadic++import           Data.Bits.Ordered+import           Data.PrimitiveArray++import           ADP.Fusion+import           ADP.Fusion.QuickCheck.Common++++-- * BitSets without interfaces++-- ** Inside checks++prop_b_ii ix@(BitSet _) = zs == ls where+  tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)+  tib = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)+  zs = ((,) <<< tia % tib ... S.toList) highestB ix+  ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) )+       | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ]+       , let kk = popShiftL ix (BitSet k)+       ]++prop_b_ii_nn ix@(BitSet _) = zs == ls where+  tia = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)+  tib = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)+  zs = ((,) <<< tia % tib ... S.toList) highestB ix+  ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) )+       | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ]+       , let kk = popShiftL ix (BitSet k)+       , popCount kk > 0+       , popCount (ix `xor` kk) > 0+       ]++prop_b_iii ix@(BitSet _) = zs == ls where+  tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)+  tib = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)+  tic = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)+  zs = ((,,) <<< tia % tib % tic ... S.toList) highestB ix+  ls = [ ( xsB ! kk , xsB ! ll , xsB ! mm )+       | k <- VU.toList . popCntSorted $ popCount ix+       , l <- VU.toList . popCntSorted $ popCount ix - popCount k+       , let kk = popShiftL ix          (BitSet k)+       , let ll = popShiftL (ix `xor` kk) (BitSet l)+       , let mm = (ix `xor` (kk .|. ll))+       ]++prop_b_iii_nnn ix@(BitSet _) = zs == ls where+  tia = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)+  tib = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)+  tic = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)+  zs = ((,,) <<< tia % tib % tic ... S.toList) highestB ix+  ls = [ ( xsB ! kk , xsB ! ll , xsB ! mm )+       | k <- VU.toList . popCntSorted $ popCount ix+       , l <- VU.toList . popCntSorted $ popCount ix - popCount k+       , let kk = popShiftL ix          (BitSet k)+       , let ll = popShiftL (ix `xor` kk) (BitSet l)+       , let mm = (ix `xor` (kk .|. ll))+       , popCount kk > 0, popCount ll > 0, popCount mm > 0+       ]+++-- * Outside checks+-- These checks are very similar to those in the @Subword@ module. We just+-- need to be a bit more careful, as indexed sets have overlap.++-- ** Two non-terminals.+--+-- @A_s -> B_(s\t) C_t    (s\t) ++ t == s@+-- @s = 111 , s\t = 101, t = 010@+--+-- with @Z@ the full set.+-- @Z = 1111@++-- @B*_Z\(s\t) -> A*_Z\s C_t@+-- @Z\(s\t) = 1010, Z\s = 1000, t = 010@+++++-- * BitSets with two interfaces++-- ** Inside checks++prop_bii_i :: BS2I First Last -> Bool+prop_bii_i ix@(s:>i:>j) = zs == ls where+  tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)+  zs = (id <<< tia ... S.toList) highestBII ix+  ls = [ xsBII ! ix ]++prop_bii_i_n :: BS2I First Last -> Bool+prop_bii_i_n ix@(s:>i:>j) = zs == ls where+  tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)+  zs = (id <<< tia ... S.toList) highestBII ix+  ls = [ xsBII ! ix | popCount s > 0 ]++-- | Edges should never work as a single terminal element.++prop_bii_e :: BS2I First Last -> Bool+prop_bii_e ix@(s:>Iter i:>Iter j) = zs == ls where+  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)+  zs = (id <<< e ... S.toList) highestBII ix+  ls = [] :: [ (Int,Int) ]++-- | Edges extend only in cases where in @i -> j@, @i@ actually happens to+-- be a true interface.++prop_bii_ie :: BS2I First Last -> Bool+prop_bii_ie ix@(s:>i:>Iter j) = zs == ls where+  tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)+  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)+  zs = ((,) <<< tia % e ... S.toList) highestBII ix+  ls = [ ( xsBII ! (t:>i:>(Iter k :: Interface Last)) , (k,j) )+       | let t = s `clearBit` j+       , k <- activeBitsL t ]++prop_bii_ie_n :: BS2I First Last -> Bool+prop_bii_ie_n ix@(s:>i:>Iter j) = zs == ls where+  tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)+  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)+  zs = ((,) <<< tia % e ... S.toList) highestBII ix+  ls = [ ( xsBII ! (t:>i:>(Iter k :: Interface Last)) , (k,j) )+       | let t = s `clearBit` j+       , popCount t >= 2+       , k <- activeBitsL t+       , k /= getIter i+       ]++prop_bii_iee :: BS2I First Last -> Bool+prop_bii_iee ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where+  tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)+  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)+  zs = ((,,) <<< tia % e % e ... S.toList) highestBII ix+  ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,j) )+       | let tmp = (s `clearBit` j)+       , l <- activeBitsL tmp+       , l /= getIter i+       , let t = tmp `clearBit` l+       , k <- activeBitsL t+       , let kk = Iter k+       ]++prop_bii_ieee :: BS2I First Last -> Bool+prop_bii_ieee ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where+  tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)+  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)+  zs = ((,,,) <<< tia % e % e % e ... S.toList) highestBII ix+  ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,m) , (m,j) )+       | let tmpM = (s `clearBit` j)+       , m <- activeBitsL tmpM+       , m /= getIter i+       , let tmpL = (tmpM `clearBit` m)+       , l <- activeBitsL tmpL+       , l /= getIter i+       , let t = tmpL `clearBit` l+       , k <- activeBitsL t+       , let kk = Iter k+       ]++prop_bii_iee_n :: BS2I First Last -> Bool+prop_bii_iee_n ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where+  tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)+  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)+  zs = ((,,) <<< tia % e % e ... S.toList) highestBII ix+  ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,j) )+       | let tmp = (s `clearBit` j)+       , l <- activeBitsL tmp+       , l /= getIter i+       , let t = tmp `clearBit` l+       , popCount t >= 2+       , k <- activeBitsL t+       , k /= getIter i+       , let kk = Iter k+       ]++prop_bii_ieee_n :: BS2I First Last -> Bool+prop_bii_ieee_n ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where+  tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)+  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)+  zs = ((,,,) <<< tia % e % e % e ... S.toList) highestBII ix+  ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,m) , (m,j) )+       | let tmpM = (s `clearBit` j)+       , m <- activeBitsL tmpM+       , m /= getIter i+       , let tmpL = (tmpM `clearBit` m)+       , l <- activeBitsL tmpL+       , l /= getIter i+       , let t = tmpL `clearBit` l+       , popCount t >= 2+       , k <- activeBitsL t+       , k /= getIter i+       , let kk = Iter k+       ]++-- prop_bii_ii (ix@(s:>i:>j) :: (BitSet:>Interface First:>Interface Last)) = tr zs ls $ zs == ls where+--   tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)+--   tib = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)+--   zs = ((,) <<< tia % tib ... S.toList) highestBII ix+--   ls = [ ( xsBII ! kk , xsBII ! ll )+--        | k  <- VU.toList . popCntSorted $ popCount s+--        , ki <- if k==0 then [0] else activeBitsL k+--        , kj <- if | k==0 -> [0] | popCount k==1 -> [ki] | otherwise -> activeBitsL (k `clearBit` ki)+--        , let kk = (BitSet k:>Iter ki:>Iter kj)+--        , let l  = s `xor` BitSet k+--        , li <- if l==0 then [0] else activeBitsL l+--        , lj <- if | l==0 -> [0] | popCount l==1 -> [li] | otherwise -> activeBitsL (l `clearBit` li)+--        , let ll = (l:>Iter li:>Iter lj)+--        ]++++-- * Helper functions++highBit = fromIntegral arbitraryBitSetMax -- should be the same as the highest bit in Index.Set.arbitrary+highestB = BitSet $ 2^(highBit+1) -1+highestBII = highestB :> Iter (highBit-1) :> Iter (highBit-1) -- assuming @highBit >= 1@++xsB :: Unboxed BitSet Int+xsB = fromList (BitSet 0) highestB [ 0 .. ]++xoB :: Unboxed (Outside BitSet) Int+xoB = fromList (O (BitSet 0)) (O highestB) [ 0 .. ]++xsBII :: Unboxed (BitSet:>Interface First:>Interface Last) Int+xsBII = fromList (BitSet 0:>Iter 0:>Iter 0) highestBII [ 0 .. ]++-- * general quickcheck stuff++options = stdArgs {maxSuccess = 1000}++customCheck = quickCheckWithResult options++return []+allProps = $forAllProperties customCheck+
+ ADP/Fusion/QuickCheck/Subword.hs view
@@ -0,0 +1,171 @@++{-# Options_GHC -O0 #-}++module ADP.Fusion.QuickCheck.Subword where++import           Test.QuickCheck+import           Test.QuickCheck.All+import           Test.QuickCheck.Monadic+import qualified Data.Vector.Fusion.Stream as S+import           Data.Vector.Fusion.Util+import           Debug.Trace+import qualified Data.List as L+import qualified Data.Vector.Unboxed as VU++import           Data.PrimitiveArray++import           ADP.Fusion+import           ADP.Fusion.QuickCheck.Common++++-- * Outside checks++-- ** two non-terminals on the r.h.s.+--+-- A_ij -> B_ik C_kj+--+-- B*_ik -> A*_ij C_kj+-- C*_kj -> B_ik  A*_ij++prop_sv_OI ox@(O (Subword (i:.k))) = zs == ls where+  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))+  tic = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))+  zs = ((,) <<< toa % tic ... S.toList) (O $ subword 0 highest) ox+  ls = [ ( unsafeIndex xoS (O $ subword i j)+         , unsafeIndex xsS (    subword k j) )+       | j <- [ k .. highest ] ]++prop_sv_IO ox@(O (Subword (k:.j))) = zs == ls where+  tib = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))+  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))+  zs = ((,) <<< tib % toa ... S.toList) (O $ subword 0 highest) ox+  ls = [ ( unsafeIndex xsS (    subword i k)+         , unsafeIndex xoS (O $ subword i j) )+       | j <= highest, i <- [ 0 .. k ] ]++-- ** three non-terminals on the r.h.s. (this provides situations where two+-- syntactic terminals are on the same side)+--+-- A_ij -> B_ik C_kl D_lj+--+-- B*_ik -> A*_ij C_kl  D_lj+-- C*_kl -> B_ik  A*_ij D_lj+-- D*_lj -> B_ik  C_kl  A*_ij++prop_sv_OII ox@(O (Subword (i:.k))) = zs == ls where+  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))+  tic = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))+  tid = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))+  zs = ((,,) <<< toa % tic % tid ... S.toList) (O $ subword 0 highest) ox+  ls = [ ( unsafeIndex xoS (O $ subword i j)+         , unsafeIndex xsS (    subword k l)+         , unsafeIndex xsS (    subword l j) )+       | j <- [ k .. highest ], l <- [ k .. j ] ]++prop_sv_IOI ox@(O (Subword (k:.l))) = zs == ls where+  tib = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))+  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))+  tid = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))+  zs = ((,,) <<< tib % toa % tid ... S.toList) (O $ subword 0 highest) ox+  ls = [ ( unsafeIndex xsS (    subword i k)+         , unsafeIndex xoS (O $ subword i j)+         , unsafeIndex xsS (    subword l j) )+       | i <- [ 0 .. k ], j <- [ l .. highest ] ]++prop_sv_IIO ox@(O (Subword (l:.j))) = zs == ls where+  tib = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))+  tic = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))+  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))+  zs = ((,,) <<< tib % tic % toa ... S.toList) (O $ subword 0 highest) ox+  ls = [ ( unsafeIndex xsS (    subword i k)+         , unsafeIndex xsS (    subword k l)+         , unsafeIndex xoS (O $ subword i j) )+       | j <= highest, i <- [ 0 .. l ], k <- [ i .. l ] ]++-- ** four non-terminals on the r.h.s. ?++-- ** five non-terminals on the r.h.s. ?++-- ** Non-terminal and terminal combinations++prop_cOc ox@(O( Subword (i:.j))) = zs == ls where+  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))+  zs  = ((,,) <<< chr csS % toa % chr csS ... S.toList) (O $ subword 0 highest) ox+  ls  = [ ( csS VU.! (i-1)+          , unsafeIndex xoS (O $ subword (i-1) (j+1))+          , csS VU.! (j  ) )+        | i > 0 && j < highest ]++prop_ccOcc ox@(O(Subword (i:.j))) = zs == ls where+  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))+  zs  = ((,,,,) <<< chr csS % chr csS % toa % chr csS % chr csS ... S.toList) (O $ subword 0 highest) ox+  ls  = [ ( csS VU.! (i-2)+          , csS VU.! (i-1)+          , unsafeIndex xoS (O $ subword (i-2) (j+2))+          , csS VU.! (j  )+          , csS VU.! (j+1) )+        | i > 1 && j < highest -1 ]++prop_cOccc ox@(O(Subword (i:.j))) = zs == ls where+  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))+  zs  = ((,,,,) <<< chr csS % toa % chr csS % chr csS % chr csS ... S.toList) (O $ subword 0 highest) ox+  ls  = [ ( csS VU.! (i-1)+          , unsafeIndex xoS (O $ subword (i-1) (j+3))+          , csS VU.! (j  )+          , csS VU.! (j+1)+          , csS VU.! (j+2) )+        | i > 0 && j < highest -2 ]++-- ** Terminals, syntactic terminals, and non-terminals++prop_cOcIc ox@(O (Subword (i:.k))) = zs == ls where+  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))+  tic = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))+  zs = ((,,,,) <<< chr csS % toa % chr csS % tic % chr csS ... S.toList) (O $ subword 0 highest) ox+  ls = [ ( csS VU.! (i-1)+         , unsafeIndex xoS (O $ subword (i-1)  j    )+         , csS VU.! (k  )+         , unsafeIndex xsS (    subword (k+1) (j-1) )+         , csS VU.! (j-1) )+       | i > 0, j <- [ k+2 .. highest ] ]++prop_cIcOc ox@(O (Subword (k:.j))) = zs == ls where+  tib = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))+  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))+  zs = ((,,,,) <<< chr csS % tib % chr csS % toa % chr csS ... S.toList) (O $ subword 0 highest) ox+  ls = [ ( csS VU.! (i  )+         , unsafeIndex xsS (    subword (i+1) (k-1))+         , csS VU.! (k-1)+         , unsafeIndex xoS (O $ subword  i    (j+1))+         , csS VU.! (j  ) )+       | j+1 <= highest, k>1, i <- [ 0 .. k-2 ] ]++-- ** Epsilonness++prop_Epsilon ox@(O (Subword (i:.j))) = zs == ls where+  zs = (id <<< Epsilon ... S.toList) (O $ subword 0 highest) ox+  ls = [ () | i==0 && j==highest ]++++highest = 2++csS :: VU.Vector (Int,Int)+csS = VU.fromList [ (i,i+1) | i <- [0 .. highest] ] -- this should be @highest -1@, we should die if we see @(highest,highest+1)@++xsS :: Unboxed Subword (Int,Int)+xsS = fromList (subword 0 0) (subword 0 highest) [ (i,j) | i <- [ 0 .. highest ] , j <- [ i .. highest ] ]++xoS :: Unboxed (Outside Subword) (Int,Int)+xoS = fromList (O $ subword 0 0) (O $ subword 0 highest) [ (i,j) | i <- [ 0 .. highest ] , j <- [ i .. highest ] ]++-- * general quickcheck stuff++options = stdArgs {maxSuccess = 10000}++customCheck = quickCheckWithResult options++return []+allProps = $forAllProperties customCheck+
− ADP/Fusion/Region.hs 
@@ -1,148 +0,0 @@-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-}--module ADP.Fusion.Region where--import Data.Array.Repa.Index-import Data.Strict.Tuple-import Data.Vector.Fusion.Stream.Size-import qualified Data.Vector.Fusion.Stream.Monadic as S-import qualified Data.Vector.Unboxed as VU-import Data.Strict.Maybe-import Prelude hiding (Maybe(..))--import Data.Array.Repa.Index.Subword--import ADP.Fusion.Classes--import Control.Exception (assert)-import Debug.Trace------ * Regions of unlimited size--data Region x = Region !(VU.Vector x)--instance Build (Region x)--instance-  ( ValidIndex ls Subword-  , VU.Unbox xs-  ) => ValidIndex (ls :!: Region xs) Subword where-  validIndex (ls :!: Region xs) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =-    i>=a && j<=VU.length xs -c && i+b<=j && validIndex ls abc ij-  {-# INLINE validIndex #-}-  getParserRange (ls :!: Region xs) ix = let (a:!:b:!:c) = getParserRange ls ix in (a:!:b:!:c)-  {-# INLINE getParserRange #-}--instance-  ( Elms ls Subword-  ) => Elms (ls :!: Region x) Subword where-  data Elm (ls :!: Region x) Subword = ElmRegion !(Elm ls Subword) !(VU.Vector x) !Subword-  type Arg (ls :!: Region x)         = Arg ls :. VU.Vector x-  getArg !(ElmRegion ls xs _) = getArg ls :. xs-  getIdx !(ElmRegion _ _   i) = i-  {-# INLINE getArg #-}-  {-# INLINE getIdx #-}--instance-  ( Monad m-  , VU.Unbox x-  , Elms ls Subword-  , MkStream m ls Subword-  ) => MkStream m (ls:!:Region x) Subword where-  mkStream !(ls:!:Region xs) Outer !ij@(Subword (i:.j))-    = S.map (\s -> let (Subword (k:.l)) = getIdx s in ElmRegion s (VU.unsafeSlice l (j-l) xs) (subword l j))-    $ mkStream ls (Inner Check Nothing) ij-  mkStream !(ls:!:Region xs) (Inner _ szd) !ij@(Subword (i:.j)) = S.flatten mk step Unknown $ mkStream ls (Inner NoCheck Nothing) ij where-      mk !s = let (Subword (k:.l)) = getIdx s-                  l' = case szd of Nothing -> l-                                   Just z  -> max l (j-z)-              in  return (s :!: l :!: l')-      step !(s :!: k :!: l)-        | l > j     =  return S.Done-        | otherwise = return $ S.Yield (ElmRegion s (VU.unsafeSlice k (l-k) xs) (subword k l)) (s :!: k :!: l+1)-  {-# INLINE mkStream #-}--region :: VU.Vector x -> Region x-region = Region-{-# INLINE region #-}------ * Regions of unlimited size--data SRegion x = SRegion !Int !Int !(VU.Vector x)--instance Build (SRegion x)--instance-  ( ValidIndex ls Subword-  , VU.Unbox xs-  ) => ValidIndex (ls :!: SRegion xs) Subword where-  validIndex (ls :!: SRegion lb ub xs) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =-    i>=a && j<=VU.length xs -c && i+b<=j && validIndex ls abc ij-  {-# INLINE validIndex #-}-  getParserRange (ls :!: SRegion lb ub xs) ix = let (a:!:b:!:c) = getParserRange ls ix in (a:!:b+lb:!:max 0 (c-lb))-  {-# INLINE getParserRange #-}--instance-  ( Elms ls Subword-  ) => Elms (ls :!: SRegion x) Subword where-  data Elm (ls :!: SRegion x) Subword = ElmSRegion !(Elm ls Subword) !(VU.Vector x) !Subword-  type Arg (ls :!: SRegion x)         = Arg ls :. VU.Vector x-  getArg !(ElmSRegion ls xs _) = getArg ls :. xs-  getIdx !(ElmSRegion _ _   i) = i-  {-# INLINE getArg #-}-  {-# INLINE getIdx #-}---- |------ TODO Check that all inner / outer sized calculations are correct------ NOTE mkStream/Inner gives a size hint of Nothing, as in purely inner cases,--- min/max boundaries are determined solely from the running rightmost index--- from the next inner component.------ NOTE the filter in mkStream/Outer is still necessary to check for--- lowerbound>0 conditions. We /could/ send the lower bound down with another--- size hint, but this only makes sense if you have use cases, where the lower--- bound is a lot higher than "0". Otherwise the current code is simpler.------ TODO use drop instead of filter: still condition, but large lower bounds are captured------ TODO remove mkStream/Outer : filter and test if one condition less gives--- much better runtimes.--instance-  ( Monad m-  , VU.Unbox x-  , Elms ls Subword-  , MkStream m ls Subword-  ) => MkStream m (ls:!:SRegion x) Subword where-  mkStream !(ls:!:SRegion lb ub xs) Outer !ij@(Subword (i:.j))-    = S.map (\s -> let (Subword (k:.l)) = getIdx s in assert (l>=0 && j-i>=0) $ ElmSRegion s (VU.slice l (j-l) xs) (subword l j))-    $ S.filter (\s -> let (Subword (k:.l)) = getIdx s in (j-l >= lb && j-l <= ub))-    $ mkStream ls (Inner Check (Just ub)) ij-  mkStream !(ls:!:SRegion lb ub xs) (Inner _ szd) !ij@(Subword (i:.j)) = S.flatten mk step Unknown $ mkStream ls (Inner NoCheck Nothing) ij where-      mk !s = let (Subword (k:.l)) = getIdx s-                  l' = case szd of Nothing -> l+lb-                                   Just z  -> max (l+lb) (j-z)-              in  return (s :!: l :!: l')-      step !(s :!: k :!: l)-        | l>j || l-k>ub =  return S.Done-        | otherwise     = return $ assert (k>=0 && l-k>=0) $ S.Yield (ElmSRegion s (VU.slice k (l-k) xs) (subword k l)) (s :!: k :!: l+1)-  {-# INLINE mkStream #-}---- |-sregion :: Int -> Int -> VU.Vector x -> SRegion x-sregion = SRegion-{-# INLINE sregion #-}-
+ ADP/Fusion/SynVar.hs view
@@ -0,0 +1,17 @@++-- | This module re-exports all table types.++module ADP.Fusion.SynVar+  ( module ADP.Fusion.SynVar.Array+  , module ADP.Fusion.SynVar.Axiom+  , module ADP.Fusion.SynVar.Backtrack+  , module ADP.Fusion.SynVar.Fill+  , module ADP.Fusion.SynVar.Recursive+  ) where++import ADP.Fusion.SynVar.Array+import ADP.Fusion.SynVar.Axiom+import ADP.Fusion.SynVar.Backtrack+import ADP.Fusion.SynVar.Fill+import ADP.Fusion.SynVar.Recursive+
+ ADP/Fusion/SynVar/Array.hs view
@@ -0,0 +1,292 @@++module ADP.Fusion.SynVar.Array+  ( module ADP.Fusion.SynVar.Array.Type+  , module ADP.Fusion.SynVar.Array.Point+  , module ADP.Fusion.SynVar.Array.Set+  , module ADP.Fusion.SynVar.Array.Subword+  ) where++import ADP.Fusion.SynVar.Array.Point+import ADP.Fusion.SynVar.Array.Set+import ADP.Fusion.SynVar.Array.Subword+import ADP.Fusion.SynVar.Array.Type++{-++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RankNTypes #-}++{-# LANGUAGE MagicHash #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}++-- | Tables in ADPfusion memoize results of parses. In the forward phase, table+-- cells are filled by a table-filling method from @Data.PrimitiveArray@. In+-- the backtracking phase, grammar rules are associated with tables to provide+-- efficient backtracking.+--+-- TODO multi-dim tables with 'OnlyZero' need a static check!+--+-- TODO PointL , PointR need sanity checks for boundaries+--+-- TODO the sanity checks are acutally a VERY BIG TODO since currently we do+-- not protect against stupidity at all!+--+-- TODO have boxed tables for top-down parsing.+--+-- TODO combine forward and backward phases to simplify the external interface+-- to the programmer.+--+-- TODO include the notion of @interfaces@ into tables. With Outside+-- grammars coming up now, we need this.++module ADP.Fusion.Table.Array+--  ( MTbl      (..)+--  , BtTbl     (..)+  ( ITbl      (..)+--  , Backtrack (..)+  , ToBT (..)+  ) where++import           Control.Exception(assert)+import           Control.Monad.Primitive (PrimMonad)+import           Data.Vector.Fusion.Stream.Size (Size(Unknown))+import qualified Data.Vector as V+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed as VU+import           GHC.Exts+import           Data.Bits++import           Data.PrimitiveArray -- (Z(..), (:.)(..), Subword(..), subword, PointL(..), pointL, PointR(..), pointR,topmostIndex, Outside(..))+import qualified Data.PrimitiveArray as PA++import           ADP.Fusion.Classes+import           ADP.Fusion.Multi.Classes+import           ADP.Fusion.Table.Axiom+import           ADP.Fusion.Table.Backtrack+import           ADP.Fusion.Table.Indices++import           Debug.Trace++++-- ** Mutable fill-phase tables.++-- | The backtracking version.++++++-- TODO empty table @ms@ stuff++instance+  ( Monad m+  , Element ls (BS2I First Last)+  , PA.PrimArrayOps arr (BS2I First Last) x+  , MkStream m ls (BS2I First Last)+  ) => MkStream m (ls :!: ITbl m arr (BS2I First Last) x) (BS2I First Last) where+  -- outermost case. Grab inner indices, calculate the remainder of the+  -- set, return value+  mkStream (ls :!: ITbl c t _) Static s (BitSet b:>Interface i:>Interface j)+    = S.map (\z -> let (BitSet zb:>_:>Interface zj) = getIdx z  -- the bitset we get from the guy before us+                       here = (BitSet (b `xor` zb .|. zj):>Interface zj:>Interface j) -- everything missing, set common interface+                   in  ElmITbl (t PA.! here) here z+            )+    $ mkStream ls (Variable Check Nothing) s (BitSet (clearBit b j):>Interface i:>Interface j)+  -- generate all possible subsets of the index. With A @Variable+  -- _ Nothing@, there is something to the right that will fill up the set.+  mkStream (ls :!: ITbl c t _) (Variable Check Nothing) full (BitSet b:>Interface i:>Interface j)+    = S.flatten mk step Unknown+    $ mkStream ls (Variable Check Nothing) full (BitSet b:>Interface i:>Interface j)+    where mk z = return (z,Just $ BitSet 0:>Interface 0:>Interface 0)+          step (_,Nothing) = return $ S.Done+          step (z,Just s ) = return $ S.Yield (ElmITbl (t PA.! s) s z) (z,succSet full s)+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  -- generate only those indices with the requested number of set bits+  {-# Inline mkStream #-}++instance+  ( Monad mB+  , Element ls (BS2I First Last)+  , PA.PrimArrayOps arr (BS2I First Last) x+  , MkStream mB ls (BS2I First Last)+  ) => MkStream mB (ls :!: BT (ITbl mF arr (BS2I First Last) x) mF mB r) (BS2I First Last) where+  mkStream (ls :!: BtITbl c arr bt) Static full (BitSet b:>Interface i:>Interface j)+    = S.map (\z -> let (BitSet zb:>Interface zi:>Interface zj) = getIdx z+                       here = BitSet (clearBit b j):>Interface i:>Interface zj+                       d = arr PA.! here+                   in ElmBtITbl' d (bt full here) here z)+    $ mkStream ls (Variable Check Nothing) full (BitSet (clearBit b j):>Interface i:>Interface (-1))+  mkStream (ls :!: BtITbl c arr bt) (Variable Check Nothing) full (BitSet b:>Interface i:>Interface j)+    = S.flatten mk step Unknown+    $ mkStream ls (Variable Check Nothing) full (BitSet b:>Interface i:>Interface j)+    where mk z = return (z,Just $ BitSet 0:>Interface 0:>Interface 0)+          step (_,Nothing) = return $ S.Done+          step (z,Just s ) = return $ S.Yield (ElmBtITbl' (arr PA.! s) (bt full s) s z) (z,succSet full s)+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  {-# Inline mkStream #-}++instance+  ( Monad m+  , Element ls (Outside PointL)+  , PA.PrimArrayOps arr (Outside PointL) x+  , MkStream m ls (Outside PointL)+  ) => MkStream m (ls :!: ITbl m arr (Outside PointL) x) (Outside PointL) where+  mkStream (ls :!: ITbl c t _) Static lu (O (PointL (i:.j)))+    = let ms = minSize c in seq ms $ seq t $+    S.mapM (\s -> let O (PointL (h:.k)) = getIdx s+                  in  return $ ElmITbl (t PA.! O (pointL k j)) (O $ pointL k j) s)+    $ mkStream ls (Variable Check Nothing) lu (O . pointL i $ j + ms)+--  mkStream _ _ _ _ = error "mkStream / ITbl / Outside PointL not implemented"+  {-# INLINE mkStream #-}++instance+  ( Monad mB+  , Element ls (Outside PointL)+  , PA.PrimArrayOps arr (Outside PointL) x+  , MkStream mB ls (Outside PointL)+  ) => MkStream mB (ls :!: BT (ITbl mF arr (Outside PointL) x) mF mB r) (Outside PointL) where+  mkStream (ls :!: BtITbl c arr bt) Static lu (O (PointL (i:.j)))+    = let ms = minSize c in ms `seq`+    S.map (\s -> let O (PointL (h:.k)) = getIdx s+                     ix                = O $ pointL k j+                     d                 = arr PA.! ix+                 in ElmBtITbl' d (bt lu ix) ix s)+    $ mkStream ls (Variable Check Nothing) lu (O . pointL i $ j + ms)+--  mkStream _ _ _ _ = error "mkStream / BT ITbl / Outside PointL not implemented"+  {-# INLINE mkStream #-}++-- | TODO As soon as we don't do static checking on @EmptyOk/NonEmpty@+-- anymore, this works! If we check @c@, we immediately have fusion+-- breaking down!++{-+instance+  ( Monad m+  , Element ls Subword+  , PA.PrimArrayOps arr Subword x+  , MkStream m ls Subword+  ) => MkStream m (ls :!: ITbl m arr Subword x) Subword where+  mkStream (ls :!: ITbl c t _) Static lu (Subword (i:.j))+    = let ms = minSize c in ms `seq`+      S.mapM (\s -> let Subword (_:.l) = getIdx s+                    in  return $ ElmITbl (t PA.! subword l j) (subword l j) s)+    $ mkStream ls (Variable Check Nothing) lu (subword i $ j - ms) -- - minSize c)+  mkStream (ls :!: ITbl c t _) (Variable _ Nothing) lu (Subword (i:.j))+    = let ms = minSize c+          {- data PBI a = PBI !a !(Int#)+          mk s = let (Subword (_:.l)) = getIdx s ; !(I# jlm) = j-l-ms in return $ PBI s jlm+          step !(PBI s z) | 1# <- z >=# 0# = do let (Subword (_:.k)) = getIdx s+                                                return $ S.Yield (ElmITbl (t PA.! subword k (j-(I# z))) (subword k $ j-(I# z)) s) (PBI s (z -# 1#))+                          | otherwise = return S.Done+          -}+          {-+          mk s = let (Subword (_:.l)) = getIdx s in return (s :. j - l - ms)+          step (s:.z) | 1# <- z' >=# 0# = do let (Subword (_:.k)) = getIdx s+                                             return $ S.Yield (ElmITbl (t PA.! subword k (j-z)) (subword k $ j-z) s) (s:.z-1)+                      | otherwise = return S.Done+                      where !(I# z') = z+          -}+          mk s = let (Subword (_:.l)) = getIdx s in return (s :. j - l - ms)+          step (s:.z) | z>=0 = do let (Subword (_:.k)) = getIdx s+                                  return $ S.Yield (ElmITbl (t PA.! subword k (j-z)) (subword k $ j-z) s) (s:.z-1)+                      | otherwise = return S.Done+          {-# INLINE [1] mk #-}+          {-# INLINE [1] step #-}+      in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (subword i j)+  {-# INLINE mkStream #-}+-}++{-+instance+  ( Monad mB+  , Element ls Subword+  , MkStream mB ls Subword+  , PA.PrimArrayOps arr Subword x+  ) => MkStream mB (ls :!: BT (ITbl mF arr Subword x) mF mB r) Subword where+  mkStream (ls :!: BtITbl c arr bt)  Static lu (Subword (i:.j))+    = let ms = minSize c in ms `seq`+      S.map (\s -> let (Subword (_:.l)) = getIdx s+                       ix               = subword l j+                       d                = arr PA.! ix+                   in  ElmBtITbl' d (bt lu ix) ix s)+      $ mkStream ls (Variable Check Nothing) lu (subword i $ j - ms)+  mkStream (ls :!: BtITbl c arr bt) (Variable _ Nothing) lu (Subword (i:.j))+    = let ms = minSize c+          mk s = let (Subword (_:.l)) = getIdx s in return (s:.j-l-ms)+          step (s:.z)+            | z>=0      = do let (Subword (_:.k)) = getIdx s+                                 ix               = subword k (j-z)+                                 d                = arr PA.! ix+                             return $ S.Yield (ElmBtITbl' d (bt lu ix) ix s) (s:.z-1)+            | otherwise = return $ S.Done+          {-# INLINE [1] mk   #-}+          {-# INLINE [1] step #-}+      in  ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (subword i j)+  {-# INLINE mkStream #-}+-}++{-+instance+  ( Monad m+  , Element ls (Outside Subword)+  , PA.PrimArrayOps arr Subword x+  , MkStream m ls (Outside Subword)+  ) => MkStream m (ls :!: ITbl m arr Subword x) (Outside Subword) where+  mkStream (ls :!: ITbl c t _) Static lu (O (Subword (i:.j)))+    = let ms = minSize c in ms `seq`+      S.mapM (\s -> let (O (Subword (_:.l))) = getIdx s+                    in  return $ ElmITbl (t PA.! (subword l j)) (O $ subword l j) s)+    $ mkStream ls (Variable Check Nothing) lu (O $ subword i $ j - ms) -- - minSize c)+  mkStream (ls :!: ITbl c t _) (Variable _ Nothing) lu (O (Subword (i:.j)))+    = let ms = minSize c+          mk s = let (O( Subword (_:.l))) = getIdx s in return (s :. j - l - ms)+          step (s:.z) | z>=0 = do let (O (Subword (_:.k))) = getIdx s+                                  return $ S.Yield (ElmITbl (t PA.! (subword k (j-z))) (O . subword k $ j-z) s) (s:.z-1)+                      | otherwise = return S.Done+          {-# INLINE [1] mk #-}+          {-# INLINE [1] step #-}+      in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (O $ subword i j)+  {-# INLINE mkStream #-}+-}++{-+instance+  ( Monad m+  , Element ls (Outside Subword)+  , PA.PrimArrayOps arr (Outside Subword) x+  , MkStream m ls (Outside Subword)+  ) => MkStream m (ls :!: ITbl m arr (Outside Subword) x) (Outside Subword) where+  mkStream (ls :!: ITbl c t _) Static lu (O (Subword (i:.j)))+    = let ms = minSize c in ms `seq`+      S.mapM (\s -> let (O (Subword (_:.l))) = getIdx s+                    in  return $ ElmITbl (t PA.! (O $ subword l j)) (O $ subword l j) s)+    $ mkStream ls (Variable Check Nothing) lu (O $ subword i $ j - ms) -- - minSize c)+  mkStream (ls :!: ITbl c t _) (Variable _ Nothing) lu (O (Subword (i:.j)))+    = let ms = minSize c+          mk s = let (O( Subword (_:.l))) = getIdx s in return (s :. j - l - ms)+          step (s:.z) | z>=0 = do let (O (Subword (_:.k))) = getIdx s+                                  return $ S.Yield (ElmITbl (t PA.! (O $ subword k (j-z))) (O . subword k $ j-z) s) (s:.z-1)+                      | otherwise = return S.Done+          {-# INLINE [1] mk #-}+          {-# INLINE [1] step #-}+      in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (O $ subword i j)+  {-# INLINE mkStream #-}+-}+++++-- * Axiom for backtracking++-}+
+ ADP/Fusion/SynVar/Array/Point.hs view
@@ -0,0 +1,79 @@++module ADP.Fusion.SynVar.Array.Point where++import Data.Strict.Tuple+import Data.Vector.Fusion.Stream.Monadic+import Data.Vector.Fusion.Stream.Size+import Data.Vector.Fusion.Util (delay_inline)+import Debug.Trace+import Prelude hiding (map,mapM)+--import qualified Data.Vector.Fusion.Stream.Monadic as S++import           Data.PrimitiveArray hiding (map)++import           ADP.Fusion.Base+import           ADP.Fusion.SynVar.Array.Type+import           ADP.Fusion.SynVar.Backtrack++++instance+  ( Monad m+  , Element ls PointL+  , PrimArrayOps arr PointL x+  , MkStream m ls PointL+  ) => MkStream m (ls :!: ITbl m arr PointL x) PointL where+  mkStream (ls :!: ITbl _ _ c t _) (IStatic d) u j@(PointL pj)+    = let ms = minSize c in ms `seq`+    map (ElmITbl (t!j) j (PointL 0))+    $ mkStream ls (IVariable d) u (PointL $ pj - ms)+  -- We can't really make sure that this is the only time we access the+  -- ITbl, so the user should know what they are doing.+  mkStream (ls :!: ITbl _ _ c t _) (IVariable d) u j@(PointL pj)+    = flatten mk step Unknown $ mkStream ls (IVariable d) u (delay_inline PointL $! pj - ms)+    where mk s = let PointL k = getIdx s in return (s :. k)+          step (s :. k)+            | k+ms>pj   = return $ Done+            | otherwise = return $ Yield (ElmITbl (t!PointL k) (PointL k) (PointL 0) s) (s :. k+1)+          !ms = minSize c+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  {-# Inline mkStream #-}++instance+  ( Monad mB+  , Element ls PointL+  , PrimArrayOps arr PointL x+  , MkStream mB ls PointL+  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr PointL x) mF mB r) PointL where+  mkStream (ls :!: BtITbl c t bt) (IStatic d) u j@(PointL pj)+    = let ms = minSize c in ms `seq`+    mapM (\s -> bt u j >>= \bb -> return $ ElmBtITbl (t!j) (bb {-bt u j-}) j (PointL 0) s)+    $ mkStream ls (IVariable d) u (PointL $ pj - ms)+  {-# INLINE mkStream #-}++instance+  ( Monad m+  , Element ls (Outside PointL)+  , PrimArrayOps arr (Outside PointL) x+  , MkStream m ls (Outside PointL)+  ) => MkStream m (ls :!: ITbl m arr (Outside PointL) x) (Outside PointL) where+  mkStream (ls :!: ITbl _ _ c t _) (OStatic d) u (O (PointL pj))+    = let ms = minSize c in ms `seq`+    map (\z -> let o = getOmx z+                 in  ElmITbl (t ! o) o o z)+    $ mkStream ls (OFirstLeft d) u (O $ PointL $ pj - ms)+  {-# Inline mkStream #-}++instance+  ( Monad mB+  , Element ls (Outside PointL)+  , PrimArrayOps arr (Outside PointL) x+  , MkStream mB ls (Outside PointL)+  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (Outside PointL) x) mF mB r) (Outside PointL) where+  mkStream (ls :!: BtITbl c t bt) (OStatic d) u (O (PointL pj))+    = let ms = minSize c in ms `seq`+    mapM (\s -> let o = getOmx s in bt u o >>= \bb -> return $ ElmBtITbl (t!o) (bb{-bt u o-}) o o s)+    $ mkStream ls (OFirstLeft d) u (O $ PointL $ pj - ms)+  {-# INLINE mkStream #-}+
+ ADP/Fusion/SynVar/Array/Set.hs view
@@ -0,0 +1,164 @@++module ADP.Fusion.SynVar.Array.Set where++import Data.Bits+import Data.Bits.Extras+import Data.Bits.Ordered+import Data.Strict.Tuple+import Data.Vector.Fusion.Stream.Monadic+import Data.Vector.Fusion.Stream.Size+import Data.Vector.Fusion.Util (delay_inline)+import Debug.Trace+import Prelude hiding (map)+import Control.Applicative ((<$>))++import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Base+import ADP.Fusion.SynVar.Array.Type+import ADP.Fusion.SynVar.Backtrack++++-- * Bitsets without any interfaces.++-- NOTE that we have to give as the filled index elements all bits that are+-- set in total, not just those we set right here. Otherwise the next+-- element will try a wrong set of indices.+--+-- NOTE even in the @IStatic@ case, we need to use flatten. If a node+-- requested a reserved bit, we need to free each reserved bit at least+-- once.++instance+  ( Monad m+  , Element ls BitSet+  , PrimArrayOps arr BitSet x+  , MkStream m ls BitSet+  ) => MkStream m (ls :!: ITbl m arr BitSet x) BitSet where+  mkStream (ls :!: ITbl _ _ c t _) (IStatic rp) u s+    = flatten mk step Unknown $ mkStream ls (delay_inline IVariable $ rp - csize) u s+    where !csize | c==EmptyOk  = 0+                 | c==NonEmpty = 1+          mk z+            | cm < csize = return (z , mask , Nothing)+            | otherwise  = return (z , mask , Just k )+            where k  = (BitSet $ 2^cm-1)+                  cm = popCount mask - rp+                  mask = s `xor` (getIdx z)+          step (_,_,Nothing) = return $ Done+          step (z,mask,Just k)+            | pk > popCount s - rp = return $ Done+            | otherwise            = let kk = popShiftL mask k+                                     in  return $ Yield (ElmITbl (t!kk) (kk .|. getIdx z) (BitSet 0) z) (z,mask,setSucc (BitSet 0) (2^pk -1) k)+            where pk = popCount k+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  mkStream (ls :!: ITbl _ _ c t _) (IVariable rp) u s+    = flatten mk step Unknown $ mkStream ls (IVariable rp) u s+    where mk z+            | c==EmptyOk  = return (z , mask , cm , Just 0 )+            | cm == 0     = return (z , mask , cm , Nothing) -- we are non-empty but have no free bits left+            | c==NonEmpty = return (z , mask , cm , Just 1 )+            where mask = s `xor` (getIdx z) -- bits that are still free+                  cm   = popCount mask+          step (z,mask,cm,Nothing) = return $ Done+          step (z,mask,cm,Just k )+            | popCount s < popCount (kk .|. getIdx z) + rp = return $ Done+            | otherwise = return $ Yield (ElmITbl (t!kk) (kk .|. getIdx z) (BitSet 0) z) (z,mask,cm,setSucc (BitSet 0) (2^cm -1) k)+            where kk = popShiftL mask k+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  {-# Inline mkStream #-}++++-- * Bitsets with two interfaces.+--+-- NOTE These are annoying to get right, if you also want to have good+-- performance.++instance+  ( Monad m+  , Element ls (BS2I First Last)+  , PrimArrayOps arr (BS2I First Last) x+  , MkStream m ls (BS2I First Last)+  , Show x+  ) => MkStream m (ls :!: ITbl m arr (BS2I First Last) x) (BS2I First Last) where+  mkStream (ls :!: ITbl _ _ c t _) (IStatic rp) u sij@(s:>i:>j@(Iter jj))+    = flatten mk step Unknown $ mkStream ls (delay_inline IVariable rpn) u (delay_inline id $ tij)+          -- calculate new index. if we don't know the right-most interface+          -- anymore, than someone has taken it already. Also, if this+          -- synvar may be empty, do not modify the index. Otherwise, if+          -- @j@ is still known, remove it from the index set.+    where tij | jj == -1       = sij+              | c  == EmptyOk  = sij+              | c  == NonEmpty = s `clearBit` jj :> i :> Iter (-1)+          -- In case we do not know the rightmost interface, we instead+          -- increase the number of reserved bits.+          rpn | jj == -1+              && c == NonEmpty = rp+1+              | otherwise      = rp+          nec | c == NonEmpty = 1+              | c == EmptyOk  = 0+          mk z+            -- in case we have a non-empty synvar but not enough bits, we+            -- shall have nothing. We only need one extra mask bit, because+            -- @j@ is still known.+            | popCount mask < 1 && c == NonEmpty && j >= 0 = return $ Naught+            -- If @j@ is not known we need two bits to be non-empty.+            | popCount mask < 2 && c == NonEmpty && j <  0 = return $ Naught+            -- Not enough bits to reserve.+            | popCount mask - rp < 0                       = return $ Naught+            -- @j@ is still known, just create the sets ending in @j@+            | j >= 0                                       = return $ This (z,mask)+            -- @j@ is not known, we have a lot of work to do. Create the+            -- required @bits@ and prepare a @mask@ which will set the+            -- correct bits.+            | j <  0                                       = return $ That (z,mask,Just bits,maybeLsb bits)+            -- we somehow ended up with an improper state+            | otherwise                                    = error $ show (sij,mask,bits)+            where (zs:>_:>Iter zk) = getIdx z+                  mask             = s `xor` zs+                  bits             = BitSet $ 2 ^ (popCount mask - rp - nec) - 1+          step Naught          = return $ Done+          -- In case @j@ is known, we calculate the bits @msk@ that are not+          -- filled yet. We grab the previous right interface @zk@ and use+          -- it as the new left interface. We also use @j@ as the right+          -- interface. @ix@ holds everything that is now covered, withe+          -- the interface @i@ and @j@.+          step (This (z,mask)) = return $ Yield (ElmITbl (t!(msk:>k:>j)) ix undefbs2i z) Naught+            where (zs:>_:>zk) = getIdx z+                  k           = Iter $ getIter zk+                  ix          = (zs .|. msk) :> i :> j+                  msk         = if popCount mask == 0 then mask else mask `setBit` getIter k `setBit` jj+          -- whenever there is nothing more to do in the variable case.+          step (That (z,mask,Nothing,_)) = return $ Done+          -- We need to permute our population a bit. Once done, we grab+          -- the lowest significant bit.+          step (That (z,mask,Just bits,Nothing)) = return $ Skip (That (z,mask,nbts, maybeLsb =<< nbts))+            where nbts = popPermutation (popCount mask) bits+          -- The variable case.+          step (That (z,mask,Just bits,Just y))+            -- we do not have enough bits to be non-empty.+            |  popCount bb < 2 && c == NonEmpty+            -- our two interfaces are the same, but we are non-empty in+            -- which case this shouldn't happen.+            || getIter kk == getIter yy && c == NonEmpty+            -- our pop-count plus reserved count doesn't match up with the+            -- mask. We skip this as well.+            || popCount bb + rp /= popCount mask = return $ Skip (That (z,mask,Just bits, maybeNextActive y bits))+            -- finally, we can create the index for the current stuff+            -- @bb:>kk:>yy@ and prepare the full index, going from @i@ to+            -- @yy@, because someone grabbed @j@ already. Must have been+            -- an @Edge@ or s.th. similar.+            | otherwise = return $ Yield (ElmITbl (t!(bb:>kk:>yy)) ((zs .|. bb):>i:>yy) undefbs2i z)+                                                                 (That (z,mask,Just bits, maybeNextActive y bits))+            where (zs:>_:>zk) = getIdx z+                  kk          = Iter $ getIter zk+                  yy          = Iter . lsb $ popShiftL mask (bit y)+                  bb          = popShiftL mask bits `setBit` getIter kk `setBit` getIter yy+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  {-# Inline mkStream #-}+
+ ADP/Fusion/SynVar/Array/Subword.hs view
@@ -0,0 +1,174 @@++module ADP.Fusion.SynVar.Array.Subword where++import Data.Strict.Tuple+import Data.Vector.Fusion.Stream.Size+import Data.Vector.Fusion.Util (delay_inline)+import Data.Vector.Fusion.Stream.Monadic+import Debug.Trace+import Prelude hiding (map,mapM)++import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Base+import ADP.Fusion.SynVar.Array.Type+import ADP.Fusion.SynVar.Backtrack+++++-- TODO delay inline @(subword i $ j - minSize c)@ or face fusion-breakage.+-- Can we just have @Inline [0] subword@ to fix this?++instance+  ( Monad m+  , Element ls Subword+  , PrimArrayOps arr Subword x+  , MkStream m ls Subword+  ) => MkStream m (ls :!: ITbl m arr Subword x) Subword where+  mkStream (ls :!: ITbl _ _ c t _) (IStatic ()) hh (Subword (i:.j))+    = map (\s -> let (Subword (_:.l)) = getIdx s+                 in  ElmITbl (t ! subword l j) (subword l j) (subword 0 0) s)+    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))+  mkStream (ls :!: ITbl _ _ c t _) (IVariable ()) hh (Subword (i:.j))+    = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))+    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - minSize c)+          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s+                                        l              = j - z+                                        kl             = subword k l+                                    return $ Yield (ElmITbl (t ! kl) kl (subword 0 0) s) (s:. z-1)+                      | otherwise = return $ Done+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  {-# Inline mkStream #-}++instance+  ( Monad mB+  , Element ls Subword+  , MkStream mB ls Subword+  , PrimArrayOps arr Subword x+  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr Subword x) mF mB r) Subword where+  mkStream (ls :!: BtITbl c t bt) (IStatic ()) hh ij@(Subword (i:.j))+    = mapM (\s -> let Subword (_:.l) = getIdx s+                      lj             = subword l j+                  in  bt hh lj >>= \ ~bb -> return $ ElmBtITbl (t ! lj) (bb {-bt hh lj-}) lj (subword 0 0) s)+    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))+  mkStream (ls :!: BtITbl c t bt) (IVariable ()) hh ij@(Subword (i:.j))+    = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))+    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - minSize c)+          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s+                                        l              = j - z+                                        kl             = subword k l+                                    bt hh kl >>= \ ~bb -> return $ Yield (ElmBtITbl (t ! kl) (bb {-bt hh kl-}) kl (subword 0 0) s) (s:.z-1)+                      | otherwise = return $ Done+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  {-# Inline mkStream #-}+++instance+  ( Monad m+  , Element ls (Outside Subword)+  , PrimArrayOps arr (Outside Subword) x+  , MkStream m ls (Outside Subword)+  ) => MkStream m (ls :!: ITbl m arr (Outside Subword) x) (Outside Subword) where+  -- TODO what about @c / minSize@+  mkStream (ls :!: ITbl _ _ c t _) (OStatic (di:.dj)) u ij@(O (Subword (i:.j)))+    = map (\s -> let O (Subword (k:._)) = getOmx s+                     kj = O $ Subword (k:.j+dj)+                 in  ElmITbl (t ! kj) (O $ Subword (i:.j+dj)) kj s) -- @ij@ or s.th. else shouldn't matter?+    $ mkStream ls (OFirstLeft (di:.dj)) u ij+  mkStream (ls :!: ITbl _ _ c t _) (ORightOf (di:.dj)) u@(O (Subword (_:.h))) ij@(O (Subword (i:.j)))+    = flatten mk step Unknown $ mkStream ls (OFirstLeft (di:.dj)) u ij+      where mk s = return (s:.j+dj)+            step (s:.l) | l <= h = do let (O (Subword (k:._))) = getIdx s+                                          kl = O $ Subword (k:.l)+                                      return $ Yield (ElmITbl (t ! kl) (O (Subword (j+dj:.j+dj))) kl s) (s:.l+1)+                        | otherwise = return $ Done+            {-# Inline [0] mk   #-}+            {-# Inline [0] step #-}+  mkStream (ls :!: ITbl _ _ c t _) (OFirstLeft d) u ij = error "Array/Outside Subword : OFirstLeft : should never be reached!"+  mkStream (ls :!: ITbl _ _ c t _) (OLeftOf d) u ij = error "Array/Outside Subword : OLeftOf : should never be reached!"+  {-# Inline mkStream #-}++++instance+  ( Monad m+  , Element ls (Outside Subword)+  , PrimArrayOps arr Subword x+  , MkStream m ls (Outside Subword)+  ) => MkStream m (ls :!: ITbl m arr Subword x) (Outside Subword) where+  -- TODO what about @c / minSize@+  mkStream (ls :!: ITbl _ _ c t _) (OStatic (di:.dj)) u ij@(O (Subword (i:.j)))+    = map (\s -> let O (Subword (_:.k))     = getIdx s+                     o@(O (Subword (_:.l))) = getOmx s+                     kl = Subword (k-dj:.l-dj)+                 in ElmITbl (t ! kl) (O (Subword (k:.l))) o s)+    $ mkStream ls (ORightOf (di:.dj)) u ij+  mkStream (ls :!: ITbl _ _ c t _) (ORightOf d) u@(O (Subword (_:.h))) ij@(O (Subword (i:.j)))+    = flatten mk step Unknown $ mkStream ls (ORightOf d) u ij+    where mk s = let O (Subword (_:.l)) = getIdx s+                 in  return (s :.l:.l + minSize c)+          step (s:.k:.l)+            | let O (Subword (_:.o)) = getOmx s+            , l <= o = do let kl = Subword (k:.l)+                          return $ Yield (ElmITbl (t ! kl) (O kl) (getOmx s) s) (s:.k:.l+1)+            | otherwise = return $ Done+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  mkStream (ls :!: ITbl _ _ c t _) (OFirstLeft (di:.dj)) u ij@(O (Subword (i:.j)))+    = map (\s -> let O (Subword (l:._)) = getOmx s+                     O (Subword (_:.k)) = getIdx s+                     kl = Subword (k:.i-di)+                 in  ElmITbl (t ! kl) (O kl) (getOmx s) s)+    $ mkStream ls (OLeftOf (di:.dj)) u ij+  mkStream (ls :!: ITbl _ _ c t _) (OLeftOf d) u ij@(O (Subword (i:.j)))+    = flatten mk step Unknown $ mkStream ls (OLeftOf d) u ij+    where mk s = let O (Subword (_:.l)) = getIdx s in return (s:.l)+          step (s:.l) | l <= i = do let O (Subword (_:.k)) = getIdx s+                                        kl = Subword (k:.l)+                                    return $ Yield (ElmITbl (t ! kl) (O kl) (getOmx s) s) (s:.l+1)+                      | otherwise = return $ Done+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  {-# Inline mkStream #-}++instance+  ( Monad m+  , Element ls (Complement Subword)+  , PrimArrayOps arr Subword x+  , MkStream m ls (Complement Subword)+  ) => MkStream m (ls :!: ITbl m arr Subword x) (Complement Subword) where+  mkStream (ls :!: ITbl _ _ c t _) Complemented u ij+    = map (\s -> let (C ix) = getIdx s+                 in  ElmITbl (t ! ix) (C ix) (getOmx s) s)+    $ mkStream ls Complemented u ij+  {-# Inline mkStream #-}++instance+  ( Monad m+  , Element ls (Complement Subword)+  , PrimArrayOps arr (Outside Subword) x+  , MkStream m ls (Complement Subword)+  ) => MkStream m (ls :!: ITbl m arr (Outside Subword) x) (Complement Subword) where+  mkStream (ls :!: ITbl _ _ c t _) Complemented u ij+    = map (\s -> let (C ox) = getOmx s      -- TODO shouldn't this be @getIdx@ as well? on the count of everything being terminals in Complement?+                 in  ElmITbl (t ! (O ox)) (getIdx s) (C ox) s)+    $ mkStream ls Complemented u ij+  {-# Inline mkStream #-}++++instance ModifyConstraint (ITbl m arr Subword x) where+  toNonEmpty (ITbl b l _ arr f) = ITbl b l NonEmpty arr f+  toEmpty    (ITbl b l _ arr f) = ITbl b l EmptyOk  arr f+  {-# Inline toNonEmpty #-}+  {-# Inline toEmpty #-}++instance ModifyConstraint (Backtrack (ITbl mF arr Subword x) mF mB r) where+  toNonEmpty (BtITbl _ arr bt) = BtITbl NonEmpty arr bt+  toEmpty    (BtITbl _ arr bt) = BtITbl EmptyOk  arr bt+  {-# Inline toNonEmpty #-}+  {-# Inline toEmpty #-}+
+ ADP/Fusion/SynVar/Array/Type.hs view
@@ -0,0 +1,144 @@++module ADP.Fusion.SynVar.Array.Type where++import Data.Strict.Tuple hiding (uncurry,snd)+import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM)+import Debug.Trace+import Prelude hiding (map,head,mapM)++import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Base+import ADP.Fusion.SynVar.Backtrack+import ADP.Fusion.SynVar.Axiom+import ADP.Fusion.SynVar.Indices++++-- | Immutable table.++data ITbl m arr i x where+  ITbl :: { iTblBigOrder    :: !Int+          , iTblLittleOrder :: !Int+          , iTblConstraint  :: !(TblConstraint i)+          , iTblArray       :: !(arr i x)+          , iTblFun         :: !(i -> i -> m x)+          } -> ITbl m arr i x++instance Build (ITbl m arr i x)++instance GenBacktrackTable (ITbl mF arr i x) mF mB r where+  data Backtrack (ITbl mF arr i x) mF mB r = BtITbl !(TblConstraint i) !(arr i x) (i -> i -> mB [r])+  type BacktrackIndex (ITbl mF arr i x) = i+  toBacktrack (ITbl _ _ c arr _) _ bt = BtITbl c arr bt+  {-# Inline toBacktrack #-}++instance+  ( Monad m+  , PrimArrayOps arr i x+  , IndexStream i+  ) => Axiom (ITbl m arr i x) where+  type AxiomStream (ITbl m arr i x) = m x+  axiom (ITbl _ _ c arr _) = do+    k <- (head . uncurry streamDown) $ bounds arr+    return $ arr ! k+  {-# Inline axiom #-}++instance+  ( Monad mB+  , PrimArrayOps arr i x+  , IndexStream i+  ) => Axiom (Backtrack (ITbl mF arr i x) mF mB r) where+  type AxiomStream (Backtrack (ITbl mF arr i x) mF mB r) = mB [r]+  axiom (BtITbl c arr bt) = do+    h <- (head . uncurry streamDown) $ bounds arr+    bt (snd $ bounds arr) h+  {-# Inline axiom #-}++instance Element ls i => Element (ls :!: ITbl m arr j x) i where+  data Elm (ls :!: ITbl m arr j x) i = ElmITbl !x !i !i !(Elm ls i)+  type Arg (ls :!: ITbl m arr j x)   = Arg ls :. x+  getArg (ElmITbl x _ _ ls) = getArg ls :. x+  getIdx (ElmITbl _ i _ _ ) = i+  getOmx (ElmITbl _ _ o _ ) = o+  {-# Inline getArg #-}+  {-# Inline getIdx #-}+  {-# Inline getOmx #-}++deriving instance (Show i, Show (Elm ls i), Show x) => Show (Elm (ls :!: ITbl m arr j x) i)++instance Element ls i => Element (ls :!: (Backtrack (ITbl mF arr i x) mF mB r)) i where+  data Elm (ls :!: (Backtrack (ITbl mF arr i x) mF mB r)) i = ElmBtITbl !x [r] !i !i !(Elm ls i)+  type Arg (ls :!: (Backtrack (ITbl mF arr i x) mF mB r))   = Arg ls :. (x, [r])+  getArg (ElmBtITbl x s _ _ ls) = getArg ls :. (x,s)+  getIdx (ElmBtITbl _ _ i _ _ ) = i+  getOmx (ElmBtITbl _ _ _ o _ ) = o+  {-# Inline getArg #-}+  {-# Inline getIdx #-}+  {-# Inline getOmx #-}++instance (Show x, Show i, Show (Elm ls i)) => Show (Elm (ls :!: (Backtrack (ITbl mF arr i x) mF mB r)) i) where+  show (ElmBtITbl x _ i o s) = show (x,i,o) ++ " " ++ show s++instance+  ( Monad m+  , Element ls (is:.i)+  , TableStaticVar (is:.i)+  , TableIndices (is:.i)+  , MkStream m ls (is:.i)+  , PrimArrayOps arr (is:.i) x+  ) => MkStream m (ls :!: ITbl m arr (is:.i) x) (is:.i) where+  mkStream (ls :!: ITbl _ _ c t _) vs lu is+    = map (\(S5 s _ _ i o) -> ElmITbl (t ! i) i o s)+    . tableIndices c vs is+    . map (\s -> S5 s Z Z (getIdx s) (getOmx s))+    $ mkStream ls (tableStaticVar vs is) lu (tableStreamIndex c vs is)+  {-# Inline mkStream #-}++instance+  ( Monad mB+  , Element ls (is:.i)+  , TableStaticVar (is:.i)+  , TableIndices (is:.i)+  , MkStream mB ls (is:.i)+  , PrimArrayOps arr (is:.i) x+  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (is:.i) x) mF mB r) (is:.i) where+  mkStream (ls :!: BtITbl c t bt) vs us is+    = mapM (\(S5 s _ _ i o) -> bt us i >>= \ ~bb -> return $ ElmBtITbl (t ! i) (bb {-bt us i-}) i o s)+    . tableIndices c vs is+    . map (\s -> S5 s Z Z (getIdx s) (getOmx s))+    $ mkStream ls (tableStaticVar vs is) us (tableStreamIndex c vs is)+  {-# Inline mkStream #-}++instance+  ( Monad m+  , Element ls (Outside (is:.i))+  , TableStaticVar (Outside (is:.i))+  , TableIndices (Outside (is:.i))+  , MkStream m ls (Outside (is:.i))+  , PrimArrayOps arr (Outside (is:.i)) x+  , Show (is:.i)+  ) => MkStream m (ls :!: ITbl m arr (Outside (is:.i)) x) (Outside (is:.i)) where+  mkStream (ls :!: ITbl _ _ c t _) vs lu is+    = map (\(S5 s _ _ i o) -> ElmITbl (t ! o) i o s)+    . tableIndices c vs is+    . map (\s -> S5 s Z Z (getIdx s) (getOmx s))+    $ mkStream ls (tableStaticVar vs is) lu (tableStreamIndex c vs is)+  {-# Inline mkStream #-}++instance+  ( Monad mB+  , Element ls (Outside (is:.i))+  , TableStaticVar (Outside (is:.i))+  , TableIndices (Outside (is:.i))+  , MkStream mB ls (Outside (is:.i))+  , PrimArrayOps arr (Outside (is:.i)) x+  , Show (is:.i)+  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (Outside (is:.i)) x) mF mB r) (Outside (is:.i)) where+  mkStream (ls :!: BtITbl c t bt) vs us is+    = mapM (\(S5 s _ _ i o) -> bt us o >>= \bb -> return $ ElmBtITbl (t ! o) (bb {-bt us o-}) i o s)+    . tableIndices c vs is+    . map (\s -> S5 s Z Z (getIdx s) (getOmx s))+    $ mkStream ls (tableStaticVar vs is) us (tableStreamIndex c vs is)+  {-# Inline mkStream #-}+
+ ADP/Fusion/SynVar/Axiom.hs view
@@ -0,0 +1,14 @@++-- | The 'axiom' runs a backtracking algebra. The name comes from Robert+-- Giegerichs @ADP@ where @axiom@ runs the fully formed algorithm.++module ADP.Fusion.SynVar.Axiom where++-- | The Axiom type class++class Axiom t where+  -- | The corresponding stream being returned by 'axiom'+  type AxiomStream t :: *+  -- | Given a table, run the axiom+  axiom :: t -> AxiomStream t+
+ ADP/Fusion/SynVar/Backtrack.hs view
@@ -0,0 +1,28 @@++-- | Wrap forward tables in such a way as to allow backtracking via+-- algebras.++module ADP.Fusion.SynVar.Backtrack where++import Data.Vector.Fusion.Stream.Monadic (Stream)++import ADP.Fusion.Base++++-- |+--+-- TODO this should go into @ADP.Fusion.Table.Backtrack@, more than just+-- tabulated syntactic vars are going to use it.+--+-- NOTE You probably need to give the @monad morphism@ between @mF@ and+-- @mB@ so as to be able to extract forward results in the backtracking+-- phase.++class GenBacktrackTable t (mF :: * -> *) (mB :: * -> *) r where+  data Backtrack t (mF :: * -> *) (mB :: * -> *) r :: *+  type BacktrackIndex t :: *+  toBacktrack :: t -> (forall a . mF a -> mB a) -> (BacktrackIndex t -> BacktrackIndex t -> mB [r]) -> Backtrack t mF mB r++instance Build (Backtrack t mF mB r)+
+ ADP/Fusion/SynVar/Fill.hs view
@@ -0,0 +1,180 @@++module ADP.Fusion.SynVar.Fill where++import           Control.Monad.Morph (hoist, MFunctor (..))+import           Control.Monad.Primitive (PrimMonad (..))+import           Control.Monad.ST+import           Control.Monad.Trans.Class (lift, MonadTrans (..))+import           Data.Vector.Fusion.Util (Id(..))+import           GHC.Exts (inline)+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import           System.IO.Unsafe+import           Control.Monad (when,forM_)+import           Data.List (nub,sort)+import qualified Data.Vector.Unboxed as VU++import           Data.PrimitiveArray++import           ADP.Fusion.SynVar.Array -- TODO we want to keep only classes in here, move instances to the corresponding modules++import           Debug.Trace++++-- * Specialized table-filling wrapper for 'MTbl's+--+-- TODO table-filling does /not/ work for single-dimensional stuff++-- | Run and freeze 'MTbl's. Since actually running the table-filling part+-- is usually the last thing to do, we can freeze as well.++runFreezeMTbls ts = do+    unsafeRunFillTables $ expose ts+    freezeTables        $ onlyTables ts+{-# INLINE runFreezeMTbls #-}++++-- * Expose inner mutable tables++-- | Expose the actual mutable table with an 'MTbl'. (Should be temporary+-- until 'MTbl's get a more thorough treatment for auto-filling.++class ExposeTables t where+    type TableFun t   :: *+    type OnlyTables t :: *+    expose     :: t -> TableFun t+    onlyTables :: t -> OnlyTables t++instance ExposeTables Z where+    type TableFun Z   = Z+    type OnlyTables Z = Z+    expose     Z = Z+    onlyTables Z = Z+    {-# INLINE expose #-}+    {-# INLINE onlyTables #-}++-- Thanks to the table being a gadt we now the internal types+--+-- TODO move to Table/Array.hs++--instance (ExposeTables ts) => ExposeTables (ts:.(MTbl m arr i x)) where+--    type TableFun   (ts:. MTbl m arr i x) = TableFun   ts :. (PA.MutArr m (arr i x), i -> m x)+--    type OnlyTables (ts:. MTbl m arr i x) = OnlyTables ts :. (PA.MutArr m (arr i x))+--    expose     (ts:.MTbl _ t f) = expose ts :. (t,f)+--    onlyTables (ts:.MTbl _ t _) = onlyTables ts :. t+--    {-# INLINE expose #-}+--    {-# INLINE onlyTables #-}++++-- * 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 (s :: *) (im :: * -> *) (om :: * -> *) i where+  mutateCell :: Int -> Int -> (forall a . im a -> om a) -> s -> i -> i -> om ()++-- |++class MutateTables (s :: *) (im :: * -> *) (om :: * -> *) where+  mutateTables :: (forall a . im a -> om a) -> s -> om s++class TableOrder (s :: *) where+  tableLittleOrder :: s -> [Int]+  tableBigOrder :: s -> [Int]++instance TableOrder Z where+  tableLittleOrder Z = []+  tableBigOrder Z = []+  {-# Inline tableLittleOrder #-}+  {-# Inline tableBigOrder #-}++instance (TableOrder ts) => TableOrder (ts:.ITbl im arr i x) where+  tableLittleOrder (ts:.ITbl _ tlo _ _ _) = tlo : tableLittleOrder ts+  tableBigOrder    (ts:.ITbl tbo _ _ _ _) = tbo : tableBigOrder ts+  {-# Inline tableLittleOrder #-}+  {-# Inline tableBigOrder #-}++-- ** individual instances for filling a *single cell*++instance+  ( PrimArrayOps  arr i x+  , MPrimArrayOps arr i x+  , MutateCell ts im om i+  , PrimMonad om+  , Show x, Show i+  ) => MutateCell (ts:.ITbl im arr i x) im om i where+  mutateCell bo lo mrph (ts:.ITbl tbo tlo c arr f) lu i = do+    mutateCell 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 #-}++{-+instance+  ( MutateCell ts im om i+  ) => MutateCell (ts:.IRec im i x) im om i where+  mutateCell mrph (ts:.IRec (!c) _ _ f) lu i = do+    mutateCell mrph ts lu i+  {-# INLINE mutateCell #-}+-}++-- ** individual instances for filling a complete table and extracting the+-- bounds++instance+  ( Monad om+  , MutateCell (ts:.ITbl im arr i x) im om i+  , PrimArrayOps arr i x+  , Show i+  , IndexStream i+  , TableOrder (ts:.ITbl im arr i x)+  ) => MutateTables (ts:.ITbl im arr i x) im om where+  mutateTables mrph tt@(_:.ITbl _ _ _ arr _) = do+    let (from,to) = bounds arr+    -- TODO (1) find the set of orders for the synvars+    let !tbos = VU.fromList . nub . sort $ tableBigOrder tt+    let !tlos = VU.fromList . nub . sort $ tableLittleOrder tt+    VU.forM_ tbos $ \bo ->+      flip SM.mapM_ (streamUp from to) $ \k ->+        VU.forM_ tlos $ \lo ->+          mutateCell bo lo (inline mrph) tt to k+    return tt+  {-# INLINE mutateTables #-}++{-+instance+  ( Monad om+  , MutateCell (ts:.IRec im i x) im om i+  , IndexStream i+  ) => MutateTables (ts:.IRec im i x) im om where+  mutateTables mrph tt@(_:.IRec _ from to _) = do+    -- SM.mapM_ (mutateCell (inline mrph) tt to) $ PA.rangeStream from to+    SM.mapM_ (mutateCell (inline mrph) tt to) $ PA.streamUp from to+    return tt+  {-# INLINE mutateTables #-}+-}++instance+  ( Monad om+  ) => MutateCell Z im om i where+  mutateCell _ _ _ Z _ _ = return ()+  {-# INLINE mutateCell #-}++-- | Default table filling, assuming that the forward monad is just @IO@.+--+-- TODO generalize to @MonadIO@ or @MonadPrim@.++mutateTablesDefault :: MutateTables t Id IO => t -> t+mutateTablesDefault t = unsafePerformIO $ mutateTables (return . unId) t+{-# INLINE mutateTablesDefault #-}+
+ ADP/Fusion/SynVar/Indices.hs view
@@ -0,0 +1,109 @@++-- | With 'tableIndices' we create a stream of legal indices for this table. We+-- need 'tableIndices' in multi-dimensional tables as the type of the+-- multi-dimensional indices is generic.++module ADP.Fusion.SynVar.Indices where++import Data.Vector.Fusion.Stream.Size (Size(Unknown))+import Data.Vector.Fusion.Stream.Monadic (flatten,map,Stream, Step(..))+import Prelude hiding (map)++import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Base++++class TableIndices i where+  tableIndices :: (Monad m) => TblConstraint i -> Context i -> i -> Stream m (S5 z j j i i) -> Stream m (S5 z j j i i)++instance TableIndices Z where+  tableIndices _ _ _ = id+  {-# INLINE tableIndices #-}++instance TableIndices (Outside Z) where+  tableIndices _ _ _ = id+  {-# INLINE tableIndices #-}++{-+instance TableIndices is => TableIndices (is:.Subword) where+  tableIndices (cs:.c) (vs:.Static) (is:.Subword (i:.j))+    = S.map (\(Tr s (x:.Subword (_:.l)) ys) -> Tr s x (is:.subword l j)) -- constraint handled: tableStreamIndex+    . tableIndices cs vs is+    . S.map moveIdxTr+  tableIndices (cs:.OnlyZero) _ _ = error "write me"+  tableIndices (cs:.c) (vs:.Variable _ Nothing) (is:.Subword (i:.j))+    = S.flatten mk step Unknown+    . tableIndices cs vs is+    . S.map moveIdxTr+    where mk (Tr s (y:.Subword (_:.l)) xs) = return $ Pn s y xs l (j-l-minSize c)+          step (Pn s y xs k z)+            | z>= 0     = return $ S.Yield (Tr s y (xs:.subword k (j-z))) (Pn s y xs k (z-1))+            | otherwise = return $ S.Done+          {-# INLINE [1] mk   #-}+          {-# INLINE [1] step #-}+  {-# INLINE tableIndices #-}+-}++-- | TODO I think we need to check @cs:.c@ here+--+-- TODO yes, handle @Empty@ / @NonEmpty@ !!!++instance TableIndices is => TableIndices (is:.PointL) where+  tableIndices (cs:._) (vs:.IStatic _) (is:.PointL j)+    = map (\(S5 s (zi:.PointL _) (zo:.PointL _) is os) -> S5 s zi zo (is:.PointL j) (os:.PointL 0)) -- constraint handled: tableStreamIndex+    . tableIndices cs vs is+    . map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)+  tableIndices (cs:._) (vs:.IVariable d) (is:.PointL j)+    = flatten mk step Unknown+    . tableIndices cs vs is+    . map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)+    where mk s@(S5 _ (_:.PointL k) _ _ _) = return (s :. k)+          step (ss@(S5 s (zi:._) (zo:._) is os) :. k)+            | k > j     = return $ Done+            | otherwise = return $ Yield (S5 s zi zo (is:.PointL k) (os:.PointL 0)) (ss :. k+1)+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  {-  TODO re-add later+  tableIndices (cs:.OnlyZero) _ _ = error "write me"+  tableIndices (cs:.c) (vs:.IVariable) (is:.PointL j)+    = flatten mk step Unknown+    . tableIndices cs vs is+    . map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)+    where mk (S5 s (zi:.PointL l) (zo:._) is os) = return $ S6 s zi zo is os (j-l-minSize c)+          step (S6 s zi zo is os x)+            | x >= 0    = return $ Yield (S5 s zi zo (is:.PointL (j-x)) (os:.PointL 0)) (S6 s zi zo is os (x-1))+            | otherwise = return $ Done+          {-# Inline [1] mk   #-}+          {-# Inline [1] step #-}+  -}+  {-# Inline tableIndices #-}++instance TableIndices (Outside is) => TableIndices (Outside (is:.PointL)) where+  tableIndices (cs:.c) (vs:.OStatic d) (O (is:.PointL j))+    = map (\(S5 s (zi:.PointL i) (zo:.PointL o) (O is) (O os)) -> S5 s zi zo (O (is:.PointL i)) (O (os:.PointL o))) -- constraint handled: tableStreamIndex+    . tableIndices cs vs (O is)+    . map (\(S5 s zi zo (O (is:.i)) (O (os:.o))) -> S5 s (zi:.i) (zo:.o) (O is) (O os))+  {-# Inline tableIndices #-}++{-+instance TableIndices is => TableIndices (is:.PointR) where+  tableIndices (cs:.c) (vs:.Static) (is:.PointR (i:.j))+    = S.map (\(Tr s (x:.PointR (_:.l)) ys) -> Tr s x (is:.pointR l j)) -- constraint handled: tableStreamIndex+    . tableIndices cs vs is+    . S.map moveIdxTr+  tableIndices (cs:.OnlyZero) _ _ = error "write me"+  tableIndices (cs:.c) (vs:.Variable _ Nothing) (is:.PointR (i:.j))+    = S.flatten mk step Unknown+    . tableIndices cs vs is+    . S.map moveIdxTr+    where mk (Tr s (y:.PointR (_:.l)) xs) = return $ Pn s y xs l (j-l-minSize c)+          step (Pn s y xs k z)+            | z>= 0     = return $ S.Yield (Tr s y (xs:.pointR k (j-z))) (Pn s y xs k (z-1))+            | otherwise = return $ S.Done+          {-# INLINE [1] mk   #-}+          {-# INLINE [1] step #-}+  {-# INLINE tableIndices #-}+-}+
+ ADP/Fusion/SynVar/Recursive.hs view
@@ -0,0 +1,74 @@++module ADP.Fusion.SynVar.Recursive+  ( module ADP.Fusion.SynVar.Recursive.Type+  , module ADP.Fusion.SynVar.Recursive.Point+  , module ADP.Fusion.SynVar.Recursive.Subword+  ) where++import ADP.Fusion.SynVar.Recursive.Point+import ADP.Fusion.SynVar.Recursive.Subword+import ADP.Fusion.SynVar.Recursive.Type+++{-+++-- * Instances++{-+instance ModifyConstraint (IRec m Subword x) where+  toNonEmpty (IRec _ iF iT f) = IRec NonEmpty iF iT f+  toEmpty    (IRec _ iF iT f) = IRec EmptyOk  iF iT f+  {-# INLINE toNonEmpty #-}+  {-# INLINE toEmpty    #-}++instance+  ( Monad m+  , Element ls Subword+  , MkStream m ls Subword+  ) => MkStream m (ls :!: IRec m Subword x) Subword where+  mkStream (ls :!: IRec c _ _ f) Static lu (Subword (i:.j))+    = let ms = minSize c in ms `seq`+    S.mapM (\s -> let Subword (_:.l) = getIdx s+                    in  f lu (subword l j) >>= \z -> return $ ElmIRec z (subword l j) s)+    $ mkStream ls (Variable Check Nothing) lu (subword i $ j - ms)+  mkStream (ls :!: IRec c _ _ f) (Variable _ Nothing) lu (Subword (i:.j))+    = let ms = minSize c+          mk s = let (Subword (_:.l)) = getIdx s in return (s:.j-l-ms)+          step (s:.z)+            | z>=0      = do let (Subword (_:.k)) = getIdx s+                             y <- f lu (subword k (j-z))+                             return $ S.Yield (ElmIRec y (subword k $ j-z) s) (s:.z-1)+            | otherwise = return $ S.Done+          {-# INLINE [1] mk   #-}+          {-# INLINE [1] step #-}+      in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (subword i j)+  {-# INLINE mkStream #-}++instance+  ( Monad mB+  , Element ls Subword+  , MkStream mB ls Subword+  ) => MkStream mB (ls :!: BT (IRec mF Subword x) mF mB r) Subword where+  mkStream (ls :!: BtIRec c _ _ f bt) Static lu (Subword (i:.j))+    = let ms = minSize c in ms `seq`+      S.mapM (\s -> let (Subword (_:.l)) = getIdx s+                        ix               = subword l j+                    in  f lu ix >>= \fx -> return $ ElmBtIRec fx (bt lu ix) ix s)+      $ mkStream ls (Variable Check Nothing) lu (subword i $ j-ms)+  mkStream (ls :!: BtIRec c _ _ f bt) (Variable _ Nothing) lu (Subword (i:.j))+    = let ms = minSize c+          mk s = let Subword (_:.l) = getIdx s in return (s:.j-l-ms)+          step (s:.z)+            | z>=0      = do let Subword (_:.k) = getIdx s+                                 ix             = subword k (j-z)+                             f lu ix >>= \fx -> return $ S.Yield (ElmBtIRec fx (bt lu ix) ix s) (s:.z-1)+            | otherwise = return $ S.Done+          {-# INLINE [1] mk   #-}+          {-# INLINE [1] step #-}+      in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (subword i j)+  {-# INLINE mkStream #-}+-}++-}+
+ ADP/Fusion/SynVar/Recursive/Point.hs view
@@ -0,0 +1,3 @@++module ADP.Fusion.SynVar.Recursive.Point where+
+ ADP/Fusion/SynVar/Recursive/Subword.hs view
@@ -0,0 +1,13 @@++module ADP.Fusion.SynVar.Recursive.Subword where++import Data.Strict.Tuple+import Data.Vector.Fusion.Stream.Monadic+import Data.Vector.Fusion.Stream.Size+import Data.Vector.Fusion.Util (delay_inline)+import Debug.Trace+import Prelude hiding (map)++import ADP.Fusion.Base+import ADP.Fusion.SynVar.Recursive.Type+import ADP.Fusion.SynVar.Backtrack
+ ADP/Fusion/SynVar/Recursive/Type.hs view
@@ -0,0 +1,80 @@++module ADP.Fusion.SynVar.Recursive.Type where++import Data.Strict.Tuple ((:!:)(..))+import Data.Vector.Fusion.Stream.Monadic (Stream,head)+import Prelude hiding (head)++import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Base+import ADP.Fusion.SynVar.Backtrack+import ADP.Fusion.SynVar.Axiom++++data IRec m i x where+  IRec :: { iRecConstraint  :: !(TblConstraint i)+          , iRecFrom        :: !i+          , iRecTo          :: !i+          , iRecFun         :: !(i -> i -> m x)+          } -> IRec m i x++++instance Build (IRec m i x)++instance GenBacktrackTable (IRec mF i x) mF mB r where+  data Backtrack (IRec mF i x) mF mB r = BtIRec !(TblConstraint i) !i !i (i -> i -> mB x) (i -> i -> mB [r]) -- (Stream mB r))+  type BacktrackIndex (IRec mF i x)         = i+  toBacktrack (IRec c iF iT f) mrph bt = BtIRec c iF iT (\lu i -> mrph $ f lu i) bt+  {-# INLINE toBacktrack #-}++++instance+  ( Monad m+  , IndexStream i+  ) => Axiom (IRec m i x) where+  type AxiomStream (IRec m i x) = m x+  axiom (IRec c l h fun) = do+    k <- (head . uncurry streamDown) (l,h)+    fun h k+  {-# Inline axiom #-}++instance+  ( Monad mB+  , IndexStream i+  ) => Axiom (Backtrack (IRec mF i x) mF mB r) where+  type AxiomStream (Backtrack (IRec mF i x) mF mB r) = mB [r] -- (Stream mB r)+  axiom (BtIRec c l h fun btfun) = do+    k <- (head . uncurry streamDown) (l,h)+    btfun h k+  {-# Inline axiom #-}++++instance Element ls i => Element (ls :!: IRec m i x) i where+  data Elm (ls :!: IRec m i x) i = ElmIRec !x !i !i !(Elm ls i)+  type Arg (ls :!: IRec m i x)   = Arg ls :. x+  getArg (ElmIRec x _ _ ls) = getArg ls :. x+  getIdx (ElmIRec _ i _ _ ) = i+  getOmx (ElmIRec _ _ o _ ) = o+  {-# Inline getArg #-}+  {-# Inline getIdx #-}+  {-# Inline getOmx #-}++instance Element ls i => Element (ls :!: (Backtrack (IRec mF i x) mF mB r)) i where+  data Elm (ls :!: (Backtrack (IRec mF i x) mF mB r)) i = ElmBtIRec !x !(mB (Stream mB r)) !i !i !(Elm ls i)+  type Arg (ls :!: (Backtrack (IRec mF i x) mF mB r))   = Arg ls :. (x, mB (Stream mB r))+  getArg (ElmBtIRec x s _ _ ls) = getArg ls :. (x,s)+  getIdx (ElmBtIRec _ _ i _ _ ) = i+  getOmx (ElmBtIRec _ _ _ o _ ) = o+  {-# Inline getArg #-}+  {-# Inline getIdx #-}+  {-# Inline getOmx #-}++++-- TODO write multi-tape instances+
ADP/Fusion/TH.hs view
@@ -1,46 +1,76 @@-{-# LANGUAGE TemplateHaskell #-} -module ADP.Fusion.TH where+-- | 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@ -import Language.Haskell.TH-import Language.Haskell.TH.Syntax-import Data.List+module ADP.Fusion.TH+  ( makeAlgebraProduct+  , (<||)+  ) where++import           Data.List+import           Data.Tuple.Select+import           Language.Haskell.TH+import           Language.Haskell.TH.Syntax import qualified Data.Vector.Fusion.Stream.Monadic as SM +import           ADP.Fusion.TH.Backtrack (makeBacktrackingProductInstance,(<||))+import           ADP.Fusion.TH.Common (getRuleResultType)  ++makeAlgebraProduct = makeBacktrackingProductInstance++{- -- | 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. -makeAlgebraProduct :: Name -> Q [Dec]-makeAlgebraProduct nm = do+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-        -- find the objective function type (we crash if the user has more than-        -- one)-        let [oF] = filter (isObjectiveF . sel3) fs-        error $ unlines $ intersperse "\n" $ map show fs+      [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" -sel3 (a,b,c) = c+-- | Creates a class for each type of product and instances for each+-- signature. -zzz :: VarStrictType -> String-zzz (nm,s,t) = show (nm,s,t)+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 []+-} -isObjectiveF :: Type -> Bool-isObjectiveF (AppT (AppT ArrowT (AppT (AppT (ConT s) _) _)) (AppT _ _)) | s == ''SM.Stream = True-isObjectiveF _ = False --- AppT (AppT ArrowT---            (AppT (AppT (ConT Data.Vector.Fusion.Stream.Monadic.Stream)---                        (VarT m_1627401654)---                  )---            (VarT x_1627401655)---            )---      )---      (AppT (VarT m_1627401654) (VarT r_1627401656))
+ ADP/Fusion/TH/Backtrack.hs view
@@ -0,0 +1,262 @@++-- | Backtracking which uses lists internally. The basic idea is to convert+-- each @Stream@ into a list. The consumer consumes the stream lazily, but+-- allows for fusion to happen. The hope is that this improves total+-- performance in those cases, where backtracking has significant costs.++module ADP.Fusion.TH.Backtrack where++import           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 qualified Data.Vector.Mutable as VM+import qualified Data.Vector.Generic.Mutable as VGM+import qualified Data.Vector as V+import qualified Data.Vector.Generic as VG+import           Control.Monad.Primitive (PrimState, PrimMonad)+import           Data.Vector.Fusion.Stream.Monadic (Stream(..))+import           Debug.Trace++import           ADP.Fusion.TH.Common++++-- | The type class of algebra products. We have the forward signature+-- @sigF@ and the backtracking signature @sigB@. Combined via @(<||)@ we+-- have a new signature @SigR@.++class BacktrackingProduct sigF sigB where+  type SigR sigF sigB :: *+  (<||) :: sigF -> sigB -> SigR sigF sigB++makeBacktrackingProductInstance :: Name -> Q [Dec]+makeBacktrackingProductInstance tyconName = do+  t <- reify tyconName+  case t of+    TyConI (DataD ctx tyConName args cs d) -> do+      let m = getMonadName args+      case cs of+        [RecC dataconName funs] -> do+          let Just (h,m',x,r) = getObjectiveNames funs+          mL <- newName "mL"+          xL <- newName "xL"+          mR <- newName "mR"+          xR <- newName "xR"+          rR <- newName "rR"+          let lType    = buildLeftType  tyconName (m', x, r) (mL, xL)        args+          let rType    = buildRightType tyconName (m', x, r) (mR, xR, rR)    args+          let sigRType = buildSigRType  tyconName (m', x, r) xL (mR, xR, rR) args+          let (fs,hs) = partition ((`notElem` [h]) . sel1) funs+          Clause ps (NormalB b) ds <- genClauseBacktrack dataconName funs fs hs+          i <- [d| instance (Monad $(varT mL), Monad $(varT mR), Eq $(varT xL), $(varT mL) ~ $(varT mR)) => BacktrackingProduct $(return lType) $(return rType) where+                     type SigR $(return lType) $(return rType) = $(return sigRType)+                     (<||) = $(return $ LamE ps $ LetE ds b)+                     {-# Inline (<||) #-}+               |]+          return i++-- | 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++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 (KindedTV 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 s              = error $ "buildLeftType: " ++ show s++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 (KindedTV z _)+          | z == m    = mR+          | z == x    = xR+          | z == r    = rR+          | otherwise = z++buildSigRType :: Name -> (Name, Name, Name) -> (Name) -> (Name, Name, Name) -> [TyVarBndr] -> Type+buildSigRType tycon (m, x, r) (xL) (mR, xR, rR) = foldl AppT (ConT tycon) . map go+  where go (KindedTV z _)+          | z == m    = VarT mR+          | z == x    = (AppT (AppT (TupleT 2) (VarT xL)) (AppT ListT (VarT xR)))+          | z == r    = VarT rR+          | otherwise = VarT z++-- |++genClauseBacktrack+  :: Name+  -> [VarStrictType]+  -> [VarStrictType]+  -> [VarStrictType]+  -> Q Clause+genClauseBacktrack 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+  -- TODO automate discovery of choice functions?+  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) (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++-- |++genChoiceFunction+  :: Name+  -> Name+  -> VarStrictType+  -> Q (Name,Exp)+genChoiceFunction hL hR (name,_,t) = do+  exp <- buildBacktrackingChoice hL hR+  return (name,exp)+++-- |+--+-- 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 t) -- @init@ since we don't want the result as a parameter+  let exp = LamE lamPat $ TupE [funL,funR]+  return (name,exp)++-- |++recBuildLamPat :: [Name] -> Name -> Name -> [Name] -> Q ([Pat], Exp, Exp)+recBuildLamPat nts fL' fR' ts = do+  -- here we just run through all arguments, either creating an @x@ and+  -- a @ys@ for a non-term or a @t@ for a term.+  ps <- sequence [ if t `elem` nts then tupP [newName "x" >>= varP, newName "ys" >>= varP] else (newName "t" >>= varP) | t<-ts]+  let buildLfun f (TupP [VarP v,_]) = appE f (varE v)+      buildLfun f (VarP v         ) = appE f (varE v)+  lfun <- foldl buildLfun (varE fL') ps+  rfun <- buildRns (VarE fR') ps+  return (ps, lfun, rfun)+++-- |+--+-- NOTE+--+-- @+-- [ f x | x <- xs ]+-- CompE [BindS (VarP x) (VarE xs), NoBindS (AppE (VarE f) (VarE x))]+-- @++buildRns+  :: Exp+--  -> [Name]+  -> [Pat]+  -> ExpQ+buildRns f ps = do+  ys <- sequence [ newName "y" | TupP [_,VarP v] <- ps ]+  let vs = zipWith (\y v -> (BindS (VarP y) (VarE v))) ys [ v | TupP [_,VarP v] <- ps ]+  let xs = go ps ys+  ff <- noBindS $ foldl (\g z -> appE g (varE z)) (return f) xs+  return $ CompE $ vs ++ [ff]+  where go [] [] = []+        go (VarP v : gs) ys     = v : go gs ys  -- keep terminal binders+        go (TupP _ : gs) (v:ys) = v : go gs ys  -- insert new binders+        go as bs = error $ show ("not done?", as, bs)++-- | Build up the backtracking choice function. This choice function will+-- backtrack based on the first result, then return only the second.+--+-- TODO it should be (only?) this function we will need to modify to build+-- all algebra products.+--+-- @ysM@ can't be unboxed, as @snd@ of each element is a list, lazily+-- consumed. We build up @ysM@ as this makes fusion happen. Of course, this+-- is a boxed vector and not as efficient, but we gain the ability to have+-- lazily created backtracking from this!+--+-- This means strict optimization AND lazy backtracking++buildBacktrackingChoice :: Name -> Name -> Q Exp+buildBacktrackingChoice hL' hR' =+  [| \xs -> do        -- first, create a boxed, mutable vector from the results+               ysM <- streamToVector xs -- VGM.unstream xs :: m (VM.MVector s (t1,[t2]))+                      -- apply first choice+               hFres <- $(varE hL') $ SM.map fst $ vectorToStream ysM+                     -- second choice on snd elements, then concat'ed up+                     -- TODO good candidate for rewriting into flatten+                     -- operation!+               $(varE hR') $ SM.concatMap (SM.fromList . snd) $ SM.filter ((hFres==) . fst) $ vectorToStream ysM+  |]++-- | Transform a monadic stream monadically into a vector.++streamToVector :: (Monad m) => SM.Stream m x -> m (V.Vector x)+streamToVector xs = do+  l <- SM.toList xs+  let v = V.fromList l+  return v+{-# Inline streamToVector #-}++-- | Transform a vector into a monadic stream.++vectorToStream :: (Monad m) => V.Vector x -> SM.Stream m x+vectorToStream = SM.fromList . V.toList+{-# Inline vectorToStream #-}++-- | Gets the names used in the evaluation function. This returns one+-- 'Name' for each variable.+--+-- In case of @TupleT 0@ the type is @()@ and there isn't a name to go with+-- it. We just @mkName "()"@ a name, but this might be slightly dangerous?+-- (Not really sure if it indeed is)+--+-- With @AppT _ _@ we have a multidim terminal and produce another hackish+-- name to be consumed above.+--+-- @+-- AppT (AppT ArrowT (AppT (AppT (ConT Data.Array.Repa.Index.:.) (AppT (AppT (ConT Data.Array.Repa.Index.:.) (ConT Data.Array.Repa.Index.Z)) (VarT c_1627675270))) (VarT c_1627675270))) (VarT x_1627675265)+-- @++getRuleSynVarNames :: Type -> [Name]+getRuleSynVarNames t' = go t' where+  go t+    | VarT x <- t = [x]+    | AppT (AppT ArrowT (VarT x  )) y <- t = x : go y   -- this is a syntactic variable, return the name that the incoming data is bound to+    | AppT (AppT ArrowT (AppT _ _)) y <- t = mkName "[]" : go y   -- this captures that we have a multi-dim terminal.+    | AppT (AppT ArrowT (TupleT 0)) y <- t = mkName "()" : go y   -- this case captures things like @nil :: () -> x@ for rules like @nil <<< Epsilon@.+    | otherwise            = error $ "getRuleSynVarNames error: " ++ show t ++ "    in:    " ++ show t'+
+ ADP/Fusion/TH/Common.hs view
@@ -0,0 +1,19 @@++module ADP.Fusion.TH.Common where++import           Data.Tuple.Select+import           Language.Haskell.TH+import           Language.Haskell.TH.Syntax++++-- | The last @Name@ of a rule is the name of the syntactic type of the+-- result.++getRuleResultType :: VarStrictType -> Name+getRuleResultType vst = go $ sel3 vst where+  go t+    | AppT _ (VarT x) <- t = x+    | AppT _ x        <- t = go x+    | otherwise            = error $ "undetermined error:" ++ show vst+
− ADP/Fusion/Table.hs 
@@ -1,563 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-}--module ADP.Fusion.Table where--import Control.Monad.Primitive-import Data.Array.Repa.Index-import Data.Array.Repa.Shape-import Data.Strict.Tuple-import Data.Vector.Fusion.Stream.Size-import qualified Data.Vector.Fusion.Stream.Monadic as S-import qualified Data.Vector.Unboxed as VU-import Data.Strict.Maybe-import Prelude hiding (Maybe(..))--import Data.Array.Repa.Index.Subword-import Data.Array.Repa.Index.Points-import Data.Array.Repa.ExtShape-import qualified Data.PrimitiveArray as PA-import qualified Data.PrimitiveArray.Zero as PA--import ADP.Fusion.Classes--import Debug.Trace------ * Mutable table with adaptive storage.--data MTbl i xs = MTbl !(ENZ i) !xs -- (PA.MutArr m (arr i x))--mTblSw :: ENE -> PA.MutArr m (arr (Z:.Subword) x) -> MTbl Subword (PA.MutArr m (arr (Z:.Subword) x))-mTblSw = MTbl-{-# INLINE mTblSw #-}--mTbl :: ENZ i -> PA.MutArr m (arr i x) -> MTbl i (PA.MutArr m (arr i x))-mTbl = MTbl-{-# INLINE mTbl #-}---- | Generate the list of indices for use in table lookup.------ Don't touch stuff in greek! ζ is the interior stack of arguments, α the--- stack of saved indices--class TableIndices i where-  tableIndices :: Monad m => InOut i -> ENZ i -> i -> S.Stream m (ζ:!:α:!:i) -> S.Stream m (ζ:!:α:!:i)------ * Instances--instance TableIndices Z where-  tableIndices Z Z Z = id-  {-# INLINE tableIndices #-}--instance TableIndices Subword where-  -- | These actually don't make sense in 1-dim settings, we keep the code as a-  -- reminder how things should look like: @tableIndices Outer ZeroT-  -- (Subword(i:.j)) = S.map (:!:subword j j)@-  tableIndices _ ZeroT _ = error "TableIndices Subword/ZeroT does not make sense"-  tableIndices Outer _ (Subword(i:.j)) = S.map (\(ζ:!:α:!:Subword(k:.l)) -> (ζ:!:α:!:subword l j))-  tableIndices (Inner _ szd) ene (Subword(i:.j)) = S.flatten mk step Unknown where-    mk (ζ:!:α:!:kl@(Subword(k:.l))) =-      let le = l + case ene of { EmptyT -> 0 ; NonEmptyT -> 1 }-          l' = case szd of { Nothing -> le ; Just z -> max le (j-z) }-      in  return (ζ:!:α:!:l:!:l')-    step (ζ:!:α:!:k:!:l)-      | i>j = return S.Done-      | otherwise = return $ S.Yield (ζ:!:α:!:subword k l) (ζ:!:α:!:k:!:l+1)-  {-# INLINE tableIndices #-}--instance TableIndices is => TableIndices (is:.Subword) where-  tableIndices (os:.Outer) (es:._) (is:.Subword(i:.j))-    = S.map (\(ζ:!:(α:!:Subword(_:.l)):!:is) -> (ζ:!:α:!:(is:.subword l j))) -- extend index to the end-    . tableIndices os es is -- extend the @is@ part-    . S.map (\(ζ:!:α:!:(is:.i)) -> (ζ:!:(α:!:i):!:is)) -- move topmost index to α for safekeeping-  -- tables annotated with zero-width have zero width @l--l@-  -- This also reduces the number of "running indices"-  ---  -- TODO consider returning "def"ault elements here, instead of data from-  -- zero-length subword? Or does 'ZeroT' actually mean to extract (a/the)-  -- zero-length subword?-  ---  tableIndices (os:.Inner _ szd) (es:.ZeroT) (is:.Subword(i:.j))-    = S.map (\(ζ:!:(α:.Subword(k:.l)):!:is) -> (ζ:!:α:!:(is:.subword l l)))-    . tableIndices os es is-    . S.map (\(ζ:!:α:!:(is:.i)) -> (ζ:!:(α:.i):!:is))-  -- the default case, where we need to create indices-  tableIndices (os:.Inner _ szd) (es:.e) (is:.Subword(i:.j))-    = S.flatten mk step Unknown-    . tableIndices os es is-    . S.map (\(ζ:!:α:!:(is:.i)) -> (ζ:!:(α:.i):!:is))-    where mk (ζ:!:(α:.Subword (k:.l)):!:is) =-            let le = l + case e of { EmptyT -> 0 ; NonEmptyT -> 1 }-                l' = case szd of { Nothing -> le ; Just z -> max le (j-z) }-            in  return (ζ:!:α:!:is:!:l:!:l')-          step (ζ:!:α:!:is:!:k:!:l)-            | l > j = return $ S.Done-            | otherwise = return $ S.Yield (ζ:!:α:!:(is:.subword k l)) (ζ:!:α:!:is:!:k:!:l+1)-  {-#  INLINE tableIndices #-}--instance TableIndices is => TableIndices (is:.PointL) where-  tableIndices (os:.Outer) (es:._) (is:.PointL(i:.j))-    = S.map (\(ζ:!:(α:!:PointL(_:.l)):!:is) -> (ζ:!:α:!:(is:.pointL l j))) -- extend index to the end-    . tableIndices os es is -- extend the @is@ part-    . S.map (\(ζ:!:α:!:(is:.i)) -> (ζ:!:(α:!:i):!:is)) -- move topmost index to α for safekeeping-  tableIndices (os:.Inner _ szd) (es:.ZeroT) (is:.PointL(i:.j))-    = S.map (\(ζ:!:(α:.PointL(k:.l)):!:is) -> (ζ:!:α:!:(is:.pointL l l)))  -- does @l==lower bound@ have to be true here?-    . tableIndices os es is-    . S.map (\(ζ:!:α:!:(is:.i)) -> (ζ:!:(α:.i):!:is))-  -- the default case, where we need to create indices-  tableIndices (os:.Inner _ szd) (es:.e) (is:.PointL(i:.j))-    = S.flatten mk step Unknown-    . tableIndices os es is-    . S.map (\(ζ:!:α:!:(is:.i)) -> (ζ:!:(α:.i):!:is))-    where mk (ζ:!:(α:.PointL (k:.l)):!:is) =-            let le = l + case e of { EmptyT -> 0 ; NonEmptyT -> 1 }-                l' = case szd of { Nothing -> le ; Just z -> max le (j-z) }-            in  return (ζ:!:α:!:is:!:l:!:l')-          step (ζ:!:α:!:is:!:k:!:l)-            | l > j = return $ S.Done-            | otherwise = return $ S.Yield (ζ:!:α:!:(is:.pointL k l)) (ζ:!:α:!:is:!:k:!:l+1)-  {-#  INLINE tableIndices #-}--instance Build (MTbl i x)---- ** Subword--instance-  ( ValidIndex ls Subword-  , Monad m-  , PA.MPrimArrayOps arr (Z:.Subword) x-  ) => ValidIndex (ls:!:MTbl Subword (PA.MutArr m (arr (Z:.Subword) x))) Subword where-  validIndex (_  :!: MTbl ZeroT _) _ _ = error "table with ZeroT found, there is no reason (actually: no implementation) for 1-dim ZeroT tables"-  validIndex (ls :!: MTbl ene tbl) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =-    let (_,Z:.Subword (0:.n)) = PA.boundsM tbl-        minsize = max b (if ene==EmptyT then 0 else 1)-    in  i>=a && i+minsize<=j && j<=n-c && validIndex ls abc ij-  {-# INLINE validIndex #-}-  getParserRange (ls :!: MTbl ene _) ix = let (a:!:b:!:c) = getParserRange ls ix in if ene==EmptyT then (a:!:b:!:c) else (a:!:b+1:!:c)-  {-# INLINE getParserRange #-}--instance-  ( Elms ls Subword-  ) => Elms (ls :!: MTbl Subword (PA.MutArr m (arr (Z:.Subword) x))) Subword where-  data Elm (ls :!: MTbl Subword (PA.MutArr m (arr (Z:.Subword) x))) Subword = ElmMTblSw !(Elm ls Subword) !x !Subword -- ElmBtTbl !(Elm ls Subword) !x !(m (S.Stream m b)) !Subword-  type Arg (ls :!: MTbl Subword (PA.MutArr m (arr (Z:.Subword) x))) = Arg ls :. x-  getArg !(ElmMTblSw ls x _) = getArg ls :. x-  getIdx !(ElmMTblSw _  _ i) = i-  {-# INLINE getArg #-}-  {-# INLINE getIdx #-}--instance-  ( Monad m-  , PrimMonad m-  , Elms ls Subword-  , MkStream m ls Subword-  , PA.MPrimArrayOps arr (Z:.Subword) x-  ) => MkStream m (ls :!: MTbl Subword (PA.MutArr m (arr (Z:.Subword) x))) Subword where-  mkStream !(ls:!:MTbl ene tbl) Outer !ij@(Subword (i:.j))-    = S.mapM (\s -> let (Subword (_:.l)) = getIdx s in PA.readM tbl (Z:.subword l j) >>= \z -> return $ ElmMTblSw s z (subword l j))-    $ mkStream ls (Inner Check Nothing) (subword i $ case ene of { EmptyT -> j ; NonEmptyT -> j-1 })-  mkStream !(ls:!:MTbl ene tbl) (Inner _ szd) !ij@(Subword (i:.j)) = S.flatten mk step Unknown $ mkStream ls (Inner NoCheck Nothing) ij where-    mk !s = let (Subword (_:.l)) = getIdx s-                le = l + case ene of { EmptyT -> 0 ; NonEmptyT -> 1}-                l' = case szd of Nothing -> le-                                 Just z  -> max le (j-z)-            in return (s :!: l :!: l')-    {-# INLINE [0] mk #-}-    step !(s :!: k :!: l)-      | l > j = return S.Done-      | otherwise = PA.readM tbl (Z:.subword k l) >>= \z -> return $ S.Yield (ElmMTblSw s z (subword k l)) (s :!: k :!: l+1)-    {-# INLINE [0] step #-}-  {-# INLINE mkStream #-}---- ** multi-dim indices--instance-  ( Elms ls (is:.i)-  ) => Elms (ls :!: MTbl (is:.i) (PA.MutArr m (arr (is:.i) x))) (is:.i) where-  data Elm (ls :!: MTbl (is:.i) (PA.MutArr m (arr (is:.i) x))) (is:.i) = ElmMTbl !(Elm ls (is:.i)) !x !(is:.i)-  type Arg (ls :!: MTbl (is:.i) (PA.MutArr m (arr (is:.i) x))) = Arg ls :. x-  getArg !(ElmMTbl ls x _) = getArg ls :. x-  getIdx !(ElmMTbl _ _  i) = i-  {-# INLINE getArg #-}-  {-# INLINE getIdx #-}--instance-  ( Monad m-  , PrimMonad m-  , PA.MPrimArrayOps arr (is:.i) x-  , Elms ls (is:.i)-  , NonTermValidIndex (is:.i)-  , TableIndices (is:.i)-  , MkStream m ls (is:.i)-  ) => MkStream m (ls:!:MTbl (is:.i) (PA.MutArr m (arr (is:.i) x))) (is:.i) where-  mkStream (ls :!: MTbl enz tbl) os is-    = S.mapM (\(s:!:Z:!:β) -> PA.readM tbl β >>= \z -> return $ ElmMTbl s z β) -- extract data using β index-    . tableIndices os enz is -- generate indices for multiple dimensions-    . S.map (\s -> (s:!:Z:!:getIdx s)) -- extract the right-most current index-    $ mkStream ls (nonTermInnerOuter is os) (nonTermLeftIndex is os enz) -- TODO fix os is!-  {-# INLINE mkStream #-}--instance-  ( ValidIndex ls (is:.i)-  , PA.MPrimArrayOps arr (is:.i) x-  , NonTermValidIndex (is:.i)-  ) => ValidIndex (ls :!: MTbl (is:.i) (PA.MutArr m (arr (is:.i) x))) (is:.i) where-  validIndex (ls :!: MTbl es tbl) abc isi =-    let (_,rght) = PA.boundsM tbl-    in  nonTermValidIndex es rght abc isi && validIndex ls abc isi-  getParserRange (ls :!: MTbl es _) ix = getNonTermParserRange es ix $ getParserRange ls ix-  {-# INLINE validIndex #-}-  {-# INLINE getParserRange #-}--class NonTermValidIndex i where-  nonTermValidIndex :: ENZ i -> i -> ParserRange i -> i -> Bool-  getNonTermParserRange :: ENZ i -> i -> ParserRange i -> ParserRange i-  nonTermInnerOuter :: i -> InOut i -> InOut i-  nonTermLeftIndex :: i -> InOut i -> ENZ i -> i--instance NonTermValidIndex Z where-  nonTermValidIndex Z Z Z Z = True-  getNonTermParserRange Z Z Z = Z-  nonTermInnerOuter Z Z = Z-  nonTermLeftIndex Z Z Z = Z-  {-# INLINE nonTermValidIndex #-}-  {-# INLINE getNonTermParserRange #-}-  {-# INLINE nonTermInnerOuter #-}-  {-# INLINE nonTermLeftIndex #-}--instance NonTermValidIndex is => NonTermValidIndex (is:.Subword) where-  nonTermValidIndex (es:.e) (ns:.Subword(_:.n)) (abc:.(a:!:b:!:c)) (is:.Subword(i:.j)) =-    let minsize = max b (if e==EmptyT then 0 else 1)-    in  i>=a && i+minsize<=j && j<=n-c && nonTermValidIndex es ns abc is-  getNonTermParserRange (es:.e) (is:._) (abc:.(a:!:b:!:c)) =-    let b' = b + if e==EmptyT then 0 else 1-    in  getNonTermParserRange es is abc :. (a:!:b':!:c)-  nonTermInnerOuter (is:._) (os:.Outer) = nonTermInnerOuter is os :. Inner Check Nothing-  nonTermInnerOuter (is:._) (os:.Inner _ _) = nonTermInnerOuter is os :. Inner NoCheck Nothing-  nonTermLeftIndex (is:.Subword(i:.j)) (os:.o) (es:.e)-    | o==Outer && e==NonEmptyT = nonTermLeftIndex is os es :. subword i (j-1)-    | otherwise                = nonTermLeftIndex is os es :. subword i j-  {-# INLINE nonTermValidIndex #-}-  {-# INLINE getNonTermParserRange #-}-  {-# INLINE nonTermInnerOuter #-}-  {-# INLINE nonTermLeftIndex #-}---- TODO autogenerated, check correctness--instance NonTermValidIndex is => NonTermValidIndex (is:.PointL) where-  nonTermValidIndex (es:.e) (ns:.PointL(_:.n)) (abc:.(a:!:b:!:c)) (is:.PointL(i:.j)) =-    let minsize = max b (if e==EmptyT then 0 else 1)-    in  i>=a && i+minsize<=j && j<=n-c && nonTermValidIndex es ns abc is-  getNonTermParserRange (es:.e) (is:._) (abc:.(a:!:b:!:c)) =-    let b' = b + if e==EmptyT then 0 else 1-    in  getNonTermParserRange es is abc :. (a:!:b':!:c)-  nonTermInnerOuter (is:._) (os:.Outer) = nonTermInnerOuter is os :. Inner Check Nothing-  nonTermInnerOuter (is:._) (os:.Inner _ _) = nonTermInnerOuter is os :. Inner NoCheck Nothing-  nonTermLeftIndex (is:.PointL(i:.j)) (os:.o) (es:.e)-    | o==Outer && e==NonEmptyT = nonTermLeftIndex is os es :. pointL i (j-1)-    | otherwise                = nonTermLeftIndex is os es :. pointL i j-  {-# INLINE nonTermValidIndex #-}-  {-# INLINE getNonTermParserRange #-}-  {-# INLINE nonTermInnerOuter #-}-  {-# INLINE nonTermLeftIndex #-}----data BtTbl i xs f = BtTbl !(ENZ i) !xs !f -- (i -> m (S.Stream m b))--btTbl :: ENZ i -> xs -> f -> BtTbl i xs f --(i -> m (S.Stream m b)) -> BtTbl m i xs b-btTbl = BtTbl-{-# INLINE btTbl #-}--type DefBtTbl m isi x b = BtTbl isi (PA.Unboxed isi x) (isi -> m (S.Stream m b))-type SwBtTbl m x b = BtTbl Subword (PA.Unboxed (Z:.Subword) x) (Subword -> m (S.Stream m b))--instance Build (BtTbl i xs f)--instance-  ( Elms ls Subword-  ) => Elms (ls :!: SwBtTbl m x b) Subword where-  data Elm (ls :!: SwBtTbl m x b) Subword = ElmSwBtTbl !(Elm ls Subword) !(x,m (S.Stream m b)) !Subword-  type Arg (ls :!: SwBtTbl m x b) = Arg ls :. (x,m (S.Stream m b))-  getArg !(ElmSwBtTbl ls x _) = getArg ls :. x-  getIdx !(ElmSwBtTbl _ _  i) = i-  {-# INLINE getArg #-}-  {-# INLINE getIdx #-}--instance-  ( Monad m-  , Elms ls Subword-  , VU.Unbox x-  , MkStream m ls Subword-  ) => MkStream m (ls :!: SwBtTbl m x b) Subword where-  mkStream !(ls:!:BtTbl ene tbl f) Outer !ij@(Subword (i:.j))-    = S.mapM (\s -> let (Subword (_:.l)) = getIdx s in return $ ElmSwBtTbl s (tbl PA.! (Z:.subword l j), f $ subword l j) (subword l j))-    $ mkStream ls (Inner Check Nothing) (subword i $ case ene of { EmptyT -> j ; NonEmptyT -> j-1 })-  mkStream !(ls:!:BtTbl ene tbl f) (Inner _ szd) !ij@(Subword (i:.j)) = S.flatten mk step Unknown $ mkStream ls (Inner NoCheck Nothing) ij where-    mk !s = let (Subword (_:.l)) = getIdx s-                le = l + case ene of { EmptyT -> 0 ; NonEmptyT -> 1}-                l' = case szd of Nothing -> le-                                 Just z  -> max le (j-z)-            in return (s :!: l :!: l')-    step !(s :!: k :!: l)-      | l > j = return S.Done-      | otherwise = return $ S.Yield (ElmSwBtTbl s (tbl PA.! (Z:.subword k l), f $ subword k l) (subword k l)) (s :!: k :!: l+1)-  {-# INLINE mkStream #-}--instance-  ( ValidIndex ls Subword-  , VU.Unbox x-  ) => ValidIndex (ls :!: SwBtTbl m x b) Subword where-  validIndex (_  :!: BtTbl ZeroT _ _) _ _ = error "table with ZeroT found, there is no reason (actually: no implementation) for 1-dim ZeroT tables"-  validIndex (ls :!: BtTbl ene tbl _) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =-    let (_,Z:.Subword (0:.n)) = PA.bounds tbl-        minsize = max b (if ene==EmptyT then 0 else 1)-    in  i>=a && i+minsize<=j && j<=n-c && validIndex ls abc ij-  {-# INLINE validIndex #-}-  getParserRange (ls :!: BtTbl ene _ f) ix = let (a:!:b:!:c) = getParserRange ls ix in if ene==EmptyT then (a:!:b:!:c) else (a:!:b+1:!:c)-  {-# INLINE getParserRange #-}--instance-  ( Elms ls (is:.i)-  ) => Elms (ls :!: DefBtTbl m (is:.i) x b) (is:.i) where-  data Elm (ls :!: DefBtTbl m (is:.i) x b) (is:.i) = ElmBtTbl !(Elm ls (is:.i)) !(x,m (S.Stream m b)) !(is:.i)-  type Arg (ls :!: DefBtTbl m (is:.i) x b) = Arg ls :. (x,m (S.Stream m b))-  getArg !(ElmBtTbl ls x _) = getArg ls :. x-  getIdx !(ElmBtTbl _ _  i) = i-  {-# INLINE getArg #-}-  {-# INLINE getIdx #-}--instance-  ( Monad m-  , Elms ls (is:.i)-  , ExtShape (is:.i)-  , Shape (is:.i)-  , VU.Unbox x-  , NonTermValidIndex (is:.i)-  , TableIndices (is:.i)-  , MkStream m ls (is:.i)-  ) => MkStream m (ls:!:DefBtTbl m (is:.i) x b) (is:.i) where-  mkStream (ls :!: BtTbl enz tbl f) os is-    = S.map (\(s:!:Z:!:β) -> ElmBtTbl s (tbl PA.! β,f β) β) -- extract data using β index-    . tableIndices os enz is -- generate indices for multiple dimensions-    . S.map (\s -> (s:!:Z:!:getIdx s)) -- extract the right-most current index-    $ mkStream ls (nonTermInnerOuter is os) (nonTermLeftIndex is os enz) -- TODO fix os is!-  {-# INLINE mkStream #-}--instance-  ( ValidIndex ls (is:.i)-  , Shape (is:.i)-  , ExtShape (is:.i)-  , VU.Unbox x-  , NonTermValidIndex (is:.i)-  ) => ValidIndex (ls :!: DefBtTbl m (is:.i) x b) (is:.i) where-  validIndex (ls :!: BtTbl es tbl f) abc isi =-    let (_,rght) = PA.bounds tbl-    in  nonTermValidIndex es rght abc isi && validIndex ls abc isi-  getParserRange (ls :!: BtTbl es _ _) ix = getNonTermParserRange es ix $ getParserRange ls ix-  {-# INLINE validIndex #-}-  {-# INLINE getParserRange #-}----class EmptyTable x where-  toEmptyT :: x -> x-  toNonEmptyT :: x -> x--instance (EmptyENZ (ENZ i)) => EmptyTable (MTbl i xs) where-  toEmptyT    (MTbl enz xs) = MTbl (toEmptyENZ    enz) xs-  toNonEmptyT (MTbl enz xs) = MTbl (toNonEmptyENZ enz) xs-  {-# INLINE toEmptyT #-}-  {-# INLINE toNonEmptyT #-}--instance (EmptyENZ (ENZ i)) => EmptyTable (BtTbl i xs f) where-  toEmptyT    (BtTbl enz xs f) = BtTbl (toEmptyENZ    enz) xs f-  toNonEmptyT (BtTbl enz xs f) = BtTbl (toNonEmptyENZ enz) xs f-  {-# INLINE toEmptyT #-}-  {-# INLINE toNonEmptyT #-}-----{----- * Backtracking tables.--data BtTbl m x b = BtTbl ENE !(PA.Unboxed (Z:.Subword) x) !(Subword -> m (S.Stream m b))--instance Build (BtTbl m x b)--instance-  ( Monad m-  , Elms ls Subword-  ) => Elms (ls :!: BtTbl m x b) Subword where-  data Elm (ls :!: BtTbl m x b) Subword = ElmBtTbl !(Elm ls Subword) !x !(m (S.Stream m b)) !Subword-  type Arg (ls :!: BtTbl m x b) = Arg ls :. (x,m (S.Stream m b))-  getArg !(ElmBtTbl ls x b _) = getArg ls :. (x,b)-  getIdx !(ElmBtTbl _  _ _ i) = i-  {-# INLINE getArg #-}-  {-# INLINE getIdx #-}--instance-  ( Monad m-  , VU.Unbox x-  , Elms ls Subword-  , MkStream m ls Subword-  ) => MkStream m (ls :!: BtTbl m x b) Subword where-  mkStream !(ls:!:BtTbl ene xs f) Outer !ij@(Subword (i:.j))-    = S.map (\s -> let (Subword (k:.l)) = getIdx s in ElmBtTbl s (xs PA.! (Z:.subword l j)) (f $ subword l j) (subword l j))-    $ mkStream ls (Inner Check Nothing) (subword i $ case ene of { EmptyT -> j ; NoEmptyT -> j-1 })-  mkStream !(ls:!:BtTbl ene xs f) (Inner _ szd) !ij@(Subword (i:.j)) = S.flatten mk step Unknown $ mkStream ls (Inner NoCheck Nothing) ij where-    mk !s = let (Subword (k:.l)) = getIdx s-                le = l + case ene of { EmptyT -> 0 ; NoEmptyT -> 1}-                l' = case szd of Nothing -> le-                                 Just z  -> max le (j-z)-            in  return (s:!:l:!: l')-    step !(s:!:k:!:l)-      | l > j     = return $ S.Done-      | otherwise = return $ S.Yield (ElmBtTbl s (xs PA.! (Z:.subword k l)) (f $ subword k l) (subword k l)) (s:!:k:!:l+1)-  {-# INLINE mkStream #-}------ * Unboxed mutable table for the forward phase in one dimension.--data MTbl xs = MTbl !ENE !xs--instance-  ( ValidIndex ls Subword-  , Monad m-  , PA.MPrimArrayOps arr (Z:.Subword) x-  ) => ValidIndex (ls:!:MTbl (PA.MutArr m (arr (Z:.Subword) x))) Subword where-  validIndex (_  :!: MTbl ZeroT _) _ _ = error "table with ZeroT found, there is no reason (actually: no implementation) for 1-dim ZeroT tables"-  validIndex (ls :!: MTbl ene tbl) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =-    let (_,Z:.Subword (0:.n)) = PA.boundsM tbl-        minsize = max b (if ene==EmptyT then 0 else 1)-    in  i>=a && i+minsize<=j && j<=n-c && validIndex ls abc ij-  {-# INLINE validIndex #-}-  getParserRange (ls :!: MTbl ene _) ix = let (a:!:b:!:c) = getParserRange ls ix in if ene==EmptyT then (a:!:b:!:c) else (a:!:b+1:!:c)-  {-# INLINE getParserRange #-}--instance Build (MTbl xs)--instance-  ( Monad m-  , Elms ls Subword-  ) => Elms (ls :!: MTbl (PA.MutArr m (arr (Z:.Subword) x))) Subword where-  data Elm (ls :!: MTbl (PA.MutArr m (arr (Z:.Subword) x))) Subword = ElmMTbl !(Elm ls Subword) !x !Subword-  type Arg (ls :!: MTbl (PA.MutArr m (arr (Z:.Subword) x))) = Arg ls :. x-  getArg !(ElmMTbl ls x _) = getArg ls :. x-  getIdx !(ElmMTbl _ _ i) = i-  {-# INLINE getArg #-}-  {-# INLINE getIdx #-}--instance-  ( PrimMonad m-  , PA.MPrimArrayOps arr (Z:.Subword) x-  , Elms ls Subword-  , MkStream m ls Subword-  ) => MkStream m (ls:!:MTbl (PA.MutArr m (arr (Z:.Subword) x))) Subword where-  mkStream !(ls:!:MTbl ene tbl) Outer !ij@(Subword (i:.j))-    = S.mapM (\s -> let (Subword (_:.l)) = getIdx s in PA.readM tbl (Z:.subword l j) >>= \z -> return $ ElmMTbl s z (subword l j))-    $ mkStream ls (Inner Check Nothing) (subword i $ case ene of { EmptyT -> j ; NoEmptyT -> j-1 })-  mkStream !(ls:!:MTbl ene tbl) (Inner _ szd) !ij@(Subword (i:.j)) = S.flatten mk step Unknown $ mkStream ls (Inner NoCheck Nothing) ij where-    mk !s = let (Subword (_:.l)) = getIdx s-                le = l + case ene of { EmptyT -> 0 ; NoEmptyT -> 1}-                l' = case szd of Nothing -> le-                                 Just z  -> max le (j-z)-            in return (s :!: l :!: l')-    step !(s :!: k :!: l)-      | l > j = return S.Done-      | otherwise = PA.readM tbl (Z:.subword k l) >>= \z -> return $ S.Yield (ElmMTbl s z (subword k l)) (s :!: k :!: l+1)-  {-# INLINE mkStream #-}----{----- ** multi-tape generalization: empty / nonempty--instance-  ( ValidIndex ls (is:.i)-  , Monad m-  , PA.MPrimArrayOps arr (is:.i) x-  ) => ValidIndex (ls :!: MTbl (PA.MutArr m (arr (is:.i) x))) (is:.i) where-    validIndex (ls :!: MTbl ene tbl) (is:.i) =-      let-      in  undefined--instance-  ( Monad m-  ) => Elms (ls :!: MTbl (PA.MutArr m (arr (is:.i) x))) (is:.i) where--instance-  ( Monad m-  ) => MkStream m (ls:!: MTbl (PA.MutArr m (arr (is:.i) x))) (is:.i) where-  mkStream !(ls:!:MTbl ene tbl) io is-    = undefined----{--data GMtbl i x = forall m . GMtbl (ENEdim i) (PA.MutArr m (Storage i x))---}---}---}---{----- * Immutable tables.--data Tbl x = Tbl !(PA.Unboxed (Z:.Subword) x)--instance Build (Tbl x)--instance-  ( Elms ls Subword-  ) => Elms (ls :!: Tbl x) Subword where-  data Elm (ls :!: Tbl x) Subword = ElmTbl !(Elm ls Subword) !x !Subword-  type Arg (ls :!: Tbl x) = Arg ls :. x-  getArg !(ElmTbl ls x _) = getArg ls :. x-  getIdx !(ElmTbl _ _ idx) = idx-  {-# INLINE getArg #-}-  {-# INLINE getIdx #-}--instance-  ( Monad m-  , VU.Unbox x-  , Elms ls Subword-  , MkStream m ls Subword-  ) => MkStream m (ls:!:Tbl x) Subword where-  mkStream !(ls:!:Tbl xs) Outer !ij@(Subword (i:.j)) = S.map (\s -> let (Subword (k:.l)) = getIdx s in ElmTbl s (xs PA.! (Z:.subword l j)) (subword l j)) $ mkStream ls (Inner Check Nothing) ij-  mkStream !(ls:!:Tbl xs) (Inner _ szd) !ij@(Subword (i:.j)) = S.flatten mk step Unknown $ mkStream ls (Inner NoCheck Nothing) ij where-    mk !s = let (Subword (k:.l)) = getIdx s-                le = l -- TODO need to add ENE here ! -- + case ene of { EmptyT -> 0 ; NoEmptyT -> 1}-                l' = case szd of Nothing -> le-                                 Just z  -> max le (j-z)-            in  return (s :!: l :!: l')-    step !(s :!: k :!: l)-      | l > j = return S.Done-      | otherwise = return $ S.Yield (ElmTbl s (xs PA.! (Z:.subword k l)) (subword k l)) (s :!: k :!: l+1)-  {-# INLINE mkStream #-}----}--
+ ADP/Fusion/Term.hs view
@@ -0,0 +1,17 @@++module ADP.Fusion.Term+  ( module ADP.Fusion.Term.Chr+  , module ADP.Fusion.Term.Deletion+  , module ADP.Fusion.Term.Edge+  , module ADP.Fusion.Term.Epsilon+  , module ADP.Fusion.Term.PeekIndex+  , module ADP.Fusion.Term.Strng+  ) where++import           ADP.Fusion.Term.Chr+import           ADP.Fusion.Term.Deletion+import           ADP.Fusion.Term.Edge+import           ADP.Fusion.Term.Epsilon+import           ADP.Fusion.Term.PeekIndex+import           ADP.Fusion.Term.Strng+
+ ADP/Fusion/Term/Chr.hs view
@@ -0,0 +1,197 @@++module ADP.Fusion.Term.Chr+  ( module ADP.Fusion.Term.Chr.Type+  , module ADP.Fusion.Term.Chr.Point+  , module ADP.Fusion.Term.Chr.Subword+  ) where++import ADP.Fusion.Term.Chr.Point+import ADP.Fusion.Term.Chr.Subword+import ADP.Fusion.Term.Chr.Type++++++++{-++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+--+-- TODO PointL , PointR need sanity checks for boundaries++module ADP.Fusion.Term.Chr where++import           Control.Exception(assert)+import qualified Data.Vector.Fusion.Stream.Monadic as S+import qualified Data.Vector.Unboxed as VU++import           Data.PrimitiveArray -- ((:.)(..), Subword(..), subword, PointL(..), pointL, PointR(..), pointR, Outside(..))+++import Debug.Trace++++++-- ** @PointL@ single-dim instances++{-+instance+  ( Monad m+  , Element ls PointL+  , MkStream m ls PointL+  ) => MkStream m (ls :!: Chr r x) PointL where+  mkStream (ls :!: Chr f xs) Static lu@(PointL (l:.u)) (PointL (i:.j))+    = staticCheck (j>l && j>0 && j<=u && j<= VG.length xs) $+      let !z = () -- f xs (j-1) -- let-floating leads to too early evaluation+      in  S.map (ElmChr (f xs $ j-1) (pointL (j-1) j))+          $ mkStream ls Static lu (pointL i $ j-1)+--  mkStream _ _ _ _ = error "mkStream / Chr / PointL not implemented"+  {-# INLINE mkStream #-}++instance+  ( Monad m+  , Element ls (Outside PointL)+  , MkStream m ls (Outside PointL)+  ) => MkStream m (ls :!: Chr r x) (Outside PointL) where+  mkStream (ls :!: Chr f xs) Static lu@(O (PointL (l:.u))) (O (PointL (i:.j)))+    = staticCheck (j<u) $+      let !z = f xs j+      in  S.map (ElmChr z (O . pointL j $ j+1))+          $ mkStream ls Static lu (O . pointL i $ j+1)+--  mkStream _ _ _ _ = error "mkStream / Chr / Outside PointL not implemented"+  {-# INLINE mkStream #-}+-}+++-- ** @Subword@ single-dim instances++{-+instance+  ( Monad m+  , Element ls Subword+  , MkStream m ls Subword+  ) => MkStream m (ls :!: Chr r x) Subword where+  mkStream (ls :!: Chr f xs) Static lu@(Subword (l:.u)) ij@(Subword (i:.j))+    -- We use a static check here as we can then pull out the @z@ character+    -- lookup. In the Nussinov example (X -> f <<< z1 t z2 t) this gives+    -- a 3x performance improvement. Note that this benchmark is a bit+    -- artificial.+    --+    -- The static part is called @right-most@, i.e. when only terminals with+    -- known fixed sizes are on the right of this terminal.+    = staticCheck (j>0 && j<=u) $+      let !z = f xs (j-1)+      in S.map (ElmChr z (subword (j-1) j))+         $ mkStream ls Static lu (subword i $ j-1)+  mkStream (ls :!: Chr f xs) v lu ij@(Subword (i:.j))+    -- This version is used when to right, we already had variable-size+    -- (non-)terminals to the right.+    = S.map (\s -> let Subword (k:.l) = getIdx s+                   in  ElmChr (f xs l) (subword l $ l+1) s+            )+    $ mkStream ls v lu (subword i $ j-1)+  {-# INLINE mkStream #-}+-}++-- Note how the indices grow to the outside!++{-+instance+  ( Monad m+  , Element ls (Outside Subword)+  , MkStream m ls (Outside Subword)+  ) => MkStream m (ls :!: Chr r x) (Outside Subword) where+  -- For the static case, we move the @j@ index.+  mkStream (ls :!: Chr f xs) Static lu@(O (Subword (l:.u))) ij@(O (Subword (i:.j)))+    = staticCheck (j>=0 && j<u) $+      let !z = f xs j+      in S.map (ElmChr z (O $ subword j (j+1)))+         $ mkStream ls Static lu (O $ subword i $ j+1)+  -- In the variable case, (i) we set @i@ to @i-1@ going further down. (ii) On+  -- going back up, we extract the rightmost index of the left symbol @l@ --+  -- which could be @i-1@ but need not be.+  mkStream (ls :!: Chr f xs) v lu ij@(O (Subword (i:.j)))+    = S.map (\s -> let O (Subword (_:.l)) = getIdx s+                   in  ElmChr (f xs l) (O . subword l $ l+1) s+            )+    $ mkStream ls v lu (O $ subword (i-1) j)+  {-# INLINE mkStream #-}+-}++++{-++-- * Multi-dimensional stuff++{-+instance TermStaticVar (Chr r x) Subword where+  termStaticVar   _ sv _                = sv+  termStreamIndex _ _  (Subword (i:.j)) = subword i $ j-1+  {-# INLINE termStaticVar #-}+  {-# INLINE termStreamIndex #-}+-}++instance TermStaticVar (Chr r x) PointR where+  termStaticVar   _ sv _                = sv+  termStreamIndex _ _  (PointR (i:.j)) = pointR i $ j-1+  {-# INLINE termStaticVar #-}+  {-# INLINE termStreamIndex #-}++-- TODO removed the static check since *in principle* the statics system down+-- at the bottom of the stack should take care of it! Need to verify with+-- QuickCheck, though.++{-+instance+  ( Monad m+  , TerminalStream m a is+  ) => TerminalStream m (TermSymbol a (Chr r x)) (is:.Subword) where+  terminalStream (a:>Chr f (!v)) (sv:.Static) (is:.Subword (i:.j))+    = id -- staticCheck (j>0)+    . S.map (\(Qd s (z:._) is e) -> Qd s z (is:.subword (j-1) j) (e:.f v (j-1)))+    . terminalStream a sv is+    . S.map (\(Tr s z (is:.i)) -> Tr s (z:.i) is)+  terminalStream (a:>Chr f (!v)) (sv:._) (is:.Subword (i:.j))+    = S.map (\(Qd s (z:.Subword (k:.l)) is e) -> Qd s z (is:.subword l (l+1)) (e:.f v (l-1)))+    . terminalStream a sv is+    . S.map (\(Tr s z (is:.i)) -> Tr s (z:.i) is)+  {-# INLINE terminalStream #-}+-}++{-+instance+  ( Monad m+  , TerminalStream m a is+  ) => TerminalStream m (TermSymbol a (Chr r x)) (is:.PointR) where+  terminalStream (a:>Chr f (!v)) (sv:.Static) (is:.PointR (i:.j))+    = S.map (\(Qd s (z:._) is e) -> Qd s z (is:.pointR (j-1) j) (e:.f v (j-1)))+    . terminalStream a sv is+    . S.map (\(Tr s z (is:.i)) -> Tr s (z:.i) is)+  terminalStream (a:>Chr f (!v)) (sv:._) (is:.PointR (i:.j))+    = S.map (\(Qd s (z:.PointR (k:.l)) is e) -> Qd s z (is:.pointR l (l+1)) (e:.f v (l-1)))+    . terminalStream a sv is+    . S.map (\(Tr s z (is:.i)) -> Tr s (z:.i) is)+  {-# INLINE terminalStream #-}+-}++-}+++-}+
+ ADP/Fusion/Term/Chr/Point.hs view
@@ -0,0 +1,91 @@++module ADP.Fusion.Term.Chr.Point where++import           Data.Strict.Tuple+import           Debug.Trace+import qualified Data.Vector.Fusion.Stream.Monadic as S+import qualified Data.Vector.Generic as VG++import           Data.PrimitiveArray++import           ADP.Fusion.Base+import           ADP.Fusion.Term.Chr.Type+++instance+  ( Monad m+  , Element ls PointL+  , MkStream m ls PointL+  ) => MkStream m (ls :!: Chr r x) PointL where+  mkStream (ls :!: Chr f xs) (IStatic d) (PointL u) (PointL i)+    = staticCheck (i>0 && i<=u && i<= VG.length xs)+    $ S.map (ElmChr (f xs $ i-1) (PointL $ i) (PointL 0))+    $ mkStream ls (IStatic d) (PointL u) (PointL $ i-1)+  mkStream _ _ _ _ = error "mkStream / Chr / PointL can only be implemented for IStatic"+  {-# Inline mkStream #-}++instance+  ( Monad m+  , Element ls (Outside PointL)+  , MkStream m ls (Outside PointL)+  ) => MkStream m (ls :!: Chr r x) (Outside PointL) where+  mkStream (ls :!: Chr f xs) (OStatic d) (O (PointL u)) (O (PointL i))+    = S.map (\z -> let (O (PointL k)) = getOmx z in ElmChr (f xs $ k-d-1) (O . PointL $ k-d) (getOmx z) z)+    $ mkStream ls (OStatic $ d+1) (O $ PointL u) (O $ PointL i)+  mkStream _ _ _ _ = error "Chr.Point / mkStream / Chr / Outside.PointL can only be implemented for OStatic"+  {-# Inline mkStream #-}++-- TODO @Inline [0]@ ???++instance TermStaticVar (Chr r x) PointL where+  termStaticVar   _ sv _                = sv+  termStreamIndex _ _  (PointL j) = PointL $ j-1+  {-# Inline termStaticVar #-}+  {-# Inline termStreamIndex #-}++instance TermStaticVar (Chr r x) (Outside PointL) where+  termStaticVar   _ (OStatic d) _ = OStatic (d+1) +  termStreamIndex _ _           j = j+  {-# Inline termStaticVar #-}+  {-# Inline termStreamIndex #-}++instance+  ( Monad m+  , TerminalStream m a is+  ) => TerminalStream m (TermSymbol a (Chr r x)) (is:.PointL) where+  terminalStream (a:|Chr f (!v)) (sv:.IStatic _) (is:.i@(PointL j))+    = S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.PointL j) (os:.PointL 0) (e:.f v (j-1)))+    . iPackTerminalStream a sv (is:.i)+    {-+    . terminalStream a sv is+    . S.map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)+    -}+  terminalStream (a:|Chr f (!v)) (sv:._) (is:.i@(PointL _))+    = S.map (\(S6 s (zi:.PointL k) (zo:.PointL l) is os e) -> S6 s zi zo (is:.PointL (k+1)) (os:.PointL 0) (e:.f v (l-1)))+    . iPackTerminalStream a sv (is:.i)+    {-+    . terminalStream a sv is+    . S.map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)+    -}+  {-# INLINE terminalStream #-}++instance+  ( Monad m+  , TerminalStream m a (Outside is)+  , Context (Outside (is:.PointL)) ~ (Context (Outside is) :. OutsideContext Int)+  ) => TerminalStream m (TermSymbol a (Chr r x)) (Outside (is:.PointL)) where+  terminalStream (a:|Chr f (!v)) (sv:.OStatic d) (O (is:.i))+    = S.map (\(S6 s (zi:._) (zo:.(PointL k)) (O is) (O os) e) -> S6 s zi zo (O (is:.(PointL $ k-d))) (O (os:.PointL k)) (e:.f v (k-d-1)))+    . oPackTerminalStream a sv (O (is:.i))+    {-+    . terminalStream a sv (O is)+    . S.map (\(S5 s zi zo (O (is:.i)) (O (os:.o))) -> S5 s (zi:.i) (zo:.o) (O is) (O os))+    -}+  {-+  terminalStream (a:|Chr f (!v)) (sv:._) (is:.PointL i)+    = S.map (\(S6 s (zi:.PointL k) (zo:.PointL l) is os e) -> S6 s zi zo (is:.PointL (k+1)) (os:.PointL 0) (e:.f v (l-1)))+    . terminalStream a sv is+    . S.map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)+  -}+  {-# INLINE terminalStream #-}+
+ ADP/Fusion/Term/Chr/Subword.hs view
@@ -0,0 +1,61 @@++module ADP.Fusion.Term.Chr.Subword where++import           Data.Strict.Tuple+import           Data.Vector.Fusion.Util (delay_inline)+import           Debug.Trace+import           Data.Vector.Fusion.Stream.Monadic as S+import qualified Data.Vector.Generic as VG+import           Prelude hiding (map)++import           Data.PrimitiveArray hiding (map)++import           ADP.Fusion.Base+import           ADP.Fusion.Term.Chr.Type++++instance+  ( Monad m+  , Element ls Subword+  , MkStream m ls Subword+  ) => MkStream m (ls :!: Chr r x) Subword where+  mkStream (ls :!: Chr f xs) (IStatic ()) hh (Subword (i:.j))+    = staticCheck (i>=0 && i<j && j<= VG.length xs)+    $ map (ElmChr (f xs $ j-1) (subword (j-1) j) (subword 0 0))+    $ mkStream ls (IStatic ()) hh (delay_inline Subword (i:.j-1))+  mkStream (ls :!: Chr f xs) (IVariable ()) hh (Subword (i:.j))+    = map (\s -> let Subword (_:.l) = getIdx s+                 in  ElmChr (f xs l) (subword l (l+1)) (subword 0 0) s)+    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j-1))+  {-# Inline mkStream #-}++++instance+  ( Monad m+  , Element ls (Outside Subword)+  , MkStream m ls (Outside Subword)+  ) => MkStream m (ls :!: Chr r x) (Outside Subword) where+  mkStream (ls :!: Chr f xs) (OStatic (di:.dj)) u ij@(O (Subword (i:.j)))+    = id -- staticCheck ( j < h ) -- TODO any check possible?+    $ map (\s -> let (O (Subword (_:.k'))) = getIdx s+                     k = k'-dj-1+                 in  ElmChr (f xs k) (O $ subword (k'-1) k') (getOmx s) s)+    $ mkStream ls (OStatic (di:.dj+1)) u ij+  mkStream (ls :!: Chr f xs) (ORightOf (di:.dj)) u ij+    = map (\s -> let (O (Subword (_:.k'))) = getIdx s+                     k = k'-dj-1+                 in  ElmChr (f xs k) (O $ subword (k'-1) k') (getOmx s) s)+    $ mkStream ls (ORightOf (di:.dj+1)) u ij+  mkStream (ls :!: Chr f xs) (OFirstLeft (di:.dj)) u ij+    = id+    $ map (\s -> let (O (Subword (_:.k))) = getIdx s+                 in  ElmChr (f xs k) (O $ subword k (k+1)) (getOmx s) s)+    $ mkStream ls (OFirstLeft (di+1:.dj)) u ij+  mkStream (ls :!: Chr f xs) (OLeftOf (di:.dj)) u ij+    = map (\s -> let (O (Subword (_:.k))) = getIdx s+                 in  ElmChr (f xs k) (O $ subword k (k+1)) (getOmx s) s)+    $ mkStream ls (OLeftOf (di+1:.dj)) u ij+  {-# Inline mkStream #-}+
+ ADP/Fusion/Term/Chr/Type.hs view
@@ -0,0 +1,57 @@++module ADP.Fusion.Term.Chr.Type where++import           Data.Strict.Tuple+import qualified Data.Vector.Generic as VG++import           Data.PrimitiveArray++import           ADP.Fusion.Base+++-- | A generic Character parser that reads a single character but allows+-- passing additional information.+--+--  'Chr' expects a function to retrieve @r@ at index position, followed by+--  the actual generic vector with data.++data Chr r x where+  Chr :: VG.Vector v x+      => !(v x -> Int -> r)+      -> !(v x)+      -> Chr r x++-- | smart constructor for regular 1-character parsers++--chr xs = Chr VG.unsafeIndex xs+chr xs = Chr (VG.unsafeIndex) xs+--chr xs = Chr (VG.!) xs+{-# Inline chr #-}++-- | Smart constructor for Maybe Peeking, followed by a character.++chrLeft xs = Chr f xs where+  f xs k = ( xs VG.!? (k-1)+           , VG.unsafeIndex xs k+           )+  {-# Inline [0] f #-}+{-# Inline chrLeft #-}++instance Build (Chr r x)++instance+  ( Element ls i+  ) => Element (ls :!: Chr r x) i where+    data Elm (ls :!: Chr r x) i = ElmChr !r !i !i !(Elm ls i)+    type Arg (ls :!: Chr r x)   = Arg ls :. r+    getArg (ElmChr x _ _ ls) = getArg ls :. x+    getIdx (ElmChr _ i _ _ ) = i+    getOmx (ElmChr _ _ o _ ) = o+    {-# Inline getArg #-}+    {-# Inline getIdx #-}+    {-# Inline getOmx #-}++deriving instance (Show i, Show r, Show (Elm ls i)) => Show (Elm (ls :!: Chr r x) i)++type instance TermArg (TermSymbol a (Chr r x)) = TermArg a :. r+
+ ADP/Fusion/Term/Deletion.hs view
@@ -0,0 +1,76 @@++module ADP.Fusion.Term.Deletion+  ( module ADP.Fusion.Term.Deletion.Type+  , module ADP.Fusion.Term.Deletion.Point+  ) where++import ADP.Fusion.Term.Deletion.Point+import ADP.Fusion.Term.Deletion.Type+++{-+import           Data.Strict.Maybe+import           Data.Strict.Tuple+import           Prelude hiding (Maybe(..))+import qualified Data.Vector.Fusion.Stream.Monadic as S++import           Data.PrimitiveArray -- (Z(..), (:.)(..), Subword(..), subword, PointL(..), pointL, PointR(..), pointR)++import           ADP.Fusion.Term.Classes+import           ADP.Fusion.Term.Multi.Classes+++++none = None+{-# INLINE none #-}++-- | Since 'None' doesn't really do anything for all indices, we just thread it+-- through.++instance TermStaticVar None ix where+  termStaticVar   _ sv _  = sv+  termStreamIndex _ _  ij = ij+  {-# INLINE termStaticVar #-}+  {-# INLINE termStreamIndex #-}++instance+  ( Monad m+  , TerminalStream m a is+  ) => TerminalStream m (TermSymbol a None) (is:.PointL) where+  terminalStream (a:|None) (sv:._) (is:._)+    = S.map (\(Qd s (z:.i) is e) -> Qd s z (is:.i) (e:.()))+    . terminalStream a sv is+    . S.map moveIdxTr+  {-# INLINE terminalStream #-}++++-- * Single dimensional instances for 'None' are really weird++{-+instance Element ls Subword => Element (ls :!: None) Subword where+  data Elm (ls :!: None) Subword = ElmNone !Subword !(Elm ls Subword)+  type Arg (ls :!: None)         = Arg ls :. ()+  getArg (ElmNone _ l) = getArg l :. ()+  getIdx (ElmNone i _) = i+  {-# INLINE getArg #-}+  {-# INLINE getIdx #-}+-}++-- | The instance does nothing (except insert @()@ into the argument+-- stack).++{-+instance+  ( Monad m+  , MkStream m ls Subword+  ) => MkStream m (ls :!: None) Subword where+  mkStream (ls :!: None) sv lu ij+    = S.map (ElmNone ij)+    $ mkStream ls sv lu ij+  {-# INLINE mkStream #-}+-}++-}+
+ ADP/Fusion/Term/Deletion/Point.hs view
@@ -0,0 +1,62 @@++module ADP.Fusion.Term.Deletion.Point where++import           Data.Strict.Tuple+import qualified Data.Vector.Fusion.Stream.Monadic as S++import           Data.PrimitiveArray++import           ADP.Fusion.Base+import           ADP.Fusion.Term.Deletion.Type++++instance+  ( Monad m+  , MkStream m ls PointL+  ) => MkStream m (ls :!: Deletion) PointL where+  mkStream (ls :!: Deletion) (IStatic d) (PointL u) (PointL i)+    = S.map (ElmDeletion (PointL i) (PointL 0))+    $ mkStream ls (IStatic d) (PointL u) (PointL i)+  {-# Inline mkStream #-}++instance+  ( Monad m+  , Element ls (Outside PointL)+  , MkStream m ls (Outside PointL)+  ) => MkStream m (ls :!: Deletion) (Outside PointL) where+  mkStream (ls :!: Deletion) (OStatic d) (O (PointL u)) (O (PointL i))+    = S.map (\z -> ElmDeletion (O $ PointL i) (getOmx z) z)+    $ mkStream ls (OStatic d) (O $ PointL u) (O $ PointL i)+  {-# Inline mkStream #-}++instance TermStaticVar Deletion PointL where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ (PointL j) = PointL j+  {-# Inline termStaticVar #-}+  {-# Inline termStreamIndex #-}++instance TermStaticVar Deletion (Outside PointL) where+  termStaticVar   _ (OStatic d) _ = OStatic d+  termStreamIndex _ _           j = j+  {-# Inline termStaticVar #-}+  {-# Inline termStreamIndex #-}++instance+  ( Monad m+  , TerminalStream m a is+  ) => TerminalStream m (TermSymbol a Deletion) (is:.PointL) where+  terminalStream (a:|Deletion) (sv:.IStatic _) (is:.i@(PointL j))+    = S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.PointL j) (os:.PointL 0) (e:.()))+    . iPackTerminalStream a sv (is:.i)+  {-# Inline terminalStream #-}++instance+  ( Monad m+  , TerminalStream m a (Outside is)+  ) => TerminalStream m (TermSymbol a Deletion) (Outside (is:.PointL)) where+  terminalStream (a:|Deletion) (sv:.OStatic d) (O (is:.i))+    = S.map (\(S6 s (zi:._) (zo:.PointL k) (O is) (O os) e) -> S6 s zi zo (O (is:.(PointL $ k-d))) (O (os:.PointL k)) (e:.()))+    . oPackTerminalStream a sv (O (is:.i))+  {-# Inline terminalStream #-}+
+ ADP/Fusion/Term/Deletion/Type.hs view
@@ -0,0 +1,27 @@++module ADP.Fusion.Term.Deletion.Type where++import Data.Strict.Tuple++import Data.PrimitiveArray++import ADP.Fusion.Base++++data Deletion = Deletion++instance Build Deletion++instance (Element ls i) => Element (ls :!: Deletion) i where+  data Elm (ls :!: Deletion) i = ElmDeletion !i !i !(Elm ls i)+  type Arg (ls :!: Deletion)   = Arg ls :. ()+  getArg (ElmDeletion _ _ l) = getArg l :. ()+  getIdx (ElmDeletion i _ _) = i+  getOmx (ElmDeletion _ o _) = o+  {-# Inline getArg #-}+  {-# Inline getIdx #-}+  {-# Inline getOmx #-}++type instance TermArg (TermSymbol a Deletion) = TermArg a :. ()+
+ ADP/Fusion/Term/Edge.hs view
@@ -0,0 +1,64 @@++module ADP.Fusion.Term.Edge+  ( module ADP.Fusion.Term.Edge.Type+  , module ADP.Fusion.Term.Edge.Set+  ) where++import ADP.Fusion.Term.Edge.Set+import ADP.Fusion.Term.Edge.Type++++{-+-- | An edge terminal returns the pair of indices forming the edge.++data Edge e where+  Edge  :: !(Int -> Int -> e) -> Edge e++edge = (,)+{-# Inline edge #-}++instance Build (Edge i)++instance+  (Element ls i+  ) => Element (ls :!: Edge e) i where+    data Elm (ls :!: Edge e) i = ElmEdge !e !i !(Elm ls i)+    type Arg (ls :!: Edge e)   = Arg ls :. e+    getArg (ElmEdge e _ ls) = getArg ls :. e+    getIdx (ElmEdge _ i _ ) = i+    {-# Inline getArg #-}+    {-# Inline getIdx #-}++instance+  ( Monad m+  , Element ls (BitSet:>Interface First:>Interface Last)+  , MkStream m ls (BitSet:>Interface First:>Interface Last)+  ) => MkStream m (ls :!: Edge e) (BitSet:>Interface First:>Interface Last) where+    -- encodes in the first index arg, what the previously set @Last@ was+    mkStream (ls :!: Edge f) Static s@(BitSet zb:>Interface zi:>Interface zj) (BitSet b:>Interface i:>Interface j)+      -- if we have @popCount b == 1@, then this is an initial node,+      -- creating the first node. Otherwise the edge just extends an+      -- existing node.+      -- TODO need to figure out this "first node" stuff here+      = S.map (\z -> let (BitSet zb:>_:>Interface zj) = getIdx z+                     in  ElmEdge (f zj j) (BitSet b:>Interface i:>Interface j) z+              )+      $ mkStream ls (Variable Check (Just (popCount b -1) )) s (BitSet (clearBit b j):>Interface i:>Interface j)+    -- in the variable case, the @Last@ point is unset and may move freely.+    -- @First@ is still fixed. In @k@, we have the number of bits from+    -- @BitSet b@ that we should set! The bit we set is also the @Last@+    -- interface bit.+    mkStream (ls :!: Edge f) (Variable Check (Just k)) s@(BitSet zb:>Interface zi:>Interface zj) c@(BitSet b:>Interface i:>_)+      = S.flatten mk step Unknown+      $ mkStream ls (Variable Check (Just $ k-1)) s c+      where mk z = let (BitSet z':>_:>_) = getIdx z ; a = b `xor` z' in return (z,a,lsbActive a)+            step (z,a,lsbA)+              | lsbA < 0  = return $ S.Done+              | otherwise = return $ S.Yield (ElmEdge (f cj lsbA) (BitSet (cs .|. bit lsbA):>Interface ci:>Interface lsbA) z) (z,a,nextActive lsbA a)+              where (BitSet cs:>Interface ci:>Interface cj) = getIdx z+            {-# Inline [0] mk   #-}+            {-# Inline [0] step #-}+    {-# Inline mkStream #-}+-}+
+ ADP/Fusion/Term/Edge/Set.hs view
@@ -0,0 +1,73 @@++module ADP.Fusion.Term.Edge.Set where++import Data.Bits+import Data.Strict.Tuple+import Data.Vector.Fusion.Stream.Monadic+import Data.Vector.Fusion.Stream.Size+import Debug.Trace+import Prelude hiding (map)++import Data.PrimitiveArray hiding (map)+import Data.Bits.Ordered++import ADP.Fusion.Base+import ADP.Fusion.Term.Edge.Type++++instance+  ( Monad m+  , Element    ls (BS2I First Last)+  , MkStream m ls (BS2I First Last)+  ) => MkStream m (ls :!: Edge e) (BS2I First Last) where+  mkStream (ls :!: Edge f) (IStatic rp) u sij@(s:>i:>j)+    = flatten mk step Unknown $ mkStream ls (IStatic rpn) u tik+    where rpn | j >= 0    = rp+              | otherwise = rp+1+          tik | j >= 0    = s `clearBit` (getIter j) :> i :> undefi+              | otherwise = sij+          mk z+            | j >= 0 && popCount s >= 2 = return $ This z+            | j <  0 && popCount s >= 2 = return $ That (z,bits,maybeLsb bits)+            | popCount s <= max 1 rp    = return $ Naught+            | otherwise                 = error $ show ("Edge",s,i,j)+            where (zs:>_:>zk) = getIdx z+                  bits        = s `xor` zs+          step Naught   = return Done+          step (This z)+            | popCount zs == 0 = return $ Done+            | otherwise = return $ Yield (ElmEdge (f (getIter zk) (getIter j)) sij undefbs2i z) Naught+            where (zs:>_:>zk) = getIdx z+          step (That (z,bits,Nothing)) = return $ Done+          step (That (z,bits,Just j')) = let (zs:>_:>Iter zk) = getIdx z+                                             tij'            = (zs .|. bit j') :> Iter zk :> Iter j'+                                         in  return $ Yield (ElmEdge (f zk j') tij' undefbs2i z) (That (z,bits,maybeNextActive j' bits))+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  {-# Inline mkStream #-}++++instance+  ( Monad m+  , Element ls    (Outside (BS2I First Last))+  , MkStream m ls (Outside (BS2I First Last))+  ) => MkStream m (ls :!: Edge f) (Outside (BS2I First Last)) where+  mkStream (ls :!: Edge f) (OStatic ()) u sij+    = map undefined+    $ mkStream ls (undefined) u sij+  {-# Inline mkStream #-}++++instance+  ( Monad m+  , Element ls    (Complement (BS2I First Last))+  , MkStream m ls (Complement (BS2I First Last))+  ) => MkStream m (ls :!: Edge f) (Complement (BS2I First Last)) where+  mkStream (ls :!: Edge f) Complemented u sij+    = map undefined+    $ mkStream ls Complemented u sij+  {-# Inline mkStream #-}+
+ ADP/Fusion/Term/Edge/Type.hs view
@@ -0,0 +1,32 @@++module ADP.Fusion.Term.Edge.Type where++import Data.Strict.Tuple++import Data.PrimitiveArray++import ADP.Fusion.Base++++data Edge e where+  Edge :: (Int -> Int -> e) -> Edge e++instance Build (Edge e)++instance+  ( Element ls i+  ) => Element (ls :!: Edge e) i where+    data Elm (ls :!: Edge e) i = ElmEdge !e !i !i (Elm ls i)+    type Arg (ls :!: Edge e)   = Arg ls :. e+    getArg (ElmEdge e _ _ ls) = getArg ls :. e+    getIdx (ElmEdge _ i _ _ ) = i+    getOmx (ElmEdge _ _ o _ ) = o+    {-# Inline getArg #-}+    {-# Inline getIdx #-}+    {-# Inline getOmx #-}++deriving instance (Show i, Show e, Show (Elm ls i)) => Show (Elm (ls :!: Edge e) i)++type instance TermArg (TermSymbol a (Edge e)) = TermArg a :. e+
+ ADP/Fusion/Term/Epsilon.hs view
@@ -0,0 +1,116 @@++module ADP.Fusion.Term.Epsilon+  ( module ADP.Fusion.Term.Epsilon.Type+  , module ADP.Fusion.Term.Epsilon.Point+  , module ADP.Fusion.Term.Epsilon.Subword+  ) where++import ADP.Fusion.Term.Epsilon.Point+import ADP.Fusion.Term.Epsilon.Subword+import ADP.Fusion.Term.Epsilon.Type++{-++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- | The 'Empty' terminal symbol parses only the empty (sub-)input. @Empty@+-- however, can mean different things.+--+-- 'Empty' needs to be bound to the input. We require this as certain index+-- structures have no natural notion of emptyness -- unless additional+-- information is given.+--+-- Consider, for example, linear grammars. Left-linear grammars can compare the+-- index @i@ to zero, @i==0@ to test for emptyness, while for right-linear+-- grammars, we need to test @i==N@ with @N@ the size of the input. Instead of+-- carrying @N@ around in the index, we bind the input to @Empty@.+--+-- This choice is currently a bit of a "hunch" but we do have algorithms in+-- mind, where this could be useful.++module ADP.Fusion.Term.Empty where++import           Data.Strict.Maybe+import           Prelude hiding (Maybe(..))++import           Data.PrimitiveArray -- (Z(..), (:.)(..), Subword(..), subword, PointL(..), pointL, PointR(..), pointR, Outside(..))++import           ADP.Fusion.Term.Classes+import           ADP.Fusion.Term.Multi.Classes++import           Debug.Trace++++-- | Empty as an argument only makes sense if empty is static. We don't get to+-- use 'staticCheck' as the underlying check for the bottom of the argument+-- stack should take care of the @i==j@ check.++{-+instance+  ( Monad m+  , MkStream m ls Subword+  ) => MkStream m (ls :!: Empty) Subword where+  mkStream (ls :!: Empty) Static lu (Subword (i:.j))+    = S.map (ElmEmpty (subword i j))+    $ mkStream ls Static lu (subword i j)+  mkStream _ _ _ _ = error "mkStream Empty/Subword called with illegal parameters"+  {-# INLINE mkStream #-}++instance+  ( Monad m+  , MkStream m ls (Outside Subword)+  ) => MkStream m (ls :!: Empty) (Outside Subword) where+  mkStream (ls :!: Empty) Static lu (O (Subword (i:.j)))+    = S.map (ElmEmpty (O $ subword i j))+    $ mkStream ls Static lu (O $ subword i j)+  mkStream _ _ _ _ = error "mkStream Empty/Subword called with illegal parameters"+  {-# INLINE mkStream #-}+-}++type instance TermArg (TermSymbol a Empty) = TermArg a :. ()++instance TermStaticVar Empty PointL where+  termStaticVar   _ sv _  = sv+  termStreamIndex _ _  ij = ij+  {-# INLINE termStaticVar #-}+  {-# INLINE termStreamIndex #-}++{-+instance TermStaticVar Empty Subword where+    termStaticVar = error "write me"+    termStreamIndex = error "write me"+-}++-- | Again, we assume that no 'staticCheck' is necessary and that @i==j@ is+-- true.++instance+  ( Monad m+  , TerminalStream m a is+  ) => TerminalStream m (TermSymbol a Empty) (is:.PointL) where+  terminalStream (a:|Empty) (sv:.Static) (is:.PointL (i:.j))+    = S.map (\(Qd s (z:.i) is e) -> Qd s z (is:.i) (e:.()))+    . terminalStream a sv is+    . S.map moveIdxTr+  terminalStream _ _ _ = error "mkStream Empty/(is:.PointL) called with illegal parameters"+  {-# INLINE terminalStream #-}++{-+instance+    ( Monad m+    , TerminalStream m a is+    ) => TerminalStream m (TermSymbol a Empty) (is:.Subword) where+      terminalStream (a:>Empty) (sv:.Static) (is:.Subword (i:.j))+        = S.map (\(Qd s (z:.i) is e) -> Qd s z (is:.i) (e:.()))+        . terminalStream a sv is+        . S.map moveIdxTr+      terminalStream _ _ _ = error "mkStream Empty/(is:.Subword) called with illegal parameters"+      {-# INLINE terminalStream #-}+-}++-}+
+ ADP/Fusion/Term/Epsilon/Point.hs view
@@ -0,0 +1,62 @@++module ADP.Fusion.Term.Epsilon.Point where++import           Data.Strict.Tuple+import qualified Data.Vector.Fusion.Stream.Monadic as S++import           Data.PrimitiveArray++import           ADP.Fusion.Base+import           ADP.Fusion.Term.Epsilon.Type++++instance+  ( Monad m+  , MkStream m ls PointL+  ) => MkStream m (ls :!: Epsilon) PointL where+  mkStream (ls :!: Epsilon) (IStatic d) (PointL u) (PointL i)+    = S.map (ElmEpsilon (PointL i) (PointL 0))+    $ mkStream ls (IStatic d) (PointL u) (PointL i)+  {-# Inline mkStream #-}++instance+  ( Monad m+  , Element ls (Outside PointL)+  , MkStream m ls (Outside PointL)+  ) => MkStream m (ls :!: Epsilon) (Outside PointL) where+  mkStream (ls :!: Epsilon) (OStatic d) (O (PointL u)) (O (PointL i))+    = S.map (\z -> ElmEpsilon (O $ PointL i) (getOmx z) z)+    $ mkStream ls (OStatic d) (O $ PointL u) (O $ PointL i)+  {-# Inline mkStream #-}++instance TermStaticVar Epsilon PointL where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ (PointL j) = PointL j+  {-# Inline termStaticVar #-}+  {-# Inline termStreamIndex #-}++instance TermStaticVar Epsilon (Outside PointL) where+  termStaticVar   _ (OStatic d) _ = OStatic d+  termStreamIndex _ _           j = j+  {-# Inline termStaticVar #-}+  {-# Inline termStreamIndex #-}++instance+  ( Monad m+  , TerminalStream m a is+  ) => TerminalStream m (TermSymbol a Epsilon) (is:.PointL) where+  terminalStream (a:|Epsilon) (sv:.IStatic _) (is:.i@(PointL j))+    = S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.PointL j) (os:.PointL 0) (e:.()))+    . iPackTerminalStream a sv (is:.i)+  {-# Inline terminalStream #-}++instance+  ( Monad m+  , TerminalStream m a (Outside is)+  ) => TerminalStream m (TermSymbol a Epsilon) (Outside (is:.PointL)) where+  terminalStream (a:|Epsilon) (sv:.OStatic d) (O (is:.i))+    = S.map (\(S6 s (zi:._) (zo:.PointL k) (O is) (O os) e) -> S6 s zi zo (O (is:.(PointL $ k-d))) (O (os:.PointL k)) (e:.()))+    . oPackTerminalStream a sv (O (is:.i))+  {-# Inline terminalStream #-}+
+ ADP/Fusion/Term/Epsilon/Subword.hs view
@@ -0,0 +1,37 @@++module ADP.Fusion.Term.Epsilon.Subword where++import Data.Strict.Tuple+import Data.Vector.Fusion.Stream.Monadic as S+import Prelude hiding (map)++import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Base+import ADP.Fusion.Term.Epsilon.Type++--import Data.Vector.Fusion.Util++++instance+  ( Monad m+  , MkStream m ls Subword+  ) => MkStream m (ls :!: Epsilon) Subword where+  mkStream (ls :!: Epsilon) (IStatic ()) hh ij@(Subword (i:.j))+    = staticCheck (i==j)+    $ map (ElmEpsilon (subword i j) (subword 0 0))+    $ mkStream ls (IStatic ()) hh ij+  {-# Inline mkStream #-}++++instance+  ( Monad m+  , MkStream m ls (Outside Subword)+  ) => MkStream m (ls :!: Epsilon) (Outside Subword) where+  mkStream (ls :!: Epsilon) (OStatic d) u ij@(O (Subword (i:.j)))+    = map (ElmEpsilon (O $ subword i j) (O $ subword i j))+    $ mkStream ls (OStatic d) u ij+  {-# Inline mkStream #-}+
+ ADP/Fusion/Term/Epsilon/Type.hs view
@@ -0,0 +1,27 @@++module ADP.Fusion.Term.Epsilon.Type where++import Data.Strict.Tuple++import Data.PrimitiveArray++import ADP.Fusion.Base++++data Epsilon = Epsilon++instance Build Epsilon++instance (Element ls i) => Element (ls :!: Epsilon) i where+  data Elm (ls :!: Epsilon) i = ElmEpsilon !i !i !(Elm ls i)+  type Arg (ls :!: Epsilon)   = Arg ls :. ()+  getArg (ElmEpsilon _ _ l) = getArg l :. ()+  getIdx (ElmEpsilon i _ _) = i+  getOmx (ElmEpsilon _ o _) = o+  {-# Inline getArg #-}+  {-# Inline getIdx #-}+  {-# Inline getOmx #-}++type instance TermArg (TermSymbol a Epsilon) = TermArg a :. ()+
+ ADP/Fusion/Term/PeekIndex/Subword.hs view
@@ -0,0 +1,24 @@++module ADP.Fusion.Term.PeekIndex.Subword where++import Data.Strict.Tuple+import Data.Vector.Fusion.Stream.Monadic (map)+import Prelude hiding (map)++import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Base+import ADP.Fusion.Term.PeekIndex.Type++++instance+  ( Monad m+  , Element ls (Complement Subword)+  , MkStream m ls (Complement Subword)+  ) => MkStream m (ls :!: PeekIndex (Complement Subword)) (Complement Subword) where+  mkStream (ls :!: PeekIndex) Complemented h ij+    = map (\s -> ElmPeekIndex (getIdx s) (getOmx s) s)+    $ mkStream ls Complemented h ij+  {-# Inline mkStream #-}+
+ ADP/Fusion/Term/PeekIndex/Type.hs view
@@ -0,0 +1,31 @@++module ADP.Fusion.Term.PeekIndex.Type where++import Data.Strict.Tuple++import Data.PrimitiveArray++import ADP.Fusion.Base++++data PeekIndex i = PeekIndex++instance Build (PeekIndex i)++instance+  ( Element ls i+  ) => Element (ls :!: PeekIndex i) i where+    data Elm (ls :!: PeekIndex i) i = ElmPeekIndex !i !i !(Elm ls i)+    type Arg (ls :!: PeekIndex i)   = Arg ls :. (i :. i)+    getArg (ElmPeekIndex i o ls)    = getArg ls :. (i:.o)+    getIdx (ElmPeekIndex i _ _ )    = i+    getOmx (ElmPeekIndex _ o _ )    = o+    {-# Inline getArg #-}+    {-# Inline getIdx #-}+    {-# Inline getOmx #-}++deriving instance (Show i, Show (Elm ls i)) => Show (Elm (ls :!: PeekIndex i) i)++type instance TermArg (TermSymbol a (PeekIndex i)) = TermArg a :. PeekIndex i+
+ ADP/Fusion/Term/Strng.hs view
@@ -0,0 +1,11 @@++-- | A 'Strng' matches [0..] 'Chr's.++module ADP.Fusion.Term.Strng+  ( module ADP.Fusion.Term.Strng.Type+  , module ADP.Fusion.Term.Strng.Point+  ) where++import ADP.Fusion.Term.Strng.Point+import ADP.Fusion.Term.Strng.Type+
+ ADP/Fusion/Term/Strng/Point.hs view
@@ -0,0 +1,43 @@++module ADP.Fusion.Term.Strng.Point where++import           Data.Strict.Tuple+import           Debug.Trace+import qualified Data.Vector.Fusion.Stream.Monadic as S+import qualified Data.Vector.Generic as VG++import           Data.PrimitiveArray++import           ADP.Fusion.Base+import           ADP.Fusion.Term.Strng.Type++++instance+  ( Monad m+  , Element ls PointL+  , MkStream m ls PointL+  ) => MkStream m (ls :!: Strng v x) PointL where+  mkStream (ls :!: Strng f minL maxL xs) (IStatic d) (PointL u) (PointL i)+    = staticCheck (i - minL >= 0 && i <= u && minL <= maxL)+    $ S.map (\z -> let PointL j = getIdx z in ElmStrng (f j (i-j) xs) (PointL i) (PointL 0) z)+    $ mkStream ls (IVariable $ d + maxL - minL) (PointL u) (PointL $ i - minL)+  mkStream _ _ _ _ = error "mkStream / Strng / PointL / IVariable"+  {-# Inline mkStream #-}++instance TermStaticVar (Strng v x) PointL where+  termStaticVar _ (IStatic   d) _ = IVariable d+  termStaticVar _ (IVariable d) _ = IVariable d+  termStreamIndex (Strng _ minL _ _) (IStatic d) (PointL j) = PointL $ j - minL+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}++instance+  ( Monad m+  , TerminalStream m a is+  ) => TerminalStream m (TermSymbol a (Strng v x)) (is:.PointL) where+  terminalStream (a:|Strng f minL maxL xs) (sv:.IStatic d) (is:.i@(PointL j))+    = S.map (\(S6 s (zi:.PointL pi) (zo:._) is os e) -> S6 s zi zo (is:.i) (os:.PointL 0) (e:.f pi (j-pi) xs))+    . iPackTerminalStream a sv (is:.i)+  {-# Inline terminalStream #-}+
+ ADP/Fusion/Term/Strng/Type.hs view
@@ -0,0 +1,56 @@++module ADP.Fusion.Term.Strng.Type where++import           Data.Strict.Tuple+import qualified Data.Vector.Generic as VG++import           Data.PrimitiveArray++import           ADP.Fusion.Base++++-- | 'Strng' terminals return "strings", i.e. vectors of @Chr@s. They allow+-- the user to specify @[ 0 .. ]@ atoms to be parsed at once. It is+-- possible to both, limit the minimal and maximal number.+--+-- NOTE gadt comments are not parsed by haddock?++data Strng v x where+  Strng :: VG.Vector v x+        => !(Int -> Int -> v x -> v x)  -- @slice@ function+        -> !Int                         -- minimal size+        -> !Int                         -- maximal size (just use s.th. big if you don't want a limit)+        -> !(v x)                       -- the actual vector+        -> Strng v x++manyS :: VG.Vector v x => v x -> Strng v x+manyS = \xs -> Strng VG.unsafeSlice 0 (VG.length xs) xs+{-# Inline manyS #-}++someS :: VG.Vector v x => v x -> Strng v x+someS = \xs -> Strng VG.unsafeSlice 1 (VG.length xs) xs+{-# Inline someS #-}++strng :: VG.Vector v x => Int -> Int -> v x -> Strng v x+strng = \minL maxL xs -> Strng VG.unsafeSlice minL maxL xs+{-# Inline strng #-}++instance Build (Strng v x)++instance+  ( Element ls i+  ) => Element (ls :!: Strng v x) i where+  data Elm (ls :!: Strng v x) i = ElmStrng !(v x) !i !i !(Elm ls i)+  type Arg (ls :!: Strng v x)   = Arg ls :. v x+  getArg (ElmStrng x _ _ ls) = getArg ls :. x+  getIdx (ElmStrng _ i _ _ ) = i+  getOmx (ElmStrng _ _ o _ ) = o+  {-# Inline getArg #-}+  {-# Inline getIdx #-}+  {-# Inline getOmx #-}++deriving instance (Show i, Show (v x), Show (Elm ls i)) => Show (Elm (ls :!: Strng v x) i)++type instance TermArg (TermSymbol a (Strng v x)) = TermArg a :. v x+
ADPfusion.cabal view
@@ -1,24 +1,36 @@ name:           ADPfusion-version:        0.2.1.0-author:         Christian Hoener zu Siederdissen, 2011-2013-copyright:      Christian Hoener zu Siederdissen, 2011-2013-homepage:       http://www.tbi.univie.ac.at/~choener/adpfusion-maintainer:     choener@tbi.univie.ac.at-category:       Algorithms, Data Structures, Bioinformatics+version:        0.4.0.0+author:         Christian Hoener zu Siederdissen, 2011-2015+copyright:      Christian Hoener zu Siederdissen, 2011-2015+homepage:       http://www.bioinf.uni-leipzig.de/Software/gADP/+maintainer:     choener@bioinf.uni-leipzig.de+category:       Algorithms, Data Structures, Bioinformatics, Formal Languages license:        BSD3 license-file:   LICENSE build-type:     Simple stability:      experimental-cabal-version:  >= 1.6.0-synopsis:-                Efficient, high-level dynamic programming.+cabal-version:  >= 1.10.0+tested-with:    GHC == 7.8.4, GHC == 7.10.1+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.                 .-                This library is described in:+                ADPfusion allows writing dynamic programs for single- and+                multi-tape problems. Inputs can be sequences, or sets. And new+                input types can be defined, without having to rewrite this+                library thanks to the open-world assumption of ADPfusion.                 .+                The library provides the machinery for Outside and Ensemble+                algorithms as well. Ensemble algorithms combine Inside and+                Outside calculations.+                .+                The homepage provides a number of tutorial-style examples, with+                linear and context-free grammars over sequence and set inputs.+                .+                Ideas implemented here are described in a couple of papers:+                .                 @                 Christian Hoener zu Siederdissen                 Sneaking Around ConcatMap: Efficient Combinators for Dynamic Programming@@ -26,109 +38,353 @@                 <http://doi.acm.org/10.1145/2364527.2364559> preprint: <http://www.tbi.univie.ac.at/newpapers/pdfs/TBI-p-2012-2.pdf>                 @                 .-                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/>).-                .-                Performance comparison figure:-                <http://www.tbi.univie.ac.at/~choener/adpfusion/gaplike-nussinov-runtime.jpg>-                .-                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.+                @+                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.+                <http://dl.acm.org/citation.cfm?doid=2543728.2543736>+                @                 .+                @+                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.+                <http://ieeexplore.ieee.org/xpl/articleDetails.jsp?arnumber=6819790>+                @                 .+                @+                Christian Höner zu Siederdissen, Sonja J. Prohaska, and Peter F. Stadler.+                Algebraic Dynamic Programming over General Data Structures.+                2015. submitted.+                @                 .-                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>.    Extra-Source-Files:   README.md-  changelog+  changelog.md   +flag examples+  description:  build the examples+  default:      False+  manual:       True++flag llvm+  description:  build using LLVM+  default:      False+  manual:       True++flag debug+  description:  dump intermediate Core files+  default:      False+  manual:       True+++ library-  build-depends:-    base >= 4 && < 5,-    deepseq        >= 1.3     ,-    ghc-prim                  ,-    primitive      >= 0.5     ,-    PrimitiveArray >= 0.5.3   ,-    QuickCheck     >= 2.5     ,-    repa           >= 3.2     ,-    strict         >= 0.3.2   ,-    template-haskell          ,-    transformers              ,-    vector         >= 0.10++  build-depends: base               >= 4.7      && < 4.9+               , bits               == 0.4.*+               , mmorph             == 1.0.*+               , monad-primitive    == 0.1+               , mtl                == 2.*+               , OrderedBits        == 0.0.0.*+               , primitive          >= 0.5.4    && < 0.7+               , PrimitiveArray     == 0.6.0.*+               , QuickCheck         >= 2.7      && < 2.9+               , strict             == 0.3.*+               , template-haskell   == 2.*+               , transformers       >= 0.3      && < 0.5+               , tuple              == 0.3.*+               , vector             == 0.10.*+   exposed-modules:     ADP.Fusion     ADP.Fusion.Apply-    ADP.Fusion.Chr-    ADP.Fusion.Classes-    ADP.Fusion.Empty-    ADP.Fusion.Examples.Palindrome-    ADP.Fusion.Multi-    ADP.Fusion.Multi.Classes-    ADP.Fusion.Multi.Empty-    ADP.Fusion.Multi.GChr-    ADP.Fusion.Multi.None-    ADP.Fusion.None-    ADP.Fusion.QuickCheck-    ADP.Fusion.Region-    ADP.Fusion.Table+    ADP.Fusion.Base+    ADP.Fusion.Base.Classes+    ADP.Fusion.Base.Multi+    ADP.Fusion.Base.Point+    ADP.Fusion.Base.Set+    ADP.Fusion.Base.Subword+    ADP.Fusion.Term+    ADP.Fusion.Term.Chr+    ADP.Fusion.Term.Chr.Point+    ADP.Fusion.Term.Chr.Subword+    ADP.Fusion.Term.Chr.Type+    ADP.Fusion.Term.Edge+    ADP.Fusion.Term.Edge.Set+    ADP.Fusion.Term.Edge.Type+    ADP.Fusion.Term.Epsilon+    ADP.Fusion.Term.Epsilon.Point+    ADP.Fusion.Term.Epsilon.Subword+    ADP.Fusion.Term.Epsilon.Type+    ADP.Fusion.Term.Deletion+    ADP.Fusion.Term.Deletion.Point+    ADP.Fusion.Term.Deletion.Type+    ADP.Fusion.Term.PeekIndex.Subword+    ADP.Fusion.Term.PeekIndex.Type+    ADP.Fusion.Term.Strng+    ADP.Fusion.Term.Strng.Point+    ADP.Fusion.Term.Strng.Type+    ADP.Fusion.SynVar+    ADP.Fusion.SynVar.Array+    ADP.Fusion.SynVar.Array.Point+    ADP.Fusion.SynVar.Array.Set+    ADP.Fusion.SynVar.Array.Subword+    ADP.Fusion.SynVar.Array.Type+    ADP.Fusion.SynVar.Axiom+    ADP.Fusion.SynVar.Backtrack+    ADP.Fusion.SynVar.Fill+    ADP.Fusion.SynVar.Indices+    ADP.Fusion.SynVar.Recursive+    ADP.Fusion.SynVar.Recursive.Point+    ADP.Fusion.SynVar.Recursive.Subword+    ADP.Fusion.SynVar.Recursive.Type     ADP.Fusion.TH+    ADP.Fusion.TH.Backtrack+    ADP.Fusion.TH.Common+    ADP.Fusion.QuickCheck.Common+    ADP.Fusion.QuickCheck.Point+    ADP.Fusion.QuickCheck.Set+    ADP.Fusion.QuickCheck.Subword +  default-extensions: BangPatterns+                    , DefaultSignatures+                    , FlexibleContexts+                    , FlexibleInstances+                    , GADTs+                    , MultiParamTypeClasses+                    , RankNTypes+                    , StandaloneDeriving+                    , TemplateHaskell+                    , TypeFamilies+                    , TypeOperators+                    , TypeSynonymInstances+                    , UndecidableInstances++  default-language:+    Haskell2010   ghc-options:     -O2 -funbox-strict-fields +++-- Very simple two-sequence alignment.+ executable NeedlemanWunsch++  if flag(examples)+    buildable:+      True+    build-depends:  base+                 ,  ADPfusion+                 ,  PrimitiveArray+                 ,  template-haskell+                 ,  vector+  else+    buildable:+      False++  hs-source-dirs:+    src   main-is:-    ADP/Fusion/Examples/TwoDim.hs+    NeedlemanWunsch.hs+  default-language:+    Haskell2010+  default-extensions: BangPatterns+                    , FlexibleContexts+                    , FlexibleInstances+                    , MultiParamTypeClasses+                    , RecordWildCards+                    , TemplateHaskell+                    , TypeFamilies+                    , TypeOperators   ghc-options:-    -Odph+    -O2     -funbox-strict-fields     -funfolding-use-threshold1000     -funfolding-keeness-factor1000-    -fllvm-    -optlo-O3 -optlo-std-compile-opts-    -fllvm-tbaa+  if flag(llvm)+    ghc-options:+      -fllvm+      -optlo-O3 -optlo-std-compile-opts+      -fllvm-tbaa+  if flag(debug)+    ghc-options:+      -ddump-to-file+      -ddump-simpl+      -dsuppress-all++++-- Basic RNA secondary structure folding++executable Nussinov++  if flag(examples)+    buildable:+      True+    build-depends:  base+                 ,  ADPfusion+                 ,  PrimitiveArray+                 ,  template-haskell+                 ,  vector+  else+    buildable:+      False++  hs-source-dirs:+    src+  main-is:+    Nussinov.hs+  default-language:+    Haskell2010+  default-extensions: BangPatterns+                    , FlexibleContexts+                    , FlexibleInstances+                    , MultiParamTypeClasses+                    , RecordWildCards+                    , TemplateHaskell+                    , TypeFamilies+                    , TypeOperators+  ghc-options:+    -O2+    -funbox-strict-fields+    -funfolding-use-threshold1000+    -funfolding-keeness-factor1000+  if flag(llvm)+    ghc-options:+      -fllvm+      -optlo-O3 -optlo-std-compile-opts+      -fllvm-tbaa+  if flag(debug)+    ghc-options:+      -ddump-to-file+      -ddump-simpl+      -dsuppress-all++++-- Basic RNA secondary structure folding with partition function calculations++executable PartNussinov++  if flag(examples)+    buildable:+      True+    build-depends:  base+                 ,  ADPfusion+                 ,  log-domain        == 0.10.*+                 ,  PrimitiveArray+                 ,  template-haskell+                 ,  vector+  else+    buildable:+      False++  hs-source-dirs:+    src+  main-is:+    PartNussinov.hs+  default-language:+    Haskell2010+  default-extensions: BangPatterns+                    , FlexibleContexts+                    , FlexibleInstances+                    , MultiParamTypeClasses+                    , RecordWildCards+                    , TemplateHaskell+                    , TypeFamilies+                    , TypeOperators+  ghc-options:+    -O2+    -funbox-strict-fields+    -funfolding-use-threshold1000+    -funfolding-keeness-factor1000+  if flag(llvm)+    ghc-options:+      -fllvm+      -optlo-O3 -optlo-std-compile-opts+      -fllvm-tbaa+  if flag(debug)+    ghc-options:+      -ddump-to-file+      -ddump-simpl+      -dsuppress-all++++executable Durbin++  if flag(examples)+    buildable:+      True+    build-depends:  base+                 ,  ADPfusion+                 ,  PrimitiveArray+                 ,  template-haskell+                 ,  vector+  else+    buildable:+      False++  hs-source-dirs:+    src+  main-is:+    Durbin.hs+  default-language:+    Haskell2010+  default-extensions: BangPatterns+                    , FlexibleContexts+                    , FlexibleInstances+                    , MultiParamTypeClasses+                    , RecordWildCards+                    , TemplateHaskell+                    , TypeFamilies+                    , TypeOperators+  ghc-options:+    -O2+    -fcpr-off+    -funbox-strict-fields+    -funfolding-use-threshold1000+    -funfolding-keeness-factor1000+  if flag(llvm)+    ghc-options:+      -fllvm+      -optlo-O3 -optlo-std-compile-opts+      -fllvm-tbaa+  if flag(debug)+    ghc-options:+      -ddump-to-file+      -ddump-simpl+      -dsuppress-all++++test-suite properties+  type:+    exitcode-stdio-1.0+  main-is:+    properties.hs+  ghc-options:+    -threaded -rtsopts -with-rtsopts=-N+  hs-source-dirs:+    tests+  default-language:+    Haskell2010+  default-extensions: TemplateHaskell+  build-depends: base+               , ADPfusion+               , QuickCheck+               , test-framework               >= 0.8  && < 0.9+               , test-framework-quickcheck2   >= 0.3  && < 0.4+               , test-framework-th            >= 0.2  && < 0.3++  source-repository head   type: git
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,13 @@+# ADPfusion -ADPfusion-(c) 2012, Christian Hoener zu Siederdissen-University of Vienna, Vienna, Austria-choener@tbi.univie.ac.at-LICENSE: BSD3+[![Build Status](https://travis-ci.org/choener/ADPfusion.svg?branch=master)](https://travis-ci.org/choener/ADPfusion) +[*generalized ADPfusion Homepage*](http://www.bioinf.uni-leipzig.de/Software/gADP/)  -Introduction-============ +# 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.@@ -46,9 +44,9 @@ <http://hackage.haskell.org/package/RNAfold>.  -Installation-============ +# 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).@@ -66,8 +64,7 @@   -Notes-=====+# 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@@ -83,35 +80,25 @@   -VERSION HISTORY-===============+# Implementors Notes -- 0.0.0.3:-  - initial version, together with submitted paper -- 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.+- The general inlining scheme is: (i) mkStream is {-# INLINE mkStream #-},+  inner functions like mk, step, worker functions, and index-modifying+  functions get an {-# INLINE [0] funName #-}. Where there is no function to+  annotate, use delay_inline. -- 0.0.1.0-  - providing just the library. Examples are found in different libraries.+- If you implement a new kind of memoizing table, like the dense Table.Array+  ones, you will have to implement mkStream code. When you hand to the left,+  the (i,j) indices and modify their extend (by, say, having NonEmpty table+  constaints), you have to delay_inline this (until inliner phase 0). Otherwise+  you will break fusion for mkStream. -- 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.+++#### Contact++Christian Hoener zu Siederdissen+choener@bioinf.uni-leipzig.de+Leipzig University, Leipzig, Germany+
− changelog 
@@ -1,4 +0,0 @@-0.2:-      * Streamlined interface: access everything via ADP.Fusion--      * /Multi-tape/ grammars can now be written and are fused
+ changelog.md view
@@ -0,0 +1,31 @@+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/Durbin.hs view
@@ -0,0 +1,122 @@++-- | Nussinovs RNA secondary structure prediction algorithm via basepair+-- maximization. Follow this file from top to bottom for a short tutorial+-- on how to use @ADPfusion@.+--+-- In general the task is the following: We are given a sequence of+-- characters from the alphabet @ACGU@. There are 6 pairing rules (cf.+-- 'pairs'), @A-U@, @C-G@, @G-C@, @G-U@, @U-A@, and @U-G@ can /pair/ with+-- each other. Pairs, denoted by brackets @(@, @)@ may be juxtaposed+-- @().()@ or enclosing @(())@. /Crossing/ pairs are not allowed: @([)]@ is+-- forbidden, with @()@ and @[]@ pairing. Dots @.@ denote unpaired+-- characters.+--+-- As an example, the sequence @CACAAGGAUU@ admits the following+-- dot-bracket string @(.)..((..))@.+--+-- The algorithm below maximizes the number of legal brackets.++module Main where++import           Control.Applicative+import           Control.Monad+import           Control.Monad.ST+import           Data.Char (toUpper,toLower)+import           Data.List+import           Data.Vector.Fusion.Util+import           Language.Haskell.TH+import           Language.Haskell.TH.Syntax+import qualified Data.Vector.Fusion.Stream as S+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Unboxed as VU+import           System.Environment (getArgs)+import           Text.Printf++-- Import PrimitiveArray for low-level tables and automatic table+-- filling.++import           Data.PrimitiveArray as PA++-- High-level ADPfusion stuff.++import           ADP.Fusion++++-- | All grammars require a signature.++data Durbin m c e x r = Durbin+  { nil :: e           -> x+  , lef :: c -> x      -> x+  , rig :: x -> c      -> x+  , pai :: c -> x -> c -> x+  , spl :: x -> x      -> x+  , h   :: SM.Stream m x -> m r+  }++makeAlgebraProduct ''Durbin++bpmax :: Monad m => Durbin m Char () Int Int+bpmax = Durbin+  { nil = \ ()    -> 0+  , lef = \ _  x  -> x+  , rig = \ x  _  -> x+  , pai = \ c x d -> if pairs c d then x+1 else -999999+  , spl = \ x y   -> x+y+  , h   = SM.foldl' max 0+  }+{-# INLINE bpmax #-}++pairs !c !d+  =  c=='A' && d=='U'+  || c=='C' && d=='G'+  || c=='G' && d=='C'+  || c=='G' && d=='U'+  || c=='U' && d=='A'+  || c=='U' && d=='G'+{-# INLINE pairs #-}++pretty :: Monad m => Durbin m Char () String [String]+pretty = Durbin+  { nil = \ ()      -> ""+  , lef = \ _  x    -> "." ++ x+  , rig = \ x  _    -> x ++ "."+  , pai = \ _  x  _ -> "(" ++ x ++ ")"+  , spl = \ x  y    -> x ++ y+  , h   = SM.toList+  }+{-# INLINE pretty #-}++-- grammar :: Durbin m Char () x r -> c' -> t' -> (t', Subword -> m r)+grammar Durbin{..} c t' =+  let t = t'  ( nil <<< Epsilon     |||+                lef <<< c  % t      |||+                rig <<< t  % c      |||+                pai <<< c  % t  % c |||+                spl <<< tt % tt     ... h+              )+      tt = toNonEmpty t+  in (Z:.t)+{-# INLINE grammar #-}++runDurbin :: Int -> String -> (Int,[String])+runDurbin k inp = (d, take k . unId $ axiom b) where+  i = VU.fromList . Prelude.map toUpper $ inp+  n = VU.length i+  !(Z:.t) = mutateTablesDefault+          $ grammar bpmax+              (chr i)+              (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) [])) :: Z:.ITbl Id Unboxed Subword Int+  -- d = let (ITbl _ _ arr _) = t in arr PA.! subword 0 n+  d = iTblArray t PA.! subword 0 n+  !(Z:.b) = grammar (bpmax <|| pretty) (chr i) (toBacktrack t (undefined :: Id a -> Id a))++main = do+  as <- getArgs+  let k = if null as then 1 else read $ head as+  ls <- lines <$> getContents+  forM_ ls $ \l -> do+    putStrLn l+    let (s,xs) = runDurbin k l+    mapM_ (\x -> printf "%s %5d\n" x s) xs+
+ src/NeedlemanWunsch.hs view
@@ -0,0 +1,323 @@++-- | The Needleman-Wunsch global alignment algorithm. This algorithm is+-- extremely simple but provides a good showcase for what ADPfusion offers.+--+-- Follow the code from top to bottom for a tutorial on usage.+--+-- 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 where++import           Control.Applicative+import           Control.Monad+import           Data.Vector.Fusion.Stream.Monadic (Stream (..))+import           Data.Vector.Fusion.Util+import           Debug.Trace+import qualified Control.Arrow as A+import qualified Data.Vector as V+import qualified Data.Vector.Fusion.Stream as S+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Unboxed as VU+import           System.Environment (getArgs)+import           System.IO.Unsafe (unsafePerformIO)+import           Text.Printf++-- @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@ exposes everything necessary for higher-level DP+-- algorithms.++import           ADP.Fusion++++-- | A signature connects the types of all non-terminals and terminals with+-- evaluation (or attribute) functions. In the grammar below, we not only+-- want to create all possible parses of how two strings can be aligned but+-- also evaluate each parse and choose the optimal one based on Bellman's+-- principle of optimality.+--+-- Assume we are in the matrix and want to calculate @x@:+--+-- @+--  -----+--  |d|u|+--  -----+--  |l|x|+--  -----+-- @+--+-- We can arrive from @d@, making a diagonal step, called @step_step@ as we+-- advance by one in both dimensions. This leads to an alignment of two+-- characters, one from each input, at @x@, which is combined with the+-- already calculated alignment at @d@.+--+-- We can also just step in the first dimension @step_loop@, going from @l@+-- to @x@. Which means that the first-dim character does not have+-- a partner, leading to an insert/deletion or in/del. We typically do not+-- care in which of the two dimensions the in/del happens, just that it+-- does.+--+-- The third case is an in/del in the other dimension, giving us+-- @loop_step@ or going from @u@ to @x@.+--+-- Of course, if @x@ happens to be the uppermost, leftmost cell, we have+-- nowhere to come from, so we need to inititialize (or terminate depending+-- on your view point) using the @nil_nil@ case. That one is the base case.+--+-- We also want to know which of the three cases is the best case (coming+-- from @d,l,u@), this requires a "choice" function or @h@.+--+-- We take a close look at the type signatures. @step_step :: x ->+-- (Z:.c:.c) -> x@ tells us that @step_step@ requires the score from the+-- non-terminal, typed @x@ for the alignment up to @d@, then we get the two+-- 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 = a'  ( step_step <<< a % (M:|chr i1:|chr i2)     |||+                step_loop <<< a % (M:|chr i1:|Deletion  ) |||+                loop_step <<< a % (M:|Deletion  :|chr i2) |||+                nil_nil   <<< (M:|Epsilon:|Epsilon)       ... h+              )+  in Z:.a+{-# INLINE grammar #-}++-- | A grammar alone is not enough, we also need to say what a @step_step@+-- means, or what an optimum is. Here, we do exactly that. We create an+-- instance of the 'Signature' from above. Since this is a simple example,+-- we just say that two aligned characters @a@ and @b@ yield a score of+-- @x+1@ (with @x@ the previous alignment score) if the characters are+-- identical. Otherwise we lower the score by 2. In/dels incur a cost of+-- @-1@, meaning that a mismatch is actually the same as two in/dels, one+-- in each dimension. The start of the alignment gives an initial score of+-- 0.+--+-- And the optimal choice, of course, is to start with a default of+-- @-999999@ and find the maximum of that score and the choices we are+-- given.++sScore :: Monad m => Signature m Int Int Char+sScore = Signature+  { step_step = \x (Z:.a:.b) -> if a==b then x+1 else x-2+  , step_loop = \x _         -> x-1+  , loop_step = \x _         -> x-1+  , nil_nil   = const 0+  , h = SM.foldl' max (-999999)+  }+{-# INLINE sScore #-}++-- | 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]])+runNeedlemanWunsch k i1' i2' = (d, take k bs) where+  i1 = VU.fromList i1'+  i2 = VU.fromList i2'+  n1 = VU.length i1+  n2 = VU.length i2+  !(Z:.t) = nwInsideForward i1 i2+  d = unId $ axiom t+  bs = nwInsideBacktrack i1 i2 t+{-# Noinline runNeedlemanWunsch #-}++-- | The forward or table-filling phase. It is possible to inline this code+-- directly into 'runNeedlemanWunsch'. Here, this phase is separated. If+-- you use @ghc-core@ to examine the @GHC Core@ language, you can search+-- for @nwInsideForward@ and check wether the inside code is optimized+-- well. This is normally /not/ required, and only done here, because these+-- algorithms are used to gauge efficiency of the fusion framework as well.+--+-- For your own code, you can write as done here, or in the way of+-- 'runOutsideNeedlemanWunsch'.++nwInsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.ITbl Id Unboxed (Z:.PointL:.PointL) Int+nwInsideForward i1 i2 = {-# SCC "nwInsideForward" #-} mutateTablesDefault $+                          grammar sScore+                          (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.PointL 0:.PointL 0) (Z:.PointL n1:.PointL n2) (-999999) []))+                          i1 i2+  where n1 = VU.length i1+        n2 = VU.length i2+{-# NoInline nwInsideForward #-}++nwInsideBacktrack :: VU.Vector Char -> VU.Vector Char -> ITbl Id Unboxed (Z:.PointL:.PointL) 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+{-# 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]])+runOutsideNeedlemanWunsch k i1' i2' = {-# SCC "runOutside" #-} (d, take k . unId $ axiom b) where -- . S.toList . unId $ axiom b) where -- ,gogo) where+  i1 = VU.fromList i1'+  i2 = VU.fromList i2'+  n1 = VU.length i1+  n2 = VU.length i2+  !(Z:.t) = nwOutsideForward i1 i2+  -- d = let (ITbl _ _ arr _) = t in arr PA.! (O (Z:.PointL 0:.PointL 0))+  d = iTblArray t PA.! (O (Z:.PointL 0:.PointL 0))+  !(Z:.b) = grammar (sScore <|| sPretty) (toBacktrack t (undefined :: Id a -> Id a)) i1 i2+{-# Noinline runOutsideNeedlemanWunsch #-}++-- | Again, to be able to observe performance, we have extracted the+-- outside-table-filling part.++nwOutsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.ITbl Id Unboxed (Outside (Z:.PointL:.PointL)) Int+nwOutsideForward i1 i2 = {-# SCC "nwOutsideForward" #-} mutateTablesDefault $+                           grammar sScore+                           (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (O (Z:.PointL 0:.PointL 0)) (O (Z:.PointL n1:.PointL n2)) (-999999) []))+                           i1 i2+  where n1 = VU.length i1+        n2 = VU.length i2+{-# 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 k (a:b:xs) = {-# SCC "align" #-} do+  putStrLn a+  putStrLn b+  putStrLn ""+  let (sI,rsI) = runNeedlemanWunsch k a b+  let (sO,rsO) = runOutsideNeedlemanWunsch k a b+  forM_ rsI $ \[u,l] -> printf "%s\n%s  %d\n\n" (reverse u) (reverse l) sI+  forM_ rsO $ \[u,l] -> printf "%s\n%s  %d\n\n" (id      u) (id      l) sO+  align k xs++-- | And finally have a minimal main that reads from stdio.+--+-- If you are brave enough then put this through @ghc-core@ and look for+-- @nwInsideForward@ or @nwOutsideForward@ in the CORE. Everything coming+-- from the forward phase should be beautifully optimized and the algorithm+-- should run quite fast.++main = do+  as <- getArgs+  let k = if null as then 1 else read $ head as+  ls <- lines <$> getContents+  align k ls+
+ src/Nussinov.hs view
@@ -0,0 +1,132 @@++-- | Nussinovs RNA secondary structure prediction algorithm via basepair+-- maximization.++module Main where++import           Control.Applicative+import           Control.Monad+import           Control.Monad.ST+import           Data.Char (toUpper,toLower)+import           Data.List as L+import           Data.Vector.Fusion.Util+import           Debug.Trace+import           Language.Haskell.TH+import           Language.Haskell.TH.Syntax+import qualified Data.Vector.Fusion.Stream as S+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Unboxed as VU+import           System.Environment (getArgs)+import           Text.Printf++import           Data.PrimitiveArray as PA++import           ADP.Fusion++++data Nussinov m x r c = Nussinov+  { unp :: x -> c -> x+  , jux :: x -> c -> x -> c -> x+  , nil :: () -> x+  , h   :: SM.Stream m x -> m r+  }++makeAlgebraProduct ''Nussinov++{-+ - due to backtracking schemes, we need a bunch of combintors+ -+ - how to deal with sup-optimal backtracking, without having to use (*||) ?++(<||)   :: Single a -> List b   -> List b         -- co-optimal backtracking+(*||)   :: Vector a -> List b   -> List (a,b)     -- classified co-optimal backtracking+(***)   :: Single a -> Single b -> Vector (a,b)   -- classified DP++-}++bpmax :: Monad m => Nussinov m Int Int Char+bpmax = Nussinov+  { unp = \ x c     -> x+  , jux = \ x c y d -> if c `pairs` d then x + y + 1 else -999999+  , nil = \ ()      -> 0+  , h   = SM.foldl' max (-999999)+  }+{-# INLINE bpmax #-}++prob :: Monad m => Nussinov m Double Double Char+prob = Nussinov+  { unp = \ x c     -> 0.3 * x+  , jux = \ x c y d -> 0.6 * if c `pairs` d then x * y else 0+  , nil = \ ()      -> 0.1+  , h   = SM.foldl' (+) 0+  }++-- |++pairs !c !d+  =  c=='A' && d=='U'+  || c=='C' && d=='G'+  || c=='G' && d=='C'+  || c=='G' && d=='U'+  || c=='U' && d=='A'+  || c=='U' && d=='G'+{-# INLINE pairs #-}++pretty :: Monad m => Nussinov m String [String] Char -- (SM.Stream m String)+pretty = Nussinov+  { unp = \ x c     -> x ++ "."+  , jux = \ x c y d -> x ++ "(" ++ y ++ ")"+  , nil = \ ()      -> ""+  , h   = SM.toList -- return . id+  }+{-# INLINE pretty #-}++prettyL :: Monad m => Nussinov m String String Char+prettyL = Nussinov+  { unp = \ x c     -> x ++ "."+  , jux = \ x c y d -> x ++ "(" ++ y ++ ")"+  , nil = \ ()      -> ""+  , h   = SM.head -- return . id+  }+{-# INLINE prettyL #-}++grammar Nussinov{..} c t' =+  let t = t'  ( unp <<< t % c           |||+                jux <<< t % c % t % c   |||+                nil <<< Epsilon         ... h+              )+  in Z:.t+{-# INLINE grammar #-}++runNussinov :: Int -> String -> (Int,[String])+runNussinov k inp = (d, take k bs) where -- . {- . S.toList . -} unId $ axiom b) where+  i = VU.fromList . Prelude.map toUpper $ inp+  n = VU.length i+  !(Z:.t) = runInsideForward i+  d = unId $ axiom t+  bs = runInsideBacktrack i t+{-# NOINLINE runNussinov #-}++runInsideForward :: VU.Vector Char -> Z:.ITbl Id Unboxed Subword Int+runInsideForward i = mutateTablesDefault+                   $ grammar bpmax+                       (chr i)+                       (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) []))+  where n = VU.length i+{-# NoInline runInsideForward #-}++runInsideBacktrack :: VU.Vector Char -> ITbl Id Unboxed Subword Int -> [String]+runInsideBacktrack i t = unId $ axiom b+  where !(Z:.b) = grammar (bpmax <|| pretty) (chr i) (toBacktrack t (undefined :: Id a -> Id a))+{-# NoInline runInsideBacktrack #-}++main = do+  as <- getArgs+  let k = if null as then 1 else read $ head as+  ls <- lines <$> getContents+  forM_ ls $ \l -> do+    putStrLn l+    let (s,xs) = runNussinov k l+    mapM_ (\x -> printf "%s %5d\n" x s) xs+
+ src/PartNussinov.hs view
@@ -0,0 +1,275 @@++-- | Nussinovs RNA secondary structure prediction algorithm via basepair+-- maximization.++module Main where++import           Control.Applicative+import           Control.Monad+import           Control.Monad.ST+import           Data.Char (toUpper,toLower)+import           Data.List+import           Data.Vector.Fusion.Util+import           Debug.Trace+import           Language.Haskell.TH+import           Language.Haskell.TH.Syntax+import           Numeric.Log as Log+import qualified Data.Vector.Fusion.Stream as S+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Unboxed as VU+import           System.Environment (getArgs)+import           Text.Printf++import           Data.PrimitiveArray as PA++import           ADP.Fusion++++-- * Inside and Outside grammar constructs++data Nussinov m c e x r = Nussinov+  { unp :: x -> c -> x+  , jux :: x -> x -> x+  , pai :: c -> x -> c -> x+  , nil :: e -> x+  , h   :: SM.Stream m x -> m r+  }++makeAlgebraProduct ''Nussinov++bpmax :: Monad m => Nussinov m Char () Int Int+bpmax = Nussinov+  { unp = \ x c   -> x+  , jux = \ x y   -> x + y+  , pai = \ c x d -> if c `pairs` d then x+1 else (-999999)+  , nil = \ ()    -> 0+  , h   = SM.foldl' max (-999999)+  }+{-# INLINE bpmax #-}++prob :: Monad m => Nussinov m Char () (Log Double) (Log Double)+prob = Nussinov+  { unp = \ x c     -> 0.1 * x                                -- 'any'+  , jux = \ x y     -> 0.9 * x * y                            -- 'any'+  , pai = \ c x d   -> 1.0 * if c `pairs` d then x else 0     -- 'paired'+  , nil = \ ()      -> 1.0                                    -- 'any'+  , h   = SM.foldl' (+) 0+  }+{-# Inline prob #-}++-- |++pairs !c !d+  =  c=='A' && d=='U'+  || c=='C' && d=='G'+  || c=='G' && d=='C'+  || c=='G' && d=='U'+  || c=='U' && d=='A'+  || c=='U' && d=='G'+{-# INLINE pairs #-}++pretty :: Monad m => Nussinov m Char () String (SM.Stream m String)+pretty = Nussinov+  { unp = \ x c     -> x ++ "."+  , jux = \ x y     -> x ++ y+  , pai = \ c x d   -> "(" ++ x ++ ")"+  , nil = \ ()      -> ""+  , h   = return . id+  }+{-# INLINE pretty #-}++-- | The inside grammar is:+--+-- @+-- A -> A c+-- A -> A P+-- A -> ε+-- P -> c A c+-- @++-- insideGrammar :: Nussinov m Char () x r -> c' -> t' -> (t', Subword -> m r)+insideGrammar Nussinov{..} c a' p' =+  let a = a'  ( unp <<< a % c     |||+                jux <<< a % p     |||+                nil <<< Epsilon   ... h+              )+      p = p'  ( pai <<< c % a % c ... h+              )+  in Z:.p:.a+{-# INLINE insideGrammar #-}++-- | Given the inside grammar, the outside grammar is:+--+-- @+-- B -> B c+-- B -> B P+-- B -> ε+-- B -> c Q c+-- Q -> A B+-- @++outsideGrammar Nussinov{..} c a p b' q' =+  let b = b'  ( unp <<< b % c         |||+                jux <<< b % p         |||+                pai <<< c % q % c     |||+                nil <<< Epsilon       ... h+              )+      q = q'  ( jux <<< a % b         ... h+              )+  in Z:.b:.q+{-# INLINE outsideGrammar #-}++++-- * Ensemble collection constructs++data NussinovEnsemble m v ci x r = NussinovEnsemble+  { ens :: v -> ci -> v -> x+  , hhh :: SM.Stream m x -> m r+  }++ensemble+  :: Monad m+  => Log Double+  -> NussinovEnsemble+        m+        (Log Double)+        (Complement Subword:.(Complement Subword))+        (Subword, Log Double)+        [(Subword, Log Double)]+ensemble z = NussinovEnsemble+  { ens = \ x (C k:._) y -> ( k , x * y / z )+  , hhh = SM.toList+  }+{-# Inline ensemble #-}++ensembleGrammar NussinovEnsemble{..} i o v' =+  let v = v' ( ens <<< i % (PeekIndex :: PeekIndex (Complement Subword)) % o ... hhh )+  in  Z:.v+{-# Inline ensembleGrammar #-}++-- makeAlgebraProductH ['hhh] ''NussinovEnsemble++++-- * Run different algorithm parts++runNussinov :: String -> ([(Subword, Log Double)], Log Double, [(Int,Int, Log Double, Log Double, Log Double, Log Double)])+runNussinov inp = (es,z,ys) where+  i = VU.fromList . Prelude.map toUpper $ inp+  n = VU.length i+  !(Z:.p:.a) = runInsideForward i+  !(Z:.b:.q) = runOutsideForward i a p+  es = runEnsembleForward z p q+  za = let (ITbl _ _ _ arr _) = a in arr PA.! subword 0 n+  zp = let (ITbl _ _ _ arr _) = p in arr PA.! subword 0 n+  z  = za+  e = let (ITbl _ _ _ arr _) = b in Log.sum [ arr PA.! (O $ subword k k) | k <- [0 .. n] ]+  ys =  [ ( k+          , l+          , fwda PA.! subword k l+          , fwdp PA.! subword k l+          , bwdb PA.! (O $ subword k l)+          , bwdq PA.! (O $ subword k l)+          )+        | let (ITbl _ _ _ fwda _) = a+        , let (ITbl _ _ _ fwdp _) = p+        , let (ITbl _ _ _ bwdb _) = b+        , let (ITbl _ _ _ bwdq _) = q+        , k <- [0 .. n]+        , l <- [k .. n]+        ]+{-# NOINLINE runNussinov #-}++neat :: String -> IO ()+neat i = do let (es,z,ys) = runNussinov i+            forM_ ys $ \ (k,_,_,_,_,_) -> printf " %6d" k+            putStrLn ""+            forM_ ys $ \ (_,l,_,_,_,_) -> printf " %6d" l+            putStrLn ""+            forM_ ys $ \ (_,_,a,_,_,_) -> printf " %0.4f" (exp $ ln a)+            putStrLn ""+            forM_ ys $ \ (_,_,_,p,_,_) -> printf " %0.4f" (exp $ ln p)+            putStrLn ""+            forM_ ys $ \ (_,_,_,_,b,_) -> printf " %0.4f" (exp $ ln b)+            putStrLn ""+            forM_ ys $ \ (_,_,_,_,_,q) -> printf " %0.4f" (exp $ ln q)+            putStrLn ""+            printf "%0.4f\n" $ exp $ ln z+            forM_ ys $ \ (_,_,_,p,_,q) -> printf " %0.4f" ((exp $ ln p) * (exp $ ln q) / (exp $ ln z))+            putStrLn ""+            putStrLn ""+            forM_ es $ \ (Subword (i:.j),v) -> printf "%3d %3d  %0.4f\n" i j (exp $ ln v)+            putStrLn ""++type TblI = ITbl Id Unboxed          Subword  (Log Double)+type TblO = ITbl Id Unboxed (Outside Subword) (Log Double)++runInsideForward :: VU.Vector Char -> Z:.TblI:.TblI+runInsideForward i = mutateTablesDefault+                   $ insideGrammar prob+                       (chr i)+                       (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) 0 []))+                       (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) 0 []))+  where n = VU.length i+{-# NoInline runInsideForward #-}++runOutsideForward :: VU.Vector Char -> TblI -> TblI -> Z:.TblO:.TblO+runOutsideForward i a p = mutateTablesDefault+                        $ outsideGrammar prob+                            (chr i)+                            a p+                            (ITbl 0 0 EmptyOk (PA.fromAssocs (O $ subword 0 0) (O $ subword 0 n) 0 []))+                            (ITbl 0 1 EmptyOk (PA.fromAssocs (O $ subword 0 0) (O $ subword 0 n) 0 []))+  where n = VU.length i+{-# NoInline runOutsideForward #-}++runEnsembleForward :: Log Double -> TblI -> TblO -> [ (Subword,Log Double) ]+runEnsembleForward z i o = unId $ axiom g+  where (Z:.g) = ensembleGrammar (ensemble z)+                   i o+                   (IRec EmptyOk (C l) (C h))+                 :: Z :. IRec Id (Complement Subword) [(Subword, Log Double)]+        (l,h) = let (ITbl _ _ _ arr _) = i in bounds arr+{-# NoInline runEnsembleForward #-}++{-+runPartitionNussinov :: String -> [(Subword,Double,Double,Double)]+runPartitionNussinov inp+  = Data.List.map (\(sh,a) -> let b = iTblArray t PA.! (O sh)+                              in (sh, a, b, a*b/d)+                  ) (PA.assocs $ iTblArray s)+  where+  i = VU.fromList . Prelude.map toUpper $ inp+  n = VU.length i+  s :: ITbl Id Unboxed Subword Double+  !(Z:.s) = mutateTablesDefault+          $ grammar prob+              (chr i)+              (ITbl EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) 0 []))+              +  d = iTblArray s PA.! subword 0 n+  t :: ITbl Id Unboxed (Outside Subword) Double+  !(Z:.t) = mutateTablesDefault+          $ outsideGrammar prob+              (chr i)+              --(undefined :: ITbl Id Unboxed (Outside Subword) Double)+              s+              (ITbl EmptyOk (PA.fromAssocs (O $ subword 0 0) (O $ subword 0 n) (-1) []))+{-# NOINLINE runPartitionNussinov #-}+-}++main :: IO ()+main = do+  return ()+  {-+  as <- getArgs+  let k = if null as then 1 else read $ head as+  ls <- lines <$> getContents+  forM_ ls $ \l -> do+    putStrLn l+    let (s,xs) = runNussinov k l+    mapM_ (\x -> printf "%s %5d\n" x s) xs+  -}+
+ tests/properties.hs view
@@ -0,0 +1,90 @@++-- | Test all properties automatically. We keep the QC2 modules in the main+-- library for now, as this allows for more efficient repl tests.++module Main where++import Test.Framework.Providers.QuickCheck2+import Test.Framework.TH++import qualified ADP.Fusion.QuickCheck.Subword  as QSW+import qualified ADP.Fusion.QuickCheck.Set      as QS+import qualified ADP.Fusion.QuickCheck.Point    as QP+import ADP.Fusion.QuickCheck.Point+++{-+grep -o -e "^prop_[[:alnum:]_]*" ADP/Fusion/QuickCheck/Subword.hs | awk '{print $1"QSW", "=", "QSW."$1 }' | uniq+grep -o -e "^prop_[[:alnum:]_]*" ADP/Fusion/QuickCheck/Set.hs | awk '{print $1"QS", "=", "QS."$1 }' | uniq+grep -o -e "^prop_[[:alnum:]_]*" ADP/Fusion/QuickCheck/Point.hs | awk '{print $1"QP", "=", "QP."$1 }' | uniq+-}++-- subwords++prop_sv_OIQSW = QSW.prop_sv_OI+prop_sv_IOQSW = QSW.prop_sv_IO+prop_sv_OIIQSW = QSW.prop_sv_OII+prop_sv_IOIQSW = QSW.prop_sv_IOI+prop_sv_IIOQSW = QSW.prop_sv_IIO+prop_cOcQSW = QSW.prop_cOc+prop_ccOccQSW = QSW.prop_ccOcc+prop_cOcccQSW = QSW.prop_cOccc+prop_cOcIcQSW = QSW.prop_cOcIc+prop_cIcOcQSW = QSW.prop_cIcOc+prop_EpsilonQSW = QSW.prop_Epsilon++-- sets++prop_b_iiQS = QS.prop_b_ii+prop_b_ii_nnQS = QS.prop_b_ii_nn+prop_b_iiiQS = QS.prop_b_iii+prop_b_iii_nnnQS = QS.prop_b_iii_nnn+prop_bii_iQS = QS.prop_bii_i+prop_bii_i_nQS = QS.prop_bii_i_n+prop_bii_eQS = QS.prop_bii_e+prop_bii_ieQS = QS.prop_bii_ie+prop_bii_ie_nQS = QS.prop_bii_ie_n+prop_bii_ieeQS = QS.prop_bii_iee+prop_bii_ieeeQS = QS.prop_bii_ieee+prop_bii_iee_nQS = QS.prop_bii_iee_n+prop_bii_ieee_nQS = QS.prop_bii_ieee_n++-- points++prop_EpsilonQP = QP.prop_Epsilon+prop_O_EpsilonQP = QP.prop_O_Epsilon+prop_ZEpsilonQP = QP.prop_ZEpsilon+prop_O_ZEpsilonQP = QP.prop_O_ZEpsilon+prop_O_ZEpsilonEpsilonQP = QP.prop_O_ZEpsilonEpsilon+prop_O_ItNCQP = QP.prop_O_ItNC+prop_O_ZItNCQP = QP.prop_O_ZItNC+prop_O_2dimIt_NC_CNQP = QP.prop_O_2dimIt_NC_CN+prop_2dimIt_NC_CNQP = QP.prop_2dimIt_NC_CN+prop_TtQP = QP.prop_Tt+prop_CCQP = QP.prop_CC+prop_ItQP = QP.prop_It+prop_O_ItQP = QP.prop_O_It+prop_ZItQP = QP.prop_ZIt+prop_O_ZItQP = QP.prop_O_ZIt+prop_ItCQP = QP.prop_ItC+prop_O_ItCQP = QP.prop_O_ItC+prop_O_ItCCQP = QP.prop_O_ItCC+prop_O_ZItCCQP = QP.prop_O_ZItCC+prop_2dimItCCQP = QP.prop_2dimItCC+prop_O_2dimItCCQP = QP.prop_O_2dimItCC+prop_ManySQP = QP.prop_ManyS+prop_SomeSQP = QP.prop_SomeS+prop_2dim_ManyS_ManySQP = QP.prop_2dim_ManyS_ManyS+prop_2dim_SomeS_SomeSQP = QP.prop_2dim_SomeS_SomeS+prop_Itbl_ManySQP = QP.prop_Itbl_ManyS+prop_Itbl_SomeSQP = QP.prop_Itbl_SomeS+prop_1dim_Itbl_ManySQP = QP.prop_1dim_Itbl_ManyS+prop_1dim_Itbl_SomeSQP = QP.prop_1dim_Itbl_SomeS+prop_2dim_Itbl_ManyS_ManySQP = QP.prop_2dim_Itbl_ManyS_ManyS+prop_2dim_Itbl_SomeS_SomeSQP = QP.prop_2dim_Itbl_SomeS_SomeS++++main :: IO ()+main = $(defaultMainGenerator)+