diff options
Diffstat (limited to 'core/src/Text/Edifact/Inspect.hs')
-rw-r--r-- | core/src/Text/Edifact/Inspect.hs | 108 |
1 files changed, 108 insertions, 0 deletions
diff --git a/core/src/Text/Edifact/Inspect.hs b/core/src/Text/Edifact/Inspect.hs new file mode 100644 index 0000000..fb3755a --- /dev/null +++ b/core/src/Text/Edifact/Inspect.hs | |||
@@ -0,0 +1,108 @@ | |||
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 | ||