picnoir/hnix
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Only invoke pretty/parser tests if PRETTY_TESTS=<N> for some N>0

Browse source
This commit is contained in:
John Wiegley 2018-05-06 22:13:30 -07:00
parent ac3ab07b8b
commit 2457efdaa3
No known key found for this signature in database
GPG key ID: C144D8F4F19FE630
4 changed files with 178 additions and 96 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
hnix.cabal
View file

@ -2,7 +2,7 @@
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
-- --
-- hash: 5eba5b1b4e2ae5297dcad048052e5bc02fc2f42aa37016fbea866ecbf3f4a380 -- hash: cbc369801227ccd516b691c3f08a9aae9b5ac8723619706b83703a805d570972
name: hnix name: hnix
version: 0.5.0 version: 0.5.0
@ -206,6 +206,7 @@ test-suite hnix-tests
, megaparsec , megaparsec
, mtl , mtl
, optparse-applicative , optparse-applicative
, pretty-show
, process , process
, quickcheck-instances , quickcheck-instances
, serialise , serialise

1
package.yaml
View file

@ -134,6 +134,7 @@ tests:
- Diff - Diff
- megaparsec - megaparsec
- tasty-quickcheck - tasty-quickcheck
- pretty-show
benchmarks: benchmarks:
hnix-benchmarks: hnix-benchmarks:

19
tests/Main.hs
View file

@ -11,7 +11,7 @@ import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Data.Fix import Data.Fix
import Data.List (isInfixOf) import Data.List (isInfixOf)
import Data.Maybe (isJust) import Data.Maybe (isJust, fromMaybe)
import Data.String.Interpolate.IsString import Data.String.Interpolate.IsString
import Data.Text (unpack) import Data.Text (unpack)
import Data.Time import Data.Time
@ -25,7 +25,7 @@ import Nix.Value
import qualified NixLanguageTests import qualified NixLanguageTests
import qualified ParserTests import qualified ParserTests
import qualified PrettyTests import qualified PrettyTests
-- import qualified PrettyParseTests import qualified PrettyParseTests
import System.Environment import System.Environment
import System.FilePath.Glob import System.FilePath.Glob
import System.Posix.Files import System.Posix.Files
@ -85,19 +85,18 @@ main = do
evalComparisonTests <- EvalTests.genEvalCompareTests evalComparisonTests <- EvalTests.genEvalCompareTests
langTestsEnv <- lookupEnv "LANGUAGE_TESTS" langTestsEnv <- lookupEnv "LANGUAGE_TESTS"
nixpkgsTestsEnv <- lookupEnv "NIXPKGS_TESTS" nixpkgsTestsEnv <- lookupEnv "NIXPKGS_TESTS"
let runLangTests = isJust langTestsEnv prettyTestsEnv <- lookupEnv "PRETTY_TESTS"
let runNixpkgsTests = isJust nixpkgsTestsEnv
defaultMain $ testGroup "hnix" $ defaultMain $ testGroup "hnix" $
[ testCase "hnix.cabal correctly generated" cabalCorrectlyGenerated ] ++ [ testCase "hnix.cabal correctly generated" cabalCorrectlyGenerated ] ++
[ ParserTests.tests [ ParserTests.tests
, EvalTests.tests , EvalTests.tests
, PrettyTests.tests , PrettyTests.tests ] ++
-- , PrettyParseTests.tests [ PrettyParseTests.tests (read (fromMaybe "0" prettyTestsEnv)) ] ++
, evalComparisonTests ] ++ [ evalComparisonTests ] ++
[ testCase "Nix language tests present" ensureLangTestsPresent [ testCase "Nix language tests present" ensureLangTestsPresent
| runLangTests ] ++ | isJust langTestsEnv ] ++
[ nixLanguageTests | runLangTests ] ++ [ nixLanguageTests | isJust langTestsEnv ] ++
[ testCase "Nixpkgs parses without errors" ensureNixpkgsCanParse [ testCase "Nixpkgs parses without errors" ensureNixpkgsCanParse
| runNixpkgsTests ] | isJust nixpkgsTestsEnv ]

251
tests/PrettyParseTests.hs
View file

@ -1,38 +1,42 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS -Wno-orphans#-} {-# OPTIONS -Wno-orphans#-}
module PrettyParseTests where module PrettyParseTests where
import Test.Tasty.QuickCheck hiding (Success, Failure) import Control.Monad
import Test.Tasty import Data.Algorithm.Diff
import Test.QuickCheck.Instances.Text () import Data.Algorithm.DiffOutput
import Test.QuickCheck.Instances.Semigroup () import Data.Char
import Data.Fix
import qualified Data.List.NonEmpty as NE
import Data.Text (Text, pack)
import qualified Data.Text as Text
import Generic.Random
import Nix.Atoms
import Nix.Expr
import Nix.Parser
import Nix.Pretty
import Test.QuickCheck.Instances.Semigroup ()
import Test.QuickCheck.Instances.Text ()
import qualified Test.QuickCheck.Property as P import qualified Test.QuickCheck.Property as P
import Test.Tasty
import Test.Tasty.QuickCheck hiding (Success, Failure)
import Text.Megaparsec (Pos, SourcePos, mkPos)
import Text.PrettyPrint.ANSI.Leijen ((</>), text)
import qualified Text.PrettyPrint.ANSI.Leijen as P
import qualified Text.Show.Pretty as PS
import Nix.Expr (NExpr, NExprF(..), NString(..), NUnaryOp(..), NBinaryOp(..) -- Instead of using the Generic arbitrary instance (which doesn't exist anyway
, Params(..), NKeyName(..), Antiquoted(..), Binding(..)) -- for Text), we use a different generator which just prints sensible looking
import Nix.Atoms -- variable names
import Nix.Pretty
import Nix.Parser
import Generic.Random
import Data.Fix
import Data.Text (Text, pack, unpack)
import Text.Megaparsec (Pos, SourcePos, mkPos)
import Control.Monad
import Data.Algorithm.Diff
import Data.Algorithm.DiffOutput
import Data.Char
-- Instead of using the Generic arbitrary instance (which doesn't exist
-- anyway for Text), we use a different generator which just prints
-- sensible looking variable names
custom :: GenList '[Text] custom :: GenList '[Text]
custom = asciiText :@ Nil custom = asciiText :@ Nil
@ -45,11 +49,11 @@ asciiText :: Gen Text
asciiText = pack <$> asciiString asciiText = pack <$> asciiString
pcustom :: GenList '[Pos] pcustom :: GenList '[Pos]
pcustom = (arbitrary) :@ Nil pcustom = arbitrary :@ Nil
-- | This generator generates selects one of the constructors uniformly -- | This generator generates selects one of the constructors uniformly and
-- and also decreases the size of the generator by dividing by the -- also decreases the size of the generator by dividing by the branching
-- branching factor. This ensures sensible termination. -- factor. This ensures sensible termination.
genArb :: (GArbitrary (Options 'Sized '[Text]) a, GUniformWeight a) => Gen a genArb :: (GArbitrary (Options 'Sized '[Text]) a, GUniformWeight a) => Gen a
genArb = genericArbitraryWith (setGenerators custom sizedOpts) uniform genArb = genericArbitraryWith (setGenerators custom sizedOpts) uniform
@ -70,13 +74,23 @@ instance Arbitrary f => Arbitrary (Binding f) where
arbitrary = genArb arbitrary = genArb
instance Arbitrary f => Arbitrary (NKeyName f) where instance Arbitrary f => Arbitrary (NKeyName f) where
arbitrary = genArb arbitrary = oneof [ DynamicKey <$> arbitrary
, StaticKey <$> asciiText <*> arbitrary ]
instance Arbitrary f => Arbitrary (Params f) where instance Arbitrary f => Arbitrary (Params f) where
arbitrary = genArb arbitrary =
oneof [ Param <$> asciiText
, ParamSet <$> listOf ((,) <$> asciiText <*> arbitrary) <*> arbitrary
<*> oneof [pure Nothing, Just <$> asciiText]
]
instance Arbitrary NAtom where instance Arbitrary NAtom where
arbitrary = genArb arbitrary =
oneof [ NInt <$> arbitrary `suchThat` (>= 0)
, NFloat <$> arbitrary `suchThat` (>= 0)
, NBool <$> arbitrary
, pure NNull
, NUri <$> asciiText `suchThat` (\x -> Text.length x > 0) ]
instance Arbitrary NUnaryOp where instance Arbitrary NUnaryOp where
arbitrary = genArb arbitrary = genArb
@ -90,76 +104,143 @@ instance (Arbitrary f) => Arbitrary (Antiquoted Text f) where
instance (Arbitrary f) => Arbitrary (Antiquoted (NString f) f) where instance (Arbitrary f) => Arbitrary (Antiquoted (NString f) f) where
arbitrary = genArb arbitrary = genArb
-- This is written by hand so we can use `fairList` rather than -- This is written by hand so we can use `fairList` rather than the normal
-- the normal list Arbitrary instance which makes the generator -- list Arbitrary instance which makes the generator terminate. The
-- terminate. The distribution is not scientifically chosen. -- distribution is not scientifically chosen.
instance Arbitrary f => Arbitrary (NExprF f) where instance Arbitrary f => Arbitrary (NExprF f) where
arbitrary = arbitrary =
sized $ \n -> sized $ \n ->
if n < 2 if n < 2
then oneof [nConstant, nStr, nSym, nLiteralPath, nEnvPath ] then oneof [genConstant, genStr, genSym, genLiteralPath, genEnvPath ]
else else
frequency frequency
[ (1, nConstant) [ ( 1, genConstant)
, (1, nSym) , ( 1, genSym)
, (4, resize (n `div` 3) nIf) , ( 4, resize (n `div` 3) genIf)
, (10, nRecSet ) , (10, genRecSet )
, (20, nSet ) , (20, genSet )
, (5, nList ) , ( 5, genList )
, (2, nUnary ) , ( 2, genUnary )
, (2, resize (n `div` 3) nBinary ) , ( 2, resize (n `div` 3) genBinary )
, (3, resize (n `div` 3) nSelect ) , ( 3, resize (n `div` 3) genSelect )
, (20, resize (n `div` 2) nAbs ) , (20, resize (n `div` 2) genAbs )
, (2, resize (n `div` 2) nHasAttr ) , ( 2, resize (n `div` 2) genHasAttr )
, (10, resize (n `div` 2) nLet ) , (10, resize (n `div` 2) genLet )
, (10, resize (n `div` 2) nWith ) , (10, resize (n `div` 2) genWith )
, (1, resize (n `div` 2) nAssert) , ( 1, resize (n `div` 2) genAssert)
] ]
where where
nConstant = NConstant <$> arbitrary genConstant = NConstant <$> arbitrary
nStr = NStr <$> arbitrary genStr = NStr <$> arbitrary
nSym = NSym <$> asciiText genSym = NSym <$> asciiText
nList = NList <$> fairList arbitrary genList = NList <$> fairList arbitrary
nSet = NSet <$> fairList arbitrary genSet = NSet <$> fairList arbitrary
nRecSet = NRecSet <$> fairList arbitrary genRecSet = NRecSet <$> fairList arbitrary
nLiteralPath = NLiteralPath <$> asciiString genLiteralPath = NLiteralPath . ("./" ++) <$> asciiString
nEnvPath = NEnvPath <$> asciiString genEnvPath = NEnvPath <$> asciiString
nUnary = NUnary <$> arbitrary <*> arbitrary genUnary = NUnary <$> arbitrary <*> arbitrary
nBinary = NBinary <$> arbitrary <*> arbitrary <*> arbitrary genBinary = NBinary <$> arbitrary <*> arbitrary <*> arbitrary
nSelect = NSelect <$> arbitrary <*> arbitrary <*> arbitrary genSelect = NSelect <$> arbitrary <*> arbitrary <*> arbitrary
nHasAttr = NHasAttr <$> arbitrary <*> arbitrary genHasAttr = NHasAttr <$> arbitrary <*> arbitrary
nAbs = NAbs <$> arbitrary <*> arbitrary genAbs = NAbs <$> arbitrary <*> arbitrary
nLet = NLet <$> arbitrary <*> arbitrary genLet = NLet <$> fairList arbitrary <*> arbitrary
nIf = NIf <$> arbitrary <*> arbitrary <*> arbitrary genIf = NIf <$> arbitrary <*> arbitrary <*> arbitrary
nWith = NWith <$> arbitrary <*> arbitrary genWith = NWith <$> arbitrary <*> arbitrary
nAssert = NAssert <$> arbitrary <*> arbitrary genAssert = NAssert <$> arbitrary <*> arbitrary
-- | Useful when there are recursive positions at each element of the list -- | Useful when there are recursive positions at each element of the list as
-- as it divides the size by the length of the generated list. -- it divides the size by the length of the generated list.
fairList :: Gen a -> Gen [a] fairList :: Gen a -> Gen [a]
fairList g = do fairList g = do
s <- getSize s <- getSize
k <- choose (0, s) k <- choose (0, s)
-- Use max here to avoid dividing by zero when there is the empty list -- Use max here to avoid dividing by zero when there is the empty list
resize (s `div` (max 1 k)) $ vectorOf k g resize (s `div` max 1 k) $ vectorOf k g
-- | Test that pretty . parse . pretty == pretty equivUpToNormalization :: NExpr -> NExpr -> Bool
equivUpToNormalization x y = normalize x == normalize y
normalize :: NExpr -> NExpr
normalize = cata $ \case
NConstant (NInt n) | n < 0 -> Fix (NUnary NNeg (Fix (NConstant (NInt (negate n)))))
NConstant (NFloat n) | n < 0 -> Fix (NUnary NNeg (Fix (NConstant (NFloat (negate n)))))
NSet binds -> Fix (NSet (map normBinding binds))
NRecSet binds -> Fix (NRecSet (map normBinding binds))
NLet binds r -> Fix (NLet (map normBinding binds) r)
NAbs params r -> Fix (NAbs (normParams params) r)
r -> Fix r
where
normBinding (NamedVar path r) = NamedVar (NE.map normKey path) r
normBinding (Inherit mr names) = Inherit mr (map normKey names)
normKey (DynamicKey quoted) = DynamicKey (normAntiquotedString quoted)
normKey (StaticKey name _) = StaticKey name Nothing
normAntiquotedString :: Antiquoted (NString NExpr) NExpr
-> Antiquoted (NString NExpr) NExpr
normAntiquotedString (Plain (DoubleQuoted [EscapedNewline])) =
EscapedNewline
normAntiquotedString (Plain (DoubleQuoted strs)) =
let strs' = map normAntiquotedText strs
in if strs == strs'
then Plain (DoubleQuoted strs)
else normAntiquotedString (Plain (DoubleQuoted strs'))
normAntiquotedString r = r
normAntiquotedText :: Antiquoted Text NExpr -> Antiquoted Text NExpr
normAntiquotedText (Plain "\n") = EscapedNewline
normAntiquotedText (Plain "''\n") = EscapedNewline
normAntiquotedText r = r
normParams (ParamSet binds var (Just "")) = ParamSet binds var Nothing
normParams r = r
-- | Test that parse . pretty == id up to attribute position information.
prop_prettyparse :: NExpr -> P.Result prop_prettyparse :: NExpr -> P.Result
prop_prettyparse p = prop_prettyparse p =
case parse (pretty p) of let prog = show (pretty p)
Failure s -> P.rejected { P.reason = show s ++ show (pretty p) } in case parse (pack prog) of
Success v -> Failure s -> P.rejected
let pp = normalise (unpack (pretty p)) { P.reason = show $
pv = normalise (unpack (pretty v)) text "Parse failed:" </> text (show s)
in (P.liftBool (pp == pv)) { P.reason = "Bad parse:" ++ pp ++ pv ++ ppDiff (diff pp pv) ++ show p ++ show v} P.<$> P.indent 2 (pretty p) }
Success v
| equivUpToNormalization p v -> P.succeeded
| otherwise ->
let pp = normalise prog
pv = normalise (show (pretty v))
in (P.liftBool (pp == pv))
{ P.reason = show $
text "----------------------------------------"
P.<$> text "Expr before:" P.<$> P.indent 2 (text (PS.ppShow p))
P.<$> text "----------------------------------------"
P.<$> text "Expr after:" P.<$> P.indent 2 (text (PS.ppShow v))
P.<$> text "----------------------------------------"
P.<$> text "Pretty before:" P.<$> P.indent 2 (text prog)
P.<$> text "----------------------------------------"
P.<$> text "Pretty after:" P.<$> P.indent 2 (pretty v)
P.<$> text "----------------------------------------"
P.<$> text "Normalised before:" P.<$> P.indent 2 (text pp)
P.<$> text "----------------------------------------"
P.<$> text "Normalised after:" P.<$> P.indent 2 (text pv)
P.<$> text "========================================"
P.<$> text "Normalised diff:"
P.<$> text (ppDiff (diff pp pv))
P.<$> text "========================================"
}
where where
pretty = pack . show . prettyNix pretty = prettyNix
parse = parseNixText parse = parseNixText
normalise = unlines . map (reverse . dropWhile isSpace . reverse) . lines normalise = unlines . map (reverse . dropWhile isSpace . reverse) . lines
diff :: String -> String -> [Diff [String]] diff :: String -> String -> [Diff [String]]
diff s1 s2 = getDiff (map (:[]) (lines s1)) (map (:[]) (lines s2)) diff s1 s2 = getDiff (map (:[]) (lines s1)) (map (:[]) (lines s2))
tests :: TestTree tests :: Int -> TestTree
tests = testProperty "Pretty Parse Property" prop_prettyparse tests n = testProperty "Pretty/Parse Property" $
withMaxSuccess n prop_prettyparse