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