{-# 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