{-# OPTIONS -Wall #-}

module Language.Haskell.HBB.OccurrencesOf (
    occurrencesOf,
    occurrencesOfM,
    showOccurrencesOfResult,
    BufLoc(..),
    BufSpan(..)
    ) where

import Language.Haskell.HBB.Internal.GHCHighlevel
import Language.Haskell.HBB.Internal.SrcSpan
import Language.Haskell.HBB.Internal.Lexer
import Language.Haskell.HBB.Internal.GHC
import Language.Haskell.HBB.Internal.AST
import System.Directory (getCurrentDirectory)
import Control.Monad (foldM)
import Data.Generics
import FastString (unpackFS)
import GHC.Paths (libdir)
import Data.List (union)
import GhcMonad (liftIO)
import HsBinds
import SrcLoc
import Name
import GHC

--
-- This file deals with the renaming of names that point to bindings (value and
-- function bindings but not pattern bindings).
--

-- | This function takes a location, searches out what is at this location and
-- then returns a list of all occurrences of this identifier. This currently
-- works for names of function- and value bindings.
occurrencesOf 
    :: [String]   -- ^ A list of ghc options (e.g. @["-isrc"]@)
    -> FilePath   -- ^ The file where the token to rename resides in
    -> BufLoc     -- ^ The location where the token to rename is
    -> [FilePath] -- ^ A list of further files which possibly contain this token and
                  -- which should be searched for it
    -> IO [(FilePath,BufSpan)]
occurrencesOf ghcOptions filename reqLoc otherFiles = 
    runGhcWithCmdLineFlags ghcOptions (Just libdir) $ occurrencesOfM filename reqLoc otherFiles

-- | This is the monadic version of occurrencesOf which allows to use this mode
-- of operation from a preconfigured GHC environment.
occurrencesOfM :: GhcMonad m => FilePath -> BufLoc -> [FilePath] -> m [(FilePath,BufSpan)]
occurrencesOfM occFile' loc otherFiles' = do

    cwd <- liftIO $ getCurrentDirectory
    
    -- We normalize the filenames to be able to use 'union' from
    -- 'Data.List' to merge them.
    let occFile    =     (normalisePath cwd)    occFile'
        otherFiles = map (normalisePath cwd) otherFiles'

    resLocs <- do

        updateDynFlagsToSuppressFileOutput

        res <- getVariableIdUsingLexerAt (occFile,loc) IncludeQualifiedVars
        let spanIdentifiedByLexer = case res of
                Left VarNotFound  -> error "It seems that there is no variable at this point?!"
                Left LexingFailed -> error "Lexing failed. The source code seems to contain errors."
                Right (_,rSpn)    -> toBufSpan rSpn

        processToken cwd occFile spanIdentifiedByLexer otherFiles
    
    return $ map (\x -> unpackRealSrcSpan x) resLocs

-- | This Function formats the results from the occurrencesOf or occurrencesOfM
-- function.
showOccurrencesOfResult 
    :: [(FilePath,BufSpan)] -- ^ The result that should be shown
    -> String
showOccurrencesOfResult elems = sOORAcc [] elems
    where
        sOORAcc :: [String] -> [(FilePath,BufSpan)] -> String
        sOORAcc acc []    = unlines $ reverse acc
        sOORAcc acc (e:r) = sOORAcc ((showSpan Nothing e):acc) r

-- | This function detects what is at the position specified (the token) and
-- according to this information it searches all references to this thing.
processToken :: GhcMonad m => FilePath -> FilePath -> BufSpan -> [FilePath] -> m [RealSrcSpan]
processToken cwd occFile spn@(BufSpan (BufLoc _ c1) (BufLoc _ c2)) otherFiles = do

    let processTokenAsBinding :: GhcMonad m => (LHsBindLR Name Name) -> m [RealSrcSpan]
        processTokenAsBinding (L _        (PatBind  _ _ _ _ _) ) = error "The token refers to a so-called pattern binding which aren't supported so far."
        processTokenAsBinding (L _        (AbsBinds _ _ _ _ _) ) = error "Internal error (unexpected AbsBinds in the renamed AST)."
        processTokenAsBinding (L _        (VarBind  _ _ _    ) ) = error "Internal error (unexpected VarBind  in the renamed AST)."
        processTokenAsBinding (L rs bind@(FunBind { fun_id = (L _ n) } ) ) = do

            let bindingFile :: [FilePath]
                bindingFile = case srcSpanFileName_maybe rs of
                                Nothing -> []
                                Just fs -> [normalisePath cwd $ unpackFS fs]

            referrers <- foldM 
                            (accumulateThingsThatRefer n)
                            [] (bindingFile `union` [occFile] `union` otherFiles)
            definitions <- return $ realSrcSpansOfBinding (c2 - c1) bind

            return $ definitions ++ referrers

    let processTokenAsFunParam :: GhcMonad m => LPat Name -> m [RealSrcSpan]
        processTokenAsFunParam (L (RealSrcSpan rs) (VarPat _)) = do

            referrers <- do
                    setTargets [fileToTarget occFile]

                    _ <- load LoadAllTargets -- Depending on the HscTarget this will create
                                             -- intermediate files (set HscNothing to
                                             -- suppress)

                    (_,currentModSum) <- searchModGraphFor (Left occFile)

                    renSource <- extractRenamedAST currentModSum

                    let locateLHsExprThatReferTo :: BufLoc -> LHsExpr Name -> [LHsExpr Name]
                        locateLHsExprThatReferTo l1 x@(L (RealSrcSpan _) (HsVar n)) =
                            case nameSrcSpan n of
                                UnhelpfulSpan _ -> []
                                RealSrcSpan   r -> if l1 == l2 then [x] else []
                                    where l2 = spanStart $ toBufSpan r
                        locateLHsExprThatReferTo _  _                       = []

                        genericQuery :: GenericQ [LHsExpr Name]
                        genericQuery = mkQ [] (locateLHsExprThatReferTo $ spanStart $ toBufSpan rs)

                    let exprs = queryRenamedAST [] (++) genericQuery renSource

                    return [ r | (L (RealSrcSpan r) _) <- exprs ]

            return $ [rs] ++ referrers

        processTokenAsFunParam _ = error "Internal error (unsupported instance of LPat Name)"

    what <- whatIsAt occFile spn

    locs <- case what of
        ThereIsAnExternalName                 _  -> error $ "The token is referring to external functionality"
        ThereIsAnIEDeclToExtern               _  -> error $ "Import/Export declaration is referring to external functionality"
        ThereIsAnIEDeclFor (ThereIsABinding   b) -> processTokenAsBinding  b
        ThereIsAnIEDeclFor _                     -> error "Internal error (unexpected reference to non-binding in IEDecl)"
        ThereIsANameFor (ThereIsABinding      b) -> processTokenAsBinding  b
        ThereIsANameFor (ThereIsAFunParameter p) -> processTokenAsFunParam p
        ThereIsANameFor _                        -> error "Internal error (the name is referencing unexpected things)"
        ThereIsABinding                       b  -> processTokenAsBinding  b
        ThereIsAFunParameter                  p  -> processTokenAsFunParam p
        ThereIsATypeSigFor (ThereIsABinding   b) -> processTokenAsBinding  b
        ThereIsATypeSigFor _                     -> error "Internal error (name from type-sig is referencing unexpected things)"
        UnknownElement                           -> -- This point is currently never reached as
                                                    -- the lexer function will throw if it doesn't find
                                                    -- a qualified or non-qualified variable.
                                                    error $ "Unsupported operation. " ++ 
                                                            "Currently only names for bindings and function parameters are supported.\n" ++
                                                            "Moreover the infix notation in function definitions isn't supported either"

    let normaliseRealSrcSpan :: RealSrcSpan -> RealSrcSpan
        normaliseRealSrcSpan r = 
            let (f,bs) = unpackRealSrcSpan r
            in  packRealSrcSpan (normalisePath cwd f,bs)

    return $ map normaliseRealSrcSpan locs
                                                            
-- | This function searches the passed file for variables, import- or export-
-- declarations that refer to the name passed as first parameter.
accumulateThingsThatRefer :: GhcMonad m => Name -> [RealSrcSpan] -> FilePath -> m [RealSrcSpan]
accumulateThingsThatRefer defName acc currentFile = do

    setTargets [fileToTarget currentFile]

    _ <- load LoadAllTargets -- Depending on the HscTarget this will create
                             -- intermediate files (set HscNothing to
                             -- suppress)

    (_,currentModSum) <- searchModGraphFor (Left currentFile)

    renSource <- extractRenamedAST currentModSum

    -- There is one problem when searching for 'Name's that refer to something.
    -- There is the possibility that it is qualified (like for example
    -- 'A.hello'). For these cases we have to remember how long the name
    -- actually is and have to shorten the RealSrcSpan by the prefix ('A.)'.

    let spanLength :: BufSpan -> Int
        spanLength (BufSpan (BufLoc _ c1) (BufLoc _ c2)) = (c2 - c1)

        originalLength :: Int
        originalLength = spanLength $ spanToBufSpan $ nameSrcSpan defName
            where
                spanToBufSpan :: SrcSpan -> BufSpan
                spanToBufSpan (RealSrcSpan r) = toBufSpan r
                spanToBufSpan _               = error "Internal error (unexpected unhelpful span in accumulateThingsThatRefer)"

        referrers :: [RealSrcSpan]
        referrers =
            let getReferrersFromIE :: Name -> LIE Name -> [RealSrcSpan]
                getReferrersFromIE refName (L (RealSrcSpan r) (IEVar n)) | (refName == n) = [r]
                getReferrersFromIE _       _                                              = []

                getReferrersFromTypeSig :: Name -> Sig Name -> [RealSrcSpan]
                getReferrersFromTypeSig refName (TypeSig lNames _) =
                    case filter (\(L _ x) -> x == refName) lNames of
                        [L (RealSrcSpan r) _] -> [r]
                        _                     -> []
                getReferrersFromTypeSig _ _ = []

                getReferrersFromExprs :: Name -> LHsExpr Name -> [RealSrcSpan]
                getReferrersFromExprs refName (L (RealSrcSpan r) (HsVar n)) | (refName == n) = 
                    let oldEnd = realSrcSpanEnd r
                        newBeg = mkRealSrcLoc (srcLocFile oldEnd) (srcLocLine oldEnd) ((srcLocCol oldEnd) - originalLength)
                    in  [mkRealSrcSpan newBeg oldEnd]
                getReferrersFromExprs _ _ = []

                genericQuery :: GenericQ [RealSrcSpan]
                genericQuery = mkQ [] (getReferrersFromIE      defName) `extQ` 
                                      (getReferrersFromTypeSig defName) `extQ`
                                      (getReferrersFromExprs   defName)

            in  queryRenamedAST [] (++) genericQuery renSource

    return $ acc ++ referrers