{-|
Copyright  :  (C) 2018, Google Inc.
                  2019, Myrtle Software Ltd
License    :  BSD2 (see the file LICENSE)
Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>

Utilities for tracing signals and dumping them in various ways. Example usage:

@
import Clash.Prelude hiding (writeFile)
import Data.Text.IO  (writeFile)

-- | Count and wrap around
subCounter :: SystemClockResetEnable => Signal System (Index 3)
subCounter = traceSignal1 "sub" counter
  where
    counter =
      register 0 (fmap succ' counter)

    succ' c
      | c == maxBound = 0
      | otherwise     = c + 1

-- | Count, but only when my subcounter is wrapping around
mainCounter :: SystemClockResetEnable => Signal System (Signed 64)
mainCounter = traceSignal1 "main" counter
  where
    counter =
      register 0 (fmap succ' $ bundle (subCounter,counter))

    succ' (sc, c)
      | sc == maxBound = c + 1
      | otherwise      = c

-- | Collect traces, and dump them to a VCD file.
main :: IO ()
main = do
  let cntrOut = exposeClockResetEnable mainCounter systemClockGen systemResetGen enableGen
  vcd <- dumpVCD (0, 100) cntrOut ["main", "sub"]
  case vcd of
    Left msg ->
      error msg
    Right contents ->
      writeFile "mainCounter.vcd" contents
@
-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE MagicHash           #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}
{-# LANGUAGE ViewPatterns        #-}

{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise       #-}

module Clash.Signal.Trace
  (
  -- * Tracing functions
  -- ** Simple
    traceSignal1
  , traceVecSignal1
  -- ** Tracing in a multi-clock environment
  , traceSignal
  , traceVecSignal

  -- * VCD dump functions
  , dumpVCD

  -- * Replay functions
  , dumpReplayable
  , replay

  -- * Internal
  -- ** Types
  , Period
  , Changed
  , Value
  , Width
  , TraceMap
  -- ** Functions
  , traceSignal#
  , traceVecSignal#
  , dumpVCD#
  , dumpVCD##
  , waitForTraces#
  , traceMap#
  ) where

-- Clash:
import           Clash.Signal.Internal (fromList)
import           Clash.Signal
  (KnownDomain(..), SDomainConfiguration(..), Signal, bundle, unbundle)
import           Clash.Sized.Vector    (Vec, iterateI)
import qualified Clash.Sized.Vector    as Vector
import           Clash.Class.BitPack   (BitPack, BitSize, pack, unpack)
import           Clash.Promoted.Nat    (snatToNum, SNat(..))
import           Clash.Signal.Internal (sample)
import           Clash.XException      (deepseqX, NFDataX)
import           Clash.Sized.Internal.BitVector
  (BitVector(BV))

-- Haskell / GHC:
import           Control.Monad         (foldM)
import           Data.Bits             (testBit)
import           Data.Binary           (encode, decodeOrFail)
import           Data.ByteString.Lazy  (ByteString)
import qualified Data.ByteString.Lazy  as ByteStringLazy
import           Data.Char             (ord, chr)
import           Data.IORef
  (IORef, atomicModifyIORef', atomicWriteIORef, newIORef, readIORef)
import           Data.List             (foldl1', foldl', unzip4, transpose)
import qualified Data.Map.Strict       as Map
import           Data.Maybe            (fromMaybe, catMaybes)
import qualified Data.Text             as Text
import           Data.Time.Clock       (UTCTime, getCurrentTime)
import           Data.Time.Format      (formatTime, defaultTimeLocale)
import           GHC.Stack             (HasCallStack)
import           GHC.TypeLits          (KnownNat, type (+))
import           System.IO.Unsafe      (unsafePerformIO)
import           Type.Reflection       (Typeable, TypeRep, typeRep)

#ifdef CABAL
import qualified Data.Version
import qualified Paths_clash_prelude
#endif

type Period   = Int
type Changed  = Bool
type Value    = (Integer, Integer) -- (Mask, Value)
type Width    = Int

-- | Serialized TypeRep we need to store for dumpReplayable / replay
type TypeRepBS = ByteString

type TraceMap  = Map.Map String (TypeRepBS, Period, Width, [Value])

-- | Map of traces used by the non-internal trace and dumpvcd functions.
traceMap# :: IORef TraceMap
traceMap# :: IORef TraceMap
traceMap# = IO (IORef TraceMap) -> IORef TraceMap
forall a. IO a -> a
unsafePerformIO (TraceMap -> IO (IORef TraceMap)
forall a. a -> IO (IORef a)
newIORef TraceMap
forall k a. Map k a
Map.empty)
{-# NOINLINE traceMap# #-}

mkTrace
  :: HasCallStack
  => KnownNat (BitSize a)
  => BitPack a
  => NFDataX a
  => Signal dom a
  -> [Value]
mkTrace :: Signal dom a -> [Value]
mkTrace signal :: Signal dom a
signal = Signal dom Value -> [Value]
forall (f :: * -> *) a. (Foldable f, NFDataX a) => f a -> [a]
sample (BitVector (BitSize a) -> Value
forall (n :: Nat). BitVector n -> Value
unsafeToTup (BitVector (BitSize a) -> Value)
-> (a -> BitVector (BitSize a)) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> BitVector (BitSize a)
forall a. BitPack a => a -> BitVector (BitSize a)
pack (a -> Value) -> Signal dom a -> Signal dom Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom a
signal)
 where
  unsafeToTup :: BitVector n -> Value
unsafeToTup (BV mask :: Integer
mask value :: Integer
value) = (Integer
mask, Integer
value)

-- | Trace a single signal. Will emit an error if a signal with the same name
-- was previously registered.
traceSignal#
  :: forall dom a
   . ( KnownNat (BitSize a)
     , BitPack a
     , NFDataX a
     , Typeable a )
  => IORef TraceMap
  -- ^ Map to store the trace
  -> Int
  -- ^ The associated clock period for the trace
  -> String
  -- ^ Name of signal in the VCD output
  -> Signal dom a
  -- ^ Signal to trace
  -> IO (Signal dom a)
traceSignal# :: IORef TraceMap
-> Int -> String -> Signal dom a -> IO (Signal dom a)
traceSignal# traceMap :: IORef TraceMap
traceMap period :: Int
period traceName :: String
traceName signal :: Signal dom a
signal =
  IORef TraceMap
-> (TraceMap -> (TraceMap, Signal dom a)) -> IO (Signal dom a)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef TraceMap
traceMap ((TraceMap -> (TraceMap, Signal dom a)) -> IO (Signal dom a))
-> (TraceMap -> (TraceMap, Signal dom a)) -> IO (Signal dom a)
forall a b. (a -> b) -> a -> b
$ \m :: TraceMap
m ->
    if String -> TraceMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member String
traceName TraceMap
m then
      String -> (TraceMap, Signal dom a)
forall a. HasCallStack => String -> a
error (String -> (TraceMap, Signal dom a))
-> String -> (TraceMap, Signal dom a)
forall a b. (a -> b) -> a -> b
$ "Already tracing a signal with the name: '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
traceName String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'."
    else
      ( String -> (ByteString, Int, Int, [Value]) -> TraceMap -> TraceMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
          String
traceName
          ( TypeRep a -> ByteString
forall a. Binary a => a -> ByteString
encode (Typeable a => TypeRep a
forall k (a :: k). Typeable a => TypeRep a
typeRep @a)
          , Int
period
          , Int
width
          , Signal dom a -> [Value]
forall a (dom :: Domain).
(HasCallStack, KnownNat (BitSize a), BitPack a, NFDataX a) =>
Signal dom a -> [Value]
mkTrace Signal dom a
signal)
          TraceMap
m
      , Signal dom a
signal)
 where
  width :: Int
width = SNat (BitSize a) -> Int
forall a (n :: Nat). Num a => SNat n -> a
snatToNum (KnownNat (BitSize a) => SNat (BitSize a)
forall (n :: Nat). KnownNat n => SNat n
SNat @ (BitSize a))
{-# NOINLINE traceSignal# #-}

-- | Trace a single vector signal: each element in the vector will show up as
-- a different trace. If the trace name already exists, this function will emit
-- an error.
traceVecSignal#
  :: forall dom n a
   . ( KnownNat (BitSize a)
     , KnownNat n
     , BitPack a
     , NFDataX a
     , Typeable a )
  => IORef TraceMap
  -- ^ Map to store the traces
  -> Int
  -- ^ Associated clock period for the trace
  -> String
  -- ^ Name of signal in the VCD output. Will be appended by _0, _1, ..., _n.
  -> Signal dom (Vec (n+1) a)
  -- ^ Signal to trace
  -> IO (Signal dom (Vec (n+1) a))
traceVecSignal# :: IORef TraceMap
-> Int
-> String
-> Signal dom (Vec (n + 1) a)
-> IO (Signal dom (Vec (n + 1) a))
traceVecSignal# traceMap :: IORef TraceMap
traceMap period :: Int
period vecTraceName :: String
vecTraceName (Signal dom (Vec (n + 1) a) -> Unbundled dom (Vec (n + 1) a)
forall a (dom :: Domain).
Bundle a =>
Signal dom a -> Unbundled dom a
unbundle -> Unbundled dom (Vec (n + 1) a)
vecSignal) =
  (Vec (n + 1) (Signal dom a) -> Signal dom (Vec (n + 1) a))
-> IO (Vec (n + 1) (Signal dom a))
-> IO (Signal dom (Vec (n + 1) a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Vec (n + 1) (Signal dom a) -> Signal dom (Vec (n + 1) a)
forall a (dom :: Domain).
Bundle a =>
Unbundled dom a -> Signal dom a
bundle (IO (Vec (n + 1) (Signal dom a))
 -> IO (Signal dom (Vec (n + 1) a)))
-> (Vec (n + 1) (IO (Signal dom a))
    -> IO (Vec (n + 1) (Signal dom a)))
-> Vec (n + 1) (IO (Signal dom a))
-> IO (Signal dom (Vec (n + 1) a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vec (n + 1) (IO (Signal dom a)) -> IO (Vec (n + 1) (Signal dom a))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (Vec (n + 1) (IO (Signal dom a))
 -> IO (Signal dom (Vec (n + 1) a)))
-> Vec (n + 1) (IO (Signal dom a))
-> IO (Signal dom (Vec (n + 1) a))
forall a b. (a -> b) -> a -> b
$
    (Int -> Signal dom a -> IO (Signal dom a))
-> Vec (n + 1) Int
-> Vec (n + 1) (Signal dom a)
-> Vec (n + 1) (IO (Signal dom a))
forall a b c (n :: Nat).
(a -> b -> c) -> Vec n a -> Vec n b -> Vec n c
Vector.zipWith Int -> Signal dom a -> IO (Signal dom a)
trace' ((Int -> Int) -> Int -> Vec (n + 1) Int
forall (n :: Nat) a. KnownNat n => (a -> a) -> a -> Vec n a
iterateI Int -> Int
forall a. Enum a => a -> a
succ (0 :: Int)) Vec (n + 1) (Signal dom a)
Unbundled dom (Vec (n + 1) a)
vecSignal
 where
  trace' :: Int -> Signal dom a -> IO (Signal dom a)
trace' i :: Int
i s :: Signal dom a
s = IORef TraceMap
-> Int -> String -> Signal dom a -> IO (Signal dom a)
forall (dom :: Domain) a.
(KnownNat (BitSize a), BitPack a, NFDataX a, Typeable a) =>
IORef TraceMap
-> Int -> String -> Signal dom a -> IO (Signal dom a)
traceSignal# IORef TraceMap
traceMap Int
period (Int -> String
name' Int
i) Signal dom a
s
  name' :: Int -> String
name' i :: Int
i    = String
vecTraceName String -> String -> String
forall a. [a] -> [a] -> [a]
++ "_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
{-# NOINLINE traceVecSignal# #-}

-- | Trace a single signal. Will emit an error if a signal with the same name
-- was previously registered.
--
-- __NB__ Works correctly when creating VCD files from traced signal in
-- multi-clock circuits. However 'traceSignal1' might be more convenient to
-- use when the domain of your circuit is polymorphic.
traceSignal
  :: forall dom  a
   . ( KnownDomain dom
     , KnownNat (BitSize a)
     , BitPack a
     , NFDataX a
     , Typeable a )
  => String
  -- ^ Name of signal in the VCD output
  -> Signal dom a
  -- ^ Signal to trace
  -> Signal dom a
traceSignal :: String -> Signal dom a -> Signal dom a
traceSignal traceName :: String
traceName signal :: Signal dom a
signal =
  case KnownDomain dom => SDomainConfiguration dom (KnownConf dom)
forall (dom :: Domain).
KnownDomain dom =>
SDomainConfiguration dom (KnownConf dom)
knownDomain @dom of
    SDomainConfiguration _dom :: SSymbol dom
_dom period :: SNat period
period _edge :: SActiveEdge edge
_edge _reset :: SResetKind reset
_reset _init :: SInitBehavior init
_init _polarity :: SResetPolarity polarity
_polarity ->
      IO (Signal dom a) -> Signal dom a
forall a. IO a -> a
unsafePerformIO (IO (Signal dom a) -> Signal dom a)
-> IO (Signal dom a) -> Signal dom a
forall a b. (a -> b) -> a -> b
$
        IORef TraceMap
-> Int -> String -> Signal dom a -> IO (Signal dom a)
forall (dom :: Domain) a.
(KnownNat (BitSize a), BitPack a, NFDataX a, Typeable a) =>
IORef TraceMap
-> Int -> String -> Signal dom a -> IO (Signal dom a)
traceSignal# IORef TraceMap
traceMap# (SNat period -> Int
forall a (n :: Nat). Num a => SNat n -> a
snatToNum SNat period
period) String
traceName Signal dom a
signal
{-# NOINLINE traceSignal #-}

-- | Trace a single signal. Will emit an error if a signal with the same name
-- was previously registered.
--
-- __NB__ associates the traced signal with a clock period of /1/, which
-- results in incorrect VCD files when working with circuits that have
-- multiple clocks. Use 'traceSignal' when working with circuits that have
-- multiple clocks.
traceSignal1
  :: ( KnownNat (BitSize a)
     , BitPack a
     , NFDataX a
     , Typeable a )
  => String
  -- ^ Name of signal in the VCD output
  -> Signal dom a
  -- ^ Signal to trace
  -> Signal dom a
traceSignal1 :: String -> Signal dom a -> Signal dom a
traceSignal1 traceName :: String
traceName signal :: Signal dom a
signal =
  IO (Signal dom a) -> Signal dom a
forall a. IO a -> a
unsafePerformIO (IORef TraceMap
-> Int -> String -> Signal dom a -> IO (Signal dom a)
forall (dom :: Domain) a.
(KnownNat (BitSize a), BitPack a, NFDataX a, Typeable a) =>
IORef TraceMap
-> Int -> String -> Signal dom a -> IO (Signal dom a)
traceSignal# IORef TraceMap
traceMap# 1 String
traceName Signal dom a
signal)
{-# NOINLINE traceSignal1 #-}

-- | Trace a single vector signal: each element in the vector will show up as
-- a different trace. If the trace name already exists, this function will emit
-- an error.
--
-- __NB__ Works correctly when creating VCD files from traced signal in
-- multi-clock circuits. However 'traceSignal1' might be more convinient to
-- use when the domain of your circuit is polymorphic.
traceVecSignal
  :: forall dom a  n
   . ( KnownDomain dom
     , KnownNat (BitSize a)
     , KnownNat n
     , BitPack a
     , NFDataX a
     , Typeable a )
  => String
  -- ^ Name of signal in debugging output. Will be appended by _0, _1, ..., _n.
  -> Signal dom (Vec (n+1) a)
  -- ^ Signal to trace
  -> Signal dom (Vec (n+1) a)
traceVecSignal :: String -> Signal dom (Vec (n + 1) a) -> Signal dom (Vec (n + 1) a)
traceVecSignal traceName :: String
traceName signal :: Signal dom (Vec (n + 1) a)
signal =
  case KnownDomain dom => SDomainConfiguration dom (KnownConf dom)
forall (dom :: Domain).
KnownDomain dom =>
SDomainConfiguration dom (KnownConf dom)
knownDomain @dom of
    SDomainConfiguration _dom :: SSymbol dom
_dom period :: SNat period
period _edge :: SActiveEdge edge
_edge _reset :: SResetKind reset
_reset _init :: SInitBehavior init
_init _polarity :: SResetPolarity polarity
_polarity ->
      IO (Signal dom (Vec (n + 1) a)) -> Signal dom (Vec (n + 1) a)
forall a. IO a -> a
unsafePerformIO (IO (Signal dom (Vec (n + 1) a)) -> Signal dom (Vec (n + 1) a))
-> IO (Signal dom (Vec (n + 1) a)) -> Signal dom (Vec (n + 1) a)
forall a b. (a -> b) -> a -> b
$
        IORef TraceMap
-> Int
-> String
-> Signal dom (Vec (n + 1) a)
-> IO (Signal dom (Vec (n + 1) a))
forall (dom :: Domain) (n :: Nat) a.
(KnownNat (BitSize a), KnownNat n, BitPack a, NFDataX a,
 Typeable a) =>
IORef TraceMap
-> Int
-> String
-> Signal dom (Vec (n + 1) a)
-> IO (Signal dom (Vec (n + 1) a))
traceVecSignal# IORef TraceMap
traceMap# (SNat period -> Int
forall a (n :: Nat). Num a => SNat n -> a
snatToNum SNat period
period) String
traceName Signal dom (Vec (n + 1) a)
signal
{-# NOINLINE traceVecSignal #-}

-- | Trace a single vector signal: each element in the vector will show up as
-- a different trace. If the trace name already exists, this function will emit
-- an error.
--
-- __NB__ associates the traced signal with a clock period of /1/, which
-- results in incorrect VCD files when working with circuits that have
-- multiple clocks. Use 'traceSignal' when working with circuits that have
-- multiple clocks.
traceVecSignal1
  :: ( KnownNat (BitSize a)
     , KnownNat n
     , BitPack a
     , NFDataX a
     , Typeable a )
  => String
  -- ^ Name of signal in debugging output. Will be appended by _0, _1, ..., _n.
  -> Signal dom (Vec (n+1) a)
  -- ^ Signal to trace
  -> Signal dom (Vec (n+1) a)
traceVecSignal1 :: String -> Signal dom (Vec (n + 1) a) -> Signal dom (Vec (n + 1) a)
traceVecSignal1 traceName :: String
traceName signal :: Signal dom (Vec (n + 1) a)
signal =
  IO (Signal dom (Vec (n + 1) a)) -> Signal dom (Vec (n + 1) a)
forall a. IO a -> a
unsafePerformIO (IO (Signal dom (Vec (n + 1) a)) -> Signal dom (Vec (n + 1) a))
-> IO (Signal dom (Vec (n + 1) a)) -> Signal dom (Vec (n + 1) a)
forall a b. (a -> b) -> a -> b
$ IORef TraceMap
-> Int
-> String
-> Signal dom (Vec (n + 1) a)
-> IO (Signal dom (Vec (n + 1) a))
forall (dom :: Domain) (n :: Nat) a.
(KnownNat (BitSize a), KnownNat n, BitPack a, NFDataX a,
 Typeable a) =>
IORef TraceMap
-> Int
-> String
-> Signal dom (Vec (n + 1) a)
-> IO (Signal dom (Vec (n + 1) a))
traceVecSignal# IORef TraceMap
traceMap# 1 String
traceName Signal dom (Vec (n + 1) a)
signal
{-# NOINLINE traceVecSignal1 #-}

iso8601Format :: UTCTime -> String
iso8601Format :: UTCTime -> String
iso8601Format = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale "%Y-%m-%dT%H:%M:%S"

toPeriodMap :: TraceMap -> Map.Map Period [(String, Width, [Value])]
toPeriodMap :: TraceMap -> Map Int [(String, Int, [Value])]
toPeriodMap m :: TraceMap
m = (Map Int [(String, Int, [Value])]
 -> (String, (ByteString, Int, Int, [Value]))
 -> Map Int [(String, Int, [Value])])
-> Map Int [(String, Int, [Value])]
-> [(String, (ByteString, Int, Int, [Value]))]
-> Map Int [(String, Int, [Value])]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map Int [(String, Int, [Value])]
-> (String, (ByteString, Int, Int, [Value]))
-> Map Int [(String, Int, [Value])]
forall k a b c a.
Ord k =>
Map k [(a, b, c)] -> (a, (a, k, b, c)) -> Map k [(a, b, c)]
go Map Int [(String, Int, [Value])]
forall k a. Map k a
Map.empty (TraceMap -> [(String, (ByteString, Int, Int, [Value]))]
forall k a. Map k a -> [(k, a)]
Map.assocs TraceMap
m)
  where
    go :: Map k [(a, b, c)] -> (a, (a, k, b, c)) -> Map k [(a, b, c)]
go periodMap :: Map k [(a, b, c)]
periodMap (traceName :: a
traceName, (_rep :: a
_rep, period :: k
period, width :: b
width, values :: c
values)) =
      (Maybe [(a, b, c)] -> Maybe [(a, b, c)])
-> k -> Map k [(a, b, c)] -> Map k [(a, b, c)]
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter ([(a, b, c)] -> Maybe [(a, b, c)]
forall a. a -> Maybe a
Just ([(a, b, c)] -> Maybe [(a, b, c)])
-> (Maybe [(a, b, c)] -> [(a, b, c)])
-> Maybe [(a, b, c)]
-> Maybe [(a, b, c)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [(a, b, c)] -> [(a, b, c)]
go') k
period Map k [(a, b, c)]
periodMap
        where
          go' :: Maybe [(a, b, c)] -> [(a, b, c)]
go' = ((a
traceName, b
width, c
values)(a, b, c) -> [(a, b, c)] -> [(a, b, c)]
forall a. a -> [a] -> [a]
:) ([(a, b, c)] -> [(a, b, c)])
-> (Maybe [(a, b, c)] -> [(a, b, c)])
-> Maybe [(a, b, c)]
-> [(a, b, c)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(a, b, c)] -> Maybe [(a, b, c)] -> [(a, b, c)]
forall a. a -> Maybe a -> a
fromMaybe [])

flattenMap :: Map.Map a [b] -> [(a, b)]
flattenMap :: Map a [b] -> [(a, b)]
flattenMap m :: Map a [b]
m = [[(a, b)]] -> [(a, b)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(a
a, b
b) | b
b <- [b]
bs] | (a :: a
a, bs :: [b]
bs) <- Map a [b] -> [(a, [b])]
forall k a. Map k a -> [(k, a)]
Map.assocs Map a [b]
m]

printable :: Char -> Bool
printable :: Char -> Bool
printable (Char -> Int
ord -> Int
c) = 33 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
c Bool -> Bool -> Bool
&& Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 126

-- | Same as @dumpVCD@, but supplied with a custom tracemap and a custom timestamp
dumpVCD##
  :: (Int, Int)
  -- ^ (offset, number of samples)
  -> TraceMap
  -> UTCTime
  -> Either String Text.Text
dumpVCD## :: (Int, Int) -> TraceMap -> UTCTime -> Either String Text
dumpVCD## (offset :: Int
offset, cycles :: Int
cycles) traceMap :: TraceMap
traceMap now :: UTCTime
now
  | Int
offset Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 =
      String -> Either String Text
forall a. HasCallStack => String -> a
error (String -> Either String Text) -> String -> Either String Text
forall a b. (a -> b) -> a -> b
$ "dumpVCD: offset was " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
offset String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", but cannot be negative."
  | Int
cycles Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 =
      String -> Either String Text
forall a. HasCallStack => String -> a
error (String -> Either String Text) -> String -> Either String Text
forall a b. (a -> b) -> a -> b
$ "dumpVCD: cycles was " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
cycles String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", but cannot be negative."
  | TraceMap -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null TraceMap
traceMap =
      String -> Either String Text
forall a. HasCallStack => String -> a
error (String -> Either String Text) -> String -> Either String Text
forall a b. (a -> b) -> a -> b
$ "dumpVCD: no traces found. Extend the given trace names."
  | TraceMap -> Int
forall k a. Map k a -> Int
Map.size TraceMap
traceMap Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 126 Int -> Int -> Int
forall a. Num a => a -> a -> a
- 33 =
      String -> Either String Text
forall a b. a -> Either a b
Left (String -> Either String Text) -> String -> Either String Text
forall a b. (a -> b) -> a -> b
$ "Tracemap contains more than 93 traces, which is not supported by VCD."
  | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ [String]
offensiveNames =
      String -> Either String Text
forall a b. a -> Either a b
Left (String -> Either String Text) -> String -> Either String Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [ "Trace '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. [a] -> a
head [String]
offensiveNames String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' contains"
                     , "non-printable ASCII characters, which is not"
                     , "supported by VCD." ]
  | Bool
otherwise =
      Text -> Either String Text
forall a b. b -> Either a b
Right (Text -> Either String Text) -> Text -> Either String Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unlines [ [Text] -> Text
Text.unwords [Text]
headerDate
                           , [Text] -> Text
Text.unwords [Text]
headerVersion
                           , [Text] -> Text
Text.unwords [Text]
headerComment
                           , String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String]
headerTimescale
                           , "$scope module logic $end"
                           , Text -> [Text] -> Text
Text.intercalate "\n" [Text]
headerWires
                           , "$upscope $end"
                           , "$enddefinitions $end"
                           , "#0"
                           , "$dumpvars"
                           , Text -> [Text] -> Text
Text.intercalate "\n" [Text]
initValues
                           , "$end"
                           , Text -> [Text] -> Text
Text.intercalate "\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Text]
bodyParts
                           ]
 where
  offensiveNames :: [String]
offensiveNames = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
printable)) [String]
traceNames

  labels :: String
labels = (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
chr [33..126]

  timescale :: Int
timescale = (Int -> Int -> Int) -> [Int] -> Int
forall a. (a -> a -> a) -> [a] -> a
foldl1' Int -> Int -> Int
forall a. Integral a => a -> a -> a
gcd (Map Int [(String, Int, [Value])] -> [Int]
forall k a. Map k a -> [k]
Map.keys Map Int [(String, Int, [Value])]
periodMap)
  periodMap :: Map Int [(String, Int, [Value])]
periodMap = TraceMap -> Map Int [(String, Int, [Value])]
toPeriodMap TraceMap
traceMap

  -- Normalize traces until they have the "same" period. That is, assume
  -- we have two traces; trace A with a period of 20 ps and trace B with
  -- a period of 40 ps:
  --
  --   A: [A1, A2, A3, ...]
  --   B: [B1, B2, B3, ...]
  --
  -- After normalization these look like:
  --
  --   A: [A1, A2, A3, A4, A5, A6, ...]
  --   B: [B1, B1, B2, B2, B3, B3, ...]
  --
  -- ..because B is "twice as slow" as A.
  (periods :: [Int]
periods, traceNames :: [String]
traceNames, widths :: [Int]
widths, valuess :: [[Value]]
valuess) =
    [(Int, String, Int, [Value])]
-> ([Int], [String], [Int], [[Value]])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 ([(Int, String, Int, [Value])]
 -> ([Int], [String], [Int], [[Value]]))
-> [(Int, String, Int, [Value])]
-> ([Int], [String], [Int], [[Value]])
forall a b. (a -> b) -> a -> b
$ ((Int, (String, Int, [Value])) -> (Int, String, Int, [Value]))
-> [(Int, (String, Int, [Value]))] -> [(Int, String, Int, [Value])]
forall a b. (a -> b) -> [a] -> [b]
map
      (\(a :: Int
a, (b :: String
b, c :: Int
c, d :: [Value]
d)) -> (Int
a, String
b, Int
c, [Value]
d))
      (Map Int [(String, Int, [Value])] -> [(Int, (String, Int, [Value]))]
forall a b. Map a [b] -> [(a, b)]
flattenMap Map Int [(String, Int, [Value])]
periodMap)

  periods' :: [Int]
periods' = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
timescale) [Int]
periods
  valuess' :: [[Value]]
valuess' = ([Value] -> [Value]) -> [[Value]] -> [[Value]]
forall a b. (a -> b) -> [a] -> [b]
map [Value] -> [Value]
slice ([[Value]] -> [[Value]]) -> [[Value]] -> [[Value]]
forall a b. (a -> b) -> a -> b
$ (Int -> [Value] -> [Value]) -> [Int] -> [[Value]] -> [[Value]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> [Value] -> [Value]
forall (t :: * -> *) b. Foldable t => Int -> t b -> [b]
normalize [Int]
periods' [[Value]]
valuess
  normalize :: Int -> t b -> [b]
normalize period :: Int
period values :: t b
values = (b -> [b]) -> t b -> [b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> b -> [b]
forall a. Int -> a -> [a]
replicate Int
period) t b
values
  slice :: [Value] -> [Value]
slice values :: [Value]
values = Int -> [Value] -> [Value]
forall a. Int -> [a] -> [a]
drop Int
offset ([Value] -> [Value]) -> [Value] -> [Value]
forall a b. (a -> b) -> a -> b
$ Int -> [Value] -> [Value]
forall a. Int -> [a] -> [a]
take Int
cycles [Value]
values

  headerDate :: [Text]
headerDate       = ["$date", String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ UTCTime -> String
iso8601Format UTCTime
now, "$end"]

#ifdef CABAL
  clashVer :: String
clashVer         = Version -> String
Data.Version.showVersion Version
Paths_clash_prelude.version
#else
  clashVer         = "development"
#endif
  headerVersion :: [Text]
headerVersion    = ["$version", "Generated by Clash", String -> Text
Text.pack String
clashVer , "$end"]
  headerComment :: [Text]
headerComment    = ["$comment", "No comment", "$end"]
  headerTimescale :: [String]
headerTimescale  = ["$timescale", (Int -> String
forall a. Show a => a -> String
show Int
timescale) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "ps", "$end"]
  headerWires :: [Text]
headerWires      = [ [Text] -> Text
Text.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String -> [Text]
forall a. Show a => a -> Char -> String -> [Text]
headerWire Int
w Char
l String
n
                     | (w :: Int
w, l :: Char
l, n :: String
n) <- ([Int] -> String -> [String] -> [(Int, Char, String)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int]
widths String
labels [String]
traceNames)]
  headerWire :: a -> Char -> String -> [Text]
headerWire w :: a
w l :: Char
l n :: String
n = (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
Text.pack ["$var wire", a -> String
forall a. Show a => a -> String
show a
w, [Char
l], String
n, "$end"]
  initValues :: [Text]
initValues       = (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
Text.pack ([String] -> [Text]) -> [String] -> [Text]
forall a b. (a -> b) -> a -> b
$ ((Value -> String) -> Value -> String)
-> [Value -> String] -> [Value] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Value -> String) -> Value -> String
forall a b. (a -> b) -> a -> b
($) [Value -> String]
formatters [Value]
inits

  formatters :: [Value -> String]
formatters = (Int -> Char -> Value -> String)
-> [Int] -> String -> [Value -> String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Char -> Value -> String
format [Int]
widths String
labels
  inits :: [Value]
inits = ([Value] -> Value) -> [[Value]] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map [Value] -> Value
forall a. [a] -> a
head [[Value]]
valuess'
  tails :: [[(Bool, Value)]]
tails = ([Value] -> [(Bool, Value)]) -> [[Value]] -> [[(Bool, Value)]]
forall a b. (a -> b) -> [a] -> [b]
map [Value] -> [(Bool, Value)]
changed [[Value]]
valuess'

  -- | Format single value according to VCD spec
  format :: Width -> Char -> Value -> String
  format :: Int -> Char -> Value -> String
format 1 label :: Char
label (0,0)   = ['0', Char
label, '\n']
  format 1 label :: Char
label (0,1)   = ['1', Char
label, '\n']
  format 1 label :: Char
label (1,_)   = ['x', Char
label, '\n']
  format 1 label :: Char
label (mask :: Integer
mask,val :: Integer
val) =
    String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ "Can't format 1 bit wide value for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
label String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
val String -> String -> String
forall a. [a] -> [a] -> [a]
++ " and mask " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
mask 
  format n :: Int
n label :: Char
label (mask :: Integer
mask,val :: Integer
val) =
    "b" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
digit ([Int] -> [Int]
forall a. [a] -> [a]
reverse [0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1]) String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
label]
    where
      digit :: Int -> Char
digit d :: Int
d = case (Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Integer
mask Int
d, Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Integer
val Int
d) of
        (False,False) -> '0'
        (False,True)  -> '1'
        (True,_)      -> 'x'

  -- | Given a list of values, return a list of list of bools indicating
  -- if a value changed. The first value is *not* included in the result.
  changed :: [Value] -> [(Changed, Value)]
  changed :: [Value] -> [(Bool, Value)]
changed (s :: Value
s:ss :: [Value]
ss) = [Bool] -> [Value] -> [(Bool, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Value -> Value -> Bool) -> [Value] -> [Value] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
(/=) (Value
sValue -> [Value] -> [Value]
forall a. a -> [a] -> [a]
:[Value]
ss) [Value]
ss) [Value]
ss
  changed []     = []

  bodyParts :: [Maybe Text.Text]
  bodyParts :: [Maybe Text]
bodyParts = (Int -> Maybe Text -> Maybe Text)
-> [Int] -> [Maybe Text] -> [Maybe Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Maybe Text -> Maybe Text
go [0..] (([(Bool, Value)] -> Maybe Text)
-> [[(Bool, Value)]] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map [(Bool, Value)] -> Maybe Text
bodyPart ([[(Bool, Value)]] -> [[(Bool, Value)]]
forall a. [[a]] -> [[a]]
Data.List.transpose [[(Bool, Value)]]
tails))
    where
      go :: Int -> Maybe Text.Text -> Maybe Text.Text
      go :: Int -> Maybe Text -> Maybe Text
go (String -> Text
Text.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show -> Text
n) t :: Maybe Text
t =
        let pre :: Text
pre = [Text] -> Text
Text.concat ["#", Text
n, "\n"] in
        (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text -> Text
Text.append Text
pre) Maybe Text
t

  bodyPart :: [(Changed, Value)] -> Maybe Text.Text
  bodyPart :: [(Bool, Value)] -> Maybe Text
bodyPart values :: [(Bool, Value)]
values =
    let formatted :: [(Bool, String)]
formatted  = [(Bool
c, Value -> String
f Value
v) | (f :: Value -> String
f, (c :: Bool
c,v :: Value
v)) <- [Value -> String]
-> [(Bool, Value)] -> [(Value -> String, (Bool, Value))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Value -> String]
formatters [(Bool, Value)]
values]
        formatted' :: [Text]
formatted' = ((Bool, String) -> Text) -> [(Bool, String)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
Text.pack (String -> Text)
-> ((Bool, String) -> String) -> (Bool, String) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, String) -> String
forall a b. (a, b) -> b
snd) ([(Bool, String)] -> [Text]) -> [(Bool, String)] -> [Text]
forall a b. (a -> b) -> a -> b
$ ((Bool, String) -> Bool) -> [(Bool, String)] -> [(Bool, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool, String) -> Bool
forall a b. (a, b) -> a
fst ([(Bool, String)] -> [(Bool, String)])
-> [(Bool, String)] -> [(Bool, String)]
forall a b. (a -> b) -> a -> b
$ [(Bool, String)]
formatted in
    if [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
formatted' then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
Text.intercalate "\n" [Text]
formatted'

-- | Same as @dumpVCD@, but supplied with a custom tracemap
dumpVCD#
  :: NFDataX a
  => IORef TraceMap
  -- ^ Map with collected traces
  -> (Int, Int)
  -- ^ (offset, number of samples)
  -> Signal dom a
  -- ^ (One of) the output(s) the circuit containing the traces
  -> [String]
  -- ^ The names of the traces you definitely want to be dumped to the VCD file
  -> IO (Either String Text.Text)
dumpVCD# :: IORef TraceMap
-> (Int, Int)
-> Signal dom a
-> [String]
-> IO (Either String Text)
dumpVCD# traceMap :: IORef TraceMap
traceMap slice :: (Int, Int)
slice signal :: Signal dom a
signal traceNames :: [String]
traceNames = do
  IORef TraceMap -> Signal dom a -> [String] -> IO ()
forall a (dom :: Domain).
NFDataX a =>
IORef TraceMap -> Signal dom a -> [String] -> IO ()
waitForTraces# IORef TraceMap
traceMap Signal dom a
signal [String]
traceNames
  TraceMap
m <- IORef TraceMap -> IO TraceMap
forall a. IORef a -> IO a
readIORef IORef TraceMap
traceMap
  (UTCTime -> Either String Text)
-> IO UTCTime -> IO (Either String Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int, Int) -> TraceMap -> UTCTime -> Either String Text
dumpVCD## (Int, Int)
slice TraceMap
m) IO UTCTime
getCurrentTime

-- | Produce a four-state VCD (Value Change Dump) according to IEEE
-- 1364-{1995,2001}. This function fails if a trace name contains either
-- non-printable or non-VCD characters.
--
-- Due to lazy evaluation, the created VCD files might not contain all the
-- traces you were expecting. You therefore have to provide a list of names
-- you definately want to be dumped in the VCD file.
--
-- For example:
--
-- @
-- vcd <- dumpVCD (0, 100) cntrOut ["main", "sub"]
-- @
--
-- Evaluates /cntrOut/ long enough in order for to guarantee that the @main@,
-- and @sub@ traces end up in the generated VCD file.
dumpVCD
  :: NFDataX a
  => (Int, Int)
  -- ^ (offset, number of samples)
  -> Signal dom a
  -- ^ (One of) the outputs of the circuit containing the traces
  -> [String]
  -- ^ The names of the traces you definitely want to be dumped in the VCD file
  -> IO (Either String Text.Text)
dumpVCD :: (Int, Int) -> Signal dom a -> [String] -> IO (Either String Text)
dumpVCD = IORef TraceMap
-> (Int, Int)
-> Signal dom a
-> [String]
-> IO (Either String Text)
forall a (dom :: Domain).
NFDataX a =>
IORef TraceMap
-> (Int, Int)
-> Signal dom a
-> [String]
-> IO (Either String Text)
dumpVCD# IORef TraceMap
traceMap#

-- | Dump a number of samples to a replayable bytestring.
dumpReplayable
  :: forall a dom
   . NFDataX a
  => Int
  -- ^ Number of samples
  -> Signal dom a
  -- ^ (One of) the outputs of the circuit containing the traces
  -> String
  -- ^ Name of trace to dump
  -> IO ByteString
dumpReplayable :: Int -> Signal dom a -> String -> IO ByteString
dumpReplayable n :: Int
n oSignal :: Signal dom a
oSignal traceName :: String
traceName = do
  IORef TraceMap -> Signal dom a -> [String] -> IO ()
forall a (dom :: Domain).
NFDataX a =>
IORef TraceMap -> Signal dom a -> [String] -> IO ()
waitForTraces# IORef TraceMap
traceMap# Signal dom a
oSignal [String
traceName]
  (ByteString, Int, Int, [Value])
replaySignal <- (TraceMap -> String -> (ByteString, Int, Int, [Value])
forall k a. Ord k => Map k a -> k -> a
Map.! String
traceName) (TraceMap -> (ByteString, Int, Int, [Value]))
-> IO TraceMap -> IO (ByteString, Int, Int, [Value])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef TraceMap -> IO TraceMap
forall a. IORef a -> IO a
readIORef IORef TraceMap
traceMap#
  let (tRep :: ByteString
tRep, _period :: Int
_period, _width :: Int
_width, samples :: [Value]
samples) = (ByteString, Int, Int, [Value])
replaySignal
  ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ByteString] -> ByteString
ByteStringLazy.concat (ByteString
tRep ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: (Value -> ByteString) -> [Value] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Value -> ByteString
forall a. Binary a => a -> ByteString
encode (Int -> [Value] -> [Value]
forall a. Int -> [a] -> [a]
take Int
n [Value]
samples)))

-- | Take a serialized signal (dumped with @dumpReplayable@) and convert it
-- back into a signal. Will error if dumped type does not match requested
-- type. The first value in the signal that fails to decode will stop the
-- decoding process and yield an error. Not that this always happens if you
-- evaluate more values than were originally dumped.
replay
  :: forall a dom n
   . ( Typeable a
     , NFDataX a
     , BitPack a
     , KnownNat n
     , n ~ BitSize a )
  => ByteString
  -> Either String (Signal dom a)
replay :: ByteString -> Either String (Signal dom a)
replay bytes0 :: ByteString
bytes0 = Either String (Signal dom a)
samples1
 where
  samples1 :: Either String (Signal dom a)
samples1 =
    case ByteString
-> Either
     (ByteString, ByteOffset, String)
     (ByteString, ByteOffset, TypeRep a)
forall a.
Binary a =>
ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
decodeOrFail ByteString
bytes0 of
      Left (_, _, err :: String
err) ->
        String -> Either String (Signal dom a)
forall a b. a -> Either a b
Left ("Failed to decode typeRep. Parser reported:\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)
      Right (bytes1 :: ByteString
bytes1, _, TypeRep a
_ :: TypeRep a) ->
        let samples0 :: [Either String a]
samples0 = ByteString -> [Either String a]
forall a (n :: Nat).
(BitPack a, KnownNat n, n ~ BitSize a) =>
ByteString -> [Either String a]
decodeSamples ByteString
bytes1 in
        let err :: String
err = "Failed to decode value in signal. Parser reported:\n\n " in
        Signal dom a -> Either String (Signal dom a)
forall a b. b -> Either a b
Right ([a] -> Signal dom a
forall a (dom :: Domain). NFDataX a => [a] -> Signal dom a
fromList ((Either String a -> a) -> [Either String a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> a) -> (a -> a) -> Either String a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> (String -> String) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++)) a -> a
forall a. a -> a
id) [Either String a]
samples0))

-- | Helper function of 'replay'. Decodes ByteString to some type with
-- BitVector as an intermediate type.
decodeSamples
  :: forall a n
   . ( BitPack a
     , KnownNat n
     , n ~ BitSize a )
  => ByteString
  -> [Either String a]
decodeSamples :: ByteString -> [Either String a]
decodeSamples bytes0 :: ByteString
bytes0 =
  case ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, Value)
forall a.
Binary a =>
ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
decodeOrFail ByteString
bytes0 of
    Left (_, _, err :: String
err) ->
      [String -> Either String a
forall a b. a -> Either a b
Left String
err]
    Right (bytes1 :: ByteString
bytes1, _, (m :: Integer
m, v :: Integer
v)) ->
      (a -> Either String a
forall a b. b -> Either a b
Right (BitVector (BitSize a) -> a
forall a. BitPack a => BitVector (BitSize a) -> a
unpack (Integer -> Integer -> BitVector n
forall (n :: Nat). Integer -> Integer -> BitVector n
BV Integer
m Integer
v))) Either String a -> [Either String a] -> [Either String a]
forall a. a -> [a] -> [a]
: ByteString -> [Either String a]
forall a (n :: Nat).
(BitPack a, KnownNat n, n ~ BitSize a) =>
ByteString -> [Either String a]
decodeSamples ByteString
bytes1

-- | Keep evaluating given signal until all trace names are present.
waitForTraces#
  :: NFDataX a
  => IORef TraceMap
  -- ^ Map with collected traces
  -> Signal dom a
  -- ^ (One of) the output(s) the circuit containing the traces
  -> [String]
  -- ^ The names of the traces you definitely want to be dumped to the VCD file
  -> IO ()
waitForTraces# :: IORef TraceMap -> Signal dom a -> [String] -> IO ()
waitForTraces# traceMap :: IORef TraceMap
traceMap signal :: Signal dom a
signal traceNames :: [String]
traceNames = do
  IORef TraceMap -> TraceMap -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef TraceMap
traceMap TraceMap
forall k a. Map k a
Map.empty
  [a]
rest <- ([a] -> String -> IO [a]) -> [a] -> [String] -> IO [a]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [a] -> String -> IO [a]
go (Signal dom a -> [a]
forall (f :: * -> *) a. (Foldable f, NFDataX a) => f a -> [a]
sample Signal dom a
signal) [String]
traceNames
  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> () -> ()
forall a b. NFDataX a => a -> b -> b
deepseqX ([a] -> a
forall a. [a] -> a
head [a]
rest) ()
 where
  go :: [a] -> String -> IO [a]
go s :: [a]
s nm :: String
nm = do
    TraceMap
m <- IORef TraceMap -> IO TraceMap
forall a. IORef a -> IO a
readIORef IORef TraceMap
traceMap
    if String -> TraceMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member String
nm TraceMap
m then
      [a] -> IO [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
s
    else
      a -> IO [a] -> IO [a]
forall a b. NFDataX a => a -> b -> b
deepseqX
        ([a] -> a
forall a. [a] -> a
head [a]
s)
        ([a] -> String -> IO [a]
go ([a] -> [a]
forall a. [a] -> [a]
tail [a]
s) String
nm)