ecu 0.0.5 → 0.0.6
raw patch · 5 files changed
+577/−162 lines, 5 filesnew-component:exe:decompnew-component:exe:parsedbc
Files
- README +2/−0
- ecu.cabal +14/−5
- src/CAN.hs +0/−157
- src/CANDBParser.hs +288/−0
- src/CANViewDecompose.hs +273/−0
README view
@@ -4,6 +4,8 @@ probe - Extracts configuration and probed signals from ECU. canview - View CAN traffic. cansend - Send CAN message.+decomp - Decomposes J1939 messages from canview.+parsedbc - Parses *.dbc files. ccp - CAN Configuration Protocol master. toesb - Converts s-record ECU images to the Eaton Standard Binary format. git2cc - Bridge Git repositories to ClearCase.
ecu.cabal view
@@ -1,5 +1,5 @@ name: ecu-version: 0.0.5+version: 0.0.6 category: Embedded, Utils @@ -33,10 +33,16 @@ vcd >= 0.2.0 && < 0.3.0 ghc-options: -W +executable decomp+ hs-source-dirs: src+ main-is: CANViewDecompose.hs+ build-depends: base >= 4.0 && < 5,+ bytestring >= 0.9.1 && < 0.9.2+ ghc-options: -W+ executable cansend hs-source-dirs: src main-is: CANSend.hs- other-modules: CAN c-sources: src/kvaser.c extra-libraries: canlib build-depends: base >= 4.0 && < 5@@ -46,7 +52,6 @@ executable canview hs-source-dirs: src main-is: CANView.hs- other-modules: CAN c-sources: src/kvaser.c extra-libraries: canlib build-depends: base >= 4.0 && < 5@@ -56,7 +61,6 @@ executable ccp hs-source-dirs: src main-is: CCP.hs- other-modules: CAN c-sources: src/kvaser.c extra-libraries: canlib build-depends: base >= 4.0 && < 5@@ -66,7 +70,6 @@ executable probe hs-source-dirs: src main-is: Probe.hs- other-modules: CAN c-sources: src/kvaser.c extra-libraries: canlib build-depends: base >= 4.0 && < 5,@@ -81,6 +84,12 @@ build-depends: base >= 4.0 && < 5, bytestring >= 0.9.1 && < 0.9.2, digest >= 0.0.0.8 && < 0.0.1+ ghc-options: -W++executable parsedbc+ hs-source-dirs: src+ main-is: CANDBParser.hs+ build-depends: base >= 4.0 && < 5 ghc-options: -W executable commit
− src/CAN.hs
@@ -1,157 +0,0 @@-module CAN- ( Msg (..)- , BusType (..)- , Bus- , initCAN- , openBus- , closeBus- , recvMsg- , recvMsgWait- , sendMsg- , busTime- , busTime'- , testBusStatus- , testIFStatus- , sendUntil- , toWord64- , fromWord64- , toWord32- , fromWord32- , toPayload- , fromPayload- , flushRxQueue- ) where--import Data.Bits-import Data.Char-import Data.Word-import Text.Printf--foreign import ccall unsafe initCAN :: IO ()-foreign import ccall unsafe canOpenExt_ :: Int -> IO Int-foreign import ccall unsafe canOpenStd_ :: Int -> IO Int---foreign import ccall unsafe canOpenVirtual_ :: Int -> IO Int-foreign import ccall unsafe canClose_ :: Int -> IO ()---foreign import ccall unsafe canRead_ :: Int -> IO Int-foreign import ccall unsafe canReadWait_ :: Int -> Int -> IO Int-foreign import ccall unsafe canReadId_ :: IO Int-foreign import ccall unsafe canReadTime_ :: IO Int-foreign import ccall unsafe canReadMsgLen_ :: IO Int-foreign import ccall unsafe canReadMsg_ :: Int -> IO Char-foreign import ccall unsafe canWriteByte_ :: Char -> Int -> IO ()-foreign import ccall unsafe canWrite_ :: Int -> Int -> Int -> IO ()-foreign import ccall unsafe canReadTimer_ :: Int -> IO Int-foreign import ccall unsafe canFlushReceiveQueue_ :: Int -> IO Int--newtype Bus = Bus Int--openBus :: Int -> BusType -> IO Bus-openBus channel busType = do- h <- case busType of- Standard -> canOpenStd_ channel- Extended -> canOpenExt_ channel- return $ Bus h--closeBus :: Bus -> IO ()-closeBus (Bus h) = canClose_ h---- | Receive a message if a message is available. Includes receive time (ms). -recvMsg :: Bus -> IO (Maybe (Int, Msg))-recvMsg b = recvMsgWait b 0---- | Waits a number of ms to receive a message. Includes receive time (ms). -recvMsgWait :: Bus -> Int -> IO (Maybe (Int, Msg))-recvMsgWait (Bus h) wait = do- status <- canReadWait_ h wait- id <- canReadId_- if status /= 0 || id == 0 then return Nothing else do- len <- canReadMsgLen_- msg <- mapM canReadMsg_ [0 .. len - 1]- t <- canReadTime_- return $ Just (t, Msg (fromIntegral id) (map (fromIntegral . ord) msg))---- | Send a message.-sendMsg :: Bus -> Msg -> IO ()-sendMsg (Bus h) (Msg id payload') = do- mapM_ (\ (b, i) -> canWriteByte_ (chr $ fromIntegral b) i) $ zip payload [0..]- canWrite_ h (fromIntegral id) $ length payload- where- payload = take 8 payload'--flushRxQueue :: Bus -> IO ()-flushRxQueue (Bus h) = do- canFlushReceiveQueue_ h- return ()---- | Current driver time (ms).-busTime :: Bus -> IO (Maybe Int)-busTime (Bus h) = do- status <- canReadTimer_ h- if status /= 0 then return Nothing else do- t <- canReadTime_- return $ Just t--busTime' :: Bus -> IO Int-busTime' bus = do- t <- busTime bus- case t of- Nothing -> busTime' bus- Just t -> return t--testBusStatus :: Bus -> IO Int-testBusStatus (Bus h) = do- status <- canReadWait_ h 500- return status--testIFStatus :: Bus -> IO Int-testIFStatus (Bus h) = do- status <- canReadTimer_ h- return status---- | Send a message periodically (in ms) until a certain message is received.-sendUntil :: Bus -> Int -> Msg -> (Msg -> Bool) -> IO Msg-sendUntil bus retryTime msg isAck = getStartTime >>= f1- where- f1 startTime = sendMsg bus msg >> f2 startTime startTime- f2 startTime currentTime | currentTime - startTime > retryTime = f1 currentTime- f2 startTime currentTime = do- m <- recvMsgWait bus $ max 0 $ retryTime - (currentTime - startTime)- case m of- Nothing -> f1 currentTime- Just (t, m) | isAck m -> return m- | otherwise -> f2 startTime t-- getStartTime = do- m <- recvMsg bus- case m of- Nothing -> getStartTime- Just (t, _) -> return t---data Msg = Msg Word32 [Word8] deriving (Eq, Ord)--data BusType = Extended | Standard--instance Show Msg where show (Msg id payload) = printf "0x%08X 0x%s" id $ concatMap formatByte payload--formatByte :: Word8 -> String-formatByte b = printf "%02X" b--toWord64 :: [Word8] -> Word64-toWord64 a = foldl1 (.|.) [ shiftL (fromIntegral a) $ i * 8 | (a, i) <- zip (a ++ [0..]) $ reverse [0..7] ]--fromWord64 :: Word64 -> [Word8]-fromWord64 a = [ fromIntegral ((shiftR a $ i * 8) .&. 0xFF) | i <- reverse [0..7] ]--toWord32 :: [Word8] -> Word32-toWord32 a = foldl1 (.|.) [ shiftL (fromIntegral a) $ i * 8 | (a, i) <- zip (a ++ [0..]) $ reverse [0..3] ]--fromWord32 :: Word32 -> [Word8]-fromWord32 a = [ fromIntegral ((shiftR a $ i * 8) .&. 0xFF) | i <- reverse [0..3] ]--toPayload :: Word64 -> [Word8]-toPayload payload = [ fromIntegral (shiftR payload (b * 8) .&. 0xFF) | b <- reverse [0..7] ]--fromPayload :: [Word8] -> Word64-fromPayload payload = foldr1 (.|.) [ shiftL (fromIntegral x .&. 0xFF) (b * 8) | (x, b) <- zip payload (reverse [0..7]) ]-
+ src/CANDBParser.hs view
@@ -0,0 +1,288 @@+module Main (main) where++import Data.Bits+import Data.Char+import Data.List+import Data.Word+import Text.Printf+import System.Environment++import CANData++main :: IO ()+main = do+ args <- getArgs+ case args of+ ["-h"] -> help+ ["--help"] -> help+ [ file ] -> do+ dbc <- readFile file+ let candb = mkCANDB dbc+ writeCANDB candb+ _ -> help++help :: IO ()+help = putStrLn $ unlines+ [ ""+ , "NAME"+ , " parsedbc - create CANDB.hs from dbc file"+ , ""+ , "SYNOPSIS"+ , " parsedbc FILE.dbc"+ , ""+ ]++writeCANDB :: CANDB -> IO ()+writeCANDB candb = writeFile "CANDB.hs" $ concat+ [ "{- Generated file. Do not modify -}\n"+ , "module CANDB\n"+ , " ( canDB\n"+ , " ) where\n"+ , "\n"+ , "import CANData\n"+ , "\n"+ , "canDB :: CANDB\n"+ , "canDB = CANDB\n"+ , showCANDB candb+ , "\n"+ ]++mkCANDB :: String -> CANDB+mkCANDB s = mkCANDB' nodes groups types attrs (CANDB name nodes [])+ where+ canLines = filter notBlank (lines s)+ name = getName canLines+ groups = getGroups canLines+ nodes = getNodes canLines+ types = getTypes canLines+ attrs = getMsgAttrs canLines++mkCANDB' :: [String] -> [[String]] -> [(Word32,String,CANSignalType)] -> [(Word32,CANMsgAttr)] -> CANDB -> CANDB+mkCANDB' _ [] _ _ canDb = canDb+mkCANDB' nodes (group0:groups) types attrs canDb = mkCANDB' nodes groups types attrs (fillDB group0 types attrs canDb)++fillDB :: [String] -> [(Word32,String,CANSignalType)] -> [(Word32,CANMsgAttr)] -> CANDB -> CANDB+fillDB group0 types attrs canDB = getSignals types (tail group0) (getMessage (head group0) attrs canDB)++getMessage :: String -> [(Word32,CANMsgAttr)] -> CANDB -> CANDB+getMessage s attrs (CANDB dbname nodes msgs) = CANDB dbname nodes newMessages+ where+ newMessages = (msg:msgs)+ msg = CANMsg + { canMsgId = id0+ , canMsgName = init c+ , canMsgDlc = read d+ , canMsgTxNode = e+ , canMsgAttrs = map (\ (_,a) -> a) (filter (\ (i,_) -> i == id0) attrs)+ , canMsgSignals = []+ }+ id0 = readId b+ (_:b:c:d:e:_) = words s++getSignals :: [(Word32,String,CANSignalType)] -> [String] -> CANDB -> CANDB+--getSignals _ [] (CANDB dbname nodes (msg:msgs)) = CANDB dbname nodes ((sortByStartBit msg):msgs)+getSignals _ [] canDb = canDb+getSignals types (l:ls) canDb = sortByStartBit (getSignal types l (getSignals types ls canDb))++sortByStartBit :: CANDB -> CANDB+sortByStartBit (CANDB dbname nodes []) = CANDB dbname nodes []+sortByStartBit (CANDB dbname nodes (msg:msgs)) = CANDB dbname nodes (newMsg:msgs)+ where+ newMsg = msg { canMsgSignals = sortBy comparingStartBit (canMsgSignals msg) }+ comparingStartBit :: CANSignal -> CANSignal -> Ordering+ comparingStartBit a b = compare (canSignalStartBit a) (canSignalStartBit b)++getSignal :: [(Word32,String,CANSignalType)] -> String -> CANDB -> CANDB+getSignal _ [] canDb = canDb+getSignal _ _ (CANDB _ _ []) = error "CANDBParser.getSignal"+getSignal types l (CANDB dbname nodes (msg:msgs)) = CANDB dbname nodes (newMsg:msgs) + where+ msgId = canMsgId msg+ newMsg = msg { canMsgSignals = newSignal:(canMsgSignals msg) }+ newSignal = CANSignal+ { canSignalName = name+ , canSignalStartBit = (read startBitStr)+ , canSignalBitLength = (read bitLengthStr)+ , canSignalEndian = if bigEndianStr == '0' then CANBigEndian else CANLittleEndian+ , canSignalSign = if signedStr == '-' then CANSigned else CANUnsigned+ , canSignalFactor = (read (drop 1 (takeWhile (/= ',') e)))+ , canSignalOffset = (read (takeWhile (/= ')') (drop 1 (dropWhile (/= ',') e))))+ , canSignalMin = (read (drop 1 (takeWhile (/= '|') f)))+ , canSignalMax = (read (takeWhile (/= ']') (drop 1 (dropWhile (/= '|') f))))+ , canSignalUnit = unit+ , canSignalRxNodes = rx+ , canSignalType = matchTypes msgId name types+ , canSignalMux = mux+ }+ startBitStr = takeWhile (/= '|') d+ bitLengthStr = drop 1 (dropWhile (/= '|') (takeWhile (/= '@') d))+ bigEndianStr = head (drop 1 (dropWhile (/= '@') d)) + signedStr = last d+ (_:name:maybeMux) = takeWhile (/= ":") (words l)+ mux = case maybeMux of+ [] -> CANSignalMuxNone+ ["M"] -> CANSignalMuxer+ [('m':muxVal)] -> CANSignalMuxed (read muxVal)+ _ -> error "CANDBParser.getSignal: error parsing \" SG_ ...\" line"+ (_:d:e:f:_) = dropWhile (/= ":") (words l)+ unitAndRx = dropWhile (/= '"') l+ unit = (takeWhile (/= '"') (drop 1 unitAndRx))+ rxlist = head (words (drop 1 (dropWhile (/= '"') (drop 1 unitAndRx))))+ rx = wordsBy ',' rxlist+ matchTypes :: Word32 -> String -> [(Word32,String,CANSignalType)] -> CANSignalType+ matchTypes _ _ [] = CANSignalTypeNormal+ matchTypes msgId0 sigName ((id0,name0,typ):types0) = + if (msgId0 == id0 && sigName == name0)+ then typ+ else matchTypes msgId0 sigName types0+ wordsBy :: Char -> [Char] -> [String]+ wordsBy sep s = case dropWhile (== sep) s of+ "" -> []+ s' -> w : wordsBy ',' s''+ where+ (w, s'') = break (== sep) s'++getName :: [String] -> String+getName [] = []+getName (l:ls) = + if isPrefixOf "BA_ \"DBName\" " l+ then (takeWhile (/= '"') (drop 1 c))+ else getName ls+ where+ (_:_:c:_) = words l++getNodes :: [String] -> [String]+getNodes (l:ls) = + if isPrefixOf "BU_: " l+ then (words (drop 5 l))+ else getNodes ls+getNodes [] = []++getTypes :: [String] -> [(Word32,String,CANSignalType)]+getTypes ls = getTypes' ls []++getTypes' :: [String] -> [(Word32,String,CANSignalType)] -> [(Word32,String,CANSignalType)]+getTypes' [] types = types+getTypes' (l:ls) types = + if isPrefixOf "SIG_VALTYPE_ " l+ then getTypes' ls ((id0,name,typ):types)+ else getTypes' ls types+ where+ typ = if typChar == '1' then CANSignalTypeFloat else CANSignalTypeDouble+ typChar = head e+ id0 = read b+ name = c+ (_:b:c:_:e:_) = words l++getMsgAttrs :: [String] -> [(Word32,CANMsgAttr)]+getMsgAttrs ls = getMsgAttrs' ls []++getMsgAttrs' :: [String] -> [(Word32,CANMsgAttr)] -> [(Word32,CANMsgAttr)]+getMsgAttrs' [] attrs = attrs+getMsgAttrs' (l:ls) attrs = + if isPrefixOf "BA_ " l && length (words l) == 5+ then + if c == "BO_"+ then getMsgAttrs' ls ((id0,attr):attrs)+ else getMsgAttrs' ls attrs+ else getMsgAttrs' ls attrs+ where+ id0 = readId d+ attr = (tail (init b), init e)+ (_:b:c:d:e:_) = words l++getGroups :: [String] -> [[String]]+getGroups ls = groupMessages ls [[]]++groupMessages :: [String] -> [[String]] -> [[String]]+groupMessages [] [] = [[]]+groupMessages [] sofar = map reverse sofar+groupMessages (l:ls) ([]:[]) = case take 4 l of+ "BO_ " -> groupMessages ls [[l]]+ _ -> groupMessages ls [[]]+groupMessages (l:ls) ((s:ss):gs) = case (take 4 l) of+ "BO_ " -> groupMessages ls ([l]:(s:ss):gs)+ " SG_" -> groupMessages ls ((l:s:ss):gs)+ _ -> reverse (map reverse ((s:ss):gs))+groupMessages _ [] = error "CANDBParser.groupMessages"+groupMessages _ ([]:_) = error "CANDBParser.groupMessages"++notBlank :: String -> Bool+notBlank a = not (and (map isSpace a))++readId :: String -> Word32+readId str = (read str) .&. 0x7FFFFFFF++showCANDB :: CANDB -> String+showCANDB candb = concat+ [ " { canDbName = " ++ show (canDbName candb) ++ "\n"+ , " , canDbNodes =\n"+ , " [" ++ (drop 7 (concatMap showNode (canDbNodes candb)))+ , " ]\n"+ , " , canDbMsgs =\n"+ , " [" ++ (drop 7 (concatMap showMsg (canDbMsgs candb)))+ , " ]\n"+ , " }\n"+ ]++showNode :: String -> String+showNode x = " , " ++ show x ++ "\n"++showMsg :: CANMsg -> String+showMsg msg = concat+ [ " , CANMsg\n"+ , " { canMsgId = " ++ (printf "0x%08X" (canMsgId msg)) ++ "\n"+ , " , canMsgName = " ++ show (canMsgName msg) ++ "\n"+ , " , canMsgDlc = " ++ show (canMsgDlc msg) ++ "\n"+ , " , canMsgTxNode = " ++ show (canMsgTxNode msg) ++ "\n"+ , " , canMsgAttrs =\n"+ , " [" ++ showMsgAttrs (canMsgAttrs msg)+ , " ]\n"+ , " , canMsgSignals =\n"+ , " [" ++ showMsgSignals (canMsgSignals msg) ++ "\n"+ , " ]\n"+ , " }\n"+ ]++showMsgAttrs :: [CANMsgAttr] -> String+showMsgAttrs attrs = case attrs of+ [] -> ""+ x -> drop 15 (concatMap showMsgAttr x)++showMsgAttr :: CANMsgAttr -> String+showMsgAttr (a , b) = " , (" ++ show a ++ ", " ++ show b ++ ")\n"++showMsgSignals :: [CANSignal] -> String+showMsgSignals signals = case signals of+ [] -> ""+ x -> drop 15 (concatMap showMsgSignal x)++showMsgSignal :: CANSignal -> String+showMsgSignal signal = concat+ [ " , CANSignal\n"+ , " { canSignalName = " ++ show (canSignalName signal) ++ "\n"+ , " , canSignalStartBit = " ++ show (canSignalStartBit signal) ++ "\n"+ , " , canSignalBitLength = " ++ show (canSignalBitLength signal) ++ "\n"+ , " , canSignalEndian = " ++ show (canSignalEndian signal) ++ "\n"+ , " , canSignalSign = " ++ show (canSignalSign signal) ++ "\n"+ , " , canSignalFactor = " ++ show (canSignalFactor signal) ++ "\n"+ , " , canSignalOffset = " ++ show (canSignalOffset signal) ++ "\n"+ , " , canSignalMin = " ++ show (canSignalMin signal) ++ "\n"+ , " , canSignalMax = " ++ show (canSignalMax signal) ++ "\n"+ , " , canSignalUnit = " ++ show (canSignalUnit signal) ++ "\n"+ , " , canSignalRxNodes =\n"+ , " [" ++ showCANSignalRxNodes (canSignalRxNodes signal)+ , " ]\n"+ , " , canSignalType = " ++ show (canSignalType signal) ++ "\n"+ , " , canSignalMux = " ++ show (canSignalMux signal) ++ "\n"+ , " }\n"+ ]++showCANSignalRxNodes :: [String] -> String+showCANSignalRxNodes nodes = case nodes of+ [] -> ""+ x -> drop 23 (concatMap showCANSignalRxNode x)++showCANSignalRxNode :: String -> String+showCANSignalRxNode x = " , " ++ show x ++ "\n"+
+ src/CANViewDecompose.hs view
@@ -0,0 +1,273 @@+module Main (main) where++import qualified Data.ByteString.Char8 as BS+import Data.Bits+import Data.Char+import Data.List+import Data.Word+import Text.Printf+import System.Environment++import CANData+import CANDB+import J1939Data++data J1939Info = J1939Info+ { msg_id :: Word32+ , priority :: Word8+ , edp :: Word8+ , dp :: Word8+ , pf :: Word8+ , ge :: Word8+ , pgn :: Word32+ , sa :: Word8+ , da :: Word8+ } deriving (Show, Ord, Eq)++main :: IO ()+main = do+ args <- getArgs+ case args of+ ["-h"] -> help+ ["--help"] -> help+ [] -> processCANViewLine+ _ -> help+ +help :: IO ()+help = putStrLn $ unlines+ [ ""+ , "NAME"+ , " decomp - decompose J1939 messages from 'canview'"+ , ""+ , "EXAMPLE"+ , " canview | decomp"+ , " OR"+ , " decomp < canview.log"+ , ""+ ]++processCANViewLine :: IO ()+processCANViewLine = do+ line <- BS.getLine+ decomposeLine line+ processCANViewLine++decomposeLine :: BS.ByteString -> IO ()+decomposeLine line = do+ BS.putStrLn line+ printTime (getTime line)+ printMsgInfo msgInfo+ decomposePayload msgInfo (getPayload line)+ BS.putStrLn (BS.pack "")+ where+ msgInfo = getInfo (getID line) ++decomposePayload :: J1939Info -> [Word8] -> IO ()+--decomposePayload _ payload = printBytes payload+decomposePayload info payload = case (getCANMsg info) of+ Nothing -> BS.putStrLn bs0+ where+ bs0 = BS.pack $ concat+ [ "<Unknown>:"+ , concatMap formatHexBytes payload+ ]+ Just thisMsg -> do+ BS.putStrLn bs0+ mapM_ (decomposeSignal payload) (canMsgSignals thisMsg)+ where+ bs0 = BS.pack $ concat+ [ printf "%s:" messageName+ , concatMap formatHexBytes payload+ ]+ messageName = canMsgName thisMsg++formatHexBytes :: Word8 -> String+formatHexBytes x = printf " %02X" x++decomposeSignal :: [Word8] -> CANSignal -> IO ()+decomposeSignal payload thisSignal = BS.putStrLn bs0+ where+ bs0 = BS.pack (printf (" %s: " ++ numberFmt) name signal)+ name = canSignalName thisSignal+ signal = decodeSignal payload thisSignal+ numberFmt = case (canSignalFactor thisSignal) of+ 1.0 -> "%.0f"+ _ -> "%f"+ +decodeSignal :: [Word8] -> CANSignal -> Float+decodeSignal payload signal = (fromIntegral binaryValue) * factor + offset+ where+ binaryValue = case (canSignalEndian signal) of+ CANBigEndian -> getBinaryValueBE word64 signal+ CANLittleEndian -> getBinaryValueLE word64 signal+ factor = canSignalFactor signal+ offset = canSignalOffset signal+ word64 = toWord64 payload++getBinaryValueLE :: Word64 -> CANSignal -> Word64+getBinaryValueLE word64 signal = tmp2 .&. mask+ where+ tmp = shiftR word64 ((7 - endByte) * 8)+ tmp1 = rearrangeBytesLEtoBE tmp numBytes+ tmp2 = shiftR tmp1 (mod startBit 8)+ mask = (shiftL 1 bitLength) - 1+ numBytes = 1 + (endByte - startByte)+ startByte = div startBit 8+ endByte = div (startBit + bitLength -1) 8+ bitLength = fromIntegral $ canSignalBitLength signal+ startBit = fromIntegral $ canSignalStartBit signal++getBinaryValueBE :: Word64 -> CANSignal -> Word64+getBinaryValueBE word64 signal = shiftedValue .&. mask+ where+ shiftedValue = shiftR word64 (getShiftAmount signal)+ mask = (shiftL 1 bitLength) - 1+ bitLength = fromIntegral $ canSignalBitLength signal++getShiftAmount :: CANSignal -> Int+getShiftAmount signal = 64 - bitLength - ((div startBit 8) * 8 + (7 - (mod startBit 8)))+ where+ bitLength = fromIntegral $ canSignalBitLength signal+ startBit = fromIntegral $ canSignalStartBit signal+ +rearrangeBytesLEtoBE :: Word64 -> Int -> Word64+rearrangeBytesLEtoBE word64 numBytes = toWord64 rearranged+ where+ desiredBytes = drop (8 - numBytes) (fromWord64 word64)+ numDontCare = 8 - numBytes+ rearranged = (replicate numDontCare 0xFF) ++ (reverse desiredBytes)++getCANMsg :: J1939Info -> Maybe CANMsg+getCANMsg info = find (isSamePGN (msg_id info)) (canDbMsgs canDB)++isSamePGN :: Word32 -> CANMsg -> Bool+isSamePGN matchID thisMsg = matchPGN == thisPGN+ where+ thisPGN = getParameterGroupNumber thisID+ matchPGN = getParameterGroupNumber matchID+ thisID = canMsgId thisMsg++--printBytes :: [Word8] -> IO ()+--printBytes payload = do +-- BS.putStrLn bs0+-- mapM_ printByte (zip [ 1 .. ] payload)+-- where+-- bs0 = BS.pack (printf " Payload:")+--+--printByte :: (Int, Word8) -> IO ()+--printByte (index, byte) = BS.putStrLn bs0+-- where+-- bs0 = BS.pack (printf " Byte%d: %02X" index byte)++getInfo :: Word32 -> J1939Info+getInfo x = J1939Info+ { msg_id = x+ , priority = getPriority x+ , edp = getExtendedDataPage x+ , dp = getDataPage x+ , pf = pduFormat+ , ge = globalExtension+ , pgn = getParameterGroupNumber x+ , sa = getSourceAddress x+ , da = getDestinationAddress x+ }+ where+ pduFormat = getPDUFormat x+ globalExtension = getGlobalExtension x++getPriority :: Word32 -> Word8+getPriority x = fromIntegral $ (shiftR x 26) .&. 0x7++getExtendedDataPage :: Word32 -> Word8+getExtendedDataPage x = fromIntegral $ (shiftR x 25) .&. 0x1+ +getDataPage :: Word32 -> Word8+getDataPage x = fromIntegral $ (shiftR x 24) .&. 0x1++getPDUFormat :: Word32 -> Word8+getPDUFormat x = fromIntegral $ (shiftR x 16) .&. 0xFF++getGlobalExtension :: Word32 -> Word8+getGlobalExtension x = fromIntegral $ (shiftR x 8) .&. 0xFF++getSourceAddress :: Word32 -> Word8+getSourceAddress x = fromIntegral $ x .&. 0xFF++getParameterGroupNumber :: Word32 -> Word32+getParameterGroupNumber x = if (getPDUFormat x) < 240+ then (shiftR x 8) .&. 0x3FF00+ else (shiftR x 8) .&. 0x3FFFF+ +getDestinationAddress :: Word32 -> Word8+getDestinationAddress x = if (getPDUFormat x) < 240+ then (getGlobalExtension x)+ else 0xFE+ +getItems :: [BS.ByteString] -> BS.ByteString -> [BS.ByteString]+getItems bss bs = case BS.null bs of + True -> bss+ False -> getItems (bss ++ [nextItem]) rest+ where+ (nextItem, rest) = BS.span (not . isSpace) noLeadingSpace+ noLeadingSpace = BS.dropWhile isSpace bs++getTime :: BS.ByteString -> Word32+getTime bs = read (BS.unpack (items !! 0))+ where+ items = getItems [] bs+ +getID :: BS.ByteString -> Word32+getID bs = read (BS.unpack (items !! 1))+ where+ items = getItems [] bs++getPayload :: BS.ByteString -> [Word8]+getPayload bs = map read (map BS.unpack hexBytes)+ where+ hexBytes = map (BS.append searchPrefix) (hexPairs hexBS)+ hexBS = case (BS.isPrefixOf searchPrefix payloadBS) of+ True -> BS.drop 2 payloadBS+ False -> payloadBS+ searchPrefix = BS.pack "0x"+ payloadBS = items !! 2+ items = getItems [] bs++hexPairs :: BS.ByteString -> [BS.ByteString]+hexPairs bs+ | BS.null bs = []+ | otherwise = BS.take 2 bs : hexPairs (BS.drop 2 bs)++printTime :: Word32 -> IO ()+printTime time = BS.putStrLn bs+ where+ bs = BS.pack (printf "Time: %9.3f" ms)+ ms = ((fromIntegral time) :: Double) / 1000.0++printMsgInfo :: J1939Info -> IO ()+printMsgInfo info = do+ BS.putStrLn bs0+ BS.putStrLn bs1+ BS.putStrLn bs2+ BS.putStrLn bs3+ BS.putStrLn bs4+ BS.putStrLn bs5+ BS.putStrLn bs6+ BS.putStrLn bs7+ BS.putStrLn bs8+ where+ bs0 = BS.pack (printf "Msg ID: 0x%08X" (msg_id info))+ bs1 = BS.pack (printf " Priority: %d" (priority info))+ bs2 = BS.pack (printf " ExtendedDataPage: %d" (edp info))+ bs3 = BS.pack (printf " DataPage: %d" (dp info))+ bs4 = BS.pack (printf " PDU Format: %d" (pf info))+ bs5 = BS.pack (printf " Global Extension: %d" (ge info))+ bs6 = BS.pack (printf " PGN: 0x%06X" (pgn info))+ bs7 = BS.pack (printf " Source Address: %d (%s)" (sa info) saName)+ bs8 = BS.pack (printf " Destination Address: %d (%s)" (da info) daName)+ saName = case (lookup (sa info) sourceAddressTable) of+ Nothing -> error (printf "couldn't find name for source address 0x%02x" (sa info))+ Just name -> name+ daName = case (lookup (da info) sourceAddressTable) of+ Nothing -> error (printf "couldn't find name for destination address 0x%02x" (da info))+ Just name -> name+