Release code as open sourceHEADmaster

3 files changed, 530 insertions, 0 deletions

diff --git a/core/src/Text/Edifact/Parsing/Combinators.hs b/core/src/Text/Edifact/Parsing/Combinators.hs
new file mode 100644
index 0000000..ce3f4be
--- /dev/null
+++ b/core/src/Text/Edifact/Parsing/Combinators.hs
@@ -0,0 +1,230 @@
+{-# LANGUAGE TupleSections #-}
+
+{-|
+Module      : Text.Edifact.Parsing.Combinators
+Description : High level combinators
+ -}
+module Text.Edifact.Parsing.Combinators
+  ( -- * Combinators
+    -- ** Values parsers
+    message
+  , segmentGroup
+  , segment
+  , composite
+  , simple
+
+    -- ** Position and strictness
+  , position
+  , (.@)
+  , (@.)
+  , mandatory
+  , optional
+
+    -- ** Repetition of segments and segment groups
+  , repeated
+  , repeatedAtLeastOnce
+  , once
+  , maybeOnce
+  ) where
+
+import           Text.Edifact.Parsing.Commons
+import           Text.Edifact.Types
+
+import           Text.Parsec                  (lookAhead, many1, optionMaybe,
+                                               string, try)
+import qualified Text.Parsec                  as P (many)
+
+-- | Parses a 'Message'.
+--
+-- > messageABCDEF :: Parser Value
+-- > messageABCDEF =
+-- >   let simple1234 = simple "1234" (alphaNumeric `upTo` 35)
+-- >       c101 = composite "C101" [ position "010" (mandatory simple1234)
+-- >                               , position "020" (optional  simple1234)
+-- >                               ]
+-- >       segmentABC = segment "ABC" [ position "010" (mandatory c101)
+-- >                                  ]
+-- >   in message "ABCDEF" [ position "0010" (mandatory segmentABC)
+-- >                       ]
+message :: MessageCode -> [Parser (Position, [Value])] -> Parser Value
+message code ps =
+  let description = "message " <> show code
+  in Message code <$> sequence ps <??> description
+
+-- | Parses a 'Group'.
+--
+-- A Segment Group is the way Edifact format represents hierarchy. One can view
+-- a segment group as a sub message. A segment group can be repeated like
+-- segments. A segment group wraps segments and segment groups.
+segmentGroup :: GroupCode -> [Parser (Position, [Value])] -> Parser Value
+segmentGroup code ps =
+  let description = "segment-group " <> show code
+  in Group code <$> sequence ps <??> description
+
+-- | Parses a 'Segment'.
+--
+-- Following parser:
+--
+-- > segmentABC :: Parser Value
+-- > segmentABC =
+-- >   let simple1234 = simple "1234" (alphaNumeric `upTo` 35)
+-- >       simple2001 = simple "2001" (alphaNumeric `exactly` 3)
+-- >       c101 = composite "C101" [ position "010" (mandatory simple1234)
+-- >                               , position "020" (optional  simple1234)
+-- >                               , position "030" (optional  simple1234)
+-- >                               ]
+-- >   in  segment "ABC" [ position "010" (mandatory simple2001)
+-- >                     , position "020" (optional c101)
+-- >                     ]
+--
+-- would parse strings such as:
+--
+-- >>> parse segmentABC "ABC+123'"
+-- Segment "ABC" [ ("010", Just (Simple "2001" "123"))
+--               ]
+-- >>> parse segmentABC "ABC+123+abcdefgh'"
+-- Segment "ABC" [ ("010", Just (Simple "2001" "123"))
+--               , ("020", Just (Composite "C101" [ ("010", Just (Simple "1234" "abcdefgh"))
+--                                                ]
+--                              ))
+--               ]
+-- >>> parse segmentABC "ABC+123+abcdefgh:ijklmno'"
+-- Segment "ABC" [ ("010", Just (Simple "2001" "123"))
+--               , ("020", Just (Composite "C101" [ ("010", Just (Simple "1234" "abcdefgh"))
+--                                                , ("020", Just (Simple "1234" "ijklmno"))
+--                                                ]
+--                              ))
+--               ]
+segment :: SegmentCode -> [Parser (Position, Maybe Value)] -> Parser Value
+segment code parsers =
+  let go []  = [] <$ parseSegmentSeparator
+      go (p:ps) =
+        tries [ []  <$  parseSegmentSeparator
+              , (:) <$> (parseElementSeparator *> p)
+                    <*> go ps
+              ]
+      description = "segment " <> show code
+  in Segment <$>  parseSegmentCode code
+             <*>  go parsers
+             <??> description
+
+parseSegmentCode :: SegmentCode -> Parser SegmentCode
+parseSegmentCode (SegmentCode code) =
+  let description = "segment code " <> show code
+  in SegmentCode <$> string code <??> description
+
+-- | Parses a 'Composite' element.
+--
+-- Following parser:
+--
+-- > compositeC101 :: Parser Value
+-- > compositeC101 =
+-- >   let simple1234 = simple "1234" (alphaNumeric `upTo` 35)
+-- >   in composite "C101" [ position "010" (mandatory simple1234)
+-- >                       , position "020" (optional  simple1234)
+-- >                       , position "030" (optional  simple1234)
+-- >                       ]
+--
+-- would parse strings such as:
+--
+-- >>> parse compositeC101 "abcdefgh"
+-- Composite "C101" [ ("010", Just (Simple "1234" "abcdefgh"))
+--                  ]
+-- >>> parse compositeC101 "abcdefgh:ijklmno"
+-- Composite "C101" [ ("010", Just (Simple "1234" "abcdefgh"))
+--                  , ("020", Just (Simple "1234" "ijklmno"))
+--                  ]
+-- >>> parse compositeC101 "abcdefgh::pqrstu"
+-- Composite "C101" [ ("010", Just (Simple "1234" "abcdefgh"))
+--                  , ("020", Just (Simple "1234" ""))
+--                  , ("030", Just (Simple "1234" "pqrstu"))
+--                  ]
+composite :: CompositeCode -> [Parser (Position, Maybe Value)] -> Parser Value
+composite code parsers =
+  let go []  = pure []
+      go (p:ps) = do
+        let parseSeparator = tries [ parseCompositeSeparator
+                                   , lookAhead parseElementSeparator
+                                   , lookAhead parseSegmentSeparator
+                                   ]
+        (value, continuation) <- tries [ (, ps) <$> p <* parseSeparator
+                                       , (, []) <$> p
+                                       ]
+        (:) value <$> go continuation
+      description = "composite element " <> show code
+  in Composite code <$> go parsers <??> description
+
+-- | Parses a 'Simple' element.
+--
+-- Following parser would parse strings of size between 0 and 35 characters.
+--
+-- > simple1234 :: Parser Value
+-- > simple1234 = simple "1234" (alphaNumeric `upTo` 35)
+simple :: SimpleCode -> Parser Primitive -> Parser Value
+simple code p =
+  let description = "simple element " <> show code
+  in Simple code <$> p <??> description
+
+-- | Makes the parsing of the element optional, which doesn't consume input if the given parser doesn't succeed.
+optional :: Parser Value -> Parser (Maybe Value)
+optional = optionMaybe
+
+-- | Makes the parsing of the element mandatory.
+mandatory :: Parser Value -> Parser (Maybe Value)
+mandatory = fmap Just
+
+-- | 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.
+position :: Position -> Parser (f Value) -> Parser (Position, f Value)
+position pos p =
+  let decorated = (pos,) <$> p
+  in setCurrentPosition pos *> decorated <* resetCurrentPosition
+
+-- | Alias to 'position'.
+--
+-- > compositeC101 :: Parser Value
+-- > compositeC101 =
+-- >   let simple1234 = simple "1234" (alphaNumeric `upTo` 35)
+-- >   in composite "C101" [ "010" .@ mandatory simple1234
+-- >                       , "020" .@ optional  simple1234
+-- >                       , "030" .@ optional  simple1234
+-- >                       ]
+(.@) :: Position -> Parser (f Value) -> Parser (Position, f Value)
+(.@) = position
+
+-- | Flipped alias to 'position'.
+--
+-- > compositeC101 :: Parser Value
+-- > compositeC101 =
+-- >   let simple1234 = simple "1234" (alphaNumeric `upTo` 35)
+-- >   in composite "C101" [ mandatory simple1234 @. "010"
+-- >                       , optional  simple1234 @. "020"
+-- >                       , optional  simple1234 @. "030"
+-- >                       ]
+(@.) :: Parser (f Value) -> Position -> Parser (Position, f Value)
+(@.) = flip position
+
+-- | For segments or segment groups, let you express how many occurrences.
+repeated :: Int -> Parser a -> Parser [a]
+repeated limit p = do
+  values <- P.many (try p)
+  let parsed = length values
+  if parsed > limit
+  then failWithPosition ("expected up to " <> show limit <> " items, but encountered " <> show parsed)
+  else pure values
+
+-- | For segments or segment groups, let you express how many occurrences with at least one occurrence.
+repeatedAtLeastOnce :: Int -> Parser a -> Parser [a]
+repeatedAtLeastOnce limit p = do
+  values <- many1 (try p)
+  let parsed = length values
+  if parsed > limit
+  then failWithPosition ("expected up to " <> show limit <> " items, but encountered " <> show parsed)
+  else pure values
+
+-- | For segments or segment groups, let you express you expect only one occurrence.
+once :: Parser a -> Parser [a]
+once = fmap pure
+
+-- | For segments or segment groups, let you express you expect one or no occurrence.
+maybeOnce :: Parser a -> Parser [a]
+maybeOnce = fmap (maybe [] pure) . optionMaybe
diff --git a/core/src/Text/Edifact/Parsing/Commons.hs b/core/src/Text/Edifact/Parsing/Commons.hs
new file mode 100644
index 0000000..a1c6150
--- /dev/null
+++ b/core/src/Text/Edifact/Parsing/Commons.hs
@@ -0,0 +1,173 @@
+module Text.Edifact.Parsing.Commons
+  ( -- * Parsing context
+    Parser
+  , Context(..)
+  , CurrentPosition(..)
+  , defaultContext
+
+    -- * State combinators
+  , updateSyntax
+  , setCurrentPosition
+  , resetCurrentPosition
+
+    -- * Syntax helpers
+    -- ** Parsing combinators
+  , parseCompositeSeparator
+  , parseElementSeparator
+  , parseSegmentSeparator
+  , parseEscape
+
+    -- ** State accessors
+    -- | Shortcuts to the syntax in current state. Doesn't alter input stream.
+  , getCompositeSeparator
+  , getElementSeparator
+  , getSegmentSeparator
+  , getDecimalSign
+
+   -- * Context aware failure helpers
+  , failWithPosition
+  , (<??>)
+
+    -- * Parsec extras
+  , tries
+
+    -- * Technical combinators
+  , notYetImplemented
+  ) where
+
+import           Text.Edifact.Types (Position, Syntax (..), defaultSyntax)
+
+import           Data.Text          (Text)
+import           Text.Parsec        (Parsec, char, choice, endOfLine, getState,
+                                     modifyState, try, updateState, (<?>))
+
+-- | Defines our "Text.Parsec" context.
+type Parser = Parsec Text Context
+
+data Context =
+  Context
+    { parsingSyntax   :: Syntax          -- ^ State of the syntax. To be updated on the encounter of the @UNA@ segment.
+    , currentPosition :: CurrentPosition -- ^ Pointer for current position in the parser. Used for enriched parsing error messages.
+    }
+
+defaultContext :: Context
+defaultContext = Context defaultSyntax Undefined
+
+-- | Current position in the parser.
+--
+-- For now it only stores the current position in a message, a segment group,
+-- a segment, or a composite.
+--
+-- Future version could store the whole path to improve debugging.
+data CurrentPosition = Undefined
+                     | Defined Position
+                       deriving Show
+
+getSyntax :: Parser Syntax
+getSyntax = parsingSyntax <$> getState
+
+-- | Get current charactor for decimal sign.
+-- It doesn't parse nor consume input.
+getDecimalSign :: Parser Char
+getDecimalSign = decimalSign <$> getSyntax
+
+-- | Get current charactor for segment separator.
+-- It doesn't parse nor consume input.
+getSegmentSeparator :: Parser Char
+getSegmentSeparator = segmentSeparator <$> getSyntax
+
+-- | Get current charactor for element separator.
+-- It doesn't parse nor consume input.
+getElementSeparator :: Parser Char
+getElementSeparator = elementSeparator <$> getSyntax
+
+-- | Get current charactor for composite separator.
+-- It doesn't parse nor consume input.
+getCompositeSeparator :: Parser Char
+getCompositeSeparator = compositeSeparator <$> getSyntax
+
+-- | This let change the operators used in the parsing. This is designed for the @UNA@ segment.
+updateSyntax :: Syntax -> Parser ()
+updateSyntax s = updateState (\ c -> c { parsingSyntax = s })
+
+-- | Read the parser state to extract current position.
+-- It doesn't parse nor consume input.
+getCurrentPosition :: Parser CurrentPosition
+getCurrentPosition = currentPosition <$> getState
+
+-- | Write the parser state to update current position.
+-- It doesn't parse nor consume input.
+setCurrentPosition :: Position -> Parser ()
+setCurrentPosition = updateCurrentPosition . Defined
+
+-- | Write the parser state to reset current position.
+-- It doesn't parse nor consume input.
+resetCurrentPosition :: Parser ()
+resetCurrentPosition = updateCurrentPosition Undefined
+
+updateCurrentPosition :: CurrentPosition -> Parser ()
+updateCurrentPosition pos = modifyState (\s -> s { currentPosition = pos })
+
+-- | Parse current charactor for element separator.
+-- It does parse and consume input.
+parseElementSeparator :: Parser Char
+parseElementSeparator = parseSpecialChar "element separator" elementSeparator
+
+-- | Parse current charactor for composite separator.
+-- It does parse and consume input.
+parseCompositeSeparator :: Parser Char
+parseCompositeSeparator = parseSpecialChar "composite separator" compositeSeparator
+
+-- | Parse current charactor for escape separator.
+-- It does parse and consume input.
+parseEscape :: Parser Char
+parseEscape = parseSpecialChar "escape character" escape
+
+-- | Parse current charactor for segment separator.
+-- It does parse and consume input.
+--
+-- It also tries consuming end of line after segment separator if any.
+parseSegmentSeparator :: Parser Char
+parseSegmentSeparator = tries [ parseSpecialChar "segment separator" segmentSeparator <* endOfLine
+                              , parseSpecialChar "segment separator" segmentSeparator
+                              ]
+
+parseSpecialChar :: String -> (Syntax -> Char) -> Parser Char
+parseSpecialChar description reader = do
+  c <- reader <$> getSyntax
+  let escape' '\"' = "\\\""
+      escape' c'   = [c']
+      comment = description <> " (\"" <> escape' c <> "\")"
+  char c <?> comment
+
+-- | Let you try various parsers, not consuming until success.
+tries :: [Parser a] -> Parser a
+tries = choice . map try
+
+-- | Like 'fail', this operator let you annotate a parser if it were to fail.
+-- The difference with the standard "Text.Parsec" operator is that it appends
+-- the current position if any.
+failWithPosition :: String -> Parser a
+failWithPosition = withPosition fail
+
+-- | Like '<?>', this operator let you annotate a parser if it were to fail.
+-- The difference with the standard "Text.Parsec" operator is that it appends
+-- the current position if any.
+(<??>) :: Parser a -> String -> Parser a
+(<??>) = withPosition . (<?>)
+
+-- Same priority as <?> from Text.Parsec
+infix 0 <??>
+
+withPosition :: (String -> Parser a) -> String -> Parser a
+withPosition continuation msg =
+  let mkMessage Undefined   = msg
+      mkMessage (Defined d) = msg <> " at position " <> show d
+      getMessage = mkMessage <$> getCurrentPosition
+  in getMessage >>= continuation
+
+-- | Alias to 'failWithPosition' to convey semantics of work-in-progress when
+-- writing a parser. This might be useful if you want to partially support a
+-- message.
+notYetImplemented :: String -> Parser a
+notYetImplemented = failWithPosition
diff --git a/core/src/Text/Edifact/Parsing/Primitives.hs b/core/src/Text/Edifact/Parsing/Primitives.hs
new file mode 100644
index 0000000..61659c8
--- /dev/null
+++ b/core/src/Text/Edifact/Parsing/Primitives.hs
@@ -0,0 +1,127 @@
+{-|
+Module      : Text.Edifact.Parsing.Primitives
+Description : Low level combinators
+
+This module let you build parsers for primitive values, ie. values contained
+in a simple element, either text or number.
+
+= Examples
+
+To parse a text of 3 characters (@an3@ in standard Edifact representation):
+
+> an3 :: Parser Primitive
+> an3 = alphaNumeric `exactly` 3
+
+To parse a text of up to 10 characters (@an..10@ in standard Edifact representation):
+
+> an_10 :: Parser Primitive
+> an_10 = alphaNumeric `upTo` 10
+
+= Known limitations
+
+Numeric representation is not strictly compatible to the specification.
+The specification tells that negative sign (@-@) and decimal sign (@.@) are not
+to be counted in the length of the field.
+
+Therefore the following parser will fail even it's legal according to the
+specification:
+
+> n_3 :: Parser Primitive
+> n_3 = numeric `upTo` 3
+>
+> parse n_3 "-12.3"
+
+To be fixed, we have to change the way primitives combinators are built so that
+the 'upTo' and 'exactly' combinators are aware of the inner parser.
+ -}
+module Text.Edifact.Parsing.Primitives
+  (
+    -- * Primitives
+    -- ** Simple elements definition
+    alphaNumeric
+  , alpha
+  , numeric
+
+    -- ** Cardinality
+  , exactly
+  , upTo
+  , many
+
+  ) where
+
+import           Text.Edifact.Parsing.Commons
+import           Text.Edifact.Types
+
+import           Data.String                  (fromString)
+import qualified Data.Text                    as T (length)
+import           Text.Parsec                  (count, lookAhead, many1, noneOf,
+                                               oneOf)
+import qualified Text.Parsec                  as P (many)
+
+-- | Parser associated with the @an@ notation.
+alphaNumeric :: Parser Char
+alphaNumeric = do
+  separators <- sequence [ getSegmentSeparator
+                         , getElementSeparator
+                         , getCompositeSeparator
+                         ]
+  tries [ parseEscape *> parseSegmentSeparator
+        , parseEscape *> parseElementSeparator
+        , parseEscape *> parseCompositeSeparator
+        , parseEscape *> parseEscape
+        , noneOf separators
+        ]
+
+-- | Parser associated with the @a@ notation.
+--
+-- So far it's simply an alias to 'alphaNumeric'.
+alpha :: Parser Char
+alpha = alphaNumeric
+
+-- | Parser associated with the @n@ notation.
+numeric :: Parser Char
+numeric = do
+  punctuationSign <- getDecimalSign
+  oneOf (punctuationSign : "0123456789-")
+
+-- | Combinator to build a parser of primitive which length is unspecified.
+--
+-- Correspondance with the Edifact notation:
+--
+-- > many alpha        # same as a
+-- > many numeric      # same as n
+-- > many alphaNumeric # same as an
+many :: Parser Char -> Parser Primitive
+many = fmap fromString . many1
+
+-- | Combinator to build a parser of primitive which length is capped.
+--
+-- Correspondance with the Edifact notation:
+--
+-- > alpha `upTo` 3        # same as a..3
+-- > numeric `upTo` 3      # same as n..3
+-- > alphaNumeric `upTo` 3 # same as an..3
+upTo :: Parser Char -> Int -> Parser Primitive
+upTo p c =
+  let check t =
+        let c' = T.length t
+        in if c' > c
+           then failWithPosition ("expected up to " <> show c <> " characters, but encountered " <> show c')
+           else pure (String t)
+      maybeEmpty = (<$) mempty . lookAhead
+  in check =<<
+       tries [ maybeEmpty parseSegmentSeparator
+             , maybeEmpty parseElementSeparator
+             , maybeEmpty parseCompositeSeparator
+             , fromString <$> P.many p
+             ]
+
+-- | Combinator to build a parser of primitive which length is fixed.
+--
+-- Correspondance with the Edifact notation:
+--
+-- > alpha `exactly` 3        # same as a3
+-- > numeric `exactly` 3      # same as n3
+-- > alphaNumeric `exactly` 3 # same as an3
+exactly :: Parser Char -> Int -> Parser Primitive
+exactly p c = fromString <$> count c p