vcd 0.0.0 → 0.1.0
raw patch · 2 files changed
+217/−154 lines, 2 filesdep +parsec
Dependencies added: parsec
Files
- Data/VCD.hs +214/−152
- vcd.cabal +3/−2
Data/VCD.hs view
@@ -1,10 +1,19 @@+-- | Generating and parsing Value Change Dump (VCD) files. module Data.VCD- ( VCD+ ( + -- * VCD Generation+ VCDHandle , Timescale (..)+ , Variable (..)+ , variable , newVCD- , level- , signal+ , scope , step+ -- * VCD Parsing+ , VCD (..)+ , Definition (..)+ , Value (..)+ , parseVCD ) where import Control.Monad@@ -14,142 +23,128 @@ import Data.IORef import Data.Word import System.IO+import Text.ParserCombinators.Parsec+import Text.ParserCombinators.Parsec.Pos import Text.Printf -data VCD = VCD- { handle :: Handle- , defs :: IORef Bool- , dirty :: IORef Bool- , time :: IORef Int- , codes :: IORef [String]+-- | The VCDHandle keeps track of generation state and the output handle.+data VCDHandle = VCDHandle+ { handle :: Handle+ , defs :: IORef Bool+ , dirty :: IORef Bool+ , time :: IORef Int+ , codes :: IORef [String]+ , dumpvars :: IORef (IO ()) } -data Timescale = US | MS | S+-- | VCD Timescale.+data Timescale+ = S -- ^ seconds+ | MS -- ^ milliseconds+ | US -- ^ microseconds+ | PS -- ^ picoseconds instance Show Timescale where- show US = "us"- show MS = "ms" show S = "s"+ show MS = "ms"+ show US = "us"+ show PS = "ps" -assertDefs :: VCD -> IO ()+assertDefs :: VCDHandle -> IO () assertDefs vcd = do defs <- readIORef $ defs vcd- when (not defs) $ error "VCD signal definition in recording phase"+ when (not defs) $ error "VCD variable definition in recording phase" -assertNotDefs :: VCD -> IO ()+assertNotDefs :: VCDHandle -> IO () assertNotDefs vcd = do defs <- readIORef $ defs vcd- when defs $ error "VCD signal recording in definition phase"+ when defs $ error "VCD variable recording in definition phase" -nextCode :: VCD -> IO String+nextCode :: VCDHandle -> IO String nextCode vcd = do assertDefs vcd codes' <- readIORef $ codes vcd writeIORef (codes vcd) (tail codes') return $ head codes' -class Signal a where signal :: VCD -> String -> IO (a -> IO ())--instance Signal Bool where- signal vcd name = do- code <- nextCode vcd- hPutStrLn (handle vcd) $ printf "$var wire 1 %s %s $end" code name- last <- newIORef Nothing- return $ \ a -> do- assertNotDefs vcd- last' <- readIORef last- when (last' /= Just a) $ do- hPutStrLn (handle vcd) $ (if a then "1" else "0") ++ code- writeIORef last $ Just a- writeIORef (dirty vcd) True+-- | Types that can be recorded as VCD variables.+class Variable a where+ -- | Define a new variable.+ var :: VCDHandle -> String -> a -> IO (a -> IO ()) -bitsSignal :: Bits a => VCD -> String -> IO (a -> IO ())-bitsSignal vcd name = do- let dumb = 0- code <- nextCode vcd- hPutStrLn (handle vcd) $ printf "$var %s %d %s %s $end" (if isSigned dumb then "integer" else "wire") (bitSize dumb) code name- last <- newIORef Nothing- return $ \ a -> do- assertNotDefs vcd- when (a == dumb) (return ())- last' <- readIORef last- when (last' /= Just a) $ do- hPutStrLn (handle vcd) $ printf "b%s %s" (bitString a) code- writeIORef last $ Just a- writeIORef (dirty vcd) True+instance Variable Bool where var = variable "wire" 1 (\ a -> if a then "1" else "0")+instance Variable Int where var vcd name init = variable "integer" (bitSize init) bitString vcd name init+instance Variable Int8 where var = variable "integer" 8 bitString+instance Variable Int16 where var = variable "integer" 16 bitString+instance Variable Int32 where var = variable "integer" 16 bitString+instance Variable Int64 where var = variable "integer" 16 bitString+instance Variable Word8 where var = variable "wire" 8 bitString+instance Variable Word16 where var = variable "wire" 16 bitString+instance Variable Word32 where var = variable "wire" 32 bitString+instance Variable Word64 where var = variable "wire" 64 bitString+instance Variable Float where var = variable "real" 32 (\ a -> "r" ++ show a ++ " ")+instance Variable Double where var = variable "real" 64 (\ a -> "r" ++ show a ++ " ") bitString :: Bits a => a -> String-bitString n = if null bits then "0" else bits+bitString n = "b" ++ (if null bits then "0" else bits) ++ " " where bits = dropWhile (== '0') $ [ if testBit n i then '1' else '0' | i <- [bitSize n - 1, bitSize n - 2 .. 0] ] -instance Signal Int where signal = bitsSignal-instance Signal Int8 where signal = bitsSignal-instance Signal Int16 where signal = bitsSignal-instance Signal Int32 where signal = bitsSignal-instance Signal Int64 where signal = bitsSignal-instance Signal Word8 where signal = bitsSignal-instance Signal Word16 where signal = bitsSignal-instance Signal Word32 where signal = bitsSignal-instance Signal Word64 where signal = bitsSignal- -instance Signal Float where- signal vcd name = do- code <- nextCode vcd- hPutStrLn (handle vcd) $ printf "$var real 32 %s %s $end" code name- last <- newIORef Nothing- return $ \ a -> do- assertNotDefs vcd- last' <- readIORef last- when (last' /= Just a) $ do- hPutStrLn (handle vcd) $ printf "r%s %s" (show a) code- writeIORef last $ Just a- writeIORef (dirty vcd) True--instance Signal Double where- signal vcd name = do- code <- nextCode vcd- hPutStrLn (handle vcd) $ printf "$var real 64 %s %s $end" code name- last <- newIORef Nothing- return $ \ a -> do- assertNotDefs vcd- last' <- readIORef last- when (last' /= Just a) $ do- hPutStrLn (handle vcd) $ printf "r%s %s" (show a) code- writeIORef last $ Just a- writeIORef (dirty vcd) True+-- | Helper to create new 'Variable' instances.+variable :: Eq a => String -> Int -> (a -> String) -> VCDHandle -> String -> a -> IO (a -> IO ())+variable typ width value vcd name init = do+ code <- nextCode vcd+ hPutStrLn (handle vcd) $ printf "$var %s %d %s %s $end" typ width code name+ last <- newIORef Nothing+ let sample a = do assertNotDefs vcd+ last' <- readIORef last+ when (last' /= Just a) $ do+ hPutStrLn (handle vcd) $ value a ++ code+ writeIORef last $ Just a+ writeIORef (dirty vcd) True+ modifyIORef (dumpvars vcd) (\ a -> a >> sample init)+ return sample -newVCD :: Handle -> Timescale -> IO VCD+-- | Create a new handle for generating a VCD file with a given timescale.+newVCD :: Handle -> Timescale -> IO VCDHandle newVCD h ts = do hPutStrLn h $ "$timescale" hPutStrLn h $ " 1 " ++ show ts hPutStrLn h $ "$end"- defs <- newIORef True- dirty <- newIORef True- time <- newIORef 0- codes <- newIORef identCodes- return VCD- { handle = h- , defs = defs- , dirty = dirty- , time = time- , codes = codes+ defs <- newIORef True+ dirty <- newIORef True+ time <- newIORef 0+ codes <- newIORef identCodes+ dumpvars <- newIORef $ return ()+ return VCDHandle+ { handle = h+ , defs = defs+ , dirty = dirty+ , time = time+ , codes = codes+ , dumpvars = dumpvars } -level :: VCD -> String -> IO a -> IO a-level vcd name a = do+-- | Define a hierarchical scope.+scope :: VCDHandle -> String -> IO a -> IO a+scope vcd name a = do hPutStrLn (handle vcd) $ "$scope module " ++ name ++ " $end" a <- a hPutStrLn (handle vcd) $ "$upscope $end" return a -step :: VCD -> Int -> IO ()+-- | Set a time step. 'step' will also transition a VCDHandle from the definition to the recording phase.+step :: VCDHandle -> Int -> IO () step vcd n = do- defs' <- readIORef $ defs vcd+ defs' <- readIORef $ defs vcd+ dumpvars' <- readIORef $ dumpvars vcd when defs' $ do- hPutStrLn (handle vcd) "$enddefinitions $end" writeIORef (defs vcd) False+ hPutStrLn (handle vcd) "$enddefinitions $end"+ hPutStrLn (handle vcd) "$dumpvars"+ dumpvars'+ hPutStrLn (handle vcd) "$end" dirty' <- readIORef $ dirty vcd when dirty' $ do@@ -166,63 +161,130 @@ code i | i < 94 = [chr (33 + mod i 94)] code i = code (div i 94) ++ [chr (33 + mod i 94)] +-- | VCD database.+data VCD = VCD Timescale [Definition] [(Int, [(String, Value)])] deriving Show -{--writeVCD :: Handle -> Handle -> String -> String -> [String] -> [Type] -> (String -> [String]) -> (String -> Int) -> IO ()-writeVCD i o date version names' types' f toTime = do- hPutStrLn o $ "$date"- hPutStrLn o date- hPutStrLn o $ "$end"- hPutStrLn o $ "$version"- hPutStrLn o version- hPutStrLn o $ "$end"- hPutStrLn o $ "$timescale"- hPutStrLn o $ " 1 ms"- hPutStrLn o $ "$end"- mapM_ writeVarDecl $ zip3 names types identCodes- hPutStrLn o $ "$enddefinitions $end"- hFlush o- writeSamples 0 (replicate (length names) "")- hClose o+-- | Recorded value.+data Value = Bool Bool | Bits [Bool] | Double Double deriving Show++-- | Variable definition.+data Definition+ = Scope String [Definition] -- ^ Hierarchical scope.+ | Var String Int String String -- ^ Variable with type, width, code, name.+ deriving Show++data Token+ = End+ | Timescale+ | Scope'+ | Var'+ | UpScope+ | EndDefinitions+ | DumpVars+ | Step Int+ | String String+ deriving (Show, Eq)++type VCDParser = GenParser Token ()++-- | Parse VCD data.+parseVCD :: String -> VCD+parseVCD a = case parse vcd "unknown" $ map token $ words a of+ Left err -> error $ show err+ Right vcd -> vcd where- names = tail names'- types = tail types'+ token a = case a of+ "$end" -> End+ "$timescale" -> Timescale+ "$scope" -> Scope'+ "$var" -> Var'+ "$upscope" -> UpScope+ "$enddefinitions" -> EndDefinitions+ "$dumpvars" -> DumpVars+ '#':a | not (null a) && all isDigit a -> Step $ read a+ a -> String a - writeVarDecl :: (String, Type, String) -> IO ()- writeVarDecl (name, t, code) = hPutStrLn o $ case t of- Bool -> "$var wire 1 " ++ code ++ " " ++ name ++ " $end"- Int8 -> "$var integer 8 " ++ code ++ " " ++ name ++ " $end"- Int16 -> "$var integer 16 " ++ code ++ " " ++ name ++ " $end"- Int32 -> "$var integer 32 " ++ code ++ " " ++ name ++ " $end"- Int64 -> "$var integer 64 " ++ code ++ " " ++ name ++ " $end"- Word8 -> "$var wire 8 " ++ code ++ " " ++ name ++ " $end"- Word16 -> "$var wire 16 " ++ code ++ " " ++ name ++ " $end"- Word32 -> "$var wire 32 " ++ code ++ " " ++ name ++ " $end"- Word64 -> "$var wire 64 " ++ code ++ " " ++ name ++ " $end"- Float -> "$var real 32 " ++ code ++ " " ++ name ++ " $end"- Double -> "$var real 64 " ++ code ++ " " ++ name ++ " $end"+noPos :: a -> SourcePos+noPos _ = initialPos "unknown" - writeSamples :: Int -> [String] -> IO ()- writeSamples lastTime lastValues = do- eof <- hIsEOF i- case eof of- True -> hPutStrLn o $ "#" ++ show (lastTime + 1)- False -> do- l <- hGetRealLine i- let values' = f l- time = (toTime $ head values') :: Int- values = tail values'- when (values /= lastValues) $ hPutStrLn o $ "#" ++ show time- mapM_ writeValue $ zip4 types identCodes values lastValues --XXX Would not work if first value is invalid.- hFlush o- writeSamples time values+tok' = token show noPos+tok a = tok' (\ b -> if a == b then Just () else Nothing)+str = tok' $ \ a -> case a of+ String a -> Just a+ _ -> Nothing - writeValue :: (Type, String, String, String) -> IO ()- writeValue (t, c, v, vl) | v == vl = return ()- | otherwise = case t of- Bool -> hPutStrLn o $ v ++ c- Float -> hPutStrLn o $ "r" ++ v ++ " " ++ c- Double -> hPutStrLn o $ "r" ++ v ++ " " ++ c- _ -> hPutStrLn o $ "b" ++ bitString (read v) ++ " " ++ c- --}+vcd :: VCDParser VCD+vcd = do+ ts <- timescale+ defs <- definitions+ tok EndDefinitions+ tok End+ tok DumpVars+ initValues <- values+ tok End+ initTime <- step'+ samples <- many sample >>= return . ((initTime, initValues):)+ eof+ return $ VCD ts defs samples++timescale :: VCDParser Timescale+timescale = do+ tok Timescale+ one <- str+ sc <- str+ tok End+ when (one /= "1") $ error $ "invalid timescale: " ++ one+ case sc of+ "s" -> return S+ "ms" -> return MS+ "us" -> return US+ "ps" -> return PS+ _ -> error $ "invalid timescale: " ++ sc++definitions :: VCDParser [Definition]+definitions = many $ scope' <|> var'++scope' :: VCDParser Definition+scope' = do+ tok Scope'+ str+ name <- str+ tok End+ defs <- definitions+ tok UpScope+ tok End+ return $ Scope name defs++var' :: VCDParser Definition+var' = do+ tok Var'+ typ <- str+ width <- str+ code <- str+ name <- str+ tok End+ return $ Var typ (read width) code name++step' :: VCDParser Int+step' = tok' $ \ a -> case a of+ Step a -> Just a+ _ -> Nothing++sample :: VCDParser (Int, [(String, Value)])+sample = do+ a <- values+ i <- step'+ return (i, a)++values :: VCDParser [(String, Value)]+values = many str >>= return . values'++values' :: [String] -> [(String, Value)]+values' a = case a of+ [] -> []+ ('0':code):a -> (code, Bool False) : values' a+ ('1':code):a -> (code, Bool True ) : values' a+ ('b':bits):code:a -> (code, Bits [ b == '1' | b <- bits ]) : values' a+ ('r':float):code:a -> (code, Double $ read float) : values' a+ (a:_) -> error $ "invalid value: " ++ a+
vcd.cabal view
@@ -1,5 +1,5 @@ name: vcd-version: 0.0.0+version: 0.1.0 category: Data @@ -22,7 +22,8 @@ library build-depends:- base >= 4.2 && < 5+ base >= 4.2 && < 5,+ parsec >= 2.1 exposed-modules: Data.VCD