retrie-1.2.0.0: tests/GroundTerms.hs

-- Copyright (c) Facebook, Inc. and its affiliates.
--
-- This source code is licensed under the MIT license found in the
-- LICENSE file in the root directory of this source tree.
--
{-# LANGUAGE OverloadedStrings #-}
module GroundTerms
  ( getFocusTests
  , groundTermsTest
  ) where

import Control.Monad
import Control.Monad.IO.Class
import qualified Data.HashSet as HashSet
import Data.Text (Text)
import Fixity
import Retrie.CPP
import Retrie.ExactPrint
import Retrie.GroundTerms
import Retrie.Monad
import Retrie.Options
import Retrie.Rewrites
import Retrie.Types
import Retrie.Universe
import Test.HUnit

groundTermsTest :: LibDir -> Test
groundTermsTest libdir = TestLabel "ground terms" $ TestList
  [ gtTest libdir "map"
      ""
      []
      [Adhoc "forall f g xs. map f (map g xs) = map (f . g) xs"]
      [["map"]]
      [GrepCommands [] ["grep -R --include=\"*.hs\" -l 'map' '~/si_sigma'"]]
  , gtTest libdir "isSpace"
      ""
      []
      [Adhoc "forall xs. or (map isSpace xs) = any isSpace xs"]
      [["or", "map isSpace"]]
      [GrepCommands [] ["grep -R --include=\"*.hs\" -l 'or' '~/si_sigma'", "grep -l 'map[[:space:]]\\+isSpace'"]]
  , gtTest libdir "MyType"
      "type MyType a = MyOtherType a"
      []
      [TypeForward "Test.MyType"]
      [["MyType"]]
      [GrepCommands [] ["grep -R --include=\"*.hs\" -l 'MyType' '~/si_sigma'"]]
  , gtTest libdir "isSpace with file"
      ""
      ["Test.hs", "Test2.hs"]
      [Adhoc "forall xs. or (map isSpace xs) = any isSpace xs"]
      [["or", "map isSpace"]]
      [GrepCommands ["Test.hs", "Test2.hs"] ["grep -l 'or'", "grep -l 'map[[:space:]]\\+isSpace'"]]
  ]

gtTest
  :: LibDir
  -> String
  -> Text
  -> [FilePath]
  -> [RewriteSpec]
  -> [[String]]
  -> [GrepCommands]
  -> Test
gtTest libdir lbl contents targFiles specs expected expectedCmds =
  TestLabel ("groundTerms: " ++ lbl) $ TestCase $ do
    -- since we 'zip' below
    assertEqual "length of specs and expected ground terms"
      (length specs)
      (length expected)
    assertEqual "length of expected ground terms and expected commands"
      (length expected)
      (length expectedCmds)

    rrs <-
      parseRewriteSpecs libdir
        (\_ -> parseCPP (parseContent libdir defaultFixityEnv "Test") contents)
        defaultFixityEnv
        specs
    let gtss = map groundTerms rrs

    assertEqual "groundTerms does not give expected term set"
      (HashSet.fromList $ map HashSet.fromList expected)
      (HashSet.fromList gtss) -- compare hashsets to avoid ordering issues

    forM_ (zip gtss expectedCmds) $ \(gts, expectedCmd) ->
          assertEqual "buildGrepChain did not give expected command"
            expectedCmd
            (buildGrepChain "~/si_sigma" gts targFiles)

getFocusTests :: LibDir -> IO [Test]
getFocusTests libdir = do
  rrs1 <- parseAdhocs libdir defaultFixityEnv ["forall xs. or (map isSpace xs) = any isSpace xs"]
  rrs2 <- parseAdhocs libdir defaultFixityEnv ["forall f g xs. map f (map g xs) = map (f . g) xs"]
  let
    -- compare hashsets to avoid ordering issues
    terms = HashSet.fromList $ map groundTerms rrs1

  return
    [ TestLabel caseName $ TestCase $
        assertEqual caseName expected $
          HashSet.fromList $ getGroundTerms retrie
    | (caseName, retrie, expected) <-
      [ ("apply", apply rrs1, terms)
      , ("apply twice", apply rrs1 >> apply rrs2, terms)
      , ("query", () <$ query rrs1, terms)
      , ("focus", focus rrs1, terms)
      , ("focus empty", focus ([] :: [Rewrite Universe]), HashSet.empty)
      , ("focus empty next", focus ([] :: [Rewrite Universe]) >> apply rrs1, terms)
        -- We should generate no ground terms if no iteration happens
      , ("iterateR 0", iterateR 0 (apply rrs1), HashSet.empty)
      , ("iterateR 0 then apply", iterateR 0 (apply rrs2) >> apply rrs1, terms)
      , ("iterateR 5", iterateR 5 (apply rrs1), terms)
        -- test that adding imports first (calling 'tell') doesn't block us
        -- from finding ground terms
      , ("addImports", addImports mempty >> apply rrs1, terms)
      , ("ifChanged normal", ifChanged (apply rrs1) (apply rrs2), terms)
      -- the pathological case: changed but no ground terms
      , ("ifChanged weird", ifChanged (addImports mempty) (apply rrs1), terms)
      , ("liftIO", liftIO (return ()) >> apply rrs1, HashSet.empty)
      , ("liftIO after focus", focus rrs1 >> liftIO (return ()) >> apply rrs2, terms)
      ]
    ]