{-# LANGUAGE RankNTypes,DeriveDataTypeable #-}
{-# OPTIONS -Wall #-}
module Language.Haskell.HBB.Internal.GHCHighlevel (
    searchFunctionBinding,
    searchFunctionBindingM,
    searchFunctionBindingForNameM,
    searchTokenForNameM,
    getThingsAt,
    getSortedLHsExprsAt, SearchTokenException(..),
    GetVariableLexerException(..),
    SearchedTokenInfo(..),
    FunBindInfo,
    BufSpan(..),
    BufLoc(..)
    ) where

-- This file contains a high-level wrapper for GHC functionalities.  It uses
-- the lower-level functionalities from GHC, AST and Lexer to provide
-- easy-to-use blocks of functionalities.
--
--         +-----------------+
--         | LibGHCHighlevel |
--         +-----------------+
--                | | |
--                | | |
--      +---------+ | +-------+----------+
--      |           |         |          |
--      v           v         v          v
--    +----+    +-----+  +-------+  +---------+
--    |GHC |    | AST |  | Lexer |  | SrcSpan |
--    +----+    +-----+  +-------+  +---------+
--

import Language.Haskell.HBB.Internal.SrcSpan
import Language.Haskell.HBB.Internal.Lexer
import Language.Haskell.HBB.Internal.AST
import Language.Haskell.HBB.Internal.GHC
import Control.Exception (throw,Exception)
import Data.Generics
import FastString (mkFastString)
import Outputable
import Data.Maybe (fromJust)
import Data.List (sortBy)
import GHC.Paths (libdir) -- GHC.Paths is available via cabal install ghc-paths
import GhcMonad
import SrcLoc (realSrcSpanStart,realSrcSpanEnd,mkRealSrcSpan,mkRealSrcLoc)
import Name (nameModule_maybe)
import GHC

-- FunBindInfo is the type returned by the function 'searchFunctionBinding'.
data SearchedTokenInfo a = SearchedTokenInfo { 
                 -- | GHC internally uses Outputable for things that may be
                 -- printed to the user for example.  As the printing functions
                 -- depend on the DynFlags used at compilation they can't be
                 -- used any more when the GHC run has finished. So 'printFun'
                 -- uses a closure to save the DynFlags in a curried function
                 -- to make it possible for clients to get a string
                 -- representation of a GHC internal data type.
                 printFun :: (forall b. Outputable b => b -> String)
                 -- | This is the Src-Span covering the full function name the
                 -- searchFunctionBinding function has determined (the
                 -- function gets passed only a certain point in a file
                 -- pointing to a (part) of the function name)
               , occSpan  :: RealSrcSpan
                 -- | The name that was at the location that has been passed to
                 -- searchFunctionBinding(M). In the case of inlining the name
                 -- is what is to be replaced by the function definition. This
                 -- name is completely enclosed by occSpan.
               , name     :: Name
                 -- | The type of the result is determined by the GenericQ a
                 -- passed as parameter.
               , result   :: a }

type FunBindInfo = SearchedTokenInfo (LHsBindLR Name Name,Maybe (LSig Name))

-- | These are exceptions searchFunctionBinding(M) may throw.
--
-- Each exception can be converted to a meaningful string. Moreover
-- searchFunctionBinding is throwing internal errors via error (exception
-- ErrorCall must be catched).
data SearchTokenException = LexingSearchError GetVariableLexerException
                          | TokenIsntAName
                          | TokenNotEndingAccordingly
                          | IsFunctionApplication
                          | IsExternalName ModuleName
                          | IsntNameOfABinding       -- The name at this location refers to for example a function parameter
                          deriving (Typeable)

instance Show SearchTokenException where
    show (LexingSearchError LexingFailed) = "Lexing failed. Input file isn't valid Haskell"
    show (LexingSearchError VarNotFound ) = "There is no variable at the specififed location"
    show  TokenIsntAName            = "Didn't find an name at the specified location.\n" ++
                                      "(Is this really an expression or something like a function parameter?)"
    show  TokenNotEndingAccordingly = "There is at least one name starting at the location but none ending accordingly.\n" ++
                                      "Did you specify the end of the source-span correctly?"
    show  IsFunctionApplication     = "This seems to be a function application of which inlining isn't supported so far."
    show (IsExternalName m)         = "The name refers to an external binding (module " ++ moduleNameString m ++ ")"
    show  IsntNameOfABinding        = "No according function binding found.\n" ++
                                      "Is this really the name of a binding (or for example a parameter to a function)?"

instance Exception SearchTokenException

-- | Parses the renamed AST of the module and returns all elements that start
-- at the passed location sorted by length in increasing oder.
getThingsAt 
    :: (GhcMonad m,Typeable a) 
    -- | Tells how to extract the span of an a.  If the a element is at the
    -- BufLoc specified then the according BufSpan is returned. Note that the
    -- results are sorted by the end location of the BufSpan that is returned
    -- here. So if this function returns weird data then the sorting of the
    -- results is not warranted.
    => (a -> BufLoc -> Maybe BufSpan) 
    -> FilePath       -- ^ The filename of the module that should be considered.
    -> BufLoc         -- ^ The required start-location of the tokens.
    -> m [a]          -- ^ A sorted list of results.
getThingsAt isAtLoc filename location = do

    loadTargetsFromFilename filename

    let asTypeOf' :: a -> (a -> BufLoc -> Maybe BufSpan) -> a
        asTypeOf' a _ = a

    checkedMod <- searchModGraphFor (Left filename) >>= return . snd >>= parseModule >>= typecheckModule

    let (rnSource,_,_,_) = fromJust $ tm_renamed_source checkedMod

        locateIt s x = case isAtLoc x s of 
            Nothing            -> []
            Just (BufSpan _ e) -> [(x,e)]

        collectedExprs = queryRenamedAST [] (++) (mkQ [] (\x -> locateIt location (asTypeOf' x isAtLoc))) rnSource

    return $ map fst $ sortBy sortByEnding collectedExprs
        where
            sortByEnding :: (a,BufLoc) -> (a,BufLoc) -> Ordering
            sortByEnding (_,end1) (_,end2) = end1 `compare` end2

-- | Returns a list of (LHsExpr Name) instances that start at the passed
-- position. The first instance is the shortest match which means that it spans
-- fewest character. This is the name of the function that should be applied or
-- the name of the value bindings.
getSortedLHsExprsAt :: GhcMonad m => FilePath -> BufLoc -> m [LHsExpr Name]
getSortedLHsExprsAt filename location = getThingsAt extractBufSpan filename location
    where extractBufSpan :: LHsExpr Name -> BufLoc -> Maybe BufSpan
          extractBufSpan (L (RealSrcSpan r) (HsVar _  )) bl = if (spanStart $ toBufSpan r) == bl then Just $ toBufSpan r else Nothing
          extractBufSpan (L (RealSrcSpan r) (HsApp _ _)) bl = if (spanStart $ toBufSpan r) == bl then Just $ toBufSpan r else Nothing
          extractBufSpan _                               _  = Nothing

-- | This function takes a file name and the location that is of interest and
-- searches out the value or function binding for the name that stands at this
-- location. The returned value contains all informations that are needed to
-- inline the function definition or describe how to inline it (smart-inline).
--
-- If the name refers to a name that is not part of the module graph (because
-- it has been loaded by a library for example) this function will fail.
searchFunctionBinding :: FilePath -> BufLoc -> Maybe BufLoc -> IO FunBindInfo
searchFunctionBinding filename loc1 mbBL =
    runGhc (Just libdir) $ searchFunctionBindingM filename loc1 mbBL

-- | This is the monadic version of searchFunctionBinding which assumes that
-- there is a preconfigured GHC.
searchFunctionBindingM :: GhcMonad m => FilePath -> BufLoc -> Maybe BufLoc -> m FunBindInfo
searchFunctionBindingM filename loc1 mbBL = do

    updateDynFlagsToSuppressFileOutput

    (blStart,blEnd) <- case mbBL of
        Nothing -> do
            lexerResult  <- getVariableIdUsingLexerAt (filename,loc1) ExcludeQualifiedVars

            let (_,rSpan) = case lexerResult of Right x -> x
                                                Left  x -> throw (LexingSearchError x)
            return ((toBufLoc $ realSrcSpanStart rSpan) 
                   ,(toBufLoc $ realSrcSpanEnd   rSpan))
        Just loc2 -> return (loc1,loc2)

    -- We search out the name that is at the position specified.
    -- With the name it is possible to get out the module and the location
    -- where the function or value bindings is defined.
    ourName <- do

        -- getSortedLHsExprsAt returns a sorted list where the first element covers
        -- the smallest range (it is directly a (LHsExpr Name) and no function
        -- application).
        exprs <- getSortedLHsExprsAt filename blStart

        let endsAt :: SrcSpan -> BufLoc -> Bool
            endsAt (RealSrcSpan r) l = l == (toBufLoc $ realSrcSpanEnd r)
            endsAt _               _ = False

        case exprs of
            [] -> throw TokenIsntAName
            xs -> case [ e | (L l e) <- xs , l `endsAt` blEnd ] of
                  []  -> throw TokenNotEndingAccordingly
                  [(HsVar n)]   -> return n
                  [(HsApp _ _)] -> throw IsFunctionApplication
                  _             -> error "Internal error (too much results for matching expressions)."

    searchFunctionBindingForNameM (ourName,(BufSpan blStart blEnd),filename)

data FunBindAndSig = FunBindAndSig [LHsBindLR Name Name] [LSig Name]

joinFunBindAndSig :: FunBindAndSig -> FunBindAndSig -> FunBindAndSig
joinFunBindAndSig (FunBindAndSig b1 s1) (FunBindAndSig b2 s2) = FunBindAndSig (b1 ++ b2) (s1 ++ s2)

-- | This version to search a function binding takes a Name and some details
-- about it.
searchFunctionBindingForNameM :: GhcMonad m => (Name,BufSpan,FilePath) -> m FunBindInfo
searchFunctionBindingForNameM (ourName,nameSpan,filename) = do

    let genericQuery :: BufLoc -> GenericQ FunBindAndSig
        genericQuery = 

            let hasSearchedStartLoc :: BufLoc -> SrcSpan -> Bool
                hasSearchedStartLoc loc (RealSrcSpan rss) =
                    loc == (toBufLoc $ realSrcSpanStart rss)
                hasSearchedStartLoc _   _ = False
                
                -- This function is used to create a generic SYB-query to collect the function
                -- bindings (usually only one) start start at a certain location.
                locateFunctionsQ :: BufLoc -> (LHsBindLR Name Name) -> FunBindAndSig
                locateFunctionsQ loc x@(L l (FunBind {})) | hasSearchedStartLoc loc l = FunBindAndSig [x] []
                -- Pattern bindings (e.g. sq :: Int -> Int = \x -> x * x)
                -- are also collected to be able to give a clear message to the user...
                locateFunctionsQ loc x@(L l (PatBind {})) | hasSearchedStartLoc loc l = FunBindAndSig [x] []
                locateFunctionsQ _     (L _ (VarBind {}))                             =
                    error $ "Internal error (unexpected VarBind: " ++ 
                            "GHC doc says that they are introduced by the typechecker)"
                locateFunctionsQ _     (L _ (AbsBinds {}))                            =
                    error $ "Internal error (unexpected AbsBind: " ++ 
                            "GHC doc says that they are introduced by the typechecker)"
                locateFunctionsQ _     _                                              = FunBindAndSig [] []


                sigQ :: Name -> BufLoc -> HsValBindsLR Name Name -> FunBindAndSig -- [LSig Name]
                sigQ na _ (ValBindsOut _ x) = FunBindAndSig [] (filter isCorrectSig x)
                    where
                        -- Tests proved that the location stored within
                        -- (LSig Name) contains weird data. Therefore the
                        -- name is used for the comparison (which should be
                        -- better anyway)...
                        isCorrectSig :: LSig Name -> Bool
                        isCorrectSig (L _ (TypeSig lNames _)) = any (\(L _ n) -> n == na) lNames
                        isCorrectSig _                        = False
                sigQ _ _ _ = FunBindAndSig [] []

            in  (\x -> mkQ (FunBindAndSig [] []) (locateFunctionsQ x) `extQ` (sigQ ourName x))

    sti@(SearchedTokenInfo {
        result = (FunBindAndSig funBinds sigs)
        }) <- 
        searchTokenForNameM 
            (ourName,nameSpan,filename)
            (FunBindAndSig [] [])
            joinFunBindAndSig
            genericQuery

    let ourFun = case funBinds of 
            []                     -> throw IsntNameOfABinding
            [b@(L _ (FunBind {}))] -> b
            [b@(L _ (PatBind {}))] -> b
            _                      -> error "Internal error (more that one matching function binding found)"

    let ourSig = case sigs of 
            []    -> Nothing
            (x:_) -> Just x
    
    fgs <- getSessionDynFlags

    return SearchedTokenInfo { printFun = showPpr fgs
                             , occSpan  = occSpan sti
                             , name     = name    sti
                             , result   = (ourFun,ourSig) }

-- | This is a generic function that takes informations about a Name and
-- queries the renamed AST according to the parameters.
searchTokenForNameM 
    :: GhcMonad m 
    => (Name,BufSpan,FilePath) -- ^ informations about the Name instance, its location and the file 
    -> b                       -- ^ neutral result
    -> (b -> b -> b)           -- ^ function to join 2 results
    -> (BufLoc -> GenericQ b)  -- ^ generic query (special cases) for the
                               --   result, produced by 'mkQ' for example...
    -> m (SearchedTokenInfo b)
searchTokenForNameM (ourName,nameSpan,filename) neutralResult joinResult queryResult = do

    let startLoc = case nameSrcSpan ourName of
             (RealSrcSpan rss) -> toBufLoc $ realSrcSpanStart rss
             _                 -> 
                -- In this case the name doesn't refer to the current unit of compilation
                -- but to a library. We throw an exception but insert the module name.
                throw $ IsExternalName (moduleName $ nameModule ourName)

    renamedAST <- do
        modSum <- do
            -- Ok now there are two possibilities.
            -- Either the name refers to something at module scope (a name
            -- defined in this or another module) or it refers to a nested
            -- function binding.
            -- In the first case 'nameModule_maybe' will return the module of
            -- interest. In the second case the binding must be located in the
            -- same module as the name. We cycle through the module graph to
            -- find the current module and return it.
            modName <- case nameModule_maybe ourName of
                       Just m  -> return $ moduleName m
                       Nothing -> searchModGraphFor (Left filename) >>= return . fst
            getModSummary modName
                                        
        extractRenamedAST modSum

    let ourResult = queryRenamedAST neutralResult joinResult (queryResult startLoc) renamedAST

        occurrenceSpan :: RealSrcSpan
        occurrenceSpan = 
            let (BufLoc l1 c1) = spanStart nameSpan
                (BufLoc l2 c2) = spanEnd   nameSpan
            in mkRealSrcSpan (mkRealSrcLoc (mkFastString filename) l1 c1) 
                             (mkRealSrcLoc (mkFastString filename) l2 c2) 

    getSessionDynFlags >>= (\fgs -> return SearchedTokenInfo { 
                                                printFun = showPpr fgs
                                              , occSpan  = occurrenceSpan
                                              , name     = ourName
                                              , result   = ourResult })