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
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
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
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
""
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
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
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