module Language.Haskell.BuildWrapper.GHC where
import Language.Haskell.BuildWrapper.Base hiding (Target)
import Language.Haskell.BuildWrapper.GHCStorage
import Data.Char
import Data.Generics hiding (Fixity, typeOf)
import Data.Maybe
import Data.Monoid
import Data.Aeson
import Data.IORef
import qualified Data.List as List
import Data.Ord (comparing)
import qualified Data.Text as T
import DynFlags
import ErrUtils ( ErrMsg(..), WarnMsg, mkPlainErrMsg,Messages,ErrorMessages,WarningMessages, Message )
import GHC
import GHC.Paths ( libdir )
import HscTypes ( srcErrorMessages, SourceError)
import Outputable
import FastString (FastString,unpackFS,concatFS,fsLit,mkFastString)
import Lexer hiding (loc)
import Bag
#if __GLASGOW_HASKELL__ >= 702
import SrcLoc
#endif
#if __GLASGOW_HASKELL__ >= 610
import StringBuffer
#endif
import System.FilePath
import qualified MonadUtils as GMU
import Control.Monad.IO.Class (liftIO)
getAST :: FilePath
-> FilePath
-> String
-> [String]
-> IO (OpResult (Maybe TypecheckedSource))
getAST =withASTNotes (return . tm_typechecked_source
)
withAST :: (TypecheckedModule -> Ghc a)
-> FilePath
-> FilePath
-> String
-> [String]
-> IO (Maybe a)
withAST f fp base_dir modul options= do
(a,_)<-withASTNotes f fp base_dir modul options
return a
withJSONAST :: (Value -> IO a)
-> FilePath
-> FilePath
-> String
-> [String]
-> IO (Maybe a)
withJSONAST f fp base_dir modul options=do
mv<-readGHCInfo fp
case mv of
Just v-> fmap Just (f v)
Nothing->do
(mTc,_)<-getAST fp base_dir modul options
case mTc of
Just tc->fmap Just (f (dataToJSON tc))
Nothing -> return Nothing
withASTNotes :: (TypecheckedModule -> Ghc a)
-> FilePath
-> FilePath
-> String
-> [String]
-> IO (OpResult (Maybe a))
withASTNotes f fp base_dir modul options=do
let lflags=map noLoc options
(_leftovers, _) <- parseStaticFlags lflags
runGhc (Just libdir) $ do
flg <- getSessionDynFlags
(flg', _, _) <- parseDynamicFlags flg _leftovers
GHC.defaultCleanupHandler flg' $ do
ref <- GMU.liftIO $ newIORef []
setSessionDynFlags flg' {hscTarget = HscNothing, ghcLink = NoLink , ghcMode = CompManager, log_action = logAction ref }
addTarget Target { targetId = TargetFile fp Nothing, targetAllowObjCode = True, targetContents = Nothing }
let modName=mkModuleName modul
res<- load (LoadUpTo modName)
`gcatch` (\(e :: SourceError) -> handle_error ref e)
notes <- GMU.liftIO $ readIORef ref
case res of
Succeeded -> do
modSum <- getModSummary modName
p <- parseModule modSum
t <- typecheckModule p
d <- desugarModule t
l <- loadModule d
#if __GLASGOW_HASKELL__ < 704
setContext [ms_mod modSum] []
#else
setContext [IIModule $ ms_mod modSum]
#endif
GMU.liftIO $ storeGHCInfo fp (typecheckedSource $ dm_typechecked_module l)
a<-f (dm_typechecked_module l)
#if __GLASGOW_HASKELL__ < 702
warns <- getWarnings
return (Just a,List.nub $ notes ++ reverse (ghcMessagesToNotes base_dir (warns, emptyBag)))
#else
notes2 <- GMU.liftIO $ readIORef ref
return $ (Just a,List.nub $ notes2)
#endif
Failed -> return (Nothing, notes)
where
add_warn_err :: GhcMonad m => IORef [BWNote] -> WarningMessages -> ErrorMessages -> m()
add_warn_err ref warns errs = do
let notes = ghcMessagesToNotes base_dir (warns, errs)
GMU.liftIO $ modifyIORef ref $
\ ns -> ns ++ notes
handle_error :: GhcMonad m => IORef [BWNote] -> SourceError -> m SuccessFlag
handle_error ref e = do
let errs = srcErrorMessages e
add_warn_err ref emptyBag errs
return Failed
logAction :: IORef [BWNote] -> Severity -> SrcSpan -> PprStyle -> Message -> IO ()
logAction ref s loc style msg
| (Just status)<-bwSeverity s=do
let n=BWNote { bwn_location = ghcSpanToBWLocation base_dir loc
, bwn_status = status
, bwn_title = removeBaseDir base_dir $ removeStatus status $ showSDocForUser (qualName style,qualModule style) msg
}
modifyIORef ref $ \ ns -> ns ++ [n]
| otherwise=return ()
bwSeverity :: Severity -> Maybe BWNoteStatus
bwSeverity SevWarning = Just BWWarning
bwSeverity SevError = Just BWError
bwSeverity SevFatal = Just BWError
bwSeverity _ = Nothing
ghcMessagesToNotes :: FilePath
-> Messages
-> [BWNote]
ghcMessagesToNotes base_dir (warns, errs) = map_bag2ms (ghcWarnMsgToNote base_dir) warns ++
map_bag2ms (ghcErrMsgToNote base_dir) errs
where
map_bag2ms f = map f . Bag.bagToList
getGhcNamesInScope :: FilePath
-> FilePath
-> String
-> [String]
-> IO [String]
getGhcNamesInScope f base_dir modul options=do
names<-withAST (\_->do
names<-getNamesInScope
return $ map (showSDocDump . ppr ) names) f base_dir modul options
return $ fromMaybe[] names
getThingAtPointJSON :: Int
-> Int
-> FilePath
-> FilePath
-> String
-> [String]
-> IO (Maybe ThingAtPoint)
getThingAtPointJSON line col fp base_dir modul options= do
mmf<-withJSONAST (\v->do
let f=overlap line (scionColToGhcCol col)
let mf=findInJSON f v
return $ findInJSONData mf
) fp base_dir modul options
return $ fromMaybe Nothing mmf
ghcSpanToLocation ::GHC.SrcSpan
-> InFileSpan
ghcSpanToLocation sp
| GHC.isGoodSrcSpan sp =let
(stl,stc)=start sp
(enl,enc)=end sp
in mkFileSpan
stl
(ghcColToScionCol stc)
enl
(ghcColToScionCol enc)
| otherwise = mkFileSpan 0 0 0 0
ghcSpanToBWLocation :: FilePath
-> GHC.SrcSpan
-> BWLocation
ghcSpanToBWLocation baseDir sp
| GHC.isGoodSrcSpan sp =
let (stl,stc)=start sp
in BWLocation (makeRelative baseDir $ foldr f [] $ normalise $ unpackFS (sfile sp))
stl
(ghcColToScionCol $stc)
| otherwise = BWLocation "" 1 1
where
f c (x:xs)
| c=='\\' && x=='\\'=x:xs
| otherwise=c:x:xs
f c s=c:s
#if __GLASGOW_HASKELL__ < 702
sfile = GHC.srcSpanFile
#else
sfile (RealSrcSpan ss)= GHC.srcSpanFile ss
#endif
ghcColToScionCol :: Int -> Int
#if __GLASGOW_HASKELL__ < 700
ghcColToScionCol c=c+1
#else
ghcColToScionCol c=c
#endif
scionColToGhcCol :: Int -> Int
#if __GLASGOW_HASKELL__ < 700
scionColToGhcCol c=c1
#else
scionColToGhcCol c=c
#endif
ghctokensArbitrary :: FilePath
-> String
-> [String]
-> IO (Either BWNote [Located Token])
ghctokensArbitrary base_dir contents options= do
#if __GLASGOW_HASKELL__ < 702
sb <- stringToStringBuffer contents
#else
let sb=stringToStringBuffer contents
#endif
let lflags=map noLoc options
(_leftovers, _) <- parseStaticFlags lflags
runGhc (Just libdir) $ do
flg <- getSessionDynFlags
(flg', _, _) <- parseDynamicFlags flg _leftovers
#if __GLASGOW_HASKELL__ >= 700
let dflags1 = List.foldl' xopt_set flg' lexerFlags
#else
let dflags1 = List.foldl' dopt_set flg' lexerFlags
#endif
let prTS = lexTokenStream sb lexLoc dflags1
case prTS of
POk _ toks -> return $ Right $ filter ofInterest toks
PFailed loc msg -> return $ Left $ ghcErrMsgToNote base_dir $ mkPlainErrMsg loc msg
#if __GLASGOW_HASKELL__ < 702
lexLoc :: SrcLoc
lexLoc = mkSrcLoc (mkFastString "<interactive>") 1 (scionColToGhcCol 1)
#else
lexLoc :: RealSrcLoc
lexLoc = mkRealSrcLoc (mkFastString "<interactive>") 1 (scionColToGhcCol 1)
#endif
#if __GLASGOW_HASKELL__ >= 700
lexerFlags :: [ExtensionFlag]
#else
lexerFlags :: [DynFlag]
#endif
lexerFlags =
[ Opt_ForeignFunctionInterface
, Opt_Arrows
#if __GLASGOW_HASKELL__ < 702
, Opt_PArr
#else
, Opt_ParallelArrays
#endif
, Opt_TemplateHaskell
, Opt_QuasiQuotes
, Opt_ImplicitParams
, Opt_BangPatterns
, Opt_TypeFamilies
#if __GLASGOW_HASKELL__ < 700
, Opt_Haddock
#endif
, Opt_MagicHash
, Opt_KindSignatures
, Opt_RecursiveDo
, Opt_UnicodeSyntax
, Opt_UnboxedTuples
, Opt_StandaloneDeriving
, Opt_TransformListComp
#if __GLASGOW_HASKELL__ < 702
, Opt_NewQualifiedOperators
#endif
#if GHC_VERSION > 611
, Opt_ExplicitForAll
, Opt_DoRec
#endif
]
ofInterest :: Located Token -> Bool
ofInterest (L loc _) =
let (sl,sc) = start loc
(el,ec) = end loc
in (sl < el) || (sc < ec)
tokenToType :: Located Token -> TokenDef
tokenToType (L sp t) = TokenDef (tokenType t) (ghcSpanToLocation sp)
tokenTypesArbitrary :: FilePath -> String -> Bool -> [String] -> IO (Either BWNote [TokenDef])
tokenTypesArbitrary projectRoot contents literate options = generateTokens projectRoot contents literate options convertTokens id
where
convertTokens = map tokenToType
occurrences :: FilePath
-> String
-> T.Text
-> Bool
-> [String]
-> IO (Either BWNote [TokenDef])
occurrences projectRoot contents query literate options =
let
qualif = isJust $ T.find (=='.') query
tokensMatching :: [TokenDef] -> [TokenDef]
tokensMatching = filter matchingVal
matchingVal :: TokenDef -> Bool
matchingVal (TokenDef v _)=query==v
mkToken (L sp t)=TokenDef (tokenValue qualif t) (ghcSpanToLocation sp)
in generateTokens projectRoot contents literate options (map mkToken) tokensMatching
generateTokens :: FilePath
-> String
-> Bool
-> [String]
-> ([Located Token] -> [TokenDef])
-> ([TokenDef] -> a)
-> IO (Either BWNote a)
generateTokens projectRoot contents literate options xform filterFunc =do
let (ppTs, ppC) = preprocessSource contents literate
result<- ghctokensArbitrary projectRoot ppC options
case result of
Right toks ->do
let filterResult = filterFunc $ List.sortBy (comparing td_loc) (ppTs ++ xform toks)
return $ Right filterResult
Left n -> return $ Left n
preprocessSource :: String
-> Bool
-> ([TokenDef],String)
preprocessSource contents literate=
let
(ts1,s2)=if literate then ppSF contents ppSLit else ([],contents)
(ts2,s3)=ppSF s2 ppSCpp
in (ts1++ts2,s3)
where
ppSF contents2 p= let
linesWithCount=zip (lines contents2) [1..]
(ts,nc,_)= List.foldl' p ([],[],Start) linesWithCount
in (reverse ts, unlines $ reverse nc)
ppSCpp :: ([TokenDef],[String],PPBehavior) -> (String,Int) -> ([TokenDef],[String],PPBehavior)
ppSCpp (ts2,l2,f) (l,c)
| (Continue _)<-f = addPPToken "PP" (l,c) (ts2,l2,lineBehavior l f)
| ('#':_)<-l =addPPToken "PP" (l,c) (ts2,l2,lineBehavior l f)
| "{-# " `List.isPrefixOf` l=addPPToken "D" (l,c) (ts2,"":l2,f)
| (Indent n)<-f=(ts2,l:(replicate n (takeWhile (== ' ') l) ++ l2),Start)
| otherwise =(ts2,l:l2,Start)
ppSLit :: ([TokenDef],[String],PPBehavior) -> (String,Int) -> ([TokenDef],[String],PPBehavior)
ppSLit (ts2,l2,f) (l,c)
| "\\begin{code}" `List.isPrefixOf` l=addPPToken "DL" ("\\begin{code}",c) (ts2,"":l2,Continue 1)
| "\\end{code}" `List.isPrefixOf` l=addPPToken "DL" ("\\end{code}",c) (ts2,"":l2,Start)
| (Continue n)<-f = (ts2,l:l2,Continue (n+1))
| ('>':lCode)<-l=(ts2, (' ':lCode ):l2,f)
| otherwise =addPPToken "DL" (l,c) (ts2,"":l2,f)
addPPToken :: T.Text -> (String,Int) -> ([TokenDef],[String],PPBehavior) -> ([TokenDef],[String],PPBehavior)
addPPToken name (l,c) (ts2,l2,f) =(TokenDef name (mkFileSpan c 1 c (length l + 1)) : ts2 ,l2,f)
lineBehavior l f
| '\\' == last l = case f of
Continue n->Continue (n+1)
_ -> Continue 1
| otherwise = case f of
Continue n->Indent (n+1)
Indent n->Indent (n+1)
_ -> Indent 1
data PPBehavior=Continue Int | Indent Int | Start
deriving Eq
ghcErrMsgToNote :: FilePath -> ErrMsg -> BWNote
ghcErrMsgToNote = ghcMsgToNote BWError
ghcWarnMsgToNote :: FilePath -> WarnMsg -> BWNote
ghcWarnMsgToNote = ghcMsgToNote BWWarning
ghcMsgToNote :: BWNoteStatus -> FilePath -> ErrMsg -> BWNote
ghcMsgToNote note_kind base_dir msg =
BWNote { bwn_location = ghcSpanToBWLocation base_dir loc
, bwn_status = note_kind
, bwn_title = removeBaseDir base_dir $ removeStatus note_kind $ show_msg (errMsgShortDoc msg)
}
where
loc | (s:_) <- errMsgSpans msg = s
| otherwise = GHC.noSrcSpan
unqual = errMsgContext msg
show_msg = showSDocForUser unqual
removeStatus :: BWNoteStatus -> String -> String
removeStatus BWWarning s
| "Warning:" `List.isPrefixOf` s = List.dropWhile isSpace $ drop 8 s
| otherwise = s
removeStatus BWError s
| "Error:" `List.isPrefixOf` s = List.dropWhile isSpace $ drop 6 s
| otherwise = s
#if CABAL_VERSION == 106
deriving instance Typeable StringBuffer
deriving instance Data StringBuffer
#endif
mkUnqualTokenValue :: FastString
-> T.Text
mkUnqualTokenValue = T.pack . unpackFS
mkQualifiedTokenValue :: FastString
-> FastString
-> T.Text
mkQualifiedTokenValue q a = (T.pack . unpackFS . concatFS) [q, dotFS, a]
mkTokenName :: Token -> T.Text
mkTokenName = T.pack . showConstr . toConstr
deriving instance Typeable Token
deriving instance Data Token
#if CABAL_VERSION == 106
deriving instance Typeable StringBuffer
deriving instance Data StringBuffer
#endif
tokenType :: Token -> T.Text
tokenType ITas = "K"
tokenType ITcase = "K"
tokenType ITclass = "K"
tokenType ITdata = "K"
tokenType ITdefault = "K"
tokenType ITderiving = "K"
tokenType ITdo = "K"
tokenType ITelse = "K"
tokenType IThiding = "K"
tokenType ITif = "K"
tokenType ITimport = "K"
tokenType ITin = "K"
tokenType ITinfix = "K"
tokenType ITinfixl = "K"
tokenType ITinfixr = "K"
tokenType ITinstance = "K"
tokenType ITlet = "K"
tokenType ITmodule = "K"
tokenType ITnewtype = "K"
tokenType ITof = "K"
tokenType ITqualified = "K"
tokenType ITthen = "K"
tokenType ITtype = "K"
tokenType ITwhere = "K"
tokenType ITscc = "K"
tokenType ITforall = "EK"
tokenType ITforeign = "EK"
tokenType ITexport= "EK"
tokenType ITlabel= "EK"
tokenType ITdynamic= "EK"
tokenType ITsafe= "EK"
#if __GLASGOW_HASKELL__ < 702
tokenType ITthreadsafe= "EK"
#endif
tokenType ITunsafe= "EK"
tokenType ITstdcallconv= "EK"
tokenType ITccallconv= "EK"
#if __GLASGOW_HASKELL__ >= 612
tokenType ITprimcallconv= "EK"
#endif
tokenType ITmdo= "EK"
tokenType ITfamily= "EK"
tokenType ITgroup= "EK"
tokenType ITby= "EK"
tokenType ITusing= "EK"
tokenType (ITinline_prag {})="P"
#if __GLASGOW_HASKELL__ >= 612 && __GLASGOW_HASKELL__ < 700
tokenType (ITinline_conlike_prag {})="P"
#endif
tokenType ITspec_prag="P"
tokenType (ITspec_inline_prag {})="P"
tokenType ITsource_prag="P"
tokenType ITrules_prag="P"
tokenType ITwarning_prag="P"
tokenType ITdeprecated_prag="P"
tokenType ITline_prag="P"
tokenType ITscc_prag="P"
tokenType ITgenerated_prag="P"
tokenType ITcore_prag="P"
tokenType ITunpack_prag="P"
#if __GLASGOW_HASKELL__ >= 612
tokenType ITann_prag="P"
#endif
tokenType ITclose_prag="P"
tokenType (IToptions_prag {})="P"
tokenType (ITinclude_prag {})="P"
tokenType ITlanguage_prag="P"
tokenType ITdotdot="S"
tokenType ITcolon="S"
tokenType ITdcolon="S"
tokenType ITequal="S"
tokenType ITlam="S"
tokenType ITvbar="S"
tokenType ITlarrow="S"
tokenType ITrarrow="S"
tokenType ITat="S"
tokenType ITtilde="S"
tokenType ITdarrow="S"
tokenType ITminus="S"
tokenType ITbang="S"
tokenType ITstar="S"
tokenType ITdot="S"
tokenType ITbiglam="ES"
tokenType ITocurly="SS"
tokenType ITccurly="SS"
tokenType ITocurlybar="SS"
tokenType ITccurlybar="SS"
tokenType ITvocurly="SS"
tokenType ITvccurly="SS"
tokenType ITobrack="SS"
tokenType ITopabrack="SS"
tokenType ITcpabrack="SS"
tokenType ITcbrack="SS"
tokenType IToparen="SS"
tokenType ITcparen="SS"
tokenType IToubxparen="SS"
tokenType ITcubxparen="SS"
tokenType ITsemi="SS"
tokenType ITcomma="SS"
tokenType ITunderscore="SS"
tokenType ITbackquote="SS"
tokenType (ITvarid {})="IV"
tokenType (ITconid {})="IC"
tokenType (ITvarsym {})="IV"
tokenType (ITconsym {})="IC"
tokenType (ITqvarid {})="IV"
tokenType (ITqconid {})="IC"
tokenType (ITqvarsym {})="IV"
tokenType (ITqconsym {})="IC"
tokenType (ITprefixqvarsym {})="IV"
tokenType (ITprefixqconsym {})="IC"
tokenType (ITdupipvarid {})="EI"
tokenType (ITchar {})="LC"
tokenType (ITstring {})="LS"
tokenType (ITinteger {})="LI"
tokenType (ITrational {})="LR"
tokenType (ITprimchar {})="LC"
tokenType (ITprimstring {})="LS"
tokenType (ITprimint {})="LI"
tokenType (ITprimword {})="LW"
tokenType (ITprimfloat {})="LF"
tokenType (ITprimdouble {})="LD"
tokenType ITopenExpQuote="TH"
tokenType ITopenPatQuote="TH"
tokenType ITopenDecQuote="TH"
tokenType ITopenTypQuote="TH"
tokenType ITcloseQuote="TH"
tokenType (ITidEscape {})="TH"
tokenType ITparenEscape="TH"
#if __GLASGOW_HASKELL__ < 704
tokenType ITvarQuote="TH"
#endif
tokenType ITtyQuote="TH"
tokenType (ITquasiQuote {})="TH"
tokenType ITproc="A"
tokenType ITrec="A"
tokenType IToparenbar="A"
tokenType ITcparenbar="A"
tokenType ITlarrowtail="A"
tokenType ITrarrowtail="A"
tokenType ITLarrowtail="A"
tokenType ITRarrowtail="A"
#if __GLASGOW_HASKELL__ <= 611
tokenType ITdotnet="SS"
tokenType (ITpragma _) = "SS"
#endif
tokenType (ITunknown {})=""
tokenType ITeof=""
tokenType (ITdocCommentNext {})="D"
tokenType (ITdocCommentPrev {})="D"
tokenType (ITdocCommentNamed {})="D"
tokenType (ITdocSection {})="D"
tokenType (ITdocOptions {})="D"
tokenType (ITdocOptionsOld {})="D"
tokenType (ITlineComment {})="D"
tokenType (ITblockComment {})="D"
#if __GLASGOW_HASKELL__ >= 702
tokenType (ITinterruptible {})="EK"
tokenType (ITvect_prag {})="P"
tokenType (ITvect_scalar_prag {})="P"
tokenType (ITnovect_prag {})="P"
#endif
#if __GLASGOW_HASKELL__ >= 704
tokenType ITcapiconv= "EK"
tokenType ITnounpack_prag= "P"
tokenType ITtildehsh= "S"
tokenType ITsimpleQuote="SS"
#endif
dotFS :: FastString
dotFS = fsLit "."
tokenValue :: Bool -> Token -> T.Text
tokenValue _ t | tokenType t `elem` ["K", "EK"] = T.drop 2 $ mkTokenName t
tokenValue _ (ITvarid a) = mkUnqualTokenValue a
tokenValue _ (ITconid a) = mkUnqualTokenValue a
tokenValue _ (ITvarsym a) = mkUnqualTokenValue a
tokenValue _ (ITconsym a) = mkUnqualTokenValue a
tokenValue False (ITqvarid (_,a)) = mkUnqualTokenValue a
tokenValue True (ITqvarid (q,a)) = mkQualifiedTokenValue q a
tokenValue False(ITqconid (_,a)) = mkUnqualTokenValue a
tokenValue True (ITqconid (q,a)) = mkQualifiedTokenValue q a
tokenValue False (ITqvarsym (_,a)) = mkUnqualTokenValue a
tokenValue True (ITqvarsym (q,a)) = mkQualifiedTokenValue q a
tokenValue False (ITqconsym (_,a)) = mkUnqualTokenValue a
tokenValue True (ITqconsym (q,a)) = mkQualifiedTokenValue q a
tokenValue False (ITprefixqvarsym (_,a)) = mkUnqualTokenValue a
tokenValue True (ITprefixqvarsym (q,a)) = mkQualifiedTokenValue q a
tokenValue False (ITprefixqconsym (_,a)) = mkUnqualTokenValue a
tokenValue True (ITprefixqconsym (q,a)) = mkQualifiedTokenValue q a
tokenValue _ _= ""
instance Monoid (Bag a) where
mempty = emptyBag
mappend = unionBags
mconcat = unionManyBags
start, end :: SrcSpan -> (Int,Int)
#if __GLASGOW_HASKELL__ < 702
start ss= (srcSpanStartLine ss, srcSpanStartCol ss)
end ss= (srcSpanEndLine ss, srcSpanEndCol ss)
#else
start (RealSrcSpan ss)= (srcSpanStartLine ss, srcSpanStartCol ss)
start (UnhelpfulSpan _)=error "UnhelpfulSpan in cmpOverlap start"
end (RealSrcSpan ss)= (srcSpanEndLine ss, srcSpanEndCol ss)
end (UnhelpfulSpan _)=error "UnhelpfulSpan in cmpOverlap start"
#endif