{-# LANGUAGE RankNTypes #-} module RetroClash.CPU where import Clash.Prelude import RetroClash.Utils import RetroClash.Barbies import Data.Functor.Identity import Control.Monad.Writer import Control.Monad.State import Control.Lens (Setter', scribe, iso) import Barbies import Barbies.Bare infix 4 .:= (.:=) :: (Applicative f, MonadWriter (Barbie b f) m) => Setter' (b f) (f a) -> a -> m () Setter' (b f) (f a) fd .:= :: Setter' (b f) (f a) -> a -> m () .:= a x = ASetter (Barbie b f) (Barbie b f) (f a) (f a) -> f a -> m () forall t (m :: Type -> Type) s a b. (MonadWriter t m, Monoid s) => ASetter s t a b -> b -> m () scribe ((Barbie b f -> b f) -> (b f -> Barbie b f) -> Iso (Barbie b f) (Barbie b f) (b f) (b f) forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b iso Barbie b f -> b f forall k (b :: (k -> Type) -> Type) (f :: k -> Type). Barbie b f -> b f getBarbie b f -> Barbie b f forall k (b :: (k -> Type) -> Type) (f :: k -> Type). b f -> Barbie b f Barbie ((b f -> Identity (b f)) -> Barbie b f -> Identity (Barbie b f)) -> ((f a -> Identity (f a)) -> b f -> Identity (b f)) -> ASetter (Barbie b f) (Barbie b f) (f a) (f a) forall b c a. (b -> c) -> (a -> b) -> a -> c . (f a -> Identity (f a)) -> b f -> Identity (b f) Setter' (b f) (f a) fd) (a -> f a forall (f :: Type -> Type) a. Applicative f => a -> f a pure a x) assignOut :: (Applicative f, MonadWriter (Barbie b f) m) => Setter' (b f) (f a) -> a -> m () assignOut :: Setter' (b f) (f a) -> a -> m () assignOut Setter' (b f) (f a) fd a x = Setter' (b f) (f a) fd Setter' (b f) (f a) -> a -> m () forall (f :: Type -> Type) (b :: (Type -> Type) -> Type) (m :: Type -> Type) a. (Applicative f, MonadWriter (Barbie b f) m) => Setter' (b f) (f a) -> a -> m () .:= a x update :: (BareB b, ApplicativeB (b Covered)) => Pure b -> Partial b -> Pure b update :: Pure b -> Partial b -> Pure b update Pure b initials Partial b edits = b Covered Identity -> Pure b forall (b :: Type -> (Type -> Type) -> Type). BareB b => b Covered Identity -> b Bare Identity bstrip (b Covered Identity -> Pure b) -> b Covered Identity -> Pure b forall a b. (a -> b) -> a -> b $ (forall a. Identity a -> Last a -> Identity a) -> b Covered Identity -> b Covered Last -> b Covered Identity forall k (b :: (k -> Type) -> Type) (f :: k -> Type) (g :: k -> Type) (h :: k -> Type). ApplicativeB b => (forall (a :: k). f a -> g a -> h a) -> b f -> b g -> b h bzipWith forall a. Identity a -> Last a -> Identity a update1 (Pure b -> b Covered Identity forall (b :: Type -> (Type -> Type) -> Type). BareB b => b Bare Identity -> b Covered Identity bcover Pure b initials) (Partial b -> b Covered Last forall k (b :: (k -> Type) -> Type) (f :: k -> Type). Barbie b f -> b f getBarbie Partial b edits) where update1 :: Identity a -> Last a -> Identity a update1 :: Identity a -> Last a -> Identity a update1 Identity a initial Last a edit = Identity a -> (a -> Identity a) -> Maybe a -> Identity a forall b a. b -> (a -> b) -> Maybe a -> b maybe Identity a initial a -> Identity a forall a. a -> Identity a Identity (Last a -> Maybe a forall a. Last a -> Maybe a getLast Last a edit) type CPUM s o = WriterT (Barbie (o Covered) Last) (State s) mealyCPU :: (BareB i, TraversableB (i Covered)) => (NFDataX s) => (BareB o, ApplicativeB (o Covered), DistributiveB (o Covered)) => (HiddenClockResetEnable dom) => s -> (s -> Pure o) -> (Pure i -> CPUM s o ()) -> Signals dom i -> Signals dom o mealyCPU :: s -> (s -> Pure o) -> (Pure i -> CPUM s o ()) -> Signals dom i -> Signals dom o mealyCPU s initState s -> Pure o defaultOutput Pure i -> CPUM s o () step = Signal dom (Pure o) -> Signals dom o forall (f :: Type -> Type) (b :: Type -> (Type -> Type) -> Type). (Functor f, BareB b, DistributiveB (b Covered)) => f (Pure b) -> b Covered f bunbundle (Signal dom (Pure o) -> Signals dom o) -> (Signals dom i -> Signal dom (Pure o)) -> Signals dom i -> Signals dom o forall b c a. (b -> c) -> (a -> b) -> a -> c . (Pure i -> State s (Pure o)) -> s -> Signal dom (Pure i) -> Signal dom (Pure o) forall (dom :: Domain) s i o. (HiddenClockResetEnable dom, NFDataX s) => (i -> State s o) -> s -> Signal dom i -> Signal dom o mealyState ((s -> Pure o) -> CPUM s o () -> State s (Pure o) forall (o :: Type -> (Type -> Type) -> Type) s. (BareB o, ApplicativeB (o Covered)) => (s -> Pure o) -> CPUM s o () -> State s (Pure o) runCPU s -> Pure o defaultOutput (CPUM s o () -> State s (Pure o)) -> (Pure i -> CPUM s o ()) -> Pure i -> State s (Pure o) forall b c a. (b -> c) -> (a -> b) -> a -> c . Pure i -> CPUM s o () step) s initState (Signal dom (Pure i) -> Signal dom (Pure o)) -> (Signals dom i -> Signal dom (Pure i)) -> Signals dom i -> Signal dom (Pure o) forall b c a. (b -> c) -> (a -> b) -> a -> c . Signals dom i -> Signal dom (Pure i) forall (f :: Type -> Type) (b :: Type -> (Type -> Type) -> Type). (Applicative f, BareB b, TraversableB (b Covered)) => b Covered f -> f (Pure b) bbundle runCPU :: (BareB o, ApplicativeB (o Covered)) => (s -> Pure o) -> CPUM s o () -> State s (Pure o) runCPU :: (s -> Pure o) -> CPUM s o () -> State s (Pure o) runCPU s -> Pure o defaultOutput CPUM s o () step = do Barbie (o Covered) Last edits <- CPUM s o () -> State s (Barbie (o Covered) Last) forall (m :: Type -> Type) w a. Monad m => WriterT w m a -> m w execWriterT CPUM s o () step Pure o out0 <- (s -> Pure o) -> State s (Pure o) forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a gets s -> Pure o defaultOutput Pure o -> State s (Pure o) forall (m :: Type -> Type) a. Monad m => a -> m a return (Pure o -> State s (Pure o)) -> Pure o -> State s (Pure o) forall a b. (a -> b) -> a -> b $ Pure o -> Barbie (o Covered) Last -> Pure o forall (b :: Type -> (Type -> Type) -> Type). (BareB b, ApplicativeB (b Covered)) => Pure b -> Partial b -> Pure b update Pure o out0 Barbie (o Covered) Last edits