module ADP.Fusion.SynVar.Fill where
import Control.Monad.Morph (hoist, MFunctor (..))
import Control.Monad.Primitive (PrimMonad (..))
import Control.Monad.ST
import Control.Monad.Trans.Class (lift, MonadTrans (..))
import Data.Vector.Fusion.Util (Id(..))
import GHC.Exts (inline)
import qualified Data.Vector.Fusion.Stream.Monadic as SM
import System.IO.Unsafe
import Control.Monad (when,forM_)
import Data.List (nub,sort)
import qualified Data.Vector.Unboxed as VU
import Data.Proxy
import Data.PrimitiveArray
import ADP.Fusion.SynVar.Array
import Debug.Trace
runFreezeMTbls ts = do
unsafeRunFillTables $ expose ts
freezeTables $ onlyTables ts
class ExposeTables t where
type TableFun t :: *
type OnlyTables t :: *
expose :: t -> TableFun t
onlyTables :: t -> OnlyTables t
instance ExposeTables Z where
type TableFun Z = Z
type OnlyTables Z = Z
expose Z = Z
onlyTables Z = Z
data CFG
data MonotoneMCFG
class MutateCell (h :: *) (s :: *) (im :: * -> *) (om :: * -> *) i where
mutateCell :: Proxy h -> Int -> Int -> (forall a . im a -> om a) -> s -> i -> i -> om ()
class MutateTables (h :: *) (s :: *) (im :: * -> *) (om :: * -> *) where
mutateTables :: Proxy h -> (forall a . im a -> om a) -> s -> om s
class TableOrder (s :: *) where
tableLittleOrder :: s -> [Int]
tableBigOrder :: s -> [Int]
instance TableOrder Z where
tableLittleOrder Z = []
tableBigOrder Z = []
instance (TableOrder ts) => TableOrder (ts:.ITbl im arr i x) where
tableLittleOrder (ts:.ITbl _ tlo _ _ _) = tlo : tableLittleOrder ts
tableBigOrder (ts:.ITbl tbo _ _ _ _) = tbo : tableBigOrder ts
instance
( PrimArrayOps arr i x
, MPrimArrayOps arr i x
, MutateCell CFG ts im om i
, PrimMonad om
, Show x, Show i
) => MutateCell CFG (ts:.ITbl im arr i x) im om i where
mutateCell h bo lo mrph (ts:.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
type ZS2 = Z:.Subword:.Subword
instance
( PrimArrayOps arr ZS2 x
, MPrimArrayOps arr ZS2 x
, MutateCell MonotoneMCFG ts im om ZS2
, PrimMonad om
) => MutateCell MonotoneMCFG (ts:.ITbl im arr ZS2 x) im om ZS2 where
mutateCell h bo lo mrph (ts:.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
instance
( PrimArrayOps arr Subword x
, MPrimArrayOps arr Subword x
, MutateCell h ts im om (Z:.Subword:.Subword)
, PrimMonad om
) => MutateCell h (ts:.ITbl im arr Subword x) im om (Z:.Subword:.Subword) where
mutateCell h bo lo mrph (ts:.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
instance
( Monad om
, MutateCell h (ts:.ITbl im arr i x) im om i
, PrimArrayOps arr i x
, Show i
, IndexStream i
, TableOrder (ts:.ITbl im arr i x)
) => MutateTables h (ts:.ITbl im arr i x) im om where
mutateTables h mrph tt@(_:.ITbl _ _ _ arr _) = do
let (from,to) = bounds arr
let !tbos = VU.fromList . nub . sort $ tableBigOrder tt
let !tlos = VU.fromList . nub . sort $ tableLittleOrder tt
VU.forM_ tbos $ \bo ->
flip SM.mapM_ (streamUp from to) $ \k ->
VU.forM_ tlos $ \lo ->
mutateCell h bo lo (inline mrph) tt to k
return tt
instance
( Monad om
) => MutateCell p Z im om i where
mutateCell _ _ _ _ Z _ _ = return ()
mutateTablesDefault :: MutateTables CFG t Id IO => t -> t
mutateTablesDefault t = unsafePerformIO $ mutateTables (Proxy :: Proxy CFG) (return . unId) t
mutateTablesWithHints :: MutateTables h t Id IO => Proxy h -> t -> t
mutateTablesWithHints h t = unsafePerformIO $ mutateTables h (return . unId) t