diff --git a/liquidhaskell.cabal b/liquidhaskell.cabal index dca82555b9..3a5723a5e8 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 @@ -297,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/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 diff --git a/tests/golden/json_output.golden b/tests/golden/json_output.golden index 46024b93ac..b97233a9cf 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 ."}] +[{"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 diff --git a/tests/test.hs b/tests/test.hs index b98dc1717c..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 @@ -39,15 +40,18 @@ 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 Text.Printf +import qualified Data.Aeson as JS +import qualified Data.HashMap.Strict as H +import qualified Data.Vector as V +import Text.Printf @@ -82,7 +86,7 @@ main = do unsetEnv "LIQUIDHASKELL_OPTS" proverTests : goldenTests : benchTests : - [] + [] -- [goldenTests] -- tests = group "Tests" [ unitTests ] @@ -257,17 +261,50 @@ 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") + goldenTest testName (toS . snd <$> runLiquidOn smt (mconcat testOpts <> opts) bin dir (filePrefix <> ".hs")) + (readFile (dir filePrefix <> ".golden")) + cmp + (\_ -> return ()) + where + 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