aboutsummaryrefslogtreecommitdiffhomepage
path: root/scaffolder
diff options
context:
space:
mode:
Diffstat (limited to 'scaffolder')
-rw-r--r--scaffolder/.gitignore2
-rw-r--r--scaffolder/Makefile7
-rw-r--r--scaffolder/README.md50
-rw-r--r--scaffolder/app/Main.hs90
-rw-r--r--scaffolder/edi-parser-scaffolder.cabal110
-rw-r--r--scaffolder/package.yaml53
-rw-r--r--scaffolder/src/Text/Edifact/BundleReader.hs59
-rw-r--r--scaffolder/src/Text/Edifact/BundleReader/CodedSimples.hs38
-rw-r--r--scaffolder/src/Text/Edifact/BundleReader/Commons.hs90
-rw-r--r--scaffolder/src/Text/Edifact/BundleReader/Composites.hs43
-rw-r--r--scaffolder/src/Text/Edifact/BundleReader/Configuration.hs30
-rw-r--r--scaffolder/src/Text/Edifact/BundleReader/Extractor.hs75
-rw-r--r--scaffolder/src/Text/Edifact/BundleReader/Messages.hs61
-rw-r--r--scaffolder/src/Text/Edifact/BundleReader/Segments.hs55
-rw-r--r--scaffolder/src/Text/Edifact/BundleReader/Simples.hs43
-rw-r--r--scaffolder/src/Text/Edifact/Fetcher.hs44
-rw-r--r--scaffolder/src/Text/Edifact/Fetcher/Commons.hs87
-rw-r--r--scaffolder/src/Text/Edifact/Fetcher/Composites.hs31
-rw-r--r--scaffolder/src/Text/Edifact/Fetcher/Configuration.hs43
-rw-r--r--scaffolder/src/Text/Edifact/Fetcher/Messages.hs84
-rw-r--r--scaffolder/src/Text/Edifact/Fetcher/Segments.hs41
-rw-r--r--scaffolder/src/Text/Edifact/Fetcher/Simples.hs27
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder.hs20
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/CodedSimples/Specification.hs28
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Commons.hs29
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Commons/Formatters.hs88
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Commons/Language.hs286
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Commons/Logging.hs11
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Commons/Parsing.hs122
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Commons/Text.hs91
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Commons/Types.hs72
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Composites.hs53
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Composites/Dependencies.hs20
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Composites/Elements.hs20
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Composites/Implementation.hs19
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Composites/Specification.hs69
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Composites/Types.hs18
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Messages.hs54
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Messages/Dependencies.hs47
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Messages/Elements.hs22
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Messages/Implementation.hs114
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Messages/Specification.hs129
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Messages/Types.hs36
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Root.hs25
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Segments.hs54
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Segments/Dependencies.hs47
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Segments/Elements.hs26
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Segments/Implementation.hs21
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Segments/Specification.hs99
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Segments/Types.hs27
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Simples.hs41
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Simples/Elements.hs26
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Simples/Implementation.hs23
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Simples/Representation.hs47
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Simples/Specification.hs28
-rw-r--r--scaffolder/src/Text/Edifact/Scaffolder/Simples/Types.hs14
56 files changed, 2989 insertions, 0 deletions
diff --git a/scaffolder/.gitignore b/scaffolder/.gitignore
new file mode 100644
index 0000000..76467e6
--- /dev/null
+++ b/scaffolder/.gitignore
@@ -0,0 +1,2 @@
1.stack-work/
2*~
diff --git a/scaffolder/Makefile b/scaffolder/Makefile
new file mode 100644
index 0000000..c69097d
--- /dev/null
+++ b/scaffolder/Makefile
@@ -0,0 +1,7 @@
1lint:
2 hlint app/ src/
3
4help:
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/scaffolder/README.md b/scaffolder/README.md
new file mode 100644
index 0000000..477b3f6
--- /dev/null
+++ b/scaffolder/README.md
@@ -0,0 +1,50 @@
1# edi-parser-scaffolder
2
3Autonomous utility to generate parser for a given revision of the Edifact
4specification.
5
6## Usage
7
81. fetch specification for a given Edifact revision
92. scaffold the parsers for this specification
10
11### Read specification
12
13Read files downloaded from
14https://unece.org/trade/uncefact/unedifact/download
15
16You can specify individual files one by one:
17```
18$ stack exec edi-parser-scaffolder -- read-bundle --revision D96A --specification ./specification/references/ --message-file /path/to/D96A/DIRDEF_D.96A --segment-file /path/to/D96A/TRSD.96A --composite-file /path/to/D96A/TRCD.96A --simple-file /path/to/D96A/TRED.96A --simple-code-file /path/to/D96A/UNCL-1.96A --simple-code-file /path/to/D96A/UNCL-2.96A
19$ stack exec edi-parser-scaffolder -- read-bundle --revision D21B --specification ./specification/references/ --message-file /path/to/D21B/IFCSUM_D.21B --message-file /path/to/D21B/IFTSTA_D.21B --segment-file /path/to/D21B/EDSD.21B --segment-file /path/to/D21B/IDSD.21B --composite-file /path/to/D21B/EDCD.21B --composite-file /path/to/D21B/IDCD.21B --simple-file /path/to/D21B/EDED.21B --simple-code-file /path/to/D21B/UNCL.21B
20```
21
22Or give the whole zip file:
23```
24$ stack exec edi-parser-scaffolder -- read-bundle --revision D96A --message IFCSUM --message IFTSTA --message IFTSAI --message DESADV --specification ./specification/references/ --bundle /path/to/D96A/d96a.zip
25```
26
27### Fetch specification
28
29This function is deprecated and parsing may break at any time!
30Prefer the bundle reading above
31
32```
33$ stack exec edi-parser-scaffolder -- \
34 fetch --revision D96A --specification ./specification/references
35```
36
37If you're only interested in a subset of the specification, you can select the
38messages:
39
40```
41$ stack exec edi-parser-scaffolder -- \
42 fetch --revision D96A --specification ./specification/references/ --messages IFCSUM,IFTSAI,DESADV
43```
44
45### Scaffold the parsers
46
47```
48$ stack exec edi-parser-scaffolder -- \
49 scaffold --revision D96A --specification ./specification/references/ --src specification/src/
50```
diff --git a/scaffolder/app/Main.hs b/scaffolder/app/Main.hs
new file mode 100644
index 0000000..646756e
--- /dev/null
+++ b/scaffolder/app/Main.hs
@@ -0,0 +1,90 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Main where
4
5import Text.Edifact.BundleReader (BundleReaderEnv (..), readBundle)
6import Text.Edifact.Fetcher (FetchingEnv (..), fetch,
7 readSelectMessages)
8import Text.Edifact.Scaffolder (ScaffoldingEnv (..), scaffold)
9
10import Data.String (fromString)
11import Options.Applicative
12
13main :: IO ()
14main = execParser argumentsParser >>= run
15
16data Command = ScaffoldCommand ScaffoldingEnv
17 | FetchCommand FetchingEnv
18 | BundleReaderCommand BundleReaderEnv
19
20commandParser :: Parser Command
21commandParser =
22 let mkCommand cmd = command (commandName cmd) (info (commandArgumentsParser cmd) (describe cmd))
23 in subparser (foldMap mkCommand [ Scaffold, Fetch, ReadBundle ])
24
25data CommandType = Scaffold | Fetch | ReadBundle
26
27run :: Command -> IO ()
28run (ScaffoldCommand env) = scaffold env
29run (FetchCommand env) = fetch env
30run (BundleReaderCommand env) = readBundle env
31
32commandName :: CommandType -> String
33commandName Scaffold = "scaffold"
34commandName Fetch = "fetch"
35commandName ReadBundle = "read-bundle"
36
37commandArgumentsParser :: CommandType -> Parser Command
38commandArgumentsParser Scaffold =
39 let revisionArg = strOption (long "revision" <> metavar "REVISION")
40 moduleNameArg = strOption (long "module-name" <> metavar "MODULE_NAME" <> value "Text.Edifact")
41 specificationArg = strOption (long "specification" <> metavar "SPECIFICATION" <> value "./specification")
42 srcArg = strOption (long "src" <> metavar "SOURCES" <> value "./src")
43 debugParsingArg = flag False True (long "debug-parsing")
44 arguments = ScaffoldingEnv <$> revisionArg
45 <*> (fromString <$> moduleNameArg)
46 <*> specificationArg
47 <*> srcArg
48 <*> debugParsingArg
49 in ScaffoldCommand <$> arguments
50commandArgumentsParser Fetch =
51 let revisionArg = strOption (long "revision" <> metavar "REVISION")
52 specificationArg = strOption (long "specification" <> metavar "SPECIFICATION" <> value "./specification")
53 selectedMessagesArg = readSelectMessages <$>
54 optional (strOption (long "messages" <> metavar "MESSAGES"))
55 arguments = FetchingEnv <$> revisionArg
56 <*> specificationArg
57 <*> selectedMessagesArg
58 in FetchCommand <$> arguments
59commandArgumentsParser ReadBundle =
60 let revisionArg = strOption (long "revision" <> metavar "REVISION")
61 specificationArg = strOption (long "specification" <> metavar "SPECIFICATION" <> value "./specification")
62 bundle = many (strOption (long "bundle" <> metavar "BUNDLE"))
63 messagesFiles = many (strOption (long "message-file" <> metavar "MESSAGE_FILE"))
64 selectedMessages = many (strOption (long "message" <> metavar "MESSAGE"))
65 segmentsFiles = many (strOption (long "segment-file" <> metavar "SEGMENT_FILE"))
66 compositeFiles = many (strOption (long "composite-file" <> metavar "COMPOSITE_FILE"))
67 simpleFiles = many (strOption (long "simple-file" <> metavar "SIMPLE_FILE"))
68 codedSimpleFiles = many (strOption (long "coded-simple-file" <> metavar "CODED_SIMPLE_FILE"))
69 arguments = BundleReaderEnv <$> revisionArg
70 <*> specificationArg
71 <*> bundle
72 <*> selectedMessages
73 <*> messagesFiles
74 <*> segmentsFiles
75 <*> compositeFiles
76 <*> simpleFiles
77 <*> codedSimpleFiles
78 in BundleReaderCommand <$> arguments
79
80describe :: CommandType -> InfoMod a
81describe Scaffold = progDesc "Scaffold parsers from specification previously fetched"
82describe Fetch = progDesc "Fetch specification from UN website (Deprecated! Use read-bundle instead)"
83describe ReadBundle = progDesc "Read specification bundle downloaded from UN website"
84
85argumentsParser :: ParserInfo Command
86argumentsParser = info (commandParser <**> helper) cliDesc
87
88cliDesc :: InfoMod a
89cliDesc = fullDesc
90 <> header "Let you scaffold parsers from an Edifact specification"
diff --git a/scaffolder/edi-parser-scaffolder.cabal b/scaffolder/edi-parser-scaffolder.cabal
new file mode 100644
index 0000000..11d628e
--- /dev/null
+++ b/scaffolder/edi-parser-scaffolder.cabal
@@ -0,0 +1,110 @@
1cabal-version: 1.12
2
3-- This file has been generated from package.yaml by hpack version 0.33.0.
4--
5-- see: https://github.com/sol/hpack
6--
7-- hash: 3fe385f41f62ec5ef4db3f95458c629df273c5bf7976e206ce59839d95ba2738
8
9name: edi-parser-scaffolder
10version: 20190607
11description: Please see the README on GitHub at <https://github.com/githubuser/edi-parser-scaffolder#readme>
12homepage: https://github.com/fretlink/edi-parser#readme
13bug-reports: https://github.com/fretlink/edi-parser/issues
14author: FretLink
15maintainer: example@example.com
16copyright: 2019 FretLink
17build-type: Simple
18extra-source-files:
19 README.md
20
21source-repository head
22 type: git
23 location: https://github.com/fretlink/edi-parser
24
25library
26 exposed-modules:
27 Text.Edifact.BundleReader
28 Text.Edifact.BundleReader.CodedSimples
29 Text.Edifact.BundleReader.Commons
30 Text.Edifact.BundleReader.Composites
31 Text.Edifact.BundleReader.Configuration
32 Text.Edifact.BundleReader.Extractor
33 Text.Edifact.BundleReader.Messages
34 Text.Edifact.BundleReader.Segments
35 Text.Edifact.BundleReader.Simples
36 Text.Edifact.Fetcher
37 Text.Edifact.Fetcher.Commons
38 Text.Edifact.Fetcher.Composites
39 Text.Edifact.Fetcher.Configuration
40 Text.Edifact.Fetcher.Messages
41 Text.Edifact.Fetcher.Segments
42 Text.Edifact.Fetcher.Simples
43 Text.Edifact.Scaffolder
44 Text.Edifact.Scaffolder.CodedSimples.Specification
45 Text.Edifact.Scaffolder.Commons
46 Text.Edifact.Scaffolder.Commons.Formatters
47 Text.Edifact.Scaffolder.Commons.Language
48 Text.Edifact.Scaffolder.Commons.Logging
49 Text.Edifact.Scaffolder.Commons.Parsing
50 Text.Edifact.Scaffolder.Commons.Text
51 Text.Edifact.Scaffolder.Commons.Types
52 Text.Edifact.Scaffolder.Composites
53 Text.Edifact.Scaffolder.Composites.Dependencies
54 Text.Edifact.Scaffolder.Composites.Elements
55 Text.Edifact.Scaffolder.Composites.Implementation
56 Text.Edifact.Scaffolder.Composites.Specification
57 Text.Edifact.Scaffolder.Composites.Types
58 Text.Edifact.Scaffolder.Messages
59 Text.Edifact.Scaffolder.Messages.Dependencies
60 Text.Edifact.Scaffolder.Messages.Elements
61 Text.Edifact.Scaffolder.Messages.Implementation
62 Text.Edifact.Scaffolder.Messages.Specification
63 Text.Edifact.Scaffolder.Messages.Types
64 Text.Edifact.Scaffolder.Root
65 Text.Edifact.Scaffolder.Segments
66 Text.Edifact.Scaffolder.Segments.Dependencies
67 Text.Edifact.Scaffolder.Segments.Elements
68 Text.Edifact.Scaffolder.Segments.Implementation
69 Text.Edifact.Scaffolder.Segments.Specification
70 Text.Edifact.Scaffolder.Segments.Types
71 Text.Edifact.Scaffolder.Simples
72 Text.Edifact.Scaffolder.Simples.Elements
73 Text.Edifact.Scaffolder.Simples.Implementation
74 Text.Edifact.Scaffolder.Simples.Representation
75 Text.Edifact.Scaffolder.Simples.Specification
76 Text.Edifact.Scaffolder.Simples.Types
77 other-modules:
78 Paths_edi_parser_scaffolder
79 hs-source-dirs:
80 src
81 ghc-options: -Wall -Werror
82 build-depends:
83 base >=4.7 && <5
84 , bytestring
85 , directory
86 , filepath
87 , formatting
88 , mtl
89 , pandoc
90 , pandoc-types
91 , parsec
92 , process
93 , split
94 , text
95 , transformers
96 , zip-archive
97 default-language: Haskell2010
98
99executable edi-parser-scaffolder
100 main-is: Main.hs
101 other-modules:
102 Paths_edi_parser_scaffolder
103 hs-source-dirs:
104 app
105 ghc-options: -threaded -rtsopts -with-rtsopts=-N
106 build-depends:
107 base >=4.7 && <5
108 , edi-parser-scaffolder
109 , optparse-applicative
110 default-language: Haskell2010
diff --git a/scaffolder/package.yaml b/scaffolder/package.yaml
new file mode 100644
index 0000000..b99b04a
--- /dev/null
+++ b/scaffolder/package.yaml
@@ -0,0 +1,53 @@
1name: edi-parser-scaffolder
2version: 20190607
3github: fretlink/edi-parser
4author: FretLink
5maintainer: example@example.com
6copyright: 2019 FretLink
7
8extra-source-files:
9- README.md
10
11# Metadata used when publishing your package
12# synopsis: Short description of your package
13# category: Web
14
15# To avoid duplicated efforts in documentation and dealing with the
16# complications of embedding Haddock markup inside cabal files, it is
17# common to point users to the README.md file.
18description: Please see the README on GitHub at <https://github.com/githubuser/edi-parser-scaffolder#readme>
19
20dependencies:
21- base >= 4.7 && < 5
22
23library:
24 source-dirs: src
25 ghc-options:
26 - -Wall
27 - -Werror
28 dependencies:
29 - bytestring
30 - directory
31 - filepath
32 - formatting
33 - mtl
34 - pandoc
35 - pandoc-types
36 - parsec
37 - process
38 - split
39 - text
40 - transformers
41 - zip-archive
42
43executables:
44 edi-parser-scaffolder:
45 main: Main.hs
46 source-dirs: app
47 ghc-options:
48 - -threaded
49 - -rtsopts
50 - -with-rtsopts=-N
51 dependencies:
52 - edi-parser-scaffolder
53 - optparse-applicative
diff --git a/scaffolder/src/Text/Edifact/BundleReader.hs b/scaffolder/src/Text/Edifact/BundleReader.hs
new file mode 100644
index 0000000..7a15199
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/BundleReader.hs
@@ -0,0 +1,59 @@
1module Text.Edifact.BundleReader
2 ( readBundle
3 , BundleReaderEnv(..)
4 ) where
5
6import Text.Edifact.BundleReader.Commons (BundleReader,
7 getSpecificationHome,
8 runBundleReader)
9import Text.Edifact.BundleReader.Composites (compositesDirectory,
10 readComposites)
11import Text.Edifact.BundleReader.Configuration
12import Text.Edifact.BundleReader.Extractor (FileContents (..),
13 readZip)
14import Text.Edifact.BundleReader.Messages (messagesDirectory,
15 readMessages)
16import Text.Edifact.BundleReader.Segments (readSegments,
17 segmentsDirectory)
18import Text.Edifact.BundleReader.CodedSimples (readCodedSimples)
19import Text.Edifact.BundleReader.Simples (readSimples,
20 simplesDirectory)
21
22import Control.Monad.IO.Class (liftIO)
23import Control.Monad.Reader (asks)
24import Data.Foldable (traverse_)
25import System.Directory (createDirectoryIfMissing)
26import System.FilePath ((</>))
27
28readBundle :: BundleReaderEnv -> IO ()
29readBundle = runBundleReader (setupDirectories >> readAll)
30
31readAll :: BundleReader ()
32readAll = do
33 revision <- asks parserRevision
34 bundles <- mapM (liftIO . readZip revision) =<< asks bundle
35 messages' <- readMessages (concatMap messages bundles)
36 printContent messages' "Messages with segments codes:"
37 segments' <- readSegments (concatMap segments bundles) $ concatMap snd messages'
38 printContent segments' "Segments with composites/simples:"
39 simples' <- readSimples (concatMap simples bundles) =<< readComposites (concatMap composites bundles) segments'
40 readCodedSimples (concatMap codedSimples bundles) simples'
41 printContent simples' "Simples:"
42 pure ()
43
44printContent :: Show a => a -> String -> BundleReader ()
45printContent content header = liftIO $ putStrLn header >> print content >> putStrLn ""
46
47setupDirectories :: BundleReader ()
48setupDirectories = do
49 home <- getSpecificationHome
50 let mkdir d = liftIO (createDirectoryIfMissing True (home </> d))
51 traverse_ mkdir directories
52
53directories :: [FilePath]
54directories =
55 [ compositesDirectory
56 , messagesDirectory
57 , segmentsDirectory
58 , simplesDirectory
59 ]
diff --git a/scaffolder/src/Text/Edifact/BundleReader/CodedSimples.hs b/scaffolder/src/Text/Edifact/BundleReader/CodedSimples.hs
new file mode 100644
index 0000000..7dc92fd
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/BundleReader/CodedSimples.hs
@@ -0,0 +1,38 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Text.Edifact.BundleReader.CodedSimples
4 ( readCodedSimples
5 ) where
6
7import Text.Edifact.BundleReader.Commons
8import Text.Edifact.BundleReader.Configuration (BundleReaderEnv (..))
9import Text.Edifact.BundleReader.Simples (simplesDirectory)
10import Text.Edifact.Scaffolder.Commons
11
12import Text.Edifact.Scaffolder.CodedSimples.Specification
13
14import Control.Monad (when)
15import Control.Monad.Reader (asks)
16import Data.ByteString as BS (ByteString,
17 readFile)
18import Formatting
19
20readCodedSimples :: [ByteString] -> [SimpleCode] -> BundleReader ()
21readCodedSimples contents simples = do
22 let parsedFile path = parseFile simples =<< liftIO (BS.readFile path)
23 parsedString = parseFile simples
24 files <- asks codedSimplesFiles
25 mapM_ parsedFile files
26 mapM_ parsedString contents
27
28parseFile :: [SimpleCode] -> ByteString -> BundleReader [SimpleCode]
29parseFile simples content =
30 let chunks = tail $ splitFileByDash 70 $ decodeContent content
31 in traverse (parseChunk simples) chunks
32
33parseChunk :: [SimpleCode] -> Text -> BundleReader SimpleCode
34parseChunk simples chunk = do
35 parsed <- parseOrFail chunk specificationParser
36 outputFile <- getOutputFile (fSimpleCodeLower % ".txt") simplesDirectory (fst parsed)
37 when (fst parsed `elem` simples) $ toFile chunk outputFile
38 pure $ fst parsed
diff --git a/scaffolder/src/Text/Edifact/BundleReader/Commons.hs b/scaffolder/src/Text/Edifact/BundleReader/Commons.hs
new file mode 100644
index 0000000..0c8334a
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/BundleReader/Commons.hs
@@ -0,0 +1,90 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Text.Edifact.BundleReader.Commons where
4
5import Text.Edifact.BundleReader.Configuration
6import Text.Edifact.Scaffolder.Commons
7
8import Control.Monad.Reader (ReaderT, runReaderT)
9import Data.ByteString (ByteString)
10import Data.Char (toLower)
11import Data.List.Split (splitWhen)
12import Data.Text as T (isInfixOf, lines,
13 map, null,
14 replicate, strip,
15 unlines, unpack)
16import Data.Text.Encoding as TE (decodeLatin1,
17 decodeUtf8')
18import Data.Text.IO as TIO (writeFile)
19import Formatting
20import Text.Parsec (Parsec, runParser)
21
22type BundleReader = ReaderT BundleReaderEnv IO
23
24decodeContent :: ByteString -> Text
25decodeContent content = either (const $ cleanupAsciiArt $ decodeLatin1 content) id (decodeUtf8' content)
26
27splitFileByDash :: Int -> Text -> [Text]
28splitFileByDash n =
29 let separator = T.replicate n "-"
30 isNotEmpty = not . T.null . T.strip
31 in
32 filter isNotEmpty . fmap T.unlines . splitWhen (separator `T.isInfixOf`) . T.lines
33
34runBundleReader :: BundleReader () -> BundleReaderEnv -> IO ()
35runBundleReader = runReaderT
36
37getOutputFile :: Format String (a -> String) -> FilePath -> a -> BundleReader FilePath
38getOutputFile f d c = do
39 home <- getSpecificationHome
40 pure (formatToString (string % "/" % string % "/" % f) home d c)
41
42getSpecificationHome :: BundleReader FilePath
43getSpecificationHome = do
44 home <- getHome
45 rev <- getTargetRevision
46 pure (home </> formatToString fRevision rev)
47
48toFile :: Text -> FilePath -> BundleReader ()
49toFile specification outputFile = liftIO (TIO.writeFile outputFile specification)
50
51parseOrFail :: (Monoid u) => Text -> Parsec String u a -> BundleReader a
52parseOrFail specification parser = either (error . (\a -> show specification <> show a)) pure (runParser parser mempty "" (T.unpack specification))
53
54toFileWithParser :: (Monoid a, Monoid u) => Text -> FilePath -> Parsec String u a -> BundleReader a
55toFileWithParser specification outputFile parser = do
56 liftIO (TIO.writeFile outputFile specification)
57 either (error . show) pure (runParser parser mempty "" (T.unpack specification))
58
59lower :: Format r (String -> r)
60lower = mapf (fmap toLower) string
61
62fRevision :: Format r (Revision -> r)
63fRevision = mapf getRevision string
64
65fRevisionLower :: Format r (Revision -> r)
66fRevisionLower = mapf getRevision lower
67
68fMessageCodeLower :: Format r (MessageCode -> r)
69fMessageCodeLower = mapf getMessageCode lower
70
71fSegmentCodeLower :: Format r (SegmentCode -> r)
72fSegmentCodeLower = mapf getSegmentCode lower
73
74fCompositeCodeLower :: Format r (CompositeCode -> r)
75fCompositeCodeLower = mapf getCompositeCode lower
76
77fSimpleCodeLower :: Format r (SimpleCode -> r)
78fSimpleCodeLower = mapf getSimpleCode lower
79
80-- This might not be the proper way to do it...
81-- Use Data.Text.Encoding.decodeUtf8With instead?
82cleanupAsciiArt :: Text -> Text
83cleanupAsciiArt =
84 let f 'Ä' = '-'
85 f '¿' = '+'
86 f '³' = '|'
87 f 'Ù' = '+'
88 f 'Á' = '+'
89 f c = c
90 in T.map f
diff --git a/scaffolder/src/Text/Edifact/BundleReader/Composites.hs b/scaffolder/src/Text/Edifact/BundleReader/Composites.hs
new file mode 100644
index 0000000..2880b95
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/BundleReader/Composites.hs
@@ -0,0 +1,43 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Text.Edifact.BundleReader.Composites
4 ( readComposites
5 , compositesDirectory
6 ) where
7
8import Text.Edifact.BundleReader.Commons
9import Text.Edifact.BundleReader.Configuration (BundleReaderEnv (..))
10import Text.Edifact.Scaffolder.Commons
11
12import Text.Edifact.Scaffolder.Composites.Specification (listSimples)
13
14import Control.Monad (when)
15import Control.Monad.Reader (asks)
16import Data.ByteString as BS (ByteString,
17 readFile)
18import Formatting
19
20compositesDirectory :: FilePath
21compositesDirectory = "composites"
22
23readComposites :: [ByteString] -> ([CompositeCode], [SimpleCode]) -> BundleReader [SimpleCode]
24readComposites contents (composites, simples) = do
25 let parsedFile path = parseFile composites =<< liftIO (BS.readFile path)
26 parsedString = parseFile composites
27 files <- asks compositesFiles
28 parsedFiles <- traverse parsedFile files
29 parsedStrings <- traverse parsedString contents
30 let filtered = mappend simples $ concatMap snd $ filter (\s -> fst s `elem` composites) $ concat (parsedFiles <> parsedStrings)
31 pure filtered
32
33parseFile :: [CompositeCode] -> ByteString -> BundleReader [(CompositeCode, [SimpleCode])]
34parseFile composites content =
35 let chunks = tail $ splitFileByDash 70 $ decodeContent content
36 in traverse (parseChunk composites) chunks
37
38parseChunk :: [CompositeCode] -> Text -> BundleReader (CompositeCode, [SimpleCode])
39parseChunk composites chunk = do
40 parsed <- parseOrFail chunk listSimples
41 outputFile <- getOutputFile (fCompositeCodeLower % ".txt") compositesDirectory (fst parsed)
42 when (fst parsed `elem` composites) $ toFile chunk outputFile
43 pure parsed
diff --git a/scaffolder/src/Text/Edifact/BundleReader/Configuration.hs b/scaffolder/src/Text/Edifact/BundleReader/Configuration.hs
new file mode 100644
index 0000000..0609c03
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/BundleReader/Configuration.hs
@@ -0,0 +1,30 @@
1{-# LANGUAGE FlexibleContexts #-}
2
3module Text.Edifact.BundleReader.Configuration
4 ( -- * Parsing environment
5 BundleReaderEnv(..)
6 -- * Shortcuts for reading the environment
7 , getTargetRevision
8 , getHome
9 ) where
10
11import Text.Edifact.Scaffolder.Commons (MessageCode, Revision)
12
13import Control.Monad.Reader.Class (MonadReader, asks)
14
15data BundleReaderEnv = BundleReaderEnv { parserRevision :: Revision
16 , specificationHome :: FilePath
17 , bundle :: [FilePath]
18 , messageNames :: [MessageCode]
19 , messagesFiles :: [FilePath]
20 , segmentsFiles :: [FilePath]
21 , compositesFiles :: [FilePath]
22 , simplesFiles :: [FilePath]
23 , codedSimplesFiles :: [FilePath]
24 }
25
26getTargetRevision :: MonadReader BundleReaderEnv m => m Revision
27getTargetRevision = asks parserRevision
28
29getHome :: MonadReader BundleReaderEnv m => m FilePath
30getHome = asks specificationHome
diff --git a/scaffolder/src/Text/Edifact/BundleReader/Extractor.hs b/scaffolder/src/Text/Edifact/BundleReader/Extractor.hs
new file mode 100644
index 0000000..f4be7e9
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/BundleReader/Extractor.hs
@@ -0,0 +1,75 @@
1{-# LANGUAGE NamedFieldPuns #-}
2{-# LANGUAGE OverloadedStrings #-}
3
4module Text.Edifact.BundleReader.Extractor
5 ( FileContents(..)
6 , readZip
7 ) where
8
9import Text.Edifact.Scaffolder.Commons (Revision (..))
10
11import Codec.Archive.Zip
12import Data.ByteString as B (ByteString, isInfixOf,
13 isPrefixOf, readFile)
14import Data.ByteString.Lazy as BS (fromStrict, toStrict)
15import Data.Char (toLower)
16import Data.List as L (intercalate, isPrefixOf)
17import Data.List.Split (splitOn)
18import Data.Maybe (maybeToList)
19
20data FileContent =
21 FileContent
22 { fileType :: FileType
23 , fileContent :: ByteString
24 }
25
26data FileType = Message | Segment | Composite | Simple | CodedSimple deriving Eq
27
28data FileContents =
29 FileContents
30 { messages :: [ByteString]
31 , segments :: [ByteString]
32 , composites :: [ByteString]
33 , simples :: [ByteString]
34 , codedSimples :: [ByteString]
35 }
36
37readZip :: Revision -> FilePath -> IO FileContents
38readZip specification f = toFileContents . parseFile (getExtension f) (getName f) specification <$> B.readFile f
39
40toFileContents :: [FileContent] -> FileContents
41toFileContents t = FileContents
42 { messages = fileContent <$> filter ((==) Message . fileType) t
43 , segments = fileContent <$> filter ((==) Segment . fileType) t
44 , composites = fileContent <$> filter ((==) Composite . fileType) t
45 , simples = fileContent <$> filter ((==) Simple . fileType) t
46 , codedSimples = fileContent <$> filter ((==) CodedSimple . fileType) t
47 }
48
49getName :: FilePath -> String
50getName = intercalate "." . init . splitOn "." . last . splitOn "/"
51
52getExtension :: FilePath -> String
53getExtension = fmap toLower . last . splitOn "."
54
55parseFile :: String -> String -> Revision -> ByteString -> [FileContent]
56parseFile "zip" _ specification content = unzipAndRead specification content
57parseFile extension name specification content
58 | ("d" <> extension) == (toLower <$> getRevision specification) = maybeToList $ identifyFile name content
59parseFile _ _ _ _ = []
60
61unzipAndRead :: Revision -> ByteString -> [FileContent]
62unzipAndRead specification content = let
63 archive = zEntries $ toArchive $ BS.fromStrict content
64 toContents e@Entry{eRelativePath} = parseFile (getExtension eRelativePath) (getName eRelativePath) specification (BS.toStrict $ fromEntry e)
65 in
66 concatMap toContents archive
67
68identifyFile :: String -> ByteString -> Maybe FileContent
69identifyFile name content
70 | " Message Type : " `isInfixOf` content = pure $ FileContent Message content
71 | "2. Composite specifications" `B.isPrefixOf` content = pure $ FileContent Composite content
72 | "2. Segment specifications" `B.isPrefixOf` content = pure $ FileContent Segment content
73 | "2. Data element specifications" `B.isPrefixOf` content = pure $ FileContent Simple content
74 | "UNCL" `L.isPrefixOf` name = pure $ FileContent CodedSimple content
75identifyFile _ _ = Nothing
diff --git a/scaffolder/src/Text/Edifact/BundleReader/Messages.hs b/scaffolder/src/Text/Edifact/BundleReader/Messages.hs
new file mode 100644
index 0000000..5537d28
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/BundleReader/Messages.hs
@@ -0,0 +1,61 @@
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE TupleSections #-}
3
4module Text.Edifact.BundleReader.Messages
5 ( readMessages
6 , messagesDirectory
7 ) where
8
9import Text.Edifact.BundleReader.Commons (BundleReader,
10 decodeContent,
11 fMessageCodeLower,
12 getOutputFile,
13 parseOrFail,
14 toFile)
15import Text.Edifact.BundleReader.Configuration (BundleReaderEnv (..))
16import Text.Edifact.Scaffolder.Commons
17import Text.Edifact.Scaffolder.Messages.Specification (listSegments, messageNameParser)
18
19import Control.Monad (when)
20import Control.Monad.Reader (asks)
21import Data.ByteString as BS (ByteString,
22 readFile)
23import qualified Data.Text as T (isPrefixOf,
24 lines,
25 unlines)
26import Formatting
27
28messagesDirectory :: FilePath
29messagesDirectory = "messages"
30
31readMessages :: [ByteString] -> BundleReader [(MessageCode, [SegmentCode])]
32readMessages contents = do
33 selectedMessages <- asks messageNames
34 let parsedFile path = parseFile selectedMessages =<< liftIO (BS.readFile path)
35 parsedString = parseFile selectedMessages
36 parsedFiles <- traverse parsedFile =<< asks messagesFiles
37 parsedStrings <- traverse parsedString contents
38 let filtered = parsedFiles <> filter (\s -> null selectedMessages || fst s `elem` selectedMessages) parsedStrings
39 pure filtered
40
41parseFile :: [MessageCode] -> ByteString -> BundleReader (MessageCode, [SegmentCode])
42parseFile selectedMessages content = do
43 let (definition, summary) = splitFile $ decodeContent content
44 messageCode <- parseOrFail definition messageNameParser
45 summaryOutputFile <- getOutputFile (fMessageCodeLower % "_s.txt") messagesDirectory messageCode
46 definitionOutputFile <- getOutputFile (fMessageCodeLower % "_d.txt") messagesDirectory messageCode
47 when (messageCode `elem` selectedMessages) $ toFile definition definitionOutputFile
48 when (messageCode `elem` selectedMessages) $ toFile summary summaryOutputFile
49 (messageCode,) <$> parseOrFail summary listSegments
50
51splitFile :: Text -> (Text, Text)
52splitFile content = let
53 separatorBefore = "4.3 Message structure"
54 separatorAfter = "Annex"
55 textBefore = takeWhile (not . T.isPrefixOf separatorBefore) $ T.lines content
56 textInsideAndAfter = dropWhile (not . T.isPrefixOf separatorBefore) $ T.lines content
57 textAfter = dropWhile (not . T.isPrefixOf separatorAfter) textInsideAndAfter
58 textSummary = T.unlines $ takeWhile (not . T.isPrefixOf separatorAfter) textInsideAndAfter
59 textDefinition = T.unlines $ textBefore <> [separatorBefore, "", "See summary file", ""] <> textAfter
60 in
61 (textDefinition, textSummary)
diff --git a/scaffolder/src/Text/Edifact/BundleReader/Segments.hs b/scaffolder/src/Text/Edifact/BundleReader/Segments.hs
new file mode 100644
index 0000000..6b71266
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/BundleReader/Segments.hs
@@ -0,0 +1,55 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Text.Edifact.BundleReader.Segments
4 ( readSegments
5 , segmentsDirectory
6 ) where
7
8import Text.Edifact.BundleReader.Commons
9import Text.Edifact.BundleReader.Configuration (BundleReaderEnv (..))
10import Text.Edifact.Scaffolder.Commons
11
12import Text.Edifact.Scaffolder.Segments.Specification (listCompositesAndSimples)
13import Text.Edifact.Scaffolder.Segments.Types (Element,
14 getComposite,
15 getSimple)
16
17import Control.Monad (when)
18import Control.Monad.Reader (asks)
19import Data.Bifunctor (bimap)
20import Data.ByteString as BS (ByteString,
21 readFile)
22import Data.List as L (partition)
23import Data.Maybe (isJust,
24 mapMaybe)
25import Formatting
26
27segmentsDirectory :: FilePath
28segmentsDirectory = "segments"
29
30readSegments :: [ByteString] -> [SegmentCode] -> BundleReader ([CompositeCode], [SimpleCode])
31readSegments contents segments = do
32 let parsedFile path = parseFile segments =<< liftIO (BS.readFile path)
33 parsedString = parseFile segments
34 files <- asks segmentsFiles
35 parsedFiles <- traverse parsedFile files
36 parsedStrings <- traverse parsedString contents
37 let filtered = concatMap snd $ filter (\s -> fst s `elem` segments) $ concat (parsedFiles <> parsedStrings)
38 pure $ partitionElements filtered
39
40parseFile :: [SegmentCode] -> ByteString -> BundleReader [(SegmentCode, [Element])]
41parseFile segments content =
42 let chunks = tail $ splitFileByDash 70 $ decodeContent content
43 in traverse (parseChunk segments) chunks
44
45parseChunk :: [SegmentCode] -> Text -> BundleReader (SegmentCode, [Element])
46parseChunk segments chunk = do
47 parsed <- parseOrFail chunk listCompositesAndSimples
48 outputFile <- getOutputFile (fSegmentCodeLower % ".txt") segmentsDirectory (fst parsed)
49 when (fst parsed `elem` segments) $ toFile chunk outputFile
50 pure parsed
51
52partitionElements :: [Element] -> ([CompositeCode], [SimpleCode])
53partitionElements =
54 let isComposite = isJust . getComposite
55 in bimap (mapMaybe getComposite) (mapMaybe getSimple) . partition isComposite
diff --git a/scaffolder/src/Text/Edifact/BundleReader/Simples.hs b/scaffolder/src/Text/Edifact/BundleReader/Simples.hs
new file mode 100644
index 0000000..df7d662
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/BundleReader/Simples.hs
@@ -0,0 +1,43 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Text.Edifact.BundleReader.Simples
4 ( readSimples
5 , simplesDirectory
6 ) where
7
8import Text.Edifact.BundleReader.Commons
9import Text.Edifact.BundleReader.Configuration (BundleReaderEnv (..))
10import Text.Edifact.Scaffolder.Commons
11
12import Text.Edifact.Scaffolder.Simples.Specification
13
14import Control.Monad (when)
15import Control.Monad.Reader (asks)
16import Data.ByteString as BS (ByteString,
17 readFile)
18import Formatting
19
20simplesDirectory :: FilePath
21simplesDirectory = "simples"
22
23readSimples :: [ByteString] -> [SimpleCode] -> BundleReader [SimpleCode]
24readSimples contents simples = do
25 let parsedFile path = parseFile simples =<< liftIO (BS.readFile path)
26 parsedString = parseFile simples
27 files <- asks simplesFiles
28 parsedFiles <- traverse parsedFile files
29 parsedStrings <- traverse parsedString contents
30 let filtered = filter (`elem` simples) $ concat (parsedFiles <> parsedStrings)
31 pure filtered
32
33parseFile :: [SimpleCode] -> ByteString -> BundleReader [SimpleCode]
34parseFile simples content =
35 let chunks = tail $ splitFileByDash 70 $ decodeContent content
36 in traverse (parseChunk simples) chunks
37
38parseChunk :: [SimpleCode] -> Text -> BundleReader SimpleCode
39parseChunk simples chunk = do
40 parsed <- parseOrFail chunk specificationParser
41 outputFile <- getOutputFile (fSimpleCodeLower % ".txt") simplesDirectory (fst parsed)
42 when (fst parsed `elem` simples) $ toFile chunk outputFile
43 pure $ fst parsed
diff --git a/scaffolder/src/Text/Edifact/Fetcher.hs b/scaffolder/src/Text/Edifact/Fetcher.hs
new file mode 100644
index 0000000..a319546
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Fetcher.hs
@@ -0,0 +1,44 @@
1module Text.Edifact.Fetcher
2 ( fetch
3 , FetchingEnv(..)
4 , readSelectMessages
5 ) where
6
7import Text.Edifact.Fetcher.Commons (Fetcher,
8 getSpecificationHome,
9 runFetcher)
10import Text.Edifact.Fetcher.Configuration
11
12import Text.Edifact.Fetcher.Composites (compositesDirectory,
13 fetchComposites)
14import Text.Edifact.Fetcher.Messages (fetchMessages,
15 messagesDirectory)
16import Text.Edifact.Fetcher.Segments (fetchSegments,
17 segmentsDirectory)
18import Text.Edifact.Fetcher.Simples (fetchSimples,
19 simplesDirectory)
20
21import Control.Monad.IO.Class (liftIO)
22import Data.Foldable (traverse_)
23import System.Directory (createDirectoryIfMissing)
24import System.FilePath ((</>))
25
26fetch :: FetchingEnv -> IO ()
27fetch = runFetcher (setupDirectories >> fetchAll)
28
29fetchAll :: Fetcher ()
30fetchAll = fetchMessages >>= fetchSegments >>= fetchComposites >>= fetchSimples
31
32setupDirectories :: Fetcher ()
33setupDirectories = do
34 home <- getSpecificationHome
35 let mkdir d = liftIO (createDirectoryIfMissing True (home </> d))
36 traverse_ mkdir directories
37
38directories :: [FilePath]
39directories =
40 [ compositesDirectory
41 , messagesDirectory
42 , segmentsDirectory
43 , simplesDirectory
44 ]
diff --git a/scaffolder/src/Text/Edifact/Fetcher/Commons.hs b/scaffolder/src/Text/Edifact/Fetcher/Commons.hs
new file mode 100644
index 0000000..1a6a058
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Fetcher/Commons.hs
@@ -0,0 +1,87 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Text.Edifact.Fetcher.Commons where
4
5import Text.Edifact.Fetcher.Configuration
6import Text.Edifact.Scaffolder.Commons
7
8import Control.Monad ((>=>))
9import Control.Monad.Error.Class (MonadError, catchError)
10import Control.Monad.IO.Class (MonadIO)
11import Control.Monad.Reader (ReaderT, runReaderT)
12import Control.Monad.Trans.Class (lift)
13import Data.ByteString (ByteString)
14import Data.Char (toLower)
15import Data.Text as T (unpack, pack)
16import Data.Text.IO as TIO (readFile, writeFile)
17import Formatting
18import System.Directory (doesFileExist)
19import Text.Pandoc as Pandoc hiding (Format,
20 getOutputFile)
21import Text.Parsec (Parsec, runParser)
22
23type Fetcher = ReaderT FetchingEnv PandocIO
24
25runFetcher :: Fetcher () -> FetchingEnv -> IO ()
26runFetcher f = Pandoc.runIOorExplode . runReaderT f
27
28getOutputFile :: Format String (a -> String) -> FilePath -> a -> Fetcher FilePath
29getOutputFile f d c = do
30 home <- getSpecificationHome
31 pure (formatToString (string % "/" % string % "/" % f) home d c)
32
33getUrl :: Format String (a -> String) -> a -> Fetcher String
34getUrl f c = do
35 rev <- getTargetRevision
36 pure (formatToString ("https://service.unece.org/trade/untdid/" % fRevisionLower % f) rev c)
37
38getSpecificationHome :: Fetcher FilePath
39getSpecificationHome = do
40 home <- getHome
41 rev <- getTargetRevision
42 pure (home </> formatToString fRevision rev)
43
44htmlToFile :: String -> (ByteString -> Text) -> FilePath -> Fetcher ()
45htmlToFile url decoder outputFile = () <$ tryCacheOrHtml decoder url outputFile
46
47htmlToFileWithParser :: (Monoid a, Monoid u) => String -> (ByteString -> Text) -> FilePath -> Parsec String u a -> Fetcher a
48htmlToFileWithParser url decoder outputFile parser = do
49 specification <- tryCacheOrHtml decoder url outputFile
50 either (error . show) pure
51 (runParser parser mempty "" (T.unpack specification))
52
53tryCacheOrHtml :: (ByteString -> Text) -> String -> FilePath -> Fetcher Text
54tryCacheOrHtml decoder url path = do
55 fileExists' <- liftIO $ doesFileExist path
56 content <- if fileExists'
57 then liftIO $ TIO.readFile path
58 else readHtmlFromURL decoder url >>= writePlain def
59 content <$ liftIO (TIO.writeFile path content)
60
61readHtmlFromURL :: (ByteString -> Text) -> String -> Fetcher Pandoc
62readHtmlFromURL decoder = lift . (openURL >=> readHtml def . decoder . fst) . pack
63
64lower :: Format r (String -> r)
65lower = mapf (fmap toLower) string
66
67fRevision :: Format r (Revision -> r)
68fRevision = mapf getRevision string
69
70fRevisionLower :: Format r (Revision -> r)
71fRevisionLower = mapf getRevision lower
72
73fMessageCodeLower :: Format r (MessageCode -> r)
74fMessageCodeLower = mapf getMessageCode lower
75
76fSegmentCodeLower :: Format r (SegmentCode -> r)
77fSegmentCodeLower = mapf getSegmentCode lower
78
79fCompositeCodeLower :: Format r (CompositeCode -> r)
80fCompositeCodeLower = mapf getCompositeCode lower
81
82fSimpleCodeLower :: Format r (SimpleCode -> r)
83fSimpleCodeLower = mapf getSimpleCode lower
84
85retry :: (MonadIO m, MonadError b m) => Int -> m a -> m a
86retry n f | n > 1 = f `catchError` const (say "Retrying" >> retry (n-1) f)
87 | otherwise = f
diff --git a/scaffolder/src/Text/Edifact/Fetcher/Composites.hs b/scaffolder/src/Text/Edifact/Fetcher/Composites.hs
new file mode 100644
index 0000000..8f94cc9
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Fetcher/Composites.hs
@@ -0,0 +1,31 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Text.Edifact.Fetcher.Composites
4 ( fetchComposites
5 , compositesDirectory
6 ) where
7
8import Text.Edifact.Fetcher.Commons
9import Text.Edifact.Scaffolder.Commons
10
11import Text.Edifact.Scaffolder.Composites.Specification (listSimples)
12
13import Data.List as L (nub,
14 sort)
15import Data.Text.Encoding as TE (decodeUtf8)
16import Formatting
17
18compositesDirectory :: FilePath
19compositesDirectory = "composites"
20
21fetchComposites :: ([CompositeCode], [SimpleCode]) -> Fetcher [SimpleCode]
22fetchComposites (composites, segments) =
23 let compactSimpleCodes = L.nub . L.sort . mappend segments . concat
24 in compactSimpleCodes <$> traverse (retry 3 . fetchComposite) composites
25
26fetchComposite :: CompositeCode -> Fetcher [SimpleCode]
27fetchComposite code = do
28 say ("Fetching composite " % fCompositeCode) code
29 url <- getUrl ("/trcd/trcd" % fCompositeCodeLower % ".htm") code
30 outputFile <- getOutputFile (fCompositeCodeLower % ".txt") compositesDirectory code
31 htmlToFileWithParser url TE.decodeUtf8 outputFile (snd <$> listSimples)
diff --git a/scaffolder/src/Text/Edifact/Fetcher/Configuration.hs b/scaffolder/src/Text/Edifact/Fetcher/Configuration.hs
new file mode 100644
index 0000000..a074641
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Fetcher/Configuration.hs
@@ -0,0 +1,43 @@
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE OverloadedStrings #-}
3
4module Text.Edifact.Fetcher.Configuration
5 ( -- * Fetching environment
6 FetchingEnv(..)
7 -- * Parsing helpers
8 , readSelectMessages
9 -- * Shortcuts for reading the environment
10 , getTargetRevision
11 , getHome
12 , getSelectedMessages
13 ) where
14
15import Text.Edifact.Scaffolder.Commons (MessageCode, Revision,
16 messageCodeParser)
17
18import Control.Monad.Reader.Class (MonadReader, asks)
19import Data.List.NonEmpty (NonEmpty, nonEmpty)
20import Text.Parsec (char, parse, sepBy1)
21
22data FetchingEnv = FetchingEnv { fetchingRevision :: Revision
23 , specificationHome :: FilePath
24 , selectedMessages :: Maybe (NonEmpty MessageCode)
25 }
26
27getTargetRevision :: MonadReader FetchingEnv m => m Revision
28getTargetRevision = asks fetchingRevision
29
30getHome :: MonadReader FetchingEnv m => m FilePath
31getHome = asks specificationHome
32
33getSelectedMessages :: MonadReader FetchingEnv m => m (Maybe (NonEmpty MessageCode))
34getSelectedMessages = asks selectedMessages
35
36readSelectMessages :: Maybe String -> Maybe (NonEmpty MessageCode)
37readSelectMessages value =
38 let tryParse p s = toMaybe . parse p s
39 toMaybe (Right v) = Just v
40 toMaybe _ = Nothing
41 messageCodesParser = messageCodeParser `sepBy1` comma
42 comma = char ','
43 in value >>= tryParse messageCodesParser "" >>= nonEmpty
diff --git a/scaffolder/src/Text/Edifact/Fetcher/Messages.hs b/scaffolder/src/Text/Edifact/Fetcher/Messages.hs
new file mode 100644
index 0000000..9daf98a
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Fetcher/Messages.hs
@@ -0,0 +1,84 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Text.Edifact.Fetcher.Messages
4 ( fetchMessages
5 , messagesDirectory
6 ) where
7
8import Text.Edifact.Fetcher.Commons
9import Text.Edifact.Fetcher.Configuration
10import Text.Edifact.Scaffolder.Commons
11
12import Text.Edifact.Scaffolder.Messages.Specification (listSegments)
13
14import Data.Foldable (toList)
15import Data.List as L (nub, sort)
16import Data.Maybe (mapMaybe)
17import Data.Text as T (map)
18import Data.Text.Encoding as TE (decodeLatin1,
19 decodeUtf8)
20import Formatting
21import Text.Pandoc as Pandoc hiding (Format,
22 getOutputFile)
23import Text.Pandoc.Walk (query)
24import Text.Parsec (parse)
25
26messagesDirectory :: FilePath
27messagesDirectory = "messages"
28
29parseMessageCode :: Text -> Maybe MessageCode
30parseMessageCode =
31 let toMaybe (Right v) = Just v
32 toMaybe _ = Nothing
33 in toMaybe . parse messageCodeParser ""
34
35scanInlineForMessageCode :: Inline -> Maybe MessageCode
36scanInlineForMessageCode (Str label) = parseMessageCode label
37scanInlineForMessageCode _ = Nothing
38
39-- The trick here is to reverse the usage of UNH which is mandatory on every single message
40listAllMessages :: Fetcher [MessageCode]
41listAllMessages =
42 let filterLink (Link _ inlines _) = mapMaybe scanInlineForMessageCode inlines
43 filterLink _ = []
44 extractMessageCodes = query filterLink
45 loadUNHUsages = readHtmlFromURL TE.decodeUtf8 =<< getUrl ("/trsd/cseg" % fSegmentCodeLower % ".htm") "UNH"
46 in extractMessageCodes <$> loadUNHUsages
47
48listMessages :: Fetcher [MessageCode]
49listMessages = getSelectedMessages >>= maybe listAllMessages (pure . toList)
50
51fetchMessages :: Fetcher [SegmentCode]
52fetchMessages = listMessages >>= fmap (L.nub . L.sort . concat) . traverse fetchMessage
53
54fetchMessage :: MessageCode -> Fetcher [SegmentCode]
55fetchMessage code = do
56 retry 3 (fetchMessageDefinition code)
57 retry 3 (fetchMessageSummary code)
58
59fetchMessageDefinition :: MessageCode -> Fetcher ()
60fetchMessageDefinition code = do
61 say ("Fetching message " % fMessageCode % " definition") code
62 url <- getUrl ("/trmd/" % fMessageCodeLower % "_d.htm") code
63 outputFile <- getOutputFile (fMessageCodeLower % "_d.txt") messagesDirectory code
64 htmlToFile url TE.decodeUtf8 outputFile
65
66fetchMessageSummary :: MessageCode -> Fetcher [SegmentCode]
67fetchMessageSummary code = do
68 say ("Fetching message " % fMessageCode % " summary") code
69 url <- getUrl ("/trmd/" % fMessageCodeLower % "_s.htm") code
70 outputFile <- getOutputFile (fMessageCodeLower % "_s.txt") messagesDirectory code
71 let decoder = cleanupAsciiArt . TE.decodeLatin1
72 htmlToFileWithParser url decoder outputFile listSegments
73
74-- This might not be the proper way to do it...
75-- Use Data.Text.Encoding.decodeUtf8With instead?
76cleanupAsciiArt :: Text -> Text
77cleanupAsciiArt =
78 let f 'Ä' = '-'
79 f '¿' = '+'
80 f '³' = '|'
81 f 'Ù' = '+'
82 f 'Á' = '+'
83 f c = c
84 in T.map f
diff --git a/scaffolder/src/Text/Edifact/Fetcher/Segments.hs b/scaffolder/src/Text/Edifact/Fetcher/Segments.hs
new file mode 100644
index 0000000..dda1d88
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Fetcher/Segments.hs
@@ -0,0 +1,41 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Text.Edifact.Fetcher.Segments
4 ( fetchSegments
5 , segmentsDirectory
6 ) where
7
8import Text.Edifact.Fetcher.Commons
9import Text.Edifact.Scaffolder.Commons
10
11import Text.Edifact.Scaffolder.Segments.Specification (listCompositesAndSimples)
12import Text.Edifact.Scaffolder.Segments.Types (Element,
13 getComposite,
14 getSimple)
15
16import Data.Bifunctor (bimap)
17import Data.List as L (nub,
18 partition,
19 sort)
20import Data.Maybe (isJust,
21 mapMaybe)
22import Data.Text.Encoding as TE (decodeUtf8)
23import Formatting
24
25segmentsDirectory :: FilePath
26segmentsDirectory = "segments"
27
28fetchSegments :: [SegmentCode] -> Fetcher ([CompositeCode], [SimpleCode])
29fetchSegments = fmap (partitionElements . L.nub . L.sort . concat) . traverse (retry 3 . fetchSegment)
30
31partitionElements :: [Element] -> ([CompositeCode], [SimpleCode])
32partitionElements =
33 let isComposite = isJust . getComposite
34 in bimap (mapMaybe getComposite) (mapMaybe getSimple) . partition isComposite
35
36fetchSegment :: SegmentCode -> Fetcher [Element]
37fetchSegment code = do
38 say ("Fetching segment " % fSegmentCode) code
39 url <- getUrl ("/trsd/trsd" % fSegmentCodeLower % ".htm") code
40 outputFile <- getOutputFile (fSegmentCodeLower % ".txt") segmentsDirectory code
41 htmlToFileWithParser url TE.decodeUtf8 outputFile (snd <$> listCompositesAndSimples)
diff --git a/scaffolder/src/Text/Edifact/Fetcher/Simples.hs b/scaffolder/src/Text/Edifact/Fetcher/Simples.hs
new file mode 100644
index 0000000..47951ad
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Fetcher/Simples.hs
@@ -0,0 +1,27 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Text.Edifact.Fetcher.Simples
4 ( fetchSimples
5 , simplesDirectory
6 ) where
7
8import Text.Edifact.Fetcher.Commons
9import Text.Edifact.Scaffolder.Commons
10
11
12import Data.Foldable (traverse_)
13import Data.Text.Encoding as TE (decodeUtf8)
14import Formatting
15
16simplesDirectory :: FilePath
17simplesDirectory = "simples"
18
19fetchSimples :: [SimpleCode] -> Fetcher ()
20fetchSimples = traverse_ (retry 3 . fetchSimple)
21
22fetchSimple :: SimpleCode -> Fetcher ()
23fetchSimple code = do
24 say ("Fetching simple " % fSimpleCode) code
25 url <- getUrl ("/uncl/uncl" % fSimpleCodeLower % ".htm") code
26 outputFile <- getOutputFile (fSimpleCodeLower % ".txt") simplesDirectory code
27 htmlToFile url TE.decodeUtf8 outputFile
diff --git a/scaffolder/src/Text/Edifact/Scaffolder.hs b/scaffolder/src/Text/Edifact/Scaffolder.hs
new file mode 100644
index 0000000..8a86d7a
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder.hs
@@ -0,0 +1,20 @@
1module Text.Edifact.Scaffolder
2 ( scaffold
3 , ScaffoldingEnv(..)
4 ) where
5
6import Text.Edifact.Scaffolder.Commons
7
8import Text.Edifact.Scaffolder.Composites
9import Text.Edifact.Scaffolder.Messages
10import Text.Edifact.Scaffolder.Root
11import Text.Edifact.Scaffolder.Segments
12import Text.Edifact.Scaffolder.Simples
13
14scaffold :: ScaffoldingEnv -> IO ()
15scaffold = runScaffolding $ do
16 messages
17 segments
18 composites
19 simples
20 rootModule
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/CodedSimples/Specification.hs b/scaffolder/src/Text/Edifact/Scaffolder/CodedSimples/Specification.hs
new file mode 100644
index 0000000..967f685
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/CodedSimples/Specification.hs
@@ -0,0 +1,28 @@
1module Text.Edifact.Scaffolder.CodedSimples.Specification
2 ( -- *
3 specificationParser
4 ) where
5
6import Text.Edifact.Scaffolder.Commons
7
8import Text.Parsec as P (anyChar, count, digit,
9 endOfLine, manyTill,
10 oneOf, skipMany, string,
11 try)
12import Text.Parsec.String (Parser)
13
14specificationParser :: Parser (SimpleCode, SimpleName)
15specificationParser = scanUntil [ codedSimpleParser ]
16
17codedSimpleParser :: Parser (SimpleCode, SimpleName)
18codedSimpleParser = do
19 _ <- count 2 (oneOf "+*#|-X ")
20 skipMany (string " ")
21 code <- simpleCodeParser
22 _ <- string " "
23 skipMany (string " ")
24 name <- SimpleName <$> manyTill anyChar (() <$ try endOfLine)
25 pure (code, name)
26
27simpleCodeParser :: Parser SimpleCode
28simpleCodeParser = fromString <$> count 4 digit
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Commons.hs b/scaffolder/src/Text/Edifact/Scaffolder/Commons.hs
new file mode 100644
index 0000000..ce960b1
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Commons.hs
@@ -0,0 +1,29 @@
1module Text.Edifact.Scaffolder.Commons
2 ( -- *
3 runScaffolding
4 -- * Reexports
5 , module X
6 ) where
7
8import Text.Edifact.Scaffolder.Commons.Formatters as X
9import Text.Edifact.Scaffolder.Commons.Language as X
10import Text.Edifact.Scaffolder.Commons.Logging as X
11import Text.Edifact.Scaffolder.Commons.Parsing as X
12import Text.Edifact.Scaffolder.Commons.Text as X
13import Text.Edifact.Scaffolder.Commons.Types as X
14
15import Control.Monad.IO.Class as X (liftIO)
16import Data.List.NonEmpty as X (NonEmpty, nub,
17 sort)
18import Data.Maybe as X (fromMaybe)
19import Data.Semigroup as X ((<>))
20import Data.String as X (IsString,
21 fromString)
22import Data.Text as X (Text)
23import System.Directory as X (listDirectory)
24import System.FilePath as X ((</>))
25
26import Control.Monad.Reader (runReaderT)
27
28runScaffolding :: Scaffolding a -> ScaffoldingEnv -> IO a
29runScaffolding = runReaderT
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Commons/Formatters.hs b/scaffolder/src/Text/Edifact/Scaffolder/Commons/Formatters.hs
new file mode 100644
index 0000000..6f0210b
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Commons/Formatters.hs
@@ -0,0 +1,88 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Text.Edifact.Scaffolder.Commons.Formatters
4 ( -- *
5 fMessageCode
6 , fMessageParserFunction
7 , fGroupCode
8 , fSegmentCode
9 , fSegmentParserFunction
10 , fCompositeCode
11 , fCompositeParserFunction
12 , fSimpleCode
13 , fSimpleParserFunction
14
15 -- *
16 , fParserSignature
17 , fParserDeclaration
18 -- *
19 , fModuleName
20 , fPosition
21 , fPresence
22 -- *
23 , quoted
24 , simpleQuoted
25 , parens
26 , notYetImplemented
27 ) where
28
29import Text.Edifact.Scaffolder.Commons.Types
30
31import Formatting as F
32
33fMessageCode:: Format r (MessageCode -> r)
34fMessageCode = mapf getMessageCode F.string
35
36fMessageParserFunction :: Format r (MessageCode -> r)
37fMessageParserFunction = mapf getMessageCode ("message" % F.string)
38
39fGroupCode :: Format r (GroupCode -> r)
40fGroupCode = mapf getGroupCode F.string
41
42fSegmentCode :: Format r (SegmentCode -> r)
43fSegmentCode = mapf getSegmentCode F.string
44
45fSegmentParserFunction :: Format r (SegmentCode -> r)
46fSegmentParserFunction = mapf getSegmentCode ("segment" % F.string)
47
48fCompositeCode :: Format r (CompositeCode -> r)
49fCompositeCode = mapf getCompositeCode F.string
50
51fCompositeParserFunction :: Format r (CompositeCode -> r)
52fCompositeParserFunction = mapf getCompositeCode ("composite" % F.string)
53
54fSimpleCode :: Format r (SimpleCode -> r)
55fSimpleCode = mapf getSimpleCode F.string
56
57fSimpleParserFunction :: Format r (SimpleCode -> r)
58fSimpleParserFunction = mapf getSimpleCode ("simple" % F.string)
59
60fParserSignature :: Format r a -> Format r a
61fParserSignature f = f % " :: Parser Value"
62
63fParserDeclaration :: Format r a -> Format r a
64fParserDeclaration f = f % " ="
65
66fModuleName :: Format r (ModuleName -> r)
67fModuleName = mapf getModuleName string
68
69fPosition :: Format r (Position -> r)
70fPosition = mapf getPosition F.string
71
72fPresence :: Format r (Presence -> r)
73fPresence =
74 let f Mandatory = "mandatory"
75 f Optional = "optional "
76 in mapf f F.string
77
78quoted :: Format r a -> Format r a
79quoted f = "\"" % f % "\""
80
81simpleQuoted :: Format r a -> Format r a
82simpleQuoted f = "'" % f % "'"
83
84parens :: Format r a -> Format r a
85parens f = "(" % f % ")"
86
87notYetImplemented :: Format r a -> Format r a
88notYetImplemented desc = "notYetImplemented " % quoted (desc % " not yet implemented")
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Commons/Language.hs b/scaffolder/src/Text/Edifact/Scaffolder/Commons/Language.hs
new file mode 100644
index 0000000..214ee43
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Commons/Language.hs
@@ -0,0 +1,286 @@
1{-# LANGUAGE DerivingStrategies #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE OverloadedLists #-}
4{-# LANGUAGE OverloadedStrings #-}
5
6module Text.Edifact.Scaffolder.Commons.Language
7 ( -- *
8 saveHaskellModule
9 , includeSpecification
10 -- *
11 , scaffoldModule
12 -- *
13 , getRootModuleName
14 , getRootModuleNameFor
15 -- *
16 , scaffoldElements
17 , ElementWithDefinition
18 -- *
19 , parentModule
20 -- *
21 , haddockDependencies
22 -- *
23 , reexportDependencies
24 -- *
25 , importDependencies
26 , importCombinators
27 , importNotYetImplementedHelper
28 -- *
29 , moduleDeclaration
30 , Export(..)
31 -- *
32 , reexportAlias
33 , singleImport
34 , ImportGroup(..)
35 , Import(..)
36 , ImportName(..)
37 , ModuleAlias(..)
38 , LanguageExtension(..)
39 ) where
40
41import Text.Edifact.Scaffolder.Commons.Formatters (fModuleName,
42 parens,
43 simpleQuoted)
44import Text.Edifact.Scaffolder.Commons.Logging (say)
45import Text.Edifact.Scaffolder.Commons.Text (commaSeparated,
46 extensions,
47 formatSpecification,
48 indent, newline)
49import Text.Edifact.Scaffolder.Commons.Types (LanguageExtension (..),
50 ModuleName (..),
51 Scaffolding,
52 getRevision,
53 hostModule,
54 revision,
55 targetDirectory,
56 (<.>))
57
58import Control.Monad ((>=>))
59import Control.Monad.IO.Class (liftIO)
60import Control.Monad.Reader (asks)
61import Data.Bifunctor (bimap)
62import Data.Foldable (traverse_)
63import Data.List (intercalate,
64 uncons)
65import Data.List.NonEmpty (NonEmpty, nonEmpty)
66import qualified Data.List.NonEmpty as NE (cons, toList)
67import Data.List.Split (splitOn)
68import Data.String (IsString (..))
69import Data.Text as T (Text, drop,
70 lines,
71 unlines)
72import qualified Data.Text.IO as TIO (readFile,
73 writeFile)
74import Data.Tuple (swap)
75import Formatting as F (Format,
76 bprint, later,
77 mapf, sformat,
78 stext, (%))
79import System.Directory (createDirectoryIfMissing)
80import System.FilePath ((</>))
81import System.Process (callCommand)
82
83getRootModuleName :: Scaffolding ModuleName
84getRootModuleName =
85 let prefix host rev = host <.> ModuleName (getRevision rev)
86 in asks (prefix . hostModule) <*> asks revision
87
88getRootModuleNameFor :: ModuleName -> Scaffolding ModuleName
89getRootModuleNameFor name =
90 let suffix root = root <.> name
91 in suffix <$> getRootModuleName
92
93saveHaskellModule :: ModuleName -> [Text] -> Scaffolding ()
94saveHaskellModule mn body =
95 let sources = T.unlines body
96 saveModule file = liftIO (saveFile file >> stylishHaskell file)
97 saveFile = flip TIO.writeFile sources
98 stylishHaskell file = callCommand ("stylish-haskell -i " <> file)
99 doNothing = pure ()
100 in say ("module " % fModuleName) mn >> mkSourceFile mn >>= maybe doNothing saveModule
101
102mkSourceFile :: ModuleName -> Scaffolding (Maybe FilePath)
103mkSourceFile = locateSourceFile >=> traverse prepareHierarchy
104
105type FileInDirectory = (Directory, FileName)
106type Directory = FilePath
107type FileName = FilePath
108
109prepareHierarchy :: FileInDirectory -> Scaffolding FilePath
110prepareHierarchy (directory, file) =
111 let fullPath = directory </> file
112 in fullPath <$ liftIO (createDirectoryIfMissing True directory)
113
114locateSourceFile :: ModuleName -> Scaffolding (Maybe FileInDirectory)
115locateSourceFile (ModuleName mn) =
116 let hierarchy = splitOn "." mn
117 toFile n = n <> ".hs"
118 path :: Directory -> Maybe (Directory, FileName)
119 path directory = fmap toFile . swap . fmap (foldl (</>) directory . reverse) <$> uncons (reverse hierarchy)
120 in asks (path . targetDirectory)
121
122includeSpecification :: FilePath -> Scaffolding [Text]
123includeSpecification = fmap (formatSpecification . T.lines) . liftIO . TIO.readFile
124
125type ElementWithDefinition elt = (FilePath, elt)
126
127scaffoldElements :: (NonEmpty (ElementWithDefinition element) -> Scaffolding ())
128 -> ( ElementWithDefinition element -> Scaffolding ())
129 -> ([ ElementWithDefinition element] -> Scaffolding ())
130scaffoldElements parentScaffolder elementScaffolder =
131 let doNothing = pure ()
132 scaffolder elts = parentScaffolder elts >> traverse_ elementScaffolder elts
133 in maybe doNothing scaffolder . nonEmpty
134
135parentModule :: ModuleName -> ModuleAlias -> (ModuleName -> element -> ModuleName) -> NonEmpty (ElementWithDefinition element) -> Scaffolding ()
136parentModule elementName alias nameModule elements =
137 getRootModuleNameFor elementName >>= generateRootModule alias nameModule (snd <$> elements)
138
139generateRootModule :: ModuleAlias -> (ModuleName -> element -> ModuleName) -> NonEmpty element -> ModuleName -> Scaffolding ()
140generateRootModule alias nameModule codes mn =
141 let importElement code = ImportAll (ImportAs (nameModule mn code) alias)
142 imports = [ ImportGroup (importElement <$> codes) ]
143 exports = [ reexportAlias alias ]
144 in saveHaskellModule mn $
145 moduleDeclaration mn exports imports
146
147haddockDependencies :: Format Text (elt -> Text) -> NonEmpty elt -> Scaffolding [Text]
148haddockDependencies formatter elts =
149 let formattedDependencies = commaSeparated . fmap (sformat (simpleQuoted formatter))
150 formatHaddock = sformat ("-- Dependencies: " % F.stext % ".")
151 in pure [ "--"
152 , formatHaddock (formattedDependencies elts)
153 ]
154
155reexportDependencies :: Format Text (elt -> Text) -> NonEmpty elt -> Scaffolding [Export]
156reexportDependencies formatter =
157 let mkReexport = Name . sformat formatter
158 prependTitle = NE.cons (Comment "* Dependencies")
159 in pure . NE.toList . prependTitle . fmap mkReexport
160
161importDependencies :: ModuleName -> Format Text (elt -> Text) -> NonEmpty elt -> Scaffolding Import
162importDependencies moduleName formatter elts =
163 let imports = NE.toList (sformat formatter <$> elts)
164 mkImport mn = Import (BasicImport mn) imports
165 in mkImport <$> getRootModuleNameFor moduleName
166
167importCombinators :: ImportGroup
168importCombinators =
169 ImportGroup
170 [ ImportAll "Text.Edifact.Parsing"
171 , Import "Text.Edifact.Types" [ "Value" ]
172 ]
173
174importNotYetImplementedHelper :: ImportGroup
175importNotYetImplementedHelper =
176 ImportGroup
177 [ Import "Text.Edifact.Parsing.Commons" [ "notYetImplemented" ]
178 ]
179
180moduleDeclaration :: ModuleName -> [Export] -> [ImportGroup] -> [Text]
181moduleDeclaration moduleName exports imports =
182 let decl mn [] = [sformat ("module " % fModuleName % " where") mn]
183 decl mn ex = sformat ("module " % fModuleName) mn
184 : renderExports ex
185 in intercalate newline [ decl moduleName exports
186 , renderImports imports
187 ]
188
189machineGeneratedWarning :: [Text]
190machineGeneratedWarning =
191 [ "---- Machine generated code."
192 , "---- Output of edi-parser-scaffolder"
193 ]
194
195scaffoldModule :: ModuleName -> [LanguageExtension] -> [Export] -> [ImportGroup] -> [Text] -> Scaffolding ()
196scaffoldModule mn exts exports imports code =
197 saveHaskellModule mn $
198 intercalate newline
199 [ extensions exts
200 , machineGeneratedWarning
201 , moduleDeclaration mn exports imports
202 , code
203 ]
204
205renderExports :: [Export] -> [Text]
206renderExports exports =
207 let formatExport (First e) = sformat (" " % fExport) e
208 formatExport (Following e) = sformat (", " % fExport) e
209 formatExport (Skipped e) = sformat (" " % fExport) e
210 fExport =
211 let f (Comment t) = bprint ("-- " % stext) t
212 f (Name t) = bprint stext t
213 in later f
214 parensOnFirstLine [] = []
215 parensOnFirstLine (firstLine : rest) = ("(" <> T.drop 1 firstLine) : rest
216 ls = parensOnFirstLine (formatExport <$> tag exports) <> [ ") where" ]
217 in indent <$> ls
218
219data Export = Name Text
220 | Comment Text
221
222instance IsString Export where
223 fromString = Name . fromString
224
225data Tag a = First a
226 | Following a
227 | Skipped a
228
229tag :: [Export] -> [Tag Export]
230tag =
231 let skipAll = fmap Skipped
232 tagFirst [] = []
233 tagFirst (elt : others) = First elt : tagOthers others
234 tagOthers = fmap tagOther
235 tagOther v | isComment v = Skipped v
236 | otherwise = Following v
237 merge (xs, ys) = xs <> ys
238 in merge . bimap skipAll tagFirst . span isComment
239
240isComment :: Export -> Bool
241isComment (Comment _) = True
242isComment _ = False
243
244newtype ModuleAlias = ModuleAlias { getModuleAlias :: Text } deriving newtype (IsString)
245
246singleImport :: Import -> ImportGroup
247singleImport = ImportGroup . pure
248
249newtype ImportGroup = ImportGroup (NonEmpty Import) deriving newtype Semigroup
250
251data Import = Import ImportName [Text]
252 | ImportAll ImportName
253
254data ImportName = BasicImport ModuleName
255 | ImportAs ModuleName ModuleAlias
256 | ImportQualified ModuleName
257 | ImportQualifiedAs ModuleName ModuleAlias
258
259instance IsString ImportName where
260 fromString = BasicImport . fromString
261
262renderImports :: [ImportGroup] -> [Text]
263renderImports = intercalate newline . fmap renderImportGroup
264
265reexportAlias :: ModuleAlias -> Export
266reexportAlias = Name . sformat ("module " % fModuleAlias)
267
268renderImportGroup :: ImportGroup -> [Text]
269renderImportGroup (ImportGroup imports) = NE.toList (renderImport <$> imports)
270
271renderImport :: Import -> Text
272renderImport (ImportAll name) = sformat fImportName name
273renderImport (Import name references) =
274 sformat (fImportName % " " % parens stext) name (commaSeparated references)
275
276fImportName :: Format r (ImportName -> r)
277fImportName =
278 let
279 build (BasicImport name) = bprint ("import " % fModuleName) name
280 build (ImportAs name alias) = bprint ("import " % fModuleName % " as " % fModuleAlias) name alias
281 build (ImportQualified name) = bprint ("import qualified " % fModuleName) name
282 build (ImportQualifiedAs name alias) = bprint ("import qualified " % fModuleName % " as " % fModuleAlias) name alias
283 in later build
284
285fModuleAlias :: Format r (ModuleAlias -> r)
286fModuleAlias = mapf getModuleAlias stext
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Commons/Logging.hs b/scaffolder/src/Text/Edifact/Scaffolder/Commons/Logging.hs
new file mode 100644
index 0000000..1287f7f
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Commons/Logging.hs
@@ -0,0 +1,11 @@
1module Text.Edifact.Scaffolder.Commons.Logging
2 ( say
3 ) where
4
5import Control.Monad.IO.Class (MonadIO, liftIO)
6import qualified Data.Text.Lazy.Builder as TLB (toLazyText)
7import qualified Data.Text.Lazy.IO as TLIO (putStrLn)
8import Formatting as F (Format, runFormat)
9
10say :: MonadIO m => Format (m ()) a -> a
11say m = runFormat m (liftIO . TLIO.putStrLn . TLB.toLazyText)
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Commons/Parsing.hs b/scaffolder/src/Text/Edifact/Scaffolder/Commons/Parsing.hs
new file mode 100644
index 0000000..24f8f80
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Commons/Parsing.hs
@@ -0,0 +1,122 @@
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE TupleSections #-}
3
4module Text.Edifact.Scaffolder.Commons.Parsing
5 ( -- *
6 maybeParse
7 , skipBeginning
8 , single
9 , silent
10 -- *
11 , listElements
12 -- *
13 , presenceParser
14 , stringToPresenceParser
15 -- *
16 , messageCodeParser
17 -- *
18 , scanDependencies
19 , scan
20 , scanUntil
21 ) where
22
23import Text.Edifact.Scaffolder.Commons.Logging (say)
24import Text.Edifact.Scaffolder.Commons.Types
25
26import Control.Monad.IO.Class (liftIO)
27import Control.Monad.Identity (Identity)
28import Control.Monad.Reader (asks, local)
29import Data.Bifunctor (first)
30import Data.List (sort)
31import Data.List.NonEmpty (NonEmpty, nonEmpty)
32import Data.Maybe (catMaybes)
33import Data.String (fromString)
34import Data.Text (Text)
35import Formatting as F (shown)
36import System.Directory (listDirectory)
37import System.FilePath ((</>))
38import Text.Parsec (Parsec, SourceName,
39 Stream, anyChar, char,
40 choice, count,
41 endOfLine, eof,
42 lookAhead, many,
43 many1, manyTill,
44 oneOf, optionMaybe,
45 runParser, string,
46 try, upper, (<?>))
47
48maybeParse :: (Show a, Stream s Identity t, Monoid u) => SourceName -> Parsec s u a -> s -> Scaffolding (Maybe a)
49maybeParse source parser input =
50 let interpretParsingResult (Right v) _ = pure (Just v)
51 interpretParsingResult e True = Nothing <$ say shown e
52 interpretParsingResult _ False = pure Nothing
53 shouldDebug = asks debugParsing
54 in shouldDebug >>= interpretParsingResult (runParser parser mempty source input)
55
56-- | Disable parsing error logging locally
57silent :: Scaffolding a -> Scaffolding a
58silent = local disableDebugging
59
60-- | Let you traverse a directory and filter files matching a parser.
61-- The filename is then paired with the matched value
62listElements :: (Show elt, Ord elt) => FilePath -> Parsec String () elt -> Scaffolding [(FilePath, elt)]
63listElements subpath parser = do
64 home <- getSpecificationHome
65 let directory = home </> subpath
66 files <- sort <$> liftIO (listDirectory directory)
67 let prependDirectory f = directory </> f
68 fmap (first prependDirectory) . catMaybes <$> traverse (extractElement parser) files
69
70getSpecificationHome :: Scaffolding FilePath
71getSpecificationHome =
72 let concatenate path (Revision rev) = path </> rev
73 in asks (concatenate . specificationsHome) <*> asks revision
74
75extractElement :: Show elt => Parsec String () elt -> FilePath -> Scaffolding (Maybe (FilePath, elt))
76extractElement parser path = silent (fmap (path,) <$> maybeParse path parser path)
77
78skipBeginning :: Stream s Identity Char => Parsec s () a -> Parsec s () a
79skipBeginning p = manyTill anyChar (try (lookAhead p)) *> p
80
81single :: Stream s Identity Char => Parsec s u a -> Parsec s u [a]
82single = count 1
83
84presenceParser :: Stream s Identity Char => Parsec s u Presence
85presenceParser =
86 choice [ Mandatory <$ char 'M'
87 , Optional <$ char 'C'
88 ] <?> "Presence"
89
90stringToPresenceParser :: Stream s Identity Char => Parsec s u Text
91stringToPresenceParser = fromString <$>
92 manyTill anyChar (try $ lookAhead $ many1 (string " ") >> presenceParser >> string " " >> many (oneOf " 0123456789"))
93 <?> "Description"
94
95messageCodeParser :: Stream s Identity Char => Parsec s u MessageCode
96messageCodeParser = fromString <$> count 6 upper
97
98scanDependencies :: (Monoid u, Show result) => FilePath -> Parsec String u [result] -> Scaffolding (Maybe (NonEmpty result))
99scanDependencies file parser =
100 let readLines = liftIO (readFile file)
101 in readLines >>= fmap (nonEmpty =<<) . maybeParse file parser
102
103scan :: Stream s Identity Char => [Parsec s u [a]] -> Parsec s u [a]
104scan scanners =
105 let parsers = (scanLine <$> scanners) <> [skipLine]
106 end = choice [ () <$ try endOfLine
107 , () <$ eof
108 ]
109 scanLine p = optionMaybe (try p) <* end
110 skipLine = Nothing <$ manyTill anyChar end
111 in concat . catMaybes <$> manyTill (choice parsers) eof
112
113scanUntil :: Stream s Identity Char => [Parsec s u a] -> Parsec s u a
114scanUntil scanners =
115 let parsers = scanLine <$> scanners
116 end = choice [ () <$ try endOfLine
117 , () <$ eof
118 ]
119 searching = choice $ fmap (() <$) parsers <> [ () <$ eof ]
120 scanLine p = p <* end
121 skipLine = manyTill anyChar end
122 in manyTill skipLine (try $ lookAhead searching) >> try (choice parsers)
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Commons/Text.hs b/scaffolder/src/Text/Edifact/Scaffolder/Commons/Text.hs
new file mode 100644
index 0000000..ef4e805
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Commons/Text.hs
@@ -0,0 +1,91 @@
1{-# LANGUAGE DerivingStrategies #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE OverloadedStrings #-}
4
5module Text.Edifact.Scaffolder.Commons.Text
6 ( -- *
7 indent
8 , quote
9 , haskellList
10 , commaSeparated
11 -- *
12 , newline
13 -- *
14 , formatSpecification
15 -- *
16 , extensions
17 ) where
18
19
20import Text.Edifact.Scaffolder.Commons.Types (LanguageExtension (..))
21
22import Control.Category ((>>>))
23import Data.Char (isSpace)
24import Data.List (dropWhileEnd)
25import Data.String (IsString)
26import Data.Text (Text)
27import qualified Data.Text as T (all, dropWhileEnd,
28 null)
29import Formatting as F (mapf, sformat,
30 stext, string, (%))
31
32formatSpecification :: [Text] -> [Text]
33formatSpecification = cleanEmptyLines
34 >>> fmap quoteLine
35 >>> prependQuote
36
37prependQuote :: [Text] -> [Text]
38prependQuote ls =
39 [ "-- | Derived from this specification:"
40 , "--"
41 ] <> ls
42
43cleanEmptyLines :: [Text] -> [Text]
44cleanEmptyLines = dropWhile blank >>> dropWhileEnd blank
45
46blank :: Text -> Bool
47blank t = T.null t || T.all isSpace t
48
49quoteLine :: Text -> Text
50quoteLine = haskellQuote >>> cleanWhitespaces
51
52haskellQuote :: Text -> Text
53haskellQuote line = "-- > " <> line
54
55cleanWhitespaces :: Text -> Text
56cleanWhitespaces = T.dropWhileEnd (== ' ')
57
58indent :: Text -> Text
59indent t = " " <> t
60
61quote :: Text -> Text
62quote t = "'" <> t <> "'"
63
64haskellList :: [Text] -> [Text]
65haskellList =
66 let prefix :: Int -> Text -> Text
67 prefix 1 dep = sformat ("[ " % F.stext) dep
68 prefix _ dep = sformat (", " % F.stext) dep
69 suffix deps = deps <> ["]"]
70 in suffix . zipWith prefix [1..]
71
72newtype CommaSeparated = CommaSeparated { getCommaSeparated :: Text } deriving newtype (IsString, Eq)
73
74instance Semigroup CommaSeparated where
75 t1 <> "" = t1
76 "" <> t2 = t2
77 t1 <> t2 = CommaSeparated (getCommaSeparated t1 <> ", " <> getCommaSeparated t2)
78
79instance Monoid CommaSeparated where
80 mempty = ""
81
82commaSeparated :: Foldable f => f Text -> Text
83commaSeparated = getCommaSeparated . foldMap CommaSeparated
84
85newline :: [Text]
86newline = [""]
87
88extensions :: [LanguageExtension] -> [Text]
89extensions =
90 let fExtension = "{-# LANGUAGE " % mapf getLanguageExtension F.string % " #-}"
91 in fmap (sformat fExtension)
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Commons/Types.hs b/scaffolder/src/Text/Edifact/Scaffolder/Commons/Types.hs
new file mode 100644
index 0000000..4d1c0a6
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Commons/Types.hs
@@ -0,0 +1,72 @@
1{-# LANGUAGE DerivingStrategies #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3
4module Text.Edifact.Scaffolder.Commons.Types
5 ( -- * Codes of elements
6 MessageCode(..)
7 , GroupCode(..)
8 , SegmentCode(..)
9 , SegmentName(..)
10 , CompositeCode (..)
11 , CompositeName (..)
12 , SimpleCode(..)
13 , SimpleName(..)
14 -- * Ordering of elements
15 , Position(..)
16 -- * Attributes
17 , Presence(..)
18 -- *
19 , ModuleName(..)
20 , (<.>)
21 -- *
22 , LanguageExtension(..)
23 -- *
24 , Scaffolding
25 , Revision(..)
26 , ScaffoldingEnv(..)
27 , disableDebugging
28 ) where
29
30import Control.Monad.Reader (ReaderT)
31import Data.String (IsString)
32
33newtype MessageCode = MessageCode { getMessageCode :: String } deriving newtype (Show, Eq, Ord, IsString)
34newtype GroupCode = GroupCode { getGroupCode :: String } deriving newtype (Show, Eq, Ord, IsString)
35newtype SegmentCode = SegmentCode { getSegmentCode :: String } deriving newtype (Show, Eq, Ord, IsString)
36newtype SegmentName = SegmentName { getSegmentName :: String } deriving newtype (Show, Eq, Ord, IsString)
37newtype CompositeCode = CompositeCode { getCompositeCode :: String } deriving newtype (Show, Eq, Ord, IsString)
38newtype CompositeName = CompositeName { getCompositeName :: String } deriving newtype (Show, Eq, Ord, IsString)
39newtype SimpleCode = SimpleCode { getSimpleCode :: String } deriving newtype (Show, Eq, Ord, IsString)
40newtype SimpleName = SimpleName { getSimpleName :: String } deriving newtype (Show, Eq, Ord, IsString)
41
42newtype Position = Position { getPosition :: String } deriving newtype (Show, Eq, Ord, IsString)
43
44data Presence = Mandatory
45 | Optional
46 deriving (Show, Eq, Ord)
47
48newtype ModuleName = ModuleName { getModuleName :: String } deriving newtype (Show, Eq, IsString)
49
50instance Semigroup ModuleName where
51 (<>) = (<.>)
52
53(<.>) :: ModuleName -> ModuleName -> ModuleName
54(ModuleName parent) <.> (ModuleName child) = ModuleName (parent <> "." <> child)
55
56newtype LanguageExtension = LanguageExtension { getLanguageExtension :: String } deriving newtype IsString
57
58type Scaffolding = ReaderT ScaffoldingEnv IO
59
60newtype Revision = Revision { getRevision :: String } deriving newtype (Show, Eq, IsString)
61
62data ScaffoldingEnv =
63 ScaffoldingEnv
64 { revision :: Revision
65 , hostModule :: ModuleName
66 , specificationsHome :: FilePath
67 , targetDirectory :: FilePath
68 , debugParsing :: Bool
69 }
70
71disableDebugging :: ScaffoldingEnv -> ScaffoldingEnv
72disableDebugging env = env { debugParsing = False }
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Composites.hs b/scaffolder/src/Text/Edifact/Scaffolder/Composites.hs
new file mode 100644
index 0000000..07ef32a
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Composites.hs
@@ -0,0 +1,53 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Text.Edifact.Scaffolder.Composites
4 ( composites
5 ) where
6
7import Text.Edifact.Scaffolder.Commons
8
9import Text.Edifact.Scaffolder.Composites.Dependencies
10import Text.Edifact.Scaffolder.Composites.Elements
11import Text.Edifact.Scaffolder.Composites.Implementation
12import Text.Edifact.Scaffolder.Composites.Specification
13import Text.Edifact.Scaffolder.Composites.Types
14
15import Formatting
16
17composites :: Scaffolding ()
18composites = listComposites >>= scaffoldElements parentCompositeModule compositeModule
19
20parentCompositeModule :: NonEmpty (ElementWithDefinition CompositeCode) -> Scaffolding ()
21parentCompositeModule = parentModule "Composites" "C" compositeModuleName
22
23compositeModuleName :: ModuleName -> CompositeCode -> ModuleName
24compositeModuleName mn code = mn <.> fromString (getCompositeCode code)
25
26compositeModule :: ElementWithDefinition CompositeCode -> Scaffolding ()
27compositeModule (inputFile, code) = do
28 moduleName <- getRootModuleNameFor (compositeModuleName "Composites" code)
29 dependencies <- scanDependencies inputFile (snd <$> specificationParser)
30 specification <- includeSpecification inputFile
31 let parserFunction = fCompositeParserFunction
32 fDescription = "Composite " % fCompositeCode
33 parserNotYetImplemented = sformat (notYetImplemented fDescription) code
34 defaultImplementation = haskellList [ parserNotYetImplemented ]
35 elements = sort . nub . fmap dependencyElement <$> dependencies
36 implementation = maybe defaultImplementation toImplementation dependencies
37 buildDependencies b = fromMaybe [] <$> traverse b elements
38 dependenciesReexports <- buildDependencies mkDependenciesReexports
39 dependenciesImports <- buildDependencies mkDependenciesImports
40 dependenciesHaddock <- buildDependencies mkDependenciesHaddock
41 let exports = Comment "* Definition"
42 : Name (sformat parserFunction code)
43 : dependenciesReexports
44 imports = dependenciesImports
45 <> [ importCombinators ]
46 <> maybe [ importNotYetImplementedHelper ] (const []) dependencies
47 documentation = specification <> dependenciesHaddock
48 signature = sformat (fParserSignature parserFunction) code
49 definition = [ sformat (fParserDeclaration parserFunction) code
50 , indent (sformat ("composite " % quoted fCompositeCode) code)
51 ] <> (indent . indent <$> implementation)
52 parser = signature : definition
53 scaffoldModule moduleName ["OverloadedStrings"] exports imports (documentation <> parser)
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Composites/Dependencies.hs b/scaffolder/src/Text/Edifact/Scaffolder/Composites/Dependencies.hs
new file mode 100644
index 0000000..51d45bf
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Composites/Dependencies.hs
@@ -0,0 +1,20 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Text.Edifact.Scaffolder.Composites.Dependencies
4 ( -- *
5 mkDependenciesHaddock
6 , mkDependenciesImports
7 , mkDependenciesReexports
8 ) where
9
10import Text.Edifact.Scaffolder.Commons
11import Text.Edifact.Scaffolder.Composites.Types
12
13mkDependenciesReexports :: NonEmpty Element -> Scaffolding [Export]
14mkDependenciesReexports = reexportDependencies fElement
15
16mkDependenciesImports :: NonEmpty Element -> Scaffolding [ImportGroup]
17mkDependenciesImports = fmap (pure . singleImport) . importDependencies "Simples" fElement
18
19mkDependenciesHaddock :: NonEmpty Element -> Scaffolding [Text]
20mkDependenciesHaddock = haddockDependencies fElement
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Composites/Elements.hs b/scaffolder/src/Text/Edifact/Scaffolder/Composites/Elements.hs
new file mode 100644
index 0000000..acfcbdb
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Composites/Elements.hs
@@ -0,0 +1,20 @@
1module Text.Edifact.Scaffolder.Composites.Elements
2 ( listComposites
3 ) where
4
5import Text.Edifact.Scaffolder.Commons
6
7import Data.Char (toUpper)
8import Text.Parsec (count, digit, eof, oneOf,
9 string)
10import Text.Parsec.String (Parser)
11
12listComposites :: Scaffolding [ElementWithDefinition CompositeCode]
13listComposites = listElements "composites" compositeCodeParser
14
15compositeCodeParser :: Parser CompositeCode
16compositeCodeParser = do
17 initial <- toUpper <$> oneOf "ce"
18 rest <- count 3 digit
19 _ <- string ".txt"
20 CompositeCode (initial : rest) <$ eof
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Composites/Implementation.hs b/scaffolder/src/Text/Edifact/Scaffolder/Composites/Implementation.hs
new file mode 100644
index 0000000..0f3e939
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Composites/Implementation.hs
@@ -0,0 +1,19 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Text.Edifact.Scaffolder.Composites.Implementation
4 ( -- *
5 toImplementation
6 ) where
7
8import Text.Edifact.Scaffolder.Commons
9import Text.Edifact.Scaffolder.Composites.Types
10
11import Data.List.NonEmpty as NE (toList)
12import Formatting
13
14toImplementation :: NonEmpty Dependency -> [Text]
15toImplementation = haskellList . fmap callDependency . NE.toList
16
17callDependency :: Dependency -> Text
18callDependency (Dependency pos element presence) =
19 sformat (quoted fPosition % " .@ " % fPresence % " " % fElement) pos presence element
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Composites/Specification.hs b/scaffolder/src/Text/Edifact/Scaffolder/Composites/Specification.hs
new file mode 100644
index 0000000..0bb749d
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Composites/Specification.hs
@@ -0,0 +1,69 @@
1module Text.Edifact.Scaffolder.Composites.Specification
2 ( -- *
3 specificationParser
4 , listSimples
5 ) where
6
7import Text.Edifact.Scaffolder.Commons
8import Text.Edifact.Scaffolder.Composites.Types
9
10import Text.Parsec as P (anyChar, count,
11 digit,
12 endOfLine, many,
13 many1, manyTill,
14 oneOf, skipMany,
15 string, try,
16 (<?>))
17import Text.Parsec.String (Parser)
18
19specificationParser :: Parser ((CompositeCode, CompositeName), [Dependency])
20specificationParser = do
21 compositeInfo <- scanUntil [ compositeParser ]
22 dependencies <- scan [ inLine dependencyParser ] <?> "Composites specification"
23 pure (compositeInfo, dependencies)
24
25listSimples :: Parser (CompositeCode, [SimpleCode])
26listSimples = do
27 parsed <- specificationParser
28 pure (fst $ fst parsed, getElementSimpleCode . dependencyElement <$> snd parsed)
29
30compositeParser :: Parser (CompositeCode, CompositeName)
31compositeParser = do
32 _ <- count 6 (oneOf "+*#|X ")
33 skipMany (string " ")
34 code <- compositeCodeParser
35 _ <- string " "
36 name <- CompositeName <$> manyTill anyChar (() <$ try endOfLine)
37 pure (code, name)
38
39compositeCodeParser :: Parser CompositeCode
40compositeCodeParser = do
41 initial <- oneOf "CE"
42 rest <- count 3 digit
43 pure (fromString (initial : rest))
44
45dependencyParser :: Parser Dependency
46dependencyParser =
47 Dependency <$> positionParser
48 <* many1 (oneOf "+*#|-X ")
49 <*> elementParser
50 <* stringToPresenceParser
51 <* many1 (string " ")
52 <*> presenceParser
53 <?> "Dependency"
54
55inLine :: Parser a -> Parser [a]
56inLine p = single (many (string " ") *> p <* filler)
57
58filler :: Parser ()
59filler = () <$ many (oneOf "an.0123456789 ")
60
61positionParser :: Parser Position
62positionParser =
63 fromString <$> count 3 digit
64 <?> "Position"
65
66elementParser :: Parser Element
67elementParser =
68 fromString <$> count 4 digit
69 <?> "Element"
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Composites/Types.hs b/scaffolder/src/Text/Edifact/Scaffolder/Composites/Types.hs
new file mode 100644
index 0000000..c7a676f
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Composites/Types.hs
@@ -0,0 +1,18 @@
1{-# LANGUAGE DerivingStrategies #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3
4module Text.Edifact.Scaffolder.Composites.Types where
5
6import Text.Edifact.Scaffolder.Commons
7
8import Formatting
9
10data Dependency = Dependency { dependencyPosition :: Position
11 , dependencyElement :: Element
12 , dependencyPresence :: Presence
13 } deriving Show
14
15newtype Element = Simple { getElementSimpleCode :: SimpleCode } deriving newtype (Show, Eq, Ord, IsString)
16
17fElement :: Format r (Element -> r)
18fElement = mapf getElementSimpleCode fSimpleParserFunction
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Messages.hs b/scaffolder/src/Text/Edifact/Scaffolder/Messages.hs
new file mode 100644
index 0000000..8919a82
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Messages.hs
@@ -0,0 +1,54 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Text.Edifact.Scaffolder.Messages
4 ( messages
5 ) where
6
7import Text.Edifact.Scaffolder.Commons
8
9import Text.Edifact.Scaffolder.Messages.Dependencies
10import Text.Edifact.Scaffolder.Messages.Elements
11import Text.Edifact.Scaffolder.Messages.Implementation
12import Text.Edifact.Scaffolder.Messages.Specification
13import Text.Edifact.Scaffolder.Messages.Types
14
15import Formatting
16
17messages :: Scaffolding ()
18messages = listMessages >>= scaffoldElements parentMessageModule messageModule
19
20parentMessageModule :: NonEmpty (ElementWithDefinition MessageCode) -> Scaffolding ()
21parentMessageModule = parentModule "Messages" "M" messageModuleName
22
23messageModuleName :: ModuleName -> MessageCode -> ModuleName
24messageModuleName mn code = mn <.> fromString (getMessageCode code)
25
26messageModule :: ElementWithDefinition MessageCode -> Scaffolding ()
27messageModule (inputFile, code) = do
28 moduleName <- getRootModuleNameFor (messageModuleName "Messages" code)
29 dependencies <- scanDependencies inputFile specificationParser
30 specification <- includeSpecification inputFile
31 let parserFunction = fMessageParserFunction
32 fDescription = "Message " % fMessageCode
33 parserNotYetImplemented = sformat (notYetImplemented fDescription) code
34 defaultImplementation = haskellList [ parserNotYetImplemented ]
35 elements = sort . nub . fmap getElement <$> dependencies
36 implementation = maybe defaultImplementation (toImplementation code) dependencies
37 buildDependencies b = fromMaybe [] <$> traverse b elements
38 dependenciesReexports <- buildDependencies mkDependenciesReexports
39 dependenciesImports <- buildDependencies mkDependenciesImports
40 dependenciesHaddock <- buildDependencies mkDependenciesHaddock
41 let exports = Comment "* Definition"
42 : Name (sformat parserFunction code)
43 : dependenciesReexports
44 segmentImport = singleImport (ImportAll "Text.Edifact.Common.Segments")
45 imports = maybe importNotYetImplementedHelper (const segmentImport) dependencies
46 : dependenciesImports
47 <> [ importCombinators ]
48 documentation = specification <> dependenciesHaddock
49 signature = sformat (fParserSignature parserFunction) code
50 definition = [ sformat (fParserDeclaration parserFunction) code
51 , indent (sformat ("message " % quoted fMessageCode) code)
52 ] <> (indent . indent <$> implementation)
53 parser = signature : definition
54 scaffoldModule moduleName ["OverloadedStrings"] exports imports (documentation <> parser)
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Messages/Dependencies.hs b/scaffolder/src/Text/Edifact/Scaffolder/Messages/Dependencies.hs
new file mode 100644
index 0000000..fbcc56b
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Messages/Dependencies.hs
@@ -0,0 +1,47 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Text.Edifact.Scaffolder.Messages.Dependencies
4 ( -- *
5 mkDependenciesHaddock
6 , mkDependenciesImports
7 , mkDependenciesReexports
8 ) where
9
10import Text.Edifact.Scaffolder.Commons
11import Text.Edifact.Scaffolder.Messages.Types
12
13import Control.Monad ((>=>))
14import Data.List (isPrefixOf)
15import Data.List.NonEmpty as NE (nonEmpty, toList)
16import Data.Maybe (mapMaybe)
17
18unlessIsCommon :: SegmentCode -> Maybe SegmentCode
19unlessIsCommon sc@(SegmentCode code) | "U" `isPrefixOf` code = Nothing
20 | otherwise = Just sc
21
22mkDependenciesReexports :: NonEmpty Element -> Scaffolding [Export]
23mkDependenciesReexports = mkSegmentDependencies mkSegmentDependenciesReexports
24
25mkSegmentDependenciesReexports :: NonEmpty SegmentCode -> Scaffolding [Export]
26mkSegmentDependenciesReexports = reexportDependencies fSegmentParserFunction
27
28mkDependenciesImports :: NonEmpty Element -> Scaffolding [ImportGroup]
29mkDependenciesImports = mkSegmentDependencies mkSegmentDependenciesImports
30
31mkSegmentDependencies :: (NonEmpty SegmentCode -> Scaffolding [output])
32 -> (NonEmpty Element -> Scaffolding [output])
33mkSegmentDependencies mk = maybe (pure []) mk . filterSegmentDependencies
34
35filterSegmentDependencies :: NonEmpty Element -> Maybe (NonEmpty SegmentCode)
36filterSegmentDependencies =
37 fmap nub . nonEmpty . mapMaybe (getSegment >=> unlessIsCommon) . NE.toList
38
39mkSegmentDependenciesImports :: NonEmpty SegmentCode -> Scaffolding [ImportGroup]
40mkSegmentDependenciesImports =
41 fmap (pure . singleImport) . importDependencies "Segments" fSegmentParserFunction
42
43mkDependenciesHaddock :: NonEmpty Element -> Scaffolding [Text]
44mkDependenciesHaddock = mkSegmentDependencies mkSegmentDependenciesHaddock
45
46mkSegmentDependenciesHaddock :: NonEmpty SegmentCode -> Scaffolding [Text]
47mkSegmentDependenciesHaddock = haddockDependencies fSegmentParserFunction
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Messages/Elements.hs b/scaffolder/src/Text/Edifact/Scaffolder/Messages/Elements.hs
new file mode 100644
index 0000000..fb590ad
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Messages/Elements.hs
@@ -0,0 +1,22 @@
1module Text.Edifact.Scaffolder.Messages.Elements
2 ( listMessages
3 ) where
4
5import Text.Edifact.Scaffolder.Commons
6
7import Data.Char (toUpper)
8import Text.Parsec (count, eof, lower, string,
9 (<?>))
10import Text.Parsec.String (Parser)
11
12-- | List elements
13listMessages :: Scaffolding [ElementWithDefinition MessageCode]
14listMessages = listElements "messages" messageFilenameParser
15
16messageFilenameParser :: Parser MessageCode
17messageFilenameParser =
18 let mkCode = MessageCode . fmap toUpper
19 in mkCode <$> count 6 lower
20 <* string "_s.txt"
21 <* eof
22 <?> "MessageCode"
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Messages/Implementation.hs b/scaffolder/src/Text/Edifact/Scaffolder/Messages/Implementation.hs
new file mode 100644
index 0000000..121aa45
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Messages/Implementation.hs
@@ -0,0 +1,114 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Text.Edifact.Scaffolder.Messages.Implementation
4 ( -- *
5 toImplementation
6 ) where
7
8import Text.Edifact.Scaffolder.Commons
9import Text.Edifact.Scaffolder.Messages.Types
10
11import Control.Monad.State.Strict (State, evalState, gets,
12 modify)
13import Data.List.NonEmpty as NE (NonEmpty (..),
14 fromList, head,
15 toList, (<|))
16import Formatting
17
18toImplementation :: MessageCode -> NonEmpty Dependency -> [Text]
19toImplementation _ =
20 let closeList deps = deps <> [ "]" ]
21 in closeList . render . fmap concat . traverse callDependency . NE.toList
22
23render :: Rendering a -> a
24render r =
25 let initialState = RenderingContext 0 0 :| []
26 in evalState r initialState
27
28type Trail = NonEmpty
29
30data RenderingContext = RenderingContext { listPosition :: Int
31 , indentLevel :: Int
32 }
33
34type Rendering = State (Trail RenderingContext)
35
36callDependency :: Dependency -> Rendering [Text]
37callDependency (Dependency element) = renderElement element
38
39increment :: Rendering ()
40increment =
41 let mapHead f (v :| t) = f v :| t
42 in modify (mapHead (\ ctx -> ctx { listPosition = listPosition ctx + 1 }))
43
44pushIndent :: Rendering ()
45pushIndent =
46 let indentState t@(previous :| _) = RenderingContext 0 (indentLevel previous + 2) <| t
47 in modify indentState
48
49popIndent :: Rendering ()
50popIndent =
51 let pop (_ :| []) = error "Incoherent state: can't unindent anymore (this shouldn't happen)"
52 pop (_ :| up) = NE.fromList up
53 in modify pop
54
55getCurrentIndex :: Rendering Int
56getCurrentIndex = gets (listPosition . NE.head)
57
58getCurrentIndentation :: Rendering Int
59getCurrentIndentation = gets (indentLevel . NE.head)
60
61renderElement :: Element -> Rendering [Text]
62renderElement (Segment code positional) =
63 let output index indentation =
64 [ sformat (fIndentation % fIndex % " " % fPositional % " " % fSegmentParserFunction) indentation index positional code
65 ]
66 in output <$> getCurrentIndex
67 <*> getCurrentIndentation
68 <* increment
69renderElement (GroupStart code positional) =
70 let output index indentation =
71 [ sformat (fIndentation % fIndex % " " % fPositional % " (") indentation index positional
72 , sformat (fIndentation % fSegmentGroupFunction) (indentation + 1) code
73 ]
74 in output <$> getCurrentIndex
75 <*> getCurrentIndentation
76 <* increment
77 <* pushIndent
78renderElement (GroupEnd _) =
79 let output indentation =
80 [ sformat (fIndentation % "]") indentation
81 , sformat (fIndentation % ")") (indentation - 1)
82 ]
83 in output <$> getCurrentIndentation
84 <* popIndent
85
86fIndentation :: Format r (Int -> r)
87fIndentation =
88 let buildIndentation n = fromString (replicate (n * 2) ' ')
89 in later buildIndentation
90
91fIndex :: Format r (Int -> r)
92fIndex =
93 let buildIndex 0 = "["
94 buildIndex _ = ","
95 in later buildIndex
96
97fPositional :: Format r (Positional -> r)
98fPositional =
99 let buildPositional (Positional p r) = bprint (quoted fPosition % " .@ " % fRepetition) p r
100 in later buildPositional
101
102fSegmentGroupFunction :: Format r (GroupCode -> r)
103fSegmentGroupFunction = "segmentGroup " % quoted fGroupCode
104
105fRepetition :: Format r (Repetition -> r)
106fRepetition =
107 let buildRepetition (Repetition Mandatory 1) = bprint "once"
108 buildRepetition (Repetition Optional 1) = bprint "maybeOnce"
109 buildRepetition (Repetition Mandatory c) = bprint ("repeatedAtLeastOnce" % " " % fCardinality) c
110 buildRepetition (Repetition Optional c) = bprint ("repeated" % " " % fCardinality) c
111 in later buildRepetition
112
113fCardinality :: Format r (Cardinality -> r)
114fCardinality = mapf getCardinality int
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Messages/Specification.hs b/scaffolder/src/Text/Edifact/Scaffolder/Messages/Specification.hs
new file mode 100644
index 0000000..b1e5c2a
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Messages/Specification.hs
@@ -0,0 +1,129 @@
1{-# LANGUAGE DerivingStrategies #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3
4module Text.Edifact.Scaffolder.Messages.Specification
5 ( -- *
6 specificationParser
7 , messageNameParser
8 , listSegments
9 ) where
10
11import Text.Edifact.Scaffolder.Commons
12import Text.Edifact.Scaffolder.Messages.Types
13
14import Data.Maybe (mapMaybe)
15import Text.Parsec
16
17type Parser = Parsec String GroupTrail
18
19newtype GroupTrail = GroupTrail [GroupCode]
20 deriving stock Show
21 deriving newtype (Semigroup, Monoid)
22
23messageNameParser :: Parser MessageCode
24messageNameParser = scanUntil [
25 manyTill anyChar (string "Message Type : ") >> MessageCode <$> count 6 upper
26 ]
27
28specificationParser :: Parser [Dependency]
29specificationParser =
30 let scanElements = scan [ segmentInLine segmentElementParser
31 , groupInLine groupStartElementParser
32 ]
33 in interpretDependencies <$> scanElements <?> "Messages specification"
34
35listSegments :: Parser [SegmentCode]
36listSegments = mapMaybe (getSegment . getElement) <$> specificationParser
37
38interpretDependencies :: [Element] -> [Dependency]
39interpretDependencies = fmap Dependency
40
41groupInLine :: Parser a -> Parser [a]
42groupInLine p = single (many (string " ") *> p <* countClosingGroups)
43
44countClosingGroups :: Parser Int
45countClosingGroups =
46 let parser = many1 (char '-')
47 *> many1 (char '+')
48 <* many (char '|')
49 in length <$> parser
50
51closingGroupTrail :: Parser [Element]
52closingGroupTrail =
53 let groupEndParser = GroupEnd <$> popFromTrail
54 in countClosingGroups >>= flip count groupEndParser
55
56groupStartElementParser :: Parser Element
57groupStartElementParser =
58 let parseStart pos code rep = GroupStart code (Positional pos rep)
59 in parseStart <$> positionParser
60 <* many1 (choice [ () <$ try (oneOf "+*#|X "), () <$ try (string "- ") ])
61 <*> groupCodeParser
62 <* many1 (char ' ')
63 <*> repetitionParser
64 <?> "GroupElement"
65
66groupCodeParser :: Parser GroupCode
67groupCodeParser =
68 let parser = manyTill (char '-') (try $ string "-- Segment group")
69 *> many1 (char ' ')
70 *> many1 digit
71 <* many1 space
72 <* many1 (char '-')
73 group = GroupCode <$> parser
74 in group >>= appendToTrail <?> "GroupCodeParser"
75
76appendToTrail :: GroupCode -> Parser GroupCode
77appendToTrail code =
78 let append (GroupTrail trail) = GroupTrail (code : trail)
79 in code <$ modifyState append
80
81popFromTrail :: Parser GroupCode
82popFromTrail = do
83 previous <- getState
84 case previous of
85 GroupTrail (current : trail) -> current <$ putState (GroupTrail trail)
86 GroupTrail [] -> unexpected "GroupEnd, when state is currently clear"
87
88segmentTrail :: Parser [a]
89segmentTrail = [] <$ (many1 (char ' ') <* many (char '|'))
90
91segmentInLine :: Parser Element -> Parser [Element]
92segmentInLine p = do
93 segment <- many (string " ") *> p
94 trail <- choice [ try closingGroupTrail
95 , try segmentTrail
96 ]
97 pure (segment : trail)
98
99repetitionParser :: Parser Repetition
100repetitionParser =
101 Repetition <$> presenceParser
102 <* many1 (string " ")
103 <*> cardinalityParser
104 <?> "Repetition"
105
106positionParser :: Parser Position
107positionParser =
108 fromString <$> many1 digit
109 <?> "Position"
110
111segmentElementParser :: Parser Element
112segmentElementParser =
113 let parseSegment pos code rep = Segment code (Positional pos rep)
114 in parseSegment <$> positionParser
115 <* many1 (oneOf "+*#|-X ")
116 <*> segmentCodeParser
117 <* many1 (string " ")
118 <* stringToPresenceParser
119 <* many1 (string " ")
120 <*> repetitionParser
121 <?> "SegmentElement"
122
123segmentCodeParser :: Parser SegmentCode
124segmentCodeParser =
125 fromString <$> count 3 upper
126 <?> "SegmentCode"
127
128cardinalityParser :: Parser Cardinality
129cardinalityParser = Cardinality . read <$> many1 digit
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Messages/Types.hs b/scaffolder/src/Text/Edifact/Scaffolder/Messages/Types.hs
new file mode 100644
index 0000000..73cc702
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Messages/Types.hs
@@ -0,0 +1,36 @@
1{-# LANGUAGE DerivingStrategies #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3
4module Text.Edifact.Scaffolder.Messages.Types where
5
6import Text.Edifact.Scaffolder.Commons
7
8import Data.Function (on)
9import Data.Ord (comparing)
10
11newtype Dependency = Dependency { getElement :: Element } deriving newtype (Show, Ord, Eq)
12
13data Repetition = Repetition Presence Cardinality deriving Show
14
15data Positional = Positional { positionalPosition :: Position
16 , positionalRepetition :: Repetition
17 } deriving (Show)
18
19instance Eq Positional where
20 (==) = (==) `on` positionalPosition
21
22instance Ord Positional where
23 compare = comparing positionalPosition
24
25data Element = Segment SegmentCode Positional
26 | GroupStart GroupCode Positional
27 | GroupEnd GroupCode
28 deriving (Show, Ord, Eq)
29
30getSegment :: Element -> Maybe SegmentCode
31getSegment (Segment code _) = Just code
32getSegment _ = Nothing
33
34newtype Cardinality = Cardinality { getCardinality :: Int }
35 deriving stock (Show)
36 deriving newtype (Eq, Num)
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Root.hs b/scaffolder/src/Text/Edifact/Scaffolder/Root.hs
new file mode 100644
index 0000000..54a48d5
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Root.hs
@@ -0,0 +1,25 @@
1{-# LANGUAGE OverloadedLists #-}
2{-# LANGUAGE OverloadedStrings #-}
3
4module Text.Edifact.Scaffolder.Root
5 ( rootModule
6 ) where
7
8import Text.Edifact.Scaffolder.Commons
9
10rootModule :: Scaffolding ()
11rootModule = getRootModuleName >>= generateRootModule
12
13generateRootModule :: ModuleName -> Scaffolding ()
14generateRootModule mn =
15 let exports = [ reexportAlias subModulesAlias ]
16 subModulesAlias = "S"
17 importSubModule sm = ImportAll (ImportAs (mn <.> sm) subModulesAlias)
18 subModules = [ "Composites"
19 , "Messages"
20 , "Segments"
21 ]
22 imports = [ ImportGroup (importSubModule <$> subModules) ]
23 in
24 saveHaskellModule mn $
25 moduleDeclaration mn exports imports
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Segments.hs b/scaffolder/src/Text/Edifact/Scaffolder/Segments.hs
new file mode 100644
index 0000000..a0b6c3d
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Segments.hs
@@ -0,0 +1,54 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Text.Edifact.Scaffolder.Segments
4 ( segments
5 ) where
6
7import Text.Edifact.Scaffolder.Commons
8
9import Text.Edifact.Scaffolder.Segments.Dependencies
10import Text.Edifact.Scaffolder.Segments.Elements
11import Text.Edifact.Scaffolder.Segments.Implementation
12import Text.Edifact.Scaffolder.Segments.Specification
13import Text.Edifact.Scaffolder.Segments.Types
14
15import Data.List.NonEmpty (nubBy)
16import Formatting
17
18segments :: Scaffolding ()
19segments = listSegments >>= scaffoldElements parentSegmentModule segmentModule
20
21parentSegmentModule :: NonEmpty (ElementWithDefinition SegmentCode) -> Scaffolding ()
22parentSegmentModule = parentModule "Segments" "S" segmentModuleName
23
24segmentModuleName :: ModuleName -> SegmentCode -> ModuleName
25segmentModuleName mn code = mn <.> fromString (getSegmentCode code)
26
27segmentModule :: ElementWithDefinition SegmentCode -> Scaffolding ()
28segmentModule (inputFile, code) = do
29 moduleName <- getRootModuleNameFor (segmentModuleName "Segments" code)
30 dependencies <- scanDependencies inputFile (snd <$> specificationParser)
31 specification <- includeSpecification inputFile
32 let parserFunction = fSegmentParserFunction
33 fDescription = "Segment " % fSegmentCode
34 parserNotYetImplemented = sformat (notYetImplemented fDescription) code
35 defaultImplementation = haskellList [ parserNotYetImplemented ]
36 elements = sort . nubBy (\a b -> getCode a == getCode b) . fmap dependencyElement <$> dependencies
37 implementation = maybe defaultImplementation toImplementation dependencies
38 buildDependencies b = fromMaybe [] <$> traverse b elements
39 dependenciesReexports <- buildDependencies mkDependenciesReexports
40 dependenciesImports <- buildDependencies mkDependenciesImports
41 dependenciesHaddock <- buildDependencies mkDependenciesHaddock
42 let exports = Comment "* Definition"
43 : Name (sformat parserFunction code)
44 : dependenciesReexports
45 imports = dependenciesImports
46 <> [ importCombinators ]
47 <> maybe [ importNotYetImplementedHelper ] (const []) dependencies
48 documentation = specification <> dependenciesHaddock
49 signature = sformat (fParserSignature parserFunction) code
50 definition = [ sformat (fParserDeclaration parserFunction) code
51 , indent (sformat ("segment " % quoted fSegmentCode) code)
52 ] <> (indent . indent <$> implementation)
53 parser = signature : definition
54 scaffoldModule moduleName ["OverloadedStrings"] exports imports (documentation <> parser)
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Segments/Dependencies.hs b/scaffolder/src/Text/Edifact/Scaffolder/Segments/Dependencies.hs
new file mode 100644
index 0000000..acb9ea8
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Segments/Dependencies.hs
@@ -0,0 +1,47 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Text.Edifact.Scaffolder.Segments.Dependencies
4 ( -- *
5 mkDependenciesHaddock
6 , mkDependenciesImports
7 , mkDependenciesReexports
8 ) where
9
10import Text.Edifact.Scaffolder.Commons
11import Text.Edifact.Scaffolder.Segments.Types
12
13import Data.List.NonEmpty as NE (nonEmpty, toList)
14import Data.Maybe (catMaybes, mapMaybe)
15import Formatting as F
16
17mkDependenciesReexports :: NonEmpty Element -> Scaffolding [Export]
18mkDependenciesReexports = reexportDependencies fElementFunction
19
20mkDependenciesImports :: NonEmpty Element -> Scaffolding [ImportGroup]
21mkDependenciesImports elements =
22 let filterElements optic = mapMaybe optic . NE.toList
23 in maybe [] (pure . ImportGroup) . nonEmpty . catMaybes <$>
24 sequence
25 [ mkCompositeDependenciesImports (filterElements getComposite elements)
26 , mkSimpleDependenciesImports (filterElements getSimple elements)
27 ]
28
29mkSimpleDependenciesImports :: [SimpleCode] -> Scaffolding (Maybe Import)
30mkSimpleDependenciesImports =
31 ifNonEmpty (importDependencies "Simples" fSimpleParserFunction)
32
33mkCompositeDependenciesImports :: [CompositeCode] -> Scaffolding (Maybe Import)
34mkCompositeDependenciesImports =
35 ifNonEmpty (importDependencies "Composites" fCompositeParserFunction)
36
37ifNonEmpty :: Applicative f => (NonEmpty input -> f output) -> [input] -> f (Maybe output)
38ifNonEmpty f = traverse f . nonEmpty
39
40mkDependenciesHaddock :: NonEmpty Element -> Scaffolding [Text]
41mkDependenciesHaddock = haddockDependencies fElementFunction
42
43fElementFunction :: Format r (Element -> r)
44fElementFunction =
45 let buildElementFunction (Simple code _ _ _ _) = bprint fSimpleParserFunction code
46 buildElementFunction (Composite code _ _) = bprint fCompositeParserFunction code
47 in later buildElementFunction
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Segments/Elements.hs b/scaffolder/src/Text/Edifact/Scaffolder/Segments/Elements.hs
new file mode 100644
index 0000000..4e8b39c
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Segments/Elements.hs
@@ -0,0 +1,26 @@
1module Text.Edifact.Scaffolder.Segments.Elements
2 ( listSegments
3 ) where
4
5import Text.Edifact.Scaffolder.Commons
6
7import Data.Char (isLower, toUpper)
8import Text.Parsec (eof, lower, satisfy, string,
9 (<?>))
10import Text.Parsec.String (Parser)
11
12listSegments :: Scaffolding [ElementWithDefinition SegmentCode]
13listSegments = listElements "segments" segmentCodeParser
14
15segmentCodeParser :: Parser SegmentCode
16segmentCodeParser = do
17 c1 <- lowerExceptU
18 c2 <- lower
19 c3 <- lower
20 let code = SegmentCode (toUpper <$> [c1,c2,c3])
21 code <$ string ".txt"
22 <* eof
23 <?> "SegmentCode"
24
25lowerExceptU :: Parser Char
26lowerExceptU = satisfy (\ c -> isLower c && c /= 'u')
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Segments/Implementation.hs b/scaffolder/src/Text/Edifact/Scaffolder/Segments/Implementation.hs
new file mode 100644
index 0000000..8535a17
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Segments/Implementation.hs
@@ -0,0 +1,21 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Text.Edifact.Scaffolder.Segments.Implementation
4 ( -- *
5 toImplementation
6 ) where
7
8import Text.Edifact.Scaffolder.Commons
9import Text.Edifact.Scaffolder.Segments.Types
10
11import Data.List.NonEmpty as NE (toList)
12import Formatting
13
14toImplementation :: NonEmpty Dependency -> [Text]
15toImplementation = haskellList . fmap callDependency . NE.toList
16
17callDependency :: Dependency -> Text
18callDependency (Dependency pos (Simple code _ presence _ _)) =
19 sformat ( quoted fPosition % " .@ " % fPresence % " simple" % fSimpleCode) pos presence code
20callDependency (Dependency pos (Composite code _ presence)) =
21 sformat ( quoted fPosition % " .@ " % fPresence % " composite" % fCompositeCode) pos presence code
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Segments/Specification.hs b/scaffolder/src/Text/Edifact/Scaffolder/Segments/Specification.hs
new file mode 100644
index 0000000..39a7ad4
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Segments/Specification.hs
@@ -0,0 +1,99 @@
1module Text.Edifact.Scaffolder.Segments.Specification
2 ( -- *
3 specificationParser
4 , listCompositesAndSimples
5 ) where
6
7import Text.Edifact.Scaffolder.Commons
8import Text.Edifact.Scaffolder.Segments.Types
9
10import Text.Parsec as P (anyChar, choice,
11 count, digit,
12 endOfLine, many,
13 many1, manyTill,
14 oneOf, skipMany,
15 string, try,
16 upper, (<?>))
17import Text.Parsec.String (Parser)
18
19specificationParser :: Parser ((SegmentCode, SegmentName), [Dependency])
20specificationParser = do
21 segmentInfo <- scanUntil [ segmentParser ]
22 dependencies <- scan [ inLine dependencyParser ] <?> "Segments specification"
23 pure (segmentInfo, dependencies)
24
25listCompositesAndSimples :: Parser (SegmentCode, [Element])
26listCompositesAndSimples = do
27 parsed <- specificationParser
28 pure (fst $ fst parsed, dependencyElement <$> snd parsed)
29
30segmentParser :: Parser (SegmentCode, SegmentName)
31segmentParser = do
32 _ <- count 6 (oneOf "+*#|X ")
33 skipMany (string " ")
34 code <- SegmentCode <$> count 3 upper
35 _ <- count 2 (string " ")
36 skipMany (string " ")
37 name <- SegmentName <$> manyTill anyChar (() <$ try endOfLine)
38 pure (code, name)
39
40dependencyParser :: Parser Dependency
41dependencyParser =
42 Dependency <$> positionParser
43 <* many1 (oneOf "+*#|-X ")
44 <*> elementParser
45 <?> "Dependency"
46
47inLine :: Parser a -> Parser [a]
48inLine p = single (many (string " ") *> p)
49
50positionParser :: Parser Position
51positionParser =
52 fromString <$> count 3 digit
53 <?> "Position"
54
55elementParser :: Parser Element
56elementParser =
57 choice [ compositeParser
58 , simpleParser
59 ]
60 <?> "Element"
61
62compositeParser :: Parser Element
63compositeParser = Composite <$> compositeCodeParser
64 <* many (string " ")
65 <*> stringToPresenceParser
66 <* many1 (string " ")
67 <*> presenceParser
68 <* string " "
69 <* many (oneOf " 0123456789")
70 <?> "Composite"
71
72simpleParser :: Parser Element
73simpleParser = Simple <$> (fromString <$> count 4 digit)
74 <* many1 (string " ")
75 <*> stringToPresenceParser
76 <* many1 (string " ")
77 <*> presenceParser
78 <* string " "
79 <* many (oneOf " 0123456789")
80 <*> simpleTypeParser
81 <*> simpleLengthParser
82 <?> "Simple"
83
84simpleTypeParser :: Parser SimpleType
85simpleTypeParser = choice [ Alphanumeric <$ string "an"
86 , Alphabetic <$ string "a"
87 , Numeric <$ string "n"
88 ] <?> "SimpleType"
89
90simpleLengthParser :: Parser SimpleLength
91simpleLengthParser = choice [ UpTo <$> fmap fromString (string ".." >> many1 digit)
92 , Exactly <$> (fromString <$> many1 digit)
93 ] <?> "SimpleLength"
94
95compositeCodeParser :: Parser CompositeCode
96compositeCodeParser = do
97 initial <- oneOf "CE"
98 rest <- count 3 digit
99 pure (fromString (initial : rest))
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Segments/Types.hs b/scaffolder/src/Text/Edifact/Scaffolder/Segments/Types.hs
new file mode 100644
index 0000000..6a34cbc
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Segments/Types.hs
@@ -0,0 +1,27 @@
1module Text.Edifact.Scaffolder.Segments.Types where
2
3import Text.Edifact.Scaffolder.Commons
4
5data Dependency = Dependency { dependencyPosition :: Position
6 , dependencyElement :: Element
7 } deriving Show
8
9data Element = Composite CompositeCode Text Presence
10 | Simple SimpleCode Text Presence SimpleType SimpleLength
11 deriving (Show, Eq, Ord)
12
13data SimpleType = Alphanumeric | Alphabetic | Numeric deriving (Show, Eq, Ord)
14
15data SimpleLength = Exactly Text | UpTo Text deriving (Show, Eq, Ord)
16
17getCode :: Element -> String
18getCode (Simple (SimpleCode c) _ _ _ _) = c
19getCode (Composite (CompositeCode c) _ _) = c
20
21getSimple :: Element -> Maybe SimpleCode
22getSimple (Simple c _ _ _ _) = Just c
23getSimple _ = Nothing
24
25getComposite :: Element -> Maybe CompositeCode
26getComposite (Composite c _ _) = Just c
27getComposite _ = Nothing
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Simples.hs b/scaffolder/src/Text/Edifact/Scaffolder/Simples.hs
new file mode 100644
index 0000000..95885c2
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Simples.hs
@@ -0,0 +1,41 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Text.Edifact.Scaffolder.Simples
4 ( simples
5 ) where
6
7import Text.Edifact.Scaffolder.Commons
8
9import Text.Edifact.Scaffolder.Simples.Elements
10import Text.Edifact.Scaffolder.Simples.Implementation
11import Text.Edifact.Scaffolder.Simples.Representation
12
13import Formatting
14
15simples :: Scaffolding ()
16simples = listSimples >>= scaffoldElements parentSimpleModule simpleModule
17
18parentSimpleModule :: NonEmpty (ElementWithDefinition SimpleCode) -> Scaffolding ()
19parentSimpleModule = parentModule "Simples" "S" simpleModuleName
20
21simpleModuleName :: ModuleName -> SimpleCode -> ModuleName
22simpleModuleName mn code = mn <.> fromString ("S" <> getSimpleCode code)
23
24simpleModule :: ElementWithDefinition SimpleCode -> Scaffolding ()
25simpleModule (inputFile, code) = do
26 moduleName <- getRootModuleNameFor (simpleModuleName "Simples" code)
27 representation <- extractRepresentation inputFile
28 specification <- includeSpecification inputFile
29 let parserFunction = fSimpleParserFunction
30 fDescription = "Simple " % fSimpleCode
31 defaultImplementation = sformat (notYetImplemented fDescription) code
32 implementation = maybe defaultImplementation toImplementation representation
33 exports = [ Name (sformat parserFunction code) ]
34 imports = importCombinators
35 : maybe [importNotYetImplementedHelper] (const []) representation
36 documentation = specification
37 signature = sformat (fParserSignature parserFunction) code
38 definition = [ sformat (fParserDeclaration parserFunction % " simple " % quoted fSimpleCode % " " % parens stext) code code implementation
39 ]
40 parser = signature : definition
41 scaffoldModule moduleName ["OverloadedStrings"] exports imports (documentation <> parser)
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Simples/Elements.hs b/scaffolder/src/Text/Edifact/Scaffolder/Simples/Elements.hs
new file mode 100644
index 0000000..328a5d0
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Simples/Elements.hs
@@ -0,0 +1,26 @@
1module Text.Edifact.Scaffolder.Simples.Elements
2 ( listSimples
3 ) where
4
5import Text.Edifact.Scaffolder.Commons
6
7import Text.Parsec (digit, eof, oneOf, string,
8 (<?>))
9import Text.Parsec.String (Parser)
10
11listSimples :: Scaffolding [ElementWithDefinition SimpleCode]
12listSimples = listElements "simples" simpleCodeParser
13
14simpleCodeParser :: Parser SimpleCode
15simpleCodeParser =
16 let codeParser =
17 sequence [ oneOf ['1'..'9']
18 , digit
19 , digit
20 , digit
21 ]
22 in
23 SimpleCode <$> codeParser
24 <* string ".txt"
25 <* eof
26 <?> "SimpleCode"
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Simples/Implementation.hs b/scaffolder/src/Text/Edifact/Scaffolder/Simples/Implementation.hs
new file mode 100644
index 0000000..6cfb2ab
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Simples/Implementation.hs
@@ -0,0 +1,23 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Text.Edifact.Scaffolder.Simples.Implementation
4 ( -- *
5 toImplementation
6 ) where
7
8import Text.Edifact.Scaffolder.Commons
9import Text.Edifact.Scaffolder.Simples.Types
10
11import Formatting
12
13toImplementation :: Representation -> Text
14toImplementation (Representation content (UpTo n) ) = sformat (fContent % " `upTo` " % int) content n
15toImplementation (Representation content (Exactly n)) = sformat (fContent % " `exactly` " % int) content n
16toImplementation (Representation content AnyNumber ) = sformat ("many " % fContent) content
17
18fContent :: Format t (Content -> t)
19fContent =
20 let display AlphaNumeric = "alphaNumeric"
21 display Alpha = "alpha"
22 display Numeric = "numeric"
23 in mapf display stext
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Simples/Representation.hs b/scaffolder/src/Text/Edifact/Scaffolder/Simples/Representation.hs
new file mode 100644
index 0000000..9555536
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Simples/Representation.hs
@@ -0,0 +1,47 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module Text.Edifact.Scaffolder.Simples.Representation
4 ( -- *
5 extractRepresentation
6 , representationParser
7 ) where
8
9import Text.Edifact.Scaffolder.Commons
10import Text.Edifact.Scaffolder.Simples.Types
11
12import Text.Parsec as P (char, choice,
13 digit, many1,
14 option, optional,
15 space, string, try)
16import Text.Parsec.String (Parser)
17
18extractRepresentation :: FilePath -> Scaffolding (Maybe Representation)
19extractRepresentation file =
20 let parser = skipBeginning representationParser
21 in liftIO (readFile file) >>= maybeParse file parser
22
23contentParser :: Parser Content
24contentParser =
25 choice [ AlphaNumeric <$ try (P.string "an")
26 , Alpha <$ P.string "a"
27 , Numeric <$ P.string "n"
28 ]
29
30cardinalityParser :: Parser Cardinality
31cardinalityParser =
32 option AnyNumber $
33 choice [ Exactly <$> (optional space *> numberParser)
34 , UpTo <$> (dot *> dot *> numberParser)
35 ]
36
37numberParser :: Parser Int
38numberParser = read <$> many1 digit
39
40dot :: Parser Char
41dot = P.char '.'
42
43representationParser :: Parser Representation
44representationParser =
45 let parser = Representation <$> contentParser
46 <*> cardinalityParser
47 in P.string "Repr:" *> space *> parser
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Simples/Specification.hs b/scaffolder/src/Text/Edifact/Scaffolder/Simples/Specification.hs
new file mode 100644
index 0000000..0651cbd
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Simples/Specification.hs
@@ -0,0 +1,28 @@
1module Text.Edifact.Scaffolder.Simples.Specification
2 ( -- *
3 specificationParser
4 ) where
5
6import Text.Edifact.Scaffolder.Commons
7
8import Text.Parsec as P (anyChar, count, digit,
9 endOfLine, manyTill,
10 oneOf, skipMany, string,
11 try)
12import Text.Parsec.String (Parser)
13
14specificationParser :: Parser (SimpleCode, SimpleName)
15specificationParser = scanUntil [ simpleParser ]
16
17simpleParser :: Parser (SimpleCode, SimpleName)
18simpleParser = do
19 _ <- count 3 (oneOf "+*#|-X ")
20 skipMany (string " ")
21 code <- simpleCodeParser
22 _ <- string " "
23 skipMany (string " ")
24 name <- SimpleName <$> manyTill anyChar (() <$ try endOfLine)
25 pure (code, name)
26
27simpleCodeParser :: Parser SimpleCode
28simpleCodeParser = fromString <$> count 4 digit
diff --git a/scaffolder/src/Text/Edifact/Scaffolder/Simples/Types.hs b/scaffolder/src/Text/Edifact/Scaffolder/Simples/Types.hs
new file mode 100644
index 0000000..08b6ca5
--- /dev/null
+++ b/scaffolder/src/Text/Edifact/Scaffolder/Simples/Types.hs
@@ -0,0 +1,14 @@
1module Text.Edifact.Scaffolder.Simples.Types where
2
3data Representation = Representation Content Cardinality
4 deriving Show
5
6data Content = AlphaNumeric
7 | Alpha
8 | Numeric
9 deriving Show
10
11data Cardinality = UpTo Int
12 | Exactly Int
13 | AnyNumber
14 deriving Show
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-21 11:32:26 +0000