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