{-# 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 Data.Either          (partitionEithers)

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.Simple.Utils                    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.Version                   as C
import qualified Distribution.Types.VersionRange              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 :: FilePath -> ByteString -> m FilePath
cabalFmt FilePath
filepath ByteString
contents = do
    [Field Position]
inputFields' <- ByteString -> m [Field Position]
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 -> ([FilePath], [Pragma])
parsePragmas Comments
c of ([FilePath]
ws, [Pragma]
ps) -> (FilePath -> f ()) -> [FilePath] -> f ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ FilePath -> f ()
forall r (m :: * -> *). MonadCabalFmt r m => FilePath -> m ()
displayWarning [FilePath]
ws f () -> f (Comments, [Pragma]) -> f (Comments, [Pragma])
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Comments, [Pragma]) -> f (Comments, [Pragma])
forall (m :: * -> *) a. Monad m => a -> m a
return (Comments
c, [Pragma]
ps)
    [Field (Comments, [Pragma])]
inputFieldsP' <- (Field Comments -> m (Field (Comments, [Pragma])))
-> [Field Comments] -> m [Field (Comments, [Pragma])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Comments -> m (Comments, [Pragma]))
-> Field Comments -> m (Field (Comments, [Pragma]))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Comments -> m (Comments, [Pragma])
forall (f :: * -> *) r.
MonadCabalFmt r f =>
Comments -> f (Comments, [Pragma])
parse) [Field Comments]
inputFieldsC
    [Pragma]
endCommentsPragmas <- case Comments -> ([FilePath], [Pragma])
parsePragmas Comments
endComments of
        ([FilePath]
ws, [Pragma]
ps) -> (FilePath -> m ()) -> [FilePath] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ FilePath -> m ()
forall r (m :: * -> *). MonadCabalFmt r m => FilePath -> m ()
displayWarning [FilePath]
ws m () -> m [Pragma] -> m [Pragma]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Pragma] -> m [Pragma]
forall (m :: * -> *) a. Monad m => a -> m a
return [Pragma]
ps

    -- apply refactorings
    let inputFieldsP :: [C.Field CommentsPragmas]
        inputFieldsP :: [Field CommentsPragmas]
inputFieldsP = (Field (Comments, [Pragma]) -> Field CommentsPragmas)
-> [Field (Comments, [Pragma])] -> [Field CommentsPragmas]
forall a b. (a -> b) -> [a] -> [b]
map (((Comments, [Pragma]) -> CommentsPragmas)
-> Field (Comments, [Pragma]) -> Field CommentsPragmas
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Pragma] -> [FieldPragma])
-> (Comments, [Pragma]) -> CommentsPragmas
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 (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 (Comments, [Pragma]) -> [Pragma])
-> [Field (Comments, [Pragma])] -> [Pragma]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (((Comments, [Pragma]) -> [Pragma])
-> Field (Comments, [Pragma]) -> [Pragma]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Comments, [Pragma]) -> [Pragma]
forall a b. (a, b) -> b
snd) [Field (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 (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap GlobalPragma -> OptionsMorphism
pragmaToOM [GlobalPragma]
pragmas

    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
options)
    CabalSpecVersion
csv <- case Bool
cabalFile of
        Bool
False -> CabalSpecVersion -> m CabalSpecVersion
forall (m :: * -> *) a. Monad m => a -> m a
return CabalSpecVersion
C.cabalSpecLatest
        Bool
True  -> do
            GenericPackageDescription
gpd <- FilePath -> ByteString -> m GenericPackageDescription
forall r (m :: * -> *).
MonadCabalFmt r m =>
FilePath -> ByteString -> m GenericPackageDescription
parseGpd FilePath
filepath ByteString
contents
            CabalSpecVersion -> m CabalSpecVersion
forall (m :: * -> *) a. Monad m => a -> m a
return (CabalSpecVersion -> m CabalSpecVersion)
-> CabalSpecVersion -> m CabalSpecVersion
forall a b. (a -> b) -> a -> b
$ [Int] -> CabalSpecVersion
C.cabalSpecFromVersionDigits
              ([Int] -> CabalSpecVersion) -> [Int] -> CabalSpecVersion
forall a b. (a -> b) -> a -> b
$ Version -> [Int]
C.versionNumbers
              (Version -> [Int]) -> Version -> [Int]
forall a b. (a -> b) -> a -> b
$ PackageDescription -> Version
C.specVersion
              (PackageDescription -> Version) -> PackageDescription -> Version
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
C.packageDescription GenericPackageDescription
gpd

    (r -> r) -> m FilePath -> m FilePath
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
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 :: CabalSpecVersion
optSpecVersion = CabalSpecVersion
csv }) (m FilePath -> m FilePath) -> m FilePath -> m FilePath
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
options)
        let inputFields :: [Field Comments]
inputFields = (Field CommentsPragmas -> Field Comments)
-> [Field CommentsPragmas] -> [Field Comments]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CommentsPragmas -> Comments)
-> Field CommentsPragmas -> Field Comments
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CommentsPragmas -> Comments
forall a b. (a, b) -> a
fst) [Field CommentsPragmas]
inputFieldsR

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

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

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

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

prettyFieldLines :: MonadCabalFmt r m => C.FieldName -> [C.FieldLine ann] -> m PP.Doc
prettyFieldLines :: ByteString -> [FieldLine ann] -> m Doc
prettyFieldLines ByteString
fn [FieldLine ann]
fls =
    Doc -> Maybe Doc -> Doc
forall a. a -> Maybe a -> a
fromMaybe (ByteString -> [FieldLine ann] -> Doc
forall ann. ByteString -> [FieldLine ann] -> Doc
C.prettyFieldLines ByteString
fn [FieldLine ann]
fls) (Maybe Doc -> Doc) -> m (Maybe Doc) -> m Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> [FieldLine ann] -> m (Maybe Doc)
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 :: ByteString -> [FieldLine ann] -> m (Maybe Doc)
knownField ByteString
fn [FieldLine ann]
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
options)
    let v :: CabalSpecVersion
v = Options -> CabalSpecVersion
optSpecVersion Options
opts
    Maybe Doc -> m (Maybe Doc)
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
-> (forall f. ParsecParser f -> (f -> Doc) -> Maybe Doc)
-> Maybe (Maybe Doc)
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 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
-> FilePath
-> FieldLineStream
-> Either ParseError f
forall a.
CabalSpecVersion
-> ParsecParser a
-> FilePath
-> FieldLineStream
-> Either ParseError a
C.runParsecParser' CabalSpecVersion
v ParsecParser f
p FilePath
"<input>" ([FieldLine ann] -> FieldLineStream
forall ann. [FieldLine ann] -> FieldLineStream
C.fieldLinesToStream [FieldLine ann]
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 () ()
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 (g :: * -> * -> *).
(FieldGrammar g, Applicative (g PackageDescription),
 Applicative (g PackageIdentifier)) =>
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 (g :: * -> * -> *).
(FieldGrammar g, Applicative (g BuildInfo)) =>
g BuildInfo BuildInfo
C.buildInfoFieldGrammar

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

prettySectionArgs :: MonadCabalFmt r m => C.FieldName -> [C.SectionArg ann] -> m [PP.Doc]
prettySectionArgs :: 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 e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \Error
_ ->
        [Doc] -> m [Doc]
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' :: a -> [SectionArg ann] -> m [Doc]
prettySectionArgs' a
_ [SectionArg ann]
args = do
    Condition ConfVar
c <- FilePath
-> ByteString
-> ParseResult (Condition ConfVar)
-> m (Condition ConfVar)
forall r (m :: * -> *) a.
MonadCabalFmt r m =>
FilePath -> ByteString -> ParseResult a -> m a
runParseResult FilePath
"<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 (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) [SectionArg ann]
args)
    [Doc] -> m [Doc]
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)      = FilePath -> Doc
PP.text (Bool -> FilePath
forall a. Show a => a -> FilePath
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, FilePath -> Doc
PP.text FilePath
"||", 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, FilePath -> Doc
PP.text FilePath
"&&", Condition ConfVar -> Doc
ppCondition Condition ConfVar
c2])

ppConfVar :: C.ConfVar -> PP.Doc
ppConfVar :: ConfVar -> Doc
ppConfVar (C.OS OS
os)     = FilePath -> Doc
PP.text FilePath
"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) = FilePath -> Doc
PP.text FilePath
"arch" Doc -> Doc -> Doc
PP.<> Doc -> Doc
PP.parens (Arch -> Doc
forall a. Pretty a => a -> Doc
C.pretty Arch
arch)
ppConfVar (C.Flag FlagName
name) = FilePath -> Doc
PP.text FilePath
"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 = FilePath -> Doc
PP.text FilePath
"impl" Doc -> Doc -> Doc
PP.<> Doc -> Doc
PP.parens (CompilerFlavor -> Doc
forall a. Pretty a => a -> Doc
C.pretty CompilerFlavor
c)
    | Bool
otherwise         = FilePath -> Doc
PP.text FilePath
"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 :: Int
optIndent = Int
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 :: Bool
optTabular = Bool
b }