diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for kcd-parser + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 marcelbuesing + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 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/kcd.cabal b/kcd.cabal new file mode 100644 --- /dev/null +++ b/kcd.cabal @@ -0,0 +1,55 @@ +-- Initial kcd-parser.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: kcd +version: 0.1.0.0 +synopsis: Kayak .kcd parsing library. +description: Parse Kayak .kcd files. + Kcd files list CAN messages details, their signal's and signal details, + e.g. the signal offset in the CAN data frame or the signal type. +license: MIT +license-file: LICENSE +author: marcelbuesing +maintainer: buesing.marcel@googlemail.com +-- copyright: +category: Data +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 +homepage: https://github.com/marcelbuesing/kcd +bug-reports: https://github.com/marcelbuesing/kcd/issues + +library + exposed-modules: Kcd + , Kcd.Parser + -- other-modules: + -- other-extensions: + build-depends: base >=4.9 && <4.10 + , conduit >= 1.2.7 + , conduit-parse >= 0.1.2 + , exceptions >= 0.8 + , lens >= 4.14 + , resourcet >= 1.1.7 + , text >= 1.2.2 + , xml-conduit >= 1.3.5 + , xml-types >= 0.3.6 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite test + default-language: + Haskell2010 + type: + exitcode-stdio-1.0 + hs-source-dirs: + tests + main-is: + test.hs + build-depends: base >= 4 && < 5 + , kcd-parser >= 0.1 + , tasty >= 0.11 + , tasty-hunit >= 0.9 + +source-repository head + type: git + location: git@github.com:marcelbuesing/kcd.git diff --git a/src/Kcd.hs b/src/Kcd.hs new file mode 100644 --- /dev/null +++ b/src/Kcd.hs @@ -0,0 +1,5 @@ +module Kcd ( + module Kcd.Parser + ) where + +import Kcd.Parser diff --git a/src/Kcd/Parser.hs b/src/Kcd/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Kcd/Parser.hs @@ -0,0 +1,450 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- > import qualified Kcd.Parser as KCD +-- > main = do +-- > kcd <- KCD.parseKcdFile "example.kcd" +-- > print kcd + +module Kcd.Parser + ( + parseKcdFile + , parseNetworkDefinition + , BasicLabelTypeValue (..) + , Bus (..) + , Consumer (..) + , Document (..) + , Endianess (..) + , Label (..) + , LabelGroup (..) + , LabelSet (..) + , Message (..) + , MessageId (..) + , MessageLength (..) + , Multiplex (..) + , MuxGroup (..) + , NetworkDefinition (..) + , Node (..) + , NodeRef (..) + , Notes (..) + , Producer (..) + , Signal (..) + , Value (..) + , ValueType (..) + , Var (..) + ) +where + +import Control.Applicative ((<|>)) +import Control.Lens.TH (makeLenses) +import Control.Monad (join) +import Control.Monad.Catch (MonadCatch, MonadThrow) +import Control.Monad.Trans.Resource (runResourceT) +import Data.Conduit (($$), ConduitM) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text, pack, unpack) +import Data.Text.Read (Reader, hexadecimal) +import Data.XML.Types (Event, Name(..)) +import Text.XML.Stream.Parse + +-- | Definition of one or more CAN bus networks in one file. +data NetworkDefinition = NetworkDefinition + { _networkDefinitionDocument :: Document + , _networkDefinitionNodes :: [Node] + , _networkDefinitionBuses :: [Bus] + } deriving (Show, Eq) + +-- | Describes the scope of application e.g. the target vehicle or controlled device. +data Document = Document + { -- | The name of the network definition document. + _documentName :: Maybe Text + -- | The version of the network definition document. + , _documentVersion :: Maybe Text + -- | The owner or author of the network definition document. + , _documentAuthor :: Maybe Text + -- | The owner company of the network definition document. + , _documentCompany :: Maybe Text + -- | The release date of this version of the network definition document. + , _documentDate :: Maybe Text + , _documentContent :: Text + } deriving (Show, Eq) + +-- | network transport system that transfers the data between several nodes. +data Bus = Bus + { _busMessages :: [Message] + -- | Human-readable name of the bus network (e.g. "Comfort"). + , _busName :: Text + -- | Nominal data transfer rate in baud (e.g. 500000, 125000, 100000 or 83333). + , _busBaudrate :: Int + } deriving (Show, Eq) + +-- | An endpoint connected to the network (e.g. an electronic control unit) that is able to +-- | send messages to or receive messages from other endpoints. +data Node = Node + { -- | Unique identifier of the network node. + _nodeId :: Text + -- | Human-readable name of the network node (e.g. "Brake"). + , _nodeName :: Maybe Text + , _nodeVars :: [Var] + } deriving (Show, Eq) + +-- | A variable, a symbolic name associated to a chunk of information (e.g. a string or a value). +data Var = Var + { _varValue :: Value + , _varNotes :: Maybe Notes + -- | Unique name of the variable. + , _varName :: Text + } deriving (Show, Eq) + +newtype MessageId = MessageId { _unMessageId :: Int } deriving (Eq, Show, Ord) + +data MessageLength = + Auto + | LengthValue Int deriving (Show, Eq) + +data Message = Message + { _messageNotes :: Maybe Notes + , _messageProducer :: Maybe Producer + , _messageMultiplex :: Maybe Multiplex + , _messageSignals :: [Signal] + , _messageId :: MessageId + , _messageName :: Text + , _messageLength :: MessageLength + -- | Repetition interval of a cyclic network message in milliseconds + , _messageInterval :: Int + -- | Sending behavior of the network message. True, if message is triggered by signal changes. + , _messageTriggered :: Bool + -- | Frame format of the network message. + , _messageFormat :: Text + -- | True, if message is a remote frame + , _messageRemote :: Bool + } deriving (Show, Eq) + +-- | A looping counter to make a group of signals (MuxGroup) alternately active at a time. +data Multiplex = Multiplex + { _multiplexMuxGroup :: [MuxGroup] + , _multiplexNotes :: Maybe Notes + , _multiplexConsumer :: Maybe Consumer + , _multiplexValue :: Maybe Value + , _multiplexLabels :: [Label] + , _multiplexEndianess :: Endianess + -- | Bit length of the signal. + , _multiplexLength :: Int + -- | Human readable name of the signal + , _multiplexName :: Text + -- | Least significant bit offset of the signal relative to the least significant bit of the messages data payload + , _multiplexOffset :: Int + } deriving (Show, Eq) + +-- | A group of signals that is just valid when the count value of the group matches with the looping +-- | counter (Multiplex). +data MuxGroup = MuxGroup + { _muxGroupSignals :: [Signal] + -- | count value of the Multiplex when the signals of this group become valid. + , _muxGroupCount :: Int + } deriving (Show, Eq) + +-- | A discrete part of information contained in the payload of a message. +data Signal = Signal + { -- | Describes the purpose of the signal/variable and/or comments on its usage. + _signalNotes :: Maybe Notes + , _signalConsumer :: Maybe Consumer + , _signalValue :: Maybe Value + -- | A set of label and label groups. Each label describes the meaning of a single raw value by an alias name. + -- | A single value can only belong to a one label or label group. + , _signalLabelSet :: [LabelSet] + -- | Determines if Byteorder is big-endian (Motorola), little-endian (Intel) otherwise. + , _signalEndianess :: Endianess + -- | Bit length of the signal. + , _signalLength :: Int + -- | Human readable name of the signal + , _signalName :: Text + -- | Least significant bit offset of the signal relative to the least significant bit of the messages data payload + , _signalOffset :: Int + } deriving (Show, Eq) + +data ValueType = + ValueTypeUnsigned -- Unsigned + | ValueTypeSigned -- Signed + | ValueTypeSingle -- Single + | ValueTypeDouble -- Double + deriving (Show, Eq) + +-- | Details of how the raw value of the signal/variable shall be interpreted. +data Value = Value + { -- | Lower validity limit of the interpreted value after using the slope/intercept equation. + _valueMin :: Double + -- | Upper validity limit of the interpreted value after using the slope/intercept equation. + , _valueMax :: Double + -- | The slope "m" of a linear equation y = mx + b. + , _valueSlope :: Double + -- | The y-axis intercept "b" of a linear equation y = mx + b. + , _valueIntercept :: Double + -- | Physical unit of the value written as unit term as described in "The Unified Code for Units of Measure" + -- | (http :://unitsofmeasure.org/ucum.html) + , _valueUnit :: Text + -- | Datatype of the value e.g. "unsigned","signed" or IEE754 "single", "double". + , _valueType :: ValueType + } deriving (Show, Eq) + +-- | Network node that is a user/receiver of the assigned signal. +data Consumer = Consumer + { _consumerNodeRef :: [NodeRef] + } deriving (Show, Eq) + +-- | Origin network node that is the sender of the assigned message. +data Producer = Producer + { _producerNodeRef :: [NodeRef] + } deriving (Show, Eq) + +-- | An endpoint connected to the network that is able to send messages to or receive messages from other endpoints. +data NodeRef = NodeRef + { -- | Referencing a network node by its unique identifier. + _nodeRefId :: Text + } deriving (Show, Eq) + +-- | Descriptive name for a single value e.g. to describe an enumeration, mark special,invalid or error values. +data Label = Label + { -- | Signal raw value that is described here. + _labelValue :: Int + -- | Human readable name of the signal + , _labelName :: Text + , _labelType :: BasicLabelTypeValue + } deriving (Show, Eq) + +data LabelGroup = LabelGroup + { -- | Signal raw value the label group is starting with. + _labelGroupFrom :: Text + -- | Signal raw value the label group is ending with. + , _labelGroupTo :: Text + -- | Human-readable name for this value. + , _labelGroupName :: Text + -- | Type of value :: "value", "invalid" or "error" + , _labelGroupType :: BasicLabelTypeValue + } deriving (Show, Eq) + +data LabelSet = LabelSet + { _labelSetLabel :: [Label] + , _labelSetLabelGroup :: [LabelGroup] + } deriving (Show, Eq) + +data BasicLabelTypeValue = + TypeValue -- Value + | TypeInvalid -- Invalid + | TypeError -- Error + deriving (Show, Eq) + +data Endianess = + LittleEndian -- Little + | BigEndian -- Big + deriving (Show, Eq) + +-- | Describes the purpose of the signal/variable and/or comments on its usage. +newtype Notes = Notes Text deriving (Show, Eq); + +parseSettings :: ParseSettings +parseSettings = def { psDecodeEntities = decodeHtmlEntities + , psRetainNamespaces = False } + +parseKcdFile :: String -> IO NetworkDefinition +parseKcdFile f = runResourceT $ + parseFile parseSettings f $$ + force "Missing NetworkDefinition" parseNetworkDefinition + +parseNetworkDefinition :: MonadThrow m => ConduitM Event o m (Maybe NetworkDefinition) +parseNetworkDefinition = tagIgnoreAttrs (ns "NetworkDefinition") $ do + document <- force "Missing document" parseDocument + nodes <- many parseNode + buses <- many parseBus + return $ NetworkDefinition document nodes buses + +parseDocument :: MonadThrow m => ConduitM Event o m (Maybe Document) +parseDocument = tagName (ns "Document") attrs $ \(name, version, author, company, date) -> do + docContent <- content + return $ Document name version author company date docContent + where attrs = do + name <- attr "name" + version <- attr "version" + author <- attr "author" + company <- attr "company" + date <- attr "date" + return $ (,,,,) name version author company date + +parseVar :: MonadThrow m => ConduitM Event o m (Maybe Var) +parseVar = tagName (ns "Var") (requireAttr "name") $ \name -> do + notes <- parseNotes + value <- force "Missing Value" parseValue + return $ Var value notes name + +parseBus :: MonadThrow m => ConduitM Event o m (Maybe Bus) +parseBus = tagName (ns "Bus") attrs $ \(name, baudrate)-> do + messages <- many parseMessage + return $ Bus messages name baudrate + where attrs = do + name <- requireAttr "name" + baudrate <- fromMaybe 500000 <$> attrRead "baudrate" + return (name, baudrate) + +parseMessageLength :: Text -> MessageLength +parseMessageLength "auto" = Auto +parseMessageLength i = LengthValue $ read $ unpack i + +parseMessage :: MonadThrow m => ConduitM Event o m (Maybe Message) +parseMessage = tagName (ns "Message") attrs $ \(id, name, length, interval, triggered, count, format, remote) -> do + notes <- parseNotes + producer <- parseProducer + multiplex <- parseMultiplex + signals <- many parseSignal + return $ Message notes producer multiplex signals id name length interval triggered format remote + where attrs = do + id <- (MessageId . readHexNumber) <$> requireAttr "id" + name <- requireAttr "name" + length <- maybe Auto parseMessageLength <$> attr "length" + interval <- fromMaybe 0 <$> attrRead "interval" + triggered <- fromMaybe False <$> attrRead "triggered" + count <- fromMaybe 0 <$> attrRead "count" + format <- fromMaybe "standard" <$> attr "format" + remote <- fromMaybe False <$> attrRead "remote" + return (id, name, length, interval, triggered, count, format, remote) + +readHexNumber :: Text -> Int +readHexNumber s = let (Right (n, _)) = hexadecimal s in n + +basicSignalAttrs :: AttrParser (Endianess, Int, Text, Int) +basicSignalAttrs = do + endianess <- (fromMaybe LittleEndian . join . fmap parseEndianess) <$> attr "endianess" + length <- fromMaybe 1 <$> attrRead "length" + name <- requireAttr "name" + offset <- (read . unpack) <$> requireAttr "offset" + return (endianess, length, name, offset) + +parseMultiplex :: MonadThrow m => ConduitM Event o m (Maybe Multiplex) +parseMultiplex = tagName (ns "Multiplex") basicSignalAttrs $ \(endianess, length, name, offset) -> do + muxGroup <- many parseMuxGroup + notes <- parseNotes + consumer <- parseConsumer + value <- parseValue + labels <- many parseLabel + return $ Multiplex muxGroup notes consumer value labels endianess length name offset + +parseMuxGroup :: MonadThrow m => ConduitM Event o m (Maybe MuxGroup) +parseMuxGroup = tagName (ns "MuxGroup") countAttr $ \count -> do + signals <- many parseSignal + return $ MuxGroup signals count + where countAttr = (read . unpack) <$> requireAttr "count" + +parseSignal :: MonadThrow m => ConduitM Event o m (Maybe Signal) +parseSignal = tagName (ns "Signal") basicSignalAttrs $ \(endianess, length, name, offset) -> do + notes <- parseNotes + consumer <- parseConsumer + value <- parseValue + labelSet <- many parseLabelSet + return $ Signal notes consumer value labelSet endianess length name offset + +parseValueType :: Text -> Maybe ValueType +parseValueType "unsigned" = Just ValueTypeUnsigned +parseValueType "signed" = Just ValueTypeSigned +parseValueType "single" = Just ValueTypeSingle +parseValueType "double" = Just ValueTypeDouble +parseValueType _ = Nothing + +parseValue :: MonadThrow m => ConduitM Event o m (Maybe Value) +parseValue = tagName (ns "Value") attrs $ \value -> return value + where attrs = do + min <- fromMaybe 0.0 <$> attrRead "min" + max <- fromMaybe 0.0 <$> attrRead "max" + slope <- fromMaybe 0.0 <$> attrRead "slope" + intercept <- fromMaybe 0.0 <$> attrRead "intercept" + unit <- fromMaybe "1" <$> attr "unit" + type' <- (fromMaybe ValueTypeUnsigned . join . fmap parseValueType) <$> attr "type" + return $ Value min max slope intercept unit type' + +parseConsumer :: MonadThrow m => ConduitM Event o m (Maybe Consumer) +parseConsumer = tagNoAttr (ns "Consumer") $ do + nodeRefs <- many parseNodeRef + return $ Consumer nodeRefs + +parseProducer :: MonadThrow m => ConduitM Event o m (Maybe Producer) +parseProducer = tagNoAttr (ns "Producer") $ do + nodeRefs <- many parseNodeRef + return $ Producer nodeRefs + +parseNode :: MonadThrow m => ConduitM Event o m (Maybe Node) +parseNode = tagName (ns "Node") attrs $ \(id, name) -> do + vars <- many parseVar + return $ Node id name vars + where attrs = do + id <- requireAttr "id" + name <- attr "name" + return (id, name) + +parseNodeRef :: MonadThrow m => ConduitM Event o m (Maybe NodeRef) +parseNodeRef = tagName (ns "NodeRef") (requireAttr "id") $ \id -> return $ NodeRef id + +parseLabel :: MonadThrow m => ConduitM Event o m (Maybe Label) +parseLabel = tagName (ns "Label") attrs $ \(value, name, type') -> + return $ Label value name type' + where attrs = do + value <- (read . unpack) <$> requireAttr "value" + name <- requireAttr "name" + type' <- (fromMaybe TypeValue . join) . fmap parseBasicLabelTypeValue <$> attr "type" + return (value, name, type') + +parseLabelGroup :: MonadThrow m => ConduitM Event o m (Maybe LabelGroup) +parseLabelGroup = tagName (ns "LabelGroup") attrs $ \(from, to, name, type') -> return $ LabelGroup from to name type' + where attrs = do + from <- requireAttr "from" + to <- requireAttr "to" + name <- requireAttr "name" + type' <- (fromMaybe TypeValue . join . fmap parseBasicLabelTypeValue) <$> attr "type" + return (from, to, name, type') + +parseNotes :: MonadThrow m => ConduitM Event o m (Maybe Notes) +parseNotes = tagNoAttr (ns "Notes") $ do + note <- content + return $ Notes note + +parseBasicLabelTypeValue :: Text -> Maybe BasicLabelTypeValue +parseBasicLabelTypeValue "value" = Just TypeValue +parseBasicLabelTypeValue "invalid" = Just TypeInvalid +parseBasicLabelTypeValue "error" = Just TypeError +parseBasicLabelTypeValue _ = Nothing + +parseEndianess :: Text -> Maybe Endianess +parseEndianess "little" = Just LittleEndian +parseEndianess "big" = Just BigEndian +parseEndianess _ = Nothing + +parseLabelSet :: MonadThrow m => ConduitM Event o m (Maybe LabelSet) +parseLabelSet = tagNoAttr (ns "LabelSet") $ do + labels <- many parseLabel + labelGroups <- many parseLabelGroup + return $ LabelSet labels labelGroups + +attrRead :: Read a => Name -> AttrParser (Maybe a) +attrRead name = fmap (read . unpack) <$> attr name + +ns :: Text -> Name +ns n = let ns' = Just "http://kayak.2codeornot2code.org/1.0" + pfx = Nothing + in Name n ns' pfx + +makeLenses ''Bus +makeLenses ''Consumer +makeLenses ''Document +makeLenses ''Label +makeLenses ''LabelGroup +makeLenses ''LabelSet +makeLenses ''Message +makeLenses ''Multiplex +makeLenses ''MuxGroup +makeLenses ''NetworkDefinition +makeLenses ''Node +makeLenses ''NodeRef +makeLenses ''Producer +makeLenses ''Signal +makeLenses ''Value +makeLenses ''Var diff --git a/tests/test.hs b/tests/test.hs new file mode 100644 --- /dev/null +++ b/tests/test.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Test.Tasty +import Test.Tasty.HUnit + +import Kcd.Parser + +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [unitTests] + +unitTests = testGroup "Parsing" + [ testCase "Test file" $ do + file <- parseKcdFile "test_example.kcd" + _documentName (_networkDefinitionDocument file) @?= Just "???" + ]