Describe RGB counter

bayeux.cabal

@@ -16,11 +16,13 @@ library
     exposed-modules:  Bayeux
                     , Bayeux.Cli
                     , Bayeux.Lp
+                    , Bayeux.RgbCounter
                     , Bayeux.Rtlil
                     , Bayeux.Tableaux
     build-depends:    base
                     , containers
                     , megaparsec
+                    , mtl
                     , parser-combinators
                     , prettyprinter
                     , text
@@ -54,6 +56,7 @@ test-suite test
     hs-source-dirs:   test
     main-is:          Main.hs
     other-modules:    Test.Bayeux.Lp
+                    , Test.Bayeux.RgbCounter
                     , Test.Bayeux.Rtlil
     build-depends:    base
                     , bayeux

src/Bayeux/RgbCounter.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
+
+module Bayeux.RgbCounter
+  ( prog
+  , compile
+  ) where
+
+import Bayeux.Rtlil
+import Control.Monad.Writer
+
+class Monad m => MonadRgb m where
+  ctr :: m SigSpec
+  at  :: SigSpec -> Integer -> m SigSpec
+  rgb :: SigSpec -> SigSpec -> SigSpec -> m (SigSpec, SigSpec, SigSpec)
+
+prog :: MonadRgb m => m (SigSpec, SigSpec, SigSpec)
+prog = do
+  c <- ctr
+  r <- c `at` 24
+  g <- c `at` 23
+  b <- c `at` 22
+  rgb r g b
+
+newtype Rgb a = Rgb{ unRgb :: Writer [ModuleBody] a }
+  deriving (Functor, Applicative, Monad, MonadWriter [ModuleBody])
+
+instance MonadRgb Rgb where
+  ctr = do
+    tell $ [ModuleBodyWire $ Wire [] $ WireStmt [WireOptionInput 1] "\\clk"] <> counter 32 "$my_counter" "\\unused"
+    return $ SigSpecWireId "\\$my_counter"
+
+  at sigSpec ix = do
+    tell
+      [ ModuleBodyWire $ Wire [] $ WireStmt [WireOptionWidth 1] n
+      , ModuleBodyConnStmt $ ConnStmt (SigSpecWireId n) (SigSpecSlice sigSpec ix Nothing)
+      ]
+    return $ SigSpecWireId n
+    where
+      n | ix == 24  = "\\pwm_r"
+        | ix == 23  = "\\pwm_g"
+        | otherwise = "\\pwm_b"
+
+  rgb r g b = do
+    tell [ ModuleBodyWire $ Wire [] $ WireStmt [WireOptionOutput 2] "\\red"
+         , ModuleBodyWire $ Wire [] $ WireStmt [WireOptionOutput 3] "\\green"
+         , ModuleBodyWire $ Wire [] $ WireStmt [WireOptionOutput 4] "\\blue"
+         , ModuleBodyCell sbRgbaDrv
+         ]
+    return ( SigSpecWireId "\\red"
+           , SigSpecWireId "\\green"
+           , SigSpecWireId "\\blue"
+           )
+
+compile :: Rgb (SigSpec, SigSpec, SigSpec) -> File
+compile = top . execWriter . unRgb
+

src/Bayeux/Rtlil.hs

@@ -75,7 +75,8 @@ module Bayeux.Rtlil
   , modC
   , divFloorC
   , modFloorC
-  , sbRgbaDrv
+  , -- *** Primitive cells
+    sbRgbaDrv
   , -- ** Processes
     Process(..)
   , ProcStmt(..)
@@ -106,7 +107,7 @@ import Data.Text (Text)
 import Prettyprinter
 
 newtype Ident = Ident Text
-  deriving (Eq, IsString, Pretty, Read, Show)
+  deriving (Eq, IsString, Pretty, Read, Semigroup, Monoid, Show)
 
 data Value = Value Integer [BinaryDigit]
   deriving (Eq, Read, Show)
@@ -246,7 +247,7 @@ counter
   -> Ident   -- ^ new
   -> [ModuleBody]
 counter w old new =
-  [ ModuleBodyWire $ Wire [] $ WireStmt [WireOptionWidth w] $ WireId old
+  [ ModuleBodyWire $ Wire [] $ WireStmt [WireOptionWidth w] $ WireId $ "\\" <> old
   , ModuleBodyWire $ Wire [] $ WireStmt [WireOptionWidth w] $ WireId new
   , ModuleBodyCell $ addC
       (CellId old)
@@ -255,20 +256,20 @@ counter w old new =
       False
       w
       w
-      (SigSpecWireId $ WireId old)
+      (SigSpecWireId $ WireId $ "\\" <> old)
       (SigSpecConstant $ ConstantInteger 1)
       (WireId new)
   , ModuleBodyProcess $ Process
       []
-      "\\procStmt"
+      "$procStmt"
       (ProcessBody
          []
          Nothing
          []
          [Sync
             (SyncStmt Posedge (SigSpecWireId "\\clk"))
             [UpdateStmt
-               (DestSigSpec $ SigSpecWireId $ WireId old)
+               (DestSigSpec $ SigSpecWireId $ WireId $ "\\" <> old)
                (SrcSigSpec  $ SigSpecWireId $ WireId new)
             ]
          ]

test/Main.hs

@@ -1,11 +1,13 @@
 module Main (main) where
 
 import qualified Test.Bayeux.Lp
+import qualified Test.Bayeux.RgbCounter
 import qualified Test.Bayeux.Rtlil
 import Test.Tasty
 
 main :: IO ()
 main = defaultMain $ testGroup "Test.Bayeux"
-  [ testGroup "Lp"    Test.Bayeux.Lp.tests
-  , testGroup "Rtlil" Test.Bayeux.Rtlil.tests
+  [ testGroup "Lp"         Test.Bayeux.Lp.tests
+  , testGroup "RgbCounter" Test.Bayeux.RgbCounter.tests
+  , testGroup "Rtlil"      Test.Bayeux.Rtlil.tests
   ]

test/Test/Bayeux/RgbCounter.hs

@@ -0,0 +1,47 @@
+module Test.Bayeux.RgbCounter
+  ( tests
+  ) where
+
+import Test.Tasty
+import Bayeux.RgbCounter
+import Bayeux.Rtlil
+import Data.String
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
+import Prettyprinter
+import Prettyprinter.Render.Text
+import System.Exit
+import System.FilePath
+import System.IO.Extra
+import System.Process
+import Test.Tasty
+import Test.Tasty.HUnit
+import Test.Tasty.Golden
+
+
+tests :: [TestTree]
+tests =
+  [ testGroup "pretty"
+      [ prettyTest "rgbcounter" $ compile prog
+      ]
+  , testGroup "synth"
+      [ synthTest "rgbcounter" $ compile prog
+      ]
+  ]
+
+prettyTest :: Pretty a => TestName -> a -> TestTree
+prettyTest n = goldenVsString n (curDir </> n <.> "pretty")
+                 . return . fromString . T.unpack . render . pretty
+
+synthTest :: TestName -> File -> TestTree
+synthTest n rtl = testCase n $ withTempFile $ \t -> do
+  TIO.writeFile t $ render $ pretty rtl
+  let c = "yosys -q -p \"synth_ice40\" -f rtlil " <> t
+  (ExitSuccess @=?) =<< waitForProcess =<< spawnCommand c
+
+curDir :: FilePath
+curDir = "test" </> "Test" </> "Bayeux" </> "RgbCounter" </> "golden"
+
+render :: Doc ann -> Text
+render = renderStrict . layoutSmart defaultLayoutOptions

test/Test/Bayeux/RgbCounter/golden/rgbcounter.pretty

@@ -0,0 +1,71 @@
+autoidx 0
+
+module \top
+
+  wire input 1 \clk
+
+  wire width 32 \$my_counter
+
+  wire width 32 \unused
+
+  cell $add $my_counter
+
+    parameter \A_SIGNED 0
+    parameter \A_WIDTH 32
+    parameter \B_SIGNED 0
+    parameter \B_WIDTH 32
+    parameter \Y_WIDTH 32
+    connect \A \$my_counter
+    connect \B 1
+    connect \Y \unused
+
+  end
+
+  process $procStmt
+
+
+
+
+    sync posedge \clk
+
+      update \$my_counter \unused
+
+  end
+
+  wire width 1 \pwm_r
+
+  connect \pwm_r \$my_counter [24]
+
+  wire width 1 \pwm_g
+
+  connect \pwm_g \$my_counter [23]
+
+  wire width 1 \pwm_b
+
+  connect \pwm_b \$my_counter [22]
+
+  wire output 2 \red
+
+  wire output 3 \green
+
+  wire output 4 \blue
+
+  attribute \module_not_derived 1
+  cell \SB_RGBA_DRV \RGBA_DRIVER
+
+    parameter \CURRENT_MODE "0b1"
+    parameter \RGB0_CURRENT "0b111111"
+    parameter \RGB1_CURRENT "0b111111"
+    parameter \RGB2_CURRENT "0b111111"
+    connect \CURREN 1'1
+    connect \RGB0 \red
+    connect \RGB0PWM \pwm_r
+    connect \RGB1 \green
+    connect \RGB1PWM \pwm_g
+    connect \RGB2 \blue
+    connect \RGB2PWM \pwm_b
+    connect \RGBLEDEN 1'1
+
+  end
+
+end

test/Test/Bayeux/Rtlil/pretty-counter.golden

@@ -1,4 +1,4 @@
-[ wire width 8 \old
+[ wire width 8 \\old
 
 , wire width 8 \new
 
@@ -9,20 +9,20 @@
   parameter \B_SIGNED 0
   parameter \B_WIDTH 8
   parameter \Y_WIDTH 8
-  connect \A \old
+  connect \A \\old
   connect \B 1
   connect \Y \new
 
 end
 
-, process \procStmt
+, process $procStmt
 
 
 
 
   sync posedge \clk
 
-    update \old \new
+    update \\old \new
 
 end
  ]