cabal-dev-scripts/src/GenSPDX.hs

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