ecu-0.0.6: src/CANDBParser.hs
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"