diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +1.1 + +- Support GHC-9.6.5...9.10.1 +- Use better algorithm for expression equivalence and preorder + (It's still very slow compared to the state of the art SAT solvers: + but it can solve the sudoku example in reasonable time) +- Remove "Distribution.SPDX.Extra.Internal" module + 1 - Move to use `Distribution.SPDX` (from `Cabal`) types. diff --git a/spdx.cabal b/spdx.cabal --- a/spdx.cabal +++ b/spdx.cabal @@ -1,6 +1,6 @@ -cabal-version: 2.2 +cabal-version: 3.4 name: spdx -version: 1.0.0.3 +version: 1.1 synopsis: SPDX license expression language, Extras category: Data description: @@ -14,32 +14,33 @@ copyright: (c) 2015-2018 Oleg Grenrus build-type: Simple extra-source-files: - README.md CHANGELOG.md + README.md -tested-with: - GHC ==7.6.3 - || ==7.8.4 - || ==7.10.3 - || ==8.0.2 - || ==8.2.2 - || ==8.4.4 - || ==8.6.5 - || ==8.8.4 - || ==8.10.7 - || ==9.0.2 - || ==9.2.2 +tested-with: GHC ==9.6.6 || ==9.8.2 || ==9.10.1 source-repository head type: git location: https://github.com/phadej/spdx -library - default-language: Haskell98 - exposed-modules: - Distribution.SPDX.Extra - Distribution.SPDX.Extra.Internal +common language + default-language: Haskell2010 + default-extensions: + BangPatterns + DeriveTraversable + DerivingStrategies + GADTs + PatternSynonyms + RankNTypes + RoleAnnotations + ScopedTypeVariables + StandaloneDeriving + StandaloneKindSignatures + TypeApplications +library + default-language: Haskell2010 + exposed-modules: Distribution.SPDX.Extra other-extensions: CPP DeriveDataTypeable @@ -50,25 +51,25 @@ hs-source-dirs: src/ ghc-options: -Wall build-depends: - , base >=4.3.0.0 && <4.17 - , Cabal ^>=2.4.0.1 || ^>=3.0.0.0 || ^>=3.2.0.0 || ^>=3.4.0.0 || ^>=3.6.0.0 - , containers >=0.5.0.0 && <0.7 - , transformers >=0.3 && <0.6 + , base >=4.18.2.1 && <4.21 + , Cabal-syntax ^>=3.10.3.0 || ^>=3.12.1.0 + , containers >=0.6.7 && <0.8 + , puresat ^>=0.1 + , transformers >=0.6.1.0 && <0.7 test-suite test - type: exitcode-stdio-1.0 - main-is: Tests.hs - other-modules: Generators - default-language: Haskell98 - hs-source-dirs: tests - ghc-options: -Wall + import: language + type: exitcode-stdio-1.0 + main-is: Tests.hs + other-modules: Generators + hs-source-dirs: tests + ghc-options: -Wall build-depends: , base - , base-compat ^>=0.10.5 || ^>=0.11.1 || ^>=0.12.1 - , Cabal + , Cabal-syntax , spdx - , tasty >=1.1.0.4 && <1.5 - , tasty-quickcheck ^>=0.10 + , tasty ^>=1.5 + , tasty-quickcheck ^>=0.11 benchmark bench type: exitcode-stdio-1.0 @@ -79,8 +80,7 @@ ghc-options: -Wall build-depends: , base - , base-compat ^>=0.10.5 || ^>=0.11.1 || ^>=0.12.1 - , Cabal - , QuickCheck >=2.12.6.1 && <2.15 + , Cabal-syntax + , QuickCheck ^>=2.15.0.1 , spdx - , tasty-quickcheck ^>=0.10 + , tasty-quickcheck ^>=0.11 diff --git a/src/Distribution/SPDX/Extra.hs b/src/Distribution/SPDX/Extra.hs --- a/src/Distribution/SPDX/Extra.hs +++ b/src/Distribution/SPDX/Extra.hs @@ -14,12 +14,20 @@ equivalent, ) where +import Control.Monad.SAT +import qualified Data.Map.Strict as Map +import Control.Monad.Trans.Class (lift) +import Data.Map.Strict (Map) +import Control.Monad.Trans.State +import Data.Maybe (isNothing) + import Distribution.SPDX (License (..), LicenseExceptionId, LicenseExpression (..), LicenseId, SimpleLicenseExpression (..)) -import Distribution.SPDX.Extra.Internal (LatticeSyntax (..)) -import qualified Distribution.SPDX.Extra.Internal as LS +-- $setup +-- >>> import Distribution.Parsec (simpleParsec) +-- >>> let unsafeParseExpr e = maybe (error $ "invalid: " ++ e) (id :: License -> License) (simpleParsec e) -- | -- @@ -43,8 +51,14 @@ satisfies :: License -- ^ package license -> License -- ^ license policy -> Bool -satisfies a b = exprToLSLic b `LS.preorder` exprToLSLic a +satisfies a b = isNothing $ runSATMaybe $ flip evalStateT Map.empty $ do + a' <- exprToProp a >>= lift . addDefinition + b' <- exprToProp b >>= lift . addDefinition + lift $ addProp $ neg $ lit b' --> lit a' + lift solve_ + -- exprToLSLic b `LS.preorder` exprToLSLic a + -- | Check wheather two 'LicenseExpression' are equivalent. -- -- >>> unsafeParseExpr "(MIT AND GPL-2.0-only)" `equivalent` unsafeParseExpr "(GPL-2.0-only AND MIT)" @@ -54,24 +68,38 @@ -- False -- equivalent :: License -> License -> Bool -equivalent a b = exprToLSLic a `LS.equivalent` exprToLSLic b +equivalent a b = isNothing $ runSATMaybe $ flip evalStateT Map.empty $ do + a' <- exprToProp a >>= lift . addDefinition + b' <- exprToProp b >>= lift . addDefinition + lift $ addProp $ neg $ lit a' <-> lit b' + lift solve_ -------------------------------------------------------------------------------- +----------------------------------f--------------------------------------------- -- internal ------------------------------------------------------------------------------- data Lic = Lic !SimpleLicenseExpression !(Maybe LicenseExceptionId) deriving (Eq, Ord) -exprToLSLic :: License -> LatticeSyntax Lic -exprToLSLic NONE = LBound False -exprToLSLic (License lic) = licTo lic - -licTo :: LicenseExpression -> LatticeSyntax Lic -licTo (ELicense lic exc) = LVar (Lic lic exc) -licTo (EAnd a b) = LMeet (licTo a) (licTo b) -licTo (EOr a b) = LJoin (licTo a) (licTo b) +exprToProp :: License -> StateT (Map Lic (Lit s)) (SAT s) (Prop s) +exprToProp NONE = return false +exprToProp (License lic) = licToProp lic --- $setup --- >>> import Distribution.Parsec.Class (simpleParsec) --- >>> let unsafeParseExpr e = maybe (error $ "invalid: " ++ e) (id :: License -> License) (simpleParsec e) +licToProp :: LicenseExpression -> StateT (Map Lic (Lit s)) (SAT s) (Prop s) +licToProp (EAnd a b) = do + a' <- licToProp a + b' <- licToProp b + return (a' /\ b') +licToProp (EOr a b) = do + a' <- licToProp a + b' <- licToProp b + return (a' \/ b') +licToProp (ELicense lic exc) = do + let k = Lic lic exc + s <- get + case Map.lookup k s of + Just l -> return (lit l) + Nothing -> do + l <- lift newLit + put (Map.insert k l s) + return (lit l) diff --git a/src/Distribution/SPDX/Extra/Internal.hs b/src/Distribution/SPDX/Extra/Internal.hs deleted file mode 100644 --- a/src/Distribution/SPDX/Extra/Internal.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} --- | --- --- Inspired by . --- --- In future this module will probably be moved into separate package. -module Distribution.SPDX.Extra.Internal - (LatticeSyntax(..), dual, freeVars, equivalent, preorder, satisfiable) where - -import Control.Applicative -import Control.Monad -import Control.Monad.Trans.State.Strict -import Data.Data -import Data.Foldable -import Data.Traversable -import Prelude hiding (all, or) - -import qualified Data.Map.Strict as Map - -data LatticeSyntax a = LVar a - | LBound Bool - | LJoin (LatticeSyntax a) (LatticeSyntax a) - | LMeet (LatticeSyntax a) (LatticeSyntax a) - deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Typeable, Data) - -instance Applicative LatticeSyntax where - pure = return - (<*>) = ap - -instance Monad LatticeSyntax where - return = LVar - LVar x >>= f = f x - LBound b >>= _ = LBound b - LJoin a b >>= f = LJoin (a >>= f) (b >>= f) - LMeet a b >>= f = LMeet (a >>= f) (b >>= f) - -freeVars :: LatticeSyntax a -> [a] -freeVars = toList - -dual :: LatticeSyntax a -> LatticeSyntax a -dual (LVar v) = LVar v -dual (LBound t) = LBound $ not t -dual (LJoin a b) = LMeet (dual a) (dual b) -dual (LMeet a b) = LJoin (dual a) (dual b) - --- | Test for equivalence. --- --- >>> equivalent (LMeet (LVar 'a') (LVar 'b')) (LMeet (LVar 'b') (LVar 'a')) --- True --- --- >>> equivalent (LVar 'a') (LMeet (LVar 'a') (LVar 'a')) --- True --- --- >>> equivalent (LMeet (LVar 'a') (LVar 'b')) (LMeet (LVar 'b') (LVar 'b')) --- False -equivalent :: Ord a => LatticeSyntax a -> LatticeSyntax a -> Bool -equivalent a b = all (uncurry (==)) . runEval $ p - where p = (,) <$> evalLattice a <*> evalLattice b - --- | Test for preorder. --- --- @ a ≤ b ⇔ a ∨ b ≡ b ⇔ a ≡ a ∧ b @ --- --- >>> preorder (LVar 'a' `LMeet` LVar 'b') (LVar 'a') --- True --- --- >>> preorder (LVar 'a') (LVar 'a' `LMeet` LVar 'b') --- False -preorder :: Ord a => LatticeSyntax a -> LatticeSyntax a -> Bool -preorder a b = (a `LJoin` b) `equivalent` b - --- | Return `True` if for some variable assigment expression evaluates to `True`. -satisfiable :: Ord a => LatticeSyntax a -> Bool -satisfiable = or . runEval . evalLattice - -newtype Eval v a = Eval { unEval :: StateT (Map.Map v Bool) [] a } - -instance Functor (Eval v) where - fmap = liftM - -instance Applicative (Eval v) where - pure = return - (<*>) = ap - -instance Alternative (Eval v) where - empty = mzero - (<|>) = mplus - -instance Monad (Eval v) where - return = Eval . return - Eval m >>= k = Eval $ m >>= unEval . k - -instance MonadPlus (Eval v) where - mzero = Eval mzero - Eval a `mplus` Eval b = Eval $ a `mplus` b - -runEval :: Eval v a -> [a] -runEval act = evalStateT (unEval act) Map.empty - -evalLattice :: Ord v => LatticeSyntax v -> Eval v Bool -evalLattice (LVar v) = guess v -evalLattice (LBound b) = return b -evalLattice (LJoin a b) = evalLattice a ||^ evalLattice b -evalLattice (LMeet a b) = evalLattice a &&^ evalLattice b - -guess :: Ord v => v -> Eval v Bool -guess v = Eval $ do - st <- get - let remember b = put (Map.insert v b st) >> return b - case Map.lookup v st of - Just b -> return b - Nothing -> remember True <|> remember False - --- From Control.Monad.Extra of extra - --- | Like @if@, but where the test can be monadic. -ifM :: Monad m => m Bool -> m a -> m a -> m a -ifM b t f = do b' <- b; if b' then t else f - --- | The lazy '||' operator lifted to a monad. If the first --- argument evaluates to 'True' the second argument will not --- be evaluated. --- --- > Just True ||^ undefined == Just True --- > Just False ||^ Just True == Just True --- > Just False ||^ Just False == Just False -(||^) :: Monad m => m Bool -> m Bool -> m Bool -(||^) a b = ifM a (return True) b - --- | The lazy '&&' operator lifted to a monad. If the first --- argument evaluates to 'False' the second argument will not --- be evaluated. --- --- > Just False &&^ undefined == Just False --- > Just True &&^ Just True == Just True --- > Just True &&^ Just False == Just False -(&&^) :: Monad m => m Bool -> m Bool -> m Bool -(&&^) a b = ifM a b (return False) diff --git a/tests/Generators.hs b/tests/Generators.hs --- a/tests/Generators.hs +++ b/tests/Generators.hs @@ -1,26 +1,15 @@ {-# LANGUAGE CPP #-} module Generators where -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 0 -#endif - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - import Test.Tasty.QuickCheck as QC import Distribution.SPDX -import Distribution.SPDX.Extra.Internal (LatticeSyntax(..)) latestLicenseListVersion :: LicenseListVersion -#if MIN_VERSION_Cabal(3,4,0) -latestLicenseListVersion = LicenseListVersion_3_9 -#elif MIN_VERSION_Cabal(3,0,0) -latestLicenseListVersion = LicenseListVersion_3_6 +#if MIN_VERSION_Cabal_syntax(3,12,0) +latestLicenseListVersion = LicenseListVersion_3_23 #else -latestLicenseListVersion = LicenseListVersion_3_2 +latestLicenseListVersion = LicenseListVersion_3_16 #endif licenseIdGen :: Gen LicenseId @@ -34,16 +23,6 @@ idStringGen :: Gen String idStringGen = elements ["foo", "bar", "baz", "AllRightsReserved"] - -latticeSyntaxGen :: Gen (LatticeSyntax Char) -latticeSyntaxGen = sized gen - where var = LVar <$> elements "abcdef" - gen 0 = var - gen n = oneof [ var - , LMeet <$> gen' <*> gen' - , LJoin <$> gen' <*> gen' - ] - where gen' = gen (n `div` 2) mkExprGen :: Gen LicenseExpression -> Gen License mkExprGen licGen = License <$> sized gen where diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -1,25 +1,14 @@ -{-# LANGUAGE CPP #-} module Main (main) where import Data.Maybe (isJust) +import Distribution.Parsec import Distribution.Pretty import Distribution.SPDX import Distribution.SPDX.Extra -import Distribution.SPDX.Extra.Internal (LatticeSyntax (..)) import Generators -import Prelude () -import Prelude.Compat import Test.Tasty import Test.Tasty.QuickCheck as QC -#if MIN_VERSION_Cabal(3,0,0) -import Distribution.Parsec -#else -import Distribution.Parsec.Class -#endif - -import qualified Distribution.SPDX.Extra.Internal as LS - main :: IO () main = defaultMain tests @@ -75,20 +64,9 @@ up "LGPL-2.1-only OR BSD-3-Clause AND MIT" == EOr (up "LGPL-2.1-only") (EAnd (up "BSD-3-Clause") (up "MIT")) ] -lsProps :: TestTree -lsProps = testGroup "LatticeSyntax" - [ QC.testProperty "a ≤ b ⇔ a ∨ b ≡ b ⇔ a ≡ a ∧ b" $ forAll latticeSyntaxGen $ \a -> forAll latticeSyntaxGen $ \b -> - let lhs = ((a `LJoin` b) `LS.equivalent` b) - rhs = ((a `LMeet` b) `LS.equivalent` a) - in label (show lhs) (lhs === rhs) - , QC.testProperty "equivalent reflexive" $ forAll latticeSyntaxGen $ \a -> a `LS.equivalent` a - , QC.testProperty "preorder reflexive" $ forAll latticeSyntaxGen $ \a -> a `LS.preorder` a - ] - qcProps :: TestTree qcProps = testGroup "By Quickcheck" [ QC.testProperty "licence identifiers are valid licenses" $ forAll licenseIdGen $ valid . prettyShow - , lsProps , parsePrettyProps ]