-- | Translate the hints to Haskell and run with GHC.
module Test.Translate(testTypeCheck, testQuickCheck) where

import Control.Monad
import Data.List.Extra
import System.IO.Extra
import Data.Maybe
import System.Process
import System.Exit
import System.FilePath

import Paths_hlint
import Settings
import HSE.All
import Test.Util


runMains :: FilePath -> [String] -> IO ()
runMains tmpdir xs = (if tmpdir == "" then withTempDir else ($ tmpdir)) $ \dir -> do
    ms <- forM (zip [1..] xs) $ \(i,x) -> do
        let m = "I" ++ show i
        writeFile (dir </> m <.> "hs") $ replace "module Main" ("module " ++ m) x
        return m
    writeFile (dir </> "Main.hs") $ unlines $
        ["import qualified " ++ m | m <- ms] ++
        ["main = do"] ++
        ["    " ++ m ++ ".main" | m <- ms]
    dat <- getDataDir
    res <- system $ "runhaskell -i" ++ dir ++ " -i" ++ dat ++ " Main"
    replicateM_ (length xs) $ tested $ res == ExitSuccess


-- | Given a set of hints, do all the HintRule hints type check
testTypeCheck :: FilePath -> [[Setting]] -> IO ()
testTypeCheck = wrap toTypeCheck

-- | Given a set of hints, do all the HintRule hints satisfy QuickCheck
testQuickCheck :: FilePath -> [[Setting]] -> IO ()
testQuickCheck = wrap toQuickCheck

wrap :: ([HintRule] -> [String]) -> FilePath -> [[Setting]] -> IO ()
wrap f tmpdir hints = runMains tmpdir [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) 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") (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 $
                Let an (BDecls an [PatBind an (toNamed "t") (UnGuardedRhs an bod) Nothing]) $
                (toNamed "test" `app` str (fileName $ ann rhs) `app` int (startLine $ ann rhs) `app`
                 str (prettyPrint lhs ++ " ==> " ++ prettyPrint rhs)) `app` toNamed "t"
            | (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