{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
-- |
-- License: GPL-3.0-or-later
-- Copyright: Oleg Grenrus
--
-- This is a demo application of how you can make Cabal-like
-- file formatter.
--
module CabalFmt (cabalFmt) where

import Control.Monad        (join)
import Control.Monad.Reader (asks, local)

import qualified Data.ByteString                              as BS
import qualified Distribution.CabalSpecVersion                as C
import qualified Distribution.FieldGrammar.Parsec             as C
import qualified Distribution.Fields                          as C
import qualified Distribution.Fields.ConfVar                  as C
import qualified Distribution.Fields.Pretty                   as C
import qualified Distribution.PackageDescription.FieldGrammar as C
import qualified Distribution.Parsec                          as C
import qualified Distribution.Pretty                          as C
import qualified Distribution.Types.Condition                 as C
import qualified Distribution.Types.ConfVar                   as C
import qualified Distribution.Types.GenericPackageDescription as C
import qualified Distribution.Types.PackageDescription        as C
import qualified Distribution.Types.VersionRange              as C
import qualified Distribution.Utils.Generic                   as C
import qualified Text.PrettyPrint                             as PP

import CabalFmt.Comments
import CabalFmt.Fields
import CabalFmt.Fields.BuildDepends
import CabalFmt.Fields.Extensions
import CabalFmt.FreeText
import CabalFmt.Fields.Modules
import CabalFmt.Fields.SourceFiles
import CabalFmt.Fields.TestedWith
import CabalFmt.Monad
import CabalFmt.Options
import CabalFmt.Parser
import CabalFmt.Pragma
import CabalFmt.Prelude
import CabalFmt.Refactoring

-------------------------------------------------------------------------------
-- Main
-------------------------------------------------------------------------------

cabalFmt :: MonadCabalFmt r m => FilePath -> BS.ByteString -> m String
cabalFmt :: forall r (m :: * -> *).
MonadCabalFmt r m =>
String -> ByteString -> m String
cabalFmt String
filepath ByteString
contents = do
    -- determine cabal-version
    Bool
cabalFile <- (r -> Bool) -> m Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Options -> Bool
optCabalFile (Options -> Bool) -> (r -> Options) -> r -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Options r Options -> r -> Options
forall a s. Getting a s a -> s -> a
view Getting Options r Options
forall e (f :: * -> *).
(HasOptions e, Functor f) =>
LensLike' f e Options
forall (f :: * -> *). Functor f => LensLike' f r Options
options)
    CabalSpecVersion
csv <- case Bool
cabalFile of
        Bool
False -> CabalSpecVersion -> m CabalSpecVersion
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return CabalSpecVersion
C.cabalSpecLatest
        Bool
True  -> do
            GenericPackageDescription
gpd <- String -> ByteString -> m GenericPackageDescription
forall r (m :: * -> *).
MonadCabalFmt r m =>
String -> ByteString -> m GenericPackageDescription
parseGpd String
filepath ByteString
contents
            CabalSpecVersion -> m CabalSpecVersion
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CabalSpecVersion -> m CabalSpecVersion)
-> CabalSpecVersion -> m CabalSpecVersion
forall a b. (a -> b) -> a -> b
$ PackageDescription -> CabalSpecVersion
C.specVersion
              (PackageDescription -> CabalSpecVersion)
-> PackageDescription -> CabalSpecVersion
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
C.packageDescription GenericPackageDescription
gpd

    [Field Position]
inputFields' <- ByteString -> m [Field Position]
forall r (m :: * -> *).
MonadCabalFmt r m =>
ByteString -> m [Field Position]
parseFields ByteString
contents
    let ([Field (Position, Comments)]
inputFieldsC, Comments
endComments) = ByteString
-> [Field Position] -> ([Field (Position, Comments)], Comments)
attachComments ByteString
contents [Field Position]
inputFields'

    -- parse pragmas
    let parse :: (a, Comments) -> f (a, Comments, [Pragma])
parse (a
pos, Comments
c) = case Comments -> ([String], [Pragma])
parsePragmas Comments
c of ([String]
ws, [Pragma]
ps) -> (String -> f ()) -> [String] -> f ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ String -> f ()
forall r (m :: * -> *). MonadCabalFmt r m => String -> m ()
displayWarning [String]
ws f () -> f (a, Comments, [Pragma]) -> f (a, Comments, [Pragma])
forall a b. f a -> f b -> f b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (a, Comments, [Pragma]) -> f (a, Comments, [Pragma])
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
pos, Comments
c, [Pragma]
ps)
    [Field (Position, Comments, [Pragma])]
inputFieldsP' <- (Field (Position, Comments)
 -> m (Field (Position, Comments, [Pragma])))
-> [Field (Position, Comments)]
-> m [Field (Position, Comments, [Pragma])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (((Position, Comments) -> m (Position, Comments, [Pragma]))
-> Field (Position, Comments)
-> m (Field (Position, Comments, [Pragma]))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Field a -> f (Field b)
traverse (Position, Comments) -> m (Position, Comments, [Pragma])
forall {f :: * -> *} {r} {a}.
MonadCabalFmt r f =>
(a, Comments) -> f (a, Comments, [Pragma])
parse) [Field (Position, Comments)]
inputFieldsC
    [Pragma]
endCommentsPragmas <- case Comments -> ([String], [Pragma])
parsePragmas Comments
endComments of
        ([String]
ws, [Pragma]
ps) -> (String -> m ()) -> [String] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ String -> m ()
forall r (m :: * -> *). MonadCabalFmt r m => String -> m ()
displayWarning [String]
ws m () -> m [Pragma] -> m [Pragma]
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Pragma] -> m [Pragma]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Pragma]
ps

    -- apply refactorings
    let inputFieldsP :: [C.Field CommentsPragmas]
        inputFieldsP :: [Field CommentsPragmas]
inputFieldsP = (Field (Position, Comments, [Pragma]) -> Field CommentsPragmas)
-> [Field (Position, Comments, [Pragma])]
-> [Field CommentsPragmas]
forall a b. (a -> b) -> [a] -> [b]
map (((Position, Comments, [Pragma]) -> CommentsPragmas)
-> Field (Position, Comments, [Pragma]) -> Field CommentsPragmas
forall a b. (a -> b) -> Field a -> Field b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Pragma] -> [FieldPragma])
-> (Position, Comments, [Pragma]) -> CommentsPragmas
forall a b.
(a -> b) -> (Position, Comments, a) -> (Position, Comments, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([GlobalPragma], [FieldPragma]) -> [FieldPragma]
forall a b. (a, b) -> b
snd (([GlobalPragma], [FieldPragma]) -> [FieldPragma])
-> ([Pragma] -> ([GlobalPragma], [FieldPragma]))
-> [Pragma]
-> [FieldPragma]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pragma] -> ([GlobalPragma], [FieldPragma])
partitionPragmas))) [Field (Position, Comments, [Pragma])]
inputFieldsP'

    [Field CommentsPragmas]
inputFieldsR  <- [Field CommentsPragmas] -> m [Field CommentsPragmas]
forall (m :: * -> *) r.
MonadCabalFmt r m =>
[Field CommentsPragmas] -> m [Field CommentsPragmas]
refactor [Field CommentsPragmas]
inputFieldsP

    -- options morphisms
    let pragmas :: [GlobalPragma]
        pragmas :: [GlobalPragma]
pragmas = ([GlobalPragma], [FieldPragma]) -> [GlobalPragma]
forall a b. (a, b) -> a
fst (([GlobalPragma], [FieldPragma]) -> [GlobalPragma])
-> ([GlobalPragma], [FieldPragma]) -> [GlobalPragma]
forall a b. (a -> b) -> a -> b
$ [Pragma] -> ([GlobalPragma], [FieldPragma])
partitionPragmas ([Pragma] -> ([GlobalPragma], [FieldPragma]))
-> [Pragma] -> ([GlobalPragma], [FieldPragma])
forall a b. (a -> b) -> a -> b
$
            (Field (Position, Comments, [Pragma]) -> [Pragma])
-> [Field (Position, Comments, [Pragma])] -> [Pragma]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (((Position, Comments, [Pragma]) -> [Pragma])
-> Field (Position, Comments, [Pragma]) -> [Pragma]
forall m a. Monoid m => (a -> m) -> Field a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Position, Comments, [Pragma]) -> [Pragma]
forall a b c. (a, b, c) -> c
trdOf3) [Field (Position, Comments, [Pragma])]
inputFieldsP' [Pragma] -> [Pragma] -> [Pragma]
forall a. Semigroup a => a -> a -> a
<> [Pragma]
endCommentsPragmas

        optsEndo :: OptionsMorphism
        optsEndo :: OptionsMorphism
optsEndo = (GlobalPragma -> OptionsMorphism)
-> [GlobalPragma] -> OptionsMorphism
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap GlobalPragma -> OptionsMorphism
pragmaToOM [GlobalPragma]
pragmas

    (r -> r) -> m String -> m String
forall a. (r -> r) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter r r Options Options -> (Options -> Options) -> r -> r
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter r r Options Options
forall e (f :: * -> *).
(HasOptions e, Functor f) =>
LensLike' f e Options
forall (f :: * -> *). Functor f => LensLike' f r Options
options ((Options -> Options) -> r -> r) -> (Options -> Options) -> r -> r
forall a b. (a -> b) -> a -> b
$ \Options
o -> OptionsMorphism -> Options -> Options
runOptionsMorphism OptionsMorphism
optsEndo (Options -> Options) -> Options -> Options
forall a b. (a -> b) -> a -> b
$ Options
o { optSpecVersion = csv }) (m String -> m String) -> m String -> m String
forall a b. (a -> b) -> a -> b
$ do
        Int
indentWith <- (r -> Int) -> m Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Options -> Int
optIndent (Options -> Int) -> (r -> Options) -> r -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Options r Options -> r -> Options
forall a s. Getting a s a -> s -> a
view Getting Options r Options
forall e (f :: * -> *).
(HasOptions e, Functor f) =>
LensLike' f e Options
forall (f :: * -> *). Functor f => LensLike' f r Options
options)
        let inputFields :: [Field CommentsPragmas]
inputFields = [Field CommentsPragmas]
inputFieldsR

        [PrettyField CommentsPragmas]
outputPrettyFields <- (ByteString
 -> CommentsPragmas -> [FieldLine CommentsPragmas] -> m Doc)
-> (ByteString -> [SectionArg CommentsPragmas] -> m [Doc])
-> [Field CommentsPragmas]
-> m [PrettyField CommentsPragmas]
forall (f :: * -> *) ann.
Applicative f =>
(ByteString -> ann -> [FieldLine ann] -> f Doc)
-> (ByteString -> [SectionArg ann] -> f [Doc])
-> [Field ann]
-> f [PrettyField ann]
genericFromParsecFields
            (\ByteString
n CommentsPragmas
ann -> ByteString -> Position -> [FieldLine CommentsPragmas] -> m Doc
forall r (m :: * -> *).
MonadCabalFmt r m =>
ByteString -> Position -> [FieldLine CommentsPragmas] -> m Doc
prettyFieldLines ByteString
n (CommentsPragmas -> Position
forall a b c. (a, b, c) -> a
fstOf3 CommentsPragmas
ann))
            ByteString -> [SectionArg CommentsPragmas] -> m [Doc]
forall r (m :: * -> *) ann.
MonadCabalFmt r m =>
ByteString -> [SectionArg ann] -> m [Doc]
prettySectionArgs
            [Field CommentsPragmas]
inputFields

        String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ (CommentsPragmas -> CommentPosition)
-> (CommentsPragmas -> [String] -> [String])
-> Int
-> [PrettyField CommentsPragmas]
-> String
forall ann.
(ann -> CommentPosition)
-> (ann -> [String] -> [String])
-> Int
-> [PrettyField ann]
-> String
C.showFields' (Comments -> CommentPosition
fromComments (Comments -> CommentPosition)
-> (CommentsPragmas -> Comments)
-> CommentsPragmas
-> CommentPosition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommentsPragmas -> Comments
forall a b c. (a, b, c) -> b
sndOf3) (([String] -> [String]) -> CommentsPragmas -> [String] -> [String]
forall a b. a -> b -> a
const [String] -> [String]
forall a. a -> a
id) Int
indentWith [PrettyField CommentsPragmas]
outputPrettyFields
            String -> (String -> String) -> String
forall a b. a -> (a -> b) -> b
& if Comments -> Bool
nullComments Comments
endComments then String -> String
forall a. a -> a
id else
                (String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (String
"" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [ ByteString -> String
C.fromUTF8BS ByteString
c | ByteString
c <- Comments -> [ByteString]
unComments Comments
endComments ]))

fromComments :: Comments -> C.CommentPosition
fromComments :: Comments -> CommentPosition
fromComments (Comments [])  = CommentPosition
C.NoComment
fromComments (Comments [ByteString]
bss) = [String] -> CommentPosition
C.CommentBefore ((ByteString -> String) -> [ByteString] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> String
C.fromUTF8BS [ByteString]
bss)

genericFromParsecFields
    :: Applicative f
    => (C.FieldName -> ann -> [C.FieldLine ann] -> f PP.Doc)     -- ^ transform field contents
    -> (C.FieldName -> [C.SectionArg ann] -> f [PP.Doc])  -- ^ transform section arguments
    -> [C.Field ann]
    -> f [C.PrettyField ann]
genericFromParsecFields :: forall (f :: * -> *) ann.
Applicative f =>
(ByteString -> ann -> [FieldLine ann] -> f Doc)
-> (ByteString -> [SectionArg ann] -> f [Doc])
-> [Field ann]
-> f [PrettyField ann]
genericFromParsecFields ByteString -> ann -> [FieldLine ann] -> f Doc
f ByteString -> [SectionArg ann] -> f [Doc]
g = [Field ann] -> f [PrettyField ann]
goMany where
    goMany :: [Field ann] -> f [PrettyField ann]
goMany = (Field ann -> f (PrettyField ann))
-> [Field ann] -> f [PrettyField ann]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Field ann -> f (PrettyField ann)
go

    go :: Field ann -> f (PrettyField ann)
go (C.Field (C.Name ann
ann ByteString
name) [FieldLine ann]
fls)          = ann -> ByteString -> Doc -> PrettyField ann
forall ann. ann -> ByteString -> Doc -> PrettyField ann
C.PrettyField ann
ann ByteString
name (Doc -> PrettyField ann) -> f Doc -> f (PrettyField ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> ann -> [FieldLine ann] -> f Doc
f ByteString
name ann
ann [FieldLine ann]
fls
    go (C.Section (C.Name ann
ann ByteString
name) [SectionArg ann]
secargs [Field ann]
fs) = ann -> ByteString -> [Doc] -> [PrettyField ann] -> PrettyField ann
forall ann.
ann -> ByteString -> [Doc] -> [PrettyField ann] -> PrettyField ann
C.PrettySection ann
ann ByteString
name ([Doc] -> [PrettyField ann] -> PrettyField ann)
-> f [Doc] -> f ([PrettyField ann] -> PrettyField ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> [SectionArg ann] -> f [Doc]
g ByteString
name [SectionArg ann]
secargs f ([PrettyField ann] -> PrettyField ann)
-> f [PrettyField ann] -> f (PrettyField ann)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Field ann] -> f [PrettyField ann]
goMany [Field ann]
fs

-------------------------------------------------------------------------------
-- Field prettyfying
-------------------------------------------------------------------------------

prettyFieldLines :: MonadCabalFmt r m => C.FieldName -> C.Position -> [C.FieldLine CommentsPragmas] -> m PP.Doc
prettyFieldLines :: forall r (m :: * -> *).
MonadCabalFmt r m =>
ByteString -> Position -> [FieldLine CommentsPragmas] -> m Doc
prettyFieldLines ByteString
fn Position
pos [FieldLine CommentsPragmas]
fls =
    Doc -> Maybe Doc -> Doc
forall a. a -> Maybe a -> a
fromMaybe (ByteString -> [FieldLine CommentsPragmas] -> Doc
forall ann. ByteString -> [FieldLine ann] -> Doc
C.prettyFieldLines ByteString
fn [FieldLine CommentsPragmas]
fls) (Maybe Doc -> Doc) -> m (Maybe Doc) -> m Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString
-> Position -> [FieldLine CommentsPragmas] -> m (Maybe Doc)
forall r (m :: * -> *).
MonadCabalFmt r m =>
ByteString
-> Position -> [FieldLine CommentsPragmas] -> m (Maybe Doc)
knownField ByteString
fn Position
pos [FieldLine CommentsPragmas]
fls

knownField :: MonadCabalFmt r m => C.FieldName -> C.Position -> [C.FieldLine CommentsPragmas] -> m (Maybe PP.Doc)
knownField :: forall r (m :: * -> *).
MonadCabalFmt r m =>
ByteString
-> Position -> [FieldLine CommentsPragmas] -> m (Maybe Doc)
knownField ByteString
fn Position
pos [FieldLine CommentsPragmas]
fls = do
    Options
opts <- (r -> Options) -> m Options
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Getting Options r Options -> r -> Options
forall a s. Getting a s a -> s -> a
view Getting Options r Options
forall e (f :: * -> *).
(HasOptions e, Functor f) =>
LensLike' f e Options
forall (f :: * -> *). Functor f => LensLike' f r Options
options)
    let v :: CabalSpecVersion
v   = Options -> CabalSpecVersion
optSpecVersion Options
opts
    let ft :: String
ft  = CabalSpecVersion -> Position -> [FieldLine Position] -> String
fieldlinesToFreeText CabalSpecVersion
v Position
pos ((FieldLine CommentsPragmas -> FieldLine Position)
-> [FieldLine CommentsPragmas] -> [FieldLine Position]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CommentsPragmas -> Position)
-> FieldLine CommentsPragmas -> FieldLine Position
forall a b. (a -> b) -> FieldLine a -> FieldLine b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CommentsPragmas -> Position
forall a b c. (a, b, c) -> a
fstOf3) [FieldLine CommentsPragmas]
fls)
    let ft' :: Doc
ft' = CabalSpecVersion -> String -> Doc
showFreeText CabalSpecVersion
v String
ft

    Maybe Doc -> m (Maybe Doc)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Doc -> m (Maybe Doc)) -> Maybe Doc -> m (Maybe Doc)
forall a b. (a -> b) -> a -> b
$ Maybe (Maybe Doc) -> Maybe Doc
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe Doc) -> Maybe Doc) -> Maybe (Maybe Doc) -> Maybe Doc
forall a b. (a -> b) -> a -> b
$ FieldDescrs () ()
-> ByteString
-> Maybe Doc
-> (forall {f}. ParsecParser f -> (f -> Doc) -> Maybe Doc)
-> Maybe (Maybe Doc)
forall (m :: * -> *) s a r.
CabalParsing m =>
FieldDescrs s a
-> ByteString -> r -> (forall f. m f -> (f -> Doc) -> r) -> Maybe r
fieldDescrLookup (Options -> FieldDescrs () ()
fieldDescrs Options
opts) ByteString
fn (Doc -> Maybe Doc
forall a. a -> Maybe a
Just Doc
ft') ((forall {f}. ParsecParser f -> (f -> Doc) -> Maybe Doc)
 -> Maybe (Maybe Doc))
-> (forall {f}. ParsecParser f -> (f -> Doc) -> Maybe Doc)
-> Maybe (Maybe Doc)
forall a b. (a -> b) -> a -> b
$ \ParsecParser f
p f -> Doc
pp ->
        case CabalSpecVersion
-> ParsecParser f
-> String
-> FieldLineStream
-> Either ParseError f
forall a.
CabalSpecVersion
-> ParsecParser a
-> String
-> FieldLineStream
-> Either ParseError a
C.runParsecParser' CabalSpecVersion
v ParsecParser f
p String
"<input>" ([FieldLine CommentsPragmas] -> FieldLineStream
forall ann. [FieldLine ann] -> FieldLineStream
C.fieldLinesToStream [FieldLine CommentsPragmas]
fls) of
            Right f
x -> Doc -> Maybe Doc
forall a. a -> Maybe a
Just (f -> Doc
pp f
x)
            Left ParseError
_  -> Maybe Doc
forall a. Maybe a
Nothing

fieldDescrs :: Options -> FieldDescrs () ()
fieldDescrs :: Options -> FieldDescrs () ()
fieldDescrs Options
opts
    =  Options -> FieldDescrs () ()
buildDependsF Options
opts
    FieldDescrs () () -> FieldDescrs () () -> FieldDescrs () ()
forall a. Semigroup a => a -> a -> a
<> Options -> FieldDescrs () ()
buildToolDependsF Options
opts
    FieldDescrs () () -> FieldDescrs () () -> FieldDescrs () ()
forall a. Semigroup a => a -> a -> a
<> Options -> FieldDescrs () ()
setupDependsF Options
opts
    FieldDescrs () () -> FieldDescrs () () -> FieldDescrs () ()
forall a. Semigroup a => a -> a -> a
<> FieldDescrs () ()
defaultExtensionsF
    FieldDescrs () () -> FieldDescrs () () -> FieldDescrs () ()
forall a. Semigroup a => a -> a -> a
<> FieldDescrs () ()
otherExtensionsF
    FieldDescrs () () -> FieldDescrs () () -> FieldDescrs () ()
forall a. Semigroup a => a -> a -> a
<> FieldDescrs () ()
exposedModulesF
    FieldDescrs () () -> FieldDescrs () () -> FieldDescrs () ()
forall a. Semigroup a => a -> a -> a
<> FieldDescrs () ()
otherModulesF
    FieldDescrs () () -> FieldDescrs () () -> FieldDescrs () ()
forall a. Semigroup a => a -> a -> a
<> Options -> FieldDescrs () ()
testedWithF Options
opts
    FieldDescrs () () -> FieldDescrs () () -> FieldDescrs () ()
forall a. Semigroup a => a -> a -> a
<> [FieldDescrs () ()] -> FieldDescrs () ()
forall a. Monoid a => [a] -> a
mconcat [FieldDescrs () ()]
sourceFilesF
    FieldDescrs () () -> FieldDescrs () () -> FieldDescrs () ()
forall a. Semigroup a => a -> a -> a
<> FieldDescrs PackageDescription PackageDescription
-> FieldDescrs () ()
forall s a. FieldDescrs s a -> FieldDescrs () ()
coerceFieldDescrs FieldDescrs PackageDescription PackageDescription
forall (c :: * -> Constraint) (g :: * -> * -> *).
(FieldGrammar c g, Applicative (g PackageDescription),
 Applicative (g PackageIdentifier), c (Identity BuildType),
 c (Identity PackageName), c (Identity Version),
 c (List FSep FilePathNT String),
 c (List FSep CompatFilePath String),
 c (List
      FSep
      (Identity (SymbolicPath PackageDir LicenseFile))
      (SymbolicPath PackageDir LicenseFile)),
 c (List FSep TestedWith (CompilerFlavor, VersionRange)),
 c (List VCat FilePathNT String), c FilePathNT, c CompatLicenseFile,
 c CompatFilePath, c SpecLicense, c SpecVersion) =>
g PackageDescription PackageDescription
C.packageDescriptionFieldGrammar
    FieldDescrs () () -> FieldDescrs () () -> FieldDescrs () ()
forall a. Semigroup a => a -> a -> a
<> FieldDescrs BuildInfo BuildInfo -> FieldDescrs () ()
forall s a. FieldDescrs s a -> FieldDescrs () ()
coerceFieldDescrs FieldDescrs BuildInfo BuildInfo
forall (c :: * -> Constraint) (g :: * -> * -> *).
(FieldGrammar c g, Applicative (g BuildInfo),
 c (List CommaFSep (Identity ExeDependency) ExeDependency),
 c (List
      CommaFSep (Identity LegacyExeDependency) LegacyExeDependency),
 c (List
      CommaFSep (Identity PkgconfigDependency) PkgconfigDependency),
 c (List CommaVCat (Identity Dependency) Dependency),
 c (List CommaVCat (Identity Mixin) Mixin),
 c (List FSep (MQuoted Extension) Extension),
 c (List FSep (MQuoted Language) Language),
 c (List FSep FilePathNT String), c (List FSep Token String),
 c (List NoCommaFSep Token' String),
 c (List VCat (MQuoted ModuleName) ModuleName),
 c (List VCat FilePathNT String),
 c (List
      FSep
      (Identity (SymbolicPath PackageDir SourceDir))
      (SymbolicPath PackageDir SourceDir)),
 c (List VCat Token String), c (MQuoted Language)) =>
g BuildInfo BuildInfo
C.buildInfoFieldGrammar

-------------------------------------------------------------------------------
-- Sections
-------------------------------------------------------------------------------

prettySectionArgs :: MonadCabalFmt r m => C.FieldName -> [C.SectionArg ann] -> m [PP.Doc]
prettySectionArgs :: forall r (m :: * -> *) ann.
MonadCabalFmt r m =>
ByteString -> [SectionArg ann] -> m [Doc]
prettySectionArgs ByteString
x [SectionArg ann]
args =
    ByteString -> [SectionArg ann] -> m [Doc]
forall r (m :: * -> *) a ann.
MonadCabalFmt r m =>
a -> [SectionArg ann] -> m [Doc]
prettySectionArgs' ByteString
x [SectionArg ann]
args m [Doc] -> (Error -> m [Doc]) -> m [Doc]
forall a. m a -> (Error -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \Error
_ ->
        [Doc] -> m [Doc]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> [SectionArg ann] -> [Doc]
forall ann. ByteString -> [SectionArg ann] -> [Doc]
C.prettySectionArgs ByteString
x [SectionArg ann]
args)

prettySectionArgs' :: MonadCabalFmt r m => a -> [C.SectionArg ann] -> m [PP.Doc]
prettySectionArgs' :: forall r (m :: * -> *) a ann.
MonadCabalFmt r m =>
a -> [SectionArg ann] -> m [Doc]
prettySectionArgs' a
_ [SectionArg ann]
args = do
    Condition ConfVar
c <- String
-> ByteString
-> ParseResult (Condition ConfVar)
-> m (Condition ConfVar)
forall r (m :: * -> *) a.
MonadCabalFmt r m =>
String -> ByteString -> ParseResult a -> m a
runParseResult String
"<args>" ByteString
"" (ParseResult (Condition ConfVar) -> m (Condition ConfVar))
-> ParseResult (Condition ConfVar) -> m (Condition ConfVar)
forall a b. (a -> b) -> a -> b
$ [SectionArg Position] -> ParseResult (Condition ConfVar)
C.parseConditionConfVar ((SectionArg ann -> SectionArg Position)
-> [SectionArg ann] -> [SectionArg Position]
forall a b. (a -> b) -> [a] -> [b]
map (Position
C.zeroPos Position -> SectionArg ann -> SectionArg Position
forall a b. a -> SectionArg b -> SectionArg a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) [SectionArg ann]
args)
    [Doc] -> m [Doc]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Condition ConfVar -> Doc
ppCondition Condition ConfVar
c]

-------------------------------------------------------------------------------
-- PrettyPrint condition
-------------------------------------------------------------------------------

-- This is originally from Cabal

ppCondition :: C.Condition C.ConfVar -> PP.Doc
ppCondition :: Condition ConfVar -> Doc
ppCondition (C.Var ConfVar
x)      = ConfVar -> Doc
ppConfVar ConfVar
x
ppCondition (C.Lit Bool
b)      = String -> Doc
PP.text (Bool -> String
forall a. Show a => a -> String
show Bool
b)
ppCondition (C.CNot Condition ConfVar
c)     = Char -> Doc
PP.char Char
'!' Doc -> Doc -> Doc
PP.<> Condition ConfVar -> Doc
ppCondition Condition ConfVar
c
ppCondition (C.COr Condition ConfVar
c1 Condition ConfVar
c2)  = Doc -> Doc
PP.parens ([Doc] -> Doc
PP.hsep [Condition ConfVar -> Doc
ppCondition Condition ConfVar
c1, String -> Doc
PP.text String
"||", Condition ConfVar -> Doc
ppCondition Condition ConfVar
c2])
ppCondition (C.CAnd Condition ConfVar
c1 Condition ConfVar
c2) = Doc -> Doc
PP.parens ([Doc] -> Doc
PP.hsep [Condition ConfVar -> Doc
ppCondition Condition ConfVar
c1, String -> Doc
PP.text String
"&&", Condition ConfVar -> Doc
ppCondition Condition ConfVar
c2])

ppConfVar :: C.ConfVar -> PP.Doc
ppConfVar :: ConfVar -> Doc
ppConfVar (C.OS OS
os)            = String -> Doc
PP.text String
"os"   Doc -> Doc -> Doc
PP.<> Doc -> Doc
PP.parens (OS -> Doc
forall a. Pretty a => a -> Doc
C.pretty OS
os)
ppConfVar (C.Arch Arch
arch)        = String -> Doc
PP.text String
"arch" Doc -> Doc -> Doc
PP.<> Doc -> Doc
PP.parens (Arch -> Doc
forall a. Pretty a => a -> Doc
C.pretty Arch
arch)
ppConfVar (C.PackageFlag FlagName
name) = String -> Doc
PP.text String
"flag" Doc -> Doc -> Doc
PP.<> Doc -> Doc
PP.parens (FlagName -> Doc
forall a. Pretty a => a -> Doc
C.pretty FlagName
name)
ppConfVar (C.Impl CompilerFlavor
c VersionRange
v)
    | VersionRange
v VersionRange -> VersionRange -> Bool
forall a. Eq a => a -> a -> Bool
== VersionRange
C.anyVersion        = String -> Doc
PP.text String
"impl" Doc -> Doc -> Doc
PP.<> Doc -> Doc
PP.parens (CompilerFlavor -> Doc
forall a. Pretty a => a -> Doc
C.pretty CompilerFlavor
c)
    | Bool
otherwise                = String -> Doc
PP.text String
"impl" Doc -> Doc -> Doc
PP.<> Doc -> Doc
PP.parens (CompilerFlavor -> Doc
forall a. Pretty a => a -> Doc
C.pretty CompilerFlavor
c Doc -> Doc -> Doc
PP.<+> VersionRange -> Doc
forall a. Pretty a => a -> Doc
C.pretty VersionRange
v)

-------------------------------------------------------------------------------
-- Pragma to OM
-------------------------------------------------------------------------------

partitionPragmas :: [Pragma] -> ([GlobalPragma], [FieldPragma])
partitionPragmas :: [Pragma] -> ([GlobalPragma], [FieldPragma])
partitionPragmas = [Either GlobalPragma FieldPragma]
-> ([GlobalPragma], [FieldPragma])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either GlobalPragma FieldPragma]
 -> ([GlobalPragma], [FieldPragma]))
-> ([Pragma] -> [Either GlobalPragma FieldPragma])
-> [Pragma]
-> ([GlobalPragma], [FieldPragma])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pragma -> Either GlobalPragma FieldPragma)
-> [Pragma] -> [Either GlobalPragma FieldPragma]
forall a b. (a -> b) -> [a] -> [b]
map Pragma -> Either GlobalPragma FieldPragma
p where
    p :: Pragma -> Either GlobalPragma FieldPragma
p (GlobalPragma GlobalPragma
x) = GlobalPragma -> Either GlobalPragma FieldPragma
forall a b. a -> Either a b
Left GlobalPragma
x
    p (FieldPragma FieldPragma
x)  = FieldPragma -> Either GlobalPragma FieldPragma
forall a b. b -> Either a b
Right FieldPragma
x

pragmaToOM :: GlobalPragma -> OptionsMorphism
pragmaToOM :: GlobalPragma -> OptionsMorphism
pragmaToOM (PragmaOptIndent Int
n)    = (Options -> Options) -> OptionsMorphism
mkOptionsMorphism ((Options -> Options) -> OptionsMorphism)
-> (Options -> Options) -> OptionsMorphism
forall a b. (a -> b) -> a -> b
$ \Options
opts -> Options
opts { optIndent = n }
pragmaToOM (PragmaOptTabular Bool
b)   = (Options -> Options) -> OptionsMorphism
mkOptionsMorphism ((Options -> Options) -> OptionsMorphism)
-> (Options -> Options) -> OptionsMorphism
forall a b. (a -> b) -> a -> b
$ \Options
opts -> Options
opts { optTabular = b }