{-# 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
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
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
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  -> forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
    Just ByteString
bs' -> forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a. Show a => a -> String
show forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a.
ParsecParser a -> String -> FieldLineStream -> Either ParseError a
C.runParsecParser ParsecParser Pragma
parser String
"<input>" 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)
        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 <- 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"    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ GlobalPragma -> Pragma
GlobalPragma forall a b. (a -> b) -> a -> b
$ Bool -> GlobalPragma
PragmaOptTabular Bool
True
            String
"no-tabular" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ GlobalPragma -> Pragma
GlobalPragma forall a b. (a -> b) -> a -> b
$ Bool -> GlobalPragma
PragmaOptTabular Bool
False
            String
"fragment"   -> ParsecParser Pragma
fragment
            String
_            -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unknown pragma " forall a. [a] -> [a] -> [a]
++ String
t

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

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

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

    globFiles :: C.ParsecParser Pragma
    globFiles :: ParsecParser Pragma
globFiles = do
        forall (m :: * -> *). CharParsing m => m ()
C.spaces
        String
t <- forall (m :: * -> *). CabalParsing m => m String
C.parsecToken
        case String -> Either String Glob
parseGlob String
t of
            Right Glob
g -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FieldPragma -> Pragma
FieldPragma forall a b. (a -> b) -> a -> b
$ Glob -> FieldPragma
PragmaGlobFiles Glob
g
            Left String
e  -> 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 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [Either a b] -> ([a], [b])
partitionEithers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Either String (Maybe Pragma)
parsePragma forall b c a. (b -> c) -> (a -> b) -> a -> c
. Comments -> [ByteString]
unComments