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