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