forked from DanielG/ghc-mod
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Info.hs
155 lines (130 loc) · 5.3 KB
/
Info.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
{-# LANGUAGE CPP, Rank2Types, TupleSections #-}
module Info (infoExpr, typeExpr) where
import Cabal
import Control.Applicative
import CoreUtils
import Data.Function
import Data.Generics
import Data.List
import Data.Maybe
import Data.Ord as O
import Desugar
import GHC
import GHC.SYB.Utils
import GHCApi
import GHCChoice
import qualified Gap
import HscTypes
import NameSet
import Outputable
import PprTyThing
import Pretty (showDocWith, Mode(OneLineMode))
import System.Time
import TcRnTypes
import Types
----------------------------------------------------------------
type Expression = String
type ModuleString = String
----------------------------------------------------------------
infoExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String
infoExpr opt modstr expr file = (++ "\n") <$> info opt file modstr expr
info :: Options -> FilePath -> ModuleString -> FilePath -> IO String
info opt fileName modstr expr =
inModuleContext opt fileName modstr exprToInfo "Cannot show info"
where
exprToInfo = infoThing expr
----------------------------------------------------------------
typeExpr :: Options -> ModuleString -> Int -> Int -> FilePath -> IO String
typeExpr opt modstr lineNo colNo file = Info.typeOf opt file modstr lineNo colNo
typeOf :: Options -> FilePath -> ModuleString -> Int -> Int -> IO String
typeOf opt fileName modstr lineNo colNo =
inModuleContext opt fileName modstr exprToType errmsg
where
exprToType = do
modSum <- getModSummary $ mkModuleName modstr
p <- parseModule modSum
tcm <- typecheckModule p
let es = findExpr tcm lineNo colNo
ts <- catMaybes <$> mapM (getType tcm) es
let sss = map toTup $ sortBy (cmp `on` fst) ts
return $ convert opt sss
toTup :: (SrcSpan, Type) -> ((Int,Int,Int,Int),String)
toTup (spn, typ) = (fourInts spn, pretty typ)
fourInts :: SrcSpan -> (Int,Int,Int,Int)
fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan
cmp a b
| a `isSubspanOf` b = O.LT
| b `isSubspanOf` a = O.GT
| otherwise = O.EQ
errmsg = convert opt ([] :: [((Int,Int,Int,Int),String)])
findExpr :: TypecheckedModule -> Int -> Int -> [LHsExpr Id]
findExpr tcm line col =
let src = tm_typechecked_source tcm
in listifyStaged TypeChecker f src
where
f :: LHsExpr Id -> Bool
f (L spn _) = isGoodSrcSpan spn && spn `spans` (line, col)
listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]
listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))
getType :: GhcMonad m => TypecheckedModule -> LHsExpr Id -> m (Maybe (SrcSpan, Type))
getType tcm e = do
hs_env <- getSession
(_, mbe) <- Gap.liftIO $ deSugarExpr hs_env modu rn_env ty_env e
return $ (getLoc e, ) <$> CoreUtils.exprType <$> mbe
where
modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm
rn_env = tcg_rdr_env $ fst $ tm_internals_ tcm
ty_env = tcg_type_env $ fst $ tm_internals_ tcm
pretty :: Type -> String
pretty = showDocWith OneLineMode . withPprStyleDoc (mkUserStyle neverQualify AllTheWay) . pprTypeForUser False
----------------------------------------------------------------
-- from ghc/InteractiveUI.hs
infoThing :: String -> Ghc String
infoThing str = do
names <- parseName str
mb_stuffs <- mapM getInfo names
let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
unqual <- getPrintUnqual
return $ showSDocForUser unqual $ vcat (intersperse (text "") $ map (pprInfo False) filtered)
filterOutChildren :: (a -> TyThing) -> [a] -> [a]
filterOutChildren get_thing xs
= [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
where
implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [Instance]) -> SDoc
pprInfo pefas (thing, fixity, insts)
= pprTyThingInContextLoc pefas thing
$$ show_fixity fixity
$$ vcat (map pprInstance insts)
where
show_fixity fx
| fx == defaultFixity = Outputable.empty
| otherwise = ppr fx <+> ppr (getName thing)
----------------------------------------------------------------
inModuleContext :: Options -> FilePath -> ModuleString -> Ghc String -> String -> IO String
inModuleContext opt fileName modstr action errmsg =
withGHC (valid ||> invalid ||> return errmsg)
where
valid = do
(file,_) <- initializeGHC opt fileName ["-w"] False
setTargetFile file
load LoadAllTargets
doif setContextFromTarget action
invalid = do
initializeGHC opt fileName ["-w"] False
setTargetBuffer
load LoadAllTargets
doif setContextFromTarget action
setTargetBuffer = do
modgraph <- depanal [mkModuleName modstr] True
let imports = concatMap (map (showSDoc . ppr . unLoc)) $
map ms_imps modgraph ++ map ms_srcimps modgraph
moddef = "module " ++ sanitize modstr ++ " where"
header = moddef : imports
importsBuf <- Gap.toStringBuffer header
clkTime <- Gap.liftIO getClockTime
setTargets [Target (TargetModule $ mkModuleName modstr) True (Just (importsBuf, clkTime))]
doif m t = m >>= \ok -> if ok then t else goNext
sanitize = fromMaybe "SomeModule" . listToMaybe . words
setContextFromTarget :: Ghc Bool
setContextFromTarget = depanal [] False >>= Gap.setCtx