diff --git a/extensible-data.cabal b/extensible-data.cabal index a1a3fb2..0857314 100644 --- a/extensible-data.cabal +++ b/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 diff --git a/test/Rerename.hs b/test/Rerename.hs new file mode 100644 index 0000000..5338aa9 --- /dev/null +++ b/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] diff --git a/test/TestRerename.hs b/test/TestRerename.hs new file mode 100644 index 0000000..78bd4c8 --- /dev/null +++ b/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|] + ] diff --git a/test/tests.hs b/test/tests.hs new file mode 100644 index 0000000..b44eaeb --- /dev/null +++ b/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]