ADPfusion 0.5.2.0 → 0.5.2.2

raw patch · 14 files changed

+293/−141 lines, 14 filesdep +tastydep +tasty-quickcheckdep +tasty-thdep −test-frameworkdep −test-framework-quickcheck2dep −test-framework-thdep ~DPutilsdep ~PrimitiveArraydep ~criterionPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: tasty, tasty-quickcheck, tasty-th

Dependencies removed: test-framework, test-framework-quickcheck2, test-framework-th

Dependency ranges changed: DPutils, PrimitiveArray, criterion, fmlist, primitive

API changes (from Hackage documentation)

Files

• ADP/Fusion/Core/Classes.hs +10/−2
• ADP/Fusion/SynVar/Array.hs +5/−4
• ADP/Fusion/SynVar/Array/Type.hs +5/−4
• ADP/Fusion/SynVar/Fill.hs +161/−59
• ADP/Fusion/SynVar/Indices/Classes.hs +8/−8
• ADP/Fusion/SynVar/Indices/Point.hs +10/−10
• ADP/Fusion/SynVar/Indices/Unit.hs +8/−8
• ADP/Fusion/SynVar/Recursive/Type.hs +2/−2
• ADP/Fusion/Term/Edge/Type.hs +16/−8
• ADPfusion.cabal +48/−30
• changelog.md +12/−0
• src/NeedlemanWunsch.hs +4/−2
• tests/QuickCheck/Point.hs +2/−2
• tests/properties.hs +2/−2

@@ -20,13 +20,21 @@   deriving (Show)  data InsideContext s-  = IStatic   s-  | IVariable s+  = IStatic   {iGetContext :: s}+  | IVariable {iGetContext :: s}   deriving (Show)  data ComplementContext   = Complemented   deriving (Show)++-- | Needed for structures that have long-range interactions and "expand",+-- like sets around edge boundaries: @set <edge> set@. requires the sets to+-- be connected.++data ExtComplementContext s+  = CStatic s+  | CVariable s  class RuleContext i where   type Context i :: *

@@ -42,8 +42,9 @@   -> Stream m (Elm (ls :!: TwITbl m arr c u x) i) iTblStream (ls :!: TW (ITbl _ _ c t) _) vs us is   = map (\(s,tt,ii') -> ElmITbl (t!tt) ii' s)-  . addIndexDense1 c vs us is+  . addIndexDense1 c vs lb ub us is   $ mkStream ls (tableStaticVar (Proxy :: Proxy u) c vs is) us (tableStreamIndex (Proxy :: Proxy u) c vs is)+  where (lb,ub) = bounds t {-# Inline iTblStream #-}  -- | General function for @Backtrack ITbl@s with skalar indices.@@ -56,10 +57,10 @@   -> i   -> Stream mB (Elm (ls :!: TwITblBt arr c u x mF mB r) i) btITblStream (ls :!: TW (BtITbl c t) bt) vs us is-    = mapM (\(s,tt,ii') -> bt us' tt >>= \ ~bb -> return $ ElmBtITbl (t!tt) bb ii' s)-    . addIndexDense1 c vs us is+    = mapM (\(s,tt,ii') -> bt ub tt >>= \ ~bb -> return $ ElmBtITbl (t!tt) bb ii' s)+    . addIndexDense1 c vs lb ub us is     $ mkStream ls (tableStaticVar (Proxy :: Proxy u) c vs is) us (tableStreamIndex (Proxy :: Proxy u) c vs is)-    where !us' = snd $ bounds t+    where (lb,ub) = bounds t {-# Inline btITblStream #-}  

@@ -124,8 +124,9 @@   ) => MkStream m (ls :!: TwITbl m arr (cs:.c) (us:.u) x) (is:.i) where   mkStream (ls :!: TW (ITbl _ _ c t) _) vs us is     = map (\(s,tt,ii') -> ElmITbl (t!tt) ii' s)-    . addIndexDense c vs us is+    . addIndexDense c vs lb ub us is     $ mkStream ls (tableStaticVar (Proxy :: Proxy (us:.u)) c vs is) us (tableStreamIndex (Proxy :: Proxy (us:.u)) c vs is)+    where (lb,ub) = bounds t   {-# Inline mkStream #-}  instance@@ -137,9 +138,9 @@   , PrimArrayOps arr (us:.u) x   ) => MkStream mB (ls :!: TwITblBt arr (cs:.c) (us:.u) x mF mB r) (is:.i) where   mkStream (ls :!: TW (BtITbl c t) bt) vs us is-    = mapM (\(s,tt,ii') -> bt us' tt >>= \ ~bb -> return $ ElmBtITbl (t!tt) bb ii' s)-    . addIndexDense c vs us is+    = mapM (\(s,tt,ii') -> bt ub tt >>= \ ~bb -> return $ ElmBtITbl (t!tt) bb ii' s)+    . addIndexDense c vs lb ub us is     $ mkStream ls (tableStaticVar (Proxy :: Proxy (us:.u)) c vs is) us (tableStreamIndex (Proxy :: Proxy (us:.u)) c vs is)-    where !us' = snd $ bounds t+    where (lb,ub) = bounds t   {-# Inline mkStream #-} 

@@ -1,6 +1,7 @@  module ADP.Fusion.SynVar.Fill where +import           Control.Monad import           Control.Monad.Morph (hoist, MFunctor (..)) import           Control.Monad.Primitive (PrimMonad (..)) import           Control.Monad.ST@@ -10,9 +11,15 @@ import qualified Data.Vector.Fusion.Stream.Monadic as SM import           System.IO.Unsafe import           Control.Monad (when,forM_)-import           Data.List (nub,sort)+import           Data.List (nub,sort,group) import qualified Data.Vector.Unboxed as VU import           Data.Proxy+import qualified GHC.Generics as G+import qualified Data.Typeable as T+import qualified Data.Data as D+import           Data.Dynamic+import           Data.Type.Equality+import qualified Data.List as L  import           Data.PrimitiveArray @@ -24,41 +31,6 @@   --- * Specialized table-filling wrapper for 'MTbl's------ TODO table-filling does /not/ work for single-dimensional stuff---- | Run and freeze 'MTbl's. Since actually running the table-filling part--- is usually the last thing to do, we can freeze as well.--runFreezeMTbls ts = do-    unsafeRunFillTables $ expose ts-    freezeTables        $ onlyTables ts-{-# INLINE runFreezeMTbls #-}------ * Expose inner mutable tables---- | Expose the actual mutable table with an 'MTbl'. (Should be temporary--- until 'MTbl's get a more thorough treatment for auto-filling.--class ExposeTables t where-    type TableFun t   :: *-    type OnlyTables t :: *-    expose     :: t -> TableFun t-    onlyTables :: t -> OnlyTables t--instance ExposeTables Z where-    type TableFun Z   = Z-    type OnlyTables Z = Z-    expose     Z = Z-    onlyTables Z = Z-    {-# INLINE expose #-}-    {-# INLINE onlyTables #-}--- -- | A vanilla context-free grammar  data CFG@@ -78,13 +50,13 @@ -- /not/ want to have this state influence forward results, unless that can -- be made deterministic, or we'll break Bellman) -class MutateCell (h :: *) (s :: *) (im :: * -> *) (om :: * -> *) i where-  mutateCell :: Proxy h -> Int -> Int -> (forall a . im a -> om a) -> s -> i -> i -> om ()+class MutateCell (h :: *) (s :: *) (im :: * -> *) i where+  mutateCell :: (Monad om, PrimMonad om) => Proxy h -> Int -> Int -> (forall a . im a -> om a) -> s -> i -> i -> om ()  -- | -class MutateTables (h :: *) (s :: *) (im :: * -> *) (om :: * -> *) where-  mutateTables :: Proxy h -> (forall a . im a -> om a) -> s -> om s+class MutateTables (h :: *) (s :: *) (im :: * -> *) where+  mutateTables :: (Monad om, PrimMonad om) => Proxy h -> (forall a . im a -> om a) -> s -> om s  class TableOrder (s :: *) where   tableLittleOrder :: s -> [Int]@@ -113,15 +85,14 @@ -- ** individual instances for filling a *single cell*  instance-  ( Monad om-  ) => MutateCell p Z im om i where+  (+  ) => MutateCell p Z im i where   mutateCell _ _ _ _ Z _ _ = return ()   {-# INLINE mutateCell #-}  instance-  ( MutateCell CFG ts im om i-  , PrimMonad om-  ) => MutateCell CFG (ts:.TwIRec im c i x) im om i where+  ( MutateCell CFG ts im i+  ) => MutateCell CFG (ts:.TwIRec im c i x) im i where   mutateCell h bo lo mrph (ts:._) lu i = do     mutateCell h bo lo mrph ts lu i   {-# Inline mutateCell #-}@@ -129,9 +100,8 @@ instance   ( PrimArrayOps  arr i x   , MPrimArrayOps arr i x-  , MutateCell CFG ts im om i-  , PrimMonad om-  ) => MutateCell CFG (ts:.TwITbl im arr c i x) im om i where+  , MutateCell CFG ts im i+  ) => MutateCell CFG (ts:.TwITbl im arr c i x) im i where   mutateCell h bo lo mrph (ts:.TW (ITbl tbo tlo c arr) f) lu i = do     mutateCell h bo lo mrph ts lu i     when (bo==tbo && lo==tlo) $ do@@ -145,9 +115,8 @@ instance   ( PrimArrayOps  arr ZS2 x   , MPrimArrayOps arr ZS2 x-  , MutateCell MonotoneMCFG ts im om ZS2-  , PrimMonad om-  ) => MutateCell MonotoneMCFG (ts:.TwITbl im arr c ZS2 x) im om ZS2 where+  , MutateCell MonotoneMCFG ts im ZS2+  ) => MutateCell MonotoneMCFG (ts:.TwITbl im arr c ZS2 x) im ZS2 where   mutateCell h bo lo mrph (ts:.TW (ITbl tbo tlo c arr) f) lu iklj@(Z:.Subword (i:.k):.Subword(l:.j)) = do     mutateCell h bo lo mrph ts lu iklj     when (bo==tbo && lo==tlo && k<=l) $ do@@ -159,9 +128,8 @@ instance   ( PrimArrayOps arr (Subword I) x   , MPrimArrayOps arr (Subword I) x-  , MutateCell h ts im om (Z:.Subword I:.Subword I)-  , PrimMonad om-  ) => MutateCell h (ts:.TwITbl im arr c (Subword I) x) im om (Z:.Subword I:.Subword I) where+  , MutateCell h ts im (Z:.Subword I:.Subword I)+  ) => MutateCell h (ts:.TwITbl im arr c (Subword I) x) im (Z:.Subword I:.Subword I) where   mutateCell h bo lo mrph (ts:.TW (ITbl tbo tlo c arr) f) lu@(Z:.Subword (l:._):.Subword(_:.u)) ix@(Z:.Subword (i1:.j1):.Subword (i2:.j2)) = do     mutateCell h bo lo mrph ts lu ix     when (bo==tbo && lo==tlo && i1==i2 && j1==j2) $ do@@ -178,13 +146,12 @@ -- bounds  instance-  ( Monad om-  , MutateCell h (ts:.TwITbl im arr c i x) im om i+  ( MutateCell h (ts:.TwITbl im arr c i x) im i   , PrimArrayOps arr i x   , Show i   , IndexStream i   , TableOrder (ts:.TwITbl im arr c i x)-  ) => MutateTables h (ts:.TwITbl im arr c i x) im om where+  ) => MutateTables h (ts:.TwITbl im arr c i x) im where   mutateTables h mrph tt@(_:.TW (ITbl _ _ _ arr) _) = do     let (from,to) = bounds arr     -- TODO (1) find the set of orders for the synvars@@ -195,6 +162,9 @@         1 -> let lo = VU.head tlos              in  flip SM.mapM_ (streamUp from to) $ \k ->                   mutateCell h bo lo (inline mrph) tt to k+        -- TODO each big-order group should be allowed to have its own sets+        -- of bounds. within a group, it doesn't make a lot of sense to+        -- have different bounds? Is there a use case for that even?         _ -> flip SM.mapM_ (streamUp from to) $ \k ->               VU.forM_ tlos $ \lo ->                 mutateCell h bo lo (inline mrph) tt to k@@ -205,13 +175,145 @@ -- -- TODO generalize to @MonadIO@ or @MonadPrim@. -mutateTablesDefault :: MutateTables CFG t Id IO => t -> t+mutateTablesDefault :: MutateTables CFG t Id => t -> t mutateTablesDefault t = unsafePerformIO $ mutateTables (Proxy :: Proxy CFG) (return . unId) t {-# INLINE mutateTablesDefault #-}  -- | Mutate tables, but observe certain hints. We use this for monotone -- mcfgs for now. -mutateTablesWithHints :: MutateTables h t Id IO => Proxy h -> t -> t+mutateTablesWithHints :: MutateTables h t Id => Proxy h -> t -> t mutateTablesWithHints h t = unsafePerformIO $ mutateTables h (return . unId) t+++++++mutateTablesST t = runST $ mutateTablesNew t+{-# Inline mutateTablesST #-}++-- | +--+-- TODO new way how to do table filling. Because we now have heterogeneous+-- tables (i) group tables by @big order@ into different bins; (ii) check+-- that each bin has the same bounds (needed? -- could we have+-- smaller-sized tables once in a while); (iii) run each bin one after the+-- other+--+-- TODO measure performance penalty, if any. We might need liberal+-- INLINEABLE, and specialization. On the other hand, we can do the+-- freeze/unfreeze outside of table filling.++mutateTablesNew+  :: forall t m .+     ( TableOrder t+     , TSBO t+     , Monad m+     , PrimMonad m+     )+  => t+  -> m t+mutateTablesNew ts = do+  -- sort the tables according to [bigorder,type,littleorder]. For each+  -- @bigorder@, we should have only one @type@ and can therefor do the+  -- following (i) get subset of the @ts@, (ii) use outermost of @ts@ to+  -- get bounds, (iii) fill these tables+  let !tbos = VU.fromList . nub . sort $ tableBigOrder ts+  let ds = L.sort $ asDyn ts+  let goM :: (Monad m, PrimMonad m) => [Q] -> m ()+      goM [] = return ()+      goM xs = do+        ys <- fillWithDyn xs ts+        if null ys+          then return ()+          else goM ys+      {-# Inlinable goM #-}+  goM ds+  return ts+{-# Inline mutateTablesNew #-}++data Q = Q+  { qBigOrder     :: Int+  , qLittleOrder  :: Int+  , qTypeRep      :: T.TypeRep+  , qObject       :: Dynamic+  }+  deriving (Show)++instance Eq Q where+  Q bo1 lo1 tr1 _ == Q bo2 lo2 tr2 _ = (bo1,tr1,lo1) == (bo2,tr2,lo2)++instance Ord Q where+  Q bo1 lo1 tr1 _ `compare` Q bo2 lo2 tr2 _ = (bo1,tr1,lo1) `compare` (bo2,tr2,lo2)++-- | Find the outermost table that has a certain big order and then fill+-- from there.++class TSBO t where+  asDyn :: t -> [Q]+  fillWithDyn :: (Monad m, PrimMonad m) => [Q] -> t -> m [Q]++instance TSBO Z where+  asDyn Z = []+  fillWithDyn qs Z = return qs+  {-# Inlinable asDyn #-}+  {-# Inline fillWithDyn #-}++instance+ ( TSBO ts+ , Typeable arr+ , Typeable c+ , Typeable i+ , Typeable x+ , PrimArrayOps arr i x+ , MPrimArrayOps arr i x+ , IndexStream i+ ) => TSBO (ts:.TwITbl Id arr c i x) where+  asDyn (ts:.t@(TW (ITbl bo lo _ _) _)) = Q bo lo (T.typeOf t) (toDyn t) : asDyn ts+  fillWithDyn qs (ts:.t@(TW (ITbl bo lo _ arr) f)) = do+    let (from,to) = bounds arr+    -- @hs@ are all tables that can be filled here+    -- @ns@ are all tables we can't fill and need to process further down+    -- the line+    let (hs,ns) = L.span (\Q{..} -> qBigOrder == bo && qTypeRep == T.typeOf t) qs+    if null hs+      then fillWithDyn qs ts+      else do+        let ms = Prelude.map concrete hs+            concrete  = (maybe (error "fromDynamic should not fail!")+                         (\x -> x `asTypeOf` t)+                        . fromDynamic . qObject)+        -- We have a single table and should short-circuit here+        --+        -- TODO we should specialize for tables of lengh @1..k@ for some+        -- small k. For @1@ and Needleman-Wunsch, we have a very nice @1.8@+        -- seconds down to @1.25@ seconds. :-)+        case (length ms) of+          1 -> do marr <- unsafeThaw arr+                  flip SM.mapM_ (streamUp from to) $ \k -> do+                    -- TODO @inline mrph@ ...+                    z <- (return . unId) $ f to k+                    writeM marr k z+        -- We have more than one table in will work over the list of tables+          _ -> do marrfs <- Prelude.mapM (\(TW (ITbl _ _ _ arr) f) -> unsafeThaw arr >>= \marr -> return (marr,f)) ms+                  flip SM.mapM_ (streamUp from to) $ \k ->+                    forM_ marrfs $ \(marr,f) -> do+                      z <- (return . unId) $ f to k+                      writeM marr k z+        -- traceShow (hs,length ms) $+        return ns+  {-# Inline fillWithDyn #-}++-- We don't need to capture @IRec@ tables as no table-filling takes place+-- for those tables. @asDyn@ therefore just collects on the remaining @ts@,+-- while @fillWithDyn@ hands of to the next possible table.++instance+  ( TSBO ts+  ) => TSBO (ts:.TwIRec Id c i x) where+  asDyn (ts:.t@(TW (IRec _ _ _) _)) = asDyn ts+  fillWithDyn qs (ts:._) = fillWithDyn qs ts+  {-# Inlinable asDyn #-}+  {-# Inline fillWithDyn #-} 

@@ -25,10 +25,10 @@ class AddIndexDense s u c i where   addIndexDenseGo     :: (Monad m)-    => c -> Context i -> i -> i -> Stream m (SvState s a Z Z) -> Stream m (SvState s a u i)+    => c -> Context i -> u -> u -> i -> i -> Stream m (SvState s a Z Z) -> Stream m (SvState s a u i)  instance AddIndexDense a Z Z Z where-  addIndexDenseGo _ _ _ _ = id+  addIndexDenseGo _ _ _ _ _ _ = id   {-# Inline addIndexDenseGo #-}  -- | @SvState@ holds the state that is currently being built up by@@ -53,8 +53,8 @@      , s ~ Elm x0 i0      , Element x0 i0      )-  => c -> Context i -> i -> i -> Stream m s -> Stream m (s,u,RunningIndex i)-addIndexDense t c u i = map (\(SvS s z i') -> (s,z,i')) . addIndexDenseGo t c u i . map (\s -> (SvS s Z RiZ))+  => c -> Context i -> u -> u -> i -> i -> Stream m s -> Stream m (s,u,RunningIndex i)+addIndexDense t c lb ub u i = map (\(SvS s z i') -> (s,z,i')) . addIndexDenseGo t c lb ub u i . map (\s -> (SvS s Z RiZ)) {-# Inline addIndexDense #-}  -- | In case of 1-dim tables, we wrap the index creation in a multi-dim@@ -68,10 +68,10 @@      , s ~ Elm x0 a      , Element x0 a      )-  => c -> Context i -> i -> i -> Stream m s -> Stream m (s,u,RunningIndex i)-addIndexDense1 t c u i = map (\(SvS (ElmSynVar1 s) (Z:.z) (RiZ:.:i')) -> (s,z,i'))-                       . addIndexDenseGo (Z:.t) (Z:.c) (Z:.u) (Z:.i)-                       . map (\s -> (SvS (elmSynVar1 s i) Z RiZ))+  => c -> Context i -> u -> u -> i -> i -> Stream m s -> Stream m (s,u,RunningIndex i)+addIndexDense1 t c lb ub u i = map (\(SvS (ElmSynVar1 s) (Z:.z) (RiZ:.:i')) -> (s,z,i'))+                             . addIndexDenseGo (Z:.t) (Z:.c) (Z:.lb) (Z:.ub) (Z:.u) (Z:.i)+                             . map (\s -> (SvS (elmSynVar1 s i) Z RiZ)) {-# Inline addIndexDense1 #-}  newtype SynVar1 s = SynVar1 s

@@ -19,11 +19,11 @@   ( IndexHdr s x0 i0 us (PointL I) cs c is (PointL I)   , MinSize c   ) => AddIndexDense s (us:.PointL I) (cs:.c) (is:.PointL I) where-  addIndexDenseGo (cs:._) (vs:.IStatic d) (us:.u) (is:.i)+  addIndexDenseGo (cs:._) (vs:.IStatic d) (lbs:.lb) (ubs:.ub) (us:.u) (is:.i)     = map (\(SvS s t y') -> SvS s (t:.i) (y' :.: RiPlI (fromPointL i)))-    . addIndexDenseGo cs vs us is-  addIndexDenseGo (cs:.c) (vs:.IVariable d) (us:.u) (is:.PointL i)-    = flatten mk step . addIndexDenseGo cs vs us is+    . addIndexDenseGo cs vs lbs ubs us is+  addIndexDenseGo (cs:.c) (vs:.IVariable d) (lbs:.lb) (ubs:.ub) (us:.u) (is:.PointL i)+    = flatten mk step . addIndexDenseGo cs vs lbs ubs us is     where mk svS = let RiPlI k = getIndex (getIdx $ sS svS {- sIx svS -} ) (Proxy :: PRI is (PointL I))                    in  return $ svS :. k           step (svS@(SvS s t y') :. k)@@ -37,27 +37,27 @@ instance   ( IndexHdr s x0 i0 us (PointL O) cs c is (PointL O)   ) => AddIndexDense s (us:.PointL O) (cs:.c) (is:.PointL O) where-  addIndexDenseGo (cs:._) (vs:.OStatic d) (us:.u) (is:.i)+  addIndexDenseGo (cs:._) (vs:.OStatic d) (lbs:.lb) (ubs:.ub) (us:.u) (is:.i)     = map (\(SvS s t y') -> let RiPlO oi oo = getIndex (getIdx s) (Proxy :: PRI is (PointL O))                             in  SvS s (t:.PointL oo) (y' :.: RiPlO oi oo) )-    . addIndexDenseGo cs vs us is+    . addIndexDenseGo cs vs lbs ubs us is   {-# Inline addIndexDenseGo #-}  instance   ( IndexHdr s x0 i0 us (PointL I) cs c is (PointL C)   ) => AddIndexDense s (us:.PointL I) (cs:.c) (is:.PointL C) where-  addIndexDenseGo (cs:._) (vs:.Complemented) (us:.u) (is:.i)+  addIndexDenseGo (cs:._) (vs:.Complemented) (lbs:.lb) (ubs:.ub) (us:.u) (is:.i)     = map (\(SvS s t y) -> let RiPlC k = getIndex (getIdx s) (Proxy :: PRI is (PointL C))                            in  SvS s (t:.PointL k) (y :.: RiPlC k) )-    . addIndexDenseGo cs vs us is+    . addIndexDenseGo cs vs lbs ubs us is   {-# Inline addIndexDenseGo #-}  instance   ( IndexHdr s x0 i0 us (PointL O) cs c is (PointL C)   ) => AddIndexDense s (us:.PointL O) (cs:.c) (is:.PointL C) where-  addIndexDenseGo (cs:._) (vs:.Complemented) (us:.u) (is:.i)+  addIndexDenseGo (cs:._) (vs:.Complemented) (lbs:.lb) (ubs:.ub) (us:.u) (is:.i)     = map (\(SvS s t y) -> let RiPlC k = getIndex (getIdx s) (Proxy :: PRI is (PointL C))                            in  SvS s (t:.PointL k) (y:.:RiPlC k) )-    . addIndexDenseGo cs vs us is+    . addIndexDenseGo cs vs lbs ubs us is   {-# Inline addIndexDenseGo #-} 

@@ -19,32 +19,32 @@ instance   ( IndexHdr s x0 i0 us (Unit I) cs c is (Unit I)   ) => AddIndexDense s (us:.Unit I) (cs:.c) (is:.Unit I) where-  addIndexDenseGo (cs:._) (vs:.IStatic ()) (us:._) (is:._)+  addIndexDenseGo (cs:._) (vs:.IStatic ()) (lbs:._) (ubs:._) (us:._) (is:._)     = map (\(SvS s t y') -> SvS s (t:.Unit) (y':.:RiU))-    . addIndexDenseGo cs vs us is+    . addIndexDenseGo cs vs lbs ubs us is   {-# Inline addIndexDenseGo #-}  instance   ( IndexHdr s x0 i0 us (Unit O) cs c is (Unit O)   ) => AddIndexDense s (us:.Unit O) (cs:.c) (is:.Unit O) where-  addIndexDenseGo (cs:._) (vs:.OStatic ()) (us:._) (is:._)+  addIndexDenseGo (cs:._) (vs:.OStatic ()) (lbs:.lb) (ubs:.ub) (us:._) (is:._)     = map (\(SvS s t y') -> SvS s (t:.Unit) (y':.:RiU))-    . addIndexDenseGo cs vs us is+    . addIndexDenseGo cs vs lbs ubs us is   {-# Inline addIndexDenseGo #-}  instance   ( IndexHdr s x0 i0 us (Unit I) cs c is (Unit C)   ) => AddIndexDense s (us:.Unit I) (cs:.c) (is:.Unit C) where-  addIndexDenseGo (cs:._) (vs:.Complemented) (us:._) (is:._)+  addIndexDenseGo (cs:._) (vs:.Complemented) (lbs:._) (ubs:._) (us:._) (is:._)     = map (\(SvS s t y') -> SvS s (t:.Unit) (y':.:RiU))-    . addIndexDenseGo cs vs us is+    . addIndexDenseGo cs vs lbs ubs us is   {-# Inline addIndexDenseGo #-}  instance   ( IndexHdr s x0 i0 us (Unit O) cs c is (Unit C)   ) => AddIndexDense s (us:.Unit O) (cs:.c) (is:.Unit C) where-  addIndexDenseGo (cs:._) (vs:.Complemented) (us:._) (is:._)+  addIndexDenseGo (cs:._) (vs:.Complemented) (lbs:._) (ubs:._) (us:._) (is:._)     = map (\(SvS s t y') -> SvS s (t:.Unit) (y':.:RiU))-    . addIndexDenseGo cs vs us is+    . addIndexDenseGo cs vs lbs ubs us is   {-# Inline addIndexDenseGo #-} 

@@ -103,7 +103,7 @@   ) => MkStream m (ls :!: TwIRec m (cs:.c) (us:.u) x) (is:.i) where   mkStream (ls :!: TW (IRec c l h) fun) vs us is     = mapM (\(s,tt,ii) -> (\res -> ElmIRec res ii s) <$> fun h tt)-    . addIndexDense c vs us is+    . addIndexDense c vs l h us is     $ mkStream ls (tableStaticVar (Proxy :: Proxy (us:.u)) c vs is) us (tableStreamIndex (Proxy :: Proxy (us:.u)) c vs is)   {-# Inline mkStream #-} @@ -117,7 +117,7 @@   ) => MkStream mB (ls :!: TwIRecBt (cs:.c) (us:.u) x mF mB r) (is:.i) where   mkStream (ls :!: TW (BtIRec c l h fun) bt) vs us is     = mapM (\(s,tt,ii) -> (\res bb -> ElmBtIRec res bb ii s) <$> fun h tt <*> bt h tt)-    . addIndexDense c vs us is+    . addIndexDense c vs l h us is     $ mkStream ls (tableStaticVar (Proxy :: Proxy (us:.u)) c vs is) us (tableStreamIndex (Proxy :: Proxy (us:.u)) c vs is)   {-# Inline mkStream #-} 

@@ -10,22 +10,30 @@   -data Edge e where-  Edge :: (Int -> Int -> e) -> Edge e+newtype From = From { getFrom :: Int }+  deriving (Eq,Ord,Show) -instance Build (Edge e)+newtype To = To { getTo :: Int }+  deriving (Eq,Ord,Show) +-- | An edge in a graph. As a parsing symbol, it will provide (From:.To)+-- pairs.++data Edge = Edge++instance Build Edge+ instance   ( Element ls i-  ) => Element (ls :!: Edge e) i where-    data Elm (ls :!: Edge e) i = ElmEdge !e !(RunningIndex i) (Elm ls i)-    type Arg (ls :!: Edge e)   = Arg ls :. e+  ) => Element (ls :!: Edge) i where+    data Elm (ls :!: Edge) i = ElmEdge !(From:.To) !(RunningIndex i) (Elm ls i)+    type Arg (ls :!: Edge)   = Arg ls :. (From:.To)     getArg (ElmEdge e _ ls) = getArg ls :. e     getIdx (ElmEdge _ i _ ) = i     {-# Inline getArg #-}     {-# Inline getIdx #-} -deriving instance (Show i, Show (RunningIndex i), Show e, Show (Elm ls i)) => Show (Elm (ls :!: Edge e) i)+deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: Edge) i) -type instance TermArg (Edge e) = e+type instance TermArg Edge = (From:.To) 

@@ -1,5 +1,5 @@ name:           ADPfusion-version:        0.5.2.0+version:        0.5.2.2 author:         Christian Hoener zu Siederdissen, 2011-2016 copyright:      Christian Hoener zu Siederdissen, 2011-2016 homepage:       https://github.com/choener/ADPfusion@@ -11,7 +11,7 @@ build-type:     Simple stability:      experimental cabal-version:  >= 1.10.0-tested-with:    GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1+tested-with:    GHC == 7.10.3, GHC == 8.0.1 synopsis:       Efficient, high-level dynamic programming. description:                 <http://www.bioinf.uni-leipzig.de/Software/gADP/ generalized Algebraic Dynamic Programming>@@ -49,16 +49,26 @@   -flag examples-  description:  build the examples+flag debug+  description:  Enable bounds checking and various other debug operations at the cost of a significant performance penalty.   default:      False   manual:       True -flag debug-  description:  dump intermediate Core files+flag debugoutput+  description:  Enable debug output, which spams the screen full of index information   default:      False   manual:       True +flag debugdump+  description:  Enable dumping intermediate / core files+  default:      False+  manual:       True++flag examples+  description:  build the examples+  default:      False+  manual:       True+ flag spectest   description:  build the spec-ctor test case   default:      False@@ -78,22 +88,22 @@  library   build-depends: base               >= 4.7    && < 5.0-               , bits               >= 0.4    && < 0.6+               , bits               >= 0.4                , containers-               , mmorph             >= 1.0    && < 1.1-               , mtl                >= 2.0    && < 2.3-               , primitive          >= 0.5.4  && < 0.7-               , QuickCheck         >= 2.7    && < 2.9-               , strict             >= 0.3    && < 0.4-               , template-haskell   >= 2.0    && < 3.0-               , th-orphans         >= 0.12   && < 0.14-               , transformers       >= 0.3    && < 0.6-               , tuple              >= 0.3    && < 0.4-               , vector             >= 0.11   && < 0.12+               , mmorph             >= 1.0+               , mtl                >= 2.0+               , primitive          >= 0.5.4+               , QuickCheck         >= 2.7+               , strict             >= 0.3+               , template-haskell   >= 2.0+               , th-orphans         >= 0.12+               , transformers       >= 0.3+               , tuple              >= 0.3+               , vector             >= 0.11                ---               , DPutils            == 0.0.0.*+               , DPutils            == 0.0.1.*                , OrderedBits        == 0.0.1.*-               , PrimitiveArray     == 0.7.1.*+               , PrimitiveArray     == 0.8.0.*    exposed-modules:     -- multi imports@@ -144,6 +154,8 @@                     , CPP                     , DataKinds                     , DefaultSignatures+                    , DeriveDataTypeable+                    , DeriveGeneric                     , FlexibleContexts                     , FlexibleInstances                     , GADTs@@ -164,6 +176,11 @@     Haskell2010   ghc-options:     -O2 -funbox-strict-fields+  if flag(debugdump)+    ghc-options:+      -ddump-to-file+      -ddump-simpl+      -dsuppress-all   @@ -200,9 +217,9 @@                , PrimitiveArray                , QuickCheck                , strict-               , test-framework               >= 0.8  && < 0.9-               , test-framework-quickcheck2   >= 0.3  && < 0.4-               , test-framework-th            >= 0.2  && < 0.3+               , tasty                        >= 0.11+               , tasty-quickcheck             >= 0.8+               , tasty-th                     >= 0.1                , vector  @@ -216,6 +233,7 @@       True     build-depends:  base                  ,  ADPfusion+                 ,  primitive                  ,  PrimitiveArray                  ,  template-haskell                  ,  vector@@ -241,7 +259,7 @@     -funbox-strict-fields     -funfolding-use-threshold1000     -funfolding-keeness-factor1000-  if flag(debug)+  if flag(debugdump)     ghc-options:       -ddump-to-file       -ddump-simpl@@ -283,11 +301,11 @@     -funbox-strict-fields     -funfolding-use-threshold1000     -funfolding-keeness-factor1000-  if flag(debug)-    ghc-options:-      -ddump-to-file-      -ddump-simpl-      -dsuppress-all+--  if flag(debug)+--    ghc-options:+--      -ddump-to-file+--      -ddump-simpl+--      -dsuppress-all   @@ -300,9 +318,9 @@       True     build-depends: base                  , template-haskell-                 , fmlist             >= 0.9  &&  < 0.10+                 , fmlist             >= 0.9                  , vector-                 , criterion          >= 1.1  &&  < 1.2+                 , criterion          >= 1.1   else     buildable:       False

@@ -1,3 +1,15 @@+0.5.2.2+-------++- Modified signature of Edge to make explicit the @From@ and @To@ nodes of the+  edge. Minor version bump, because @Edge@ is not official yet.+- optimized table filling yields large improvements for linear languages++0.5.2.1+-------++- removed upper bounds+ 0.5.2.0 ------- 

@@ -83,6 +83,8 @@ import           Control.Monad (forM_) import           System.Environment (getArgs) import           Text.Printf+import           Control.Monad.Primitive+import           Control.Monad.ST  -- Streams of parses are the streams defined in the @vector@ package. @@ -272,7 +274,7 @@ -- 'runOutsideNeedlemanWunsch'.  nwInsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.TwITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int-nwInsideForward i1 i2 = {-# SCC "nwInsideForward" #-} mutateTablesDefault $+nwInsideForward i1 i2 = {-# SCC "nwInsideForward" #-} mutateTablesST $                           grammar sScore                           (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.PointL 0:.PointL 0) (Z:.PointL n1:.PointL n2) (-999999) []))                           i1 i2@@ -307,7 +309,7 @@ -- outside-table-filling part.  nwOutsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.TwITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL O:.PointL O) Int-nwOutsideForward i1 i2 = {-# SCC "nwOutsideForward" #-} mutateTablesDefault $+nwOutsideForward i1 i2 = {-# SCC "nwOutsideForward" #-} mutateTablesST $                            grammar sScore                            (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.PointL 0:.PointL 0) (Z:.PointL n1:.PointL n2) (-999999) []))                            i1 i2

@@ -15,8 +15,8 @@ import           Test.QuickCheck.All import           Test.QuickCheck.Monadic #ifdef ADPFUSION_TEST_SUITE_PROPERTIES-import           Test.Framework.TH-import           Test.Framework.Providers.QuickCheck2+import           Test.Tasty.TH+import           Test.Tasty.QuickCheck #endif  import           Data.PrimitiveArray

@@ -3,12 +3,12 @@  module Main where -import Test.Framework+import Test.Tasty  import QuickCheck.Point   (testgroup_point)    main :: IO ()-main = defaultMain [testgroup_point]+main = defaultMain testgroup_point