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