module Distribution.FieldGrammar.FieldDescrs (
FieldDescrs,
fieldDescrPretty,
fieldDescrParse,
fieldDescrsToList,
) where
import Distribution.Compat.Prelude
import Prelude ()
import Data.List (dropWhileEnd)
import Distribution.Compat.Lens (aview, cloneLens)
import Distribution.Compat.Newtype
import Distribution.FieldGrammar
import Distribution.Pretty (Pretty (..), showFreeText)
import qualified Data.Map as Map
import qualified Distribution.Compat.CharParsing as C
import qualified Distribution.Fields.Field as P
import qualified Distribution.Parsec as P
import qualified Text.PrettyPrint as Disp
data SP s = SP
{ pPretty :: !(s -> Disp.Doc)
, pParse :: !(forall m. P.CabalParsing m => s -> m s)
}
newtype FieldDescrs s a = F { runF :: Map P.FieldName (SP s) }
deriving (Functor)
instance Applicative (FieldDescrs s) where
pure _ = F mempty
f <*> x = F (mappend (runF f) (runF x))
singletonF :: P.FieldName -> (s -> Disp.Doc) -> (forall m. P.CabalParsing m => s -> m s) -> FieldDescrs s a
singletonF fn f g = F $ Map.singleton fn (SP f g)
fieldDescrPretty :: FieldDescrs s a -> P.FieldName -> Maybe (s -> Disp.Doc)
fieldDescrPretty (F m) fn = pPretty <$> Map.lookup fn m
fieldDescrParse :: P.CabalParsing m => FieldDescrs s a -> P.FieldName -> Maybe (s -> m s)
fieldDescrParse (F m) fn = (\f -> pParse f) <$> Map.lookup fn m
fieldDescrsToList
:: P.CabalParsing m
=> FieldDescrs s a
-> [(P.FieldName, s -> Disp.Doc, s -> m s)]
fieldDescrsToList = map mk . Map.toList . runF where
mk (name, SP ppr parse) = (name, ppr, parse)
instance FieldGrammar ParsecPretty FieldDescrs where
blurFieldGrammar l (F m) = F (fmap blur m) where
blur (SP f g) = SP (f . aview l) (cloneLens l g)
booleanFieldDef fn l _def = singletonF fn f g where
f s = Disp.text (show (aview l s))
g s = cloneLens l (const P.parsec) s
uniqueFieldAla fn _pack l = singletonF fn f g where
f s = pretty (pack' _pack (aview l s))
g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s
optionalFieldAla fn _pack l = singletonF fn f g where
f s = maybe mempty (pretty . pack' _pack) (aview l s)
g s = cloneLens l (const (Just . unpack' _pack <$> P.parsec)) s
optionalFieldDefAla fn _pack l _def = singletonF fn f g where
f s = pretty (pack' _pack (aview l s))
g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s
freeTextField fn l = singletonF fn f g where
f s = maybe mempty showFreeText (aview l s)
g s = cloneLens l (const (Just <$> parsecFreeText)) s
freeTextFieldDef fn l = singletonF fn f g where
f s = showFreeText (aview l s)
g s = cloneLens l (const parsecFreeText) s
freeTextFieldDefST = defaultFreeTextFieldDefST
monoidalFieldAla fn _pack l = singletonF fn f g where
f s = pretty (pack' _pack (aview l s))
g s = cloneLens l (\x -> mappend x . unpack' _pack <$> P.parsec) s
prefixedFields _fnPfx _l = F mempty
knownField _ = pure ()
deprecatedSince _ _ x = x
removedIn _ _ x = x
availableSince _ _ = id
hiddenField _ = F mempty
parsecFreeText :: P.CabalParsing m => m String
parsecFreeText = dropDotLines <$ C.spaces <*> many C.anyChar
where
dropDotLines "." = "."
dropDotLines x = intercalate "\n" . map dotToEmpty . lines $ x
dotToEmpty x | trim' x == "." = ""
dotToEmpty x = trim x
trim' :: String -> String
trim' = dropWhileEnd (`elem` (" \t" :: String))
trim :: String -> String
trim = dropWhile isSpace . dropWhileEnd isSpace
class (P.Parsec a, Pretty a) => ParsecPretty a
instance (P.Parsec a, Pretty a) => ParsecPretty a