buildwrapper-0.4.0: src/Language/Haskell/BuildWrapper/GHC.hs
{-# LANGUAGE CPP, OverloadedStrings, TypeSynonymInstances,StandaloneDeriving,DeriveDataTypeable,ScopedTypeVariables, MultiParamTypeClasses, PatternGuards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Module : Language.Haskell.BuildWrapper.GHC
-- Author : JP Moresmau
-- Copyright : (c) JP Moresmau 2011
-- License : BSD3
--
-- Maintainer : jpmoresmau@gmail.com
-- Stability : beta
-- Portability : portable
--
-- Load relevant module in the GHC AST and get GHC messages and thing at point info.
module Language.Haskell.BuildWrapper.GHC where
import Language.Haskell.BuildWrapper.Base hiding (Target)
import Language.Haskell.BuildWrapper.Find
import Language.Haskell.BuildWrapper.GHCStorage
-- import Text.JSON
-- import Data.DeriveTH
-- import Data.Derive.JSON
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 SrcLoc
import GHC.Paths ( libdir )
import HscTypes ( srcErrorMessages, SourceError, liftIO)
import Outputable
import FastString (FastString,unpackFS,concatFS,fsLit,mkFastString)
import Lexer
import PprTyThing ( pprTypeForUser )
import Bag
#if __GLASGOW_HASKELL__ >= 610
import StringBuffer
#endif
import System.FilePath
--import System.Time
import qualified MonadUtils as GMU
import qualified Data.ByteString.Lazy as BS
getAST :: FilePath -> FilePath -> String -> [String] -> IO (OpResult (Maybe TypecheckedSource))
getAST =withASTNotes (\t -> do
return $ tm_typechecked_source t
)
withAST :: (TypecheckedModule -> Ghc a) -> FilePath -> FilePath -> String -> [String] -> IO (Maybe a)
withAST f fp base_dir mod options= do
(a,_)<-withASTNotes f fp base_dir mod options
return a
withJSONAST :: (Value -> IO a) -> FilePath -> FilePath -> String -> [String] -> IO (Maybe a)
withJSONAST f fp base_dir mod options=do
mv<-readGHCInfo fp
case mv of
Just v-> f v >>= return . Just
Nothing->do
(mTc,ns)<-getAST fp base_dir mod options
case mTc of
Just tc->f (dataToJSON tc) >>= return . Just
Nothing -> return Nothing
withASTNotes :: (TypecheckedModule -> Ghc a) -> FilePath -> FilePath -> String -> [String] -> IO (OpResult (Maybe a))
withASTNotes f fp base_dir mod options=do
let lflags=map noLoc options
-- putStrLn $ show options
(_leftovers, _) <- parseStaticFlags lflags
runGhc (Just libdir) $ do
flg <- getSessionDynFlags
(flg', _, _) <- parseDynamicFlags flg _leftovers
GHC.defaultCleanupHandler flg' $ do
ref <- GMU.liftIO $ newIORef []
-- our options here
-- if we use OneShot, we need the other modules to be built
-- so we can't use hscTarget = HscNothing
-- and it takes a while to actually generate the o and hi files for big modules
-- if we use CompManager, it's slower for modules with lots of dependencies but we can keep hscTarget= HscNothing which makes it better for bigger modules
setSessionDynFlags flg' {hscTarget = HscNothing, ghcLink = NoLink , ghcMode = CompManager, log_action = logAction ref }
-- $ dopt_set (flg' { ghcLink = NoLink , ghcMode = CompManager }) Opt_ForceRecomp
addTarget Target { targetId = TargetFile fp Nothing, targetAllowObjCode = True, targetContents = Nothing }
--c1<-GMU.liftIO getClockTime
let modName=mkModuleName mod
-- loadWithLogger (logWarnErr ref)
res<- load (LoadUpTo modName) -- LoadAllTargets
`gcatch` (\(e :: SourceError) -> handle_error ref e)
--(warns, errs) <- GMU.liftIO $ readIORef ref
--let notes = ghcMessagesToNotes base_dir (warns, errs)
notes <- GMU.liftIO $ readIORef ref
--c2<-GMU.liftIO getClockTime
--GMU.liftIO $ putStrLn ("load all targets: " ++ (timeDiffToString $ diffClockTimes c2 c1))
case res of
Succeeded -> do
modSum <- getModSummary $ modName
p <- parseModule modSum
--return $ showSDocDump $ ppr $ pm_mod_summary p
t <- typecheckModule p
d <- desugarModule t -- to get warnings
l <- loadModule d
--c3<-GMU.liftIO getClockTime
setContext [ms_mod modSum] []
GMU.liftIO $ storeGHCInfo fp (typecheckedSource $ dm_typechecked_module l)
--GMU.liftIO $ putStrLn ("parse, typecheck load: " ++ (timeDiffToString $ diffClockTimes c3 c2))
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,notes2)
#endif
Failed -> return $ (Nothing,notes)
where
-- logWarnErr :: GhcMonad m => IORef [BWNote] -> Maybe SourceError -> m ()
-- logWarnErr ref err = do
-- let errs = case err of
-- Nothing -> mempty
-- Just exc -> srcErrorMessages exc
-- warns <- getWarnings
-- clearWarnings
-- add_warn_err ref warns errs
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
-- warns <- getWarnings
-- add_warn_err ref warns errs
-- clearWarnings
return Failed
logAction :: IORef [BWNote] -> Severity -> SrcSpan -> PprStyle -> Message -> IO ()
logAction ref s loc ppr 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 ppr,qualModule ppr) msg
}
modifyIORef ref $ \ns -> ( ns ++ [n])
| otherwise=do
return ()
bwSeverity :: Severity -> Maybe BWNoteStatus
bwSeverity SevWarning = Just BWWarning
bwSeverity SevError = Just BWError
bwSeverity SevFatal = Just BWError
bwSeverity _ = Nothing
--f $ tm_typechecked_source t
--return $ showSDocDump $ ppr $ pm_parsed_source p
--return $ showSDocDump $ ppr $ tm_typechecked_source t
--return $ makeObj [("parse" , (showJSON $ tm_typechecked_source t))]
--return r
-- | Convert 'GHC.Messages' to '[BWNote]'.
--
-- This will mix warnings and errors, but you can split them back up
-- by filtering the '[BWNote]' based on the 'bw_status'.
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 mod options=do
names<-withAST (\_->do
--c1<-GMU.liftIO getClockTime
names<-getNamesInScope
--c2<-GMU.liftIO getClockTime
--GMU.liftIO $ putStrLn ("getNamesInScope: " ++ (timeDiffToString $ diffClockTimes c2 c1))
return $ map (showSDocDump . ppr ) names) f base_dir mod options
return $ fromMaybe[] names
getThingAtPoint :: Int -> Int -> Bool -> Bool -> FilePath -> FilePath -> String -> [String] -> IO String
getThingAtPoint line col qual typed fp base_dir mod options= do
t<-withAST (\tcm->do
let loc = srcLocSpan $ mkSrcLoc (fsLit fp) line (scionColToGhcCol col)
uq<-unqualifiedForModule tcm
--liftIO $ debugToJSON (typecheckedSource tcm)
--liftIO $ debugFindInJSON line col (typecheckedSource tcm)
let f=(if typed then (doThingAtPointTyped $ typecheckedSource tcm) else (doThingAtPointUntyped $ renamedSource tcm))
--tap<- doThingAtPoint loc qual typed tcm (if typed then (typecheckedSource tcm) else (renamedSource tcm))
let tap=f loc qual tcm uq
--(if typed then (doThingAtPointTyped $ typecheckedSource tcm)
-- else doThingAtPointTyped (renamedSource tcm) loc qual tcm
return tap) fp base_dir mod options
return $ fromMaybe "no info" t
where
doThingAtPointTyped :: TypecheckedSource -> SrcSpan -> Bool -> TypecheckedModule -> PrintUnqualified -> String
doThingAtPointTyped src loc qual tcm uq=let
in_range = overlaps loc
r = searchBindBag in_range noSrcSpan src
unqual = if qual
then alwaysQualify
else uq
--liftIO $ putStrLn $ showData TypeChecker 2 src
in case pathToDeepest r of
Nothing -> "no info"
Just (x,xs) ->
case typeOf (x,xs) of
Just t ->
showSDocForUser unqual
(prettyResult x <+> dcolon <+>
pprTypeForUser True t)
_ -> showSDocForUser unqual (prettyResult x) --(Just (showSDocDebug (ppr x $$ ppr xs )))
doThingAtPointUntyped :: (Search id a, OutputableBndr id) => a -> SrcSpan -> Bool -> TypecheckedModule -> PrintUnqualified -> String
doThingAtPointUntyped src loc qual tcm uq=let
in_range = overlaps loc
r = findHsThing in_range src
unqual = if qual
then neverQualify
else uq
in case pathToDeepest r of
Nothing -> "no info"
Just (x,_) ->
if qual
then showSDocForUser unqual ((qualifiedResult x) <+> (text $ haddockType x))
else showSDocForUser unqual ((prettyResult x) <+> (text $ haddockType x))
getThingAtPointJSON :: Int -> Int -> Bool -> Bool -> FilePath -> FilePath -> String -> [String] -> IO String
getThingAtPointJSON line col qual typed fp base_dir mod options= do
mr<-withJSONAST (\v->do
let f=overlap line (scionColToGhcCol col)
let mf=findInJSON f v
BS.putStrLn $ encode (fromJust mf)
return $ findInJSONFormatted qual typed mf
) fp base_dir mod options
return $ fromMaybe "no info" mr
unqualifiedForModule :: TypecheckedMod m => m -> Ghc PrintUnqualified
unqualifiedForModule tcm =fromMaybe alwaysQualify `fmap` mkPrintUnqualifiedForModule (moduleInfo tcm)
--data S a=S String
--
--instance Show (S a) where
-- show (S s)=s
--
--data TestLoc=TestLoc Int Int
-- deriving (Show,Data,Typeable)
--data Test=Test [TestLoc]
-- deriving (Show,Data,Typeable)
--
--test1=Test [TestLoc 3 4,TestLoc 2 14,TestLoc 3 16]
--
--getThingAtPoint :: TypecheckedSource -> Int -> Int -> [String]
--getThingAtPoint ts line col= everything (++) ([] `mkQ` (\x -> p x )) test1
-- -- synthesize [] toS (mkQ Nothing toS) test1
-- where
-- p :: TestLoc -> [String]
-- p t@(TestLoc a b)= if a==line || b==col
-- then [show t]
-- else []
--
--getThingAtPoint :: TypecheckedSource -> Int -> Int -> [String]
--getThingAtPoint ts line col= maybeToList $ something (mkQ Nothing toS) test1
-- where
-- toS :: TestLoc -> Maybe String
-- toS t@(TestLoc a b)=if a==line || b==col
-- then Just $ show t
-- else Nothing
--getThingAtPoint :: TypecheckedSource -> Int -> Int -> [String]
--getThingAtPoint ts line col=map show ((listify (mkQ False (isJust . toS)) test1)::[TestLoc])
-- -- maybeToList $ something (mkQ Nothing toS) test1
-- where
-- toS :: TestLoc -> Maybe String
-- toS t@(TestLoc a b)=if a==line || b==col
-- then Just $ show t
-- else Nothing
--newtype C a = C a deriving (Data,Typeable)
--
----getThingAtPoint :: TypecheckedSource -> Int -> Int -> [String]
--
--coerce :: a -> C a
--coerce = unsafeCoerce
--uncoerce :: C a -> a
--uncoerce = unsafeCoerce
--
--fmapData :: forall t a b. (Typeable a, Data (t (C a)), Data (t a)) =>
-- (a -> b) -> t a -> t b
--fmapData f input = uc . everything (++) ([] `mkQ` (\(x::C a) -> [coerce (f (uncoerce x))]))
-- $ (coerce input)
-- where uc = unsafeCoerce
--
--getThingAtPoint :: TypecheckedSource -> Int -> Int -> [String]
--getThingAtPoint ts line col= --map unLoc $ filter (\(L _ o)->not $ null o) $ fmapData overlap (bagToList ts)
-- map unLoc $ filter (\(L _ o)->not $ null o) $ everything (++) ([] `mkQ` overlap) (bagToList ts)
-- where
-- --overlap :: forall b1 . (Outputable b1, Typeable b1) =>Located b1 -> Located String
-- overlap :: Located (HsBindLR Id Id) -> [Located String]
-- overlap (L loc o)= let
-- st=srcSpanStart loc
-- en=srcSpanEnd loc
-- in if (isGoodSrcLoc st) && (isGoodSrcLoc en) && ((srcLocLine st) <= line) && ((srcLocCol st) <=col) && ((srcLocLine en) >= line) && ((srcLocCol en) >=col)
-- then [L loc $ showSDocDump $ ppr o]
-- else []
--
-- [showData TypeChecker 4 ts]
--getThingAtPoint :: TypecheckedSource -> Int -> Int -> [String]
--getThingAtPoint ts line col= map pr lf
-- --maybeToList $ something (mkQ Nothing toS) ts -- listify (mkQ False overlap) ts
-- where
-- lf :: forall b1 . (Outputable b1, Typeable b1) => [Located b1]
-- lf=listify (mkQ False overlap) ts
-- --find :: (Outputable a,Typeable a) => TypecheckedSource -> [Located a]
-- --find = listify $ overlap
-- toS :: forall b1 . (Outputable b1, Typeable b1) =>Located b1 -> Maybe String
-- toS l= if overlap l
-- then Just $ pr l
-- else Nothing
-- pr :: forall b1 . (Outputable b1) => Located b1 -> String
-- pr=showSDocDump . ppr . unLoc
-- --showData TypeChecker 4
-- overlap :: forall b1 . (Outputable b1, Typeable b1) =>Located b1 -> Bool
-- overlap (a::Located b1)= let
-- (L loc _)=a
-- st=srcSpanStart loc
-- en=srcSpanEnd loc
-- in (isGoodSrcLoc st) && (isGoodSrcLoc en) && ((srcLocLine st) <= line) && ((srcLocCol st) <=col) && ((srcLocLine en) >= line) && ((srcLocCol en) >=col)
-- -- overlap _ =False
--
--
ghcSpanToLocation :: FilePath -- ^ Base directory
-> GHC.SrcSpan
-> InFileSpan
ghcSpanToLocation baseDir 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 -- ^ Base directory
-> 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 -- WHY do we get two slashed after the drive sometimes?
| otherwise=c:x:xs
f c s=c:s
#if __GLASGOW_HASKELL__ < 702
sfile ss= GHC.srcSpanFile ss
#else
sfile (RealSrcSpan ss)= GHC.srcSpanFile ss
#endif
ghcColToScionCol :: Int -> Int
#if __GLASGOW_HASKELL__ < 700
ghcColToScionCol c=c+1 -- GHC 6.x starts at 0 for columns
#else
ghcColToScionCol c=c -- GHC 7 starts at 1 for columns
#endif
scionColToGhcCol :: Int -> Int
#if __GLASGOW_HASKELL__ < 700
scionColToGhcCol c=c-1 -- GHC 6.x starts at 0 for columns
#else
scionColToGhcCol c=c -- GHC 7 starts at 1 for columns
#endif
-- | Get a stream of tokens generated by the GHC lexer from the current document
ghctokensArbitrary :: FilePath -- ^ The file path to the document
-> String -- ^ The document's contents
-> [String] -- ^ The options
-> 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 -- 6.12
, Opt_DoRec -- 6.12
#endif
]
-- | Filter tokens whose span appears legitimate (start line is less than end line, start column is
-- less than end column.)
ofInterest :: Located Token -> Bool
ofInterest (L span _) =
let (sl,sc) = start span
(el,ec) = end span
in (sl < el) || (sc < ec)
--toInteractive :: Location -> Location
--toInteractive l =
-- let (_, sl1, sc1, el1, ec1) = viewLoc l
-- in mkLocation interactive sl1 sc1 el1 ec1
-- | Convert a GHC token to an interactive token (abbreviated token type)
tokenToType :: FilePath -> Located Token -> TokenDef
tokenToType base_dir (L sp t) = TokenDef (tokenType t) (ghcSpanToLocation base_dir sp)
-- | Generate the interactive token list used by EclipseFP for syntax highlighting
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 projectRoot)
-- | Extract occurrences based on lexing
occurrences :: FilePath -- ^ Project root or base directory for absolute path conversion
-> String -- ^ Contents to be parsed
-> T.Text -- ^ Token value to find
-> Bool -- ^ Literate source flag (True = literate, False = ordinary)
-> [String] -- ^ Options
-> IO (Either BWNote [TokenDef])
occurrences projectRoot contents query literate options =
let
qualif = isJust $ T.find (=='.') query
-- Get the list of tokens matching the query for relevant token types
tokensMatching :: [TokenDef] -> [TokenDef]
tokensMatching = filter matchingVal
matchingVal :: TokenDef -> Bool
matchingVal (TokenDef v _)=query==v
mkTokenDef (L sp t)=TokenDef (tokenValue qualif t) (ghcSpanToLocation projectRoot sp)
in generateTokens projectRoot contents literate options (map mkTokenDef) tokensMatching
-- | Parse the current document, generating a TokenDef list, filtered by a function
generateTokens :: FilePath -- ^ The project's root directory
-> String -- ^ The current document contents, to be parsed
-> Bool -- ^ Literate Haskell flag
-> [String] -- ^ The options
-> ([Located Token] -> [TokenDef]) -- ^ Transform function from GHC tokens to TokenDefs
-> ([TokenDef] -> a) -- ^ The TokenDef filter function
-> IO (Either BWNote a)
generateTokens projectRoot contents literate options xform filterFunc =
let (ppTs, ppC) = preprocessSource contents literate
in ghctokensArbitrary projectRoot ppC options
>>= (\result ->
case result of
Right toks ->
let filterResult = filterFunc $ List.sortBy (comparing td_loc) (ppTs ++ (xform toks))
--liftIO $ putStrLn $ show tokenList
in return $ Right filterResult
Left n -> return $ Left n
)
-- | Preprocess some source, returning the literate and Haskell source as tuple.
--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 (Seq.empty,Seq.empty,False) linesWithCount
-- in (F.toList ts, F.concatMap (++ "\n") nc)
-- ppSCpp :: (Seq.Seq TokenDef,Seq.Seq String,Bool) -> (String,Int) -> (Seq.Seq TokenDef,Seq.Seq String,Bool)
-- ppSCpp (ts2,l2,f) (l,c)
-- | f = addPPToken "PP" (l,c) (ts2,l2,'\\' == (last l))
-- | ('#':_)<-l =addPPToken "PP" (l,c) (ts2,l2,'\\' == (last l))
-- | ("{-# " `List.isPrefixOf` l)=addPPToken "D" (l,c) (ts2,l2,False)
-- | otherwise =(ts2,l2 Seq.|> l,False)
-- ppSLit :: (Seq.Seq TokenDef,Seq.Seq String,Bool) -> (String,Int) -> (Seq.Seq TokenDef,Seq.Seq String,Bool)
-- ppSLit (ts2,l2,f) (l,c)
-- | "\\begin{code}" `List.isPrefixOf` l=addPPToken "DL" ("\\begin{code}",c) (ts2,l2,True)
-- | "\\end{code}" `List.isPrefixOf` l=addPPToken "DL" ("\\end{code}",c) (ts2,l2,False)
-- | f = (ts2,l2 Seq.|> l,True)
-- | ('>':lCode)<-l=(ts2,l2 Seq.|> (' ':lCode ),f)
-- | otherwise =addPPToken "DL" (l,c) (ts2,l2,f)
-- addPPToken :: T.Text -> (String,Int) -> (Seq.Seq TokenDef,Seq.Seq String,Bool) -> (Seq.Seq TokenDef,Seq.Seq String,Bool)
-- addPPToken name (l,c) (ts2,l2,f) =(ts2 Seq.|> (TokenDef name (mkFileSpan c 1 c ((length l)+1))),l2 Seq.|> "",f)
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
-- Note that we don *not* include the extra info, since that information is
-- only useful in the case where we don not show the error location directly
-- in the source.
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
| List.isPrefixOf "Warning:" s = List.dropWhile isSpace $ drop 8 s
| otherwise = s
removeStatus BWError s
| List.isPrefixOf "Error:" 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]
-- | Make a token definition from its source location and Lexer.hs token type.
mkTokenDef :: FilePath -> Located Token -> TokenDef
mkTokenDef base_dir (L sp t) = TokenDef (mkTokenName t) (ghcSpanToLocation base_dir sp)
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" -- Haskell keywords
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" -- ToDo: remove (we use {-# SCC "..." #-} now)
tokenType ITforall = "EK" -- GHC extension keywords
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"
-- Pragmas
tokenType (ITinline_prag {})="P" -- True <=> INLINE, False <=> NOINLINE
#if __GLASGOW_HASKELL__ >= 612 && __GLASGOW_HASKELL__ < 700
tokenType (ITinline_conlike_prag {})="P" -- same
#endif
tokenType ITspec_prag="P" -- SPECIALISE
tokenType (ITspec_inline_prag {})="P" -- SPECIALISE INLINE (or NOINLINE)
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" -- hdaume: core annotations
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" -- reserved symbols
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" -- GHC-extension symbols
tokenType ITocurly="SS" -- special symbols
tokenType ITccurly="SS"
tokenType ITocurlybar="SS" -- "{|", for type applications
tokenType ITccurlybar="SS" -- "|}", for type applications
tokenType ITvocurly="SS"
tokenType ITvccurly="SS"
tokenType ITobrack="SS"
tokenType ITopabrack="SS" -- [:, for parallel arrays with -XParr
tokenType ITcpabrack="SS" -- :], for parallel arrays with -XParr
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" -- identifiers
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" -- GHC extension: implicit param: ?x
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"
-- Template Haskell extension tokens
tokenType ITopenExpQuote="TH" -- [| or [e|
tokenType ITopenPatQuote="TH" -- [p|
tokenType ITopenDecQuote="TH" -- [d|
tokenType ITopenTypQuote="TH" -- [t|
tokenType ITcloseQuote="TH" --tokenType ]
tokenType (ITidEscape {})="TH" -- $x
tokenType ITparenEscape="TH" -- $(
tokenType ITvarQuote="TH" -- '
tokenType ITtyQuote="TH" -- ''
tokenType (ITquasiQuote {})="TH" -- [:...|...|]
-- Arrow notation extension
tokenType ITproc="A"
tokenType ITrec="A"
tokenType IToparenbar="A" -- (|
tokenType ITcparenbar="A" --tokenType )
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 {})="" -- Used when the lexer can't make sense of it
tokenType ITeof="" -- end of file token
-- Documentation annotations
tokenType (ITdocCommentNext {})="D" -- something beginning '-- |'
tokenType (ITdocCommentPrev {})="D" -- something beginning '-- ^'
tokenType (ITdocCommentNamed {})="D" -- something beginning '-- $'
tokenType (ITdocSection {})="D" -- a section heading
tokenType (ITdocOptions {})="D" -- doc options (prune, ignore-exports, etc)
tokenType (ITdocOptionsOld {})="D" -- doc options declared "-- # ..."-style
tokenType (ITlineComment {})="D" -- comment starting by "--"
tokenType (ITblockComment {})="D" -- comment in {- -}
-- 7.2 new token types
#if __GLASGOW_HASKELL__ >= 702
tokenType (ITinterruptible {})="EK"
tokenType (ITvect_prag {})="P"
tokenType (ITvect_scalar_prag {})="P"
tokenType (ITnovect_prag {})="P"
#endif
dotFS :: FastString
dotFS = fsLit "."
tokenValue :: Bool -> Token -> T.Text
tokenValue _ t | elem (tokenType t) ["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
--instance JSON SrcLoc
-- where showJSON src
-- | isGoodSrcLoc src =makeObj [((unpackFS $ srcLocFile src) , (JSArray [showJSON $ srcLocLine src,showJSON $ srcLocCol src])) ]
-- | otherwise = JSNull
--
--instance JSON SrcSpan
-- where showJSON src
-- | isGoodSrcSpan src=makeObj [((unpackFS $ srcSpanFile src) , (JSArray [showJSON $ srcSpanStartLine src,showJSON $ srcSpanStartCol src,showJSON $ srcSpanEndLine src,showJSON $ srcSpanEndCol src])) ]
-- | otherwise = JSNull
--
--instance JSON FastString
-- where showJSON=JSString . toJSString . unpackFS
--
--instance JSON ModuleName
-- where showJSON=JSString . toJSString . moduleNameString
--
--instance JSON OccName
-- where showJSON=JSString . toJSString . showSDocDump . ppr
--
--instance JSON Type
-- where showJSON =JSString . toJSString . showSDocDump . ppr
--
--instance JSON DataCon
-- where showJSON=JSString . toJSString . showSDocDump . ppr
--
--instance JSON Unique
-- where showJSON=JSString . toJSString . showSDocDump . ppr
--
--instance JSON Name
-- where showJSON=JSString . toJSString . showSDocDump . ppr
--
--instance JSON EvBindsVar
-- where showJSON=JSString . toJSString . showSDocDump . ppr
--
--instance JSON PackageId
-- where showJSON=JSString . toJSString . showSDocDump . ppr
--
--instance (JSON a)=> JSON (Bag a)
-- where showJSON=JSArray . map showJSON . bagToList
--
--instance (JSON a)=> JSON (UniqSet a)
-- where showJSON=JSArray . map showJSON . uniqSetToList
--
--instance JSON Rational
-- where showJSON=JSRational False
--
--instance JSON Var
-- where showJSON v=makeObj [("Name",showJSON $ Var.varName v),("Unique",showJSON $ varUnique v),("Type",showJSON $ varType v)]
--
--instance JSON RdrName
-- where
-- showJSON (Unqual on) = JSArray [showJSON on]
-- showJSON (Qual mn on) = JSArray [showJSON mn,showJSON on]
--
--instance(JSON a)=> JSON (Located a)
-- where showJSON (L s o)=case showJSON o of
-- JSObject o->let
-- ass=fromJSObject o
-- in JSObject $ toJSObject (("Loc",(showJSON s)):ass)
-- JSNull -> JSNull
-- v->makeObj [("Loc",(showJSON s)),("Object" ,v)]
--
-- $( derive makeJSON ''HsModule )
-- $( derive makeJSON ''ImportDecl )
-- $( derive makeJSON ''HsDocString )
-- $( derive makeJSON ''HsDecl)
-- $( derive makeJSON ''WarningTxt)
--
--
-- $( derive makeJSON ''InstDecl )
---- $( derive makeJSON ''HsBind )
-- $( derive makeJSON ''HsBindLR )
-- $( derive makeJSON ''DefaultDecl )
-- $( derive makeJSON ''WarnDecl )
-- $( derive makeJSON ''RuleDecl )
-- $( derive makeJSON ''DocDecl )
-- $( derive makeJSON ''HsQuasiQuote )
-- $( derive makeJSON ''SpliceDecl )
-- $( derive makeJSON ''AnnDecl )
-- $( derive makeJSON ''ForeignDecl )
-- $( derive makeJSON ''Sig )
-- $( derive makeJSON ''DerivDecl )
-- $( derive makeJSON ''TyClDecl )
--
-- $( derive makeJSON ''NewOrData )
-- $( derive makeJSON ''HsTyVarBndr )
-- $( derive makeJSON ''HsPred )
-- $( derive makeJSON ''HsType )
-- $( derive makeJSON ''ConDecl )
-- $( derive makeJSON ''FamilyFlavour )
-- $( derive makeJSON ''ResType )
-- $( derive makeJSON ''HsConDetails )
-- $( derive makeJSON ''HsExplicitFlag )
-- $( derive makeJSON ''ConDeclField )
-- $( derive makeJSON ''Boxity )
-- $( derive makeJSON ''HsSplice )
-- $( derive makeJSON ''HsBang )
-- $( derive makeJSON ''IPName )
-- $( derive makeJSON ''HsExpr )
--
-- $( derive makeJSON ''HsLit)
-- $( derive makeJSON ''MatchGroup)
-- $( derive makeJSON ''HsStmtContext)
-- $( derive makeJSON ''HsBracket)
-- $( derive makeJSON ''Pat)
-- $( derive makeJSON ''HsWrapper)
-- $( derive makeJSON ''HsCmdTop)
-- $( derive makeJSON ''Fixity)
-- $( derive makeJSON ''HsArrAppType)
-- $( derive makeJSON ''ArithSeqInfo)
-- $( derive makeJSON ''HsRecFields )
-- $( derive makeJSON ''HsRecField )
-- $( derive makeJSON ''StmtLR )
-- $( derive makeJSON ''HsLocalBindsLR )
-- $( derive makeJSON ''HsTupArg )
-- $( derive makeJSON ''HsOverLit )
-- $( derive makeJSON ''OverLitVal )
-- $( derive makeJSON ''HsValBindsLR )
-- $( derive makeJSON ''HsIPBinds )
-- $( derive makeJSON ''IPBind )
-- $( derive makeJSON ''FixitySig )
-- $( derive makeJSON ''InlinePragma )
-- $( derive makeJSON ''Match )
-- $( derive makeJSON ''Activation )
-- $( derive makeJSON ''RuleMatchInfo )
-- $( derive makeJSON ''InlineSpec )
-- $( derive makeJSON ''RecFlag )
-- $( derive makeJSON ''GRHSs )
-- $( derive makeJSON ''GRHS )
-- $( derive makeJSON ''FixityDirection )
-- $( derive makeJSON ''EvTerm )
-- $( derive makeJSON ''TcEvBinds )
-- $( derive makeJSON ''ForeignExport )
-- $( derive makeJSON ''ForeignImport )
-- $( derive makeJSON ''HsMatchContext )
-- $( derive makeJSON ''HsGroup )
-- $( derive makeJSON ''CExportSpec )
-- $( derive makeJSON ''CImportSpec )
-- $( derive makeJSON ''CCallConv )
-- $( derive makeJSON ''CCallTarget )
-- $( derive makeJSON ''EvBind )
-- $( derive makeJSON ''Safety )
-- $( derive makeJSON ''AnnProvenance )
-- $( derive makeJSON ''RuleBndr )
-- $( derive makeJSON ''TcSpecPrags )
-- $( derive makeJSON ''TcSpecPrag )
--
--instance (JSON a)=> JSON (IE a)
-- where
-- showJSON= showJSON . ieName
--
-- {--
-- p <- parseModule modSum
-- t <- typecheckModule p
-- d <- desugarModule t
-- l <- loadModule d
-- n <- getNamesInScope
-- c <- return $ coreModule d
--
-- g <- getModuleGraph
-- mapM showModule g
-- return $ (parsedSource d,"/n-----/n", typecheckedSource d)
-- --}
--
--{--
--instance ToJSON SrcLoc
-- where toJSON src
-- | isGoodSrcLoc src =object [(pack $ unpackFS $ srcLocFile src) .= (Array $ fromList [toJSON $ srcLocLine src,toJSON $ srcLocCol src]) ]
-- | otherwise = Null
--
--instance ToJSON SrcSpan
-- where toJSON src
-- | isGoodSrcSpan src=object [(pack $ unpackFS $ srcSpanFile src) .= (Array $ fromList [toJSON $ srcSpanStartLine src,toJSON $ srcSpanStartCol src,toJSON $ srcSpanEndLine src,toJSON $ srcSpanEndCol src]) ]
-- | otherwise = Null
--
--instance(ToJSON a)=> ToJSON (Located a)
-- where toJSON (L s o)=case toJSON o of
-- Object o->Object (M.insert "Loc" (toJSON s) o)
-- Null -> Null
-- v->object ["Loc" .= (toJSON s),"Object" .= v]
--
--instance (ToJSON a, OutputableBndr a)=> ToJSON (HsModule a)
-- where toJSON hsm=object ["ModName" .= (toJSON $ hsmodName hsm),
-- "Exports" .= (toJSON $ hsmodExports hsm),
-- "Imports" .= (toJSON $ hsmodImports hsm),
-- "Decls" .= (toJSON $ hsmodDecls hsm)
-- ]
--
--instance ToJSON FastString
-- where toJSON=toJSON . pack . unpackFS
--
--instance ToJSON ModuleName
-- where toJSON=toJSON . moduleNameString
--
--instance ToJSON OccName
-- where toJSON=toJSON . showSDocDump . ppr
--
--instance ToJSON RdrName
-- where
-- toJSON (Unqual on) = Array $ fromList [toJSON on]
-- toJSON (Qual mn on) = Array $ fromList [toJSON mn,toJSON on]
--
--instance (ToJSON a)=> ToJSON (IE a)
-- where
-- toJSON= toJSON . ieName --}
-- {--toJSON (IEVar name)= object ["IEVar" .= toJSON name]
-- toJSON (IEThingAbs name)=object ["IEThingAbs" .= toJSON name]
-- toJSON (IEThingAll name)= object ["IEThingAll" .= toJSON name]
-- toJSON (IEThingWith name ns)= object ["IEVar" .= toJSON name]
-- toJSON (IEModuleContents mn)= object ["IEModuleContents" .= toJSON name]
-- toJSON (IEGroup i hds)= object ["IEVar" .= toJSON hds]
-- toJSON (IEDoc hds)= object ["IEDoc" .= toJSON hds]
-- toJSON (IEDocNamed s)= object ["IEDocNamed" .= toJSON s] --}
--{--
--instance (ToJSON a)=> ToJSON (ImportDecl a)
-- where
-- toJSON imd=object ["ModName" .= toJSON (ideclName imd),
-- "PackageQualified" .= toJSON (ideclPkgQual imd),
-- "Source" .= toJSON (ideclSource imd),
-- "Qualified" .= toJSON (ideclQualified imd),
-- "As" .= toJSON (ideclAs imd),
-- "Hiding" .= toJSON (ideclHiding imd)
-- ]
--
--instance (ToJSON a, OutputableBndr a)=> ToJSON (HsDecl a)
-- where toJSON =toJSON . showSDocDump . ppr
--
-- --}