Tests

extensible-data.cabal

@@ -123,3 +123,26 @@ executable lam
   hs-source-dirs: examples/lam
   main-is: Lam.hs
   other-modules: LamBase, Typed, DeBruijn
+
+
+test-suite test-extensible-data
+  import: deps
+  type: exitcode-stdio-1.0
+  hs-source-dirs: test
+  main-is: tests.hs
+  other-modules:
+    Rerename, TestRerename
+  build-depends:
+    extensible-data,
+    containers  ^>= 0.6.2.1,
+    mtl         ^>= 2.2.2,
+    tasty       ^>= 1.3.1,
+    tasty-hunit ^>= 0.10.0.2
+  default-extensions:
+    TemplateHaskell, TypeFamilies, PatternSynonyms, ConstraintKinds,
+    StandaloneDeriving, FlexibleContexts, UndecidableInstances
+  ghc-options:
+    -Wno-unused-top-binds
+    -Wno-missing-pattern-synonym-signatures
+    -Wno-unused-imports
+    -Werror=incomplete-patterns

test/Rerename.hs

@@ -0,0 +1,73 @@
+{-# LANGUAGE LambdaCase, RecordWildCards #-}
+module Rerename
+  (rerename, rerename', eqTH, neqTH, assertEqTH, assertNeqTH, assertEqTHSelf)
+where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+import Generics.SYB
+import Control.Monad.State
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Test.Tasty.HUnit
+
+
+type Rerename = MonadState RerenameState
+
+data RerenameState =
+  RS { nameMap :: Map Name Name, lastIndex :: Map OccName Int }
+
+-- | Replaces the name suffixes from 'newName' or TH quotes in a deterministic
+-- way.
+--
+-- The name bases are still kept so this doesn't make e.g.
+-- @\\x -> x@ and @\\y -> y@ equal! But the result of two different instances
+-- of @'newName' \"a\"@ or @[|\\x -> x|]@ will be.
+rerename :: Data a => a -> a
+rerename x = evalState (rerename' x) (RS Map.empty Map.empty)
+
+rerename' :: (Data a, Rerename m) => a -> m a
+rerename' = everywhereM $ mkM rerename1
+
+rerename1 :: Rerename m => Name -> m Name
+rerename1 n@(Name b (NameU _)) = do -- from newName or [|...|]
+  RS {..} <- get
+  case Map.lookup n nameMap of
+    Just n' -> pure n'
+    Nothing -> do
+      case Map.lookup b lastIndex of
+        Just i -> do
+          let n' = mkName $ occString b ++ show i
+          modify $ \r -> r {nameMap = Map.insert n n' nameMap}
+          pure n'
+        Nothing -> do
+          let n' = mkName $ occString b
+          put $ RS {nameMap   = Map.insert n n' nameMap,
+                    lastIndex = Map.insert b 0 lastIndex}
+          pure n'
+rerename1 n = pure n
+
+infix 4 `eqTH`, `neqTH`  -- same as ==, /=
+eqTH, neqTH :: (Eq a, Data a) => a -> a -> Bool
+x  `eqTH` y = rerename x == rerename y
+x `neqTH` y = not $ x `eqTH` y
+
+assertEqTHSelf :: (Data a, Eq a, Ppr a) => Q a -> Assertion
+assertEqTHSelf x = assertEqTH x x
+
+assertEqTH, assertNeqTH :: (Eq a, Data a, Ppr a)
+                        => Q a -> Q a -> Assertion
+assertEqTH  = assertEqTH' "expected" "but got" eqTH
+assertNeqTH = assertEqTH' "first"    "second"  neqTH
+
+assertEqTH' :: Ppr a
+            => String -> String -> (a -> a -> Bool)
+            -> Q a -> Q a -> Assertion
+assertEqTH' mx my p qx qy = do
+  x <- runQ qx; y <- runQ qy
+  let msg = mx ++ ":\n" ++ indent (pprint x) ++ "\n" ++
+            my ++ ":\n" ++ indent (pprint y)
+  assertBool msg (x `p` y)
+
+indent :: String -> String
+indent = concatMap $ \case '\n' -> "\n    "; c -> [c]

test/TestRerename.hs

@@ -0,0 +1,40 @@
+{-# OPTIONS_GHC -Wno-name-shadowing -Wno-unused-matches #-}
+{-# LANGUAGE RankNTypes #-}
+module TestRerename (tests) where
+
+import Rerename
+import Language.Haskell.TH
+import Test.Tasty
+import Test.Tasty.HUnit
+
+tests :: TestTree
+tests = testGroup "Rerename" $
+  [testCase "newName \"x\"" $ assertEqTHSelf $ newName "x",
+   testCase "two (newName \"x\")s" $
+     assertEqTHSelf $
+       [|($(VarE <$> newName "x"), $(VarE <$> newName "x"))|],
+   testCase "11" $ assertEqTHSelf [|11|],
+   testCase "Nothing" $ assertEqTHSelf [|Nothing|],
+   testCase "id" $ assertEqTHSelf [|id|],
+   testCase "\\x -> x" $ assertEqTHSelf [|\x -> x|],
+   testCase "\\x -> x ≠ \\y -> y" $
+     assertNeqTH [|\x -> x|] [|\y -> y|],
+   testCase "\\x -> \\x -> x" $
+     assertEqTHSelf [|\x -> \x -> x|],
+
+   testCase "x [pattern]" $ assertEqTHSelf [p|x|],
+   testCase "Just (x, y) [pattern]" $ assertEqTHSelf [p|Just (x, y)|],
+
+   testCase "Either" $ assertEqTHSelf [t|Either|],
+   testCase "forall a b. Either a b" $
+     assertEqTHSelf [t|forall a b. Either a b|],
+
+   testCase "f x y = (y, x, x)" $
+     assertEqTHSelf [d|f x y = (y, x, x)|],
+   testCase "id2 :: a -> a; id2 x = x" $
+     -- can't have just a type signature by itself :(
+     assertEqTHSelf [d|id2 :: a -> a; id2 x = x|],
+
+   testCase "data Pair a b = Pair a b deriving Eq" $ do
+     assertEqTHSelf [d|data Pair a b = Pair a b deriving Eq|]
+  ]

test/tests.hs

@@ -0,0 +1,8 @@
+module Main (main) where
+
+import Test.Tasty
+import qualified TestRerename
+
+main :: IO ()
+main = defaultMain $ testGroup "Tests" $
+  [TestRerename.tests]