diff --git a/spdx.cabal b/spdx.cabal --- a/spdx.cabal +++ b/spdx.cabal @@ -1,11 +1,11 @@ name: spdx -version: 0.1.2.0 +version: 0.2.0.0 synopsis: SPDX license expression language description: Implementation of related functionality. homepage: https://github.com/phadej/spdx license: BSD3 license-file: LICENSE -author: Oleg Grenrus +author: Oleg Grenrus maintainer: Oleg Grenrus copyright: (c) 2015 Oleg Grenrus category: Data @@ -20,6 +20,7 @@ other-modules: Data.SPDX.Licenses, Data.SPDX.Types, Data.SPDX.Parser, + Data.SPDX.Pretty, Data.SPDX.Ranges other-extensions: CPP DeriveFunctor, @@ -38,6 +39,7 @@ test-suite test type: exitcode-stdio-1.0 main-is: Tests.hs + other-modules: Generators default-language: Haskell2010 hs-source-dirs: tests ghc-options: -Wall diff --git a/src/Data/SPDX.hs b/src/Data/SPDX.hs --- a/src/Data/SPDX.hs +++ b/src/Data/SPDX.hs @@ -25,15 +25,24 @@ -- * Parsing , parseExpression , unsafeParseExpr + -- * Prettifying + -- | Inverse of parsing + , prettyLicenseId + , prettyLicenseExceptionId + , prettyLicenseRef + , prettyLicenseExpression -- * Logic , satisfies + , equivalent ) where -import Data.SPDX.Types -import Data.SPDX.Ranges -import Data.SPDX.Licenses -import Data.SPDX.Parser -import Data.SPDX.LatticeSyntax +import Data.SPDX.LatticeSyntax (LatticeSyntax(..)) +import qualified Data.SPDX.LatticeSyntax as LS +import Data.SPDX.Licenses +import Data.SPDX.Parser +import Data.SPDX.Pretty +import Data.SPDX.Ranges +import Data.SPDX.Types data Lic = Lic (Either LicenseRef LicenseId) (Maybe LicenseExceptionId) deriving (Eq, Ord, Show, Read) @@ -67,4 +76,14 @@ satisfies :: LicenseExpression -- ^ package license -> LicenseExpression -- ^ license policy -> Bool -satisfies a b = exprToLSLic b `preorder` exprToLSLic a +satisfies a b = exprToLSLic b `LS.preorder` exprToLSLic a + +-- | Check wheather two 'LicenseExpression' are equivalent. +-- +-- >>> unsafeParseExpr "(MIT AND GPL-2.0)" `equivalent` unsafeParseExpr "(GPL-2.0 AND MIT)" +-- True +-- +-- >>> unsafeParseExpr "MIT" `equivalent` unsafeParseExpr "MIT OR BSD-3-Clause" +-- False +equivalent :: LicenseExpression -> LicenseExpression -> Bool +equivalent a b = exprToLSLic a `LS.equivalent` exprToLSLic b diff --git a/src/Data/SPDX/Parser.hs b/src/Data/SPDX/Parser.hs --- a/src/Data/SPDX/Parser.hs +++ b/src/Data/SPDX/Parser.hs @@ -5,10 +5,7 @@ #define MIN_VERSION_base(x,y,z) 0 #endif -#if !MIN_VERSION_base(4, 8, 0) import Control.Applicative -#endif - import Data.Char import Text.ParserCombinators.ReadP @@ -21,6 +18,10 @@ instance Applicative ReadP where pure = return (<*>) = ap + +instance Alternative ReadP where + empty = mzero + (<|>) = mplus #endif license :: ReadP LicenseId @@ -31,24 +32,24 @@ licenseException = choice (map f licenseExceptions) where f l = l <$ string (getLicenseExceptionId l) -elicense :: ReadP LicenseExpression -elicense = (\l -> ELicense False (Right l) Nothing) <$> license - -elicenseWith :: ReadP LicenseExpression -elicenseWith = (\l e -> ELicense False (Right l) (Just e)) <$> license <* skipSpaces1 <* string "WITH" <* skipSpaces1 <*> licenseException +licenseRef :: ReadP LicenseRef +licenseRef = l <|> d + where l = LicenseRef Nothing <$ string "LicenseRef-" <*> idString + d = (\docId licId -> LicenseRef (Just docId) licId) <$ string "DocumentRef-" <*> idString <* char ':' <* string "LicenseRef-" <*> idString -elicenseAndNewer :: ReadP LicenseExpression -elicenseAndNewer = (\l -> ELicense True (Right l) Nothing) <$> license <* char '+' +mkLicense :: ReadP (Either LicenseRef LicenseId) -> ReadP LicenseExpression +mkLicense p = choice + [ (\l -> ELicense False l Nothing) <$> p + , (\l e -> ELicense False l (Just e)) <$> p <* skipSpaces1 <* string "WITH" <* skipSpaces1 <*> licenseException + , (\l -> ELicense True l Nothing) <$> p <* char '+' + , (\l e -> ELicense True l (Just e)) <$> p <* char '+' <* string " WITH " <*> licenseException + ] -elicenseWithAndNewer :: ReadP LicenseExpression -elicenseWithAndNewer = (\l e -> ELicense True (Right l) (Just e)) <$> license <* char '+' <* string " WITH " <*> licenseException +elicense :: ReadP LicenseExpression +elicense = mkLicense (Right <$> license) elicenseRef :: ReadP LicenseExpression -elicenseRef = (\licId -> ELicense False (Left $ LicenseRef Nothing licId) Nothing) <$ string "LicenseRef-" <*> idString - -elicenseDocRef :: ReadP LicenseExpression -elicenseDocRef = f <$ string "DocumentRef-" <*> idString <* char ':' <* string "LicenseRef-" <*> idString - where f docId licId = ELicense False (Left $ LicenseRef (Just docId) licId) Nothing +elicenseRef = mkLicense (Left <$> licenseRef) idString :: ReadP String idString = munch1 p @@ -64,11 +65,7 @@ terminal :: ReadP LicenseExpression terminal = choice [ elicense - , elicenseWith - , elicenseAndNewer - , elicenseWithAndNewer , elicenseRef - , elicenseDocRef , parens expression ] diff --git a/src/Data/SPDX/Pretty.hs b/src/Data/SPDX/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Data/SPDX/Pretty.hs @@ -0,0 +1,39 @@ +-- | Parser inverse. +module Data.SPDX.Pretty + ( prettyLicenseId + , prettyLicenseExceptionId + , prettyLicenseRef + , prettyLicenseExpression + ) where + +import Data.SPDX.Types + +prettyLicenseId :: LicenseId -> String +prettyLicenseId = getLicenseId + +prettyLicenseExceptionId :: LicenseExceptionId -> String +prettyLicenseExceptionId = getLicenseExceptionId + +prettyLicenseRef :: LicenseRef -> String +prettyLicenseRef (LicenseRef Nothing r) = "LicenseRef-" ++ r +prettyLicenseRef (LicenseRef (Just d) r) = "DocumentRef-" ++ d ++ ":LicenseRef-" ++ r + +prettyLicenseExpression :: LicenseExpression -> String +prettyLicenseExpression = pprExpr 1 + +pprLicense :: Either LicenseRef LicenseId -> String +pprLicense (Left ref) = prettyLicenseRef ref +pprLicense (Right i) = prettyLicenseId i + +pprExpr :: Int -> LicenseExpression -> String +pprExpr _ (ELicense newer lic exc) = pprLicense lic ++ n ++ e + where n = if newer then "+" else "" + e = case exc of + Just exc' -> " WITH " ++ prettyLicenseExceptionId exc' + Nothing -> "" +pprExpr d (EConjunction e1 e2) = parens (d < 0) $ pprExpr 0 e1 ++ " AND " ++ pprExpr 0 e2 +pprExpr d (EDisjunction e1 e2) = parens (d < 1) $ pprExpr 1 e1 ++ " OR " ++ pprExpr 1 e2 + +parens :: Bool -> String -> String +parens False s = s +parens True s = "(" ++ s ++ ")" diff --git a/tests/Generators.hs b/tests/Generators.hs new file mode 100644 --- /dev/null +++ b/tests/Generators.hs @@ -0,0 +1,59 @@ +module Generators where + +import Control.Applicative +import Test.Tasty.QuickCheck as QC + +import Data.SPDX +import Data.SPDX.LatticeSyntax (LatticeSyntax(..)) + +licenseIdGen :: Gen LicenseId +licenseIdGen = elements licenseIdentifiers + +licenseExceptionGen :: Gen LicenseExceptionId +licenseExceptionGen = elements licenseExceptions + +maybeGen :: Gen a -> Gen (Maybe a) +maybeGen g = oneof [ pure Nothing, Just <$> g] + +licenseRefGen :: Gen LicenseRef +licenseRefGen = LicenseRef <$> maybeGen idStringGen <*> idStringGen + +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 LicenseExpression +mkExprGen licGen = sized gen + where gen 0 = licGen + gen n = oneof [ licGen + , EDisjunction <$> gen' <*> gen' + , EConjunction <$> gen' <*> gen' + ] + where gen' = gen (n `div` 2) + +exprGen :: Gen LicenseExpression +exprGen = mkExprGen $ ELicense <$> arbitrary <*> (Right <$> licenseIdGen) <*> (pure Nothing) + +-- | 'exprGen' which contains also LicenseRefs and exceptions +exprGen' :: Gen LicenseExpression +exprGen' = mkExprGen $ ELicense <$> arbitrary <*> eitherLicenseIdRefGen <*> maybeGen licenseExceptionGen + +eitherLicenseIdRefGen :: Gen (Either LicenseRef LicenseId) +eitherLicenseIdRefGen = oneof [Right <$> licenseIdGen, Left <$> licenseRefGen] + +exprShrink :: LicenseExpression -> [LicenseExpression] +exprShrink (ELicense _ _ _) = [] +exprShrink (EDisjunction a b) = a : b : ((a `EDisjunction`) <$> exprShrink b) ++ ((`EDisjunction` b) <$> exprShrink a) +exprShrink (EConjunction a b) = a : b : ((a `EConjunction`) <$> exprShrink b) ++ ((`EConjunction` b) <$> exprShrink a) + +scaleGen :: (Int -> Int) -> Gen a -> Gen a +scaleGen f g = sized (\n -> resize (f n) g) diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -1,13 +1,15 @@ module Main (main) where -import Control.Applicative -import Data.List -import Test.Tasty -import Test.Tasty.QuickCheck as QC +import Data.List +import Test.Tasty +import Test.Tasty.QuickCheck as QC -import Data.SPDX -import Data.SPDX.LatticeSyntax +import Data.SPDX +import Data.SPDX.LatticeSyntax (LatticeSyntax(..)) +import qualified Data.SPDX.LatticeSyntax as LS +import Generators + main :: IO () main = defaultMain tests @@ -35,28 +37,10 @@ , rangeUnit ] -simpleExprGen :: Gen LicenseId -simpleExprGen = elements licenseIdentifiers - -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) - -exprGen :: Gen LicenseExpression -exprGen = sized gen - where sim = ELicense <$> arbitrary <*> (Right <$> simpleExprGen) <*> (pure Nothing) - gen 0 = sim - gen n = oneof [ sim - , EDisjunction <$> gen' <*> gen' - , EConjunction <$> gen' <*> gen' - ] - where gen' = gen (n `div` 2) +-- | Like `equivalent`, but prints a counterexample when it fails. +equivalentProp :: [LicenseExpression] -> [LicenseExpression] -> Property +equivalentProp x y = + counterexample (show x ++ " /= " ++ show y) $ length x == length y && (and $ zipWith equivalent x y) simpleUnits :: TestTree simpleUnits = testGroup "Simple License Expressions" @@ -85,11 +69,11 @@ 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) `equivalent` b) - rhs = ((a `LMeet` b) `equivalent` a) + 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 `equivalent` a - , QC.testProperty "preorder reflexive" $ forAll latticeSyntaxGen $ \a -> a `preorder` a + , QC.testProperty "equivalent reflexive" $ forAll latticeSyntaxGen $ \a -> a `LS.equivalent` a + , QC.testProperty "preorder reflexive" $ forAll latticeSyntaxGen $ \a -> a `LS.preorder` a ] osiLicenseIds :: [LicenseId] @@ -109,15 +93,20 @@ isOsiApprovedExpr' :: LicenseExpression -> Bool isOsiApprovedExpr' e = e `satisfies` osiLicenseExpr -scaleGen :: (Int -> Int) -> Gen a -> Gen a -scaleGen f g = sized (\n -> resize (f n) g) - qcProps :: TestTree qcProps = testGroup "By Quickcheck" - [ QC.testProperty "licence identifiers are valid licenses" $ forAll simpleExprGen $ valid . getLicenseId - , QC.testProperty "satisfies osi checked" $ forAll (scaleGen (`div` 2) exprGen) $ + [ QC.testProperty "licence identifiers are valid licenses" $ forAll licenseIdGen $ valid . getLicenseId + , QC.testProperty "satisfies osi checked" $ forAll (scaleGen (`div` 3) exprGen) $ \e -> isOsiApprovedExpr e == isOsiApprovedExpr' e -- Skip , lsProps + , parsePrettyProps + ] + +parsePrettyProps :: TestTree +parsePrettyProps = testGroup "parse . pretty" + [ QC.testProperty "LicenseId" $ forAll licenseIdGen $ \i -> mkLicenseId (prettyLicenseId i) === Just i + , QC.testProperty "LicenseExpression" $ forAllShrink (scaleGen (`div` 3) exprGen) exprShrink $ \e -> parseExpression (prettyLicenseExpression e) `equivalentProp` [e] + , QC.testProperty "LicenseExpression'" $ forAllShrink (scaleGen (`div` 3) exprGen') exprShrink $ \e -> parseExpression (prettyLicenseExpression e) `equivalentProp` [e] ] ranges :: [[String]]