sump (empty) → 0.1.0.1
raw patch · 5 files changed
+400/−0 lines, 5 filesdep +basedep +bytestringdep +data-defaultsetup-changed
Dependencies added: base, bytestring, data-default, either, lens, serialport, transformers, vector
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- src/System/Hardware/Sump.hs +278/−0
- src/System/Hardware/Sump/Types.hs +56/−0
- sump.cabal +34/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Ben Gamari++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Ben Gamari nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/System/Hardware/Sump.hs view
@@ -0,0 +1,278 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module System.Hardware.Sump+ ( -- * Basic Types+ module System.Hardware.Sump.Types+ , Channel+ , ch+ , ChannelGroup (..)+ , Stage (..)+ -- * Initialization+ , Sump+ , open+ , reset+ , ProtocolVersion (..)+ , identify+ -- * Trigger configuration+ , Trigger (..)+ , levelTrigger+ , configureTrigger+ -- * Other configuration+ , setDivider+ , setReadDelayCounts+ , Flags (..)+ , setFlags+ -- * Acquisition+ , Sample (..)+ , channelLevel+ , run+ ) where++import Data.Char (chr)+import Data.Bits+import Data.Word+import Data.List (foldl')+import Control.Monad (replicateM_, void)+import Numeric (readHex, showHex)++import Control.Monad.Trans.Either+import Control.Monad.IO.Class++import qualified Data.Vector as V+import qualified Data.ByteString as BS+import Data.ByteString (ByteString)+import Data.Default++import System.Hardware.Serialport+import System.Hardware.Sump.Types++data ProtocolVersion = Version0+ | Version1+ | VersionUnknown Char+ deriving (Eq, Ord, Show)++-- | A connection to an SUMP-compatible logic analyzer+data Sump = Sump+ { sumpDevice :: SerialPort+ }+++open :: FilePath -> EitherT String IO Sump+open path = do+ s <- liftIO $ openSerial path settings+ liftIO $ flush s+ let sump = Sump s+ replicateM_ 5 $ command [0x0] 0 sump -- reset+ return sump+ where+ settings = defaultSerialSettings { commSpeed = CS115200+ , timeout = 1+ }++command :: [Word8] -> Int -> Sump -> EitherT String IO ByteString+command c replyLen (Sump sump) = do+ liftIO $ putStrLn $ concat $ map (flip showHex " ") c+ void $ liftIO $ send sump (BS.pack c)+ reply <- liftIO $ recv sump replyLen+ return reply++reset :: Sump -> EitherT String IO ()+reset = void . command [0x0] 0++newtype Sample = Sample Word32++instance Show Sample where+ show (Sample s) = showHex s ""++instance Read Sample where+ readsPrec _ = map (\(a,b)->(Sample a, b)) . readHex++channelLevel :: Channel -> Sample -> Level+channelLevel (Ch c) (Sample s)+ | bit c .&. s == 0 = Low+ | otherwise = High++readSample :: Sump -> EitherT String IO (Maybe Sample)+readSample sump = do+ s <- liftIO $ recv (sumpDevice sump) 4+ --liftIO $ print s+ case BS.unpack s of+ bs@[_,_,_,_] -> right $ Just $ Sample+ $ foldl' (\accum a->(accum `shiftL` 8) .|. fromIntegral a) 0+ $ reverse bs+ [] -> right Nothing+ _ -> left "Unknown response"++run :: Sump -> EitherT String IO (V.Vector Sample)+run sump = do+ void $ command [0x1] 0 sump+ let go accum = do+ ss <- readSample sump+ case ss of+ Just s -> go $ V.snoc accum s+ Nothing -> return $ V.reverse accum++ let readFirst = do+ ss <- readSample sump+ case ss of+ Just s -> return s+ Nothing -> readFirst++ first <- readFirst+ go (V.singleton first)++identify :: Sump -> EitherT String IO (ByteString, ProtocolVersion)+identify sump = do+ reply <- BS.reverse `fmap` command [0x2] 4 sump+ let device = BS.take 3 reply+ version <- case map (chr . fromIntegral) $ BS.unpack $ BS.drop 3 reply of+ ['0'] -> right Version0+ ['1'] -> right Version1+ [c] -> right $ VersionUnknown c+ [] -> left "No reply to ID command"+ _ -> error "identify: This can't happen"+ return (device, version)++byte :: (Integral a, Bits a) => Int -> a -> Word8+byte b a = fromIntegral $ a `shiftR` (8*b)++word32Bytes :: Word32 -> [Word8]+word32Bytes v = [byte 0 v, byte 1 v, byte 2 v, byte 3 v]++setDivider :: Sump -> Int -> EitherT String IO ()+setDivider sump d =+ void $ command [0x80, byte 0 d, byte 1 d, byte 2 d, 0] 0 sump++-- | A trigger stage+data Stage = Stage0 | Stage1 | Stage2 | Stage3+ deriving (Eq, Ord, Bounded, Enum, Show)++-- | A logic analyzer channel+newtype Channel = Ch Int+ deriving (Eq, Ord, Enum, Show)++instance Bounded Channel where+ minBound = Ch 0+ maxBound = Ch 32++-- | Construct a channel+ch :: Int -> Channel+ch c+ | c >= minBound && c < maxBound = Ch c+ | otherwise = error "Invalid channel"++channelBit :: Bits a => Channel -> a+channelBit (Ch c) = bit c++data Trigger+ = SerialTrigger { triggerDelay :: Word16+ , triggerLevel :: Word8+ , triggerChannel :: Channel+ , triggerStart :: Bool+ , triggerMask :: Word32+ , triggerValue :: Word32+ }+ | ParallelTrigger { triggerDelay :: Word16+ , triggerLevel :: Word8+ , triggerStart :: Bool+ , triggerValues :: [(Channel, Level)]+ }++-- | Trigger on the simultaneous levels of a set of channels+levelTrigger :: [(Channel, Level)] -> Trigger+levelTrigger values =+ ParallelTrigger { triggerDelay = 0+ , triggerLevel = 0+ , triggerStart = True+ , triggerValues = values+ }++configureTrigger :: Sump+ -> Stage+ -> Trigger+ -> EitherT String IO ()+configureTrigger sump stage config@(SerialTrigger {}) = do+ void $ command (forStage 0xc0 : word32Bytes (triggerMask config)) 0 sump+ void $ command (forStage 0xc1 : word32Bytes (triggerValue config)) 0 sump+ _ <- command [ forStage 0xc2+ , byte 0 (triggerDelay config)+ , byte 1 (triggerDelay config)+ , fromIntegral (0xf .&. fromEnum (triggerChannel config))+ .|. fromIntegral (fromEnum $ triggerLevel config)+ , if triggerStart config then 0x8 else 0+ .|. 0x4+ .|. fromIntegral (0xf .&. (fromEnum $ triggerChannel config) `shiftR` 4)+ ] 0 sump+ return ()+ where+ forStage :: Word8 -> Word8+ forStage cmd = cmd .|. (fromIntegral (fromEnum stage) `shiftL` 2)++configureTrigger sump stage config@(ParallelTrigger {triggerValues=trigger}) = do+ let mask = foldl' (.|.) 0 $ map (channelBit . fst) trigger+ values = foldl' (.|.) 0+ $ map (\(c,v)->case v of+ High -> bit $ channelBit c+ Low -> 0)+ $ trigger+ void $ command (forStage 0xc0 : word32Bytes mask) 0 sump+ void $ command (forStage 0xc1 : word32Bytes values) 0 sump+ void $ command+ [ forStage 0xc2+ , byte 0 (triggerDelay config)+ , byte 1 (triggerDelay config)+ , fromIntegral (fromEnum $ triggerLevel config)+ , if triggerStart config then 0x8 else 0+ ] 0 sump+ return ()+ where+ forStage :: Word8 -> Word8+ forStage cmd = cmd .|. (fromIntegral (fromEnum stage) `shiftL` 2)++setReadDelayCounts :: Sump+ -> Word16 -- ^ Read count divided by four+ -> Word16 -- ^ Delay count divided by four+ -> EitherT String IO ()+setReadDelayCounts sump readCnt delayCnt = do+ let c = [ 0x81+ , byte 0 readCnt, byte 1 readCnt+ , byte 0 delayCnt, byte 1 delayCnt]+ void $ command c 0 sump++data ChannelGroup = ChGrp0 | ChGrp1 | ChGrp2 | ChGrp3+ deriving (Show, Eq, Ord, Bounded, Enum)++data Flags = Flags { demux :: Bool+ , inputFilter :: Bool+ , enabledGroups :: [ChannelGroup]+ , externalClock :: Bool+ , invertedClock :: Bool+ }+ deriving (Show)++setFlags :: Sump -> Flags -> EitherT String IO ()+setFlags sump flags = do+ let groups = enabledGroups flags+ v = foldl' (.|.) 0+ [ bit 0 `is` demux flags+ , bit 1 `is` inputFilter flags+ , bit 2 `is` (ChGrp0 `notElem` groups)+ , bit 3 `is` (ChGrp1 `notElem` groups)+ , bit 4 `is` (ChGrp2 `notElem` groups)+ , bit 5 `is` (ChGrp3 `notElem` groups)+ , bit 6 `is` externalClock flags+ , bit 7 `is` invertedClock flags+ ]+ b `is` True = bit b+ _ `is` False = 0+ void $ command [0x82, v, 0, 0, 0] 0 sump+ return ()++-- | All groups enabled, internal clock, no demux or input filter+instance Default Flags where+ def = Flags { demux = False+ , inputFilter = False+ , enabledGroups = [minBound .. maxBound]+ , externalClock = False+ , invertedClock = False+ }
+ src/System/Hardware/Sump/Types.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module System.Hardware.Sump.Types+ ( -- * Logical levels+ Level (..)+ , _Low, _High+ , invert+ -- * Logical transitions+ , Edge (..)+ , startLevel+ , finalLevel+ , edgeLevels+ -- * Time+ , Time (..)+ ) where++import Control.Lens hiding (Level)++-- | A logical high or low+data Level = High | Low+ deriving (Eq, Ord, Bounded, Enum, Show)++makePrisms ''Level++invert :: Level -> Level+invert Low = High+invert High = Low++-- | A notion of discrete time+newtype Time = Time Int+ deriving (Show, Ord, Eq, Enum)+makeWrapped ''Time++data Edge = Falling | Rising+ deriving (Show, Eq, Ord)++makePrisms ''Edge++startLevel :: Edge -> Level+startLevel Falling = High+startLevel Rising = Low++finalLevel :: Edge -> Level+finalLevel = invert . startLevel++edgeLevels :: Prism' (Level, Level) Edge+edgeLevels = prism' fromEdge toEdge+ where+ fromEdge e = (startLevel e, finalLevel e)+ toEdge (Low, High) = Just Rising+ toEdge (High, Low) = Just Falling+ toEdge _ = Nothing
+ sump.cabal view
@@ -0,0 +1,34 @@+name: sump+version: 0.1.0.1+synopsis: A Haskell interface to SUMP-compatible logic analyzers+description: A Haskell interface to SUMP-compatible logic analyzers including+ a utilities for visualization of logic traces.+homepage: http://github.com/bgamari/sump+license: BSD3+license-file: LICENSE+author: Ben Gamari+maintainer: ben@smart-cactus.org+copyright: (c) 2014 Ben Gamari+category: Hardware+build-type: Simple+cabal-version: >=1.10++source-repository head+ type: git+ location: https://github.com/bgamari/sump++library+ exposed-modules: System.Hardware.Sump+ System.Hardware.Sump.Types+ other-extensions: GeneralizedNewtypeDeriving+ ghc-options: -Wall+ build-depends: base >=4.7 && <4.9,+ data-default >=0.5 && <0.6,+ transformers >=0.4 && <0.5,+ either >=4.3 && <4.5,+ vector >=0.10 && <0.12,+ bytestring >=0.10 && <0.11,+ lens,+ serialport >=0.4 && <0.5+ hs-source-dirs: src+ default-language: Haskell2010