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