packages feed

ADPfusion 0.1.0.0 → 0.2.0.0

raw patch · 25 files changed

+2822/−1767 lines, 25 filesdep +deepseqdep +repadep +strictdep −criteriondep ~PrimitiveArraydep ~QuickCheckdep ~primitivenew-component:exe:NeedlemanWunsch

Dependencies added: deepseq, repa, strict, template-haskell, transformers

Dependencies removed: criterion

Dependency ranges changed: PrimitiveArray, QuickCheck, primitive, vector

Files

ADP/Fusion.hs view
@@ -1,12 +1,122 @@+{-# 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 #-} --- | Pure combinators along the lines of original ADP. We simply re-export the--- monadic interface without the monadic function application combinator.+-- | Generalized fusion system for grammars.+--+-- NOTE Symbols typically do not check bound data for consistency. If you, say,+-- bind a terminal symbol to an input of length 0 and then run your grammar,+-- you probably get errors, garbled data or random crashes. Such checks are+-- done via asserts in non-production code.+--+-- 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-  ( module ADP.Fusion.Monadic-  , module ADP.Fusion.Monadic.Internal+  -- basic combinators+  ( (<<<)+  , (<<#)+  , (|||)+  , (...)+  , (~~)+  , (%)+  -- filters+  , check+  -- parsers+  , chr+  , chrLeft+  , chrRight+  , peekL+  , peekR+  , empty+  , region+  , sregion+--  , Tbl (..)+--  , BtTbl (..)+  , MTbl (..)+  , ENE (..)+  , ENZ (..)+  , None (..)   ) where -import ADP.Fusion.Monadic hiding ((#<<))-import ADP.Fusion.Monadic.Internal (Scalar(..))+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++++-- | Apply a function to symbols on the RHS of a production rule. Builds the+-- stack of symbols from 'xs' using 'build', then hands this stack to+-- 'mkStream' together with the initial 'iniT' telling 'mkStream' that we are+-- in the "outer" position. Once the stream has been created, we 'S.map'+-- 'getArg' to get just the arguments in the stack, and finally 'apply' the+-- function 'f'.++infixl 8 <<<+(<<<) f xs = \ij -> outerCheck (checkValidIndex (build xs) ij) . S.map (apply (inline f) . getArg) . mkStream (build xs) (outer ij) $ ij+{-# INLINE (<<<) #-}++infixl 8 <<#+(<<#) f xs = \ij -> outerCheck (checkValidIndex (build xs) ij) . S.mapM (apply (inline f) . getArg) . mkStream (build xs) (outer ij) $ ij+{-# INLINE (<<#) #-}++-- | Combine two RHSs to give a choice between parses.++infixl 7 |||+(|||) xs ys = \ij -> xs ij S.++ ys ij+{-# INLINE (|||) #-}++-- | Applies the objective function 'h' to a stream 's'. The objective function+-- reduces the stream to a single optimal value (or some vector of co-optimal+-- things).++infixl 5 ...+(...) s h = h . s+{-# INLINE (...) #-}++-- | Additional outer check with user-given check function++infixl 6 `check`+check xs f = \ij -> let chk = f ij in chk `seq` outerCheck chk (xs ij)+{-# INLINE check #-}++-- | Separator between RHS symbols.++infixl 9 ~~+(~~) = (:!:)+{-# INLINE (~~) #-}++-- | This separator looks much paper "on paper" and is not widely used otherwise.++infixl 9 %+(%) = (:!:)+{-# INLINE (%) #-}++++++++
+ ADP/Fusion/Apply.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module ADP.Fusion.Apply where++import Data.Array.Repa.Index++++-- * Apply function 'f' in '(<<<)'++class Apply x where+  type Fun x :: *+  apply :: Fun x -> x++instance Apply (Z:.a -> res) where+  type Fun (Z:.a -> res) = a -> res+  apply fun (Z:.a) = fun a+  {-# INLINE apply #-}++instance Apply (Z:.a:.b -> res) where+  type Fun (Z:.a:.b -> res) = a->b -> res+  apply fun (Z:.a:.b) = fun a b+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c -> res) where+  type Fun (Z:.a:.b:.c -> res) = a->b->c -> res+  apply fun (Z:.a:.b:.c) = fun a b c+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d -> res) where+  type Fun (Z:.a:.b:.c:.d -> res) = a->b->c->d -> res+  apply fun (Z:.a:.b:.c:.d) = fun a b c d+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d:.e -> res) where+  type Fun (Z:.a:.b:.c:.d:.e -> res) = a->b->c->d->e -> res+  apply fun (Z:.a:.b:.c:.d:.e) = fun a b c d e+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d:.e:.f -> res) where+  type Fun (Z:.a:.b:.c:.d:.e:.f -> res) = a->b->c->d->e->f -> res+  apply fun (Z:.a:.b:.c:.d:.e:.f) = fun a b c d e f+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d:.e:.f:.g -> res) where+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g -> res) = a->b->c->d->e->f->g -> res+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g) = fun a b c d e f g+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h -> res) where+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h -> res) = a->b->c->d->e->f->g->h -> res+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h) = fun a b c d e f g h+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) where+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) = a->b->c->d->e->f->g->h->i -> res+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i) = fun a b c d e f g h i+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) where+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) = a->b->c->d->e->f->g->h->i->j -> res+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j) = fun a b c d e f g h i j+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) where+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) = a->b->c->d->e->f->g->h->i->j->k -> res+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k) = fun a b c d e f g h i j k+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) where+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) = a->b->c->d->e->f->g->h->i->j->k->l -> res+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l) = fun a b c d e f g h i j k l+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) where+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m -> res+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m) = fun a b c d e f g h i j k l m+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) where+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n -> res+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n) = fun a b c d e f g h i j k l m n+  {-# INLINE apply #-}++instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) where+  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n->o -> res+  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o) = fun a b c d e f g h i j k l m n o+  {-# INLINE apply #-}+
+ ADP/Fusion/Chr.hs view
@@ -0,0 +1,306 @@+{-# 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 view
@@ -0,0 +1,396 @@+{-# 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 view
@@ -0,0 +1,56 @@+{-# 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 view
@@ -0,0 +1,118 @@+{-# 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 view
@@ -0,0 +1,98 @@+{-# 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/GAPlike.hs 
@@ -1,571 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---- | ------ HINTS for writing your own (Non-) terminals:------ - ALWAYS provide types for local functions of 'mkStream' and--- 'mkStreamInner'. Otherwise stream-fusion gets confused and doesn't optimize.--- (Observable in core by looking for 'Left', 'RIght' constructors and 'SPEC'--- constructors.--module ADP.Fusion.GAPlike where--import Control.Monad.Primitive-import Data.Primitive.Types (Prim(..))-import Data.Vector.Fusion.Stream.Size-import GHC.Prim (Constraint)-import qualified Data.Vector.Fusion.Stream.Monadic as S-import qualified Data.Vector.Unboxed as VU--import Data.PrimitiveArray (PrimArrayOps(..), MPrimArrayOps(..))-import "PrimitiveArray" Data.Array.Repa.Index-import qualified Data.PrimitiveArray as PA-import qualified Data.PrimitiveArray.Zero.Unboxed as ZU------ * The required type classes. Each class does its own thing.---- | The 'Build' class. Combines the arguments into a stack before they are--- turned into a stream.------------ To use, simply write "instance Build MyDataCtor" as we have sensible default--- instances.--class Build x where-  -- | The stack of arguments we are building.-  type BuildStack x :: *-  -- | The default is for the left-most element.-  type BuildStack x = None :. x-  -- | Given an element, create the stack.-  build :: x -> BuildStack x-  -- | Default for the left-most element.-  default build :: (BuildStack x ~ (None :. x)) => x -> BuildStack x-  build x = None :. x-  {-# INLINE build #-}---- | The stream element. Creates a type-level recursive data type containing--- the extracted arguments.--class StreamElement x where-  -- | one element of the stream, recursively defined-  data StreamElm x :: *-  -- | top-most index of the stream -- typically int-  type StreamTopIdx  x :: *-  -- | complete, recursively defined argument of the stream-  type StreamArg  x :: *-  -- | Given a stream element, we extract the top-most idx-  getTopIdx :: StreamElm x -> StreamTopIdx x-  -- | extract the recursively defined argument in a well-defined way for 'apply'-  getArg :: StreamElm x -> StreamArg x---- | Given the arguments, creates a stream of 'StreamElement's.--class (StreamConstraint x) => MkStream m x where-  type StreamConstraint x :: Constraint-  type StreamConstraint x = ()-  mkStream      :: (StreamConstraint x) => x -> (Int,Int) -> S.Stream m (StreamElm x)-  mkStreamInner :: (StreamConstraint x) => x -> (Int,Int) -> S.Stream m (StreamElm x)------ * Terminates the stack of arguments---- | Very simple data ctor--data None = None---- | For CORE-language, we have our own Arg-terminator--data ArgZ = ArgZ--instance StreamElement None where-  data StreamElm None    = SeNone !Int-  type StreamTopIdx None = Int-  type StreamArg    None = ArgZ-  getTopIdx (SeNone k) = k-  getArg _ = ArgZ-  {-# INLINE getTopIdx #-}-  {-# INLINE getArg #-}--instance (Monad m) => MkStream m None where-  mkStream None (i,j) = S.unfoldr step i where-    step k-      | k<=j = Just (SeNone i, j+1)-      | otherwise = Nothing-    {-# INLINE step #-}-  {-# INLINE mkStream #-}-  mkStreamInner = mkStream-  {-# INLINE mkStreamInner #-}------ * A single character terminal. Using unboxed vector to hold the input. Note--- that "character" means parsing a scalar, not that the 'Chr' parser only--- accepts "Char"s.--data Chr e = Chr !(VU.Vector e)--instance Build (Chr e)--instance (StreamElement x) => StreamElement (x:.Chr e) where-  data StreamElm (x:.Chr e) = SeChr !(StreamElm x) !Int !e-  type StreamTopIdx (x:.Chr e) = Int-  type StreamArg (x:.Chr e) = StreamArg x :. e-  getTopIdx (SeChr _ k _) = k-  getArg (SeChr x _ e) = getArg x :. e-  {-# INLINE getTopIdx #-}-  {-# INLINE getArg #-}---- TODO I think, we can rewrite both versions to use S.map instead of S.flatten.--instance (Monad m, MkStream m x, StreamElement x, StreamTopIdx x ~ Int, VU.Unbox e) => MkStream m (x:.Chr e) where-  mkStream (x:.Chr es) (i,j) = S.flatten mk step Unknown $ mkStream x (i,j-1) where-    mk :: StreamElm x -> m (StreamElm x, Int)-    mk x = return (x, getTopIdx x)-    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.Chr e)))-    step (x,k)-      | k+1 == j = return $ S.Yield (SeChr x (k+1) (VU.unsafeIndex es k)) (x,j+1)-      | otherwise = return S.Done-    {-# INLINE mk #-}-    {-# INLINE step #-}-  {-# INLINE mkStream #-}-  mkStreamInner (x:.Chr es) (i,j) = S.flatten mk step Unknown $ mkStreamInner x (i,j-1) where-    mk :: StreamElm x -> m (StreamElm x, Int)-    mk x = return (x, getTopIdx x)-    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.Chr e)))-    step (x,k)-      | k < j     = return $ S.Yield (SeChr x (k+1) (VU.unsafeIndex es k)) (x,j+1)-      | otherwise = return $ S.Done-    {-# INLINE mk #-}-    {-# INLINE step #-}-  {-# INLINE mkStreamInner #-}------ * Empty and non-empty tables.------ TODO This will probably become more funny with triangular tables ...---- | empty subwords allowed--data E---- | only non-empty subwords--data N--class TransToN t where-  type TransTo t :: *-  transToN :: t -> TransTo t---- | Used by the instances below for index calculations.--class TblType tt where-  initDeltaIdx :: tt -> Int--instance TblType E where-  initDeltaIdx _ = 0-  {-# INLINE initDeltaIdx #-}--instance TblType N where-  initDeltaIdx _ = 1-  {-# INLINE initDeltaIdx #-}---- ** Immutable tables--data Tbl c es = Tbl !es--instance TransToN (Tbl c es) where-  type TransTo (Tbl c es) = Tbl N es-  transToN (Tbl es) = Tbl es-  {-# INLINE transToN #-}--instance Build (Tbl c es)--instance (StreamElement x, PrimArrayOps arr DIM2 e, TblType c) => StreamElement (x:.Tbl c (arr DIM2 e)) where-  data StreamElm    (x:.Tbl c (arr DIM2 e)) = SeTbl !(StreamElm x) !Int !e-  type StreamTopIdx (x:.Tbl c (arr DIM2 e)) = Int-  type StreamArg    (x:.Tbl c (arr DIM2 e)) = StreamArg x :. e-  getTopIdx (SeTbl _ k _) = k-  getArg    (SeTbl x _ e) = getArg x :. e-  {-# INLINE getTopIdx #-}-  {-# INLINE getArg #-}--instance (Monad m, MkStream m x, StreamElement x, StreamTopIdx x ~ Int, PrimArrayOps arr DIM2 e, TblType c) => MkStream m (x:.Tbl c (arr DIM2 e)) where-  -- | The outer stream function assumes that mkStreamInner generates a valid-  -- stream that does not need to be checked. (This should always be true!).-  -- The table entry to read is [k,j], as we supposedly are generating the-  -- outermost stream. Even more "outermost" streams will have changed 'j'-  -- beforehand. 'mkStream' should only ever be used if 'j' can be fixed.-  mkStream (x:.Tbl t) (i,j) = S.map step $ mkStreamInner x (i,j - initDeltaIdx (undefined :: c)) where-    step :: StreamElm x -> StreamElm (x:.Tbl c (arr DIM2 e))-    step x = let k = getTopIdx x in SeTbl x j (t PA.! (Z:.k:.j))-    {-# INLINE step #-}-  -- | The inner stream will, in each step, check if the current subword [k,l]-  -- (forall l>=k) is valid and terminate the stream once l>j.-  mkStreamInner (x:.Tbl t) (i,j) = S.flatten mk step Unknown $ mkStreamInner x (i,j) where-    mk :: StreamElm x -> m (StreamElm x, Int)-    mk x = return (x, getTopIdx x + initDeltaIdx (undefined :: c))-    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.Tbl c (arr DIM2 e))))-    step (x,l)-      | l<=j      = return $ S.Yield (SeTbl x l (t PA.! (Z:.k:.l))) (x,l+1)-      | otherwise = return $ S.Done-      where k = getTopIdx x-    {-# INLINE mk #-}-    {-# INLINE step #-}-  {-# INLINE mkStream #-}-  {-# INLINE mkStreamInner #-}---- ** Mutable tables in some monad.--data MTbl c es = MTbl !es--instance TransToN (MTbl c es) where-  type TransTo (MTbl c es) = MTbl N es-  transToN (MTbl es) = MTbl es-  {-# INLINE transToN #-}--mtblN :: es -> MTbl N es-mtblN es = MTbl es-{-# INLINE mtblN #-}--mtblE :: es -> MTbl E es-mtblE es = MTbl es-{-# INLINE mtblE #-}--instance Build (MTbl c es)--instance (StreamElement x, MPrimArrayOps marr DIM2 e, TblType c) => StreamElement (x:.MTbl c (marr s DIM2 e)) where-  data StreamElm    (x:.MTbl c (marr s DIM2 e)) = SeMTbl !(StreamElm x) !Int !e-  type StreamTopIdx (x:.MTbl c (marr s DIM2 e)) = Int-  type StreamArg    (x:.MTbl c (marr s DIM2 e)) = StreamArg x :. e-  getTopIdx (SeMTbl _ k _) = k-  getArg    (SeMTbl x _ e) = getArg x :. e-  {-# INLINE getTopIdx #-}-  {-# INLINE getArg #-}--instance-  ( Monad m-  , PrimMonad m-  , MkStream m x-  , StreamElement x-  , StreamTopIdx x ~ Int-  , MPrimArrayOps marr DIM2 e-  , TblType c-  , s ~ PrimState m-  ) => MkStream m (x:.MTbl c (marr s DIM2 e)) where-  -- | The outer stream function assumes that mkStreamInner generates a valid-  -- stream that does not need to be checked. (This should always be true!).-  -- The table entry to read is [k,j], as we supposedly are generating the-  -- outermost stream. Even more "outermost" streams will have changed 'j'-  -- beforehand. 'mkStream' should only ever be used if 'j' can be fixed.-  mkStream (x:.MTbl t) (i,j) = S.mapM step $ mkStreamInner x (i,j - initDeltaIdx (undefined :: c)) where-    step :: StreamElm x -> m (StreamElm (x:.MTbl c (marr s DIM2 e)))-    step x = let k = getTopIdx x in PA.readM t (Z:.k:.j) >>= \e -> return $ SeMTbl x j e-    {-# INLINE step #-}-  -- | The inner stream will, in each step, check if the current subword [k,l]-  -- (forall l>=k) is valid and terminate the stream once l>j.-  mkStreamInner (x:.MTbl t) (i,j) = S.flatten mk step Unknown $ mkStreamInner x (i,j) where-    mk :: StreamElm x -> m (StreamElm x, Int)-    mk x = return (x, getTopIdx x + initDeltaIdx (undefined :: c))-    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.MTbl c (marr s DIM2 e))))-    step (x,l)-      | l<=j      = readM t (Z:.k:.l) >>= \e -> return $ S.Yield (SeMTbl x l e) (x,l+1)-      | otherwise = return $ S.Done-      where k = getTopIdx x-    {-# INLINE mk #-}-    {-# INLINE step #-}-  {-# INLINE mkStream #-}-  {-# INLINE mkStreamInner #-}---- ** Some convenience functions.--tNtoE :: Tbl N x -> Tbl E x-tNtoE (Tbl x) = Tbl x-{-# INLINE tNtoE #-}--tEtoN :: Tbl E x -> Tbl N x-tEtoN (Tbl x) = Tbl x-{-# INLINE tEtoN #-}------ * Parses an empty subword.---- | The empty subword. Can not be part of a more complex RHS for obvious--- reasons: "S -> E S" doesn't make sense. Used in some grammars as the base--- case.--data Empty = Empty--instance Build Empty where-  type BuildStack Empty = Empty-  build c = c-  {-# INLINE build #-}--instance StreamElement (Empty) where-  data StreamElm    Empty = SeEmpty !Int-  type StreamTopIdx Empty = Int-  type StreamArg    Empty = ArgZ :. ()-  getTopIdx (SeEmpty k) = k-  getArg    (SeEmpty _) = ArgZ :. ()-  {-# INLINE getTopIdx #-}-  {-# INLINE getArg #-}--instance (Monad m) => MkStream m (Empty) where-  mkStream Empty (i,j) = S.unfoldr step i where-    step k-      | k==j      = Just (SeEmpty k, j+1)-      | otherwise = Nothing-    {-# INLINE step #-}-  mkStreamInner = error "undefined for Empty"-  {-# INLINE mkStream #-}-  {-# INLINE mkStreamInner #-}------ * Parsing subwords with restriced size. Both min- and max-size are given--- when binding input.--data RestrictedRegion e = RRegion !Int !Int !(VU.Vector e)--instance Build (RestrictedRegion e)--instance (StreamElement x) => StreamElement (x:.RestrictedRegion e) where-  data StreamElm (x:.RestrictedRegion e) = SeResRegion !(StreamElm x) !Int (VU.Vector e)-  type StreamTopIdx (x:.RestrictedRegion e) = Int-  type StreamArg (x:.RestrictedRegion e) = StreamArg x :. (VU.Vector e)-  getTopIdx (SeResRegion _ k _) = k-  getArg (SeResRegion x _ e) = getArg x :. e-  {-# INLINE getTopIdx #-}-  {-# INLINE getArg #-}--instance (Monad m, MkStream m x, StreamElement x, StreamTopIdx x ~ Int, VU.Unbox e) => MkStream m (x:.RestrictedRegion e) where-  mkStream (x:.RRegion minR maxR xs) (i,j) = S.flatten mk step Unknown $ mkStream x (i,j-1) where-    mk :: StreamElm x -> m (StreamElm x, Int)-    mk x = return (x, getTopIdx x)-    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.RestrictedRegion e)))-    step (x,k)-      | k+minR <= j && k+maxR >= j = return $ S.Yield (SeResRegion x k (VU.unsafeSlice k (max maxR (j-k)) xs)) (x,j+1)-      | otherwise = return S.Done-    {-# INLINE mk #-}-    {-# INLINE step #-}-  {-# INLINE mkStream #-}-  mkStreamInner (x:.RRegion minR maxR xs) (i,j) = S.flatten mk step Unknown $ mkStream x (i,j) where-    mk :: StreamElm x -> m (StreamElm x, Int)-    mk x = return (x, getTopIdx x + minR)-    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.RestrictedRegion e)))-    step (x,l)-      | l<=j && (l-k)<=maxR = return $ S.Yield (SeResRegion x l (VU.unsafeSlice k (l-k) xs)) (x,j+1)-      | otherwise           = return S.Done-      where k = getTopIdx x-    {-# INLINE mk #-}-    {-# INLINE step #-}-  {-# INLINE mkStreamInner #-}------ * Backtracking tables.------ Since we want the slow forward phase to be fast, in the backtracking phase,--- we need to keep track of additional things. The backtracking table 'BTtbl'--- requires the table and an additional backtracking function. You should use--- the same composed function as for the forward pahse creating the bound table--- in the first place.---- | The backtracking table 'BTtbl" captures a DP table and the function used--- to fill it.--data BTtbl c t g = BTtbl t g--instance TransToN (BTtbl c t g) where-  type TransTo (BTtbl c t g) = BTtbl N t g-  transToN (BTtbl t g) = BTtbl t g-  {-# INLINE transToN #-}--bttblN :: t -> g -> BTtbl N t g-bttblN t g = BTtbl t g-{-# INLINE bttblN #-}--bttblE :: t -> g -> BTtbl E t g-bttblE t g = BTtbl t g-{-# INLINE bttblE #-}--instance Build (BTtbl c t g)---- | The backtracking function, given our index pair, return a stream of--- backtracked results. (Return as in we are in a monad).------ TODO Should this be "(Int,Int) -> m (SM.Stream Id b)" or are there cases--- where we'd like to have monadic effects on the "b"s?--type BTfun m b = (Int,Int) -> m (S.Stream m b)--instance (Monad m, StreamElement x, TblType c) => StreamElement (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) where-  data StreamElm    (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) = SeBTtbl !(StreamElm x) !Int !e (m (S.Stream m b))-  type StreamTopIdx (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) = Int-  type StreamArg    (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) = StreamArg x :. (e, m (S.Stream m b))-  getTopIdx (SeBTtbl _ k _ _) = k-  getArg    (SeBTtbl x _ e g) = getArg x :. (e,g)-  {-# INLINE getTopIdx #-}-  {-# INLINE getArg #-}--instance-  ( Monad m-  , MkStream m x-  , StreamElement x-  , VU.Unbox e-  , StreamTopIdx x ~ Int-  , TblType c-  ) => MkStream m (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) where-  mkStream (x:.BTtbl t g) (i,j) = S.map step $ mkStreamInner x (i,j - initDeltaIdx (undefined :: c)) where-    step :: StreamElm x -> StreamElm (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b))-    step x = let k = getTopIdx x in SeBTtbl x j (t PA.! (Z:.k:.j)) (g (k,j))-    {-# INLINE step #-}-  mkStreamInner (x:.BTtbl t g) (i,j) = S.flatten mk step Unknown $ mkStreamInner x (i,j) where-    mk :: StreamElm x -> m (StreamElm x, Int)-    mk x = return (x, getTopIdx x + initDeltaIdx (undefined :: c))-    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b))))-    step (x,l)-      | l<=j      = return $ S.Yield (SeBTtbl x l (t PA.! (Z:.k:.l)) (g (k,l))) (x,l+1)-      | otherwise = return $ S.Done-      where k = getTopIdx x-    {-# INLINE mk #-}-    {-# INLINE step #-}-  {-# INLINE mkStream #-}-  {-# INLINE mkStreamInner #-}------ * Build complex stacks--instance Build x => Build (x,y) where-  type BuildStack (x,y) = BuildStack x :. y-  build (x,y) = build x :. y-  {-# INLINE build #-}------ * combinators--infixl 8 <<<-(<<<) f t ij = S.map (\s -> apply f $ getArg s) $ mkStream (build t) ij-{-# INLINE (<<<) #-}--infixl 7 |||-(|||) xs ys ij = xs ij S.++ ys ij-{-# INLINE (|||) #-}--infixl 6 ...-(...) s h ij = h $ s ij-{-# INLINE (...) #-}--infixl 6 ..@-(..@) s h ij = h ij $ s ij-{-# INLINE (..@) #-}--infixl 9 ~~-(~~) = (,)-{-# INLINE (~~) #-}--infixl 9 %-(%) = (,)-{-# INLINE (%) #-}------ * Apply function 'f' in '(<<<)'--class Apply x where-  type Fun x :: *-  apply :: Fun x -> x--instance Apply (ArgZ:.a -> res) where-  type Fun (ArgZ:.a -> res) = a -> res-  apply fun (ArgZ:.a) = fun a-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b -> res) where-  type Fun (ArgZ:.a:.b -> res) = a->b -> res-  apply fun (ArgZ:.a:.b) = fun a b-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c -> res) where-  type Fun (ArgZ:.a:.b:.c -> res) = a->b->c -> res-  apply fun (ArgZ:.a:.b:.c) = fun a b c-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d -> res) where-  type Fun (ArgZ:.a:.b:.c:.d -> res) = a->b->c->d -> res-  apply fun (ArgZ:.a:.b:.c:.d) = fun a b c d-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d:.e -> res) where-  type Fun (ArgZ:.a:.b:.c:.d:.e -> res) = a->b->c->d->e -> res-  apply fun (ArgZ:.a:.b:.c:.d:.e) = fun a b c d e-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d:.e:.f -> res) where-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f -> res) = a->b->c->d->e->f -> res-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f) = fun a b c d e f-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g -> res) where-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g -> res) = a->b->c->d->e->f->g -> res-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g) = fun a b c d e f g-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h -> res) where-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h -> res) = a->b->c->d->e->f->g->h -> res-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h) = fun a b c d e f g h-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) where-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) = a->b->c->d->e->f->g->h->i -> res-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i) = fun a b c d e f g h i-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) where-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) = a->b->c->d->e->f->g->h->i->j -> res-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j) = fun a b c d e f g h i j-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) where-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) = a->b->c->d->e->f->g->h->i->j->k -> res-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k) = fun a b c d e f g h i j k-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) where-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) = a->b->c->d->e->f->g->h->i->j->k->l -> res-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l) = fun a b c d e f g h i j k l-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) where-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m -> res-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m) = fun a b c d e f g h i j k l m-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) where-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n -> res-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n) = fun a b c d e f g h i j k l m n-  {-# INLINE apply #-}--instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) where-  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n->o -> res-  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o) = fun a b c d e f g h i j k l m n o-  {-# INLINE apply #-}-
− ADP/Fusion/GAPlike/Criterion.hs 
@@ -1,179 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PackageImports #-}--module ADP.Fusion.GAPlike.Criterion where--import Control.Monad.ST-import Criterion.Main-import Data.Char-import qualified Data.Vector.Fusion.Stream.Monadic as S-import qualified Data.Vector.Fusion.Stream as SP--import Data.PrimitiveArray-import Data.PrimitiveArray.Unboxed.VectorZero as UVZ-import Data.PrimitiveArray.Unboxed.Zero as UZ-import "PrimitiveArray" Data.Array.Repa.Index-import "PrimitiveArray" Data.Array.Repa.Shape--import ADP.Fusion.GAPlike-import ADP.Fusion.GAPlike.DevelCommon----criterionMain = defaultMain-  [ bgroup "testTTT3"-    [ bench "  10" (whnf (testTTT 0)   10)-    , bench " 100" (whnf (testTTT 0)  100)-    , bench "1000" (whnf (testTTT 0) 1000)-    ]-  , bgroup "testTTTT4"-    [ bench "  10" (whnf (testTTTT 0)   10)-    , bench " 100" (whnf (testTTTT 0)  100)-    , bench "1000" (whnf (testTTTT 0) 1000)-    ]-  , bgroup "testTTTT4ga"-    [ bench "  10" (whnf (testTTTTga 0)   10)-    , bench " 100" (whnf (testTTTTga 0)  100)-    , bench "1000" (whnf (testTTTTga 0) 1000)-    ]-  , bgroup "testTTTT4gaPA"-    [ bench "  10" (whnf (testTTTTgaPA 0)   10)-    , bench " 100" (whnf (testTTTTgaPA 0)  100)-    , bench "1000" (whnf (testTTTTgaPA 0) 1000)-    ]-  , bgroup "testTTTT4gaImmu"-    [ bench "  10" (whnf (testTTTTgaImmu 0)   10)-    , bench " 100" (whnf (testTTTTgaImmu 0)  100)-    , bench "1000" (whnf (testTTTTgaImmu 0) 1000)-    ]-  , bgroup "testTTTT4gaImmuPA"-    [ bench "  10" (whnf (testTTTTgaImmuPA 0)   10)-    , bench " 100" (whnf (testTTTTgaImmuPA 0)  100)-    , bench "1000" (whnf (testTTTTgaImmuPA 0) 1000)-    ]-  ]------ * Criterion tests--testC :: Int -> Int -> Int-testC i j = runST doST where-  doST :: ST s Int-  doST = do-    let c = Chr dvu-    (gord1 <<< c ... ghsum) (i,j)-{-# NOINLINE testC #-}--gTestC (ord1,hsum) c =-  (ord1 <<< c ... hsum)--aTestC = (ord1,hsum) where-  ord1 = gord1-  hsum = ghsum--testCC :: Int -> Int -> Int-testCC i j = runST doST where-  doST :: ST s Int-  doST = do-    let c = Chr dvu-    let d = Chr dvu-    (gord2 <<< c % d ... ghsum) (i,j)-{-# NOINLINE testCC #-}--type TBL s = Tbl N (UVZ.MArr0 s DIM2 Int)--testT :: Int -> Int -> Int-testT i j = runST doST where-  doST :: ST s Int-  doST = do-    tbl :: TBL s <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) 1 []-    (id <<< tbl ... ghsum) (i,j)-{-# NOINLINE testT #-}--testTT :: Int -> Int -> Int-testTT i j = runST doST where-  doST :: ST s Int-  doST = do-    tbl :: TBL s <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) 1 []-    (gplus2 <<< tbl % tbl ... ghsum) (i,j)-  {-# INLINE doST #-}-{-# NOINLINE testTT #-}--testTTT :: Int -> Int -> Int-testTTT i j = runST doST where-  doST :: ST s Int-  doST = do-    tbl :: TBL s <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) 1 []-    (gplus3 <<< tbl % tbl % tbl ... ghsum) (i,j)-{-# NOINLINE testTTT #-}--testTTTT :: Int -> Int -> Int-testTTTT i j = runST doST where-  doST :: ST s Int-  doST = do-    tbl :: TBL s <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) (1::Int) []-    (gplus4 <<< tbl % tbl % tbl % tbl ... ghsum) (i,j)-  {-# INLINE doST #-}-{-# NOINLINE testTTTT #-}--testTTTTga :: Int -> Int -> Int-testTTTTga i j = runST doST where-  doST :: ST s Int-  doST = do-    tbl :: TBL s <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) (1::Int) []-    gTTTga aTTTga tbl (i,j)-  {-# INLINE doST #-}-{-# NOINLINE testTTTTga #-}--testTTTTgaPA :: Int -> Int -> Int-testTTTTgaPA i j = runST doST where-  doST :: ST s Int-  doST = do-    tbl :: Tbl N (UZ.MArr0 s DIM2 Int) <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) (1::Int) []-    gTTTga aTTTga tbl (i,j)-  {-# INLINE doST #-}-{-# NOINLINE testTTTTgaPA #-}--testTTTTgaImmu :: Int -> Int -> Int-testTTTTgaImmu i j =-    let tbl = (Tbl $ fromAssocs (Z:.0:.0) (Z:.j:.j) 1 []) :: Tbl N (UVZ.Arr0 DIM2 Int) -    in tbl `seq` gTTTga aTTTgaImmu tbl (i,j)-{-# NOINLINE testTTTTgaImmu #-}--testTTTTgaImmuPA :: Int -> Int -> Int-testTTTTgaImmuPA i j =-    let tbl = (Tbl $ fromAssocs (Z:.0:.0) (Z:.j:.j) 1 []) :: Tbl N (UZ.Arr0 DIM2 Int) -    in tbl `seq` gTTTga aTTTgaImmu tbl (i,j)-{-# NOINLINE testTTTTgaImmuPA #-}--gTTTga (plus4, hsum) tbl =-  (plus4 <<< tbl % tbl % tbl % tbl ... hsum)-{-# INLINE gTTTga #-}--aTTTga = (plus4, hsum) where-  plus4 = gplus4-  hsum = ghsum--aTTTgaImmu = (plus4, hsum) where-  plus4 = gplus4-  hsum = gihsum-{-# INLINE aTTTgaImmu #-}--gord1 a = ord a--gord2 a b = ord a + ord b--gord3 a b c = ord a + ord b + ord c--gplus2 a b = a+b--gplus3 a b c = a+b+c--gplus4 a b c d = a+b+c+d--ghsum :: S.Stream (ST s) Int -> ST s Int-ghsum = S.foldl' (+) 0--gihsum :: SP.Stream Int -> Int-gihsum = SP.foldl' (+) 0
− ADP/Fusion/GAPlike/DevelCommon.hs 
@@ -1,22 +0,0 @@-{-# LANGUAGE PackageImports #-}--module ADP.Fusion.GAPlike.DevelCommon where--import qualified Data.PrimitiveArray as PA-import qualified Data.Vector.Unboxed as VU--import Data.PrimitiveArray.Unboxed.VectorZero as UVZ-import Data.PrimitiveArray.Unboxed.Zero as UZ-import "PrimitiveArray" Data.Array.Repa.Index-import "PrimitiveArray" Data.Array.Repa.Shape----dvu = VU.fromList $ concat $ replicate 10 ['a'..'z']-{-# NOINLINE dvu #-}--type PAT = UVZ.Arr0 DIM2 Int-pat :: PAT-pat = PA.fromAssocs (Z:.0:.0) (Z:.1000:.1000) 0 [(Z:.i:.j,j-i) | i <-[0..1000], j<-[i..1000] ]-{-# NOINLINE pat #-}-
− ADP/Fusion/GAPlike/QuickCheck.hs 
@@ -1,57 +0,0 @@-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE TemplateHaskell #-}--module ADP.Fusion.GAPlike.QuickCheck where--import Test.QuickCheck-import Test.QuickCheck.All-import qualified Data.Vector.Fusion.Stream as SP-import qualified Data.Vector.Unboxed as VU--import "PrimitiveArray" Data.Array.Repa.Index-import "PrimitiveArray" Data.Array.Repa.Shape-import Data.PrimitiveArray--import ADP.Fusion.QuickCheck.Arbitrary-import ADP.Fusion.GAPlike.DevelCommon-import ADP.Fusion.GAPlike------ * QuickCheck--checkC_fusion (i,j) = id <<< Chr dvu ... SP.toList $ (i,j)-checkC_list   (i,j) = [dvu VU.! i | i+1==j]-prop_checkC = checkC_fusion === checkC_list--checkCC_fusion (i,j) = (,) <<< Chr dvu % Chr dvu ... SP.toList $ (i,j)-checkCC_list   (i,j) = [ (dvu VU.! i, dvu VU.! (i+1)) | i+2==j ]-prop_checkCC = checkCC_fusion === checkCC_list--checkP_fusion (i,j) = id <<< (Tbl pat :: Tbl E PAT)  ... SP.toList $ (i,j)-checkP_list   (i,j) = [ (pat!(Z:.i:.j)) | i<=j ]-prop_checkP = checkP_fusion === checkP_list--checkPP_fusion (i,j) = let tbl = Tbl pat :: Tbl E PAT-                       in  (,) <<< tbl % tbl ... SP.toList $ (i,j)-checkPP_list   (i,j) = [ (pat!(Z:.i:.k), pat!(Z:.k:.j)) | k<-[i..j] ]-prop_checkPP = checkPP_fusion === checkPP_list--checkCPC_fusion (i,j) = let tbl = Tbl pat :: Tbl E PAT-                        in  (,,) <<< Chr dvu % tbl % Chr dvu ... SP.toList $ (i,j)-checkCPC_list (i,j) = [ (dvu VU.! i, pat!(Z:.i+1:.j-1), dvu VU.! (j-1)) | i+2<=j ]-prop_checkCPC = checkCPC_fusion === checkCPC_list--checkNN_fusion (i,j) = let tbl = Tbl pat :: Tbl N PAT-                       in  (,) <<< tbl % tbl ... SP.toList $ (i,j)-checkNN_list   (i,j) = [ (pat!(Z:.i:.k), pat!(Z:.k:.j)) | k<-[i+1..j-1] ]-prop_checkNN = checkNN_fusion === checkNN_list----options = stdArgs {maxSuccess = 1000}--customCheck = quickCheckWithResult options--allProps = $forAllProperties customCheck-
− ADP/Fusion/Monadic.hs 
@@ -1,197 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE PackageImports #-}---- | Monadic combinators. Code like------ @f <<< xs ~~~ ys ... Stream.sum@------ will generate efficient GHC core for a dynamic program comparable to------ @sum [ f (xs!(i,k)) (ys!(k,j)) | k<-[i..j]]@.--module ADP.Fusion.Monadic where--import "PrimitiveArray" Data.Array.Repa.Index-import qualified Data.Vector.Fusion.Stream.Monadic as S--import ADP.Fusion.Monadic.Internal------ * Apply functions to arguments.---- | A monadic version of the function application combinator. Applies 'f'--- which has a monadic effect.--infixl 8 #<<-(#<<) f t ij = S.mapM (\(_,_,c) -> apply f c) $ streamGen t ij-{-# INLINE (#<<) #-}---- | Pure function application combinator. Applies 'f' which is pure. The--- arguments to 'f', meaning 't' can be monadic, however!--infixl 8 <<<-(<<<) f t ij = S.map (\(_,_,c) -> apply f c) $ streamGen t ij-{-# INLINE (<<<) #-}------ * Combine multiple right-hand sides of a non-terminal in a context-free--- grammar.---- | If both, 'xs' and 'ys' are streams of candidate answers, they can be--- combined here. The answer (or sort) type of 'xs' and 'ys' has to be the--- same. Works like @(++)@ for lists.--infixl 7 |||-(|||) xs ys ij = xs ij S.++ ys ij-{-# INLINE (|||) #-}------ * Reduce streams to single answers.------ NOTE "Single answers" can be of a vector-type! One is not constrained to--- scalar results. This allows for many exiting algorithms.---- | Reduces a streams of answers to the type of stored answers. The resulting--- type could be scalar, which it will be for highest-performance algorithms,--- or it could be a subset of answers stored in some kind of data structure.--infixl 6 ...-(...) stream h ij = h $ stream ij-{-# INLINE (...) #-}---- | Specialized version of choice function application, with a choice function--- that needs to know the subword index it is working on.--infixl 6 ..@-(..@) stream h ij = h ij $ stream ij-{-# INLINE (..@) #-}------ * Combinators to chain function arguments.------ ** General combinator creation.---- | General function to create combinators. The left-hand side @xs@ in @xs--- `comb` ys@ will have a size between @minL@ and @maxL@, while @ys@ and--- /everything to its right will be guaranteed @minR@ size.--makeLeft_MinRight (minL,maxL) minR = comb where-  {-# INLINE comb #-}-  comb xs ys = Box mk step xs ys-  {-# INLINE mk #-}-  mk (z:.k:.j,a,b) = return (z:.k:.k+minL:.j,a,b)-  {-# INLINE step #-}-  step (z:.k:.l:.j,a,b)-    | l<=j-minR && l<=k+maxL = return $ S.Yield (z:.k:.l:.j,a,b) (z:.k:.l+1:.j,a,b)-    | otherwise              = return $ S.Done-{-# INLINE makeLeft_MinRight #-}---- | Create combinators which are to be used in the right-most position of a--- chain. 1st, they make sure that the second to last region has a size of at--- least 'minL'. 2nd, they constrain the last argument to a size between 'minR'--- and 'maxR'.--makeMinLeft_Right minL (minR,maxR) = comb where-  {-# INLINE comb #-}-  comb xs ys = Box mk step xs ys-  {-# INLINE mk #-}-  mk (z:.k:.j,a,b) = let l = max (k+minL) (j-maxR) in return (z:.k:.l:.j,a,b)-  {-# INLINE step #-}-  step (z:.k:.l:.j,a,b)-    | l<=j-minR = return $ S.Yield (z:.k:.l:.j,a,b) (z:.k:.l+1:.j,a,b)-    | otherwise = return $ S.Done-{-# INLINE makeMinLeft_Right #-}------ ** A number of often-used combinators.--infixl 9 -~+, +~-, -~~, ~~---(-~+) = makeLeft_MinRight (1,1) 1-{-# INLINE (-~+) #-}--(+~-) = makeMinLeft_Right 1 (1,1)-{-# INLINE (+~-) #-}--(-~~) = makeLeft_MinRight (1,1) 0-{-# INLINE (-~~) #-}--(~~-) = makeMinLeft_Right 0 (1,1)-{-# INLINE (~~-) #-}--(+~--) = makeMinLeft_Right 1 (2,2)-{-# INLINE (+~--) #-}--infixl 9 ~~~-(~~~) xs ys = Box mk step xs ys where-  {-# INLINE mk #-}-  mk (z:.k:.j,vidx,vstack) = return $ (z:.k:.k:.j,vidx,vstack)-  {-# INLINE step #-}-  step (z:.k:.l:.j,vidx,vstack)-    | l<=j      = return $ S.Yield (z:.k:.l:.j,vidx,vstack) (z:.k:.l+1:.j,vidx,vstack)-    | otherwise = return $ S.Done-{-# INLINE (~~~) #-}---- | @xs +~+ ys@ with @xs@ and @ys@ non-empty. The non-emptyness constraint on--- @ys@ works only for two arguments. With three or more arguments, a--- left-leaning combinator to the right of @ys@ is required to establish--- non-emptyness.--infixl 9 +~+-(+~+) xs ys = Box mk step xs ys where-  {-# INLINE mk #-}-  mk (z:.k:.j,vidx,vstack) = return $ (z:.k:.k+1:.j,vidx,vstack)-  {-# INLINE step #-}-  step (z:.k:.l:.j,vidx,vstack)-    | l+1<=j    = return $ S.Yield (z:.k:.l:.j,vidx,vstack) (z:.k:.l+1:.j,vidx,vstack)-    | otherwise = return $ S.Done-{-# INLINE (+~+) #-}---- | @ls ~~~ xs !-~+ ys@ with xs having a size of one and @ls@ further to the--- left having a size of one or more.--infixl 9 !-~+-(!-~+) xs ys = Box mk step xs ys where-  {-# INLINE mk #-}-  mk (z:.k:.j,vidx,vstack)-    | k>0       = return $ (z:.k:.k+1:.j,vidx,vstack)-    | otherwise = return $ (z:.k:.j+1:.j,vidx,vstack)-  {-# INLINE step #-}-  step (z:.k:.l:.j,vidx,vstack)-    | l+1<=j    = return $ S.Yield (z:.k:.l:.j,vidx,vstack) (z:.k:.j+1:.j,vidx,vstack)-    | otherwise = return $ S.Done-{-# INLINE (!-~+) #-}---- | @xs +~-! ys ~~~ rs@ with @ys@ having a size of one and @rs@ further to the--- right having a size of one.--infixl 9 +~-!-(+~-!) xs ys = Box mk step xs ys where-  {-# INLINE mk #-}-  mk (z:.k:.j,vidx,vstack) = return $ (z:.k:.j-2:.j,vidx,vstack)-  {-# INLINE step #-}-  step (z:.k:.l:.j,vidx,vstack)-    | l+2==j    = return $ S.Yield (z:.k:.l:.j,vidx,vstack) (z:.k:.j+1:.j,vidx,vstack)-    | otherwise = return $ S.Done-{-# INLINE (+~-!) #-}---- | @xs -~- ys@ produces an answer only if both @xs@ and @ys@ have size one.--- The total size here then is two.--infixl 9 -~--(-~-) xs ys = Box mk step xs ys where-  {-# INLINE mk #-}-  mk (z:.k:.j,vidx,vstack) = return $ (z:.k:.k+1:.j,vidx,vstack)-  {-# INLINE step #-}-  step (z:.k:.l:.j,vidx,vstack)-    | k+1==l && l+1==j = return $ S.Yield (z:.k:.l:.j,vidx,vstack) (z:.k:.l+1:.j,vidx,vstack)-    | otherwise        = return $ S.Done-{-# INLINE (-~-) #-}-
− ADP/Fusion/Monadic/Internal.hs 
@@ -1,492 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--{-# OPTIONS_HADDOCK hide #-}---- | The internal working of ADPfusion. All combinator applications are turned--- into efficient code during compile time.------ If you have a data structure to be used as an argument in a combinator--- chain, derive an instance 'ExtractValue', 'StreamGen', and 'PreStreamGen'.------ NOTE: If this doesn't happen, it is a possible bug, or GHC changed its--- optimizer (like with GHC 7.2 -> 7.4).------ TODO If possible, instance generation will be using the Generics system in--- the future.--module ADP.Fusion.Monadic.Internal where--import Control.Monad.Primitive-import Control.Monad.ST-import Data.List (intersperse)-import Data.Primitive.Types-import Data.Vector.Fusion.Stream.Size-import "PrimitiveArray" Data.Array.Repa.Index-import "PrimitiveArray" Data.Array.Repa.Shape-import qualified Data.Vector.Fusion.Stream.Monadic as S-import qualified Data.Vector.Unboxed as VU-import Text.Printf--import qualified Data.PrimitiveArray as PA-import qualified Data.PrimitiveArray.Zero.Unboxed as ZU-import qualified Data.PrimitiveArray.Zero as Z------ * StreamGen---- | Generate stream from either one (DIM2 -> m cnt) or some combination of--- terminals derived from uses of nextTo.--class Monad m => StreamGen m t r | t -> r where-  streamGen :: t -> DIM2 -> S.Stream m r--#define mkStreamGen(cnt) \-instance (Monad m, ExtractValue m (cnt), Asor (cnt) ~ k, Elem (cnt) ~ elm) \-=> StreamGen m (cnt) (DIM2,Z:.k,Z:.elm) where { \-  {-# INLINE streamGen #-} \-;  streamGen x ij = extractStreamLast x $ preStreamGen x ij }--mkStreamGen(DIM2 -> Scalar elm)-mkStreamGen(DIM2 -> ScalarM elm)-mkStreamGen(DIM2 -> Vect elm)-mkStreamGen(DIM2 -> VectM elm)-mkStreamGen(ZU.MArr0 s sh elm)-mkStreamGen(ZU.Arr0 sh elm)--mkStreamGen(Z.MArr0 s sh (VU.Vector elm))-mkStreamGen(Z.Arr0 sh (VU.Vector elm))---- | two or more elements combined by NextTo (~~~), "xs" as anything, "ys" is--- monadic.--instance-  ( Monad m-  , ExtractValue m ys, Asor ys ~ cY, Elem ys ~ eY-  , PreStreamGen m (Box mk step xs ys) (idx:.Int,adx:.cX,arg:.eX)-  , Idx2 _idx ~ idx-  ) => StreamGen m (Box mk step xs ys) (idx:.Int,adx:.cX:.cY,arg:.eX:.eY) where-  streamGen (Box mk step xs ys) ij-    = extractStreamLast ys-    $ preStreamGen (Box mk step xs ys) ij-  {-# INLINE streamGen #-}------ * PreStreamGen---- | Required by most 'StreamGen' instances just before 'extractStreamLast' is--- called.--class Monad m => PreStreamGen m s q | s -> q where-  preStreamGen-    :: s      -- ^ the composite type of the arguments-    -> DIM2   -- ^ the original index @(Z:.i:.j)@-    -> S.Stream m q -- ^ the stream we get out of it---- | Creates the single step on the left which does nothing more then set the--- outermost indices to (i,j). This does not use the alpha/omega's--singlePreStreamGen ij = S.unfoldr step ij where-  {-# INLINE step #-}-  step (Z:.i:.j)-    | i<=j      = Just ((Z:.i:.j ,Z,Z), Z:.j+1:.j)-    | otherwise = Nothing-{-# INLINE singlePreStreamGen #-}--#define mkPreStreamGen(s) \-instance (Monad m) => PreStreamGen m (s) (DIM2,Z,Z) where { \-  {-# INLINE preStreamGen #-} \-;  preStreamGen _ = singlePreStreamGen }--mkPreStreamGen(DIM2 -> Scalar elm)-mkPreStreamGen(DIM2 -> ScalarM elm)-mkPreStreamGen(DIM2 -> Vect elm)-mkPreStreamGen(DIM2 -> VectM elm)-mkPreStreamGen(ZU.MArr0 s sh elm)-mkPreStreamGen(ZU.Arr0 sh elm)--mkPreStreamGen(Z.MArr0 s sh (VU.Vector elm))-mkPreStreamGen(Z.Arr0 sh (VU.Vector elm))---- | the first two arguments from nextTo, monadic xs.--instance ( Monad m-         , ExtractValue m xs, Asor xs ~ cX, Elem xs ~ eX-         , PreStreamGen m xs xsStack-         , (idxX,adxX,argX) ~ xsStack-         , (z0:.Int:.Int) ~ idxX-         , ((idxX,adxX,argX) -> m (idxX:.Int,adxX,argX)) ~ mk-         , ((idxX:.Int,adxX,argX) -> m (S.Step (idxX:.Int,adxX,argX) (idxX:.Int,adxX,argX))) ~ step-         ) => PreStreamGen m (Box mk step xs ys) (idxX:.Int,adxX:.cX,argX:.eX) where-  preStreamGen (Box mk step xs ys) ij-    = extractStream xs-    $ S.flatten mk step Unknown-    $ preStreamGen xs ij-  {-# INLINE preStreamGen #-}---- | Pre-stream generation for deeply nested boxes.--instance-  ( Monad m-  , ExtractValue m xs, Asor xs ~ cX, Elem xs ~ eX-  , PreStreamGen m (Box box2 box3 box1 xs) xsStack-  , (idxX,adxX,argX) ~ xsStack-  , (z0:.Int:.Int) ~ idxX-  , ((idxX,adxX,argX) -> m (idxX:.Int,adxX,argX)) ~ mk-  , ((idxX:.Int,adxX,argX) -> m (S.Step (idxX:.Int,adxX,argX) (idxX:.Int,adxX,argX))) ~ step-  ) => PreStreamGen m (Box mk step (Box box2 box3 box1 xs) ys) (idxX:.Int,adxX:.cX,argX:.eX) where-  preStreamGen (Box mk step box@(Box _ _ _ xs) ys) ij-    = extractStream xs-    $ S.flatten mk step Unknown-    $ preStreamGen box ij-  {-# INLINE preStreamGen #-}------ * ExtractValue: extract values from data structures.--class (Monad m) => ExtractValue m cnt where-  type Asor cnt :: *-  type Elem cnt :: *-  extractValue  :: ()-                => cnt-                -> DIM2-                -> Asor cnt-                -> m (Elem cnt)-  extractStream :: ()-                => cnt-                -> S.Stream m (Idx3 z,astack,vstack)-                -> S.Stream m (Idx3 z,astack:.Asor cnt,vstack:.Elem cnt)-  extractStreamLast :: ()-                    => cnt-                    -> S.Stream m (Idx2 z,astack,vstack)-                    -> S.Stream m (Idx2 z,astack:.Asor cnt,vstack:.Elem cnt)---- | Mutable arrays.--instance-  ( PrimMonad m-  , VU.Unbox elm-  , PrimState m ~ s-  , DIM2 ~ sh-  ) => ExtractValue m (ZU.MArr0 s sh elm) where-  type Asor (ZU.MArr0 s sh elm) = Z-  type Elem (ZU.MArr0 s sh elm) = elm-  extractValue cnt ij z = do-    x <- PA.readM cnt ij-    x `seq` return x-  extractStream cnt stream = S.mapM addElm stream where-    addElm (z:.k:.x:.l, astack, vstack) = do-      vadd <- PA.readM cnt (Z:.k:.x)-      vadd `seq` return (z:.k:.x:.l, astack:.Z, vstack :. vadd)-  extractStreamLast sngl stream = S.mapM addElm stream where-    addElm (z:.k:.x, astack, vstack) = do-      vadd <- PA.readM sngl (Z:.k:.x)-      vadd `seq` return (z:.k:.x, astack:.Z, vstack:.vadd)-  {-# INLINE extractValue #-}-  {-# INLINE extractStream #-}-  {-# INLINE extractStreamLast #-}---- | Immutable arrays.--instance-  ( Monad m-  , VU.Unbox elm-  , DIM2 ~ sh-  ) => ExtractValue m (ZU.Arr0 sh elm) where-  type Asor (ZU.Arr0 sh elm) = Z-  type Elem (ZU.Arr0 sh elm) = elm-  extractValue cnt ij z = do-    let x = PA.index cnt ij-    x `seq` return x-  extractStream cnt stream = S.map addElm stream where-    addElm (z:.k:.x:.l, astack, vstack) = let vadd = PA.index cnt (Z:.k:.x) in-      vadd `seq` (z:.k:.x:.l, astack:.Z, vstack :. vadd)-  extractStreamLast cnt stream = S.map addElm stream where-    addElm (z:.k:.x, astack, vstack) = let vadd = PA.index cnt (Z:.k:.x) in-      vadd `seq` (z:.k:.x, astack:.Z, vstack:.vadd)-  {-# INLINE extractValue #-}-  {-# INLINE extractStream #-}-  {-# INLINE extractStreamLast #-}---- | Function with 'Scalar' return value.--instance-  ( Monad m-  ) => ExtractValue m (DIM2 -> Scalar elm) where-  type Asor (DIM2 -> Scalar elm) = Z-  type Elem (DIM2 -> Scalar elm) = elm-  extractValue cnt ij z = do-    let Scalar x = cnt ij-    x `seq` return x-  extractStream cnt stream = S.map addElm stream where-    addElm (z:.k:.x:.l, astack, vstack) = let Scalar vadd = cnt (Z:.k:.x) in-      vadd `seq` (z:.k:.x:.l, astack:.Z, vstack :. vadd)-  extractStreamLast cnt stream = S.map addElm stream where-    addElm (z:.k:.x, astack, vstack) = let Scalar vadd = cnt (Z:.k:.x) in-      vadd `seq` (z:.k:.x, astack:.Z, vstack:.vadd)-  {-# INLINE extractValue #-}-  {-# INLINE extractStream #-}-  {-# INLINE extractStreamLast #-}---- | Function with monadic 'Scalar' return value.--instance-  ( Monad m-  ) => ExtractValue m (DIM2 -> ScalarM (m elm)) where-  type Asor (DIM2 -> ScalarM (m elm)) = Z-  type Elem (DIM2 -> ScalarM (m elm)) = elm-  extractValue cnt ij z = do-    let ScalarM x' = cnt ij-    x <- x'-    x `seq` return x-  extractStream cnt stream = S.mapM addElm stream where-    addElm (z:.k:.x:.l, astack, vstack) = do-      let ScalarM vadd' = cnt (Z:.k:.x)-      vadd <- vadd'-      vadd `seq` return (z:.k:.x:.l, astack:.Z, vstack :. vadd)-  extractStreamLast cnt stream = S.mapM addElm stream where-    addElm (z:.k:.x, astack, vstack) = do-      let ScalarM vadd' = cnt (Z:.k:.x)-      vadd <- vadd'-      vadd `seq` return (z:.k:.x, astack:.Z, vstack:.vadd)-  {-# INLINE extractValue #-}-  {-# INLINE extractStream #-}-  {-# INLINE extractStreamLast #-}---- | This instance is a bit crazy, since the accessor is the current stream--- itself. No idea how efficient this is (need to squint at CORE), but I plan--- to use it for backtracking only.------ TODO Using this instance tends to break to optimizer ;-) -- don't use it--- yet!--instance-  ( Monad m-  ) => ExtractValue m (DIM2 -> S.Stream m elm) where-  type Asor (DIM2 -> S.Stream m elm) = S.Stream m elm-  type Elem (DIM2 -> S.Stream m elm) = elm-  extractValue cnt ij z = error "this function is not well-defined for these streams"-  extractStream cnt stream = S.flatten mk step Unknown $ stream where-    mk (z:.k:.l:.j,as,vs) = do-      let strm = cnt (Z:.k:.l)-      return (z:.k:.l:.j,as:.strm,vs)-    step (idx,as:.strm,vs) = do-      isNull <- S.null strm-      if isNull-      then return $ S.Done-      else do hd <- S.head strm-              hd `seq` return $ S.Yield (idx,as:.strm,vs:.hd) (idx,as:.S.tail strm,vs)-  extractStreamLast cnt stream = S.flatten mk step Unknown $ stream where-    mk (z:.l:.j,as,vs) = do-      let strm = cnt (Z:.l:.j)-      return (z:.l:.j,as:.strm,vs)-    step (idx,as:.strm,vs) = do-      isNull <- S.null strm-      if isNull-      then return $ S.Done-      else do hd <- S.head strm-              hd `seq` return $ S.Yield (idx,as:.strm,vs:.hd) (idx,as:.S.tail strm,vs)-  {-# INLINE extractValue #-}-  {-# INLINE extractStream #-}-  {-# INLINE extractStreamLast #-}---- | Instance of boxed array with vector-valued cells. We assume that we want--- to store multiple results for each cell. If the intent is to store one--- scalar result, use the 'Scalar' wrapper.--instance-  ( PrimMonad m-  , Prim elm-  , VU.Unbox elm-  , PrimState m ~ s-  , DIM2 ~ sh-  ) => ExtractValue m (Z.MArr0 s sh (VU.Vector elm)) where-  type Asor (Z.MArr0 s sh (VU.Vector elm)) = Int-  type Elem (Z.MArr0 s sh (VU.Vector elm)) = elm-  extractValue cnt ij z = do-    x <- PA.readM cnt ij-    let y = x `VU.unsafeIndex` z-    y `seq` return y-  extractStream cnt stream = S.flatten mk step Unknown $ stream where-    mk (idx,as,vs) = return (idx,as:.0,vs)-    step (z:.k:.l:.j,as:.a,vs) = do-      x <- PA.readM cnt (Z:.k:.l)-      case (x VU.!? a) of-        Just v  -> v `seq` return $ S.Yield (z:.k:.l:.j,as:.a,vs:.v) (z:.k:.l:.j,as:.(a+1),vs)-        Nothing -> return $ S.Done-  extractStreamLast cnt stream = S.flatten mk step Unknown $ stream where-    mk (idx,as,vs) = return (idx,as:.0,vs)-    step (z:.l:.j,as:.a,vs) = do-      x <- PA.readM cnt (Z:.l:.j)-      case (x VU.!? a) of-        Just v  -> v `seq` return $ S.Yield (z:.l:.j,as:.a,vs:.v) (z:.l:.j,as:.(a+1),vs)-        Nothing -> return $ S.Done-  {-# INLINE extractValue #-}-  {-# INLINE extractStream #-}-  {-# INLINE extractStreamLast #-}---- | vector-based cells--instance-  ( Monad m-  , Prim elm-  , VU.Unbox elm-  , DIM2 ~ sh-  ) => ExtractValue m (Z.Arr0 sh (VU.Vector elm)) where-  type Asor (Z.Arr0 sh (VU.Vector elm)) = Int-  type Elem (Z.Arr0 sh (VU.Vector elm)) = elm-  extractValue cnt ij z = do-    let x = PA.index cnt ij-    let y = x `VU.unsafeIndex` z-    y `seq` return y-  extractStream cnt stream = S.flatten mk step Unknown $ stream where-    mk (idx,as,vs) = return (idx,as:.0,vs)-    step (z:.k:.l:.j,as:.a,vs) = do-      let x = PA.index cnt (Z:.k:.l)-      case (x VU.!? a) of-        Just v  -> v `seq` return $ S.Yield (z:.k:.l:.j,as:.a,vs:.v) (z:.k:.l:.j,as:.(a+1),vs)-        Nothing -> return $ S.Done-  extractStreamLast cnt stream = S.flatten mk step Unknown $ stream where-    mk (idx,as,vs) = return (idx,as:.0,vs)-    step (z:.l:.j,as:.a,vs) = do-      let x = PA.index cnt (Z:.l:.j)-      case (x VU.!? a) of-        Just v  -> v `seq` return $ S.Yield (z:.l:.j,as:.a,vs:.v) (z:.l:.j,as:.(a+1),vs)-        Nothing -> return $ S.Done-  {-# INLINE extractValue #-}-  {-# INLINE extractStream #-}-  {-# INLINE extractStreamLast #-}----- * Apply function 'f' with arguments on a stack 'x'.------ NOTE look at the end of this part for mkApply before writing instances by--- hand... ;-)--class Apply x where-  type Fun x :: *-  apply :: Fun x -> x--instance Apply (Z:.a -> res) where-  type Fun (Z:.a -> res) = a -> res-  apply fun (Z:.a) = fun a-  {-# INLINE apply #-}--instance Apply (Z:.a:.b -> res) where-  type Fun (Z:.a:.b -> res) = a->b -> res-  apply fun (Z:.a:.b) = fun a b-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c -> res) where-  type Fun (Z:.a:.b:.c -> res) = a->b->c -> res-  apply fun (Z:.a:.b:.c) = fun a b c-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d -> res) where-  type Fun (Z:.a:.b:.c:.d -> res) = a->b->c->d -> res-  apply fun (Z:.a:.b:.c:.d) = fun a b c d-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e -> res) where-  type Fun (Z:.a:.b:.c:.d:.e -> res) = a->b->c->d->e -> res-  apply fun (Z:.a:.b:.c:.d:.e) = fun a b c d e-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f -> res) = a->b->c->d->e->f -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f) = fun a b c d e f-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g -> res) = a->b->c->d->e->f->g -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g) = fun a b c d e f g-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h -> res) = a->b->c->d->e->f->g->h -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h) = fun a b c d e f g h-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) = a->b->c->d->e->f->g->h->i -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i) = fun a b c d e f g h i-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) = a->b->c->d->e->f->g->h->i->j -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j) = fun a b c d e f g h i j-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) = a->b->c->d->e->f->g->h->i->j->k -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k) = fun a b c d e f g h i j k-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) = a->b->c->d->e->f->g->h->i->j->k->l -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l) = fun a b c d e f g h i j k l-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m) = fun a b c d e f g h i j k l m-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n) = fun a b c d e f g h i j k l m n-  {-# INLINE apply #-}--instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) where-  type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n->o -> res-  apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o) = fun a b c d e f g h i j k l m n o-  {-# INLINE apply #-}--{--mkApply to = do-  let xs    = ['a' .. to]-  let args  = concat . (":.":) . intersperse ":." . map (:[]) $ xs-  let arga  = concat . intersperse "->" . map (:[]) $ xs-  let args' = intersperse ' ' xs-  printf "instance Apply (Z%s -> res) where\n" args-  printf "  type Fun (Z%s -> res) = %s -> res\n" args arga-  printf "  apply fun (Z%s) = fun %s\n" args args'-  printf "  {-# INLINE apply #-}\n"--}------ * helper stuff--data Box mk step xs ys = Box mk step xs ys--type Idx3 z = z:.Int:.Int:.Int--type Idx2 z = z:.Int:.Int------ * wrappers for functions instead of arrays as arguments. It can be much--- cheaper in terms of writing code to just provide a function @DIM2 -> Scalar--- a@ instead of writing instances for your data structure.--newtype Scalar a = Scalar {unScalar :: a}--newtype ScalarM a = ScalarM {unScalarM :: a}--newtype Vect a = Vect {unVect :: a}--newtype VectM a = VectM {unVectM :: a}
+ ADP/Fusion/Multi.hs view
@@ -0,0 +1,70 @@+{-# 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 view
@@ -0,0 +1,112 @@+{-# 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 view
@@ -0,0 +1,46 @@+{-# 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:.())))+    . 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 view
@@ -0,0 +1,101 @@+{-# 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 view
@@ -0,0 +1,52 @@+{-# 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 view
@@ -0,0 +1,58 @@+{-# 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 view
@@ -1,185 +1,531 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE PackageImports #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} --- | QuickCheck properties for a number of ADPfusion combinators. Each test is--- once written using ADPfusion and once using list comprehensions. Typing--- @allProps@ in ghci will run all tests, prefixed @prop_@ with a thousand--- tests each.- module ADP.Fusion.QuickCheck where -import Data.List-import Data.Vector.Fusion.Stream.Size-import Data.Vector.Fusion.Util+import 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 "PrimitiveArray" Data.Array.Repa.Index+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.QuickCheck.Arbitrary-import qualified ADP.Fusion as F-import qualified ADP.Fusion.Monadic as M-import qualified ADP.Fusion.Monadic.Internal as F+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). -options = stdArgs {maxSuccess = 1000}+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] -customCheck = quickCheckWithResult options+-- | Two regions next to each other. -allProps = $forAllProperties customCheck+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]] --- * Some definitions:------ @O@ means one--- @M@ means many--- @P@ means one or more--- @ML_x_y@ is for a makeLeftCombinator with boundaries x and y+-- | Three sized regions (with smaller subword sizes only) --- ** @xs -~+ ys@, size @xs@ = 1, size @ys@ >= 1.+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] -fOP (i,j) = S.toList $ (,) F.<<< fRegion F.-~+ fRegion F.... id $ Z:.i:.j+-- | Single-character parser. -lOP (i,j) = [ ((i,i+1), (i+1,j)) | i+1<=j-1 ]+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] -prop_OP = fOP === lOP+-- | 2x Single-character parser. --- ** @xs -~~ ys -~~ zs@, size @xs@ = 1, size @ys@ = 1, size @zs@ >= 0.+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] -fOOP (i,j) = S.toList $ (,,) F.<<< fRegion F.-~~ fRegion F.-~~ fRegion F.... id $ Z:.i:.j+-- ** Single character plus peeking -lOOP (i,j) = [ ( (i,i+1), (i+1,i+2), (i+2,j) ) | i+2<=j ]+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_OOP = fOOP === lOOP+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] --- ** @xs +~- ys@, size @xs@ >= 1, size @ys@ = 1.+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] -fPO (i,j) = S.toList $ (,) F.<<< fRegion F.+~- fRegion F.... id $ Z:.i:.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] -lPO (i,j) = [ ( (i,j-1), (j-1,j) ) | i+1<=j-1 ]+-- | 2x Single-character parser bracketing a single region. -prop_PO (Small i, Small j) = fPO (i,j) == lPO (i,j)+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] --- ** @xs -~+ ys +~- zs@, size @xs@ = 1, size @ys@ >= 1, size @zs@ = 1. This is--- a "hairpin" in RNA bioinformatics.+-- | 2x Single-character parser bracketing regions. -fOPO (i,j) = S.toList $ (,,) F.<<< fRegion F.-~+ fRegion F.+~- fRegion F.... id $ Z:.i:.j+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]] -lOPO (i,j) = [ ( (i,i+1), (i+1,j-1), (j-1,j) ) | i+2<=j, i+1<j-1 ]+-- | complex behaviour with characters and regions -prop_OPO = fOPO === lOPO+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] ] --- ** The central region is non-empty, with two size-1 regions on each side.--- Will create @O(n)@ candidates, which will all fail, except for the last one--- (if @j-i@ is large enough).+-- | Interior-loop like structures. -fOOPOOslow (i,j) = S.toList $ (,,,,) F.<<< fRegion F.-~+ fRegion F.-~+ fRegion F.+~+ fRegion F.-~- fRegion F.... id $ Z:.i:.j+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+       ] -lOOPOO (i,j) = [ ( (i,i+1), (i+1,i+2), (i+2,j-2), (j-2,j-1), (j-1,j) ) | i+4<=j, i+2<j-2 ]+prop_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_OOPOOslow = fOOPOOslow === lOOPOO+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+       ] --- ** The above test can be sped up by the use of the @+~--@ combinator. It--- fixes the left and right side, by allowing only exactly size two on its--- right. Each combinator here will 'Yield' exactly once, then be 'Done'.+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+       ] -fOOPOOfast (i,j) = S.toList $ (,,,,) F.<<< fRegion F.-~+ fRegion F.-~+ fRegion F.+~-- fRegion F.-~- fRegion F.... id $ Z:.i:.j+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+       ] -prop_OOPOOfast = fOOPOOfast === lOOPOO+-- | A single mutable table should return one result. --- ** A complex right-hand side which was problematic in 0.0.0.3 of ADPfusion.--- In original ADP @base -~~ weak ~~- base +~+ string@ we want the @base@ parts--- to have size 1, @weak@ of any size, and @string@ to be non-empty. In--- ADPfusion @as -~+ bs@ means that @as@ has size one, @bs@ size 1 or more.+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 -fOPOP (i,j) = S.toList $ (,,,) F.<<< fRegion F.-~+ fRegion F.+~+ fRegion F.-~+ fRegion F.... id $ Z:.i:.j+-- | table, then character. -lOPOP (i,j) = [ ( (i,i+1), (i+1,k), (k,k+1), (k+1,j) ) | k <- [i+1 .. j-2], i+1<k, k+1<j ]+prop_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 -prop_OPOP = fOPOP === lOPOP+-- | Character, then table. --- ** One more of those complex right-hand sides. This one is already rather--- complicated. We have @one -~+ one -~+ many +~+ one -~~ one -~+ plus@ where--- @one@ has size 1, many has size 0 to many, plus has size 1 to many. The last--- combinator @-~+@ again short-curcuits by being 'Done' once the left-hand--- side is larger than one.+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 -fOOPOOP (i,j) = S.toList $ (,,,,,) F.<<< fRegion F.-~+ fRegion F.-~+ fRegion F.+~+ fRegion F.-~~ fRegion F.-~+ fRegion F.... id $ Z:.i:.j+-- | Two mutable tables. Basically like Region's. -lOOPOOP (i,j) = [ ( (i,i+1), (i+1,i+2), (i+2,k), (k,k+1), (k+1,k+2), (k+2,j) ) | k <- [i+2 .. j-3], i+2<k, k+2<j ]+prop_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 -prop_OOPOOP = fOOPOOP === lOOPOOP+-- | Just to make it more interesting, sprinkle in some 'Chr' symbols. --- ** We now introduce two independently moving indices and size zero regions.+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 -fMMM (i,j) = S.toList $ (,,) F.<<< fRegion F.~~~ fRegion F.~~~ fRegion F.... id $ Z:.i:.j+-- | And now with non-empty tables. -lMMM (i,j) = [ ( (i,k), (k,l), (l,j) ) | k <- [i..j], l<-[k..j] ]+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 -prop_MMM = fMMM === lMMM+{-+ - Currently not allowing 0-dim multi-tapes. --- ** Three independent regions, each one enclosed by two size-1 regions.--- Compile-time hog.+prop_Tt ix@Z = zs == ls where+  zs = id <<< T ... S.toList $ ix+  ls = [ Z ]+-} -fOPOOPOOPO (i,j) = S.toList $ (,,,,,,,,) F.<<< fRegion F.-~+ fRegion F.+~+ fRegion F.-~+-                                          {--} fRegion F.-~+ fRegion F.+~+ fRegion F.-~+-                                          {--} fRegion F.-~+ fRegion F.+~- fRegion F.... id $ Z:.i:.j+-- ** -lOPOOPOOPO (i,j) = [ ( (i,i+1), (i+1,k), (k,k+1), {--} (k+1,k+2), (k+2,l), (l,l+1), {--} (l+1,l+2), (l+2,j-1), (j-1,j) )-                   | k<-[i+1 .. j-5], l<-[k+2 .. j-3], i+1<k, k+2<l, l+2<j-1 ]+prop_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_OPOOPOOPO = fOPOOPOOPO === lOPOOPOOPO+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 ] --- ** Two non-empty regions, the right one with single-size regions around it.--- (sorry about the name)+-- ** -fPOPO (i,j) = S.toList $ (,,,) F.<<< fRegion F.+~+ fRegion F.-~+ fRegion F.+~- fRegion F.... id $ Z:.i:.j+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 ] -lPOPO (i,j) = [ ( (i,k), (k,k+1), (k+1,j-1), (j-1,j) ) | k <- [i+1 .. j-3] ]+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_POPO (Small i, Small j) = fPOPO (i,j) == lPOPO (i,j)+-- ** --- ** Sanity-checking special constraints.+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 -fOO (i,j) = S.toList $ (,) F.<<< fRegion F.-~- fRegion F.... id $ Z:.i:.j+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 -lOO (i,j) = [ ( (i,i+1), (j-1,j) ) | i+2==j ]+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_OO (Small i, Small j) = fOO (i,j) == lOO (i,j)+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 --- ** Two non-empty regions+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 -fPP (i,j) = S.toList $ (,) F.<<< fRegion F.+~+ fRegion F.... id $ Z:.i:.j+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 -lPP (i,j) = [ ( (i,k), (k,j) ) | k<-[i+1 .. j-1] ]+-- * working on 'PointL's -prop_PP (Small i, Small j) = fPP (i,j) == lPP (i,j)+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 ] --- ** using 'makeLeft_MinRight'+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 ] -fML_1_4M (i,j) = S.toList $ (,) F.<<< fRegion `ml_1_4` fRegion F.... id $ Z:.i:.j where-  infixl 9 `ml_1_4`-  ml_1_4 = F.makeLeft_MinRight (1,4) 0+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 -lML_1_4M (i,j) = [ ( (i,k), (k,j) ) | k <- [i+1 .. min (i+4) j] ]+{-+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 ] -prop_ML_1_4M = fML_1_4M === lML_1_4M+-- deriving instance Show (Elm (None :. Term (T :. Chr Int)) (Z :. Point)) --- ** using 'makeLeft_MinRight' and 'makeMinLeft_Right'. Inner regions fixed to--- be non-empty.+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) -fML_1_4MMR_1_4 (i,j) = S.toList $ (,,) F.<<< fRegion `ml_1_4` fRegion `mr_1_4` fRegion F.... id $ Z:.i:.j where-  infixl 9 `ml_1_4`-  ml_1_4 = F.makeLeft_MinRight (1,4) 1-  infixl 9 `mr_1_4`-  mr_1_4 = F.makeMinLeft_Right 1 (1,4)+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) -lML_1_4MMR_1_4 (i,j) = [ ( (i,k), (k,l), (l,j) ) | k<-[i+1 .. min (i+4) j], l <- [max k (j-4) .. j-1], k<l ]+{-+prop_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_ML_1_4MMR_1_4 = fML_1_4MMR_1_4 === lML_1_4MMR_1_4+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/Arbitrary.hs 
@@ -1,39 +0,0 @@-{-# LANGUAGE PackageImports #-}--module ADP.Fusion.QuickCheck.Arbitrary where--import Test.QuickCheck-import Test.QuickCheck.All--import "PrimitiveArray" Data.Array.Repa.Index--import qualified ADP.Fusion.Monadic.Internal as F--lAchar (i,j) = [j | i+1 == j]---- |------ NOTE we have to add 1 to the i-index. Legacy ADP reads chars from an input--- array starting at "1", while ADPfusion starts arrays at "0".--fAchar :: DIM2 -> (F.Scalar Int)-fAchar (Z:.i:.j) = F.Scalar $ (i+1)--fRegion :: DIM2 -> (F.Scalar (Int,Int))-fRegion (Z:.i:.j) = F.Scalar $ (i,j)---- * quickcheck stuff--newtype Small = Small Int-  deriving (Show)--instance Arbitrary Small where-  arbitrary = Small `fmap` choose (0,50)-  shrink (Small x)-    | x>0       = [Small $ x-1]-    | otherwise = []--small x = x>=0 && x <=50--(===) f g (Small i, Small j) = f (i,j) == g (i,j)-
+ ADP/Fusion/Region.hs view
@@ -0,0 +1,148 @@+{-# 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/Table.hs view
@@ -0,0 +1,563 @@+{-# 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 #-}+++-}++
ADPfusion.cabal view
@@ -1,7 +1,7 @@ name:           ADPfusion-version:        0.1.0.0-author:         Christian Hoener zu Siederdissen, 2011-2012-copyright:      Christian Hoener zu Siederdissen, 2011-2012+version:        0.2.0.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@@ -35,12 +35,13 @@                 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"+                characters. "C" is an implementation (@./C/@ directory) in "C"                 using "gcc -O3". "ADP" is the original ADP approach (see link                 above), while "GAPC" uses the "GAP" language                 (<http://gapc.eu/>).-                <<https://github.com/choener/ADPfusion/gaplike-performance.png>>                 .+                <<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@@ -57,116 +58,65 @@                 that performs backtracking, or samples structures                 stochastically, among others things.                 .-                This version is still highly experimental and makes use of-                multiple recent improvements in GHC. This is particularly true-                for the monadic interface.                 .                 .-                .-                Newley added are the ADP.Fusion.GAPlike modules. These allow-                for writing grammars with only one (non)-terminal combinator.-                The logic for index manipulation is now moved into data types-                for terminals and non-terminals.-                .-                While this change leads to slightly more complicated instances-                for each new terminal or non-terminal, the overall code-                complexity is significantly lower. In addition, Constraint-                Kinds make complex interactions between (non)-terminals-                possible, while still managing to produce high-performance-                code.-                .-                The final goal would, of course, be to have no inter-terminal-                combinators anymore.-                .-                * GHC 7.6, LLVM, and -fnew-codegen recommended: gives a speedup-                  of x2 for GAPcriterion-                .-                .-                .-                .-                Long term goals: Outer indices with more than two dimensions,-                specialized table design, a combinator library, a library for-                computational biology.-                .                 Two algorithms from the realm of computational biology are                 provided as examples on how to write dynamic programming                 algorithms using this library:                 <http://hackage.haskell.org/package/Nussinov78> and                 <http://hackage.haskell.org/package/RNAFold>.-                .-                Changes since 0.0.1.2:-                .-                * require GHC 7.6-                .-                * ADP.Fusion.GAPlike module for (almost) combinator-less grammars-                .-                * ConstraintKinds for constrained parsers in GAPlike.-                .-                .-                .-                Changes since 0.0.1.0:-                .-                * compatibility with GHC 7.4-                .-                * note: still using fundeps & and TFs together. The TF-only version does not optimize as well (I know why but not yet how to fix it)-                .-                .-                .-                Using the new code generator?-                .-                The new code generator is not official yet, but I recommend trying it out:-                <<https://github.com/choener/ADPfusion/gaplike-newcodegen.png>>    Extra-Source-Files:   README.md-  ADP/Fusion/QuickCheck.hs-  ADP/Fusion/QuickCheck/Arbitrary.hs  -Flag devel-  description: build criterion benchmarks and pull in QuickCheck-  default: False - library   build-depends:     base >= 4 && < 5,-    ghc-prim,-    primitive      == 0.5.*   ,-    vector         == 0.10.*  ,-    PrimitiveArray == 0.4.*+    deepseq        >= 1.3     ,+    ghc-prim                  ,+    primitive      >= 0.5     ,+    PrimitiveArray == 0.5.2.* ,+    QuickCheck     >= 2.5     ,+    repa           >= 3.2     ,+    strict         >= 0.3.2   ,+    template-haskell          ,+    transformers              ,+    vector         >= 0.10   exposed-modules:     ADP.Fusion-    ADP.Fusion.Monadic-    ADP.Fusion.Monadic.Internal-    ADP.Fusion.GAPlike+    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    ghc-options:     -O2 -funbox-strict-fields -executable GAPcriterion-  buildable:-    False-  if flag(devel)-    buildable:-      True-    build-depends:-      criterion  == 0.6.* ,-      QuickCheck == 2.5-  other-modules:-    ADP.Fusion.GAPlike.DevelCommon-    ADP.Fusion.GAPlike.Criterion-    ADP.Fusion.GAPlike.QuickCheck+executable NeedlemanWunsch   main-is:-    Tests/GAPcriterion.hs+    ADP/Fusion/Examples/TwoDim.hs   ghc-options:-    -fllvm -O2 -funbox-strict-fields -optlo-O3 -optlo-std-compile-opts-  if impl(GHC > 7.4)-    ghc-options:-      -fnew-codegen-+    -Odph+    -funbox-strict-fields+    -funfolding-use-threshold1000+    -funfolding-keeness-factor1000+    -fllvm+    -optlo-O3 -optlo-std-compile-opts+    -fllvm-tbaa  source-repository head   type: git
− Tests/GAPcriterion.hs 
@@ -1,9 +0,0 @@--module Main where--import ADP.Fusion.GAPlike2.Criterion----main = criterionMain-