Add QuickCheck test for pretty printer and parser

I have not spent any time optimising the generated programs but they do
not look totally unreasonable from a cursory inspection.

Fixes #158

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

package.yaml

@@ -125,6 +125,12 @@ tests:
       - tasty-hunit
       - tasty-th
       - unix
+      - QuickCheck
+      - quickcheck-instances
+      - generic-random
+      - Diff
+      - megaparsec
+      - tasty-quickcheck
 
 benchmarks:
   hnix-benchmarks:

tests/Main.hs

@@ -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 ]
+

tests/PrettyParseTests.hs

@@ -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