1{-# LANGUAGE DeriveFunctor #-} 2{-# LANGUAGE RankNTypes #-} 3module Distribution.FieldGrammar.FieldDescrs ( 4 FieldDescrs, 5 fieldDescrPretty, 6 fieldDescrParse, 7 fieldDescrsToList, 8 ) where 9 10import Distribution.Compat.Prelude 11import Prelude () 12 13import Data.List (dropWhileEnd) 14import Distribution.Compat.Lens (aview, cloneLens) 15import Distribution.Compat.Newtype 16import Distribution.FieldGrammar 17import Distribution.Pretty (pretty, showFreeText) 18 19import qualified Data.Map as Map 20import qualified Distribution.Compat.CharParsing as C 21import qualified Distribution.Fields.Field as P 22import qualified Distribution.Parsec as P 23import qualified Text.PrettyPrint as Disp 24 25-- strict pair 26data SP s = SP 27 { pPretty :: !(s -> Disp.Doc) 28 , pParse :: !(forall m. P.CabalParsing m => s -> m s) 29 } 30 31-- | A collection field parsers and pretty-printers. 32newtype FieldDescrs s a = F { runF :: Map P.FieldName (SP s) } 33 deriving (Functor) 34 35instance Applicative (FieldDescrs s) where 36 pure _ = F mempty 37 f <*> x = F (mappend (runF f) (runF x)) 38 39singletonF :: P.FieldName -> (s -> Disp.Doc) -> (forall m. P.CabalParsing m => s -> m s) -> FieldDescrs s a 40singletonF fn f g = F $ Map.singleton fn (SP f g) 41 42-- | Lookup a field value pretty-printer. 43fieldDescrPretty :: FieldDescrs s a -> P.FieldName -> Maybe (s -> Disp.Doc) 44fieldDescrPretty (F m) fn = pPretty <$> Map.lookup fn m 45 46-- | Lookup a field value parser. 47fieldDescrParse :: P.CabalParsing m => FieldDescrs s a -> P.FieldName -> Maybe (s -> m s) 48fieldDescrParse (F m) fn = pParse <$> Map.lookup fn m 49 50fieldDescrsToList 51 :: P.CabalParsing m 52 => FieldDescrs s a 53 -> [(P.FieldName, s -> Disp.Doc, s -> m s)] 54fieldDescrsToList = map mk . Map.toList . runF where 55 mk (name, SP ppr parse) = (name, ppr, parse) 56 57-- | /Note:/ default values are printed. 58instance FieldGrammar FieldDescrs where 59 blurFieldGrammar l (F m) = F (fmap blur m) where 60 blur (SP f g) = SP (f . aview l) (cloneLens l g) 61 62 booleanFieldDef fn l _def = singletonF fn f g where 63 f s = Disp.text (show (aview l s)) 64 g s = cloneLens l (const P.parsec) s 65 -- Note: eta expansion is needed for RankNTypes type-checking to work. 66 67 uniqueFieldAla fn _pack l = singletonF fn f g where 68 f s = pretty (pack' _pack (aview l s)) 69 g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s 70 71 optionalFieldAla fn _pack l = singletonF fn f g where 72 f s = maybe mempty (pretty . pack' _pack) (aview l s) 73 g s = cloneLens l (const (Just . unpack' _pack <$> P.parsec)) s 74 75 optionalFieldDefAla fn _pack l _def = singletonF fn f g where 76 f s = pretty (pack' _pack (aview l s)) 77 g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s 78 79 freeTextField fn l = singletonF fn f g where 80 f s = maybe mempty showFreeText (aview l s) 81 g s = cloneLens l (const (Just <$> parsecFreeText)) s 82 83 freeTextFieldDef fn l = singletonF fn f g where 84 f s = showFreeText (aview l s) 85 g s = cloneLens l (const parsecFreeText) s 86 87 monoidalFieldAla fn _pack l = singletonF fn f g where 88 f s = pretty (pack' _pack (aview l s)) 89 g s = cloneLens l (\x -> mappend x . unpack' _pack <$> P.parsec) s 90 91 prefixedFields _fnPfx _l = F mempty 92 knownField _ = pure () 93 deprecatedSince _ _ x = x 94 removedIn _ _ x = x 95 availableSince _ _ = id 96 hiddenField _ = F mempty 97 98parsecFreeText :: P.CabalParsing m => m String 99parsecFreeText = dropDotLines <$ C.spaces <*> many C.anyChar 100 where 101 -- Example package with dot lines 102 -- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal 103 dropDotLines "." = "." 104 dropDotLines x = intercalate "\n" . map dotToEmpty . lines $ x 105 106 dotToEmpty x | trim' x == "." = "" 107 dotToEmpty x = trim x 108 109 trim' :: String -> String 110 trim' = dropWhileEnd (`elem` (" \t" :: String)) 111 112 trim :: String -> String 113 trim = dropWhile isSpace . dropWhileEnd isSpace 114