module IDE.HeaderParser (
parseTheHeader
) where
import Control.Applicative
import Prelude hiding (readFile)
import IDE.Core.CTypes hiding(SrcSpan(..))
import GHC hiding (ImportDecl)
import FastString(unpackFS)
import IDE.Utils.GHCUtils
import Data.Maybe (mapMaybe)
#if MIN_VERSION_ghc(7,4,1)
import Outputable(pprPrefixOcc, ppr)
#else
import Outputable(pprHsVar, ppr)
#endif
#if MIN_VERSION_ghc(7,6,0)
import Outputable(showSDoc)
#else
import qualified Outputable as O
#endif
import IDE.Utils.FileUtils (figureOutHaddockOpts)
import Control.Monad.IO.Class (MonadIO(..))
import System.IO.Strict (readFile)
import qualified Data.Text as T (pack)
#if !MIN_VERSION_ghc(7,6,0)
showSDoc :: DynFlags -> O.SDoc -> String
showSDoc _ = O.showSDoc
showSDocUnqual :: DynFlags -> O.SDoc -> String
showSDocUnqual _ = O.showSDocUnqual
#endif
#if MIN_VERSION_ghc(7,10,0)
unLoc710 :: GenLocated l e -> e
unLoc710 = unLoc
#else
unLoc710 :: a -> a
unLoc710 = id
#endif
showRdrName :: DynFlags -> RdrName -> String
showRdrName dflags r = showSDoc dflags (ppr r)
parseTheHeader :: FilePath -> IO ServerAnswer
parseTheHeader filePath = do
text <- readFile filePath
opts <- figureOutHaddockOpts
parseResult <- liftIO $ myParseHeader filePath text (filterOpts opts)
case parseResult of
Left str -> return (ServerFailed str)
Right (_, pr@HsModule{ hsmodImports = []}) -> do
let i = case hsmodDecls pr of
decls@(_hd:_tl) -> foldl (\ a b -> min a (srcSpanStartLine' (getLoc b))) 0 decls 1
[] -> case hsmodExports pr of
Just list -> foldl (\ a b -> max a (srcSpanEndLine' (getLoc b))) 0 (unLoc710 list) + 1
Nothing -> case hsmodName pr of
Nothing -> 0
Just mn -> srcSpanEndLine' (getLoc mn) + 2
return (ServerHeader (Right i))
Right (dflags, _pr@HsModule{ hsmodImports = imports }) -> return (ServerHeader (Left (transformImports dflags imports)))
where
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
transformImports :: DynFlags -> [LImportDecl RdrName] -> [ImportDecl]
transformImports dflags = map (transformImport dflags)
transformImport :: DynFlags -> LImportDecl RdrName -> ImportDecl
transformImport dflags (L srcSpan importDecl) =
ImportDecl {
importLoc = srcSpanToLocation srcSpan,
importModule = T.pack modName,
importQualified = ideclQualified importDecl,
importSrc = ideclSource importDecl,
importPkg = T.pack <$> pkgQual,
importAs = T.pack <$> impAs,
importSpecs = specs}
where
modName = moduleNameString $ unLoc $ ideclName importDecl
pkgQual = case ideclPkgQual importDecl of
Nothing -> Nothing
Just fs -> Just (unpackFS fs)
impAs = case ideclAs importDecl of
Nothing -> Nothing
Just mn -> Just (moduleNameString mn)
specs = case ideclHiding importDecl of
Nothing -> Nothing
Just (hide, list) -> Just (ImportSpecList hide (mapMaybe (transformEntity dflags) (unLoc710 list)))
transformEntity :: DynFlags -> LIE RdrName -> Maybe ImportSpec
#if MIN_VERSION_ghc(7,2,0)
transformEntity dflags (L _ (IEVar name)) = Just (IVar (T.pack $ showSDoc dflags (pprPrefixOcc $ unLoc710 name)))
#else
transformEntity dflags (L _ (IEVar name)) = Just (IVar (T.pack $ showSDoc dflags (pprHsVar name)))
#endif
transformEntity dflags (L _ (IEThingAbs name)) = Just (IAbs (T.pack . showRdrName dflags $ unLoc710 name))
transformEntity dflags (L _ (IEThingAll name)) = Just (IThingAll (T.pack . showRdrName dflags $ unLoc710 name))
transformEntity dflags (L _ (IEThingWith name list)) = Just (IThingWith (T.pack . showRdrName dflags $ unLoc710 name)
(map (T.pack . showRdrName dflags . unLoc710) list))
transformEntity _ _ = Nothing
#if MIN_VERSION_ghc(7,2,0)
srcSpanToLocation :: SrcSpan -> Location
srcSpanToLocation (RealSrcSpan span')
= Location (unpackFS $ srcSpanFile span') (srcSpanStartLine span') (srcSpanStartCol span')
(srcSpanEndLine span') (srcSpanEndCol span')
srcSpanToLocation _ = error "srcSpanToLocation: unhelpful span"
srcSpanStartLine' :: SrcSpan -> Int
srcSpanStartLine' (RealSrcSpan span') = srcSpanStartLine span'
srcSpanStartLine' _ = error "srcSpanStartLine': unhelpful span"
srcSpanEndLine' :: SrcSpan -> Int
srcSpanEndLine' (RealSrcSpan span') = srcSpanEndLine span'
srcSpanEndLine' _ = error "srcSpanEndLine': unhelpful span"
#else
srcSpanToLocation :: SrcSpan -> Location
srcSpanToLocation span' | not (isGoodSrcSpan span')
= error "srcSpanToLocation: unhelpful span"
srcSpanToLocation span'
= Location (unpackFS $ srcSpanFile span') (srcSpanStartLine span') (srcSpanStartCol span')
(srcSpanEndLine span') (srcSpanEndCol span')
srcSpanStartLine' :: SrcSpan -> Int
srcSpanStartLine' = srcSpanStartLine
srcSpanEndLine' :: SrcSpan -> Int
srcSpanEndLine' = srcSpanEndLine
#endif