diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/System/Hardware/Sump.hs b/src/System/Hardware/Sump.hs new file mode 100644 --- /dev/null +++ b/src/System/Hardware/Sump.hs @@ -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 + } diff --git a/src/System/Hardware/Sump/Types.hs b/src/System/Hardware/Sump/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/Hardware/Sump/Types.hs @@ -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 diff --git a/sump.cabal b/sump.cabal new file mode 100644 --- /dev/null +++ b/sump.cabal @@ -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