Release code as open sourceHEADmaster

5 files changed, 348 insertions, 0 deletions

diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Messages/Dependencies.hs b/scaffolder/src/Text/Edifact/Scaffolder/Messages/Dependencies.hs
new file mode 100644
index 0000000..fbcc56b
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Messages/Dependencies.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Text.Edifact.Scaffolder.Messages.Dependencies
+  ( -- *
+    mkDependenciesHaddock
+  , mkDependenciesImports
+  , mkDependenciesReexports
+  ) where
+
+import           Text.Edifact.Scaffolder.Commons
+import           Text.Edifact.Scaffolder.Messages.Types
+
+import           Control.Monad                          ((>=>))
+import           Data.List                              (isPrefixOf)
+import           Data.List.NonEmpty                     as NE (nonEmpty, toList)
+import           Data.Maybe                             (mapMaybe)
+
+unlessIsCommon :: SegmentCode -> Maybe SegmentCode
+unlessIsCommon sc@(SegmentCode code) | "U" `isPrefixOf` code = Nothing
+                                     | otherwise             = Just sc
+
+mkDependenciesReexports :: NonEmpty Element -> Scaffolding [Export]
+mkDependenciesReexports = mkSegmentDependencies mkSegmentDependenciesReexports
+
+mkSegmentDependenciesReexports :: NonEmpty SegmentCode -> Scaffolding [Export]
+mkSegmentDependenciesReexports = reexportDependencies fSegmentParserFunction
+
+mkDependenciesImports :: NonEmpty Element -> Scaffolding [ImportGroup]
+mkDependenciesImports = mkSegmentDependencies mkSegmentDependenciesImports
+
+mkSegmentDependencies :: (NonEmpty SegmentCode -> Scaffolding [output])
+                      -> (NonEmpty Element     -> Scaffolding [output])
+mkSegmentDependencies mk = maybe (pure []) mk . filterSegmentDependencies
+
+filterSegmentDependencies :: NonEmpty Element -> Maybe (NonEmpty SegmentCode)
+filterSegmentDependencies =
+  fmap nub . nonEmpty . mapMaybe (getSegment >=> unlessIsCommon) . NE.toList
+
+mkSegmentDependenciesImports :: NonEmpty SegmentCode -> Scaffolding [ImportGroup]
+mkSegmentDependenciesImports =
+  fmap (pure . singleImport) . importDependencies "Segments" fSegmentParserFunction
+
+mkDependenciesHaddock :: NonEmpty Element -> Scaffolding [Text]
+mkDependenciesHaddock = mkSegmentDependencies mkSegmentDependenciesHaddock
+
+mkSegmentDependenciesHaddock :: NonEmpty SegmentCode -> Scaffolding [Text]
+mkSegmentDependenciesHaddock = haddockDependencies fSegmentParserFunction
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Messages/Elements.hs b/scaffolder/src/Text/Edifact/Scaffolder/Messages/Elements.hs
new file mode 100644
index 0000000..fb590ad
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Messages/Elements.hs
@@ -0,0 +1,22 @@
+module Text.Edifact.Scaffolder.Messages.Elements
+  ( listMessages
+  ) where
+
+import           Text.Edifact.Scaffolder.Commons
+
+import           Data.Char                       (toUpper)
+import           Text.Parsec                     (count, eof, lower, string,
+                                                  (<?>))
+import           Text.Parsec.String              (Parser)
+
+-- | List elements
+listMessages :: Scaffolding [ElementWithDefinition MessageCode]
+listMessages = listElements "messages" messageFilenameParser
+
+messageFilenameParser :: Parser MessageCode
+messageFilenameParser =
+  let mkCode = MessageCode . fmap toUpper
+  in mkCode <$> count 6 lower
+            <*  string "_s.txt"
+            <*  eof
+            <?> "MessageCode"
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Messages/Implementation.hs b/scaffolder/src/Text/Edifact/Scaffolder/Messages/Implementation.hs
new file mode 100644
index 0000000..121aa45
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Messages/Implementation.hs
@@ -0,0 +1,114 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Text.Edifact.Scaffolder.Messages.Implementation
+  ( -- *
+    toImplementation
+  ) where
+
+import           Text.Edifact.Scaffolder.Commons
+import           Text.Edifact.Scaffolder.Messages.Types
+
+import           Control.Monad.State.Strict             (State, evalState, gets,
+                                                         modify)
+import           Data.List.NonEmpty                     as NE (NonEmpty (..),
+                                                               fromList, head,
+                                                               toList, (<|))
+import           Formatting
+
+toImplementation :: MessageCode -> NonEmpty Dependency -> [Text]
+toImplementation _ =
+  let closeList deps = deps <> [ "]" ]
+  in closeList . render . fmap concat . traverse callDependency . NE.toList
+
+render :: Rendering a -> a
+render r =
+  let initialState = RenderingContext 0 0 :| []
+  in evalState r initialState
+
+type Trail = NonEmpty
+
+data RenderingContext = RenderingContext { listPosition :: Int
+                                         , indentLevel  :: Int
+                                         }
+
+type Rendering = State (Trail RenderingContext)
+
+callDependency :: Dependency -> Rendering [Text]
+callDependency (Dependency element) = renderElement element
+
+increment :: Rendering ()
+increment =
+  let mapHead f (v :| t)  = f v :| t
+  in modify (mapHead (\ ctx -> ctx { listPosition = listPosition ctx + 1 }))
+
+pushIndent :: Rendering ()
+pushIndent =
+  let indentState t@(previous :| _) = RenderingContext 0 (indentLevel previous + 2) <| t
+  in modify indentState
+
+popIndent :: Rendering ()
+popIndent =
+  let pop (_ :| []) = error "Incoherent state: can't unindent anymore (this shouldn't happen)"
+      pop (_ :| up) = NE.fromList up
+  in modify pop
+
+getCurrentIndex :: Rendering Int
+getCurrentIndex = gets (listPosition . NE.head)
+
+getCurrentIndentation :: Rendering Int
+getCurrentIndentation = gets (indentLevel . NE.head)
+
+renderElement :: Element -> Rendering [Text]
+renderElement (Segment code positional) =
+  let output index indentation =
+        [ sformat (fIndentation % fIndex % " " % fPositional % " " % fSegmentParserFunction) indentation index positional code
+        ]
+  in output <$> getCurrentIndex
+            <*> getCurrentIndentation
+            <*  increment
+renderElement (GroupStart code positional) =
+  let output index indentation =
+        [ sformat (fIndentation % fIndex % " " % fPositional % " (") indentation index positional
+        , sformat (fIndentation % fSegmentGroupFunction) (indentation + 1) code
+        ]
+  in output <$> getCurrentIndex
+            <*> getCurrentIndentation
+            <*  increment
+            <*  pushIndent
+renderElement (GroupEnd _) =
+  let output indentation =
+        [ sformat (fIndentation % "]") indentation
+        , sformat (fIndentation % ")") (indentation - 1)
+        ]
+  in output <$> getCurrentIndentation
+            <*  popIndent
+
+fIndentation :: Format r (Int -> r)
+fIndentation =
+  let buildIndentation n = fromString (replicate (n * 2) ' ')
+  in later buildIndentation
+
+fIndex :: Format r (Int -> r)
+fIndex =
+  let buildIndex 0 = "["
+      buildIndex _ = ","
+  in later buildIndex
+
+fPositional :: Format r (Positional -> r)
+fPositional =
+  let buildPositional (Positional p r) = bprint (quoted fPosition % " .@ " % fRepetition) p r
+  in later buildPositional
+
+fSegmentGroupFunction :: Format r (GroupCode -> r)
+fSegmentGroupFunction = "segmentGroup " % quoted fGroupCode
+
+fRepetition :: Format r (Repetition -> r)
+fRepetition =
+  let buildRepetition (Repetition Mandatory 1) = bprint  "once"
+      buildRepetition (Repetition Optional  1) = bprint  "maybeOnce"
+      buildRepetition (Repetition Mandatory c) = bprint ("repeatedAtLeastOnce" % " " % fCardinality) c
+      buildRepetition (Repetition Optional  c) = bprint ("repeated" % " " % fCardinality) c
+  in later buildRepetition
+
+fCardinality :: Format r (Cardinality -> r)
+fCardinality = mapf getCardinality int
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Messages/Specification.hs b/scaffolder/src/Text/Edifact/Scaffolder/Messages/Specification.hs
new file mode 100644
index 0000000..b1e5c2a
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Messages/Specification.hs
@@ -0,0 +1,129 @@
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Text.Edifact.Scaffolder.Messages.Specification
+  ( -- *
+    specificationParser
+  , messageNameParser
+  , listSegments
+  ) where
+
+import           Text.Edifact.Scaffolder.Commons
+import           Text.Edifact.Scaffolder.Messages.Types
+
+import           Data.Maybe                             (mapMaybe)
+import           Text.Parsec
+
+type Parser = Parsec String GroupTrail
+
+newtype GroupTrail = GroupTrail [GroupCode]
+  deriving stock Show
+  deriving newtype (Semigroup, Monoid)
+
+messageNameParser :: Parser MessageCode
+messageNameParser = scanUntil [
+    manyTill anyChar (string "Message Type : ") >> MessageCode <$> count 6 upper
+  ]
+
+specificationParser :: Parser [Dependency]
+specificationParser =
+  let scanElements = scan [ segmentInLine segmentElementParser
+                          , groupInLine   groupStartElementParser
+                          ]
+  in interpretDependencies <$> scanElements <?> "Messages specification"
+
+listSegments :: Parser [SegmentCode]
+listSegments = mapMaybe (getSegment . getElement) <$> specificationParser
+
+interpretDependencies :: [Element] -> [Dependency]
+interpretDependencies = fmap Dependency
+
+groupInLine :: Parser a -> Parser [a]
+groupInLine p = single (many (string " ") *> p <* countClosingGroups)
+
+countClosingGroups :: Parser Int
+countClosingGroups =
+  let parser = many1 (char '-')
+            *> many1 (char '+')
+           <*  many  (char '|')
+  in length <$> parser
+
+closingGroupTrail :: Parser [Element]
+closingGroupTrail =
+  let groupEndParser = GroupEnd <$> popFromTrail
+  in countClosingGroups >>= flip count groupEndParser
+
+groupStartElementParser :: Parser Element
+groupStartElementParser =
+  let parseStart pos code rep = GroupStart code (Positional pos rep)
+  in parseStart <$> positionParser
+                <*  many1 (choice [ () <$ try (oneOf "+*#|X "), () <$ try (string "- ") ])
+                <*> groupCodeParser
+                <*  many1 (char ' ')
+                <*> repetitionParser
+                <?> "GroupElement"
+
+groupCodeParser :: Parser GroupCode
+groupCodeParser =
+  let parser = manyTill (char '-') (try $ string "-- Segment group")
+            *> many1 (char ' ')
+            *> many1 digit
+           <*  many1 space
+           <*  many1 (char '-')
+      group = GroupCode <$> parser
+  in group >>= appendToTrail <?> "GroupCodeParser"
+
+appendToTrail :: GroupCode -> Parser GroupCode
+appendToTrail code =
+  let append (GroupTrail trail) = GroupTrail (code : trail)
+  in code <$ modifyState append
+
+popFromTrail :: Parser GroupCode
+popFromTrail = do
+  previous <- getState
+  case previous of
+    GroupTrail (current : trail) -> current <$ putState (GroupTrail trail)
+    GroupTrail []                -> unexpected "GroupEnd, when state is currently clear"
+
+segmentTrail :: Parser [a]
+segmentTrail = [] <$ (many1 (char ' ') <* many (char '|'))
+
+segmentInLine :: Parser Element -> Parser [Element]
+segmentInLine p = do
+  segment <- many (string " ") *> p
+  trail <- choice [ try closingGroupTrail
+                  , try segmentTrail
+                  ]
+  pure (segment : trail)
+
+repetitionParser :: Parser Repetition
+repetitionParser =
+  Repetition <$> presenceParser
+             <*  many1 (string " ")
+             <*> cardinalityParser
+             <?> "Repetition"
+
+positionParser :: Parser Position
+positionParser =
+  fromString <$> many1 digit
+             <?> "Position"
+
+segmentElementParser :: Parser Element
+segmentElementParser =
+  let parseSegment pos code rep = Segment code (Positional pos rep)
+  in parseSegment <$> positionParser
+                  <*  many1 (oneOf "+*#|-X ")
+                  <*> segmentCodeParser
+                  <*  many1 (string " ")
+                  <*  stringToPresenceParser
+                  <*  many1 (string " ")
+                  <*> repetitionParser
+                  <?> "SegmentElement"
+
+segmentCodeParser :: Parser SegmentCode
+segmentCodeParser =
+  fromString <$> count 3 upper
+             <?> "SegmentCode"
+
+cardinalityParser :: Parser Cardinality
+cardinalityParser = Cardinality . read <$> many1 digit
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Messages/Types.hs b/scaffolder/src/Text/Edifact/Scaffolder/Messages/Types.hs
new file mode 100644
index 0000000..73cc702
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Messages/Types.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Text.Edifact.Scaffolder.Messages.Types where
+
+import           Text.Edifact.Scaffolder.Commons
+
+import           Data.Function                   (on)
+import           Data.Ord                        (comparing)
+
+newtype Dependency = Dependency { getElement :: Element } deriving newtype (Show, Ord, Eq)
+
+data Repetition = Repetition Presence Cardinality deriving Show
+
+data Positional = Positional { positionalPosition   :: Position
+                             , positionalRepetition :: Repetition
+                             } deriving (Show)
+
+instance Eq Positional where
+  (==) = (==) `on` positionalPosition
+
+instance Ord Positional where
+  compare = comparing positionalPosition
+
+data Element = Segment    SegmentCode Positional
+             | GroupStart GroupCode   Positional
+             | GroupEnd   GroupCode
+               deriving (Show, Ord, Eq)
+
+getSegment :: Element -> Maybe SegmentCode
+getSegment (Segment code _) = Just code
+getSegment _                = Nothing
+
+newtype Cardinality = Cardinality { getCardinality :: Int }
+  deriving stock (Show)
+  deriving newtype (Eq, Num)