module Derive.Test(test) where

import Derive.Utils
import Data.Derive.DSL.HSE
import Control.Monad
import Data.Maybe
import Data.List
import System.FilePath
import System.Process
import System.Exit
import Control.Arrow
import Data.Derive.All
import Data.Derive.Internal.Derivation


-- These overlap with other derivations
overlaps =
    [["BinaryDefer","EnumCyclic","LazySet","DataAbstract"]
    ,["Serialize"]]

-- REASONS:
-- UniplateDirect: Doesn't work through Template Haskell
-- Typeable cannot be separately derived in GHC 7.8
exclude = ["ArbitraryOld","UniplateDirect","Ref","Serial","Binary","Typeable"]

-- These must be first and in every set
priority = []


listType :: Decl ()
listType = DataDecl () (DataType ()) Nothing (DHApp () (DHead () (Ident () "[]")) (UnkindedVar () $ Ident () "a"))
    [QualConDecl () Nothing Nothing (ConDecl () (Ident () "[]") [])
    ,QualConDecl () Nothing Nothing (ConDecl () (Ident () "Cons")
        [TyVar () (Ident () "a")
        ,TyApp () (TyCon () (UnQual () (Ident () "List"))) (TyVar () (Ident () "a"))])]
    Nothing


-- test each derivation
test :: IO ()
test = do
    decls <- fmap (filter isDataDecl . moduleDecls) $ readHSE "Data/Derive/Internal/Test.hs"

    -- check the test bits
    let ts = ("[]",listType) : map (dataDeclName &&& id) decls
    mapM_ (testFile ts) derivations

    -- check the $(derive) bits
    putStrLn "Type checking examples"
    let name = "AutoGenerated_Test"
    devs <- sequence [liftM ((,) d) $ readSrc $ "Data/Derive" </> derivationName d <.> "hs" | d <- derivations]
    let lookupDev x = fromMaybe (error $ "Couldn't find derivation: " ++ x) $ find ((==) x . derivationName . fst) devs

    let sets = zip [1..] $ map (map lookupDev) $ map (priority++) $
            [d | d <- map (derivationName . fst) devs, d `notElem` (exclude ++ priority ++ concat overlaps)] : overlaps

    forM sets $ \(i,xs) -> autoTest (name++show i) decls xs
    writeFile (name++".hs") $ unlines $
        ["import " ++ name ++ show (fst i) | i <- sets] ++ ["main = putStrLn \"Type checking successful\""]
    res <- system $ "runhaskell -isrc " ++ name ++ ".hs"
    when (res /= ExitSuccess) $ error "Failed to typecheck results"


testFile :: [(String,Decl ())] -> Derivation -> IO ()
testFile types (Derivation name op) = do
    putStrLn $ "Testing " ++ name
    src <- readSrc $ "Data/Derive/" ++ name ++ ".hs"
    forM_ (srcTest src) $ \(typ,res) -> do
        let d = if tyRoot typ /= name then tyRoot typ else tyRoot $ head $ snd $ fromTyApps $ fromTyParen typ
        let grab x = fromMaybe (error $ "Error in tests, couldn't resolve type: " ++ x) $ lookup x types
        let Right r = op typ grab (ModuleName () "Example", grab d)
        when (not $ r `outEq` res) $
            error $ "Results don't match!\nExpected:\n" ++ showOut res ++ "\nGot:\n" ++ showOut r ++ "\n\n" ++ detailedNeq res r

detailedNeq as bs | na /= nb = "Lengths don't match, " ++ show na ++ " vs " ++ show nb
    where na = length as ; nb = length bs

detailedNeq as bs = "Mismatch on line " ++ show i ++ "\n" ++ show a ++ "\n" ++ show b
    where (i,a,b) = head $ filter (\(i,a,b) -> a /= b) $ zip3 [1..] (noSl as) (noSl bs)


autoTest :: String -> [DataDecl] -> [(Derivation,Src)] -> IO ()
autoTest name ts ds =
    writeFile (name++".hs") $ unlines $
        ["{-# LANGUAGE TemplateHaskell,FlexibleInstances,MultiParamTypeClasses,TypeOperators,DeriveDataTypeable #-}"
        ,"{-# OPTIONS_GHC -Wall -fno-warn-missing-fields -fno-warn-unused-imports #-}"
        ,"module " ++ name ++ " where"
        ,"import Prelude"
        ,"import Data.DeriveTH"
        ,"import Data.Typeable"
        ,"import Derive.TestInstances()"] ++
        [prettyPrint i | (_,s) <- ds, i <- srcImportStd s] ++
        [prettyPrint t ++ "\n  deriving Typeable" | t <- ts2] ++
        ["$(derives [make" ++ derivationName d ++ "] " ++ types ++ ")" | (d,_) <- ds]
    where
        types = "[" ++ intercalate "," ["''" ++ dataDeclName t | t <- ts2] ++ "]"
        ts2 = filter (not . isBuiltIn) ts

isBuiltIn x = dataDeclName x `elem` ["Bool","Either"]