buildinfo-reference-generator/src/Main.hs

   1 {-# LANGUAGE DeriveFunctor         #-}
   2 {-# LANGUAGE DeriveGeneric         #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4 module Main (main) where
   5
   6 import Data.Map.Strict (Map)
   7
   8 import Data.Bifunctor                  (first)
   9 import Data.Proxy                      (Proxy (..))
  10 import Data.Void                       (Void)
  11 import Distribution.CabalSpecVersion   (CabalSpecVersion, showCabalSpecVersion)
  12 import Distribution.Compat.Newtype     (pack')
  13 import Distribution.FieldGrammar.Class (FieldGrammar (..))
  14 import Distribution.Fields.Field       (FieldName)
  15 import Distribution.Pretty             (pretty)
  16 import Distribution.Simple.Utils       (fromUTF8BS)
  17 import GHC.Generics                    (Generic)
  18 import System.Environment              (getArgs)
  19 import System.Exit                     (exitFailure)
  20
  21 import Distribution.PackageDescription.FieldGrammar (buildInfoFieldGrammar, packageDescriptionFieldGrammar, testSuiteFieldGrammar)
  22
  23 import qualified Data.Map.Strict  as Map
  24 import qualified Text.PrettyPrint as PP
  25
  26 import qualified Zinza as Z
  27
  28 import Distribution.Described
  29 import Distribution.Utils.GrammarRegex
  30
  31 import Distribution.ModuleName         (ModuleName)
  32 import Distribution.Types.Version      (Version)
  33 import Distribution.Types.VersionRange (VersionRange)
  34
  35 -------------------------------------------------------------------------------
  36 -- Main
  37 -------------------------------------------------------------------------------
  38
  39 main :: IO ()
  40 main = do
  41     args <- getArgs
  42     case args of
  43         [tmpl] -> do
  44             -- TODO: getArgs
  45             run <- Z.parseAndCompileTemplateIO tmpl
  46             contents <- run $ Z
  47                 { zBuildInfoFields          = fromReference buildInfoFieldGrammar
  48                 , zPackageDescriptionFields = fromReference packageDescriptionFieldGrammar
  49                 , zTestSuiteFields          = fromReference $ testSuiteFieldGrammar // buildInfoFieldGrammar
  50                 , zProductions              =
  51                     [ zproduction "hs-string"       reHsString
  52                         "String as in Haskell; it's recommended to avoid using Haskell-specific escapes."
  53                     , zproduction "unqual-name"     reUnqualComponent $ unwords
  54                         [ "Unqualified component names are used for package names, component names etc. but not flag names."
  55                         , "Unqualified component name consist of components separated by dash, each component is non-empty alphanumeric string, with at least one alphabetic character."
  56                         , "In other words, component may not look like a number."
  57                         ]
  58
  59                     , zproduction "module-name"     (describe (Proxy :: Proxy ModuleName))
  60                         "Haskell module name as recognized by Cabal parser."
  61                     , zproduction "version"         (describe (Proxy :: Proxy Version))
  62                         "Version is to first approximation numbers separated by dots, where leading zero is not allowed and each version digit is consists at most of nine characters."
  63                     , zproduction "version-range"   (describe (Proxy :: Proxy VersionRange))
  64                         "Version range syntax is recursive. Also note the set syntax added in ``cabal-version: 3.0``, set cannot be empty."
  65                     ]
  66                 , zSpaceList                = show $ regexDoc $
  67                     REMunch RESpaces1 (RENamed "element" RETodo)
  68                 , zCommaList                = show $ regexDoc $
  69                     expandedCommaList (RENamed "element" RETodo)
  70                 , zOptCommaList             = show $ regexDoc $
  71                     expandedOptCommaList (RENamed "element" RETodo)
  72
  73                 , zNull                     = null
  74                 , zNotNull                  = not . null
  75                 }
  76
  77             putStrLn contents
  78         _ -> do
  79           putStrLn "Usage: generator <tmpl>"
  80           exitFailure
  81
  82 zproduction :: String -> GrammarRegex Void -> String -> ZProduction
  83 zproduction name re desc = ZProduction
  84     { zprodName        = name
  85     , zprodSyntax      = show (regexDoc re')
  86     , zprodDescription = desc
  87     }
  88   where
  89     re' = case re of
  90         RENamed _ r -> r
  91         _           -> re
  92
  93 -- also in UnitTests.Distribution.Described
  94 expandedCommaList :: GrammarRegex a -> GrammarRegex a
  95 expandedCommaList = REUnion . expandedCommaList'
  96
  97 expandedCommaList' :: GrammarRegex a -> [GrammarRegex a]
  98 expandedCommaList' r =
  99     [ REMunch reSpacedComma r
 100     , reComma <> RESpaces <> REMunch1 reSpacedComma r
 101     , REMunch1 reSpacedComma r <> RESpaces <> reComma
 102     ]
 103
 104 expandedOptCommaList :: GrammarRegex a -> GrammarRegex a
 105 expandedOptCommaList r = REUnion $ reSpacedList r : expandedCommaList' r
 106
 107 -------------------------------------------------------------------------------
 108 -- Template Inputs
 109 -------------------------------------------------------------------------------
 110
 111 data Z = Z
 112     { zBuildInfoFields          :: [ZField]
 113     , zPackageDescriptionFields :: [ZField]
 114     , zTestSuiteFields          :: [ZField]
 115     , zProductions              :: [ZProduction]
 116     , zSpaceList                :: String
 117     , zCommaList                :: String
 118     , zOptCommaList             :: String
 119     , zNull                     :: String -> Bool
 120     , zNotNull                  :: String -> Bool
 121     }
 122   deriving (Generic)
 123
 124 data ZField = ZField
 125     { zfieldName            :: String
 126     , zfieldAvailableSince  :: String
 127     , zfieldDeprecatedSince :: (String, String)
 128     , zfieldRemovedIn       :: (String, String)
 129     , zfieldFormat          :: String
 130     , zfieldDefault         :: String
 131     , zfieldSyntax          :: String
 132     }
 133   deriving (Generic)
 134
 135 data ZProduction = ZProduction
 136     { zprodName        :: String
 137     , zprodSyntax      :: String
 138     , zprodDescription :: String
 139     }
 140   deriving (Generic)
 141
 142 instance Z.Zinza Z where
 143     toType    = Z.genericToTypeSFP
 144     toValue   = Z.genericToValueSFP
 145     fromValue = Z.genericFromValueSFP
 146
 147 instance Z.Zinza ZField where
 148     toType    = Z.genericToTypeSFP
 149     toValue   = Z.genericToValueSFP
 150     fromValue = Z.genericFromValueSFP
 151
 152 instance Z.Zinza ZProduction where
 153     toType    = Z.genericToTypeSFP
 154     toValue   = Z.genericToValueSFP
 155     fromValue = Z.genericFromValueSFP
 156
 157 -------------------------------------------------------------------------------
 158 -- From reference
 159 -------------------------------------------------------------------------------
 160
 161 -- TODO: produce ZField
 162 fromReference :: Reference a a -> [ZField]
 163 fromReference (Reference m) =
 164     [ ZField
 165         { zfieldName            = fromUTF8BS n
 166         , zfieldAvailableSince  = maybe "" showCabalSpecVersion (fdAvailableSince desc)
 167         , zfieldDeprecatedSince = maybe ("", "") (first showCabalSpecVersion) (fdDeprecatedSince desc)
 168         , zfieldRemovedIn       = maybe ("", "") (first showCabalSpecVersion) (fdRemovedIn desc)
 169         , zfieldFormat          = fmt
 170         , zfieldDefault         = def
 171         , zfieldSyntax          = syntax
 172         }
 173     | (n, desc) <- Map.toList m
 174     , let (fmt, def, syntax) = fromFieldDesc' (fdDescription desc)
 175     ]
 176
 177 fromFieldDesc' :: FieldDesc' -> (String, String, String)
 178 fromFieldDesc' (MonoidalFieldAla s)        = ("Monoidal field",  "",       show s)
 179 fromFieldDesc' (BooleanFieldDesc def)      = ("Boolean field",   show def, show $ describeDoc ([] :: [Bool]))
 180 fromFieldDesc' (OptionalFieldAla s)        = ("Optional field",  "",       show s)
 181 fromFieldDesc' (OptionalFieldDefAla s def) = ("Optional field",  show def, show s)
 182 fromFieldDesc' FreeTextField               = ("Free text field", "",      "")
 183 fromFieldDesc' (UniqueField s)             = ("Required field",  "",       show s)
 184
 185 -------------------------------------------------------------------------------
 186 -- Reference
 187 -------------------------------------------------------------------------------
 188
 189 newtype Reference a b = Reference (Map FieldName FieldDesc)
 190   deriving (Functor)
 191
 192 referenceAvailableSince :: CabalSpecVersion -> Reference a b -> Reference a b
 193 referenceAvailableSince v (Reference m) =
 194     Reference (fmap (fieldDescAvailableSince v) m)
 195
 196 referenceRemovedIn :: CabalSpecVersion -> String -> Reference a b -> Reference a b
 197 referenceRemovedIn v desc (Reference m) =
 198     Reference (fmap (fieldDescRemovedIn v desc) m)
 199
 200 referenceDeprecatedSince :: CabalSpecVersion -> String -> Reference a b -> Reference a b
 201 referenceDeprecatedSince v desc (Reference m) =
 202     Reference (fmap (fieldDescDeprecatedSince v desc) m)
 203
 204 (//) :: Reference a b -> Reference c d -> Reference a b
 205 Reference ab // Reference cd = Reference $ Map.difference ab cd
 206
 207 fieldDescAvailableSince :: CabalSpecVersion -> FieldDesc -> FieldDesc
 208 fieldDescAvailableSince v d = d { fdAvailableSince = Just v }
 209
 210 fieldDescRemovedIn :: CabalSpecVersion -> String -> FieldDesc -> FieldDesc
 211 fieldDescRemovedIn v desc d = d { fdRemovedIn = Just (v, desc) }
 212
 213 fieldDescDeprecatedSince :: CabalSpecVersion -> String -> FieldDesc -> FieldDesc
 214 fieldDescDeprecatedSince v desc d = d { fdDeprecatedSince = Just (v, desc) }
 215
 216 data FieldDesc = FieldDesc
 217     { fdAvailableSince  :: Maybe CabalSpecVersion
 218     , fdRemovedIn       :: Maybe (CabalSpecVersion, String)
 219     , fdDeprecatedSince :: Maybe (CabalSpecVersion, String)
 220     , fdDescription     :: FieldDesc'
 221     }
 222   deriving Show
 223
 224 reference :: FieldName -> FieldDesc' -> Reference a b
 225 reference fn d = Reference $ Map.singleton fn $ FieldDesc Nothing Nothing Nothing d
 226
 227 data FieldDesc'
 228     = BooleanFieldDesc Bool
 229     | UniqueField  PP.Doc  -- ^ not used in BuildInfo
 230     | FreeTextField        -- ^ not user in BuildInfo
 231     | OptionalFieldAla PP.Doc
 232     | OptionalFieldDefAla PP.Doc PP.Doc
 233     | MonoidalFieldAla PP.Doc
 234   deriving Show
 235
 236 instance Applicative (Reference a) where
 237     pure _                      = Reference Map.empty
 238     Reference f <*> Reference x = Reference (Map.union f x)
 239
 240 instance FieldGrammar Described Reference where
 241     blurFieldGrammar _ (Reference xs) = Reference xs
 242
 243     uniqueFieldAla fn pack _l =
 244         reference fn $ UniqueField (describeDoc pack)
 245
 246     booleanFieldDef fn _l def =
 247         reference fn $ BooleanFieldDesc def
 248
 249     optionalFieldAla fn pack _l =
 250         reference fn $ OptionalFieldAla (describeDoc pack)
 251
 252     optionalFieldDefAla fn pack _l def =
 253         reference fn $ OptionalFieldDefAla
 254             (describeDoc pack)
 255             (pretty $ pack' pack def)
 256
 257     freeTextField fn _l = reference fn FreeTextField
 258
 259     freeTextFieldDef   fn _l = reference fn FreeTextField
 260     freeTextFieldDefST fn _l = reference fn FreeTextField
 261
 262     monoidalFieldAla fn pack _l =
 263         reference fn (MonoidalFieldAla (describeDoc pack))
 264
 265     prefixedFields _pfx _l = Reference Map.empty
 266
 267     knownField _fn = Reference Map.empty -- TODO
 268
 269     -- hidden fields are hidden from the reference.
 270     hiddenField _ = Reference Map.empty
 271
 272     deprecatedSince = referenceDeprecatedSince
 273     removedIn       = referenceRemovedIn
 274     availableSince  v _ r = referenceAvailableSince v r