{-# LANGUAGE OverloadedStrings #-}
module CabalFmt.Pragma where

import qualified Data.ByteString                     as BS
import qualified Distribution.Compat.CharParsing     as C
import qualified Distribution.ModuleName             as C
import qualified Distribution.Parsec                 as C
import qualified Distribution.Parsec.FieldLineStream as C

import CabalFmt.Prelude
import CabalFmt.Comments
import CabalFmt.Glob

-------------------------------------------------------------------------------
-- Types
-------------------------------------------------------------------------------

data Pragma
    = FieldPragma FieldPragma
    | GlobalPragma GlobalPragma
  deriving (Int -> Pragma -> ShowS
[Pragma] -> ShowS
Pragma -> String
(Int -> Pragma -> ShowS)
-> (Pragma -> String) -> ([Pragma] -> ShowS) -> Show Pragma
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pragma] -> ShowS
$cshowList :: [Pragma] -> ShowS
show :: Pragma -> String
$cshow :: Pragma -> String
showsPrec :: Int -> Pragma -> ShowS
$cshowsPrec :: Int -> Pragma -> ShowS
Show)

-- | Pragmas applied per field
data FieldPragma
    = PragmaExpandModules FilePath [C.ModuleName]
    | PragmaGlobFiles Glob
    | PragmaFragment FilePath
  deriving (Int -> FieldPragma -> ShowS
[FieldPragma] -> ShowS
FieldPragma -> String
(Int -> FieldPragma -> ShowS)
-> (FieldPragma -> String)
-> ([FieldPragma] -> ShowS)
-> Show FieldPragma
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FieldPragma] -> ShowS
$cshowList :: [FieldPragma] -> ShowS
show :: FieldPragma -> String
$cshow :: FieldPragma -> String
showsPrec :: Int -> FieldPragma -> ShowS
$cshowsPrec :: Int -> FieldPragma -> ShowS
Show)

-- | Pragmas affecting global output
data GlobalPragma
    = PragmaOptIndent Int
    | PragmaOptTabular Bool
  deriving (Int -> GlobalPragma -> ShowS
[GlobalPragma] -> ShowS
GlobalPragma -> String
(Int -> GlobalPragma -> ShowS)
-> (GlobalPragma -> String)
-> ([GlobalPragma] -> ShowS)
-> Show GlobalPragma
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GlobalPragma] -> ShowS
$cshowList :: [GlobalPragma] -> ShowS
show :: GlobalPragma -> String
$cshow :: GlobalPragma -> String
showsPrec :: Int -> GlobalPragma -> ShowS
$cshowsPrec :: Int -> GlobalPragma -> ShowS
Show)

-------------------------------------------------------------------------------
-- Parser
-------------------------------------------------------------------------------

-- | Parse pragma from 'ByteString'.
--
-- An error ('Left') is reported only if input 'ByteString' starts with @-- cabal-fmt:@.
--
parsePragma :: ByteString -> Either String (Maybe Pragma)
parsePragma :: ByteString -> Either String (Maybe Pragma)
parsePragma ByteString
bs = case ByteString -> Maybe ByteString
dropPrefix ByteString
bs of
    Maybe ByteString
Nothing  -> Maybe Pragma -> Either String (Maybe Pragma)
forall a b. b -> Either a b
Right Maybe Pragma
forall a. Maybe a
Nothing
    Just ByteString
bs' -> (ParseError -> String)
-> (Pragma -> Maybe Pragma)
-> Either ParseError Pragma
-> Either String (Maybe Pragma)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ParseError -> String
forall a. Show a => a -> String
show Pragma -> Maybe Pragma
forall a. a -> Maybe a
Just (Either ParseError Pragma -> Either String (Maybe Pragma))
-> Either ParseError Pragma -> Either String (Maybe Pragma)
forall a b. (a -> b) -> a -> b
$ ParsecParser Pragma
-> String -> FieldLineStream -> Either ParseError Pragma
forall a.
ParsecParser a -> String -> FieldLineStream -> Either ParseError a
C.runParsecParser ParsecParser Pragma
parser String
"<input>" (FieldLineStream -> Either ParseError Pragma)
-> FieldLineStream -> Either ParseError Pragma
forall a b. (a -> b) -> a -> b
$ ByteString -> FieldLineStream
C.fieldLineStreamFromBS ByteString
bs'
  where
    dropPrefix :: ByteString -> Maybe ByteString
dropPrefix ByteString
bs0 = do
        ByteString
bs1 <- ByteString -> ByteString -> Maybe ByteString
BS.stripPrefix ByteString
"--" ByteString
bs0
        ByteString
bs2 <- ByteString -> ByteString -> Maybe ByteString
BS.stripPrefix ByteString
"cabal-fmt:" (ByteString -> ByteString
stripWhitespace ByteString
bs1)
        ByteString -> Maybe ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ByteString
stripWhitespace ByteString
bs2)

    parser :: C.ParsecParser Pragma
    parser :: ParsecParser Pragma
parser = do
        String
t <- ParsecParser String
forall (m :: * -> *). CabalParsing m => m String
C.parsecToken
        case String
t of
            String
"expand"     -> ParsecParser Pragma
expandModules
            String
"indent"     -> ParsecParser Pragma
indent
            String
"glob-files" -> ParsecParser Pragma
globFiles
            String
"tabular"    -> Pragma -> ParsecParser Pragma
forall (m :: * -> *) a. Monad m => a -> m a
return (Pragma -> ParsecParser Pragma) -> Pragma -> ParsecParser Pragma
forall a b. (a -> b) -> a -> b
$ GlobalPragma -> Pragma
GlobalPragma (GlobalPragma -> Pragma) -> GlobalPragma -> Pragma
forall a b. (a -> b) -> a -> b
$ Bool -> GlobalPragma
PragmaOptTabular Bool
True
            String
"no-tabular" -> Pragma -> ParsecParser Pragma
forall (m :: * -> *) a. Monad m => a -> m a
return (Pragma -> ParsecParser Pragma) -> Pragma -> ParsecParser Pragma
forall a b. (a -> b) -> a -> b
$ GlobalPragma -> Pragma
GlobalPragma (GlobalPragma -> Pragma) -> GlobalPragma -> Pragma
forall a b. (a -> b) -> a -> b
$ Bool -> GlobalPragma
PragmaOptTabular Bool
False
            String
"fragment"   -> ParsecParser Pragma
fragment
            String
_            -> String -> ParsecParser Pragma
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecParser Pragma) -> String -> ParsecParser Pragma
forall a b. (a -> b) -> a -> b
$ String
"Unknown pragma " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
t

    expandModules :: C.ParsecParser Pragma
    expandModules :: ParsecParser Pragma
expandModules = do
        ParsecParser ()
forall (m :: * -> *). CharParsing m => m ()
C.spaces
        String
dir <- ParsecParser String
forall (m :: * -> *). CabalParsing m => m String
C.parsecToken
        [ModuleName]
mns <- ParsecParser ModuleName -> ParsecParser [ModuleName]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
C.many (ParsecParser Char
forall (m :: * -> *). CharParsing m => m Char
C.space ParsecParser Char -> ParsecParser () -> ParsecParser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecParser ()
forall (m :: * -> *). CharParsing m => m ()
C.spaces ParsecParser () -> ParsecParser Char -> ParsecParser Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> ParsecParser Char
forall (m :: * -> *). CharParsing m => Char -> m Char
C.char Char
'-' ParsecParser Char
-> ParsecParser ModuleName -> ParsecParser ModuleName
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecParser ModuleName
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
C.parsec)
        Pragma -> ParsecParser Pragma
forall (m :: * -> *) a. Monad m => a -> m a
return (Pragma -> ParsecParser Pragma) -> Pragma -> ParsecParser Pragma
forall a b. (a -> b) -> a -> b
$ FieldPragma -> Pragma
FieldPragma (FieldPragma -> Pragma) -> FieldPragma -> Pragma
forall a b. (a -> b) -> a -> b
$ String -> [ModuleName] -> FieldPragma
PragmaExpandModules String
dir [ModuleName]
mns

    indent :: C.ParsecParser Pragma
    indent :: ParsecParser Pragma
indent = do
        ParsecParser ()
forall (m :: * -> *). CharParsing m => m ()
C.spaces
        Int
n <- ParsecParser Int
forall (m :: * -> *) a. (CharParsing m, Integral a) => m a
C.integral
        Pragma -> ParsecParser Pragma
forall (m :: * -> *) a. Monad m => a -> m a
return (Pragma -> ParsecParser Pragma) -> Pragma -> ParsecParser Pragma
forall a b. (a -> b) -> a -> b
$ GlobalPragma -> Pragma
GlobalPragma (GlobalPragma -> Pragma) -> GlobalPragma -> Pragma
forall a b. (a -> b) -> a -> b
$ Int -> GlobalPragma
PragmaOptIndent Int
n

    fragment :: C.ParsecParser Pragma
    fragment :: ParsecParser Pragma
fragment = do
        ParsecParser ()
forall (m :: * -> *). CharParsing m => m ()
C.spaces
        String
fn <- ParsecParser String
forall (m :: * -> *). CabalParsing m => m String
C.parsecToken
        Pragma -> ParsecParser Pragma
forall (m :: * -> *) a. Monad m => a -> m a
return (Pragma -> ParsecParser Pragma) -> Pragma -> ParsecParser Pragma
forall a b. (a -> b) -> a -> b
$ FieldPragma -> Pragma
FieldPragma (FieldPragma -> Pragma) -> FieldPragma -> Pragma
forall a b. (a -> b) -> a -> b
$ String -> FieldPragma
PragmaFragment String
fn

    globFiles :: C.ParsecParser Pragma
    globFiles :: ParsecParser Pragma
globFiles = do
        ParsecParser ()
forall (m :: * -> *). CharParsing m => m ()
C.spaces
        String
t <- ParsecParser String
forall (m :: * -> *). CabalParsing m => m String
C.parsecToken
        case String -> Either String Glob
parseGlob String
t of
            Right Glob
g -> Pragma -> ParsecParser Pragma
forall (m :: * -> *) a. Monad m => a -> m a
return (Pragma -> ParsecParser Pragma) -> Pragma -> ParsecParser Pragma
forall a b. (a -> b) -> a -> b
$ FieldPragma -> Pragma
FieldPragma (FieldPragma -> Pragma) -> FieldPragma -> Pragma
forall a b. (a -> b) -> a -> b
$ Glob -> FieldPragma
PragmaGlobFiles Glob
g
            Left String
e  -> String -> ParsecParser Pragma
forall (m :: * -> *) a. Parsing m => String -> m a
C.unexpected String
e

stripWhitespace :: ByteString -> ByteString
stripWhitespace :: ByteString -> ByteString
stripWhitespace ByteString
bs = case ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
bs of
    Maybe (Word8, ByteString)
Nothing                   -> ByteString
bs
    Just (Word8
w, ByteString
bs') | Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
32   -> ByteString -> ByteString
stripWhitespace ByteString
bs'
                  | Bool
otherwise -> ByteString
bs

parsePragmas :: Comments -> ([String], [Pragma])
parsePragmas :: Comments -> ([String], [Pragma])
parsePragmas = ([Maybe Pragma] -> [Pragma])
-> ([String], [Maybe Pragma]) -> ([String], [Pragma])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe Pragma] -> [Pragma]
forall a. [Maybe a] -> [a]
catMaybes (([String], [Maybe Pragma]) -> ([String], [Pragma]))
-> (Comments -> ([String], [Maybe Pragma]))
-> Comments
-> ([String], [Pragma])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either String (Maybe Pragma)] -> ([String], [Maybe Pragma])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either String (Maybe Pragma)] -> ([String], [Maybe Pragma]))
-> (Comments -> [Either String (Maybe Pragma)])
-> Comments
-> ([String], [Maybe Pragma])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Either String (Maybe Pragma))
-> [ByteString] -> [Either String (Maybe Pragma)]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Either String (Maybe Pragma)
parsePragma ([ByteString] -> [Either String (Maybe Pragma)])
-> (Comments -> [ByteString])
-> Comments
-> [Either String (Maybe Pragma)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Comments -> [ByteString]
unComments