cabal-dev-scripts/src/GenUtils.hs

   1 {-# LANGUAGE DeriveFoldable         #-}
   2 {-# LANGUAGE DeriveFunctor          #-}
   3 {-# LANGUAGE DeriveGeneric          #-}
   4 {-# LANGUAGE DeriveTraversable      #-}
   5 {-# LANGUAGE FunctionalDependencies #-}
   6 {-# LANGUAGE OverloadedStrings      #-}
   7 {-# LANGUAGE ScopedTypeVariables    #-}
   8 module GenUtils where
   9
  10 import Control.Lens (each, ix, (%~), (&))
  11 import Data.Char    (toUpper)
  12 import Data.Maybe   (fromMaybe)
  13 import Data.Proxy   (Proxy (..))
  14 import Data.Text    (Text)
  15 import GHC.Generics (Generic)
  16
  17 import qualified Data.Algorithm.Diff as Diff
  18 import qualified Data.Map            as Map
  19 import qualified Data.Set            as Set
  20 import qualified Data.Text           as T
  21 import qualified Zinza               as Z
  22
  23 -------------------------------------------------------------------------------
  24 -- License List version
  25 -------------------------------------------------------------------------------
  26
  27 -- | SPDX license list version
  28 data SPDXLicenseListVersion
  29     = SPDXLicenseListVersion_3_0
  30     | SPDXLicenseListVersion_3_2
  31     | SPDXLicenseListVersion_3_6
  32     | SPDXLicenseListVersion_3_9
  33     | SPDXLicenseListVersion_3_10
  34     | SPDXLicenseListVersion_3_16
  35     | SPDXLicenseListVersion_3_23
  36   deriving (Eq, Ord, Show, Enum, Bounded)
  37
  38 allVers :: Set.Set SPDXLicenseListVersion
  39 allVers =  Set.fromList [minBound .. maxBound]
  40
  41 prettyVer :: SPDXLicenseListVersion -> Text
  42 prettyVer SPDXLicenseListVersion_3_23 = "SPDX License List 3.23"
  43 prettyVer SPDXLicenseListVersion_3_16 = "SPDX License List 3.16"
  44 prettyVer SPDXLicenseListVersion_3_10 = "SPDX License List 3.10"
  45 prettyVer SPDXLicenseListVersion_3_9  = "SPDX License List 3.9"
  46 prettyVer SPDXLicenseListVersion_3_6  = "SPDX License List 3.6"
  47 prettyVer SPDXLicenseListVersion_3_2  = "SPDX License List 3.2"
  48 prettyVer SPDXLicenseListVersion_3_0  = "SPDX License List 3.0"
  49
  50 suffixVer :: SPDXLicenseListVersion -> String
  51 suffixVer SPDXLicenseListVersion_3_23 = "_3_23"
  52 suffixVer SPDXLicenseListVersion_3_16 = "_3_16"
  53 suffixVer SPDXLicenseListVersion_3_10 = "_3_10"
  54 suffixVer SPDXLicenseListVersion_3_9  = "_3_9"
  55 suffixVer SPDXLicenseListVersion_3_6  = "_3_6"
  56 suffixVer SPDXLicenseListVersion_3_2  = "_3_2"
  57 suffixVer SPDXLicenseListVersion_3_0  = "_3_0"
  58
  59 -------------------------------------------------------------------------------
  60 -- Per version
  61 -------------------------------------------------------------------------------
  62
  63 data PerV a = PerV a a a a a a a
  64   deriving (Show, Functor, Foldable, Traversable)
  65
  66 class Functor f => Representable i f | f -> i where
  67     index    :: i -> f a -> a
  68     tabulate :: (i -> a) -> f a
  69
  70 instance Representable SPDXLicenseListVersion PerV where
  71     index SPDXLicenseListVersion_3_0  (PerV x _ _ _ _ _ _) = x
  72     index SPDXLicenseListVersion_3_2  (PerV _ x _ _ _ _ _) = x
  73     index SPDXLicenseListVersion_3_6  (PerV _ _ x _ _ _ _) = x
  74     index SPDXLicenseListVersion_3_9  (PerV _ _ _ x _ _ _) = x
  75     index SPDXLicenseListVersion_3_10 (PerV _ _ _ _ x _ _) = x
  76     index SPDXLicenseListVersion_3_16 (PerV _ _ _ _ _ x _) = x
  77     index SPDXLicenseListVersion_3_23 (PerV _ _ _ _ _ _ x) = x
  78
  79     tabulate f = PerV
  80         (f SPDXLicenseListVersion_3_0)
  81         (f SPDXLicenseListVersion_3_2)
  82         (f SPDXLicenseListVersion_3_6)
  83         (f SPDXLicenseListVersion_3_9)
  84         (f SPDXLicenseListVersion_3_10)
  85         (f SPDXLicenseListVersion_3_16)
  86         (f SPDXLicenseListVersion_3_23)
  87
  88 -------------------------------------------------------------------------------
  89 -- Sorting
  90 -------------------------------------------------------------------------------
  91
  92 newtype OrdT = OrdT Text deriving (Eq)
  93
  94 instance Ord OrdT where
  95     compare (OrdT a) (OrdT b)
  96         | a == b             = EQ
  97         | a `T.isPrefixOf` b = GT
  98         | b `T.isPrefixOf` a = LT
  99         | otherwise          = compare a b
 100
 101 -------------------------------------------------------------------------------
 102 -- Commons
 103 -------------------------------------------------------------------------------
 104
 105 header :: String
 106 header = "-- This file is generated. See Makefile's spdx rule"
 107
 108 -------------------------------------------------------------------------------
 109 -- Tools
 110 -------------------------------------------------------------------------------
 111
 112 combine
 113     :: forall a b tag. (Ord b, Ord tag, Enum tag, Bounded tag)
 114     => (a -> b)
 115     -> (tag -> [a])
 116     -> [(a, Set.Set tag)]
 117 combine f t
 118     = map addTags
 119     $ foldr process [] [ minBound .. maxBound ]
 120   where
 121     unDiff :: Diff.Diff a -> a
 122     unDiff (Diff.First a)  = a
 123     unDiff (Diff.Second a) = a
 124     unDiff (Diff.Both _ a) = a -- important we prefer latter versions!
 125
 126     addTags :: a -> (a, Set.Set tag)
 127     addTags a = (a, fromMaybe Set.empty (Map.lookup (f a) tags))
 128
 129     process :: tag -> [a] -> [a]
 130     process tag as = map unDiff $ Diff.getDiffBy (\x y -> f x == f y) (t tag) as
 131
 132     tags :: Map.Map b (Set.Set tag)
 133     tags = Map.fromListWith Set.union
 134         [ (f a, Set.singleton tag)
 135         | tag <- [ minBound .. maxBound ]
 136         , a <- t tag
 137         ]
 138
 139 ordNubOn :: Ord b => (a -> b) -> [a] -> [a]
 140 ordNubOn f = go Set.empty where
 141     go _    [] = []
 142     go past (a:as)
 143         | b `Set.member` past = go past as
 144         | otherwise           = a :  go (Set.insert b past) as
 145       where
 146         b = f a
 147
 148 textShow :: Text -> Text
 149 textShow = T.pack . show
 150
 151 toConstructorName :: Text -> Text
 152 toConstructorName t = t
 153     & each %~ f
 154     & ix 0 %~ toUpper
 155     & special
 156   where
 157     f '.' = '_'
 158     f '-' = '_'
 159     f '+' = '\''
 160     f c   = c
 161
 162     special :: Text -> Text
 163     special "0BSD"          = "NullBSD"
 164     special "389_exception" = "DS389_exception"
 165     special u               = u
 166
 167 mkList :: [Text] -> Text
 168 mkList []     = "    []"
 169 mkList (x:xs) =
 170     "    [ " <> x <> "\n"
 171     <> foldMap (\x' -> "    , " <> x' <> "\n") xs
 172     <> "    ]"
 173
 174 -------------------------------------------------------------------------------
 175 -- Zinza inputs
 176 -------------------------------------------------------------------------------
 177
 178 data Input = Input
 179     { inputLicenseIds       :: Text
 180     , inputLicenses         :: [InputLicense]
 181     , inputLicenseList_all  :: Text
 182     , inputLicenseList_perv :: PerV Text
 183     }
 184   deriving (Show, Generic)
 185
 186 instance Z.Zinza Input where
 187     toType    = Z.genericToTypeSFP
 188     toValue   = Z.genericToValueSFP
 189     fromValue = Z.genericFromValueSFP
 190
 191 data InputLicense = InputLicense
 192     { ilConstructor   :: Text
 193     , ilId            :: Text
 194     , ilName          :: Text
 195     , ilIsOsiApproved :: Bool
 196     , ilIsFsfLibre    :: Bool
 197     }
 198   deriving (Show, Generic)
 199
 200 instance Z.Zinza InputLicense where
 201     toType    = Z.genericToTypeSFP
 202     toValue   = Z.genericToValueSFP
 203     fromValue = Z.genericFromValueSFP
 204
 205 instance Z.Zinza a => Z.Zinza (PerV a) where
 206     toType _ = Z.TyRecord $ Map.fromList
 207         [ ("v" ++ suffixVer v, ("index " ++ show v, Z.toType (Proxy :: Proxy a)))
 208         | v <- [ minBound .. maxBound ]
 209         ]
 210
 211     toValue x = Z.VRecord $ Map.fromList
 212         [ ("v" ++ suffixVer v, Z.toValue (index v x))
 213         | v <- [ minBound .. maxBound ]
 214         ]
 215
 216     fromValue = error "fromExpr @PerV not implemented"