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