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

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

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

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

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

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

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

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

        [PrettyField Comments]
outputPrettyFields <- forall (f :: * -> *) ann.
Applicative f =>
(ByteString -> [FieldLine ann] -> f Doc)
-> (ByteString -> [SectionArg ann] -> f [Doc])
-> [Field ann]
-> f [PrettyField ann]
C.genericFromParsecFields
            forall r (m :: * -> *) ann.
MonadCabalFmt r m =>
ByteString -> [FieldLine ann] -> m Doc
prettyFieldLines
            forall r (m :: * -> *) ann.
MonadCabalFmt r m =>
ByteString -> [SectionArg ann] -> m [Doc]
prettySectionArgs
            [Field Comments]
inputFields

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall ann.
(ann -> CommentPosition)
-> (ann -> [String] -> [String])
-> Int
-> [PrettyField ann]
-> String
C.showFields' Comments -> CommentPosition
fromComments (forall a b. a -> b -> a
const forall a. a -> a
id) Int
indentWith [PrettyField Comments]
outputPrettyFields
            forall a b. a -> (a -> b) -> b
& if Comments -> Bool
nullComments Comments
endComments then forall a. a -> a
id else
                (forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (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 (forall a b. (a -> b) -> [a] -> [b]
map ByteString -> String
C.fromUTF8BS [ByteString]
bss)

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

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

knownField :: MonadCabalFmt r m => C.FieldName -> [C.FieldLine ann] -> m (Maybe PP.Doc)
knownField :: forall r (m :: * -> *) ann.
MonadCabalFmt r m =>
ByteString -> [FieldLine ann] -> m (Maybe Doc)
knownField ByteString
fn [FieldLine ann]
fls = do
    Options
opts <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a s. Getting a s a -> s -> a
view forall e (f :: * -> *).
(HasOptions e, Functor f) =>
LensLike' f e Options
options)
    let v :: CabalSpecVersion
v = Options -> CabalSpecVersion
optSpecVersion Options
opts
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s a r.
CabalParsing m =>
FieldDescrs s a
-> ByteString -> (forall f. m f -> (f -> Doc) -> r) -> Maybe r
fieldDescrLookup (Options -> FieldDescrs () ()
fieldDescrs Options
opts) ByteString
fn forall a b. (a -> b) -> a -> b
$ \ParsecParser f
p f -> Doc
pp ->
        case forall a.
CabalSpecVersion
-> ParsecParser a
-> String
-> FieldLineStream
-> Either ParseError a
C.runParsecParser' CabalSpecVersion
v ParsecParser f
p String
"<input>" (forall ann. [FieldLine ann] -> FieldLineStream
C.fieldLinesToStream [FieldLine ann]
fls) of
            Right f
x -> forall a. a -> Maybe a
Just (f -> Doc
pp f
x)
            Left ParseError
_  -> forall a. Maybe a
Nothing

fieldDescrs :: Options -> FieldDescrs () ()
fieldDescrs :: Options -> FieldDescrs () ()
fieldDescrs Options
opts
    =  Options -> FieldDescrs () ()
buildDependsF Options
opts
    forall a. Semigroup a => a -> a -> a
<> Options -> FieldDescrs () ()
buildToolDependsF Options
opts
    forall a. Semigroup a => a -> a -> a
<> Options -> FieldDescrs () ()
setupDependsF Options
opts
    forall a. Semigroup a => a -> a -> a
<> FieldDescrs () ()
defaultExtensionsF
    forall a. Semigroup a => a -> a -> a
<> FieldDescrs () ()
otherExtensionsF
    forall a. Semigroup a => a -> a -> a
<> FieldDescrs () ()
exposedModulesF
    forall a. Semigroup a => a -> a -> a
<> FieldDescrs () ()
otherModulesF
    forall a. Semigroup a => a -> a -> a
<> Options -> FieldDescrs () ()
testedWithF Options
opts
    forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat [FieldDescrs () ()]
sourceFilesF
    forall a. Semigroup a => a -> a -> a
<> forall s a. FieldDescrs s a -> FieldDescrs () ()
coerceFieldDescrs 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
    forall a. Semigroup a => a -> a -> a
<> forall s a. FieldDescrs s a -> FieldDescrs () ()
coerceFieldDescrs 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 =
    forall r (m :: * -> *) a ann.
MonadCabalFmt r m =>
a -> [SectionArg ann] -> m [Doc]
prettySectionArgs' ByteString
x [SectionArg ann]
args forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \Error
_ ->
        forall (m :: * -> *) a. Monad m => a -> m a
return (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 <- forall r (m :: * -> *) a.
MonadCabalFmt r m =>
String -> ByteString -> ParseResult a -> m a
runParseResult String
"<args>" ByteString
"" forall a b. (a -> b) -> a -> b
$ [SectionArg Position] -> ParseResult (Condition ConfVar)
C.parseConditionConfVar (forall a b. (a -> b) -> [a] -> [b]
map (Position
C.zeroPos forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) [SectionArg ann]
args)
    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 (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 (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 (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 (forall a. Pretty a => a -> Doc
C.pretty FlagName
name)
ppConfVar (C.Impl CompilerFlavor
c VersionRange
v)
    | VersionRange
v forall a. Eq a => a -> a -> Bool
== VersionRange
C.anyVersion        = String -> Doc
PP.text String
"impl" Doc -> Doc -> Doc
PP.<> Doc -> Doc
PP.parens (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 (forall a. Pretty a => a -> Doc
C.pretty CompilerFlavor
c Doc -> Doc -> Doc
PP.<+> forall a. Pretty a => a -> Doc
C.pretty VersionRange
v)

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

partitionPragmas :: [Pragma] -> ([GlobalPragma], [FieldPragma])
partitionPragmas :: [Pragma] -> ([GlobalPragma], [FieldPragma])
partitionPragmas = 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 Pragma -> Either GlobalPragma FieldPragma
p where
    p :: Pragma -> Either GlobalPragma FieldPragma
p (GlobalPragma GlobalPragma
x) = forall a b. a -> Either a b
Left GlobalPragma
x
    p (FieldPragma FieldPragma
x)  = forall a b. b -> Either a b
Right FieldPragma
x

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