scaffolder/src/Text/Edifact/Scaffolder/Commons/Parsing.hs

   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)