diff options
author | Frédéric Menou <frederic.menou@fretlink.com> | 2016-12-08 10:19:15 +0200 |
---|---|---|
committer | Ismaël Bouya <ismael.bouya@fretlink.com> | 2022-05-17 18:01:51 +0200 |
commit | a9d77a20008efe82862cc1adbfa7a6d4f09f8ff7 (patch) | |
tree | adf3186fdccaeef19151026cdfbd38a530cf9ecb /core | |
download | edi-parser-master.tar.gz edi-parser-master.tar.zst edi-parser-master.zip |
Diffstat (limited to 'core')
24 files changed, 2074 insertions, 0 deletions
diff --git a/core/Makefile b/core/Makefile new file mode 100644 index 0000000..1012f16 --- /dev/null +++ b/core/Makefile | |||
@@ -0,0 +1,7 @@ | |||
1 | lint: | ||
2 | hlint src/ | ||
3 | |||
4 | help: | ||
5 | @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' | ||
6 | |||
7 | .PHONY: lint help | ||
diff --git a/core/README.md b/core/README.md new file mode 100644 index 0000000..2f944d9 --- /dev/null +++ b/core/README.md | |||
@@ -0,0 +1,8 @@ | |||
1 | # edi-parser-core | ||
2 | |||
3 | Combinators and utilities to parse and decode Edifact messages. | ||
4 | |||
5 | This package doesn't support any Edifact specification. You'll have to use | ||
6 | [edi-parser-scaffolder] from the textual specification of your choice first. | ||
7 | |||
8 | [edi-parser-scaffolder]: ../scaffolder/README.md | ||
diff --git a/core/edi-parser-core.cabal b/core/edi-parser-core.cabal new file mode 100644 index 0000000..d0d81ca --- /dev/null +++ b/core/edi-parser-core.cabal | |||
@@ -0,0 +1,80 @@ | |||
1 | cabal-version: 1.12 | ||
2 | |||
3 | -- This file has been generated from package.yaml by hpack version 0.31.2. | ||
4 | -- | ||
5 | -- see: https://github.com/sol/hpack | ||
6 | -- | ||
7 | -- hash: ac9aca9d28ed9aecc58673e920756536a610462adfc7c396aac1a00fa8ea526c | ||
8 | |||
9 | name: edi-parser-core | ||
10 | version: 20190607 | ||
11 | synopsis: Example parser for EDI files | ||
12 | description: Please see README.md | ||
13 | category: Text | ||
14 | homepage: https://github.com/fretlink/edi-parser#readme | ||
15 | bug-reports: https://github.com/fretlink/edi-parser/issues | ||
16 | author: FretLink | ||
17 | maintainer: example@example.com | ||
18 | copyright: 2019 FretLink | ||
19 | build-type: Simple | ||
20 | extra-source-files: | ||
21 | README.md | ||
22 | |||
23 | source-repository head | ||
24 | type: git | ||
25 | location: https://github.com/fretlink/edi-parser | ||
26 | |||
27 | library | ||
28 | exposed-modules: | ||
29 | Text.Edifact.Common | ||
30 | Text.Edifact.Common.Composites | ||
31 | Text.Edifact.Common.Segments | ||
32 | Text.Edifact.Common.Segments.UNA | ||
33 | Text.Edifact.Common.Segments.UNB | ||
34 | Text.Edifact.Common.Segments.UNH | ||
35 | Text.Edifact.Common.Segments.UNS | ||
36 | Text.Edifact.Common.Segments.UNT | ||
37 | Text.Edifact.Common.Segments.UNZ | ||
38 | Text.Edifact.Common.Simples | ||
39 | Text.Edifact.Inspect | ||
40 | Text.Edifact.Parsing | ||
41 | Text.Edifact.Parsing.Combinators | ||
42 | Text.Edifact.Parsing.Commons | ||
43 | Text.Edifact.Parsing.Primitives | ||
44 | Text.Edifact.Types | ||
45 | other-modules: | ||
46 | Paths_edi_parser_core | ||
47 | hs-source-dirs: | ||
48 | src | ||
49 | ghc-options: -Wall -Werror | ||
50 | build-depends: | ||
51 | base >=4.7 && <5 | ||
52 | , data-default | ||
53 | , formatting | ||
54 | , mtl | ||
55 | , parsec | ||
56 | , scientific | ||
57 | , text | ||
58 | , time | ||
59 | default-language: Haskell2010 | ||
60 | |||
61 | test-suite edi-parser-core-test | ||
62 | type: exitcode-stdio-1.0 | ||
63 | main-is: Spec.hs | ||
64 | other-modules: | ||
65 | Parsing.CombinatorsTest | ||
66 | Parsing.PrimitivesTest | ||
67 | ParsingTest | ||
68 | Paths_edi_parser_core | ||
69 | hs-source-dirs: | ||
70 | test | ||
71 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Werror | ||
72 | build-depends: | ||
73 | HUnit | ||
74 | , base | ||
75 | , edi-parser-core | ||
76 | , parsec | ||
77 | , test-framework | ||
78 | , test-framework-hunit | ||
79 | , text | ||
80 | default-language: Haskell2010 | ||
diff --git a/core/package.yaml b/core/package.yaml new file mode 100644 index 0000000..6d60877 --- /dev/null +++ b/core/package.yaml | |||
@@ -0,0 +1,47 @@ | |||
1 | name: edi-parser-core | ||
2 | version: 20190607 | ||
3 | synopsis: Example parser for EDI files | ||
4 | description: Please see README.md | ||
5 | category: Text | ||
6 | author: FretLink | ||
7 | maintainer: example@example.com | ||
8 | copyright: 2019 FretLink | ||
9 | github: fretlink/edi-parser | ||
10 | |||
11 | extra-source-files: | ||
12 | - README.md | ||
13 | |||
14 | dependencies: | ||
15 | - text | ||
16 | |||
17 | library: | ||
18 | source-dirs: src | ||
19 | ghc-options: | ||
20 | - -Wall | ||
21 | - -Werror | ||
22 | dependencies: | ||
23 | - base >=4.7 && <5 | ||
24 | - data-default | ||
25 | - formatting | ||
26 | - mtl | ||
27 | - parsec | ||
28 | - scientific | ||
29 | - time | ||
30 | |||
31 | tests: | ||
32 | edi-parser-core-test: | ||
33 | main: Spec.hs | ||
34 | source-dirs: test | ||
35 | ghc-options: | ||
36 | - -threaded | ||
37 | - -rtsopts | ||
38 | - -with-rtsopts=-N | ||
39 | - -Wall | ||
40 | - -Werror | ||
41 | dependencies: | ||
42 | - base | ||
43 | - edi-parser-core | ||
44 | - parsec | ||
45 | - HUnit | ||
46 | - test-framework | ||
47 | - test-framework-hunit | ||
diff --git a/core/src/Text/Edifact/Common.hs b/core/src/Text/Edifact/Common.hs new file mode 100644 index 0000000..c938d48 --- /dev/null +++ b/core/src/Text/Edifact/Common.hs | |||
@@ -0,0 +1,39 @@ | |||
1 | {-| | ||
2 | Module : Text.Edifact.Common | ||
3 | Description : Common syntax | ||
4 | |||
5 | This module should handle the main revision of the Edifact specification, which | ||
6 | covers UN* segments. | ||
7 | |||
8 | Currently it barely covers the revision 3 and this has not been scaffolded. | ||
9 | |||
10 | One future evolution will be to scaffold the various revisions from a more | ||
11 | general specification. | ||
12 | -} | ||
13 | module Text.Edifact.Common | ||
14 | ( | ||
15 | -- * Routine | ||
16 | parseFull | ||
17 | |||
18 | -- * Reexports | ||
19 | , ParseError | ||
20 | , Parser | ||
21 | , Text | ||
22 | ) where | ||
23 | |||
24 | import Text.Edifact.Parsing | ||
25 | import Text.Edifact.Parsing.Commons | ||
26 | |||
27 | import Text.Edifact.Common.Segments | ||
28 | |||
29 | import Data.Text (Text) | ||
30 | |||
31 | parseFull :: Parser value -> Text -> Either ParseError value | ||
32 | parseFull = parse . fullSyntaxParser | ||
33 | |||
34 | fullSyntaxParser :: Parser a -> Parser a | ||
35 | fullSyntaxParser messageParser = | ||
36 | segmentUNA >> | ||
37 | tries [ segmentUNB *> messageParser <* segmentUNZ | ||
38 | , messageParser | ||
39 | ] | ||
diff --git a/core/src/Text/Edifact/Common/Composites.hs b/core/src/Text/Edifact/Common/Composites.hs new file mode 100644 index 0000000..39f61e7 --- /dev/null +++ b/core/src/Text/Edifact/Common/Composites.hs | |||
@@ -0,0 +1,135 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | ||
2 | |||
3 | module Text.Edifact.Common.Composites | ||
4 | ( compositeS001 | ||
5 | , compositeS002 | ||
6 | , compositeS003 | ||
7 | , compositeS004 | ||
8 | , compositeS005 | ||
9 | , compositeS009 | ||
10 | , compositeS010 | ||
11 | ) where | ||
12 | |||
13 | import Text.Edifact.Common.Simples (simple0001, simple0002, | ||
14 | simple0004, simple0007, | ||
15 | simple0008, simple0010, | ||
16 | simple0014, simple0017, | ||
17 | simple0019, simple0022, | ||
18 | simple0025, simple0042, | ||
19 | simple0046, simple0051, | ||
20 | simple0052, simple0054, | ||
21 | simple0057, simple0065, | ||
22 | simple0070, simple0073, | ||
23 | simple0080, simple0133) | ||
24 | |||
25 | import Text.Edifact.Parsing | ||
26 | import Text.Edifact.Types (Value) | ||
27 | |||
28 | -- | Derived from this specification: | ||
29 | -- | ||
30 | -- > 010 0001 Syntax identifier M a4 | ||
31 | -- > 020 0002 Syntax version number M an1 | ||
32 | -- > 030 0080 Service code list directory version number C an..6 | ||
33 | -- > 040 0133 Character encoding, coded C an..3 | ||
34 | -- | ||
35 | -- Dependencies: 'simple0001', 'simple0002', 'simple0080', 'simple0133'. | ||
36 | compositeS001 :: Parser Value | ||
37 | compositeS001 = | ||
38 | composite "S001" | ||
39 | [ "010" .@ mandatory simple0001 | ||
40 | , "020" .@ mandatory simple0002 | ||
41 | , "030" .@ optional simple0080 | ||
42 | , "040" .@ optional simple0133 | ||
43 | ] | ||
44 | |||
45 | -- | Derived from this specification: | ||
46 | -- | ||
47 | -- > 010 0004 Interchange sender identification M an..35 | ||
48 | -- > 020 0007 Identification code qualifier C an..4 | ||
49 | -- > 030 0008 Interchange sender internal identification C an..35 | ||
50 | -- > 040 0042 Interchange sender internal sub-identification C an..35 | ||
51 | -- | ||
52 | -- Dependencies: 'simple0004', 'simple0007', 'simple0008', 'simple0042'. | ||
53 | compositeS002 :: Parser Value | ||
54 | compositeS002 = | ||
55 | composite "S002" | ||
56 | [ "010" .@ mandatory simple0004 | ||
57 | , "020" .@ optional simple0007 | ||
58 | , "030" .@ optional simple0008 | ||
59 | , "040" .@ optional simple0042 | ||
60 | ] | ||
61 | |||
62 | -- | Derived from this specification: | ||
63 | -- | ||
64 | -- > 010 0010 Interchange recipient identification M an..35 | ||
65 | -- > 020 0007 Identification code qualifier C an..4 | ||
66 | -- > 030 0014 Interchange recipient internal identification C an..35 | ||
67 | -- > 040 0046 Interchange recipient internal sub-identification C an..35 | ||
68 | -- | ||
69 | -- Dependencies: 'simple0007', 'simple0010', 'simple0014', 'simple0046'. | ||
70 | compositeS003 :: Parser Value | ||
71 | compositeS003 = | ||
72 | composite "S003" | ||
73 | [ "010" .@ mandatory simple0010 | ||
74 | , "020" .@ optional simple0007 | ||
75 | , "030" .@ optional simple0014 | ||
76 | , "040" .@ optional simple0046 | ||
77 | ] | ||
78 | |||
79 | -- | Derived from this specification: | ||
80 | -- | ||
81 | -- > 010 0017 Date M n6 | ||
82 | -- > 020 0019 Time M n4 | ||
83 | -- | ||
84 | -- Dependencies: 'simple0017', 'simple0019'. | ||
85 | compositeS004 :: Parser Value | ||
86 | compositeS004 = | ||
87 | composite "S004" | ||
88 | [ "010" .@ mandatory simple0017 | ||
89 | , "020" .@ mandatory simple0019 | ||
90 | ] | ||
91 | |||
92 | -- | Derived from this specification: | ||
93 | -- | ||
94 | -- > 010 0022 Recipient reference/password M an..14 | ||
95 | -- > 020 0025 Recipient reference/password qualifier C an2 | ||
96 | -- | ||
97 | -- Dependencies: 'simple0022', 'simple0025'. | ||
98 | compositeS005 :: Parser Value | ||
99 | compositeS005 = | ||
100 | composite "S005" | ||
101 | [ "010" .@ mandatory simple0022 | ||
102 | , "020" .@ optional simple0025 | ||
103 | ] | ||
104 | |||
105 | -- | Derived from this specification: | ||
106 | -- | ||
107 | -- > 010 0065 Message type M an..6 | ||
108 | -- > 020 0052 Message version number M an..3 | ||
109 | -- > 030 0054 Message release number M an..3 | ||
110 | -- > 040 0051 Controlling agency M an..2 | ||
111 | -- > 050 0057 Association assigned code C an..6 | ||
112 | -- | ||
113 | -- Dependencies: 'simple0051', 'simple0052', 'simple0054', 'simple0057', 'simple0065'. | ||
114 | compositeS009 :: Parser Value | ||
115 | compositeS009 = | ||
116 | composite "S009" | ||
117 | [ "010" .@ mandatory simple0065 | ||
118 | , "020" .@ mandatory simple0052 | ||
119 | , "030" .@ mandatory simple0054 | ||
120 | , "040" .@ mandatory simple0051 | ||
121 | , "050" .@ optional simple0057 | ||
122 | ] | ||
123 | |||
124 | -- | Derived from this specification: | ||
125 | -- | ||
126 | -- > 010 0070 Sequence of transfers M n..2 | ||
127 | -- > 020 0073 First and last transfer C a1 | ||
128 | -- | ||
129 | -- Dependencies: 'simple0070', 'simple0073'. | ||
130 | compositeS010 :: Parser Value | ||
131 | compositeS010 = | ||
132 | composite "S010" | ||
133 | [ "010" .@ mandatory simple0070 | ||
134 | , "020" .@ optional simple0073 | ||
135 | ] | ||
diff --git a/core/src/Text/Edifact/Common/Segments.hs b/core/src/Text/Edifact/Common/Segments.hs new file mode 100644 index 0000000..e73719f --- /dev/null +++ b/core/src/Text/Edifact/Common/Segments.hs | |||
@@ -0,0 +1,10 @@ | |||
1 | module Text.Edifact.Common.Segments | ||
2 | ( module S | ||
3 | ) where | ||
4 | |||
5 | import Text.Edifact.Common.Segments.UNA as S | ||
6 | import Text.Edifact.Common.Segments.UNB as S | ||
7 | import Text.Edifact.Common.Segments.UNH as S | ||
8 | import Text.Edifact.Common.Segments.UNS as S | ||
9 | import Text.Edifact.Common.Segments.UNT as S | ||
10 | import Text.Edifact.Common.Segments.UNZ as S | ||
diff --git a/core/src/Text/Edifact/Common/Segments/UNA.hs b/core/src/Text/Edifact/Common/Segments/UNA.hs new file mode 100644 index 0000000..1b20a9f --- /dev/null +++ b/core/src/Text/Edifact/Common/Segments/UNA.hs | |||
@@ -0,0 +1,34 @@ | |||
1 | module Text.Edifact.Common.Segments.UNA | ||
2 | ( segmentUNA | ||
3 | ) where | ||
4 | |||
5 | import Text.Edifact.Parsing | ||
6 | import Text.Edifact.Parsing.Commons (updateSyntax) | ||
7 | import Text.Edifact.Types (Syntax (..), defaultSyntax) | ||
8 | |||
9 | import Control.Monad (void) | ||
10 | import Text.Parsec (anyChar, char, endOfLine, | ||
11 | optionMaybe, string, try) | ||
12 | import qualified Text.Parsec as P (optional) | ||
13 | |||
14 | segmentUNA :: Parser () | ||
15 | segmentUNA = | ||
16 | let segmentParser = string "UNA" *> parseSyntax <* P.optional endOfLine | ||
17 | nothing = pure () | ||
18 | in optionMaybe (try segmentParser) >>= maybe nothing updateSyntax | ||
19 | |||
20 | parseSyntax :: Parser Syntax | ||
21 | parseSyntax = do | ||
22 | compositeSeparator' <- anyChar | ||
23 | elementSeparator' <- anyChar | ||
24 | decimalSign' <- anyChar | ||
25 | escape' <- anyChar | ||
26 | void $ char ' ' -- reserved, not used | ||
27 | segmentSeparator' <- anyChar | ||
28 | pure defaultSyntax | ||
29 | { compositeSeparator = compositeSeparator' | ||
30 | , elementSeparator = elementSeparator' | ||
31 | , decimalSign = decimalSign' | ||
32 | , escape = escape' | ||
33 | , segmentSeparator = segmentSeparator' | ||
34 | } | ||
diff --git a/core/src/Text/Edifact/Common/Segments/UNB.hs b/core/src/Text/Edifact/Common/Segments/UNB.hs new file mode 100644 index 0000000..55f1eea --- /dev/null +++ b/core/src/Text/Edifact/Common/Segments/UNB.hs | |||
@@ -0,0 +1,63 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | ||
2 | |||
3 | module Text.Edifact.Common.Segments.UNB | ||
4 | ( segmentUNB | ||
5 | ) where | ||
6 | |||
7 | import Text.Edifact.Common.Composites (compositeS001, compositeS002, | ||
8 | compositeS003, compositeS004, | ||
9 | compositeS005) | ||
10 | import Text.Edifact.Common.Simples (simple0020, simple0026, | ||
11 | simple0029, simple0031, | ||
12 | simple0032, simple0035) | ||
13 | |||
14 | import Text.Edifact.Parsing | ||
15 | import Text.Edifact.Types (Value) | ||
16 | |||
17 | -- | Derived from this specification: | ||
18 | -- | ||
19 | -- > Pos Segment M/C Repeat Repr. Notes | ||
20 | -- > 010 S001 SYNTAX IDENTIFIER M 1 | ||
21 | -- > 0001 Syntax identifier M a4 | ||
22 | -- > 0002 Syntax version number M an1 | ||
23 | -- > 0080 Service code list directory version number C an..6 | ||
24 | -- > 0133 Character encoding, coded C an..3 | ||
25 | -- > 020 S002 INTERCHANGE SENDER M 1 | ||
26 | -- > 0004 Interchange sender identification M an..35 | ||
27 | -- > 0007 Identification code qualifier C an..4 | ||
28 | -- > 0008 Interchange sender internal identification C an..35 | ||
29 | -- > 0042 Interchange sender internal sub-identification C an..35 | ||
30 | -- > 030 S003 INTERCHANGE RECIPIENT M 1 | ||
31 | -- > 0010 Interchange recipient identification M an..35 | ||
32 | -- > 0007 Identification code qualifier C an..4 | ||
33 | -- > 0014 Interchange recipient internal identification C an..35 | ||
34 | -- > 0046 Interchange recipient internal sub-identification C an..35 | ||
35 | -- > 040 S004 DATE AND TIME OF PREPARATION M 1 | ||
36 | -- > 0017 Date M n8 | ||
37 | -- > 0019 Time M n4 | ||
38 | -- > 050 0020 Interchange control reference M 1 an..14 | ||
39 | -- > 060 S005 RECIPIENT'S REFERENCE/PASSWORD DETAILS C 1 | ||
40 | -- > 0022 Recipient reference/password M an..14 | ||
41 | -- > 0025 Recipient reference/password qualifier C an2 | ||
42 | -- > 070 0026 Application reference C 1 an..14 | ||
43 | -- > 080 0029 Processing priority code C 1 a1 | ||
44 | -- > 090 0031 Acknowledgement request C 1 n1 | ||
45 | -- > 100 0032 Interchange agreement identifier C 1 an..35 | ||
46 | -- > 110 0035 Test indicator C 1 n1 | ||
47 | -- | ||
48 | -- Dependencies: 'compositeS001', 'compositeS002', 'compositeS003', 'compositeS004', 'compositeS005', 'simple0020', 'simple0026', 'simple0029', 'simple0031', 'simple0032', 'simple0035'. | ||
49 | segmentUNB :: Parser Value | ||
50 | segmentUNB = | ||
51 | segment "UNB" | ||
52 | [ "010" .@ mandatory compositeS001 | ||
53 | , "020" .@ mandatory compositeS002 | ||
54 | , "030" .@ mandatory compositeS003 | ||
55 | , "040" .@ mandatory compositeS004 | ||
56 | , "050" .@ mandatory simple0020 | ||
57 | , "060" .@ optional compositeS005 | ||
58 | , "070" .@ optional simple0026 | ||
59 | , "080" .@ optional simple0029 | ||
60 | , "090" .@ optional simple0031 | ||
61 | , "100" .@ optional simple0032 | ||
62 | , "110" .@ optional simple0035 | ||
63 | ] | ||
diff --git a/core/src/Text/Edifact/Common/Segments/UNH.hs b/core/src/Text/Edifact/Common/Segments/UNH.hs new file mode 100644 index 0000000..61cb6b3 --- /dev/null +++ b/core/src/Text/Edifact/Common/Segments/UNH.hs | |||
@@ -0,0 +1,44 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | ||
2 | |||
3 | module Text.Edifact.Common.Segments.UNH | ||
4 | ( segmentUNH | ||
5 | ) where | ||
6 | |||
7 | import Text.Edifact.Common.Composites (compositeS009, compositeS010) | ||
8 | import Text.Edifact.Common.Simples (simple0062, simple0068) | ||
9 | |||
10 | import Text.Edifact.Parsing | ||
11 | import Text.Edifact.Types (Value) | ||
12 | |||
13 | -- | Derived from this specification: | ||
14 | -- | ||
15 | -- > Change indicators | ||
16 | -- > | ||
17 | -- > UNH MESSAGE HEADER | ||
18 | -- > | ||
19 | -- > Function: To head, identify and specify a message. | ||
20 | -- > | ||
21 | -- > 010 0062 MESSAGE REFERENCE NUMBER M an..14 | ||
22 | -- > | ||
23 | -- > 020 S009 MESSAGE IDENTIFIER M | ||
24 | -- > 0065 Message type M an..6 | ||
25 | -- > 0052 Message version number M an..3 | ||
26 | -- > 0054 Message release number M an..3 | ||
27 | -- > 0051 Controlling agency M an..2 | ||
28 | -- > 0057 Association assigned code C an..6 | ||
29 | -- > | ||
30 | -- > 030 0068 COMMON ACCESS REFERENCE C an..35 | ||
31 | -- > | ||
32 | -- > 040 S010 STATUS OF THE TRANSFER C | ||
33 | -- > 0070 Sequence of transfers M n..2 | ||
34 | -- > 0073 First and last transfer C a1 | ||
35 | -- | ||
36 | -- Dependencies: 'compositeS009', 'compositeS010', 'simple0062', 'simple0068'. | ||
37 | segmentUNH :: Parser Value | ||
38 | segmentUNH = | ||
39 | segment "UNH" | ||
40 | [ "010" .@ mandatory simple0062 | ||
41 | , "020" .@ mandatory compositeS009 | ||
42 | , "030" .@ optional simple0068 | ||
43 | , "040" .@ optional compositeS010 | ||
44 | ] | ||
diff --git a/core/src/Text/Edifact/Common/Segments/UNS.hs b/core/src/Text/Edifact/Common/Segments/UNS.hs new file mode 100644 index 0000000..3d9b395 --- /dev/null +++ b/core/src/Text/Edifact/Common/Segments/UNS.hs | |||
@@ -0,0 +1,27 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | ||
2 | |||
3 | module Text.Edifact.Common.Segments.UNS | ||
4 | ( segmentUNS | ||
5 | ) where | ||
6 | |||
7 | import Text.Edifact.Common.Simples (simple0081) | ||
8 | |||
9 | import Text.Edifact.Parsing | ||
10 | import Text.Edifact.Types (Value) | ||
11 | |||
12 | -- | Derived from this specification: | ||
13 | -- | ||
14 | -- > Change indicators | ||
15 | -- > | ||
16 | -- > UNS SECTION CONTROL | ||
17 | -- > | ||
18 | -- > Function: To separate Header, Detail and Summary sections of a message | ||
19 | -- > | ||
20 | -- > 010 0081 SECTION IDENTIFICATION M a1 | ||
21 | -- | ||
22 | -- Dependencies: 'simple0081'. | ||
23 | segmentUNS :: Parser Value | ||
24 | segmentUNS = | ||
25 | segment "UNS" | ||
26 | [ "010" .@ mandatory simple0081 | ||
27 | ] | ||
diff --git a/core/src/Text/Edifact/Common/Segments/UNT.hs b/core/src/Text/Edifact/Common/Segments/UNT.hs new file mode 100644 index 0000000..e91f9cf --- /dev/null +++ b/core/src/Text/Edifact/Common/Segments/UNT.hs | |||
@@ -0,0 +1,30 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | ||
2 | |||
3 | module Text.Edifact.Common.Segments.UNT | ||
4 | ( segmentUNT | ||
5 | ) where | ||
6 | |||
7 | import Text.Edifact.Common.Simples (simple0062, simple0074) | ||
8 | |||
9 | import Text.Edifact.Parsing | ||
10 | import Text.Edifact.Types (Value) | ||
11 | |||
12 | -- | Derived from this specification: | ||
13 | -- | ||
14 | -- > Change indicators | ||
15 | -- > | ||
16 | -- > UNT MESSAGE TRAILER | ||
17 | -- > | ||
18 | -- > Function: To end and check the completeness of a message. | ||
19 | -- > | ||
20 | -- > 010 0074 NUMBER OF SEGMENTS IN THE MESSAGE M n..6 | ||
21 | -- > | ||
22 | -- > 020 0062 MESSAGE REFERENCE NUMBER M an..14 | ||
23 | -- | ||
24 | -- Dependencies: 'simple0062', 'simple0074'. | ||
25 | segmentUNT :: Parser Value | ||
26 | segmentUNT = | ||
27 | segment "UNT" | ||
28 | [ "010" .@ mandatory simple0074 | ||
29 | , "020" .@ mandatory simple0062 | ||
30 | ] | ||
diff --git a/core/src/Text/Edifact/Common/Segments/UNZ.hs b/core/src/Text/Edifact/Common/Segments/UNZ.hs new file mode 100644 index 0000000..0566860 --- /dev/null +++ b/core/src/Text/Edifact/Common/Segments/UNZ.hs | |||
@@ -0,0 +1,24 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | ||
2 | |||
3 | module Text.Edifact.Common.Segments.UNZ | ||
4 | ( segmentUNZ | ||
5 | ) where | ||
6 | |||
7 | import Text.Edifact.Common.Simples (simple0020, simple0036) | ||
8 | |||
9 | import Text.Edifact.Parsing | ||
10 | import Text.Edifact.Types (Value) | ||
11 | |||
12 | -- | Derived from this specification: | ||
13 | -- | ||
14 | -- > Pos Segment M/C Repeat Repr. Notes | ||
15 | -- > 010 0036 Interchange control count M 1 n..6 | ||
16 | -- > 020 0020 Interchange control reference M 1 an..14 | ||
17 | -- | ||
18 | -- Dependencies: 'simple0020', 'simple0036'. | ||
19 | segmentUNZ :: Parser Value | ||
20 | segmentUNZ = | ||
21 | segment "UNZ" | ||
22 | [ "010" .@ mandatory simple0036 | ||
23 | , "030" .@ mandatory simple0020 | ||
24 | ] | ||
diff --git a/core/src/Text/Edifact/Common/Simples.hs b/core/src/Text/Edifact/Common/Simples.hs new file mode 100644 index 0000000..537b128 --- /dev/null +++ b/core/src/Text/Edifact/Common/Simples.hs | |||
@@ -0,0 +1,271 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | ||
2 | |||
3 | module Text.Edifact.Common.Simples | ||
4 | ( simple0001 | ||
5 | , simple0002 | ||
6 | , simple0004 | ||
7 | , simple0007 | ||
8 | , simple0008 | ||
9 | , simple0010 | ||
10 | , simple0014 | ||
11 | , simple0017 | ||
12 | , simple0019 | ||
13 | , simple0020 | ||
14 | , simple0022 | ||
15 | , simple0025 | ||
16 | , simple0026 | ||
17 | , simple0029 | ||
18 | , simple0031 | ||
19 | , simple0032 | ||
20 | , simple0035 | ||
21 | , simple0036 | ||
22 | , simple0042 | ||
23 | , simple0046 | ||
24 | , simple0051 | ||
25 | , simple0052 | ||
26 | , simple0054 | ||
27 | , simple0057 | ||
28 | , simple0062 | ||
29 | , simple0065 | ||
30 | , simple0068 | ||
31 | , simple0070 | ||
32 | , simple0073 | ||
33 | , simple0074 | ||
34 | , simple0080 | ||
35 | , simple0081 | ||
36 | , simple0133 | ||
37 | ) where | ||
38 | |||
39 | import Text.Edifact.Parsing | ||
40 | import Text.Edifact.Types (Value) | ||
41 | |||
42 | -- | Derived from this specification: | ||
43 | -- | ||
44 | -- > 0001 Syntax identifier | ||
45 | -- > Repr: a4 | ||
46 | simple0001 :: Parser Value | ||
47 | simple0001 = simple "0001" (alpha `exactly` 4) | ||
48 | |||
49 | -- | Derived from this specification: | ||
50 | -- | ||
51 | -- > 0002 Syntax version number | ||
52 | -- > Repr: an1 | ||
53 | simple0002 :: Parser Value | ||
54 | simple0002 = simple "0002" (alphaNumeric `exactly` 1) | ||
55 | |||
56 | -- | Derived from this specification: | ||
57 | -- | ||
58 | -- > 0004 Interchange sender identification | ||
59 | -- > Repr: an..35 | ||
60 | simple0004 :: Parser Value | ||
61 | simple0004 = simple "0004" (alphaNumeric `upTo` 35) | ||
62 | |||
63 | -- | Derived from this specification: | ||
64 | -- | ||
65 | -- > 0007 Identification code qualifier | ||
66 | -- > Repr: an..4 | ||
67 | simple0007 :: Parser Value | ||
68 | simple0007 = simple "0007" (alphaNumeric `upTo` 4) | ||
69 | |||
70 | -- | Derived from this specification: | ||
71 | -- | ||
72 | -- > 0008 Interchange sender internal identification | ||
73 | -- > Repr: an..35 | ||
74 | simple0008 :: Parser Value | ||
75 | simple0008 = simple "0008" (alphaNumeric `upTo` 35) | ||
76 | |||
77 | -- | Derived from this specification: | ||
78 | -- | ||
79 | -- > 0010 Interchange recipient identification | ||
80 | -- > Repr: an..35 | ||
81 | simple0010 :: Parser Value | ||
82 | simple0010 = simple "0010" (alphaNumeric `upTo` 35) | ||
83 | |||
84 | -- | Derived from this specification: | ||
85 | -- | ||
86 | -- > 0014 Interchange recipient internal identification | ||
87 | -- > Repr: an..35 | ||
88 | simple0014 :: Parser Value | ||
89 | simple0014 = simple "0014" (alphaNumeric `upTo` 35) | ||
90 | |||
91 | -- | Derived from this specification: | ||
92 | -- | ||
93 | -- > 0017 Date | ||
94 | -- > Repr: n6 | ||
95 | simple0017 :: Parser Value | ||
96 | simple0017 = simple "0017" (numeric `exactly` 6) | ||
97 | |||
98 | -- | Derived from this specification: | ||
99 | -- | ||
100 | -- > 0019 Time | ||
101 | -- > Repr: n4 | ||
102 | simple0019 :: Parser Value | ||
103 | simple0019 = simple "0019" (numeric `exactly` 4) | ||
104 | |||
105 | -- | Derived from this specification: | ||
106 | -- | ||
107 | -- > 0020 Interchange control reference | ||
108 | -- > Repr: an..14 | ||
109 | simple0020 :: Parser Value | ||
110 | simple0020 = simple "0020" (alphaNumeric `upTo` 14) | ||
111 | |||
112 | -- | Derived from this specification: | ||
113 | -- | ||
114 | -- > 0022 Recipient reference/password | ||
115 | -- > Repr: an..14 | ||
116 | simple0022 :: Parser Value | ||
117 | simple0022 = simple "0022" (alphaNumeric `upTo` 14) | ||
118 | |||
119 | -- | Derived from this specification: | ||
120 | -- | ||
121 | -- > 0025 Recipient reference/password qualifier | ||
122 | -- > Repr: an2 | ||
123 | simple0025 :: Parser Value | ||
124 | simple0025 = simple "0025" (alphaNumeric `exactly` 2) | ||
125 | |||
126 | -- | Derived from this specification: | ||
127 | -- | ||
128 | -- > 0026 Application reference | ||
129 | -- > Repr: an..14 | ||
130 | simple0026 :: Parser Value | ||
131 | simple0026 = simple "0026" (alphaNumeric `upTo` 14) | ||
132 | |||
133 | -- | Derived from this specification: | ||
134 | -- | ||
135 | -- > 0029 Processing priority code | ||
136 | -- > Repr: a1 | ||
137 | simple0029 :: Parser Value | ||
138 | simple0029 = simple "0029" (alphaNumeric `exactly` 1) | ||
139 | |||
140 | -- | Derived from this specification: | ||
141 | -- | ||
142 | -- > 0031 Acknowledgement request | ||
143 | -- > Repr: n1 | ||
144 | simple0031 :: Parser Value | ||
145 | simple0031 = simple "0031" (numeric `exactly` 1) | ||
146 | |||
147 | -- | Derived from this specification: | ||
148 | -- | ||
149 | -- > 0032 Interchange agreement identifier | ||
150 | -- > Repr: an..35 | ||
151 | simple0032 :: Parser Value | ||
152 | simple0032 = simple "0032" (alphaNumeric `upTo` 35) | ||
153 | |||
154 | -- | Derived from this specification: | ||
155 | -- | ||
156 | -- > 0035 Test indicator | ||
157 | -- > Repr: n1 | ||
158 | simple0035 :: Parser Value | ||
159 | simple0035 = simple "0035" (numeric `exactly` 1) | ||
160 | |||
161 | -- | Derived from this specification: | ||
162 | -- | ||
163 | -- > 0036 Interchange control count | ||
164 | -- > Repr: n..6 | ||
165 | simple0036 :: Parser Value | ||
166 | simple0036 = simple "0036" (numeric `upTo` 6) | ||
167 | |||
168 | -- | Derived from this specification: | ||
169 | -- | ||
170 | -- > 0042 Interchange sender internal sub-identification | ||
171 | -- > Repr: an..35 | ||
172 | simple0042 :: Parser Value | ||
173 | simple0042 = simple "0042" (alphaNumeric `upTo` 35) | ||
174 | |||
175 | -- | Derived from this specification: | ||
176 | -- | ||
177 | -- > 0046 Interchange recipient internal sub-identification | ||
178 | -- > Repr: an..35 | ||
179 | simple0046 :: Parser Value | ||
180 | simple0046 = simple "0046" (alphaNumeric `upTo` 35) | ||
181 | |||
182 | -- | Derived from this specification: | ||
183 | -- | ||
184 | -- > 0051 Controlling agency | ||
185 | -- > Repr: an..2 | ||
186 | simple0051 :: Parser Value | ||
187 | simple0051 = simple "0051" (alphaNumeric `upTo` 2) | ||
188 | |||
189 | -- | Derived from this specification: | ||
190 | -- | ||
191 | -- > 0052 Message version number | ||
192 | -- > Repr: an..3 | ||
193 | simple0052 :: Parser Value | ||
194 | simple0052 = simple "0052" (alphaNumeric `upTo` 3) | ||
195 | |||
196 | -- | Derived from this specification: | ||
197 | -- | ||
198 | -- > 0054 Message release number | ||
199 | -- > Repr: an..3 | ||
200 | simple0054 :: Parser Value | ||
201 | simple0054 = simple "0054" (alphaNumeric `upTo` 3) | ||
202 | |||
203 | -- | Derived from this specification: | ||
204 | -- | ||
205 | -- > 0057 Association assigned code | ||
206 | -- > Repr: an..6 | ||
207 | simple0057 :: Parser Value | ||
208 | simple0057 = simple "0057" (alphaNumeric `upTo` 6) | ||
209 | |||
210 | -- | Derived from this specification: | ||
211 | -- | ||
212 | -- > 0062 MESSAGE REFERENCE NUMBER | ||
213 | -- > Repr: an..14 | ||
214 | simple0062 :: Parser Value | ||
215 | simple0062 = simple "0062" (alphaNumeric `upTo` 14) | ||
216 | |||
217 | -- | Derived from this specification: | ||
218 | -- | ||
219 | -- > 0065 Message type | ||
220 | -- > Repr: an..6 | ||
221 | simple0065 :: Parser Value | ||
222 | simple0065 = simple "0065" (alphaNumeric `upTo` 6) | ||
223 | |||
224 | -- | Derived from this specification: | ||
225 | -- | ||
226 | -- > 0068 COMMON ACCESS REFERENCE | ||
227 | -- > Repr: an..35 | ||
228 | simple0068 :: Parser Value | ||
229 | simple0068 = simple "0068" (alphaNumeric `upTo` 35) | ||
230 | |||
231 | -- | Derived from this specification: | ||
232 | -- | ||
233 | -- > 0070 Sequence of transfers | ||
234 | -- > Repr: n..2 | ||
235 | simple0070 :: Parser Value | ||
236 | simple0070 = simple "0070" (numeric `upTo` 2) | ||
237 | |||
238 | -- | Derived from this specification: | ||
239 | -- | ||
240 | -- > 0073 First and last transfer | ||
241 | -- > Repr: a1 | ||
242 | simple0073 :: Parser Value | ||
243 | simple0073 = simple "0073" (alpha `exactly` 1) | ||
244 | |||
245 | -- | Derived from this specification: | ||
246 | -- | ||
247 | -- > 0074 NUMBER OF SEGMENTS IN THE MESSAGE | ||
248 | -- > Repr: n..6 | ||
249 | simple0074 :: Parser Value | ||
250 | simple0074 = simple "0074" (numeric `upTo` 6) | ||
251 | |||
252 | -- | Derived from this specification: | ||
253 | -- | ||
254 | -- > 0080 Service code list directory version number | ||
255 | -- > Repr: an..6 | ||
256 | simple0080 :: Parser Value | ||
257 | simple0080 = simple "0080" (alphaNumeric `upTo` 6) | ||
258 | |||
259 | -- | Derived from this specification: | ||
260 | -- | ||
261 | -- > 0081 SECTION IDENTIFICATION | ||
262 | -- > Repr: a1 | ||
263 | simple0081 :: Parser Value | ||
264 | simple0081 = simple "0081" (alpha `exactly` 1) | ||
265 | |||
266 | -- | Derived from this specification: | ||
267 | -- | ||
268 | -- > 0133 Character encoding, coded | ||
269 | -- > Repr: an..3 | ||
270 | simple0133 :: Parser Value | ||
271 | simple0133 = simple "0133" (alphaNumeric `upTo` 3) | ||
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 | ||
diff --git a/core/src/Text/Edifact/Parsing.hs b/core/src/Text/Edifact/Parsing.hs new file mode 100644 index 0000000..0b1ece8 --- /dev/null +++ b/core/src/Text/Edifact/Parsing.hs | |||
@@ -0,0 +1,72 @@ | |||
1 | {-| | ||
2 | Module : Text.Edifact.Parsing | ||
3 | Description : Parsing routines and combinators | ||
4 | |||
5 | This module is there to reexport most of the combinators and helpers required | ||
6 | to parse an Edifact payload. | ||
7 | |||
8 | For high level combinators, have a look at "Text.Edifact.Parsing.Combinators". | ||
9 | |||
10 | For low level combinators, have a look at "Text.Edifact.Parsing.Primitives". | ||
11 | -} | ||
12 | module Text.Edifact.Parsing | ||
13 | ( | ||
14 | -- * Parsing routines | ||
15 | parse | ||
16 | |||
17 | -- * Combinators | ||
18 | -- | See "Text.Edifact.Parsing.Combinators" for more details | ||
19 | |||
20 | -- ** Values parsers | ||
21 | , message | ||
22 | , segment | ||
23 | , segmentGroup | ||
24 | , composite | ||
25 | , simple | ||
26 | |||
27 | -- ** Position and strictness | ||
28 | , position | ||
29 | , (.@) | ||
30 | , (@.) | ||
31 | , mandatory | ||
32 | , optional | ||
33 | |||
34 | -- ** Repetition of segments and segment groups | ||
35 | , repeated | ||
36 | , repeatedAtLeastOnce | ||
37 | , once | ||
38 | , maybeOnce | ||
39 | |||
40 | -- * Primitives | ||
41 | -- | See "Text.Edifact.Parsing.Primitives" for more details and known limitations. | ||
42 | |||
43 | -- ** Simple elements definition | ||
44 | , alphaNumeric | ||
45 | , alpha | ||
46 | , numeric | ||
47 | -- ** Cardinality | ||
48 | , exactly | ||
49 | , upTo | ||
50 | , many | ||
51 | |||
52 | -- * Types | ||
53 | , Parser | ||
54 | -- ** Reexported | ||
55 | , ParseError | ||
56 | ) where | ||
57 | |||
58 | import Text.Edifact.Parsing.Combinators (composite, mandatory, | ||
59 | maybeOnce, message, once, | ||
60 | optional, position, repeated, | ||
61 | repeatedAtLeastOnce, segment, | ||
62 | segmentGroup, simple, (.@), | ||
63 | (@.)) | ||
64 | import Text.Edifact.Parsing.Commons (Parser, defaultContext) | ||
65 | import Text.Edifact.Parsing.Primitives (alpha, alphaNumeric, exactly, | ||
66 | many, numeric, upTo) | ||
67 | |||
68 | import Data.Text (Text) | ||
69 | import Text.Parsec (ParseError, runParser) | ||
70 | |||
71 | parse :: Parser value -> Text -> Either ParseError value | ||
72 | parse p = runParser p defaultContext "" | ||
diff --git a/core/src/Text/Edifact/Parsing/Combinators.hs b/core/src/Text/Edifact/Parsing/Combinators.hs new file mode 100644 index 0000000..ce3f4be --- /dev/null +++ b/core/src/Text/Edifact/Parsing/Combinators.hs | |||
@@ -0,0 +1,230 @@ | |||
1 | {-# LANGUAGE TupleSections #-} | ||
2 | |||
3 | {-| | ||
4 | Module : Text.Edifact.Parsing.Combinators | ||
5 | Description : High level combinators | ||
6 | -} | ||
7 | module Text.Edifact.Parsing.Combinators | ||
8 | ( -- * Combinators | ||
9 | -- ** Values parsers | ||
10 | message | ||
11 | , segmentGroup | ||
12 | , segment | ||
13 | , composite | ||
14 | , simple | ||
15 | |||
16 | -- ** Position and strictness | ||
17 | , position | ||
18 | , (.@) | ||
19 | , (@.) | ||
20 | , mandatory | ||
21 | , optional | ||
22 | |||
23 | -- ** Repetition of segments and segment groups | ||
24 | , repeated | ||
25 | , repeatedAtLeastOnce | ||
26 | , once | ||
27 | , maybeOnce | ||
28 | ) where | ||
29 | |||
30 | import Text.Edifact.Parsing.Commons | ||
31 | import Text.Edifact.Types | ||
32 | |||
33 | import Text.Parsec (lookAhead, many1, optionMaybe, | ||
34 | string, try) | ||
35 | import qualified Text.Parsec as P (many) | ||
36 | |||
37 | -- | Parses a 'Message'. | ||
38 | -- | ||
39 | -- > messageABCDEF :: Parser Value | ||
40 | -- > messageABCDEF = | ||
41 | -- > let simple1234 = simple "1234" (alphaNumeric `upTo` 35) | ||
42 | -- > c101 = composite "C101" [ position "010" (mandatory simple1234) | ||
43 | -- > , position "020" (optional simple1234) | ||
44 | -- > ] | ||
45 | -- > segmentABC = segment "ABC" [ position "010" (mandatory c101) | ||
46 | -- > ] | ||
47 | -- > in message "ABCDEF" [ position "0010" (mandatory segmentABC) | ||
48 | -- > ] | ||
49 | message :: MessageCode -> [Parser (Position, [Value])] -> Parser Value | ||
50 | message code ps = | ||
51 | let description = "message " <> show code | ||
52 | in Message code <$> sequence ps <??> description | ||
53 | |||
54 | -- | Parses a 'Group'. | ||
55 | -- | ||
56 | -- A Segment Group is the way Edifact format represents hierarchy. One can view | ||
57 | -- a segment group as a sub message. A segment group can be repeated like | ||
58 | -- segments. A segment group wraps segments and segment groups. | ||
59 | segmentGroup :: GroupCode -> [Parser (Position, [Value])] -> Parser Value | ||
60 | segmentGroup code ps = | ||
61 | let description = "segment-group " <> show code | ||
62 | in Group code <$> sequence ps <??> description | ||
63 | |||
64 | -- | Parses a 'Segment'. | ||
65 | -- | ||
66 | -- Following parser: | ||
67 | -- | ||
68 | -- > segmentABC :: Parser Value | ||
69 | -- > segmentABC = | ||
70 | -- > let simple1234 = simple "1234" (alphaNumeric `upTo` 35) | ||
71 | -- > simple2001 = simple "2001" (alphaNumeric `exactly` 3) | ||
72 | -- > c101 = composite "C101" [ position "010" (mandatory simple1234) | ||
73 | -- > , position "020" (optional simple1234) | ||
74 | -- > , position "030" (optional simple1234) | ||
75 | -- > ] | ||
76 | -- > in segment "ABC" [ position "010" (mandatory simple2001) | ||
77 | -- > , position "020" (optional c101) | ||
78 | -- > ] | ||
79 | -- | ||
80 | -- would parse strings such as: | ||
81 | -- | ||
82 | -- >>> parse segmentABC "ABC+123'" | ||
83 | -- Segment "ABC" [ ("010", Just (Simple "2001" "123")) | ||
84 | -- ] | ||
85 | -- >>> parse segmentABC "ABC+123+abcdefgh'" | ||
86 | -- Segment "ABC" [ ("010", Just (Simple "2001" "123")) | ||
87 | -- , ("020", Just (Composite "C101" [ ("010", Just (Simple "1234" "abcdefgh")) | ||
88 | -- ] | ||
89 | -- )) | ||
90 | -- ] | ||
91 | -- >>> parse segmentABC "ABC+123+abcdefgh:ijklmno'" | ||
92 | -- Segment "ABC" [ ("010", Just (Simple "2001" "123")) | ||
93 | -- , ("020", Just (Composite "C101" [ ("010", Just (Simple "1234" "abcdefgh")) | ||
94 | -- , ("020", Just (Simple "1234" "ijklmno")) | ||
95 | -- ] | ||
96 | -- )) | ||
97 | -- ] | ||
98 | segment :: SegmentCode -> [Parser (Position, Maybe Value)] -> Parser Value | ||
99 | segment code parsers = | ||
100 | let go [] = [] <$ parseSegmentSeparator | ||
101 | go (p:ps) = | ||
102 | tries [ [] <$ parseSegmentSeparator | ||
103 | , (:) <$> (parseElementSeparator *> p) | ||
104 | <*> go ps | ||
105 | ] | ||
106 | description = "segment " <> show code | ||
107 | in Segment <$> parseSegmentCode code | ||
108 | <*> go parsers | ||
109 | <??> description | ||
110 | |||
111 | parseSegmentCode :: SegmentCode -> Parser SegmentCode | ||
112 | parseSegmentCode (SegmentCode code) = | ||
113 | let description = "segment code " <> show code | ||
114 | in SegmentCode <$> string code <??> description | ||
115 | |||
116 | -- | Parses a 'Composite' element. | ||
117 | -- | ||
118 | -- Following parser: | ||
119 | -- | ||
120 | -- > compositeC101 :: Parser Value | ||
121 | -- > compositeC101 = | ||
122 | -- > let simple1234 = simple "1234" (alphaNumeric `upTo` 35) | ||
123 | -- > in composite "C101" [ position "010" (mandatory simple1234) | ||
124 | -- > , position "020" (optional simple1234) | ||
125 | -- > , position "030" (optional simple1234) | ||
126 | -- > ] | ||
127 | -- | ||
128 | -- would parse strings such as: | ||
129 | -- | ||
130 | -- >>> parse compositeC101 "abcdefgh" | ||
131 | -- Composite "C101" [ ("010", Just (Simple "1234" "abcdefgh")) | ||
132 | -- ] | ||
133 | -- >>> parse compositeC101 "abcdefgh:ijklmno" | ||
134 | -- Composite "C101" [ ("010", Just (Simple "1234" "abcdefgh")) | ||
135 | -- , ("020", Just (Simple "1234" "ijklmno")) | ||
136 | -- ] | ||
137 | -- >>> parse compositeC101 "abcdefgh::pqrstu" | ||
138 | -- Composite "C101" [ ("010", Just (Simple "1234" "abcdefgh")) | ||
139 | -- , ("020", Just (Simple "1234" "")) | ||
140 | -- , ("030", Just (Simple "1234" "pqrstu")) | ||
141 | -- ] | ||
142 | composite :: CompositeCode -> [Parser (Position, Maybe Value)] -> Parser Value | ||
143 | composite code parsers = | ||
144 | let go [] = pure [] | ||
145 | go (p:ps) = do | ||
146 | let parseSeparator = tries [ parseCompositeSeparator | ||
147 | , lookAhead parseElementSeparator | ||
148 | , lookAhead parseSegmentSeparator | ||
149 | ] | ||
150 | (value, continuation) <- tries [ (, ps) <$> p <* parseSeparator | ||
151 | , (, []) <$> p | ||
152 | ] | ||
153 | (:) value <$> go continuation | ||
154 | description = "composite element " <> show code | ||
155 | in Composite code <$> go parsers <??> description | ||
156 | |||
157 | -- | Parses a 'Simple' element. | ||
158 | -- | ||
159 | -- Following parser would parse strings of size between 0 and 35 characters. | ||
160 | -- | ||
161 | -- > simple1234 :: Parser Value | ||
162 | -- > simple1234 = simple "1234" (alphaNumeric `upTo` 35) | ||
163 | simple :: SimpleCode -> Parser Primitive -> Parser Value | ||
164 | simple code p = | ||
165 | let description = "simple element " <> show code | ||
166 | in Simple code <$> p <??> description | ||
167 | |||
168 | -- | Makes the parsing of the element optional, which doesn't consume input if the given parser doesn't succeed. | ||
169 | optional :: Parser Value -> Parser (Maybe Value) | ||
170 | optional = optionMaybe | ||
171 | |||
172 | -- | Makes the parsing of the element mandatory. | ||
173 | mandatory :: Parser Value -> Parser (Maybe Value) | ||
174 | mandatory = fmap Just | ||
175 | |||
176 | -- | Sets the current 'Position'. This is relevant for segment in a message, for composite or simple element in a segment, and for simple element in a composite. | ||
177 | position :: Position -> Parser (f Value) -> Parser (Position, f Value) | ||
178 | position pos p = | ||
179 | let decorated = (pos,) <$> p | ||
180 | in setCurrentPosition pos *> decorated <* resetCurrentPosition | ||
181 | |||
182 | -- | Alias to 'position'. | ||
183 | -- | ||
184 | -- > compositeC101 :: Parser Value | ||
185 | -- > compositeC101 = | ||
186 | -- > let simple1234 = simple "1234" (alphaNumeric `upTo` 35) | ||
187 | -- > in composite "C101" [ "010" .@ mandatory simple1234 | ||
188 | -- > , "020" .@ optional simple1234 | ||
189 | -- > , "030" .@ optional simple1234 | ||
190 | -- > ] | ||
191 | (.@) :: Position -> Parser (f Value) -> Parser (Position, f Value) | ||
192 | (.@) = position | ||
193 | |||
194 | -- | Flipped alias to 'position'. | ||
195 | -- | ||
196 | -- > compositeC101 :: Parser Value | ||
197 | -- > compositeC101 = | ||
198 | -- > let simple1234 = simple "1234" (alphaNumeric `upTo` 35) | ||
199 | -- > in composite "C101" [ mandatory simple1234 @. "010" | ||
200 | -- > , optional simple1234 @. "020" | ||
201 | -- > , optional simple1234 @. "030" | ||
202 | -- > ] | ||
203 | (@.) :: Parser (f Value) -> Position -> Parser (Position, f Value) | ||
204 | (@.) = flip position | ||
205 | |||
206 | -- | For segments or segment groups, let you express how many occurrences. | ||
207 | repeated :: Int -> Parser a -> Parser [a] | ||
208 | repeated limit p = do | ||
209 | values <- P.many (try p) | ||
210 | let parsed = length values | ||
211 | if parsed > limit | ||
212 | then failWithPosition ("expected up to " <> show limit <> " items, but encountered " <> show parsed) | ||
213 | else pure values | ||
214 | |||
215 | -- | For segments or segment groups, let you express how many occurrences with at least one occurrence. | ||
216 | repeatedAtLeastOnce :: Int -> Parser a -> Parser [a] | ||
217 | repeatedAtLeastOnce limit p = do | ||
218 | values <- many1 (try p) | ||
219 | let parsed = length values | ||
220 | if parsed > limit | ||
221 | then failWithPosition ("expected up to " <> show limit <> " items, but encountered " <> show parsed) | ||
222 | else pure values | ||
223 | |||
224 | -- | For segments or segment groups, let you express you expect only one occurrence. | ||
225 | once :: Parser a -> Parser [a] | ||
226 | once = fmap pure | ||
227 | |||
228 | -- | For segments or segment groups, let you express you expect one or no occurrence. | ||
229 | maybeOnce :: Parser a -> Parser [a] | ||
230 | maybeOnce = fmap (maybe [] pure) . optionMaybe | ||
diff --git a/core/src/Text/Edifact/Parsing/Commons.hs b/core/src/Text/Edifact/Parsing/Commons.hs new file mode 100644 index 0000000..a1c6150 --- /dev/null +++ b/core/src/Text/Edifact/Parsing/Commons.hs | |||
@@ -0,0 +1,173 @@ | |||
1 | module Text.Edifact.Parsing.Commons | ||
2 | ( -- * Parsing context | ||
3 | Parser | ||
4 | , Context(..) | ||
5 | , CurrentPosition(..) | ||
6 | , defaultContext | ||
7 | |||
8 | -- * State combinators | ||
9 | , updateSyntax | ||
10 | , setCurrentPosition | ||
11 | , resetCurrentPosition | ||
12 | |||
13 | -- * Syntax helpers | ||
14 | -- ** Parsing combinators | ||
15 | , parseCompositeSeparator | ||
16 | , parseElementSeparator | ||
17 | , parseSegmentSeparator | ||
18 | , parseEscape | ||
19 | |||
20 | -- ** State accessors | ||
21 | -- | Shortcuts to the syntax in current state. Doesn't alter input stream. | ||
22 | , getCompositeSeparator | ||
23 | , getElementSeparator | ||
24 | , getSegmentSeparator | ||
25 | , getDecimalSign | ||
26 | |||
27 | -- * Context aware failure helpers | ||
28 | , failWithPosition | ||
29 | , (<??>) | ||
30 | |||
31 | -- * Parsec extras | ||
32 | , tries | ||
33 | |||
34 | -- * Technical combinators | ||
35 | , notYetImplemented | ||
36 | ) where | ||
37 | |||
38 | import Text.Edifact.Types (Position, Syntax (..), defaultSyntax) | ||
39 | |||
40 | import Data.Text (Text) | ||
41 | import Text.Parsec (Parsec, char, choice, endOfLine, getState, | ||
42 | modifyState, try, updateState, (<?>)) | ||
43 | |||
44 | -- | Defines our "Text.Parsec" context. | ||
45 | type Parser = Parsec Text Context | ||
46 | |||
47 | data Context = | ||
48 | Context | ||
49 | { parsingSyntax :: Syntax -- ^ State of the syntax. To be updated on the encounter of the @UNA@ segment. | ||
50 | , currentPosition :: CurrentPosition -- ^ Pointer for current position in the parser. Used for enriched parsing error messages. | ||
51 | } | ||
52 | |||
53 | defaultContext :: Context | ||
54 | defaultContext = Context defaultSyntax Undefined | ||
55 | |||
56 | -- | Current position in the parser. | ||
57 | -- | ||
58 | -- For now it only stores the current position in a message, a segment group, | ||
59 | -- a segment, or a composite. | ||
60 | -- | ||
61 | -- Future version could store the whole path to improve debugging. | ||
62 | data CurrentPosition = Undefined | ||
63 | | Defined Position | ||
64 | deriving Show | ||
65 | |||
66 | getSyntax :: Parser Syntax | ||
67 | getSyntax = parsingSyntax <$> getState | ||
68 | |||
69 | -- | Get current charactor for decimal sign. | ||
70 | -- It doesn't parse nor consume input. | ||
71 | getDecimalSign :: Parser Char | ||
72 | getDecimalSign = decimalSign <$> getSyntax | ||
73 | |||
74 | -- | Get current charactor for segment separator. | ||
75 | -- It doesn't parse nor consume input. | ||
76 | getSegmentSeparator :: Parser Char | ||
77 | getSegmentSeparator = segmentSeparator <$> getSyntax | ||
78 | |||
79 | -- | Get current charactor for element separator. | ||
80 | -- It doesn't parse nor consume input. | ||
81 | getElementSeparator :: Parser Char | ||
82 | getElementSeparator = elementSeparator <$> getSyntax | ||
83 | |||
84 | -- | Get current charactor for composite separator. | ||
85 | -- It doesn't parse nor consume input. | ||
86 | getCompositeSeparator :: Parser Char | ||
87 | getCompositeSeparator = compositeSeparator <$> getSyntax | ||
88 | |||
89 | -- | This let change the operators used in the parsing. This is designed for the @UNA@ segment. | ||
90 | updateSyntax :: Syntax -> Parser () | ||
91 | updateSyntax s = updateState (\ c -> c { parsingSyntax = s }) | ||
92 | |||
93 | -- | Read the parser state to extract current position. | ||
94 | -- It doesn't parse nor consume input. | ||
95 | getCurrentPosition :: Parser CurrentPosition | ||
96 | getCurrentPosition = currentPosition <$> getState | ||
97 | |||
98 | -- | Write the parser state to update current position. | ||
99 | -- It doesn't parse nor consume input. | ||
100 | setCurrentPosition :: Position -> Parser () | ||
101 | setCurrentPosition = updateCurrentPosition . Defined | ||
102 | |||
103 | -- | Write the parser state to reset current position. | ||
104 | -- It doesn't parse nor consume input. | ||
105 | resetCurrentPosition :: Parser () | ||
106 | resetCurrentPosition = updateCurrentPosition Undefined | ||
107 | |||
108 | updateCurrentPosition :: CurrentPosition -> Parser () | ||
109 | updateCurrentPosition pos = modifyState (\s -> s { currentPosition = pos }) | ||
110 | |||
111 | -- | Parse current charactor for element separator. | ||
112 | -- It does parse and consume input. | ||
113 | parseElementSeparator :: Parser Char | ||
114 | parseElementSeparator = parseSpecialChar "element separator" elementSeparator | ||
115 | |||
116 | -- | Parse current charactor for composite separator. | ||
117 | -- It does parse and consume input. | ||
118 | parseCompositeSeparator :: Parser Char | ||
119 | parseCompositeSeparator = parseSpecialChar "composite separator" compositeSeparator | ||
120 | |||
121 | -- | Parse current charactor for escape separator. | ||
122 | -- It does parse and consume input. | ||
123 | parseEscape :: Parser Char | ||
124 | parseEscape = parseSpecialChar "escape character" escape | ||
125 | |||
126 | -- | Parse current charactor for segment separator. | ||
127 | -- It does parse and consume input. | ||
128 | -- | ||
129 | -- It also tries consuming end of line after segment separator if any. | ||
130 | parseSegmentSeparator :: Parser Char | ||
131 | parseSegmentSeparator = tries [ parseSpecialChar "segment separator" segmentSeparator <* endOfLine | ||
132 | , parseSpecialChar "segment separator" segmentSeparator | ||
133 | ] | ||
134 | |||
135 | parseSpecialChar :: String -> (Syntax -> Char) -> Parser Char | ||
136 | parseSpecialChar description reader = do | ||
137 | c <- reader <$> getSyntax | ||
138 | let escape' '\"' = "\\\"" | ||
139 | escape' c' = [c'] | ||
140 | comment = description <> " (\"" <> escape' c <> "\")" | ||
141 | char c <?> comment | ||
142 | |||
143 | -- | Let you try various parsers, not consuming until success. | ||
144 | tries :: [Parser a] -> Parser a | ||
145 | tries = choice . map try | ||
146 | |||
147 | -- | Like 'fail', this operator let you annotate a parser if it were to fail. | ||
148 | -- The difference with the standard "Text.Parsec" operator is that it appends | ||
149 | -- the current position if any. | ||
150 | failWithPosition :: String -> Parser a | ||
151 | failWithPosition = withPosition fail | ||
152 | |||
153 | -- | Like '<?>', this operator let you annotate a parser if it were to fail. | ||
154 | -- The difference with the standard "Text.Parsec" operator is that it appends | ||
155 | -- the current position if any. | ||
156 | (<??>) :: Parser a -> String -> Parser a | ||
157 | (<??>) = withPosition . (<?>) | ||
158 | |||
159 | -- Same priority as <?> from Text.Parsec | ||
160 | infix 0 <??> | ||
161 | |||
162 | withPosition :: (String -> Parser a) -> String -> Parser a | ||
163 | withPosition continuation msg = | ||
164 | let mkMessage Undefined = msg | ||
165 | mkMessage (Defined d) = msg <> " at position " <> show d | ||
166 | getMessage = mkMessage <$> getCurrentPosition | ||
167 | in getMessage >>= continuation | ||
168 | |||
169 | -- | Alias to 'failWithPosition' to convey semantics of work-in-progress when | ||
170 | -- writing a parser. This might be useful if you want to partially support a | ||
171 | -- message. | ||
172 | notYetImplemented :: String -> Parser a | ||
173 | notYetImplemented = failWithPosition | ||
diff --git a/core/src/Text/Edifact/Parsing/Primitives.hs b/core/src/Text/Edifact/Parsing/Primitives.hs new file mode 100644 index 0000000..61659c8 --- /dev/null +++ b/core/src/Text/Edifact/Parsing/Primitives.hs | |||
@@ -0,0 +1,127 @@ | |||
1 | {-| | ||
2 | Module : Text.Edifact.Parsing.Primitives | ||
3 | Description : Low level combinators | ||
4 | |||
5 | This module let you build parsers for primitive values, ie. values contained | ||
6 | in a simple element, either text or number. | ||
7 | |||
8 | = Examples | ||
9 | |||
10 | To parse a text of 3 characters (@an3@ in standard Edifact representation): | ||
11 | |||
12 | > an3 :: Parser Primitive | ||
13 | > an3 = alphaNumeric `exactly` 3 | ||
14 | |||
15 | To parse a text of up to 10 characters (@an..10@ in standard Edifact representation): | ||
16 | |||
17 | > an_10 :: Parser Primitive | ||
18 | > an_10 = alphaNumeric `upTo` 10 | ||
19 | |||
20 | = Known limitations | ||
21 | |||
22 | Numeric representation is not strictly compatible to the specification. | ||
23 | The specification tells that negative sign (@-@) and decimal sign (@.@) are not | ||
24 | to be counted in the length of the field. | ||
25 | |||
26 | Therefore the following parser will fail even it's legal according to the | ||
27 | specification: | ||
28 | |||
29 | > n_3 :: Parser Primitive | ||
30 | > n_3 = numeric `upTo` 3 | ||
31 | > | ||
32 | > parse n_3 "-12.3" | ||
33 | |||
34 | To be fixed, we have to change the way primitives combinators are built so that | ||
35 | the 'upTo' and 'exactly' combinators are aware of the inner parser. | ||
36 | -} | ||
37 | module Text.Edifact.Parsing.Primitives | ||
38 | ( | ||
39 | -- * Primitives | ||
40 | -- ** Simple elements definition | ||
41 | alphaNumeric | ||
42 | , alpha | ||
43 | , numeric | ||
44 | |||
45 | -- ** Cardinality | ||
46 | , exactly | ||
47 | , upTo | ||
48 | , many | ||
49 | |||
50 | ) where | ||
51 | |||
52 | import Text.Edifact.Parsing.Commons | ||
53 | import Text.Edifact.Types | ||
54 | |||
55 | import Data.String (fromString) | ||
56 | import qualified Data.Text as T (length) | ||
57 | import Text.Parsec (count, lookAhead, many1, noneOf, | ||
58 | oneOf) | ||
59 | import qualified Text.Parsec as P (many) | ||
60 | |||
61 | -- | Parser associated with the @an@ notation. | ||
62 | alphaNumeric :: Parser Char | ||
63 | alphaNumeric = do | ||
64 | separators <- sequence [ getSegmentSeparator | ||
65 | , getElementSeparator | ||
66 | , getCompositeSeparator | ||
67 | ] | ||
68 | tries [ parseEscape *> parseSegmentSeparator | ||
69 | , parseEscape *> parseElementSeparator | ||
70 | , parseEscape *> parseCompositeSeparator | ||
71 | , parseEscape *> parseEscape | ||
72 | , noneOf separators | ||
73 | ] | ||
74 | |||
75 | -- | Parser associated with the @a@ notation. | ||
76 | -- | ||
77 | -- So far it's simply an alias to 'alphaNumeric'. | ||
78 | alpha :: Parser Char | ||
79 | alpha = alphaNumeric | ||
80 | |||
81 | -- | Parser associated with the @n@ notation. | ||
82 | numeric :: Parser Char | ||
83 | numeric = do | ||
84 | punctuationSign <- getDecimalSign | ||
85 | oneOf (punctuationSign : "0123456789-") | ||
86 | |||
87 | -- | Combinator to build a parser of primitive which length is unspecified. | ||
88 | -- | ||
89 | -- Correspondance with the Edifact notation: | ||
90 | -- | ||
91 | -- > many alpha # same as a | ||
92 | -- > many numeric # same as n | ||
93 | -- > many alphaNumeric # same as an | ||
94 | many :: Parser Char -> Parser Primitive | ||
95 | many = fmap fromString . many1 | ||
96 | |||
97 | -- | Combinator to build a parser of primitive which length is capped. | ||
98 | -- | ||
99 | -- Correspondance with the Edifact notation: | ||
100 | -- | ||
101 | -- > alpha `upTo` 3 # same as a..3 | ||
102 | -- > numeric `upTo` 3 # same as n..3 | ||
103 | -- > alphaNumeric `upTo` 3 # same as an..3 | ||
104 | upTo :: Parser Char -> Int -> Parser Primitive | ||
105 | upTo p c = | ||
106 | let check t = | ||
107 | let c' = T.length t | ||
108 | in if c' > c | ||
109 | then failWithPosition ("expected up to " <> show c <> " characters, but encountered " <> show c') | ||
110 | else pure (String t) | ||
111 | maybeEmpty = (<$) mempty . lookAhead | ||
112 | in check =<< | ||
113 | tries [ maybeEmpty parseSegmentSeparator | ||
114 | , maybeEmpty parseElementSeparator | ||
115 | , maybeEmpty parseCompositeSeparator | ||
116 | , fromString <$> P.many p | ||
117 | ] | ||
118 | |||
119 | -- | Combinator to build a parser of primitive which length is fixed. | ||
120 | -- | ||
121 | -- Correspondance with the Edifact notation: | ||
122 | -- | ||
123 | -- > alpha `exactly` 3 # same as a3 | ||
124 | -- > numeric `exactly` 3 # same as n3 | ||
125 | -- > alphaNumeric `exactly` 3 # same as an3 | ||
126 | exactly :: Parser Char -> Int -> Parser Primitive | ||
127 | exactly p c = fromString <$> count c p | ||
diff --git a/core/src/Text/Edifact/Types.hs b/core/src/Text/Edifact/Types.hs new file mode 100644 index 0000000..d0bbe0d --- /dev/null +++ b/core/src/Text/Edifact/Types.hs | |||
@@ -0,0 +1,124 @@ | |||
1 | {-# LANGUAGE DerivingStrategies #-} | ||
2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
3 | |||
4 | {-| | ||
5 | Data types to represent Edifact values. | ||
6 | |||
7 | See "Text.Edifact.Parsing" to learn how to build parsers and use such parsers. | ||
8 | -} | ||
9 | module Text.Edifact.Types | ||
10 | ( -- * Values | ||
11 | Value(..) | ||
12 | , Primitive(..) | ||
13 | , Position(..) | ||
14 | -- ** Element codes | ||
15 | , MessageCode(..) | ||
16 | , GroupCode(..) | ||
17 | , SegmentCode(..) | ||
18 | , CompositeCode(..) | ||
19 | , SimpleCode(..) | ||
20 | -- * Syntax | ||
21 | , Syntax(..) | ||
22 | , defaultSyntax | ||
23 | ) where | ||
24 | |||
25 | import Data.Scientific (Scientific) | ||
26 | import Data.String (IsString (..)) | ||
27 | import Data.Text (Text) | ||
28 | |||
29 | -- | Code for a message. | ||
30 | -- | ||
31 | -- Content is expected to match this regexp: @[A-Z]{6}@. | ||
32 | newtype MessageCode = MessageCode { getMessageCode :: String } deriving newtype (Eq, Show, IsString) | ||
33 | |||
34 | -- | Code for a segment group. | ||
35 | -- | ||
36 | -- It's a code local to the message definition. | ||
37 | newtype GroupCode = GroupCode { getGroupCode :: String } deriving newtype (Eq, Show, IsString) | ||
38 | |||
39 | -- | Code for a segment. | ||
40 | -- | ||
41 | -- Content is expected to match this regexp: @[A-Z]{3}@. | ||
42 | -- | ||
43 | -- Standard segment codes are expected to match this regexp: @UN[A-Z]@. | ||
44 | newtype SegmentCode = SegmentCode { getSegmentCode :: String } deriving newtype (Eq, Show, IsString) | ||
45 | |||
46 | -- | Code for a composite element. | ||
47 | -- | ||
48 | -- Content is expected to match this regexp: @C[0-9]{3}@. | ||
49 | -- | ||
50 | -- It can also be used for standalone composites, frequently in standard segment | ||
51 | -- definitions. In this case the codes are expected to match this regexp: @S[0-9]{3}@. | ||
52 | newtype CompositeCode = CompositeCode String deriving newtype (Eq, Show, IsString) | ||
53 | |||
54 | -- | Code for a simple element. | ||
55 | -- | ||
56 | -- Content is expected to match this regexp: @[0-9]{4}@. | ||
57 | newtype SimpleCode = SimpleCode String deriving newtype (Eq, Show, IsString) | ||
58 | |||
59 | -- | Annotation of the position of the value relative to the parent value. | ||
60 | -- | ||
61 | -- Content is expected to match this regexp: @[0-9]{3,4}@. | ||
62 | -- | ||
63 | -- Example values: | ||
64 | -- | ||
65 | -- > "010" :: Position | ||
66 | -- > "0210" :: Position | ||
67 | -- | ||
68 | -- See 'Text.Edifact.Parsing.position' for how to parse one. | ||
69 | newtype Position = Position { getPosition :: String } deriving newtype (Eq, Show, IsString) | ||
70 | |||
71 | -- | Representation of a simple component. | ||
72 | -- | ||
73 | -- When defined by the 'Text.Edifact.Parsing.numeric' combinator, the simple | ||
74 | -- component will produce a 'Number'. | ||
75 | -- | ||
76 | -- When parsed by the 'Text.Edifact.Parsing.alphaNumeric' or | ||
77 | -- 'Text.Edifact.Parsing.alpha' combinators, the simple component will produce a | ||
78 | -- 'Text.Edifact.Types.String' from the raw textual representation. | ||
79 | data Primitive = String Text -- ^ Default representation of a simple component. | ||
80 | | Number Scientific -- ^ Representation of a numerical simple component. | ||
81 | deriving stock (Eq, Show) | ||
82 | |||
83 | -- | String like primitive values can be constructed via overloaded strings. | ||
84 | -- This is convenient, but might be removed. | ||
85 | instance IsString Primitive where | ||
86 | fromString = String . fromString | ||
87 | |||
88 | -- | Recursive data structure to represent parsed Edifact values. | ||
89 | data Value = Message MessageCode [(Position, [Value])] | ||
90 | | Group GroupCode [(Position, [Value])] | ||
91 | | Segment SegmentCode [(Position, Maybe Value)] | ||
92 | | Composite CompositeCode [(Position, Maybe Value)] | ||
93 | | Simple SimpleCode Primitive | ||
94 | deriving stock (Show, Eq) | ||
95 | |||
96 | -- | Defines the special charactors the parser should respect. | ||
97 | -- | ||
98 | -- This is defined in every payload via the @UNA@ segment (first segment expected). | ||
99 | data Syntax = Syntax { compositeSeparator :: Char | ||
100 | , elementSeparator :: Char | ||
101 | , decimalSign :: Char | ||
102 | , escape :: Char | ||
103 | , segmentSeparator :: Char | ||
104 | } | ||
105 | |||
106 | -- | Default value to initialize the parser. | ||
107 | -- | ||
108 | -- > Syntax { compositeSeparator = ':' | ||
109 | -- > , elementSeparator = '+' | ||
110 | -- > , decimalSign = '.' | ||
111 | -- > , escape = '?' | ||
112 | -- > , segmentSeparator = '\'' | ||
113 | -- > } | ||
114 | -- | ||
115 | -- Those default charactors should be considered as recommended values rather | ||
116 | -- than official default values. | ||
117 | defaultSyntax :: Syntax | ||
118 | defaultSyntax = | ||
119 | Syntax { compositeSeparator = ':' | ||
120 | , elementSeparator = '+' | ||
121 | , decimalSign = '.' | ||
122 | , escape = '?' | ||
123 | , segmentSeparator = '\'' | ||
124 | } | ||
diff --git a/core/test/Parsing/CombinatorsTest.hs b/core/test/Parsing/CombinatorsTest.hs new file mode 100644 index 0000000..03e6642 --- /dev/null +++ b/core/test/Parsing/CombinatorsTest.hs | |||
@@ -0,0 +1,288 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | ||
2 | |||
3 | module Parsing.CombinatorsTest | ||
4 | ( suite | ||
5 | ) where | ||
6 | |||
7 | import Text.Edifact.Parsing | ||
8 | import Text.Edifact.Types | ||
9 | |||
10 | import Data.Text (Text, unpack) | ||
11 | import Text.Parsec (eof) | ||
12 | |||
13 | import Test.Framework | ||
14 | import Test.Framework.Providers.HUnit (testCase) | ||
15 | import Test.HUnit ((@?=)) | ||
16 | |||
17 | suite :: Test | ||
18 | suite = | ||
19 | testGroup "Combinators" | ||
20 | [ testMessage | ||
21 | , testSegmentGroup | ||
22 | , testSegment | ||
23 | , testComposite | ||
24 | ] | ||
25 | |||
26 | testMessage :: Test | ||
27 | testMessage = | ||
28 | testGroup "Message" | ||
29 | [ testGroup "repeated" | ||
30 | [ expectSuccess messageABCDEF "TAG'" $ | ||
31 | Message "ABCDEF" [ "0010" .= Group "sg1" [ "010" .= Segment "TAG" [] | ||
32 | , ("020", []) | ||
33 | ] | ||
34 | ] | ||
35 | , expectSuccess messageABCDEF "TAG'TAG'" $ | ||
36 | Message "ABCDEF" [ "0010" .= Group "sg1" [ ("010", [ Segment "TAG" [] | ||
37 | , Segment "TAG" [] | ||
38 | ]) | ||
39 | , ("020", []) | ||
40 | ] | ||
41 | ] | ||
42 | , expectFailure messageABCDEF "TAG'TAG'TAG'" | ||
43 | , expectSuccess messageABCDEF "TAG'ANN'" $ | ||
44 | Message "ABCDEF" [ "0010" .= Group "sg1" [ "010" .= Segment "TAG" [] | ||
45 | , "020" .= Segment "ANN" [] | ||
46 | ] | ||
47 | ] | ||
48 | , expectSuccess messageABCDEF "ANN'" $ | ||
49 | Message "ABCDEF" [ "0010" .= Group "sg1" [ ("010", []) | ||
50 | , "020" .= Segment "ANN" [] | ||
51 | ] | ||
52 | ] | ||
53 | ] | ||
54 | , testGroup "mandatory repeated" | ||
55 | [ expectSuccess messageGHIJKL "TAG'" $ | ||
56 | Message "GHIJKL" [ "0010" .= Group "sg2" [ "010" .= Segment "TAG" [] | ||
57 | , ("020", []) | ||
58 | ] | ||
59 | ] | ||
60 | , expectSuccess messageGHIJKL "TAG'TAG'" $ | ||
61 | Message "GHIJKL" [ "0010" .= Group "sg2" [ ("010", [ Segment "TAG" [] | ||
62 | , Segment "TAG" [] | ||
63 | ]) | ||
64 | , ("020", []) | ||
65 | ] | ||
66 | ] | ||
67 | , expectFailure messageGHIJKL "TAG'TAG'TAG'" | ||
68 | , expectSuccess messageGHIJKL "TAG'ANN'" $ | ||
69 | Message "GHIJKL" [ "0010" .= Group "sg2" [ "010" .= Segment "TAG" [] | ||
70 | , "020" .= Segment "ANN" [] | ||
71 | ] | ||
72 | ] | ||
73 | , expectFailure messageGHIJKL "ANN'" | ||
74 | ] | ||
75 | ] | ||
76 | |||
77 | messageABCDEF :: Parser Value | ||
78 | messageABCDEF = message "ABCDEF" [ once sg1 @. "0010" | ||
79 | ] | ||
80 | |||
81 | messageGHIJKL :: Parser Value | ||
82 | messageGHIJKL = message "GHIJKL" [ once sg2 @. "0010" | ||
83 | ] | ||
84 | |||
85 | testSegmentGroup :: Test | ||
86 | testSegmentGroup = | ||
87 | testGroup "Segment Group" | ||
88 | [ testGroup "repeated" | ||
89 | [ expectSuccess sg1 "TAG'" $ | ||
90 | Group "sg1" [ "010" .= Segment "TAG" [] | ||
91 | , ("020", []) | ||
92 | ] | ||
93 | , expectSuccess sg1 "TAG'TAG'" $ | ||
94 | Group "sg1" [ ("010", [ Segment "TAG" [] | ||
95 | , Segment "TAG" [] | ||
96 | ]) | ||
97 | , ("020", []) | ||
98 | ] | ||
99 | , expectFailure sg1 "TAG'TAG'TAG'" | ||
100 | , expectSuccess sg1 "TAG'ANN'" $ | ||
101 | Group "sg1" [ "010" .= Segment "TAG" [] | ||
102 | , "020" .= Segment "ANN" [] | ||
103 | ] | ||
104 | , expectSuccess sg1 "ANN'" $ | ||
105 | Group "sg1" [ ("010", []) | ||
106 | , "020" .= Segment "ANN" [] | ||
107 | ] | ||
108 | ] | ||
109 | , testGroup "mandatory repeated" | ||
110 | [ expectSuccess sg2 "TAG'" $ | ||
111 | Group "sg2" [ "010" .= Segment "TAG" [] | ||
112 | , ("020", []) | ||
113 | ] | ||
114 | , expectSuccess sg2 "TAG'TAG'" $ | ||
115 | Group "sg2" [ ("010", [ Segment "TAG" [] | ||
116 | , Segment "TAG" [] | ||
117 | ]) | ||
118 | , ("020", []) | ||
119 | ] | ||
120 | , expectFailure sg2 "TAG'TAG'TAG'" | ||
121 | , expectSuccess sg2 "TAG'ANN'" $ | ||
122 | Group "sg2" [ "010" .= Segment "TAG" [] | ||
123 | , "020" .= Segment "ANN" [] | ||
124 | ] | ||
125 | , expectFailure sg2 "ANN'" | ||
126 | ] | ||
127 | ] | ||
128 | |||
129 | sg1 :: Parser Value | ||
130 | sg1 = segmentGroup "sg1" [ repeated 2 segmentTAG @. "010" | ||
131 | , repeated 9 segmentANN @. "020" | ||
132 | ] | ||
133 | |||
134 | sg2 :: Parser Value | ||
135 | sg2 = segmentGroup "sg2" [ repeatedAtLeastOnce 2 segmentTAG @. "010" | ||
136 | , repeated 9 segmentANN @. "020" | ||
137 | ] | ||
138 | |||
139 | segmentTAG :: Parser Value | ||
140 | segmentTAG = | ||
141 | segment "TAG" [ optional s01 @. "010" | ||
142 | , optional s02 @. "020" | ||
143 | , optional s03 @. "030" | ||
144 | , optional c01 @. "040" | ||
145 | ] | ||
146 | |||
147 | segmentANN :: Parser Value | ||
148 | segmentANN = | ||
149 | segment "ANN" [ optional s01 @. "010" | ||
150 | ] | ||
151 | |||
152 | s01 :: Parser Value | ||
153 | s01 = simple "S01" an2 | ||
154 | |||
155 | s02 :: Parser Value | ||
156 | s02 = simple "S02" an2 | ||
157 | |||
158 | s03 :: Parser Value | ||
159 | s03 = simple "S03" an2 | ||
160 | |||
161 | s04 :: Parser Value | ||
162 | s04 = simple "S04" an2 | ||
163 | |||
164 | s05 :: Parser Value | ||
165 | s05 = simple "S05" an2 | ||
166 | |||
167 | s06 :: Parser Value | ||
168 | s06 = simple "S06" an2 | ||
169 | |||
170 | c01 :: Parser Value | ||
171 | c01 = composite "C01" [ mandatory s04 @. "010" | ||
172 | , mandatory s05 @. "020" | ||
173 | , mandatory s06 @. "030" | ||
174 | ] | ||
175 | |||
176 | testSegment :: Test | ||
177 | testSegment = | ||
178 | let parser = segment "TAG" [ optional s01 @. "010" | ||
179 | , optional s02 @. "020" | ||
180 | , optional s03 @. "030" | ||
181 | , optional c01 @. "040" | ||
182 | ] | ||
183 | parser2 = segment "TAG" [ mandatory s01 @. "010" | ||
184 | , optional s02 @. "020" | ||
185 | , optional s03 @. "030" | ||
186 | ] | ||
187 | in testGroup "Segment" | ||
188 | [ expectSuccess parser "TAG'" $ | ||
189 | Segment "TAG" [] | ||
190 | , expectSuccess parser "TAG+DE+DE+DE+CE:CE:CE'" $ | ||
191 | Segment "TAG" [ "010" .= Simple "S01" "DE" | ||
192 | , "020" .= Simple "S02" "DE" | ||
193 | , "030" .= Simple "S03" "DE" | ||
194 | , "040" .= Composite "C01" [ "010" .= Simple "S04" "CE" | ||
195 | , "020" .= Simple "S05" "CE" | ||
196 | , "030" .= Simple "S06" "CE" | ||
197 | ] | ||
198 | ] | ||
199 | , expectFailure parser "TAG+DE+DE+CE:CE:CE'" | ||
200 | , expectSuccess parser "TAG+DE++DE+CE:CE:CE'" $ | ||
201 | Segment "TAG" [ "010" .= Simple "S01" "DE" | ||
202 | , ("020", Nothing) | ||
203 | , "030" .= Simple "S03" "DE" | ||
204 | , "040" .= Composite "C01" [ "010" .= Simple "S04" "CE" | ||
205 | , "020" .= Simple "S05" "CE" | ||
206 | , "030" .= Simple "S06" "CE" | ||
207 | ] | ||
208 | ] | ||
209 | , expectSuccess parser2 "TAG+DE+DE'" $ | ||
210 | Segment "TAG" [ "010" .= Simple "S01" "DE" | ||
211 | , "020" .= Simple "S02" "DE" | ||
212 | ] | ||
213 | , expectSuccess parser2 "TAG+DE'" $ | ||
214 | Segment "TAG" [ "010" .= Simple "S01" "DE" | ||
215 | ] | ||
216 | , expectSuccess parser2 "TAG+DE++DE'" $ | ||
217 | Segment "TAG" [ "010" .= Simple "S01" "DE" | ||
218 | , ("020", Nothing) | ||
219 | , "030" .= Simple "S03" "DE" | ||
220 | ] | ||
221 | ] | ||
222 | |||
223 | testComposite :: Test | ||
224 | testComposite = | ||
225 | let parser = compositeX001 | ||
226 | in testGroup "Composite" | ||
227 | [ expectSuccess parser "" $ | ||
228 | Composite "X001" [ "010" .= Simple "1001" "" | ||
229 | ] | ||
230 | , expectSuccess parser "ABC" $ | ||
231 | Composite "X001" [ "010" .= Simple "1001" "ABC" | ||
232 | ] | ||
233 | , expectSuccess parser ":DEF" $ | ||
234 | Composite "X001" [ "010" .= Simple "1001" "" | ||
235 | , "020" .= Simple "1001" "DEF" | ||
236 | ] | ||
237 | , expectSuccess parser "ABC:DEF" $ | ||
238 | Composite "X001" [ "010" .= Simple "1001" "ABC" | ||
239 | , "020" .= Simple "1001" "DEF" | ||
240 | ] | ||
241 | , expectSuccess parser "ABC:DEF:" $ | ||
242 | Composite "X001" [ "010" .= Simple "1001" "ABC" | ||
243 | , "020" .= Simple "1001" "DEF" | ||
244 | , "030" .= Simple "1001" "" | ||
245 | ] | ||
246 | , expectSuccess parser "ABC:DEF:GHI" $ | ||
247 | Composite "X001" [ "010" .= Simple "1001" "ABC" | ||
248 | , "020" .= Simple "1001" "DEF" | ||
249 | , "030" .= Simple "1001" "GHI" | ||
250 | ] | ||
251 | , expectSuccess parser "ABC::GHI" $ | ||
252 | Composite "X001" [ "010" .= Simple "1001" "ABC" | ||
253 | , "020" .= Simple "1001" "" | ||
254 | , "030" .= Simple "1001" "GHI" | ||
255 | ] | ||
256 | ] | ||
257 | |||
258 | compositeX001 :: Parser Value | ||
259 | compositeX001 = | ||
260 | composite "X001" | ||
261 | [ mandatory simple1001 @. "010" | ||
262 | , optional simple1001 @. "020" | ||
263 | , optional simple1001 @. "030" | ||
264 | ] | ||
265 | |||
266 | simple1001 :: Parser Value | ||
267 | simple1001 = simple "1001" an_35 | ||
268 | |||
269 | an2 :: Parser Primitive | ||
270 | an2 = alpha `exactly` 2 | ||
271 | |||
272 | an_35 :: Parser Primitive | ||
273 | an_35 = alphaNumeric `upTo` 35 | ||
274 | |||
275 | expectSuccess :: (Show a, Eq a) => Parser a -> Text -> a -> Test | ||
276 | expectSuccess p t = expectParse p t . pure | ||
277 | |||
278 | expectFailure :: (Show a, Eq a) => Parser a -> Text -> Test | ||
279 | expectFailure p t = expectParse p t Nothing | ||
280 | |||
281 | expectParse :: (Show a, Eq a) => Parser a -> Text -> Maybe a -> Test | ||
282 | expectParse p t e = | ||
283 | let either2Maybe = either (const Nothing) Just | ||
284 | title = "\"" <> unpack t <> "\"" | ||
285 | in testCase title (either2Maybe (parse (p <* eof) t) @?= e) | ||
286 | |||
287 | (.=) :: Applicative f => Position -> Value -> (Position, f Value) | ||
288 | pos .= value = (pos, pure value) | ||
diff --git a/core/test/Parsing/PrimitivesTest.hs b/core/test/Parsing/PrimitivesTest.hs new file mode 100644 index 0000000..95bc8c8 --- /dev/null +++ b/core/test/Parsing/PrimitivesTest.hs | |||
@@ -0,0 +1,105 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | ||
2 | |||
3 | module Parsing.PrimitivesTest | ||
4 | ( suite | ||
5 | ) where | ||
6 | |||
7 | import Text.Edifact.Parsing | ||
8 | |||
9 | import Data.Text (Text, unpack) | ||
10 | import Text.Parsec (eof) | ||
11 | |||
12 | import Test.Framework | ||
13 | import Test.Framework.Providers.HUnit (testCase) | ||
14 | import Test.HUnit ((@?=)) | ||
15 | |||
16 | suite :: Test | ||
17 | suite = | ||
18 | testGroup "Primitives" | ||
19 | [ test_an | ||
20 | , test_an_3 | ||
21 | , test_an3 | ||
22 | , test_n | ||
23 | ] | ||
24 | |||
25 | test_an :: Test | ||
26 | test_an = | ||
27 | let parser = alphaNumeric | ||
28 | in testGroup "an" | ||
29 | [ expectSuccess parser "A" 'A' | ||
30 | , expectSuccess parser "?:" ':' | ||
31 | , expectSuccess parser "?+" '+' | ||
32 | , expectSuccess parser "??" '?' | ||
33 | , expectSuccess parser "?'" '\'' | ||
34 | ] | ||
35 | |||
36 | test_an_3 :: Test | ||
37 | test_an_3 = | ||
38 | let parser = alphaNumeric `upTo` 3 | ||
39 | in testGroup "an..3" | ||
40 | [ testGroup "valid" | ||
41 | [ expectSuccess parser "" "" | ||
42 | , expectSuccess parser "A" "A" | ||
43 | , expectSuccess parser "AB" "AB" | ||
44 | , expectSuccess parser "ABC" "ABC" | ||
45 | , expectSuccess parser "AB??" "AB?" | ||
46 | ] | ||
47 | , testGroup "invalid" | ||
48 | [ expectFailure parser "ABCD" | ||
49 | ] | ||
50 | ] | ||
51 | |||
52 | test_an3 :: Test | ||
53 | test_an3 = | ||
54 | let parser = alphaNumeric `exactly` 3 | ||
55 | in testGroup "an3" | ||
56 | [ testGroup "valid" | ||
57 | [ expectSuccess parser "ABC" "ABC" | ||
58 | , expectSuccess parser "AB??" "AB?" | ||
59 | ] | ||
60 | , testGroup "invalid" | ||
61 | [ expectFailure parser "" | ||
62 | , expectFailure parser "A" | ||
63 | , expectFailure parser "AB" | ||
64 | , expectFailure parser "ABCD" | ||
65 | ] | ||
66 | ] | ||
67 | |||
68 | test_n :: Test | ||
69 | test_n = | ||
70 | let parser = numeric | ||
71 | in testGroup "n" | ||
72 | [ testGroup "valid" | ||
73 | [ expectSuccess parser "0" '0' | ||
74 | , expectSuccess parser "1" '1' | ||
75 | , expectSuccess parser "2" '2' | ||
76 | , expectSuccess parser "3" '3' | ||
77 | , expectSuccess parser "4" '4' | ||
78 | , expectSuccess parser "5" '5' | ||
79 | , expectSuccess parser "6" '6' | ||
80 | , expectSuccess parser "7" '7' | ||
81 | , expectSuccess parser "8" '8' | ||
82 | , expectSuccess parser "9" '9' | ||
83 | , expectSuccess parser "-" '-' | ||
84 | , expectSuccess parser "." '.' | ||
85 | ] | ||
86 | , testGroup "invalid" | ||
87 | [ expectFailure parser "A" | ||
88 | , expectFailure parser "?:" | ||
89 | , expectFailure parser "?+" | ||
90 | , expectFailure parser "??" | ||
91 | , expectFailure parser "?'" | ||
92 | ] | ||
93 | ] | ||
94 | |||
95 | expectSuccess :: (Show a, Eq a) => Parser a -> Text -> a -> Test | ||
96 | expectSuccess p t = expectParse p t . pure | ||
97 | |||
98 | expectFailure :: (Show a, Eq a) => Parser a -> Text -> Test | ||
99 | expectFailure p t = expectParse p t Nothing | ||
100 | |||
101 | expectParse :: (Show a, Eq a) => Parser a -> Text -> Maybe a -> Test | ||
102 | expectParse p t e = | ||
103 | let either2Maybe = either (const Nothing) Just | ||
104 | title = "\"" <> unpack t <> "\"" | ||
105 | in testCase title (either2Maybe (parse (p <* eof) t) @?= e) | ||
diff --git a/core/test/ParsingTest.hs b/core/test/ParsingTest.hs new file mode 100644 index 0000000..9608e00 --- /dev/null +++ b/core/test/ParsingTest.hs | |||
@@ -0,0 +1,17 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | ||
2 | |||
3 | module ParsingTest | ||
4 | ( suite | ||
5 | ) where | ||
6 | |||
7 | import qualified Parsing.CombinatorsTest as Combinators (suite) | ||
8 | import qualified Parsing.PrimitivesTest as Primitives (suite) | ||
9 | |||
10 | import Test.Framework | ||
11 | |||
12 | suite :: Test | ||
13 | suite = | ||
14 | testGroup "Parsing" | ||
15 | [ Combinators.suite | ||
16 | , Primitives.suite | ||
17 | ] | ||
diff --git a/core/test/Spec.hs b/core/test/Spec.hs new file mode 100644 index 0000000..efbffa0 --- /dev/null +++ b/core/test/Spec.hs | |||
@@ -0,0 +1,11 @@ | |||
1 | import qualified ParsingTest | ||
2 | |||
3 | import Test.Framework | ||
4 | |||
5 | main :: IO () | ||
6 | main = defaultMain [suite] | ||
7 | |||
8 | suite :: Test | ||
9 | suite = testGroup "Edifact" | ||
10 | [ ParsingTest.suite | ||
11 | ] | ||