kcd (empty) → 0.1.0.0
raw patch · 7 files changed
+554/−0 lines, 7 filesdep +basedep +conduitdep +conduit-parsesetup-changed
Dependencies added: base, conduit, conduit-parse, exceptions, kcd-parser, lens, resourcet, tasty, tasty-hunit, text, xml-conduit, xml-types
Files
- ChangeLog.md +5/−0
- LICENSE +20/−0
- Setup.hs +2/−0
- kcd.cabal +55/−0
- src/Kcd.hs +5/−0
- src/Kcd/Parser.hs +450/−0
- tests/test.hs +17/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for kcd-parser++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ kcd.cabal view
@@ -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
+ src/Kcd.hs view
@@ -0,0 +1,5 @@+module Kcd (+ module Kcd.Parser+ ) where++import Kcd.Parser
+ src/Kcd/Parser.hs view
@@ -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
+ tests/test.hs view
@@ -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 "???"+ ]