-- |
--
-- Copyright:
--   This file is part of the package vimeta. It is subject to the
--   license terms in the LICENSE file found in the top-level
--   directory of this distribution and at:
--
--     https://github.com/pjones/vimeta
--
--   No part of this package, including this file, may be copied,
--   modified, propagated, or distributed except according to the terms
--   contained in the LICENSE file.
--
-- License: BSD-2-Clause
--
-- | Mapping files can be used to map file names to other information.
module Vimeta.Core.MappingFile
  ( Parser,
    parseMappingFile,
  )
where

import Data.Char (isSpace)
import System.Directory (doesFileExist)
import System.FilePath (takeExtension)
import Text.Parsec hiding ((<|>))
import Vimeta.Core.Vimeta

-- | Parser type.
type Parser a = ParsecT Text () Identity a

-- | Internal token used for parsing.
data Token a = Comment | Entry FilePath a

-- | Parse a mapping file.
parseMappingFile ::
  (MonadIO m) =>
  -- | File name for the mapping file.
  FilePath ->
  -- | Parser for the second column.
  Parser a ->
  Vimeta m [(FilePath, a)]
parseMappingFile :: FilePath -> Parser a -> Vimeta m [(FilePath, a)]
parseMappingFile FilePath
filename Parser a
p = do
  Text
contents <- IO Text -> Vimeta m Text
forall (m :: * -> *) a. MonadIO m => IO a -> Vimeta m a
runIO (IO Text -> Vimeta m Text) -> IO Text -> Vimeta m Text
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Text
forall (m :: * -> *). MonadIO m => FilePath -> m Text
readFileText FilePath
filename

  case Identity (Either ParseError [(FilePath, a)])
-> Either ParseError [(FilePath, a)]
forall a. Identity a -> a
runIdentity (Identity (Either ParseError [(FilePath, a)])
 -> Either ParseError [(FilePath, a)])
-> Identity (Either ParseError [(FilePath, a)])
-> Either ParseError [(FilePath, a)]
forall a b. (a -> b) -> a -> b
$ ParsecT Text () Identity [(FilePath, a)]
-> ()
-> FilePath
-> Text
-> Identity (Either ParseError [(FilePath, a)])
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> u -> FilePath -> s -> m (Either ParseError a)
runParserT (Parser a -> ParsecT Text () Identity [(FilePath, a)]
forall a. Parser a -> Parser [(FilePath, a)]
mapping Parser a
p) () FilePath
filename Text
contents of
    Left ParseError
e -> FilePath -> Vimeta m [(FilePath, a)]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ParseError -> FilePath
forall b a. (Show a, IsString b) => a -> b
show ParseError
e)
    Right [(FilePath, a)]
m -> [(FilePath, a)] -> Vimeta m [(FilePath, a)]
forall (m :: * -> *) a.
MonadIO m =>
[(FilePath, a)] -> Vimeta m [(FilePath, a)]
checkFileMappingOrDie [(FilePath, a)]
m

checkFileMappingOrDie ::
  (MonadIO m) =>
  [(FilePath, a)] ->
  Vimeta m [(FilePath, a)]
checkFileMappingOrDie :: [(FilePath, a)] -> Vimeta m [(FilePath, a)]
checkFileMappingOrDie [(FilePath, a)]
xs =
  do
    [Either (FilePath, a) (FilePath, a)]
ys <- [(FilePath, a)] -> Vimeta m [Either (FilePath, a) (FilePath, a)]
forall (m :: * -> *) a.
MonadIO m =>
[(FilePath, a)] -> Vimeta m [Either (FilePath, a) (FilePath, a)]
checkFileMapping [(FilePath, a)]
xs
    if [(FilePath, a)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Either (FilePath, a) (FilePath, a)] -> [(FilePath, a)]
forall a b. [Either a b] -> [a]
lefts [Either (FilePath, a) (FilePath, a)]
ys)
      then [(FilePath, a)] -> Vimeta m [(FilePath, a)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either (FilePath, a) (FilePath, a)] -> [(FilePath, a)]
forall a b. [Either a b] -> [b]
rights [Either (FilePath, a) (FilePath, a)]
ys)
      else FilePath -> Vimeta m [(FilePath, a)]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FilePath -> Vimeta m [(FilePath, a)])
-> FilePath -> Vimeta m [(FilePath, a)]
forall a b. (a -> b) -> a -> b
$ [(FilePath, a)] -> FilePath
forall a. [(FilePath, a)] -> FilePath
report ([Either (FilePath, a) (FilePath, a)] -> [(FilePath, a)]
forall a b. [Either a b] -> [a]
lefts [Either (FilePath, a) (FilePath, a)]
ys)
  where
    report :: [(FilePath, a)] -> String
    report :: [(FilePath, a)] -> FilePath
report [(FilePath, a)]
fs =
      FilePath
"the following files are listed in the mapping file "
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"but they don't exist: \n"
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\n" (((FilePath, a) -> FilePath) -> [(FilePath, a)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, a) -> FilePath
forall a b. (a, b) -> a
fst [(FilePath, a)]
fs)

-- | Checks to see that all of the file names mentioned exist.  If a
-- file doesn't exist the @m4v@ file extension is added to it and the
-- existence checking happens again.
checkFileMapping ::
  (MonadIO m) =>
  -- | The mapping.
  [(FilePath, a)] ->
  Vimeta m [Either (FilePath, a) (FilePath, a)]
checkFileMapping :: [(FilePath, a)] -> Vimeta m [Either (FilePath, a) (FilePath, a)]
checkFileMapping = ((FilePath, a) -> Vimeta m (Either (FilePath, a) (FilePath, a)))
-> [(FilePath, a)] -> Vimeta m [Either (FilePath, a) (FilePath, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath, a) -> Vimeta m (Either (FilePath, a) (FilePath, a))
forall (m :: * -> *) a.
MonadIO m =>
(FilePath, a) -> Vimeta m (Either (FilePath, a) (FilePath, a))
checkFile
  where
    checkFile ::
      (MonadIO m) =>
      (FilePath, a) ->
      Vimeta m (Either (FilePath, a) (FilePath, a))
    checkFile :: (FilePath, a) -> Vimeta m (Either (FilePath, a) (FilePath, a))
checkFile f :: (FilePath, a)
f@(FilePath
filename, a
a) = do
      let ext :: FilePath
ext = FilePath -> FilePath
takeExtension FilePath
filename
      Bool
exists <- IO Bool -> Vimeta m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> Vimeta m a
runIO (FilePath -> IO Bool
doesFileExist FilePath
filename)

      case Bool
exists of
        Bool
False
          | FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
ext -> (FilePath, a) -> Vimeta m (Either (FilePath, a) (FilePath, a))
forall (m :: * -> *) a.
MonadIO m =>
(FilePath, a) -> Vimeta m (Either (FilePath, a) (FilePath, a))
checkFile (FilePath
filename FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
".m4v", a
a)
          | Bool
otherwise -> Either (FilePath, a) (FilePath, a)
-> Vimeta m (Either (FilePath, a) (FilePath, a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (FilePath, a) (FilePath, a)
 -> Vimeta m (Either (FilePath, a) (FilePath, a)))
-> Either (FilePath, a) (FilePath, a)
-> Vimeta m (Either (FilePath, a) (FilePath, a))
forall a b. (a -> b) -> a -> b
$ (FilePath, a) -> Either (FilePath, a) (FilePath, a)
forall a b. a -> Either a b
Left (FilePath, a)
f
        Bool
True -> Either (FilePath, a) (FilePath, a)
-> Vimeta m (Either (FilePath, a) (FilePath, a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (FilePath, a) (FilePath, a)
 -> Vimeta m (Either (FilePath, a) (FilePath, a)))
-> Either (FilePath, a) (FilePath, a)
-> Vimeta m (Either (FilePath, a) (FilePath, a))
forall a b. (a -> b) -> a -> b
$ (FilePath, a) -> Either (FilePath, a) (FilePath, a)
forall a b. b -> Either a b
Right (FilePath, a)
f

-- | The actual file parser.
mapping :: Parser a -> Parser [(FilePath, a)]
mapping :: Parser a -> Parser [(FilePath, a)]
mapping Parser a
p = [Token a] -> [(FilePath, a)]
forall a. [Token a] -> [(FilePath, a)]
entries ([Token a] -> [(FilePath, a)])
-> ParsecT Text () Identity [Token a] -> Parser [(FilePath, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity (Token a)
-> ParsecT Text () Identity ()
-> ParsecT Text () Identity [Token a]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill (ParsecT Text () Identity (Token a)
forall a. Parser (Token a)
whitespace ParsecT Text () Identity (Token a)
-> ParsecT Text () Identity (Token a)
-> ParsecT Text () Identity (Token a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Text () Identity (Token a)
forall a. Parser (Token a)
comment ParsecT Text () Identity (Token a)
-> ParsecT Text () Identity (Token a)
-> ParsecT Text () Identity (Token a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser a -> ParsecT Text () Identity (Token a)
forall a. Parser a -> Parser (Token a)
fileName Parser a
p) ParsecT Text () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
  where
    entries :: [Token a] -> [(FilePath, a)]
    entries :: [Token a] -> [(FilePath, a)]
entries = (Token a -> [(FilePath, a)]) -> [Token a] -> [(FilePath, a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Token a -> [(FilePath, a)]
forall a. Token a -> [(FilePath, a)]
extract ([Token a] -> [(FilePath, a)])
-> ([Token a] -> [Token a]) -> [Token a] -> [(FilePath, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Token a -> Bool) -> [Token a] -> [Token a]
forall a. (a -> Bool) -> [a] -> [a]
filter Token a -> Bool
forall a. Token a -> Bool
predicate
    predicate :: Token a -> Bool
    predicate :: Token a -> Bool
predicate (Entry FilePath
_ a
_) = Bool
True
    predicate Token a
Comment = Bool
False
    extract :: Token a -> [(FilePath, a)]
    extract :: Token a -> [(FilePath, a)]
extract (Entry FilePath
f a
a) = [(FilePath
f, a
a)]
    extract Token a
Comment = []

-- | Parse a file name followed by whatever the second column parser
-- extracts.
fileName :: Parser a -> Parser (Token a)
fileName :: Parser a -> Parser (Token a)
fileName Parser a
p =
  do
    Char
first <- ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar
    FilePath
others <- ParsecT Text () Identity Char
-> ParsecT Text () Identity Char
-> ParsecT Text () Identity FilePath
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT Text () Identity Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space)
    a
a <- ParsecT Text () Identity ()
spaceWithoutNewline ParsecT Text () Identity () -> Parser a -> Parser a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser a
p
    Token a -> Parser (Token a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Token a -> Parser (Token a)) -> Token a -> Parser (Token a)
forall a b. (a -> b) -> a -> b
$ FilePath -> a -> Token a
forall a. FilePath -> a -> Token a
Entry (Char
first Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
others) a
a
    Parser (Token a) -> FilePath -> Parser (Token a)
forall s u (m :: * -> *) a.
ParsecT s u m a -> FilePath -> ParsecT s u m a
<?> FilePath
"filename and mapping"

-- | Skip whitespace.
whitespace :: Parser (Token a)
whitespace :: Parser (Token a)
whitespace = ParsecT Text () Identity Char -> ParsecT Text () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
skipMany1 ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space ParsecT Text () Identity () -> Parser (Token a) -> Parser (Token a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token a -> Parser (Token a)
forall (m :: * -> *) a. Monad m => a -> m a
return Token a
forall a. Token a
Comment

-- | Like whitespace, but doesn't span multiple lines.
spaceWithoutNewline :: Parser ()
spaceWithoutNewline :: ParsecT Text () Identity ()
spaceWithoutNewline = ParsecT Text () Identity Char -> ParsecT Text () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
skipMany1 (ParsecT Text () Identity Char -> ParsecT Text () Identity ())
-> ParsecT Text () Identity Char -> ParsecT Text () Identity ()
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (\Char
c -> Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')

-- | Skip comments.
comment :: Parser (Token a)
comment :: Parser (Token a)
comment = (Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'#' ParsecT Text () Identity Char
-> ParsecT Text () Identity FilePath
-> ParsecT Text () Identity FilePath
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT Text () Identity Char
-> ParsecT Text () Identity Char
-> ParsecT Text () Identity FilePath
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline ParsecT Text () Identity FilePath
-> Parser (Token a) -> Parser (Token a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token a -> Parser (Token a)
forall (m :: * -> *) a. Monad m => a -> m a
return Token a
forall a. Token a
Comment) Parser (Token a) -> FilePath -> Parser (Token a)
forall s u (m :: * -> *) a.
ParsecT s u m a -> FilePath -> ParsecT s u m a
<?> FilePath
"comment"