{-# 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 filepath contents = do
-- determine cabal-version
cabalFile <- asks (optCabalFile . view options)
csv <- case cabalFile of
False -> return C.cabalSpecLatest
True -> do
gpd <- parseGpd filepath contents
return $ C.specVersion
$ C.packageDescription gpd
inputFields' <- parseFields contents
let (inputFieldsC, endComments) = attachComments contents inputFields'
-- parse pragmas
let parse (pos, c) = case parsePragmas c of (ws, ps) -> traverse_ displayWarning ws *> return (pos, c, ps)
inputFieldsP' <- traverse (traverse parse) inputFieldsC
endCommentsPragmas <- case parsePragmas endComments of
(ws, ps) -> traverse_ displayWarning ws *> return ps
-- apply refactorings
let inputFieldsP :: [C.Field CommentsPragmas]
inputFieldsP = map (fmap (fmap (snd . partitionPragmas))) inputFieldsP'
inputFieldsR <- refactor inputFieldsP
-- options morphisms
let pragmas :: [GlobalPragma]
pragmas = fst $ partitionPragmas $
foldMap (foldMap trdOf3) inputFieldsP' <> endCommentsPragmas
optsEndo :: OptionsMorphism
optsEndo = foldMap pragmaToOM pragmas
local (over options $ \o -> runOptionsMorphism optsEndo $ o { optSpecVersion = csv }) $ do
indentWith <- asks (optIndent . view options)
let inputFields = inputFieldsR
outputPrettyFields <- genericFromParsecFields
(\n ann -> prettyFieldLines n (fstOf3 ann))
prettySectionArgs
inputFields
return $ C.showFields' (fromComments . sndOf3) (const id) indentWith outputPrettyFields
& if nullComments endComments then id else
(++ unlines ("" : [ C.fromUTF8BS c | c <- unComments endComments ]))
fromComments :: Comments -> C.CommentPosition
fromComments (Comments []) = C.NoComment
fromComments (Comments bss) = C.CommentBefore (map C.fromUTF8BS 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 f g = goMany where
goMany = traverse go
go (C.Field (C.Name ann name) fls) = C.PrettyField ann name <$> f name ann fls
go (C.Section (C.Name ann name) secargs fs) = C.PrettySection ann name <$> g name secargs <*> goMany fs
-------------------------------------------------------------------------------
-- Field prettyfying
-------------------------------------------------------------------------------
prettyFieldLines :: MonadCabalFmt r m => C.FieldName -> C.Position -> [C.FieldLine CommentsPragmas] -> m PP.Doc
prettyFieldLines fn pos fls =
fromMaybe (C.prettyFieldLines fn fls) <$> knownField fn pos fls
knownField :: MonadCabalFmt r m => C.FieldName -> C.Position -> [C.FieldLine CommentsPragmas] -> m (Maybe PP.Doc)
knownField fn pos fls = do
opts <- asks (view options)
let v = optSpecVersion opts
let ft = fieldlinesToFreeText v pos (fmap (fmap fstOf3) fls)
let ft' = showFreeText v ft
return $ join $ fieldDescrLookup (fieldDescrs opts) fn (Just ft') $ \p pp ->
case C.runParsecParser' v p "" (C.fieldLinesToStream fls) of
Right x -> Just (pp x)
Left _ -> Nothing
fieldDescrs :: Options -> FieldDescrs () ()
fieldDescrs opts
= buildDependsF opts
<> buildToolDependsF opts
<> setupDependsF opts
<> defaultExtensionsF
<> otherExtensionsF
<> exposedModulesF
<> otherModulesF
<> testedWithF opts
<> mconcat sourceFilesF
<> coerceFieldDescrs C.packageDescriptionFieldGrammar
<> coerceFieldDescrs C.buildInfoFieldGrammar
-------------------------------------------------------------------------------
-- Sections
-------------------------------------------------------------------------------
prettySectionArgs :: MonadCabalFmt r m => C.FieldName -> [C.SectionArg ann] -> m [PP.Doc]
prettySectionArgs x args =
prettySectionArgs' x args `catchError` \_ ->
return (C.prettySectionArgs x args)
prettySectionArgs' :: MonadCabalFmt r m => a -> [C.SectionArg ann] -> m [PP.Doc]
prettySectionArgs' _ args = do
c <- runParseResult "" "" $ C.parseConditionConfVar (map (C.zeroPos <$) args)
return [ppCondition c]
-------------------------------------------------------------------------------
-- PrettyPrint condition
-------------------------------------------------------------------------------
-- This is originally from Cabal
ppCondition :: C.Condition C.ConfVar -> PP.Doc
ppCondition (C.Var x) = ppConfVar x
ppCondition (C.Lit b) = PP.text (show b)
ppCondition (C.CNot c) = PP.char '!' PP.<> ppCondition c
ppCondition (C.COr c1 c2) = PP.parens (PP.hsep [ppCondition c1, PP.text "||", ppCondition c2])
ppCondition (C.CAnd c1 c2) = PP.parens (PP.hsep [ppCondition c1, PP.text "&&", ppCondition c2])
ppConfVar :: C.ConfVar -> PP.Doc
ppConfVar (C.OS os) = PP.text "os" PP.<> PP.parens (C.pretty os)
ppConfVar (C.Arch arch) = PP.text "arch" PP.<> PP.parens (C.pretty arch)
ppConfVar (C.PackageFlag name) = PP.text "flag" PP.<> PP.parens (C.pretty name)
ppConfVar (C.Impl c v)
| v == C.anyVersion = PP.text "impl" PP.<> PP.parens (C.pretty c)
| otherwise = PP.text "impl" PP.<> PP.parens (C.pretty c PP.<+> C.pretty v)
-------------------------------------------------------------------------------
-- Pragma to OM
-------------------------------------------------------------------------------
partitionPragmas :: [Pragma] -> ([GlobalPragma], [FieldPragma])
partitionPragmas = partitionEithers . map p where
p (GlobalPragma x) = Left x
p (FieldPragma x) = Right x
pragmaToOM :: GlobalPragma -> OptionsMorphism
pragmaToOM (PragmaOptIndent n) = mkOptionsMorphism $ \opts -> opts { optIndent = n }
pragmaToOM (PragmaOptTabular b) = mkOptionsMorphism $ \opts -> opts { optTabular = b }