spdx 1.0.0.3 → 1.1
raw patch · 6 files changed
+94/−243 lines, 6 filesdep +Cabal-syntaxdep +puresatdep −Cabaldep −base-compatdep ~QuickCheckdep ~basedep ~containers
Dependencies added: Cabal-syntax, puresat
Dependencies removed: Cabal, base-compat
Dependency ranges changed: QuickCheck, base, containers, tasty, tasty-quickcheck, transformers
Files
- CHANGELOG.md +8/−0
- spdx.cabal +38/−38
- src/Distribution/SPDX/Extra.hs +44/−16
- src/Distribution/SPDX/Extra/Internal.hs +0/−142
- tests/Generators.hs +3/−24
- tests/Tests.hs +1/−23
CHANGELOG.md view
@@ -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.
spdx.cabal view
@@ -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
src/Distribution/SPDX/Extra.hs view
@@ -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)
− src/Distribution/SPDX/Extra/Internal.hs
@@ -1,142 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-}--- |------ Inspired by <http://www.well-typed.com/blog/2014/12/simple-smt-solver/ Simple SMT Solver>.------ 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)
tests/Generators.hs view
@@ -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
tests/Tests.hs view
@@ -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 ]