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         <*> licenses "3.23"
  38         <*> licenses "3.25"
  39
  40     template = O.strArgument $ mconcat
  41         [ O.metavar "SPDX.LicenseExceptionId.template.hs"
  42         , O.help    "Module template file"
  43         ]
  44
  45     licenses ver = O.strArgument $ mconcat
  46         [ O.metavar $ "exceptions" ++  ver ++ ".json"
  47         , O.help    "Exceptions JSON. https://github.com/spdx/license-list-data"
  48         ]
  49
  50     output = O.strArgument $ mconcat
  51         [ O.metavar "Output.hs"
  52         , O.help    "Output file"
  53         ]
  54
  55 generate :: Opts -> IO ()
  56 generate (Opts tmplFile fns out) = do
  57     lss <- for fns $ \fn -> either fail pure . eitherDecode =<< LBS.readFile fn
  58     template <- Z.parseAndCompileTemplateIO tmplFile
  59     output <- generate' lss template
  60     writeFile out (header <> "\n" <> output)
  61     putStrLn $ "Generated file " ++ out
  62
  63 generate'
  64     :: PerV LicenseList
  65     -> (Input -> IO String)
  66     -> IO String
  67 generate' lss template = template $ Input
  68     { inputLicenseIds       = licenseIds
  69     , inputLicenses         = licenseValues
  70     , inputLicenseList_all  = mkLicenseList (== allVers)
  71     , inputLicenseList_perv = tabulate $ \ver -> mkLicenseList
  72         (\vers -> vers /= allVers && Set.member ver vers)
  73     }
  74   where
  75     constructorNames :: [(Text, License, Set.Set SPDXLicenseListVersion)]
  76     constructorNames
  77         = map (\(l, tags) -> (toConstructorName $ licenseId l, l, tags))
  78         $ combine licenseId $ \ver -> filterDeprecated $ unLL $ index ver lss
  79
  80     filterDeprecated = filter (not . licenseDeprecated)
  81
  82     licenseValues :: [InputLicense]
  83     licenseValues = flip map constructorNames $ \(c, l, _) -> InputLicense
  84         { ilConstructor   = c
  85         , ilId            = textShow (licenseId l)
  86         , ilName          = textShow (licenseName l)
  87         , ilIsOsiApproved = False -- not used in exceptions
  88         , ilIsFsfLibre    = False -- not used in exceptions
  89         }
  90
  91     licenseIds :: Text
  92     licenseIds = T.intercalate "\n" $ flip imap constructorNames $ \i (c, l, vers) ->
  93         let pfx = if i == 0 then "    = " else "    | "
  94             versInfo
  95                 | vers == allVers = ""
  96                 | otherwise       = foldMap (\v -> ", " <> prettyVer v) vers
  97         in pfx <> c <> " -- ^ @" <> licenseId l <> "@, " <> licenseName l <> versInfo
  98
  99     mkLicenseList :: (Set.Set SPDXLicenseListVersion -> Bool) -> Text
 100     mkLicenseList p = mkList [ n | (n, _, vers) <- constructorNames, p vers ]
 101
 102 -------------------------------------------------------------------------------
 103 -- JSON inputs
 104 -------------------------------------------------------------------------------
 105
 106 data License = License
 107     { licenseId          :: !Text
 108     , licenseName        :: !Text
 109     , licenseDeprecated  :: !Bool
 110     }
 111   deriving (Show)
 112
 113 instance FromJSON License where
 114     parseJSON = withObject "License" $ \obj -> License
 115         <$> obj .: "licenseExceptionId"
 116         <*> fmap (T.map fixSpace) (obj .: "name")
 117         <*> obj .: "isDeprecatedLicenseId"
 118       where
 119         fixSpace '\n' = ' '
 120         fixSpace c =   c
 121
 122 newtype LicenseList = LL { unLL :: [License] }
 123   deriving (Show)
 124
 125 instance FromJSON LicenseList where
 126     parseJSON = withObject "Exceptions list" $ \obj ->
 127         LL . sortOn (OrdT . T.toLower . licenseId)
 128             <$> obj .: "exceptions"