From a9d77a20008efe82862cc1adbfa7a6d4f09f8ff7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Menou?= Date: Thu, 8 Dec 2016 10:19:15 +0200 Subject: Release code as open source --- scaffolder/.gitignore | 2 + scaffolder/Makefile | 7 + scaffolder/README.md | 50 ++++ scaffolder/app/Main.hs | 90 +++++++ scaffolder/edi-parser-scaffolder.cabal | 110 ++++++++ scaffolder/package.yaml | 53 ++++ scaffolder/src/Text/Edifact/BundleReader.hs | 59 +++++ .../src/Text/Edifact/BundleReader/CodedSimples.hs | 38 +++ .../src/Text/Edifact/BundleReader/Commons.hs | 90 +++++++ .../src/Text/Edifact/BundleReader/Composites.hs | 43 ++++ .../src/Text/Edifact/BundleReader/Configuration.hs | 30 +++ .../src/Text/Edifact/BundleReader/Extractor.hs | 75 ++++++ .../src/Text/Edifact/BundleReader/Messages.hs | 61 +++++ .../src/Text/Edifact/BundleReader/Segments.hs | 55 ++++ .../src/Text/Edifact/BundleReader/Simples.hs | 43 ++++ scaffolder/src/Text/Edifact/Fetcher.hs | 44 ++++ scaffolder/src/Text/Edifact/Fetcher/Commons.hs | 87 +++++++ scaffolder/src/Text/Edifact/Fetcher/Composites.hs | 31 +++ .../src/Text/Edifact/Fetcher/Configuration.hs | 43 ++++ scaffolder/src/Text/Edifact/Fetcher/Messages.hs | 84 ++++++ scaffolder/src/Text/Edifact/Fetcher/Segments.hs | 41 +++ scaffolder/src/Text/Edifact/Fetcher/Simples.hs | 27 ++ scaffolder/src/Text/Edifact/Scaffolder.hs | 20 ++ .../Scaffolder/CodedSimples/Specification.hs | 28 ++ scaffolder/src/Text/Edifact/Scaffolder/Commons.hs | 29 +++ .../Text/Edifact/Scaffolder/Commons/Formatters.hs | 88 +++++++ .../Text/Edifact/Scaffolder/Commons/Language.hs | 286 +++++++++++++++++++++ .../src/Text/Edifact/Scaffolder/Commons/Logging.hs | 11 + .../src/Text/Edifact/Scaffolder/Commons/Parsing.hs | 122 +++++++++ .../src/Text/Edifact/Scaffolder/Commons/Text.hs | 91 +++++++ .../src/Text/Edifact/Scaffolder/Commons/Types.hs | 72 ++++++ .../src/Text/Edifact/Scaffolder/Composites.hs | 53 ++++ .../Edifact/Scaffolder/Composites/Dependencies.hs | 20 ++ .../Text/Edifact/Scaffolder/Composites/Elements.hs | 20 ++ .../Scaffolder/Composites/Implementation.hs | 19 ++ .../Edifact/Scaffolder/Composites/Specification.hs | 69 +++++ .../Text/Edifact/Scaffolder/Composites/Types.hs | 18 ++ scaffolder/src/Text/Edifact/Scaffolder/Messages.hs | 54 ++++ .../Edifact/Scaffolder/Messages/Dependencies.hs | 47 ++++ .../Text/Edifact/Scaffolder/Messages/Elements.hs | 22 ++ .../Edifact/Scaffolder/Messages/Implementation.hs | 114 ++++++++ .../Edifact/Scaffolder/Messages/Specification.hs | 129 ++++++++++ .../src/Text/Edifact/Scaffolder/Messages/Types.hs | 36 +++ scaffolder/src/Text/Edifact/Scaffolder/Root.hs | 25 ++ scaffolder/src/Text/Edifact/Scaffolder/Segments.hs | 54 ++++ .../Edifact/Scaffolder/Segments/Dependencies.hs | 47 ++++ .../Text/Edifact/Scaffolder/Segments/Elements.hs | 26 ++ .../Edifact/Scaffolder/Segments/Implementation.hs | 21 ++ .../Edifact/Scaffolder/Segments/Specification.hs | 99 +++++++ .../src/Text/Edifact/Scaffolder/Segments/Types.hs | 27 ++ scaffolder/src/Text/Edifact/Scaffolder/Simples.hs | 41 +++ .../Text/Edifact/Scaffolder/Simples/Elements.hs | 26 ++ .../Edifact/Scaffolder/Simples/Implementation.hs | 23 ++ .../Edifact/Scaffolder/Simples/Representation.hs | 47 ++++ .../Edifact/Scaffolder/Simples/Specification.hs | 28 ++ .../src/Text/Edifact/Scaffolder/Simples/Types.hs | 14 + 56 files changed, 2989 insertions(+) create mode 100644 scaffolder/.gitignore create mode 100644 scaffolder/Makefile create mode 100644 scaffolder/README.md create mode 100644 scaffolder/app/Main.hs create mode 100644 scaffolder/edi-parser-scaffolder.cabal create mode 100644 scaffolder/package.yaml create mode 100644 scaffolder/src/Text/Edifact/BundleReader.hs create mode 100644 scaffolder/src/Text/Edifact/BundleReader/CodedSimples.hs create mode 100644 scaffolder/src/Text/Edifact/BundleReader/Commons.hs create mode 100644 scaffolder/src/Text/Edifact/BundleReader/Composites.hs create mode 100644 scaffolder/src/Text/Edifact/BundleReader/Configuration.hs create mode 100644 scaffolder/src/Text/Edifact/BundleReader/Extractor.hs create mode 100644 scaffolder/src/Text/Edifact/BundleReader/Messages.hs create mode 100644 scaffolder/src/Text/Edifact/BundleReader/Segments.hs create mode 100644 scaffolder/src/Text/Edifact/BundleReader/Simples.hs create mode 100644 scaffolder/src/Text/Edifact/Fetcher.hs create mode 100644 scaffolder/src/Text/Edifact/Fetcher/Commons.hs create mode 100644 scaffolder/src/Text/Edifact/Fetcher/Composites.hs create mode 100644 scaffolder/src/Text/Edifact/Fetcher/Configuration.hs create mode 100644 scaffolder/src/Text/Edifact/Fetcher/Messages.hs create mode 100644 scaffolder/src/Text/Edifact/Fetcher/Segments.hs create mode 100644 scaffolder/src/Text/Edifact/Fetcher/Simples.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/CodedSimples/Specification.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Commons.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Commons/Formatters.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Commons/Language.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Commons/Logging.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Commons/Parsing.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Commons/Text.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Commons/Types.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Composites.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Composites/Dependencies.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Composites/Elements.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Composites/Implementation.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Composites/Specification.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Composites/Types.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Messages.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Messages/Dependencies.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Messages/Elements.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Messages/Implementation.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Messages/Specification.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Messages/Types.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Root.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Segments.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Segments/Dependencies.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Segments/Elements.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Segments/Implementation.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Segments/Specification.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Segments/Types.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Simples.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Simples/Elements.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Simples/Implementation.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Simples/Representation.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Simples/Specification.hs create mode 100644 scaffolder/src/Text/Edifact/Scaffolder/Simples/Types.hs (limited to 'scaffolder') diff --git a/scaffolder/.gitignore b/scaffolder/.gitignore new file mode 100644 index 0000000..76467e6 --- /dev/null +++ b/scaffolder/.gitignore @@ -0,0 +1,2 @@ +.stack-work/ +*~ diff --git a/scaffolder/Makefile b/scaffolder/Makefile new file mode 100644 index 0000000..c69097d --- /dev/null +++ b/scaffolder/Makefile @@ -0,0 +1,7 @@ +lint: + hlint app/ src/ + +help: + @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' + +.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 @@ +# edi-parser-scaffolder + +Autonomous utility to generate parser for a given revision of the Edifact +specification. + +## Usage + +1. fetch specification for a given Edifact revision +2. scaffold the parsers for this specification + +### Read specification + +Read files downloaded from +https://unece.org/trade/uncefact/unedifact/download + +You can specify individual files one by one: +``` +$ 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 +$ 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 +``` + +Or give the whole zip file: +``` +$ 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 +``` + +### Fetch specification + +This function is deprecated and parsing may break at any time! +Prefer the bundle reading above + +``` +$ stack exec edi-parser-scaffolder -- \ + fetch --revision D96A --specification ./specification/references +``` + +If you're only interested in a subset of the specification, you can select the +messages: + +``` +$ stack exec edi-parser-scaffolder -- \ + fetch --revision D96A --specification ./specification/references/ --messages IFCSUM,IFTSAI,DESADV +``` + +### Scaffold the parsers + +``` +$ stack exec edi-parser-scaffolder -- \ + scaffold --revision D96A --specification ./specification/references/ --src specification/src/ +``` 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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Text.Edifact.BundleReader (BundleReaderEnv (..), readBundle) +import Text.Edifact.Fetcher (FetchingEnv (..), fetch, + readSelectMessages) +import Text.Edifact.Scaffolder (ScaffoldingEnv (..), scaffold) + +import Data.String (fromString) +import Options.Applicative + +main :: IO () +main = execParser argumentsParser >>= run + +data Command = ScaffoldCommand ScaffoldingEnv + | FetchCommand FetchingEnv + | BundleReaderCommand BundleReaderEnv + +commandParser :: Parser Command +commandParser = + let mkCommand cmd = command (commandName cmd) (info (commandArgumentsParser cmd) (describe cmd)) + in subparser (foldMap mkCommand [ Scaffold, Fetch, ReadBundle ]) + +data CommandType = Scaffold | Fetch | ReadBundle + +run :: Command -> IO () +run (ScaffoldCommand env) = scaffold env +run (FetchCommand env) = fetch env +run (BundleReaderCommand env) = readBundle env + +commandName :: CommandType -> String +commandName Scaffold = "scaffold" +commandName Fetch = "fetch" +commandName ReadBundle = "read-bundle" + +commandArgumentsParser :: CommandType -> Parser Command +commandArgumentsParser Scaffold = + let revisionArg = strOption (long "revision" <> metavar "REVISION") + moduleNameArg = strOption (long "module-name" <> metavar "MODULE_NAME" <> value "Text.Edifact") + specificationArg = strOption (long "specification" <> metavar "SPECIFICATION" <> value "./specification") + srcArg = strOption (long "src" <> metavar "SOURCES" <> value "./src") + debugParsingArg = flag False True (long "debug-parsing") + arguments = ScaffoldingEnv <$> revisionArg + <*> (fromString <$> moduleNameArg) + <*> specificationArg + <*> srcArg + <*> debugParsingArg + in ScaffoldCommand <$> arguments +commandArgumentsParser Fetch = + let revisionArg = strOption (long "revision" <> metavar "REVISION") + specificationArg = strOption (long "specification" <> metavar "SPECIFICATION" <> value "./specification") + selectedMessagesArg = readSelectMessages <$> + optional (strOption (long "messages" <> metavar "MESSAGES")) + arguments = FetchingEnv <$> revisionArg + <*> specificationArg + <*> selectedMessagesArg + in FetchCommand <$> arguments +commandArgumentsParser ReadBundle = + let revisionArg = strOption (long "revision" <> metavar "REVISION") + specificationArg = strOption (long "specification" <> metavar "SPECIFICATION" <> value "./specification") + bundle = many (strOption (long "bundle" <> metavar "BUNDLE")) + messagesFiles = many (strOption (long "message-file" <> metavar "MESSAGE_FILE")) + selectedMessages = many (strOption (long "message" <> metavar "MESSAGE")) + segmentsFiles = many (strOption (long "segment-file" <> metavar "SEGMENT_FILE")) + compositeFiles = many (strOption (long "composite-file" <> metavar "COMPOSITE_FILE")) + simpleFiles = many (strOption (long "simple-file" <> metavar "SIMPLE_FILE")) + codedSimpleFiles = many (strOption (long "coded-simple-file" <> metavar "CODED_SIMPLE_FILE")) + arguments = BundleReaderEnv <$> revisionArg + <*> specificationArg + <*> bundle + <*> selectedMessages + <*> messagesFiles + <*> segmentsFiles + <*> compositeFiles + <*> simpleFiles + <*> codedSimpleFiles + in BundleReaderCommand <$> arguments + +describe :: CommandType -> InfoMod a +describe Scaffold = progDesc "Scaffold parsers from specification previously fetched" +describe Fetch = progDesc "Fetch specification from UN website (Deprecated! Use read-bundle instead)" +describe ReadBundle = progDesc "Read specification bundle downloaded from UN website" + +argumentsParser :: ParserInfo Command +argumentsParser = info (commandParser <**> helper) cliDesc + +cliDesc :: InfoMod a +cliDesc = fullDesc + <> 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 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 3fe385f41f62ec5ef4db3f95458c629df273c5bf7976e206ce59839d95ba2738 + +name: edi-parser-scaffolder +version: 20190607 +description: Please see the README on GitHub at +homepage: https://github.com/fretlink/edi-parser#readme +bug-reports: https://github.com/fretlink/edi-parser/issues +author: FretLink +maintainer: example@example.com +copyright: 2019 FretLink +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/fretlink/edi-parser + +library + exposed-modules: + Text.Edifact.BundleReader + Text.Edifact.BundleReader.CodedSimples + Text.Edifact.BundleReader.Commons + Text.Edifact.BundleReader.Composites + Text.Edifact.BundleReader.Configuration + Text.Edifact.BundleReader.Extractor + Text.Edifact.BundleReader.Messages + Text.Edifact.BundleReader.Segments + Text.Edifact.BundleReader.Simples + Text.Edifact.Fetcher + Text.Edifact.Fetcher.Commons + Text.Edifact.Fetcher.Composites + Text.Edifact.Fetcher.Configuration + Text.Edifact.Fetcher.Messages + Text.Edifact.Fetcher.Segments + Text.Edifact.Fetcher.Simples + Text.Edifact.Scaffolder + Text.Edifact.Scaffolder.CodedSimples.Specification + Text.Edifact.Scaffolder.Commons + Text.Edifact.Scaffolder.Commons.Formatters + Text.Edifact.Scaffolder.Commons.Language + Text.Edifact.Scaffolder.Commons.Logging + Text.Edifact.Scaffolder.Commons.Parsing + Text.Edifact.Scaffolder.Commons.Text + Text.Edifact.Scaffolder.Commons.Types + Text.Edifact.Scaffolder.Composites + Text.Edifact.Scaffolder.Composites.Dependencies + Text.Edifact.Scaffolder.Composites.Elements + Text.Edifact.Scaffolder.Composites.Implementation + Text.Edifact.Scaffolder.Composites.Specification + Text.Edifact.Scaffolder.Composites.Types + Text.Edifact.Scaffolder.Messages + Text.Edifact.Scaffolder.Messages.Dependencies + Text.Edifact.Scaffolder.Messages.Elements + Text.Edifact.Scaffolder.Messages.Implementation + Text.Edifact.Scaffolder.Messages.Specification + Text.Edifact.Scaffolder.Messages.Types + Text.Edifact.Scaffolder.Root + Text.Edifact.Scaffolder.Segments + Text.Edifact.Scaffolder.Segments.Dependencies + Text.Edifact.Scaffolder.Segments.Elements + Text.Edifact.Scaffolder.Segments.Implementation + Text.Edifact.Scaffolder.Segments.Specification + Text.Edifact.Scaffolder.Segments.Types + Text.Edifact.Scaffolder.Simples + Text.Edifact.Scaffolder.Simples.Elements + Text.Edifact.Scaffolder.Simples.Implementation + Text.Edifact.Scaffolder.Simples.Representation + Text.Edifact.Scaffolder.Simples.Specification + Text.Edifact.Scaffolder.Simples.Types + other-modules: + Paths_edi_parser_scaffolder + hs-source-dirs: + src + ghc-options: -Wall -Werror + build-depends: + base >=4.7 && <5 + , bytestring + , directory + , filepath + , formatting + , mtl + , pandoc + , pandoc-types + , parsec + , process + , split + , text + , transformers + , zip-archive + default-language: Haskell2010 + +executable edi-parser-scaffolder + main-is: Main.hs + other-modules: + Paths_edi_parser_scaffolder + hs-source-dirs: + app + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , edi-parser-scaffolder + , optparse-applicative + 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 @@ +name: edi-parser-scaffolder +version: 20190607 +github: fretlink/edi-parser +author: FretLink +maintainer: example@example.com +copyright: 2019 FretLink + +extra-source-files: +- README.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +dependencies: +- base >= 4.7 && < 5 + +library: + source-dirs: src + ghc-options: + - -Wall + - -Werror + dependencies: + - bytestring + - directory + - filepath + - formatting + - mtl + - pandoc + - pandoc-types + - parsec + - process + - split + - text + - transformers + - zip-archive + +executables: + edi-parser-scaffolder: + main: Main.hs + source-dirs: app + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - edi-parser-scaffolder + - 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 @@ +module Text.Edifact.BundleReader + ( readBundle + , BundleReaderEnv(..) + ) where + +import Text.Edifact.BundleReader.Commons (BundleReader, + getSpecificationHome, + runBundleReader) +import Text.Edifact.BundleReader.Composites (compositesDirectory, + readComposites) +import Text.Edifact.BundleReader.Configuration +import Text.Edifact.BundleReader.Extractor (FileContents (..), + readZip) +import Text.Edifact.BundleReader.Messages (messagesDirectory, + readMessages) +import Text.Edifact.BundleReader.Segments (readSegments, + segmentsDirectory) +import Text.Edifact.BundleReader.CodedSimples (readCodedSimples) +import Text.Edifact.BundleReader.Simples (readSimples, + simplesDirectory) + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (asks) +import Data.Foldable (traverse_) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) + +readBundle :: BundleReaderEnv -> IO () +readBundle = runBundleReader (setupDirectories >> readAll) + +readAll :: BundleReader () +readAll = do + revision <- asks parserRevision + bundles <- mapM (liftIO . readZip revision) =<< asks bundle + messages' <- readMessages (concatMap messages bundles) + printContent messages' "Messages with segments codes:" + segments' <- readSegments (concatMap segments bundles) $ concatMap snd messages' + printContent segments' "Segments with composites/simples:" + simples' <- readSimples (concatMap simples bundles) =<< readComposites (concatMap composites bundles) segments' + readCodedSimples (concatMap codedSimples bundles) simples' + printContent simples' "Simples:" + pure () + +printContent :: Show a => a -> String -> BundleReader () +printContent content header = liftIO $ putStrLn header >> print content >> putStrLn "" + +setupDirectories :: BundleReader () +setupDirectories = do + home <- getSpecificationHome + let mkdir d = liftIO (createDirectoryIfMissing True (home d)) + traverse_ mkdir directories + +directories :: [FilePath] +directories = + [ compositesDirectory + , messagesDirectory + , segmentsDirectory + , simplesDirectory + ] 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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.BundleReader.CodedSimples + ( readCodedSimples + ) where + +import Text.Edifact.BundleReader.Commons +import Text.Edifact.BundleReader.Configuration (BundleReaderEnv (..)) +import Text.Edifact.BundleReader.Simples (simplesDirectory) +import Text.Edifact.Scaffolder.Commons + +import Text.Edifact.Scaffolder.CodedSimples.Specification + +import Control.Monad (when) +import Control.Monad.Reader (asks) +import Data.ByteString as BS (ByteString, + readFile) +import Formatting + +readCodedSimples :: [ByteString] -> [SimpleCode] -> BundleReader () +readCodedSimples contents simples = do + let parsedFile path = parseFile simples =<< liftIO (BS.readFile path) + parsedString = parseFile simples + files <- asks codedSimplesFiles + mapM_ parsedFile files + mapM_ parsedString contents + +parseFile :: [SimpleCode] -> ByteString -> BundleReader [SimpleCode] +parseFile simples content = + let chunks = tail $ splitFileByDash 70 $ decodeContent content + in traverse (parseChunk simples) chunks + +parseChunk :: [SimpleCode] -> Text -> BundleReader SimpleCode +parseChunk simples chunk = do + parsed <- parseOrFail chunk specificationParser + outputFile <- getOutputFile (fSimpleCodeLower % ".txt") simplesDirectory (fst parsed) + when (fst parsed `elem` simples) $ toFile chunk outputFile + 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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.BundleReader.Commons where + +import Text.Edifact.BundleReader.Configuration +import Text.Edifact.Scaffolder.Commons + +import Control.Monad.Reader (ReaderT, runReaderT) +import Data.ByteString (ByteString) +import Data.Char (toLower) +import Data.List.Split (splitWhen) +import Data.Text as T (isInfixOf, lines, + map, null, + replicate, strip, + unlines, unpack) +import Data.Text.Encoding as TE (decodeLatin1, + decodeUtf8') +import Data.Text.IO as TIO (writeFile) +import Formatting +import Text.Parsec (Parsec, runParser) + +type BundleReader = ReaderT BundleReaderEnv IO + +decodeContent :: ByteString -> Text +decodeContent content = either (const $ cleanupAsciiArt $ decodeLatin1 content) id (decodeUtf8' content) + +splitFileByDash :: Int -> Text -> [Text] +splitFileByDash n = + let separator = T.replicate n "-" + isNotEmpty = not . T.null . T.strip + in + filter isNotEmpty . fmap T.unlines . splitWhen (separator `T.isInfixOf`) . T.lines + +runBundleReader :: BundleReader () -> BundleReaderEnv -> IO () +runBundleReader = runReaderT + +getOutputFile :: Format String (a -> String) -> FilePath -> a -> BundleReader FilePath +getOutputFile f d c = do + home <- getSpecificationHome + pure (formatToString (string % "/" % string % "/" % f) home d c) + +getSpecificationHome :: BundleReader FilePath +getSpecificationHome = do + home <- getHome + rev <- getTargetRevision + pure (home formatToString fRevision rev) + +toFile :: Text -> FilePath -> BundleReader () +toFile specification outputFile = liftIO (TIO.writeFile outputFile specification) + +parseOrFail :: (Monoid u) => Text -> Parsec String u a -> BundleReader a +parseOrFail specification parser = either (error . (\a -> show specification <> show a)) pure (runParser parser mempty "" (T.unpack specification)) + +toFileWithParser :: (Monoid a, Monoid u) => Text -> FilePath -> Parsec String u a -> BundleReader a +toFileWithParser specification outputFile parser = do + liftIO (TIO.writeFile outputFile specification) + either (error . show) pure (runParser parser mempty "" (T.unpack specification)) + +lower :: Format r (String -> r) +lower = mapf (fmap toLower) string + +fRevision :: Format r (Revision -> r) +fRevision = mapf getRevision string + +fRevisionLower :: Format r (Revision -> r) +fRevisionLower = mapf getRevision lower + +fMessageCodeLower :: Format r (MessageCode -> r) +fMessageCodeLower = mapf getMessageCode lower + +fSegmentCodeLower :: Format r (SegmentCode -> r) +fSegmentCodeLower = mapf getSegmentCode lower + +fCompositeCodeLower :: Format r (CompositeCode -> r) +fCompositeCodeLower = mapf getCompositeCode lower + +fSimpleCodeLower :: Format r (SimpleCode -> r) +fSimpleCodeLower = mapf getSimpleCode lower + +-- This might not be the proper way to do it... +-- Use Data.Text.Encoding.decodeUtf8With instead? +cleanupAsciiArt :: Text -> Text +cleanupAsciiArt = + let f 'Ä' = '-' + f '¿' = '+' + f '³' = '|' + f 'Ù' = '+' + f 'Á' = '+' + f c = c + 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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.BundleReader.Composites + ( readComposites + , compositesDirectory + ) where + +import Text.Edifact.BundleReader.Commons +import Text.Edifact.BundleReader.Configuration (BundleReaderEnv (..)) +import Text.Edifact.Scaffolder.Commons + +import Text.Edifact.Scaffolder.Composites.Specification (listSimples) + +import Control.Monad (when) +import Control.Monad.Reader (asks) +import Data.ByteString as BS (ByteString, + readFile) +import Formatting + +compositesDirectory :: FilePath +compositesDirectory = "composites" + +readComposites :: [ByteString] -> ([CompositeCode], [SimpleCode]) -> BundleReader [SimpleCode] +readComposites contents (composites, simples) = do + let parsedFile path = parseFile composites =<< liftIO (BS.readFile path) + parsedString = parseFile composites + files <- asks compositesFiles + parsedFiles <- traverse parsedFile files + parsedStrings <- traverse parsedString contents + let filtered = mappend simples $ concatMap snd $ filter (\s -> fst s `elem` composites) $ concat (parsedFiles <> parsedStrings) + pure filtered + +parseFile :: [CompositeCode] -> ByteString -> BundleReader [(CompositeCode, [SimpleCode])] +parseFile composites content = + let chunks = tail $ splitFileByDash 70 $ decodeContent content + in traverse (parseChunk composites) chunks + +parseChunk :: [CompositeCode] -> Text -> BundleReader (CompositeCode, [SimpleCode]) +parseChunk composites chunk = do + parsed <- parseOrFail chunk listSimples + outputFile <- getOutputFile (fCompositeCodeLower % ".txt") compositesDirectory (fst parsed) + when (fst parsed `elem` composites) $ toFile chunk outputFile + 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 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Text.Edifact.BundleReader.Configuration + ( -- * Parsing environment + BundleReaderEnv(..) + -- * Shortcuts for reading the environment + , getTargetRevision + , getHome + ) where + +import Text.Edifact.Scaffolder.Commons (MessageCode, Revision) + +import Control.Monad.Reader.Class (MonadReader, asks) + +data BundleReaderEnv = BundleReaderEnv { parserRevision :: Revision + , specificationHome :: FilePath + , bundle :: [FilePath] + , messageNames :: [MessageCode] + , messagesFiles :: [FilePath] + , segmentsFiles :: [FilePath] + , compositesFiles :: [FilePath] + , simplesFiles :: [FilePath] + , codedSimplesFiles :: [FilePath] + } + +getTargetRevision :: MonadReader BundleReaderEnv m => m Revision +getTargetRevision = asks parserRevision + +getHome :: MonadReader BundleReaderEnv m => m FilePath +getHome = 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 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.BundleReader.Extractor + ( FileContents(..) + , readZip + ) where + +import Text.Edifact.Scaffolder.Commons (Revision (..)) + +import Codec.Archive.Zip +import Data.ByteString as B (ByteString, isInfixOf, + isPrefixOf, readFile) +import Data.ByteString.Lazy as BS (fromStrict, toStrict) +import Data.Char (toLower) +import Data.List as L (intercalate, isPrefixOf) +import Data.List.Split (splitOn) +import Data.Maybe (maybeToList) + +data FileContent = + FileContent + { fileType :: FileType + , fileContent :: ByteString + } + +data FileType = Message | Segment | Composite | Simple | CodedSimple deriving Eq + +data FileContents = + FileContents + { messages :: [ByteString] + , segments :: [ByteString] + , composites :: [ByteString] + , simples :: [ByteString] + , codedSimples :: [ByteString] + } + +readZip :: Revision -> FilePath -> IO FileContents +readZip specification f = toFileContents . parseFile (getExtension f) (getName f) specification <$> B.readFile f + +toFileContents :: [FileContent] -> FileContents +toFileContents t = FileContents + { messages = fileContent <$> filter ((==) Message . fileType) t + , segments = fileContent <$> filter ((==) Segment . fileType) t + , composites = fileContent <$> filter ((==) Composite . fileType) t + , simples = fileContent <$> filter ((==) Simple . fileType) t + , codedSimples = fileContent <$> filter ((==) CodedSimple . fileType) t + } + +getName :: FilePath -> String +getName = intercalate "." . init . splitOn "." . last . splitOn "/" + +getExtension :: FilePath -> String +getExtension = fmap toLower . last . splitOn "." + +parseFile :: String -> String -> Revision -> ByteString -> [FileContent] +parseFile "zip" _ specification content = unzipAndRead specification content +parseFile extension name specification content + | ("d" <> extension) == (toLower <$> getRevision specification) = maybeToList $ identifyFile name content +parseFile _ _ _ _ = [] + +unzipAndRead :: Revision -> ByteString -> [FileContent] +unzipAndRead specification content = let + archive = zEntries $ toArchive $ BS.fromStrict content + toContents e@Entry{eRelativePath} = parseFile (getExtension eRelativePath) (getName eRelativePath) specification (BS.toStrict $ fromEntry e) + in + concatMap toContents archive + +identifyFile :: String -> ByteString -> Maybe FileContent +identifyFile name content + | " Message Type : " `isInfixOf` content = pure $ FileContent Message content + | "2. Composite specifications" `B.isPrefixOf` content = pure $ FileContent Composite content + | "2. Segment specifications" `B.isPrefixOf` content = pure $ FileContent Segment content + | "2. Data element specifications" `B.isPrefixOf` content = pure $ FileContent Simple content + | "UNCL" `L.isPrefixOf` name = pure $ FileContent CodedSimple content +identifyFile _ _ = 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 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Text.Edifact.BundleReader.Messages + ( readMessages + , messagesDirectory + ) where + +import Text.Edifact.BundleReader.Commons (BundleReader, + decodeContent, + fMessageCodeLower, + getOutputFile, + parseOrFail, + toFile) +import Text.Edifact.BundleReader.Configuration (BundleReaderEnv (..)) +import Text.Edifact.Scaffolder.Commons +import Text.Edifact.Scaffolder.Messages.Specification (listSegments, messageNameParser) + +import Control.Monad (when) +import Control.Monad.Reader (asks) +import Data.ByteString as BS (ByteString, + readFile) +import qualified Data.Text as T (isPrefixOf, + lines, + unlines) +import Formatting + +messagesDirectory :: FilePath +messagesDirectory = "messages" + +readMessages :: [ByteString] -> BundleReader [(MessageCode, [SegmentCode])] +readMessages contents = do + selectedMessages <- asks messageNames + let parsedFile path = parseFile selectedMessages =<< liftIO (BS.readFile path) + parsedString = parseFile selectedMessages + parsedFiles <- traverse parsedFile =<< asks messagesFiles + parsedStrings <- traverse parsedString contents + let filtered = parsedFiles <> filter (\s -> null selectedMessages || fst s `elem` selectedMessages) parsedStrings + pure filtered + +parseFile :: [MessageCode] -> ByteString -> BundleReader (MessageCode, [SegmentCode]) +parseFile selectedMessages content = do + let (definition, summary) = splitFile $ decodeContent content + messageCode <- parseOrFail definition messageNameParser + summaryOutputFile <- getOutputFile (fMessageCodeLower % "_s.txt") messagesDirectory messageCode + definitionOutputFile <- getOutputFile (fMessageCodeLower % "_d.txt") messagesDirectory messageCode + when (messageCode `elem` selectedMessages) $ toFile definition definitionOutputFile + when (messageCode `elem` selectedMessages) $ toFile summary summaryOutputFile + (messageCode,) <$> parseOrFail summary listSegments + +splitFile :: Text -> (Text, Text) +splitFile content = let + separatorBefore = "4.3 Message structure" + separatorAfter = "Annex" + textBefore = takeWhile (not . T.isPrefixOf separatorBefore) $ T.lines content + textInsideAndAfter = dropWhile (not . T.isPrefixOf separatorBefore) $ T.lines content + textAfter = dropWhile (not . T.isPrefixOf separatorAfter) textInsideAndAfter + textSummary = T.unlines $ takeWhile (not . T.isPrefixOf separatorAfter) textInsideAndAfter + textDefinition = T.unlines $ textBefore <> [separatorBefore, "", "See summary file", ""] <> textAfter + in + (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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.BundleReader.Segments + ( readSegments + , segmentsDirectory + ) where + +import Text.Edifact.BundleReader.Commons +import Text.Edifact.BundleReader.Configuration (BundleReaderEnv (..)) +import Text.Edifact.Scaffolder.Commons + +import Text.Edifact.Scaffolder.Segments.Specification (listCompositesAndSimples) +import Text.Edifact.Scaffolder.Segments.Types (Element, + getComposite, + getSimple) + +import Control.Monad (when) +import Control.Monad.Reader (asks) +import Data.Bifunctor (bimap) +import Data.ByteString as BS (ByteString, + readFile) +import Data.List as L (partition) +import Data.Maybe (isJust, + mapMaybe) +import Formatting + +segmentsDirectory :: FilePath +segmentsDirectory = "segments" + +readSegments :: [ByteString] -> [SegmentCode] -> BundleReader ([CompositeCode], [SimpleCode]) +readSegments contents segments = do + let parsedFile path = parseFile segments =<< liftIO (BS.readFile path) + parsedString = parseFile segments + files <- asks segmentsFiles + parsedFiles <- traverse parsedFile files + parsedStrings <- traverse parsedString contents + let filtered = concatMap snd $ filter (\s -> fst s `elem` segments) $ concat (parsedFiles <> parsedStrings) + pure $ partitionElements filtered + +parseFile :: [SegmentCode] -> ByteString -> BundleReader [(SegmentCode, [Element])] +parseFile segments content = + let chunks = tail $ splitFileByDash 70 $ decodeContent content + in traverse (parseChunk segments) chunks + +parseChunk :: [SegmentCode] -> Text -> BundleReader (SegmentCode, [Element]) +parseChunk segments chunk = do + parsed <- parseOrFail chunk listCompositesAndSimples + outputFile <- getOutputFile (fSegmentCodeLower % ".txt") segmentsDirectory (fst parsed) + when (fst parsed `elem` segments) $ toFile chunk outputFile + pure parsed + +partitionElements :: [Element] -> ([CompositeCode], [SimpleCode]) +partitionElements = + let isComposite = isJust . getComposite + 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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.BundleReader.Simples + ( readSimples + , simplesDirectory + ) where + +import Text.Edifact.BundleReader.Commons +import Text.Edifact.BundleReader.Configuration (BundleReaderEnv (..)) +import Text.Edifact.Scaffolder.Commons + +import Text.Edifact.Scaffolder.Simples.Specification + +import Control.Monad (when) +import Control.Monad.Reader (asks) +import Data.ByteString as BS (ByteString, + readFile) +import Formatting + +simplesDirectory :: FilePath +simplesDirectory = "simples" + +readSimples :: [ByteString] -> [SimpleCode] -> BundleReader [SimpleCode] +readSimples contents simples = do + let parsedFile path = parseFile simples =<< liftIO (BS.readFile path) + parsedString = parseFile simples + files <- asks simplesFiles + parsedFiles <- traverse parsedFile files + parsedStrings <- traverse parsedString contents + let filtered = filter (`elem` simples) $ concat (parsedFiles <> parsedStrings) + pure filtered + +parseFile :: [SimpleCode] -> ByteString -> BundleReader [SimpleCode] +parseFile simples content = + let chunks = tail $ splitFileByDash 70 $ decodeContent content + in traverse (parseChunk simples) chunks + +parseChunk :: [SimpleCode] -> Text -> BundleReader SimpleCode +parseChunk simples chunk = do + parsed <- parseOrFail chunk specificationParser + outputFile <- getOutputFile (fSimpleCodeLower % ".txt") simplesDirectory (fst parsed) + when (fst parsed `elem` simples) $ toFile chunk outputFile + 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 @@ +module Text.Edifact.Fetcher + ( fetch + , FetchingEnv(..) + , readSelectMessages + ) where + +import Text.Edifact.Fetcher.Commons (Fetcher, + getSpecificationHome, + runFetcher) +import Text.Edifact.Fetcher.Configuration + +import Text.Edifact.Fetcher.Composites (compositesDirectory, + fetchComposites) +import Text.Edifact.Fetcher.Messages (fetchMessages, + messagesDirectory) +import Text.Edifact.Fetcher.Segments (fetchSegments, + segmentsDirectory) +import Text.Edifact.Fetcher.Simples (fetchSimples, + simplesDirectory) + +import Control.Monad.IO.Class (liftIO) +import Data.Foldable (traverse_) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) + +fetch :: FetchingEnv -> IO () +fetch = runFetcher (setupDirectories >> fetchAll) + +fetchAll :: Fetcher () +fetchAll = fetchMessages >>= fetchSegments >>= fetchComposites >>= fetchSimples + +setupDirectories :: Fetcher () +setupDirectories = do + home <- getSpecificationHome + let mkdir d = liftIO (createDirectoryIfMissing True (home d)) + traverse_ mkdir directories + +directories :: [FilePath] +directories = + [ compositesDirectory + , messagesDirectory + , segmentsDirectory + , simplesDirectory + ] 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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.Fetcher.Commons where + +import Text.Edifact.Fetcher.Configuration +import Text.Edifact.Scaffolder.Commons + +import Control.Monad ((>=>)) +import Control.Monad.Error.Class (MonadError, catchError) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader (ReaderT, runReaderT) +import Control.Monad.Trans.Class (lift) +import Data.ByteString (ByteString) +import Data.Char (toLower) +import Data.Text as T (unpack, pack) +import Data.Text.IO as TIO (readFile, writeFile) +import Formatting +import System.Directory (doesFileExist) +import Text.Pandoc as Pandoc hiding (Format, + getOutputFile) +import Text.Parsec (Parsec, runParser) + +type Fetcher = ReaderT FetchingEnv PandocIO + +runFetcher :: Fetcher () -> FetchingEnv -> IO () +runFetcher f = Pandoc.runIOorExplode . runReaderT f + +getOutputFile :: Format String (a -> String) -> FilePath -> a -> Fetcher FilePath +getOutputFile f d c = do + home <- getSpecificationHome + pure (formatToString (string % "/" % string % "/" % f) home d c) + +getUrl :: Format String (a -> String) -> a -> Fetcher String +getUrl f c = do + rev <- getTargetRevision + pure (formatToString ("https://service.unece.org/trade/untdid/" % fRevisionLower % f) rev c) + +getSpecificationHome :: Fetcher FilePath +getSpecificationHome = do + home <- getHome + rev <- getTargetRevision + pure (home formatToString fRevision rev) + +htmlToFile :: String -> (ByteString -> Text) -> FilePath -> Fetcher () +htmlToFile url decoder outputFile = () <$ tryCacheOrHtml decoder url outputFile + +htmlToFileWithParser :: (Monoid a, Monoid u) => String -> (ByteString -> Text) -> FilePath -> Parsec String u a -> Fetcher a +htmlToFileWithParser url decoder outputFile parser = do + specification <- tryCacheOrHtml decoder url outputFile + either (error . show) pure + (runParser parser mempty "" (T.unpack specification)) + +tryCacheOrHtml :: (ByteString -> Text) -> String -> FilePath -> Fetcher Text +tryCacheOrHtml decoder url path = do + fileExists' <- liftIO $ doesFileExist path + content <- if fileExists' + then liftIO $ TIO.readFile path + else readHtmlFromURL decoder url >>= writePlain def + content <$ liftIO (TIO.writeFile path content) + +readHtmlFromURL :: (ByteString -> Text) -> String -> Fetcher Pandoc +readHtmlFromURL decoder = lift . (openURL >=> readHtml def . decoder . fst) . pack + +lower :: Format r (String -> r) +lower = mapf (fmap toLower) string + +fRevision :: Format r (Revision -> r) +fRevision = mapf getRevision string + +fRevisionLower :: Format r (Revision -> r) +fRevisionLower = mapf getRevision lower + +fMessageCodeLower :: Format r (MessageCode -> r) +fMessageCodeLower = mapf getMessageCode lower + +fSegmentCodeLower :: Format r (SegmentCode -> r) +fSegmentCodeLower = mapf getSegmentCode lower + +fCompositeCodeLower :: Format r (CompositeCode -> r) +fCompositeCodeLower = mapf getCompositeCode lower + +fSimpleCodeLower :: Format r (SimpleCode -> r) +fSimpleCodeLower = mapf getSimpleCode lower + +retry :: (MonadIO m, MonadError b m) => Int -> m a -> m a +retry n f | n > 1 = f `catchError` const (say "Retrying" >> retry (n-1) f) + | 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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.Fetcher.Composites + ( fetchComposites + , compositesDirectory + ) where + +import Text.Edifact.Fetcher.Commons +import Text.Edifact.Scaffolder.Commons + +import Text.Edifact.Scaffolder.Composites.Specification (listSimples) + +import Data.List as L (nub, + sort) +import Data.Text.Encoding as TE (decodeUtf8) +import Formatting + +compositesDirectory :: FilePath +compositesDirectory = "composites" + +fetchComposites :: ([CompositeCode], [SimpleCode]) -> Fetcher [SimpleCode] +fetchComposites (composites, segments) = + let compactSimpleCodes = L.nub . L.sort . mappend segments . concat + in compactSimpleCodes <$> traverse (retry 3 . fetchComposite) composites + +fetchComposite :: CompositeCode -> Fetcher [SimpleCode] +fetchComposite code = do + say ("Fetching composite " % fCompositeCode) code + url <- getUrl ("/trcd/trcd" % fCompositeCodeLower % ".htm") code + outputFile <- getOutputFile (fCompositeCodeLower % ".txt") compositesDirectory code + 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 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.Fetcher.Configuration + ( -- * Fetching environment + FetchingEnv(..) + -- * Parsing helpers + , readSelectMessages + -- * Shortcuts for reading the environment + , getTargetRevision + , getHome + , getSelectedMessages + ) where + +import Text.Edifact.Scaffolder.Commons (MessageCode, Revision, + messageCodeParser) + +import Control.Monad.Reader.Class (MonadReader, asks) +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Text.Parsec (char, parse, sepBy1) + +data FetchingEnv = FetchingEnv { fetchingRevision :: Revision + , specificationHome :: FilePath + , selectedMessages :: Maybe (NonEmpty MessageCode) + } + +getTargetRevision :: MonadReader FetchingEnv m => m Revision +getTargetRevision = asks fetchingRevision + +getHome :: MonadReader FetchingEnv m => m FilePath +getHome = asks specificationHome + +getSelectedMessages :: MonadReader FetchingEnv m => m (Maybe (NonEmpty MessageCode)) +getSelectedMessages = asks selectedMessages + +readSelectMessages :: Maybe String -> Maybe (NonEmpty MessageCode) +readSelectMessages value = + let tryParse p s = toMaybe . parse p s + toMaybe (Right v) = Just v + toMaybe _ = Nothing + messageCodesParser = messageCodeParser `sepBy1` comma + comma = char ',' + 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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.Fetcher.Messages + ( fetchMessages + , messagesDirectory + ) where + +import Text.Edifact.Fetcher.Commons +import Text.Edifact.Fetcher.Configuration +import Text.Edifact.Scaffolder.Commons + +import Text.Edifact.Scaffolder.Messages.Specification (listSegments) + +import Data.Foldable (toList) +import Data.List as L (nub, sort) +import Data.Maybe (mapMaybe) +import Data.Text as T (map) +import Data.Text.Encoding as TE (decodeLatin1, + decodeUtf8) +import Formatting +import Text.Pandoc as Pandoc hiding (Format, + getOutputFile) +import Text.Pandoc.Walk (query) +import Text.Parsec (parse) + +messagesDirectory :: FilePath +messagesDirectory = "messages" + +parseMessageCode :: Text -> Maybe MessageCode +parseMessageCode = + let toMaybe (Right v) = Just v + toMaybe _ = Nothing + in toMaybe . parse messageCodeParser "" + +scanInlineForMessageCode :: Inline -> Maybe MessageCode +scanInlineForMessageCode (Str label) = parseMessageCode label +scanInlineForMessageCode _ = Nothing + +-- The trick here is to reverse the usage of UNH which is mandatory on every single message +listAllMessages :: Fetcher [MessageCode] +listAllMessages = + let filterLink (Link _ inlines _) = mapMaybe scanInlineForMessageCode inlines + filterLink _ = [] + extractMessageCodes = query filterLink + loadUNHUsages = readHtmlFromURL TE.decodeUtf8 =<< getUrl ("/trsd/cseg" % fSegmentCodeLower % ".htm") "UNH" + in extractMessageCodes <$> loadUNHUsages + +listMessages :: Fetcher [MessageCode] +listMessages = getSelectedMessages >>= maybe listAllMessages (pure . toList) + +fetchMessages :: Fetcher [SegmentCode] +fetchMessages = listMessages >>= fmap (L.nub . L.sort . concat) . traverse fetchMessage + +fetchMessage :: MessageCode -> Fetcher [SegmentCode] +fetchMessage code = do + retry 3 (fetchMessageDefinition code) + retry 3 (fetchMessageSummary code) + +fetchMessageDefinition :: MessageCode -> Fetcher () +fetchMessageDefinition code = do + say ("Fetching message " % fMessageCode % " definition") code + url <- getUrl ("/trmd/" % fMessageCodeLower % "_d.htm") code + outputFile <- getOutputFile (fMessageCodeLower % "_d.txt") messagesDirectory code + htmlToFile url TE.decodeUtf8 outputFile + +fetchMessageSummary :: MessageCode -> Fetcher [SegmentCode] +fetchMessageSummary code = do + say ("Fetching message " % fMessageCode % " summary") code + url <- getUrl ("/trmd/" % fMessageCodeLower % "_s.htm") code + outputFile <- getOutputFile (fMessageCodeLower % "_s.txt") messagesDirectory code + let decoder = cleanupAsciiArt . TE.decodeLatin1 + htmlToFileWithParser url decoder outputFile listSegments + +-- This might not be the proper way to do it... +-- Use Data.Text.Encoding.decodeUtf8With instead? +cleanupAsciiArt :: Text -> Text +cleanupAsciiArt = + let f 'Ä' = '-' + f '¿' = '+' + f '³' = '|' + f 'Ù' = '+' + f 'Á' = '+' + f c = c + 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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.Fetcher.Segments + ( fetchSegments + , segmentsDirectory + ) where + +import Text.Edifact.Fetcher.Commons +import Text.Edifact.Scaffolder.Commons + +import Text.Edifact.Scaffolder.Segments.Specification (listCompositesAndSimples) +import Text.Edifact.Scaffolder.Segments.Types (Element, + getComposite, + getSimple) + +import Data.Bifunctor (bimap) +import Data.List as L (nub, + partition, + sort) +import Data.Maybe (isJust, + mapMaybe) +import Data.Text.Encoding as TE (decodeUtf8) +import Formatting + +segmentsDirectory :: FilePath +segmentsDirectory = "segments" + +fetchSegments :: [SegmentCode] -> Fetcher ([CompositeCode], [SimpleCode]) +fetchSegments = fmap (partitionElements . L.nub . L.sort . concat) . traverse (retry 3 . fetchSegment) + +partitionElements :: [Element] -> ([CompositeCode], [SimpleCode]) +partitionElements = + let isComposite = isJust . getComposite + in bimap (mapMaybe getComposite) (mapMaybe getSimple) . partition isComposite + +fetchSegment :: SegmentCode -> Fetcher [Element] +fetchSegment code = do + say ("Fetching segment " % fSegmentCode) code + url <- getUrl ("/trsd/trsd" % fSegmentCodeLower % ".htm") code + outputFile <- getOutputFile (fSegmentCodeLower % ".txt") segmentsDirectory code + 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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.Fetcher.Simples + ( fetchSimples + , simplesDirectory + ) where + +import Text.Edifact.Fetcher.Commons +import Text.Edifact.Scaffolder.Commons + + +import Data.Foldable (traverse_) +import Data.Text.Encoding as TE (decodeUtf8) +import Formatting + +simplesDirectory :: FilePath +simplesDirectory = "simples" + +fetchSimples :: [SimpleCode] -> Fetcher () +fetchSimples = traverse_ (retry 3 . fetchSimple) + +fetchSimple :: SimpleCode -> Fetcher () +fetchSimple code = do + say ("Fetching simple " % fSimpleCode) code + url <- getUrl ("/uncl/uncl" % fSimpleCodeLower % ".htm") code + outputFile <- getOutputFile (fSimpleCodeLower % ".txt") simplesDirectory code + 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 @@ +module Text.Edifact.Scaffolder + ( scaffold + , ScaffoldingEnv(..) + ) where + +import Text.Edifact.Scaffolder.Commons + +import Text.Edifact.Scaffolder.Composites +import Text.Edifact.Scaffolder.Messages +import Text.Edifact.Scaffolder.Root +import Text.Edifact.Scaffolder.Segments +import Text.Edifact.Scaffolder.Simples + +scaffold :: ScaffoldingEnv -> IO () +scaffold = runScaffolding $ do + messages + segments + composites + simples + 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 @@ +module Text.Edifact.Scaffolder.CodedSimples.Specification + ( -- * + specificationParser + ) where + +import Text.Edifact.Scaffolder.Commons + +import Text.Parsec as P (anyChar, count, digit, + endOfLine, manyTill, + oneOf, skipMany, string, + try) +import Text.Parsec.String (Parser) + +specificationParser :: Parser (SimpleCode, SimpleName) +specificationParser = scanUntil [ codedSimpleParser ] + +codedSimpleParser :: Parser (SimpleCode, SimpleName) +codedSimpleParser = do + _ <- count 2 (oneOf "+*#|-X ") + skipMany (string " ") + code <- simpleCodeParser + _ <- string " " + skipMany (string " ") + name <- SimpleName <$> manyTill anyChar (() <$ try endOfLine) + pure (code, name) + +simpleCodeParser :: Parser SimpleCode +simpleCodeParser = 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 @@ +module Text.Edifact.Scaffolder.Commons + ( -- * + runScaffolding + -- * Reexports + , module X + ) where + +import Text.Edifact.Scaffolder.Commons.Formatters as X +import Text.Edifact.Scaffolder.Commons.Language as X +import Text.Edifact.Scaffolder.Commons.Logging as X +import Text.Edifact.Scaffolder.Commons.Parsing as X +import Text.Edifact.Scaffolder.Commons.Text as X +import Text.Edifact.Scaffolder.Commons.Types as X + +import Control.Monad.IO.Class as X (liftIO) +import Data.List.NonEmpty as X (NonEmpty, nub, + sort) +import Data.Maybe as X (fromMaybe) +import Data.Semigroup as X ((<>)) +import Data.String as X (IsString, + fromString) +import Data.Text as X (Text) +import System.Directory as X (listDirectory) +import System.FilePath as X (()) + +import Control.Monad.Reader (runReaderT) + +runScaffolding :: Scaffolding a -> ScaffoldingEnv -> IO a +runScaffolding = 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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.Scaffolder.Commons.Formatters + ( -- * + fMessageCode + , fMessageParserFunction + , fGroupCode + , fSegmentCode + , fSegmentParserFunction + , fCompositeCode + , fCompositeParserFunction + , fSimpleCode + , fSimpleParserFunction + + -- * + , fParserSignature + , fParserDeclaration + -- * + , fModuleName + , fPosition + , fPresence + -- * + , quoted + , simpleQuoted + , parens + , notYetImplemented + ) where + +import Text.Edifact.Scaffolder.Commons.Types + +import Formatting as F + +fMessageCode:: Format r (MessageCode -> r) +fMessageCode = mapf getMessageCode F.string + +fMessageParserFunction :: Format r (MessageCode -> r) +fMessageParserFunction = mapf getMessageCode ("message" % F.string) + +fGroupCode :: Format r (GroupCode -> r) +fGroupCode = mapf getGroupCode F.string + +fSegmentCode :: Format r (SegmentCode -> r) +fSegmentCode = mapf getSegmentCode F.string + +fSegmentParserFunction :: Format r (SegmentCode -> r) +fSegmentParserFunction = mapf getSegmentCode ("segment" % F.string) + +fCompositeCode :: Format r (CompositeCode -> r) +fCompositeCode = mapf getCompositeCode F.string + +fCompositeParserFunction :: Format r (CompositeCode -> r) +fCompositeParserFunction = mapf getCompositeCode ("composite" % F.string) + +fSimpleCode :: Format r (SimpleCode -> r) +fSimpleCode = mapf getSimpleCode F.string + +fSimpleParserFunction :: Format r (SimpleCode -> r) +fSimpleParserFunction = mapf getSimpleCode ("simple" % F.string) + +fParserSignature :: Format r a -> Format r a +fParserSignature f = f % " :: Parser Value" + +fParserDeclaration :: Format r a -> Format r a +fParserDeclaration f = f % " =" + +fModuleName :: Format r (ModuleName -> r) +fModuleName = mapf getModuleName string + +fPosition :: Format r (Position -> r) +fPosition = mapf getPosition F.string + +fPresence :: Format r (Presence -> r) +fPresence = + let f Mandatory = "mandatory" + f Optional = "optional " + in mapf f F.string + +quoted :: Format r a -> Format r a +quoted f = "\"" % f % "\"" + +simpleQuoted :: Format r a -> Format r a +simpleQuoted f = "'" % f % "'" + +parens :: Format r a -> Format r a +parens f = "(" % f % ")" + +notYetImplemented :: Format r a -> Format r a +notYetImplemented 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 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.Scaffolder.Commons.Language + ( -- * + saveHaskellModule + , includeSpecification + -- * + , scaffoldModule + -- * + , getRootModuleName + , getRootModuleNameFor + -- * + , scaffoldElements + , ElementWithDefinition + -- * + , parentModule + -- * + , haddockDependencies + -- * + , reexportDependencies + -- * + , importDependencies + , importCombinators + , importNotYetImplementedHelper + -- * + , moduleDeclaration + , Export(..) + -- * + , reexportAlias + , singleImport + , ImportGroup(..) + , Import(..) + , ImportName(..) + , ModuleAlias(..) + , LanguageExtension(..) + ) where + +import Text.Edifact.Scaffolder.Commons.Formatters (fModuleName, + parens, + simpleQuoted) +import Text.Edifact.Scaffolder.Commons.Logging (say) +import Text.Edifact.Scaffolder.Commons.Text (commaSeparated, + extensions, + formatSpecification, + indent, newline) +import Text.Edifact.Scaffolder.Commons.Types (LanguageExtension (..), + ModuleName (..), + Scaffolding, + getRevision, + hostModule, + revision, + targetDirectory, + (<.>)) + +import Control.Monad ((>=>)) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (asks) +import Data.Bifunctor (bimap) +import Data.Foldable (traverse_) +import Data.List (intercalate, + uncons) +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import qualified Data.List.NonEmpty as NE (cons, toList) +import Data.List.Split (splitOn) +import Data.String (IsString (..)) +import Data.Text as T (Text, drop, + lines, + unlines) +import qualified Data.Text.IO as TIO (readFile, + writeFile) +import Data.Tuple (swap) +import Formatting as F (Format, + bprint, later, + mapf, sformat, + stext, (%)) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) +import System.Process (callCommand) + +getRootModuleName :: Scaffolding ModuleName +getRootModuleName = + let prefix host rev = host <.> ModuleName (getRevision rev) + in asks (prefix . hostModule) <*> asks revision + +getRootModuleNameFor :: ModuleName -> Scaffolding ModuleName +getRootModuleNameFor name = + let suffix root = root <.> name + in suffix <$> getRootModuleName + +saveHaskellModule :: ModuleName -> [Text] -> Scaffolding () +saveHaskellModule mn body = + let sources = T.unlines body + saveModule file = liftIO (saveFile file >> stylishHaskell file) + saveFile = flip TIO.writeFile sources + stylishHaskell file = callCommand ("stylish-haskell -i " <> file) + doNothing = pure () + in say ("module " % fModuleName) mn >> mkSourceFile mn >>= maybe doNothing saveModule + +mkSourceFile :: ModuleName -> Scaffolding (Maybe FilePath) +mkSourceFile = locateSourceFile >=> traverse prepareHierarchy + +type FileInDirectory = (Directory, FileName) +type Directory = FilePath +type FileName = FilePath + +prepareHierarchy :: FileInDirectory -> Scaffolding FilePath +prepareHierarchy (directory, file) = + let fullPath = directory file + in fullPath <$ liftIO (createDirectoryIfMissing True directory) + +locateSourceFile :: ModuleName -> Scaffolding (Maybe FileInDirectory) +locateSourceFile (ModuleName mn) = + let hierarchy = splitOn "." mn + toFile n = n <> ".hs" + path :: Directory -> Maybe (Directory, FileName) + path directory = fmap toFile . swap . fmap (foldl () directory . reverse) <$> uncons (reverse hierarchy) + in asks (path . targetDirectory) + +includeSpecification :: FilePath -> Scaffolding [Text] +includeSpecification = fmap (formatSpecification . T.lines) . liftIO . TIO.readFile + +type ElementWithDefinition elt = (FilePath, elt) + +scaffoldElements :: (NonEmpty (ElementWithDefinition element) -> Scaffolding ()) + -> ( ElementWithDefinition element -> Scaffolding ()) + -> ([ ElementWithDefinition element] -> Scaffolding ()) +scaffoldElements parentScaffolder elementScaffolder = + let doNothing = pure () + scaffolder elts = parentScaffolder elts >> traverse_ elementScaffolder elts + in maybe doNothing scaffolder . nonEmpty + +parentModule :: ModuleName -> ModuleAlias -> (ModuleName -> element -> ModuleName) -> NonEmpty (ElementWithDefinition element) -> Scaffolding () +parentModule elementName alias nameModule elements = + getRootModuleNameFor elementName >>= generateRootModule alias nameModule (snd <$> elements) + +generateRootModule :: ModuleAlias -> (ModuleName -> element -> ModuleName) -> NonEmpty element -> ModuleName -> Scaffolding () +generateRootModule alias nameModule codes mn = + let importElement code = ImportAll (ImportAs (nameModule mn code) alias) + imports = [ ImportGroup (importElement <$> codes) ] + exports = [ reexportAlias alias ] + in saveHaskellModule mn $ + moduleDeclaration mn exports imports + +haddockDependencies :: Format Text (elt -> Text) -> NonEmpty elt -> Scaffolding [Text] +haddockDependencies formatter elts = + let formattedDependencies = commaSeparated . fmap (sformat (simpleQuoted formatter)) + formatHaddock = sformat ("-- Dependencies: " % F.stext % ".") + in pure [ "--" + , formatHaddock (formattedDependencies elts) + ] + +reexportDependencies :: Format Text (elt -> Text) -> NonEmpty elt -> Scaffolding [Export] +reexportDependencies formatter = + let mkReexport = Name . sformat formatter + prependTitle = NE.cons (Comment "* Dependencies") + in pure . NE.toList . prependTitle . fmap mkReexport + +importDependencies :: ModuleName -> Format Text (elt -> Text) -> NonEmpty elt -> Scaffolding Import +importDependencies moduleName formatter elts = + let imports = NE.toList (sformat formatter <$> elts) + mkImport mn = Import (BasicImport mn) imports + in mkImport <$> getRootModuleNameFor moduleName + +importCombinators :: ImportGroup +importCombinators = + ImportGroup + [ ImportAll "Text.Edifact.Parsing" + , Import "Text.Edifact.Types" [ "Value" ] + ] + +importNotYetImplementedHelper :: ImportGroup +importNotYetImplementedHelper = + ImportGroup + [ Import "Text.Edifact.Parsing.Commons" [ "notYetImplemented" ] + ] + +moduleDeclaration :: ModuleName -> [Export] -> [ImportGroup] -> [Text] +moduleDeclaration moduleName exports imports = + let decl mn [] = [sformat ("module " % fModuleName % " where") mn] + decl mn ex = sformat ("module " % fModuleName) mn + : renderExports ex + in intercalate newline [ decl moduleName exports + , renderImports imports + ] + +machineGeneratedWarning :: [Text] +machineGeneratedWarning = + [ "---- Machine generated code." + , "---- Output of edi-parser-scaffolder" + ] + +scaffoldModule :: ModuleName -> [LanguageExtension] -> [Export] -> [ImportGroup] -> [Text] -> Scaffolding () +scaffoldModule mn exts exports imports code = + saveHaskellModule mn $ + intercalate newline + [ extensions exts + , machineGeneratedWarning + , moduleDeclaration mn exports imports + , code + ] + +renderExports :: [Export] -> [Text] +renderExports exports = + let formatExport (First e) = sformat (" " % fExport) e + formatExport (Following e) = sformat (", " % fExport) e + formatExport (Skipped e) = sformat (" " % fExport) e + fExport = + let f (Comment t) = bprint ("-- " % stext) t + f (Name t) = bprint stext t + in later f + parensOnFirstLine [] = [] + parensOnFirstLine (firstLine : rest) = ("(" <> T.drop 1 firstLine) : rest + ls = parensOnFirstLine (formatExport <$> tag exports) <> [ ") where" ] + in indent <$> ls + +data Export = Name Text + | Comment Text + +instance IsString Export where + fromString = Name . fromString + +data Tag a = First a + | Following a + | Skipped a + +tag :: [Export] -> [Tag Export] +tag = + let skipAll = fmap Skipped + tagFirst [] = [] + tagFirst (elt : others) = First elt : tagOthers others + tagOthers = fmap tagOther + tagOther v | isComment v = Skipped v + | otherwise = Following v + merge (xs, ys) = xs <> ys + in merge . bimap skipAll tagFirst . span isComment + +isComment :: Export -> Bool +isComment (Comment _) = True +isComment _ = False + +newtype ModuleAlias = ModuleAlias { getModuleAlias :: Text } deriving newtype (IsString) + +singleImport :: Import -> ImportGroup +singleImport = ImportGroup . pure + +newtype ImportGroup = ImportGroup (NonEmpty Import) deriving newtype Semigroup + +data Import = Import ImportName [Text] + | ImportAll ImportName + +data ImportName = BasicImport ModuleName + | ImportAs ModuleName ModuleAlias + | ImportQualified ModuleName + | ImportQualifiedAs ModuleName ModuleAlias + +instance IsString ImportName where + fromString = BasicImport . fromString + +renderImports :: [ImportGroup] -> [Text] +renderImports = intercalate newline . fmap renderImportGroup + +reexportAlias :: ModuleAlias -> Export +reexportAlias = Name . sformat ("module " % fModuleAlias) + +renderImportGroup :: ImportGroup -> [Text] +renderImportGroup (ImportGroup imports) = NE.toList (renderImport <$> imports) + +renderImport :: Import -> Text +renderImport (ImportAll name) = sformat fImportName name +renderImport (Import name references) = + sformat (fImportName % " " % parens stext) name (commaSeparated references) + +fImportName :: Format r (ImportName -> r) +fImportName = + let + build (BasicImport name) = bprint ("import " % fModuleName) name + build (ImportAs name alias) = bprint ("import " % fModuleName % " as " % fModuleAlias) name alias + build (ImportQualified name) = bprint ("import qualified " % fModuleName) name + build (ImportQualifiedAs name alias) = bprint ("import qualified " % fModuleName % " as " % fModuleAlias) name alias + in later build + +fModuleAlias :: Format r (ModuleAlias -> r) +fModuleAlias = 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 @@ +module Text.Edifact.Scaffolder.Commons.Logging + ( say + ) where + +import Control.Monad.IO.Class (MonadIO, liftIO) +import qualified Data.Text.Lazy.Builder as TLB (toLazyText) +import qualified Data.Text.Lazy.IO as TLIO (putStrLn) +import Formatting as F (Format, runFormat) + +say :: MonadIO m => Format (m ()) a -> a +say 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 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} + +module Text.Edifact.Scaffolder.Commons.Parsing + ( -- * + maybeParse + , skipBeginning + , single + , silent + -- * + , listElements + -- * + , presenceParser + , stringToPresenceParser + -- * + , messageCodeParser + -- * + , scanDependencies + , scan + , scanUntil + ) where + +import Text.Edifact.Scaffolder.Commons.Logging (say) +import Text.Edifact.Scaffolder.Commons.Types + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Identity (Identity) +import Control.Monad.Reader (asks, local) +import Data.Bifunctor (first) +import Data.List (sort) +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Data.Maybe (catMaybes) +import Data.String (fromString) +import Data.Text (Text) +import Formatting as F (shown) +import System.Directory (listDirectory) +import System.FilePath (()) +import Text.Parsec (Parsec, SourceName, + Stream, anyChar, char, + choice, count, + endOfLine, eof, + lookAhead, many, + many1, manyTill, + oneOf, optionMaybe, + runParser, string, + try, upper, ()) + +maybeParse :: (Show a, Stream s Identity t, Monoid u) => SourceName -> Parsec s u a -> s -> Scaffolding (Maybe a) +maybeParse source parser input = + let interpretParsingResult (Right v) _ = pure (Just v) + interpretParsingResult e True = Nothing <$ say shown e + interpretParsingResult _ False = pure Nothing + shouldDebug = asks debugParsing + in shouldDebug >>= interpretParsingResult (runParser parser mempty source input) + +-- | Disable parsing error logging locally +silent :: Scaffolding a -> Scaffolding a +silent = local disableDebugging + +-- | Let you traverse a directory and filter files matching a parser. +-- The filename is then paired with the matched value +listElements :: (Show elt, Ord elt) => FilePath -> Parsec String () elt -> Scaffolding [(FilePath, elt)] +listElements subpath parser = do + home <- getSpecificationHome + let directory = home subpath + files <- sort <$> liftIO (listDirectory directory) + let prependDirectory f = directory f + fmap (first prependDirectory) . catMaybes <$> traverse (extractElement parser) files + +getSpecificationHome :: Scaffolding FilePath +getSpecificationHome = + let concatenate path (Revision rev) = path rev + in asks (concatenate . specificationsHome) <*> asks revision + +extractElement :: Show elt => Parsec String () elt -> FilePath -> Scaffolding (Maybe (FilePath, elt)) +extractElement parser path = silent (fmap (path,) <$> maybeParse path parser path) + +skipBeginning :: Stream s Identity Char => Parsec s () a -> Parsec s () a +skipBeginning p = manyTill anyChar (try (lookAhead p)) *> p + +single :: Stream s Identity Char => Parsec s u a -> Parsec s u [a] +single = count 1 + +presenceParser :: Stream s Identity Char => Parsec s u Presence +presenceParser = + choice [ Mandatory <$ char 'M' + , Optional <$ char 'C' + ] "Presence" + +stringToPresenceParser :: Stream s Identity Char => Parsec s u Text +stringToPresenceParser = fromString <$> + manyTill anyChar (try $ lookAhead $ many1 (string " ") >> presenceParser >> string " " >> many (oneOf " 0123456789")) + "Description" + +messageCodeParser :: Stream s Identity Char => Parsec s u MessageCode +messageCodeParser = fromString <$> count 6 upper + +scanDependencies :: (Monoid u, Show result) => FilePath -> Parsec String u [result] -> Scaffolding (Maybe (NonEmpty result)) +scanDependencies file parser = + let readLines = liftIO (readFile file) + in readLines >>= fmap (nonEmpty =<<) . maybeParse file parser + +scan :: Stream s Identity Char => [Parsec s u [a]] -> Parsec s u [a] +scan scanners = + let parsers = (scanLine <$> scanners) <> [skipLine] + end = choice [ () <$ try endOfLine + , () <$ eof + ] + scanLine p = optionMaybe (try p) <* end + skipLine = Nothing <$ manyTill anyChar end + in concat . catMaybes <$> manyTill (choice parsers) eof + +scanUntil :: Stream s Identity Char => [Parsec s u a] -> Parsec s u a +scanUntil scanners = + let parsers = scanLine <$> scanners + end = choice [ () <$ try endOfLine + , () <$ eof + ] + searching = choice $ fmap (() <$) parsers <> [ () <$ eof ] + scanLine p = p <* end + skipLine = manyTill anyChar end + 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 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.Scaffolder.Commons.Text + ( -- * + indent + , quote + , haskellList + , commaSeparated + -- * + , newline + -- * + , formatSpecification + -- * + , extensions + ) where + + +import Text.Edifact.Scaffolder.Commons.Types (LanguageExtension (..)) + +import Control.Category ((>>>)) +import Data.Char (isSpace) +import Data.List (dropWhileEnd) +import Data.String (IsString) +import Data.Text (Text) +import qualified Data.Text as T (all, dropWhileEnd, + null) +import Formatting as F (mapf, sformat, + stext, string, (%)) + +formatSpecification :: [Text] -> [Text] +formatSpecification = cleanEmptyLines + >>> fmap quoteLine + >>> prependQuote + +prependQuote :: [Text] -> [Text] +prependQuote ls = + [ "-- | Derived from this specification:" + , "--" + ] <> ls + +cleanEmptyLines :: [Text] -> [Text] +cleanEmptyLines = dropWhile blank >>> dropWhileEnd blank + +blank :: Text -> Bool +blank t = T.null t || T.all isSpace t + +quoteLine :: Text -> Text +quoteLine = haskellQuote >>> cleanWhitespaces + +haskellQuote :: Text -> Text +haskellQuote line = "-- > " <> line + +cleanWhitespaces :: Text -> Text +cleanWhitespaces = T.dropWhileEnd (== ' ') + +indent :: Text -> Text +indent t = " " <> t + +quote :: Text -> Text +quote t = "'" <> t <> "'" + +haskellList :: [Text] -> [Text] +haskellList = + let prefix :: Int -> Text -> Text + prefix 1 dep = sformat ("[ " % F.stext) dep + prefix _ dep = sformat (", " % F.stext) dep + suffix deps = deps <> ["]"] + in suffix . zipWith prefix [1..] + +newtype CommaSeparated = CommaSeparated { getCommaSeparated :: Text } deriving newtype (IsString, Eq) + +instance Semigroup CommaSeparated where + t1 <> "" = t1 + "" <> t2 = t2 + t1 <> t2 = CommaSeparated (getCommaSeparated t1 <> ", " <> getCommaSeparated t2) + +instance Monoid CommaSeparated where + mempty = "" + +commaSeparated :: Foldable f => f Text -> Text +commaSeparated = getCommaSeparated . foldMap CommaSeparated + +newline :: [Text] +newline = [""] + +extensions :: [LanguageExtension] -> [Text] +extensions = + let fExtension = "{-# LANGUAGE " % mapf getLanguageExtension F.string % " #-}" + 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 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Text.Edifact.Scaffolder.Commons.Types + ( -- * Codes of elements + MessageCode(..) + , GroupCode(..) + , SegmentCode(..) + , SegmentName(..) + , CompositeCode (..) + , CompositeName (..) + , SimpleCode(..) + , SimpleName(..) + -- * Ordering of elements + , Position(..) + -- * Attributes + , Presence(..) + -- * + , ModuleName(..) + , (<.>) + -- * + , LanguageExtension(..) + -- * + , Scaffolding + , Revision(..) + , ScaffoldingEnv(..) + , disableDebugging + ) where + +import Control.Monad.Reader (ReaderT) +import Data.String (IsString) + +newtype MessageCode = MessageCode { getMessageCode :: String } deriving newtype (Show, Eq, Ord, IsString) +newtype GroupCode = GroupCode { getGroupCode :: String } deriving newtype (Show, Eq, Ord, IsString) +newtype SegmentCode = SegmentCode { getSegmentCode :: String } deriving newtype (Show, Eq, Ord, IsString) +newtype SegmentName = SegmentName { getSegmentName :: String } deriving newtype (Show, Eq, Ord, IsString) +newtype CompositeCode = CompositeCode { getCompositeCode :: String } deriving newtype (Show, Eq, Ord, IsString) +newtype CompositeName = CompositeName { getCompositeName :: String } deriving newtype (Show, Eq, Ord, IsString) +newtype SimpleCode = SimpleCode { getSimpleCode :: String } deriving newtype (Show, Eq, Ord, IsString) +newtype SimpleName = SimpleName { getSimpleName :: String } deriving newtype (Show, Eq, Ord, IsString) + +newtype Position = Position { getPosition :: String } deriving newtype (Show, Eq, Ord, IsString) + +data Presence = Mandatory + | Optional + deriving (Show, Eq, Ord) + +newtype ModuleName = ModuleName { getModuleName :: String } deriving newtype (Show, Eq, IsString) + +instance Semigroup ModuleName where + (<>) = (<.>) + +(<.>) :: ModuleName -> ModuleName -> ModuleName +(ModuleName parent) <.> (ModuleName child) = ModuleName (parent <> "." <> child) + +newtype LanguageExtension = LanguageExtension { getLanguageExtension :: String } deriving newtype IsString + +type Scaffolding = ReaderT ScaffoldingEnv IO + +newtype Revision = Revision { getRevision :: String } deriving newtype (Show, Eq, IsString) + +data ScaffoldingEnv = + ScaffoldingEnv + { revision :: Revision + , hostModule :: ModuleName + , specificationsHome :: FilePath + , targetDirectory :: FilePath + , debugParsing :: Bool + } + +disableDebugging :: ScaffoldingEnv -> ScaffoldingEnv +disableDebugging 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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.Scaffolder.Composites + ( composites + ) where + +import Text.Edifact.Scaffolder.Commons + +import Text.Edifact.Scaffolder.Composites.Dependencies +import Text.Edifact.Scaffolder.Composites.Elements +import Text.Edifact.Scaffolder.Composites.Implementation +import Text.Edifact.Scaffolder.Composites.Specification +import Text.Edifact.Scaffolder.Composites.Types + +import Formatting + +composites :: Scaffolding () +composites = listComposites >>= scaffoldElements parentCompositeModule compositeModule + +parentCompositeModule :: NonEmpty (ElementWithDefinition CompositeCode) -> Scaffolding () +parentCompositeModule = parentModule "Composites" "C" compositeModuleName + +compositeModuleName :: ModuleName -> CompositeCode -> ModuleName +compositeModuleName mn code = mn <.> fromString (getCompositeCode code) + +compositeModule :: ElementWithDefinition CompositeCode -> Scaffolding () +compositeModule (inputFile, code) = do + moduleName <- getRootModuleNameFor (compositeModuleName "Composites" code) + dependencies <- scanDependencies inputFile (snd <$> specificationParser) + specification <- includeSpecification inputFile + let parserFunction = fCompositeParserFunction + fDescription = "Composite " % fCompositeCode + parserNotYetImplemented = sformat (notYetImplemented fDescription) code + defaultImplementation = haskellList [ parserNotYetImplemented ] + elements = sort . nub . fmap dependencyElement <$> dependencies + implementation = maybe defaultImplementation toImplementation dependencies + buildDependencies b = fromMaybe [] <$> traverse b elements + dependenciesReexports <- buildDependencies mkDependenciesReexports + dependenciesImports <- buildDependencies mkDependenciesImports + dependenciesHaddock <- buildDependencies mkDependenciesHaddock + let exports = Comment "* Definition" + : Name (sformat parserFunction code) + : dependenciesReexports + imports = dependenciesImports + <> [ importCombinators ] + <> maybe [ importNotYetImplementedHelper ] (const []) dependencies + documentation = specification <> dependenciesHaddock + signature = sformat (fParserSignature parserFunction) code + definition = [ sformat (fParserDeclaration parserFunction) code + , indent (sformat ("composite " % quoted fCompositeCode) code) + ] <> (indent . indent <$> implementation) + parser = signature : definition + 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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.Scaffolder.Composites.Dependencies + ( -- * + mkDependenciesHaddock + , mkDependenciesImports + , mkDependenciesReexports + ) where + +import Text.Edifact.Scaffolder.Commons +import Text.Edifact.Scaffolder.Composites.Types + +mkDependenciesReexports :: NonEmpty Element -> Scaffolding [Export] +mkDependenciesReexports = reexportDependencies fElement + +mkDependenciesImports :: NonEmpty Element -> Scaffolding [ImportGroup] +mkDependenciesImports = fmap (pure . singleImport) . importDependencies "Simples" fElement + +mkDependenciesHaddock :: NonEmpty Element -> Scaffolding [Text] +mkDependenciesHaddock = 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 @@ +module Text.Edifact.Scaffolder.Composites.Elements + ( listComposites + ) where + +import Text.Edifact.Scaffolder.Commons + +import Data.Char (toUpper) +import Text.Parsec (count, digit, eof, oneOf, + string) +import Text.Parsec.String (Parser) + +listComposites :: Scaffolding [ElementWithDefinition CompositeCode] +listComposites = listElements "composites" compositeCodeParser + +compositeCodeParser :: Parser CompositeCode +compositeCodeParser = do + initial <- toUpper <$> oneOf "ce" + rest <- count 3 digit + _ <- string ".txt" + 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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.Scaffolder.Composites.Implementation + ( -- * + toImplementation + ) where + +import Text.Edifact.Scaffolder.Commons +import Text.Edifact.Scaffolder.Composites.Types + +import Data.List.NonEmpty as NE (toList) +import Formatting + +toImplementation :: NonEmpty Dependency -> [Text] +toImplementation = haskellList . fmap callDependency . NE.toList + +callDependency :: Dependency -> Text +callDependency (Dependency pos element presence) = + 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 @@ +module Text.Edifact.Scaffolder.Composites.Specification + ( -- * + specificationParser + , listSimples + ) where + +import Text.Edifact.Scaffolder.Commons +import Text.Edifact.Scaffolder.Composites.Types + +import Text.Parsec as P (anyChar, count, + digit, + endOfLine, many, + many1, manyTill, + oneOf, skipMany, + string, try, + ()) +import Text.Parsec.String (Parser) + +specificationParser :: Parser ((CompositeCode, CompositeName), [Dependency]) +specificationParser = do + compositeInfo <- scanUntil [ compositeParser ] + dependencies <- scan [ inLine dependencyParser ] "Composites specification" + pure (compositeInfo, dependencies) + +listSimples :: Parser (CompositeCode, [SimpleCode]) +listSimples = do + parsed <- specificationParser + pure (fst $ fst parsed, getElementSimpleCode . dependencyElement <$> snd parsed) + +compositeParser :: Parser (CompositeCode, CompositeName) +compositeParser = do + _ <- count 6 (oneOf "+*#|X ") + skipMany (string " ") + code <- compositeCodeParser + _ <- string " " + name <- CompositeName <$> manyTill anyChar (() <$ try endOfLine) + pure (code, name) + +compositeCodeParser :: Parser CompositeCode +compositeCodeParser = do + initial <- oneOf "CE" + rest <- count 3 digit + pure (fromString (initial : rest)) + +dependencyParser :: Parser Dependency +dependencyParser = + Dependency <$> positionParser + <* many1 (oneOf "+*#|-X ") + <*> elementParser + <* stringToPresenceParser + <* many1 (string " ") + <*> presenceParser + "Dependency" + +inLine :: Parser a -> Parser [a] +inLine p = single (many (string " ") *> p <* filler) + +filler :: Parser () +filler = () <$ many (oneOf "an.0123456789 ") + +positionParser :: Parser Position +positionParser = + fromString <$> count 3 digit + "Position" + +elementParser :: Parser Element +elementParser = + fromString <$> count 4 digit + "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 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Text.Edifact.Scaffolder.Composites.Types where + +import Text.Edifact.Scaffolder.Commons + +import Formatting + +data Dependency = Dependency { dependencyPosition :: Position + , dependencyElement :: Element + , dependencyPresence :: Presence + } deriving Show + +newtype Element = Simple { getElementSimpleCode :: SimpleCode } deriving newtype (Show, Eq, Ord, IsString) + +fElement :: Format r (Element -> r) +fElement = 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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.Scaffolder.Messages + ( messages + ) where + +import Text.Edifact.Scaffolder.Commons + +import Text.Edifact.Scaffolder.Messages.Dependencies +import Text.Edifact.Scaffolder.Messages.Elements +import Text.Edifact.Scaffolder.Messages.Implementation +import Text.Edifact.Scaffolder.Messages.Specification +import Text.Edifact.Scaffolder.Messages.Types + +import Formatting + +messages :: Scaffolding () +messages = listMessages >>= scaffoldElements parentMessageModule messageModule + +parentMessageModule :: NonEmpty (ElementWithDefinition MessageCode) -> Scaffolding () +parentMessageModule = parentModule "Messages" "M" messageModuleName + +messageModuleName :: ModuleName -> MessageCode -> ModuleName +messageModuleName mn code = mn <.> fromString (getMessageCode code) + +messageModule :: ElementWithDefinition MessageCode -> Scaffolding () +messageModule (inputFile, code) = do + moduleName <- getRootModuleNameFor (messageModuleName "Messages" code) + dependencies <- scanDependencies inputFile specificationParser + specification <- includeSpecification inputFile + let parserFunction = fMessageParserFunction + fDescription = "Message " % fMessageCode + parserNotYetImplemented = sformat (notYetImplemented fDescription) code + defaultImplementation = haskellList [ parserNotYetImplemented ] + elements = sort . nub . fmap getElement <$> dependencies + implementation = maybe defaultImplementation (toImplementation code) dependencies + buildDependencies b = fromMaybe [] <$> traverse b elements + dependenciesReexports <- buildDependencies mkDependenciesReexports + dependenciesImports <- buildDependencies mkDependenciesImports + dependenciesHaddock <- buildDependencies mkDependenciesHaddock + let exports = Comment "* Definition" + : Name (sformat parserFunction code) + : dependenciesReexports + segmentImport = singleImport (ImportAll "Text.Edifact.Common.Segments") + imports = maybe importNotYetImplementedHelper (const segmentImport) dependencies + : dependenciesImports + <> [ importCombinators ] + documentation = specification <> dependenciesHaddock + signature = sformat (fParserSignature parserFunction) code + definition = [ sformat (fParserDeclaration parserFunction) code + , indent (sformat ("message " % quoted fMessageCode) code) + ] <> (indent . indent <$> implementation) + parser = signature : definition + 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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.Scaffolder.Messages.Dependencies + ( -- * + mkDependenciesHaddock + , mkDependenciesImports + , mkDependenciesReexports + ) where + +import Text.Edifact.Scaffolder.Commons +import Text.Edifact.Scaffolder.Messages.Types + +import Control.Monad ((>=>)) +import Data.List (isPrefixOf) +import Data.List.NonEmpty as NE (nonEmpty, toList) +import Data.Maybe (mapMaybe) + +unlessIsCommon :: SegmentCode -> Maybe SegmentCode +unlessIsCommon sc@(SegmentCode code) | "U" `isPrefixOf` code = Nothing + | otherwise = Just sc + +mkDependenciesReexports :: NonEmpty Element -> Scaffolding [Export] +mkDependenciesReexports = mkSegmentDependencies mkSegmentDependenciesReexports + +mkSegmentDependenciesReexports :: NonEmpty SegmentCode -> Scaffolding [Export] +mkSegmentDependenciesReexports = reexportDependencies fSegmentParserFunction + +mkDependenciesImports :: NonEmpty Element -> Scaffolding [ImportGroup] +mkDependenciesImports = mkSegmentDependencies mkSegmentDependenciesImports + +mkSegmentDependencies :: (NonEmpty SegmentCode -> Scaffolding [output]) + -> (NonEmpty Element -> Scaffolding [output]) +mkSegmentDependencies mk = maybe (pure []) mk . filterSegmentDependencies + +filterSegmentDependencies :: NonEmpty Element -> Maybe (NonEmpty SegmentCode) +filterSegmentDependencies = + fmap nub . nonEmpty . mapMaybe (getSegment >=> unlessIsCommon) . NE.toList + +mkSegmentDependenciesImports :: NonEmpty SegmentCode -> Scaffolding [ImportGroup] +mkSegmentDependenciesImports = + fmap (pure . singleImport) . importDependencies "Segments" fSegmentParserFunction + +mkDependenciesHaddock :: NonEmpty Element -> Scaffolding [Text] +mkDependenciesHaddock = mkSegmentDependencies mkSegmentDependenciesHaddock + +mkSegmentDependenciesHaddock :: NonEmpty SegmentCode -> Scaffolding [Text] +mkSegmentDependenciesHaddock = 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 @@ +module Text.Edifact.Scaffolder.Messages.Elements + ( listMessages + ) where + +import Text.Edifact.Scaffolder.Commons + +import Data.Char (toUpper) +import Text.Parsec (count, eof, lower, string, + ()) +import Text.Parsec.String (Parser) + +-- | List elements +listMessages :: Scaffolding [ElementWithDefinition MessageCode] +listMessages = listElements "messages" messageFilenameParser + +messageFilenameParser :: Parser MessageCode +messageFilenameParser = + let mkCode = MessageCode . fmap toUpper + in mkCode <$> count 6 lower + <* string "_s.txt" + <* eof + "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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.Scaffolder.Messages.Implementation + ( -- * + toImplementation + ) where + +import Text.Edifact.Scaffolder.Commons +import Text.Edifact.Scaffolder.Messages.Types + +import Control.Monad.State.Strict (State, evalState, gets, + modify) +import Data.List.NonEmpty as NE (NonEmpty (..), + fromList, head, + toList, (<|)) +import Formatting + +toImplementation :: MessageCode -> NonEmpty Dependency -> [Text] +toImplementation _ = + let closeList deps = deps <> [ "]" ] + in closeList . render . fmap concat . traverse callDependency . NE.toList + +render :: Rendering a -> a +render r = + let initialState = RenderingContext 0 0 :| [] + in evalState r initialState + +type Trail = NonEmpty + +data RenderingContext = RenderingContext { listPosition :: Int + , indentLevel :: Int + } + +type Rendering = State (Trail RenderingContext) + +callDependency :: Dependency -> Rendering [Text] +callDependency (Dependency element) = renderElement element + +increment :: Rendering () +increment = + let mapHead f (v :| t) = f v :| t + in modify (mapHead (\ ctx -> ctx { listPosition = listPosition ctx + 1 })) + +pushIndent :: Rendering () +pushIndent = + let indentState t@(previous :| _) = RenderingContext 0 (indentLevel previous + 2) <| t + in modify indentState + +popIndent :: Rendering () +popIndent = + let pop (_ :| []) = error "Incoherent state: can't unindent anymore (this shouldn't happen)" + pop (_ :| up) = NE.fromList up + in modify pop + +getCurrentIndex :: Rendering Int +getCurrentIndex = gets (listPosition . NE.head) + +getCurrentIndentation :: Rendering Int +getCurrentIndentation = gets (indentLevel . NE.head) + +renderElement :: Element -> Rendering [Text] +renderElement (Segment code positional) = + let output index indentation = + [ sformat (fIndentation % fIndex % " " % fPositional % " " % fSegmentParserFunction) indentation index positional code + ] + in output <$> getCurrentIndex + <*> getCurrentIndentation + <* increment +renderElement (GroupStart code positional) = + let output index indentation = + [ sformat (fIndentation % fIndex % " " % fPositional % " (") indentation index positional + , sformat (fIndentation % fSegmentGroupFunction) (indentation + 1) code + ] + in output <$> getCurrentIndex + <*> getCurrentIndentation + <* increment + <* pushIndent +renderElement (GroupEnd _) = + let output indentation = + [ sformat (fIndentation % "]") indentation + , sformat (fIndentation % ")") (indentation - 1) + ] + in output <$> getCurrentIndentation + <* popIndent + +fIndentation :: Format r (Int -> r) +fIndentation = + let buildIndentation n = fromString (replicate (n * 2) ' ') + in later buildIndentation + +fIndex :: Format r (Int -> r) +fIndex = + let buildIndex 0 = "[" + buildIndex _ = "," + in later buildIndex + +fPositional :: Format r (Positional -> r) +fPositional = + let buildPositional (Positional p r) = bprint (quoted fPosition % " .@ " % fRepetition) p r + in later buildPositional + +fSegmentGroupFunction :: Format r (GroupCode -> r) +fSegmentGroupFunction = "segmentGroup " % quoted fGroupCode + +fRepetition :: Format r (Repetition -> r) +fRepetition = + let buildRepetition (Repetition Mandatory 1) = bprint "once" + buildRepetition (Repetition Optional 1) = bprint "maybeOnce" + buildRepetition (Repetition Mandatory c) = bprint ("repeatedAtLeastOnce" % " " % fCardinality) c + buildRepetition (Repetition Optional c) = bprint ("repeated" % " " % fCardinality) c + in later buildRepetition + +fCardinality :: Format r (Cardinality -> r) +fCardinality = 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 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Text.Edifact.Scaffolder.Messages.Specification + ( -- * + specificationParser + , messageNameParser + , listSegments + ) where + +import Text.Edifact.Scaffolder.Commons +import Text.Edifact.Scaffolder.Messages.Types + +import Data.Maybe (mapMaybe) +import Text.Parsec + +type Parser = Parsec String GroupTrail + +newtype GroupTrail = GroupTrail [GroupCode] + deriving stock Show + deriving newtype (Semigroup, Monoid) + +messageNameParser :: Parser MessageCode +messageNameParser = scanUntil [ + manyTill anyChar (string "Message Type : ") >> MessageCode <$> count 6 upper + ] + +specificationParser :: Parser [Dependency] +specificationParser = + let scanElements = scan [ segmentInLine segmentElementParser + , groupInLine groupStartElementParser + ] + in interpretDependencies <$> scanElements "Messages specification" + +listSegments :: Parser [SegmentCode] +listSegments = mapMaybe (getSegment . getElement) <$> specificationParser + +interpretDependencies :: [Element] -> [Dependency] +interpretDependencies = fmap Dependency + +groupInLine :: Parser a -> Parser [a] +groupInLine p = single (many (string " ") *> p <* countClosingGroups) + +countClosingGroups :: Parser Int +countClosingGroups = + let parser = many1 (char '-') + *> many1 (char '+') + <* many (char '|') + in length <$> parser + +closingGroupTrail :: Parser [Element] +closingGroupTrail = + let groupEndParser = GroupEnd <$> popFromTrail + in countClosingGroups >>= flip count groupEndParser + +groupStartElementParser :: Parser Element +groupStartElementParser = + let parseStart pos code rep = GroupStart code (Positional pos rep) + in parseStart <$> positionParser + <* many1 (choice [ () <$ try (oneOf "+*#|X "), () <$ try (string "- ") ]) + <*> groupCodeParser + <* many1 (char ' ') + <*> repetitionParser + "GroupElement" + +groupCodeParser :: Parser GroupCode +groupCodeParser = + let parser = manyTill (char '-') (try $ string "-- Segment group") + *> many1 (char ' ') + *> many1 digit + <* many1 space + <* many1 (char '-') + group = GroupCode <$> parser + in group >>= appendToTrail "GroupCodeParser" + +appendToTrail :: GroupCode -> Parser GroupCode +appendToTrail code = + let append (GroupTrail trail) = GroupTrail (code : trail) + in code <$ modifyState append + +popFromTrail :: Parser GroupCode +popFromTrail = do + previous <- getState + case previous of + GroupTrail (current : trail) -> current <$ putState (GroupTrail trail) + GroupTrail [] -> unexpected "GroupEnd, when state is currently clear" + +segmentTrail :: Parser [a] +segmentTrail = [] <$ (many1 (char ' ') <* many (char '|')) + +segmentInLine :: Parser Element -> Parser [Element] +segmentInLine p = do + segment <- many (string " ") *> p + trail <- choice [ try closingGroupTrail + , try segmentTrail + ] + pure (segment : trail) + +repetitionParser :: Parser Repetition +repetitionParser = + Repetition <$> presenceParser + <* many1 (string " ") + <*> cardinalityParser + "Repetition" + +positionParser :: Parser Position +positionParser = + fromString <$> many1 digit + "Position" + +segmentElementParser :: Parser Element +segmentElementParser = + let parseSegment pos code rep = Segment code (Positional pos rep) + in parseSegment <$> positionParser + <* many1 (oneOf "+*#|-X ") + <*> segmentCodeParser + <* many1 (string " ") + <* stringToPresenceParser + <* many1 (string " ") + <*> repetitionParser + "SegmentElement" + +segmentCodeParser :: Parser SegmentCode +segmentCodeParser = + fromString <$> count 3 upper + "SegmentCode" + +cardinalityParser :: Parser Cardinality +cardinalityParser = Cardinality . read <$> many1 digit 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 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Text.Edifact.Scaffolder.Messages.Types where + +import Text.Edifact.Scaffolder.Commons + +import Data.Function (on) +import Data.Ord (comparing) + +newtype Dependency = Dependency { getElement :: Element } deriving newtype (Show, Ord, Eq) + +data Repetition = Repetition Presence Cardinality deriving Show + +data Positional = Positional { positionalPosition :: Position + , positionalRepetition :: Repetition + } deriving (Show) + +instance Eq Positional where + (==) = (==) `on` positionalPosition + +instance Ord Positional where + compare = comparing positionalPosition + +data Element = Segment SegmentCode Positional + | GroupStart GroupCode Positional + | GroupEnd GroupCode + deriving (Show, Ord, Eq) + +getSegment :: Element -> Maybe SegmentCode +getSegment (Segment code _) = Just code +getSegment _ = Nothing + +newtype Cardinality = Cardinality { getCardinality :: Int } + deriving stock (Show) + 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 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.Scaffolder.Root + ( rootModule + ) where + +import Text.Edifact.Scaffolder.Commons + +rootModule :: Scaffolding () +rootModule = getRootModuleName >>= generateRootModule + +generateRootModule :: ModuleName -> Scaffolding () +generateRootModule mn = + let exports = [ reexportAlias subModulesAlias ] + subModulesAlias = "S" + importSubModule sm = ImportAll (ImportAs (mn <.> sm) subModulesAlias) + subModules = [ "Composites" + , "Messages" + , "Segments" + ] + imports = [ ImportGroup (importSubModule <$> subModules) ] + in + saveHaskellModule mn $ + 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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.Scaffolder.Segments + ( segments + ) where + +import Text.Edifact.Scaffolder.Commons + +import Text.Edifact.Scaffolder.Segments.Dependencies +import Text.Edifact.Scaffolder.Segments.Elements +import Text.Edifact.Scaffolder.Segments.Implementation +import Text.Edifact.Scaffolder.Segments.Specification +import Text.Edifact.Scaffolder.Segments.Types + +import Data.List.NonEmpty (nubBy) +import Formatting + +segments :: Scaffolding () +segments = listSegments >>= scaffoldElements parentSegmentModule segmentModule + +parentSegmentModule :: NonEmpty (ElementWithDefinition SegmentCode) -> Scaffolding () +parentSegmentModule = parentModule "Segments" "S" segmentModuleName + +segmentModuleName :: ModuleName -> SegmentCode -> ModuleName +segmentModuleName mn code = mn <.> fromString (getSegmentCode code) + +segmentModule :: ElementWithDefinition SegmentCode -> Scaffolding () +segmentModule (inputFile, code) = do + moduleName <- getRootModuleNameFor (segmentModuleName "Segments" code) + dependencies <- scanDependencies inputFile (snd <$> specificationParser) + specification <- includeSpecification inputFile + let parserFunction = fSegmentParserFunction + fDescription = "Segment " % fSegmentCode + parserNotYetImplemented = sformat (notYetImplemented fDescription) code + defaultImplementation = haskellList [ parserNotYetImplemented ] + elements = sort . nubBy (\a b -> getCode a == getCode b) . fmap dependencyElement <$> dependencies + implementation = maybe defaultImplementation toImplementation dependencies + buildDependencies b = fromMaybe [] <$> traverse b elements + dependenciesReexports <- buildDependencies mkDependenciesReexports + dependenciesImports <- buildDependencies mkDependenciesImports + dependenciesHaddock <- buildDependencies mkDependenciesHaddock + let exports = Comment "* Definition" + : Name (sformat parserFunction code) + : dependenciesReexports + imports = dependenciesImports + <> [ importCombinators ] + <> maybe [ importNotYetImplementedHelper ] (const []) dependencies + documentation = specification <> dependenciesHaddock + signature = sformat (fParserSignature parserFunction) code + definition = [ sformat (fParserDeclaration parserFunction) code + , indent (sformat ("segment " % quoted fSegmentCode) code) + ] <> (indent . indent <$> implementation) + parser = signature : definition + 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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.Scaffolder.Segments.Dependencies + ( -- * + mkDependenciesHaddock + , mkDependenciesImports + , mkDependenciesReexports + ) where + +import Text.Edifact.Scaffolder.Commons +import Text.Edifact.Scaffolder.Segments.Types + +import Data.List.NonEmpty as NE (nonEmpty, toList) +import Data.Maybe (catMaybes, mapMaybe) +import Formatting as F + +mkDependenciesReexports :: NonEmpty Element -> Scaffolding [Export] +mkDependenciesReexports = reexportDependencies fElementFunction + +mkDependenciesImports :: NonEmpty Element -> Scaffolding [ImportGroup] +mkDependenciesImports elements = + let filterElements optic = mapMaybe optic . NE.toList + in maybe [] (pure . ImportGroup) . nonEmpty . catMaybes <$> + sequence + [ mkCompositeDependenciesImports (filterElements getComposite elements) + , mkSimpleDependenciesImports (filterElements getSimple elements) + ] + +mkSimpleDependenciesImports :: [SimpleCode] -> Scaffolding (Maybe Import) +mkSimpleDependenciesImports = + ifNonEmpty (importDependencies "Simples" fSimpleParserFunction) + +mkCompositeDependenciesImports :: [CompositeCode] -> Scaffolding (Maybe Import) +mkCompositeDependenciesImports = + ifNonEmpty (importDependencies "Composites" fCompositeParserFunction) + +ifNonEmpty :: Applicative f => (NonEmpty input -> f output) -> [input] -> f (Maybe output) +ifNonEmpty f = traverse f . nonEmpty + +mkDependenciesHaddock :: NonEmpty Element -> Scaffolding [Text] +mkDependenciesHaddock = haddockDependencies fElementFunction + +fElementFunction :: Format r (Element -> r) +fElementFunction = + let buildElementFunction (Simple code _ _ _ _) = bprint fSimpleParserFunction code + buildElementFunction (Composite code _ _) = bprint fCompositeParserFunction code + 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 @@ +module Text.Edifact.Scaffolder.Segments.Elements + ( listSegments + ) where + +import Text.Edifact.Scaffolder.Commons + +import Data.Char (isLower, toUpper) +import Text.Parsec (eof, lower, satisfy, string, + ()) +import Text.Parsec.String (Parser) + +listSegments :: Scaffolding [ElementWithDefinition SegmentCode] +listSegments = listElements "segments" segmentCodeParser + +segmentCodeParser :: Parser SegmentCode +segmentCodeParser = do + c1 <- lowerExceptU + c2 <- lower + c3 <- lower + let code = SegmentCode (toUpper <$> [c1,c2,c3]) + code <$ string ".txt" + <* eof + "SegmentCode" + +lowerExceptU :: Parser Char +lowerExceptU = 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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.Scaffolder.Segments.Implementation + ( -- * + toImplementation + ) where + +import Text.Edifact.Scaffolder.Commons +import Text.Edifact.Scaffolder.Segments.Types + +import Data.List.NonEmpty as NE (toList) +import Formatting + +toImplementation :: NonEmpty Dependency -> [Text] +toImplementation = haskellList . fmap callDependency . NE.toList + +callDependency :: Dependency -> Text +callDependency (Dependency pos (Simple code _ presence _ _)) = + sformat ( quoted fPosition % " .@ " % fPresence % " simple" % fSimpleCode) pos presence code +callDependency (Dependency pos (Composite code _ presence)) = + 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 @@ +module Text.Edifact.Scaffolder.Segments.Specification + ( -- * + specificationParser + , listCompositesAndSimples + ) where + +import Text.Edifact.Scaffolder.Commons +import Text.Edifact.Scaffolder.Segments.Types + +import Text.Parsec as P (anyChar, choice, + count, digit, + endOfLine, many, + many1, manyTill, + oneOf, skipMany, + string, try, + upper, ()) +import Text.Parsec.String (Parser) + +specificationParser :: Parser ((SegmentCode, SegmentName), [Dependency]) +specificationParser = do + segmentInfo <- scanUntil [ segmentParser ] + dependencies <- scan [ inLine dependencyParser ] "Segments specification" + pure (segmentInfo, dependencies) + +listCompositesAndSimples :: Parser (SegmentCode, [Element]) +listCompositesAndSimples = do + parsed <- specificationParser + pure (fst $ fst parsed, dependencyElement <$> snd parsed) + +segmentParser :: Parser (SegmentCode, SegmentName) +segmentParser = do + _ <- count 6 (oneOf "+*#|X ") + skipMany (string " ") + code <- SegmentCode <$> count 3 upper + _ <- count 2 (string " ") + skipMany (string " ") + name <- SegmentName <$> manyTill anyChar (() <$ try endOfLine) + pure (code, name) + +dependencyParser :: Parser Dependency +dependencyParser = + Dependency <$> positionParser + <* many1 (oneOf "+*#|-X ") + <*> elementParser + "Dependency" + +inLine :: Parser a -> Parser [a] +inLine p = single (many (string " ") *> p) + +positionParser :: Parser Position +positionParser = + fromString <$> count 3 digit + "Position" + +elementParser :: Parser Element +elementParser = + choice [ compositeParser + , simpleParser + ] + "Element" + +compositeParser :: Parser Element +compositeParser = Composite <$> compositeCodeParser + <* many (string " ") + <*> stringToPresenceParser + <* many1 (string " ") + <*> presenceParser + <* string " " + <* many (oneOf " 0123456789") + "Composite" + +simpleParser :: Parser Element +simpleParser = Simple <$> (fromString <$> count 4 digit) + <* many1 (string " ") + <*> stringToPresenceParser + <* many1 (string " ") + <*> presenceParser + <* string " " + <* many (oneOf " 0123456789") + <*> simpleTypeParser + <*> simpleLengthParser + "Simple" + +simpleTypeParser :: Parser SimpleType +simpleTypeParser = choice [ Alphanumeric <$ string "an" + , Alphabetic <$ string "a" + , Numeric <$ string "n" + ] "SimpleType" + +simpleLengthParser :: Parser SimpleLength +simpleLengthParser = choice [ UpTo <$> fmap fromString (string ".." >> many1 digit) + , Exactly <$> (fromString <$> many1 digit) + ] "SimpleLength" + +compositeCodeParser :: Parser CompositeCode +compositeCodeParser = do + initial <- oneOf "CE" + rest <- count 3 digit + 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 @@ +module Text.Edifact.Scaffolder.Segments.Types where + +import Text.Edifact.Scaffolder.Commons + +data Dependency = Dependency { dependencyPosition :: Position + , dependencyElement :: Element + } deriving Show + +data Element = Composite CompositeCode Text Presence + | Simple SimpleCode Text Presence SimpleType SimpleLength + deriving (Show, Eq, Ord) + +data SimpleType = Alphanumeric | Alphabetic | Numeric deriving (Show, Eq, Ord) + +data SimpleLength = Exactly Text | UpTo Text deriving (Show, Eq, Ord) + +getCode :: Element -> String +getCode (Simple (SimpleCode c) _ _ _ _) = c +getCode (Composite (CompositeCode c) _ _) = c + +getSimple :: Element -> Maybe SimpleCode +getSimple (Simple c _ _ _ _) = Just c +getSimple _ = Nothing + +getComposite :: Element -> Maybe CompositeCode +getComposite (Composite c _ _) = Just c +getComposite _ = 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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.Scaffolder.Simples + ( simples + ) where + +import Text.Edifact.Scaffolder.Commons + +import Text.Edifact.Scaffolder.Simples.Elements +import Text.Edifact.Scaffolder.Simples.Implementation +import Text.Edifact.Scaffolder.Simples.Representation + +import Formatting + +simples :: Scaffolding () +simples = listSimples >>= scaffoldElements parentSimpleModule simpleModule + +parentSimpleModule :: NonEmpty (ElementWithDefinition SimpleCode) -> Scaffolding () +parentSimpleModule = parentModule "Simples" "S" simpleModuleName + +simpleModuleName :: ModuleName -> SimpleCode -> ModuleName +simpleModuleName mn code = mn <.> fromString ("S" <> getSimpleCode code) + +simpleModule :: ElementWithDefinition SimpleCode -> Scaffolding () +simpleModule (inputFile, code) = do + moduleName <- getRootModuleNameFor (simpleModuleName "Simples" code) + representation <- extractRepresentation inputFile + specification <- includeSpecification inputFile + let parserFunction = fSimpleParserFunction + fDescription = "Simple " % fSimpleCode + defaultImplementation = sformat (notYetImplemented fDescription) code + implementation = maybe defaultImplementation toImplementation representation + exports = [ Name (sformat parserFunction code) ] + imports = importCombinators + : maybe [importNotYetImplementedHelper] (const []) representation + documentation = specification + signature = sformat (fParserSignature parserFunction) code + definition = [ sformat (fParserDeclaration parserFunction % " simple " % quoted fSimpleCode % " " % parens stext) code code implementation + ] + parser = signature : definition + 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 @@ +module Text.Edifact.Scaffolder.Simples.Elements + ( listSimples + ) where + +import Text.Edifact.Scaffolder.Commons + +import Text.Parsec (digit, eof, oneOf, string, + ()) +import Text.Parsec.String (Parser) + +listSimples :: Scaffolding [ElementWithDefinition SimpleCode] +listSimples = listElements "simples" simpleCodeParser + +simpleCodeParser :: Parser SimpleCode +simpleCodeParser = + let codeParser = + sequence [ oneOf ['1'..'9'] + , digit + , digit + , digit + ] + in + SimpleCode <$> codeParser + <* string ".txt" + <* eof + "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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.Scaffolder.Simples.Implementation + ( -- * + toImplementation + ) where + +import Text.Edifact.Scaffolder.Commons +import Text.Edifact.Scaffolder.Simples.Types + +import Formatting + +toImplementation :: Representation -> Text +toImplementation (Representation content (UpTo n) ) = sformat (fContent % " `upTo` " % int) content n +toImplementation (Representation content (Exactly n)) = sformat (fContent % " `exactly` " % int) content n +toImplementation (Representation content AnyNumber ) = sformat ("many " % fContent) content + +fContent :: Format t (Content -> t) +fContent = + let display AlphaNumeric = "alphaNumeric" + display Alpha = "alpha" + display Numeric = "numeric" + 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 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Edifact.Scaffolder.Simples.Representation + ( -- * + extractRepresentation + , representationParser + ) where + +import Text.Edifact.Scaffolder.Commons +import Text.Edifact.Scaffolder.Simples.Types + +import Text.Parsec as P (char, choice, + digit, many1, + option, optional, + space, string, try) +import Text.Parsec.String (Parser) + +extractRepresentation :: FilePath -> Scaffolding (Maybe Representation) +extractRepresentation file = + let parser = skipBeginning representationParser + in liftIO (readFile file) >>= maybeParse file parser + +contentParser :: Parser Content +contentParser = + choice [ AlphaNumeric <$ try (P.string "an") + , Alpha <$ P.string "a" + , Numeric <$ P.string "n" + ] + +cardinalityParser :: Parser Cardinality +cardinalityParser = + option AnyNumber $ + choice [ Exactly <$> (optional space *> numberParser) + , UpTo <$> (dot *> dot *> numberParser) + ] + +numberParser :: Parser Int +numberParser = read <$> many1 digit + +dot :: Parser Char +dot = P.char '.' + +representationParser :: Parser Representation +representationParser = + let parser = Representation <$> contentParser + <*> cardinalityParser + 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 @@ +module Text.Edifact.Scaffolder.Simples.Specification + ( -- * + specificationParser + ) where + +import Text.Edifact.Scaffolder.Commons + +import Text.Parsec as P (anyChar, count, digit, + endOfLine, manyTill, + oneOf, skipMany, string, + try) +import Text.Parsec.String (Parser) + +specificationParser :: Parser (SimpleCode, SimpleName) +specificationParser = scanUntil [ simpleParser ] + +simpleParser :: Parser (SimpleCode, SimpleName) +simpleParser = do + _ <- count 3 (oneOf "+*#|-X ") + skipMany (string " ") + code <- simpleCodeParser + _ <- string " " + skipMany (string " ") + name <- SimpleName <$> manyTill anyChar (() <$ try endOfLine) + pure (code, name) + +simpleCodeParser :: Parser SimpleCode +simpleCodeParser = 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 @@ +module Text.Edifact.Scaffolder.Simples.Types where + +data Representation = Representation Content Cardinality + deriving Show + +data Content = AlphaNumeric + | Alpha + | Numeric + deriving Show + +data Cardinality = UpTo Int + | Exactly Int + | AnyNumber + deriving Show -- cgit v1.2.3