-- -*- coding: utf-8; mode: haskell; -*-

-- File: tests/Tests.hs
--
-- License:
--     Copyright 2017 Awake Security
--
--     Licensed under the Apache License, Version 2.0 (the "License");
--     you may not use this file except in compliance with the License.
--     You may obtain a copy of the License at
--
--       http://www.apache.org/licenses/LICENSE-2.0
--
--     Unless required by applicable law or agreed to in writing, software
--     distributed under the License is distributed on an "AS IS" BASIS,
--     WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--     See the License for the specific language governing permissions and
--     limitations under the License.

{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UndecidableInstances  #-}

-- |
--   Module      : Main
--   Copyright   : Copyright 2017 Awake Security
--   License     : Apache-2.0
--   Maintainer  : opensource@awakesecurity.com
--   Stability   : experimental
--
--   The @language-ninja@ test suite.
module Main (main) where

import           Data.Maybe                 (catMaybes)
import           Data.Monoid                ((<>))

import qualified Data.Typeable              as Ty

import           Data.Text                  (Text)

import           Control.Exception          (displayException)
import           Control.Monad              (forM, unless, void)
import           Control.Monad.Identity     (Identity)
import           Control.Monad.Trans.Except (ExceptT, runExceptT)

import qualified Control.Lens               as Lens

import qualified Language.Ninja.AST.Env     as AST (Maps)

import qualified Language.Ninja.AST         as AST
import qualified Language.Ninja.Compile     as Compile
import qualified Language.Ninja.Errors      as Errors
import qualified Language.Ninja.IR          as IR
import qualified Language.Ninja.Lexer       as Lexer
import qualified Language.Ninja.Misc        as Misc
import qualified Language.Ninja.Parser      as Parser
import qualified Language.Ninja.Pretty      as Pretty

import           Test.Tasty                 (TestName, TestTree)

import qualified Test.Tasty                 as Test
import qualified Test.Tasty.HUnit           as Test
import qualified Test.Tasty.Ingredients     as Test
import qualified Test.Tasty.Options         as Test
import qualified Test.Tasty.Runners.Html    as Test

import qualified Test.Tasty.QuickCheck      as Test.QC
import qualified Test.Tasty.SmallCheck      as Test.SC

import qualified Test.Tasty.Lens.Iso        as Test.Iso
import qualified Test.Tasty.Lens.Lens       as Test.Lens
import qualified Test.Tasty.Lens.Prism      as Test.Prism

import           Test.QuickCheck            ((===))
import qualified Test.QuickCheck            as QC
import           Test.QuickCheck.Instances  ()

import qualified Test.SmallCheck.Series     as SC

import           Filesystem.Path.CurrentOS  ((</>))
import qualified Filesystem.Path.CurrentOS  as FP

import qualified Data.Aeson                 as Aeson
import qualified Data.Aeson.Types           as Aeson

import qualified Turtle

import           Flow                       ((.>), (|>))

import qualified Tests.Lint                 as Lint
import           Tests.Orphans              ()
import qualified Tests.ReferenceLexer       as RefLex

--------------------------------------------------------------------------------

dataPrefix :: String
dataPrefix = "./tests/data/"

testFiles :: [String]
testFiles = [ "buildseparate"
            , "compdb"
            , "lexical"
            , "lint"
            , "nocreate"
            , "outputtouch"
            , "phonyorder"
            , "redefine"
            , "test1"
            , "test2"
            , "test3"
            , "test4"
            , "test5"
            , "test6"
            ]

aesonSC' :: (Eq x, Show x)
         => SC.Series IO x
         -> (x -> Aeson.Value)
         -> (Aeson.Value -> Aeson.Parser x)
         -> TestTree
aesonSC' s toJ fromJ
  = Test.SC.testProperty "parseJSON . toJSON ≡ₛ pure"
    (Test.SC.over s (\x -> Aeson.parseEither fromJ (toJ x) == Right x))

aesonSC :: forall x.
           ( Eq x, Show x, SC.Serial IO x, Aeson.ToJSON x, Aeson.FromJSON x
           ) => Ty.Proxy x -> TestTree
aesonSC _ = aesonSC' @x SC.series Aeson.toJSON Aeson.parseJSON

aesonQC' :: (Eq x, Show x)
         => (QC.Gen x, x -> [x])
         -> (x -> Aeson.Value)
         -> (Aeson.Value -> Aeson.Parser x)
         -> TestTree
aesonQC' (gen, shrink) toJ fromJ
  = Test.QC.testProperty "parseJSON . toJSON ≡ₐ pure"
    (Test.QC.forAllShrink gen shrink
     (\x -> Aeson.parseEither fromJ (toJ x) === Right x))

aesonQC :: forall x.
           ( Eq x, Show x, QC.Arbitrary x, Aeson.ToJSON x, Aeson.FromJSON x
           ) => Ty.Proxy x -> TestTree
aesonQC _ = aesonQC' @x (QC.arbitrary, QC.shrink) Aeson.toJSON Aeson.parseJSON

parseTestNinja :: String -> IO (AST.Ninja ())
parseTestNinja name = do
  old <- Turtle.pwd
  Turtle.cd (FP.decodeString dataPrefix)
  let file = Lens.view (Lens.from Misc.pathString) (name <> ".ninja")
  result <- Parser.parseFileIO file >>= void .> pure
  Turtle.cd old
  pure result

lexerEquivalentTest :: String -> IO ()
lexerEquivalentTest name = do
  let file = dataPrefix <> name <> ".ninja"
             |> Lens.view (Lens.from Misc.pathString)

  let oldLexer :: Misc.Path -> ExceptT Errors.ParseError IO [Lexer.Lexeme ()]
      oldLexer = RefLex.lexFile

  let newLexer :: Misc.Path -> ExceptT Errors.ParseError IO [Lexer.Lexeme ()]
      newLexer = Lexer.lexFile .> fmap (map void)

  expected <- runExceptT (oldLexer file)
  actual   <- runExceptT (newLexer file)

  unless (expected == actual) $ do
    Test.assertEqual "prefix" expected actual

roundtripTest :: AST.Ninja () -> IO ()
roundtripTest ninja = do
  let withTempDir :: (FP.FilePath -> IO a) -> IO a
      withTempDir = Turtle.with (Turtle.mktempdir "." "test")

  (expected, actual) <- withTempDir $ \tmpdir -> do
    let prettyInput = Pretty.prettyNinja ninja
    let tmpfile = tmpdir </> "generated.ninja"
    Turtle.writeTextFile tmpfile prettyInput
    output <- Parser.parseFileIO (Lens.view (Lens.from Misc.pathFP) tmpfile)
              >>= void .> pure
    let prettyOutput = Pretty.prettyNinja output
    pure (prettyInput, prettyOutput)

  unless (expected == actual) $ do
    -- let actualJ   = Aeson.toJSON actual
    -- let expectedJ = Aeson.toJSON expected
    -- -- LBSC8.putStrLn (Aeson.encodePretty (Aeson.diff actualJ expectedJ))
    -- LBSC8.putStrLn (Aeson.encodePretty expectedJ)
    -- LBSC8.putStrLn (Aeson.encodePretty actualJ)
    -- Aeson.encode actualJ `H.shouldBe` Aeson.encode expectedJ
    Test.assertEqual "prefix" expected actual

compileTest :: AST.Ninja () -> IO ()
compileTest ninja = void $ do
  either (displayException .> fail) pure (Compile.compile ninja)

ninjaTests :: String -> AST.Ninja () -> TestTree
ninjaTests name ninja
  = Test.testGroup (name <> ".ninja")
    [ Test.testCase "compare lexer against reference implementation" $ do
        lexerEquivalentTest name
    , Test.testCase "roundtrip through parser and pretty-printer" $ do
        roundtripTest ninja
    , Test.testCase "compile to Ninja" $ do
        compileTest ninja
    ]

aesonTests :: TestTree
aesonTests
  = Test.testGroup "aeson"
    [ testModule "Language.Ninja.Lexer"
      [ testAesonSC 2   (Ty.Proxy @(Lexer.Lexeme Bool))
      , testAesonSC 4   (Ty.Proxy @(Lexer.LName  Bool))
      , testAesonSC 4   (Ty.Proxy @(Lexer.LFile  Bool))
      , testAesonSC 4   (Ty.Proxy @(Lexer.LBind  Bool))
      , testAesonSC 2   (Ty.Proxy @(Lexer.LBuild Bool))
      -- TODO: add Arbitrary instances so we can testAesonQC
      ]
    , testModule "Language.Ninja.IR.Build"
      [ testAesonSC 2   (Ty.Proxy @IR.Build)
      -- TODO: add Arbitrary instances so we can testAesonQC
      ]
    , testModule "Language.Ninja.IR.Meta"
      [ testAesonSC def (Ty.Proxy @IR.Meta)
      -- TODO: add Arbitrary instances so we can testAesonQC
      ]
    , testModule "Language.Ninja.IR.Ninja"
      [ testAesonSC 2   (Ty.Proxy @IR.Ninja)
      -- TODO: add Arbitrary instances so we can testAesonQC
      ]
    , testModule "Language.Ninja.IR.Pool"
      [ testAesonSC def (Ty.Proxy @IR.Pool)
      , testAesonSC def (Ty.Proxy @IR.PoolName)
      , testAesonSC def (Ty.Proxy @IR.PoolDepth)
      -- TODO: add Arbitrary instances so we can testAesonQC
      ]
    , testModule "Language.Ninja.IR.Rule"
      [ testAesonSC 1   (Ty.Proxy @IR.Rule)
      , testAesonSC def (Ty.Proxy @IR.SpecialDeps)
      , testAesonSC def (Ty.Proxy @IR.ResponseFile)
      -- TODO: add Arbitrary instances so we can testAesonQC
      ]
    , testModule "Language.Ninja.IR.Target"
      [ testAesonSC def (Ty.Proxy @IR.Target)
      , testAesonSC def (Ty.Proxy @IR.Output)
      , testAesonSC def (Ty.Proxy @IR.Dependency)
      , testAesonSC def (Ty.Proxy @IR.DependencyType)
      -- TODO: add Arbitrary instances so we can testAesonQC
      ]
    , testModule "Language.Ninja.AST.Env"
      [ testAesonSC def (Ty.Proxy @(AST.Env Text Text))
      , testAesonQC     (Ty.Proxy @(AST.Env Text Text))
      ]
    , testModule "Language.Ninja.AST.Expr"
      [ testAesonSC def (Ty.Proxy @(AST.Expr Bool))
      , testAesonQC     (Ty.Proxy @(AST.Expr Bool))
      ]
    , testModule "Language.Ninja.AST.Rule"
      [ testAesonSC def (Ty.Proxy @(AST.Rule Bool))
      , testAesonQC     (Ty.Proxy @(AST.Rule Bool))
      ]
    , testModule "Language.Ninja.AST.Ninja"
      [ -- TODO: combinatorial explosion
        testAesonSC 0   (Ty.Proxy @(AST.Ninja Bool))
      -- , testAesonQC     (Ty.Proxy @(AST.Ninja Bool))
      ]
    , testModule "Language.Ninja.AST.Build"
      [ -- TODO: combinatorial explosion
        testAesonSC 1   (Ty.Proxy @(AST.Build Bool))
      -- , testAesonQC     (Ty.Proxy @(AST.Build Bool))
      ]
    , testModule "Language.Ninja.AST.Deps"
      [ testAesonSC def (Ty.Proxy @(AST.Deps Bool))
      , testAesonQC     (Ty.Proxy @(AST.Deps Bool))
      ]
    , testModule "Language.Ninja.Misc.Command"
      [ testAesonSC def (Ty.Proxy @Misc.Command)
      -- TODO: add Arbitrary instances so we can testAesonQC
      ]
    , testModule "Language.Ninja.Misc.Path"
      [ testAesonSC def (Ty.Proxy @Misc.Path)
      -- TODO: add Arbitrary instances so we can testAesonQC
      ]
    , testModule "Language.Ninja.Misc.Located"
      [ testAesonSC def (Ty.Proxy @(Misc.Located Bool))
      , testAesonSC def (Ty.Proxy @Misc.Position)
      -- TODO: add Arbitrary instances so we can testAesonQC
      ]
    , testModule "Language.Ninja.Misc.IText"
      [ testAesonSC def (Ty.Proxy @Misc.IText)
      -- TODO: add Arbitrary instances so we can testAesonQC
      ]
    ]
  where
    testAesonSC :: forall x.
                   ( Eq x, Show x, Ty.Typeable x, SC.Serial IO x
                   , Aeson.ToJSON x, Aeson.FromJSON x
                   ) => Int -> Ty.Proxy x -> Maybe TestTree
    testAesonSC d p = withDepth d
                      (testType p
                       [Test.testGroup "ToJSON/FromJSON Laws" [aesonSC p]])

    testAesonQC :: forall x.
                   ( Eq x, Show x, Ty.Typeable x, QC.Arbitrary x
                   , Aeson.ToJSON x, Aeson.FromJSON x
                   ) => Ty.Proxy x -> Maybe TestTree
    testAesonQC p = Just (testType p
                          [Test.testGroup "ToJSON/FromJSON Laws" [aesonQC p]])

    withDepth :: Int -> (TestTree -> Maybe TestTree)
    withDepth 0     = const Nothing
    withDepth depth = Test.localOption (Test.SC.SmallCheckDepth depth) .> Just

    testModule :: TestName -> [Maybe TestTree] -> TestTree
    testModule name subtrees = Test.testGroup name (catMaybes subtrees)

    testType :: forall x. (Ty.Typeable x)
             => Ty.Proxy x -> [TestTree] -> TestTree
    testType p subtrees = Test.localOption typeTimeout
                          $ Test.testGroup (printProxy p) subtrees

    printProxy :: forall x. (Ty.Typeable x) => Ty.Proxy x -> String
    printProxy p = Ty.showsTypeRep (Ty.typeRep p) ""

    def :: Int
    def = (Test.defaultValue :: Test.SC.SmallCheckDepth)
          |> toInteger |> fromIntegral

    typeTimeout :: Test.Timeout
    typeTimeout = Test.mkTimeout 20000000 -- 20 seconds

opticsTests :: TestTree
opticsTests
  = Test.testGroup "optics"
    [ testModule "Language.Ninja.IR.Build"
      [ testType "Build" [] -- TODO: combinatorial explosion
        -- [ testLens 1 "buildRule" IR.buildRule
        -- , testLens 1 "buildOuts" IR.buildOuts
        -- , testLens 1 "buildDeps" IR.buildDeps
        -- ]
      ]
    , testModule "Language.Ninja.IR.Meta"
      [ testType "Meta"
        [ testLens def "metaReqVersion" IR.metaReqVersion
        , testLens def "metaBuildDir"   IR.metaBuildDir
        ]
      ]
    , testModule "Language.Ninja.IR.Ninja"
      [ testType "Ninja" [] -- TODO: combinatorial explosion
        -- [ testLens 1 "ninjaMeta"     IR.ninjaMeta
        -- , testLens 1 "ninjaBuilds"   IR.ninjaBuilds
        -- , testLens 1 "ninjaPhonys"   IR.ninjaPhonys
        -- , testLens 1 "ninjaDefaults" IR.ninjaDefaults
        -- , testLens 1 "ninjaPools"    IR.ninjaPools
        -- ]
      ]
    , testModule "Language.Ninja.IR.Pool"
      [ testType "Pool"
        [
        ]
      , testType "PoolName"
        [ testIso def "poolNameText" IR.poolNameText
        ]
      , testType "PoolDepth"
        [ testIso def "poolDepthPositive" IR.poolDepthPositive
        ]
      ]
    , testModule "Language.Ninja.IR.Rule"
      [ testType "Rule" [] -- TODO: combinatorial explosion
        -- [ testLens 1 "ruleName"         IR.ruleName
        -- , testLens 1 "ruleCommand"      IR.ruleCommand
        -- , testLens 1 "ruleDescription"  IR.ruleDescription
        -- , testLens 1 "rulePool"         IR.rulePool
        -- , testLens 1 "ruleDepfile"      IR.ruleDepfile
        -- , testLens 1 "ruleSpecialDeps"  IR.ruleSpecialDeps
        -- , testLens 1 "ruleGenerator"    IR.ruleGenerator
        -- , testLens 1 "ruleRestat"       IR.ruleRestat
        -- , testLens 1 "ruleResponseFile" IR.ruleResponseFile
        -- ]
      , testType "SpecialDeps"
        [ testPrism def "_SpecialDepsGCC"  IR._SpecialDepsGCC
        , testPrism def "_SpecialDepsMSVC" IR._SpecialDepsMSVC
        ]
      , testType "ResponseFile"
        [ testLens def "responseFilePath"    IR.responseFilePath
        , testLens def "responseFileContent" IR.responseFileContent
        ]
      ]
    , testModule "Language.Ninja.IR.Target"
      [ testType "Target"
        [ testIso def "targetIText" IR.targetIText
        , testIso def "targetText"  IR.targetText
        ]
      , testType "Output"
        [ testLens def "outputTarget" IR.outputTarget
        ]
      , testType "Dependency"
        [ testLens def "dependencyTarget" IR.dependencyTarget
        , testLens def "dependencyType"   IR.dependencyType
        ]
      , testType "DependencyType"
        [ testPrism def "_NormalDependency"    IR._NormalDependency
        , testPrism def "_OrderOnlyDependency" IR._OrderOnlyDependency
        ]
      ]
    , testModule "Language.Ninja.AST.Env"
      [ testType "Env"
        [ testIso 1 "fromEnv"
          (AST.fromEnv :: Lens.Iso' (AST.Env Text Int) (AST.Maps Text Int))
        ]
      ]
    , testModule "Language.Ninja.AST.Expr"
      [ testType "Expr"
        [ testPrism 4 "_Exprs" (AST._Exprs @Bool)
        , testPrism 4 "_Lit"   (AST._Lit   @Bool)
        , testPrism 4 "_Var"   (AST._Var   @Bool)
        ]
      ]
    , testModule "Language.Ninja.AST.Rule"
      [ testType "Rule"
        [ testLens 4 "ruleBind" (AST.ruleBind @Bool)
        ]
      ]
    , testModule "Language.Ninja.AST.Ninja"
      [ testType "Ninja" [] -- TODO: combinatorial explosion
        -- [ testLens 1 "ninjaRules"     (AST.ninjaRules     @Bool)
        -- , testLens 1 "ninjaSingles"   (AST.ninjaSingles   @Bool)
        -- , testLens 1 "ninjaMultiples" (AST.ninjaMultiples @Bool)
        -- , testLens 1 "ninjaPhonys"    (AST.ninjaPhonys    @Bool)
        -- , testLens 1 "ninjaDefaults"  (AST.ninjaDefaults  @Bool)
        -- , testLens 1 "ninjaSpecials"  (AST.ninjaSpecials  @Bool)
        -- ]
      ]
    , testModule "Language.Ninja.AST.Build"
      [ testType "Build" [] -- TODO: combinatorial explosion
        -- [ testLens 1 "buildRule" (AST.buildRule @Bool)
        -- , testLens 1 "buildEnv"  (AST.buildEnv  @Bool)
        -- , testLens 1 "buildDeps" (AST.buildDeps @Bool)
        -- , testLens 1 "buildBind" (AST.buildBind @Bool)
        -- ]
      ]
    , testModule "Language.Ninja.AST.Deps"
      [ testType "Deps"
        [ testLens def "depsNormal"    (AST.depsNormal    @Bool)
        , testLens def "depsImplicit"  (AST.depsImplicit  @Bool)
        , testLens def "depsOrderOnly" (AST.depsOrderOnly @Bool)
        ]
      ]
    , testModule "Language.Ninja.Misc.Command"
      [ testType "Command"
        [ testIso def "commandText" Misc.commandText
        ]
      ]
    , testModule "Language.Ninja.Misc.Path"
      [ testType "Path"
        [ testIso def "pathIText"  Misc.pathIText
        , testIso def "pathText"   Misc.pathText
        , testIso def "pathString" Misc.pathString
        , testIso def "pathFP"     Misc.pathFP
        ]
      ]
    , testModule "Language.Ninja.Misc.Located"
      [ testType "Located"
        [ testLens 4 "locatedPos"
          (Misc.locatedPos :: Lens.Lens' (Misc.Located Bool) Misc.Position)
        , testLens 4 "locatedVal"
          (Misc.locatedVal :: Lens.Lens' (Misc.Located Bool) Bool)
        ]
      , testType "Position"
        [ testLens 4 "positionFile" Misc.positionFile
        , testLens 4 "positionLine" Misc.positionLine
        , testLens 4 "positionCol"  Misc.positionCol
        ]
      ]
    , testModule "Language.Ninja.Misc.IText"
      [ testType "IText"
        [ testIso def "itext" Misc.itext
        ]
      ]
    ]
  where
    testIso   :: ( Eq s, Eq a, Show s, Show a
                 , SC.Serial Identity s, SC.Serial IO s, SC.CoSerial IO s
                 , SC.Serial Identity a, SC.Serial IO a, SC.CoSerial IO a
                 ) => Int -> TestName -> Lens.Iso' s a -> TestTree
    testLens  :: ( Eq s, Eq a, Show s, Show a
                 , SC.Serial IO s, SC.Serial IO a
                 , SC.Serial Identity a, SC.CoSerial IO a
                 ) => Int -> TestName -> Lens.Lens' s a -> TestTree
    testPrism :: ( Eq s, Eq a, Show s, Show a
                 , SC.Serial IO s, SC.Serial IO a
                 , SC.Serial Identity a, SC.CoSerial IO a
                 ) => Int -> TestName -> Lens.Prism' s a -> TestTree
    testIso   d name i = withDepth d $ Test.testGroup name [Test.Iso.test   i]
    testLens  d name l = withDepth d $ Test.testGroup name [Test.Lens.test  l]
    testPrism d name p = withDepth d $ Test.testGroup name [Test.Prism.test p]

    withDepth :: Int -> (TestTree -> TestTree)
    withDepth depth = Test.localOption (Test.SC.SmallCheckDepth depth)

    testModule :: TestName -> [TestTree] -> TestTree
    testModule = Test.testGroup

    testType :: TestName -> [TestTree] -> TestTree
    testType name subtrees = Test.localOption typeTimeout
                             $ Test.testGroup name subtrees

    def :: Int
    def = (Test.defaultValue :: Test.SC.SmallCheckDepth)
          |> toInteger |> fromIntegral

    typeTimeout :: Test.Timeout
    typeTimeout = Test.mkTimeout 20000000 -- 20 seconds

ingredients :: IO [Test.Ingredient]
ingredients = [ [Test.htmlRunner]
              , Test.defaultIngredients
              ] |> mconcat |> pure

testTree :: IO TestTree
testTree = do
  ninjas <- forM testFiles parseTestNinja

  haddockTests <- Lint.emptyLintHaddockOptions
                  |> Lint.addComponentName "language-ninja"
                  |> Lint.lintHaddock

  let tests = Test.testGroup "language-ninja"
              [ Test.testGroup "golden"
                 (fmap (uncurry ninjaTests) (zip testFiles ninjas))
              , aesonTests
              , opticsTests
              , haddockTests
              ]
  pure tests

test :: IO ()
test = do
  is <- ingredients
  tree <- testTree
  Test.defaultMainWithIngredients is tree

main :: IO ()
main = do
  test

--------------------------------------------------------------------------------