Fixing bugs in type family application

- when the type constructor showed up on the rhs it could lead to loops,
so it is checked before just applying the rhs

.gitignore

@@ -48,4 +48,5 @@ hsreduce_timing.csv
 hsreduce_statistics.csv
 hsreduce_performance.csv
 Bug.stale.hs
-*.hs.stale_state
+*.hs.stale_state
+hsreduce.log

default.nix

@@ -1,9 +1,10 @@
 { mkDerivation, aeson, base, bytestring, Cabal, cassava, containers
 , Diff, edit-distance, ghc, ghc-boot-th, ghc-exactprint, ghc-paths
-, hashable, hie-bios, hspec, katip, lifted-async, lifted-base
-, megaparsec, microlens-platform, monad-control, MonadRandom, mtl
-, optparse-generic, path, path-io, process, regex, split, stdenv
-, stm-lifted, syb, text, time, transformers-base, uniplate, word8
+, hashable, hie-bios, hspec, HUnit, katip, lifted-async
+, lifted-base, megaparsec, microlens-platform, monad-control
+, MonadRandom, mtl, optparse-generic, path, path-io, process, regex
+, split, stdenv, stm-lifted, syb, text, time, transformers-base
+, uniplate, word8
 }:
 mkDerivation {
   pname = "hsreduce";
@@ -13,16 +14,16 @@ mkDerivation {
   isExecutable = true;
   libraryHaskellDepends = [
     aeson base bytestring Cabal cassava containers Diff edit-distance
-    ghc ghc-boot-th ghc-exactprint ghc-paths hashable hie-bios katip
-    lifted-async lifted-base megaparsec microlens-platform
+    ghc ghc-boot-th ghc-exactprint ghc-paths hashable hie-bios HUnit
+    katip lifted-async lifted-base megaparsec microlens-platform
     monad-control MonadRandom mtl optparse-generic path path-io process
     regex split stm-lifted syb text time transformers-base uniplate
     word8
   ];
   executableHaskellDepends = [
     aeson base bytestring Cabal cassava containers Diff edit-distance
-    ghc ghc-boot-th ghc-exactprint ghc-paths hashable hie-bios katip
-    lifted-async lifted-base megaparsec microlens-platform
+    ghc ghc-boot-th ghc-exactprint ghc-paths hashable hie-bios HUnit
+    katip lifted-async lifted-base megaparsec microlens-platform
     monad-control MonadRandom mtl optparse-generic path path-io process
     regex split stm-lifted syb text time transformers-base uniplate
     word8
@@ -30,7 +31,7 @@ mkDerivation {
   testHaskellDepends = [
     aeson base bytestring Cabal cassava containers Diff edit-distance
     ghc ghc-boot-th ghc-exactprint ghc-paths hashable hie-bios hspec
-    katip lifted-async lifted-base megaparsec microlens-platform
+    HUnit katip lifted-async lifted-base megaparsec microlens-platform
     monad-control MonadRandom mtl optparse-generic path path-io process
     regex split stm-lifted syb text time transformers-base uniplate
     word8

hsreduce.cabal

@@ -11,6 +11,7 @@ common dry
         src
     build-depends:       
         base
+        , HUnit
         , Cabal
         , MonadRandom
         , aeson

src/Reduce/Driver.hs

@@ -3,11 +3,12 @@ module Reduce.Driver
     )
 where
 
+import qualified Data.ByteString.Lazy as LBS
+import Data.Csv
 import Control.Concurrent.STM.Lifted
 import Control.Exception
 import Control.Monad
 import Control.Monad.Reader
-import Data.Csv
 import Data.Text(pack)
 import Data.Text.Lazy.Builder
 import Data.Time
@@ -87,9 +88,7 @@ hsreduce allActions (fromIntegral -> numberOfThreads) test filePath = do
                 perfStats <- mkPerformance (fromIntegral oldSize) (fromIntegral newSize) t1 t2 (fromIntegral numberOfThreads)
 
                 liftIO $ appendFile "hsreduce_performance.csv" $ show perfStats
-
-                -- TODO: format this better
-                $(logTM) InfoS (LogStr . fromString . show . map snd . M.toList . _passStats $ _statistics newState)
+                liftIO . LBS.writeFile "hsreduce_statistics.csv" . encodeDefaultOrderedByName . map snd . M.toList . _passStats $ _statistics newState
 
     forM_ [1 .. numberOfThreads] $ \_ -> do
         t <- atomically $ readTChan tChan

src/Reduce/Passes.hs

@@ -66,9 +66,9 @@ slow = do
         , DataTypes.inline
         , DataTypes.rmvConArgs
         , Imports.unqualImport
-        -- , TypeFamilies.apply
+        , TypeFamilies.apply
         , TypeFamilies.rmvEquations
-        , Parameters.reduce
+        -- , Parameters.reduce
         , Functions.inline
         ]
     medium

src/Reduce/Passes/Extensions/TypeFamilies.hs

@@ -46,7 +46,8 @@ apply = AST "typefamilies:apply" $ \ast ->
                             -- find occurrences of the type family
                             -- replace them by nth pattern
                             takeNthArgument tycon (length feqn_pats) index
-                        else replaceWithRHs tycon feqn_rhs
+                        else 
+                            replaceWithRHs tycon feqn_rhs
                 in transformBi (overwriteAtLoc l c)
                 )
                 [t | (t :: LHsType GhcPs) <- universeBi ast, isContainedIn tycon t]
@@ -58,20 +59,23 @@ isContainedIn feqn_rhs = (oshow feqn_rhs `isInfixOf`) . oshow
 
 replaceWithRHs :: p ~ GhcPs => IdP p -> LHsType p -> HsType p -> HsType p
 replaceWithRHs tycon (unLoc -> rhs) t
-    | oshow tycon `isPrefixOf` oshow t = rhs
-    | oshow tycon `isInfixOf` oshow t = rhs
-    | otherwise = t
+    | typeContainsTyCon tycon t, not $ tycon `isContainedIn` rhs = rhs
+    | otherwise = t                
 
 -- the rhs is one of the patterns sub type expressions
 -- get the index of the pattern
 -- find occurrences of the sub type expression
 -- replace them by the right hand side
 
+typeContainsTyCon :: RdrName -> HsType GhcPs -> Bool
+typeContainsTyCon tycon (HsTyVar _ _ (L _ name)) = tycon == name
+typeContainsTyCon tycon (HsAppTy _ (L _ t) _) = typeContainsTyCon tycon t
+typeContainsTyCon _ _ = False
+
 -- TODO: see if we have a HsAppTy and count the arguments
 takeNthArgument :: p ~ GhcPs => IdP p -> Int -> Int -> HsType p -> HsType p
 takeNthArgument tycon n i t
-    | oshow tycon `isInfixOf` oshow t = takeNthArgumentHelper n i t
-    | oshow tycon `isPrefixOf` oshow t = takeNthArgumentHelper n i t
+    | typeContainsTyCon tycon t = takeNthArgumentHelper n i t
     | otherwise = t
 
 takeNthArgumentHelper :: Int -> Int -> HsType GhcPs -> HsType GhcPs

test-cases/regressions/TypeFamilies.hs

@@ -1,5 +1,7 @@
 {-# language TypeFamilies #-}
 
+import GHC.Generics
+
 main = undefined
 
 type family F a b where
@@ -7,3 +9,12 @@ type family F a b where
 
 arst :: F Int Char -> String
 arst = undefined
+
+type family G a b where
+  G a b = String
+
+brst :: G Int Char -> String
+brst = undefined
+
+type family Zip a b where
+  Zip (_ s) (_ m t) = M1 () m (Zip s t)

test/Test.hs

@@ -1,5 +1,7 @@
 module Main where
 
+import Test.HUnit.Lang
+import System.Timeout
 import qualified Data.Text as T
 import Data.Foldable
 import Path 
@@ -8,12 +10,13 @@ import Control.Monad
 import Test.Hspec
 
 import Reduce.Driver (hsreduce)
-import qualified Reduce.Passes.Remove.Imports        as Imports
-import qualified Reduce.Passes.Remove.Pragmas        as Pragmas
-import qualified Reduce.Passes.Remove.Exports        as Exports
-import qualified Reduce.Passes.Remove.Decls          as Decls
-import qualified Reduce.Passes.Remove.Parameters     as Parameters
-import qualified Reduce.Passes.Stubbing              as Stubbing 
+import qualified Reduce.Passes.Extensions.TypeFamilies as TypeFamilies
+import qualified Reduce.Passes.Remove.Imports          as Imports
+import qualified Reduce.Passes.Remove.Pragmas          as Pragmas
+import qualified Reduce.Passes.Remove.Exports          as Exports
+import qualified Reduce.Passes.Remove.Decls            as Decls
+import qualified Reduce.Passes.Remove.Parameters       as Parameters
+import qualified Reduce.Passes.Stubbing                as Stubbing 
     ( contexts,
       simplifyDeriving,
       simplifyDerivingClause,
@@ -23,8 +26,8 @@ import qualified Reduce.Passes.Stubbing              as Stubbing
       rmvGuards,
       tyVarBndr,
     )
-import qualified Reduce.Passes.DataTypes             as DataTypes
-import qualified Reduce.Passes.Simplify.Expr as Expr
+import qualified Reduce.Passes.DataTypes      as DataTypes
+import qualified Reduce.Passes.Simplify.Expr  as Expr
 import qualified Reduce.Passes.Simplify.Types as Types
 import Util.Util
 
@@ -122,6 +125,11 @@ main = hspec $ do
                     runPass Stubbing.rmvRHSs,           
                     Nothing,                
                     "module RHSs where\narst | 3 > 5 = \"arst\"")
+                -- TODO: add timeout to test
+                , ("TypeFamilies",   
+                    runPass TypeFamilies.apply,           
+                    Nothing,                
+                    "{-# LANGUAGE TypeFamilies #-}\nimport GHC.Generics\nmain = undefined\ntype family F a b where\n  F a b = a\narst :: Int -> String\narst = undefined\ntype family G a b where\n  G a b = String\nbrst :: String -> String\nbrst = undefined\ntype family Zip a b where\n  Zip (_ s) (_ m t) = M1 () m (Zip s t)\n")
                 ]
 
     -- TODO: make this parametric, give a list of test cases with their reduce functions and a title
@@ -134,11 +142,15 @@ main = hspec $ do
                     Nothing -> test
                     Just t  -> fromJust . parseRelFile $ root <> t
 
-            hsreduce [a] 1 (fromRelFile realTest) (fromRelFile src <> ".hs")
+            timeout (10 * 1000 * 1000) (hsreduce [a] 1 (fromRelFile realTest) (fromRelFile src <> ".hs")) >>= \case
+                Nothing -> assertFailure "test case timed out"
+                Just () -> return ()
+
             fileContent <- readFile newFilePath
 
             return (drop (length root) filePath, (fileContent, expected))
 
+
         forM_ results (\(filePath, (fileContent, expected)) -> it filePath $ fileContent `shouldBe` expected)
 
 -- realFloor :: T.Text