core/src/Text/Edifact/Parsing/Combinators.hs

   1 {-# LANGUAGE TupleSections #-}
   2
   3 {-|
   4 Module      : Text.Edifact.Parsing.Combinators
   5 Description : High level combinators
   6  -}
   7 module Text.Edifact.Parsing.Combinators
   8   ( -- * Combinators
   9     -- ** Values parsers
  10     message
  11   , segmentGroup
  12   , segment
  13   , composite
  14   , simple
  15
  16     -- ** Position and strictness
  17   , position
  18   , (.@)
  19   , (@.)
  20   , mandatory
  21   , optional
  22
  23     -- ** Repetition of segments and segment groups
  24   , repeated
  25   , repeatedAtLeastOnce
  26   , once
  27   , maybeOnce
  28   ) where
  29
  30 import           Text.Edifact.Parsing.Commons
  31 import           Text.Edifact.Types
  32
  33 import           Text.Parsec                  (lookAhead, many1, optionMaybe,
  34                                                string, try)
  35 import qualified Text.Parsec                  as P (many)
  36
  37 -- | Parses a 'Message'.
  38 --
  39 -- > messageABCDEF :: Parser Value
  40 -- > messageABCDEF =
  41 -- >   let simple1234 = simple "1234" (alphaNumeric `upTo` 35)
  42 -- >       c101 = composite "C101" [ position "010" (mandatory simple1234)
  43 -- >                               , position "020" (optional  simple1234)
  44 -- >                               ]
  45 -- >       segmentABC = segment "ABC" [ position "010" (mandatory c101)
  46 -- >                                  ]
  47 -- >   in message "ABCDEF" [ position "0010" (mandatory segmentABC)
  48 -- >                       ]
  49 message :: MessageCode -> [Parser (Position, [Value])] -> Parser Value
  50 message code ps =
  51   let description = "message " <> show code
  52   in Message code <$> sequence ps <??> description
  53
  54 -- | Parses a 'Group'.
  55 --
  56 -- A Segment Group is the way Edifact format represents hierarchy. One can view
  57 -- a segment group as a sub message. A segment group can be repeated like
  58 -- segments. A segment group wraps segments and segment groups.
  59 segmentGroup :: GroupCode -> [Parser (Position, [Value])] -> Parser Value
  60 segmentGroup code ps =
  61   let description = "segment-group " <> show code
  62   in Group code <$> sequence ps <??> description
  63
  64 -- | Parses a 'Segment'.
  65 --
  66 -- Following parser:
  67 --
  68 -- > segmentABC :: Parser Value
  69 -- > segmentABC =
  70 -- >   let simple1234 = simple "1234" (alphaNumeric `upTo` 35)
  71 -- >       simple2001 = simple "2001" (alphaNumeric `exactly` 3)
  72 -- >       c101 = composite "C101" [ position "010" (mandatory simple1234)
  73 -- >                               , position "020" (optional  simple1234)
  74 -- >                               , position "030" (optional  simple1234)
  75 -- >                               ]
  76 -- >   in  segment "ABC" [ position "010" (mandatory simple2001)
  77 -- >                     , position "020" (optional c101)
  78 -- >                     ]
  79 --
  80 -- would parse strings such as:
  81 --
  82 -- >>> parse segmentABC "ABC+123'"
  83 -- Segment "ABC" [ ("010", Just (Simple "2001" "123"))
  84 --               ]
  85 -- >>> parse segmentABC "ABC+123+abcdefgh'"
  86 -- Segment "ABC" [ ("010", Just (Simple "2001" "123"))
  87 --               , ("020", Just (Composite "C101" [ ("010", Just (Simple "1234" "abcdefgh"))
  88 --                                                ]
  89 --                              ))
  90 --               ]
  91 -- >>> parse segmentABC "ABC+123+abcdefgh:ijklmno'"
  92 -- Segment "ABC" [ ("010", Just (Simple "2001" "123"))
  93 --               , ("020", Just (Composite "C101" [ ("010", Just (Simple "1234" "abcdefgh"))
  94 --                                                , ("020", Just (Simple "1234" "ijklmno"))
  95 --                                                ]
  96 --                              ))
  97 --               ]
  98 segment :: SegmentCode -> [Parser (Position, Maybe Value)] -> Parser Value
  99 segment code parsers =
 100   let go []  = [] <$ parseSegmentSeparator
 101       go (p:ps) =
 102         tries [ []  <$  parseSegmentSeparator
 103               , (:) <$> (parseElementSeparator *> p)
 104                     <*> go ps
 105               ]
 106       description = "segment " <> show code
 107   in Segment <$>  parseSegmentCode code
 108              <*>  go parsers
 109              <??> description
 110
 111 parseSegmentCode :: SegmentCode -> Parser SegmentCode
 112 parseSegmentCode (SegmentCode code) =
 113   let description = "segment code " <> show code
 114   in SegmentCode <$> string code <??> description
 115
 116 -- | Parses a 'Composite' element.
 117 --
 118 -- Following parser:
 119 --
 120 -- > compositeC101 :: Parser Value
 121 -- > compositeC101 =
 122 -- >   let simple1234 = simple "1234" (alphaNumeric `upTo` 35)
 123 -- >   in composite "C101" [ position "010" (mandatory simple1234)
 124 -- >                       , position "020" (optional  simple1234)
 125 -- >                       , position "030" (optional  simple1234)
 126 -- >                       ]
 127 --
 128 -- would parse strings such as:
 129 --
 130 -- >>> parse compositeC101 "abcdefgh"
 131 -- Composite "C101" [ ("010", Just (Simple "1234" "abcdefgh"))
 132 --                  ]
 133 -- >>> parse compositeC101 "abcdefgh:ijklmno"
 134 -- Composite "C101" [ ("010", Just (Simple "1234" "abcdefgh"))
 135 --                  , ("020", Just (Simple "1234" "ijklmno"))
 136 --                  ]
 137 -- >>> parse compositeC101 "abcdefgh::pqrstu"
 138 -- Composite "C101" [ ("010", Just (Simple "1234" "abcdefgh"))
 139 --                  , ("020", Just (Simple "1234" ""))
 140 --                  , ("030", Just (Simple "1234" "pqrstu"))
 141 --                  ]
 142 composite :: CompositeCode -> [Parser (Position, Maybe Value)] -> Parser Value
 143 composite code parsers =
 144   let go []  = pure []
 145       go (p:ps) = do
 146         let parseSeparator = tries [ parseCompositeSeparator
 147                                    , lookAhead parseElementSeparator
 148                                    , lookAhead parseSegmentSeparator
 149                                    ]
 150         (value, continuation) <- tries [ (, ps) <$> p <* parseSeparator
 151                                        , (, []) <$> p
 152                                        ]
 153         (:) value <$> go continuation
 154       description = "composite element " <> show code
 155   in Composite code <$> go parsers <??> description
 156
 157 -- | Parses a 'Simple' element.
 158 --
 159 -- Following parser would parse strings of size between 0 and 35 characters.
 160 --
 161 -- > simple1234 :: Parser Value
 162 -- > simple1234 = simple "1234" (alphaNumeric `upTo` 35)
 163 simple :: SimpleCode -> Parser Primitive -> Parser Value
 164 simple code p =
 165   let description = "simple element " <> show code
 166   in Simple code <$> p <??> description
 167
 168 -- | Makes the parsing of the element optional, which doesn't consume input if the given parser doesn't succeed.
 169 optional :: Parser Value -> Parser (Maybe Value)
 170 optional = optionMaybe
 171
 172 -- | Makes the parsing of the element mandatory.
 173 mandatory :: Parser Value -> Parser (Maybe Value)
 174 mandatory = fmap Just
 175
 176 -- | Sets the current 'Position'. This is relevant for segment in a message, for composite or simple element in a segment, and for simple element in a composite.
 177 position :: Position -> Parser (f Value) -> Parser (Position, f Value)
 178 position pos p =
 179   let decorated = (pos,) <$> p
 180   in setCurrentPosition pos *> decorated <* resetCurrentPosition
 181
 182 -- | Alias to 'position'.
 183 --
 184 -- > compositeC101 :: Parser Value
 185 -- > compositeC101 =
 186 -- >   let simple1234 = simple "1234" (alphaNumeric `upTo` 35)
 187 -- >   in composite "C101" [ "010" .@ mandatory simple1234
 188 -- >                       , "020" .@ optional  simple1234
 189 -- >                       , "030" .@ optional  simple1234
 190 -- >                       ]
 191 (.@) :: Position -> Parser (f Value) -> Parser (Position, f Value)
 192 (.@) = position
 193
 194 -- | Flipped alias to 'position'.
 195 --
 196 -- > compositeC101 :: Parser Value
 197 -- > compositeC101 =
 198 -- >   let simple1234 = simple "1234" (alphaNumeric `upTo` 35)
 199 -- >   in composite "C101" [ mandatory simple1234 @. "010"
 200 -- >                       , optional  simple1234 @. "020"
 201 -- >                       , optional  simple1234 @. "030"
 202 -- >                       ]
 203 (@.) :: Parser (f Value) -> Position -> Parser (Position, f Value)
 204 (@.) = flip position
 205
 206 -- | For segments or segment groups, let you express how many occurrences.
 207 repeated :: Int -> Parser a -> Parser [a]
 208 repeated limit p = do
 209   values <- P.many (try p)
 210   let parsed = length values
 211   if parsed > limit
 212   then failWithPosition ("expected up to " <> show limit <> " items, but encountered " <> show parsed)
 213   else pure values
 214
 215 -- | For segments or segment groups, let you express how many occurrences with at least one occurrence.
 216 repeatedAtLeastOnce :: Int -> Parser a -> Parser [a]
 217 repeatedAtLeastOnce limit p = do
 218   values <- many1 (try p)
 219   let parsed = length values
 220   if parsed > limit
 221   then failWithPosition ("expected up to " <> show limit <> " items, but encountered " <> show parsed)
 222   else pure values
 223
 224 -- | For segments or segment groups, let you express you expect only one occurrence.
 225 once :: Parser a -> Parser [a]
 226 once = fmap pure
 227
 228 -- | For segments or segment groups, let you express you expect one or no occurrence.
 229 maybeOnce :: Parser a -> Parser [a]
 230 maybeOnce = fmap (maybe [] pure) . optionMaybe