diff --git a/ADP/Fusion/Core.hs b/ADP/Fusion/Core.hs --- a/ADP/Fusion/Core.hs +++ b/ADP/Fusion/Core.hs @@ -1,4 +1,6 @@ +{-# Language MagicHash #-} + -- | Generalized fusion system for grammars. -- -- This module re-exports only the core functionality. @@ -13,22 +15,23 @@ , module ADP.Fusion.Core.Apply , module ADP.Fusion.Core.Classes , module ADP.Fusion.Core.Multi + , module ADP.Fusion.Core.SynVar.Array.Type + , module ADP.Fusion.Core.SynVar.Axiom + , module ADP.Fusion.Core.SynVar.Backtrack + , module ADP.Fusion.Core.SynVar.FillTyLvl + , module ADP.Fusion.Core.SynVar.Indices + , module ADP.Fusion.Core.SynVar.Recursive.Type + , module ADP.Fusion.Core.SynVar.Split.Type + , module ADP.Fusion.Core.SynVar.TableWrap + , module ADP.Fusion.Core.Term.Chr + , module ADP.Fusion.Core.Term.Deletion + , module ADP.Fusion.Core.Term.Edge + , module ADP.Fusion.Core.Term.Epsilon + , module ADP.Fusion.Core.Term.MultiChr + , module ADP.Fusion.Core.Term.PeekIndex + , module ADP.Fusion.Core.Term.Str , module ADP.Fusion.Core.TH , module ADP.Fusion.Core.TyLvlIx - , module ADP.Fusion.SynVar.Array.Type - , module ADP.Fusion.SynVar.Axiom - , module ADP.Fusion.SynVar.Backtrack - , module ADP.Fusion.SynVar.Fill - , module ADP.Fusion.SynVar.Indices.Classes - , module ADP.Fusion.SynVar.Recursive.Type - , module ADP.Fusion.SynVar.Split.Type - , module ADP.Fusion.SynVar.TableWrap - , module ADP.Fusion.Term.Chr.Type - , module ADP.Fusion.Term.Deletion.Type - , module ADP.Fusion.Term.Edge.Type - , module ADP.Fusion.Term.Epsilon.Type - , module ADP.Fusion.Term.PeekIndex.Type - , module ADP.Fusion.Term.Strng.Type , module Data.Vector.Fusion.Stream.Monadic , module Data.Vector.Fusion.Util ) where @@ -44,22 +47,23 @@ import ADP.Fusion.Core.Apply import ADP.Fusion.Core.Classes hiding (iIx) import ADP.Fusion.Core.Multi hiding (iIx) +import ADP.Fusion.Core.SynVar.Array.Type +import ADP.Fusion.Core.SynVar.Axiom +import ADP.Fusion.Core.SynVar.Backtrack +import ADP.Fusion.Core.SynVar.FillTyLvl +import ADP.Fusion.Core.SynVar.Indices +import ADP.Fusion.Core.SynVar.Recursive.Type +import ADP.Fusion.Core.SynVar.Split.Type +import ADP.Fusion.Core.SynVar.TableWrap +import ADP.Fusion.Core.Term.Chr +import ADP.Fusion.Core.Term.Deletion +import ADP.Fusion.Core.Term.Edge +import ADP.Fusion.Core.Term.Epsilon +import ADP.Fusion.Core.Term.MultiChr +import ADP.Fusion.Core.Term.PeekIndex +import ADP.Fusion.Core.Term.Str import ADP.Fusion.Core.TH import ADP.Fusion.Core.TyLvlIx -import ADP.Fusion.SynVar.Array.Type -import ADP.Fusion.SynVar.Axiom -import ADP.Fusion.SynVar.Backtrack -import ADP.Fusion.SynVar.Fill -import ADP.Fusion.SynVar.Indices.Classes -import ADP.Fusion.SynVar.Recursive.Type -import ADP.Fusion.SynVar.Split.Type -import ADP.Fusion.SynVar.TableWrap -import ADP.Fusion.Term.Chr.Type -import ADP.Fusion.Term.Deletion.Type -import ADP.Fusion.Term.Edge.Type -import ADP.Fusion.Term.Epsilon.Type -import ADP.Fusion.Term.PeekIndex.Type -import ADP.Fusion.Term.Strng.Type @@ -71,18 +75,54 @@ -- function 'f'. infixl 8 <<< -(<<<) f xs = \lu ij -> S.map (apply (inline f) . getArg) . mkStream (build xs) (initialContext ij) lu $ ij +(<<<) + ∷ forall k m initCtx symbols i b + . ( Monad m + , Build symbols + , Element (Stack symbols) i + , Apply (Arg (Stack symbols) → b) + , initCtx ~ InitialContext i + , MkStream m initCtx (Stack symbols) i + ) + ⇒ (Fun (Arg (Stack symbols) → b)) + → symbols + → (LimitType i → i → Stream m b) +(<<<) f xs + = \lu ij + → S.map (apply (inline f) . getArg) + $ mkStream (Proxy ∷ Proxy initCtx) (build xs) 1# lu ij {-# INLINE (<<<) #-} -infixl 8 <<# -(<<#) f xs = \lu ij -> S.mapM (apply (inline f) . getArg) . mkStream (build xs) (initialContext ij) lu $ ij -{-# INLINE (<<#) #-} +--infixl 8 <<# +--(<<#) f xs = \lu ij -> S.mapM (apply (inline f) . getArg) $ mkStream Proxy (build xs) 1# lu ij +--{-# INLINE (<<#) #-} -- | Combine two RHSs to give a choice between parses. infixl 7 ||| -(|||) xs ys = \lu ij -> xs lu ij S.++ ys lu ij +(|||) xs ys = \lu ij -> xs lu ij `streamappend` ys lu ij {-# INLINE (|||) #-} + +data StreamAppend a b = SAL a | SAR b + +streamappend :: Monad m => Stream m a -> Stream m a -> Stream m a +{-# Inline streamappend #-} +Stream stepa ta `streamappend` Stream stepb tb = Stream step (SAL ta) + where + {-# Inline [0] step #-} + step (SAL sa) = do + r <- stepa sa + case r of + S.Yield x sa' -> return $ S.Yield x (SAL sa') + S.Skip sa' -> return $ S.Skip (SAL sa') + S.Done -> return $ S.Skip (SAR tb) + step (SAR sb) = do + r <- stepb sb + case r of + S.Yield x sb' -> return $ S.Yield x (SAR sb') + S.Skip sb' -> return $ S.Skip (SAR sb') + S.Done -> return $ S.Done + -- | Applies the objective function 'h' to a stream 's'. The objective function -- reduces the stream to a single optimal value (or some vector of co-optimal diff --git a/ADP/Fusion/Core/Apply.hs b/ADP/Fusion/Core/Apply.hs --- a/ADP/Fusion/Core/Apply.hs +++ b/ADP/Fusion/Core/Apply.hs @@ -2,7 +2,7 @@ module ADP.Fusion.Core.Apply where --import Data.Array.Repa.Index -import Data.PrimitiveArray (Z(..), (:.)(..)) +import Data.PrimitiveArray.Index.Class (Z(..), (:.)(..)) diff --git a/ADP/Fusion/Core/Classes.hs b/ADP/Fusion/Core/Classes.hs --- a/ADP/Fusion/Core/Classes.hs +++ b/ADP/Fusion/Core/Classes.hs @@ -3,30 +3,49 @@ module ADP.Fusion.Core.Classes where +import Control.DeepSeq import Data.Proxy import Data.Strict.Tuple import GHC.Exts hiding (build) +import GHC.Generics (Generic, Generic1) import qualified Data.Vector.Fusion.Stream.Monadic as S -import Data.PrimitiveArray +import Data.PrimitiveArray.Index.Class +-- TODO Until I figure out how to use @InitialContext ∷ k@ instead of +-- @InitialContext ∷ *@ we need to live in @*@. Unfortunately, @(<<<)@ does not +-- like differently-kinded types. + +{- data OutsideContext s = OStatic s | ORightOf s | OFirstLeft s | OLeftOf s deriving (Show) +-} +data OStatic s +data ORightOf s +data OFirstLeft s +data OLeftOf s +{- data InsideContext s = IStatic {iGetContext :: s} | IVariable {iGetContext :: s} deriving (Show) +-} +data IStatic s +data IVariable s +{- data ComplementContext = Complemented deriving (Show) +-} +data Complement -- | Needed for structures that have long-range interactions and "expand", -- like sets around edge boundaries: @set set@. requires the sets to @@ -36,37 +55,37 @@ = CStatic s | CVariable s -class RuleContext i where - type Context i :: * - initialContext :: i -> Context i +-- | For each index type @ix@, @initialContext (Proxy ∷ ix)@ yields the initial +-- context from which to start up rules. +-- +-- TODO turn into type family and make 'initialContext' a global function. +type family InitialContext ix ∷ * + +{- +class RuleContext ix where + type InitialContext ix ∷ * + initialContext ∷ Proxy ix → Proxy (InitialContext ix) +-- default initialContext ∷ Proxy ix → Proxy (InitialContext ix ∷ k) + initialContext Proxy = Proxy + {-# Inline initialContext #-} +-} + -- | While we ostensibly use an index of type @i@ we typically do not need -- every element of an @i@. For example, when looking at 'Subword's, we do -- not need both element of @j:.k@ but only @k@. -- Also, inside grammars do need fewer moving indices than outside -- grammars. --- --- TODO Sometimes, the actual RunningIndex ctors are not erased. This could --- be due to . To test, we --- should transform RunningIndex into a type class to give us access to the --- left and right member, also we should create instances a la --- @RunningIndex (is :. Subword I) = RiSwI !(RunningIndex is) !Int@. --- Hopefully, these are completely erased. -{- -class RunningIndexCl i where - type RecursiveRl i :: * - type ThisRI i :: * --} - data family RunningIndex i :: * -data instance RunningIndex (is:.i) = !(RunningIndex is) :.: !(RunningIndex i) - data instance RunningIndex Z = RiZ + deriving (Generic, NFData, Show) -deriving instance Show (RunningIndex Z) +data instance RunningIndex (is:.i) = !(RunningIndex is) :.: !(RunningIndex i) + deriving (Generic) +deriving instance (NFData (RunningIndex is), NFData (RunningIndex i)) => NFData (RunningIndex (is:.i)) -- | During construction of the stream, we need to extract individual elements -- from symbols in production rules. An element in a stream is fixed by both, @@ -76,22 +95,41 @@ -- @Elm@ data constructors are all eradicated during fusion and should never -- show up in CORE. -class Element x i where - data Elm x i :: * - type RecElm x i :: * - type Arg x :: * - getArg :: Elm x i -> Arg x - getIdx :: Elm x i -> RunningIndex i - getElm :: Elm x i -> RecElm x i +class Element (x ∷ *) i where + data Elm x i ∷ * + type RecElm x i ∷ * + type Arg x ∷ * + getArg ∷ Elm x i → Arg x + getIdx ∷ Elm x i → RunningIndex i + getElm ∷ Elm x i → RecElm x i -- | @mkStream@ creates the actual stream of elements (@Elm@) that will be fed -- to functions on the left of the @(<<<)@ operator. Streams work over all -- monads and are specialized for each combination of arguments @x@ and indices -- @i@. -class (Monad m) => MkStream m x i where - mkStream :: x -> Context i -> i -> i -> S.Stream m (Elm x i) +class (Monad m) ⇒ MkStream m pos sym ix where + mkStream + ∷ Proxy pos + -- ^ Fix static/variable/... depending on position in r.h.s. of rule. + → sym + -- ^ the symbol type (syntactic variable with or with memoization, terminal types like char, string, etc) + → Int# + -- ^ guard system for stopping execution of rule + → LimitType ix + -- ^ upper limit of index @i@, using the specialized 'LimitType' for type @i@. + → ix + -- ^ the current index @i@ + → S.Stream m (Elm sym ix) + -- ^ resulting stream of elements +-- | This type family yields for a given positional type @posty ∷ k@, the +-- current symbol type @symty@ and index type @ix@ the next-left positional +-- type within the same kind @k@ Keeping within the same kind should prevent +-- accidental switching from Inside to Outside or similar bugs. + +type family LeftPosTy (pos ∷ *) sym ix ∷ * + -- | Finally, we need to be able to correctly build together symbols on the -- right-hand side of the @(<<<)@ operator. -- @@ -119,12 +157,12 @@ instance ( ) => Element S i where - data Elm S i = ElmS !(RunningIndex i) + newtype Elm S i = ElmS (RunningIndex i) type Arg S = Z getArg (ElmS _) = Z getIdx (ElmS i) = i - {-# Inline getArg #-} - {-# Inline getIdx #-} + {-# Inline [0] getArg #-} + {-# Inline [0] getIdx #-} deriving instance (Show (RunningIndex ix)) => Show (Elm S ix) @@ -132,7 +170,7 @@ -- elements. If 'b' is false, we discard all stream elements. staticCheck :: Monad m => Bool -> S.Stream m a -> S.Stream m a -staticCheck b (S.Stream step t) = b `seq` S.Stream snew (CheckLeft b t) where +staticCheck !b (S.Stream step t) = S.Stream snew (CheckLeft b t) where {-# Inline [0] snew #-} snew (CheckLeft False _) = return $ S.Done snew (CheckLeft True s) = return $ S.Skip (CheckRight s) @@ -146,10 +184,10 @@ data StaticCheck a b = CheckLeft Bool a | CheckRight b staticCheck# :: Monad m => Int# -> S.Stream m a -> S.Stream m a -staticCheck# !b (S.Stream step t) = S.Stream snew (SL t b) where +staticCheck# b (S.Stream step t) = S.Stream snew (SL b t) where {-# Inline [0] snew #-} - snew (SL s k) - | 1# <- k = return $ S.Skip (SR s) + snew (SL q s) + | 1# <- q = return $ S.Skip (SR s) | otherwise = return $ S.Done snew (SR s ) = do r <- step s case r of @@ -159,22 +197,18 @@ {-# Inline staticCheck# #-} -data SLR z = SL !z !Int# | SR !z +data SLR z = SL Int# z | SR z -- | Constrains the behaviour of the memoizing tables. They may be 'EmptyOk' if -- @i==j@ is allowed (empty subwords or similar); or they may need 'NonEmpty' -- indices, or finally they can be 'OnlyZero' (only @i==j@ allowed) which is -- useful in multi-dimensional casese. ---data TableConstraint --- = EmptyOk --- | NonEmpty --- | OnlyZero --- deriving (Eq,Show) - data EmptyOk = EmptyOk + deriving (Show) data NonEmpty = NonEmpty + deriving (Show) class MinSize c where minSize :: c -> Int @@ -187,13 +221,6 @@ minSize NonEmpty = 1 {-# Inline minSize #-} -{- -minSize :: TableConstraint -> Int -minSize NonEmpty = 1 -minSize _ = 0 -{-# Inline [0] minSize #-} --} - -- | -- -- TODO Rewrite to generalize easily over multi-dim cases. @@ -203,22 +230,4 @@ type TE t :: * toNonEmpty :: t -> TNE t toEmpty :: t -> TE t - --- ---instance ModifyConstraint EmptyOk --- type TNE EmptyOk = NonEmpty --- type TE EmptyOk = - --- | - ---type family TblConstraint x :: * --- ---type instance TblConstraint (is:.i) = TblConstraint is :. TblConstraint i ---type instance TblConstraint Z = Z --- ----- TODO move into the sub-modules --- ---type instance TblConstraint (PointL t) = TableConstraint ---type instance TblConstraint (PointR t) = TableConstraint ---type instance TblConstraint (Subword t) = TableConstraint diff --git a/ADP/Fusion/Core/Multi.hs b/ADP/Fusion/Core/Multi.hs --- a/ADP/Fusion/Core/Multi.hs +++ b/ADP/Fusion/Core/Multi.hs @@ -1,4 +1,6 @@ +{-# Language MagicHash #-} + module ADP.Fusion.Core.Multi where import qualified Data.Vector.Fusion.Stream.Monadic as S @@ -6,8 +8,10 @@ import Data.Strict.Tuple import Data.Proxy import Prelude hiding (map) +import GHC.Exts +import Debug.Trace -import Data.PrimitiveArray hiding (map) +import Data.PrimitiveArray.Index.Class hiding (map) import ADP.Fusion.Core.Classes import ADP.Fusion.Core.TyLvlIx @@ -34,7 +38,7 @@ type family TermArg x :: * type instance TermArg M = Z -type instance TermArg (TermSymbol a b) = TermArg a :. TermArg b +type instance TermArg (TermSymbol a b) = (TermArg a) :. (TermArg b) instance (Element ls i) => Element (ls :!: TermSymbol a b) i where data Elm (ls :!: TermSymbol a b) i = ElmTS !(TermArg (TermSymbol a b)) !(RunningIndex i) !(Elm ls i) @@ -46,121 +50,118 @@ deriving instance (Show i, Show (RunningIndex i), Show (TermArg (TermSymbol a b)), Show (Elm ls i)) => Show (Elm (ls :!: TermSymbol a b) i) +type instance LeftPosTy (ps :. p) (TermSymbol a b) (is:.i) = (LeftPosTy ps a is) :. (LeftPosTy p b i) + instance ( Monad m - , MkStream m ls i + , MkStream m posLeft ls i , Element ls i - , TermStaticVar (TermSymbol a b) i - , TermStream m (TermSymbol a b) (Elm ls i) i - ) => MkStream m (ls :!: TermSymbol a b) i where - mkStream (ls :!: ts) sv lu i + , TermStaticVar pos (TermSymbol a b) i + , TermStream m pos (TermSymbol a b) (Elm ls i) i + , posLeft ~ LeftPosTy pos (TermSymbol a b) i + ) => MkStream m pos (ls :!: TermSymbol a b) i where + mkStream Proxy (ls :!: ts) grd lu i = map (\(TState sS ii ee) -> ElmTS ee ii sS) - . termStream ts sv lu i + . termStream (Proxy ∷ Proxy pos) ts lu i . map (\s -> TState s RiZ Z) - $ mkStream ls (termStaticVar ts sv i) lu (termStreamIndex ts sv i) + $ mkStream (Proxy ∷ Proxy posLeft) + ls + (termStaticCheck (Proxy ∷ Proxy pos) ts lu i grd) + lu (termStreamIndex (Proxy ∷ Proxy pos) ts i) {-# Inline mkStream #-} ----- | Handles each individual argument within a stack of terminal symbols. --- ---class TerminalStream m t i where --- terminalStream :: t -> Context i -> i -> S.Stream m (S5 s j j i i) -> S.Stream m (S6 s j j i i (TermArg t)) --- ---iPackTerminalStream a sv (ii:._) = terminalStream a sv ii . S.map (\(S5 s zi zo (is:.i) (os:.o) ) -> S5 s (zi:.i) (zo:.o) is os ) ---{-# Inline iPackTerminalStream #-} --- ---instance (Monad m) => TerminalStream m M Z where --- terminalStream M _ Z = S.map (\(S5 s j1 j2 Z Z) -> S6 s j1 j2 Z Z Z) --- {-# INLINE terminalStream #-} +-- | -instance Monad m => MkStream m S Z where - mkStream _ _ _ _ = S.singleton (ElmS RiZ) - {-# INLINE mkStream #-} +type instance LeftPosTy Z M Z = Z +instance Monad m => MkStream m Z S Z where + -- mkStream Proxy S grd ZZ Z = S.filter (const $ isTrue# grd) $ S.singleton $ ElmS RiZ + mkStream Proxy S grd ZZ Z = staticCheck# grd $ S.singleton $ ElmS RiZ + {-# Inline mkStream #-} + -- | For multi-dimensional terminals we need to be able to calculate how the -- static/variable signal changes and if the index for the inner part needs to -- be modified. -class TermStaticVar t i where - termStaticVar :: t -> Context i -> i -> Context i - termStreamIndex :: t -> Context i -> i -> i +class TermStaticVar pos sym ix where +-- termStaticVar ∷ sym → Context i → i → Context i + termStreamIndex ∷ Proxy pos → sym → ix → ix + termStaticCheck ∷ Proxy pos → sym → LimitType ix → ix → Int# → Int# -instance TermStaticVar M Z where - termStaticVar _ _ _ = Z - termStreamIndex _ _ _ = Z - {-# INLINE [0] termStaticVar #-} +instance TermStaticVar pos M Z where + termStreamIndex Proxy M Z = Z + termStaticCheck Proxy M _ Z grd = grd {-# INLINE [0] termStreamIndex #-} + {-# INLINE [0] termStaticCheck #-} instance - ( TermStaticVar a is - , TermStaticVar b i - ) => TermStaticVar (TermSymbol a b) (is:.i) where - termStaticVar (a:|b) (vs:.v) (is:.i) = termStaticVar a vs is :. termStaticVar b v i - termStreamIndex (a:|b) (vs:.v) (is:.i) = termStreamIndex a vs is :. termStreamIndex b v i - {-# INLINE [0] termStaticVar #-} + ( TermStaticVar ps ts is + , TermStaticVar p t i + ) => TermStaticVar (ps:.p) (TermSymbol ts t) (is:.i) where + termStreamIndex Proxy (ts:|t) (is:.i) = termStreamIndex (Proxy ∷ Proxy ps) ts is :. termStreamIndex (Proxy ∷ Proxy p) t i + termStaticCheck Proxy (ts:|t) (us:..u) (is:.i) grd = termStaticCheck (Proxy ∷ Proxy ps) ts us is (termStaticCheck (Proxy ∷ Proxy p) t u i grd) {-# INLINE [0] termStreamIndex #-} - ---data S3 a b c = S3 !a !b !c --- ---data S4 a b c d = S4 !a !b !c !d --- ---data S5 a b c d e = S5 !a !b !c !d !e --- ---data S6 a b c d e f = S6 !a !b !c !d !e !f --- ---data S7 a b c d e f g = S7 !a !b !c !d !e !f !g --- ---data S8 a b c d e f g h = S8 !a !b !c !d !e !f !g !h - ---fromTerminalStream (S6 s Z Z i o e) = ElmTS e i o s ---{-# INLINE fromTerminalStream #-} + {-# INLINE [0] termStaticCheck #-} ---toTerminalStream s = S5 s Z Z (getIdx s) (getOmx s) ---{-# INLINE toTerminalStream #-} +--instance RuleContext Z where +type instance InitialContext Z = Z -instance RuleContext Z where - type Context Z = Z - initialContext _ = Z - {-# INLINE initialContext #-} +--instance (RuleContext is, RuleContext i) => RuleContext (is:.i) where +type instance InitialContext (is:.i) = InitialContext is:.InitialContext i -instance (RuleContext is, RuleContext i) => RuleContext (is:.i) where - type Context (is:.i) = Context is:.Context i - initialContext (is:.i) = initialContext is:.initialContext i - {-# INLINE initialContext #-} +class TableStaticVar pos minSize tableIx ix where + tableStreamIndex + ∷ Proxy pos + -- ^ provide type-level information on if we are currently static/variable/ + -- etc + → minSize + -- ^ Information on the minimal size of the corresponding table. + → LimitType tableIx + -- ^ provide type-level information on the index structure of the table we + -- are looking at. This index structure might well be different than the + -- @ix@ index we use in the grammar. + → ix + -- ^ current right-most index + → ix + -- ^ right-most index for symbol to the left of us -class TableStaticVar u c i where - tableStaticVar :: Proxy u -> c -> Context i -> i -> Context i - tableStreamIndex :: Proxy u -> c -> Context i -> i -> i +-- | Index "0" for multi-dimensional syntactic variables. -instance TableStaticVar c u Z where - tableStaticVar _ _ _ _ = Z - tableStreamIndex _ _ _ _ = Z - {-# INLINE [0] tableStaticVar #-} +instance TableStaticVar pos Z tableIx Z where + tableStreamIndex Proxy Z _ Z = Z {-# INLINE [0] tableStreamIndex #-} -instance (TableStaticVar us cs is, TableStaticVar u c i) => TableStaticVar (us:.u) (cs:.c) (is:.i) where - tableStaticVar _ (cs:.c) (vs:.v) (is:.i) = tableStaticVar (Proxy :: Proxy us) cs vs is :. tableStaticVar (Proxy :: Proxy u) c v i - tableStreamIndex _ (cs:.c) (vs:.v) (is:.i) = tableStreamIndex (Proxy :: Proxy us) cs vs is :. tableStreamIndex (Proxy :: Proxy u) c v i - {-# INLINE [0] tableStaticVar #-} +instance + ( TableStaticVar ps cs us is + , TableStaticVar p c u i + ) + ⇒ TableStaticVar (ps:.p) (cs:.c) (us:.u) (is:.i) where + tableStreamIndex Proxy (cs:.c) (us:..u) (is:.i) + = tableStreamIndex (Proxy ∷ Proxy ps) cs us is + :. tableStreamIndex (Proxy ∷ Proxy p ) c u i {-# INLINE [0] tableStreamIndex #-} - data TermState s i e = TState - { tS :: !s -- ^ state coming in from the left --- , tIx :: !(RunningIndex a) -- @I/C@ index from @sS@ - , iIx :: !(RunningIndex i) -- ^ @I/C@ building up state to hand over to next symbol - , eTS :: !e -- ^ element data + { tS :: !s + -- ^ state coming in from the left + , iIx :: !(RunningIndex i) + -- ^ @I/C@ building up state to hand over to next symbol + , eTS :: !e + -- ^ element data } ---getTIX :: (Element x0 a, s ~ Elm x0 a) => TermState s a i e -> RunningIndex a ---getTIX (TState s a i e) = getIdx s ---{-# Inline getTIX #-} - -class TermStream m t s i where - termStream :: t -> Context i -> i -> i -> Stream m (TermState s Z Z) -> Stream m (TermState s i (TermArg t)) +class TermStream m pos t s i where + termStream + ∷ Proxy pos + → t + → LimitType i + → i + → Stream m (TermState s Z Z) + → Stream m (TermState s i (TermArg t)) -instance (Monad m) => TermStream m M s Z where - termStream _ _ _ _ = id -- map (\(!s) -> s) +instance (Monad m) => TermStream m pos M s Z where + termStream Proxy M ZZ Z = id {-# Inline termStream #-} -- | @@ -171,13 +172,19 @@ -- returning @u@ !!! addTermStream1 - :: ( Monad m - , TermStream m (TermSymbol M t) (Elm (Term1 s) (Z:.i)) (Z:.i) - ) - => t -> Context i -> i -> i -> Stream m s -> Stream m (s,TermArg t,RunningIndex i) -addTermStream1 t c u i + ∷ forall m pos t s i + . ( Monad m + , TermStream m (Z:.pos) (TermSymbol M t) (Elm (Term1 s) (Z:.i)) (Z:.i) + ) + ⇒ Proxy pos + → t + → LimitType i + → i + → Stream m s + → Stream m (s,TermArg t,RunningIndex i) +addTermStream1 Proxy t u i = map (\(TState (ElmTerm1 sS) (RiZ:.:ii) (Z:.ee)) -> (sS,ee,ii)) - . termStream (M:|t) (Z:.c) (Z:.u) (Z:.i) + . termStream (Proxy ∷ Proxy (Z:.pos)) (M:|t) (ZZ:..u) (Z:.i) . map (\s -> TState (elmTerm1 s i) RiZ Z) {-# Inline addTermStream1 #-} @@ -193,27 +200,22 @@ {-# Inline getIdx #-} -- | @Term MkStream@ context - -type TmkCtx1 m ls t i - = ( Monad m - , MkStream m ls i - , TermStream m (TermSymbol M t) (Elm (Term1 (Elm ls i)) (Z:.i)) (Z:.i) - , Element ls i - , TermStaticVar t i - ) - --- | @Term TermStream@ context +-- +-- TODO prepare for deletion ---type TstCtx1 m ts s sixty is i +--type TermMkStreamContext m (pos ∷ k) ls t i -- = ( Monad m --- , TermStream m ts s is --- , GetIndex (RunningIndex sixty) (RunningIndex (is:.i)) --- , GetIx (RunningIndex sixty) (RunningIndex (is:.i)) ~ (RunningIndex i) +-- , MkStream m pos ls i +-- , TermStream m pos (TermSymbol M t) (Elm (Term1 (Elm ls i)) (Z:.i)) (Z:.i) +-- , Element ls i +-- , TermStaticVar pos t i -- ) -type TstCtx m ts s x0 sixty is i +-- | @Term TermStream@ context + +type TermStreamContext m (pos ∷ k) ts s x0 sixty is i = ( Monad m - , TermStream m ts s is + , TermStream m pos ts s is , GetIndex (RunningIndex sixty) (RunningIndex (is:.i)) , GetIx (RunningIndex sixty) (RunningIndex (is:.i)) ~ (RunningIndex i) , Element x0 sixty diff --git a/ADP/Fusion/Core/Point.hs b/ADP/Fusion/Core/Point.hs deleted file mode 100644 --- a/ADP/Fusion/Core/Point.hs +++ /dev/null @@ -1,121 +0,0 @@ - -{-# Language MagicHash #-} - -module ADP.Fusion.Core.Point where - -import Data.Proxy -import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..)) -import Debug.Trace -import Prelude hiding (map,filter) -import GHC.Exts - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Core.Classes -import ADP.Fusion.Core.Multi - - - -instance RuleContext (PointL I) where - type Context (PointL I) = InsideContext Int - initialContext _ = IStatic 0 - {-# Inline initialContext #-} - -instance RuleContext (PointL O) where - type Context (PointL O) = OutsideContext Int - initialContext _ = OStatic 0 - {-# Inline initialContext #-} - -instance RuleContext (PointL C) where - type Context (PointL C) = ComplementContext - initialContext _ = Complemented - {-# Inline initialContext #-} - -newtype instance RunningIndex (PointL I) = RiPlI Int - -data instance RunningIndex (PointL O) = RiPlO !Int !Int - -data instance RunningIndex (PointL C) = RiPlC !Int - - - -instance (Monad m) => MkStream m S (PointL I) where - mkStream S (IStatic (I# d)) (PointL (I# u)) (PointL (I# i)) --- = staticCheck (isTrue# ( (i >=# 0#) `andI#` (i <=# d) `andI#` (i <=# d) ) ) -- (i>=0 && i<=d && i<=u) - = staticCheck# ( (i >=# 0#) `andI#` (i <=# d) `andI#` (i <=# d) ) --- = filter (const (isTrue# ( (i >=# 0#) `andI#` (i <=# d) `andI#` (i <=# d) ) )) - . singleton . ElmS $ RiPlI 0 - mkStream S (IVariable _) (PointL (I# u)) (PointL (I# i)) --- = staticCheck (isTrue# ( (i >=# 0#) `andI#` (i <=# u) ) ) -- (i>=0 && i<=u) - = staticCheck# ( (i >=# 0#) `andI#` (i <=# u) ) --- = filter (const (isTrue# ( (i >=# 0#) `andI#` (i <=# u) ) )) - . singleton . ElmS $ RiPlI 0 - {-# Inline mkStream #-} - -instance - ( Monad m - , MkStream m S is - ) => MkStream m S (is:.PointL I) where - mkStream S (vs:.IStatic d) (lus:.PointL u) (is:.PointL i) - = map (\(ElmS zi) -> ElmS $ zi :.: RiPlI 0) - . staticCheck (i>=0 && i<=d && i<=u) - $ mkStream S vs lus is - mkStream S (vs:.IVariable d) (lus:.PointL u) (is:.PointL i) - = map (\(ElmS zi) -> ElmS $ zi :.: RiPlI 0) - . staticCheck (i>=0 && i<=u) - $ mkStream S vs lus is - {-# INLINE mkStream #-} - - - -instance (Monad m) => MkStream m S (PointL O) where - mkStream S (OStatic d) (PointL u) (PointL i) - = staticCheck (i>=0 && i+d<=u && u == i) . singleton . ElmS $ RiPlO i (i+d) - mkStream S (OFirstLeft d) (PointL u) (PointL i) - = staticCheck (i>=0 && i+d<=u) . singleton . ElmS $ RiPlO i (i+d) - {-# Inline mkStream #-} - -instance - ( Monad m - , MkStream m S is - ) => MkStream m S (is:.PointL O) where - mkStream S (vs:.OStatic d) (lus:.PointL u) (is:.PointL i) - = staticCheck (i>=0 && i+d == u) - . map (\(ElmS zi) -> ElmS $ zi :.: RiPlO i (i+d)) - $ mkStream S vs lus is - mkStream S (vs:.OFirstLeft d) (us:.PointL u) (is:.PointL i) - = staticCheck (i>=0 && i+d<=u) - . map (\(ElmS zi) -> ElmS $ zi :.: RiPlO i (i+d)) - $ mkStream S vs us is - {-# Inline mkStream #-} - - - -instance (Monad m) => MkStream m S (PointL C) where - mkStream S Complemented (PointL u) (PointL i) - = staticCheck (i>=0 && i<=u) . singleton . ElmS $ RiPlC i - {-# Inline mkStream #-} - - - -instance (MinSize c) => TableStaticVar u c (PointL I) where - tableStaticVar _ _ (IStatic d) _ = IVariable d - tableStaticVar _ _ (IVariable d) _ = IVariable d - -- NOTE this code used to destroy fusion. If we inline tableStreamIndex - -- very late (after 'mkStream', probably) then everything works out. - tableStreamIndex _ c _ (PointL j) = PointL $ j - minSize c - {-# INLINE [0] tableStaticVar #-} - {-# INLINE [0] tableStreamIndex #-} - -instance (MinSize c) => TableStaticVar u c (PointL O) where - tableStaticVar _ _ (OStatic d) _ = OFirstLeft d - tableStreamIndex _ c _ (PointL j) = PointL $ j - minSize c - {-# INLINE [0] tableStaticVar #-} - {-# INLINE [0] tableStreamIndex #-} - -instance (MinSize c) => TableStaticVar u c (PointL C) where - tableStaticVar _ _ Complemented _ = Complemented - tableStreamIndex _ c _ (PointL k) = PointL $ k - minSize c - {-# INLINE [0] tableStaticVar #-} - {-# INLINE [0] tableStreamIndex #-} - diff --git a/ADP/Fusion/Core/SynVar/Array.hs b/ADP/Fusion/Core/SynVar/Array.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/SynVar/Array.hs @@ -0,0 +1,150 @@ + +{-# Language MagicHash #-} + +module ADP.Fusion.Core.SynVar.Array + ( module ADP.Fusion.Core.SynVar.Array.Type + , module ADP.Fusion.Core.SynVar.Array + ) where + + +import Data.Proxy +import Data.Strict.Tuple hiding (snd) +import Data.Vector.Fusion.Stream.Monadic +import GHC.Exts +import Prelude hiding (map,mapM) + +import Data.PrimitiveArray hiding (map) + +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi +import ADP.Fusion.Core.SynVar.Array.Type +import ADP.Fusion.Core.SynVar.Backtrack +import ADP.Fusion.Core.SynVar.Indices +import ADP.Fusion.Core.SynVar.TableWrap + + + +-- | Constraints needed to use @iTblStream@. + +type ITblCx m pos ls arr x u c i = + ( TableStaticVar pos c u i + , Element ls i + , AddIndexDense (Z:.pos) (Elm (SynVar1 (Elm ls i)) (Z:.i)) (Z:.c) (Z:.u) (Z:.i) + , PrimArrayOps arr u x + ) + +-- | General function for @ITbl@s with skalar indices. + +iTblStream + ∷ forall b s m pos posLeft ls arr x u c i + . ( ITblCx m pos ls arr x u c i + , posLeft ~ LeftPosTy pos (TwITbl b s m arr c u x) i + , MkStream m posLeft ls i + ) + ⇒ Proxy pos + → Pair ls (TwITbl b s m arr c u x) + → Int# + → LimitType i + → i + → Stream m (Elm (ls :!: TwITbl b s m arr c u x) i) +iTblStream pos (ls :!: TW (ITbl c t) _) grd us is + = map (\(s,tt,ii') -> ElmITbl (t!tt) ii' s) + . addIndexDense1 pos c ub us is + $ mkStream (Proxy ∷ Proxy posLeft) ls grd us (tableStreamIndex (Proxy :: Proxy pos) c ub is) + where ub = upperBound t +{-# Inline iTblStream #-} + +-- | General function for @Backtrack ITbl@s with skalar indices. + +btITblStream + ∷ forall b s mB mF pos posLeft ls arr x r u c i + . ( ITblCx mB pos ls arr x u c i + , posLeft ~ LeftPosTy pos (TwITblBt b s arr c u x mF mB r) i + , MkStream mB posLeft ls i + ) + ⇒ Proxy pos + → Pair ls (TwITblBt b s arr c u x mF mB r) + → Int# + → LimitType i + → i + → Stream mB (Elm (ls :!: TwITblBt b s arr c u x mF mB r) i) +btITblStream pos (ls :!: TW (BtITbl c t) bt) grd us is + = mapM (\(s,tt,ii') -> bt ub tt >>= \ ~bb -> return $ ElmBtITbl (t!tt) bb ii' s) + . addIndexDense1 pos c ub us is + $ mkStream (Proxy ∷ Proxy posLeft) ls grd us (tableStreamIndex (Proxy :: Proxy pos) c ub is) + where ub = upperBound t +{-# Inline btITblStream #-} + + + +-- ** Instances + +instance + ( Monad m + , ITblCx m pos ls arr x u c (i I) + , MkStream m (LeftPosTy pos (TwITbl b s m arr c u x) (i I)) ls (i I) + ) => MkStream m pos (ls :!: TwITbl b s m arr c u x) (i I) where + mkStream = iTblStream + {-# Inline mkStream #-} + +instance + ( Monad mB + , ITblCx mB pos ls arr x u c (i I) + , MkStream mB (LeftPosTy pos (TwITblBt b s arr c u x mF mB r) (i I)) ls (i I) + ) + ⇒ MkStream mB pos (ls :!: TwITblBt b s arr c u x mF mB r) (i I) where + mkStream = btITblStream + {-# Inline mkStream #-} + +instance + ( Monad m + , ITblCx m pos ls arr x u c (i O) + , MkStream m (LeftPosTy pos (TwITbl b s m arr c u x) (i O)) ls (i O) + ) => MkStream m pos (ls :!: TwITbl b s m arr c u x) (i O) where + mkStream = iTblStream + {-# Inline mkStream #-} + +instance + ( Monad mB + , ITblCx mB pos ls arr x u c (i O) + , MkStream mB (LeftPosTy pos (TwITblBt b s arr c u x mF mB r) (i O)) ls (i O) + ) + ⇒ MkStream mB pos (ls :!: TwITblBt b s arr c u x mF mB r) (i O) where + mkStream = btITblStream + {-# Inline mkStream #-} + +{- +instance + ( Monad m + , ITblCx m ls arr x u c (i C) + ) => MkStream m (ls :!: TwITbl m arr c u x) (i C) where + mkStream = iTblStream + {-# Inline mkStream #-} + +instance + ( Monad mB + , ITblCx mB ls arr x u c (i O) + ) => MkStream mB (ls :!: TwITblBt arr c u x mF mB r) (i O) where + mkStream = btITblStream + {-# Inline mkStream #-} + +instance + ( Monad mB + , ITblCx mB ls arr x u c (i C) + ) => MkStream mB (ls :!: TwITblBt arr c u x mF mB r) (i C) where + mkStream = btITblStream + {-# Inline mkStream #-} + +instance ModifyConstraint (TwITbl m arr EmptyOk i x) where + type TNE (TwITbl m arr EmptyOk i x) = TwITbl m arr NonEmpty i x + type TE (TwITbl m arr EmptyOk i x) = TwITbl m arr EmptyOk i x + toNonEmpty (TW (ITbl b l _ arr) f) = TW (ITbl b l NonEmpty arr) f + {-# Inline toNonEmpty #-} + +instance ModifyConstraint (TwITblBt arr EmptyOk i x mF mB r) where + type TNE (TwITblBt arr EmptyOk i x mF mB r) = TwITblBt arr NonEmpty i x mF mB r + type TE (TwITblBt arr EmptyOk i x mF mB r) = TwITblBt arr EmptyOk i x mF mB r + toNonEmpty (TW (BtITbl _ arr) bt) = TW (BtITbl NonEmpty arr) bt + {-# Inline toNonEmpty #-} +-} + diff --git a/ADP/Fusion/Core/SynVar/Array/Type.hs b/ADP/Fusion/Core/SynVar/Array/Type.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/SynVar/Array/Type.hs @@ -0,0 +1,177 @@ + +{-# Language DataKinds #-} +{-# Language TypeOperators #-} + +module ADP.Fusion.Core.SynVar.Array.Type where + +import Data.Proxy +import Data.Strict.Tuple hiding (uncurry,snd) +import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..)) +import Debug.Trace +import GHC.TypeNats +import Prelude hiding (map,head,mapM) + +import Data.PrimitiveArray hiding (map) + +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi +import ADP.Fusion.Core.SynVar.Axiom +import ADP.Fusion.Core.SynVar.Backtrack +import ADP.Fusion.Core.SynVar.Indices +import ADP.Fusion.Core.SynVar.TableWrap + + + +-- | Immutable table. +-- +-- NOTE / TODO We can *NOT* move the little order into the type-level until we +-- have a fully working TH-based table filler. + +data ITbl (bigorder ∷ Nat) (smallOrder ∷ Nat) arr c i x where + ITbl ∷ { iTblConstraint ∷ !c -- TODO next to go?! + , iTblArray ∷ !(arr i x) + } → ITbl bigOrder smallOrder arr c i x + +instance (Show c, Show (arr i x)) ⇒ Show (ITbl bo so arr c i x) where + show (ITbl c arr) = "ITbl " ++ " " ++ show c ++ " [" ++ show arr ++ "]" + +type TwITbl (b ∷ Nat) (s ∷ Nat) (m ∷ * → *) arr c i x = TW (ITbl b s arr c i x) (LimitType i → i → m x) + +type TwITblBt b s arr c i x mF mB r = TW (Backtrack (TwITbl b s mF arr c i x) mF mB) (LimitType i → i → mB [r]) + +instance Build (TwITbl b s m arr c i x) + +instance Build (TwITblBt b s arr c i x mF mB r) + +type instance TermArg (TwITbl b s m arr c i x) = x + +type instance TermArg (TwITblBt b s arr c i x mF mB r) = (x,[r]) + +instance GenBacktrackTable (TwITbl b s mF arr c i x) mF mB where + data Backtrack (TwITbl b s mF arr c i x) mF mB = BtITbl !c !(arr i x) + type BacktrackIndex (TwITbl b s mF arr c i x) = i + toBacktrack (TW (ITbl c arr) _) _ = BtITbl c arr + {-# Inline toBacktrack #-} + + + +-- * axiom stuff + +instance + ( Monad m + , PrimArrayOps arr i x + , IndexStream i + ) ⇒ Axiom (TwITbl b s m arr c i x) where + type AxiomStream (TwITbl b s m arr c i x) = m x + type AxiomIx (TwITbl b s m arr c i x) = i + axiom (TW (ITbl c arr) _) = do + k ← head . streamDown zeroBound' $ upperBound arr + return $ arr ! k + {-# Inline axiom #-} + axiomAt (TW (ITbl c arr) _) k = + return $ arr ! k + {-# Inline axiomAt #-} + +-- | We need this somewhat annoying instance construction (@i ~ j@ and @m +-- ~ mB@) in order to force selection of this instance. + +instance + ( Monad mB + , PrimArrayOps arr i x + , IndexStream i + , j ~ i + , m ~ mB + ) ⇒ Axiom (TW (Backtrack (TwITbl b s mF arr c i x) mF mB) (LimitType j → j → m [r])) where + type AxiomStream (TW (Backtrack (TwITbl b s mF arr c i x) mF mB) (LimitType j → j → m [r])) = mB [r] + type AxiomIx (TW (Backtrack (TwITbl b s mF arr c i x) mF mB) (LimitType j → j → m [r])) = i + axiom (TW (BtITbl c arr) bt) = do + h ← head . streamDown zeroBound' $ upperBound arr + bt (upperBound arr) h + {-# Inline axiom #-} + axiomAt (TW (BtITbl c arr) bt) k = do + bt (upperBound arr) k + {-# Inline axiomAt #-} + + + +-- * 'Element' + +instance Element ls i ⇒ Element (ls :!: TwITbl b s m arr c j x) i where + data Elm (ls :!: TwITbl b s m arr c j x) i = ElmITbl !x !(RunningIndex i) !(Elm ls i) + type Arg (ls :!: TwITbl b s m arr c j x) = Arg ls :. x + type RecElm (ls :!: TwITbl b s m arr c j x) i = Elm ls i + getArg (ElmITbl x _ ls) = getArg ls :. x + getIdx (ElmITbl _ i _ ) = i + getElm (ElmITbl _ _ ls) = ls + {-# Inline getArg #-} + {-# Inline getIdx #-} + {-# Inline getElm #-} + +deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i), Show x) => Show (Elm (ls :!: TwITbl b s m arr c j x) i) + +instance Element ls i => Element (ls :!: TwITblBt b s arr c j x mF mB r) i where + data Elm (ls :!: TwITblBt b s arr c j x mF mB r) i = ElmBtITbl !x [r] !(RunningIndex i) !(Elm ls i) + type Arg (ls :!: TwITblBt b s arr c j x mF mB r) = Arg ls :. (x, [r]) + type RecElm (ls :!: TwITblBt b s arr c j x mF mB r) i = Elm ls i + getArg (ElmBtITbl x s _ ls) = getArg ls :. (x,s) + getIdx (ElmBtITbl _ _ i _ ) = i + getElm (ElmBtITbl _ _ _ ls) = ls + {-# Inline getArg #-} + {-# Inline getIdx #-} + {-# Inline getElm #-} + +instance (Show x, Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: TwITblBt b s arr c i x mF mB r) i) where + show (ElmBtITbl x _ i s) = show (x,i) ++ " " ++ show s + + + +-- * Multi-dim extensions + +type instance LeftPosTy Z (TwITbl b s m arr EmptyOk Z x) Z = Z +type instance LeftPosTy Z (TwITblBt b s arr EmptyOk Z x mF mB r) Z = Z + +type instance LeftPosTy (ps:.p) (TwITbl b s m arr (eos:.EmptyOk) (us:.u) x) (is:.i) + = (LeftPosTy ps (TwITbl b s m arr eos us x) is) :. (LeftPosTy p (TwITbl b s m arr EmptyOk u x) i) + +type instance LeftPosTy (ps:.p) (TwITblBt b s arr (eos:.EmptyOk) (us:.u) x mF mB r) (is:.i) + = (LeftPosTy ps (TwITblBt b s arr eos us x mF mB r) is) :. (LeftPosTy p (TwITblBt b s arr EmptyOk u x mF mB r) i) + +type instance LeftPosTy Z (TwITbl b s m arr Z Z x) Z = Z +type instance LeftPosTy Z (TwITblBt b s arr Z Z x mF mB r) Z = Z + + +instance + forall b s l m pos ps p posLeft arr cs c us u x is i ls + . ( Monad m + , pos ~ (ps:.p) + , posLeft ~ LeftPosTy pos (TwITbl b s m arr (cs:.c) (us:.u) x) (is:.i) + , Element ls (is:.i) + , TableStaticVar (ps:.p) (cs:.c) (us:.u) (is:.i) + , AddIndexDense pos (Elm ls (is:.i)) (cs:.c) (us:.u) (is:.i) + , MkStream m posLeft ls (is:.i) + , PrimArrayOps arr (us:.u) x + ) ⇒ MkStream m (ps:.p) (ls :!: TwITbl b s m arr (cs:.c) (us:.u) x) (is:.i) where + mkStream Proxy (ls :!: TW (ITbl csc t) _) grd usu isi + = map (\(s,tt,ii') -> ElmITbl (t!tt) ii' s) + . addIndexDense (Proxy ∷ Proxy pos) csc ub usu isi + $ mkStream (Proxy ∷ Proxy posLeft) ls grd usu (tableStreamIndex (Proxy ∷ Proxy pos) csc ub isi) + where ub = upperBound t + {-# Inline mkStream #-} + +instance + ( Monad mB + , pos ~ (ps:.p) + , posLeft ~ LeftPosTy pos (TwITblBt b s arr (cs:.c) (us:.u) x mF mB r) (is:.i) + , Element ls (is:.i) + , TableStaticVar (ps:.p) (cs:.c) (us:.u) (is:.i) + , AddIndexDense pos (Elm ls (is:.i)) (cs:.c) (us:.u) (is:.i) + , MkStream mB posLeft ls (is:.i) + , PrimArrayOps arr (us:.u) x + ) ⇒ MkStream mB (ps:.p) (ls :!: TwITblBt b s arr (cs:.c) (us:.u) x mF mB r) (is:.i) where + mkStream Proxy (ls :!: TW (BtITbl csc t) bt) grd usu isi + = mapM (\(s,tt,ii') -> bt ub tt >>= \ ~bb -> return $ ElmBtITbl (t!tt) bb ii' s) + . addIndexDense (Proxy ∷ Proxy pos) csc ub usu isi + $ mkStream (Proxy ∷ Proxy posLeft) ls grd usu (tableStreamIndex (Proxy :: Proxy pos) csc ub isi) + where ub = upperBound t + {-# Inline mkStream #-} + diff --git a/ADP/Fusion/Core/SynVar/Axiom.hs b/ADP/Fusion/Core/SynVar/Axiom.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/SynVar/Axiom.hs @@ -0,0 +1,20 @@ + +-- | The 'axiom' runs a backtracking algebra. The name comes from Robert +-- Giegerichs @ADP@ where @axiom@ runs the fully formed algorithm. + +module ADP.Fusion.Core.SynVar.Axiom where + +-- | The Axiom type class + +class Axiom t where + -- | The corresponding stream being returned by 'axiom' + type AxiomStream t ∷ * + -- | Index type when running the axiom + type AxiomIx t ∷ * + -- | Given a table, run the axiom + axiom ∷ t → AxiomStream t + -- | Given a table and index, run the axiom from the index on. This is useful + -- for scanning type algorithms that need to return all locally optimal + -- structures, as a locally optimal may start at any given index. + axiomAt ∷ t → AxiomIx t → AxiomStream t + diff --git a/ADP/Fusion/Core/SynVar/Backtrack.hs b/ADP/Fusion/Core/SynVar/Backtrack.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/SynVar/Backtrack.hs @@ -0,0 +1,28 @@ + +-- | Wrap forward tables in such a way as to allow backtracking via +-- algebras. + +module ADP.Fusion.Core.SynVar.Backtrack where + +import Data.Vector.Fusion.Stream.Monadic (Stream) + +import ADP.Fusion.Core.SynVar.TableWrap + + + +-- | +-- +-- TODO this should go into @ADP.Fusion.Table.Backtrack@, more than just +-- tabulated syntactic vars are going to use it. +-- +-- NOTE You probably need to give the @monad morphism@ between @mF@ and +-- @mB@ so as to be able to extract forward results in the backtracking +-- phase. + +class GenBacktrackTable t (mF :: * -> *) (mB :: * -> *) where + data Backtrack t (mF :: * -> *) (mB :: * -> *) :: * + type BacktrackIndex t :: * + toBacktrack :: t -> (forall a . mF a -> mB a) {- -> (BacktrackIndex t -> BacktrackIndex t -> mB [r]) -} -> Backtrack t mF mB + +-- instance Build (TW (Backtrack t mF mB) f) + diff --git a/ADP/Fusion/Core/SynVar/Fill.hs b/ADP/Fusion/Core/SynVar/Fill.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/SynVar/Fill.hs @@ -0,0 +1,442 @@ + +module ADP.Fusion.Core.SynVar.Fill where + +import Control.Monad +import Control.Monad.Morph (hoist, MFunctor (..)) +import Control.Monad.Primitive +import Control.Monad.ST +import Control.Monad.Trans.Class (lift, MonadTrans (..)) +import Control.Monad (when,forM_) +import Data.Dynamic +import Data.List (nub,sort,group) +import Data.Maybe (fromJust) +import Data.Proxy +import Data.Type.Equality +import Data.Vector.Fusion.Util (Id(..)) +import Debug.Trace (traceShow) +import GHC.Exts (inline) +import GHC.TypeNats +import qualified Data.Data as D +import qualified Data.List as L +import qualified Data.Typeable as T +import qualified Data.Vector as V +import qualified Data.Vector.Fusion.Stream.Monadic as SM +import qualified Data.Vector.Mutable as VM +import qualified Data.Vector.Unboxed as VU +import qualified GHC.Generics as G +import System.IO.Unsafe +import System.CPUTime +import GHC.Conc (pseq) + +import Data.PrimitiveArray + +import ADP.Fusion.Core.SynVar.Array -- TODO we want to keep only classes in here, move instances to the corresponding modules +import ADP.Fusion.Core.SynVar.Recursive.Type +import ADP.Fusion.Core.SynVar.TableWrap + +import Debug.Trace + + + +{- + +-- | A vanilla context-free grammar + +data CFG + +-- | This grammar is a multi-cfg in a monotone setting + +data MonotoneMCFG + + +-- * Unsafely mutate 'ITbls' and similar tables in the forward phase. + +-- | Mutate a cell in a stack of syntactic variables. +-- +-- TODO generalize to monad morphism via @mmorph@ package. This will allow +-- more interesting @mrph@ functions that can, for example, track some +-- state in the forward phase. (Note that this can be dangerous, we do +-- /not/ want to have this state influence forward results, unless that can +-- be made deterministic, or we'll break Bellman) + +class MutateCell (h ∷ *) (s ∷ *) (im ∷ * → *) i where + mutateCell + ∷ (Monad om, PrimMonad om) + ⇒ Proxy h + → Int + → Int + → (forall a . im a → om a) + → s + → LimitType i + → i + → om () + +-- | + +class MutateTables (h :: *) (s :: *) (im :: * -> *) where + mutateTables :: (Monad om, PrimMonad om) => Proxy h -> (forall a . im a -> om a) -> s -> om s + +class TableOrder (s :: *) where + tableLittleOrder :: s -> [Int] + tableBigOrder :: s -> [Int] + +instance TableOrder Z where + tableLittleOrder Z = [] + tableBigOrder Z = [] + {-# Inline tableLittleOrder #-} + {-# Inline tableBigOrder #-} + +instance + ( TableOrder ts + , KnownNat bo +-- , KnownNat lo + ) ⇒ TableOrder (ts:.TwITbl bo im arr c i x) where + tableLittleOrder (ts:.TW (ITbl tlo _ _) _) = + let -- tlo = fromIntegral $ natVal (Proxy ∷ Proxy lo) + in tlo : tableLittleOrder ts + tableBigOrder (ts:.TW (ITbl _ _ _) _) = + let tbo = fromIntegral $ natVal (Proxy ∷ Proxy bo) + in tbo : tableBigOrder ts + {-# Inline tableLittleOrder #-} + {-# Inline tableBigOrder #-} + +-- | @IRec@s do not need an order, given that they do not memoize. + +instance (TableOrder ts) => TableOrder (ts:.TwIRec im c i x) where + tableLittleOrder (ts:._) = tableLittleOrder ts + tableBigOrder (ts:._) = tableBigOrder ts + {-# Inline tableLittleOrder #-} + {-# Inline tableBigOrder #-} + +-- ** individual instances for filling a *single cell* + +instance + ( + ) => MutateCell p Z im i where + mutateCell _ _ _ _ Z _ _ = return () + {-# INLINE mutateCell #-} + +instance + ( MutateCell CFG ts im i + ) => MutateCell CFG (ts:.TwIRec im c i x) im i where + mutateCell h bo lo mrph (ts:._) lu i = do + mutateCell h bo lo mrph ts lu i + {-# Inline mutateCell #-} + +instance + ( PrimArrayOps arr i x + , MPrimArrayOps arr i x + , MutateCell CFG ts im i + , KnownNat bo +-- , KnownNat lo + ) => MutateCell CFG (ts:.TwITbl bo im arr c i x) im i where + mutateCell h bo lo mrph (ts:.TW (ITbl tlo c arr) f) lu i = do + let tbo = fromIntegral $ natVal (Proxy ∷ Proxy bo) +-- tlo = fromIntegral $ natVal (Proxy ∷ Proxy lo) + mutateCell h bo lo mrph ts lu i + when (bo==tbo && lo==tlo) $ do + marr <- unsafeThaw arr + z <- (inline mrph) $ f lu i + writeM marr i z + {-# INLINE mutateCell #-} + +{- + - TODOThe following code goes into ADPfusionSubword! + - +type ZS2 = Z:.Subword I:.Subword I + +instance + ( PrimArrayOps arr ZS2 x + , MPrimArrayOps arr ZS2 x + , MutateCell MonotoneMCFG ts im ZS2 + ) => MutateCell MonotoneMCFG (ts:.TwITbl im arr c ZS2 x) im ZS2 where + mutateCell h bo lo mrph (ts:.TW (ITbl tbo tlo c arr) f) lu iklj@(Z:.Subword (i:.k):.Subword(l:.j)) = do + mutateCell h bo lo mrph ts lu iklj + when (bo==tbo && lo==tlo && k<=l) $ do + marr <- unsafeThaw arr + z <- (inline mrph) $ f lu iklj + writeM marr iklj z + {-# INLINE mutateCell #-} + +instance + ( PrimArrayOps arr (Subword I) x + , MPrimArrayOps arr (Subword I) x + , MutateCell h ts im (Z:.Subword I:.Subword I) + ) => MutateCell h (ts:.TwITbl im arr c (Subword I) x) im (Z:.Subword I:.Subword I) where + mutateCell h bo lo mrph (ts:.TW (ITbl tbo tlo c arr) f) lu@(Z:.Subword (l:._):.Subword(_:.u)) ix@(Z:.Subword (i1:.j1):.Subword (i2:.j2)) = do + mutateCell h bo lo mrph ts lu ix + when (bo==tbo && lo==tlo && i1==i2 && j1==j2) $ do + let i = i1 + let j = j1 + marr <- unsafeThaw arr + z <- (inline mrph) $ f (subword l u) (subword i j) + writeM marr (subword i j) z + {-# Inline mutateCell #-} +-} + + +-- ** individual instances for filling a complete table and extracting the +-- bounds + +instance + ( MutateCell h (ts:.TwITbl bo im arr c i x) im i + , PrimArrayOps arr i x + , Show i + , IndexStream i + , TableOrder (ts:.TwITbl bo im arr c i x) + ) => MutateTables h (ts:.TwITbl bo im arr c i x) im where + mutateTables h mrph tt@(_:.TW (ITbl lo _ arr) _) = do + let to = upperBound arr + -- TODO (1) find the set of orders for the synvars + let !tbos = VU.fromList . nub . sort $ tableBigOrder tt + let !tlos = VU.fromList . nub . sort $ tableLittleOrder tt + VU.forM_ tbos $ \bo -> + case (VU.length tlos) of + 1 -> let lo = VU.head tlos + in flip SM.mapM_ (streamUp zeroBound' to) $ \k -> + mutateCell h bo lo (inline mrph) tt to k + -- TODO each big-order group should be allowed to have its own sets + -- of bounds. within a group, it doesn't make a lot of sense to + -- have different bounds? Is there a use case for that even? + _ -> flip SM.mapM_ (streamUp zeroBound' to) $ \k -> + VU.forM_ tlos $ \lo -> + mutateCell h bo lo (inline mrph) tt to k + return tt + {-# INLINE mutateTables #-} + +-- | Default table filling, assuming that the forward monad is just @IO@. +-- +-- TODO generalize to @MonadIO@ or @MonadPrim@. + +mutateTablesDefault :: MutateTables CFG t Id => t -> t +mutateTablesDefault t = unsafePerformIO $ mutateTables (Proxy :: Proxy CFG) (return . unId) t +{-# INLINE mutateTablesDefault #-} + +-- | Mutate tables, but observe certain hints. We use this for monotone +-- mcfgs for now. + +mutateTablesWithHints :: MutateTables h t Id => Proxy h -> t -> t +mutateTablesWithHints h t = unsafePerformIO $ mutateTables h (return . unId) t + + + + + + +mutateTablesST t = runST $ mutateTablesNew t +{-# Inline mutateTablesST #-} + +class CountNumberOfCells t where + countNumberOfCells ∷ t → Integer + +instance CountNumberOfCells Z where + countNumberOfCells Z = 0 + +instance + ( CountNumberOfCells ts + , Index i + , PrimArrayOps arr i x + ) ⇒ CountNumberOfCells (ts:.TwITbl bo Id arr c i x) where + countNumberOfCells (ts:.(TW (ITbl lo _ arr) fun)) = + countNumberOfCells ts + (product . totalSize $ upperBound arr) + +data PerfCounter = PerfCounter + { picoSeconds :: !Integer + , seconds :: !Double + , numberOfCells :: !Integer + } + deriving (Eq,Ord,Show) + +data Mutated ts = Mutated + { mutatedTables ∷ !ts + , perfCounter ∷ !PerfCounter + , eachBigPerfCounter ∷ [PerfCounter] + } + +-- | +-- +-- TODO new way how to do table filling. Because we now have heterogeneous +-- tables (i) group tables by @big order@ into different bins; (ii) check +-- that each bin has the same bounds (needed? -- could we have +-- smaller-sized tables once in a while); (iii) run each bin one after the +-- other +-- +-- TODO measure performance penalty, if any. We might need liberal +-- INLINEABLE, and specialization. On the other hand, we can do the +-- freeze/unfreeze outside of table filling. + +mutateTablesNew + :: forall t m . + ( TableOrder t + , TSBO t + , Monad m + , PrimMonad m + , CountNumberOfCells t + ) + => t + -> m (Mutated t) +mutateTablesNew ts = do + -- sort the tables according to [bigorder,type,littleorder]. For each + -- @bigorder@, we should have only one @type@ and can therefor do the + -- following (i) get subset of the @ts@, (ii) use outermost of @ts@ to + -- get bounds, (iii) fill these tables + -- let !tbos = VU.fromList . nub . sort $ tableBigOrder ts + let justOrder = L.map (\d → (qBigOrder d, qLittleOrder d)) + let ds = L.sort $ asDyn ts + let goM ∷ (Monad m, PrimMonad m) ⇒ [Q] → [PerfCounter] → m [PerfCounter] + goM [] ps = return $ reverse ps + goM xs ps = do + (ys,p) <- fillWithDyn xs ts + goM ys (p:ps) + {-# Inlinable goM #-} + startTime ← unsafeIOToPrim getCPUTime + ps ← goM ds [] + stopTime ← unsafeIOToPrim getCPUTime + let deltaTime = max 1 $ stopTime - startTime + return $! Mutated + { mutatedTables = ts + , perfCounter = PerfCounter + { picoSeconds = deltaTime + , seconds = 1e-12 * fromIntegral deltaTime + , numberOfCells = countNumberOfCells ts + } + , eachBigPerfCounter = ps + } +{-# Inline mutateTablesNew #-} + +data Q = Q + { qBigOrder :: Int + , qLittleOrder :: Int + , qTypeRep :: T.TypeRep + , qObject :: Dynamic + , qTable :: Dynamic + , qFunction :: Dynamic + } + deriving (Show) + +instance Eq Q where + Q bo1 lo1 tr1 _ _ _ == Q bo2 lo2 tr2 _ _ _ = (bo1,tr1,lo1) == (bo2,tr2,lo2) + +instance Ord Q where + Q bo1 lo1 tr1 _ _ _ `compare` Q bo2 lo2 tr2 _ _ _ = (bo1,lo1,tr1) `compare` (bo2,lo2,tr2) + +-- | Find the outermost table that has a certain big order and then fill +-- from there. + +class TSBO t where + asDyn :: t -> [Q] + fillWithDyn :: (Monad m, PrimMonad m) => [Q] -> t -> m ([Q], PerfCounter) + +instance TSBO Z where + asDyn Z = [] + fillWithDyn qs Z = return (qs, PerfCounter 0 0 0) + {-# Inlinable asDyn #-} + {-# Inline fillWithDyn #-} + +instance + ( TSBO ts + , Typeable arr + , Typeable c + , Typeable i + , Typeable x + , PrimArrayOps arr i x + , MPrimArrayOps arr i x + , IndexStream i + , KnownNat bo +-- , KnownNat lo + ) => TSBO (ts:.TwITbl bo Id arr c i x) where + asDyn (ts:.t@(TW (ITbl lo _ arr) fun)) = + let bo = fromIntegral $ natVal (Proxy ∷ Proxy bo) +-- lo = fromIntegral $ natVal (Proxy ∷ Proxy lo) + in Q bo lo (T.typeOf t) (toDyn t) (toDyn arr) (seq fun $ toDyn fun) : asDyn ts + fillWithDyn qs (ts:.t@(TW (ITbl _ _ arrDirect) fDirect)) = do + let to = upperBound arrDirect + bo = fromIntegral $ natVal (Proxy ∷ Proxy bo) +-- lo = fromIntegral $ natVal (Proxy ∷ Proxy lo) + -- @hs@ are all tables that can be filled here + -- @ns@ are all tables we can't fill and need to process further down + -- the line + -- TODO FIXME FIXME FIXME why are the typereps different??? + let (hs,ns) = L.span (\Q{..} -> qBigOrder == bo) qs -- && qTypeRep == T.typeOf t) qs + if null hs + then fillWithDyn qs ts + else do + let ms = Prelude.map concreteTW hs + af = Prelude.map concreteAF hs + concreteTW = (maybe (error "fromDynamic should not fail!") + (\x -> x `asTypeOf` t) + . fromDynamic . qObject) + concreteAF q = ( (`asTypeOf` arrDirect) . fromJust . fromDynamic $ qTable q + , (`asTypeOf` fDirect) . fromJust . fromDynamic $ qFunction q + ) + -- We have a single table and should short-circuit here + -- + -- TODO we should specialize for tables of lengh @1..k@ for some + -- small k. For @1@ and Needleman-Wunsch, we have a very nice @1.8@ + -- seconds down to @1.25@ seconds. :-) + -- + -- TODO how about + -- case ms of + -- [a] -> bla + -- [a,b] -> bla + -- [a,b,c] -> bla + -- [a:b:c:d:ms'] -> bla >> go ms' + -- measure if this yields meaningful performance improvements + -- + -- TODO also consider if we maybe just put marrfs into a vector + -- + -- TODO we should use TH here. + -- + -- (1) Have @Proxy @0@, say to set up big and small orders -- this + -- gives us the order on the type level. @data One = One, data Two + -- = Two, ...@ might be easier... maybe this is not too annoying to + -- write using type equality + -- + -- (2) Then deconstruct the @ts:.t@ things with TH into the correct + -- pieces. + -- + -- (3) Finally generate fill code. This should yield to performance + -- similar to what we have here with the @case of 1@ construction, + -- because @fDirect@ is partially floated out. + -- + marrfs <- V.fromList <$> Prelude.mapM (\(TW (ITbl _ _ arr) f) -> unsafeThaw arr >>= \marr -> return (marr,f)) ms + startTime ← unsafeIOToPrim getCPUTime + case (V.length marrfs) of + 1 -> do -- let (!marr,!f) = marrfs V.! 0 -- this takes 1.3 seconds for NeedlemanWunsch + -- marr <- unsafeThaw arrDirect -- this takes 0.8 seconds for NeedlemanWunsch + marr <- unsafeThaw arrDirect -- (fst $ af!!0) -- this takes 1.3 seconds for NeedlemanWunsch + let !ffff = fDirect --snd $ af!!0 + flip SM.mapM_ (streamUp zeroBound' to) $ \k -> do + -- TODO @inline mrph@ ... + z <- (return . unId) $ fDirect to k + writeM marr k z + -- We have more than one table in will work over the list of tables + _ -> do flip SM.mapM_ (streamUp zeroBound' to) $ \k -> + V.forM_ marrfs $ \(marr,f) -> do + z <- (return . unId) $ f to k + writeM marr k z + -- traceShow (hs,length ms) $ + stopTime ← unsafeIOToPrim getCPUTime + let deltaTime = stopTime - startTime + let perf = PerfCounter + { picoSeconds = deltaTime + , seconds = 1e-12 * fromIntegral deltaTime + , numberOfCells = sum $ Prelude.map (\(TW t _) → product . totalSize . upperBound $ iTblArray t) ms + } + return (ns, perf) + {-# Inline fillWithDyn #-} + +-- We don't need to capture @IRec@ tables as no table-filling takes place +-- for those tables. @asDyn@ therefore just collects on the remaining @ts@, +-- while @fillWithDyn@ hands of to the next possible table. + +instance + ( TSBO ts + ) => TSBO (ts:.TwIRec Id c i x) where + asDyn (ts:.t@(TW (IRec _ _) _)) = asDyn ts + fillWithDyn qs (ts:._) = fillWithDyn qs ts + {-# Inlinable asDyn #-} + {-# Inline fillWithDyn #-} + +-} + diff --git a/ADP/Fusion/Core/SynVar/FillTyLvl.hs b/ADP/Fusion/Core/SynVar/FillTyLvl.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/SynVar/FillTyLvl.hs @@ -0,0 +1,324 @@ + +-- | +-- +-- TODO Need to add additional type family instances as required. +-- +-- TODO Need to have little order nats as well. + +module ADP.Fusion.Core.SynVar.FillTyLvl where + +import Control.DeepSeq +import Control.Monad.Primitive +import Control.Monad.ST +import Data.Proxy +import Data.Singletons.Prelude.Bool +import Data.Singletons.Prelude.Bool +import Data.Singletons.Prelude.List +import Data.Type.Equality +import Data.Vector.Fusion.Util (Id(..)) +import GHC.Exts +import GHC.Generics +import GHC.TypeNats +import qualified Data.Vector.Fusion.Stream.Monadic as SM +import qualified Data.Vector.Unboxed as VU +import System.CPUTime +import Text.Printf + +import Data.PrimitiveArray + +import ADP.Fusion.Core.SynVar.TableWrap +import ADP.Fusion.Core.SynVar.Array + + + +-- -- | Fill/mutate tables using @ST@. +-- +-- fillTablesST +-- ∷ forall bigOrder ts +-- . ( bigOrder ~ BigOrderNats ts +-- , EachBigOrder bigOrder ts +-- ) +-- ⇒ ts +-- → ts +-- {-# Inline fillTablesST #-} +-- fillTablesST ts = runST $ fillTables ts + +-- | + +fillTables +-- ∷ Proxy (BigOrderNats ts) +-- -- ^ Proxy that provides the set of @BigOrder@ naturals + ∷ forall bigOrder s ts + . ( bigOrder ~ BigOrderNats ts + , EachBigOrder bigOrder ts + , CountNumberOfCells 0 ts + ) + ⇒ ts + -- ^ The tables + → ST s (Mutated ts) +{-# Inline fillTables #-} +fillTables ts = do + startTime ← unsafeIOToPrim getCPUTime + ps ← eachBigOrder (Proxy ∷ Proxy bigOrder) ts + stopTime ← unsafeIOToPrim getCPUTime + let deltaTime = max 1 $ stopTime - startTime + return $! Mutated + { mutatedTables = ts + , perfCounter = PerfCounter + { picoSeconds = deltaTime + , seconds = 1e-12 * fromIntegral deltaTime + , numberOfCells = countNumberOfCells (Nothing ∷ Maybe (Proxy 0)) ts + } + , eachBigPerfCounter = ps + } + +-- | This type class instanciates to the specialized machinery for each +-- @BigOrder Natural@ number. + +class EachBigOrder (boNats ∷ [Nat]) ts where + eachBigOrder ∷ Proxy boNats → ts → ST s [PerfCounter] + +-- | No more big orders to handle. + +instance EachBigOrder '[] ts where + {-# Inline eachBigOrder #-} + eachBigOrder Proxy _ = return [] + +-- | handle this big order. + +instance + ( EachBigOrder ns ts + , ThisBigOrder n (IsThisBigOrder n ts) ts + , CountNumberOfCells n ts + ) ⇒ EachBigOrder (n ': ns) ts where + {-# Inline eachBigOrder #-} + eachBigOrder Proxy ts = do + startTime ← unsafeIOToPrim getCPUTime + thisBigOrder (Proxy ∷ Proxy n) (Proxy ∷ Proxy (IsThisBigOrder n ts)) ts + stopTime ← unsafeIOToPrim getCPUTime + let deltaTime = max 1 $ stopTime - startTime + ps ← eachBigOrder (Proxy ∷ Proxy ns) ts + let p = PerfCounter + { picoSeconds = deltaTime + , seconds = 1e-12 * fromIntegral deltaTime + , numberOfCells = countNumberOfCells (Just (Proxy ∷ Proxy n)) ts + } + return $ p:ps + +-- | + +class ThisBigOrder (boNat ∷ Nat) (thisOrder ∷ Bool) ts where + thisBigOrder ∷ Proxy boNat → Proxy thisOrder → ts → ST s () + getAllBounds ∷ Proxy boNat → Proxy thisOrder → ts → [()] + +instance ThisBigOrder boNat anyOrder Z where + {-# Inline thisBigOrder #-} + thisBigOrder Proxy Proxy Z = return () + {-# Inline getAllBounds #-} + getAllBounds Proxy Proxy Z = [] + +-- | We have found the first table for our big order. Extract the bounds and +-- hand over to small order. We do not need to check for another big order with +-- this nat, since all tables are now being filled by the small order. + +instance + ( smallOrder ~ SmallOrderNats (ts:.TwITbl bo so m arr c i x) + , EachSmallOrder boNat smallOrder (ts:.TwITbl bo so m arr c i x) i + , PrimArrayOps arr i x + , IndexStream i + ) ⇒ ThisBigOrder boNat True (ts:.TwITbl bo so m arr c i x) where + {-# Inline thisBigOrder #-} + thisBigOrder Proxy Proxy tst@(_:.TW (ITbl _ arr) _) = do + let to = upperBound arr + let allBounds = getAllBounds (Proxy ∷ Proxy boNat) (Proxy ∷ Proxy True) tst + -- TODO check bounds + flip SM.mapM_ (streamUp zeroBound' to) $ \k -> + eachSmallOrder (Proxy ∷ Proxy boNat) (Proxy ∷ Proxy smallOrder) tst k + {-# Inline getAllBounds #-} + getAllBounds Proxy Proxy (ts:.t) = undefined + +-- | Go down the tables until we find the first table for our big order. + +instance + ( ThisBigOrder n (IsThisBigOrder n ts) ts + ) ⇒ ThisBigOrder n False (ts:.t) where + {-# Inline thisBigOrder #-} + thisBigOrder Proxy Proxy (ts:.t) = + thisBigOrder (Proxy ∷ Proxy n) (Proxy ∷ Proxy (IsThisBigOrder n ts)) ts + +-- | + +class EachSmallOrder (bigOrder ∷ Nat) (smallOrders ∷ [Nat]) ts i where + eachSmallOrder + ∷ Proxy bigOrder + -- ^ Only fill exactly this big order + → Proxy smallOrders + -- ^ These are all the small order to go through. + → ts + -- ^ set of tables. + → i + -- ^ index to update. + → ST s () + +-- | Went through all tables, nothing more to do. + +instance EachSmallOrder bigOrder '[] ts i where + {-# Inline eachSmallOrder #-} + eachSmallOrder Proxy Proxy ts i = return () + +-- | + +instance + ( EachSmallOrder bigOrder so ts i + , isThisBigOrder ~ IsThisBigOrder bigOrder ts + , isThisSmallOrder ~ IsThisSmallOrder s ts + , isThisOrder ~ (isThisBigOrder && isThisSmallOrder) + , ThisSmallOrder bigOrder s isThisOrder ts i + ) ⇒ EachSmallOrder bigOrder (s ': so) ts i where + {-# Inline eachSmallOrder #-} + eachSmallOrder Proxy Proxy ts i = do + -- fill all tables that have the same big & small order + thisSmallOrder (Proxy ∷ Proxy bigOrder) (Proxy ∷ Proxy s) (Proxy ∷ Proxy isThisOrder) ts i + -- fill tables with the next small order + eachSmallOrder (Proxy ∷ Proxy bigOrder) (Proxy ∷ Proxy so) ts i + +-- | + +class ThisSmallOrder (bigNat ∷ Nat) (smallNat ∷ Nat) (thisOrder ∷ Bool) ts i where + thisSmallOrder ∷ Proxy bigNat → Proxy smallNat → Proxy thisOrder → ts → i → ST s () + +instance ThisSmallOrder b s any Z i where + {-# Inline thisSmallOrder #-} + thisSmallOrder _ _ _ _ _ = return () + +instance + ( isThisBigOrder ~ IsThisBigOrder bigOrder ts + , isThisSmallOrder ~ IsThisSmallOrder smallOrder ts + , isThisOrder ~ (isThisBigOrder && isThisSmallOrder) + , ThisSmallOrder bigOrder smallOrder isThisOrder ts i + ) ⇒ ThisSmallOrder bigOrder smallOrder 'False (ts:.t) i where + {-# Inline thisSmallOrder #-} + thisSmallOrder Proxy Proxy Proxy (ts:.t) i = + thisSmallOrder (Proxy ∷ Proxy bigOrder) (Proxy ∷ Proxy smallOrder) (Proxy ∷ Proxy isThisOrder) ts i + +-- | +-- +-- TODO generalize from @Id@ to any monad in a stack with a primitive base + +instance + ( PrimArrayOps arr i x + , MPrimArrayOps arr i x + , isThisBigOrder ~ IsThisBigOrder bigOrder ts + , isThisSmallOrder ~ IsThisSmallOrder smallOrder ts + , isThisOrder ~ (isThisBigOrder && isThisSmallOrder) + , ThisSmallOrder bigOrder smallOrder isThisOrder ts i + ) ⇒ ThisSmallOrder bigOrder smallOrder 'True (ts:.TwITbl bo so Id arr c i x) i where + {-# Inline thisSmallOrder #-} + thisSmallOrder Proxy Proxy Proxy (ts:.TW (ITbl _ arr) f) i = do + let uB = upperBound arr + marr <- unsafeThaw arr + z ← return . unId $ (inline f) uB i + writeM marr i z + -- TODO need to write test case that checks that all tables are always filled + thisSmallOrder (Proxy ∷ Proxy bigOrder) (Proxy ∷ Proxy smallOrder) (Proxy ∷ Proxy isThisOrder) ts i + +-- | The set of arrays to fill is a tuple of the form @(Z:.a:.b:.c)@. Here, we +-- extract the big order @Nat@s. The set of @Nat@s being returned is already +-- ordered with the smallest @Nat@ up front. + +type BigOrderNats arr = Nub (Sort (BigOrderNats' arr)) + +type family BigOrderNats' arr ∷ [Nat] + +type instance BigOrderNats' Z = '[] + +type instance BigOrderNats' (ts:.TwITbl bo so m arr c i x) = bo ': BigOrderNats' ts + + + +type family IsThisBigOrder (n ∷ Nat) arr ∷ Bool + +type instance IsThisBigOrder n Z = 'False + +type instance IsThisBigOrder n (ts:.TwITbl bo so m arr c i x) = n == bo + + + +type SmallOrderNats arr = Nub (Sort (SmallOrderNats' arr)) + +type family SmallOrderNats' arr ∷ [Nat] + +type instance SmallOrderNats' Z = '[] + +-- TODO fix small order + +type instance SmallOrderNats' (ts:.TwITbl bo so m arr c i x) = so ': SmallOrderNats' ts + + + +type family IsThisSmallOrder (n ∷ Nat) arr ∷ Bool + +type instance IsThisSmallOrder n Z = 'False + +-- TODO fix small order comparision + +type instance IsThisSmallOrder n (ts:.TwITbl bo so m arr c i x) = n == so + +data Mutated ts = Mutated + { mutatedTables ∷ !ts + , perfCounter ∷ !PerfCounter + , eachBigPerfCounter ∷ [PerfCounter] + } + deriving (Eq,Ord,Show,Generic) + +instance NFData ts ⇒ NFData (Mutated ts) + +data PerfCounter = PerfCounter + { picoSeconds :: !Integer + , seconds :: !Double + , numberOfCells :: !Integer + } + deriving (Eq,Ord,Show,Generic) + +instance NFData PerfCounter + +showPerfCounter ∷ PerfCounter → String +{-# NoInline showPerfCounter #-} +showPerfCounter PerfCounter{..} = + let cellsSecond = round $ fromIntegral numberOfCells / seconds + m ∷ Integer = 1000000 + in printf "%.4f seconds, %d,%06d cells @ %d,%06d cells/second" + seconds + (numberOfCells `div` m) (numberOfCells `mod` m) + (cellsSecond `div` m) (cellsSecond `mod` m) + +-- | Adding two 'PerfCounter's yields the time they take together. + +instance Num PerfCounter where + PerfCounter p1 s1 n1 + PerfCounter p2 s2 n2 = PerfCounter (p1+p2) (s1+s2) (n1+n2) + + +class CountNumberOfCells (n ∷ Nat) t where + countNumberOfCells ∷ Maybe (Proxy n) → t → Integer + +instance CountNumberOfCells n Z where + {-# NoInline countNumberOfCells #-} + countNumberOfCells p Z = 0 + +instance + ( CountNumberOfCells n ts + , Index i + , PrimArrayOps arr i x + , KnownNat n + , KnownNat bo + ) ⇒ CountNumberOfCells n (ts:.TwITbl bo so Id arr c i x) where + {-# NoInline countNumberOfCells #-} + countNumberOfCells mayP (ts:.(TW (ITbl _ arr) fun)) = + let n = natVal (Proxy ∷ Proxy n) + bo = natVal (Proxy ∷ Proxy bo) + cs = countNumberOfCells mayP ts + c = product . totalSize $ upperBound arr + in case mayP of + Nothing → cs + c + Just _ → cs + if n==bo then c else 0 + diff --git a/ADP/Fusion/Core/SynVar/Indices.hs b/ADP/Fusion/Core/SynVar/Indices.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/SynVar/Indices.hs @@ -0,0 +1,140 @@ + +-- | Classes that enumerate the index structure necessary for actually +-- performing the indexing. +-- +-- TODO Currently, we only provide dense index generation. + +module ADP.Fusion.Core.SynVar.Indices where + +import Data.Proxy (Proxy(..)) +import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,flatten,Step(..)) +import Prelude hiding (map,head,mapM) + +import Data.PrimitiveArray hiding (map) + +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi +import ADP.Fusion.Core.TyLvlIx + + + +-- | This type classes enable enumeration both in single- and multi-dim +-- cases. The type @a@ is the type of the /full stack/ of indices, i.e. the +-- full multi-tape problem. +-- +-- @pos@ is the positional information, +-- @s@ is the element type over the index @ix@, +-- @ minSize@ the minimal size or width to request from the syntactic variable, +-- @tableIx@ the index type of the table to walk over, +-- and @ix@ the actual index. + +class AddIndexDense pos elm minSize tableIx ix where + addIndexDenseGo + ∷ (Monad m) + ⇒ Proxy pos + -- ^ Positional information in the rule (static/variable/etc) + → minSize + -- ^ Minimal size of the structure under consideration. We might want to + -- constrain enumeration over syntactic variables to only consider at least + -- "size>=1" cases. Normally, a syntactic variable may be of size 0 as + -- well, but with rules like @X -> X X@, we don't want to have one of the + -- @X@'s on the r.h.s. be of size 0. + → LimitType tableIx + -- ^ The upper limit imposed by the structure to traverse over. + → LimitType ix + -- ^ The upper limit imposed by the rule that traverses. + → ix + -- ^ The current index for the full rule. + → Stream m (SvState elm Z Z) + -- ^ Initial stream state with @Z@ero indices. + → Stream m (SvState elm tableIx ix) + -- ^ The type of the full stream. + +instance AddIndexDense pos elm Z Z Z where + addIndexDenseGo _ _ _ _ _ = id + {-# Inline addIndexDenseGo #-} + +-- | @SvState@ holds the state that is currently being built up by +-- @AddIndexDense@. We have both @tIx@ (and @tOx@) and @iIx@ (and @iOx@). +-- For most index structures, the indices will co-incide; however for some, +-- this will not be true -- herein for @Set@ index structures. + +data SvState elm tableIx ix = SvS + { sS ∷ !elm + -- ^ state coming in from the left + , tx ∷ !tableIx + -- ^ @I/C@ building up state to index the @table@. + , iIx ∷ !(RunningIndex ix) + -- ^ @I/C@ building up state to hand over to next symbol + } + + +-- | Given an incoming stream with indices, this adds indices for the +-- current syntactic variable / symbol. + +addIndexDense + ∷ ( Monad m + , AddIndexDense pos elm minSize tableIx ix + , elm ~ Elm x0 i0 + , Element x0 i0 + ) + ⇒ Proxy pos + → minSize + → LimitType tableIx + → LimitType ix + → ix + → Stream m elm + → Stream m (elm,tableIx,RunningIndex ix) +addIndexDense pos minSize tableBound upperBound ix + = map (\(SvS s z i') -> (s,z,i')) + . addIndexDenseGo pos minSize tableBound upperBound ix + . map (\s -> (SvS s Z RiZ)) +{-# Inline addIndexDense #-} + +-- | In case of 1-dim tables, we wrap the index creation in a multi-dim +-- system and remove the @Z@ later on. This allows us to have to write only +-- a single instance. + +addIndexDense1 + ∷ forall m pos x0 a ix minSize tableIx elm + . ( Monad m + , AddIndexDense (Z:.pos) (Elm (SynVar1 (Elm x0 a)) (Z:.ix)) (Z:.minSize) (Z:.tableIx) (Z:.ix) + , GetIndex (Z:.a) (Z:.ix) + , elm ~ Elm x0 a + , Element x0 a + ) + ⇒ Proxy pos + → minSize + → LimitType tableIx + → LimitType ix + → ix + → Stream m elm + → Stream m (elm,tableIx,RunningIndex ix) +addIndexDense1 Proxy minSize tableBound upperBound ix + = map (\(SvS (ElmSynVar1 s) (Z:.z) (RiZ:.:i')) -> (s,z,i')) + . addIndexDenseGo (Proxy ∷ Proxy (Z:.pos)) (Z:.minSize) (ZZ:..tableBound) (ZZ:..upperBound) (Z:.ix) + . map (\s -> (SvS (elmSynVar1 s ix) Z RiZ)) +{-# Inline addIndexDense1 #-} + +newtype SynVar1 s = SynVar1 s + +elmSynVar1 :: s -> i -> Elm (SynVar1 s) (Z:.i) +elmSynVar1 s _ = ElmSynVar1 s +{-# Inline elmSynVar1 #-} + +instance (s ~ Elm x0 i, Element x0 i) => Element (SynVar1 s) (Z:.i) where + newtype Elm (SynVar1 s) (Z:.i) = ElmSynVar1 s + getIdx (ElmSynVar1 s) = RiZ :.: getIdx s + {-# Inline getIdx #-} + + +-- | Instance headers, we typically need. + +type AddIndexDenseContext pos elm x0 i0 minSizes minSize tableIxs tableIx ixs ix = + ( AddIndexDense pos elm minSizes tableIxs ixs + , GetIndex (RunningIndex i0) (RunningIndex (ixs:.ix)) + , GetIx (RunningIndex i0) (RunningIndex (ixs:.ix)) ~ (RunningIndex ix) + , Element x0 i0 + , elm ~ Elm x0 i0 + ) + diff --git a/ADP/Fusion/Core/SynVar/Recursive/Type.hs b/ADP/Fusion/Core/SynVar/Recursive/Type.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/SynVar/Recursive/Type.hs @@ -0,0 +1,131 @@ + +module ADP.Fusion.Core.SynVar.Recursive.Type where + +import Control.Applicative (Applicative,(<$>),(<*>)) +import Control.Monad.Morph +import Data.Proxy +import Data.Strict.Tuple +import Data.Vector.Fusion.Stream.Monadic (Stream,head,map,mapM) +import Prelude hiding (head,map,mapM) + +import Data.PrimitiveArray hiding (map) + +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi +import ADP.Fusion.Core.SynVar.Axiom +import ADP.Fusion.Core.SynVar.Backtrack +import ADP.Fusion.Core.SynVar.Indices +import ADP.Fusion.Core.SynVar.TableWrap + + + +-- | A syntactic variable that does not memoize but simplify recurses. One +-- needs to be somewhat careful when using this one. @ITbl@ performs +-- memoization to perform DP in polynomial time (roughly speaking). If the +-- rules for an @IRec@ are of a particular type, they will exponential +-- running time. Things like @X -> X X@ are, for example, rather bad. Rules +-- of the type @X -> Y, Y -> Z@ are ok, if @Y@ is an @IRec@ since we just +-- continue on. The same holds for @Y -> a Y@. Basically, things are safe +-- if there is only a (small) constant number of parses of an @IRec@ +-- synvar. + +data IRec c i x where + IRec ∷ { iRecConstraint ∷ !c + , iRecTo ∷ !(LimitType i) + } → IRec c i x + +type TwIRec (m ∷ * → *) c i x = TW (IRec c i x) (LimitType i → i → m x) + +type TwIRecBt c i x mF mB r = TW (Backtrack (TwIRec mF c i x) mF mB) (LimitType i → i → mB [r]) + +instance Build (TwIRec m c i x) + +instance Build (TwIRecBt c i x mF mB r) + +type instance TermArg (TwIRec m c i x) = x + +instance GenBacktrackTable (TwIRec mF c i x) mF mB where + data Backtrack (TwIRec mF c i x) mF mB = BtIRec !c !(LimitType i) !(LimitType i → i → mB x) + type BacktrackIndex (TwIRec mF c i x) = i + toBacktrack (TW (IRec c iT) f) mrph = BtIRec c iT (\lu i -> mrph $ f lu i) + {-# Inline toBacktrack #-} + + + +instance + ( Monad m + , IndexStream i + ) ⇒ Axiom (TwIRec m c i x) where + type AxiomStream (TwIRec m c i x) = m x + axiom (TW (IRec _ h) fun) = do + k ← head $ streamDown zeroBound' h + fun h k + {-# Inline axiom #-} + +instance + ( Monad mB + , IndexStream i + , i ~ j + , m ~ mB + ) ⇒ Axiom (TW (Backtrack (TwIRec mF c i x) mF mB) (LimitType j → j → m [r])) where + type AxiomStream (TW (Backtrack (TwIRec mF c i x) mF mB) (LimitType j → j → m [r])) = mB [r] + axiom (TW (BtIRec c h fun) btfun) = do + k <- head $ streamDown zeroBound' h + btfun h k + {-# Inline axiom #-} + + + +instance Element ls i ⇒ Element (ls :!: TwIRec m c u x) i where + data Elm (ls :!: TwIRec m c u x) i = ElmIRec !x !(RunningIndex i) !(Elm ls i) + type Arg (ls :!: TwIRec m c u x) = Arg ls :. x + getArg (ElmIRec x _ ls) = getArg ls :. x + getIdx (ElmIRec _ i _ ) = i + {-# Inline getArg #-} + {-# Inline getIdx #-} + +instance Element ls i ⇒ Element (ls :!: TwIRecBt c u x mF mB r) i where + data Elm (ls :!: (TwIRecBt c u x mF mB r)) i = ElmBtIRec !x [r] !(RunningIndex i) !(Elm ls i) + type Arg (ls :!: (TwIRecBt c u x mF mB r)) = Arg ls :. (x, [r]) + getArg (ElmBtIRec x s _ ls) = getArg ls :. (x,s) + getIdx (ElmBtIRec _ _ i _ ) = i + {-# Inline getArg #-} + {-# Inline getIdx #-} + +instance + ( Functor m + , Monad m + , pos ~ (ps:.p) + , posLeft ~ LeftPosTy pos (TwIRec m (cs:.c) (us:.u) x) (is:.i) + , Element ls (is:.i) +-- , TableStaticVar ps cs us is +-- , TableStaticVar p c u i + , TableStaticVar (ps:.p) (cs:.c) (us:.u) (is:.i) + , AddIndexDense pos (Elm ls (is:.i)) (cs:.c) (us:.u) (is:.i) + , MkStream m posLeft ls (is:.i) + ) ⇒ MkStream m ('(:.) ps p) (ls :!: TwIRec m (cs:.c) (us:.u) x) (is:.i) where + mkStream Proxy (ls :!: TW (IRec csc h) fun) grd usu isi + = mapM (\(s,tt,ii) -> (\res -> ElmIRec res ii s) <$> fun h tt) + . addIndexDense (Proxy ∷ Proxy pos) csc h usu isi + $ mkStream (Proxy ∷ Proxy posLeft) ls grd usu (tableStreamIndex (Proxy ∷ Proxy pos) csc h isi) + {-# Inline mkStream #-} + +instance + ( Applicative mB + , Monad mB + , pos ~ (ps :. p) + , posLeft ~ LeftPosTy pos (TwIRecBt (cs:.c) (us:.u) x mF mB r) (is:.i) + , Element ls (is:.i) +-- , TableStaticVar (us:.u) (cs:.c) (is:.i) +-- , TableStaticVar ps cs us is +-- , TableStaticVar p c u i + , TableStaticVar (ps:.p) (cs:.c) (us:.u) (is:.i) + , AddIndexDense pos (Elm ls (is:.i)) (cs:.c) (us:.u) (is:.i) + , MkStream mB posLeft ls (is:.i) + ) => MkStream mB ('(:.) ps p) (ls :!: TwIRecBt (cs:.c) (us:.u) x mF mB r) (is:.i) where + mkStream Proxy (ls :!: TW (BtIRec csc h fun) bt) grd usu isi + = mapM (\(s,tt,ii) -> (\res bb -> ElmBtIRec res bb ii s) <$> fun h tt <*> bt h tt) + . addIndexDense (Proxy ∷ Proxy pos) csc h usu isi + $ mkStream (Proxy ∷ Proxy posLeft) ls grd usu (tableStreamIndex (Proxy :: Proxy pos) csc h isi) + {-# Inline mkStream #-} + diff --git a/ADP/Fusion/Core/SynVar/Split/Type.hs b/ADP/Fusion/Core/SynVar/Split/Type.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/SynVar/Split/Type.hs @@ -0,0 +1,200 @@ + +-- | +-- +-- NOTE /highly experimental/ + +module ADP.Fusion.Core.SynVar.Split.Type + ( module ADP.Fusion.Core.SynVar.Split.Type + , Proxy (..) + ) where + +import Data.Proxy +import Data.Strict.Tuple +import Data.Vector.Fusion.Stream.Monadic +import Data.Vector.Fusion.Util (delay_inline) +import Debug.Trace +import GHC.TypeLits +import Prelude hiding (map,mapM) +import Data.Type.Equality + +import Data.PrimitiveArray hiding (map) + +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi +import ADP.Fusion.Core.SynVar.Array.Type +import ADP.Fusion.Core.SynVar.Backtrack +import ADP.Fusion.Core.SynVar.TableWrap + + + +data SplitType = Fragment | Final + +-- | The @Arg synVar@ means that we probably need to rewrite the internal +-- type resolution now! + +type family CalcSplitType splitType varTy where + CalcSplitType Fragment varTy = () + CalcSplitType Final varTy = varTy + +-- | Should never fail? + +type family ArgTy argTy where +-- ArgTy Z = Z + ArgTy (z:.x) = x + +-- | Wraps a normal non-terminal and attaches a type-level unique identier +-- and z-ordering (with the unused @Z@ at @0@). +-- +-- TODO attach empty/non-empty stuff (or get from non-splitted synvar?) +-- +-- TODO re-introduce z-ordering later (once we have a sort fun) + +newtype Split (uId :: Symbol) {- (zOrder :: Nat) -} (splitType :: SplitType) synVar = Split { getSplit :: synVar } + +-- | +-- +-- TODO Here, we probably want to default to a @NonEmpty@ condition. Or at +-- least have different versions of @split@. + +split :: Proxy (uId::Symbol) -> {- Proxy (zOrder::Nat) -> -} Proxy (splitType::SplitType) -> synVar -> Split uId splitType synVar +split _ _ = Split +{-# Inline split #-} + +--splitNE :: (ModifyConstraint synVar) => Proxy (uId::Symbol) -> {- Proxy (zOrder::Nat) -> -} Proxy (splitType::SplitType) -> synVar -> Split uId splitType synVar +--splitNE _ _ = Split . toNonEmpty +--{-# Inline splitNE #-} + +--type Spl uId zOrder splitType = forall synVar . Split uId zOrder splitType synVar + +instance Build (Split uId splitType synVar) + +instance + ( Element ls i + ) => Element (ls :!: Split uId splitType (TwITbl b s m arr c j x)) i where + -- | @ElmSplitITbl@ carry one additional element of type @i@. We need + -- those to be able to extract the full index via @collectIx@. + data Elm (ls :!: Split uId splitType (TwITbl b s m arr c j x)) i = ElmSplitITbl !(Proxy uId) !(CalcSplitType splitType x) !(RunningIndex i) !(Elm ls i) !i + type Arg (ls :!: Split uId splitType (TwITbl b s m arr c j x)) = Arg ls :. (CalcSplitType splitType x) + type RecElm (ls :!: Split uId splitType (TwITbl b s m arr c j x)) i = Elm ls i + getArg (ElmSplitITbl _ x _ ls _) = getArg ls :. x + getIdx (ElmSplitITbl _ _ i _ _) = i + getElm (ElmSplitITbl _ _ _ ls _) = ls + {-# Inline getArg #-} + {-# Inline getIdx #-} + {-# Inline getElm #-} + +instance + ( Element ls i + ) => Element (ls :!: Split uId splitType (TwITblBt b s arr c j x mF mB r)) i where + data Elm (ls :!: Split uId splitType (TwITblBt b s arr c j x mF mB r)) i = ElmSplitBtITbl !(Proxy uId) !(CalcSplitType splitType (x, [r])) !(RunningIndex i) !(Elm ls i) !i + type Arg (ls :!: Split uId splitType (TwITblBt b s arr c j x mF mB r)) = Arg ls :. (CalcSplitType splitType (x,[r])) + type RecElm (ls :!: Split uId splitType (TwITblBt b s arr c j x mF mB r)) i = Elm ls i + getArg (ElmSplitBtITbl _ xs _ ls _) = getArg ls :. xs + getIdx (ElmSplitBtITbl _ _ i _ _) = i + getElm (ElmSplitBtITbl _ _ _ ls _) = ls + {-# Inline getArg #-} + {-# Inline getIdx #-} + {-# Inline getElm #-} + + + +-- | 'collectIx' gobbles up indices that are tagged with the same symbolic +-- identifier. + +collectIx + :: forall uId ls i . + ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i) + ) + => Proxy uId -> Elm ls i -> SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i) +collectIx p e = splitIxCol p (Proxy :: Proxy (SameSid uId (Elm ls i))) e + +-- | Closed type family that gives us a (type) function for type symbol +-- equality. + +type family SameSid uId elm :: Bool where + SameSid uId (Elm (ls :!: Split sId splitType synVar) i) = uId == sId + SameSid uId (Elm (ls :!: TermSymbol a b ) i) = SameSid uId (TermSymbol a b) + SameSid uId M = False + SameSid uId (TermSymbol a (Split sId splitType synVar)) = OR (uId == sId) (SameSid uId a) + SameSid uId (Elm (ls :!: l ) i) = False + +-- | Type-level @(||)@ + +type family OR a b where + OR False False = False + OR a b = True + +-- | @x ++ y@ but for inductive tuples. +-- +-- TODO move to PrimitiveArray + +class Zconcat x y where + type Zpp x y :: * + zconcat :: x -> y -> Zpp x y + +instance Zconcat x Z where + type Zpp x Z = x + zconcat x Z = x + {-# Inline zconcat #-} + +instance + ( Zconcat x z + ) => Zconcat x (z:.y) where + type Zpp x (z:.y) = Zpp x z :. y + zconcat x (z:.y) = zconcat x z :. y + {-# Inline zconcat #-} + +-- WORKS + +-- | Actually collect split indices based on if we managed to find the +-- right @Split@ synvar (based on the right symbol). +-- +-- TODO this is not completely right, or? Since we should consider +-- inside/outside? +-- +-- TODO 'splitIxCol' will need the index type @i@ to combine running index +-- and index into the actual lookup part. + +class SplitIxCol (uId::Symbol) (b::Bool) e where + type SplitIxTy uId b e :: * + splitIxCol :: Proxy uId -> Proxy b -> e -> SplitIxTy uId b e + + + +instance SplitIxCol uId b (Elm S i) where + type SplitIxTy uId b (Elm S i) = Z + splitIxCol p b (ElmS _) = Z + {-# Inline splitIxCol #-} + + +instance + ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i) + , Element (ls :!: l) i + , RecElm (ls :!: l) i ~ Elm ls i + ) => SplitIxCol uId False (Elm (ls :!: l) i) where + type SplitIxTy uId False (Elm (ls :!: l) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i) + splitIxCol p b e = collectIx p (getElm e) + {-# Inline splitIxCol #-} + +instance + ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i) + ) => SplitIxCol uId True (Elm (ls :!: Split sId splitType (TwITbl b s m arr c j x)) i) where + type SplitIxTy uId True (Elm (ls :!: Split sId splitType (TwITbl b s m arr c j x)) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i) :. i + splitIxCol p b (ElmSplitITbl _ _ i e ix) = collectIx p e :. ix + {-# Inline splitIxCol #-} + +instance + ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i) + ) => SplitIxCol uId True (Elm (ls :!: Split sId splitType (TwITblBt b s arr c j x mF mB r)) i) where + type SplitIxTy uId True (Elm (ls :!: Split sId splitType (TwITblBt b s arr c j x mF mB r)) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i) :. i + splitIxCol p b (ElmSplitBtITbl _ _ i e ix) = collectIx p e :. ix + {-# Inline splitIxCol #-} + +instance + ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i) + , Zconcat (SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)) (SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b)) + ) => SplitIxCol uId True (Elm (ls :!: TermSymbol a b) i) where + type SplitIxTy uId True (Elm (ls :!: TermSymbol a b) i) = Zpp (SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)) (SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b)) + splitIxCol p b (ElmTS t i e) = collectIx p e `zconcat` ((error "ElmTS / splitIxCol") {- p t -} :: SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b)) + {-# Inline splitIxCol #-} + diff --git a/ADP/Fusion/Core/SynVar/TableWrap.hs b/ADP/Fusion/Core/SynVar/TableWrap.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/SynVar/TableWrap.hs @@ -0,0 +1,15 @@ + +-- | Wrap the underlying table and the rules. Isomorphic to @(,)@. + +module ADP.Fusion.Core.SynVar.TableWrap where + + + +-- | Wrap tables of type @t@. The tables are strict, the functions @f@ can +-- not be strict, because we need to build grammars recursively. + +data TW t f = TW !t f + +instance Show t ⇒ Show (TW t f) where + show (TW t _) = "TW(" ++ show t ++ ")" + diff --git a/ADP/Fusion/Core/TH/Backtrack.hs b/ADP/Fusion/Core/TH/Backtrack.hs --- a/ADP/Fusion/Core/TH/Backtrack.hs +++ b/ADP/Fusion/Core/TH/Backtrack.hs @@ -24,7 +24,7 @@ import qualified Data.Vector.Mutable as VM import qualified Data.Set as S -import Data.PrimitiveArray ( (:.)(..) , Z(..) ) +import Data.PrimitiveArray.Index.Class ( (:.)(..) , Z(..) ) import ADP.Fusion.Core.TH.Common diff --git a/ADP/Fusion/Core/Term/Chr.hs b/ADP/Fusion/Core/Term/Chr.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/Term/Chr.hs @@ -0,0 +1,62 @@ + +-- | +-- +-- TODO Rename @Chr@ to @Vtx@, a vertex parser is a generalization of +-- a char parser. But this is only semantics, so not super important to do +-- now. + +module ADP.Fusion.Core.Term.Chr where + +import Data.Strict.Tuple +import qualified Data.Vector.Generic as VG + +import Data.PrimitiveArray + +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi + + + +-- | A generic Character parser that reads a single character but allows +-- passing additional information. +-- +-- 'Chr' expects a function to retrieve @r@ at index position, followed by +-- the actual generic vector with data. + +data Chr r x where + Chr :: VG.Vector v x + => (v x -> Int -> r) + -> !(v x) + -> Chr r x + +-- | smart constructor for regular 1-character parsers + +chr :: VG.Vector v x => v x -> Chr x x +chr = Chr VG.unsafeIndex +{-# Inline chr #-} + +-- | Smart constructor for Maybe Peeking, followed by a character. + +chrLeft xs = Chr f xs where + f xs k = ( xs VG.!? (k-1) + , VG.unsafeIndex xs k + ) + {-# Inline [0] f #-} +{-# Inline chrLeft #-} + +instance Build (Chr r x) + +instance + ( Element ls i + ) => Element (ls :!: Chr r x) i where + data Elm (ls :!: Chr r x) i = ElmChr !r !(RunningIndex i) !(Elm ls i) + type Arg (ls :!: Chr r x) = Arg ls :. r + getArg (ElmChr x _ ls) = getArg ls :. x + getIdx (ElmChr _ i _ ) = i + {-# Inline getArg #-} + {-# Inline getIdx #-} + +deriving instance (Show i, Show (RunningIndex i), Show r, Show (Elm ls i)) => Show (Elm (ls :!: Chr r x) i) + +type instance TermArg (Chr r x) = r + diff --git a/ADP/Fusion/Core/Term/Deletion.hs b/ADP/Fusion/Core/Term/Deletion.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/Term/Deletion.hs @@ -0,0 +1,26 @@ + +module ADP.Fusion.Core.Term.Deletion where + +import Data.Strict.Tuple + +import Data.PrimitiveArray + +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi + + + +data Deletion = Deletion + +instance Build Deletion + +instance (Element ls i) => Element (ls :!: Deletion) i where + data Elm (ls :!: Deletion) i = ElmDeletion !(RunningIndex i) !(Elm ls i) + type Arg (ls :!: Deletion) = Arg ls :. () + getArg (ElmDeletion _ l) = getArg l :. () + getIdx (ElmDeletion i _) = i + {-# Inline getArg #-} + {-# Inline getIdx #-} + +type instance TermArg Deletion = () + diff --git a/ADP/Fusion/Core/Term/Edge.hs b/ADP/Fusion/Core/Term/Edge.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/Term/Edge.hs @@ -0,0 +1,73 @@ + +module ADP.Fusion.Core.Term.Edge where + +import Data.Strict.Tuple +import Data.Proxy + +import Data.PrimitiveArray + +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi + + + +newtype From = From { getFrom :: Int } + deriving (Eq,Ord,Show) + +newtype To = To { getTo :: Int } + deriving (Eq,Ord,Show) + +-- | An edge in a graph. As a parsing symbol, it will provide (From:.To) +-- pairs. + +data Edge = Edge + +instance Build Edge + +instance + ( Element ls i + ) => Element (ls :!: Edge) i where + data Elm (ls :!: Edge) i = ElmEdge !(From:.To) !(RunningIndex i) !(Elm ls i) + type Arg (ls :!: Edge) = Arg ls :. (From:.To) + getArg (ElmEdge e _ ls) = getArg ls :. e + getIdx (ElmEdge _ i _ ) = i + {-# Inline getArg #-} + {-# Inline getIdx #-} + +deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: Edge) i) + +type instance TermArg Edge = (From:.To) + +-- | 'edgeFromTo' creates a @(From:.To)@ structure for edges. How this is +-- filled depends on the @Proxy@. Possible are @Proxy First@ and @Proxy Last@. +-- @First@ denotes that @To@ is the first node to be visited. I.e. @First(From) +-- → Set(To)@. @Last@ on the other hand is @Set(From) → Last(To)@. + +class EdgeFromTo k where + edgeFromTo ∷ Proxy k → SetBoundary → NewBoundary → (From:.To) + +newtype SetBoundary = SetBoundary Int + +newtype NewBoundary = NewBoundary Int + +-- | In case our sets have a @First@ boundary, then we always point from +-- the boundary "into" the set. Hence @SetNode == To@ and @NewNode == +-- From@. +-- +-- @{1,2,(3)} <- (4)@ yields @From 4 :. To 3@. Note the arrow direction @INTO@ +-- the set. + +instance EdgeFromTo First where + edgeFromTo Proxy (SetBoundary to) (NewBoundary from) = From from :. To to + {-# Inline edgeFromTo #-} + +-- | And if the set has a @Last@ boundary, then we point from somewhere in +-- the set @To@ the @NewNode@, which is @Last@. +-- +-- @{1,2,(3)} -> (4)@ yields @From 3 :. To 4@. Note the arrow direction @OUT +-- OF@ the set. + +instance EdgeFromTo Last where + edgeFromTo Proxy (SetBoundary from) (NewBoundary to) = From from :. To to + {-# Inline edgeFromTo #-} + diff --git a/ADP/Fusion/Core/Term/Epsilon.hs b/ADP/Fusion/Core/Term/Epsilon.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/Term/Epsilon.hs @@ -0,0 +1,35 @@ + +-- | 'Epsilon' is a global or local starting (or ending, depending on the view) +-- point for a grammar. + +module ADP.Fusion.Core.Term.Epsilon where + +import Data.Data +import Data.Strict.Tuple +import Data.Typeable +import GHC.Generics(Generic) + +import Data.PrimitiveArray + +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi + + + +data LocalGlobal = Local | Global + deriving (Eq,Ord,Read,Show,Data,Typeable,Generic) + +data Epsilon (lg ∷ LocalGlobal) = Epsilon + +instance Build (Epsilon lg) + +instance (Element ls i) => Element (ls :!: Epsilon lg) i where + data Elm (ls :!: Epsilon lg) i = ElmEpsilon !(RunningIndex i) !(Elm ls i) + type Arg (ls :!: Epsilon lg) = Arg ls :. () + getArg (ElmEpsilon _ l) = getArg l :. () + getIdx (ElmEpsilon i _) = i + {-# Inline getArg #-} + {-# Inline getIdx #-} + +type instance TermArg (Epsilon lg) = () + diff --git a/ADP/Fusion/Core/Term/MultiChr.hs b/ADP/Fusion/Core/Term/MultiChr.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/Term/MultiChr.hs @@ -0,0 +1,49 @@ + +-- | +-- +-- TODO Rename @Chr@ to @Vtx@, a vertex parser is a generalization of +-- a char parser. But this is only semantics, so not super important to do +-- now. + +module ADP.Fusion.Core.Term.MultiChr where + +import Data.Strict.Tuple +import GHC.TypeNats +import qualified Data.Vector.Generic as VG + +import Data.PrimitiveArray + +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi + + + +-- | A multi-character parser. + +data MultiChr (c ∷ Nat) (v ∷ * → *) (x ∷ *) where + MultiChr ∷ VG.Vector v x + ⇒ !(v x) + → MultiChr c v x + +-- | smart constructor for regular 1-character parsers + +multiChr :: VG.Vector v x => v x -> MultiChr c v x +multiChr = MultiChr +{-# Inline multiChr #-} + +instance Build (MultiChr c v x) + +instance + ( Element ls i + ) => Element (ls :!: MultiChr c v x) i where + data Elm (ls :!: MultiChr c v x) i = ElmMultiChr !(v x) !(RunningIndex i) !(Elm ls i) + type Arg (ls :!: MultiChr c v x) = Arg ls :. v x + getArg (ElmMultiChr x _ ls) = getArg ls :. x + getIdx (ElmMultiChr _ i _ ) = i + {-# Inline getArg #-} + {-# Inline getIdx #-} + +deriving instance (Show i, Show (RunningIndex i), Show (v x), Show (Elm ls i)) => Show (Elm (ls :!: MultiChr c v x) i) + +type instance TermArg (MultiChr c v x) = v x + diff --git a/ADP/Fusion/Core/Term/PeekIndex.hs b/ADP/Fusion/Core/Term/PeekIndex.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/Term/PeekIndex.hs @@ -0,0 +1,30 @@ + +module ADP.Fusion.Core.Term.PeekIndex where + +import Data.Strict.Tuple + +import Data.PrimitiveArray + +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi + + + +data PeekIndex i = PeekIndex + +instance Build (PeekIndex i) + +instance + ( Element ls i + ) => Element (ls :!: PeekIndex i) i where + data Elm (ls :!: PeekIndex i) i = ElmPeekIndex !i !(RunningIndex i) !(Elm ls i) + type Arg (ls :!: PeekIndex i) = Arg ls :. i + getArg (ElmPeekIndex x _ ls) = getArg ls :. x + getIdx (ElmPeekIndex _ i _ ) = i + {-# Inline getArg #-} + {-# Inline getIdx #-} + +deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: PeekIndex i) i) + +type instance TermArg (PeekIndex i) = PeekIndex i + diff --git a/ADP/Fusion/Core/Term/Str.hs b/ADP/Fusion/Core/Term/Str.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/Term/Str.hs @@ -0,0 +1,61 @@ + +module ADP.Fusion.Core.Term.Str where + +import Data.Strict.Tuple +import GHC.TypeLits +import GHC.TypeNats +import qualified Data.Vector.Generic as VG + +import Data.PrimitiveArray + +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi + + + +-- | A @Str@ wraps an input vector and provides type-level annotations on +-- linked @Str@'s, their minimal and maximal size. +-- +-- If @linked ∷ Maybe Symbol@ is set to @Just aName@, then all @Str@'s that are +-- part of the same rule share their size information. This allows rules of the +-- kind @X -> a Y b@ where @a,b@ have a common maximal size. +-- +-- @minSz@ and @maxSz@ provide minimal and maximal parser width, if set. +-- +-- TODO consider if @maxSz@ could do with just @Nat@ + +data Str (linked ∷ Maybe Symbol) (minSz ∷ Nat) (maxSz ∷ Maybe Nat) v x where + Str ∷ VG.Vector v x + ⇒ !(v x) + → Str linked minSz maxSz v x + +-- | Construct string parsers with no special constraints. + +manyV ∷ VG.Vector v x ⇒ v x → Str Nothing 0 Nothing v x +manyV = Str +{-# Inline manyV #-} + +someV ∷ VG.Vector v x ⇒ v x → Str Nothing 1 Nothing v x +someV = Str +{-# Inline someV #-} + +-- TODO really need to be able to remove this system. Forgetting @Build@ gives +-- very strange type errors. + +instance Build (Str linked minSz maxSz v x) + +instance + ( Element ls i + , VG.Vector v x + ) => Element (ls :!: Str linked minSz maxSz v x) i where + data Elm (ls :!: Str linked minSz maxSz v x) i = ElmStr !(v x) !(RunningIndex i) !(Elm ls i) + type Arg (ls :!: Str linked minSz maxSz v x) = Arg ls :. v x + getArg (ElmStr x _ ls) = getArg ls :. x + getIdx (ElmStr _ i _ ) = i + {-# Inline getArg #-} + {-# Inline getIdx #-} + +deriving instance (Show i, Show (RunningIndex i), Show (v x), Show (Elm ls i)) => Show (Elm (ls :!: Str linked minSz maxSz v x) i) + +type instance TermArg (Str linked minSz maxSz v x) = v x + diff --git a/ADP/Fusion/Core/Term/Switch.hs b/ADP/Fusion/Core/Term/Switch.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/Term/Switch.hs @@ -0,0 +1,48 @@ + +-- | 'Switch'es allow enabling and disabling individual rules on a global +-- level. +-- +-- TODO Consider moving the switch status to the type level. +-- TODO Consider using patterns for the switch status and encode using @Int@s. + +module ADP.Fusion.Core.Term.Switch where + +import Data.Strict.Tuple +import qualified Data.Vector.Generic as VG + +import Data.PrimitiveArray + +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi + + + +-- | Explicit naming of the status of the switch. + +data SwitchStatus = Disabled | Enabled + deriving (Eq,Ord,Show) + +-- | Terminal for the switch. The switch status is not given to any function, +-- since processing of the rule already indicates that the switch is enabled -- +-- if all other symbols parse successfully. Due to consistency, the type of +-- result is @()@. + +data Switch where + Switch ∷ !SwitchStatus → Switch + +instance Build Switch + +instance + ( Element ls i + ) => Element (ls :!: Switch) i where + data Elm (ls :!: Switch) i = ElmSwitch !(RunningIndex i) !(Elm ls i) + type Arg (ls :!: Switch) = Arg ls :. () + getArg (ElmSwitch _ ls) = getArg ls :. () + getIdx (ElmSwitch i _ ) = i + {-# Inline getArg #-} + {-# Inline getIdx #-} + +deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: Switch) i) + +type instance TermArg Switch = () + diff --git a/ADP/Fusion/Core/Term/Test.hs b/ADP/Fusion/Core/Term/Test.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/Term/Test.hs @@ -0,0 +1,60 @@ + +module ADP.Fusion.Core.Term.Test where + +import Data.Strict.Tuple +import qualified Data.Vector.Generic as VG + +import Data.PrimitiveArray + +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi + + + +-- | 'Test' terminals return "strings", i.e. vectors of @Chr@s. They allow +-- the user to specify @[ 0 .. ]@ atoms to be parsed at once. It is +-- possible to both, limit the minimal and maximal number. +-- +-- NOTE gadt comments are not parsed by haddock? + +{- +data Test v x where + Test :: VG.Vector v x + => (Int -> Int -> v x -> v x) -- @slice@ function + -> Int -- minimal size + -> Int -- maximal size (just use s.th. big if you don't want a limit) + -> (v x) -- the actual vector + -> Test v x + +manyS :: VG.Vector v x => v x -> Test v x +manyS = \xs -> Test VG.unsafeSlice 0 (VG.length xs) xs +{-# Inline manyS #-} + +someS :: VG.Vector v x => v x -> Test v x +someS = \xs -> Test VG.unsafeSlice 1 (VG.length xs) xs +{-# Inline someS #-} + +strng :: VG.Vector v x => Int -> Int -> v x -> Test v x +strng = \minL maxL xs -> Test VG.unsafeSlice minL maxL xs +{-# Inline strng #-} +-} + +data Test v x where + Test :: VG.Vector v x => v x -> Test v x + +instance Build (Test v x) + +instance + ( Element ls i + ) => Element (ls :!: Test v x) i where + data Elm (ls :!: Test v x) i = ElmTest !(v x) !(RunningIndex i) !(Elm ls i) + type Arg (ls :!: Test v x) = Arg ls :. v x + getArg (ElmTest x _ ls) = getArg ls :. x + getIdx (ElmTest _ i _ ) = i + {-# Inline getArg #-} + {-# Inline getIdx #-} + +deriving instance (Show i, Show (RunningIndex i), Show (v x), Show (Elm ls i)) => Show (Elm (ls :!: Test v x) i) + +type instance TermArg (Test v x) = v x + diff --git a/ADP/Fusion/Core/TyLvlIx.hs b/ADP/Fusion/Core/TyLvlIx.hs --- a/ADP/Fusion/Core/TyLvlIx.hs +++ b/ADP/Fusion/Core/TyLvlIx.hs @@ -1,12 +1,15 @@ -- | Type-level indexing functionality -module ADP.Fusion.Core.TyLvlIx where +module ADP.Fusion.Core.TyLvlIx + ( module ADP.Fusion.Core.TyLvlIx + , module GHC.TypeLits + ) where import Data.Proxy import GHC.TypeLits -import Data.PrimitiveArray hiding (map) +import Data.PrimitiveArray.Index.Class hiding (map) import ADP.Fusion.Core.Classes (RunningIndex (..)) @@ -22,49 +25,49 @@ instance GetIndexGo (ix:.i) (my:.m) EQ where type ResolvedIx (ix:.i) (my:.m) EQ = i - getIndexGo (ix:.i) _ _ = i - {-# Inline getIndexGo #-} + getIndexGo (ix:.i) _ _ = seq ix $ i + {-# Inline [0] getIndexGo #-} instance (GetIndexGo ix (my:.m) (CmpNat (ToNat ix) (ToNat (my:.m)))) => GetIndexGo (ix:.i) (my:.m) GT where type ResolvedIx (ix:.i) (my:.m) GT = ResolvedIx ix (my:.m) (CmpNat (ToNat ix) (ToNat (my:.m))) getIndexGo (ix:._) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat ix) (ToNat (my:.m)))) - {-# Inline getIndexGo #-} + {-# Inline [0] getIndexGo #-} instance (GetIndexGo ix Z (CmpNat (ToNat ix) (ToNat Z))) => GetIndexGo (ix:.i) Z GT where type ResolvedIx (ix:.i) Z GT = ResolvedIx ix Z (CmpNat (ToNat ix) (ToNat Z)) getIndexGo (ix:._) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat ix) (ToNat Z))) - {-# Inline getIndexGo #-} + {-# Inline [0] getIndexGo #-} instance GetIndexGo Z Z EQ where type ResolvedIx Z Z EQ = Z getIndexGo _ _ _ = Z - {-# Inline getIndexGo #-} + {-# Inline [0] getIndexGo #-} instance GetIndexGo (RunningIndex (ix:.i)) (RunningIndex (my:.m)) EQ where type ResolvedIx (RunningIndex (ix:.i)) (RunningIndex (my:.m)) EQ = RunningIndex i - getIndexGo (ix:.:i) _ _ = i - {-# Inline getIndexGo #-} + getIndexGo (ix:.:i) _ _ = seq ix i + {-# Inline [0] getIndexGo #-} instance ( GetIndexGo (RunningIndex ix) (RunningIndex (my:.m)) (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex (my:.m)))) ) => GetIndexGo (RunningIndex (ix:.i)) (RunningIndex (my:.m)) GT where type ResolvedIx (RunningIndex (ix:.i)) (RunningIndex (my:.m)) GT = ResolvedIx (RunningIndex ix) (RunningIndex (my:.m)) (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex (my:.m)))) getIndexGo (ix:.:_) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex (my:.m))))) - {-# Inline getIndexGo #-} + {-# Inline [0] getIndexGo #-} instance ( GetIndexGo (RunningIndex ix) (RunningIndex Z) (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex Z))) ) => GetIndexGo (RunningIndex (ix:.i)) (RunningIndex Z) GT where type ResolvedIx (RunningIndex (ix:.i)) (RunningIndex Z) GT = ResolvedIx (RunningIndex ix) (RunningIndex Z) (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex Z))) getIndexGo (ix:.:_) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex Z)))) - {-# Inline getIndexGo #-} + {-# Inline [0] getIndexGo #-} instance GetIndexGo (RunningIndex Z) (RunningIndex Z) EQ where type ResolvedIx (RunningIndex Z) (RunningIndex Z) EQ = RunningIndex Z - getIndexGo _ _ _ = RiZ - {-# Inline getIndexGo #-} + getIndexGo riz _ _ = riz + {-# Inline [0] getIndexGo #-} @@ -83,7 +86,7 @@ -> Proxy myTy -> GetIx ixTy myTy getIndex ixTy myTy = getIndexGo ixTy (Proxy :: Proxy myTy) (Proxy :: Proxy (CmpNat (ToNat ixTy) (ToNat myTy))) -{-# Inline getIndex #-} +{-# Inline [0] getIndex #-} diff --git a/ADP/Fusion/Core/Unit.hs b/ADP/Fusion/Core/Unit.hs deleted file mode 100644 --- a/ADP/Fusion/Core/Unit.hs +++ /dev/null @@ -1,98 +0,0 @@ - --- | --- --- TODO the 'mkStream' instances here are probably wonky for everything --- that is non-static. - -module ADP.Fusion.Core.Unit where - -import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..)) -import Debug.Trace -import Prelude hiding (map,filter) - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Core.Classes -import ADP.Fusion.Core.Multi - - - -instance RuleContext (Unit I) where - type Context (Unit I) = InsideContext () - initialContext _ = IStatic () - {-# Inline initialContext #-} - -instance RuleContext (Unit O) where - type Context (Unit O) = OutsideContext () - initialContext _ = OStatic () - {-# Inline initialContext #-} - -instance RuleContext (Unit C) where - type Context (Unit C) = ComplementContext - initialContext _ = Complemented - {-# Inline initialContext #-} - -data instance RunningIndex (Unit t) = RiU - - - -instance (Monad m) => MkStream m S (Unit I) where - mkStream S _ Unit Unit = singleton $ ElmS RiU - {-# Inline mkStream #-} - -instance (Monad m) => MkStream m S (Unit O) where - mkStream S _ Unit Unit = singleton $ ElmS RiU - {-# Inline mkStream #-} - -instance (Monad m) => MkStream m S (Unit C) where - mkStream S _ Unit Unit = singleton $ ElmS RiU - {-# Inline mkStream #-} - -instance - ( Monad m - , MkStream m S is - ) => MkStream m S (is:.Unit I) where - mkStream S (vs:._) (us:._) (is:._) - = map (\(ElmS zi) -> ElmS $ zi :.: RiU) - $ mkStream S vs us is - {-# Inline mkStream #-} - -instance - ( Monad m - , MkStream m S is - ) => MkStream m S (is:.Unit O) where - mkStream S (vs:._) (us:._) (is:._) - = map (\(ElmS zi) -> ElmS $ zi :.: RiU) - $ mkStream S vs us is - {-# Inline mkStream #-} - -instance - ( Monad m - , MkStream m S is - ) => MkStream m S (is:.Unit C) where - mkStream S (vs:._) (us:._) (is:._) - = map (\(ElmS zi) -> ElmS $ zi :.: RiU) - $ mkStream S vs us is - {-# Inline mkStream #-} - - - -instance TableStaticVar c u (Unit I) where - tableStaticVar _ _ _ _ = IStatic () - tableStreamIndex _ _ _ _ = Unit - {-# Inline [0] tableStaticVar #-} - {-# Inline [0] tableStreamIndex #-} - -instance TableStaticVar c u (Unit O) where - tableStaticVar _ _ _ _ = OStatic () - tableStreamIndex _ _ _ _ = Unit - {-# Inline [0] tableStaticVar #-} - {-# Inline [0] tableStreamIndex #-} - -instance TableStaticVar c u (Unit C) where - tableStaticVar _ _ _ _ = Complemented - tableStreamIndex _ _ _ _ = Unit - {-# Inline [0] tableStaticVar #-} - {-# Inline [0] tableStreamIndex #-} - - diff --git a/ADP/Fusion/Point.hs b/ADP/Fusion/Point.hs deleted file mode 100644 --- a/ADP/Fusion/Point.hs +++ /dev/null @@ -1,25 +0,0 @@ - --- | This exports everything needed for sequence-based alignment style --- algorithms. - -module ADP.Fusion.Point - ( module ADP.Fusion.Core - , module ADP.Fusion.Core.Point - , module ADP.Fusion.SynVar.Indices.Point - , module ADP.Fusion.SynVar.Recursive.Point - , module ADP.Fusion.Term.Chr.Point - , module ADP.Fusion.Term.Deletion.Point - , module ADP.Fusion.Term.Strng.Point - , module ADP.Fusion.Term.Epsilon.Point - ) where - -import ADP.Fusion.Core - -import ADP.Fusion.Core.Point -import ADP.Fusion.SynVar.Recursive.Point -import ADP.Fusion.Term.Chr.Point -import ADP.Fusion.Term.Deletion.Point -import ADP.Fusion.Term.Epsilon.Point -import ADP.Fusion.Term.Strng.Point -import ADP.Fusion.SynVar.Indices.Point - diff --git a/ADP/Fusion/PointL.hs b/ADP/Fusion/PointL.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/PointL.hs @@ -0,0 +1,33 @@ + +-- | This exports everything needed for sequence-based alignment style +-- algorithms. +-- +-- Here are some notes on implementation of the Inside and Outside +-- +-- X_j -> S_{j-1} X_{j-1} c_j +-- Y_{j-1} -> S_? X_j c_j +-- Y_j -> S_{j+1} X_{j+1} c_{j+1} + +module ADP.Fusion.PointL + ( module ADP.Fusion.Core + , module ADP.Fusion.PointL.Core + , module ADP.Fusion.PointL.SynVar.Indices +-- , module ADP.Fusion.PointL.SynVar.Recursive + , module ADP.Fusion.PointL.Term.Chr + , module ADP.Fusion.PointL.Term.Deletion + , module ADP.Fusion.PointL.Term.Epsilon + , module ADP.Fusion.PointL.Term.MultiChr + , module ADP.Fusion.PointL.Term.Str + ) where + +import ADP.Fusion.Core + +import ADP.Fusion.PointL.Core +import ADP.Fusion.PointL.SynVar.Indices +--import ADP.Fusion.PointL.SynVar.Recursive +import ADP.Fusion.PointL.Term.Chr +import ADP.Fusion.PointL.Term.Deletion +import ADP.Fusion.PointL.Term.Epsilon +import ADP.Fusion.PointL.Term.MultiChr +import ADP.Fusion.PointL.Term.Str + diff --git a/ADP/Fusion/PointL/Core.hs b/ADP/Fusion/PointL/Core.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/PointL/Core.hs @@ -0,0 +1,191 @@ + +{-# Language MagicHash #-} + +module ADP.Fusion.PointL.Core where + +import GHC.Generics (Generic, Generic1) +import Control.DeepSeq +import Data.Proxy +import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..)) +import Debug.Trace +import Prelude hiding (map,filter) +import GHC.Exts +import GHC.TypeLits + +import Data.PrimitiveArray hiding (map) + +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi + + + +-- * Contexts, and running indices. + +type instance InitialContext (PointL I) = IStatic 0 + +type instance InitialContext (PointL O) = OStatic 0 + +type instance InitialContext (PointL C) = Complement + +newtype instance RunningIndex (PointL I) = RiPlI Int + deriving (Generic) + +deriving instance NFData (RunningIndex (PointL I)) + +data instance RunningIndex (PointL O) = RiPlO !Int !Int + deriving (Generic) + +newtype instance RunningIndex (PointL C) = RiPlC Int + deriving (Generic) + + + +-- * Inside + +-- ** Single-tape +-- +-- TODO should IStatic do these additional control of @I <=# d@? cf. Epsilon Local. + +instance + ( Monad m + , KnownNat d + ) + ⇒ MkStream m (IStatic d) S (PointL I) where + mkStream Proxy S grd (LtPointL (I# u)) (PointL (I# i)) + = staticCheck# ( grd `andI#` (i >=# 0#) `andI#` (i <=# d) `andI#` (i <=# u) ) + . singleton . ElmS $ RiPlI 0 + where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d) + {-# Inline mkStream #-} + +instance + ( Monad m + , KnownNat d + ) + ⇒ MkStream m (IVariable d) S (PointL I) where + mkStream Proxy S grd (LtPointL (I# u)) (PointL (I# i)) + = staticCheck# (grd `andI#` (i >=# 0#) `andI#` (i <=# u) ) + . singleton . ElmS $ RiPlI 0 + {-# Inline mkStream #-} + +-- ** Multi-tape + +instance + ( Monad m + , MkStream m ps S is + , KnownNat d + ) ⇒ MkStream m (ps:.IStatic d) S (is:.PointL I) where + mkStream Proxy S grd (lus:..LtPointL (I# u)) (is:.PointL (I# i)) + = map (\(ElmS e) -> ElmS $ e :.: RiPlI 0) + $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#) `andI#` (i <=# d) `andI#` (i <=# u)) lus is + -- $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#)) lus is + -- NOTE we should optimize which parameters are actually required, the gain is about 10% on the + -- NeedlemanWunsch algorithm + where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d) + {-# Inline mkStream #-} + +instance + ( Monad m + , MkStream m ps S is + , KnownNat d + ) ⇒ MkStream m (ps:.IVariable d) S (is:.PointL I) where + mkStream Proxy S grd (lus:..LtPointL (I# u)) (is:.PointL (I# i)) + = map (\(ElmS e) -> ElmS $ e :.: RiPlI 0) + $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#) `andI#` (i <=# u)) lus is + -- $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#)) lus is + {-# Inline mkStream #-} + + + +-- * Outside + +-- ** Single-tape + +instance + ( Monad m + , KnownNat d + ) ⇒ MkStream m (OStatic d) S (PointL O) where + mkStream Proxy S grd (LtPointL (I# u)) (PointL (I# i)) + = staticCheck# (grd `andI#` (i >=# 0#) `andI#` (i +# d ==# u)) + -- ??? `andI#` (u ==# i) + . singleton . ElmS $ RiPlO (I# i) (I# (i +# d)) + where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d) + {-# Inline mkStream #-} + +instance + ( Monad m + , KnownNat d + ) ⇒ MkStream m (OFirstLeft d) S (PointL O) where + mkStream Proxy s grd (LtPointL (I# u)) (PointL (I# i)) + = staticCheck# (grd `andI#` (i >=# 0#) `andI#` (i +# d <=# u)) + . singleton . ElmS $ RiPlO (I# i) (I# (i +# d)) + where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d) + {-# Inline mkStream #-} + +-- ** Multi-tape + +instance + ( Monad m + , MkStream m ps S is + , KnownNat d + ) ⇒ MkStream m (ps:.OStatic d) S (is:.PointL O) where + mkStream Proxy S grd (lus:..LtPointL (I# u)) (is:.PointL (I# i)) + = map (\(ElmS zi) -> ElmS $ zi :.: RiPlO (I# i) (I# (i +# d))) + -- ??? `andI#` (u ==# i) + $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#) `andI#` (i +# d ==# u)) lus is + where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d) + {-# Inline mkStream #-} + +instance + ( Monad m + , MkStream m ps S is + , KnownNat d + ) ⇒ MkStream m (ps:.OFirstLeft d) S (is:.PointL O) where + mkStream Proxy S grd (lus:..LtPointL (I# u)) (is:.PointL (I# i)) + = map (\(ElmS zi) -> ElmS $ zi :.: RiPlO (I# i) (I# (i +# d))) + $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#) `andI#` (i +# d <=# u)) lus is + where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d) + {-# Inline mkStream #-} + + + +-- * Complemented + +-- ** Single-tape + +instance + ( Monad m + ) ⇒ MkStream m Complement S (PointL C) where + mkStream Proxy S grd (LtPointL (I# u)) (PointL (I# i)) + = error "write me" -- staticCheck# (grd `andI#` (i >=# 0#) `andI#` (i <=# u)) . singleton . ElmS $ RiPlC (I# i) + {-# Inline mkStream #-} + +-- ** Multi-tape + +instance + ( Monad m + , MkStream m ps S is + ) ⇒ MkStream m (ps:.Complement) S (is:.PointL C) where + mkStream Proxy S grd (lus:..LtPointL (I# u)) (is:.PointL (I# i)) + = error "write me" + -- -- = map (\(ElmS zi) → ElmS $ zi :.: RiPlC (I# i)) + -- -- $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#) `andI#` (i <=# u)) lus is + {-# Inline mkStream #-} + + + +-- * Table index modification + +instance (MinSize minSize) ⇒ TableStaticVar pos minSize u (PointL I) where + -- NOTE this code used to destroy fusion. If we inline tableStreamIndex + -- very late (after 'mkStream', probably) then everything works out. + tableStreamIndex Proxy minSz _upperBound (PointL j) = PointL $ j - minSize minSz + {-# INLINE [0] tableStreamIndex #-} + +instance (MinSize minSize) ⇒ TableStaticVar pos minSize u (PointL O) where + tableStreamIndex Proxy minSz _upperBound (PointL j) = PointL $ j - minSize minSz + {-# INLINE [0] tableStreamIndex #-} + +instance (MinSize minSize) ⇒ TableStaticVar pos minSize u (PointL C) where + tableStreamIndex Proxy minSz _upperBound (PointL k) = PointL $ k - minSize minSz + {-# INLINE [0] tableStreamIndex #-} + diff --git a/ADP/Fusion/PointL/SynVar/Indices.hs b/ADP/Fusion/PointL/SynVar/Indices.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/PointL/SynVar/Indices.hs @@ -0,0 +1,139 @@ + +-- | Index movement for syntactic variables in linear @PointL@ grammars. +-- +-- Syntactic variables for @PointL@ indices can be both, static and variable. +-- Static is the default, whenever we have @X -> X a@ where @a@ is a character +-- or similar. However, we can expect to see @a@ as a string as well. Then, @X@ +-- on the r.h.s. is variable. + +module ADP.Fusion.PointL.SynVar.Indices where + +import Data.Proxy +import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..),flatten) +import Data.Vector.Fusion.Util (delay_inline) +import Debug.Trace +import Prelude hiding (map,head,mapM) + +import Data.PrimitiveArray hiding (map) + +import ADP.Fusion.Core +import ADP.Fusion.Core.SynVar.Indices +import ADP.Fusion.PointL.Core + + + +-- * type function for the type of the left position + +-- ** Inside + +type instance LeftPosTy (IStatic d) (TwITbl b s m arr EmptyOk (PointL I) x) (PointL I) = IVariable d +type instance LeftPosTy (IStatic d) (TwITblBt b s arr EmptyOk (PointL I) x mB mF r) (PointL I) = IVariable d + +type instance LeftPosTy (IVariable d) (TwITbl b s m arr EmptyOk (PointL I) x) (PointL I) = IVariable d +type instance LeftPosTy (IVariable d) (TwITblBt b s arr EmptyOk (PointL I) x mB mF r) (PointL I) = IVariable d + +-- ** Outside + +type instance LeftPosTy (OStatic d) (TwITbl b s m arr EmptyOk (PointL O) x) (PointL O) = OFirstLeft d +type instance LeftPosTy (OStatic d) (TwITblBt b s arr EmptyOk (PointL O) x mB mF r) (PointL O) = OFirstLeft d + +-- TODO @OLeftOf@ + +type instance LeftPosTy (OFirstLeft d) (TwITbl b s m arr EmptyOk (PointL O) x) (PointL O) = TypeError + (Text "OFirstLeft is illegal for outside tables. Check your grammars for multiple Outside syntactic variable on the r.h.s!") +type instance LeftPosTy (OFirstLeft d) (TwITblBt b s arr EmptyOk (PointL O) x mB mF r) (PointL O) = TypeError + (Text "OFirstLeft is illegal for outside tables. Check your grammars for multiple Outside syntactic variable on the r.h.s!") + +type instance LeftPosTy (OLeftOf d) (TwITbl b s m arr EmptyOk (PointL O) x) (PointL O) = TypeError + (Text "OLeftOf is illegal for outside tables. Check your grammars for multiple Outside syntactic variable on the r.h.s!") +type instance LeftPosTy (OLeftOf d) (TwITblBt s b arr EmptyOk (PointL O) x mB mF r) (PointL O) = TypeError + (Text "OLeftOf is illegal for outside tables. Check your grammars for multiple Outside syntactic variable on the r.h.s!") + +-- ** Complement. Note that @Complement@ joins inside and outside syntactic +-- variables. + +type instance LeftPosTy Complement (TwITbl b s m arr EmptyOk (PointL I) x) (PointL C) = Complement +type instance LeftPosTy Complement (TwITblBt b s arr EmptyOk (PointL I) x mB mF r) (PointL C) = Complement + +type instance LeftPosTy Complement (TwITbl b s m arr EmptyOk (PointL O) x) (PointL C) = Complement +type instance LeftPosTy Complement (TwITblBt b s arr EmptyOk (PointL O) x mB mF r) (PointL C) = Complement + + + +-- * 'AddIndexDense' instances + +-- ** Inside + +instance + ( AddIndexDenseContext ps elm x0 i0 cs c us (PointL I) is (PointL I) + , MinSize c + ) + ⇒ AddIndexDense (ps:.IStatic d) elm (cs:.c) (us:.PointL I) (is:.PointL I) where + addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i) + = map (\(SvS s t y') → SvS s (t:.i) (y' :.: RiPlI (fromPointL i))) + . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is + {-# Inline addIndexDenseGo #-} + +instance + ( AddIndexDenseContext ps elm x0 i0 cs c us (PointL I) is (PointL I) + , MinSize c + ) + ⇒ AddIndexDense (ps:.IVariable d) elm (cs:.c) (us:.PointL I) (is:.PointL I) where + addIndexDenseGo Proxy (cs:.c) (ubs:..ub) (us:..u) (is:.PointL i) + = flatten mk step . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is + where mk svS = let RiPlI k = getIndex (getIdx $ sS svS {- sIx svS -} ) (Proxy :: PRI is (PointL I)) + in return $ svS :. k + step (svS@(SvS s t y') :. k) + | k + csize > i = return $ Done + | otherwise = return $ Yield (SvS s (t:.PointL k) (y' :.: RiPlI k)) (svS :. k+1) + where csize = minSize c + {-# Inline [0] mk #-} + {-# Inline [0] step #-} + {-# Inline addIndexDenseGo #-} + + + +-- ** Outside + +instance + ( AddIndexDenseContext ps elm x0 i0 cs c us (PointL O) is (PointL O) + , MinSize c + ) ⇒ AddIndexDense (ps:.OStatic d) elm (cs:.c) (us:.PointL O) (is:.PointL O) where + addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i) + = map (\(SvS s t y') → let RiPlO oi oo = getIndex (getIdx s) (Proxy :: PRI is (PointL O)) + in SvS s (t:.PointL oo) (y' :.: RiPlO oi oo) ) + . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is + {-# Inline addIndexDenseGo #-} + +instance + ( AddIndexDenseContext ps elm x0 i0 cs c us (PointL O) is (PointL O) + , MinSize c + ) ⇒ AddIndexDense (ps:.ORightOf d) elm (cs:.c) (us:.PointL O) (is:.PointL O) where + addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i) + = map (\(SvS s t y') → let RiPlO oi oo = getIndex (getIdx s) (Proxy :: PRI is (PointL O)) + in SvS s (t:.PointL oo) (y' :.: RiPlO oi oo) ) + . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is + {-# Inline addIndexDenseGo #-} + + + +-- ** Complement + +instance + ( AddIndexDenseContext ps elm x0 i0 cs c us (PointL I) is (PointL C) + ) ⇒ AddIndexDense (ps:.Complement) elm (cs:.c) (us:.PointL I) (is:.PointL C) where + addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i) + = map (\(SvS s t y) → let RiPlC k = getIndex (getIdx s) (Proxy :: PRI is (PointL C)) + in SvS s (t:.PointL k) (y :.: RiPlC k) ) + . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is + {-# Inline addIndexDenseGo #-} + +instance + ( AddIndexDenseContext ps elm x0 i0 cs c us (PointL O) is (PointL C) + ) ⇒ AddIndexDense (ps:.Complement) elm (cs:.c) (us:.PointL O) (is:.PointL C) where + addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i) + = map (\(SvS s t y) → let RiPlC k = getIndex (getIdx s) (Proxy :: PRI is (PointL C)) + in SvS s (t:.PointL k) (y:.:RiPlC k) ) + . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is + {-# Inline addIndexDenseGo #-} + diff --git a/ADP/Fusion/PointL/Term/Chr.hs b/ADP/Fusion/PointL/Term/Chr.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/PointL/Term/Chr.hs @@ -0,0 +1,81 @@ + +module ADP.Fusion.PointL.Term.Chr where + +import Data.Proxy +import Data.Strict.Tuple +import Debug.Trace +import qualified Data.Vector.Fusion.Stream.Monadic as S +import qualified Data.Vector.Generic as VG +import GHC.Exts + +import Data.PrimitiveArray + +import ADP.Fusion.Core +import ADP.Fusion.Core.Term.Chr +import ADP.Fusion.PointL.Core + + + +type instance LeftPosTy (IStatic d) (Chr r x) (PointL I) = IStatic d +--type instance LeftPosTy (IVariable d) (Chr r x) (PointL I) = IVariable d + +type instance LeftPosTy (OStatic d) (Chr r x) (PointL O) = OStatic (d+1) + +-- | First try in getting this right with a @termStream@. +-- +-- TODO use @PointL i@ since this is probably the same for all single-tape +-- instances with @ElmChr@. +-- +-- TODO it might even be possible to auto-generate this code via TH. + +instance + forall pos posLeft m ls r x i + . ( TermStream m (Z:.pos) (TermSymbol M (Chr r x)) (Elm (Term1 (Elm ls (PointL i))) (Z :. PointL i)) (Z:.PointL i) + , posLeft ~ LeftPosTy pos (Chr r x) (PointL i) + , TermStaticVar pos (Chr r x) (PointL i) + , MkStream m posLeft ls (PointL i) + ) + ⇒ MkStream m pos (ls :!: Chr r x) (PointL i) where + mkStream pos (ls :!: Chr f xs) grd us is + = S.map (\(ss,ee,ii) -> ElmChr ee ii ss) -- recover ElmChr + . addTermStream1 pos (Chr f xs) us is + $ mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos (Chr f xs) us is grd) us (termStreamIndex pos (Chr f xs) is) + {-# Inline mkStream #-} + + +-- | + +instance + ( TermStreamContext m ps ts s x0 i0 is (PointL I) + ) => TermStream m (ps:.IStatic d) (TermSymbol ts (Chr r x)) s (is:.PointL I) where + termStream Proxy (ts:|Chr f xs) (us:..LtPointL u) (is:.PointL i) + -- NOTE changing from @f xs (i-1)@ to @f xs $! i-1@, forcing @i-1@ first, + -- yielding 50% better performance in Needleman-Wunsch + = S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:. (f xs $! i-1))) + . termStream (Proxy ∷ Proxy ps) ts us is + {-# Inline termStream #-} + +instance + ( TermStreamContext m ps ts s x0 i0 is (PointL O) + ) => TermStream m (ps:.OStatic d) (TermSymbol ts (Chr r x)) s (is:.PointL O) where + termStream Proxy (ts:|Chr f xs) (us:..LtPointL u) (is:.PointL i) + = S.map (\(TState s ii ee) -> + let RiPlO k o = getIndex (getIdx s) (Proxy :: PRI is (PointL O)) + in TState s (ii:.: RiPlO (k+1) o) (ee:.f xs k)) + . termStream (Proxy ∷ Proxy ps) ts us is + {-# Inline termStream #-} + + + +instance TermStaticVar (IStatic d) (Chr r x) (PointL I) where + termStreamIndex Proxy (Chr f x) (PointL j) = PointL $! j-1 + termStaticCheck Proxy (Chr f x) _ (PointL j) grd = grd + {-# Inline [0] termStreamIndex #-} + {-# Inline [0] termStaticCheck #-} + +instance TermStaticVar (OStatic d) (Chr r x) (PointL O) where + termStreamIndex Proxy (Chr f x) (PointL j) = PointL $ j + termStaticCheck Proxy (Chr f x) _ (PointL j) grd = grd + {-# Inline [0] termStreamIndex #-} + {-# Inline [0] termStaticCheck #-} + diff --git a/ADP/Fusion/PointL/Term/Deletion.hs b/ADP/Fusion/PointL/Term/Deletion.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/PointL/Term/Deletion.hs @@ -0,0 +1,85 @@ + +module ADP.Fusion.PointL.Term.Deletion where + +import Data.Proxy +import Data.Strict.Tuple +import qualified Data.Vector.Fusion.Stream.Monadic as S +import GHC.Exts + +import Data.PrimitiveArray + +import ADP.Fusion.Core +import ADP.Fusion.Core.Term.Deletion +import ADP.Fusion.PointL.Core + + + +type instance LeftPosTy (IStatic d) Deletion (PointL I) = IStatic d +type instance LeftPosTy (IVariable d) Deletion (PointL I) = IVariable d + +type instance LeftPosTy (OStatic d) Deletion (PointL O) = OStatic d + +instance + forall pos posLeft m ls i + . ( TermStream m (Z:.pos) (TermSymbol M Deletion) (Elm (Term1 (Elm ls (PointL i))) (Z :. PointL i)) (Z:.PointL i) + , posLeft ~ LeftPosTy pos Deletion (PointL i) + , TermStaticVar pos Deletion (PointL i) + , MkStream m posLeft ls (PointL i) + ) + ⇒ MkStream m pos (ls :!: Deletion) (PointL i) where + mkStream pos (ls :!: Deletion) grd us is + = S.map (\(ss,ee,ii) -> ElmDeletion ii ss) + . addTermStream1 pos Deletion us is + $ mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos Deletion us is grd) us (termStreamIndex pos Deletion is) + {-# Inline mkStream #-} + + + +instance + ( TermStreamContext m ps ts s x0 i0 is (PointL I) + ) + ⇒ TermStream m (ps:.IStatic d) (TermSymbol ts Deletion) s (is:.PointL I) where + termStream Proxy (ts:|Deletion) (us:..LtPointL u) (is:.PointL i) + = S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:.())) + . termStream (Proxy ∷ Proxy ps) ts us is + {-# Inline termStream #-} + +instance + ( TermStreamContext m ps ts s x0 i0 is (PointL I) + ) + ⇒ TermStream m (ps:.IVariable d) (TermSymbol ts Deletion) s (is:.PointL I) where + termStream Proxy (ts:|Deletion) (us:..LtPointL u) (is:.PointL i) + = S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:.())) + . termStream (Proxy ∷ Proxy ps) ts us is + {-# Inline termStream #-} + +instance + ( TermStreamContext m ps ts s x0 i0 is (PointL O) + ) => TermStream m (ps:.OStatic d) (TermSymbol ts Deletion) s (is:.PointL O) where + termStream Proxy (ts:|Deletion) (us:..LtPointL u) (is:.PointL i) + = S.map (\(TState s ii ee) -> + let io = getIndex (getIdx s) (Proxy :: PRI is (PointL O)) + in TState s (ii:.: io) (ee:.())) + . termStream (Proxy ∷ Proxy ps) ts us is + {-# Inline termStream #-} + + + +instance TermStaticVar (IStatic d) Deletion (PointL I) where + termStreamIndex Proxy Deletion (PointL j) = PointL j + termStaticCheck Proxy Deletion _ (PointL j) grd = grd + {-# Inline [0] termStreamIndex #-} + {-# Inline [0] termStaticCheck #-} + +instance TermStaticVar (IVariable d) Deletion (PointL I) where + termStreamIndex Proxy Deletion (PointL j) = PointL j + termStaticCheck Proxy Deletion _ (PointL j) grd = grd + {-# Inline [0] termStreamIndex #-} + {-# Inline [0] termStaticCheck #-} + +instance TermStaticVar oAny Deletion (PointL O) where + termStreamIndex Proxy Deletion (PointL j) = PointL j + termStaticCheck Proxy Deletion _ (PointL j) grd = grd + {-# Inline [0] termStreamIndex #-} + {-# Inline [0] termStaticCheck #-} + diff --git a/ADP/Fusion/PointL/Term/Epsilon.hs b/ADP/Fusion/PointL/Term/Epsilon.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/PointL/Term/Epsilon.hs @@ -0,0 +1,119 @@ + +-- | Rules of the type @X → ε@ denote termination of parsing if @X@ is empty. + +module ADP.Fusion.PointL.Term.Epsilon where + +import Data.Proxy +import Data.Strict.Tuple +import qualified Data.Vector.Fusion.Stream.Monadic as S +import GHC.Exts + +import Data.PrimitiveArray + +import ADP.Fusion.Core +import ADP.Fusion.Core.Term.Epsilon +import ADP.Fusion.PointL.Core + + + +type instance LeftPosTy (IStatic d) (Epsilon Global) (PointL I) = IStatic d +type instance LeftPosTy (IStatic d) (Epsilon Local) (PointL I) = IVariable d -- to actually allow local epsilons to work, IStatic does additional static controls +--type instance LeftPosTy (IVariable d) Epsilon (PointL I) = IVariable d + +type instance LeftPosTy (OStatic d) (Epsilon Global) (PointL O) = OStatic d + +instance + forall pos posLeft m ls i lg + . ( TermStream m (Z:.pos) (TermSymbol M (Epsilon lg)) (Elm (Term1 (Elm ls (PointL i))) (Z :. PointL i)) (Z:.PointL i) + , posLeft ~ LeftPosTy pos (Epsilon lg) (PointL i) + , TermStaticVar pos (Epsilon lg) (PointL i) + , MkStream m posLeft ls (PointL i) + ) + ⇒ MkStream m pos (ls :!: (Epsilon lg)) (PointL i) where + mkStream Proxy (ls :!: Epsilon) grd us is + = S.map (\(ss,ee,ii) -> ElmEpsilon ii ss) + . addTermStream1 (Proxy ∷ Proxy pos) (Epsilon @lg) us is + $ mkStream (Proxy ∷ Proxy posLeft) + ls + (termStaticCheck (Proxy ∷ Proxy pos) (Epsilon @lg) us is grd) + us + (termStreamIndex (Proxy ∷ Proxy pos) (Epsilon @lg) is) + {-# Inline mkStream #-} + + +instance + ( TermStreamContext m ps ts s x0 i0 is (PointL I) + ) + ⇒ TermStream m (ps:.IStatic d) (TermSymbol ts (Epsilon lg)) s (is:.PointL I) where + termStream Proxy (ts:|Epsilon) (us:..LtPointL u) (is:.PointL i) + = S.map (\(TState s ii ee) -> + let RiPlI k = getIndex (getIdx s) (Proxy :: PRI is (PointL I)) + in TState s (ii:.:RiPlI k) (ee:.())) + . termStream (Proxy ∷ Proxy ps) ts us is + {-# Inline termStream #-} + +{- +instance + ( TermStreamContext m ps ts s x0 i0 is (PointL I) + ) + ⇒ TermStream m (ps:.IVariable d) (TermSymbol ts Epsilon) s (is:.PointL I) where + termStream Proxy (ts:|Epsilon) (us:..LtPointL u) (is:.PointL i) + = S.map (\(TState s ii ee) -> + let RiPlI k = getIndex (getIdx s) (Proxy :: PRI is (PointL I)) + in TState s (ii:.:RiPlI k) (ee:.())) + . termStream (Proxy ∷ Proxy ps) ts us is + {-# Inline termStream #-} +-} + +instance + ( TermStreamContext m ps ts s x0 i0 is (PointL O) + ) => TermStream m (ps:.OStatic d) (TermSymbol ts (Epsilon lg)) s (is:.PointL O) where + termStream Proxy (ts:|Epsilon) (us:..LtPointL u) (is:.PointL i) + = S.map (\(TState s ii ee) -> + let io = getIndex (getIdx s) (Proxy :: PRI is (PointL O)) + in TState s (ii:.:io) (ee:.())) + . termStream (Proxy ∷ Proxy ps) ts us is + {-# Inline termStream #-} + +-- | We assume that @ε / Epsilon@ is ever only the single symbol (maybe apart +-- from @- / Deletion@) on a tape. Hence The instance is only active in +-- @IStatic 0@ cases. + +instance TermStaticVar (IStatic 0) (Epsilon Global) (PointL I) where + termStreamIndex Proxy Epsilon (PointL i ) = PointL i + termStaticCheck Proxy Epsilon _ (PointL (I# i)) grd = (i ==# 0#) `andI#` grd + {-# Inline [0] termStreamIndex #-} + {-# Inline [0] termStaticCheck #-} + +instance TermStaticVar (IStatic 0) (Epsilon Local) (PointL I) where + termStreamIndex Proxy Epsilon (PointL i ) = PointL i + -- | Local epsilons are *always* possible. + termStaticCheck Proxy Epsilon _ (PointL (I# i)) grd = grd + {-# Inline termStreamIndex #-} + {-# Inline termStaticCheck #-} + +instance TermStaticVar (OStatic 0) (Epsilon Global) (PointL O) where + termStreamIndex Proxy Epsilon (PointL i ) = PointL i + -- | + -- + -- TODO Consider this as a potential bug: we do *not* check that the upper + -- bound @us@ (which we not even hand over to termStaticCheck but should) is + -- equal to the current index @i@. HERE this ends up not being a bug because + -- @Epsilon@ keeps the positional system at @OStatic@ and does not move to + -- @ORightOf@ or anything, and in correct epsilon rules, everything is fine. + -- + -- We even end up being correct with @X -> whatever epsilon@ because epsilon + -- is neutral ... + -- + -- TODO But we should probably statically assert that epsilon is the only + -- symbol on the r.h.s. of whatever we write ... + termStaticCheck Proxy Epsilon (LtPointL (I# u)) (PointL (I# i)) grd = (u ==# i) `andI#` grd + {-# Inline [0] termStreamIndex #-} + {-# Inline [0] termStaticCheck #-} + +instance TermStaticVar (OStatic 0) (Epsilon Local) (PointL O) where + termStreamIndex Proxy Epsilon (PointL i ) = PointL i + termStaticCheck Proxy Epsilon (LtPointL (I# u)) (PointL (I# i)) grd = grd + {-# Inline [0] termStreamIndex #-} + {-# Inline [0] termStaticCheck #-} + diff --git a/ADP/Fusion/PointL/Term/MultiChr.hs b/ADP/Fusion/PointL/Term/MultiChr.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/PointL/Term/MultiChr.hs @@ -0,0 +1,85 @@ + +module ADP.Fusion.PointL.Term.MultiChr where + +import Data.Proxy +import Data.Strict.Tuple +import Debug.Trace +import GHC.Exts +--import GHC.TypeNats +import qualified Data.Vector.Fusion.Stream.Monadic as S +import qualified Data.Vector.Generic as VG + +import Data.PrimitiveArray + +import ADP.Fusion.Core +import ADP.Fusion.Core.Term.MultiChr +import ADP.Fusion.PointL.Core + + + +type instance LeftPosTy (IStatic d) (MultiChr c v x) (PointL I) = IStatic d +--type instance LeftPosTy (IVariable d) (Chr r x) (PointL I) = IVariable d + +type instance LeftPosTy (OStatic d) (MultiChr c v x) (PointL O) = OStatic (d + c) + +-- | First try in getting this right with a @termStream@. +-- +-- TODO use @PointL i@ since this is probably the same for all single-tape +-- instances with @ElmChr@. +-- +-- TODO it might even be possible to auto-generate this code via TH. + +instance + forall pos posLeft m ls c v x i + . ( TermStream m (Z:.pos) (TermSymbol M (MultiChr c v x)) (Elm (Term1 (Elm ls (PointL i))) (Z :. PointL i)) (Z:.PointL i) + , posLeft ~ LeftPosTy pos (MultiChr c v x) (PointL i) + , TermStaticVar pos (MultiChr c v x) (PointL i) + , MkStream m posLeft ls (PointL i) + ) + ⇒ MkStream m pos (ls :!: MultiChr c v x) (PointL i) where + mkStream pos (ls :!: MultiChr xs) grd us is + = S.map (\(ss,ee,ii) -> ElmMultiChr ee ii ss) -- recover ElmChr + . addTermStream1 pos (MultiChr @v @x @c xs) us is + $ mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos (MultiChr @v @x @c xs) us is grd) us (termStreamIndex pos (MultiChr @v @x @c xs) is) + {-# Inline mkStream #-} + + +-- | + +instance + ( TermStreamContext m ps ts s x0 i0 is (PointL I) + , KnownNat c + ) => TermStream m (ps:.IStatic d) (TermSymbol ts (MultiChr c v x)) s (is:.PointL I) where + termStream Proxy (ts:|MultiChr xs) (us:..LtPointL u) (is:.PointL i) + = let !c = fromIntegral $ natVal (Proxy ∷ Proxy c) in + S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:. VG.unsafeSlice (i-c) c xs)) + . termStream (Proxy ∷ Proxy ps) ts us is + {-# Inline termStream #-} + +instance + ( TermStreamContext m ps ts s x0 i0 is (PointL O) + , KnownNat c + ) => TermStream m (ps:.OStatic d) (TermSymbol ts (MultiChr c v x)) s (is:.PointL O) where + termStream Proxy (ts:|MultiChr xs) (us:..LtPointL u) (is:.PointL i) + = S.map (\(TState s ii ee) -> + let RiPlO k o = getIndex (getIdx s) (Proxy :: PRI is (PointL O)) + c = fromIntegral $ natVal (Proxy ∷ Proxy c) + in TState s (ii:.: RiPlO (k+c) o) (ee:.VG.unsafeSlice k c xs)) + . termStream (Proxy ∷ Proxy ps) ts us is + {-# Inline termStream #-} + + + +instance (KnownNat c) ⇒ TermStaticVar (IStatic d) (MultiChr c v x) (PointL I) where + termStreamIndex Proxy (MultiChr x) (PointL j) = PointL $ j-(fromIntegral $ natVal (Proxy ∷ Proxy c)) + termStaticCheck Proxy (MultiChr x) _ (PointL j) grd = grd + {-# Inline [0] termStreamIndex #-} + {-# Inline [0] termStaticCheck #-} + +instance TermStaticVar (OStatic d) (MultiChr c v x) (PointL O) where + termStreamIndex Proxy (MultiChr x) (PointL j) = PointL $ j + -- | TODO check if @c@ to the right goes out of bounds? + termStaticCheck Proxy (MultiChr x) _ (PointL j) grd = grd + {-# Inline [0] termStreamIndex #-} + {-# Inline [0] termStaticCheck #-} + diff --git a/ADP/Fusion/PointL/Term/Str.hs b/ADP/Fusion/PointL/Term/Str.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/PointL/Term/Str.hs @@ -0,0 +1,87 @@ + +module ADP.Fusion.PointL.Term.Str where + +import Data.Proxy +import Data.Strict.Tuple +import Debug.Trace +import GHC.Exts +--import GHC.TypeNats +import qualified Data.Vector.Fusion.Stream.Monadic as S +import qualified Data.Vector.Generic as VG + +import Data.PrimitiveArray + +import ADP.Fusion.Core +import ADP.Fusion.Core.Term.Str +import ADP.Fusion.PointL.Core + + + +-- minSz done via TermStaticVar ?! + +type instance LeftPosTy (IStatic d) (Str linked minSz maxSz v x) (PointL I) = IVariable d +type instance LeftPosTy (IVariable d) (Str linked minSz maxSz v x) (PointL I) = IVariable d + +{- +type instance LeftPosTy (OStatic d) (Chr r x) (PointL O) = OStatic (d+1) +-} + +-- | + +instance + forall pos posLeft m ls linked minSz maxSz v x i + . ( TermStream m (Z:.pos) (TermSymbol M (Str linked minSz maxSz v x)) + (Elm (Term1 (Elm ls (PointL i))) (Z :. PointL i)) (Z:.PointL i) + , posLeft ~ LeftPosTy pos (Str linked minSz maxSz v x) (PointL i) + , TermStaticVar pos (Str linked minSz maxSz v x) (PointL i) + , MkStream m posLeft ls (PointL i) + ) + ⇒ MkStream m pos (ls :!: Str linked minSz maxSz v x) (PointL i) where + mkStream pos (ls :!: Str xs) grd us is + = S.map (\(ss,ee,ii) -> ElmStr ee ii ss) -- recover ElmChr + . addTermStream1 pos (Str @v @x @linked @minSz @maxSz xs) us is + $ mkStream (Proxy ∷ Proxy posLeft) ls + (termStaticCheck pos (Str @v @x @linked @minSz @maxSz xs) us is grd) + us (termStreamIndex pos (Str @v @x @linked @minSz @maxSz xs) is) + {-# Inline mkStream #-} + +-- | Note that the @minSz@ should automatically work out due to the encoding in +-- @d@. + +instance + ( TermStreamContext m ps ts s x0 i0 is (PointL I) + ) ⇒ TermStream m (ps:.IStatic d) (TermSymbol ts (Str Nothing minSz Nothing v x)) s (is:.PointL I) where + termStream Proxy (ts:|Str xs) (us:..LtPointL u) (is:.PointL i) + = S.map (\(TState s ii ee) → + let RiPlI k = getIndex (getIdx s) (Proxy ∷ PRI is (PointL I)) + in TState s (ii:.:RiPlI i) (ee:.VG.slice k (i-k) xs)) + . termStream (Proxy ∷ Proxy ps) ts us is + {-# Inline termStream #-} + +{- +instance + ( TermStreamContext m ps ts s x0 i0 is (PointL O) + ) => TermStream m (ps:.OStatic d) (TermSymbol ts (Chr r x)) s (is:.PointL O) where + termStream Proxy (ts:|Chr f xs) (us:..LtPointL u) (is:.PointL i) + = S.map (\(TState s ii ee) -> + let RiPlO k o = getIndex (getIdx s) (Proxy :: PRI is (PointL O)) + in TState s (ii:.: RiPlO (k+1) o) (ee:.f xs k)) + . termStream (Proxy ∷ Proxy ps) ts us is + {-# Inline termStream #-} +-} + +instance (KnownNat minSz) + ⇒ TermStaticVar (IStatic d) (Str Nothing minSz Nothing v x) (PointL I) where + termStreamIndex Proxy (Str xs) (PointL j) = PointL $ j - fromIntegral (natVal (Proxy ∷ Proxy minSz)) + termStaticCheck Proxy (Str xs) _ (PointL j) grd = grd + {-# Inline [0] termStreamIndex #-} + {-# Inline [0] termStaticCheck #-} + +{- +instance TermStaticVar (OStatic d) (Chr r x) (PointL O) where + termStreamIndex Proxy (Chr f x) (PointL j) = PointL $ j + termStaticCheck Proxy (Chr f x) (PointL j) = 1# + {-# Inline [0] termStreamIndex #-} + {-# Inline [0] termStaticCheck #-} +-} + diff --git a/ADP/Fusion/PointL/Term/Switch.hs b/ADP/Fusion/PointL/Term/Switch.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/PointL/Term/Switch.hs @@ -0,0 +1,75 @@ + +module ADP.Fusion.PointL.Term.Switch where + +import Data.Proxy +import Data.Strict.Tuple +import Debug.Trace +import qualified Data.Vector.Fusion.Stream.Monadic as S +import qualified Data.Vector.Generic as VG +import GHC.Exts + +import Data.PrimitiveArray + +import ADP.Fusion.Core +import ADP.Fusion.Core.Term.Switch +import ADP.Fusion.PointL.Core + + + +type instance LeftPosTy (IStatic d) Switch (PointL I) = IStatic d +type instance LeftPosTy (IVariable d) Switch (PointL I) = IVariable d + +type instance LeftPosTy (OStatic d) Switch (PointL O) = OStatic d + +-- | + +instance + forall pos posLeft m ls r x i + . ( TermStream m (Z:.pos) (TermSymbol M Switch) (Elm (Term1 (Elm ls (PointL i))) (Z :. PointL i)) (Z:.PointL i) + , posLeft ~ LeftPosTy pos Switch (PointL i) + , TermStaticVar pos Switch (PointL i) + , MkStream m posLeft ls (PointL i) + ) + ⇒ MkStream m pos (ls :!: Switch) (PointL i) where + mkStream pos (ls :!: Switch s) grd us is + = S.map (\(ss,ee,ii) -> ElmSwitch ii ss) -- recover ElmChr + . addTermStream1 pos (Switch s) us is + $ mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos (Switch s) us is grd) us (termStreamIndex pos (Switch s) is) + {-# Inline mkStream #-} + + +-- | + +instance + ( TermStreamContext m ps ts s x0 i0 is (PointL I) + ) => TermStream m (ps:.IStatic d) (TermSymbol ts Switch) s (is:.PointL I) where + termStream Proxy (ts:|Switch s) (us:..LtPointL u) (is:.PointL i) + = S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:. ())) + . termStream (Proxy ∷ Proxy ps) ts us is + {-# Inline termStream #-} + +instance + ( TermStreamContext m ps ts s x0 i0 is (PointL O) + ) => TermStream m (ps:.OStatic d) (TermSymbol ts Switch) s (is:.PointL O) where + termStream Proxy (ts:|Switch s) (us:..LtPointL u) (is:.PointL i) + = S.map (\(TState s ii ee) -> + let ko = getIndex (getIdx s) (Proxy :: PRI is (PointL O)) + in TState s (ii:.:ko) (ee:.())) + . termStream (Proxy ∷ Proxy ps) ts us is + {-# Inline termStream #-} + + + +instance TermStaticVar (IStatic d) Switch (PointL I) where + termStreamIndex Proxy (Switch s) (PointL j) = PointL $ j + -- TODO is trac #15696 a problem here? + termStaticCheck Proxy (Switch s) _ (PointL j) grd = dataToTag# s `andI#` grd -- case s of {Enabled → grd; Disabled → 0# } + {-# Inline [0] termStreamIndex #-} + {-# Inline [0] termStaticCheck #-} + +instance TermStaticVar (OStatic d) Switch (PointL O) where + termStreamIndex Proxy (Switch s) (PointL j) = PointL $ j + termStaticCheck Proxy (Switch s) _ (PointL j) grd = case s of {Enabled → grd; Disabled → 0# } + {-# Inline [0] termStreamIndex #-} + {-# Inline [0] termStaticCheck #-} + diff --git a/ADP/Fusion/PointR.hs b/ADP/Fusion/PointR.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/PointR.hs @@ -0,0 +1,29 @@ + +-- | This exports everything needed for sequence-based alignment style +-- algorithms. +-- +-- Here are some notes on implementation of the Inside and Outside +-- +-- X_j -> S_{j-1} X_{j-1} c_j +-- Y_{j-1} -> S_? X_j c_j +-- Y_j -> S_{j+1} X_{j+1} c_{j+1} + +module ADP.Fusion.PointR + ( module ADP.Fusion.Core + , module ADP.Fusion.PointR.Core + , module ADP.Fusion.PointR.SynVar.Indices + , module ADP.Fusion.PointR.Term.Chr + , module ADP.Fusion.PointR.Term.Deletion + , module ADP.Fusion.PointR.Term.Epsilon + , module ADP.Fusion.PointR.Term.MultiChr + ) where + +import ADP.Fusion.Core + +import ADP.Fusion.PointR.Core +import ADP.Fusion.PointR.SynVar.Indices +import ADP.Fusion.PointR.Term.Chr +import ADP.Fusion.PointR.Term.Deletion +import ADP.Fusion.PointR.Term.Epsilon +import ADP.Fusion.PointR.Term.MultiChr + diff --git a/ADP/Fusion/PointR/Core.hs b/ADP/Fusion/PointR/Core.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/PointR/Core.hs @@ -0,0 +1,121 @@ + +{-# Language MagicHash #-} + +module ADP.Fusion.PointR.Core where + +import GHC.Generics (Generic, Generic1) +import Control.DeepSeq +import Data.Proxy +import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..)) +import Debug.Trace +import Prelude hiding (map,filter) +import GHC.Exts +import GHC.TypeLits + +import Data.PrimitiveArray hiding (map) + +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi + + + +-- * Contexts, and running indices. + +type instance InitialContext (PointR I) = IStatic 0 + +type instance InitialContext (PointR O) = OStatic 0 + +type instance InitialContext (PointR C) = Complement + +newtype instance RunningIndex (PointR I) = RiPrI Int + deriving (Generic) + +deriving instance NFData (RunningIndex (PointR I)) + +data instance RunningIndex (PointR O) = RiPrO !Int !Int + deriving (Generic) + +newtype instance RunningIndex (PointR C) = RiPrC Int + deriving (Generic) + + + +-- * Inside + +-- ** Single-tape + +instance + ( Monad m + , KnownNat d + ) + ⇒ MkStream m (IStatic d) S (PointR I) where + mkStream Proxy S grd (LtPointR (I# u)) (PointR (I# i)) + = staticCheck# ( grd `andI#` (i >=# 0#) `andI#` (i +# d ==# u) ) -- TODO include @d@ correctly: i<=d + . singleton . ElmS . RiPrI $ I# i + where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d) + {-# Inline mkStream #-} + +instance + ( Monad m + , KnownNat d + ) + ⇒ MkStream m (IVariable d) S (PointR I) where + mkStream Proxy S grd (LtPointR (I# u)) (PointR (I# i)) + = staticCheck# (grd `andI#` (i >=# 0#) `andI#` (i +# d <=# u)) + . singleton . ElmS . RiPrI $ I# i + where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d) + {-# Inline mkStream #-} + + + +-- ** Multi-tape + +instance + ( Monad m + , MkStream m ps S is + , KnownNat d + ) ⇒ MkStream m (ps:.IStatic d) S (is:.PointR I) where + mkStream Proxy S grd (lus:..LtPointR (I# u)) (is:.PointR (I# i)) + = map (\(ElmS e) -> ElmS $ e :.: RiPrI (I# i)) + $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#) `andI#` (i +# d ==# u)) lus is + where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d) + {-# Inline mkStream #-} + +instance + ( Monad m + , MkStream m ps S is + , KnownNat d + ) ⇒ MkStream m (ps:.IVariable d) S (is:.PointR I) where + mkStream Proxy S grd (lus:..LtPointR (I# u)) (is:.PointR (I# i)) + = map (\(ElmS e) -> ElmS $ e :.: RiPrI (I# i)) + $ mkStream (Proxy ∷ Proxy ps) S (grd `andI#` (i >=# 0#) `andI#` (i +# d <=# u)) lus is + where (I# d) = fromIntegral $ natVal (Proxy ∷ Proxy d) + {-# Inline mkStream #-} + + + +-- * Outside + +-- ** Single-tape + + + + +-- * Complemented + +-- ** Single-tape + + +-- ** Multi-tape + + + + +-- * Table index modification + +instance (MinSize minSize) ⇒ TableStaticVar pos minSize u (PointR I) where + -- NOTE this code used to destroy fusion. If we inline tableStreamIndex + -- very late (after 'mkStream', probably) then everything works out. + tableStreamIndex Proxy minSz _upperBound (PointR j) = PointR $ j + minSize minSz + {-# INLINE [0] tableStreamIndex #-} + diff --git a/ADP/Fusion/PointR/SynVar/Indices.hs b/ADP/Fusion/PointR/SynVar/Indices.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/PointR/SynVar/Indices.hs @@ -0,0 +1,44 @@ + +-- | Index movement for syntactic variables in linear @PointL@ grammars. +-- +-- Syntactic variables for @PointL@ indices can be both, static and variable. +-- Static is the default, whenever we have @X -> X a@ where @a@ is a character +-- or similar. However, we can expect to see @a@ as a string as well. Then, @X@ +-- on the r.h.s. is variable. + +module ADP.Fusion.PointR.SynVar.Indices where + +import Data.Proxy +import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..),flatten) +import Data.Vector.Fusion.Util (delay_inline) +import Debug.Trace +import Prelude hiding (map,head,mapM) + +import Data.PrimitiveArray hiding (map) + +import ADP.Fusion.Core +import ADP.Fusion.Core.SynVar.Indices +import ADP.Fusion.PointR.Core + + + +type instance LeftPosTy (IStatic d) (TwITbl b s m arr EmptyOk (PointR I) x) (PointR I) = IVariable d +type instance LeftPosTy (IStatic d) (TwITblBt b s arr EmptyOk (PointR I) x mB mF r) (PointR I) = IVariable d + +type instance LeftPosTy (IVariable d) (TwITbl b s m arr EmptyOk (PointR I) x) (PointR I) = IVariable d +type instance LeftPosTy (IVariable d) (TwITblBt b s arr EmptyOk (PointR I) x mB mF r) (PointR I) = IVariable d + + + +instance + ( AddIndexDenseContext ps elm x0 i0 cs c us (PointR I) is (PointR I) + , MinSize c + ) + ⇒ AddIndexDense (ps:.IStatic d) elm (cs:.c) (us:.PointR I) (is:.PointR I) where + addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..LtPointR u) (is:.i) + = map (\(SvS s t y') → + let RiPrI k = getIndex (getIdx s) (Proxy ∷ PRI is (PointR I)) + in SvS s (t:.PointR k) (y' :.: RiPrI u)) + . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is + {-# Inline addIndexDenseGo #-} + diff --git a/ADP/Fusion/PointR/Term/Chr.hs b/ADP/Fusion/PointR/Term/Chr.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/PointR/Term/Chr.hs @@ -0,0 +1,72 @@ + +module ADP.Fusion.PointR.Term.Chr where + +import Data.Proxy +import Data.Strict.Tuple +import Debug.Trace +import qualified Data.Vector.Fusion.Stream.Monadic as S +import qualified Data.Vector.Generic as VG +import GHC.Exts + +import Data.PrimitiveArray + +import ADP.Fusion.Core +import ADP.Fusion.Core.Term.Chr +import ADP.Fusion.PointR.Core + + + +type instance LeftPosTy (IStatic d) (Chr r x) (PointR I) = IStatic (d+1) +type instance LeftPosTy (IVariable d) (Chr r x) (PointR I) = IVariable (d+1) + + + +instance + forall pos posLeft m ls r x i + . ( TermStream m (Z:.pos) (TermSymbol M (Chr r x)) (Elm (Term1 (Elm ls (PointR i))) (Z :. PointR i)) (Z:.PointR i) + , posLeft ~ LeftPosTy pos (Chr r x) (PointR i) + , TermStaticVar pos (Chr r x) (PointR i) + , MkStream m posLeft ls (PointR i) + ) + ⇒ MkStream m pos (ls :!: Chr r x) (PointR i) where + {-# Inline mkStream #-} + mkStream pos (ls :!: Chr f xs) grd us is + = S.map (\(ss,ee,ii) -> ElmChr ee ii ss) + . addTermStream1 pos (Chr f xs) us is + $ mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos (Chr f xs) us is grd) us (termStreamIndex pos (Chr f xs) is) + + +instance + ( TermStreamContext m ps ts s x0 i0 is (PointR I) + ) => TermStream m (ps:.IStatic d) (TermSymbol ts (Chr r x)) s (is:.PointR I) where + {-# Inline termStream #-} + termStream Proxy (ts:|Chr f xs) (us:..LtPointR u) (is:.PointR i) + = S.map (\(TState s ii ee) → + let RiPrI k = getIndex (getIdx s) (Proxy ∷ PRI is (PointR I)) + in TState s (ii:.:RiPrI (k+1)) (ee:. f xs k)) + . termStream (Proxy ∷ Proxy ps) ts us is + +instance + ( TermStreamContext m ps ts s x0 i0 is (PointR I) + ) => TermStream m (ps:.IVariable d) (TermSymbol ts (Chr r x)) s (is:.PointR I) where + {-# Inline termStream #-} + termStream Proxy (ts:|Chr f xs) (us:..LtPointR u) (is:.PointR i) + = S.map (\(TState s ii ee) -> + let RiPrI k = getIndex (getIdx s) (Proxy ∷ PRI is (PointR I)) + in TState s (ii:.:RiPrI (k+1)) (ee:. f xs k)) + . termStream (Proxy ∷ Proxy ps) ts us is + + + +instance TermStaticVar (IStatic d) (Chr r x) (PointR I) where + termStreamIndex Proxy (Chr f x) (PointR j) = PointR $ j + termStaticCheck Proxy (Chr f x) (LtPointR _) (PointR j) grd = grd + {-# Inline [0] termStreamIndex #-} + {-# Inline [0] termStaticCheck #-} + +instance TermStaticVar (IVariable d) (Chr r x) (PointR I) where + termStreamIndex Proxy (Chr f x) (PointR j) = PointR $ j + termStaticCheck Proxy (Chr f x) (LtPointR _) (PointR j) grd = grd + {-# Inline [0] termStreamIndex #-} + {-# Inline [0] termStaticCheck #-} + diff --git a/ADP/Fusion/PointR/Term/Deletion.hs b/ADP/Fusion/PointR/Term/Deletion.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/PointR/Term/Deletion.hs @@ -0,0 +1,69 @@ + +module ADP.Fusion.PointR.Term.Deletion where + +import Data.Proxy +import Data.Strict.Tuple +import qualified Data.Vector.Fusion.Stream.Monadic as S +import GHC.Exts + +import Data.PrimitiveArray + +import ADP.Fusion.Core +import ADP.Fusion.Core.Term.Deletion +import ADP.Fusion.PointR.Core + + + +type instance LeftPosTy (IStatic d) Deletion (PointR I) = IStatic d +type instance LeftPosTy (IVariable d) Deletion (PointR I) = IVariable d + + + +instance + forall pos posLeft m ls i + . ( TermStream m (Z:.pos) (TermSymbol M Deletion) (Elm (Term1 (Elm ls (PointR i))) (Z :. PointR i)) (Z:.PointR i) + , posLeft ~ LeftPosTy pos Deletion (PointR i) + , TermStaticVar pos Deletion (PointR i) + , MkStream m posLeft ls (PointR i) + ) + ⇒ MkStream m pos (ls :!: Deletion) (PointR i) where + {-# Inline mkStream #-} + mkStream pos (ls :!: Deletion) grd us is + = S.map (\(ss,ee,ii) -> ElmDeletion ii ss) + . addTermStream1 pos Deletion us is + $ mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos Deletion us is grd) us (termStreamIndex pos Deletion is) + + + +instance + ( TermStreamContext m ps ts s x0 i0 is (PointR I) + ) + ⇒ TermStream m (ps:.IStatic d) (TermSymbol ts Deletion) s (is:.PointR I) where + {-# Inline termStream #-} + termStream Proxy (ts:|Deletion) (us:..LtPointR u) (is:.PointR i) + = S.map (\(TState s ii ee) -> TState s (ii:.:RiPrI i) (ee:.())) + . termStream (Proxy ∷ Proxy ps) ts us is + +instance + ( TermStreamContext m ps ts s x0 i0 is (PointR I) + ) + ⇒ TermStream m (ps:.IVariable d) (TermSymbol ts Deletion) s (is:.PointR I) where + {-# Inline termStream #-} + termStream Proxy (ts:|Deletion) (us:..LtPointR u) (is:.PointR i) + = S.map (\(TState s ii ee) -> TState s (ii:.:RiPrI i) (ee:.())) + . termStream (Proxy ∷ Proxy ps) ts us is + + + +instance TermStaticVar (IStatic d) Deletion (PointR I) where + termStreamIndex Proxy Deletion (PointR j) = PointR j + termStaticCheck Proxy Deletion _ (PointR j) grd = grd + {-# Inline [0] termStreamIndex #-} + {-# Inline [0] termStaticCheck #-} + +instance TermStaticVar (IVariable d) Deletion (PointR I) where + termStreamIndex Proxy Deletion (PointR j) = PointR j + termStaticCheck Proxy Deletion _ (PointR j) grd = grd + {-# Inline [0] termStreamIndex #-} + {-# Inline [0] termStaticCheck #-} + diff --git a/ADP/Fusion/PointR/Term/Epsilon.hs b/ADP/Fusion/PointR/Term/Epsilon.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/PointR/Term/Epsilon.hs @@ -0,0 +1,66 @@ + +-- | Rules of the type @X → ε@ denote termination of parsing if @X@ is empty. + +module ADP.Fusion.PointR.Term.Epsilon where + +import Data.Proxy +import Data.Strict.Tuple +import qualified Data.Vector.Fusion.Stream.Monadic as S +import GHC.Exts + +import Data.PrimitiveArray + +import ADP.Fusion.Core +import ADP.Fusion.Core.Term.Epsilon +import ADP.Fusion.PointR.Core + + + +type instance LeftPosTy (IStatic d) (Epsilon Global) (PointR I) = IStatic d + +instance + forall pos posLeft m ls i lg + . ( TermStream m (Z:.pos) (TermSymbol M (Epsilon lg)) (Elm (Term1 (Elm ls (PointR i))) (Z :. PointR i)) (Z:.PointR i) + , posLeft ~ LeftPosTy pos (Epsilon lg) (PointR i) + , TermStaticVar pos (Epsilon lg) (PointR i) + , MkStream m posLeft ls (PointR i) + ) + ⇒ MkStream m pos (ls :!: Epsilon lg) (PointR i) where + mkStream Proxy (ls :!: Epsilon) grd us is + = S.map (\(ss,ee,ii) -> ElmEpsilon ii ss) + . addTermStream1 (Proxy ∷ Proxy pos) (Epsilon @lg) us is + $ mkStream (Proxy ∷ Proxy posLeft) + ls + (termStaticCheck (Proxy ∷ Proxy pos) (Epsilon @lg) us is grd) + us + (termStreamIndex (Proxy ∷ Proxy pos) (Epsilon @lg) is) + {-# Inline mkStream #-} + + +instance + ( TermStreamContext m ps ts s x0 i0 is (PointR I) + ) + ⇒ TermStream m (ps:.IStatic d) (TermSymbol ts (Epsilon lg)) s (is:.PointR I) where + termStream Proxy (ts:|Epsilon) (us:..LtPointR u) (is:.PointR i) + = S.map (\(TState s ii ee) -> + let RiPrI k = getIndex (getIdx s) (Proxy :: PRI is (PointR I)) + in TState s (ii:.:RiPrI k) (ee:.())) + . termStream (Proxy ∷ Proxy ps) ts us is + {-# Inline termStream #-} + + + +-- TODO need upper bound in @termStaticCheck@ to be able to check against that! + +instance TermStaticVar (IStatic 0) (Epsilon Global) (PointR I) where + termStreamIndex Proxy Epsilon (PointR i ) = PointR i + termStaticCheck Proxy Epsilon (LtPointR (I# u)) (PointR (I# i)) grd = (i ==# u) `andI#` grd + {-# Inline termStreamIndex #-} + {-# Inline termStaticCheck #-} + +instance TermStaticVar (IStatic 0) (Epsilon Local) (PointR I) where + termStreamIndex Proxy Epsilon (PointR i ) = PointR i + termStaticCheck Proxy Epsilon (LtPointR (I# u)) (PointR (I# i)) grd = grd + {-# Inline termStreamIndex #-} + {-# Inline termStaticCheck #-} + diff --git a/ADP/Fusion/PointR/Term/MultiChr.hs b/ADP/Fusion/PointR/Term/MultiChr.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/PointR/Term/MultiChr.hs @@ -0,0 +1,77 @@ + +module ADP.Fusion.PointR.Term.MultiChr where + +import Data.Proxy +import Data.Strict.Tuple +import Debug.Trace +import GHC.Exts +--import GHC.TypeNats +import qualified Data.Vector.Fusion.Stream.Monadic as S +import qualified Data.Vector.Generic as VG + +import Data.PrimitiveArray + +import ADP.Fusion.Core +import ADP.Fusion.Core.Term.MultiChr +import ADP.Fusion.PointR.Core + + + +type instance LeftPosTy (IStatic d) (MultiChr c v x) (PointR I) = IStatic (d+c) +type instance LeftPosTy (IVariable d) (MultiChr c v x) (PointR I) = IVariable (d+c) + + + +instance + forall pos posLeft m ls c v x i + . ( TermStream m (Z:.pos) (TermSymbol M (MultiChr c v x)) (Elm (Term1 (Elm ls (PointR i))) (Z :. PointR i)) (Z:.PointR i) + , posLeft ~ LeftPosTy pos (MultiChr c v x) (PointR i) + , TermStaticVar pos (MultiChr c v x) (PointR i) + , MkStream m posLeft ls (PointR i) + ) + ⇒ MkStream m pos (ls :!: MultiChr c v x) (PointR i) where + mkStream pos (ls :!: MultiChr xs) grd us is + = S.map (\(ss,ee,ii) -> ElmMultiChr ee ii ss) -- recover ElmChr + . addTermStream1 pos (MultiChr @v @x @c xs) us is + $ mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos (MultiChr @v @x @c xs) us is grd) us (termStreamIndex pos (MultiChr @v @x @c xs) is) + {-# Inline mkStream #-} + + +instance + ( TermStreamContext m ps ts s x0 i0 is (PointR I) + , KnownNat c + ) => TermStream m (ps:.IStatic d) (TermSymbol ts (MultiChr c v x)) s (is:.PointR I) where + termStream Proxy (ts:|MultiChr xs) (us:..LtPointR u) (is:.PointR i) + = let !c = fromIntegral $ natVal (Proxy ∷ Proxy c) in + S.map (\(TState s ii ee) -> + let RiPrI k = getIndex (getIdx s) (Proxy ∷ PRI is (PointR I)) + in TState s (ii:.:RiPrI (k+c)) (ee:. VG.unsafeSlice k c xs)) + . termStream (Proxy ∷ Proxy ps) ts us is + {-# Inline termStream #-} + +instance + ( TermStreamContext m ps ts s x0 i0 is (PointR I) + , KnownNat c + ) => TermStream m (ps:.IVariable d) (TermSymbol ts (MultiChr c v x)) s (is:.PointR I) where + termStream Proxy (ts:|MultiChr xs) (us:..LtPointR u) (is:.PointR i) + = let !c = fromIntegral $ natVal (Proxy ∷ Proxy c) in + S.map (\(TState s ii ee) -> + let RiPrI k = getIndex (getIdx s) (Proxy ∷ PRI is (PointR I)) + in TState s (ii:.:RiPrI (k+c)) (ee:. VG.unsafeSlice k c xs)) + . termStream (Proxy ∷ Proxy ps) ts us is + {-# Inline termStream #-} + + + +instance (KnownNat c) ⇒ TermStaticVar (IStatic d) (MultiChr c v x) (PointR I) where + termStreamIndex Proxy (MultiChr x) (PointR j) = PointR $ j + termStaticCheck Proxy (MultiChr x) _ (PointR j) grd = grd + {-# Inline [0] termStreamIndex #-} + {-# Inline [0] termStaticCheck #-} + +instance (KnownNat c) ⇒ TermStaticVar (IVariable d) (MultiChr c v x) (PointR I) where + termStreamIndex Proxy (MultiChr x) (PointR j) = PointR $ j + termStaticCheck Proxy (MultiChr x) _ (PointR j) grd = grd + {-# Inline [0] termStreamIndex #-} + {-# Inline [0] termStaticCheck #-} + diff --git a/ADP/Fusion/SynVar/Array.hs b/ADP/Fusion/SynVar/Array.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar/Array.hs +++ /dev/null @@ -1,123 +0,0 @@ - -module ADP.Fusion.SynVar.Array - ( module ADP.Fusion.SynVar.Array.Type - , module ADP.Fusion.SynVar.Array - ) where - - -import Data.Proxy -import Data.Strict.Tuple hiding (snd) -import Data.Vector.Fusion.Stream.Monadic -import Prelude hiding (map,mapM) - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Core.Classes -import ADP.Fusion.Core.Multi -import ADP.Fusion.SynVar.Array.Type -import ADP.Fusion.SynVar.Backtrack -import ADP.Fusion.SynVar.Indices.Classes -import ADP.Fusion.SynVar.TableWrap - - - --- | Constraints needed to use @iTblStream@. - -type ITblCx m ls arr x u c i = - ( TableStaticVar u c i - , MkStream m ls i - , Element ls i - , AddIndexDense (Elm (SynVar1 (Elm ls i)) (Z:.i)) (Z:.u) (Z:.c) (Z:.i) - , PrimArrayOps arr u x - ) - --- | General function for @ITbl@s with skalar indices. - -iTblStream - :: forall m ls arr x u c i . ITblCx m ls arr x u c i - => Pair ls (TwITbl m arr c u x) - -> Context i - -> i - -> i - -> 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 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. - -btITblStream - :: forall mB mF ls arr x r u c i . ITblCx mB ls arr x u c i - => Pair ls (TwITblBt arr c u x mF mB r) - -> Context i - -> i - -> 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 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 (lb,ub) = bounds t -{-# Inline btITblStream #-} - - - --- ** Instances - -instance - ( Monad m - , ITblCx m ls arr x u c (i I) - ) => MkStream m (ls :!: TwITbl m arr c u x) (i I) where - mkStream = iTblStream - {-# Inline mkStream #-} - -instance - ( Monad m - , ITblCx m ls arr x u c (i O) - ) => MkStream m (ls :!: TwITbl m arr c u x) (i O) where - mkStream = iTblStream - {-# Inline mkStream #-} - -instance - ( Monad m - , ITblCx m ls arr x u c (i C) - ) => MkStream m (ls :!: TwITbl m arr c u x) (i C) where - mkStream = iTblStream - {-# Inline mkStream #-} - -instance - ( Monad mB - , ITblCx mB ls arr x u c (i I) - ) => MkStream mB (ls :!: TwITblBt arr c u x mF mB r) (i I) where - mkStream = btITblStream - {-# Inline mkStream #-} - -instance - ( Monad mB - , ITblCx mB ls arr x u c (i O) - ) => MkStream mB (ls :!: TwITblBt arr c u x mF mB r) (i O) where - mkStream = btITblStream - {-# Inline mkStream #-} - -instance - ( Monad mB - , ITblCx mB ls arr x u c (i C) - ) => MkStream mB (ls :!: TwITblBt arr c u x mF mB r) (i C) where - mkStream = btITblStream - {-# Inline mkStream #-} - -instance ModifyConstraint (TwITbl m arr EmptyOk i x) where - type TNE (TwITbl m arr EmptyOk i x) = TwITbl m arr NonEmpty i x - type TE (TwITbl m arr EmptyOk i x) = TwITbl m arr EmptyOk i x - toNonEmpty (TW (ITbl b l _ arr) f) = TW (ITbl b l NonEmpty arr) f - {-# Inline toNonEmpty #-} - -instance ModifyConstraint (TwITblBt arr EmptyOk i x mF mB r) where - type TNE (TwITblBt arr EmptyOk i x mF mB r) = TwITblBt arr NonEmpty i x mF mB r - type TE (TwITblBt arr EmptyOk i x mF mB r) = TwITblBt arr EmptyOk i x mF mB r - toNonEmpty (TW (BtITbl _ arr) bt) = TW (BtITbl NonEmpty arr) bt - {-# Inline toNonEmpty #-} - diff --git a/ADP/Fusion/SynVar/Array/Type.hs b/ADP/Fusion/SynVar/Array/Type.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar/Array/Type.hs +++ /dev/null @@ -1,146 +0,0 @@ - -{-# Language DataKinds #-} -{-# Language TypeOperators #-} - -module ADP.Fusion.SynVar.Array.Type where - -import Data.Proxy -import Data.Strict.Tuple hiding (uncurry,snd) -import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..)) -import Debug.Trace -import Prelude hiding (map,head,mapM) - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Core.Classes -import ADP.Fusion.Core.Multi -import ADP.Fusion.SynVar.Axiom -import ADP.Fusion.SynVar.Backtrack -import ADP.Fusion.SynVar.Indices.Classes -import ADP.Fusion.SynVar.TableWrap - - - --- | Immutable table. - -data ITbl arr c i x where - ITbl :: { iTblBigOrder :: {-# Unpack #-} !Int - , iTblLittleOrder :: {-# Unpack #-} !Int - , iTblConstraint :: !c - , iTblArray :: !(arr i x) - } -> ITbl arr c i x - -type TwITbl m arr c i x = TW (ITbl arr c i x) (i -> i -> m x) - -type TwITblBt arr c i x mF mB r = TW (Backtrack (TwITbl mF arr c i x) mF mB) (i -> i -> mB [r]) - -instance Build (TwITbl m arr c i x) - -instance Build (TwITblBt arr c i x mF mB r) - -type instance TermArg (TwITbl m arr c i x) = x - -instance GenBacktrackTable (TwITbl mF arr c i x) mF mB where - data Backtrack (TwITbl mF arr c i x) mF mB = BtITbl !c !(arr i x) -- !(i -> i -> mB [r]) - type BacktrackIndex (TwITbl mF arr c i x) = i - toBacktrack (TW (ITbl _ _ c arr) _) _ = BtITbl c arr - {-# Inline toBacktrack #-} - -type instance TermArg (TwITblBt arr c i x mF mB r) = (x,[r]) - - - --- * axiom stuff - -instance - ( Monad m - , PrimArrayOps arr i x - , IndexStream i - ) => Axiom (TwITbl m arr c i x) where - type AxiomStream (TwITbl m arr c i x) = m x - axiom (TW (ITbl _ _ c arr) _) = do - k <- (head . uncurry streamDown) $ bounds arr - return $ arr ! k - {-# Inline axiom #-} - --- | We need this somewhat annoying instance construction (@i ~ j@ and @m --- ~ mB@) in order to force selection of this instance. - -instance - ( Monad mB - , PrimArrayOps arr i x - , IndexStream i - , j ~ i - , m ~ mB - ) => Axiom (TW (Backtrack (TwITbl mF arr c i x) mF mB) (j -> j -> m [r])) where - type AxiomStream (TW (Backtrack (TwITbl mF arr c i x) mF mB) (j -> j -> m [r])) = mB [r] - axiom (TW (BtITbl c arr) bt) = do - h <- (head . uncurry streamDown) $ bounds arr - bt (snd $ bounds arr) h - {-# Inline axiom #-} - - - --- * 'Element' - -instance Element ls i => Element (ls :!: TwITbl m arr c j x) i where - data Elm (ls :!: TwITbl m arr c j x) i = ElmITbl !x !(RunningIndex i) !(Elm ls i) - type Arg (ls :!: TwITbl m arr c j x) = Arg ls :. x - type RecElm (ls :!: TwITbl m arr c j x) i = Elm ls i - getArg (ElmITbl x _ ls) = getArg ls :. x - getIdx (ElmITbl _ i _ ) = i - getElm (ElmITbl _ _ ls) = ls - {-# Inline getArg #-} - {-# Inline getIdx #-} - {-# Inline getElm #-} - -deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i), Show x) => Show (Elm (ls :!: TwITbl m arr c j x) i) - -instance Element ls i => Element (ls :!: TwITblBt arr c j x mF mB r) i where - data Elm (ls :!: TwITblBt arr c j x mF mB r) i = ElmBtITbl !x [r] !(RunningIndex i) !(Elm ls i) - type Arg (ls :!: TwITblBt arr c j x mF mB r) = Arg ls :. (x, [r]) - type RecElm (ls :!: TwITblBt arr c j x mF mB r) i = Elm ls i - getArg (ElmBtITbl x s _ ls) = getArg ls :. (x,s) - getIdx (ElmBtITbl _ _ i _ ) = i - getElm (ElmBtITbl _ _ _ ls) = ls - {-# Inline getArg #-} - {-# Inline getIdx #-} - {-# Inline getElm #-} - -instance (Show x, Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: TwITblBt arr c i x mF mB r) i) where - show (ElmBtITbl x _ i s) = show (x,i) ++ " " ++ show s - - - --- * Multi-dim extensions - -instance - ( Monad m - , Element ls (is:.i) - , TableStaticVar (us:.u) (cs:.c) (is:.i) - , AddIndexDense (Elm ls (is:.i)) (us:.u) (cs:.c) (is:.i) - , MkStream m ls (is:.i) - , PrimArrayOps arr (us:.u) x - ) => 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 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 - ( Monad mB - , Element ls (is:.i) - , TableStaticVar (us:.u) (cs:.c) (is:.i) - , AddIndexDense (Elm ls (is:.i)) (us:.u) (cs:.c) (is:.i) - , MkStream mB ls (is:.i) - , 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 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 (lb,ub) = bounds t - {-# Inline mkStream #-} - diff --git a/ADP/Fusion/SynVar/Axiom.hs b/ADP/Fusion/SynVar/Axiom.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar/Axiom.hs +++ /dev/null @@ -1,14 +0,0 @@ - --- | The 'axiom' runs a backtracking algebra. The name comes from Robert --- Giegerichs @ADP@ where @axiom@ runs the fully formed algorithm. - -module ADP.Fusion.SynVar.Axiom where - --- | The Axiom type class - -class Axiom t where - -- | The corresponding stream being returned by 'axiom' - type AxiomStream t :: * - -- | Given a table, run the axiom - axiom :: t -> AxiomStream t - diff --git a/ADP/Fusion/SynVar/Backtrack.hs b/ADP/Fusion/SynVar/Backtrack.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar/Backtrack.hs +++ /dev/null @@ -1,28 +0,0 @@ - --- | Wrap forward tables in such a way as to allow backtracking via --- algebras. - -module ADP.Fusion.SynVar.Backtrack where - -import Data.Vector.Fusion.Stream.Monadic (Stream) - -import ADP.Fusion.SynVar.TableWrap - - - --- | --- --- TODO this should go into @ADP.Fusion.Table.Backtrack@, more than just --- tabulated syntactic vars are going to use it. --- --- NOTE You probably need to give the @monad morphism@ between @mF@ and --- @mB@ so as to be able to extract forward results in the backtracking --- phase. - -class GenBacktrackTable t (mF :: * -> *) (mB :: * -> *) where - data Backtrack t (mF :: * -> *) (mB :: * -> *) :: * - type BacktrackIndex t :: * - toBacktrack :: t -> (forall a . mF a -> mB a) {- -> (BacktrackIndex t -> BacktrackIndex t -> mB [r]) -} -> Backtrack t mF mB - --- instance Build (TW (Backtrack t mF mB) f) - diff --git a/ADP/Fusion/SynVar/Fill.hs b/ADP/Fusion/SynVar/Fill.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar/Fill.hs +++ /dev/null @@ -1,319 +0,0 @@ - -module ADP.Fusion.SynVar.Fill where - -import Control.Monad -import Control.Monad.Morph (hoist, MFunctor (..)) -import Control.Monad.Primitive (PrimMonad (..)) -import Control.Monad.ST -import Control.Monad.Trans.Class (lift, MonadTrans (..)) -import Data.Vector.Fusion.Util (Id(..)) -import GHC.Exts (inline) -import qualified Data.Vector.Fusion.Stream.Monadic as SM -import System.IO.Unsafe -import Control.Monad (when,forM_) -import Data.List (nub,sort,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 - -import ADP.Fusion.SynVar.Array -- TODO we want to keep only classes in here, move instances to the corresponding modules -import ADP.Fusion.SynVar.Recursive.Type -import ADP.Fusion.SynVar.TableWrap - -import Debug.Trace - - - --- | A vanilla context-free grammar - -data CFG - --- | This grammar is a multi-cfg in a monotone setting - -data MonotoneMCFG - - --- * Unsafely mutate 'ITbls' and similar tables in the forward phase. - --- | Mutate a cell in a stack of syntactic variables. --- --- TODO generalize to monad morphism via @mmorph@ package. This will allow --- more interesting @mrph@ functions that can, for example, track some --- state in the forward phase. (Note that this can be dangerous, we do --- /not/ want to have this state influence forward results, unless that can --- be made deterministic, or we'll break Bellman) - -class MutateCell (h :: *) (s :: *) (im :: * -> *) i where - mutateCell :: (Monad om, PrimMonad om) => Proxy h -> Int -> Int -> (forall a . im a -> om a) -> s -> i -> i -> om () - --- | - -class MutateTables (h :: *) (s :: *) (im :: * -> *) where - mutateTables :: (Monad om, PrimMonad om) => Proxy h -> (forall a . im a -> om a) -> s -> om s - -class TableOrder (s :: *) where - tableLittleOrder :: s -> [Int] - tableBigOrder :: s -> [Int] - -instance TableOrder Z where - tableLittleOrder Z = [] - tableBigOrder Z = [] - {-# Inline tableLittleOrder #-} - {-# Inline tableBigOrder #-} - -instance (TableOrder ts) => TableOrder (ts:.TwITbl im arr c i x) where - tableLittleOrder (ts:.TW (ITbl _ tlo _ _) _) = tlo : tableLittleOrder ts - tableBigOrder (ts:.TW (ITbl tbo _ _ _) _) = tbo : tableBigOrder ts - {-# Inline tableLittleOrder #-} - {-# Inline tableBigOrder #-} - --- | @IRec@s do not need an order, given that they do not memoize. - -instance (TableOrder ts) => TableOrder (ts:.TwIRec im c i x) where - tableLittleOrder (ts:._) = tableLittleOrder ts - tableBigOrder (ts:._) = tableBigOrder ts - {-# Inline tableLittleOrder #-} - {-# Inline tableBigOrder #-} - --- ** individual instances for filling a *single cell* - -instance - ( - ) => MutateCell p Z im i where - mutateCell _ _ _ _ Z _ _ = return () - {-# INLINE mutateCell #-} - -instance - ( MutateCell CFG ts im i - ) => MutateCell CFG (ts:.TwIRec im c i x) im i where - mutateCell h bo lo mrph (ts:._) lu i = do - mutateCell h bo lo mrph ts lu i - {-# Inline mutateCell #-} - -instance - ( PrimArrayOps arr i x - , MPrimArrayOps arr i x - , MutateCell CFG ts im i - ) => 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 - marr <- unsafeThaw arr - z <- (inline mrph) $ f lu i - writeM marr i z - {-# INLINE mutateCell #-} - -type ZS2 = Z:.Subword I:.Subword I - -instance - ( PrimArrayOps arr ZS2 x - , MPrimArrayOps arr ZS2 x - , MutateCell MonotoneMCFG ts im ZS2 - ) => MutateCell MonotoneMCFG (ts:.TwITbl im arr c ZS2 x) im ZS2 where - mutateCell h bo lo mrph (ts:.TW (ITbl tbo tlo c arr) f) lu iklj@(Z:.Subword (i:.k):.Subword(l:.j)) = do - mutateCell h bo lo mrph ts lu iklj - when (bo==tbo && lo==tlo && k<=l) $ do - marr <- unsafeThaw arr - z <- (inline mrph) $ f lu iklj - writeM marr iklj z - {-# INLINE mutateCell #-} - -instance - ( PrimArrayOps arr (Subword I) x - , MPrimArrayOps arr (Subword I) x - , MutateCell h ts im (Z:.Subword I:.Subword I) - ) => MutateCell h (ts:.TwITbl im arr c (Subword I) x) im (Z:.Subword I:.Subword I) where - mutateCell h bo lo mrph (ts:.TW (ITbl tbo tlo c arr) f) lu@(Z:.Subword (l:._):.Subword(_:.u)) ix@(Z:.Subword (i1:.j1):.Subword (i2:.j2)) = do - mutateCell h bo lo mrph ts lu ix - when (bo==tbo && lo==tlo && i1==i2 && j1==j2) $ do - let i = i1 - let j = j1 - marr <- unsafeThaw arr - z <- (inline mrph) $ f (subword l u) (subword i j) - writeM marr (subword i j) z - {-# Inline mutateCell #-} - - - --- ** individual instances for filling a complete table and extracting the --- bounds - -instance - ( MutateCell h (ts:.TwITbl 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 where - mutateTables h mrph tt@(_:.TW (ITbl _ _ _ arr) _) = do - let (from,to) = bounds arr - -- TODO (1) find the set of orders for the synvars - let !tbos = VU.fromList . nub . sort $ tableBigOrder tt - let !tlos = VU.fromList . nub . sort $ tableLittleOrder tt - VU.forM_ tbos $ \bo -> - case (VU.length tlos) of - 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 - return tt - {-# INLINE mutateTables #-} - --- | Default table filling, assuming that the forward monad is just @IO@. --- --- TODO generalize to @MonadIO@ or @MonadPrim@. - -mutateTablesDefault :: MutateTables CFG t Id => t -> t -mutateTablesDefault t = unsafePerformIO $ mutateTables (Proxy :: Proxy CFG) (return . unId) t -{-# INLINE mutateTablesDefault #-} - --- | Mutate tables, but observe certain hints. We use this for monotone --- mcfgs for now. - -mutateTablesWithHints :: MutateTables h t Id => Proxy h -> t -> t -mutateTablesWithHints h t = unsafePerformIO $ mutateTables h (return . unId) t - - - - - - -mutateTablesST t = runST $ mutateTablesNew t -{-# Inline mutateTablesST #-} - --- | --- --- 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 #-} - diff --git a/ADP/Fusion/SynVar/Indices/Classes.hs b/ADP/Fusion/SynVar/Indices/Classes.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar/Indices/Classes.hs +++ /dev/null @@ -1,98 +0,0 @@ - --- | Classes that enumerate the index structure necessary for actually --- performing the indexing. --- --- TODO Currently, we only provide dense index generation. - -module ADP.Fusion.SynVar.Indices.Classes where - -import Data.Proxy (Proxy(..)) -import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,flatten,Step(..)) -import Prelude hiding (map,head,mapM) - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Core.Classes -import ADP.Fusion.Core.Multi -import ADP.Fusion.Core.TyLvlIx - - - --- | This type classes enable enumeration both in single- and multi-dim --- cases. The type @a@ is the type of the /full stack/ of indices, i.e. the --- full multi-tape problem. - -class AddIndexDense s u c i where - addIndexDenseGo - :: (Monad m) - => 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 - {-# Inline addIndexDenseGo #-} - --- | @SvState@ holds the state that is currently being built up by --- @AddIndexDense@. We have both @tIx@ (and @tOx@) and @iIx@ (and @iOx@). --- For most index structures, the indices will co-incide; however for some, --- this will not be true -- herein for @Set@ index structures. - -data SvState s a u i = SvS - { sS :: !s -- ^ state coming in from the left --- , sIx :: !(RunningIndex a) -- @I/C@ index from @sS@ - , tx :: !u -- ^ @I/C@ building up state to index the @table@. - , iIx :: !(RunningIndex i) -- ^ @I/C@ building up state to hand over to next symbol - } - - --- | Given an incoming stream with indices, this adds indices for the --- current syntactic variable / symbol. - -addIndexDense - :: ( Monad m - , AddIndexDense s u c i - , s ~ Elm x0 i0 - , Element x0 i0 - ) - => 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 --- system and remove the @Z@ later on. This allows us to have to write only --- a single instance. - -addIndexDense1 - :: ( Monad m - , AddIndexDense (Elm (SynVar1 (Elm x0 a)) (Z:.i)) (Z:.u) (Z:.c) (Z:.i) - , GetIndex (Z:.a) (Z:.i) - , s ~ Elm x0 a - , Element x0 a - ) - => 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 - -elmSynVar1 :: s -> i -> Elm (SynVar1 s) (Z:.i) -elmSynVar1 s _ = ElmSynVar1 s -{-# Inline elmSynVar1 #-} - -instance (s ~ Elm x0 i, Element x0 i) => Element (SynVar1 s) (Z:.i) where - newtype Elm (SynVar1 s) (Z:.i) = ElmSynVar1 s - getIdx (ElmSynVar1 s) = RiZ :.: getIdx s - {-# Inline getIdx #-} - - --- | Instance headers, we typically need. - -type IndexHdr s x0 i0 us u cs c is i = - ( AddIndexDense s us cs is - , GetIndex (RunningIndex i0) (RunningIndex (is:.i)) - , GetIx (RunningIndex i0) (RunningIndex (is:.i)) ~ (RunningIndex i) - , Element x0 i0 - , s ~ Elm x0 i0 - ) - diff --git a/ADP/Fusion/SynVar/Indices/Point.hs b/ADP/Fusion/SynVar/Indices/Point.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar/Indices/Point.hs +++ /dev/null @@ -1,63 +0,0 @@ - -module ADP.Fusion.SynVar.Indices.Point where - -import Data.Proxy -import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..)) -import Data.Vector.Fusion.Util (delay_inline) -import Debug.Trace -import Prelude hiding (map,head,mapM) - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Core -import ADP.Fusion.Core.Point -import ADP.Fusion.SynVar.Indices.Classes - - - -instance - ( 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) (lbs:.lb) (ubs:.ub) (us:.u) (is:.i) - = map (\(SvS s t y') -> SvS s (t:.i) (y' :.: RiPlI (fromPointL i))) - . 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) - | k + csize > i = return $ Done - | otherwise = return $ Yield (SvS s (t:.PointL k) (y' :.: RiPlI k)) (svS :. k+1) - where csize = minSize c - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - {-# Inline addIndexDenseGo #-} - -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) (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 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) (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 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) (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 lbs ubs us is - {-# Inline addIndexDenseGo #-} - diff --git a/ADP/Fusion/SynVar/Indices/Unit.hs b/ADP/Fusion/SynVar/Indices/Unit.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar/Indices/Unit.hs +++ /dev/null @@ -1,50 +0,0 @@ - --- | TODO if we have a table that has min-size @>0@ we need to immediately --- terminate @addIndexDenseGo@ ! - -module ADP.Fusion.SynVar.Indices.Unit where - -import Data.Proxy -import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..)) -import Data.Vector.Fusion.Util (delay_inline) -import Prelude hiding (map,head,mapM) - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Core -import ADP.Fusion.Core.Unit - - - -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 ()) (lbs:._) (ubs:._) (us:._) (is:._) - = map (\(SvS s t y') -> SvS s (t:.Unit) (y':.:RiU)) - . 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 ()) (lbs:.lb) (ubs:.ub) (us:._) (is:._) - = map (\(SvS s t y') -> SvS s (t:.Unit) (y':.:RiU)) - . 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) (lbs:._) (ubs:._) (us:._) (is:._) - = map (\(SvS s t y') -> SvS s (t:.Unit) (y':.:RiU)) - . 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) (lbs:._) (ubs:._) (us:._) (is:._) - = map (\(SvS s t y') -> SvS s (t:.Unit) (y':.:RiU)) - . addIndexDenseGo cs vs lbs ubs us is - {-# Inline addIndexDenseGo #-} - diff --git a/ADP/Fusion/SynVar/Recursive/Point.hs b/ADP/Fusion/SynVar/Recursive/Point.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar/Recursive/Point.hs +++ /dev/null @@ -1,3 +0,0 @@ - -module ADP.Fusion.SynVar.Recursive.Point where - diff --git a/ADP/Fusion/SynVar/Recursive/Type.hs b/ADP/Fusion/SynVar/Recursive/Type.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar/Recursive/Type.hs +++ /dev/null @@ -1,123 +0,0 @@ - -module ADP.Fusion.SynVar.Recursive.Type where - -import Control.Applicative (Applicative,(<$>),(<*>)) -import Control.Monad.Morph -import Data.Proxy -import Data.Strict.Tuple -import Data.Vector.Fusion.Stream.Monadic (Stream,head,map,mapM) -import Prelude hiding (head,map,mapM) - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Core.Classes -import ADP.Fusion.Core.Multi -import ADP.Fusion.SynVar.Axiom -import ADP.Fusion.SynVar.Backtrack -import ADP.Fusion.SynVar.Indices.Classes -import ADP.Fusion.SynVar.TableWrap - - - --- | A syntactic variable that does not memoize but simplify recurses. One --- needs to be somewhat careful when using this one. @ITbl@ performs --- memoization to perform DP in polynomial time (roughly speaking). If the --- rules for an @IRec@ are of a particular type, they will exponential --- running time. Things like @X -> X X@ are, for example, rather bad. Rules --- of the type @X -> Y, Y -> Z@ are ok, if @Y@ is an @IRec@ since we just --- continue on. The same holds for @Y -> a Y@. Basically, things are safe --- if there is only a (small) constant number of parses of an @IRec@ --- synvar. - -data IRec c i x where - IRec :: { iRecConstraint :: !c - , iRecFrom :: !i - , iRecTo :: !i - } -> IRec c i x - -type TwIRec m c i x = TW (IRec c i x) (i -> i -> m x) - -type TwIRecBt c i x mF mB r = TW (Backtrack (TwIRec mF c i x) mF mB) (i -> i -> mB [r]) - -instance Build (TwIRec m c i x) - -instance Build (TwIRecBt c i x mF mB r) - -type instance TermArg (TwIRec m c i x) = x - -instance GenBacktrackTable (TwIRec mF c i x) mF mB where - data Backtrack (TwIRec mF c i x) mF mB = BtIRec !c !i !i !(i -> i -> mB x) -- !(i -> i -> mB [r]) - type BacktrackIndex (TwIRec mF c i x) = i - toBacktrack (TW (IRec c iF iT) f) mrph = BtIRec c iF iT (\lu i -> mrph $ f lu i) - {-# Inline toBacktrack #-} - - - -instance - ( Monad m - , IndexStream i - ) => Axiom (TwIRec m c i x) where - type AxiomStream (TwIRec m c i x) = m x - axiom (TW (IRec _ l h) fun) = do - k <- head $ streamDown l h - fun h k - {-# Inline axiom #-} - -instance - ( Monad mB - , IndexStream i - , i ~ j - , m ~ mB - ) => Axiom (TW (Backtrack (TwIRec mF c i x) mF mB) (j -> j -> m [r])) where - type AxiomStream (TW (Backtrack (TwIRec mF c i x) mF mB) (j -> j -> m [r])) = mB [r] - axiom (TW (BtIRec c l h fun) btfun) = do - k <- head $ streamDown l h - btfun h k - {-# Inline axiom #-} - - - -instance Element ls i => Element (ls :!: TwIRec m c u x) i where - data Elm (ls :!: TwIRec m c u x) i = ElmIRec !x !(RunningIndex i) !(Elm ls i) - type Arg (ls :!: TwIRec m c u x) = Arg ls :. x - getArg (ElmIRec x _ ls) = getArg ls :. x - getIdx (ElmIRec _ i _ ) = i - {-# Inline getArg #-} - {-# Inline getIdx #-} - -instance Element ls i => Element (ls :!: TwIRecBt c u x mF mB r) i where - data Elm (ls :!: (TwIRecBt c u x mF mB r)) i = ElmBtIRec !x [r] !(RunningIndex i) !(Elm ls i) - type Arg (ls :!: (TwIRecBt c u x mF mB r)) = Arg ls :. (x, [r]) - getArg (ElmBtIRec x s _ ls) = getArg ls :. (x,s) - getIdx (ElmBtIRec _ _ i _ ) = i - {-# Inline getArg #-} - {-# Inline getIdx #-} - -instance - ( Functor m - , Monad m - , Element ls (is:.i) - , TableStaticVar (us:.u) (cs:.c) (is:.i) - , AddIndexDense (Elm ls (is:.i)) (us:.u) (cs:.c) (is:.i) - , MkStream m ls (is:.i) - ) => 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 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 #-} - -instance - ( Applicative mB - , Monad mB - , Element ls (is:.i) - , TableStaticVar (us:.u) (cs:.c) (is:.i) - , AddIndexDense (Elm ls (is:.i)) (us:.u) (cs:.c) (is:.i) - , MkStream mB ls (is:.i) - ) => 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 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 #-} - diff --git a/ADP/Fusion/SynVar/Split/Type.hs b/ADP/Fusion/SynVar/Split/Type.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar/Split/Type.hs +++ /dev/null @@ -1,200 +0,0 @@ - --- | --- --- NOTE /highly experimental/ - -module ADP.Fusion.SynVar.Split.Type - ( module ADP.Fusion.SynVar.Split.Type - , Proxy (..) - ) where - -import Data.Proxy -import Data.Strict.Tuple -import Data.Vector.Fusion.Stream.Monadic -import Data.Vector.Fusion.Util (delay_inline) -import Debug.Trace -import GHC.TypeLits -import Prelude hiding (map,mapM) -import Data.Type.Equality - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Core.Classes -import ADP.Fusion.Core.Multi -import ADP.Fusion.SynVar.Array.Type -import ADP.Fusion.SynVar.Backtrack -import ADP.Fusion.SynVar.TableWrap - - - -data SplitType = Fragment | Final - --- | The @Arg synVar@ means that we probably need to rewrite the internal --- type resolution now! - -type family CalcSplitType splitType varTy where - CalcSplitType Fragment varTy = () - CalcSplitType Final varTy = varTy - --- | Should never fail? - -type family ArgTy argTy where --- ArgTy Z = Z - ArgTy (z:.x) = x - --- | Wraps a normal non-terminal and attaches a type-level unique identier --- and z-ordering (with the unused @Z@ at @0@). --- --- TODO attach empty/non-empty stuff (or get from non-splitted synvar?) --- --- TODO re-introduce z-ordering later (once we have a sort fun) - -newtype Split (uId :: Symbol) {- (zOrder :: Nat) -} (splitType :: SplitType) synVar = Split { getSplit :: synVar } - --- | --- --- TODO Here, we probably want to default to a @NonEmpty@ condition. Or at --- least have different versions of @split@. - -split :: Proxy (uId::Symbol) -> {- Proxy (zOrder::Nat) -> -} Proxy (splitType::SplitType) -> synVar -> Split uId splitType synVar -split _ _ = Split -{-# Inline split #-} - ---splitNE :: (ModifyConstraint synVar) => Proxy (uId::Symbol) -> {- Proxy (zOrder::Nat) -> -} Proxy (splitType::SplitType) -> synVar -> Split uId splitType synVar ---splitNE _ _ = Split . toNonEmpty ---{-# Inline splitNE #-} - ---type Spl uId zOrder splitType = forall synVar . Split uId zOrder splitType synVar - -instance Build (Split uId splitType synVar) - -instance - ( Element ls i - ) => Element (ls :!: Split uId splitType (TwITbl m arr c j x)) i where - -- | @ElmSplitITbl@ carry one additional element of type @i@. We need - -- those to be able to extract the full index via @collectIx@. - data Elm (ls :!: Split uId splitType (TwITbl m arr c j x)) i = ElmSplitITbl !(Proxy uId) !(CalcSplitType splitType x) !(RunningIndex i) !(Elm ls i) !i - type Arg (ls :!: Split uId splitType (TwITbl m arr c j x)) = Arg ls :. (CalcSplitType splitType x) - type RecElm (ls :!: Split uId splitType (TwITbl m arr c j x)) i = Elm ls i - getArg (ElmSplitITbl _ x _ ls _) = getArg ls :. x - getIdx (ElmSplitITbl _ _ i _ _) = i - getElm (ElmSplitITbl _ _ _ ls _) = ls - {-# Inline getArg #-} - {-# Inline getIdx #-} - {-# Inline getElm #-} - -instance - ( Element ls i - ) => Element (ls :!: Split uId splitType (TwITblBt arr c j x mF mB r)) i where - data Elm (ls :!: Split uId splitType (TwITblBt arr c j x mF mB r)) i = ElmSplitBtITbl !(Proxy uId) !(CalcSplitType splitType (x, [r])) !(RunningIndex i) !(Elm ls i) !i - type Arg (ls :!: Split uId splitType (TwITblBt arr c j x mF mB r)) = Arg ls :. (CalcSplitType splitType (x,[r])) - type RecElm (ls :!: Split uId splitType (TwITblBt arr c j x mF mB r)) i = Elm ls i - getArg (ElmSplitBtITbl _ xs _ ls _) = getArg ls :. xs - getIdx (ElmSplitBtITbl _ _ i _ _) = i - getElm (ElmSplitBtITbl _ _ _ ls _) = ls - {-# Inline getArg #-} - {-# Inline getIdx #-} - {-# Inline getElm #-} - - - --- | 'collectIx' gobbles up indices that are tagged with the same symbolic --- identifier. - -collectIx - :: forall uId ls i . - ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i) - ) - => Proxy uId -> Elm ls i -> SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i) -collectIx p e = splitIxCol p (Proxy :: Proxy (SameSid uId (Elm ls i))) e - --- | Closed type family that gives us a (type) function for type symbol --- equality. - -type family SameSid uId elm :: Bool where - SameSid uId (Elm (ls :!: Split sId splitType synVar) i) = uId == sId - SameSid uId (Elm (ls :!: TermSymbol a b ) i) = SameSid uId (TermSymbol a b) - SameSid uId M = False - SameSid uId (TermSymbol a (Split sId splitType synVar)) = OR (uId == sId) (SameSid uId a) - SameSid uId (Elm (ls :!: l ) i) = False - --- | Type-level @(||)@ - -type family OR a b where - OR False False = False - OR a b = True - --- | @x ++ y@ but for inductive tuples. --- --- TODO move to PrimitiveArray - -class Zconcat x y where - type Zpp x y :: * - zconcat :: x -> y -> Zpp x y - -instance Zconcat x Z where - type Zpp x Z = x - zconcat x Z = x - {-# Inline zconcat #-} - -instance - ( Zconcat x z - ) => Zconcat x (z:.y) where - type Zpp x (z:.y) = Zpp x z :. y - zconcat x (z:.y) = zconcat x z :. y - {-# Inline zconcat #-} - --- WORKS - --- | Actually collect split indices based on if we managed to find the --- right @Split@ synvar (based on the right symbol). --- --- TODO this is not completely right, or? Since we should consider --- inside/outside? --- --- TODO 'splitIxCol' will need the index type @i@ to combine running index --- and index into the actual lookup part. - -class SplitIxCol (uId::Symbol) (b::Bool) e where - type SplitIxTy uId b e :: * - splitIxCol :: Proxy uId -> Proxy b -> e -> SplitIxTy uId b e - - - -instance SplitIxCol uId b (Elm S i) where - type SplitIxTy uId b (Elm S i) = Z - splitIxCol p b (ElmS _) = Z - {-# Inline splitIxCol #-} - - -instance - ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i) - , Element (ls :!: l) i - , RecElm (ls :!: l) i ~ Elm ls i - ) => SplitIxCol uId False (Elm (ls :!: l) i) where - type SplitIxTy uId False (Elm (ls :!: l) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i) - splitIxCol p b e = collectIx p (getElm e) - {-# Inline splitIxCol #-} - -instance - ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i) - ) => SplitIxCol uId True (Elm (ls :!: Split sId splitType (TwITbl m arr c j x)) i) where - type SplitIxTy uId True (Elm (ls :!: Split sId splitType (TwITbl m arr c j x)) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i) :. i - splitIxCol p b (ElmSplitITbl _ _ i e ix) = collectIx p e :. ix - {-# Inline splitIxCol #-} - -instance - ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i) - ) => SplitIxCol uId True (Elm (ls :!: Split sId splitType (TwITblBt arr c j x mF mB r)) i) where - type SplitIxTy uId True (Elm (ls :!: Split sId splitType (TwITblBt arr c j x mF mB r)) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i) :. i - splitIxCol p b (ElmSplitBtITbl _ _ i e ix) = collectIx p e :. ix - {-# Inline splitIxCol #-} - -instance - ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i) - , Zconcat (SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)) (SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b)) - ) => SplitIxCol uId True (Elm (ls :!: TermSymbol a b) i) where - type SplitIxTy uId True (Elm (ls :!: TermSymbol a b) i) = Zpp (SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)) (SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b)) - splitIxCol p b (ElmTS t i e) = collectIx p e `zconcat` ((error "ElmTS / splitIxCol") {- p t -} :: SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b)) - {-# Inline splitIxCol #-} - diff --git a/ADP/Fusion/SynVar/TableWrap.hs b/ADP/Fusion/SynVar/TableWrap.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar/TableWrap.hs +++ /dev/null @@ -1,11 +0,0 @@ - --- | Wrap the underlying table and the rules. Isomorphic to @(,)@. - -module ADP.Fusion.SynVar.TableWrap where - - - --- | Wrap tables of type @t@. The tables are strict, the functions @f@ can --- not be strict, because we need to build grammars recursively. - -data TW t f = TW !t f diff --git a/ADP/Fusion/Term/Chr/Point.hs b/ADP/Fusion/Term/Chr/Point.hs deleted file mode 100644 --- a/ADP/Fusion/Term/Chr/Point.hs +++ /dev/null @@ -1,74 +0,0 @@ - -module ADP.Fusion.Term.Chr.Point where - -import Data.Proxy -import Data.Strict.Tuple -import Debug.Trace -import qualified Data.Vector.Fusion.Stream.Monadic as S -import qualified Data.Vector.Generic as VG - -import Data.PrimitiveArray - -import ADP.Fusion.Core -import ADP.Fusion.Core.Point -import ADP.Fusion.Term.Chr.Type - - - --- | First try in getting this right with a @termStream@. --- --- TODO use @PointL i@ since this is probably the same for all single-tape --- instances with @ElmChr@. --- --- TODO it might even be possible to auto-generate this code via TH. - -instance - ( TmkCtx1 m ls (Chr r x) (PointL i) - ) => MkStream m (ls :!: Chr r x) (PointL i) where - mkStream (ls :!: Chr f xs) sv us is - = S.map (\(ss,ee,ii) -> ElmChr ee ii ss) -- recover ElmChr - . addTermStream1 (Chr f xs) sv us is - $ mkStream ls (termStaticVar (Chr f xs) sv is) us (termStreamIndex (Chr f xs) sv is) - {-# Inline mkStream #-} - - - --- | Current first try for using @TermStream@ --- --- TODO what happens to fusion if @staticCheck@ happens before @S.map@? --- --- NOTE / TODO a bit faster with @seq xs@ ? - -instance - ( TstCtx m ts s x0 i0 is (PointL I) - ) => TermStream m (TermSymbol ts (Chr r x)) s (is:.PointL I) where - termStream (ts:|Chr f xs) (cs:.IStatic d) (us:.PointL u) (is:.PointL i) - -- seq xs . staticCheck (i>0 && i<=u && i<= VG.length xs) - = S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:. f xs (i-1))) - . termStream ts cs us is - {-# Inline termStream #-} - -instance - ( TstCtx m ts s x0 i0 is (PointL O) - ) => TermStream m (TermSymbol ts (Chr r x)) s (is:.PointL O) where - termStream (ts:|Chr f xs) (cs:.OStatic d) (us:.PointL u) (is:.PointL i) - = S.map (\(TState s ii ee) -> - let RiPlO k o = getIndex (getIdx s) (Proxy :: PRI is (PointL O)) - in TState s (ii:.: RiPlO (k+1) o) (ee:.f xs k)) - . termStream ts cs us is - {-# Inline termStream #-} - - - -instance TermStaticVar (Chr r x) (PointL I) where - termStaticVar _ sv _ = sv - termStreamIndex _ _ (PointL j) = PointL $ j-1 - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - -instance TermStaticVar (Chr r x) (PointL O) where - termStaticVar _ (OStatic d) _ = OStatic (d+1) - termStreamIndex _ _ j = j - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - diff --git a/ADP/Fusion/Term/Chr/Type.hs b/ADP/Fusion/Term/Chr/Type.hs deleted file mode 100644 --- a/ADP/Fusion/Term/Chr/Type.hs +++ /dev/null @@ -1,62 +0,0 @@ - --- | --- --- TODO Rename @Chr@ to @Vtx@, a vertex parser is a generalization of --- a char parser. But this is only semantics, so not super important to do --- now. - -module ADP.Fusion.Term.Chr.Type where - -import Data.Strict.Tuple -import qualified Data.Vector.Generic as VG - -import Data.PrimitiveArray - -import ADP.Fusion.Core.Classes -import ADP.Fusion.Core.Multi - - - --- | A generic Character parser that reads a single character but allows --- passing additional information. --- --- 'Chr' expects a function to retrieve @r@ at index position, followed by --- the actual generic vector with data. - -data Chr r x where - Chr :: VG.Vector v x - => (v x -> Int -> r) - -> !(v x) - -> Chr r x - --- | smart constructor for regular 1-character parsers - -chr :: VG.Vector v x => v x -> Chr x x -chr = Chr VG.unsafeIndex -{-# Inline chr #-} - --- | Smart constructor for Maybe Peeking, followed by a character. - -chrLeft xs = Chr f xs where - f xs k = ( xs VG.!? (k-1) - , VG.unsafeIndex xs k - ) - {-# Inline [0] f #-} -{-# Inline chrLeft #-} - -instance Build (Chr r x) - -instance - ( Element ls i - ) => Element (ls :!: Chr r x) i where - data Elm (ls :!: Chr r x) i = ElmChr !r !(RunningIndex i) !(Elm ls i) - type Arg (ls :!: Chr r x) = Arg ls :. r - getArg (ElmChr x _ ls) = getArg ls :. x - getIdx (ElmChr _ i _ ) = i - {-# Inline getArg #-} - {-# Inline getIdx #-} - -deriving instance (Show i, Show (RunningIndex i), Show r, Show (Elm ls i)) => Show (Elm (ls :!: Chr r x) i) - -type instance TermArg (Chr r x) = r - diff --git a/ADP/Fusion/Term/Deletion/Point.hs b/ADP/Fusion/Term/Deletion/Point.hs deleted file mode 100644 --- a/ADP/Fusion/Term/Deletion/Point.hs +++ /dev/null @@ -1,58 +0,0 @@ - -module ADP.Fusion.Term.Deletion.Point where - -import Data.Proxy -import Data.Strict.Tuple -import qualified Data.Vector.Fusion.Stream.Monadic as S - -import Data.PrimitiveArray - -import ADP.Fusion.Core -import ADP.Fusion.Core.Point -import ADP.Fusion.Term.Deletion.Type - - - -instance - ( TmkCtx1 m ls Deletion (PointL i) - ) => MkStream m (ls :!: Deletion) (PointL i) where - mkStream (ls :!: Deletion) sv us is - = S.map (\(ss,ee,ii) -> ElmDeletion ii ss) - . addTermStream1 Deletion sv us is - $ mkStream ls (termStaticVar Deletion sv is) us (termStreamIndex Deletion sv is) - {-# Inline mkStream #-} - - - -instance - ( TstCtx m ts s x0 i0 is (PointL I) - ) => TermStream m (TermSymbol ts Deletion) s (is:.PointL I) where - termStream (ts:|Deletion) (cs:.IStatic d) (us:.PointL u) (is:.PointL i) - = S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:.())) - . termStream ts cs us is - {-# Inline termStream #-} - -instance - ( TstCtx m ts s x0 i0 is (PointL O) - ) => TermStream m (TermSymbol ts Deletion) s (is:.PointL O) where - termStream (ts:|Deletion) (cs:.OStatic d) (us:.PointL u) (is:.PointL i) - = S.map (\(TState s ii ee) -> - let io = getIndex (getIdx s) (Proxy :: PRI is (PointL O)) - in TState s (ii:.: io) (ee:.())) - . termStream ts cs us is - {-# Inline termStream #-} - - - -instance TermStaticVar Deletion (PointL I) where - termStaticVar _ sv _ = sv - termStreamIndex _ _ (PointL j) = PointL j - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - -instance TermStaticVar Deletion (PointL O) where - termStaticVar _ (OStatic d) _ = OStatic d - termStreamIndex _ _ j = j - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - diff --git a/ADP/Fusion/Term/Deletion/Type.hs b/ADP/Fusion/Term/Deletion/Type.hs deleted file mode 100644 --- a/ADP/Fusion/Term/Deletion/Type.hs +++ /dev/null @@ -1,26 +0,0 @@ - -module ADP.Fusion.Term.Deletion.Type where - -import Data.Strict.Tuple - -import Data.PrimitiveArray - -import ADP.Fusion.Core.Classes -import ADP.Fusion.Core.Multi - - - -data Deletion = Deletion - -instance Build Deletion - -instance (Element ls i) => Element (ls :!: Deletion) i where - data Elm (ls :!: Deletion) i = ElmDeletion !(RunningIndex i) !(Elm ls i) - type Arg (ls :!: Deletion) = Arg ls :. () - getArg (ElmDeletion _ l) = getArg l :. () - getIdx (ElmDeletion i _) = i - {-# Inline getArg #-} - {-# Inline getIdx #-} - -type instance TermArg Deletion = () - diff --git a/ADP/Fusion/Term/Deletion/Unit.hs b/ADP/Fusion/Term/Deletion/Unit.hs deleted file mode 100644 --- a/ADP/Fusion/Term/Deletion/Unit.hs +++ /dev/null @@ -1,55 +0,0 @@ - -module ADP.Fusion.Term.Deletion.Unit where - -import Data.Proxy -import Data.Strict.Tuple -import qualified Data.Vector.Fusion.Stream.Monadic as S - -import Data.PrimitiveArray - -import ADP.Fusion.Core -import ADP.Fusion.Core.Unit - - - -instance - ( TmkCtx1 m ls Deletion (Unit i) - ) => MkStream m (ls :!: Deletion) (Unit i) where - mkStream (ls :!: Deletion) sv us is - = S.map (\(ss,ee,ii) -> ElmDeletion ii ss) - . addTermStream1 Deletion sv us is - $ mkStream ls (termStaticVar Deletion sv is) us (termStreamIndex Deletion sv is) - {-# Inline mkStream #-} - - - -instance - ( TstCtx m ts s x0 i0 is (Unit I) - ) => TermStream m (TermSymbol ts Deletion) s (is:.Unit I) where - termStream (ts:|Deletion) (cs:.IStatic ()) (us:._) (is:._) - = S.map (\(TState s ii ee) -> TState s (ii:.:RiU) (ee:.())) - . termStream ts cs us is - {-# Inline termStream #-} - -instance - ( TstCtx m ts s x0 i0 is (Unit O) - ) => TermStream m (TermSymbol ts Deletion) s (is:.Unit O) where - termStream (ts:|Deletion) (cs:.OStatic ()) (us:._) (is:._) - = S.map (\(TState s ii ee) -> TState s (ii:.:RiU) (ee:.())) - . termStream ts cs us is - {-# Inline termStream #-} - - - -instance TermStaticVar Deletion (Unit I) where - termStaticVar _ _ _ = IStatic () - termStreamIndex _ _ _ = Unit - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - -instance TermStaticVar Deletion (Unit O) where - termStaticVar _ _ _ = OStatic () - termStreamIndex _ _ _ = Unit - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - diff --git a/ADP/Fusion/Term/Edge/Type.hs b/ADP/Fusion/Term/Edge/Type.hs deleted file mode 100644 --- a/ADP/Fusion/Term/Edge/Type.hs +++ /dev/null @@ -1,39 +0,0 @@ - -module ADP.Fusion.Term.Edge.Type where - -import Data.Strict.Tuple - -import Data.PrimitiveArray - -import ADP.Fusion.Core.Classes -import ADP.Fusion.Core.Multi - - - -newtype From = From { getFrom :: Int } - deriving (Eq,Ord,Show) - -newtype To = To { getTo :: Int } - deriving (Eq,Ord,Show) - --- | An edge in a graph. As a parsing symbol, it will provide (From:.To) --- pairs. - -data Edge = Edge - -instance Build Edge - -instance - ( Element ls i - ) => Element (ls :!: Edge) i where - data Elm (ls :!: Edge) i = ElmEdge !(From:.To) !(RunningIndex i) (Elm ls i) - type Arg (ls :!: Edge) = Arg ls :. (From:.To) - getArg (ElmEdge e _ ls) = getArg ls :. e - getIdx (ElmEdge _ i _ ) = i - {-# Inline getArg #-} - {-# Inline getIdx #-} - -deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: Edge) i) - -type instance TermArg Edge = (From:.To) - diff --git a/ADP/Fusion/Term/Epsilon/Point.hs b/ADP/Fusion/Term/Epsilon/Point.hs deleted file mode 100644 --- a/ADP/Fusion/Term/Epsilon/Point.hs +++ /dev/null @@ -1,58 +0,0 @@ - -module ADP.Fusion.Term.Epsilon.Point where - -import Data.Proxy -import Data.Strict.Tuple -import qualified Data.Vector.Fusion.Stream.Monadic as S - -import Data.PrimitiveArray - -import ADP.Fusion.Core -import ADP.Fusion.Core.Point -import ADP.Fusion.Term.Epsilon.Type - - - -instance - ( TmkCtx1 m ls Epsilon (PointL i) - ) => MkStream m (ls :!: Epsilon) (PointL i) where - mkStream (ls :!: Epsilon) sv us is - = S.map (\(ss,ee,ii) -> ElmEpsilon ii ss) - . addTermStream1 Epsilon sv us is - $ mkStream ls (termStaticVar Epsilon sv is) us (termStreamIndex Epsilon sv is) - {-# Inline mkStream #-} - - - -instance - ( TstCtx m ts s x0 i0 is (PointL I) - ) => TermStream m (TermSymbol ts Epsilon) s (is:.PointL I) where - termStream (ts:|Epsilon) (cs:.IStatic d) (us:.PointL u) (is:.PointL i) - = S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:.())) - . termStream ts cs us is - {-# Inline termStream #-} - -instance - ( TstCtx m ts s x0 i0 is (PointL O) - ) => TermStream m (TermSymbol ts Epsilon) s (is:.PointL O) where - termStream (ts:|Epsilon) (cs:.OStatic d) (us:.PointL u) (is:.PointL i) - = S.map (\(TState s ii ee) -> - let io = getIndex (getIdx s) (Proxy :: PRI is (PointL O)) - in TState s (ii:.:io) (ee:.())) - . termStream ts cs us is - {-# Inline termStream #-} - - - -instance TermStaticVar Epsilon (PointL I) where - termStaticVar _ sv _ = sv - termStreamIndex _ _ (PointL j) = PointL j - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - -instance TermStaticVar Epsilon (PointL O) where - termStaticVar _ (OStatic d) _ = OStatic d - termStreamIndex _ _ j = j - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - diff --git a/ADP/Fusion/Term/Epsilon/Type.hs b/ADP/Fusion/Term/Epsilon/Type.hs deleted file mode 100644 --- a/ADP/Fusion/Term/Epsilon/Type.hs +++ /dev/null @@ -1,26 +0,0 @@ - -module ADP.Fusion.Term.Epsilon.Type where - -import Data.Strict.Tuple - -import Data.PrimitiveArray - -import ADP.Fusion.Core.Classes -import ADP.Fusion.Core.Multi - - - -data Epsilon = Epsilon - -instance Build Epsilon - -instance (Element ls i) => Element (ls :!: Epsilon) i where - data Elm (ls :!: Epsilon) i = ElmEpsilon !(RunningIndex i) !(Elm ls i) - type Arg (ls :!: Epsilon) = Arg ls :. () - getArg (ElmEpsilon _ l) = getArg l :. () - getIdx (ElmEpsilon i _) = i - {-# Inline getArg #-} - {-# Inline getIdx #-} - -type instance TermArg Epsilon = () - diff --git a/ADP/Fusion/Term/Epsilon/Unit.hs b/ADP/Fusion/Term/Epsilon/Unit.hs deleted file mode 100644 --- a/ADP/Fusion/Term/Epsilon/Unit.hs +++ /dev/null @@ -1,55 +0,0 @@ - -module ADP.Fusion.Term.Epsilon.Unit where - -import Data.Proxy -import Data.Strict.Tuple -import qualified Data.Vector.Fusion.Stream.Monadic as S - -import Data.PrimitiveArray - -import ADP.Fusion.Core -import ADP.Fusion.Core.Unit - - - -instance - ( TmkCtx1 m ls Epsilon (Unit i) - ) => MkStream m (ls :!: Epsilon) (Unit i) where - mkStream (ls :!: Epsilon) sv us is - = S.map (\(ss,ee,ii) -> ElmEpsilon ii ss) - . addTermStream1 Epsilon sv us is - $ mkStream ls (termStaticVar Epsilon sv is) us (termStreamIndex Epsilon sv is) - {-# Inline mkStream #-} - - - -instance - ( TstCtx m ts s x0 i0 is (Unit I) - ) => TermStream m (TermSymbol ts Epsilon) s (is:.Unit I) where - termStream (ts:|Epsilon) (cs:.IStatic ()) (us:._) (is:._) - = S.map (\(TState s ii ee) -> TState s (ii:.:RiU) (ee:.())) - . termStream ts cs us is - {-# Inline termStream #-} - -instance - ( TstCtx m ts s x0 i0 is (Unit O) - ) => TermStream m (TermSymbol ts Epsilon) s (is:.Unit O) where - termStream (ts:|Epsilon) (cs:.OStatic ()) (us:._) (is:._) - = S.map (\(TState s ii ee) -> TState s (ii:.:RiU) (ee:.())) - . termStream ts cs us is - {-# Inline termStream #-} - - - -instance TermStaticVar Epsilon (Unit I) where - termStaticVar _ _ _ = IStatic () - termStreamIndex _ _ _ = Unit - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - -instance TermStaticVar Epsilon (Unit O) where - termStaticVar _ _ _ = OStatic () - termStreamIndex _ _ _ = Unit - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - diff --git a/ADP/Fusion/Term/PeekIndex/Type.hs b/ADP/Fusion/Term/PeekIndex/Type.hs deleted file mode 100644 --- a/ADP/Fusion/Term/PeekIndex/Type.hs +++ /dev/null @@ -1,30 +0,0 @@ - -module ADP.Fusion.Term.PeekIndex.Type where - -import Data.Strict.Tuple - -import Data.PrimitiveArray - -import ADP.Fusion.Core.Classes -import ADP.Fusion.Core.Multi - - - -data PeekIndex i = PeekIndex - -instance Build (PeekIndex i) - -instance - ( Element ls i - ) => Element (ls :!: PeekIndex i) i where - data Elm (ls :!: PeekIndex i) i = ElmPeekIndex !i !(RunningIndex i) !(Elm ls i) - type Arg (ls :!: PeekIndex i) = Arg ls :. i - getArg (ElmPeekIndex x _ ls) = getArg ls :. x - getIdx (ElmPeekIndex _ i _ ) = i - {-# Inline getArg #-} - {-# Inline getIdx #-} - -deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: PeekIndex i) i) - -type instance TermArg (PeekIndex i) = PeekIndex i - diff --git a/ADP/Fusion/Term/Strng/Point.hs b/ADP/Fusion/Term/Strng/Point.hs deleted file mode 100644 --- a/ADP/Fusion/Term/Strng/Point.hs +++ /dev/null @@ -1,96 +0,0 @@ - -module ADP.Fusion.Term.Strng.Point where - -import Data.Proxy -import Data.Strict.Tuple -import Debug.Trace -import qualified Data.Vector.Fusion.Stream.Monadic as S -import qualified Data.Vector.Generic as VG - -import Data.PrimitiveArray - -import ADP.Fusion.Core -import ADP.Fusion.Core.Point -import ADP.Fusion.Term.Strng.Type - - - -instance - ( TmkCtx1 m ls (Strng v x) (PointL i) - ) => MkStream m (ls :!: Strng v x) (PointL i) where - mkStream (ls :!: strng@(Strng _ minL maxL xs)) sv us is - = S.map (\(ss,ee,ii) -> ElmStrng ee ii ss) - . addTermStream1 strng sv us is - $ mkStream ls (termStaticVar strng sv is) us (termStreamIndex strng sv is) - {-# Inline mkStream #-} - - - -instance - ( TstCtx m ts s x0 i0 is (PointL I) - ) => TermStream m (TermSymbol ts (Strng v x)) s (is:.PointL I) where - -- - termStream (ts:|Strng f minL maxL v) (cs:.IStatic d) (us:.PointL u) (is:.PointL i) - = S.map (\(TState s ii ee) -> - let RiPlI k = getIndex (getIdx s) (Proxy :: PRI is (PointL I)) - in TState s (ii:.:RiPlI i) (ee:.f k (i-k) v)) - . termStream ts cs us is - -- - termStream (ts:|Strng f minL maxL v) (cs:.IVariable d) (us:.PointL u) (is:.PointL i) - = S.flatten mk step . termStream ts cs us is - where mk (tstate@(TState s ii ee)) = - let RiPlI k = getIndex (getIdx s) (Proxy :: PRI is (PointL I)) - in return (tstate, i-k-d-minL) - step (tstate@(TState s ii ee), z) - | z >= 0 && (l-k <= maxL) = return $ S.Yield (TState s (ii:.:RiPlI l) (ee:.f k (l-k+1) v)) (tstate, z-1) - | otherwise = return $ S.Done - where RiPlI k = getIndex (getIdx s) (Proxy :: PRI is (PointL I)) - l = i - z - d - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - {-# Inline termStream #-} - -instance - ( TstCtx m ts s x0 i0 is (PointL O) - ) => TermStream m (TermSymbol ts (Strng v x)) s (is:.PointL O) where - -- - termStream (ts:|Strng f minL maxL v) (cs:.OStatic d) (us:.PointL u) (is:.PointL i) - = S.map (\(TState s ii ee) -> - let RiPlO k o = getIndex (getIdx s) (Proxy :: PRI is (PointL O)) - in TState s (ii:.:RiPlO (i-d+1) o) (ee:.f k (i-k) v)) -- @i-d+1 or k-d+1@ ? - . termStream ts cs us is - -- - termStream (ts:|Strng f minL maxL v) (cs:.ORightOf d) (us:.PointL u) (is:.PointL i) - = S.flatten mk step . termStream ts cs us is - where mk (tstate@(TState s ii ee)) = - let RiPlO k _ = getIndex (getIdx s) (Proxy :: PRI is (PointL O)) - in return (tstate, i-k-d-minL) - step (tstate@(TState s ii ee), z) - | z >= 0 && (l-k <= maxL) = return $ S.Yield (TState s (ii:.:RiPlO l o) (ee:.f k (l-k+1) v)) (tstate, z-1) - | otherwise = return $ S.Done - where RiPlO k o = getIndex (getIdx s) (Proxy :: PRI is (PointL O)) - l = i - z - d - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - {-# Inline termStream #-} - - - -instance TermStaticVar (Strng v x) (PointL I) where - termStaticVar (Strng _ minL maxL _) (IStatic d) _ = IVariable $ d + maxL - minL - termStaticVar _ (IVariable d) _ = IVariable d -- TODO is this right? - -- - termStreamIndex (Strng _ minL _ _) (IStatic d) (PointL j) = PointL $ j - minL - -- - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - -instance TermStaticVar (Strng v x) (PointL O) where - termStaticVar (Strng _ minL maxL _) (OStatic d) _ = ORightOf $ d + maxL - minL - termStaticVar _ (ORightOf d) _ = ORightOf 0 -- TODO is this right? - -- - termStreamIndex _ _ j = j - -- - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - diff --git a/ADP/Fusion/Term/Strng/Type.hs b/ADP/Fusion/Term/Strng/Type.hs deleted file mode 100644 --- a/ADP/Fusion/Term/Strng/Type.hs +++ /dev/null @@ -1,55 +0,0 @@ - -module ADP.Fusion.Term.Strng.Type where - -import Data.Strict.Tuple -import qualified Data.Vector.Generic as VG - -import Data.PrimitiveArray - -import ADP.Fusion.Core.Classes -import ADP.Fusion.Core.Multi - - - --- | 'Strng' terminals return "strings", i.e. vectors of @Chr@s. They allow --- the user to specify @[ 0 .. ]@ atoms to be parsed at once. It is --- possible to both, limit the minimal and maximal number. --- --- NOTE gadt comments are not parsed by haddock? - -data Strng v x where - Strng :: VG.Vector v x - => (Int -> Int -> v x -> v x) -- @slice@ function - -> Int -- minimal size - -> Int -- maximal size (just use s.th. big if you don't want a limit) - -> (v x) -- the actual vector - -> Strng v x - -manyS :: VG.Vector v x => v x -> Strng v x -manyS = \xs -> Strng VG.unsafeSlice 0 (VG.length xs) xs -{-# Inline manyS #-} - -someS :: VG.Vector v x => v x -> Strng v x -someS = \xs -> Strng VG.unsafeSlice 1 (VG.length xs) xs -{-# Inline someS #-} - -strng :: VG.Vector v x => Int -> Int -> v x -> Strng v x -strng = \minL maxL xs -> Strng VG.unsafeSlice minL maxL xs -{-# Inline strng #-} - -instance Build (Strng v x) - -instance - ( Element ls i - ) => Element (ls :!: Strng v x) i where - data Elm (ls :!: Strng v x) i = ElmStrng !(v x) !(RunningIndex i) !(Elm ls i) - type Arg (ls :!: Strng v x) = Arg ls :. v x - getArg (ElmStrng x _ ls) = getArg ls :. x - getIdx (ElmStrng _ i _ ) = i - {-# Inline getArg #-} - {-# Inline getIdx #-} - -deriving instance (Show i, Show (RunningIndex i), Show (v x), Show (Elm ls i)) => Show (Elm (ls :!: Strng v x) i) - -type instance TermArg (Strng v x) = v x - diff --git a/ADP/Fusion/Tutorial/NeedlemanWunsch.hs b/ADP/Fusion/Tutorial/NeedlemanWunsch.hs deleted file mode 100644 --- a/ADP/Fusion/Tutorial/NeedlemanWunsch.hs +++ /dev/null @@ -1,495 +0,0 @@ - -{-# Options_GHC -fno-warn-unused-imports #-} - -{-| - -The Needleman-Wunsch global alignment algorithm. This algorithm is -extremely simple but provides a good showcase for what ADPfusion offers. - -The Needleman-Wunsch algorithm aligns to strings @x = x_1 x_2 x_3 ...@ and -@y = y_1 y_2 y_3 ...@ which may be of differing lengths. Assume that @x_1 -... x_{i-1}@ and @y_1 ... y_{j-1}@ have already been optimally aligned. We -can match @x_i@ with @y_j@, or perform one of two possible insert-deletion -pairs. Either @x_i@ is aligned with @-@ or @-@ is aligned with @y_j@. More -general, in each DP step, either one or both inputs are extended by one -character. - -For the actual implementation, we assume however, that we work backward. -The entries @d@, @u@, and @l@ have already been calculated. Now we want to -compute the entry at @x@ in the lower right corner. - -@ - ----- - |d|u| - ----- - |l|x| - ----- -@ - -We introduce a generic naming scheme for each possible move. If we move in -a direction, we call it a @step@. If we do not move, then we call it -a @loop@, because the index loops for this computation. - -We can arrive from @d@, making a diagonal step, called @step_step@ as we -advance by one in both dimensions. This leads to an alignment of two -characters, one from each input, at @x@, which is combined with the already -calculated alignment at @d@. - -We can also just step in the first dimension @step_loop@, going from @l@ to -@x@. Which means that the first-dim character does not have a partner, -leading to an insert/deletion or in/del. We typically do not care in which -of the two dimensions the in/del happens, just that it does. - -The third case is an in/del in the other dimension, giving us @loop_step@ -or going from @u@ to @x@. - -Of course, if @x@ happens to be the uppermost, leftmost cell, we have -nowhere to come from, so we need to inititialize (or terminate depending on -your view point) using the @nil_nil@ case. That one is the base case. - -We also want to know which of the three cases is the best case (coming from -@d,l,u@), this requires a "choice" function or @h@. - - -We now implement this algorithm using the low-level ADPfusion library. -Follow the code from top to bottom for a tutorial on usage. The -Needleman-Wunsch tutorial for the @FormalGrammars@ library provides -a higher-level style of implementation. - - - -We also provide an implementation based on grammar products, which simplify -the design of alignment-type algorithms. The corresponding tutorial is -here. - - - - - -Don't forget to inline basically everything! - --} - -module ADP.Fusion.Tutorial.NeedlemanWunsch - ( - -- * Module Header - -- $header - - -- * Signature - -- $signature - - -- * Algebra Product - -- $algebraproduct - - -- * Grammar - -- $grammar - - -- * Scoring Algebra - -- $algebrascore - - -- * Pretty-printing Algebra - -- $algebrapretty - - -- * The @Inside@ version - - -- ** Table-filling for the @Inside@ version - -- $insideforward - - -- ** Backtracking optimal results for the @Inside@ version - -- $insidebacktrack - - -- ** Glueing the @Inside@ version parts together - -- $runforward - - -- * The @Outside@ version - - -- ** Table-filling for the @Outside@ version - -- $outsideforward - - -- ** Backtracking optimal results for the @Outside@ version - -- $outsidebacktrack - - -- ** Glueing the @Outside@ version parts together - -- $runoutside - - -- * Wrapping everything up - - -- ** Alignment wrapper - -- $alignwrapper - - -- ** Main - -- $main - - ) where - -import ADP.Fusion.Point - -{- $header - -We start by importing a bunch of modules, including @Data.PrimitiveArray@ -for low-level arrays and automated filling of the arrays or tables in the -correct order. - -We also need to import @ADP.Fusion@ to access the high-level code for -dynamic programs. - - -> module Main where - -> import Control.Monad (forM_) -> import System.Environment (getArgs) -> import Text.Printf - -Streams of parses are the streams defined in the @vector@ package. - -> import qualified Data.Vector.Fusion.Stream.Monadic as SM - -We use unboxed vectors to hold the input sequences to be aligned. The -terminal parses work with any vector in the @vector@ package. - -> import qualified Data.Vector.Unboxed as VU - -@Data.PrimitiveArray@ contains data structures, and index structures for -dynamic programming. Notably, the primitive arrays holding the cell data -with Boxed and Unboxed tables. In addition, linear, context-free, and set -data structures are made available. - -> import Data.PrimitiveArray as PA hiding (map) - -@ADP.Fusion.Point@ exposes everything necessary for higher-level DP -algorithms. Depending on the type of DP algorithm, different top-level -modules can be imported. @.Point@ for linear grammars, and @.Core@ are -provided in this package. @.Core@ exports only the core modules required to -extend ADPfusion. - -> import ADP.Fusion.Point - --} - - - -{- $signature - -A signature connects the types of all non-terminals and terminals with -evaluation (or attribute) functions. In the grammar below, we not only want -to create all possible parses of how two strings can be aligned but also -evaluate each parse and choose the optimal one based on Bellman's principle -of optimality. - -We take a close look at the type signatures. @step_step :: x -> (Z:.c:.c) --> x@ tells us that @step_step@ requires the score from the non-terminal, -typed @x@ for the alignment up to @d@, then we get the two characters with -type @c@ and produce a new non-terminal typed score @x@. For our simple -alignment we'll later choose @Char@ for @c@ and @Int@ for @x@. - -The type of @h :: Stream m x -> m r@ is more interesting. We get a @Stream@ -of @x@'s and produce an @r@ monadically. The left part is clear @Stream -m x@ are the results from the four rules, but the right part allows us to -maybe not only return the best case, types @x == r@, but maybe the two best -cases @r == (x,x)@ or similar. While we do not use this feature here, it -makes ADPfusion fully "classified DP" capable, which is a really cool -feature for advanced algorithms. - -> data Signature m x r c = Signature -> { step_step :: x -> (Z:.c :.c ) -> x -> , step_loop :: x -> (Z:.c :.()) -> x -> , loop_step :: x -> (Z:.():.c ) -> x -> , nil_nil :: (Z:.():.()) -> x -> , h :: Stream m x -> m r -> } - --} - - - -{- $algebraproduct - -We also want to be able to backtrace the optimal result. Given our -alignment, knowing that we get an alignment score of 29 doesn't help us -much. But with /algebra products/ we can ask for @(optimal <** pretty)@ and -get the optimal result /and/ the parse for it. - -The @(<**)@ operator is notoriously difficult to write, so we just compute -it ☺. - -Note that haddock actually shows @(<**)@, while you just write -@makeAlgebraProductH ['h] ''Signature@ (the primes are TemplateHaskell, -the only TemplateHaskell we need). - -> makeAlgebraProduct ''Signature - --} - - - -{- $grammar - -This is the linear grammar in two dimensions describing the -"Needleman-Wunsch" search space. It will, in principle, enumerate the -exponential number of possible alignment, but due to memoization and the -choice function @h@, the calculation time is @O(N^2)@ and if only one -optimal alignment is requested, backtracking works in linear time. - -The grammar first requires a 'Signature', we use @RecordWildCards@ as -a language extension to bind @step_step@ and friends. We also need -a variable for the single non-terminal (@a@), and have two inputs @i1@ and -@i2@. Each grammar starts with a "base case" @Z:.@ followed by one or more -pairs of non-terminal plus rules. Here we have one pair @(a, rules)@, where -in @rules@ we combine the four different rules. - -@step_step \<\<\< a % (M:>chr i1:>chr i2)@, for example, means that -@step_step@ first gets the non-terminal @a@, which will give the score up -to @d@ (see the ascii-art above), followed by @(%)@ the 2-dim terminal for -@i1@ and @i2@. - -Multi-dimensional terminals are built up from the zero-dimension @M@, -separated by @:|@ symbols and just bind the input. In this case we want -individual characters from @i1@ and @i2@, so we write @chr i1@ or @chr i2@. - -Different rules are combined with @(|||)@ and the optimal case is selected -via @... h@. Rules can, of course, be co-recursive, each rule can request -all terminal and non-terminal symbols. - -Due to the way @nil_nil@ works on @Epsilon@, @nil_nil@ is actually /only/ -called once, when we start the alignment, not for every cell! - -/However/, due to this being a high-performance library, we do not provide -a runtime scheme to detect misbehaving rules. Some debug-code is in place -that performs certain checks in non-optimized GHCI sessions, but optimized -code is built for raw speed, without any checks. - -If you are a "conventional" DP programmer, you might miss the usual -indices. Just as in the spiritual father of @ADPfusion@, Robert Giegerichs -@ADP@, we hide the actual index calculations. - -> grammar Signature{..} !a' !i1 !i2 = -> let a = TW a' ( step_step <<< a % (M:|chr i1:|chr i2) ||| -> step_loop <<< a % (M:|chr i1:|Deletion ) ||| -> loop_step <<< a % (M:|Deletion :|chr i2) ||| -> nil_nil <<< (M:|Epsilon:|Epsilon) ... h -> ) -> in Z:.a -@ -\{\-\# INLINE grammar \#\-\} -@ - --} - - - -{- $algebrascore - -A grammar alone is not enough, we also need to say what a @step_step@ -means, or what an optimum is. Here, we do exactly that. We create an -instance of the 'Signature' from above. Since this is a simple example, we -just say that two aligned characters @a@ and @b@ yield a score of @x+1@ -(with @x@ the previous alignment score) if the characters are identical. -Otherwise we lower the score by 2. In/dels incur a cost of @-1@, meaning -that a mismatch is actually the same as two in/dels, one in each dimension. -The start of the alignment gives an initial score of 0. - -And the optimal choice, of course, is to start with a default of @-999999@ -and find the maximum of that score and the choices we are given. - -> sScore :: Monad m => Signature m Int Int Char -> sScore = Signature -> { step_step = \x (Z:.a:.b) -> if a==b then x+1 else x-2 -> , step_loop = \x _ -> x-1 -> , loop_step = \x _ -> x-1 -> , nil_nil = const 0 -> , h = SM.foldl' max (-999999) -> } -@ -\{\-\# INLINE sScore \#\-\} -@ - --} - - - -{- $algebrapretty - -Scores alone are still not enough, we also want to pretty-print alignments. -An alignment are basically two strings @[String 1, String 2]@, being turned -into a whole stream of alignments, using @Char@s for the individual -characters being aligned. - -We follow the same theme as in 'sScore', but this time @h = toList@, that -is the choice function @h@ does not (!) make choice but rather returns all -alignments. You already heard about @<**@, we'll use it below. - -> sPretty :: Monad m => Signature m [String] [[String]] Char -> sPretty = Signature -> { step_step = \[x,y] (Z:.a :.b ) -> [a :x, b :y] -> , step_loop = \[x,y] (Z:.a :.()) -> [a :x, '-':y] -> , loop_step = \[x,y] (Z:.():.b ) -> ['-':x, b :y] -> , nil_nil = const ["",""] -> , h = SM.toList -> } -@ -\{\-\# Inline sPretty \#\-\} -@ - --} - - - -{- $insideforward - -The forward or table-filling phase. It is possible to inline this code -directly into 'runNeedlemanWunsch'. Here, this phase is separated. If you -use @ghc-core@ to examine the @GHC Core@ language, you can search for -@nwInsideForward@ and check wether the inside code is optimized well. This -is normally /not/ required, and only done here, because these algorithms -are used to gauge efficiency of the fusion framework as well. - -For your own code, you can write as done here, or in the way of -'runOutsideNeedlemanWunsch'. - -> nwInsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.TwITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int -> nwInsideForward i1 i2 = {-# SCC "nwInsideForward" #-} mutateTablesDefault $ -> grammar sScore -> (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.PointL 0:.PointL 0) (Z:.PointL n1:.PointL n2) (-999999) [])) -> i1 i2 -> where n1 = VU.length i1 -> n2 = VU.length i2 -@ -\{\-\# NoInline nwInsideForward \#\-\} -@ - -We normally do not want to inline a fully specified algorithm. Compilation -times are rather long, and in this way, we only compile once for the -library, not every time the algorithm is called. - --} - - - -{- $insidebacktrack - -> nwInsideBacktrack :: VU.Vector Char -> VU.Vector Char -> TwITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int -> [[String]] -> nwInsideBacktrack i1 i2 t = {-# SCC "nwInsideBacktrack" #-} unId $ axiom b -> where !(Z:.b) = grammar (sScore <|| sPretty) (toBacktrack t (undefined :: Id a -> Id a)) i1 i2 -> :: Z:.TwITblBt Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int Id Id [String] -@ -\{\-\# NoInline nwInsideBacktrack \#\-\} -@ - --} - - - -{- $runforward - -The inside grammar, with efficient table-filling (via 'nwInsideForward') -and backtracking. Requests @k@ co-optimal backtrackings, given the inputs -@i1@ and @i2@. The @fst@ element returned is the score, the @snd@ are the -co-optimal parses. - -runNeedlemanWunsch :: Int -> String -> String -> (Int,[[String]]) -runNeedlemanWunsch k i1' i2' = (d, take k bs) where - i1 = VU.fromList i1' - i2 = VU.fromList i2' - n1 = VU.length i1 - n2 = VU.length i2 - !(Z:.t) = nwInsideForward i1 i2 - d = unId $ axiom t - bs = nwInsideBacktrack i1 i2 t -@ -\{\-\# Noinline runNeedlemanWunsch \#\-\} -@ - --} - - - -{- $outsideforward - -Again, to be able to observe performance, we have extracted the -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 $ -> grammar sScore -> (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.PointL 0:.PointL 0) (Z:.PointL n1:.PointL n2) (-999999) [])) -> i1 i2 -> where n1 = VU.length i1 -> n2 = VU.length i2 -@ -\{\-\# Noinline nwOutsideForward \#\-\} -@ - --} - - - -{- $runoutside - -The outside version of the Needleman-Wunsch alignment algorithm. The -outside grammar is identical to the inside grammar! This is not generally -the case, but here it is. Hence we may just use outside tables and the -grammar from above. - -> runOutsideNeedlemanWunsch :: Int -> String -> String -> (Int,[[String]]) -> runOutsideNeedlemanWunsch k i1' i2' = {-# SCC "runOutside" #-} (d, take k . unId $ axiom b) where -> i1 = VU.fromList i1' -> i2 = VU.fromList i2' -> n1 = VU.length i1 -> n2 = VU.length i2 -> !(Z:.t) = nwOutsideForward i1 i2 -> d = unId $ axiom t -> !(Z:.b) = grammar (sScore <|| sPretty) (toBacktrack t (undefined :: Id a -> Id a)) i1 i2 -> :: Z:.TwITblBt Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL O:.PointL O) Int Id Id [String] -@ -\{\-\# Noinline runOutsideNeedlemanWunsch \#\-\} -@ - --} - - - -{- $alignwrapper - -This wrapper takes a list of input sequences and aligns each odd sequence -with the next even sequence. We want one alignment for each such pair. - -Since we use basic lists during backtracking, the resulting lists have to -be reversed for inside-backtracking. Note that because the Outside grammar -is quasi-right-linear, it does not require reversing the two strings. - -For real applications, consider using @Data.Sequence@ which has @O(1)@ -append and prepend. - -> align _ [] = return () -> align _ [c] = putStrLn "single last line" -> align k (a:b:xs) = {-# SCC "align" #-} do -> putStrLn a -> putStrLn b -> putStrLn "" -> let (sI,rsI) = runNeedlemanWunsch k a b -> let (sO,rsO) = runOutsideNeedlemanWunsch k a b -> forM_ rsI $ \[u,l] -> printf "%s\n%s %d\n\n" (reverse u) (reverse l) sI -> forM_ rsO $ \[u,l] -> printf "%s\n%s %d\n\n" (id u) (id l) sO -> align k xs - --} - - - -{- $main - -And finally have a minimal main that reads from stdio. - -If you are brave enough then put this through @ghc-core@ and look for -@nwInsideForward@ or @nwOutsideForward@ in the CORE. Everything coming from -the forward phase should be beautifully optimized and the algorithm should -run quite fast. - -> main = do -> as <- getArgs -> let k = if null as then 1 else read $ head as -> ls <- lines <$> getContents -> align k ls - --} - diff --git a/ADP/Fusion/Unit.hs b/ADP/Fusion/Unit.hs --- a/ADP/Fusion/Unit.hs +++ b/ADP/Fusion/Unit.hs @@ -5,14 +5,14 @@ module ADP.Fusion.Unit ( module ADP.Fusion.Core - , module ADP.Fusion.Term.Deletion.Unit - , module ADP.Fusion.SynVar.Indices.Unit - , module ADP.Fusion.Term.Epsilon.Unit + , module ADP.Fusion.Unit.SynVar.Indices + , module ADP.Fusion.Unit.Term.Deletion + , module ADP.Fusion.Unit.Term.Epsilon ) where import ADP.Fusion.Core -import ADP.Fusion.Term.Deletion.Unit -import ADP.Fusion.Term.Epsilon.Unit -import ADP.Fusion.SynVar.Indices.Unit +import ADP.Fusion.Unit.SynVar.Indices +import ADP.Fusion.Unit.Term.Deletion +import ADP.Fusion.Unit.Term.Epsilon diff --git a/ADP/Fusion/Unit/Core.hs b/ADP/Fusion/Unit/Core.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Unit/Core.hs @@ -0,0 +1,116 @@ + +-- | +-- +-- TODO the 'mkStream' instances here are probably wonky for everything that is +-- non-static. +-- +-- TODO should @d@ in each case here be @d==0@? What is the exact meaning @d@ +-- should convey? + +module ADP.Fusion.Unit.Core where + +import Data.Proxy +import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..)) +import Debug.Trace +import Prelude hiding (map,filter) + +import Data.PrimitiveArray hiding (map) + +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi + + + +type instance InitialContext (Unit I) = IStatic 0 + +type instance InitialContext (Unit O) = OStatic 0 + +type instance InitialContext (Unit C) = Complement + +data instance RunningIndex (Unit t) = RiUnit + + + +instance + ( Monad m + ) + ⇒ MkStream m (IStatic d) S (Unit I) where + mkStream Proxy S grd LtUnit Unit + = staticCheck# grd + . singleton $ ElmS RiUnit + {-# Inline mkStream #-} + +instance + ( Monad m + ) + ⇒ MkStream m (IVariable d) S (Unit I) where + mkStream Proxy S grd LtUnit Unit + = staticCheck# grd + . singleton $ ElmS RiUnit + {-# Inline mkStream #-} + +instance + ( Monad m + ) + ⇒ MkStream m (OStatic d) S (Unit O) where + mkStream Proxy S grd LtUnit Unit + = staticCheck# grd + . singleton $ ElmS RiUnit + {-# Inline mkStream #-} + +instance + ( Monad m + ) + ⇒ MkStream m Complement S (Unit C) where + mkStream Proxy S grd LtUnit Unit + = staticCheck# grd + . singleton $ ElmS RiUnit + {-# Inline mkStream #-} + +--instance +-- forall m ps p is +-- . ( Monad m +-- , MkStream m ps S is +-- ) +-- ⇒ MkStream m ('(:.) ps p) S (is:.Unit I) where +-- mkStream Proxy S grd (us:.._) (is:._) +-- = map (\(ElmS zi) -> ElmS $ zi :.: RiU) +-- $ mkStream (Proxy ∷ Proxy ps) S grd us is +-- {-# Inline mkStream #-} +-- +--instance +-- forall m ps p is +-- . ( Monad m +-- , MkStream m ps S is +-- ) +-- ⇒ MkStream m ('(:.) ps p) S (is:.Unit O) where +-- mkStream Proxy S grd (us:.._) (is:._) +-- = map (\(ElmS zi) -> ElmS $ zi :.: RiU) +-- $ mkStream (Proxy ∷ Proxy ps) S grd us is +-- {-# Inline mkStream #-} +-- +--instance +-- forall m ps p is +-- . ( Monad m +-- , MkStream m ps S is +-- ) +-- ⇒ MkStream m ('(:.) ps p) S (is:.Unit C) where +-- mkStream Proxy S grd (us:.._) (is:._) +-- = map (\(ElmS zi) -> ElmS $ zi :.: RiU) +-- $ mkStream (Proxy ∷ Proxy ps) S grd us is +-- {-# Inline mkStream #-} +-- +-- +-- +--instance TableStaticVar pos c u (Unit I) where +-- tableStreamIndex _ _ _ _ = Unit +-- {-# Inline [0] tableStreamIndex #-} +-- +--instance TableStaticVar pos c u (Unit O) where +-- tableStreamIndex _ _ _ _ = Unit +-- {-# Inline [0] tableStreamIndex #-} +-- +--instance TableStaticVar pos c u (Unit C) where +-- tableStreamIndex _ _ _ _ = Unit +-- {-# Inline [0] tableStreamIndex #-} + diff --git a/ADP/Fusion/Unit/SynVar/Indices.hs b/ADP/Fusion/Unit/SynVar/Indices.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Unit/SynVar/Indices.hs @@ -0,0 +1,70 @@ + +-- | TODO if we have a table that has min-size @>0@ we need to immediately +-- terminate @addIndexDenseGo@ ! + +module ADP.Fusion.Unit.SynVar.Indices where + +import Data.Proxy +import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..)) +import Data.Vector.Fusion.Util (delay_inline) +import Prelude hiding (map,head,mapM) + +import Data.PrimitiveArray hiding (map) + +import ADP.Fusion.Core +import ADP.Fusion.Unit.Core + + + +type instance LeftPosTy (IStatic d) (TwITbl b s m arr EmptyOk (Unit I) x) (Unit I) = IStatic d +type instance LeftPosTy (IStatic d) (TwITblBt b s arr EmptyOk (Unit I) x mB mF r) (Unit I) = IStatic d + +type instance LeftPosTy (OStatic d) (TwITbl b s m arr EmptyOk (Unit O) x) (Unit O) = OStatic d +type instance LeftPosTy (OStatic d) (TwITblBt b s arr EmptyOk (Unit O) x mB mF r) (Unit O) = OStatic d + +type instance LeftPosTy Complement (TwITbl b s m arr EmptyOk (Unit I) x) (Unit C) = Complement +type instance LeftPosTy Complement (TwITblBt b s arr EmptyOk (Unit I) x mB mF r) (Unit C) = Complement + +type instance LeftPosTy Complement (TwITbl b s m arr EmptyOk (Unit O) x) (Unit C) = Complement +type instance LeftPosTy Complement (TwITblBt b s arr EmptyOk (Unit O) x mB mF r) (Unit C) = Complement + +instance + ( AddIndexDenseContext ps elm x0 i0 cs c us (Unit I) is (Unit I) + , MinSize c + ) + ⇒ AddIndexDense (ps:.Unit d) elm (cs:.c) (us:.Unit I) (is:.Unit I) where + addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i) + = map (\(SvS s t y') → SvS s (t:.i) (y' :.: RiUnit)) + . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is + {-# Inline addIndexDenseGo #-} + +instance + ( AddIndexDenseContext ps elm x0 i0 cs c us (Unit O) is (Unit O) + , MinSize c + ) + ⇒ AddIndexDense (ps:.Unit d) elm (cs:.c) (us:.Unit O) (is:.Unit O) where + addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i) + = map (\(SvS s t y') → SvS s (t:.i) (y' :.: RiUnit)) + . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is + {-# Inline addIndexDenseGo #-} + +instance + ( AddIndexDenseContext ps elm x0 i0 cs c us (Unit I) is (Unit C) + , MinSize c + ) + ⇒ AddIndexDense (ps:.Unit d) elm (cs:.c) (us:.Unit I) (is:.Unit C) where + addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i) + = map (\(SvS s t y') → SvS s (t:.Unit) (y' :.: RiUnit)) + . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is + {-# Inline addIndexDenseGo #-} + +instance + ( AddIndexDenseContext ps elm x0 i0 cs c us (Unit O) is (Unit C) + , MinSize c + ) + ⇒ AddIndexDense (ps:.Unit d) elm (cs:.c) (us:.Unit O) (is:.Unit C) where + addIndexDenseGo Proxy (cs:._) (ubs:..ub) (us:..u) (is:.i) + = map (\(SvS s t y') → SvS s (t:.Unit) (y' :.: RiUnit)) + . addIndexDenseGo (Proxy ∷ Proxy ps) cs ubs us is + {-# Inline addIndexDenseGo #-} + diff --git a/ADP/Fusion/Unit/Term/Deletion.hs b/ADP/Fusion/Unit/Term/Deletion.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Unit/Term/Deletion.hs @@ -0,0 +1,47 @@ + +module ADP.Fusion.Unit.Term.Deletion where + +import Data.Proxy +import Data.Strict.Tuple +import qualified Data.Vector.Fusion.Stream.Monadic as S +import GHC.Exts + +import Data.PrimitiveArray + +import ADP.Fusion.Core +import ADP.Fusion.Unit.Core + + + +instance + forall m pos posLeft ls i + . ( TermStream m (Z:.pos) (TermSymbol M Deletion) (Elm (Term1 (Elm ls (Unit i))) (Z :. Unit i)) (Z:.Unit i) + , posLeft ~ LeftPosTy pos Deletion (Unit i) + , TermStaticVar pos Deletion (Unit i) + , MkStream m posLeft ls (Unit i) + ) + ⇒ MkStream m pos (ls :!: Deletion) (Unit i) where + mkStream pos (ls :!: Deletion) grd us is + = S.map (\(ss,ee,ii) -> ElmDeletion ii ss) + . addTermStream1 pos Deletion us is + . mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos Deletion us is grd) us + $ (termStreamIndex pos Deletion is) + {-# Inline mkStream #-} + + +instance + ( TermStreamContext m ps ts s x0 i0 is (Unit I) + , Monad m + , (TermStream m ps ts (Elm x0 i0) is) + ) => TermStream m ('(:.) ps p) (TermSymbol ts Deletion) s (is:.Unit I) where + termStream Proxy (ts:|Deletion) (us:.._) (is:._) + = S.map (\(TState s ii ee) -> TState s (ii:.:RiUnit) (ee:.())) + . termStream (Proxy ∷ Proxy ps) ts us is + {-# Inline termStream #-} + +instance TermStaticVar (IStatic d) Deletion (Unit I) where + termStreamIndex Proxy Deletion Unit = Unit + termStaticCheck Proxy Deletion _ Unit grd = grd + {-# Inline [0] termStreamIndex #-} + {-# Inline [0] termStaticCheck #-} + diff --git a/ADP/Fusion/Unit/Term/Epsilon.hs b/ADP/Fusion/Unit/Term/Epsilon.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Unit/Term/Epsilon.hs @@ -0,0 +1,65 @@ + +module ADP.Fusion.Unit.Term.Epsilon where + +import Data.Proxy +import Data.Strict.Tuple +import qualified Data.Vector.Fusion.Stream.Monadic as S +import GHC.Exts + +import Data.PrimitiveArray + +import ADP.Fusion.Core +import ADP.Fusion.Unit.Core + + + +instance + forall m pos posLeft ls i lg + . ( TermStream m (Z:.pos) (TermSymbol M (Epsilon lg)) (Elm (Term1 (Elm ls (Unit i))) (Z:.Unit i)) (Z:.Unit i) + , posLeft ~ LeftPosTy pos (Epsilon lg) (Unit i) + , TermStaticVar pos (Epsilon lg) (Unit i) + , MkStream m posLeft ls (Unit i) + ) + ⇒ MkStream m pos (ls :!: Epsilon lg) (Unit i) where + mkStream pos (ls :!: Epsilon) grd us is + = S.map (\(ss,ee,ii) -> ElmEpsilon ii ss) + . addTermStream1 pos (Epsilon @lg) us is + . mkStream (Proxy ∷ Proxy posLeft) ls (termStaticCheck pos (Epsilon @lg) us is grd) us + $ termStreamIndex pos (Epsilon @lg) is + {-# Inline mkStream #-} + + + +--instance +-- ( TermStreamContext m ps ts s x0 i0 is (Unit I) +-- , TermStream m ps ts (Elm x0 i0) is +-- ) ⇒ TermStream m (TermSymbol ts Epsilon) s (is:.Unit I) where +-- termStream (ts:|Epsilon) (cs:.IStatic ()) (us:.._) (is:._) +-- = S.map (\(TState s ii ee) -> TState s (ii:.:RiU) (ee:.())) +-- . termStream ts cs us is +-- {-# Inline termStream #-} + +{- +instance + ( TstCtx m ts s x0 i0 is (Unit O) + ) => TermStream m (TermSymbol ts Epsilon) s (is:.Unit O) where + termStream (ts:|Epsilon) (cs:.OStatic ()) (us:.._) (is:._) + = S.map (\(TState s ii ee) -> TState s (ii:.:RiU) (ee:.())) + . termStream ts cs us is + {-# Inline termStream #-} + + + +instance TermStaticVar Epsilon (Unit I) where + termStaticVar _ _ _ = IStatic () + termStreamIndex _ _ _ = Unit + {-# Inline [0] termStaticVar #-} + {-# Inline [0] termStreamIndex #-} + +instance TermStaticVar Epsilon (Unit O) where + termStaticVar _ _ _ = OStatic () + termStreamIndex _ _ _ = Unit + {-# Inline [0] termStaticVar #-} + {-# Inline [0] termStreamIndex #-} +-} + diff --git a/ADPfusion.cabal b/ADPfusion.cabal --- a/ADPfusion.cabal +++ b/ADPfusion.cabal @@ -1,45 +1,46 @@ +cabal-version: 2.2 name: ADPfusion -version: 0.5.2.2 -author: Christian Hoener zu Siederdissen, 2011-2016 -copyright: Christian Hoener zu Siederdissen, 2011-2016 +version: 0.6.0.0 +author: Christian Hoener zu Siederdissen, 2011-2019 +copyright: Christian Hoener zu Siederdissen, 2011-2019 homepage: https://github.com/choener/ADPfusion bug-reports: https://github.com/choener/ADPfusion/issues maintainer: choener@bioinf.uni-leipzig.de category: Algorithms, Data Structures, Bioinformatics, Formal Languages -license: BSD3 +license: BSD-3-Clause license-file: LICENSE build-type: Simple stability: experimental -cabal-version: >= 1.10.0 -tested-with: GHC == 7.10.3, GHC == 8.0.1 +tested-with: GHC == 8.6.4 synopsis: Efficient, high-level dynamic programming. description: . - ADPfusion combines stream-fusion (using the stream interface - provided by the vector library) and type-level programming to - provide highly efficient dynamic programming combinators. + ADPfusion combines stream-fusion (using the stream interface provided by the vector + library) and type-level programming to provide highly efficient dynamic programming + combinators. . - ADPfusion allows writing dynamic programs for single- and - multi-tape problems. Inputs can be sequences, or sets. New - input types can be defined, without having to rewrite this - library thanks to the open-world assumption of ADPfusion. + ADPfusion allows writing dynamic programs for single- and multi-tape problems. + Inputs can be sequences, or sets. New input types can be defined, without having to + rewrite this library thanks to the open-world assumption of ADPfusion. . - The library provides the machinery for Outside and Ensemble - algorithms as well. Ensemble algorithms combine Inside and - Outside calculations. + The library provides the machinery for Outside and Ensemble algorithms as well. + Ensemble algorithms combine Inside and Outside calculations. . - Starting with version 0.4.1 we support writing multiple - context-free grammars (interleaved syntactic variables). Such - grammars have applications in bioinformatics and linguistics. + Starting with version 0.4.1 we support writing multiple context-free grammars + (interleaved syntactic variables). Such grammars have applications in bioinformatics + and linguistics. . - The homepage provides a number of tutorial-style examples, with - linear and context-free grammars over sequence and set inputs. + The homepage provides a number of tutorial-style examples, with linear and + context-free grammars over sequence and set inputs. . - The formal background for generalized algebraic dynamic - progrmaming and ADPfusion is described in a number of papers. - These can be found on the gADP homepage and in the README. + The formal background for generalized algebraic dynamic programming and ADPfusion is + described in a number of papers. These can be found on the gADP homepage and in the + README. . + Note: The core @ADPfusion@ library only provides machinery for linear language over + sequences. The add-ons @ADPfusionSubword@, @ADPfusionForest@, and others provide + specialized machinery for other types of formal languages. @@ -64,6 +65,11 @@ default: False manual: True +flag dump-core + description: Dump HTML for the core generated by GHC during compilation + default: False + manual: True + flag examples description: build the examples default: False @@ -84,16 +90,24 @@ default: False manual: True +flag llvm + description: use llvm + default: False + manual: True -library + +common deps build-depends: base >= 4.7 && < 5.0 , bits >= 0.4 , containers + , deepseq + , ghc-prim , mmorph >= 1.0 , mtl >= 2.0 , primitive >= 0.5.4 , QuickCheck >= 2.7 + , singletons >= 2.4 , strict >= 0.3 , template-haskell >= 2.0 , th-orphans >= 0.12 @@ -101,77 +115,38 @@ , tuple >= 0.3 , vector >= 0.11 -- - , DPutils == 0.0.1.* - , OrderedBits == 0.0.1.* - , PrimitiveArray == 0.8.0.* - - exposed-modules: - -- multi imports - ADP.Fusion.Core - ADP.Fusion.Point - ADP.Fusion.Unit - -- core system - ADP.Fusion.Core.Apply - ADP.Fusion.Core.Classes - ADP.Fusion.Core.Multi - ADP.Fusion.Core.TH - ADP.Fusion.Core.TH.Backtrack - ADP.Fusion.Core.TH.Common - ADP.Fusion.Core.TyLvlIx - ADP.Fusion.SynVar.Array - ADP.Fusion.SynVar.Array.Type - ADP.Fusion.SynVar.Axiom - ADP.Fusion.SynVar.Backtrack - ADP.Fusion.SynVar.Fill - ADP.Fusion.SynVar.Indices.Classes - ADP.Fusion.SynVar.Recursive.Type - ADP.Fusion.SynVar.Split.Type - ADP.Fusion.SynVar.TableWrap - ADP.Fusion.Term.Chr.Type - ADP.Fusion.Term.Deletion.Type - ADP.Fusion.Term.Edge.Type - ADP.Fusion.Term.Epsilon.Type - ADP.Fusion.Term.PeekIndex.Type - ADP.Fusion.Term.Strng.Type - -- Point - ADP.Fusion.Core.Point - ADP.Fusion.SynVar.Indices.Point - ADP.Fusion.SynVar.Recursive.Point - ADP.Fusion.Term.Chr.Point - ADP.Fusion.Term.Deletion.Point - ADP.Fusion.Term.Epsilon.Point - ADP.Fusion.Term.Strng.Point - -- Unit - ADP.Fusion.Core.Unit - ADP.Fusion.SynVar.Indices.Unit - ADP.Fusion.Term.Deletion.Unit - ADP.Fusion.Term.Epsilon.Unit - -- tutorials - ADP.Fusion.Tutorial.NeedlemanWunsch - + , DPutils == 0.1.0.* + , OrderedBits == 0.0.2.* + , PrimitiveArray == 0.10.0.* default-extensions: BangPatterns , ConstraintKinds , CPP , DataKinds , DefaultSignatures + , DeriveAnyClass , DeriveDataTypeable , DeriveGeneric , FlexibleContexts , FlexibleInstances , GADTs , KindSignatures + , MagicHash , MultiParamTypeClasses + -- PolyKinds is very important to get GHC to pick up all + -- the instances correctly. + , PolyKinds , RankNTypes , RecordWildCards , ScopedTypeVariables , StandaloneDeriving , TemplateHaskell , TupleSections + , TypeApplications , TypeFamilies , TypeOperators , TypeSynonymInstances , UndecidableInstances - + , UnicodeSyntax default-language: Haskell2010 ghc-options: @@ -181,10 +156,78 @@ -ddump-to-file -ddump-simpl -dsuppress-all + if flag(dump-core) + build-depends: dump-core + ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html +library + import: + deps + exposed-modules: + -- core system + ADP.Fusion.Core + ADP.Fusion.Core.Apply + ADP.Fusion.Core.Classes + ADP.Fusion.Core.Multi + ADP.Fusion.Core.SynVar.Array + ADP.Fusion.Core.SynVar.Array.Type + ADP.Fusion.Core.SynVar.Axiom + ADP.Fusion.Core.SynVar.Backtrack + ADP.Fusion.Core.SynVar.Fill + ADP.Fusion.Core.SynVar.FillTyLvl + ADP.Fusion.Core.SynVar.Indices + ADP.Fusion.Core.SynVar.Recursive.Type + ADP.Fusion.Core.SynVar.Split.Type + ADP.Fusion.Core.SynVar.TableWrap + ADP.Fusion.Core.Term.Chr + ADP.Fusion.Core.Term.Deletion + ADP.Fusion.Core.Term.Edge + ADP.Fusion.Core.Term.Epsilon + ADP.Fusion.Core.Term.MultiChr + ADP.Fusion.Core.Term.PeekIndex + ADP.Fusion.Core.Term.Str + ADP.Fusion.Core.Term.Switch + ADP.Fusion.Core.Term.Test + ADP.Fusion.Core.TH + ADP.Fusion.Core.TH.Backtrack + ADP.Fusion.Core.TH.Common + ADP.Fusion.Core.TyLvlIx +-- -- Point L + ADP.Fusion.PointL + ADP.Fusion.PointL.Core + ADP.Fusion.PointL.SynVar.Indices +-- ADP.Fusion.PointL.SynVar.Recursive + ADP.Fusion.PointL.Term.Chr + ADP.Fusion.PointL.Term.Deletion + ADP.Fusion.PointL.Term.Epsilon + ADP.Fusion.PointL.Term.MultiChr + ADP.Fusion.PointL.Term.Str + ADP.Fusion.PointL.Term.Switch +-- ADP.Fusion.PointL.Term.Test +-- -- Point R + ADP.Fusion.PointR + ADP.Fusion.PointR.Core + ADP.Fusion.PointR.SynVar.Indices + ADP.Fusion.PointR.Term.Chr + ADP.Fusion.PointR.Term.Deletion + ADP.Fusion.PointR.Term.Epsilon + ADP.Fusion.PointR.Term.MultiChr + -- Unit + ADP.Fusion.Unit + ADP.Fusion.Unit.Core + ADP.Fusion.Unit.SynVar.Indices + ADP.Fusion.Unit.Term.Deletion + ADP.Fusion.Unit.Term.Epsilon +-- -- tutorials +-- ADP.Fusion.Tutorial.NeedlemanWunsch + + + test-suite properties + import: + deps type: exitcode-stdio-1.0 main-is: @@ -196,31 +239,12 @@ -threaded -rtsopts -with-rtsopts=-N hs-source-dirs: tests - default-language: - Haskell2010 - default-extensions: BangPatterns - , CPP - , FlexibleContexts - , FlexibleInstances - , MultiParamTypeClasses - , ScopedTypeVariables - , TemplateHaskell - , TypeFamilies - , TypeOperators - , TypeSynonymInstances cpp-options: -DADPFUSION_TEST_SUITE_PROPERTIES - build-depends: base - , ADPfusion - , bits - , OrderedBits - , PrimitiveArray - , QuickCheck - , strict + build-depends: ADPfusion , tasty >= 0.11 , tasty-quickcheck >= 0.8 , tasty-th >= 0.1 - , vector @@ -237,6 +261,7 @@ , PrimitiveArray , template-haskell , vector + , DPutils else buildable: False @@ -247,87 +272,123 @@ default-language: Haskell2010 default-extensions: BangPatterns + , DataKinds , FlexibleContexts , FlexibleInstances , MultiParamTypeClasses + , PartialTypeSignatures + , PolyKinds , RecordWildCards , TemplateHaskell + , TypeApplications , TypeFamilies , TypeOperators + , UnicodeSyntax ghc-options: -O2 -funbox-strict-fields - -funfolding-use-threshold1000 - -funfolding-keeness-factor1000 + -- these parameters do well enough with GHC 8.2 + -- for larger programs, we may have to increase the number of worker + -- arguments. + -flate-dmd-anal + -fspec-constr-count=20 + -fspec-constr-keen + -fspec-constr-recursive=20 + -fspec-constr-threshold=20 if flag(debugdump) ghc-options: -ddump-to-file -ddump-simpl -dsuppress-all + if flag(llvm) + ghc-options: + -fllvm + -optlo-O3 + if flag(dump-core) + build-depends: dump-core + ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html --- Very simple two-sequence alignment. - -executable spectest +executable SmithWaterman - if flag(spectest) + if flag(examples) buildable: True build-depends: base , ADPfusion + , primitive , PrimitiveArray , template-haskell , vector + , DPutils else buildable: False hs-source-dirs: src main-is: - SpecTest.hs + SmithWaterman.hs default-language: Haskell2010 default-extensions: BangPatterns + , DataKinds , FlexibleContexts , FlexibleInstances , MultiParamTypeClasses + , PartialTypeSignatures + , PolyKinds , RecordWildCards , TemplateHaskell + , TypeApplications , TypeFamilies , TypeOperators + , UnicodeSyntax ghc-options: -O2 -funbox-strict-fields - -funfolding-use-threshold1000 - -funfolding-keeness-factor1000 --- if flag(debug) --- ghc-options: --- -ddump-to-file --- -ddump-simpl --- -dsuppress-all + -- these parameters do well enough with GHC 8.2 + -- for larger programs, we may have to increase the number of worker + -- arguments. + -flate-dmd-anal + -fspec-constr-count=20 + -fspec-constr-keen + -fspec-constr-recursive=20 + -fspec-constr-threshold=20 + if flag(debugdump) + ghc-options: + -ddump-to-file + -ddump-simpl + -dsuppress-all + if flag(llvm) + ghc-options: + -fllvm + -optlo-O3 + if flag(dump-core) + build-depends: dump-core + ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html -benchmark TestBacktrackingStructures - type: - exitcode-stdio-1.0 +-- Very simple two-sequence alignment. - if flag(btstruc) +executable spectest + + if flag(spectest) buildable: True - build-depends: base - , template-haskell - , fmlist >= 0.9 - , vector - , criterion >= 1.1 + build-depends: base + , ADPfusion + , PrimitiveArray + , template-haskell + , vector else buildable: False hs-source-dirs: - tests + src main-is: - BacktrackingStructures.hs + SpecTest.hs default-language: Haskell2010 default-extensions: BangPatterns @@ -340,8 +401,10 @@ , TypeOperators ghc-options: -O2 + -funbox-strict-fields -funfolding-use-threshold1000 -funfolding-keeness-factor1000 + diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -26,7 +26,7 @@ [preprint](http://www.bioinf.uni-leipzig.de/Software/gADP/preprints/hoe-pro-2015.pdf) 1. Maik Riechert, Christian Höner zu Siederdissen, and Peter F. Stadler *Algebraic dynamic programming for multiple context-free languages* - 2015, submitted + 2016, Theoretical Computer Science [preprint](http://www.bioinf.uni-leipzig.de/Software/gADP/preprints/rie-hoe-2015.pdf) @@ -68,25 +68,7 @@ # Implementors Notes (if you want to extend ADPfusion) - -- The general inlining scheme is: (i) mkStream is {-# INLINE mkStream #-}, - inner functions like mk, step, worker functions, and index-modifying - functions get an {-# INLINE [0] funName #-}. Where there is no function to - annotate, use delay_inline. - -- If you implement a new kind of memoizing table, like the dense Table.Array - ones, you will have to implement mkStream code. When you hand to the left, - the (i,j) indices and modify their extend (by, say, having NonEmpty table - constaints), you have to delay_inline this (until inliner phase 0). Otherwise - you will break fusion for mkStream. - -- Terminals that capture both, say indexing functions, and data should have no - strictness annotations for the indexing function. This allows the code to be - duplicated, then inlined. This improves performance a lot, because otherwise - a function is created that performs these lookups, which has serious (50% - slower or so) performance implications. - - +These have been moved to [HACKING.md](https://github.com/choener/ADPfusion/blob/master/HACKING.md). #### Contact diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,17 @@ +0.6.0.0 +------- + +- major change as to how rule compilation proceeds (ctor spec -> type class instances) +- use new PrimitiveArray-0.9.0.0 +- backtrace from any given index using 'axiomAt' +- Epsilon is tagged @Global or @Local, to allow local-alignment style algorithms + +0.5.3.0 +------- + +- using unboxed Ints (primbool style) for rule guards. This nets a nice speedup + of 30-50% for linear languages + 0.5.2.2 ------- diff --git a/src/NeedlemanWunsch.hs b/src/NeedlemanWunsch.hs --- a/src/NeedlemanWunsch.hs +++ b/src/NeedlemanWunsch.hs @@ -1,4 +1,7 @@ +{-# Options_GHC -fforce-recomp #-} +{-# Options_GHC -Wno-partial-type-signatures #-} + -- | The Needleman-Wunsch global alignment algorithm. This algorithm is -- extremely simple but provides a good showcase for what ADPfusion offers. -- @@ -78,13 +81,15 @@ -- do this. The relative overhead for each cell to be written into goes -- down with more complex grammars and algebras. -module Main where +module Main (main) where -import Control.Monad (forM_) -import System.Environment (getArgs) -import Text.Printf +import Control.Monad (forM_,when) import Control.Monad.Primitive import Control.Monad.ST +import Data.Ord.Fast +import Debug.Trace +import System.Environment (getArgs) +import Text.Printf -- Streams of parses are the streams defined in the @vector@ package. @@ -94,6 +99,7 @@ -- terminal parses work with any vector in the @vector@ package. import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Storable as VS -- @Data.PrimitiveArray@ contains data structures, and index structures for -- dynamic programming. Notably, the primitive arrays holding the cell data @@ -108,10 +114,12 @@ -- provided in this package. @.Core@ exports only the core modules required -- to extend ADPfusion. -import ADP.Fusion.Point +import ADP.Fusion.PointL +import Data.Ord.Fast + -- | A signature connects the types of all non-terminals and terminals with -- evaluation (or attribute) functions. In the grammar below, we not only -- want to create all possible parses of how two strings can be aligned but @@ -134,11 +142,11 @@ -- capable, which is a really cool feature for advanced algorithms. data Signature m x r c = Signature - { step_step :: x -> (Z:.c :.c ) -> x - , step_loop :: x -> (Z:.c :.()) -> x - , loop_step :: x -> (Z:.():.c ) -> x - , nil_nil :: (Z:.():.()) -> x - , h :: Stream m x -> m r + { step_step ∷ x → (Z:.c :.c ) → x + , step_loop ∷ x → (Z:.c :.()) → x + , loop_step ∷ x → (Z:.():.c ) → x + , nil_nil ∷ (Z:.():.()) → x + , h ∷ Stream m x -> m r } -- | We also want to be able to backtrace the optimal result. Given our @@ -198,7 +206,7 @@ let a = TW a' ( step_step <<< a % (M:|chr i1:|chr i2) ||| step_loop <<< a % (M:|chr i1:|Deletion ) ||| loop_step <<< a % (M:|Deletion :|chr i2) ||| - nil_nil <<< (M:|Epsilon:|Epsilon) ... h + nil_nil <<< (M:|Epsilon @Global:|Epsilon @Global) ... h ) in Z:.a {-# INLINE grammar #-} @@ -217,13 +225,14 @@ -- @-999999@ and find the maximum of that score and the choices we are -- given. -sScore :: Monad m => Signature m Int Int Char +sScore ∷ Monad m ⇒ Signature m Int Int Char sScore = Signature - { step_step = \x (Z:.a:.b) -> if a==b then x+1 else x-2 - , step_loop = \x _ -> x-1 - , loop_step = \x _ -> x-1 + { step_step = \x (Z:.a:.b) → if a==b then x+7 else x-5 + , step_loop = \x _ → x-3 + , loop_step = \x _ → x-2 , nil_nil = const 0 - , h = SM.foldl' max (-999999) + , h = SM.foldl' fastmax (-999999) +-- , h = SM.foldl1' fastmax } {-# INLINE sScore #-} @@ -237,11 +246,11 @@ -- rather returns all alignments. You already heard about @<**@, we'll use -- it below. -sPretty :: Monad m => Signature m [String] [[String]] Char +sPretty ∷ Monad m ⇒ Signature m [String] [[String]] Char sPretty = Signature - { step_step = \[x,y] (Z:.a :.b ) -> [a :x, b :y] - , step_loop = \[x,y] (Z:.a :.()) -> [a :x, '-':y] - , loop_step = \[x,y] (Z:.():.b ) -> ['-':x, b :y] + { step_step = \[x,y] (Z:.a :.b ) → [a :x, b :y] + , step_loop = \[x,y] (Z:.a :.()) → [a :x, '-':y] + , loop_step = \[x,y] (Z:.():.b ) → ['-':x, b :y] , nil_nil = const ["",""] , h = SM.toList } @@ -252,13 +261,17 @@ -- backtrackings, given the inputs @i1@ and @i2@. The @fst@ element -- returned is the score, the @snd@ are the co-optimal parses. -runNeedlemanWunsch :: Int -> String -> String -> (Int,[[String]]) -runNeedlemanWunsch k i1' i2' = (d, take k bs) where +runNeedlemanWunsch + ∷ Int + → String + → String + → (Int,[[String]],PerfCounter) +runNeedlemanWunsch k i1' i2' = (d, take k bs,perf) where i1 = VU.fromList i1' i2 = VU.fromList i2' n1 = VU.length i1 n2 = VU.length i2 - !(Z:.t) = nwInsideForward i1 i2 + Mutated (Z:.t) perf eachPerf = nwInsideForward i1 i2 d = unId $ axiom t bs = nwInsideBacktrack i1 i2 t {-# Noinline runNeedlemanWunsch #-} @@ -273,19 +286,28 @@ -- For your own code, you can write as done here, or in the way of -- 'runOutsideNeedlemanWunsch'. -nwInsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.TwITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int -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 - where n1 = VU.length i1 - n2 = VU.length i2 +nwInsideForward + ∷ VU.Vector Char + → VU.Vector Char + → Mutated (Z:.TwITbl _ _ Id (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int) +nwInsideForward !i1 !i2 = {-# SCC "nwInsideForward" #-} runST $ do + arr ← newWithPA (ZZ:..LtPointL n1:..LtPointL n2) (-999999) + ts ← fillTables $ grammar sScore + (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk:.EmptyOk) arr) + i1 i2 + return ts + where !n1 = VU.length i1 + !n2 = VU.length i2 {-# NoInline nwInsideForward #-} -nwInsideBacktrack :: VU.Vector Char -> VU.Vector Char -> TwITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int -> [[String]] +nwInsideBacktrack + ∷ VU.Vector Char + → VU.Vector Char + → TwITbl _ _ Id (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int + → [[String]] nwInsideBacktrack i1 i2 t = {-# SCC "nwInsideBacktrack" #-} unId $ axiom b where !(Z:.b) = grammar (sScore <|| sPretty) (toBacktrack t (undefined :: Id a -> Id a)) i1 i2 - :: Z:.TwITblBt Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int Id Id [String] + :: Z:.TwITblBt _ _ (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int Id Id [String] {-# NoInline nwInsideBacktrack #-} -- | The outside version of the Needleman-Wunsch alignment algorithm. The @@ -293,28 +315,39 @@ -- generally the case, but here it is. Hence we may just use outside tables -- and the grammar from above. -runOutsideNeedlemanWunsch :: Int -> String -> String -> (Int,[[String]]) -runOutsideNeedlemanWunsch k i1' i2' = {-# SCC "runOutside" #-} (d, take k . unId $ axiom b) where +runOutsideNeedlemanWunsch + ∷ Int + → String + → String + → (Int,[[String]],PerfCounter) +runOutsideNeedlemanWunsch k i1' i2' = {-# SCC "runOutside" #-} (d, take k . unId $ axiom b, perf) where i1 = VU.fromList i1' i2 = VU.fromList i2' n1 = VU.length i1 n2 = VU.length i2 - !(Z:.t) = nwOutsideForward i1 i2 + Mutated (Z:.t) perf eachPerf = nwOutsideForward i1 i2 d = unId $ axiom t !(Z:.b) = grammar (sScore <|| sPretty) (toBacktrack t (undefined :: Id a -> Id a)) i1 i2 - :: Z:.TwITblBt Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL O:.PointL O) Int Id Id [String] + :: Z:.TwITblBt _ _ (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL O:.PointL O) Int Id Id [String] {-# Noinline runOutsideNeedlemanWunsch #-} -- | Again, to be able to observe performance, we have extracted the -- outside-table-filling part. +-- +-- The partial type signature is filled by GHC. -nwOutsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.TwITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL O:.PointL O) Int -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 - where n1 = VU.length i1 - n2 = VU.length i2 +nwOutsideForward + ∷ VU.Vector Char + → VU.Vector Char + → Mutated (Z:.TwITbl _ _ Id (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL O:.PointL O) Int) +nwOutsideForward !i1 !i2 = {-# SCC "nwOutsideForward" #-} runST $ do + arr ← newWithPA (ZZ:..LtPointL n1:..LtPointL n2) (-999999) + ts ← fillTables $ grammar sScore + (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk:.EmptyOk) arr) + i1 i2 + return ts + where !n1 = VU.length i1 + !n2 = VU.length i2 {-# Noinline nwOutsideForward #-} -- | This wrapper takes a list of input sequences and aligns each odd @@ -331,15 +364,19 @@ align _ [] = return () align _ [c] = putStrLn "single last line" -align k (a:b:xs) = {-# SCC "align" #-} do +align (kI,kO) (a:b:xs) = {-# SCC "align" #-} do putStrLn a putStrLn b + let (sI,rsI,perfI) = runNeedlemanWunsch kI a b + let (sO,rsO,perfO) = runOutsideNeedlemanWunsch kO a b + when (kI>=0) $ forM_ rsI $ \[u,l] -> printf "%s\n%s %d\n\n" (reverse u) (reverse l) sI + when (kO>=0) $ forM_ rsO $ \[u,l] -> printf "%s\n%s %d\n\n" (id u) (id l) sO + when (kI>=0) $ print sI + when (kO>=0) $ print sO + when (kI>=0) . putStrLn $ showPerfCounter perfI + when (kO>=0) . putStrLn $ showPerfCounter perfO putStrLn "" - let (sI,rsI) = runNeedlemanWunsch k a b - let (sO,rsO) = runOutsideNeedlemanWunsch k a b - forM_ rsI $ \[u,l] -> printf "%s\n%s %d\n\n" (reverse u) (reverse l) sI - forM_ rsO $ \[u,l] -> printf "%s\n%s %d\n\n" (id u) (id l) sO - align k xs + align (kI,kO) xs -- | And finally have a minimal main that reads from stdio. -- @@ -350,7 +387,13 @@ main = do as <- getArgs - let k = if null as then 1 else read $ head as + let k = case as of + [] -> (1,1) + [x] -> let x' = read x + in (x',x') + [x,y] -> let x' = read x; y' = read y + in (x',y') + args -> error $ "too many arguments" ls <- lines <$> getContents align k ls diff --git a/src/SmithWaterman.hs b/src/SmithWaterman.hs new file mode 100644 --- /dev/null +++ b/src/SmithWaterman.hs @@ -0,0 +1,194 @@ + +{-# Options_GHC -fforce-recomp #-} +{-# Options_GHC -Wno-partial-type-signatures #-} + +{-# Language MagicHash #-} + + +module Main (main) where + +import Control.Monad (forM_,when) +import Debug.Trace +import System.Environment (getArgs) +import Text.Printf +import Control.Monad.Primitive +import Control.Monad.ST +import Data.Foldable (maximumBy) +import Data.Ord (comparing) +import Data.Ord.Fast +import GHC.Exts + +import qualified Data.Vector.Fusion.Stream.Monadic as SM +import qualified Data.Vector.Unboxed as VU + +import Data.PrimitiveArray as PA hiding (map) + +import ADP.Fusion.PointL + + + +data Signature m x r c = Signature + { step_step ∷ x → (Z:.c :.c ) → x + , step_loop ∷ x → (Z:.c :.()) → x + , loop_step ∷ x → (Z:.():.c ) → x + , nil_nil ∷ (Z:.():.()) → x + , h ∷ Stream m x -> m r + } + +makeAlgebraProduct ''Signature + +grammar Signature{..} !a' !i1 !i2 = + let a = TW a' ( step_step <<< a % (M:|chr i1:|chr i2) ||| + step_loop <<< a % (M:|chr i1:|Deletion ) ||| + loop_step <<< a % (M:|Deletion :|chr i2) ||| + nil_nil <<< (M:|Epsilon @Local:|Epsilon @Local) ... h + ) + in Z:.a +{-# INLINE grammar #-} + +fasteq ∷ Char → Char → Int → Int → Int +{-# Inline fasteq #-} +fasteq (C# a) (C# b) (I# x) (I# y) = + let l = (eqChar# a b) + in I# ( (x *# l) +# (y *# (1# -# l)) ) + +sScore ∷ Monad m ⇒ Signature m Int Int Char +sScore = Signature + -- { step_step = \x (Z:.a:.b) → if a==b then x + 1 else x-2 + { step_step = \x (Z:.a:.b) → fasteq a b (x+1) (x-2) -- if a==b then x + 1 else x-2 + , step_loop = \x _ → x-1 + , loop_step = \x _ → x-1 + , nil_nil = const 0 + , h = SM.foldl' fastmax (-999999) + } +{-# INLINE sScore #-} + + +sPretty ∷ Monad m ⇒ Signature m [String] [[String]] Char +sPretty = Signature + { step_step = \[x,y] (Z:.a :.b ) → [a :x, b :y] + , step_loop = \[x,y] (Z:.a :.()) → [a :x, '-':y] + , loop_step = \[x,y] (Z:.():.b ) → ['-':x, b :y] + , nil_nil = const ["",""] + , h = SM.toList + } +{-# Inline sPretty #-} + + +runNeedlemanWunsch + ∷ Int + → String + → String + → ((Z:.PointL I:.PointL I),Int,[[String]],PerfCounter) +runNeedlemanWunsch k i1' i2' = (fst dlocal, snd dlocal, take k bs,perf) where + i1 = VU.fromList i1' + i2 = VU.fromList i2' + n1 = VU.length i1 + n2 = VU.length i2 + Mutated (Z:.t) perf eachPerf = nwInsideForward i1 i2 + dlocal = let TW (ITbl _ t') _ = t + in unId . SM.foldl' (\(ap,as) (p,s) → if s > as then (p,s) else (ap,as)) (Z:.PointL 0:.PointL 0,0) $ PA.assocsS t' + bs = nwInsideBacktrack i1 i2 t (fst dlocal) +{-# Noinline runNeedlemanWunsch #-} + + +nwInsideForward + ∷ VU.Vector Char + → VU.Vector Char + → Mutated (Z:.TwITbl _ _ Id (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int) +nwInsideForward !i1 !i2 = {-# SCC "nwInsideForward" #-} runST $ do + arr ← newWithPA (ZZ:..LtPointL n1:..LtPointL n2) (-999999) + ts ← fillTables $ grammar sScore + (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk:.EmptyOk) arr) + i1 i2 + return ts + where !n1 = VU.length i1 + !n2 = VU.length i2 +{-# NoInline nwInsideForward #-} + +nwInsideBacktrack + ∷ VU.Vector Char + → VU.Vector Char + → TwITbl _ _ Id (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int + → (Z:.PointL I:.PointL I) + → [[String]] +nwInsideBacktrack i1 i2 t k = {-# SCC "nwInsideBacktrack" #-} unId $ axiomAt b k + where !(Z:.b) = grammar (sScore <|| sPretty) (toBacktrack t (undefined :: Id a -> Id a)) i1 i2 + :: Z:.TwITblBt _ _ (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int Id Id [String] +{-# NoInline nwInsideBacktrack #-} + + +--runOutsideNeedlemanWunsch +-- ∷ Int +-- → String +-- → String +-- → (Int,[[String]],PerfCounter) +--runOutsideNeedlemanWunsch k i1' i2' = {-# SCC "runOutside" #-} (d, take k . unId $ axiom b, perf) where +-- i1 = VU.fromList i1' +-- i2 = VU.fromList i2' +-- n1 = VU.length i1 +-- n2 = VU.length i2 +-- Mutated (Z:.t) perf eachPerf = nwOutsideForward i1 i2 +-- d = unId $ axiom t +-- !(Z:.b) = grammar (sScore <|| sPretty) (toBacktrack t (undefined :: Id a -> Id a)) i1 i2 +-- :: Z:.TwITblBt _ _ (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL O:.PointL O) Int Id Id [String] +--{-# Noinline runOutsideNeedlemanWunsch #-} +-- +-- +--nwOutsideForward +-- ∷ VU.Vector Char +-- → VU.Vector Char +-- → Mutated (Z:.TwITbl _ _ Id (Dense VU.Vector) (Z:.EmptyOk:.EmptyOk) (Z:.PointL O:.PointL O) Int) +--nwOutsideForward !i1 !i2 = {-# SCC "nwOutsideForward" #-} runST $ do +-- arr ← newWithPA (ZZ:..LtPointL n1:..LtPointL n2) (-999999) +-- ts ← fillTables $ grammar sScore +-- (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk:.EmptyOk) arr) +-- i1 i2 +-- return ts +-- where !n1 = VU.length i1 +-- !n2 = VU.length i2 +--{-# Noinline nwOutsideForward #-} + +-- | This wrapper takes a list of input sequences and aligns each odd +-- sequence with the next even sequence. We want one alignment for each +-- such pair. +-- +-- Since we use basic lists during backtracking, the resulting lists have +-- to be reversed for inside-backtracking. Note that because the Outside +-- grammar is quasi-right-linear, it does not require reversing the two +-- strings. +-- +-- For real applications, consider using @Data.Sequence@ which has @O(1)@ +-- append and prepend. + +align _ [] = return () +align _ [c] = putStrLn "single last line" +align (kI,kO) (a:b:xs) = {-# SCC "align" #-} do + putStrLn a + putStrLn b + let (posI,sI,rsI,perfI) = runNeedlemanWunsch kI a b + when (kI>=0) $ forM_ rsI $ \[u,l] -> printf "%s\n%s\n %d %s\n\n" (reverse u) (reverse l) (sI) (show posI) + when (kI>=0) $ print sI + when (kI>=0) . putStrLn $ showPerfCounter perfI + putStrLn "" + align (kI,kO) xs + +-- | And finally have a minimal main that reads from stdio. +-- +-- If you are brave enough then put this through @ghc-core@ and look for +-- @nwInsideForward@ or @nwOutsideForward@ in the CORE. Everything coming +-- from the forward phase should be beautifully optimized and the algorithm +-- should run quite fast. + +main = do + as <- getArgs + let k = case as of + [] -> (1,1) + [x] -> let x' = read x + in (x',x') + [x,y] -> let x' = read x; y' = read y + in (x',y') + args -> error $ "too many arguments" + ls <- lines <$> getContents + align k ls + diff --git a/tests/BacktrackingStructures.hs b/tests/BacktrackingStructures.hs deleted file mode 100644 --- a/tests/BacktrackingStructures.hs +++ /dev/null @@ -1,76 +0,0 @@ - -{-# Language MagicHash #-} - -module Main where - -import Criterion.Main -import Data.Vector.Fusion.Stream.Monadic (Stream,foldl',mapM_) -import Data.Vector.Fusion.Util -import Data.Vector.Unboxed (Vector, fromList) -import GHC.Exts (inline, Int(..), (<=#) ) -import Prelude hiding (mapM_) -import System.IO.Unsafe -import qualified Data.FMList as F - - - -listLeft :: Int -> Int -listLeft k = sum $ go k [] - where go 0 xs = xs - go k xs = go (k-1) (k:xs) -{-# NoInline listLeft #-} - -listRight :: Int -> Int -listRight k = sum $ go k [] - where go 0 xs = xs - go k xs = go (k-1) (xs++[k]) -{-# NoInline listRight #-} - -listRightRev :: Int -> Int -listRightRev k = sum . reverse $ go k [] - where go 0 xs = xs - go k xs = go (k-1) (k:xs) -{-# NoInline listRightRev #-} - -listBoth :: Int -> Int -listBoth k = sum $ go (k `div` 2) [] - where go 0 xs = xs - go k xs = go (k-1) (k:xs++[k]) -{-# NoInline listBoth #-} - -fmLeft :: Int -> Int -fmLeft k = sum . F.toList $ go k F.empty - where go 0 xs = xs - go k xs = go (k-1) (k `F.cons` xs) -{-# NoInline fmLeft #-} - -fmRight :: Int -> Int -fmRight k = sum . F.toList $ go k F.empty - where go 0 xs = xs - go k xs = go (k-1) (xs `F.snoc` k) -{-# NoInline fmRight #-} - --- | - -benchWithK s k = - bgroup s - [ bench "listLeft" $ whnf listLeft k - , bench "listRight" $ whnf listRight k - , bench "listRightRev" $ whnf listRight k - , bench "listBoth" $ whnf listBoth k - , bench "fmLeft" $ whnf fmLeft k - , bench "fmRight" $ whnf fmRight k - ] -{-# Inline benchWithK #-} - --- | - -main :: IO () -main = do - defaultMain - [ benchWithK "10" 10 - , benchWithK "20" 20 - , benchWithK "100" 100 - , benchWithK "1000" 1000 - ] - diff --git a/tests/QuickCheck/Point.hs b/tests/QuickCheck/Point.hs --- a/tests/QuickCheck/Point.hs +++ b/tests/QuickCheck/Point.hs @@ -8,43 +8,44 @@ import Data.Strict.Tuple import Data.Vector.Fusion.Util import Debug.Trace +--import GHC.TypeNats import qualified Data.Vector.Fusion.Stream.Monadic as SM import qualified Data.Vector.Unboxed as VU import System.IO.Unsafe import Test.QuickCheck import Test.QuickCheck.All import Test.QuickCheck.Monadic -#ifdef ADPFUSION_TEST_SUITE_PROPERTIES +-- #ifdef ADPFUSION_TEST_SUITE_PROPERTIES import Test.Tasty.TH import Test.Tasty.QuickCheck -#endif +-- #endif import Data.PrimitiveArray -import ADP.Fusion.Point +import ADP.Fusion.PointL -- * Epsilon cases prop_I_Epsilon ix@(PointL j) = zs == ls where - zs = (id <<< Epsilon ... stoList) maxPLi ix + zs = (id <<< Epsilon @Global ... stoList) maxPLi ix ls = [ () | j == 0 ] prop_O_Epsilon ix@(PointL j) = zs == ls where - zs = (id <<< Epsilon ... stoList) maxPLo ix + zs = (id <<< Epsilon @Global ... stoList) maxPLo ix ls = [ () | j == maxI ] prop_I_ZEpsilon ix@(Z:.PointL j) = zs == ls where - zs = (id <<< (M:|Epsilon) ... stoList) (Z:.maxPLi) ix + zs = (id <<< (M:|Epsilon @Global) ... stoList) (ZZ:..maxPLi) ix ls = [ Z:.() | j == 0 ] prop_O_ZEpsilon ix@(Z:.PointL j) = zs == ls where - zs = (id <<< (M:|Epsilon) ... stoList) (Z:.maxPLo) ix + zs = (id <<< (M:|Epsilon @Global) ... stoList) (ZZ:..maxPLo) ix ls = [ Z:.() | j == maxI ] prop_O_ZEpsilonEpsilon ix@(Z:.PointL j:.PointL l) = zs == ls where - zs = (id <<< (M:|Epsilon:|Epsilon) ... stoList) (Z:.maxPLo:.maxPLo) ix + zs = (id <<< (M:|Epsilon @Global:|Epsilon @Global) ... stoList) (ZZ:..maxPLo:..maxPLo) ix ls = [ Z:.():.() | j == maxI, l == maxI ] @@ -67,21 +68,21 @@ {-# Noinline prop_O_ItNC #-} prop_O_ZItNC ix@(Z:.PointL j) = zs == ls where - zs = ((,,) <<< tZ1O % (M:|Deletion) % (M:|chr xs) ... stoList) (Z:.maxPLo) ix + zs = ((,,) <<< tZ1O % (M:|Deletion) % (M:|chr xs) ... stoList) (ZZ:..maxPLo) ix ls = [ ( unsafeIndex xsZPo (Z:.PointL (j+1)) , Z:.() , Z:.xs VU.! (j+0) ) | j >= 0, j <= (maxI-1) ] prop_O_2dimIt_NC_CN ix@(Z:.PointL j:.PointL l) = zs == ls where - zs = ((,,) <<< tZ2O % (M:|Deletion:|chr xs) % (M:|chr xs:|Deletion) ... stoList) (Z:.maxPLo:.maxPLo) ix + zs = ((,,) <<< tZ2O % (M:|Deletion:|chr xs) % (M:|chr xs:|Deletion) ... stoList) (ZZ:..maxPLo:..maxPLo) ix ls = [ ( unsafeIndex xsPPo (Z:.PointL (j+1):.PointL (l+1)) , Z:.() :.xs VU.! (l+0) , Z:.xs VU.! (j+0):.() ) | j>=0, l>=0, j<=(maxI-1), l<=(maxI-1) ] prop_I_2dimIt_NC_CN ix@(Z:.PointL j:.PointL l) = zs == ls where - zs = ((,,) <<< tZ2I % (M:|Deletion:|chr xs) % (M:|chr xs:|Deletion) ... stoList) (Z:.maxPLi:.maxPLi) ix + zs = ((,,) <<< tZ2I % (M:|Deletion:|chr xs) % (M:|chr xs:|Deletion) ... stoList) (ZZ:..maxPLi:..maxPLi) ix ls = [ ( unsafeIndex xsPP (Z:.PointL (j-1):.PointL (l-1)) , Z:.() :.xs VU.! (l-1) , Z:.xs VU.! (j-1):.() @@ -92,28 +93,32 @@ -- * terminal cases -- | A single character terminal +-- +-- X_j -> c_j || j==1 prop_I_Tt ix@(Z:.PointL j) = zs == ls where - zs = (id <<< (M:|chr xs) ... stoList) (Z:.maxPLi) ix + zs = (id <<< (M:|chr xs) ... stoList) (ZZ:..maxPLi) ix ls = [ (Z:.xs VU.! (j-1)) | 1==j ] ---prop_O_Tt ix@(Z:.O (PointL j)) = traceShow (j,zs,ls) $ zs == ls where --- zs = (id <<< (M:|chr xs) ... stoList) (Z:.O maxPLo) ix --- ls = [ (Z:.xs VU.! (j-1)) | 1==j ] +-- | +-- +-- X_j -> ε_{j-1} c_j ||| j==1 +-- E_{j-1} -> X_{j} c_j +-- E_j -> X_{j+1} c_{j+1} ||| j-1==max ?! +prop_O_Tt ix@(Z:.(PointL j)) + | zs == ls = True + | otherwise = traceShow (j,zs,ls) False + where + zs = (id <<< (M:|chr xs) ... stoList) (ZZ:..maxPLo) ix + ls = [ (Z:.xs VU.! j) | j==maxI-1 ] + -- | Two single-character terminals prop_I_CC ix@(Z:.PointL i) = zs == ls where - zs = ((,) <<< (M:|chr xs) % (M:|chr xs) ... stoList) (Z:.maxPLi) ix + zs = ((,) <<< (M:|chr xs) % (M:|chr xs) ... stoList) (ZZ:..maxPLi) ix ls = [ (Z:.xs VU.! (i-2), Z:.xs VU.! (i-1)) | 2==i ] -tSI = TW (ITbl 0 0 EmptyOk xsP) (\ (_ :: PointL I) (_ :: PointL I) -> Id (1::Int)) -tSO = TW (ITbl 0 0 EmptyOk xsPo) (\ (_ :: PointL O) (_ :: PointL O) -> Id (1::Int)) -tZ1I = TW (ITbl 0 0 (Z:.EmptyOk) xsZP) (\ (_::Z:.PointL I) (_::Z:.PointL I) -> Id (1::Int)) -tZ1O = TW (ITbl 0 0 (Z:.EmptyOk) xsZPo) (\ (_::Z:.PointL O) (_::Z:.PointL O) -> Id (1::Int)) -tZ2I = TW (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPP) (\ (_::Z:.PointL I:.PointL I) (_::Z:.PointL I:.PointL I) -> Id (1::Int)) -tZ2O = TW (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPPo) (\ (_::Z:.PointL O:.PointL O) (_::Z:.PointL O:.PointL O) -> Id (1::Int)) - -- | Just a table prop_I_It ix@(PointL j) = zs == ls where @@ -125,11 +130,15 @@ ls = [ unsafeIndex xsPo ix | j>=0, j<=maxI ] prop_I_ZIt ix@(Z:.PointL j) = zs == ls where - zs = (id <<< tZ1I ... stoList) (Z:.maxPLi) ix + zs = (id <<< tZ1I ... stoList) (ZZ:..maxPLi) ix ls = [ unsafeIndex xsZP ix | j>=0, j<=maxI ] +prop_I_2dimIt ix@(Z:.PointL i:.PointL j) = zs == ls where + zs = (id <<< tZ2I ... stoList) (ZZ:..maxPLi:..maxPLi) ix + ls = [ unsafeIndex xsPP ix | j>=0, j<=maxI ] + prop_O_ZIt ix@(Z:.PointL j) = zs == ls where - zs = (id <<< tZ1O ... stoList) (Z:.maxPLo) ix + zs = (id <<< tZ1O ... stoList) (ZZ:..maxPLo) ix ls = [ unsafeIndex xsZPo ix | j>=0, j<=maxI ] -- | Table, then single terminal @@ -142,11 +151,14 @@ -- | @A^*_j -> A^*_{j+1} c_{j+1)@ ! -prop_O_ItC ix@(PointL j) = zs == ls where - zs = ((,) <<< tSO % chr xs ... stoList) maxPLo ix - ls = [ ( unsafeIndex xsPo (PointL $ j+1) - , xs VU.! (j+0) - ) | j >= 0, j <= (maxI-1) ] +prop_O_ItC ix@(PointL j) + | zs == ls = True + | otherwise = traceShow (j,zs,ls) False + where + zs = ((,) <<< tSO % chr xs ... stoList) maxPLo ix + ls = [ ( unsafeIndex xsPo (PointL $ j+1) + , xs VU.! (j+0) -- j-1 in inside, here moved one right! + ) | j >= 0, j <= (maxI-1) ] prop_O_ItCC ix@(PointL j) = zs == ls where zs = ((,,) <<< tSO % chr xs % chr xs ... stoList) maxPLo ix @@ -164,7 +176,7 @@ ) | j >= 0, j <= (maxI-3) ] prop_O_ZItCC ix@(Z:.PointL j) = zs == ls where - zs = ((,,) <<< tZ1O % (M:|chr xs) % (M:|chr xs) ... stoList) (Z:.maxPLo) ix + zs = ((,,) <<< tZ1O % (M:|chr xs) % (M:|chr xs) ... stoList) (ZZ:..maxPLo) ix ls = [ ( unsafeIndex xsZPo (Z:.PointL (j+2)) , Z:.xs VU.! (j+0) , Z:.xs VU.! (j+1) @@ -173,14 +185,14 @@ -- | synvar followed by a 2-tape character terminal prop_I_2dimItCC ix@(Z:.PointL j:.PointL l) = zs == ls where - zs = ((,,) <<< tZ2I % (M:|chr xs:|chr xs) % (M:|chr xs:|chr xs) ... stoList) (Z:.maxPLi:.maxPLi) ix + zs = ((,,) <<< tZ2I % (M:|chr xs:|chr xs) % (M:|chr xs:|chr xs) ... stoList) (ZZ:..maxPLi:..maxPLi) ix ls = [ ( unsafeIndex xsPP (Z:.PointL (j-2):.PointL (l-2)) , Z:.xs VU.! (j-2):.xs VU.! (l-2) , Z:.xs VU.! (j-1):.xs VU.! (l-1) ) | j>=2, l>=2, j<=maxI, l<=maxI ] prop_O_2dimItCC ix@(Z:.PointL j:.PointL l) = zs == ls where - zs = ((,,) <<< tZ2O % (M:|chr xs:|chr xs) % (M:|chr xs:|chr xs) ... stoList) (Z:.maxPLo:.maxPLo) ix + zs = ((,,) <<< tZ2O % (M:|chr xs:|chr xs) % (M:|chr xs:|chr xs) ... stoList) (ZZ:..maxPLo:..maxPLo) ix ls = [ ( unsafeIndex xsPPo (Z:.PointL (j+2):.PointL (l+2)) , Z:.xs VU.! (j+0):.xs VU.! (l+0) , Z:.xs VU.! (j+1):.xs VU.! (l+1) @@ -190,84 +202,112 @@ -- ** Just the 'Strng' terminal -prop_I_ManyS ix@(PointL j) = zs == ls where - zs = (id <<< manyS xs ... stoList) maxPLi ix +prop_I_ManyV ix@(PointL j) = zs == ls where + zs = (id <<< manyV xs ... stoList) maxPLi ix ls = [ (VU.slice 0 j xs) ] -prop_I_SomeS ix@(PointL j) = zs == ls where - zs = (id <<< someS xs ... stoList) maxPLi ix +prop_I_SomeV ix@(PointL j) + | zs == ls = True + | otherwise = traceShow (ix,zs,ls) False + where + zs = (id <<< someV xs ... stoList) maxPLi ix ls = [ (VU.slice 0 j xs) | j>0 ] -prop_2dim_ManyS_ManyS ix@(Z:.PointL i:.PointL j) = zs == ls where - zs = (id <<< (M:|manyS xs:|manyS xs) ... stoList) (Z:.maxPLi:.maxPLi) ix +prop_2dim_ManyV_ManyV ix@(Z:.PointL i:.PointL j) = zs == ls where + zs = (id <<< (M:|manyV xs:|manyV xs) ... stoList) (ZZ:..maxPLi:..maxPLi) ix ls = [ (Z:.VU.slice 0 i xs:.VU.slice 0 j xs) ] -prop_2dim_SomeS_SomeS ix@(Z:.PointL i:.PointL j) = zs == ls where - zs = (id <<< (M:|someS xs:|someS xs) ... stoList) (Z:.maxPLi:.maxPLi) ix +prop_2dim_SomeV_SomeV ix@(Z:.PointL i:.PointL j) = zs == ls where + zs = (id <<< (M:|someV xs:|someV xs) ... stoList) (ZZ:..maxPLi:..maxPLi) ix ls = [ (Z:.VU.slice 0 i xs:.VU.slice 0 j xs) | i > 0 && j > 0 ] -- ** Together with a syntactic variable. -prop_I_Itbl_ManyS ix@(PointL i) = zs == ls where - zs = ((,) <<< tSI % manyS xs ... stoList) maxPLi ix +prop_I_Itbl_ManyV ix@(PointL i) = zs == ls where + zs = ((,) <<< tSI % manyV xs ... stoList) maxPLi ix ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i] ] -prop_I_Itbl_SomeS ix@(PointL i) = zs == ls where - zs = ((,) <<< tSI % someS xs ... stoList) maxPLi ix +prop_I_Itbl_SomeV ix@(PointL i) = zs == ls where + zs = ((,) <<< tSI % someV xs ... stoList) maxPLi ix ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i-1] ] -prop_I_1dim_Itbl_ManyS ix@(Z:.PointL i) = zs == ls where - zs = ((,) <<< tZ1I % (M:|manyS xs) ... stoList) (Z:.maxPLi) ix +-- | NOTE Be aware of the needed match between the type-level and value-level +-- @13@s. + +prop_I_Itbl_Str ix@(PointL i) = zs == ls where + zs = ((,) <<< tSI % Str @_ @_ @Nothing @13 @Nothing xs ... stoList) maxPLi ix + ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i-13] ] + +-- | And now for some funny type-level shenanigans. + +prop_I_Itbl_StrTyLvl (Positive bound', ix@(PointL i)) = let bound = bound' `mod` 23 in + case (someNatVal bound) of + Nothing → error "zzz" + Just (SomeNat (Proxy ∷ Proxy b)) → + let zs = ((,) <<< tSI % Str @_ @_ @Nothing @b @Nothing xs ... stoList) maxPLi ix + ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i-bv] ] + bv = fromIntegral $ natVal (Proxy ∷ Proxy b) + in zs == ls + +prop_I_1dim_Itbl_ManyV ix@(Z:.PointL i) = zs == ls where + zs = ((,) <<< tZ1I % (M:|manyV xs) ... stoList) (ZZ:..maxPLi) ix ls = [ (unsafeIndex xsZP (Z:.PointL k), Z:. VU.slice k (i-k) xs) | k <- [0..i] ] -prop_I_1dim_Itbl_SomeS ix@(Z:.PointL i) = zs == ls where - zs = ((,) <<< tZ1I % (M:|someS xs) ... stoList) (Z:.maxPLi) ix +prop_I_1dim_Itbl_SomeV ix@(Z:.PointL i) = zs == ls where + zs = ((,) <<< tZ1I % (M:|someV xs) ... stoList) (ZZ:..maxPLi) ix ls = [ (unsafeIndex xsZP (Z:.PointL k), Z:. VU.slice k (i-k) xs) | k <- [0..i-1] ] -prop_I_2dim_Itbl_ManyS_ManyS ix@(Z:.PointL i:.PointL j) = zs == ls where - zs = ((,) <<< tZ2I % (M:|manyS xs:|manyS xs) ... stoList) (Z:.maxPLi:.maxPLi) ix +prop_I_2dim_Itbl_ManyV_ManyV ix@(Z:.PointL i:.PointL j) = zs == ls where + zs = ((,) <<< tZ2I % (M:|manyV xs:|manyV xs) ... stoList) (ZZ:..maxPLi:..maxPLi) ix ls = [ (unsafeIndex xsPP (Z:.PointL k:.PointL l), Z:. VU.slice k (i-k) xs :. VU.slice l (j-l) xs) | k <- [0..i], l <- [0..j] ] -prop_I_2dim_Itbl_SomeS_SomeS ix@(Z:.PointL i:.PointL j) = zs == ls where - zs = ((,) <<< tZ2I % (M:|someS xs:|someS xs) ... stoList) (Z:.maxPLi:.maxPLi) ix +prop_I_2dim_Itbl_SomeV_SomeV ix@(Z:.PointL i:.PointL j) = zs == ls where + zs = ((,) <<< tZ2I % (M:|someV xs:|someV xs) ... stoList) (ZZ:..maxPLi:..maxPLi) ix ls = [ (unsafeIndex xsPP (Z:.PointL k:.PointL l), Z:. VU.slice k (i-k) xs :. VU.slice l (j-l) xs) | k <- [0..i-1], l <- [0..j-1] ] stoList = unId . SM.toList -infixl 8 >>> -(>>>) f xs = \lu ij -> SM.map f . mkStream (build xs) (initialContext ij) lu $ ij +--infixl 8 >>> +--(>>>) f xs = \lu ij -> SM.map f . mkStream (build xs) (initialContext ij) lu $ ij +tSI = TW (ITbl @_ @_ @_ @_ @0 @0 EmptyOk xsP) (\ (_ :: LimitType (PointL I)) (_ :: PointL I) -> Id (1::Int)) +tSO = TW (ITbl @_ @_ @_ @_ @0 @0 EmptyOk xsPo) (\ (_ :: LimitType (PointL O)) (_ :: PointL O) -> Id (1::Int)) +tZ1I = TW (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk) xsZP) (\ (_::LimitType (Z:.PointL I)) (_::Z:.PointL I) -> Id (1::Int)) +tZ1O = TW (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk) xsZPo) (\ (_::LimitType (Z:.PointL O)) (_::Z:.PointL O) -> Id (1::Int)) +tZ2I = TW (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk:.EmptyOk) xsPP) (\ (_::LimitType (Z:.PointL I:.PointL I)) (_::Z:.PointL I:.PointL I) -> Id (1::Int)) +tZ2O = TW (ITbl @_ @_ @_ @_ @0 @0 (Z:.EmptyOk:.EmptyOk) xsPPo) (\ (_::LimitType (Z:.PointL O:.PointL O)) (_::Z:.PointL O:.PointL O) -> Id (1::Int)) + xsP :: Unboxed (PointL I) Int -xsP = fromList (PointL 0) maxPLi [0 ..] +xsP = fromList maxPLi [0 ..] xsZP :: Unboxed (Z:.PointL I) Int -xsZP = fromList (Z:.PointL 0) (Z:.maxPLi) [0 ..] +xsZP = fromList (ZZ:..maxPLi) [0 ..] xsPo :: Unboxed (PointL O) Int -xsPo = fromList (PointL 0) maxPLo [0 ..] +xsPo = fromList maxPLo [0 ..] xsZPo :: Unboxed (Z:.PointL O) Int -xsZPo = fromList (Z:.PointL 0) (Z:.maxPLo) [0 ..] +xsZPo = fromList (ZZ:..maxPLo) [0 ..] xsPP :: Unboxed (Z:.PointL I:.PointL I) Int -xsPP = fromList (Z:.PointL 0:.PointL 0) (Z:.maxPLi:.maxPLi) [0 ..] +xsPP = fromList (ZZ:..maxPLi:..maxPLi) [0 ..] xsPPo :: Unboxed (Z:.PointL O:.PointL O) Int -xsPPo = fromList (Z:.PointL 0:.PointL 0) (Z:.maxPLo:.maxPLo) [0 ..] +xsPPo = fromList (ZZ:..maxPLo:..maxPLo) [0 ..] mxsPP = unsafePerformIO $ zzz where zzz :: IO (MutArr IO (Unboxed (Z:.PointL I:.PointL I) Int)) - zzz = fromListM (Z:.PointL 0:.PointL 0) (Z:.maxPLi:.maxPLi) [0 ..] + zzz = fromListM (ZZ:..maxPLi:..maxPLi) [0 ..] maxI =100 -maxPLi :: PointL I -maxPLi = PointL maxI +maxPLi :: LimitType (PointL I) +maxPLi = LtPointL maxI -maxPLo :: PointL O -maxPLo = PointL maxI +maxPLo :: LimitType (PointL O) +maxPLo = LtPointL maxI xs = VU.fromList [0 .. maxI - 1 :: Int] @@ -282,7 +322,7 @@ -#ifdef ADPFUSION_TEST_SUITE_PROPERTIES +-- #ifdef ADPFUSION_TEST_SUITE_PROPERTIES testgroup_point = $(testGroupGenerator) -#endif +-- #endif