scaffolder/src/Text/Edifact/Scaffolder/Messages/Specification.hs

   1 {-# LANGUAGE DerivingStrategies         #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3
   4 module Text.Edifact.Scaffolder.Messages.Specification
   5   ( -- *
   6     specificationParser
   7   , messageNameParser
   8   , listSegments
   9   ) where
  10
  11 import           Text.Edifact.Scaffolder.Commons
  12 import           Text.Edifact.Scaffolder.Messages.Types
  13
  14 import           Data.Maybe                             (mapMaybe)
  15 import           Text.Parsec
  16
  17 type Parser = Parsec String GroupTrail
  18
  19 newtype GroupTrail = GroupTrail [GroupCode]
  20   deriving stock Show
  21   deriving newtype (Semigroup, Monoid)
  22
  23 messageNameParser :: Parser MessageCode
  24 messageNameParser = scanUntil [
  25     manyTill anyChar (string "Message Type : ") >> MessageCode <$> count 6 upper
  26   ]
  27
  28 specificationParser :: Parser [Dependency]
  29 specificationParser =
  30   let scanElements = scan [ segmentInLine segmentElementParser
  31                           , groupInLine   groupStartElementParser
  32                           ]
  33   in interpretDependencies <$> scanElements <?> "Messages specification"
  34
  35 listSegments :: Parser [SegmentCode]
  36 listSegments = mapMaybe (getSegment . getElement) <$> specificationParser
  37
  38 interpretDependencies :: [Element] -> [Dependency]
  39 interpretDependencies = fmap Dependency
  40
  41 groupInLine :: Parser a -> Parser [a]
  42 groupInLine p = single (many (string " ") *> p <* countClosingGroups)
  43
  44 countClosingGroups :: Parser Int
  45 countClosingGroups =
  46   let parser = many1 (char '-')
  47             *> many1 (char '+')
  48            <*  many  (char '|')
  49   in length <$> parser
  50
  51 closingGroupTrail :: Parser [Element]
  52 closingGroupTrail =
  53   let groupEndParser = GroupEnd <$> popFromTrail
  54   in countClosingGroups >>= flip count groupEndParser
  55
  56 groupStartElementParser :: Parser Element
  57 groupStartElementParser =
  58   let parseStart pos code rep = GroupStart code (Positional pos rep)
  59   in parseStart <$> positionParser
  60                 <*  many1 (choice [ () <$ try (oneOf "+*#|X "), () <$ try (string "- ") ])
  61                 <*> groupCodeParser
  62                 <*  many1 (char ' ')
  63                 <*> repetitionParser
  64                 <?> "GroupElement"
  65
  66 groupCodeParser :: Parser GroupCode
  67 groupCodeParser =
  68   let parser = manyTill (char '-') (try $ string "-- Segment group")
  69             *> many1 (char ' ')
  70             *> many1 digit
  71            <*  many1 space
  72            <*  many1 (char '-')
  73       group = GroupCode <$> parser
  74   in group >>= appendToTrail <?> "GroupCodeParser"
  75
  76 appendToTrail :: GroupCode -> Parser GroupCode
  77 appendToTrail code =
  78   let append (GroupTrail trail) = GroupTrail (code : trail)
  79   in code <$ modifyState append
  80
  81 popFromTrail :: Parser GroupCode
  82 popFromTrail = do
  83   previous <- getState
  84   case previous of
  85     GroupTrail (current : trail) -> current <$ putState (GroupTrail trail)
  86     GroupTrail []                -> unexpected "GroupEnd, when state is currently clear"
  87
  88 segmentTrail :: Parser [a]
  89 segmentTrail = [] <$ (many1 (char ' ') <* many (char '|'))
  90
  91 segmentInLine :: Parser Element -> Parser [Element]
  92 segmentInLine p = do
  93   segment <- many (string " ") *> p
  94   trail <- choice [ try closingGroupTrail
  95                   , try segmentTrail
  96                   ]
  97   pure (segment : trail)
  98
  99 repetitionParser :: Parser Repetition
 100 repetitionParser =
 101   Repetition <$> presenceParser
 102              <*  many1 (string " ")
 103              <*> cardinalityParser
 104              <?> "Repetition"
 105
 106 positionParser :: Parser Position
 107 positionParser =
 108   fromString <$> many1 digit
 109              <?> "Position"
 110
 111 segmentElementParser :: Parser Element
 112 segmentElementParser =
 113   let parseSegment pos code rep = Segment code (Positional pos rep)
 114   in parseSegment <$> positionParser
 115                   <*  many1 (oneOf "+*#|-X ")
 116                   <*> segmentCodeParser
 117                   <*  many1 (string " ")
 118                   <*  stringToPresenceParser
 119                   <*  many1 (string " ")
 120                   <*> repetitionParser
 121                   <?> "SegmentElement"
 122
 123 segmentCodeParser :: Parser SegmentCode
 124 segmentCodeParser =
 125   fromString <$> count 3 upper
 126              <?> "SegmentCode"
 127
 128 cardinalityParser :: Parser Cardinality
 129 cardinalityParser = Cardinality . read <$> many1 digit