From 892552d4e7177da1135a157624363a8d5107c623 Mon Sep 17 00:00:00 2001 From: Niki Vazou Date: Fri, 26 Feb 2021 14:46:00 +0100 Subject: [PATCH 1/7] Update Resolve.hs --- src/Language/Haskell/Liquid/Bare/Resolve.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Language/Haskell/Liquid/Bare/Resolve.hs b/src/Language/Haskell/Liquid/Bare/Resolve.hs index dbbae152a5..0836d856f5 100644 --- a/src/Language/Haskell/Liquid/Bare/Resolve.hs +++ b/src/Language/Haskell/Liquid/Bare/Resolve.hs @@ -898,7 +898,11 @@ matchTyCon :: Env -> ModName -> LocSymbol -> Int -> Either UserError Ghc.TyCon matchTyCon env name lc@(Loc _ _ c) arity | isList c && arity == 1 = Right Ghc.listTyCon | isTuple c = Right tuplTc - | otherwise = resolveLocSym env name msg lc + | otherwise = case resolveLocSym env name msg lc of + Right c -> Right c + no -> case resolveLocSym env name msg lc of + Right t -> Right (Ghc.promoteDataCon t) + _ -> no where msg = "matchTyCon: " ++ F.showpp c tuplTc = Ghc.tupleTyCon Ghc.Boxed arity From dca2ed633f2f57e6ea2f0d319a2549716a3cc019 Mon Sep 17 00:00:00 2001 From: Niki Vazou Date: Wed, 3 Mar 2021 14:15:39 +0100 Subject: [PATCH 2/7] change order fields of golden --- tests/golden/json_output.golden | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/golden/json_output.golden b/tests/golden/json_output.golden index 46024b93ac..04718a9000 100644 --- a/tests/golden/json_output.golden +++ b/tests/golden/json_output.golden @@ -1,2 +1,2 @@ LIQUID -[{"start":{"line":9,"column":1},"stop":{"line":9,"column":12},"message":"Type Mismatch\n .\n The inferred type\n VV : {v : GHC.Types.Int | v == 7}\n .\n is not a subtype of the required type\n VV : {VV : GHC.Types.Int | VV mod 2 == 0}\n ."}] +["message":"Type Mismatch\n .\n The inferred type\n VV : {v : GHC.Types.Int | v == 7}\n .\n is not a subtype of the required type\n VV : {VV : GHC.Types.Int | VV mod 2 == 0}\n ."},{"start":{"column":1,"line":9},"stop":{"column":12,"line":9}] From 9493b66517586e15b17002b60955e64090c3aaf1 Mon Sep 17 00:00:00 2001 From: Niki Vazou Date: Thu, 4 Mar 2021 11:34:16 +0100 Subject: [PATCH 3/7] json play --- liquidhaskell.cabal | 1 + tests/test.hs | 24 ++++++++++++++++-------- 2 files changed, 17 insertions(+), 8 deletions(-) diff --git a/liquidhaskell.cabal b/liquidhaskell.cabal index dca82555b9..3e2189660d 100644 --- a/liquidhaskell.cabal +++ b/liquidhaskell.cabal @@ -282,6 +282,7 @@ test-suite test hs-source-dirs: tests build-depends: base >= 4.8.1.0 && < 5 , containers >= 0.5 + , aeson , directory >= 1.2 , filepath >= 1.3 , mtl >= 2.1 diff --git a/tests/test.hs b/tests/test.hs index b98dc1717c..9ae8210130 100644 --- a/tests/test.hs +++ b/tests/test.hs @@ -39,13 +39,15 @@ import System.IO import System.IO.Error import System.Process import Test.Tasty -import Test.Tasty.Golden +import Test.Tasty.Golden.Advanced import Test.Tasty.HUnit + ( testCase, assertBool, assertEqual, Assertion ) import Test.Tasty.Ingredients.Rerun import Test.Tasty.Options import Test.Tasty.Runners import Test.Tasty.Runners.AntXML import Paths_liquidhaskell +import Data.Aeson (toJSON) import Text.Printf @@ -257,18 +259,24 @@ macroTests = group "Macro" goldenTests :: IO TestTree goldenTests = group "Golden tests" - [ pure $ goldenTest "--json output" "tests/golden" "json_output" [LO "--json"] + [ pure $ goldenTest' "--json output" "tests/golden" "json_output" [LO "--json"] ] -goldenTest :: TestName -> FilePath -> FilePath -> [LiquidOpts] -> TestTree -goldenTest testName dir filePrefix testOpts = +goldenTest' :: TestName -> FilePath -> FilePath -> [LiquidOpts] -> TestTree +goldenTest' testName dir filePrefix testOpts = askOption $ \(smt :: SmtSolver) -> askOption $ \(opts :: LiquidOpts) -> askOption $ \(bin :: LiquidRunner) -> - goldenVsString testName - (dir filePrefix <> ".golden") - (toS . snd <$> runLiquidOn smt (mconcat testOpts <> opts) bin dir (filePrefix <> ".hs")) - + goldenTest testName + (readFile (toS . snd <$> runLiquidOn smt (mconcat testOpts <> opts) bin dir (filePrefix <> ".hs"))) + (dir filePrefix <> ".golden") + cmp + (\_ -> return ()) + where + cmp x y = if toJSON x == toJSON y + then return Nothing + else return $ Just ("Test output was different from" ++ x ++ "It was:\n" ++ y) + microTests :: IO TestTree microTests = group "Micro" From 95f1e1bf1f4e0751dc87f391beba0fc04f5d30b1 Mon Sep 17 00:00:00 2001 From: Niki Vazou Date: Fri, 5 Mar 2021 11:28:00 +0100 Subject: [PATCH 4/7] keep playin with json --- tests/test.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/test.hs b/tests/test.hs index 9ae8210130..4795719391 100644 --- a/tests/test.hs +++ b/tests/test.hs @@ -84,7 +84,7 @@ main = do unsetEnv "LIQUIDHASKELL_OPTS" proverTests : goldenTests : benchTests : - [] + [] -- [goldenTests] -- tests = group "Tests" [ unitTests ] @@ -268,8 +268,8 @@ goldenTest' testName dir filePrefix testOpts = askOption $ \(opts :: LiquidOpts) -> askOption $ \(bin :: LiquidRunner) -> goldenTest testName - (readFile (toS . snd <$> runLiquidOn smt (mconcat testOpts <> opts) bin dir (filePrefix <> ".hs"))) - (dir filePrefix <> ".golden") + (toS . snd <$> runLiquidOn smt (mconcat testOpts <> opts) bin dir (filePrefix <> ".hs")) + (readFile (dir filePrefix <> ".golden")) cmp (\_ -> return ()) where From 59fc962dd13ad28171057a420f118cefbd34f86f Mon Sep 17 00:00:00 2001 From: Niki Vazou Date: Fri, 5 Mar 2021 14:18:20 +0100 Subject: [PATCH 5/7] keep playing with jsonn cmp --- liquidhaskell.cabal | 2 ++ tests/test.hs | 43 ++++++++++++++++++++++++++++++++++++------- 2 files changed, 38 insertions(+), 7 deletions(-) diff --git a/liquidhaskell.cabal b/liquidhaskell.cabal index 3e2189660d..3a5723a5e8 100644 --- a/liquidhaskell.cabal +++ b/liquidhaskell.cabal @@ -298,6 +298,8 @@ test-suite test , tasty-rerun >= 1.1 , text , transformers >= 0.3 + , unordered-containers + , vector default-language: Haskell98 ghc-options: -W -threaded if !flag(no-plugin) diff --git a/tests/test.hs b/tests/test.hs index 4795719391..4052ed8c10 100644 --- a/tests/test.hs +++ b/tests/test.hs @@ -6,7 +6,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} - +{-# LANGUAGE FlexibleInstances #-} module Main where import Data.Function (on) @@ -20,7 +20,8 @@ import qualified Data.Functor.Compose as Functor import qualified Data.IntMap as IntMap import qualified Data.Map as Map import qualified Data.List as L -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust) +import Data.List (find) import Data.Monoid (Sum(..)) import Data.Proxy import Data.String @@ -47,9 +48,10 @@ import Test.Tasty.Options import Test.Tasty.Runners import Test.Tasty.Runners.AntXML import Paths_liquidhaskell -import Data.Aeson (toJSON) - -import Text.Printf +import qualified Data.Aeson as JS +import qualified Data.HashMap.Strict as H +import qualified Data.Vector as V +import Text.Printf @@ -273,10 +275,37 @@ goldenTest' testName dir filePrefix testOpts = cmp (\_ -> return ()) where - cmp x y = if toJSON x == toJSON y + cmp x y = if JS.toJSON x === JS.toJSON y then return Nothing else return $ Just ("Test output was different from" ++ x ++ "It was:\n" ++ y) - + +class JEq a where + (===) :: a -> a -> Bool + +instance JEq JS.Value where + JS.Null === JS.Null = True + JS.Bool b1 === JS.Bool b2 = b1 == b2 + JS.Number n1 === JS.Number n2 = n1 == n2 + JS.String s1 === JS.String s2 = s1 == s2 + JS.Array a1 === JS.Array a2 = a1 === a2 + JS.Object o1 === JS.Object o2 = o1 === o2 + _ === _ = False + +instance JEq a => JEq (H.HashMap T.Text a) where + m1 === m2 = let l1 = H.toList m1 + l2 = H.toList m2 + in length l1 == length l2 && all (\(k,v) -> + case H.lookup k m2 of + Nothing -> False + Just v2 -> v === v2 + ) l1 + +instance JEq a => JEq (V.Vector a) where + v1 === v2 = V.toList v1 === V.toList v2 + +instance JEq a => JEq [a] where + l1 === l2 = length l1 == length l2 && all (\v1 -> isJust (find (===v1) l2)) l1 + microTests :: IO TestTree microTests = group "Micro" From 3c2a3e1b95021e145b46699899a43c9f066e2dcd Mon Sep 17 00:00:00 2001 From: Niki Vazou Date: Sat, 6 Mar 2021 11:13:00 +0100 Subject: [PATCH 6/7] fix brackets --- tests/golden/json_output.golden | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/golden/json_output.golden b/tests/golden/json_output.golden index 04718a9000..978b0d8c03 100644 --- a/tests/golden/json_output.golden +++ b/tests/golden/json_output.golden @@ -1,2 +1,2 @@ LIQUID -["message":"Type Mismatch\n .\n The inferred type\n VV : {v : GHC.Types.Int | v == 7}\n .\n is not a subtype of the required type\n VV : {VV : GHC.Types.Int | VV mod 2 == 0}\n ."},{"start":{"column":1,"line":9},"stop":{"column":12,"line":9}] +[{"message":"Type Mismatch\n .\n The inferred type\n VV : {v : GHC.Types.Int | v == 7}\n .\n is not a subtype of the required type\n VV : {VV : GHC.Types.Int | VV mod 2 == 0}\n ."},{"start":{"column":1,"line":9},"stop":{"column":12,"line":9}}] From e6f839b483a0af9d69015341ff047c6a73d2eeba Mon Sep 17 00:00:00 2001 From: Niki Vazou Date: Sat, 6 Mar 2021 12:37:49 +0100 Subject: [PATCH 7/7] update message --- tests/golden/json_output.golden | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/golden/json_output.golden b/tests/golden/json_output.golden index 978b0d8c03..b97233a9cf 100644 --- a/tests/golden/json_output.golden +++ b/tests/golden/json_output.golden @@ -1,2 +1,2 @@ LIQUID -[{"message":"Type Mismatch\n .\n The inferred type\n VV : {v : GHC.Types.Int | v == 7}\n .\n is not a subtype of the required type\n VV : {VV : GHC.Types.Int | VV mod 2 == 0}\n ."},{"start":{"column":1,"line":9},"stop":{"column":12,"line":9}}] +[{"start":{"line":9,"column":1},"stop":{"line":9,"column":12},"message":"Type Mismatch\n .\n The inferred type\n VV : {v : GHC.Types.Int | v == 7}\n .\n is not a subtype of the required type\n VV : {VV : GHC.Types.Int | VV mod 2 == 0}\n ."}] \ No newline at end of file