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 ADP.Fusion.SynVar.Recursive.Type
import ADP.Fusion.SynVar.TableWrap
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:.TwITbl im arr c i x) where
tableLittleOrder (ts:.TW (ITbl _ tlo _ _) _) = tlo : tableLittleOrder ts
tableBigOrder (ts:.TW (ITbl tbo _ _ _) _) = tbo : tableBigOrder ts
instance (TableOrder ts) => TableOrder (ts:.TwIRec im c i x) where
tableLittleOrder (ts:._) = tableLittleOrder ts
tableBigOrder (ts:._) = tableBigOrder ts
instance
( Monad om
) => MutateCell p Z im om i where
mutateCell _ _ _ _ Z _ _ = return ()
instance
( MutateCell CFG ts im om i
, PrimMonad om
) => MutateCell CFG (ts:.TwIRec im c i x) im om i where
mutateCell h bo lo mrph (ts:._) lu i = do
mutateCell h bo lo mrph ts lu i
instance
( PrimArrayOps arr i x
, MPrimArrayOps arr i x
, MutateCell CFG ts im om i
, PrimMonad om
) => MutateCell CFG (ts:.TwITbl im arr c i x) im om i where
mutateCell 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
type ZS2 = Z:.Subword I:.Subword I
instance
( PrimArrayOps arr ZS2 x
, MPrimArrayOps arr ZS2 x
, MutateCell MonotoneMCFG ts im om ZS2
, PrimMonad om
) => MutateCell MonotoneMCFG (ts:.TwITbl im arr c ZS2 x) im om ZS2 where
mutateCell 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
instance
( PrimArrayOps arr (Subword I) x
, MPrimArrayOps arr (Subword I) x
, MutateCell h ts im om (Z:.Subword I:.Subword I)
, PrimMonad om
) => MutateCell h (ts:.TwITbl im arr c (Subword I) x) im om (Z:.Subword I:.Subword I) where
mutateCell h 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
instance
( Monad om
, MutateCell h (ts:.TwITbl im arr c i x) im om i
, PrimArrayOps arr i x
, Show i
, IndexStream i
, TableOrder (ts:.TwITbl im arr c i x)
) => MutateTables h (ts:.TwITbl im arr c i x) im om where
mutateTables h mrph tt@(_:.TW (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 ->
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
_ -> flip SM.mapM_ (streamUp from to) $ \k ->
VU.forM_ tlos $ \lo ->
mutateCell h bo lo (inline mrph) tt to k
return tt
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