-- |Description: Parser for the "Data.Prune.ApplyStrategy.Smart" strategy.
module Data.Prune.Section.Parser where

import Prelude

import Control.Applicative ((<|>))
import Control.Arrow (left)
import Control.Monad (void)
import Data.Text (pack, unpack)
import Data.Void (Void)
import Text.Megaparsec (Parsec, many, noneOf, parse, some, try)
import Text.Megaparsec.Char (alphaNumChar, char, eol, hspace, hspace1, string)

import qualified Data.Prune.Section.Types as T
import qualified Data.Prune.Types as T

type Parser = Parsec Void String

targetName :: Parser T.CompilableName
targetName :: Parser CompilableName
targetName = Text -> CompilableName
T.CompilableName (Text -> CompilableName)
-> (String -> Text) -> String -> CompilableName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> CompilableName)
-> ParsecT Void String Identity String -> Parser CompilableName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity Char
-> ParsecT Void String Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (ParsecT Void String Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar ParsecT Void String Identity Char
-> ParsecT Void String Identity Char
-> ParsecT Void String Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'-')

restOfLine :: Parser String
restOfLine :: ParsecT Void String Identity String
restOfLine = ParsecT Void String Identity Char
-> ParsecT Void String Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ([Token String] -> ParsecT Void String Identity (Token String)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf (String
"\r\n" :: String)) ParsecT Void String Identity String
-> ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity String
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol

emptyLine :: Parser String
emptyLine :: ParsecT Void String Identity String
emptyLine = String
"" String
-> ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT Void String Identity String
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol

-- |Parse an indented line with @indentedLine numSpaces@, failing if the line isn't indented to @numSpaces@.
indentedLine :: Int -> Parser String
indentedLine :: Int -> ParsecT Void String Identity String
indentedLine Int
numSpaces = do
  String
spaces <- ParsecT Void String Identity Char
-> ParsecT Void String Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
' ')
  let n :: Int
n = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
spaces
  case Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
numSpaces of
    Bool
True -> String -> ParsecT Void String Identity String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT Void String Identity String)
-> String -> ParsecT Void String Identity String
forall a b. (a -> b) -> a -> b
$ String
"indentation: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
numSpaces String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
    Bool
False -> (String
spaces String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String)
-> ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity String
restOfLine

-- |Parse many indented lines with @indentedLines numSpaces@, traversing empty lines until the line isn't indented to @numSpaces@.
indentedLines :: Int -> Parser [String]
indentedLines :: Int -> Parser [String]
indentedLines Int
numSpaces = (:) (String -> [String] -> [String])
-> ParsecT Void String Identity String
-> ParsecT Void String Identity ([String] -> [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity String
restOfLine ParsecT Void String Identity ([String] -> [String])
-> Parser [String] -> Parser [String]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void String Identity String -> Parser [String]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Int -> ParsecT Void String Identity String
indentedLine Int
numSpaces ParsecT Void String Identity String
-> ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void String Identity String
emptyLine))

nestedSection :: Parser T.NestedSection
nestedSection :: Parser NestedSection
nestedSection = do
  Int
numSpaces <- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int)
-> ParsecT Void String Identity String
-> ParsecT Void String Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity Char
-> ParsecT Void String Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
' ')
  let buildDepends :: Parser NestedSection
buildDepends = do
        ParsecT Void String Identity String
-> ParsecT Void String Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void String Identity String
 -> ParsecT Void String Identity ())
-> ParsecT Void String Identity String
-> ParsecT Void String Identity ()
forall a b. (a -> b) -> a -> b
$ Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens String
"build-depends:"
        Int -> [String] -> NestedSection
T.BuildDependsNestedSection Int
numSpaces ([String] -> NestedSection)
-> Parser [String] -> Parser NestedSection
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser [String]
indentedLines Int
numSpaces
      import_ :: Parser NestedSection
import_ = do
        ParsecT Void String Identity String
-> ParsecT Void String Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void String Identity String
 -> ParsecT Void String Identity ())
-> ParsecT Void String Identity String
-> ParsecT Void String Identity ()
forall a b. (a -> b) -> a -> b
$ Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens String
"import:"
        Int -> [String] -> NestedSection
T.ImportNestedSection Int
numSpaces ([String] -> NestedSection)
-> Parser [String] -> Parser NestedSection
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser [String]
indentedLines Int
numSpaces
      other :: Parser NestedSection
other = Int -> [String] -> NestedSection
T.OtherNestedSection Int
numSpaces ([String] -> NestedSection)
-> Parser [String] -> Parser NestedSection
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser [String]
indentedLines Int
numSpaces
  Parser NestedSection
buildDepends Parser NestedSection
-> Parser NestedSection -> Parser NestedSection
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser NestedSection
import_ Parser NestedSection
-> Parser NestedSection -> Parser NestedSection
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser NestedSection
other

nestedSections :: Parser [T.NestedSection]
nestedSections :: Parser [NestedSection]
nestedSections = Parser NestedSection -> Parser [NestedSection]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some Parser NestedSection
nestedSection

section :: Parser T.Section
section :: Parser Section
section =
  let lib :: Parser Section
lib = do
        ParsecT Void String Identity String
-> ParsecT Void String Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void String Identity String
 -> ParsecT Void String Identity ())
-> ParsecT Void String Identity String
-> ParsecT Void String Identity ()
forall a b. (a -> b) -> a -> b
$ Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens String
"library"
        ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace
        ParsecT Void String Identity String
-> ParsecT Void String Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void String Identity String
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol
        CompilableType
-> Maybe CompilableName -> [NestedSection] -> Section
T.TargetSection CompilableType
T.CompilableTypeLibrary Maybe CompilableName
forall a. Maybe a
Nothing ([NestedSection] -> Section)
-> Parser [NestedSection] -> Parser Section
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [NestedSection]
nestedSections
      target :: CompilableType -> String -> Parser Section
target CompilableType
typ String
typName = do
        ParsecT Void String Identity String
-> ParsecT Void String Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void String Identity String
 -> ParsecT Void String Identity ())
-> ParsecT Void String Identity String
-> ParsecT Void String Identity ()
forall a b. (a -> b) -> a -> b
$ Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string String
Tokens String
typName
        ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace1
        CompilableName
name <- Parser CompilableName
targetName
        ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace
        ParsecT Void String Identity String
-> ParsecT Void String Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void String Identity String
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol
        CompilableType
-> Maybe CompilableName -> [NestedSection] -> Section
T.TargetSection CompilableType
typ (CompilableName -> Maybe CompilableName
forall a. a -> Maybe a
Just CompilableName
name) ([NestedSection] -> Section)
-> Parser [NestedSection] -> Parser Section
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [NestedSection]
nestedSections
      common :: Parser Section
common = do
        ParsecT Void String Identity String
-> ParsecT Void String Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void String Identity String
 -> ParsecT Void String Identity ())
-> ParsecT Void String Identity String
-> ParsecT Void String Identity ()
forall a b. (a -> b) -> a -> b
$ Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens String
"common"
        ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace1
        CommonName
name <- Text -> CommonName
T.CommonName (Text -> CommonName) -> (String -> Text) -> String -> CommonName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> CommonName)
-> ParsecT Void String Identity String
-> ParsecT Void String Identity CommonName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity String
restOfLine
        CommonName -> [NestedSection] -> Section
T.CommonSection CommonName
name ([NestedSection] -> Section)
-> Parser [NestedSection] -> Parser Section
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [NestedSection]
nestedSections
      sublib :: Parser Section
sublib = CompilableType -> String -> Parser Section
target CompilableType
T.CompilableTypeLibrary String
"library"
      exe :: Parser Section
exe = CompilableType -> String -> Parser Section
target CompilableType
T.CompilableTypeExecutable String
"executable"
      test :: Parser Section
test = CompilableType -> String -> Parser Section
target CompilableType
T.CompilableTypeTest String
"test-suite"
      bench :: Parser Section
bench = CompilableType -> String -> Parser Section
target CompilableType
T.CompilableTypeBenchmark String
"benchmark"
      other :: Parser Section
other = [String] -> Section
T.OtherSection ([String] -> Section) -> Parser [String] -> Parser Section
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser [String]
indentedLines Int
0
  in Parser Section
lib Parser Section -> Parser Section -> Parser Section
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Section
sublib Parser Section -> Parser Section -> Parser Section
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Section
exe Parser Section -> Parser Section -> Parser Section
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Section
test Parser Section -> Parser Section -> Parser Section
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Section
bench Parser Section -> Parser Section -> Parser Section
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Section
common Parser Section -> Parser Section -> Parser Section
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Section
other

sections :: Parser [T.Section]
sections :: Parser [Section]
sections = Parser Section -> Parser [Section]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some Parser Section
section

-- |Parse using 'sections'.
parseCabalSections :: String -> Either String [T.Section]
parseCabalSections :: String -> Either String [Section]
parseCabalSections = (ParseErrorBundle String Void -> String)
-> Either (ParseErrorBundle String Void) [Section]
-> Either String [Section]
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ParseErrorBundle String Void -> String
forall a. Show a => a -> String
show (Either (ParseErrorBundle String Void) [Section]
 -> Either String [Section])
-> (String -> Either (ParseErrorBundle String Void) [Section])
-> String
-> Either String [Section]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser [Section]
-> String
-> String
-> Either (ParseErrorBundle String Void) [Section]
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parser [Section]
sections String
""

-- |Render sections. @parseCabalSections . renderCabalSections@ should be equivalent to @Right@.
renderCabalSections :: [T.Section] -> String
renderCabalSections :: [Section] -> String
renderCabalSections = (Section -> String -> String) -> String -> [Section] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Section -> String -> String
go String
forall a. Monoid a => a
mempty
  where
    go2 :: NestedSection -> String -> String
go2 NestedSection
next String
accum = case NestedSection
next of
      T.BuildDependsNestedSection Int
numSpaces [String]
dependencies -> Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
numSpaces Char
' ' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"build-depends:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines [String]
dependencies String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
accum
      T.ImportNestedSection Int
numSpaces [String]
imports -> Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
numSpaces Char
' ' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"import:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines [String]
imports String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
accum
      T.OtherNestedSection Int
numSpaces [String]
rest -> Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
numSpaces Char
' ' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines [String]
rest String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
accum
    go :: Section -> String -> String
go Section
next String
accum =
      let str :: String
str = case Section
next of
            T.TargetSection CompilableType
compilableType Maybe CompilableName
compilableNameMay [NestedSection]
nested ->
              let sectionType :: String
sectionType = case CompilableType
compilableType of
                    CompilableType
T.CompilableTypeLibrary -> String
"library"
                    CompilableType
T.CompilableTypeExecutable -> String
"executable"
                    CompilableType
T.CompilableTypeTest -> String
"test-suite"
                    CompilableType
T.CompilableTypeBenchmark -> String
"benchmark"
                  sectionName :: String
sectionName = case Maybe CompilableName
compilableNameMay of
                    Maybe CompilableName
Nothing -> String
""
                    Just (T.CompilableName Text
name) -> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
name
              in String
sectionType String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
sectionName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (NestedSection -> String -> String)
-> String -> [NestedSection] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr NestedSection -> String -> String
go2 String
forall a. Monoid a => a
mempty [NestedSection]
nested
            T.CommonSection (T.CommonName Text
name) [NestedSection]
nested ->
              String
"common " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (NestedSection -> String -> String)
-> String -> [NestedSection] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr NestedSection -> String -> String
go2 String
forall a. Monoid a => a
mempty [NestedSection]
nested
            T.OtherSection [String]
xs -> [String] -> String
unlines [String]
xs
      in String
str String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
accum

-- |Read sections from a file using 'parseCabalSections'.
readCabalSections :: FilePath -> IO (Either String [T.Section])
readCabalSections :: String -> IO (Either String [Section])
readCabalSections String
cabalFile = String -> Either String [Section]
parseCabalSections (String -> Either String [Section])
-> IO String -> IO (Either String [Section])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
cabalFile

-- |Write sections to a file using 'renderCabalSections'.
writeCabalSections :: FilePath -> [T.Section] -> IO ()
writeCabalSections :: String -> [Section] -> IO ()
writeCabalSections String
cabalFile = String -> String -> IO ()
writeFile String
cabalFile (String -> IO ()) -> ([Section] -> String) -> [Section] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Section] -> String
renderCabalSections