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

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
--
-- hash: 5eba5b1b4e2ae5297dcad048052e5bc02fc2f42aa37016fbea866ecbf3f4a380
-- hash: cbc369801227ccd516b691c3f08a9aae9b5ac8723619706b83703a805d570972
name: hnix
version: 0.5.0
@ -206,6 +206,7 @@ test-suite hnix-tests
, megaparsec
, mtl
, optparse-applicative
, pretty-show
, process
, quickcheck-instances
, serialise

1
package.yaml
View File

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

19
tests/Main.hs
View File

@ -11,7 +11,7 @@ import Control.Monad
import Control.Monad.IO.Class
import Data.Fix
import Data.List (isInfixOf)
import Data.Maybe (isJust)
import Data.Maybe (isJust, fromMaybe)
import Data.String.Interpolate.IsString
import Data.Text (unpack)
import Data.Time
@ -25,7 +25,7 @@ import Nix.Value
import qualified NixLanguageTests
import qualified ParserTests
import qualified PrettyTests
-- import qualified PrettyParseTests
import qualified PrettyParseTests
import System.Environment
import System.FilePath.Glob
import System.Posix.Files
@ -85,19 +85,18 @@ main = do
evalComparisonTests <- EvalTests.genEvalCompareTests
langTestsEnv <- lookupEnv "LANGUAGE_TESTS"
nixpkgsTestsEnv <- lookupEnv "NIXPKGS_TESTS"
let runLangTests = isJust langTestsEnv
let runNixpkgsTests = isJust nixpkgsTestsEnv
prettyTestsEnv <- lookupEnv "PRETTY_TESTS"
defaultMain $ testGroup "hnix" $
[ testCase "hnix.cabal correctly generated" cabalCorrectlyGenerated ] ++
[ ParserTests.tests
, EvalTests.tests
, PrettyTests.tests
-- , PrettyParseTests.tests
, evalComparisonTests ] ++
, PrettyTests.tests ] ++
[ PrettyParseTests.tests (read (fromMaybe "0" prettyTestsEnv)) ] ++
[ evalComparisonTests ] ++
[ testCase "Nix language tests present" ensureLangTestsPresent
| runLangTests ] ++
[ nixLanguageTests | runLangTests ] ++
| isJust langTestsEnv ] ++
[ nixLanguageTests | isJust langTestsEnv ] ++
[ 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 FlexibleInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS -Wno-orphans#-}
module PrettyParseTests where
import Test.Tasty.QuickCheck hiding (Success, Failure)
import Test.Tasty
import Test.QuickCheck.Instances.Text ()
import Test.QuickCheck.Instances.Semigroup ()
import Control.Monad
import Data.Algorithm.Diff
import Data.Algorithm.DiffOutput
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 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(..)
, Params(..), NKeyName(..), Antiquoted(..), Binding(..))
import Nix.Atoms
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
-- 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 = asciiText :@ Nil
@ -45,11 +49,11 @@ asciiText :: Gen Text
asciiText = pack <$> asciiString
pcustom :: GenList '[Pos]
pcustom = (arbitrary) :@ Nil
pcustom = arbitrary :@ Nil
-- | This generator generates selects one of the constructors uniformly
-- and also decreases the size of the generator by dividing by the
-- branching factor. This ensures sensible termination.
-- | This generator generates selects one of the constructors uniformly and
-- also decreases the size of the generator by dividing by the branching
-- factor. This ensures sensible termination.
genArb :: (GArbitrary (Options 'Sized '[Text]) a, GUniformWeight a) => Gen a
genArb = genericArbitraryWith (setGenerators custom sizedOpts) uniform
@ -70,13 +74,23 @@ instance Arbitrary f => Arbitrary (Binding f) where
arbitrary = genArb
instance Arbitrary f => Arbitrary (NKeyName f) where
arbitrary = genArb
arbitrary = oneof [ DynamicKey <$> arbitrary
, StaticKey <$> asciiText <*> arbitrary ]
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
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
arbitrary = genArb
@ -90,76 +104,143 @@ instance (Arbitrary f) => Arbitrary (Antiquoted Text f) where
instance (Arbitrary f) => Arbitrary (Antiquoted (NString f) f) where
arbitrary = genArb
-- This is written by hand so we can use `fairList` rather than
-- the normal list Arbitrary instance which makes the generator
-- terminate. The distribution is not scientifically chosen.
-- This is written by hand so we can use `fairList` rather than the normal
-- list Arbitrary instance which makes the generator terminate. The
-- distribution is not scientifically chosen.
instance Arbitrary f => Arbitrary (NExprF f) where
arbitrary =
sized $ \n ->
if n < 2
then oneof [nConstant, nStr, nSym, nLiteralPath, nEnvPath ]
then oneof [genConstant, genStr, genSym, genLiteralPath, genEnvPath ]
else
frequency
[ (1, nConstant)
, (1, nSym)
, (4, resize (n `div` 3) nIf)
, (10, nRecSet )
, (20, nSet )
, (5, nList )
, (2, nUnary )
, (2, resize (n `div` 3) nBinary )
, (3, resize (n `div` 3) nSelect )
, (20, resize (n `div` 2) nAbs )
, (2, resize (n `div` 2) nHasAttr )
, (10, resize (n `div` 2) nLet )
, (10, resize (n `div` 2) nWith )
, (1, resize (n `div` 2) nAssert)
[ ( 1, genConstant)
, ( 1, genSym)
, ( 4, resize (n `div` 3) genIf)
, (10, genRecSet )
, (20, genSet )
, ( 5, genList )
, ( 2, genUnary )
, ( 2, resize (n `div` 3) genBinary )
, ( 3, resize (n `div` 3) genSelect )
, (20, resize (n `div` 2) genAbs )
, ( 2, resize (n `div` 2) genHasAttr )
, (10, resize (n `div` 2) genLet )
, (10, resize (n `div` 2) genWith )
, ( 1, resize (n `div` 2) genAssert)
]
where
nConstant = NConstant <$> arbitrary
nStr = NStr <$> arbitrary
nSym = NSym <$> asciiText
nList = NList <$> fairList arbitrary
nSet = NSet <$> fairList arbitrary
nRecSet = NRecSet <$> fairList arbitrary
nLiteralPath = NLiteralPath <$> asciiString
nEnvPath = NEnvPath <$> asciiString
nUnary = NUnary <$> arbitrary <*> arbitrary
nBinary = NBinary <$> arbitrary <*> arbitrary <*> arbitrary
nSelect = NSelect <$> arbitrary <*> arbitrary <*> arbitrary
nHasAttr = NHasAttr <$> arbitrary <*> arbitrary
nAbs = NAbs <$> arbitrary <*> arbitrary
nLet = NLet <$> arbitrary <*> arbitrary
nIf = NIf <$> arbitrary <*> arbitrary <*> arbitrary
nWith = NWith <$> arbitrary <*> arbitrary
nAssert = NAssert <$> arbitrary <*> arbitrary
genConstant = NConstant <$> arbitrary
genStr = NStr <$> arbitrary
genSym = NSym <$> asciiText
genList = NList <$> fairList arbitrary
genSet = NSet <$> fairList arbitrary
genRecSet = NRecSet <$> fairList arbitrary
genLiteralPath = NLiteralPath . ("./" ++) <$> asciiString
genEnvPath = NEnvPath <$> asciiString
genUnary = NUnary <$> arbitrary <*> arbitrary
genBinary = NBinary <$> arbitrary <*> arbitrary <*> arbitrary
genSelect = NSelect <$> arbitrary <*> arbitrary <*> arbitrary
genHasAttr = NHasAttr <$> arbitrary <*> arbitrary
genAbs = NAbs <$> arbitrary <*> arbitrary
genLet = NLet <$> fairList arbitrary <*> arbitrary
genIf = NIf <$> arbitrary <*> arbitrary <*> arbitrary
genWith = NWith <$> arbitrary <*> arbitrary
genAssert = NAssert <$> arbitrary <*> arbitrary
-- | Useful when there are recursive positions at each element of the list
-- as it divides the size by the length of the generated list.
-- | Useful when there are recursive positions at each element of the list as
-- it divides the size by the length of the generated list.
fairList :: Gen a -> Gen [a]
fairList g = do
s <- getSize
k <- choose (0, s)
-- 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 p =
case parse (pretty p) of
Failure s -> P.rejected { P.reason = show s ++ show (pretty p) }
Success v ->
let pp = normalise (unpack (pretty p))
pv = normalise (unpack (pretty v))
in (P.liftBool (pp == pv)) { P.reason = "Bad parse:" ++ pp ++ pv ++ ppDiff (diff pp pv) ++ show p ++ show v}
let prog = show (pretty p)
in case parse (pack prog) of
Failure s -> P.rejected
{ P.reason = show $
text "Parse failed:" </> text (show s)
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
pretty = pack . show . prettyNix
parse = parseNixText
pretty = prettyNix
parse = parseNixText
normalise = unlines . map (reverse . dropWhile isSpace . reverse) . lines
diff :: String -> String -> [Diff [String]]
diff s1 s2 = getDiff (map (:[]) (lines s1)) (map (:[]) (lines s2))
diff :: String -> String -> [Diff [String]]
diff s1 s2 = getDiff (map (:[]) (lines s1)) (map (:[]) (lines s2))
tests :: TestTree
tests = testProperty "Pretty Parse Property" prop_prettyparse
tests :: Int -> TestTree
tests n = testProperty "Pretty/Parse Property" $
withMaxSuccess n prop_prettyparse