cabal-dev-scripts/src/GenSPDXExc.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module Main (main) where
   3
   4 import Control.Lens     (imap)
   5 import Data.Aeson       (FromJSON (..), eitherDecode, withObject, (.:))
   6 import Data.List        (sortOn)
   7 import Data.Text        (Text)
   8 import Data.Traversable (for)
   9
  10 import qualified Data.ByteString.Lazy as LBS
  11 import qualified Data.Set             as Set
  12 import qualified Data.Text            as T
  13 import qualified Options.Applicative  as O
  14 import qualified Zinza                as Z
  15
  16 import GenUtils
  17
  18 data Opts = Opts FilePath (PerV FilePath) FilePath
  19
  20 main :: IO ()
  21 main = generate =<< O.execParser opts where
  22     opts = O.info (O.helper <*> parser) $ mconcat
  23         [ O.fullDesc
  24         , O.progDesc "Generate SPDX LicenseExceptionId module"
  25         ]
  26
  27     parser :: O.Parser Opts
  28     parser = Opts <$> template <*> licensesAll <*> output
  29
  30     licensesAll = PerV
  31         <$> licenses "3.0"
  32         <*> licenses "3.2"
  33         <*> licenses "3.6"
  34         <*> licenses "3.9"
  35         <*> licenses "3.10"
  36         <*> licenses "3.16"
  37
  38     template = O.strArgument $ mconcat
  39         [ O.metavar "SPDX.LicenseExceptionId.template.hs"
  40         , O.help    "Module template file"
  41         ]
  42
  43     licenses ver = O.strArgument $ mconcat
  44         [ O.metavar $ "exceptions" ++  ver ++ ".json"
  45         , O.help    "Exceptions JSON. https://github.com/spdx/license-list-data"
  46         ]
  47
  48     output = O.strArgument $ mconcat
  49         [ O.metavar "Output.hs"
  50         , O.help    "Output file"
  51         ]
  52
  53 generate :: Opts -> IO ()
  54 generate (Opts tmplFile fns out) = do
  55     lss <- for fns $ \fn -> either fail pure . eitherDecode =<< LBS.readFile fn
  56     template <- Z.parseAndCompileTemplateIO tmplFile
  57     output <- generate' lss template
  58     writeFile out (header <> "\n" <> output)
  59     putStrLn $ "Generated file " ++ out
  60
  61 generate'
  62     :: PerV LicenseList
  63     -> (Input -> IO String)
  64     -> IO String
  65 generate' lss template = template $ Input
  66     { inputLicenseIds       = licenseIds
  67     , inputLicenses         = licenseValues
  68     , inputLicenseList_all  = mkLicenseList (== allVers)
  69     , inputLicenseList_perv = tabulate $ \ver -> mkLicenseList
  70         (\vers -> vers /= allVers && Set.member ver vers)
  71     }
  72   where
  73     constructorNames :: [(Text, License, Set.Set SPDXLicenseListVersion)]
  74     constructorNames
  75         = map (\(l, tags) -> (toConstructorName $ licenseId l, l, tags))
  76         $ combine licenseId $ \ver -> filterDeprecated $ unLL $ index ver lss
  77
  78     filterDeprecated = filter (not . licenseDeprecated)
  79
  80     licenseValues :: [InputLicense]
  81     licenseValues = flip map constructorNames $ \(c, l, _) -> InputLicense
  82         { ilConstructor   = c
  83         , ilId            = textShow (licenseId l)
  84         , ilName          = textShow (licenseName l)
  85         , ilIsOsiApproved = False -- not used in exceptions
  86         , ilIsFsfLibre    = False -- not used in exceptions
  87         }
  88
  89     licenseIds :: Text
  90     licenseIds = T.intercalate "\n" $ flip imap constructorNames $ \i (c, l, vers) ->
  91         let pfx = if i == 0 then "    = " else "    | "
  92             versInfo
  93                 | vers == allVers = ""
  94                 | otherwise       = foldMap (\v -> ", " <> prettyVer v) vers
  95         in pfx <> c <> " -- ^ @" <> licenseId l <> "@, " <> licenseName l <> versInfo
  96
  97     mkLicenseList :: (Set.Set SPDXLicenseListVersion -> Bool) -> Text
  98     mkLicenseList p = mkList [ n | (n, _, vers) <- constructorNames, p vers ]
  99
 100 -------------------------------------------------------------------------------
 101 -- JSON inputs
 102 -------------------------------------------------------------------------------
 103
 104 data License = License
 105     { licenseId          :: !Text
 106     , licenseName        :: !Text
 107     , licenseDeprecated  :: !Bool
 108     }
 109   deriving (Show)
 110
 111 instance FromJSON License where
 112     parseJSON = withObject "License" $ \obj -> License
 113         <$> obj .: "licenseExceptionId"
 114         <*> fmap (T.map fixSpace) (obj .: "name")
 115         <*> obj .: "isDeprecatedLicenseId"
 116       where
 117         fixSpace '\n' = ' '
 118         fixSpace c =   c
 119
 120 newtype LicenseList = LL { unLL :: [License] }
 121   deriving (Show)
 122
 123 instance FromJSON LicenseList where
 124     parseJSON = withObject "Exceptions list" $ \obj ->
 125         LL . sortOn (OrdT . T.toLower . licenseId)
 126             <$> obj .: "exceptions"