core/src/Text/Edifact/Inspect.hs

   1 {-# LANGUAGE DerivingStrategies         #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# LANGUAGE OverloadedStrings          #-}
   4
   5 module Text.Edifact.Inspect
   6   ( inspect
   7   ) where
   8
   9 import           Text.Edifact.Types
  10
  11 import           Control.Monad.Reader (Reader, ask, local, runReader)
  12 import           Data.Maybe           (catMaybes)
  13 import           Data.String          (IsString)
  14 import           Data.Text            (Text)
  15 import           Formatting
  16
  17 type Indent = Int
  18
  19 type Rendering = Reader Indent
  20
  21 indent :: Rendering a -> Rendering a
  22 indent = local (+1)
  23
  24 getIndentation :: Rendering Int
  25 getIndentation = ask
  26
  27 inspect :: Value -> Text
  28 inspect = renderInspection . valueRenderer
  29
  30 renderInspection :: Rendering a -> a
  31 renderInspection r = runReader r 0
  32
  33 valueRenderer :: Value -> Rendering Text
  34 valueRenderer (Simple    _ primitive) = primitiveRenderer primitive
  35 valueRenderer (Composite _ values)    = sformat inBrackets . commaSeparated . catMaybes <$> traverse positionRenderer values
  36 valueRenderer (Segment code values)   = indentedPrefix fSegmentCode code " " . spaceSeparated . catMaybes =<< traverse positionRenderer values
  37 valueRenderer (Group   code values)   = indentedPrefix fGroupCode code "\n" . lineSeparated =<< indent (traverse silentPositionRenderer values)
  38 valueRenderer (Message code values)   = indentedPrefix fMessageCode code "\n" . lineSeparated =<< indent (traverse silentPositionRenderer values)
  39
  40 inBrackets :: Format r (Text -> r)
  41 inBrackets = "[" % stext % "]"
  42
  43 indentedPrefix :: Format (String -> Text -> Text) (code -> String -> Text -> Text) -> code -> String -> Text -> Rendering Text
  44 indentedPrefix codeFormatter code sep t = do
  45   i <- getIndentation
  46   let prefix = replicate (i * 2) ' '
  47   pure (sformat (string % codeFormatter % string % stext) prefix code sep t)
  48
  49 fMessageCode :: Format r (MessageCode -> r)
  50 fMessageCode = mapf getMessageCode ("message " % string)
  51
  52 fGroupCode :: Format r (GroupCode -> r)
  53 fGroupCode = mapf getGroupCode ("Segment Group - " % string)
  54
  55 fSegmentCode :: Format r (SegmentCode -> r)
  56 fSegmentCode = mapf getSegmentCode string
  57
  58 positionRenderer :: (Position, Maybe Value) -> Rendering (Maybe Text)
  59 positionRenderer (pos, value) = fmap (flip (sformat (stext % fPosition)) pos)  <$> traverse valueRenderer value
  60
  61 silentPositionRenderer :: (Position, [Value]) -> Rendering Text
  62 silentPositionRenderer (_, value) = lineSeparated <$> traverse valueRenderer value
  63
  64 fPosition :: Format r (Position -> r)
  65 fPosition = mapf getPosition ("@" % string)
  66
  67 primitiveRenderer :: Primitive -> Rendering Text
  68 primitiveRenderer (String t) = pure (sformat ("\"" % stext % "\"") t)
  69 primitiveRenderer (Number s) = pure (sformat shown s)
  70
  71 newtype CommaSeparated = CommaSeparated { getCommaSeparated :: Text } deriving newtype (IsString, Eq)
  72
  73 instance Semigroup CommaSeparated where
  74   t1 <> "" = t1
  75   "" <> t2 = t2
  76   t1 <> t2 = CommaSeparated (getCommaSeparated t1 <> "," <> getCommaSeparated t2)
  77
  78 instance Monoid CommaSeparated where
  79   mempty = ""
  80
  81 commaSeparated :: Foldable f => f Text -> Text
  82 commaSeparated = getCommaSeparated . foldMap CommaSeparated
  83
  84 newtype SpaceSeparated = SpaceSeparated { getSpaceSeparated :: Text } deriving newtype (IsString, Eq)
  85
  86 instance Semigroup SpaceSeparated where
  87   t1 <> "" = t1
  88   "" <> t2 = t2
  89   t1 <> t2 = SpaceSeparated (getSpaceSeparated t1 <> " " <> getSpaceSeparated t2)
  90
  91 instance Monoid SpaceSeparated where
  92   mempty = ""
  93
  94 spaceSeparated :: Foldable f => f Text -> Text
  95 spaceSeparated = getSpaceSeparated . foldMap SpaceSeparated
  96
  97 newtype LineSeparated = LineSeparated { getLineSeparated :: Text } deriving newtype (IsString, Eq)
  98
  99 instance Semigroup LineSeparated where
 100   t1 <> "" = t1
 101   "" <> t2 = t2
 102   t1 <> t2 = LineSeparated (getLineSeparated t1 <> "\n" <> getLineSeparated t2)
 103
 104 instance Monoid LineSeparated where
 105   mempty = ""
 106
 107 lineSeparated :: Foldable f => f Text -> Text
 108 lineSeparated = getLineSeparated . foldMap LineSeparated