{-# Language MagicHash #-}
module ADP.Fusion.Core.Multi where
import qualified Data.Vector.Fusion.Stream.Monadic as S
import Data.Vector.Fusion.Stream.Monadic
import Data.Strict.Tuple
import Data.Proxy
import Prelude hiding (map)
import GHC.Exts
import Debug.Trace
import Data.PrimitiveArray.Index.Class hiding (map)
import ADP.Fusion.Core.Classes
import ADP.Fusion.Core.TyLvlIx
data M = M
deriving (Eq,Show)
infixl 2 :|
data TermSymbol a b = a :| b
deriving (Eq,Show)
instance Build (TermSymbol a b)
type family TermArg x :: *
type instance TermArg M = Z
type instance TermArg (TermSymbol a b) = (TermArg a) :. (TermArg b)
instance (Element ls i) => Element (ls :!: TermSymbol a b) i where
data Elm (ls :!: TermSymbol a b) i = ElmTS !(TermArg (TermSymbol a b)) !(RunningIndex i) !(Elm ls i)
type Arg (ls :!: TermSymbol a b) = Arg ls :. TermArg (TermSymbol a b)
getArg (ElmTS a _ ls) = getArg ls :. a
getIdx (ElmTS _ i _ ) = i
{-# INLINE getArg #-}
{-# INLINE getIdx #-}
deriving instance (Show i, Show (RunningIndex i), Show (TermArg (TermSymbol a b)), Show (Elm ls i)) => Show (Elm (ls :!: TermSymbol a b) i)
type instance LeftPosTy (ps :. p) (TermSymbol a b) (is:.i) = (LeftPosTy ps a is) :. (LeftPosTy p b i)
instance
( Monad m
, MkStream m posLeft ls i
, Element ls i
, TermStaticVar pos (TermSymbol a b) i
, TermStream m pos (TermSymbol a b) (Elm ls i) i
, posLeft ~ LeftPosTy pos (TermSymbol a b) i
) => MkStream m pos (ls :!: TermSymbol a b) i where
mkStream Proxy (ls :!: ts) grd lu i
= map (\(TState sS ii ee) -> ElmTS ee ii sS)
. termStream (Proxy ∷ Proxy pos) ts lu i
. map (\s -> TState s RiZ Z)
$ mkStream (Proxy ∷ Proxy posLeft)
ls
(termStaticCheck (Proxy ∷ Proxy pos) ts lu i grd)
lu (termStreamIndex (Proxy ∷ Proxy pos) ts i)
{-# Inline mkStream #-}
type instance LeftPosTy Z M Z = Z
instance Monad m => MkStream m Z S Z where
mkStream Proxy S grd ZZ Z = staticCheck# grd $ S.singleton $ ElmS RiZ
{-# Inline mkStream #-}
class TermStaticVar pos sym ix where
termStreamIndex ∷ Proxy pos → sym → ix → ix
termStaticCheck ∷ Proxy pos → sym → LimitType ix → ix → Int# → Int#
instance TermStaticVar pos M Z where
termStreamIndex Proxy M Z = Z
termStaticCheck Proxy M _ Z grd = grd
{-# INLINE [0] termStreamIndex #-}
{-# INLINE [0] termStaticCheck #-}
instance
( TermStaticVar ps ts is
, TermStaticVar p t i
) => TermStaticVar (ps:.p) (TermSymbol ts t) (is:.i) where
termStreamIndex Proxy (ts:|t) (is:.i) = termStreamIndex (Proxy ∷ Proxy ps) ts is :. termStreamIndex (Proxy ∷ Proxy p) t i
termStaticCheck Proxy (ts:|t) (us:..u) (is:.i) grd = termStaticCheck (Proxy ∷ Proxy ps) ts us is (termStaticCheck (Proxy ∷ Proxy p) t u i grd)
{-# INLINE [0] termStreamIndex #-}
{-# INLINE [0] termStaticCheck #-}
type instance InitialContext Z = Z
type instance InitialContext (is:.i) = InitialContext is:.InitialContext i
class TableStaticVar pos minSize tableIx ix where
tableStreamIndex
∷ Proxy pos
→ minSize
→ LimitType tableIx
→ ix
→ ix
instance TableStaticVar pos Z tableIx Z where
tableStreamIndex Proxy Z _ Z = Z
{-# INLINE [0] tableStreamIndex #-}
instance
( TableStaticVar ps cs us is
, TableStaticVar p c u i
)
⇒ TableStaticVar (ps:.p) (cs:.c) (us:.u) (is:.i) where
tableStreamIndex Proxy (cs:.c) (us:..u) (is:.i)
= tableStreamIndex (Proxy ∷ Proxy ps) cs us is
:. tableStreamIndex (Proxy ∷ Proxy p ) c u i
{-# INLINE [0] tableStreamIndex #-}
data TermState s i e = TState
{ tS :: !s
, iIx :: !(RunningIndex i)
, eTS :: !e
}
class TermStream m pos t s i where
termStream
∷ Proxy pos
→ t
→ LimitType i
→ i
→ Stream m (TermState s Z Z)
→ Stream m (TermState s i (TermArg t))
instance (Monad m) => TermStream m pos M s Z where
termStream Proxy M ZZ Z = id
{-# Inline termStream #-}
addTermStream1
∷ forall m pos t s i
. ( Monad m
, TermStream m (Z:.pos) (TermSymbol M t) (Elm (Term1 s) (Z:.i)) (Z:.i)
)
⇒ Proxy pos
→ t
→ LimitType i
→ i
→ Stream m s
→ Stream m (s,TermArg t,RunningIndex i)
addTermStream1 Proxy t u i
= map (\(TState (ElmTerm1 sS) (RiZ:.:ii) (Z:.ee)) -> (sS,ee,ii))
. termStream (Proxy ∷ Proxy (Z:.pos)) (M:|t) (ZZ:..u) (Z:.i)
. map (\s -> TState (elmTerm1 s i) RiZ Z)
{-# Inline addTermStream1 #-}
newtype Term1 s = Term1 s
elmTerm1 :: s -> i -> Elm (Term1 s) (Z:.i)
elmTerm1 s _ = ElmTerm1 s
{-# Inline elmTerm1 #-}
instance (s ~ Elm x0 i, Element x0 i) => Element (Term1 s) (Z:.i) where
newtype Elm (Term1 s) (Z:.i) = ElmTerm1 s
getIdx (ElmTerm1 s) = RiZ :.: getIdx s
{-# Inline getIdx #-}
type TermStreamContext m (pos ∷ k) ts s x0 sixty is i
= ( Monad m
, TermStream m pos ts s is
, GetIndex (RunningIndex sixty) (RunningIndex (is:.i))
, GetIx (RunningIndex sixty) (RunningIndex (is:.i)) ~ (RunningIndex i)
, Element x0 sixty
, s ~ Elm x0 sixty
)
type PRI is i = Proxy (RunningIndex (is:.i))