{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables, PatternGuards, OverloadedStrings #-}
-----------------------------------------------------------------------------
--
-- Module      :  IDE.Metainfo.WorkspaceCollector
-- Copyright   :  2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie
-- License     :  GPL
--
-- Maintainer  :  maintainer@leksah.org
-- Stability   :  provisional
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------

module IDE.Metainfo.WorkspaceCollector (

    collectWorkspace

,   sortByLoc
,   attachComments
,   uncommentData
,   uncommentDecl
,   printHsDoc
,   toComment
,   srcSpanToLocation
,   sigToByteString

) where


import Control.Applicative hiding(empty)
import Prelude
import IDE.Utils.Utils
import IDE.Utils.GHCUtils
#if MIN_VERSION_ghc(7,10,0)
import GHC hiding(Id,Failed,Succeeded,ModuleName,PackageKey)
#else
import GHC hiding(Id,Failed,Succeeded,ModuleName)
import PackageConfig (mkPackageId)
#endif
#if !MIN_VERSION_ghc(7,2,0)
import HscTypes hiding (liftIO)
#endif
#if MIN_VERSION_ghc(7,6,0)
import Outputable hiding(trace, (<>))
#else
import Outputable hiding(trace, (<>), showSDoc, showSDocUnqual)
import qualified Outputable as O
#endif
import ErrUtils
import qualified Data.Map as Map
import Data.Map(Map)
import System.Directory
import Distribution.Package hiding (PackageId)
import Distribution.ModuleName
import System.FilePath
import qualified Data.ByteString.Char8 as BS
import Data.Binary.Shared
import IDE.Utils.FileUtils
import IDE.Core.Serializable ()
import IDE.Core.CTypes hiding (SrcSpan(..))
import Data.ByteString.Char8 (ByteString)
import DriverPipeline (preprocess)
import StringBuffer(hGetStringBuffer)
import Data.List(partition,sortBy,nub,find)
import Data.Ord(comparing)
import GHC.Exception
#if !MIN_VERSION_ghc(7,6,0)
import MyMissing(forceHead)
#endif
import LoadIface(findAndReadIface)
import Distribution.Text(display)
import TcRnMonad (initTcRnIf, IfGblEnv(..))
import qualified Maybes as M
import IDE.Metainfo.InterfaceCollector
import Data.Maybe
       (isJust, catMaybes, isNothing)
import PrelNames
import System.Log.Logger
import Control.DeepSeq (deepseq)
import FastString(mkFastString,appendFS,nullFS,unpackFS)
import Control.Monad.IO.Class (MonadIO, MonadIO(..))
import Control.Monad (when)
import Control.Exception as E
import Data.Text (Text)
import qualified Data.Text as T
import Data.Monoid ((<>))

type NDecl = LHsDecl RdrName
myDocEmpty :: NDoc
myDocAppend :: NDoc -> NDoc -> NDoc
isEmptyDoc :: NDoc -> Bool

type NDoc  = HsDocString
type MyLDocDecl = LDocDecl

myDocEmpty=HsDocString(mkFastString "")
myDocAppend (HsDocString l) (HsDocString r) = HsDocString (appendFS l r)
isEmptyDoc (HsDocString fs) = nullFS fs

type NSig  = Located (Sig RdrName)

#if !MIN_VERSION_ghc(7,6,0)
showSDoc :: DynFlags -> SDoc -> Text
showSDoc _ = O.showSDoc
showSDocUnqual :: DynFlags -> SDoc -> Text
showSDocUnqual _ = O.showSDocUnqual
#endif

showRdrName :: DynFlags -> RdrName -> Text
showRdrName dflags r = T.pack . showSDoc dflags $ ppr r

-- | Test
collectWorkspace :: PackageIdentifier -> [(Text,FilePath)] -> Bool -> Bool -> FilePath -> IO()
collectWorkspace pid moduleList forceRebuild writeAscii dir = do
    debugM "leksah-server" $ "collectWorkspace called with modules " ++ show moduleList ++ " in folder " ++ dir
    collectorPath <- liftIO $ getCollectorPath
    let packageCollectorPath = collectorPath </> T.unpack (packageIdentifierToString pid)
    when forceRebuild $ do
        exists <- doesDirectoryExist packageCollectorPath
        when exists $ removeDirectoryRecursive packageCollectorPath
    -- Construct directory
    liftIO $ createDirectoryIfMissing True packageCollectorPath
    setCurrentDirectory dir
    opts1 <- filterOpts <$> figureOutGhcOpts
    opts2 <- figureOutHaddockOpts

    debugM "leksah-server" $ ("before collect modules" ++ "\n\nopts1: " ++ show opts1 ++ "\n\n opt2: " ++ show opts2)
    mapM_ (collectModule packageCollectorPath writeAscii pid opts1) moduleList
    debugM "leksah-server" $ "after collect modules"
  where
    filterOpts :: [Text] -> [Text]
    filterOpts []    = []
    filterOpts (o:_:r) | o `elem` ["-link-js-lib", "-js-lib-outputdir", "-js-lib-src", "-package-id"] = filterOpts r
    filterOpts (o:r) = o:filterOpts r

collectModule :: FilePath -> Bool -> PackageIdentifier -> [Text] -> (Text,FilePath) -> IO()
collectModule collectorPackagePath writeAscii pid opts (modId,sourcePath) = do
    case parseModuleKey (T.unpack modId) sourcePath of
        Nothing -> errorM "leksah-server" (T.unpack $ "Can't parse module name " <> modId)
        Just modKey -> do
            let collectorModulePath = collectorPackagePath </> (moduleCollectorFileName modKey) <.> leksahMetadataWorkspaceFileExtension
                moduleName' = moduleKeyToName modKey
            existCollectorFile <- doesFileExist collectorModulePath
            existSourceFile    <- doesFileExist sourcePath
            if existSourceFile
                then do
                    if not existCollectorFile
                        then collectModule' sourcePath collectorModulePath writeAscii pid opts moduleName'
                        else do
                            sourceModTime <-  getModificationTime sourcePath
                            collModTime   <-  getModificationTime collectorModulePath
                            if sourceModTime > collModTime
                                then collectModule' sourcePath collectorModulePath writeAscii pid
                                        opts moduleName'
                                else return ()
                else errorM "leksah-server" ("source file not found " ++ sourcePath)


collectModule' :: FilePath -> FilePath -> Bool -> PackageIdentifier -> [Text] -> ModuleName -> IO()
collectModule' sourcePath destPath writeAscii pid opts moduleName' = gcatch (
    inGhcIO (opts++["-cpp"]) [Opt_Haddock] [] $ \ dynFlags -> do
        session         <-  getSession
#if MIN_VERSION_ghc(7,2,0)
        (dynFlags3,fp') <-  liftIO $ preprocess session (sourcePath,Nothing)
#else
        (dynFlags3,fp') <-  preprocess session (sourcePath,Nothing)
#endif
        let packIdAndKey = PackageIdAndKey pid
#if MIN_VERSION_ghc(7,10,0)
                                (thisPackage dynFlags3)
#endif
        mbInterfaceDescr <- mayGetInterfaceDescription dynFlags packIdAndKey moduleName'
        liftIO $ do
            stringBuffer    <-  hGetStringBuffer fp'
            parseResult     <-  myParseModule dynFlags3 sourcePath (Just stringBuffer)
            case parseResult of
                Right (L _ hsMod@(HsModule{})) -> do
                    let moduleDescr = extractModDescr dynFlags pid moduleName' sourcePath hsMod
                    let moduleDescr' = case mbInterfaceDescr of
                                            Nothing -> moduleDescr
                                            Just md  -> mergeWithInterfaceDescr moduleDescr md
                    E.catch (writeExtractedModule destPath writeAscii moduleDescr')
                        (\ (_:: IOException) -> errorM "leksah-server" ("Can't write extracted package " ++ destPath))
                Left errMsg -> do
                    errorM "leksah-server" $ "Failed to parse " ++ sourcePath ++ " " ++ show errMsg
                    let moduleDescr =  ModuleDescr {
                        mdModuleId          =   PM pid moduleName'
                    ,   mdMbSourcePath      =   Just sourcePath
                    ,   mdReferences        =   Map.empty -- imports
                    ,   mdIdDescriptions    =   [Real $ RealDescr {
                            dscName'        =   "Parse Error"
                        ,   dscMbTypeStr'   =   Nothing
                        ,   dscMbModu'      =   Just (PM pid moduleName')
#if MIN_VERSION_ghc(7,7,0)
                        ,   dscMbLocation'  =   srcSpanToLocation $ errMsgSpan errMsg
#else
                        ,   dscMbLocation'  =   case errMsgSpans errMsg of
                                                    (sp:_) -> srcSpanToLocation sp
                                                    [] -> Nothing
#endif
                        ,   dscMbComment'   =   Just (BS.pack $ show errMsg)
                        ,   dscTypeHint'    =   ErrorDescr
                        ,   dscExported'    =   False}]}
                    E.catch (deepseq moduleDescr $ writeExtractedModule destPath writeAscii moduleDescr)
                        (\ (_:: IOException) -> errorM "leksah-server" ("Can't write extracted module " ++ destPath))
    ) (\ (e :: SomeException) -> errorM "leksah-server" ("Can't extract module " ++ destPath ++ " " ++ show e))


writeExtractedModule :: MonadIO m => FilePath -> Bool -> ModuleDescr -> m ()
writeExtractedModule filePath writeAscii md =
    if writeAscii
        then liftIO $ writeFile (filePath ++ "dpg") (show md)
        else liftIO $ encodeFileSer filePath (metadataVersion, md)

-----------------------------------------------------------------------------------
-- Format conversion
#if MIN_VERSION_ghc(7,10,0)
unLoc710 :: GenLocated l e -> e
unLoc710 = unLoc
#else
unLoc710 :: a -> a
unLoc710 = id
#endif

extractModDescr :: DynFlags -> PackageIdentifier -> ModuleName -> FilePath -> HsModule RdrName -> ModuleDescr
extractModDescr dflags pid moduleName' sourcePath hsMod = ModuleDescr {
        mdModuleId          =   PM pid moduleName'
    ,   mdMbSourcePath      =   modFile $ hsmodName hsMod
    ,   mdReferences        =   Map.empty -- imports
    ,   mdIdDescriptions    =   descrs'}
    where
        descrs = extractDescrs dflags (PM pid moduleName') (hsmodDecls hsMod)
        descrs' = fixExports dflags (fmap unLoc710 $ hsmodExports hsMod) descrs
        modFile (Just (L loc _)) =
            (locationFile <$> srcSpanToLocation loc) <|> Just sourcePath
        modFile _ = Just sourcePath

-----------------------------------------------------------------------------------
-- Add exported hint

fixExports :: DynFlags -> Maybe [LIE RdrName] -> [Descr] -> [Descr]
fixExports _ Nothing descrs = descrs
fixExports dflags (Just iel) descrs = map (fixDescr (map unLoc iel)) descrs
    where
        fixDescr ::  [IE RdrName] -> Descr -> Descr
        fixDescr _ d@(Reexported _) = d
        fixDescr list (Real rd) = Real rd'
            where
                rd' = case dscTypeHint' rd of
                          VariableDescr   -> rd{dscExported' = isJust findVar}
                          InstanceDescr _ -> rd
                          _               -> case findThing of
                                                Nothing                -> nothingExported rd
                                                Just (IEThingAll _)    -> allExported rd
                                                Just (IEThingAbs _)    -> someExported rd []
                                                Just (IEThingWith _ l) -> someExported rd (map (showRdrName dflags . unLoc710) l)
                                                _                      -> allExported rd
                findVar = find (\ a ->
                            case a of
                                IEVar r | showRdrName dflags (unLoc710 r) == dscName' rd -> True
                                _                                     -> False)
                                    list
                findThing = find (\ a ->
                                case a of
                                IEThingAbs r | showRdrName dflags (unLoc710 r) == dscName' rd -> True
                                IEThingAll r | showRdrName dflags (unLoc710 r) == dscName' rd -> True
                                IEThingWith r _list | showRdrName dflags (unLoc710 r) == dscName' rd -> True
                                _                                     -> False)
                                    list
        allExported rd                                 = rd
        nothingExported rd                             = rd{dscExported' = False,
                                                             dscTypeHint' = nothingExportedS (dscTypeHint' rd)}
        nothingExportedS (DataDescr lsd1 lsd2)         = DataDescr (map (setExportedSD False) lsd1)
                                                            (map (setExportedSD False) lsd2)
        nothingExportedS (NewtypeDescr sd1 Nothing)    = NewtypeDescr (setExportedSD False sd1)
                                                            Nothing
        nothingExportedS (NewtypeDescr sd1 (Just _sd2)) = NewtypeDescr (setExportedSD False sd1)
                                                            (Just (setExportedSD False sd1))
        nothingExportedS (ClassDescr n lsd2)           = ClassDescr n (map (setExportedSD False) lsd2)
        nothingExportedS other                         = other

        someExported rd l                              = rd{dscExported' = True,
                                                            dscTypeHint' = someExportedS (dscTypeHint' rd) l}
        someExportedS (DataDescr lsd1 lsd2) l          = DataDescr (map (maySetExportedSD l) lsd1)
                                                            (map (maySetExportedSD l) lsd2)
        someExportedS (NewtypeDescr sd1 Nothing) l     = NewtypeDescr (maySetExportedSD l sd1)
                                                            Nothing
        someExportedS (NewtypeDescr sd1 (Just _sd2)) l  = NewtypeDescr (maySetExportedSD l sd1)
                                                            (Just (maySetExportedSD l sd1))
        someExportedS (ClassDescr n lsd2) l            = ClassDescr n (map (maySetExportedSD l) lsd2)
        someExportedS other _                          = other


        setExportedSD bool sd = sd{sdExported = bool}
        maySetExportedSD list sd = sd{sdExported = elem (sdName sd) list}


extractDescrs :: DynFlags -> PackModule -> [NDecl] -> [Descr]
extractDescrs dflags pm decls = transformToDescrs dflags pm tripleWithSigs
    where
        sortedDecls                    = sortByLoc decls
        pairedWithDocs                 = collectDocs sortedDecls
        filteredDecls                  = filterUninteresting pairedWithDocs
        (withoutSignatures,signatures) = partitionSignatures filteredDecls
        tripleWithSigs                 = attachSignatures dflags signatures withoutSignatures

-- | Sort by source location
sortByLoc :: [Located a] -> [Located a]
sortByLoc = sortBy (comparing getLoc)

filterUninteresting :: [(NDecl,Maybe NDoc)] -> [(NDecl,Maybe NDoc)]
filterUninteresting = filter filterSignature
    where
    filterSignature ((L _srcDecl (SpliceD _)),_)  = False
    filterSignature ((L _srcDecl (RuleD _)),_)    = False
    filterSignature ((L _srcDecl (WarningD _)),_) = False
    filterSignature ((L _srcDecl (ForD _)),_)     = False
    filterSignature ((L _srcDecl (DefD _)),_)     = False
    filterSignature _                            = True

partitionSignatures :: [(NDecl,Maybe NDoc)] -> ([(NDecl,Maybe NDoc)],[(NDecl,Maybe NDoc)])
partitionSignatures = partition filterSignature
    where
    filterSignature ((L _srcDecl (SigD _)),_) = False
    filterSignature _ = True

--partitionInstances :: [(NDecl,Maybe NDoc)] -> ([(NDecl,Maybe NDoc)],[(NDecl,Maybe NDoc)])
--partitionInstances i = (i,[])
--partition filterInstances
--    where
--    filterInstances ((L srcDecl (InstD _)),_) = False
--    filterInstances _ = True

-- | Collect the docs and attach them to the right declaration.
collectDocs :: [LHsDecl RdrName] -> [(LHsDecl RdrName, (Maybe NDoc))]
collectDocs = collect Nothing myDocEmpty

collect :: Maybe (LHsDecl RdrName) -> NDoc -> [LHsDecl RdrName] -> [(LHsDecl RdrName, (Maybe (NDoc)))]
collect d doc_so_far [] =
   case d of
        Nothing -> []
        Just d0  -> finishedDoc d0 doc_so_far []

collect d doc_so_far (e:es) =
  case e of
    L _ (DocD (DocCommentNext str)) ->
      case d of
        Nothing -> collect d (myDocAppend doc_so_far str) es
        Just d0 -> finishedDoc d0 doc_so_far (collect Nothing str es)

    L _ (DocD (DocCommentPrev str)) -> collect d (myDocAppend doc_so_far str) es

    _ -> case d of
      Nothing -> collect (Just e) doc_so_far es
      Just d0 -> finishedDoc d0 doc_so_far (collect (Just e) myDocEmpty es)

finishedDoc :: LHsDecl RdrName -> NDoc -> [(LHsDecl RdrName, (Maybe NDoc))] -> [(LHsDecl RdrName, (Maybe NDoc))]
finishedDoc d doc rest | isEmptyDoc doc = (d, Nothing) : rest
finishedDoc d doc rest | notDocDecl d = (d, Just doc) : rest
  where
    notDocDecl (L _ (DocD _)) = False
    notDocDecl _              = True
finishedDoc _ _ rest = rest

sigNameNoLoc' :: Sig name -> [name]
#if MIN_VERSION_ghc(7,2,0)
#if MIN_VERSION_ghc(7,10,0)
sigNameNoLoc' (TypeSig   ns _ _)        = map unLoc ns
#else
sigNameNoLoc' (TypeSig   ns _)          = map unLoc ns
#endif
sigNameNoLoc' (SpecSig   n _ _)         = [unLoc n]
sigNameNoLoc' (InlineSig n _)           = [unLoc n]
#if MIN_VERSION_ghc(7,10,0)
sigNameNoLoc' (FixSig (FixitySig ns _)) = map unLoc ns
#else
sigNameNoLoc' (FixSig (FixitySig n _)) = [unLoc n]
#endif
sigNameNoLoc' _                         = []
#else
sigNameNoLoc' = maybe [] (:[]) . sigNameNoLoc
#endif

attachSignatures :: DynFlags -> [(NDecl, (Maybe NDoc))] -> [(NDecl,Maybe NDoc)]
    -> [(NDecl, (Maybe NDoc), [(NSig,Maybe NDoc)])]
attachSignatures dflags signatures = map (attachSignature signaturesMap)
    where
    signaturesMap = Map.fromListWith (++) $ concatMap sigMap signatures

    sigMap (L loc (SigD sig),c) | nameList <- sigNameNoLoc' sig =
        map (\n -> (n, [(L loc sig,c)])) nameList
    sigMap v = error ("Unexpected location type" ++ (showSDoc dflags . ppr) v)

    attachSignature :: Map RdrName  [(NSig,Maybe NDoc)] -> (NDecl, (Maybe NDoc))
        -> (NDecl, (Maybe NDoc), [(NSig,Maybe NDoc)])
    attachSignature signaturesMap'  (decl,mbDoc) =
        case declName (unLoc decl) of
            Nothing -> (decl,mbDoc, [])
            Just name -> case name `Map.lookup` signaturesMap' of
                            Just sigList -> (decl,mbDoc, sigList)
                            Nothing ->  (decl, mbDoc, [])
    declName _t@(TyClD x)                           = Just (tcdName x)
    declName _t@(ValD (FunBind fun_id' _ _ _ _ _ )) = Just (unLoc fun_id')
    declName _                                      = Nothing


transformToDescrs :: DynFlags -> PackModule -> [(NDecl, (Maybe NDoc), [(NSig, Maybe NDoc)])] -> [Descr]
transformToDescrs dflags pm = concatMap transformToDescr
    where
    transformToDescr :: (NDecl, (Maybe NDoc), [(NSig, Maybe NDoc)]) -> [Descr]
    transformToDescr ((L loc (ValD (FunBind lid _ _ _ _ _))), mbComment,sigList) =
        [Real $ RealDescr {
        dscName'        =   showRdrName dflags (unLoc lid)
    ,   dscMbTypeStr'   =   sigToByteString dflags sigList
    ,   dscMbModu'      =   Just pm
    ,   dscMbLocation'  =   srcSpanToLocation loc
    ,   dscMbComment'   =   toComment mbComment (catMaybes (map snd sigList))
    ,   dscTypeHint'    =   VariableDescr
    ,   dscExported'    =   True}]

#if MIN_VERSION_ghc(7,7,0)
    transformToDescr ((L loc for@(ForD (ForeignImport lid _ _ _))), mbComment,_sigList) =
        [Real $ RealDescr {
        dscName'        =   showRdrName dflags (unLoc lid)
    ,   dscMbTypeStr'   =   Just (BS.pack (showSDocUnqual dflags $ppr for))
    ,   dscMbModu'      =   Just pm
    ,   dscMbLocation'  =   srcSpanToLocation loc
    ,   dscMbComment'   =   toComment mbComment []
    ,   dscTypeHint'    =   TypeDescr
    ,   dscExported'    =   True}]

    transformToDescr ((L loc (TyClD typ@(FamDecl {tcdFam = (FamilyDecl{ fdLName = lid})}))), mbComment,_sigList) =
        [Real $ RealDescr {
        dscName'        =   showRdrName dflags (unLoc lid)
    ,   dscMbTypeStr'   =   Just (BS.pack (showSDocUnqual dflags $ppr typ))
    ,   dscMbModu'      =   Just pm
    ,   dscMbLocation'  =   srcSpanToLocation loc
    ,   dscMbComment'   =   toComment mbComment []
    ,   dscTypeHint'    =   TypeDescr
    ,   dscExported'    =   True}]

    transformToDescr ((L loc (TyClD typ@(SynDecl {tcdLName = lid}))), mbComment,_sigList) =
        [Real $ RealDescr {
        dscName'        =   showRdrName dflags (unLoc lid)
    ,   dscMbTypeStr'   =   Just (BS.pack (showSDocUnqual dflags $ppr typ))
    ,   dscMbModu'      =   Just pm
    ,   dscMbLocation'  =   srcSpanToLocation loc
    ,   dscMbComment'   =   toComment mbComment []
    ,   dscTypeHint'    =   TypeDescr
    ,   dscExported'    =   True}]

    transformToDescr ((L loc (TyClD typ@(DataDecl {tcdLName = lid, tcdDataDefn = HsDataDefn {dd_cons=lConDecl, dd_derivs=tcdDerivs'}}))), mbComment,_sigList) =
        [Real $ RealDescr {
        dscName'        =   name
    ,   dscMbTypeStr'   =   Just (BS.pack (showSDocUnqual dflags $ppr (uncommentData typ)))
    ,   dscMbModu'      =   Just pm
    ,   dscMbLocation'  =   srcSpanToLocation loc
    ,   dscMbComment'   =   toComment mbComment []
    ,   dscTypeHint'    =   DataDescr constructors fields
    ,   dscExported'    =   True}]
            ++ derivings tcdDerivs'
        where
        constructors    =   concatMap (extractConstructor dflags) lConDecl
        fields          =   nub $ concatMap (extractRecordFields dflags) lConDecl
        name            =   showRdrName dflags (unLoc lid)
        derivings Nothing = []
        derivings (Just l) = map (extractDeriving dflags pm name) (unLoc710 l)
#elif MIN_VERSION_ghc(7,6,0)
    transformToDescr ((L loc (TyClD typ@(ForeignType {tcdLName = lid}))), mbComment,_sigList) =
        [Real $ RealDescr {
        dscName'        =   showRdrName dflags (unLoc lid)
    ,   dscMbTypeStr'   =   Just (BS.pack (showSDocUnqual dflags $ppr typ))
    ,   dscMbModu'      =   Just pm
    ,   dscMbLocation'  =   srcSpanToLocation loc
    ,   dscMbComment'   =   toComment mbComment []
    ,   dscTypeHint'    =   TypeDescr
    ,   dscExported'    =   True}]

    transformToDescr ((L loc (TyClD typ@(TyFamily {tcdLName = lid}))), mbComment,_sigList) =
        [Real $ RealDescr {
        dscName'        =   showRdrName dflags (unLoc lid)
    ,   dscMbTypeStr'   =   Just (BS.pack (showSDocUnqual dflags $ppr typ))
    ,   dscMbModu'      =   Just pm
    ,   dscMbLocation'  =   srcSpanToLocation loc
    ,   dscMbComment'   =   toComment mbComment []
    ,   dscTypeHint'    =   TypeDescr
    ,   dscExported'    =   True}]

    transformToDescr ((L loc (TyClD typ@(TyDecl {tcdLName = lid, tcdTyDefn = TySynonym {}}))), mbComment,_sigList) =
        [Real $ RealDescr {
        dscName'        =   showRdrName dflags (unLoc lid)
    ,   dscMbTypeStr'   =   Just (BS.pack (showSDocUnqual dflags $ppr typ))
    ,   dscMbModu'      =   Just pm
    ,   dscMbLocation'  =   srcSpanToLocation loc
    ,   dscMbComment'   =   toComment mbComment []
    ,   dscTypeHint'    =   TypeDescr
    ,   dscExported'    =   True}]

    transformToDescr ((L loc (TyClD typ@(TyDecl {tcdLName = lid, tcdTyDefn = TyData {td_cons=lConDecl, td_derivs=tcdDerivs'}}))), mbComment,_sigList) =
        [Real $ RealDescr {
        dscName'        =   name
    ,   dscMbTypeStr'   =   Just (BS.pack (showSDocUnqual dflags $ppr (uncommentData typ)))
    ,   dscMbModu'      =   Just pm
    ,   dscMbLocation'  =   srcSpanToLocation loc
    ,   dscMbComment'   =   toComment mbComment []
    ,   dscTypeHint'    =   DataDescr constructors fields
    ,   dscExported'    =   True}]
            ++ derivings tcdDerivs'
        where
        constructors    =   concatMap (extractConstructor dflags) lConDecl
        fields          =   nub $ concatMap (extractRecordFields dflags) lConDecl
        name            =   showRdrName dflags (unLoc lid)
        derivings Nothing = []
        derivings (Just l) = map (extractDeriving dflags pm name) l
#else
    transformToDescr ((L loc (TyClD typ@(TySynonym lid _ _ _ ))), mbComment,_sigList) =
        [Real $ RealDescr {
        dscName'        =   showRdrName dflags (unLoc lid)
    ,   dscMbTypeStr'   =   Just (BS.pack (showSDocUnqual dflags $ppr typ))
    ,   dscMbModu'      =   Just pm
    ,   dscMbLocation'  =   srcSpanToLocation loc
    ,   dscMbComment'   =   toComment mbComment []
    ,   dscTypeHint'    =   TypeDescr
    ,   dscExported'    =   True}]

    transformToDescr ((L loc (TyClD typ@(TyData DataType _ tcdLName' _ _ _ lConDecl tcdDerivs'))), mbComment,_sigList) =
        [Real $ RealDescr {
        dscName'        =   name
    ,   dscMbTypeStr'   =   Just (BS.pack (showSDocUnqual dflags $ppr (uncommentData typ)))
    ,   dscMbModu'      =   Just pm
    ,   dscMbLocation'  =   srcSpanToLocation loc
    ,   dscMbComment'   =   toComment mbComment []
    ,   dscTypeHint'    =   DataDescr constructors fields
    ,   dscExported'    =   True}]
            ++ derivings tcdDerivs'
        where
        constructors    =   map (extractConstructor dflags) lConDecl
        fields          =   nub $ concatMap (extractRecordFields dflags) lConDecl
        name            =   showRdrName dflags (unLoc tcdLName')
        derivings Nothing = []
        derivings (Just l) = map (extractDeriving dflags pm name) l

    transformToDescr ((L loc (TyClD typ@(TyData NewType _ tcdLName' _ _ _ lConDecl tcdDerivs'))), mbComment,_sigList) =
        [Real $ RealDescr {
        dscName'        =   name
    ,   dscMbTypeStr'   =   Just (BS.pack (showSDocUnqual dflags $ppr (uncommentData typ)))
    ,   dscMbModu'      =   Just pm
    ,   dscMbLocation'  =   srcSpanToLocation loc
    ,   dscMbComment'   =   toComment mbComment []
    ,   dscTypeHint'    =   NewtypeDescr constructor mbField
    ,   dscExported'    =   True}]
            ++ derivings tcdDerivs'
        where
        constructor     =   forceHead (map (extractConstructor dflags) lConDecl)
                                "WorkspaceCollector>>transformToDescr: no constructor for newtype"
        mbField         =   case concatMap (extractRecordFields dflags) lConDecl of
                                [] -> Nothing
                                a:_ -> Just a
        name            =   showRdrName dflags (unLoc tcdLName')
        derivings Nothing = []
        derivings (Just l) = map (extractDeriving dflags pm name) l
#endif

    transformToDescr ((L loc (TyClD cl@(ClassDecl{tcdLName=tcdLName', tcdSigs=tcdSigs', tcdDocs=docs}))), mbComment,_sigList) =
        [Real $ RealDescr {
        dscName'        =   showRdrName dflags (unLoc tcdLName')
    ,   dscMbTypeStr'   =   Just (BS.pack (showSDocUnqual dflags $ppr cl{tcdMeths = emptyLHsBinds}))
    ,   dscMbModu'      =   Just pm
    ,   dscMbLocation'  =   srcSpanToLocation loc
    ,   dscMbComment'   =   toComment mbComment []
    ,   dscTypeHint'    =   ClassDescr super methods
    ,   dscExported'    =   True    }]
        where
        methods         =   extractMethods dflags tcdSigs' docs
        super           =   []

#if MIN_VERSION_ghc(7,7,0)
    transformToDescr ((L loc (InstD inst)), mbComment, _sigList) =
        let typp = case inst of
                     ClsInstD t -> ppr t
                     DataFamInstD t -> ppr t
                     TyFamInstD t -> ppr t
            (instn,nameI,other) =   case T.words . T.pack $ showSDocUnqual dflags typp of
                                        instn':nameI':tl -> (instn',nameI',takeWhile (/= "where") tl)
                                        _ -> ("","",[])
        in
            [Real $ RealDescr {
            dscName'        =   instn <> " " <> nameI
        ,   dscMbTypeStr'   =   Just (BS.pack . T.unpack $ instn <> " " <> nameI <> " " <> (T.intercalate " " other))
        ,   dscMbModu'      =   Just pm
        ,   dscMbLocation'  =   srcSpanToLocation loc
        ,   dscMbComment'   =   toComment mbComment []
        ,   dscTypeHint'    =   InstanceDescr other
        ,   dscExported'    =   True}]
            where

#elif MIN_VERSION_ghc(7,6,0)
    transformToDescr ((L loc (InstD _inst@(ClsInstD typ _ _ _))), mbComment, _sigList) =
        [Real $ RealDescr {
        dscName'        =   name
    ,   dscMbTypeStr'   =   Just (BS.pack ("instance " ++ (showSDocUnqual dflags $ppr typ)))
    ,   dscMbModu'      =   Just pm
    ,   dscMbLocation'  =   srcSpanToLocation loc
    ,   dscMbComment'   =   toComment mbComment []
    ,   dscTypeHint'    =   InstanceDescr other
    ,   dscExported'    =   True}]
        where
        (name,other)           =   case T.words $ T.pack (showSDocUnqual dflags $ppr typ) of
                                [] -> ("",[])
                                hd:tl -> (hd,tl)
#else
    transformToDescr ((L loc (InstD _inst@(InstDecl typ _ _ _))), mbComment, _sigList) =
        [Real $ RealDescr {
        dscName'        =   name
    ,   dscMbTypeStr'   =   Just (BS.pack ("instance " ++ (showSDocUnqual dflags $ppr typ)))
    ,   dscMbModu'      =   Just pm
    ,   dscMbLocation'  =   srcSpanToLocation loc
    ,   dscMbComment'   =   toComment mbComment []
    ,   dscTypeHint'    =   InstanceDescr other
    ,   dscExported'    =   True}]
        where
        (name,other)           =   case T.words $ T.pack (showSDocUnqual dflags $ppr typ) of
                                [] -> ("",[])
                                hd:tl -> (hd,tl)
#endif

    transformToDescr (_, _mbComment, _sigList) = []


uncommentData :: TyClDecl a -> TyClDecl a
#if MIN_VERSION_ghc(7,7,0)
uncommentData td@(DataDecl {tcdDataDefn = def@(HsDataDefn{dd_cons = conDecls})}) = td{
    tcdDataDefn = def{dd_cons = map uncommentDecl conDecls}}
#elif MIN_VERSION_ghc(7,6,0)
uncommentData td@(TyDecl {tcdTyDefn = def@(TyData{td_cons = conDecls})}) = td{
    tcdTyDefn = def{td_cons = map uncommentDecl conDecls}}
#else
uncommentData td@(TyData {tcdCons = conDecls}) = td{tcdCons = map uncommentDecl conDecls}
#endif
uncommentData other                            = other

uncommentDecl :: LConDecl a -> LConDecl a
uncommentDecl (L l cd) =
    L l cd{con_details= uncommentDetails (con_details cd)}

uncommentDetails :: HsConDeclDetails a -> HsConDeclDetails a
#if MIN_VERSION_ghc(7,10,0)
uncommentDetails (RecCon (L l flds)) = RecCon (L l (map uncommentField flds))
    where
    uncommentField (L l2 (ConDeclField a1 a2 _doc))  =  L l2 (ConDeclField a1 a2 Nothing)
#else
uncommentDetails (RecCon flds) = RecCon (map uncommentField flds)
    where
    uncommentField (ConDeclField a1 a2 _doc)  =  ConDeclField a1 a2 Nothing
#endif
uncommentDetails other = other

mergeWithInterfaceDescr :: ModuleDescr -> ModuleDescr -> ModuleDescr
mergeWithInterfaceDescr md imd = md {
    mdReferences = mdReferences imd,
    mdIdDescriptions = mergeIdDescrs (mdIdDescriptions md) (mdIdDescriptions imd)}

mergeIdDescrs :: [Descr] -> [Descr] -> [Descr]
mergeIdDescrs d1 d2 = dres ++ reexported
    where
        (reexported,real)  = partition isReexported d2
        lm = Map.fromList $ zip (map (\d -> (dscName d,dscTypeHint d)) real) real
        dres =  map (addType lm) d1

        addType lm' (Real d1') | isNothing (dscMbTypeStr' d1') =
            Real $ d1'{dscMbTypeStr' = case (dscName' d1', dscTypeHint' d1') `Map.lookup` lm' of
                                        Nothing -> Nothing
                                        Just d -> dscMbTypeStr d}
        addType _ d                     = d

extractDeriving :: OutputableBndr alpha => DynFlags -> PackModule -> Text -> LHsType alpha -> Descr
extractDeriving dflags pm name (L loc typ) =
        Real $ RealDescr {
        dscName'        =   className
    ,   dscMbTypeStr'   =   Just (BS.pack . T.unpack $ "instance " <> className <> " " <> name)
    ,   dscMbModu'      =   Just pm
    ,   dscMbLocation'  =   srcSpanToLocation loc
    ,   dscMbComment'   =   toComment (Nothing :: Maybe NDoc) []
    ,   dscTypeHint'    =   InstanceDescr (T.words name)
    ,   dscExported'    =   True}
        where
        className       =   T.pack . showSDocUnqual dflags $ ppr typ

extractMethods :: DynFlags -> [LSig RdrName] -> [MyLDocDecl] -> [SimpleDescr]
extractMethods dflags sigs docs =
    let pairs = attachComments sigs docs
    in concatMap (extractMethod dflags) pairs

extractMethod :: OutputableBndr alpha => DynFlags -> (LHsDecl alpha, Maybe (NDoc)) -> [SimpleDescr]
#if MIN_VERSION_ghc(7,10,0)
extractMethod dflags ((L loc (SigD ts@(TypeSig names _typ _))), mbDoc) = map extractName names
#elif MIN_VERSION_ghc(7,2,0)
extractMethod dflags ((L loc (SigD ts@(TypeSig names _typ))), mbDoc) = map extractName names
#else
extractMethod dflags ((L loc (SigD ts@(TypeSig name' _typ))), mbDoc) = [extractName name']
#endif
  where
  extractName name =
    SimpleDescr
        (T.pack . showSDoc dflags . ppr $ unLoc name)
        (Just . BS.pack . showSDocUnqual dflags $ ppr ts)
        (srcSpanToLocation loc)
        (toComment mbDoc [])
        True
extractMethod _ (_, _mbDoc) = []

extractConstructor :: DynFlags -> Located (ConDecl RdrName) -> [SimpleDescr]
#if MIN_VERSION_ghc(7,10,0)
extractConstructor dflags decl@(L loc (ConDecl {con_names = names, con_doc = doc})) =
    map extractName names
#else
extractConstructor dflags decl@(L loc (ConDecl {con_name = name', con_doc = doc})) =
    [extractName name']
#endif
 where
  extractName name =
    SimpleDescr
        (T.pack . showSDoc dflags . ppr $ unLoc name)
        (Just . BS.pack . showSDocUnqual dflags . ppr $ uncommentDecl decl)
        (srcSpanToLocation loc)
        (case doc of
            Nothing -> Nothing
            Just (L _ d) -> Just . BS.pack . T.unpack $ printHsDoc d)
        True

extractRecordFields :: DynFlags -> Located (ConDecl RdrName) -> [SimpleDescr]
extractRecordFields dflags (L _ _decl@(ConDecl {con_details = RecCon flds})) =
    concatMap extractRecordFields' (unLoc710 flds)
    where
#if MIN_VERSION_ghc(7,10,0)
    extractRecordFields' (L _ _field@(ConDeclField names typ doc)) = map extractName names
#else
    extractRecordFields' _field@(ConDeclField name' typ doc) = [extractName name']
#endif
      where
      extractName name =
        SimpleDescr
            (T.pack . showSDoc dflags . ppr $ unLoc710 name)
            (Just . BS.pack . showSDocUnqual dflags $ ppr typ)
            (srcSpanToLocation $ getLoc name)
            (case doc of
                Nothing -> Nothing
                Just (L _ d) -> Just . BS.pack . T.unpack $ printHsDoc d)
            True
extractRecordFields _ _ = []

attachComments :: [LSig RdrName] -> [MyLDocDecl] -> [(LHsDecl RdrName, Maybe (NDoc))]
attachComments sigs docs = collectDocs $ sortByLoc $
        ((map (\ (L l i) -> L l (SigD i)) sigs) ++ (map (\ (L l i) -> L l (DocD i)) docs))

sigToByteString :: DynFlags -> [(NSig, Maybe NDoc)] -> Maybe ByteString
sigToByteString _ [] = Nothing
sigToByteString dflags [(sig,_)] = Just (BS.pack (showSDocUnqual dflags $ppr sig))
sigToByteString dflags ((sig,_):_) = Just (BS.pack (showSDocUnqual dflags $ppr sig))

srcSpanToLocation :: SrcSpan -> Maybe Location
#if MIN_VERSION_ghc(7,2,0)
srcSpanToLocation (RealSrcSpan span')
    =   Just (Location (unpackFS $ srcSpanFile span') (srcSpanStartLine span') (srcSpanStartCol span')
                 (srcSpanEndLine span') (srcSpanEndCol span'))
srcSpanToLocation _ = Nothing
#else
srcSpanToLocation span' | not (isGoodSrcSpan span')
    =   Nothing
srcSpanToLocation span'
    =   Just (Location (unpackFS $ srcSpanFile span') (srcSpanStartLine span') (srcSpanStartCol span')
                 (srcSpanEndLine span') (srcSpanEndCol span'))
#endif

toComment :: Maybe (NDoc) -> [NDoc] -> Maybe ByteString
toComment (Just c) _    =  Just . BS.pack . T.unpack $ printHsDoc c
toComment Nothing (c:_) =  Just . BS.pack . T.unpack $ printHsDoc c
toComment Nothing []    =  Nothing


{--
    =   addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Data] []
collectParseInfoForDecl (l,st) ((Just (L loc (TyClD (TyFamily _ lid _ _)))), mbComment')
    =   addLocationAndComment (l,st) (unLoc lid) loc mbComment' [] []
collectParseInfoForDecl (l,st) ((Just (L loc (TyClD (ClassDecl _ lid _ _ _ _ _ _ )))), mbComment')
    =   addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Class] []
--}
printHsDoc :: NDoc  -> Text
printHsDoc (HsDocString fs) = T.pack $ unpackFS fs

---------------------------------------------------------------------------------
-- Now the interface file stuff

mayGetInterfaceFile :: PackageIdAndKey -> ModuleName -> Ghc (Maybe (ModIface,FilePath))
mayGetInterfaceFile p mn =
    let pid             =   packId p
        makeMod         =   mkModule
#if MIN_VERSION_ghc(7,10,0)
                                 (packKey p)
#else
                                 (mkPackageId pid)
#endif
        isBase  =   pkgName pid == (PackageName "base")
        mn'     =   mkModuleName (display mn)
        iface   =   findAndReadIface empty (if isBase
                                                then mkBaseModule_ mn'
                                                else makeMod mn') False
        gblEnv  =   IfGblEnv { if_rec_types = Nothing }
    in do
        hscEnv              <-  getSession
        maybe'              <-  liftIO $ initTcRnIf  'i' hscEnv gblEnv () iface
        case maybe' of
            M.Succeeded val ->    return (Just val)
            _               ->    return Nothing

mayGetInterfaceDescription :: DynFlags -> PackageIdAndKey -> ModuleName -> Ghc (Maybe ModuleDescr)
mayGetInterfaceDescription dflags pid mn = do
    mbIf <- mayGetInterfaceFile pid mn
    case mbIf of
        Nothing -> do
            liftIO $ debugM "leksah-server" ("no interface file for " ++ show mn)
            return Nothing
        Just (mif,_) ->
            let allDescrs  =    extractExportedDescrH dflags pid mif
                mod'       =    extractExportedDescrR dflags pid allDescrs mif
            in do
                liftIO $ debugM "leksah-server" ("interface file for " ++ show mn ++ " descrs: " ++
                                    show (length (mdIdDescriptions mod')))
                return (Just mod')