    {-# LANGUAGE DeriveFunctor #-}
    {-# LANGUAGE ViewPatterns #-}
    {-# LANGUAGE LambdaCase #-}
    module Hpack.License where

    import           Control.Arrow ((&&&))

    import           Distribution.Pretty (prettyShow)
    import           Distribution.Version (mkVersion)
    import qualified Distribution.License as Cabal
    import qualified Distribution.SPDX.License as SPDX
    import           Distribution.Parsec.Class (eitherParsec)

    import qualified Data.License.Infer as Infer

    data License a = DontTouch String | CanSPDX Cabal.License a | MustSPDX a
      deriving (Eq, Show, Functor)

    parseLicense :: String -> License SPDX.License
    parseLicense license = case lookup license knownLicenses of
      Just l -> CanSPDX l (Cabal.licenseToSPDX l)
      Nothing -> case spdxLicense of
        Just l -> MustSPDX l
        Nothing -> DontTouch license
      where
        knownLicenses :: [(String, Cabal.License)]
        knownLicenses = map (prettyShow &&& id) (Cabal.BSD4 : Cabal.knownLicenses)

        spdxLicense :: Maybe SPDX.License
        spdxLicense  = either (const Nothing) Just (eitherParsec license)

    inferLicense :: String -> Maybe (License SPDX.License)
    inferLicense = fmap (uncurry CanSPDX . (id &&& Cabal.licenseToSPDX) . toLicense) . Infer.inferLicense
      where
        toLicense = \ case
          Infer.MIT -> Cabal.MIT
          Infer.ISC -> Cabal.ISC
          Infer.BSD2 -> Cabal.BSD2
          Infer.BSD3 -> Cabal.BSD3
          Infer.BSD4 -> Cabal.BSD4
          Infer.Apache_2_0 -> Cabal.Apache (Just $ mkVersion [2,0])
          Infer.MPL_2_0 -> Cabal.MPL (mkVersion [2,0])
          Infer.GPLv2 -> Cabal.GPL (Just $ mkVersion [2])
          Infer.GPLv3 -> Cabal.GPL (Just $ mkVersion [3])
          Infer.LGPLv2_1 -> Cabal.LGPL (Just $ mkVersion [2,1])
          Infer.LGPLv3 -> Cabal.LGPL (Just $ mkVersion [3])
          Infer.AGPLv3 -> Cabal.AGPL (Just $ mkVersion [3])