Merge pull request #229 from mpickering/quickcheck-expr
Add QuickCheck test for pretty printer and parser
This commit is contained in:
commit
b886e5825e
11
hnix.cabal
11
hnix.cabal
|
@ -2,7 +2,7 @@
|
|||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: b50a1c4cf11872cb711f0ed200482f16620ea7754fe7bf8cf8892413d0231746
|
||||
-- hash: ee27a667ebb4b2c1f121147d9491a677c0d0979c0d6547120ded75758329207a
|
||||
|
||||
name: hnix
|
||||
version: 0.5.0
|
||||
|
@ -176,6 +176,7 @@ test-suite hnix-tests
|
|||
EvalTests
|
||||
NixLanguageTests
|
||||
ParserTests
|
||||
PrettyParseTests
|
||||
PrettyTests
|
||||
TestCommon
|
||||
Paths_hnix
|
||||
|
@ -183,7 +184,9 @@ test-suite hnix-tests
|
|||
tests
|
||||
ghc-options: -Wall -threaded
|
||||
build-depends:
|
||||
Glob
|
||||
Diff
|
||||
, Glob
|
||||
, QuickCheck
|
||||
, ansi-wl-pprint
|
||||
, base >=4.9 && <5
|
||||
, bytestring
|
||||
|
@ -194,15 +197,19 @@ test-suite hnix-tests
|
|||
, directory
|
||||
, exceptions
|
||||
, filepath
|
||||
, generic-random
|
||||
, hnix
|
||||
, interpolate
|
||||
, megaparsec
|
||||
, mtl
|
||||
, optparse-applicative
|
||||
, process
|
||||
, quickcheck-instances
|
||||
, serialise
|
||||
, split
|
||||
, tasty
|
||||
, tasty-hunit
|
||||
, tasty-quickcheck
|
||||
, tasty-th
|
||||
, template-haskell
|
||||
, text
|
||||
|
|
|
@ -125,6 +125,12 @@ tests:
|
|||
- tasty-hunit
|
||||
- tasty-th
|
||||
- unix
|
||||
- QuickCheck
|
||||
- quickcheck-instances
|
||||
- generic-random
|
||||
- Diff
|
||||
- megaparsec
|
||||
- tasty-quickcheck
|
||||
|
||||
benchmarks:
|
||||
hnix-benchmarks:
|
||||
|
|
|
@ -49,13 +49,21 @@ data NixDoc = NixDoc
|
|||
-- operator. It is needed to determine if we need to wrap the expression in
|
||||
-- parentheses.
|
||||
, rootOp :: OperatorInfo
|
||||
, wasPath :: Bool -- This is needed so that when a path is used in a selector path
|
||||
-- we can add brackets appropiately
|
||||
}
|
||||
|
||||
mkNixDoc :: Doc -> OperatorInfo -> NixDoc
|
||||
mkNixDoc d o = NixDoc { withoutParens = d, rootOp = o, wasPath = False }
|
||||
|
||||
-- | A simple expression is never wrapped in parentheses. The expression
|
||||
-- behaves as if its root operator had a precedence higher than all
|
||||
-- other operators (including function application).
|
||||
simpleExpr :: Doc -> NixDoc
|
||||
simpleExpr = flip NixDoc $ OperatorInfo minBound NAssocNone "simple expr"
|
||||
simpleExpr d = mkNixDoc d (OperatorInfo minBound NAssocNone "simple expr")
|
||||
|
||||
pathExpr :: Doc -> NixDoc
|
||||
pathExpr d = (simpleExpr d) { wasPath = True }
|
||||
|
||||
-- | An expression that behaves as if its root operator had a precedence lower
|
||||
-- than all other operators. That ensures that the expression is wrapped in
|
||||
|
@ -64,7 +72,7 @@ simpleExpr = flip NixDoc $ OperatorInfo minBound NAssocNone "simple expr"
|
|||
-- binding).
|
||||
leastPrecedence :: Doc -> NixDoc
|
||||
leastPrecedence =
|
||||
flip NixDoc $ OperatorInfo maxBound NAssocNone "least precedence"
|
||||
flip mkNixDoc $ OperatorInfo maxBound NAssocNone "least precedence"
|
||||
|
||||
appOp :: OperatorInfo
|
||||
appOp = getBinaryOperator NApp
|
||||
|
@ -86,10 +94,17 @@ wrapParens op sub
|
|||
&& associativity op /= NAssocNone = withoutParens sub
|
||||
| otherwise = parens $ withoutParens sub
|
||||
|
||||
-- Used in the selector case to print a path in a selector as
|
||||
-- "${./abc}"
|
||||
wrapPath :: OperatorInfo -> NixDoc -> Doc
|
||||
wrapPath op sub =
|
||||
if wasPath sub then dquotes (text "$" <> braces (withoutParens sub))
|
||||
else wrapParens op sub
|
||||
|
||||
prettyString :: NString NixDoc -> Doc
|
||||
prettyString (DoubleQuoted parts) = dquotes . hcat . map prettyPart $ parts
|
||||
where prettyPart (Plain t) = text . concatMap escape . unpack $ t
|
||||
prettyPart EscapedNewline = text "\n"
|
||||
prettyPart EscapedNewline = text "''\\n"
|
||||
prettyPart (Antiquoted r) = text "$" <> braces (withoutParens r)
|
||||
escape '"' = "\\\""
|
||||
escape x = maybe [x] (('\\':) . (:[])) $ toEscapeCode x
|
||||
|
@ -102,7 +117,7 @@ prettyString (Indented _ parts)
|
|||
f xs = xs
|
||||
prettyLine = hcat . map prettyPart
|
||||
prettyPart (Plain t) = text . unpack . replace "${" "''${" . replace "''" "'''" $ t
|
||||
prettyPart EscapedNewline = text "\n"
|
||||
prettyPart EscapedNewline = text "\\n"
|
||||
prettyPart (Antiquoted r) = text "$" <> braces (withoutParens r)
|
||||
|
||||
prettyParams :: Params NixDoc -> Doc
|
||||
|
@ -174,8 +189,8 @@ exprFNixDoc = \case
|
|||
NAbs args body -> leastPrecedence $
|
||||
nest 2 ((prettyParams args <> colon) <$> withoutParens body)
|
||||
NBinary NApp fun arg ->
|
||||
NixDoc (wrapParens appOp fun <+> wrapParens appOpNonAssoc arg) appOp
|
||||
NBinary op r1 r2 -> flip NixDoc opInfo $ hsep
|
||||
mkNixDoc (wrapParens appOp fun <+> wrapParens appOpNonAssoc arg) appOp
|
||||
NBinary op r1 r2 -> flip mkNixDoc opInfo $ hsep
|
||||
[ wrapParens (f NAssocLeft) r1
|
||||
, text $ unpack $ operatorName opInfo
|
||||
, wrapParens (f NAssocRight) r2
|
||||
|
@ -185,16 +200,16 @@ exprFNixDoc = \case
|
|||
f x | associativity opInfo /= x = opInfo { associativity = NAssocNone }
|
||||
| otherwise = opInfo
|
||||
NUnary op r1 ->
|
||||
NixDoc (text (unpack (operatorName opInfo)) <> wrapParens opInfo r1) opInfo
|
||||
mkNixDoc (text (unpack (operatorName opInfo)) <> wrapParens opInfo r1) opInfo
|
||||
where opInfo = getUnaryOperator op
|
||||
NSelect r attr o ->
|
||||
(if isJust o then leastPrecedence else flip NixDoc selectOp) $
|
||||
wrapParens selectOp r <> dot <> prettySelector attr <> ordoc
|
||||
(if isJust o then leastPrecedence else flip mkNixDoc selectOp) $
|
||||
wrapPath selectOp r <> dot <> prettySelector attr <> ordoc
|
||||
where ordoc = maybe empty (((space <> text "or") <+>) . wrapParens selectOp) o
|
||||
NHasAttr r attr ->
|
||||
NixDoc (wrapParens hasAttrOp r <+> text "?" <+> prettySelector attr) hasAttrOp
|
||||
mkNixDoc (wrapParens hasAttrOp r <+> text "?" <+> prettySelector attr) hasAttrOp
|
||||
NEnvPath p -> simpleExpr $ text ("<" ++ p ++ ">")
|
||||
NLiteralPath p -> simpleExpr $ text $ case p of
|
||||
NLiteralPath p -> pathExpr $ text $ case p of
|
||||
"./" -> "./."
|
||||
"../" -> "../."
|
||||
".." -> "../."
|
||||
|
|
|
@ -25,6 +25,7 @@ import Nix.Value
|
|||
import qualified NixLanguageTests
|
||||
import qualified ParserTests
|
||||
import qualified PrettyTests
|
||||
import qualified PrettyParseTests
|
||||
import System.Environment
|
||||
import System.FilePath.Glob
|
||||
import System.Posix.Files
|
||||
|
@ -92,9 +93,11 @@ main = do
|
|||
[ ParserTests.tests
|
||||
, EvalTests.tests
|
||||
, PrettyTests.tests
|
||||
, PrettyParseTests.tests
|
||||
, evalComparisonTests ] ++
|
||||
[ testCase "Nix language tests present" ensureLangTestsPresent
|
||||
| runLangTests ] ++
|
||||
[ nixLanguageTests | runLangTests ] ++
|
||||
[ testCase "Nixpkgs parses without errors" ensureNixpkgsCanParse
|
||||
| runNixpkgsTests ]
|
||||
|
||||
|
|
165
tests/PrettyParseTests.hs
Normal file
165
tests/PrettyParseTests.hs
Normal file
|
@ -0,0 +1,165 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE NoMonomorphismRestriction #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MonoLocalBinds #-}
|
||||
{-# 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 qualified Test.QuickCheck.Property as P
|
||||
|
||||
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
|
||||
custom :: GenList '[Text]
|
||||
custom = asciiText :@ Nil
|
||||
|
||||
asciiString :: Gen String
|
||||
asciiString = do
|
||||
n <- choose (1, 15)
|
||||
replicateM n (elements ['a'..'z'])
|
||||
|
||||
asciiText :: Gen Text
|
||||
asciiText = pack <$> asciiString
|
||||
|
||||
pcustom :: GenList '[Pos]
|
||||
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.
|
||||
genArb :: (GArbitrary (Options 'Sized '[Text]) a, GUniformWeight a) => Gen a
|
||||
genArb = genericArbitraryWith (setGenerators custom sizedOpts) uniform
|
||||
|
||||
-- Might want to replace this instance with a constant value
|
||||
instance Arbitrary Pos where
|
||||
arbitrary = mkPos <$> (getSmall <$> arbitrary `suchThat` (> 0))
|
||||
|
||||
instance Arbitrary (f (Fix f)) => Arbitrary (Fix f) where
|
||||
arbitrary = genArb
|
||||
|
||||
instance Arbitrary f => Arbitrary (NString f) where
|
||||
arbitrary = genArb
|
||||
|
||||
instance Arbitrary SourcePos where
|
||||
arbitrary = genericArbitraryWith (setGenerators pcustom sizedOpts) uniform
|
||||
|
||||
instance Arbitrary f => Arbitrary (Binding f) where
|
||||
arbitrary = genArb
|
||||
|
||||
instance Arbitrary f => Arbitrary (NKeyName f) where
|
||||
arbitrary = genArb
|
||||
|
||||
instance Arbitrary f => Arbitrary (Params f) where
|
||||
arbitrary = genArb
|
||||
|
||||
instance Arbitrary NAtom where
|
||||
arbitrary = genArb
|
||||
|
||||
instance Arbitrary NUnaryOp where
|
||||
arbitrary = genArb
|
||||
|
||||
instance Arbitrary NBinaryOp where
|
||||
arbitrary = genArb
|
||||
|
||||
instance (Arbitrary f) => Arbitrary (Antiquoted Text f) where
|
||||
arbitrary = genArb
|
||||
|
||||
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.
|
||||
instance Arbitrary f => Arbitrary (NExprF f) where
|
||||
arbitrary =
|
||||
sized $ \n ->
|
||||
if n < 2
|
||||
then oneof [nConstant, nStr, nSym, nLiteralPath, nEnvPath ]
|
||||
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)
|
||||
]
|
||||
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
|
||||
|
||||
-- | 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
|
||||
|
||||
-- | Test that pretty . parse . pretty == pretty
|
||||
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}
|
||||
where
|
||||
pretty = pack . show . 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))
|
||||
|
||||
tests :: TestTree
|
||||
tests = testProperty "Pretty Parse Property" prop_prettyparse
|
Loading…
Reference in a new issue