{-# LANGUAGE PatternGuards, ScopedTypeVariables, RecordWildCards, ViewPatterns #-} -- | Translate the hints to Haskell and run with GHC. module Test.Translate(testTypeCheck, testQuickCheck) where import Control.Monad import Data.List import Data.Maybe import System.Cmd import System.Exit import System.FilePath import Paths_hlint import Settings import Util import HSE.All import Test.Util runMains :: [String] -> IO () runMains xs = withTemporaryFiles "HLint_tmp.hs" (length xs + 1) $ \(root:bodies) -> do forM_ (zip bodies xs) $ \(file,x) -> do writeFile file $ replace "module Main" ("module " ++ takeBaseName file) x let ms = map takeBaseName bodies writeFile root $ unlines $ ["import qualified " ++ m | m <- ms] ++ ["main = do"] ++ [" " ++ m ++ ".main" | m <- ms] dat <- getDataDir res <- system $ "runhaskell -i" ++ takeDirectory root ++ " -i" ++ dat ++ " " ++ root replicateM_ (length xs) $ tested $ res == ExitSuccess -- | Given a set of hints, do all the HintRule hints type check testTypeCheck :: [[Setting]] -> IO () testTypeCheck = wrap toTypeCheck -- | Given a set of hints, do all the HintRule hints satisfy QuickCheck testQuickCheck :: [[Setting]] -> IO () testQuickCheck = wrap toQuickCheck wrap :: ([HintRule] -> [String]) -> [[Setting]] -> IO () wrap f hints = runMains [unlines $ body [x | SettingMatchExp x <- xs] | xs <- hints] where body xs = ["{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules, ScopedTypeVariables, DeriveDataTypeable #-}" ,"{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances #-}" ,"module Main(main) where"] ++ concat [map (prettyPrint . hackImport) $ scopeImports $ hintRuleScope x | x <- take 1 xs] ++ f xs -- Hack around haskell98 not being compatible with base anymore hackImport i@ImportDecl{importAs=Just a,importModule=b} | prettyPrint b `elem` words "Maybe List Monad IO Char" = i{importAs=Just b,importModule=a} hackImport i = i --------------------------------------------------------------------- -- TYPE CHECKING toTypeCheck :: [HintRule] -> [String] toTypeCheck hints = ["import HLint_TypeCheck hiding(main)" ,"main = return ()"] ++ ["{-# LINE " ++ show (startLine $ ann rhs) ++ " " ++ show (fileName $ ann rhs) ++ " #-}\n" ++ prettyPrint (PatBind an (toNamed $ "test" ++ show i) Nothing bod Nothing) | (i, HintRule _ _ _ lhs rhs side _) <- zip [1..] hints, "noTypeCheck" `notElem` vars (maybeToList side) , let vs = map toNamed $ nub $ filter isUnifyVar $ vars lhs ++ vars rhs , let inner = InfixApp an (Paren an lhs) (toNamed "==>") (Paren an rhs) , let bod = UnGuardedRhs an $ if null vs then inner else Lambda an vs inner] --------------------------------------------------------------------- -- QUICKCHECK toQuickCheck :: [HintRule] -> [String] toQuickCheck hints = ["import HLint_QuickCheck hiding(main)" ,"default(Maybe Bool,Int,Dbl)" ,prettyPrint $ PatBind an (toNamed "main") Nothing (UnGuardedRhs an $ toNamed "withMain" $$ Do an tests) Nothing] where str x = Lit an $ String an x (show x) int x = Lit an $ Int an (toInteger x) (show x) app = App an a $$ b = InfixApp an a (toNamed "$") b tests = [ Qualifier an $ (toNamed "test" `app` str (fileName $ ann rhs) `app` int (startLine $ ann rhs) `app` str (prettyPrint lhs ++ " ==> " ++ prettyPrint rhs)) $$ bod | (i, HintRule _ _ _ lhs rhs side note) <- zip [1..] hints, "noQuickCheck" `notElem` vars (maybeToList side) , let vs = map (restrict side) $ nub $ filter isUnifyVar $ vars lhs ++ vars rhs , let op = if any isRemovesError note then "?==>" else "==>" , let inner = InfixApp an (Paren an lhs) (toNamed op) (Paren an rhs) , let bod = if null vs then Paren an inner else Lambda an vs inner] restrict (Just side) v | any (=~= App an (toNamed "isNegZero") (toNamed v)) (universe side) = PApp an (toNamed "NegZero") [toNamed v] | any (=~= App an (toNamed "isNat") (toNamed v)) (universe side) = PApp an (toNamed "Nat") [toNamed v] | any (=~= App an (toNamed "isCompare") (toNamed v)) (universe side) = PApp an (toNamed "Compare") [toNamed v] restrict _ v = toNamed v isRemovesError RemovesError{} = True isRemovesError _ = False