module Language.Haskell.BuildWrapper.GHC where
import Language.Haskell.BuildWrapper.Base hiding (Target,ImportExportType(..))
import Language.Haskell.BuildWrapper.GHCStorage
import Prelude hiding (readFile, writeFile)
import Control.Applicative ((<$>))
import Data.Char
import Data.Generics hiding (Fixity, typeOf, empty)
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 qualified Data.Map as DM
import qualified Data.Set as DS
import qualified Data.HashMap.Lazy as HM
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as BSC
import DynFlags
import ErrUtils
( ErrMsg(..), WarnMsg, mkPlainErrMsg,Messages,ErrorMessages,WarningMessages
#if __GLASGOW_HASKELL__ > 704
, MsgDoc
#else
, Message
#endif
)
import GHC
import GHC.Paths ( libdir )
import HscTypes (srcErrorMessages, SourceError, GhcApiError, extendInteractiveContext, hsc_IC)
import Outputable
import FastString (FastString,unpackFS,concatFS,fsLit,mkFastString, lengthFS)
import Lexer hiding (loc)
import Bag
import Linker
import RtClosureInspect
#if __GLASGOW_HASKELL__ >= 707
import ConLike
import PatSyn (patSynType)
#endif
import GhcMonad
import Id
import Var hiding (varName)
import UniqSupply
import PprTyThing
#if __GLASGOW_HASKELL__ >= 702
import SrcLoc
#endif
#if __GLASGOW_HASKELL__ >= 610
import StringBuffer
#endif
import System.FilePath
import qualified MonadUtils as GMU
import Name (isTyVarName,isDataConName,isVarName,isTyConName, mkInternalName)
import Control.Monad (when, liftM, liftM2)
import qualified Data.Vector as V (foldr)
import Module (moduleNameFS)
import System.IO (hFlush, stdout, stderr)
import System.Directory (getModificationTime)
#if __GLASGOW_HASKELL__ < 706
import System.Time (ClockTime(TOD))
#else
import Data.Time.Clock (UTCTime(UTCTime))
import Data.Time.Calendar (Day(ModifiedJulianDay))
#endif
import Control.Exception (SomeException)
import Exception (gtry)
import Control.Arrow ((&&&))
import Unsafe.Coerce (unsafeCoerce)
import OccName (mkOccName, varName)
type GHCApplyFunction a=FilePath -> TypecheckedModule -> Ghc a
getAST :: FilePath
-> FilePath
-> String
-> [String]
-> IO (OpResult (Maybe TypecheckedSource))
getAST fp base_dir modul opts=do
(a,n)<-withASTNotes (\_ -> return . tm_typechecked_source) id base_dir (SingleFile fp modul) opts
return (listToMaybe a,n)
withAST :: (TypecheckedModule -> Ghc a)
-> FilePath
-> FilePath
-> String
-> [String]
-> IO (Maybe a)
withAST f fp base_dir modul options= do
(a,_)<-withASTNotes (const f) id base_dir (SingleFile fp modul) options
return $ listToMaybe 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
mv2<-withAST gen fp base_dir modul options
case mv2 of
Just v2->fmap Just (f v2)
Nothing-> return Nothing
where gen tc=do
df<-getSessionDynFlags
env<-getSession
GMU.liftIO $ generateGHCInfo df env tc
withASTNotes :: GHCApplyFunction a
-> (FilePath -> FilePath)
-> FilePath
-> LoadContents
-> [String]
-> IO (OpResult [a])
withASTNotes f ff base_dir contents =initGHC (ghcWithASTNotes f ff base_dir contents True)
initGHC :: Ghc a
-> [String]
-> IO a
initGHC f options= do
let cleaned=filter (not . List.isInfixOf "-O") options
let lflags=map noLoc cleaned
(_leftovers, _) <- parseStaticFlags lflags
runGhc (Just libdir) $ do
flg <- getSessionDynFlags
(flg', _, _) <- parseDynamicFlags flg _leftovers
GHC.defaultCleanupHandler flg' $ do
setSessionDynFlags flg' {hscTarget = HscInterpreted, ghcLink = LinkInMemory , ghcMode = CompManager}
f
ghcWithASTNotes ::
GHCApplyFunction a
-> (FilePath -> FilePath)
-> FilePath
-> LoadContents
-> Bool
-> Ghc (OpResult [a])
ghcWithASTNotes f ff base_dir contents shouldAddTargets= do
ref <- GMU.liftIO $ newIORef []
cflg <- getSessionDynFlags
#if __GLASGOW_HASKELL__ > 704
setSessionDynFlags cflg {log_action = logAction ref }
#else
setSessionDynFlags cflg {log_action = logAction ref cflg }
#endif
let fps=getLoadFiles contents
when shouldAddTargets
(mapM_ (\(fp,_)-> addTarget Target { targetId = TargetFile fp Nothing, targetAllowObjCode = False, targetContents = Nothing }) fps)
let howMuch=LoadAllTargets
sf<-load howMuch
`gcatch` (\(e :: SourceError) -> handle_error ref e)
`gcatch` (\(ae :: GhcApiError) -> do
dumpError ref contents ae
return Failed)
`gcatch` (\(se :: SomeException) -> do
dumpError ref contents se
return Failed)
a<-case sf of
Failed-> return []
_ -> catMaybes <$> mapM (\(fp,m)->(do
modSum <- getModSummary $ mkModuleName m
Just <$> workOnResult f fp modSum)
`gcatch` (\(se :: SourceError) -> do
dumpError ref contents se
return Nothing)
`gcatch` (\(ae :: GhcApiError) -> do
dumpError ref contents ae
return Nothing)
`gcatch` (\(se :: SomeException) -> do
dumpError ref contents se
return Nothing)
) fps
notes <- GMU.liftIO $ readIORef ref
#if __GLASGOW_HASKELL__ < 702
warns <- getWarnings
df <- getSessionDynFlags
return (a,List.nub $ notes ++ reverse (ghcMessagesToNotes df base_dir (warns, emptyBag)))
#else
return (a,List.nub notes)
#endif
where
processError :: LoadContents -> String -> Bool
processError MultipleFile{} "Module not part of module graph"=False
processError _ _=True
dumpError :: (Show a)=> IORef [BWNote] -> LoadContents -> a -> Ghc ()
dumpError ref conts ae= when (processError conts (show ae)) (do
GMU.liftIO $ print conts
GMU.liftIO $ print ae
case conts of
(SingleFile fp _)->do
let relfp=makeRelative base_dir $ normalise fp
let notes=[BWNote BWError (show ae) (BWLocation relfp 1 1 1 1)]
GMU.liftIO $ modifyIORef ref $
\ ns -> ns ++ notes
_->return ()
)
workOnResult :: GHCApplyFunction a -> FilePath -> ModSummary -> Ghc a
workOnResult f2 fp modSum= do
p <- parseModule modSum
t <- typecheckModule p
d <- desugarModule t
l <- loadModule d
#if __GLASGOW_HASKELL__ < 704
setContext [ms_mod modSum] []
#else
#if __GLASGOW_HASKELL__ < 706
setContext [IIModule $ ms_mod modSum]
#else
setContext [IIModule $ moduleName $ ms_mod modSum]
#endif
#endif
let fullfp=ff fp
let opts=ms_hspp_opts modSum
setSessionDynFlags opts
env <- getSession
GMU.liftIO $ storeGHCInfo opts env fullfp (dm_typechecked_module l)
f2 fp $ dm_typechecked_module l
add_warn_err :: GhcMonad m => IORef [BWNote] -> WarningMessages -> ErrorMessages -> m()
add_warn_err ref warns errs = do
df <- getSessionDynFlags
let notes = ghcMessagesToNotes df 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
#if __GLASGOW_HASKELL__ > 704
logAction :: IORef [BWNote] -> DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
#else
logAction :: IORef [BWNote] -> DynFlags -> Severity -> SrcSpan -> PprStyle -> Message -> IO ()
#endif
logAction ref df s loc style msg
| (Just status)<-bwSeverity df s=do
let n=BWNote { bwnLocation = ghcSpanToBWLocation base_dir loc
, bwnStatus = status
, bwnTitle = removeBaseDir base_dir $ removeStatus status $ showSDUser (qualName style,qualModule style) df msg
}
modifyIORef ref $ \ ns -> ns ++ [n]
| otherwise=return ()
bwSeverity :: DynFlags -> Severity -> Maybe BWNoteStatus
bwSeverity df SevWarning = Just (if isWarnIsError df then BWError else BWWarning)
bwSeverity _ SevError = Just BWError
bwSeverity _ SevFatal = Just BWError
bwSeverity _ _ = Nothing
isWarnIsError :: DynFlags -> Bool
#if __GLASGOW_HASKELL__ >= 707
isWarnIsError df = gopt Opt_WarnIsError df
#else
isWarnIsError df = dopt Opt_WarnIsError df
#endif
ghcMessagesToNotes :: DynFlags ->
FilePath
-> Messages
-> [BWNote]
ghcMessagesToNotes df base_dir (warns, errs) = map_bag2ms (ghcWarnMsgToNote df base_dir) warns ++
map_bag2ms (ghcErrMsgToNote df 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
df<-getSessionDynFlags
return $ map (showSDDump df . ppr ) names) f base_dir modul options
return $ fromMaybe[] names
getGhcNameDefsInScope :: FilePath
-> FilePath
-> String
-> [String]
-> IO (OpResult (Maybe [NameDef]))
getGhcNameDefsInScope fp base_dir modul options=do
(nns,ns)<-withASTNotes (\_ _->do
names<-getNamesInScope
df<-getSessionDynFlags
mapM (name2nd df) names) id base_dir (SingleFile fp modul) options
return $ case nns of
(x:_)->(Just x,ns)
_->(Nothing, ns)
getGhcNameDefsInScopeLongRunning :: FilePath
-> FilePath
-> String
-> [String]
-> IO ()
getGhcNameDefsInScopeLongRunning fp base_dir modul =
#if __GLASGOW_HASKELL__ < 706
initGHC (go (TOD 0 0))
#else
initGHC (go (UTCTime (ModifiedJulianDay 0) 0))
#endif
where
#if __GLASGOW_HASKELL__ < 706
go :: ClockTime -> Ghc ()
#else
go :: UTCTime -> Ghc ()
#endif
go t1 = do
let hasLoaded=case t1 of
#if __GLASGOW_HASKELL__ < 706
TOD 0 _ -> False
#else
UTCTime (ModifiedJulianDay 0) _ -> False
#endif
_ -> True
t2<- GMU.liftIO $ getModificationTime fp
(ns1,add2)<-if hasLoaded && t2==t1 then
(do
removeTarget (TargetFile fp Nothing)
load LoadAllTargets
return ([],True)
) `gcatch` (\(e :: SourceError) -> do
let errs = srcErrorMessages e
df <- getSessionDynFlags
return (ghcMessagesToNotes df base_dir (emptyBag, errs),True)
)
else return ([],not hasLoaded)
(nns,ns)<- ghcWithASTNotes (\_ _->do
names<-getNamesInScope
df<-getSessionDynFlags
mapM (name2nd df) names) id base_dir (SingleFile fp modul) add2
let res=case nns of
(x:_) -> (Just x,ns1 ++ ns)
_ -> (Nothing,ns1 ++ ns)
GMU.liftIO $ BSC.putStrLn $ BS.append "build-wrapper-json:" $ encode res
GMU.liftIO $ hFlush stdout
r1 t2
r1 t2=do
l<- GMU.liftIO getLine
case l of
"q"->return ()
'e':' ':expr->do
s<-getEvalResults expr
GMU.liftIO $ do
let js=encode (s,[]::[BWNote])
hFlush stdout
hFlush stderr
BSC.putStrLn ""
BSC.putStrLn $ BS.append "build-wrapper-json:" js
hFlush stdout
r1 t2
"t"->do
input<- GMU.liftIO $ readFile fp
ett<-tokenTypesArbitrary' fp input (".lhs" == takeExtension fp)
let ret= case ett of
Right tt-> (tt,[])
Left bw -> ([],[bw])
GMU.liftIO $ do
BSC.putStrLn $ BS.append "build-wrapper-json:" $ encode ret
hFlush stdout
r1 t2
'o':xs->do
input<- GMU.liftIO $ readFile fp
ett<-occurrences' fp input (T.pack xs) (".lhs" == takeExtension fp)
let ret= case ett of
Right tt-> (tt,[])
Left bw -> ([],[bw])
GMU.liftIO $ do
BSC.putStrLn $ BS.append "build-wrapper-json:" $ encode ret
hFlush stdout
r1 t2
'p':xs->do
GMU.liftIO $ do
let (line,col)=read xs
mv<-readGHCInfo fp
let mm=case mv of
Just v->let
f=overlap line (scionColToGhcCol col)
mf=findInJSON f v
in findInJSONData mf
_-> Nothing
BSC.putStrLn $ BS.append "build-wrapper-json:" $ encode (mm,[]::[BWNote])
hFlush stdout
r1 t2
'l':xs->do
GMU.liftIO $ do
let (sline,scol,eline,ecol)=read xs
mv<-readGHCInfo fp
let mm=case mv of
Just v->let
cont=contains sline (scionColToGhcCol scol) eline (scionColToGhcCol ecol)
isVar=isGHCType "Var"
mf=findAllInJSON (\x->cont x && isVar x) v
in mapMaybe (findInJSONData . Just) mf
_-> []
BSC.putStrLn $ BS.append "build-wrapper-json:" $ encode (mm,[]::[BWNote])
hFlush stdout
r1 t2
_ ->go t2
getEvalResults :: forall (m :: * -> *).
GhcMonad m =>
String -> m [EvalResult]
getEvalResults expr=handleSourceError (\e->return [EvalResult Nothing Nothing (Just $ show e)])
(do
df<-getSessionDynFlags
do
rr<- runStmt expr RunToCompletion
case rr of
RunOk ns->do
let q=(qualName &&& qualModule) defaultUserStyle
mapM (\n->do
mty<-lookupName n
case mty of
Just (AnId aid)->do
#if __GLASGOW_HASKELL__ >= 707
let pprTyp = (pprTypeForUser . idType) aid
#else
let pprTyp = (pprTypeForUser True . idType) aid
#endif
t<-gtry $ GHC.obtainTermFromId maxBound True aid
evalDoc<-case t of
Right term -> showTerm term
Left exn -> return (text "*** Exception:" <+>
text (show (exn :: SomeException)))
return $ EvalResult (Just $ showSDUser q df pprTyp) (Just $ showSDUser neverQualify df evalDoc) Nothing
_->return $ EvalResult Nothing Nothing Nothing
) ns
RunException e ->return [EvalResult Nothing Nothing (Just $ show e)]
_->return []
`gfinally`
setSessionDynFlags df)
where
showTerm :: GhcMonad m => Term -> m SDoc
showTerm =
cPprTerm (liftM2 (++) (const [cPprShowable]) cPprTermBase)
cPprShowable prec Term{ty=ty, val=val} =
do
hsc_env <- getSession
dflags <- GHC.getSessionDynFlags
do
(new_env, bname) <- bindToFreshName hsc_env ty "showme"
setSession new_env
let exprS = "show " ++ showPpr dflags bname
txt_ <- withExtendedLinkEnv [(bname, val)]
(GHC.compileExpr exprS)
let myprec = 10
let txt = unsafeCoerce txt_
return $ if not (null txt)
then Just $ cparen (prec >= myprec && needsParens txt)
(text txt)
else Nothing
`gfinally`
setSession hsc_env
cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =
cPprShowable prec t{ty=new_ty}
cPprShowable _ _ = return Nothing
needsParens ('"':_) = False
needsParens ('(':_) = False
needsParens txt = ' ' `elem` txt
bindToFreshName hsc_env ty userName = do
name <- newGrimName userName
let mkid = AnId $ mkVanillaGlobal name ty
new_ic = extendInteractiveContext (hsc_IC hsc_env) [mkid]
return (hsc_env {hsc_IC = new_ic }, name)
newGrimName :: GMU.MonadIO m => String -> m Name
newGrimName userName = do
us <- liftIO $ mkSplitUniqSupply 'b'
let unique = uniqFromSupply us
occname = mkOccName varName userName
name = mkInternalName unique occname noSrcSpan
return name
name2nd :: GhcMonad m=> DynFlags -> Name -> m NameDef
name2nd df n=do
#if __GLASGOW_HASKELL__ >= 707
m<- getInfo False n
let ty=case m of
Just (tyt,_,_,_)->ty2t tyt
#else
m<- getInfo n
let ty=case m of
Just (tyt,_,_)->ty2t tyt
#endif
Nothing->Nothing
return $ NameDef (T.pack $ showSDDump df $ ppr n) (name2t n) ty
where
name2t :: Name -> [OutlineDefType]
name2t n2
| isTyVarName n2=[Type]
| isTyConName n2=[Type]
| isDataConName n2 = [Constructor]
| isVarName n2 = [Function]
| otherwise =[]
ty2t :: TyThing -> Maybe T.Text
#if __GLASGOW_HASKELL__ >= 707
ty2t (AnId aid)=Just $ T.pack $ showSD False df $ pprTypeForUser $ varType aid
ty2t (AConLike(RealDataCon dc))=Just $ T.pack $ showSD False df $ pprTypeForUser $ dataConUserType dc
ty2t (AConLike(PatSynCon ps))=Just $ T.pack $ showSD False df $ pprTypeForUser $ patSynType ps
#else
ty2t (AnId aid)=Just $ T.pack $ showSD False df $ pprTypeForUser True $ varType aid
ty2t (ADataCon dc)=Just $ T.pack $ showSD False df $ pprTypeForUser True $ dataConUserType dc
#endif
ty2t _ = Nothing
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
getLocalsJSON ::Int
-> Int
-> Int
-> Int
-> FilePath
-> FilePath
-> String
-> [String]
-> IO [ThingAtPoint]
getLocalsJSON sline scol eline ecol fp base_dir modul options= do
mmf<-withJSONAST (\v->do
let cont=contains sline (scionColToGhcCol scol) eline (scionColToGhcCol ecol)
let isVar=isGHCType "Var"
let mf=findAllInJSON (\x->cont x && isVar x) v
return $ mapMaybe (findInJSONData . Just) mf
) fp base_dir modul options
return $ fromMaybe [] mmf
eval :: String
-> FilePath
-> FilePath
-> String
-> [String]
-> IO [EvalResult]
eval expression fp base_dir modul options= do
mf<-withASTNotes (\_ _->getEvalResults expression) id base_dir (SingleFile fp modul) options
return $ concat $ fst mf
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
(enl,enc)=end sp
in BWLocation (makeRelative baseDir $ foldr f [] $ normalise $ unpackFS (sfile sp))
stl
(ghcColToScionCol stc)
enl
(ghcColToScionCol enc)
| otherwise = mkEmptySpan "" 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 = lexTokenStreamH sb lexLoc dflags1
case prTS of
POk _ toks ->
return $ Right $ filter ofInterest toks
PFailed loc msg -> return $ Left $ ghcErrMsgToNote dflags1 base_dir $
#if __GLASGOW_HASKELL__ < 706
mkPlainErrMsg loc msg
#else
mkPlainErrMsg dflags1 loc msg
#endif
ghctokensArbitrary' :: FilePath
-> String
-> Ghc (Either BWNote [Located Token])
ghctokensArbitrary' base_dir contents= do
#if __GLASGOW_HASKELL__ < 702
sb <- stringToStringBuffer contents
#else
let sb=stringToStringBuffer contents
#endif
flg' <- getSessionDynFlags
#if __GLASGOW_HASKELL__ >= 700
let dflags1 = List.foldl' xopt_set flg' lexerFlags
#else
let dflags1 = List.foldl' dopt_set flg' lexerFlags
#endif
let prTS = lexTokenStreamH sb lexLoc dflags1
case prTS of
POk _ toks ->
return $ Right $ filter ofInterest toks
PFailed loc msg -> return $ Left $ ghcErrMsgToNote dflags1 base_dir $
#if __GLASGOW_HASKELL__ < 706
mkPlainErrMsg loc msg
#else
mkPlainErrMsg dflags1 loc msg
#endif
lexTokenStreamH :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token]
lexTokenStreamH buf loc dflags = unP go initState
#if __GLASGOW_HASKELL__ >= 707
where dflags' = gopt_set (gopt_set dflags Opt_KeepRawTokenStream) Opt_Haddock
#else
where dflags' = dopt_set (dopt_set dflags Opt_KeepRawTokenStream) Opt_Haddock
#endif
initState = mkPState dflags' buf loc
go = do
ltok <- lexer return
case ltok of
L _ ITeof -> return []
_ -> liftM (ltok:) go
#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
, 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
tokenTypesArbitrary' :: FilePath -> String -> Bool -> Ghc (Either BWNote [TokenDef])
tokenTypesArbitrary' projectRoot contents literate = generateTokens' projectRoot contents literate 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
occurrences' :: FilePath
-> String
-> T.Text
-> Bool
-> Ghc (Either BWNote [TokenDef])
occurrences' projectRoot contents query literate =
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 (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 tdLoc) (ppTs ++ xform toks)
return $ Right filterResult
Left n -> return $ Left n
generateTokens' :: FilePath
-> String
-> Bool
-> ([Located Token] -> [TokenDef])
-> ([TokenDef] -> a)
-> Ghc (Either BWNote a)
generateTokens' projectRoot contents literate xform filterFunc =do
let (ppTs, ppC) = preprocessSource contents literate
result<- ghctokensArbitrary' projectRoot ppC
case result of
Right toks ->do
let filterResult = filterFunc $ List.sortBy (comparing tdLoc) (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)
| (ContinuePragma f2) <-f= addPPToken "P" (l,c) (ts2,"":l2,pragmaBehavior l f2)
| ('#':_)<-l =addPPToken "PP" (l,c) (ts2,l2,lineBehavior l f)
| Just (l',s,e,f2)<-pragmaExtract l f=
(TokenDef "P" (mkFileSpan c s c e) : ts2 ,l':l2,f2)
| (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)
ContinuePragma p->p
Indent n->Indent (n+1)
_ -> Indent 1
pragmaBehavior l f
| "-}" `List.isInfixOf` l = f
| otherwise = ContinuePragma f
pragmaExtract :: String -> PPBehavior -> Maybe (String,Int,Int,PPBehavior)
pragmaExtract l f=
let
(spl1,spl2)=splitString "{-# " l
in if not $ null spl2
then
let
startIdx= length spl1
(spl3,spl4)=splitString "-}" spl2
in if not $ null spl4
then
let
endIdx= length spl3 + 2
len=endIdx
in Just (spl1++ replicate len ' ' ++ drop 2 spl4,startIdx+1,startIdx+len+1,f)
else Just (spl1,startIdx+1,length l+1,ContinuePragma f)
else Nothing
data PPBehavior=Continue Int | Indent Int | Start | ContinuePragma PPBehavior
deriving Eq
ghcErrMsgToNote :: DynFlags -> FilePath -> ErrMsg -> BWNote
ghcErrMsgToNote df= ghcMsgToNote df BWError
ghcWarnMsgToNote :: DynFlags -> FilePath -> WarnMsg -> BWNote
ghcWarnMsgToNote df= ghcMsgToNote df (if isWarnIsError df then BWError else BWWarning)
ghcMsgToNote :: DynFlags -> BWNoteStatus -> FilePath -> ErrMsg -> BWNote
ghcMsgToNote df note_kind base_dir msg =
BWNote { bwnLocation = ghcSpanToBWLocation base_dir loc
, bwnStatus = note_kind
, bwnTitle = removeBaseDir base_dir $ removeStatus note_kind $ show_msg (errMsgShortDoc msg)
}
where
#if __GLASGOW_HASKELL__ >= 707
loc | s <- errMsgSpan msg = s
#else
loc | (s:_) <- errMsgSpans msg = s
#endif
| otherwise = GHC.noSrcSpan
unqual = errMsgContext msg
show_msg = showSDUser unqual df
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"
#if __GLASGOW_HASKELL__ < 707
tokenType ITscc = "K"
#endif
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"
#if __GLASGOW_HASKELL__ < 706
tokenType ITocurlybar="SS"
tokenType ITccurlybar="SS"
#endif
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 {})="VS"
tokenType (ITconsym {})="IC"
tokenType (ITqvarid {})="IV"
tokenType (ITqconid {})="IC"
tokenType (ITqvarsym {})="VS"
tokenType (ITqconsym {})="IC"
tokenType (ITprefixqvarsym {})="VS"
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 {})="C"
tokenType (ITblockComment {})="C"
#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
#if __GLASGOW_HASKELL__ >= 706
tokenType ITctype= "P"
tokenType ITlcase= "S"
tokenType (ITqQuasiQuote {}) = "TH"
#endif
#if __GLASGOW_HASKELL__ >= 708
tokenType ITjavascriptcallconv = "EK"
tokenType ITrole = "EK"
tokenType ITpattern = "EK"
tokenType ITminimal_prag = "EK"
tokenType ITopenTExpQuote = "TH"
tokenType ITcloseTExpQuote = "TH"
tokenType (ITidTyEscape {}) = "TH"
tokenType ITparenTyEscape = "TH"
#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 :: SrcSpan -> (Int,Int)
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
type AliasMap=DM.Map ModuleName [ModuleName]
ghcImportToUsage :: T.Text -> LImportDecl Name -> ([Usage],AliasMap) -> Ghc ([Usage],AliasMap)
ghcImportToUsage myPkg (L _ imp) (ls,moduMap)=(do
let L src modu=ideclName imp
pkg<-lookupModule modu (ideclPkgQual imp)
df<-getSessionDynFlags
let tmod=T.pack $ showSD True df $ ppr modu
tpkg=T.pack $ showSD True df $ ppr $ modulePackageId pkg
nomain=if tpkg=="main" then myPkg else tpkg
subs=concatMap (ghcLIEToUsage df (Just nomain) tmod "import") $ maybe [] snd $ ideclHiding imp
moduMap2=maybe moduMap (\alias->let
mlmods=DM.lookup alias moduMap
newlmods=case mlmods of
Just lmods->modu:lmods
Nothing->[modu]
in DM.insert alias newlmods moduMap) $ ideclAs imp
usg =Usage (Just nomain) tmod "" "import" False (toJSON $ ghcSpanToLocation src) False
return (usg:subs++ls,moduMap2)
)
`gcatch` (\(se :: SourceError) -> do
GMU.liftIO $ print se
return ([],moduMap))
ghcLIEToUsage :: DynFlags -> Maybe T.Text -> T.Text -> T.Text -> LIE Name -> [Usage]
ghcLIEToUsage df tpkg tmod tsection (L src (IEVar nm))=[ghcNameToUsage df tpkg tmod tsection nm src False]
ghcLIEToUsage df tpkg tmod tsection (L src (IEThingAbs nm))=[ghcNameToUsage df tpkg tmod tsection nm src True ]
ghcLIEToUsage df tpkg tmod tsection (L src (IEThingAll nm))=[ghcNameToUsage df tpkg tmod tsection nm src True]
ghcLIEToUsage df tpkg tmod tsection (L src (IEThingWith nm cons))=ghcNameToUsage df tpkg tmod tsection nm src True :
map (\ x -> ghcNameToUsage df tpkg tmod tsection x src False) cons
ghcLIEToUsage _ tpkg tmod tsection (L src (IEModuleContents _))= [Usage tpkg tmod "" tsection False (toJSON $ ghcSpanToLocation src) False]
ghcLIEToUsage _ _ _ _ _=[]
ghcExportToUsage :: DynFlags -> T.Text -> T.Text ->AliasMap -> LIE Name -> Ghc [Usage]
ghcExportToUsage df myPkg myMod moduMap lie@(L _ name)=(do
ls<-case name of
(IEModuleContents modu)-> do
let realModus=fromMaybe [modu] (DM.lookup modu moduMap)
mapM (\modu2->do
pkg<-lookupModule modu2 Nothing
let tpkg=T.pack $ showSD True df $ ppr $ modulePackageId pkg
let tmod=T.pack $ showSD True df $ ppr modu2
return (tpkg,tmod)
) realModus
_ -> return [(myPkg,myMod)]
return $ concatMap (\(tpkg,tmod)->ghcLIEToUsage df (Just tpkg) tmod "export" lie) ls
)
`gcatch` (\(se :: SourceError) -> do
GMU.liftIO $ print se
return [])
ghcNameToUsage :: DynFlags -> Maybe T.Text -> T.Text -> T.Text -> Name -> SrcSpan -> Bool -> Usage
ghcNameToUsage df tpkg tmod tsection nm src typ=Usage tpkg tmod (T.pack $ showSD False df $ ppr nm) tsection typ (toJSON $ ghcSpanToLocation src) False
type ImportMap=DM.Map T.Text (LImportDecl Name,[T.Text])
ghcImportMap :: LImportDecl Name -> Ghc ImportMap
ghcImportMap l@(L _ imp)=(do
let L _ modu=ideclName imp
let moduS=T.pack $ moduleNameString modu
let mm=DM.singleton moduS (l,[])
m<-lookupModule modu Nothing
mmi<-getModuleInfo m
df <- getSessionDynFlags
let maybeHiding=ideclHiding imp
let hidden=case maybeHiding of
Just(True,ns)->map (T.pack . showSD False df . ppr . unLoc) ns
_ ->[]
let fullM =case mmi of
Nothing -> mm
Just mi->let
exps=modInfoExports mi
in foldr insertImport mm exps
where insertImport :: Name -> ImportMap -> ImportMap
insertImport x mmx=
let
expM=T.pack $ moduleNameString $ moduleName $ nameModule x
nT=T.pack $ showSD False df $ ppr x
in if nT `elem` hidden
then mmx
else DM.insertWith (\(_,xs1) (_,xs2)->(l,xs1++xs2)) expM (l,[nT]) mmx
return $ if ideclImplicit imp
then DM.insert "" (l, concatMap snd $ DM.elems fullM) fullM
else fullM
)
`gcatch` (\(se :: SourceError) -> do
GMU.liftIO $ print se
return DM.empty)
type TypeMap=DM.Map T.Text (DM.Map T.Text (DS.Set T.Text))
type FinalImportValue=(LImportDecl Name,DM.Map T.Text (DS.Set T.Text))
type FinalImportMap=DM.Map T.Text FinalImportValue
ghcCleanImports :: FilePath
-> FilePath
-> String
-> [String]
-> Bool
-> IO (OpResult [ImportClean])
ghcCleanImports f base_dir modul options doFormat = do
(m,bwns)<-withASTNotes clean (base_dir </>) base_dir (SingleFile f modul) options
return (if null m then [] else head m,bwns)
where
clean :: GHCApplyFunction [ImportClean]
clean _ tm=do
let (_,imps,_,_)=fromJust $ tm_renamed_source tm
df <- getSessionDynFlags
env<- getSession
let modu=T.pack $ showSD True df $ ppr $ moduleName $ ms_mod $ pm_mod_summary $ tm_parsed_module tm
(Array vs)<- GMU.liftIO $ generateGHCInfo df env tm
impMaps<-mapM ghcImportMap imps
let implicit=DS.fromList $ concatMap (maybe [] snd . DM.lookup "") impMaps
let allImps=concatMap DM.assocs impMaps
let usgMap=V.foldr ghcValToUsgMap DM.empty vs
let usgMapWithoutMe=DM.delete modu usgMap
let ftm=foldr (buildImportCleanMap usgMapWithoutMe implicit) DM.empty allImps
let missingCleans=getRemovedImports allImps ftm
let formatF=if doFormat then formatImports else map (dumpImportMap df)
let allCleans=formatF (DM.elems ftm) ++ missingCleans
return allCleans
ghcValToUsgMap :: Value -> TypeMap -> TypeMap
ghcValToUsgMap (Object m) um |
Just (String n)<-HM.lookup "Name" m,
Just (String mo)<-HM.lookup "Module" m,
not $ T.null mo,
mst<-HM.lookup "Type" m,
Just (String ht)<-HM.lookup "HType" m
=let
mm=DM.lookup mo um
isType=ht=="t"
isConstructor=not isType && isUpper (T.head n) && isJust mst && Null /= fromJust mst
key=if isConstructor
then let
Just (String t)=mst
in fst $ T.breakOn " " $ T.strip $ snd $ T.breakOnEnd "->" t
else n
val=if isConstructor
then DS.singleton n
else DS.empty
in case mm of
Just usgM1->DM.insert mo (DM.insertWith DS.union key val usgM1) um
Nothing->DM.insert mo (DM.singleton key val) um
ghcValToUsgMap _ um=um
buildImportCleanMap :: TypeMap -> DS.Set T.Text ->(T.Text,(LImportDecl Name,[T.Text])) -> FinalImportMap -> FinalImportMap
buildImportCleanMap usgMap implicit (cmod,(l@(L _ imp),ns)) tm |
Just namesMap<-DM.lookup cmod usgMap,
namesMapFiltered<-foldr (keepKeys namesMap) DM.empty ns,
namesWithoutImplicit<-if ideclQualified imp
then namesMapFiltered
else DM.map (`DS.difference` implicit) $ foldr DM.delete namesMapFiltered $ DS.elems implicit,
not $ DM.null namesWithoutImplicit,
not $ ideclImplicit imp = let
L _ modu=ideclName imp
moduS=T.pack $ moduleNameString modu
in DM.insertWith mergeTypeMap moduS (l,namesWithoutImplicit) tm
buildImportCleanMap _ _ _ tm = tm
keepKeys :: Ord k => DM.Map k v -> k -> DM.Map k v -> DM.Map k v
keepKeys m1 k m2=case DM.lookup k m1 of
Nothing -> m2
Just v1->DM.insert k v1 m2
mergeTypeMap :: FinalImportValue -> FinalImportValue -> FinalImportValue
mergeTypeMap (l1,m1) (_,m2)= (l1,DM.unionWith DS.union m1 m2)
dumpImportMap :: DynFlags -> FinalImportValue -> ImportClean
dumpImportMap df (L loc imp,ns)=let
txt= T.pack $ showSDDump df $ ppr (imp{ideclHiding=Nothing} :: ImportDecl Name)
nameList= T.intercalate ", " $ List.sortBy (comparing T.toLower) $ map buildName $ DM.assocs ns
full=txt `mappend` " (" `mappend` nameList `mappend` ")"
in ImportClean (ghcSpanToLocation loc) full
pprName :: T.Text -> T.Text
pprName n | T.null n =n
| isAlpha $ T.head n=n
| otherwise=T.concat ["(",n,")"]
buildName :: (T.Text,DS.Set T.Text)->T.Text
buildName (n,cs)
| DS.null cs=pprName n
| otherwise =let
nameList= T.intercalate ", " $ List.sortBy (comparing T.toLower) $ map pprName $ DS.toList cs
in pprName n `mappend` " (" `mappend` nameList `mappend` ")"
getRemovedImports :: [(T.Text,(LImportDecl Name,[T.Text]))] -> FinalImportMap -> [ImportClean]
getRemovedImports allImps ftm= let
cleanedLines=DS.fromList $ map (\(L l _,_)->iflLine $ifsStart $ ghcSpanToLocation l) $ DM.elems ftm
missingImps=filter (\(_,(L l imp,_))->not $ ideclImplicit imp || DS.member (iflLine $ifsStart $ ghcSpanToLocation l) cleanedLines) allImps
in nubOrd $ map (\(_,(L l _,_))-> ImportClean (ghcSpanToLocation l) "") missingImps
getFormatInfo :: FinalImportValue -> (Int,Int,Int,Int,Int)->(Int,Int,Int,Int,Int)
getFormatInfo (L _ imp,_) (szSafe,szQualified,szPkg,szName,szAs)=let
szSafe2=if ideclSafe imp then 5 else szSafe
szQualified2=if ideclQualified imp then 10 else szQualified
szPkg2=maybe szPkg (\p->max szPkg (3 + lengthFS p)) $ ideclPkgQual imp
L _ mo=ideclName imp
szName2=maybe szName (\_->max szName (1 + lengthFS (moduleNameFS mo))) $ ideclAs imp
szAs2=maybe szAs (\m->max szAs (3 + lengthFS (moduleNameFS m))) $ ideclAs imp
in (szSafe2,szQualified2,szPkg2,szName2,szAs2)
formatImport :: (Int,Int,Int,Int,Int)-> FinalImportValue -> ImportClean
formatImport (szSafe,szQualified,szPkg,szName,szAs) (L loc imp,ns) =let
st="import "
saf=if ideclSafe imp then "safe " else T.justifyLeft szSafe ' ' ""
qual=if ideclQualified imp then "qualified " else T.justifyLeft szQualified ' ' ""
pkg=maybe (T.justifyLeft szPkg ' ' "") (\p->"\"" `mappend` T.pack (unpackFS p) `mappend` "\" ") $ ideclPkgQual imp
L _ mo=ideclName imp
nm=T.justifyLeft szName ' ' $ T.pack $ moduleNameString mo
ast=maybe (T.justifyLeft szAs ' ' "") (\m->"as " `mappend` T.pack (moduleNameString m)) $ ideclAs imp
nameList= T.intercalate ", " $ List.sortBy (comparing T.toLower) $ map buildName $ DM.assocs ns
full=st `mappend` saf `mappend` qual `mappend` pkg `mappend` nm `mappend` ast `mappend` " (" `mappend` nameList `mappend` ")"
in ImportClean (ghcSpanToLocation loc) full
formatImports :: [FinalImportValue] -> [ImportClean]
formatImports fivs = let
formatInfo=foldr getFormatInfo (0,0,0,0,0) fivs
in map (formatImport formatInfo) fivs