packages feed

retroclash-lib (empty) → 0.1.0

raw patch · 19 files changed

+1898/−0 lines, 19 filesdep +barbiesdep +basedep +clash-ghc

Dependencies added: barbies, base, clash-ghc, clash-lib, clash-prelude, containers, ghc-typelits-extra, ghc-typelits-knownnat, ghc-typelits-natnormalise, lens, lift-type, monoidal-containers, mtl, template-haskell, transformers

Files

+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2020 Gergő Érdi (http://gergo.erdi.hu/)++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ retroclash-lib.cabal view
@@ -0,0 +1,115 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack+--+-- hash: 63033a7be2d6ae3d881c517aef6195d61a5d85ec40614c32287bfaccb2176dc4++name:           retroclash-lib+version:        0.1.0+synopsis:       Code shared across the code samples in the book "Retrocomputing with Clash"+description:    Clash components useful when implementing, or interfacing with,+                retro-computers:+                .+                  * UART+                .+                  * Multi-digit seven-segment display driver+                .+                  * Keypad matrix scanner+                .+                  * PS/2 keyboard driver+                .+                  * VGA signal generator+                .+                  * Video coordinate transformers+                .+                  * A framework for monadic CPU descriptions+                .+                  * Address maps+                .+                  * Various small utilities+                .+category:       Hardware+homepage:       https://unsafePerform.IO/retroclash/+bug-reports:    https://github.com/gergoerdi/retroclash-lib/issues+author:         Gergő Érdi+maintainer:     gergo@erdi.hu+copyright:      2021 Gergő Érdi+license:        MIT+license-file:   LICENSE+build-type:     Simple++source-repository head+  type: git+  location: https://github.com/gergoerdi/retroclash-lib++library+  exposed-modules:+      RetroClash.Utils+      RetroClash.Clock+      RetroClash.Barbies+      RetroClash.Keypad+      RetroClash.SevenSegment+      RetroClash.SerialRx+      RetroClash.SerialTx+      RetroClash.VGA+      RetroClash.Video+      RetroClash.CPU+      RetroClash.Delayed+      RetroClash.Stack+      RetroClash.BCD+      RetroClash.Port+      RetroClash.PS2+      RetroClash.PS2.ASCII+      RetroClash.Memory+  other-modules:+      Paths_retroclash_lib+  hs-source-dirs:+      src+  default-extensions:+      BinaryLiterals+      ConstraintKinds+      DataKinds+      DeriveAnyClass+      DeriveGeneric+      DeriveLift+      DerivingStrategies+      ExplicitForAll+      ExplicitNamespaces+      FlexibleContexts+      FlexibleInstances+      KindSignatures+      MagicHash+      MonoLocalBinds+      NoImplicitPrelude+      NoMonomorphismRestriction+      NoStarIsType+      NoStrictData+      NoStrict+      QuasiQuotes+      ScopedTypeVariables+      TemplateHaskellQuotes+      TemplateHaskell+      TypeApplications+      TypeFamilies+      TypeInType+      TypeOperators+  ghc-options: -fexpose-all-unfoldings -fno-worker-wrapper -fplugin GHC.TypeLits.KnownNat.Solver -fplugin GHC.TypeLits.Normalise -fplugin GHC.TypeLits.Extra.Solver+  build-depends:+      barbies >=2.0.1 && <2.1+    , base >=4.14 && <5+    , clash-ghc >=1.4.2 && <1.5+    , clash-lib >=1.4.2 && <1.5+    , clash-prelude >=1.4.2 && <1.5+    , containers+    , ghc-typelits-extra+    , ghc-typelits-knownnat+    , ghc-typelits-natnormalise+    , lens+    , lift-type ==0.1.*+    , monoidal-containers ==0.6.*+    , mtl+    , template-haskell+    , transformers+  default-language: Haskell2010
+ src/RetroClash/BCD.hs view
@@ -0,0 +1,50 @@+{-# OPTIONS_GHC -fconstraint-solver-iterations=5 #-}+module RetroClash.BCD+    ( Digit, toDigit+    , BCD+    , fromBCD+    , BCDSize+    , toBCD+    , ShiftAdd, initBCD, stepBCD+    , prop_BCD+    ) where++import Clash.Prelude hiding (shift, add)+import RetroClash.Utils++type Digit = Index 10+type BCD n = Vec n Digit++toDigit :: Unsigned 4 -> Digit+toDigit = bitCoerce++fromBCD :: BCD n -> Integer+fromBCD = foldl (\x d -> x * 10 + fromIntegral d) 0++type BCDSize n = CLog 10 (2 ^ n)+type ShiftAdd n = (Vec (BCDSize n) (Unsigned 4), Unsigned n)++{-# INLINE initBCD #-}+initBCD :: (KnownNat n) => Unsigned n -> ShiftAdd n+initBCD = (,) (repeat 0)++stepBCD :: (KnownNat n) => ShiftAdd n -> ShiftAdd n+stepBCD = shift . add+  where+    shift :: (KnownNat n) => ShiftAdd n -> ShiftAdd n+    shift = bitwise (`shiftL` 1)++    add :: ShiftAdd n -> ShiftAdd n+    add (digits, buf) = (map add3 digits, buf)+      where+        add3 d = if d >= 5 then d + 3 else d++{-# INLINE toBCD #-}+toBCD :: forall n. (KnownNat n) => Unsigned n -> BCD (BCDSize n)+toBCD = map toDigit . fst . last . iterate (SNat @(n + 1)) stepBCD . initBCD++roundtrip :: (KnownNat n) => Unsigned n -> Unsigned n+roundtrip = fromIntegral . fromBCD . map bitCoerce . toBCD++prop_BCD :: (KnownNat n) => Unsigned n -> Bool+prop_BCD x = x == roundtrip x
+ src/RetroClash/Barbies.hs view
@@ -0,0 +1,29 @@+module RetroClash.Barbies+    ( Pure+    , Partial+    , Signals+    , bbundle+    , bunbundle+    ) where++import Clash.Prelude+import Data.Monoid (Last(..))+import Data.Functor.Identity++import Barbies+import Barbies.Bare++type Pure b = b Bare Identity+type Partial b = Barbie (b Covered) Last+type Signals dom b = b Covered (Signal dom)++bbundle :: (Applicative f, BareB b, TraversableB (b Covered)) => b Covered f -> f (Pure b)+bbundle = fmap bstrip . bsequence'++bunbundle :: (Functor f, BareB b, DistributiveB (b Covered)) => f (Pure b) -> b Covered f+bunbundle = bdistribute' . fmap bcover++instance (BareB b, TraversableB (b Covered), DistributiveB (b Covered)) => Bundle (Pure b) where+    type Unbundled dom (Pure b) = Signals dom b+    bundle = bbundle+    unbundle = bunbundle
+ src/RetroClash/CPU.hs view
@@ -0,0 +1,52 @@+{-# 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 ()+fd .:= x = scribe (iso getBarbie Barbie . fd) (pure x)++assignOut :: (Applicative f, MonadWriter (Barbie b f) m) => Setter' (b f) (f a) -> a -> m ()+assignOut fd x = fd .:= x++update :: (BareB b, ApplicativeB (b Covered)) => Pure b -> Partial b -> Pure b+update initials edits = bstrip $ bzipWith update1 (bcover initials) (getBarbie edits)+  where+    update1 :: Identity a -> Last a -> Identity a+    update1 initial edit = maybe initial Identity (getLast 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 initState defaultOutput step =+    bunbundle . mealyState (runCPU defaultOutput . step) initState . bbundle++runCPU+    :: (BareB o, ApplicativeB (o Covered))+    => (s -> Pure o)+    -> CPUM s o ()+    -> State s (Pure o)+runCPU defaultOutput step = do+    edits <- execWriterT step+    out0 <- gets defaultOutput+    return $ update out0 edits
+ src/RetroClash/Clock.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE ScopedTypeVariables, NumericUnderscores, PartialTypeSignatures #-}+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}+module RetroClash.Clock+    ( HzToPeriod++    , Seconds+    , Milliseconds+    , Microseconds+    , Nanoseconds+    , Picoseconds++    , ClockDivider+    , risePeriod+    , riseRate+    ) where++import Clash.Prelude++type HzToPeriod (rate :: Nat) = Seconds 1 `Div` rate++type Seconds      (s  :: Nat) = Milliseconds (1_000 * s)+type Milliseconds (ms :: Nat) = Microseconds (1_000 * ms)+type Microseconds (us :: Nat) = Nanoseconds  (1_000 * us)+type Nanoseconds  (ns :: Nat) = Picoseconds  (1_000 * ns)+type Picoseconds  (ps :: Nat) = ps++type ClockDivider dom ps = ps `Div` DomainPeriod dom++risePeriod+    :: forall ps dom. (HiddenClockResetEnable dom, _)+    => SNat ps+    -> Signal dom Bool+risePeriod _ = riseEvery (SNat @(ClockDivider dom ps))++riseRate+    :: forall rate dom. (HiddenClockResetEnable dom, _)+    => SNat rate+    -> Signal dom Bool+riseRate _ = risePeriod (SNat @(HzToPeriod rate))
+ src/RetroClash/Delayed.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE RecordWildCards, RankNTypes #-}+module RetroClash.Delayed+    ( delayVGA++    , delayedRom+    , delayedRam+    , delayedBlockRam1+    , sharedDelayed+    , sharedDelayedRW++    , delayedRegister+    , liftD+    , liftD2+    , matchDelay+    )+    where++import Clash.Prelude+import qualified Clash.Signal.Delayed.Bundle as D+import RetroClash.VGA+import RetroClash.Utils (enable, guardA, muxA, (.<|))+import Data.Maybe+import Control.Monad (mplus)++delayVGA+    :: (KnownNat d, KnownNat r, KnownNat g, KnownNat b)+    => (HiddenClockResetEnable dom)+    => VGASync dom+    -> DSignal dom d (Unsigned r, Unsigned g, Unsigned b)+    -> VGAOut dom r g b+delayVGA VGASync{..} rgb = vgaOut vgaSync' (toSignal rgb)+  where+    vgaSync' = VGASync+        { vgaHSync = matchDelay rgb undefined vgaHSync+        , vgaVSync = matchDelay rgb undefined vgaVSync+        , vgaDE = matchDelay rgb False vgaDE+        }++matchDelay+    :: (KnownNat d, NFDataX a, HiddenClockResetEnable dom)+    => DSignal dom d any+    -> a+    -> Signal dom a+    -> Signal dom a+matchDelay ref x0 = toSignal . (ref *>) . delayI x0 . fromSignal++delayedRam+    :: (HiddenClockResetEnable dom)+    => (forall dom'. (HiddenClockResetEnable dom') => Signal dom' addr -> Signal dom' wr -> Signal dom' a)+    -> DSignal dom d addr+    -> DSignal dom d wr+    -> DSignal dom (d + 1) a+delayedRam syncRam addr write = unsafeFromSignal $ syncRam (toSignal addr) (toSignal write)++delayedRom+    :: (HiddenClockResetEnable dom)+    => (forall dom'. (HiddenClockResetEnable dom') => Signal dom' addr -> Signal dom' a)+    -> DSignal dom d addr+    -> DSignal dom (d + 1) a+delayedRom syncRom addr = unsafeFromSignal $ syncRom (toSignal addr)++delayedBlockRam1+    :: (1 <= n, Enum addr, NFDataX a, HiddenClockResetEnable dom)+    => ResetStrategy r+    -> SNat n+    -> a+    -> DSignal dom d addr+    -> DSignal dom d (Maybe (addr, a))+    -> DSignal dom (d + 1) a+delayedBlockRam1 resetStrat size content = delayedRam (blockRam1 resetStrat size content)++delayedRegister+    :: (NFDataX a, HiddenClockResetEnable dom)+    => a+    -> (DSignal dom d a -> DSignal dom d a)+    -> DSignal dom (d + 1) a+delayedRegister initial feedback = r+  where+    r = unsafeFromSignal $ register initial $ toSignal new+    old = antiDelay (SNat @1) r+    new = feedback old++liftD+    :: (HiddenClockResetEnable dom)+    => (forall dom'. (HiddenClockResetEnable dom') => Signal dom' a -> Signal dom' b)+    -> DSignal dom d a -> DSignal dom d b+liftD f = unsafeFromSignal . f . toSignal++liftD2+    :: (HiddenClockResetEnable dom)+    => (forall dom'. (HiddenClockResetEnable dom') => Signal dom' a -> Signal dom' b -> Signal dom' c)+    -> DSignal dom d a -> DSignal dom d b -> DSignal dom d c+liftD2 f x y = unsafeFromSignal $ f (toSignal x) (toSignal y)++sharedDelayed+    :: (KnownNat k, KnownNat n, HiddenClockResetEnable dom)+    => (DSignal dom d (Maybe addr) -> DSignal dom (d + k) a)+    -> Vec (n + 1) (DSignal dom d (Maybe addr))+    -> Vec (n + 1) (DSignal dom (d + k) (Maybe a))+sharedDelayed mem reqs = reads+  where+    addrs = snd $ mapAccumL step (pure True) reqs+      where+        step en addr = (en .&&. isNothing <$> addr, guardA en addr)++    addr = muxA addrs++    read = mem addr+    reads = map (\addr -> enable (delayI False $ isJust <$> addr) read) addrs++sharedDelayedRW+    :: (KnownNat k, KnownNat n, HiddenClockResetEnable dom)+    => (DSignal dom d addr -> DSignal dom d (Maybe wr) -> DSignal dom (d + k) a)+    -> Vec (n + 1) (DSignal dom d (Maybe (addr, Maybe wr)))+    -> Vec (n + 1) (DSignal dom (d + k) (Maybe a))+sharedDelayedRW ram = sharedDelayed $ uncurry ram . D.unbundle . (.<| (undefined, Nothing))
+ src/RetroClash/Keypad.hs view
@@ -0,0 +1,72 @@+module RetroClash.Keypad+    ( Matrix(..), KeyStates(..), KeyEvent(..), KeyEvents(..)+    , scanKeypad, keypadEvents+    , pressedKeys+    , firstJust2D+    , inputKeypad+    ) where++import Clash.Prelude+import RetroClash.Utils+import RetroClash.Clock+import Control.Monad (mplus)++type Matrix rows cols a = Vec rows (Vec cols a)++type KeyStates rows cols = Matrix rows cols Bool++data KeyEvent+    = Pressed+    | Released+    deriving (Show, Eq, Generic, NFDataX)++type KeyEvents rows cols = Matrix rows cols (Maybe KeyEvent)++scanKeypad+    :: (KnownNat rows, KnownNat cols, IsActive rowAct, IsActive colAct, HiddenClockResetEnable dom)+    => Signal dom (Vec rows (Active rowAct))+    -> (Signal dom (Vec cols (Active colAct)), Signal dom (KeyStates rows cols))+scanKeypad rows = (map toActive <$> cols, transpose <$> bundle state)+  where+    (cols, currentCol) = roundRobin nextCol+    nextCol = riseEvery (SNat @1000)++    state = map colState indicesI+      where+        colState thisCol = regEn (repeat False) (stable .&&. currentCol .== thisCol) $ map fromActive <$> rows++        stable = cnt .== maxBound+        cnt = register (0 :: Index 10) $ mux nextCol 0 (moreIdx <$> cnt)++keypadEvents+    :: (KnownNat rows, KnownNat cols, HiddenClockResetEnable dom)+    => Signal dom (KeyStates rows cols)+    -> Signal dom (KeyEvents rows cols)+keypadEvents states = zipWith (zipWith event) <$> delayed <*> states+  where+    delayed = register (repeat $ repeat False) states++    event False True = Just Pressed+    event True False = Just Released+    event _ _ = Nothing++pressedKeys :: Matrix rows cols a -> KeyEvents rows cols  -> Matrix rows cols (Maybe a)+pressedKeys = zipWith (zipWith decode)+  where+    decode mapping (Just Pressed) = Just mapping+    decode _ _ = Nothing++firstJust2D :: (KnownNat rows, KnownNat cols) => Matrix (rows + 1) (cols + 1) (Maybe a) -> Maybe a+firstJust2D = fold mplus . map (fold mplus)++inputKeypad+    :: (KnownNat rows, KnownNat cols, IsActive rowAct, IsActive colAct)+    => (HiddenClockResetEnable dom, KnownNat (ClockDivider dom (Milliseconds 5)))+    => Matrix (rows + 1) (cols + 1) a+    -> Signal dom (Vec (rows + 1) (Active rowAct))+    -> (Signal dom (Vec (cols + 1) (Active colAct)), Signal dom (Maybe a))+inputKeypad keymap rows = (cols, pressedKey)+  where+    (cols, keyState) = scanKeypad rows+    events = keypadEvents . debounce (SNat @(Milliseconds 5)) (repeat . repeat $ False) $ keyState+    pressedKey = firstJust2D . pressedKeys keymap <$> events
+ src/RetroClash/Memory.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE DerivingStrategies, GeneralizedNewtypeDeriving #-}+module RetroClash.Memory+    ( RAM, ROM, Port, Port_+    , packRam++    , Handle+    , mapH++    , Addressing+    , memoryMap, memoryMap_++    , conduit, readWrite, readWrite_+    , romFromVec, romFromFile+    , ram0, ramFromFile+    , port, port_++    , connect+    , override++    , from+    , matchJust+    , matchLeft, matchRight+    , tag+    ) where++import Clash.Prelude hiding (Exp, lift)+import RetroClash.Utils+import RetroClash.Port+import Data.Maybe+import Control.Arrow (second)+import Control.Monad+import Control.Monad.Reader+import Control.Monad.Writer+import Data.Kind (Type)++import Data.List as L+import Data.Map.Monoidal as Map++import Language.Haskell.TH hiding (Type)+import LiftType+import Type.Reflection (Typeable)++type RAM dom addr dat = Signal dom addr -> Signal dom (Maybe (addr, dat)) -> Signal dom dat+type ROM dom addr dat = Signal dom addr ->                                   Signal dom dat+type Port dom addr dat a = Signal dom (Maybe (PortCommand addr dat)) -> (Signal dom dat, a)+type Port_ dom addr dat = Signal dom (Maybe (PortCommand addr dat)) -> Signal dom dat++packRam :: (BitPack dat) => RAM dom addr (BitVector (BitSize dat)) -> RAM dom addr dat+packRam ram addr = fmap unpack . ram addr . fmap (second pack <$>)++data Handle addr = Handle Name Name++-- | type Addr dom addr = TExpQ (Signal dom (Maybe addr))+type Addr = ExpQ++-- | type Dat dom dat = TExpQ (Signal dom (Maybe dat))+type Dat = ExpQ++-- | type Component dom dat a = TExpQ (Signal dom (Maybe dat))+type Component = ExpQ++newtype Addressing addr a = Addressing+    { runAddressing :: ReaderT (Addr, Dat) (WriterT (DecsQ, MonoidalMap Name [Addr], [Component]) Q) a }+    deriving newtype (Functor, Applicative, Monad)++class Backpane a where+    backpane :: a -> ExpQ++instance Backpane () where+    backpane () = [|()|]++instance (Backpane a1, Backpane a2) => Backpane (a1, a2) where+    backpane (x1, x2) = [| ($(backpane x1), $(backpane x2)) |]++instance (Backpane a1, Backpane a2, Backpane a3) => Backpane (a1, a2, a3) where+    backpane (x1, x2, x3) = [| ($(backpane x1), $(backpane x2), $(backpane x3)) |]++data Result = Result ExpQ++instance Backpane Result where+    backpane (Result e) = e++compile+    :: forall addr a b. (Backpane a)+    => Addressing addr a+    -> Addr+    -> Dat+    -> Component+compile addressing addr wr = do+    (x, (decs, conns, rds)) <-+        runWriterT $ runReaderT (runAddressing addressing) ([| Just <$> $addr |], wr)++    let compAddrs = [ [d| $(varP nm) = muxA $(listE addrs) |]+                    | (nm, addrs) <- Map.toList conns+                    ]+    decs <- mconcat (decs:compAddrs)+    letE (pure <$> decs) [| (muxA $(listE rds), $(backpane x)) |]++memoryMap+    :: forall addr a. (Backpane a)+    => Addr+    -> Dat+    -> Addressing addr a+    -> Component+memoryMap addr wr addressing =+    [| let addr' = $addr; wr' = $wr+        in $(compile addressing [| addr' |] [| wr' |])+    |]++memoryMap_+    :: forall addr dat. ()+    => Addr+    -> Dat+    -> Addressing addr ()+    -> Dat+memoryMap_ addr wr addressing = [| fst $(memoryMap addr wr addressing) |]++connect+    :: Handle addr+    -> Addressing addr ()+connect (Handle rd compAddr) = Addressing $ do+    (addr, _) <- ask+    let masked = [| enable (delay False $ isJust <$> $addr) $(varE rd) |]+    tell (mempty, Map.singleton compAddr [addr], [masked])++override+    :: ExpQ+    -> Addressing addr ()+override sig = Addressing $ do+    rd <- lift . lift $ newName "rd"+    let decs = [d| $(varP rd) = $sig |]+    tell (decs, mempty, [varE rd])++matchAddr+    :: ExpQ {-(addr -> Maybe addr')-}+    -> Addressing addr' a+    -> Addressing addr a+matchAddr match body = Addressing $ do+    nm <- lift . lift $ newName "addr"+    let addr' = varE nm+    ReaderT $ \(addr, wr) -> do+        let dec = [d| $(varP nm) = ($match =<<) <$> $addr |]+        runReaderT+          (tell (dec, mempty, mempty) >> runAddressing body)+          (addr', wr)++mapH :: ExpQ -> Handle addr' -> Addressing addr (Handle addr')+mapH f (Handle rd compAddr) = Addressing $ do+    rd' <- lift . lift $ newName "rd"+    tell ([d| $(varP rd') = $f <$> $(varE rd)|], mempty, mempty)+    return $ Handle rd' compAddr++readWrite+    :: forall addr' addr. ()+    => (Addr -> Dat -> Component)+    -> Addressing addr (Handle addr', Result)+readWrite component = Addressing $ do+    rd <- lift . lift $ newName "rd"+    addr <- lift . lift $ newName "compAddr"+    result <- lift . lift $ newName "result"+    (_, wr) <- ask+    let decs = [d| ($(varP rd), $(varP result)) = $(component (varE addr) wr) |]+    tell (decs, Map.singleton addr mempty, mempty)+    return (Handle rd addr, Result (varE result))++readWrite_+    :: forall addr' addr. ()+    => (Addr -> Dat -> Dat)+    -> Addressing addr (Handle addr')+readWrite_ component = fmap fst $ readWrite $ \addr wr -> [| ($(component addr wr), ()) |]++conduit+    :: forall addr' addr. ()+    => ExpQ+    -> Addressing addr (Handle addr', Result, Result)+conduit rdExt = do+    (h, Result x) <- readWrite $ \addr wr -> [| ($rdExt, ($addr, $wr)) |]+    return (h, Result [| fst $x |], Result [| snd $x |])++romFromVec+    :: (1 <= n)+    => SNat n+    -> ExpQ {-(Vec n dat)-}+    -> Addressing addr (Handle (Index n))+romFromVec size xs = readWrite_ $ \addr _wr ->+    [| rom $xs (bitCoerce . fromJustX <$> $addr) |]++romFromFile+    :: (1 <= n)+    => SNat n+    -> ExpQ+    -> Addressing addr (Handle (Index n))+romFromFile size fileName = readWrite_ $ \addr _wr ->+    [| fmap unpack $ romFilePow2 $fileName (bitCoerce . fromJustX <$> $addr) |]++ram0+    :: (1 <= n)+    => SNat n+    -> Addressing addr (Handle (Index n))+ram0 size = readWrite_ $ \addr wr ->+    [| blockRam1 NoClearOnReset size 0 (fromJustX <$> $addr) (liftA2 (,) <$> $addr <*> $wr) |]++ramFromFile+    :: SNat n+    -> ExpQ {- FilePath -}+    -> Addressing addr (Handle (Index n))+ramFromFile size fileName = readWrite_ $ \addr wr ->+    [| packRam (blockRamFile size $fileName)+           (fromJustX <$> $addr)+           (liftA2 (,) <$> $addr <*> $wr)+    |]++port+    :: forall addr' a addr. ()+    => ExpQ+    -> Addressing addr (Handle addr', Result)+port mkPort = readWrite $ \addr wr ->+  [| let (read, x) = $mkPort $ portFromAddr $addr $wr+     in (delay undefined read, x)+  |]++port_+    :: forall addr' addr. ()+    => ExpQ+    -> Addressing addr (Handle addr')+port_ mkPort = readWrite_ $ \addr wr ->+  [| let read = $mkPort $ portFromAddr $addr $wr+     in delay undefined read+  |]++from+    :: forall addr' addr a. (Typeable addr', Lift addr)+    => (Integral addr, Ord addr, Integral addr', Bounded addr')+    => addr+    -> Addressing addr' a+    -> Addressing addr a+from base = matchAddr [| from' @($(liftTypeQ @addr')) base |]++tag+    :: (Lift addr')+    => addr'+    -> Addressing (addr', addr) a+    -> Addressing addr a+tag t = matchAddr [| \addr -> Just (t, addr) |]++matchJust+    :: Addressing addr a+    -> Addressing (Maybe addr) a+matchJust = matchAddr [| id |]++matchLeft+    :: Addressing addr1 a+    -> Addressing (Either addr1 addr2) a+matchLeft = matchAddr [| either Just (const Nothing) |]++matchRight+    :: Addressing addr2 a+    -> Addressing (Either addr1 addr2) a+matchRight = matchAddr [| either (const Nothing) Just |]++from'+    :: forall addr' addr. (Integral addr, Ord addr, Integral addr', Bounded addr')+    => addr -> addr -> Maybe addr'+from' base addr = do+    guard $ addr >= base+    let offset = addr - base+    guard $ offset <= fromIntegral (maxBound :: addr')+    return (fromIntegral offset)
+ src/RetroClash/PS2.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE RecordWildCards, LambdaCase #-}+module RetroClash.PS2+    ( PS2(..)+    , samplePS2++    , decodePS2++    , KeyEvent(..)+    , ScanCode(..)+    , KeyCode(..)+    , parseScanCode++    , keyPress+    , keyState+    ) where++import Clash.Prelude+import RetroClash.Utils+import RetroClash.Clock+import Control.Monad.State+import Control.Monad.Trans.Writer+import Data.Monoid (Last(..))+import Data.Foldable (traverse_)++data PS2 dom = PS2+    { ps2Clk :: "CLK"   ::: Signal dom Bit+    , ps2Data :: "DATA" ::: Signal dom Bit+    }++samplePS2+    :: forall dom. (HiddenClockResetEnable dom, KnownNat (ClockDivider dom (Microseconds 1)))+    => PS2 dom -> Signal dom (Maybe Bit)+samplePS2 PS2{..} =+    enable (isFalling low . lowpass $ ps2Clk) (lowpass ps2Data)+  where+    lowpass :: Signal dom Bit -> Signal dom Bit+    lowpass = debounce (SNat @(Microseconds 1)) low++data PS2State+    = Idle+    | Bit (BitVector 8) (Index 8)+    | Parity (BitVector 8)+    | Stop (Maybe (Unsigned 8))+    deriving (Show, Eq, Generic, NFDataX)++decoder :: Bit -> WriterT (Last (Unsigned 8)) (State PS2State) ()+decoder x = get >>= \case+    Idle -> do+        when (x == low) $ put $ Bit 0 0+    Bit xs i -> do+        let (xs', _) = bvShiftR x xs+        put $ maybe (Parity xs') (Bit xs') $ succIdx i+    Parity xs -> do+        put $ Stop $ unpack xs <$ guard (parity xs /= x)+    Stop b -> do+        when (x == high) $ tell . Last $ b+        put Idle++decodePS2+    :: (HiddenClockResetEnable dom)+    => Signal dom (Maybe Bit) -> Signal dom (Maybe (Unsigned 8))+decodePS2 = mealyState sampleDecoder Idle+  where+    sampleDecoder = fmap getLast . execWriterT . traverse_ decoder++data KeyEvent = KeyPress | KeyRelease+    deriving (Generic, Eq, Show, NFDataX)++type KeyCode = Unsigned 9++data ScanCode = ScanCode KeyEvent KeyCode+    deriving (Generic, Eq, Show, NFDataX)++data ScanState+    = Init+    | Extended+    | Code KeyEvent Bit+    deriving (Show, Generic, NFDataX)++parser :: Unsigned 8 -> WriterT (Last ScanCode) (State ScanState) ()+parser raw = get >>= \case+    Init+        | raw == 0xe0 -> put $ Extended+        | raw == 0xf0 -> put $ Code KeyRelease 0+        | otherwise   -> finish KeyPress 0+    Extended+        | raw == 0xf0 -> put $ Code KeyRelease 1+        | otherwise   -> finish KeyPress 1+    Code ev ext       -> finish ev ext+  where+    finish ev ext = do+        tell $ Last . Just $ ScanCode ev $ bitCoerce (ext, raw)+        put Init++parseScanCode+    :: (HiddenClockResetEnable dom)+    => Signal dom (Maybe (Unsigned 8)) -> Signal dom (Maybe ScanCode)+parseScanCode = mealyState byteParser Init+  where+    byteParser = fmap getLast . execWriterT . traverse_ parser++keyPress :: ScanCode -> Maybe KeyCode+keyPress (ScanCode KeyPress kc) = Just kc+keyPress _ = Nothing++keyState+    :: (HiddenClockResetEnable dom)+    => KeyCode+    -> Signal dom (Maybe ScanCode)+    -> Signal dom Bool+keyState target = regMaybe False . fmap fromScanCode+  where+    fromScanCode sc = do+        ScanCode ev kc <- sc+        guard $ kc == target+        return $ ev == KeyPress
+ src/RetroClash/PS2/ASCII.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE RecordWildCards, LambdaCase #-}+module RetroClash.PS2.ASCII+    ( Side(..), Modifier(..)+    , modMap+    , asciiMap+    ) where++import Clash.Prelude+import RetroClash.PS2+import Data.Char++data Side+    = OnLeft+    | OnRight+    deriving (Eq, Show, Enum, Bounded, Generic, NFDataX)++data Modifier+    = Shift+    | Ctrl+    | Alt+    | Win+    deriving (Eq, Show, Enum, Bounded, Generic, NFDataX)++modMap :: KeyCode -> Maybe (Modifier, Side)+modMap 0x012 = Just (Shift, OnLeft)+modMap 0x059 = Just (Shift, OnRight)+modMap 0x014 = Just (Ctrl, OnLeft)+modMap 0x114 = Just (Ctrl, OnRight)+modMap 0x011 = Just (Alt, OnLeft)+modMap 0x111 = Just (Alt, OnRight)+modMap 0x11f = Just (Win, OnLeft)+modMap 0x127 = Just (Win, OnRight)+modMap _ = Nothing++{-# INLINE asciiMap #-}+asciiMap :: KeyCode -> Maybe (Unsigned 7)+asciiMap = fmap fromChar . charMap+  where+    fromChar = fromIntegral . ord++{-# INLINE charMap #-}+charMap :: KeyCode -> Maybe Char+charMap 0x05a = Just '\r'+charMap 0x15a = Just '\r' -- Keypad+charMap 0x00d = Just '\t'+charMap 0x029 = Just ' '+charMap 0x04c = Just ';'+charMap 0x052 = Just '\''+charMap 0x054 = Just '['+charMap 0x05b = Just ']'+charMap 0x05d = Just '\\'+charMap 0x04a = Just '/'+charMap 0x041 = Just ','+charMap 0x049 = Just '.'+charMap 0x04e = Just '-'+charMap 0x055 = Just '='+charMap 0x045 = Just '0'+charMap 0x016 = Just '1'+charMap 0x01e = Just '2'+charMap 0x026 = Just '3'+charMap 0x025 = Just '4'+charMap 0x02e = Just '5'+charMap 0x036 = Just '6'+charMap 0x03d = Just '7'+charMap 0x03e = Just '8'+charMap 0x046 = Just '9'+charMap 0x01c = Just 'a'+charMap 0x032 = Just 'b'+charMap 0x021 = Just 'c'+charMap 0x023 = Just 'd'+charMap 0x024 = Just 'e'+charMap 0x02b = Just 'f'+charMap 0x034 = Just 'g'+charMap 0x033 = Just 'h'+charMap 0x043 = Just 'i'+charMap 0x03b = Just 'j'+charMap 0x042 = Just 'k'+charMap 0x04b = Just 'l'+charMap 0x03a = Just 'm'+charMap 0x031 = Just 'n'+charMap 0x044 = Just 'o'+charMap 0x04d = Just 'p'+charMap 0x015 = Just 'q'+charMap 0x02d = Just 'r'+charMap 0x01b = Just 's'+charMap 0x02c = Just 't'+charMap 0x03c = Just 'u'+charMap 0x02a = Just 'v'+charMap 0x01d = Just 'w'+charMap 0x022 = Just 'x'+charMap 0x035 = Just 'y'+charMap 0x01a = Just 'z'+charMap _ = Nothing
+ src/RetroClash/Port.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE LambdaCase, ApplicativeDo #-}+module RetroClash.Port+    ( PortCommand(..)+    , portFromAddr+    ) where++import Clash.Prelude++import Data.Bifunctor+import Data.Bifoldable+import Data.Bitraversable++data PortCommand port a+    = ReadPort port+    | WritePort port a+    deriving (Generic, NFDataX, Show)++instance Functor (PortCommand port) where+    {-# INLINE fmap #-}+    fmap f = \case+        ReadPort port -> ReadPort port+        WritePort port val -> WritePort port (f val)++instance Bifunctor PortCommand where+    {-# INLINE bimap #-}+    bimap f g = \case+        ReadPort port -> ReadPort (f port)+        WritePort port val -> WritePort (f port) (g val)++    {-# INLINE second #-}+    second = fmap++instance Bifoldable PortCommand where+    {-# INLINE bifoldMap #-}+    bifoldMap f g = \case+        ReadPort port -> f port+        WritePort port val -> f port <> g val++instance Bitraversable PortCommand where+    {-# INLINE bitraverse #-}+    bitraverse f g = \case+        ReadPort port -> ReadPort <$> f port+        WritePort port val -> WritePort <$> f port <*> g val++portFromAddr :: Signal dom (Maybe port) -> Signal dom (Maybe a) -> Signal dom (Maybe (PortCommand port a))+portFromAddr addr w = do+    addr <- addr+    w <- w+    pure $ case (addr, w) of+        (Just addr, Nothing) -> Just $ ReadPort addr+        (Just addr, Just w) -> Just $ WritePort addr w+        _ -> Nothing
+ src/RetroClash/SerialRx.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE RecordWildCards, LambdaCase #-}+module RetroClash.SerialRx+    ( serialRx+    , serialRxDyn+    , RxState(..)+    , RxBit(..)+    , rxStep+    ) where++import Clash.Prelude+import RetroClash.Utils+import RetroClash.Clock++import Control.Monad.State+import Control.Monad.Trans.Writer+import Data.Monoid+import Data.Word++data RxState n+    = RxIdle+    | RxBit Word32 (Maybe Bit) (RxBit n)+    deriving (Generic, Eq, Show, NFDataX)++data RxBit n+    = StartBit+    | DataBit (BitVector n) (Index n)+    | StopBit (BitVector n)+    deriving (Generic, Eq, Show, NFDataX)++rxStep :: (KnownNat n) => Word32 -> Bit -> State (RxState n) (Maybe (BitVector n))+rxStep bitDuration input = fmap getLast . execWriterT $ get >>= \case+    RxIdle -> do+        when (input == low) $ put $ RxBit (bitDuration1 - 1) Nothing StartBit+    RxBit cnt sample b | cnt > 1 -> do+        put $ RxBit (cnt - 1) sample b+    RxBit _ Nothing b -> do+        consume input b+    RxBit _ (Just sample) rx -> case rx of+        StartBit -> do+            if sample == low then waitFor (DataBit 0 0) else put RxIdle+        DataBit xs i -> do+            let (xs', _) = bvShiftR sample xs+            waitFor $ maybe (StopBit xs') (DataBit xs') $ succIdx i+        StopBit xs -> do+            when (sample == high) $ tell $ pure xs+            put RxIdle+  where+    bitDuration1 = half bitDuration+    bitDuration2 = bitDuration - bitDuration1++    waitFor = put . RxBit bitDuration1 Nothing+    consume input = put . RxBit bitDuration2 (Just input)++serialRxDyn+    :: (KnownNat n, HiddenClockResetEnable dom)+    => Signal dom Word32+    -> Signal dom Bit+    -> Signal dom (Maybe (BitVector n))+serialRxDyn bitDuration input = mealyStateB (uncurry rxStep) RxIdle (bitDuration, input)++serialRx+    :: forall n rate dom. (KnownNat n, KnownNat (ClockDivider dom (HzToPeriod rate)), HiddenClockResetEnable dom)+    => SNat rate+    -> Signal dom Bit+    -> Signal dom (Maybe (BitVector n))+serialRx rate = serialRxDyn $ pure bitDuration+  where+    bitDuration = fromIntegral . natVal $ SNat @(ClockDivider dom (HzToPeriod rate))
+ src/RetroClash/SerialTx.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE RecordWildCards, LambdaCase #-}+module RetroClash.SerialTx+    ( serialTx+    , serialTxDyn+    , fifo+    , TxState(..)+    , TxBit(..)+    , txStep+    ) where++import Clash.Prelude+import RetroClash.Utils+import RetroClash.Clock++import Control.Monad.State+import Control.Monad.Writer+import Data.Foldable (traverse_)+import Data.Word++data TxState n+    = TxIdle+    | TxBit Word32 (TxBit n)+    deriving (Show, Eq, Generic, NFDataX)++data TxBit n+    = StartBit (BitVector n)+    | DataBit (BitVector n) (Index n)+    | StopBit+    deriving (Show, Eq, Generic, NFDataX)++txStep :: forall n. (KnownNat n) => Word32 -> Maybe (BitVector n) -> State (TxState n) (Bit, Bool)+txStep bitDuration input = fmap (fmap getAny) . runWriterT $ get >>= \case+    TxIdle -> do+        tell $ Any True+        traverse_ (goto . StartBit) input+        return high+    TxBit cnt tx -> slowly cnt tx $ case tx of+        StartBit xs -> do+            goto $ DataBit xs 0+            return low+        DataBit xs i -> do+            let (xs', _) = bvShiftR 0 xs+            goto $ maybe StopBit (DataBit xs') $ succIdx i+            return $ lsb xs+        StopBit -> do+            put TxIdle+            return high+  where+    goto = put . TxBit bitDuration++    slowly cnt tx act+        | cnt > 1 = act <* put (TxBit (cnt - 1) tx)+        | otherwise = act++serialTxDyn+    :: (KnownNat n, HiddenClockResetEnable dom)+    => Signal dom Word32+    -> Signal dom (Maybe (BitVector n))+    -> (Signal dom Bit, Signal dom Bool)+serialTxDyn bitDuration input = mealyStateB (uncurry txStep) TxIdle (bitDuration, input)++serialTx+    :: forall n rate dom. (KnownNat n, KnownNat (ClockDivider dom (HzToPeriod rate)), HiddenClockResetEnable dom)+    => SNat rate+    -> Signal dom (Maybe (BitVector n))+    -> (Signal dom Bit, Signal dom Bool)+serialTx rate = serialTxDyn $ pure . fromIntegral . natVal $ SNat @(ClockDivider dom (HzToPeriod rate))++fifo+    :: forall a dom. (NFDataX a, HiddenClockResetEnable dom)+    => Signal dom (Maybe a) -> Signal dom Bool -> Signal dom (Maybe a)+fifo input outReady = r+  where+    r = register Nothing $ mux outReady input (mplus <$> r <*> input)
+ src/RetroClash/SevenSegment.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE PartialTypeSignatures, RecordWildCards, ApplicativeDo #-}+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}+module RetroClash.SevenSegment+    ( SevenSegment(..)+    , encodeHexSS+    , showSS+    , showSSs+    , muxRR+    , driveSS+    , sevenSegmentPort+    -- , bytesSS+    ) where++import Clash.Prelude+import qualified Data.List as L+import RetroClash.Utils+import RetroClash.Clock++data SevenSegment n anodes segments dp = SevenSegment+    { anodes :: "AN" ::: Vec n (Active anodes)+    , segments :: "SEG" ::: Vec 7 (Active segments)+    , dp :: "DP" ::: Active dp+    }+    deriving (Generic)++muxRR+    :: (KnownNat n, HiddenClockResetEnable dom)+    => Signal dom Bool+    -> Signal dom (Vec n a)+    -> (Signal dom (Vec n Bool), Signal dom a)+muxRR tick xs = (selector, current)+  where+    (selector, i) = roundRobin tick+    current = (!!) <$> xs <*> i++driveSS+    :: (KnownNat n, HiddenClockResetEnable dom, _)+    => (a -> (Vec 7 Bool, Bool))+    -> Signal dom (Vec n (Maybe a))+    -> Signal dom (SevenSegment n anodes segments dp)+driveSS draw digits = do+    anodes <- map toActive <$> anodes+    segments <- map toActive <$> segments+    dp <- toActive <$> dp+    pure SevenSegment{..}+  where+    (anodes, digit) = muxRR (risePeriod (SNat @(Milliseconds 1))) digits+    (segments, dp) = unbundle $ maybe (repeat False, False) draw <$> digit++sevenSegmentPort :: PortName+sevenSegmentPort = PortProduct "SS" $ PortName <$> ["AN", "SEG", "DP"]++bytesSS+    :: forall n div dom clk sync. (KnownNat n, KnownNat div, HiddenClockResetEnable dom)+    => Unsigned div+    -> Signal dom (Vec n (Maybe (Unsigned 8)))+    -> (Signal dom (Vec (n * 2) Bool), Signal dom (Vec 7 Bool))+bytesSS div bytes = (shownDigit, segments)+  where+    digit = regEn (0 :: Index (n * 2)) timer $ nextIdx <$> digit+      where+        counter = countFromTo 0 div (pure True)+        timer = counter .==. pure 0++    shownDigit = oneHot <$> digit+    segments = maybe (pure False) encodeHexSS <$> nibble++    nibble = (!!) <$> nibbles <*> digit++    nibbles = concatMap (traverse splitByte) <$> bytes++    splitByte :: Unsigned 8 -> Vec 2 (Unsigned 4)+    splitByte byte = hi :> lo :> Nil+      where+        (hi, lo) = bitCoerce byte++encodeHexSS :: Unsigned 4 -> Vec 7 Bool+encodeHexSS n = case n of+    --       a        b        c        d        e        f        g+    0x0 ->  True  :> True  :> True  :> True  :> True  :> True  :> False :> Nil+    0x1 ->  False :> True  :> True  :> False :> False :> False :> False :> Nil+    0x2 ->  True  :> True  :> False :> True  :> True  :> False :> True  :> Nil+    0x3 ->  True  :> True  :> True  :> True  :> False :> False :> True  :> Nil+    0x4 ->  False :> True  :> True  :> False :> False :> True  :> True  :> Nil+    0x5 ->  True  :> False :> True  :> True  :> False :> True  :> True  :> Nil+    0x6 ->  True  :> False :> True  :> True  :> True  :> True  :> True  :> Nil+    0x7 ->  True  :> True  :> True  :> False :> False :> False :> False :> Nil+    0x8 ->  True  :> True  :> True  :> True  :> True  :> True  :> True  :> Nil+    0x9 ->  True  :> True  :> True  :> True  :> False :> True  :> True  :> Nil+    0xa ->  True  :> True  :> True  :> False :> True  :> True  :> True  :> Nil+    0xb ->  False :> False :> True  :> True  :> True  :> True  :> True  :> Nil+    0xc ->  True  :> False :> False :> True  :> True  :> True  :> False :> Nil+    0xd ->  False :> True  :> True  :> True  :> True  :> False :> True  :> Nil+    0xe ->  True  :> False :> False :> True  :> True  :> True  :> True  :> Nil+    0xf ->  True  :> False :> False :> False :> True  :> True  :> True  :> Nil++showSS :: Vec 7 Bool -> String+showSS (a :> b :> c :> d :> e :> f :> g :> Nil) = unlines . L.concat $+    [ L.replicate 1 $ horiz   a+    , L.replicate 3 $ vert  f   b+    , L.replicate 1 $ horiz   g+    , L.replicate 3 $ vert  e   c+    , L.replicate 1 $ horiz   d+    ]+  where+    horiz True  = " ###### "+    horiz False = " ...... "++    vert b1 b2 = part b1 <> "      " <> part b2+      where+        part True  = "#"+        part False = "."++showSSs :: [Vec 7 Bool] -> String+showSSs = unlines . L.map (L.intercalate "  ") . L.transpose . L.map (lines . showSS)
+ src/RetroClash/Stack.hs view
@@ -0,0 +1,12 @@+module RetroClash.Stack where++import Clash.Prelude++data Stack n a = Stack (Vec n a) (Index n)+    deriving (Generic, NFDataX, Show)++push :: (KnownNat n) => a -> Stack n a -> Stack n a+push x (Stack xs i) = Stack (replace i x xs) (i + 1)++pop :: (KnownNat n) => Stack n a -> (a, Stack n a)+pop (Stack xs i) = (xs !! (i - 1), Stack xs (i - 1))
+ src/RetroClash/Utils.hs view
@@ -0,0 +1,365 @@+{-# LANGUAGE ScopedTypeVariables, ApplicativeDo, Rank2Types #-}+{-# LANGUAGE TupleSections #-}+module RetroClash.Utils+    ( withResetEnableGen+    , withEnableGen++    , withStart++    , Polarity(..), Active, active, IsActive(..)+    , toActiveDyn++    , bitwise+    , parity+    , half+    , halfIndex++    , bvShiftL+    , bvShiftR++    , (.==)+    , (==.)+    , (./=)+    , (/=.)+    , (.>)+    , (.>=)+    , (.<)+    , (.<=)+    , (<=.)++    , (.!!.)+    , (.!!)+    , (!!.)++    , changed+    , integrate+    , debounce++    , riseEveryWhen+    , oscillateWhen++    , oneHot+    , roundRobin++    , countFromTo+    , nextIdx, prevIdx+    , succIdx, predIdx+    , moreIdx, lessIdx++    , mealyState+    , mealyStateB++    , mooreState+    , mooreStateB++    , enable+    , guardA+    , muxA+    , (.<|>.)+    , (.|>.)+    , (|>.)+    , (.<|.)+    , (.<|)+    , muxMaybe++    , packWrite+    , noWrite+    , withWrite+    , singlePort+    , unbraid++    , shifterL+    , shifterR+    ) where++import Clash.Prelude+import RetroClash.Clock+import Data.Maybe (fromMaybe)+import Control.Monad.State+import qualified Data.Foldable as F+import Data.Monoid++withResetEnableGen+    :: (KnownDomain dom)+    => (HiddenClockResetEnable dom => r)+    -> Clock dom -> r+withResetEnableGen board clk = withClockResetEnable clk resetGen enableGen board++withEnableGen+    :: (KnownDomain dom)+    => (HiddenClockResetEnable dom => r)+    -> Clock dom -> Reset dom -> r+withEnableGen board clk rst = withClockResetEnable clk rst enableGen board++oneHot :: forall n. (KnownNat n) => Index n -> Vec n Bool+oneHot = reverse . bitCoerce . bit @(Unsigned n) . fromIntegral++changed :: (HiddenClockResetEnable dom, Eq a, NFDataX a) => a -> Signal dom a -> Signal dom Bool+changed x0 x = x ./=. register x0 x++integrate+    :: (Monoid a, NFDataX a, HiddenClockResetEnable dom)+    => Signal dom Bool -> Signal dom a -> Signal dom a+integrate clear x = acc+  where+    acc = register mempty $ mux clear x $ mappend <$> acc <*> x++debounce+    :: forall ps a dom. (Eq a, NFDataX a, HiddenClockResetEnable dom, KnownNat (ClockDivider dom ps))+    => SNat ps -> a -> Signal dom a -> Signal dom a+debounce SNat start this = regEn start stable this+  where+    counter = register (0 :: Index (ClockDivider dom ps)) counterNext+    counterNext = mux (changed start this) 0 (moreIdx <$> counter)+    stable = counterNext .==. pure maxBound++roundRobin+    :: forall n dom a. (KnownNat n, HiddenClockResetEnable dom)+    => Signal dom Bool+    -> (Signal dom (Vec n Bool), Signal dom (Index n))+roundRobin next = (selector, i)+  where+    i = regEn (0 :: Index n) next $ nextIdx <$> i+    selector = oneHot <$> i++data Polarity = High | Low+    deriving (Show, Eq)++newtype Active (p :: Polarity) = MkActive{ activeLevel :: Bit }+    deriving (Show, Eq, Ord, Generic, NFDataX, BitPack)++active :: Bit -> Active p+active = MkActive++toActiveDyn :: Polarity -> Bool -> Bit+toActiveDyn High = boolToBit+toActiveDyn Low = complement . boolToBit++fromActiveDyn :: Polarity -> Bit -> Bool+fromActiveDyn High = bitToBool+fromActiveDyn Low = bitToBool . complement++class IsActive p where+    fromActive :: Active p -> Bool+    toActive :: Bool -> Active p++instance IsActive High where+    fromActive = fromActiveDyn High . activeLevel+    toActive = MkActive . toActiveDyn High++instance IsActive Low where+    fromActive = fromActiveDyn Low . activeLevel+    toActive = MkActive . toActiveDyn Low++infix 4 ==.+(==.) :: (Eq a, Functor f) => a -> f a -> f Bool+x ==. fy = (x ==) <$> fy++infix 4 .==+(.==) :: (Eq a, Functor f) => f a -> a -> f Bool+fx .== y = (== y) <$> fx++infix 4 /=.+(/=.) :: (Eq a, Functor f) => a -> f a -> f Bool+x /=. fy = (x /=) <$> fy++infix 4 ./=+(./=) :: (Eq a, Functor f) => f a -> a -> f Bool+fx ./= y = (/= y) <$> fx++infix 4 .>+(.>) :: (Ord a, Functor f) => f a -> a -> f Bool+fx .> y = (> y) <$> fx++infix 4 .>=+(.>=) :: (Ord a, Functor f) => f a -> a -> f Bool+fx .>= y = (>= y) <$> fx++infix 4 .<+(.<) :: (Ord a, Functor f) => f a -> a -> f Bool+fx .< y = (< y) <$> fx++infix 4 .<=+(.<=) :: (Ord a, Functor f) => f a -> a -> f Bool+fx .<= y = (<= y) <$> fx++infix 4 <=.+(<=.) :: (Ord a, Functor f) => a -> f a -> f Bool+x <=. fy = (x <=) <$> fy++(.!!.) :: (KnownNat n, Enum i, Applicative f) => f (Vec n a) -> f i -> f a+(.!!.) = liftA2 (!!)++(!!.) :: (KnownNat n, Enum i, Functor f) => Vec n a -> f i -> f a+xs !!. i = (xs !!) <$> i++(.!!) :: (KnownNat n, Enum i, Functor f) => f (Vec n a) -> i -> f a+xs .!! i = (!! i) <$> xs++countFromTo :: (Eq a, Enum a, NFDataX a, HiddenClockResetEnable dom) => a -> a -> Signal dom Bool -> Signal dom a+countFromTo from to tick = counter+  where+    counter = regEn from tick $ mux (counter .==. pure to) (pure from) (succ <$> counter)++nextIdx :: (Eq a, Enum a, Bounded a) => a -> a+nextIdx = fromMaybe minBound . succIdx++prevIdx :: (Eq a, Enum a, Bounded a) => a -> a+prevIdx = fromMaybe maxBound . predIdx++moreIdx :: (Eq a, Enum a, Bounded a) => a -> a+moreIdx = fromMaybe maxBound . succIdx++lessIdx :: (Eq a, Enum a, Bounded a) => a -> a+lessIdx = fromMaybe minBound . predIdx++succIdx :: (Eq a, Enum a, Bounded a) => a -> Maybe a+succIdx x | x == maxBound = Nothing+          | otherwise = Just $ succ x++predIdx :: (Eq a, Enum a, Bounded a) => a -> Maybe a+predIdx x | x == minBound = Nothing+          | otherwise = Just $ pred x++mealyState+   :: (HiddenClockResetEnable dom, NFDataX s)+   => (i -> State s o) -> s -> (Signal dom i -> Signal dom o)+mealyState f = mealy step+  where+    step s x = let (y, s') = runState (f x) s in (s', y)++mealyStateB+    :: (HiddenClockResetEnable dom, NFDataX s, Bundle i, Bundle o)+    => (i -> State s o) -> s -> (Unbundled dom i -> Unbundled dom o)+mealyStateB f s0 = unbundle . mealyState f s0 . bundle++mooreState+    :: (HiddenClockResetEnable dom, NFDataX s)+    => (i -> State s ()) -> (s -> o) -> s -> (Signal dom i -> Signal dom o)+mooreState step = moore step'+  where+    step' s x = execState (step x) s++mooreStateB+    :: (HiddenClockResetEnable dom, NFDataX s, Bundle i, Bundle o)+    => (i -> State s ()) -> (s -> o) -> s -> (Unbundled dom i -> Unbundled dom o)+mooreStateB step out s0 = unbundle . mooreState step out s0 . bundle++enable :: (Applicative f) => f Bool -> f a -> f (Maybe a)+enable en x = mux en (Just <$> x) (pure Nothing)++guardA :: (Applicative f, Alternative m) => f Bool -> f (m a) -> f (m a)+guardA en x = mux en x (pure empty)++packWrite :: addr -> Maybe val -> Maybe (addr, val)+packWrite addr val = (addr,) <$> val++withWrite :: (Applicative f) => f (Maybe addr) -> f (Maybe wr) -> f (Maybe (addr, Maybe wr))+withWrite = liftA2 $ \addr wr -> (,wr) <$> addr++noWrite :: (Applicative f) => f (Maybe addr) -> f (Maybe (addr, Maybe wr))+noWrite addr = addr `withWrite` pure Nothing++singlePort :: (Applicative f) => (f addr -> f (Maybe (addr, wr)) -> r) -> (f addr -> f (Maybe wr) -> r)+singlePort mem addr wr = mem addr (packWrite <$> addr <*> wr)++unbraid+    :: (KnownNat n, KnownNat k, 1 <= n, 1 <= (n * 2 ^ k), (CLog 2 (2 ^ k)) ~ k, (CLog 2 (n * 2 ^ k)) ~ (CLog 2 n + k))+    => Maybe (Index (n * 2 ^ k))+    -> Vec (2 ^ k) (Maybe (Index n))+unbraid Nothing = repeat Nothing+unbraid (Just addr) = map (\k -> addr' <$ guard (sel == k)) indicesI+  where+    (addr', sel) = bitCoerce addr++muxA :: (Foldable t, Alternative m, Applicative f) => t (f (m a)) -> f (m a)+muxA = fmap getAlt . getAp . F.foldMap (Ap . fmap Alt)++infixl 3 .<|>.+(.<|>.) :: (Applicative f, Alternative m) => f (m a) -> f (m a) -> f (m a)+(.<|>.) = liftA2 (<|>)++infix 2 .<|., .<|, |>., .|>.++(.<|.) :: (Applicative f) => f (Maybe a) -> f a -> f a+(.<|.) = flip (.|>.)++(.<|) :: (Applicative f) => f (Maybe a) -> a -> f a+(.<|) = flip (|>.)++(.|>.) :: (Applicative f) => f a -> f (Maybe a) -> f a+(.|>.) = muxMaybe++(|>.) :: (Applicative f) => a -> f (Maybe a) -> f a+x |>. fmx = fromMaybe x <$> fmx++muxMaybe :: (Applicative f) => f a -> f (Maybe a) -> f a+muxMaybe = liftA2 fromMaybe++withStart :: (HiddenClockResetEnable dom) => a -> Signal dom a -> Signal dom a+withStart x0 = mux (register True $ pure False) (pure x0)++bitwise :: (BitPack a) => (BitVector (BitSize a) -> BitVector (BitSize a)) -> (a -> a)+bitwise f = unpack . f . pack++parity :: forall a n. (BitPack a, BitSize a ~ (n + 1)) => a -> Bit+parity = fold xor . bitCoerce @_ @(Vec (BitSize a) Bit)++half :: (Bits a) => a -> a+half x = x `shiftR` 1++halfIndex+    :: (KnownNat n, 1 <= (2 * n), (CLog 2 (2 * n)) ~ (CLog 2 n + 1))+    => Index (2 * n)+    -> Index n+halfIndex = fst . bitCoerce @_ @(_, Bit)++bvShiftL :: (KnownNat n) => BitVector n -> Bit -> (Bit, BitVector n)+bvShiftL xs x = bitCoerce (xs, x)++bvShiftR :: (KnownNat n) => Bit -> BitVector n -> (BitVector n, Bit)+bvShiftR x xs = bitCoerce (x, xs)++riseEveryWhen+    :: forall n dom. (HiddenClockResetEnable dom, KnownNat n)+    => SNat n -> Signal dom Bool -> Signal dom Bool+riseEveryWhen n trigger = isRising False $ cnt .==. pure maxBound+  where+    cnt = regEn (0 :: Index n) trigger (nextIdx <$> cnt)++oscillateWhen+    :: (HiddenClockResetEnable dom)+    => Bool -> Signal dom Bool -> Signal dom Bool+oscillateWhen init trigger = r+  where+    r = regEn init trigger $ not <$> r++shifterL+    :: (BitPack a, HiddenClockResetEnable dom)+    => Signal dom (Maybe a)+    -> Signal dom Bool+    -> Signal dom Bit+shifterL load tick = msb <$> next+  where+    r = register 0 next++    next = muxA+        [ fmap pack <$> load+        , enable tick $ (`shiftL` 1) <$> r+        ] .<|.+        r++shifterR+    :: (BitPack a, HiddenClockResetEnable dom)+    => Signal dom (Maybe a)+    -> Signal dom Bool+    -> Signal dom Bit+shifterR load tick = lsb <$> next+  where+    r = register 0 next++    next = muxA+        [ fmap pack <$> load+        , enable tick $ (`shiftR` 1) <$> r+        ] .<|.+        r
+ src/RetroClash/VGA.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE ScopedTypeVariables, NumericUnderscores, PartialTypeSignatures #-}+{-# LANGUAGE DuplicateRecordFields, RecordWildCards, ApplicativeDo #-}+{-# LANGUAGE ExistentialQuantification, StandaloneDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}+module RetroClash.VGA+    ( VGASync(..)+    , VGADriver(..)+    , vgaDriver+    , VGAOut(..)+    , vgaOut+    , VGATiming(..), VGATimings(..)++    , vga640x480at60+    , vga800x600at60+    , vga800x600at72+    , vga1024x768at60+    ) where++import Clash.Prelude+import RetroClash.Clock+import RetroClash.Utils+import Data.Maybe (isJust)++data VGASync dom = VGASync+    { vgaHSync :: "HSYNC" ::: Signal dom Bit+    , vgaVSync :: "VSYNC" ::: Signal dom Bit+    , vgaDE :: "DE" ::: Signal dom Bool+    }++data VGAOut dom r g b = VGAOut+    { vgaSync  :: VGASync dom+    , vgaR     :: "RED" ::: Signal dom (Unsigned r)+    , vgaG     :: "GREEN" ::: Signal dom (Unsigned g)+    , vgaB     :: "BLUE" ::: Signal dom (Unsigned b)+    }++data VGADriver dom w h = VGADriver+    { vgaSync :: VGASync dom+    , vgaX :: Signal dom (Maybe (Index w))+    , vgaY :: Signal dom (Maybe (Index h))+    }++data VGATiming (visible :: Nat) = forall front pulse back. VGATiming+    { polarity :: Polarity+    , preWidth :: SNat front+    , pulseWidth :: SNat pulse+    , postWidth :: SNat back+    }+deriving instance Show (VGATiming vis)++data VGATimings (ps :: Nat) (w :: Nat) (h :: Nat) = VGATimings+    { vgaHorizTiming :: VGATiming w+    , vgaVertTiming :: VGATiming h+    }+    deriving (Show)++data VGAState visible front pulse back+    = Visible (Index visible)+    | FrontPorch (Index front)+    | SyncPulse (Index pulse)+    | BackPorch (Index back)+    deriving (Show, Generic, NFDataX)++visible :: VGAState visible front pulse back -> Maybe (Index visible)+visible (Visible coord) = Just coord+visible _ = Nothing++sync :: VGAState visible front pulse back -> Bool+sync SyncPulse{} = True+sync _ = False++end :: (KnownNat back) => VGAState visible front pulse back -> Bool+end (BackPorch cnt) | cnt == maxBound = True+end _ = False++type Step a = a -> a++data VGACounter visible+    = forall front pulse back. (KnownNat front, KnownNat pulse, KnownNat back)+    => VGACounter (Step (VGAState visible front pulse back))++mkVGACounter+    :: SNat front -> SNat pulse -> SNat back+    -> Step (VGAState visible front pulse back)+    -> VGACounter visible+mkVGACounter SNat SNat SNat = VGACounter++vgaCounter :: (KnownNat visible) => VGATiming visible -> VGACounter visible+vgaCounter (VGATiming _ front@SNat pulse@SNat back@SNat) =+    mkVGACounter front pulse back $ \case+        Visible cnt    -> count Visible    FrontPorch cnt+        FrontPorch cnt -> count FrontPorch SyncPulse  cnt+        SyncPulse cnt  -> count SyncPulse  BackPorch  cnt+        BackPorch cnt  -> count BackPorch  Visible    cnt+  where+    count :: (KnownNat n, KnownNat m) => (Index n -> a) -> (Index m -> a) -> Index n -> a+    count this next = maybe (next 0) this . succIdx++vgaDriver+    :: (HiddenClockResetEnable dom, KnownNat w, KnownNat h)+    => (DomainPeriod dom ~ ps)+    => VGATimings ps w h+    -> VGADriver dom w h+vgaDriver VGATimings{..} = case (vgaCounter vgaHorizTiming, vgaCounter vgaVertTiming) of+    (VGACounter nextH, VGACounter nextV) -> VGADriver{ vgaSync = VGASync{..}, .. }+      where+        stateH = register (Visible 0) $ nextH <$> stateH+        stateV = regEn (Visible 0) endLine $ nextV <$> stateV++        vgaX = visible <$> stateH+        vgaHSync = toActiveDyn (polarity vgaHorizTiming) . sync <$> stateH+        endLine = end <$> stateH++        vgaY = visible <$> stateV+        vgaVSync = toActiveDyn (polarity vgaVertTiming) . sync <$> stateV++        vgaDE = isJust <$> vgaX .&&. isJust <$> vgaY+++vgaOut+    :: (HiddenClockResetEnable dom, KnownNat r, KnownNat g, KnownNat b)+    => VGASync dom+    -> Signal dom (Unsigned r, Unsigned g, Unsigned b)+    -> VGAOut dom r g b+vgaOut vgaSync@VGASync{..} rgb = VGAOut{..}+  where+    (vgaR, vgaG, vgaB) = unbundle $ blank rgb++    blank = mux (not <$> vgaDE) (pure (0, 0, 0))++-- | VGA 640*480@60Hz, 25.175 MHz pixel clock+vga640x480at60 :: VGATimings (HzToPeriod 25_175_000) 640 480+vga640x480at60 = VGATimings+    { vgaHorizTiming = VGATiming Low (SNat @16) (SNat @96) (SNat @48)+    , vgaVertTiming  = VGATiming Low (SNat @11) (SNat @2)  (SNat @31)+    }++-- | VGA 800x600@72Hz, 50 MHz pixel clock+vga800x600at72 :: VGATimings (HzToPeriod 50_000_000) 800 600+vga800x600at72 = VGATimings+    { vgaHorizTiming = VGATiming High (SNat @56) (SNat @120) (SNat @64)+    , vgaVertTiming  = VGATiming High (SNat @37) (SNat @6)   (SNat @23)+    }++-- | VGA 800x600@60Hz, 40 MHz pixel clock+vga800x600at60 :: VGATimings (HzToPeriod 40_000_000) 800 600+vga800x600at60 = VGATimings+    { vgaHorizTiming = VGATiming High (SNat @40) (SNat @128) (SNat @88)+    , vgaVertTiming  = VGATiming High (SNat @1)  (SNat @4)   (SNat @23)+    }++-- | VGA 1024*768@60Hz, 65 MHz pixel clock+vga1024x768at60 :: VGATimings (HzToPeriod 65_000_000) 1024 768+vga1024x768at60 = VGATimings+    { vgaHorizTiming = VGATiming Low (SNat @24) (SNat @136) (SNat @160)+    , vgaVertTiming  = VGATiming Low (SNat @3)  (SNat @6)   (SNat @29)+    }
+ src/RetroClash/Video.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE ScopedTypeVariables #-}+module RetroClash.Video+    ( maskStart, maskEnd, maskSides+    , center+    , scale+    , withBorder+    ) where++import Clash.Prelude+import RetroClash.Utils+import Data.Maybe++maskStart+    :: forall k n dom. (KnownNat n, KnownNat k)+    => (HiddenClockResetEnable dom)+    => Signal dom (Maybe (Index (k + n)))+    -> Signal dom (Maybe (Index n))+maskStart = maskSides (SNat @k)++maskEnd+    :: forall k n dom. (KnownNat n, KnownNat k)+    => (HiddenClockResetEnable dom)+    => Signal dom (Maybe (Index (n + k)))+    -> Signal dom (Maybe (Index n))+maskEnd = maskSides (SNat @0)++center+    :: forall n n0 k m dom. (KnownNat n, KnownNat n0, KnownNat k, KnownNat m)+    => (k ~ ((n0 - n) `Div` 2), n0 ~ (k + n + m))+    => (HiddenClockResetEnable dom)+    => Signal dom (Maybe (Index n0))+    -> Signal dom (Maybe (Index n))+center = maskSides (SNat @k)++maskSides+    :: (KnownNat n, KnownNat m, KnownNat k)+    => (HiddenClockResetEnable dom)+    => SNat k+    -> Signal dom (Maybe (Index (k + n + m)))+    -> Signal dom (Maybe (Index n))+maskSides k raw = transformed+  where+    changed = register Nothing raw ./=. raw+    started = raw .== Just (snatToNum k)++    r = register Nothing transformed+    transformed =+        mux (not <$> changed) r $+        mux (isNothing <$> raw) (pure Nothing) $+        mux started (pure $ Just 0) $+        (succIdx =<<) <$> r++scale+    :: forall n k dom. (KnownNat n, KnownNat k, 1 <= k)+    => (HiddenClockResetEnable dom)+    => SNat k+    -> Signal dom (Maybe (Index (n * k)))+    -> (Signal dom (Maybe (Index n)), Signal dom (Maybe (Index k)))+scale k raw = (scaledNext, enable (isJust <$> scaledNext) counterNext)+  where+    prev = register Nothing raw+    changed = raw ./=. prev++    counter = register (0 :: Index k) counterNext+    counterNext =+        mux (not <$> changed) counter $+        mux (isNothing <$> prev) (pure 0) $+        nextIdx <$> counter++    scaled = register Nothing scaledNext+    scaledNext =+        mux (not <$> changed) scaled $+        mux (counterNext .== 0) (maybe (Just 0) succIdx <$> scaled) $+        scaled++withBorder+    :: (BitPack a, BitPack a', BitSize a' ~ BitSize a)+    => a+    -> (x -> y -> a')+    -> Maybe x -> Maybe y -> a+withBorder border draw x y = case (x, y) of+    (Just x, Just y) -> bitCoerce $ draw x y+    _ -> border