Promote DataCon in matchTyCon

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)

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 

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    ."}]

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