/
Db.hs
322 lines (295 loc) · 13.9 KB
/
Db.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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
{-|
Module : ExHack.Data.Db
Description : Database-related operations.
Copyright : (c) Félix Baylac-Jacqué, 2018
License : GPL-3
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module ExHack.Data.Db (
getHomePagePackages,
getModulePageSyms,
getPackagePageMods,
getPkgImportScopes,
initDb,
saveModuleExports,
saveModuleUnifiedSymbols,
savePackageDeps,
savePackageMods,
savePackages
) where
import Control.Monad (unless)
import Control.Monad.Catch (Exception, MonadMask, throwM)
import qualified Data.HashMap.Strict as HM (fromList)
import qualified Data.HashSet as HS (HashSet, fromList)
import Data.Maybe (listToMaybe, maybe)
import Data.Text (Text, pack)
import qualified Data.Text as T (lines, unlines)
import Database.Selda ((:*:) (..), RowID, Selector, Table,
aggregate, autoPrimary, count, def, fk,
fromRowId, fromSql, groupBy, innerJoin,
insertWithPK, insert_, literal, query,
required, restrict, select,
tableWithSelectors, text,
tryCreateTable, (!), (.==), (.||))
import Database.Selda.Backend (MonadSelda (..), SqlValue (SqlInt))
import GHC (SrcSpan (..), getLoc, srcSpanStartCol,
srcSpanStartLine)
import ExHack.Renderer.Types (HomePagePackage (..), ModuleName (..),
PackageName (..), SymbolName,
SymbolOccurs (..))
import ExHack.Types (ImportsScope, IndexedModuleNameT (..),
IndexedSym (..), LocatedSym (..),
ModuleNameT (..), PackageExports (..),
PackageNameT (..), SourceCodeFile (..),
SourceCodeFile (..), SymName (..),
UnifiedSym (..), depsNames, getModName,
getName)
import qualified ExHack.Types as ET (Package (..))
packageId :: Selector (RowID :*: Text :*: Text :*: Text) RowID
packageName :: Selector (RowID :*: Text :*: Text :*: Text) Text
packages :: Table (RowID :*: Text :*: Text :*: Text)
(packages, packageId :*: packageName :*: _ :*: _)
= tableWithSelectors "packages" $
autoPrimary "packageId"
:*: required "name"
:*: required "tarball_path"
:*: required "cabal_file"
dependancies :: Table (RowID :*: RowID :*: RowID)
depPack :: Selector (RowID :*: RowID :*: RowID) RowID
depId :: Selector (RowID :*: RowID :*: RowID) RowID
(dependancies, _ :*: depPack :*: depId) = tableWithSelectors "dependancies" $
autoPrimary "id"
:*: required "packID" `fk` (packages, packageId)
:*: required "depID" `fk` (packages, packageId)
exposedModules :: Table (RowID :*: Text :*: RowID)
modId :: Selector (RowID :*: Text :*: RowID) RowID
modName :: Selector (RowID :*: Text :*: RowID) Text
modPack :: Selector (RowID :*: Text :*: RowID) RowID
(exposedModules, modId :*: modName :*: modPack) = tableWithSelectors "exposedModules" $
autoPrimary "id"
:*: required "name"
:*: required "packID" `fk` (packages, packageId)
exposedSymbols :: Table (RowID :*: Text :*: RowID)
symId :: Selector (RowID :*: Text :*: RowID) RowID
symName :: Selector (RowID :*: Text :*: RowID) Text
symModId :: Selector (RowID :*: Text :*: RowID) RowID
(exposedSymbols, symId :*: symName :*: symModId) = tableWithSelectors "exposedSymbols" $
autoPrimary "id"
:*: required "name"
:*: required "modId" `fk` (exposedModules, modId)
sourceFiles :: Table (RowID :*: Text :*: Text :*: Text)
fileId :: Selector (RowID :*: Text :*: Text :*: Text) RowID
fileContent :: Selector (RowID :*: Text :*: Text :*: Text) Text
fileModule :: Selector (RowID :*: Text :*: Text :*: Text) Text
filePackage :: Selector (RowID :*: Text :*: Text :*: Text) Text
(sourceFiles, fileId :*: fileContent :*: fileModule :*: filePackage)
= tableWithSelectors "sourceFiles" $
autoPrimary "id"
:*: required "fileContent"
:*: required "modName"
:*: required "packName"
symbolOccurences :: Table (RowID :*: Int :*: Int :*: RowID :*: RowID)
occCol :: Selector (RowID :*: Int :*: Int :*: RowID :*: RowID) Int
occLine :: Selector (RowID :*: Int :*: Int :*: RowID :*: RowID) Int
occFileId :: Selector (RowID :*: Int :*: Int :*: RowID :*: RowID) RowID
occSymId :: Selector (RowID :*: Int :*: Int :*: RowID :*: RowID) RowID
(symbolOccurences, _ :*: occCol :*: occLine :*: occFileId :*: occSymId)
= tableWithSelectors "symbolOccurences" $
autoPrimary "id"
:*: required "column"
:*: required "line"
:*: required "sourceFileId" `fk` (sourceFiles, fileId)
:*: required "importedSymID" `fk` (exposedSymbols, symId)
-- | Create the internal database schema.
initDb :: (MonadSelda m) => m ()
initDb = do
tryCreateTable packages
tryCreateTable dependancies
tryCreateTable exposedModules
tryCreateTable exposedSymbols
tryCreateTable symbolOccurences
tryCreateTable sourceFiles
-- | Save a package dependancies.
--
-- Note that if we can't find a dependancy in the
-- packages table, we'll ignore it.
--
-- You should make sure your package database is already
-- populated before using this.
savePackageDeps :: (MonadSelda m) => ET.Package -> m ()
savePackageDeps p = do
mpid <- queryPkg p
let resPackDeps = depsNames p
mapM_ (\rowId -> saveDep rowId `mapM_` resPackDeps) mpid
where
saveDep pid d = do
mdid <- query $ do
pks <- select packages
restrict (pks ! packageName .== text (pack d))
return $ pks ! packageId
mapM_ (\did -> insert_ dependancies [ def :*: pid :*: did]) (listToMaybe mdid)
-- | Save a package list in the DB.
savePackages :: (MonadSelda m) => [ET.Package] -> m ()
savePackages xs = insert_ packages $
(\p -> def :*: getName p :*: ET.cabalFile p :*: (pack . ET.tarballPath) p) <$> xs
data SaveModuleException = PackageNotInDatabase | ModuleNotInDatabase Text
deriving (Show)
instance Exception SaveModuleException
-- | Potentially confusing:
-- * If we have a package id in the Package type, use it
-- * Otherwise retrieve the package id from the DB
-- * If the package is not in the DB, something weird happened...
-- Throw an error
getPackageId :: forall m. (MonadSelda m, MonadMask m)
=> ET.Package -> m RowID
getPackageId p = maybe
(queryPkg p >>= maybe (throwM PackageNotInDatabase) pure)
pure
(ET.dbId p)
-- | Save the exposed modules as well as their exposed symbols.
savePackageMods :: forall m. (MonadSelda m, MonadMask m)
=> PackageExports -> m ()
savePackageMods (PackageExports (p, _, xs)) = do
pid <- getPackageId p
saveMod pid `mapM_` xs
where
saveMod pid (m, syms) = do
mid <- insertWithPK exposedModules [def :*: getModName m :*: pid]
insert_ exposedSymbols $ (\(SymName sn) -> def :*: sn :*: mid) <$> syms
-- | Given a module database ID, saves the exported symbols of this
-- module in ExHack's database.
saveModuleExports :: (MonadSelda m) => Int -> [SymName] -> m ()
saveModuleExports midi xs = insert_ exposedSymbols $
(\(SymName s) -> def :*: s :*: fromSql (SqlInt midi)) <$> xs
queryPkg :: (MonadSelda m) => ET.Package -> m (Maybe RowID)
queryPkg p = do
let r = query $ do
pks <- select packages
restrict (pks ! packageName .== (text . getName) p)
return $ pks ! packageId
listToMaybe <$> r
-- | Query ExHack database to retrieve the available symbols to be imported
-- from within this package.
--
-- This scope should be filtered on a per-module basis, depending on the module
-- imports, before being used in a symbol unification process.
getPkgImportScopes :: forall m. (MonadSelda m, MonadMask m) => ET.Package -> m ImportsScope
getPkgImportScopes p = do
mods <- getScopeModules p
o <- sequence (wrapSyms <$> mods)
pure $ HM.fromList o
where
wrapSyms :: IndexedModuleNameT -> m (IndexedModuleNameT, HS.HashSet IndexedSym)
wrapSyms mnt@(IndexedModuleNameT (_, i)) = do
let mid = fromSql $ SqlInt i :: RowID
q <- query $ do
mods <- select exposedModules
restrict (mods ! modId .== literal mid)
syms <- innerJoin (\s -> s ! symModId .== mods ! modId) $ select exposedSymbols
pure $ syms ! symId :*: syms ! symName
pure (mnt, HS.fromList (wrapResult <$> q))
wrapResult (i :*: n) = IndexedSym (SymName n, fromRowId i)
getScopeModules :: (MonadSelda m, MonadMask m) => ET.Package -> m [IndexedModuleNameT]
getScopeModules p = do
pid <- getPackageId p
q <- query $ do
deps <- select dependancies
restrict (deps ! depPack .== literal pid)
mods <- innerJoin (\m -> m ! modPack .== deps ! depId) $ select exposedModules
return (mods ! modId :*: mods ! modName)
-- Here, we also want to look for occurences in current's package module.
-- Not sure if it's a really good idea: we'll find occurences for sure, but we also
-- probably consider the symbol definition as an occurence...
qp <- query $ do
mods <- select exposedModules
restrict $ (mods ! modPack .== literal pid)
return (mods ! modId :*: mods ! modName)
pure $ (wrapResult <$> q) <> (wrapResult <$> qp)
where
wrapResult (i :*: n) = IndexedModuleNameT (ModuleNameT n, fromRowId i)
-- | Insert both the source file in which some symbols have been unified as well as
-- the symbols occurences in ExHack's database.
saveModuleUnifiedSymbols :: forall m. (MonadSelda m, MonadMask m) => [UnifiedSym] -> SourceCodeFile -> m ()
saveModuleUnifiedSymbols xs (SourceCodeFile f (ModuleNameT mnt) (PackageNameT pnt)) =
unless (null xs) $ do
fid <- insertWithPK sourceFiles [def :*: f :*: mnt :*: pnt]
insert_ symbolOccurences $ generateLine fid <$> xs
where
generateLine fid (UnifiedSym (IndexedSym (_, sidi), LocatedSym (_, _, gloc))) =
def :*: col :*: line :*: fid :*: sid
where
(RealSrcSpan loc) = getLoc gloc
!line = srcSpanStartLine loc
!col = srcSpanStartCol loc
!sid = fromSql (SqlInt sidi)
-- | Retrieve the data necessary to render the HTML home page.
getHomePagePackages :: forall m. (MonadSelda m, MonadMask m) => m [HomePagePackage]
getHomePagePackages = do
res <- query $ aggregate $ do
pkgs <- select packages
mods <- innerJoin (\m -> pkgs ! packageId .== m ! modPack) $ select exposedModules
pid <- groupBy (pkgs ! packageId)
pn <- groupBy (pkgs ! packageName)
pure $ pid :*: pn :*: count (mods ! modId)
pure $ wrapResult <$> res
where
wrapResult (i :*: n :*: c) = HomePagePackage (PackageName (i,n)) c
-- | Retrieve the data necessary to render the HTML package page.
getPackagePageMods :: forall m. (MonadSelda m, MonadMask m) => PackageName -> m [ModuleName]
getPackagePageMods (PackageName (pid, _)) = do
res <- query $ do
pkgs <- select packages
restrict $ pkgs ! packageId .== literal pid
mods <- innerJoin (\m -> pkgs ! packageId .== m ! modPack) $ select exposedModules
pure $ mods ! modId :*: mods ! modName
pure $ wrapResult <$> res
where
wrapResult (i :*: n) = ModuleName (i,n)
-- | Retrieve the data necessary to render the HTML module page.
getModulePageSyms :: forall m. (MonadSelda m, MonadMask m) => PackageName -> ModuleName -> m [SymbolOccurs]
getModulePageSyms _ (ModuleName (mid,_)) = do
sids <- query $ do
syms <- select exposedSymbols
restrict $ syms ! symModId .== literal mid
pure $ syms ! symId :*: syms ! symName
mapM (\(sid :*: sn) -> wrapResult sn <$> querySym sid) sids
where
querySym :: RowID -> m [Int :*: Int :*: Text :*: Text :*: Text]
querySym sid = query $ do
syms <- select exposedSymbols
restrict $ syms ! symId .== literal sid
occs <- innerJoin (\o -> o ! occSymId .== syms ! symId) $ select symbolOccurences
files <- innerJoin (\f -> f ! fileId .== occs ! occFileId) $ select sourceFiles
pure $ (occs ! occCol) :*: (occs ! occLine) :*:
(files ! fileContent) :*: (files ! fileModule) :*:
(files ! filePackage)
wrapResult :: SymbolName -> [Int :*: Int :*: Text :*: Text :*: Text] -> SymbolOccurs
wrapResult sname occs = SymbolOccurs sname (wrapOcc occs)
wrapOcc = fmap
(\(col :*: line :*: content :*: mname :*: pname) ->
let (nLine, nContent) = extractSample line content
in (col, nLine,
SourceCodeFile nContent
(ModuleNameT mname)
(PackageNameT pname)))
-- Ahum, not typesafe at all. TODO: create sample-associated datatypes.
extractSample :: Int -> Text -> (Int, Text)
extractSample line t = (nLine, T.unlines nText)
where
!tLines = T.lines t
linesBefore = 15
linesAfter = 5
-- Nb lines to ignore.
!toIgnore = max 0 (line - linesBefore)
-- Intermediate length, ie init length - ignored lines.
!iLength = length tLines - toIgnore
-- New line number.
!nLine = line - toIgnore
-- Nb lines to take
!toTake = min (nLine + linesAfter) iLength
!nText = take toTake $ drop toIgnore tLines