blob: b1e5c2ad25df00080a8658c364322c35c97e7871 (
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
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
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
|
