-- Copyright 2017 Google Inc.
--
-- 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 LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.Haskell.Indexer.Backend.Ghc.Test.BasicTestBase (allTests) where

import Control.Monad ((>=>), unless, void)
import Control.Monad.Trans.Reader (ReaderT, runReaderT)

import Language.Haskell.Indexer.Backend.Ghc.Test.TestHelper

import Test.Framework (Test)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit (assertFailure)

type AssertionInEnv = ReaderT TestEnv IO ()

-- | Tests that arguments of top-level functions, and their references, are
-- extracted. The argument references happen in various common syntactic
-- environments, such as if-then-else, case, etc.
testArgRef :: AssertionInEnv
testArgRef = assertXRefsFrom ["basic/ArgRef.hs"] $ do
    declAt (3,3) >>= singleUsage >>= includesPos (3,7)
    declAt (5,3) >>= singleUsage >>= includesPos (5,7)
    declAt (7,3) >>= singleUsage >>= includesPos (7,22)
    declAt (7,5) >>= singleUsage >>= includesPos (7,29)

-- | Tests recursive references in various contexts.
testRecursiveRef :: AssertionInEnv
testRecursiveRef = assertXRefsFrom ["basic/RecursiveRef.hs"] $ do
    -- Recursive function call without type signature targets the
    -- monomorphic binding. Test that we detect this.
    declAt (4,1) >>= singleUsage >>= includesPos (4,14)
    declAt (8,5) >>= usages >>= \case
        [u1, u2] -> do
            includesPos (6,9) u1
            includesPos (8,23) u2
        us -> checking $ assertFailure $ "Usage count differs: " ++ show us
    -- Recursive fun with type signature should target using the
    -- polymorphic binding.
    declAt (11,1) >>= usages >>= \case
        [u1, u2] -> do
            -- Note: first one is the ref from the type signature (see #25).
            includesPos (10,1) u1
            includesPos (11,16) u2
        us -> checking $ assertFailure $ "Usage count differs " ++ show us
    -- Other interesting cases.
    declAt (13,1) >>= singleUsage >>= includesPos (14,16)
    declAt (14,1) >>= singleUsage >>= includesPos (13,16)
    declAt (16,1) >>= singleUsage >>= includesPos (16,12)

testDataDecl :: AssertionInEnv
testDataDecl = assertXRefsFrom ["basic/DataDecl.hs"] $ do
    -- Plain data type.
    -- Ctor references.
    declAt (3,11) >>= singleUsage >>= includesPos (6,3)
    declAt (3,15) >>= singleUsage >>= includesPos (7,4)
    -- Record constructor reference.
    -- Based on the AST there would be a reference from the compiler-generated
    -- implementation of the field accessor, but we filter the body of such
    -- generated functions (see GhcAnalyser.hs for reasons).
    declAt (9,15) >>= singleUsage >>= includesPos (12,4)
    -- Accessor function reference.
    declAt (9,24) >>= singleUsage >>= includesPos (14,5)
    -- TODO(robinpalotai): datatype ref (once supported).
    -- TODO(robinpalotai): ctor arg references (once supported).

-- | Test that function applications are emitted as calls.
testFunCall :: AssertionInEnv
testFunCall = assertXRefsFrom ["basic/FunCall.hs"] $ do
    declAt (3,1) >>= singleUsage >>= assertAll
        [ refKindIs Call
        , includesPos (4,11)
        , refContextIs `funk` declAt (4,1)
        ]
    declAt (6,1) >>= singleUsage >>= assertAll
        [ refKindIs Ref
        , includesPos (7,13)
        , refContextIs `funk` declAt (7,1)
        ]
    declAt (9,1) >>= usages >>= \case
        [u1, u2] -> do
            flip assertAll u1
                [ includesPos (10,10)
                , refKindIs Call
                ]
            flip assertAll u2
                [ includesPos (10,12)
                , refKindIs Ref
                ]
        us -> checking $ assertFailure $ "Usage count differs: " ++ show us

-- | Tests that typeclass method usages are extracted.
-- Also includes test for types, as typeclass/instance types are trickier to
-- gather - but this test should be deeper + moved to type tests eventually.
testTypeClass :: AssertionInEnv
testTypeClass = assertXRefsFrom ["basic/TypeClass.hs"] $ do
    -- TODO(robinpalotai): have a separate set of tests where we only
    --   test the reported types of things. For type constructor-like things
    --   maybe we should report their kind instead.
    declAt (5,5) >>= assertAll
        [ singleUsage >=> includesPos (17,5)
          -- Unfortunately class method signatures come from the renamed
          -- (but not typechecked) source, so no fancy forall / contexts.
          -- Could synthetise them if needed, see 'top_matter' in GHC's
          -- HsDecls.
        , userFriendlyTypeIs "a"
        ]
    declAt (9,5) >>= userFriendlyTypeIs "Int"
    declAt (11,1) >>= userFriendlyTypeIs "forall a. Foo a => a -> String"
    -- Test the extracted relations.
    instanceDecl <- declAt (7,10)
    extraAlternateIdSpanContainsPos (7,1) instanceDecl
    declAt (3,7) >>= hasRelation InstantiatesClass instanceDecl
    bind2 (hasRelation ImplementsMethod) (declAt (9,5)) (declAt (5,5))
    -- TODO(robinpalotai): default method support

-- | Tests that calls in instance method bodies are emitted.
-- Also tests that instance methods have an identifier which includes the
-- class + instance name, to make it distinguishable from other instances'
-- method in the caller list.
testTypeClassRef :: AssertionInEnv
testTypeClassRef = assertXRefsFrom ["basic/TypeClassRef.hs"] $ do
    declAt (3,1) >>= singleUsage >>= assertAll
        [ refKindIs Call
        , includesPos (9,13)
        , refContextIs `funk` declAt (9,5)
        ]
    declAt (9,5) >>= extraMethodForInstanceIs "Foo ()"

-- | Tests that C-preprocessed files can be processed, and that declaration
-- locations refer to the original location (not offset by includes etc).
-- This is a smoke test, doesn't check declarations/references originating
-- to/from included files.
testCppInclude :: AssertionInEnv
testCppInclude = assertXRefsFromExtra ["basic/DummyInclude.hs"]
                                      ["basic/CppInclude.hs"] $
    declAt (4,1) >>= singleUsage >>= assertAll
        [ includesPos (8,30)
        , refContextIs `funk` declAt (8,1)
        ]

-- | Smoke test that TemplateHaskell works and references to TH-decls are
-- found. See also b/26456233.
testTemplateHaskellQuotation :: AssertionInEnv
testTemplateHaskellQuotation = assertXRefsFrom
      ["basic/TemplateHaskellQuotation.hs"] $
    -- Location for TH-generated decls is just the whole span of the runQ
    -- block - can live with that.
    declsAt (6, 3) >>= \case
        [f, v] -> do
            singleUsage f >>= includesPos (11,11)
            singleUsage v >>= includesPos (11,17)
        decls -> checking $
            assertFailure $ "Expected two decls from TH, but got " ++ show decls

testTemplateHaskellCodeExec :: AssertionInEnv
testTemplateHaskellCodeExec = assertXRefsFrom
      ["basic/TemplateHaskellCodeExec.hs", "basic/UsedByTH.hs"] $
    void $ declAt (8,1)

testTemplateHaskellWerrorOpt :: AssertionInEnv
testTemplateHaskellWerrorOpt = assertXRefsFrom
      ["-O2", "-Werror", "basic/TemplateHaskellQuotation.hs"] $
    return ()

testTemplateHaskellCodeExecFFI :: AssertionInEnv
testTemplateHaskellCodeExecFFI = assertXRefsFrom
      [ "basic/TemplateHaskellCodeExecFFI.hs"
      , "basic/ForeignImport.hs"
      , "basic/ffi.c"
      ] $
    void $ declAt (8,1)

-- TODO(https://github.com/google/haskell-indexer/issues/70): more infra tests.

testForeignImport :: AssertionInEnv
testForeignImport = assertXRefsFrom
      ["basic/ForeignImport.hs", "basic/ffi.c"] $
    -- If we get this far it compiles.
    -- TODO(robinpalotai): assert declaration once supported.
    return ()

testForeignExport :: AssertionInEnv
testForeignExport = assertXRefsFrom ["basic/ForeignExport.hs"] $
    void $ declAt (7,1)

testRtsArgsSkipped :: AssertionInEnv
testRtsArgsSkipped = assertXRefsFrom
      ["+RTS", "-A128M", "-RTS", "basic/ArgRef.hs"] $
    return ()

-- | Contains same name on type and term level, checks if usages go to the
-- correct one.
testDisambiguateTermType :: AssertionInEnv
testDisambiguateTermType = assertXRefsFrom ["basic/TypeVsTerm.hs"] $ do
    declAt (3,10) >>= singleUsage >>= includesPos (6,10)
    declAt (3,6)  >>= singleUsage >>= includesPos (5,11)

-- | Checks that an executable (which usually has package 'main' in GHC) gets a
-- more specific package by including the fallback (set as "dummyPkg" in
-- TestHelper).
testExecutableTickPackage :: AssertionInEnv
testExecutableTickPackage = assertXRefsFrom ["basic/ExecutableMain.hs"] $
    declAt (3,1) >>= declPropEquals
        (getPackage . tickPkgModule . declTick) "dummyPkg_main"

testLocalRef :: AssertionInEnv
testLocalRef = assertXRefsFrom ["basic/LocalRef.hs"] $ do
    declAt (8,5) >>= singleUsage >>= includesPos (6,32)
    declAt (16,5) >>= singleUsage >>= includesPos (14,34)

testRecordRead :: AssertionInEnv
testRecordRead = assertXRefsFrom ["basic/RecordRead.hs"] $ do
    declAt (4,12) >>= usages >>= \case
        -- Don't really caring about this, just a smoke check.
        u1:u2:_ -> do
            includesPos (6,9) u1
            includesPos (10,10) u2
        us -> checking $
            assertFailure $ "Different use count for ctor read: " ++ show us
    declAt (4,18) >>= usages >>= \case
        [u1, u2, u3, u4, u5, u6, u7, u8] -> do
            -- Simple accessor.
            includesPos (8,12) u1
            -- Unpacked field using record wildcards.
            includesPos (10,14) u2  -- Dotdots.
            includesPos (10,20) u3  -- Unpacked ref.
            -- Unpacked using punning.
            includesPos (12,12) u4  -- The pun.
            includesPos (12,21) u5  -- Unpacked ref.
            -- Unpacked using normal reassignment.
            includesPos (14,16) u6
            -- Wildcard mixed with normal extracted field.
            includesPos (19,20) u7  -- Dotdot.
            includesPos (19,26) u8  -- Unpacked ref.
        other -> checking $ assertFailure (
            "Different use count for field read: " ++ show other)
    -- The reassigned field.
    declAt (14,22) >>= singleUsage >>= includesPos (14, 29)
    -- Complex deconstructed fields should emit a reference from the place
    -- of deconstruction.
    declAt (16,26) >>= singleUsage >>= includesPos (17,24)

testRecordWrite :: AssertionInEnv
testRecordWrite = assertXRefsFrom ["basic/RecordWrite.hs"] $ do
    declAt (4,12) >>= usages >>= \case
        [u1, u2, u3, u4, u5, u6] -> do
            includesPos (9,10) u1
            includesPos (11,26) u2
            includesPos (16,8) u3
            includesPos (21,8) u4
            includesPos (25,14) u5
            includesPos (25,24) u6
        xs -> checking $ assertFailure
            ("Different use count for ctor ref: " ++ show (length xs))
    declAt (5,7) >>= usages >>= \case
        [u1, u2, u3, u4, u5, u6, u7] -> do
            includesPos (11,41) u1  -- Explicit record field assignment.
            --
            includesPos (14,9) u2   -- Wildcard preparation.
            includesPos (16,12) u3  -- Wildcard dots.
            --
            includesPos (19,9) u4   -- Pun preparation.
            includesPos (21,12) u5  -- Pun record write.
            -- Wildcard unpack without use + write with assignment.
            includesPos (25,18) u6  -- Unpack (not really a write).
            includesPos (26,7) u7   -- Assignment.
        xs -> checking $ assertFailure
            ("Different use count for 'foo' write: " ++ show (length xs))
    declAt (6,7) >>= usages >>= \case
        [u1, u2, u3, u4, u5, u6, u7, u8, u9] -> do
            -- Normal field write.
            includesPos (11,32) u1
            -- Wildcard write.
            includesPos (15,9) u2   -- Preparation.
            includesPos (16,12) u3  -- Dots.
            -- Trailing wildcard write.
            includesPos (20,9) u4   -- Preparation.
            includesPos (21,16) u5  -- Trailing wildcard dots.
            -- Record update.
            includesPos (23,16) u6
            -- Unpack from wildcard and write value.
            includesPos (25,18) u7  -- Dots.
            includesPos (27,7) u8   -- Field specifier.
            includesPos (27,13) u9  -- Assigned value.
        xs -> checking $ assertFailure
            ("Different use count for 'bar' write: " ++ show (length xs))
    -- Multi-ctor field update.
    -- TODO(robinpalotai): the non-first ctor's fields should refer that of the
    --   first instead of introducing a decl (as happens in the AST).
    declAt (30,18) >>= singleUsage >>= includesPos (32,23)

-- | Banging fields (and some other things) makes the Wrapper Id to be used
-- instead of the Worker / DataCon Id. If we don't handle this, we wouldn't
-- be able to refer the data constructor.
testDataConWrap :: AssertionInEnv
testDataConWrap = assertXRefsFrom ["basic/DataConWrap.hs"] $
    declAt (3,12) >>= singleUsage >>= includesPos (5,8)

-- | Test that source locations are reported in characters and not bytes. Also
-- verifies that GHC accepts UTF-8 encoding errors as long as those are just in
-- the comments.
--
-- Warning: as the source file contains encoding error, take care if editing it.
-- For example, some text editors refuse to open it at all, and some will
-- replace the bad sequence with something else. Please verify with a hexeditor.
testUtf8 :: AssertionInEnv
testUtf8 = assertXRefsFrom ["basic/Utf8.hs"] $
    declAt (6,1) >>= usages >>= \case
        [u1, u2] -> do
            spanIs (8,7) (8,10) u1
            spanIs (8,14) (8,17) u2
        xs -> checking $ assertFailure
            ("Different use count for unicodey var: " ++ show (length xs))

-- | Test that the module imports are emitted.
testImports :: AssertionInEnv
testImports = assertXRefsFrom ["basic/Imports.hs"] $ do
    importAt (3, 8) "Data.Int"
    importAt (4, 8) "Data.List"

assertRefKind :: ReferenceKind -> TickReference -> ReaderT XRef IO ()
assertRefKind expected tick =
  let actual = refKind tick
   in unless (actual == expected)
        $ checking
        $ assertFailure
        $ show expected ++ " expected; got " ++ show actual

testImpExpRefs :: AssertionInEnv
testImpExpRefs = assertXRefsFrom ["basic/ImpExpDefs.hs", "basic/ImportRefs.hs"]
  $ do
    -- foo
    declAt (9, 1) >>= usages >>= \case
      [u1, u2, u3] -> do
        includesPos (3, 25) u1 -- import statement in ImportRefs.hs
        assertRefKind Import u1
        includesPos (4, 5) u2 -- export list in ImpExpDefs.hs
        includesPos (8, 1) u3 -- type signature in ImpExpDefs.hs
      us -> checking $
        assertFailure $ "Usage count differs for foo: " ++ show us
    -- bar
    declAt (12, 1) >>= usages >>= \case
      [u1, u2, u3] -> do
        includesPos (3, 5) u1 -- export list in ImpExpDefs.hs
        includesPos (3, 20) u2 -- import statement in ImportRefs.hs
        assertRefKind Import u2
        includesPos (11, 1) u3 -- type signature in ImpExpDefs.hs
      us -> checking $
        assertFailure $ "Usage count differs for bar: " ++ show us
    -- FooBar
    declAt (14, 6) >>= usages >>= \case
      [u1, u2, u3, u4] -> do
        includesPos (2, 5) u1 -- export list in ImpExpDefs.h
        includesPos (4, 20) u2
        includesPos (5, 20) u3
        includesPos (6, 20) u4
      us -> checking $
        assertFailure $ "Usage count differs for FooBar: " ++ show us
    -- MkFooBar
    declAt (15, 5) >>= usages >>= \case
      [u1, u2] -> do
        includesPos (2, 13) u1 -- export list in ImpExpDefs.h
        includesPos (6, 28) u2
      us -> checking $
        assertFailure $ "Usage count differs for MkFooBar: " ++ show us
    -- fbFoo
    declAt (16, 9) >>= usages >>= \case
      [u1, u2] -> do
        includesPos (2, 23) u1 -- export list in ImpExpDefs.h
        includesPos (6, 38) u2
      us -> checking $
        assertFailure $ "Usage count differs for fbFoo: " ++ show us
    -- fbBar
    declAt (17, 9) >>= usages >>= \case
      [u1, u2] -> do
        includesPos (2, 30) u1 -- export list in ImpExpDefs.h
        includesPos (6, 45) u2
      us -> checking $
        assertFailure $ "Usage count differs for fbBar: " ++ show us

testImportRefsHiding :: AssertionInEnv
testImportRefsHiding =
  assertXRefsFrom ["basic/ImpExpDefs.hs", "basic/ImportRefsHiding.hs"]
    $ do
      declAt (12, 1) >>= usages >>= \case
        [u1, u2, u3] -> do
          includesPos (3, 5) u1 -- export list in ImpExpDefs.hs
          includesPos (3, 27) u2 -- import statement in ImportRefsHiding.hs
          assertRefKind Ref u2
          includesPos (11, 1) u3 -- type signature in ImpExpDefs.hs
        us -> checking $
          assertFailure $ "Usage count differs for bar: " ++ show us

testDocUri :: AssertionInEnv
testDocUri = assertXRefsFrom ["basic/DocUri.hs"] $ do
  moduleDocUriDecl "base" "Data.Maybe.html"
    >>= singleModuleDocUriDeclImport -- Data.Maybe
    >>= includesPos (3, 8)
  docUriDecl "base" "GHC.Maybe.html" "#Maybe"
    >>= singleDocUriDeclUsage -- Maybe
    >>= includesPos (5, 7)
  docUriDecl "base" "Data.Maybe.html" "#catMaybes"
    >>= docUriDeclUsages -- catMaybes
    >>= \case
      [u1, u2] -> do
        includesPos (3, 20) u1
        includesPos (6, 5) u2
      us ->
        checking
          $ assertFailure
          $ "Usage count differs for catMaybes: " ++ show us

testPatternSynonyms :: AssertionInEnv
testPatternSynonyms = assertXRefsFrom ["basic/PatSyn.hs"] $ do
    declAt (4, 9) >>= singleUsage >>= includesPos (6, 15)
    declAt (8, 9) >>= usages >>= \case
      [u1, u2] -> do
        includesPos (10, 14) u1
        includesPos (12, 14) u2
      us -> checking $
        assertFailure $ "Usage count differs for BiSingle: " ++ show us

testTypeOperators :: AssertionInEnv
testTypeOperators = assertXRefsFrom ["basic/TypeOperators.hs"] $ do
    declAt (5, 8) >>= singleUsage >>= includesPos (7, 22)

-- | Prepares the tests to run with the given test environment.
allTests :: TestEnv -> [Test]
allTests env =
    [ envTestCase "arg-ref" testArgRef
    , envTestCase "recursive-ref" testRecursiveRef
    , envTestCase "data-decl" testDataDecl
    , envTestCase "fun-call" testFunCall
    , envTestCase "typeclass" testTypeClass
    , envTestCase "typeclass-ref" testTypeClassRef
    , envTestCase "cpp-include" testCppInclude
    , envTestCase "th-quotation" testTemplateHaskellQuotation
    , envTestCase "th-code-exec" testTemplateHaskellCodeExec
    , envTestCase "th-code-exec-ffi" testTemplateHaskellCodeExecFFI
    , envTestCase "th-werror-opt" testTemplateHaskellWerrorOpt
    , envTestCase "foreign-import" testForeignImport
    , envTestCase "foreign-export" testForeignExport
    , envTestCase "rts-args-skipped" testRtsArgsSkipped
    , envTestCase "disambiguate-term-type" testDisambiguateTermType
    , envTestCase "executable-package" testExecutableTickPackage
    , envTestCase "local-ref" testLocalRef
    , envTestCase "record-read" testRecordRead
    , envTestCase "record-write" testRecordWrite
    , envTestCase "data-con-wrap" testDataConWrap
    , envTestCase "utf8" testUtf8
    , envTestCase "imports" testImports
    , envTestCase "import-export-refs" testImpExpRefs
    , envTestCase "import-refs-hiding" testImportRefsHiding
    , envTestCase "doc-uri" testDocUri
    , envTestCase "pattern-synonyms" testPatternSynonyms
    , envTestCase "type-operators" testTypeOperators
    ]
  where
    envTestCase name test = testCase name (runReaderT test env)
