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

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 module Text.Edifact.Scaffolder.Messages.Implementation
   4   ( -- *
   5     toImplementation
   6   ) where
   7
   8 import           Text.Edifact.Scaffolder.Commons
   9 import           Text.Edifact.Scaffolder.Messages.Types
  10
  11 import           Control.Monad.State.Strict             (State, evalState, gets,
  12                                                          modify)
  13 import           Data.List.NonEmpty                     as NE (NonEmpty (..),
  14                                                                fromList, head,
  15                                                                toList, (<|))
  16 import           Formatting
  17
  18 toImplementation :: MessageCode -> NonEmpty Dependency -> [Text]
  19 toImplementation _ =
  20   let closeList deps = deps <> [ "]" ]
  21   in closeList . render . fmap concat . traverse callDependency . NE.toList
  22
  23 render :: Rendering a -> a
  24 render r =
  25   let initialState = RenderingContext 0 0 :| []
  26   in evalState r initialState
  27
  28 type Trail = NonEmpty
  29
  30 data RenderingContext = RenderingContext { listPosition :: Int
  31                                          , indentLevel  :: Int
  32                                          }
  33
  34 type Rendering = State (Trail RenderingContext)
  35
  36 callDependency :: Dependency -> Rendering [Text]
  37 callDependency (Dependency element) = renderElement element
  38
  39 increment :: Rendering ()
  40 increment =
  41   let mapHead f (v :| t)  = f v :| t
  42   in modify (mapHead (\ ctx -> ctx { listPosition = listPosition ctx + 1 }))
  43
  44 pushIndent :: Rendering ()
  45 pushIndent =
  46   let indentState t@(previous :| _) = RenderingContext 0 (indentLevel previous + 2) <| t
  47   in modify indentState
  48
  49 popIndent :: Rendering ()
  50 popIndent =
  51   let pop (_ :| []) = error "Incoherent state: can't unindent anymore (this shouldn't happen)"
  52       pop (_ :| up) = NE.fromList up
  53   in modify pop
  54
  55 getCurrentIndex :: Rendering Int
  56 getCurrentIndex = gets (listPosition . NE.head)
  57
  58 getCurrentIndentation :: Rendering Int
  59 getCurrentIndentation = gets (indentLevel . NE.head)
  60
  61 renderElement :: Element -> Rendering [Text]
  62 renderElement (Segment code positional) =
  63   let output index indentation =
  64         [ sformat (fIndentation % fIndex % " " % fPositional % " " % fSegmentParserFunction) indentation index positional code
  65         ]
  66   in output <$> getCurrentIndex
  67             <*> getCurrentIndentation
  68             <*  increment
  69 renderElement (GroupStart code positional) =
  70   let output index indentation =
  71         [ sformat (fIndentation % fIndex % " " % fPositional % " (") indentation index positional
  72         , sformat (fIndentation % fSegmentGroupFunction) (indentation + 1) code
  73         ]
  74   in output <$> getCurrentIndex
  75             <*> getCurrentIndentation
  76             <*  increment
  77             <*  pushIndent
  78 renderElement (GroupEnd _) =
  79   let output indentation =
  80         [ sformat (fIndentation % "]") indentation
  81         , sformat (fIndentation % ")") (indentation - 1)
  82         ]
  83   in output <$> getCurrentIndentation
  84             <*  popIndent
  85
  86 fIndentation :: Format r (Int -> r)
  87 fIndentation =
  88   let buildIndentation n = fromString (replicate (n * 2) ' ')
  89   in later buildIndentation
  90
  91 fIndex :: Format r (Int -> r)
  92 fIndex =
  93   let buildIndex 0 = "["
  94       buildIndex _ = ","
  95   in later buildIndex
  96
  97 fPositional :: Format r (Positional -> r)
  98 fPositional =
  99   let buildPositional (Positional p r) = bprint (quoted fPosition % " .@ " % fRepetition) p r
 100   in later buildPositional
 101
 102 fSegmentGroupFunction :: Format r (GroupCode -> r)
 103 fSegmentGroupFunction = "segmentGroup " % quoted fGroupCode
 104
 105 fRepetition :: Format r (Repetition -> r)
 106 fRepetition =
 107   let buildRepetition (Repetition Mandatory 1) = bprint  "once"
 108       buildRepetition (Repetition Optional  1) = bprint  "maybeOnce"
 109       buildRepetition (Repetition Mandatory c) = bprint ("repeatedAtLeastOnce" % " " % fCardinality) c
 110       buildRepetition (Repetition Optional  c) = bprint ("repeated" % " " % fCardinality) c
 111   in later buildRepetition
 112
 113 fCardinality :: Format r (Cardinality -> r)
 114 fCardinality = mapf getCardinality int