scion-browser 0.4.3 → 0.5.0
raw patch · 7 files changed
+84/−86 lines, 7 filesdep ~persistent
Dependency ranges changed: persistent
Files
- scion-browser.cabal +3/−3
- src/Scion/PersistentBrowser/Build.hs +11/−7
- src/Scion/PersistentBrowser/DbTypes.hs +1/−1
- src/Scion/PersistentBrowser/FileUtil.hs +11/−5
- src/Scion/PersistentBrowser/Query.hs +13/−13
- src/Scion/PersistentBrowser/ToDb.hs +33/−46
- src/Scion/PersistentHoogle/Parser.hs +12/−11
scion-browser.cabal view
@@ -1,5 +1,5 @@ name: scion-browser -version: 0.4.3+version: 0.5.0 cabal-version: >= 1.8 build-type: Simple license: BSD3 @@ -33,7 +33,7 @@ aeson >=0.4 && <0.9, parallel-io >= 0.3, utf8-string,- persistent >= 1.2 && < 2,+ persistent >= 2.1 && < 3, persistent-sqlite >= 1.2, persistent-template >= 1.2, conduit>=1.0,@@ -114,7 +114,7 @@ aeson >=0.4 && <0.9, parallel-io >= 0.3, utf8-string,- persistent >= 1.2 && <2,+ persistent >= 2.1 && < 3, persistent-sqlite >= 1.2, persistent-template >= 1.2, conduit>=1.0,
src/Scion/PersistentBrowser/Build.hs view
@@ -83,12 +83,16 @@ -- Parse Hoogle database createDirectoryIfMissing True hoogleDbDir logToStdout "Started downloading Hoogle database" - hoogleDownloaded <- downloadFileLazy hoogleDbUrl - logToStdout "Uncompressing Hoogle database" - unTarGzip hoogleDownloaded hoogleDbDir - logToStdout $ "Hoogle database is now in " ++ hoogleDbDir - createDirectoryIfMissing True tmpDir - (pkgs, errors) <- parseDirectory hoogleDbDir tmpDir + mhoogleDownloaded <- downloadFileLazy hoogleDbUrl + case mhoogleDownloaded of + Just hoogleDownloaded -> do + logToStdout "Uncompressing Hoogle database" + unTarGzip hoogleDownloaded hoogleDbDir + logToStdout $ "Hoogle database is now in " ++ hoogleDbDir + createDirectoryIfMissing True tmpDir + (pkgs, errors) <- parseDirectory hoogleDbDir tmpDir + return (pkgs, errors) + Nothing -> return ([],[]) --let (pkgs, errors) = ([], []) {- -- Parse base package @@ -105,7 +109,7 @@ Left e -> (dbBase, ("ghc.txt", e):errorsBase) return (pkgListToDb dbGhc, errorsGhc) -} - return (pkgs, errors) + -- | Run SQL on the given path runSQL :: FilePath -> SQL a -> IO a
src/Scion/PersistentBrowser/DbTypes.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls, FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls, FlexibleInstances, MultiParamTypeClasses #-} module Scion.PersistentBrowser.DbTypes where
src/Scion/PersistentBrowser/FileUtil.hs view
@@ -5,7 +5,7 @@ import Control.Applicative import qualified Codec.Archive.Tar as Tar import qualified Codec.Compression.GZip as GZip-import Control.Exception (bracket)+import Control.Exception (bracket,catch,SomeException) import qualified Data.ByteString as SBS import qualified Data.ByteString.Lazy as LBS import System.Directory@@ -19,12 +19,15 @@ filterDots = filter (\d -> d /= "." && d /= "..") -- |Downloads a file from the internet.-downloadFileLazy :: String -> IO LBS.ByteString-downloadFileLazy = simpleHttp+downloadFileLazy :: String -> IO (Maybe LBS.ByteString)+downloadFileLazy s = (Just <$> (simpleHttp s))+ -- yes it's bad practice to catch them all, but I don't know what could be thrown here+ -- StatusCodeException, yes, and maybe ASN1 exceptions, and probably others...+ `catch` \(_ :: SomeException)->return Nothing -- |Downloads a file from the internet.-downloadFileStrict :: String -> IO SBS.ByteString-downloadFileStrict = (LBS.toStrict <$>) . downloadFileLazy+downloadFileStrict :: String -> IO (Maybe SBS.ByteString)+downloadFileStrict = (fmap LBS.toStrict <$>) . downloadFileLazy -- |Downloads a file from the internet and check it's a Hoogle file.@@ -32,6 +35,9 @@ downloadHoogleFile mgr url = do req <- parseUrl url getHoogleFile <$> LBS.toStrict <$> responseBody <$> httpLbs req mgr+ -- yes it's bad practice to catch them all, but I don't know what could be thrown here+ -- StatusCodeException, yes, and maybe ASN1 exceptions, and probably others...+ `catch` \(_ :: SomeException)->return Nothing
src/Scion/PersistentBrowser/Query.hs view
@@ -68,7 +68,7 @@ queryDb sql [modName ++ ".%", pkgName, pkgVersion] moduleAction moduleAction :: [PersistValue] -> DbModule -moduleAction [PersistText name, doc, pkgId@(PersistInt64 _)] = DbModule (T.unpack name) (fromDbText doc) (Key pkgId) +moduleAction [PersistText name, doc, PersistInt64 pkgId] = DbModule (T.unpack name) (fromDbText doc) (DbPackageKey $ SqlBackendKey pkgId) moduleAction _ = error "This should not happen" -- |Get information about all declaration with that name. @@ -88,10 +88,10 @@ queryDb sql [name, pkgName, pkgVersion] declAction declAction :: [PersistValue] -> DbDecl -declAction [PersistText declType, PersistText name , doc, kind, signature, equals, modId@(PersistInt64 _)] = +declAction [PersistText declType, PersistText name , doc, kind, signature, equals, PersistInt64 modId] = DbDecl (read (T.unpack declType)) (T.unpack name) (fromDbText doc) (fromDbText kind) (fromDbText signature) (fromDbText equals) - (Key modId) + (DbModuleKey $ SqlBackendKey modId) declAction _ = error "This should not happen" @@ -131,13 +131,13 @@ dclAll <- getAllDeclInfo (dclId, dcl) return (p, dclAll)) elts where action :: [PersistValue] -> (DbDeclId, DbDecl, DbPackageIdentifier) - action [declId@(PersistInt64 _), PersistText declType, PersistText name - , doc, kind, signature, equals, modId@(PersistInt64 _) + action [PersistInt64 declId, PersistText declType, PersistText name + , doc, kind, signature, equals, PersistInt64 modId , PersistText pkgName, PersistText pkgVersion] = - ( Key declId + ( DbDeclKey $ SqlBackendKey declId , DbDecl (read (T.unpack declType)) (T.unpack name) (fromDbText doc) (fromDbText kind) (fromDbText signature) (fromDbText equals) - (Key modId) + (DbModuleKey $ SqlBackendKey modId) , DbPackageIdentifier (T.unpack pkgName) (T.unpack pkgVersion) ) action _ = error "This should not happen" @@ -167,15 +167,15 @@ let dclAll=DbCompleteDecl dcl [] [] [] cs return (p,m, dclAll)) elts where action :: [PersistValue] -> (DbDeclId, DbDecl, DbPackageIdentifier, DbModule) - action [declId@(PersistInt64 _), PersistText declType, PersistText name - , doc, kind, signature, equals, modId@(PersistInt64 _) + action [ PersistInt64 declId, PersistText declType, PersistText name + , doc, kind, signature, equals, PersistInt64 modId , PersistText modName, PersistText pkgName, PersistText pkgVersion] = - ( Key declId + ( DbDeclKey $ SqlBackendKey declId , DbDecl (read (T.unpack declType)) (T.unpack name) (fromDbText doc) (fromDbText kind) (fromDbText signature) (fromDbText equals) - (Key modId) + (DbModuleKey $ SqlBackendKey modId) , DbPackageIdentifier (T.unpack pkgName) (T.unpack pkgVersion) - , DbModule (T.unpack modName) Nothing (Key modId) + , DbModule (T.unpack modName) Nothing (DbPackageKey $ SqlBackendKey modId) ) action _ = error "This should not happen" consts declId=do @@ -214,7 +214,7 @@ cons <- queryDb sqlCons [declName] action return (decls ++ cons) where action :: [PersistValue] -> (DbModule,String,String) - action [PersistText name, doc, pkgId@(PersistInt64 _),PersistText decl,PersistText pkgName] = (DbModule (T.unpack name) (fromDbText doc) (Key pkgId),T.unpack decl,T.unpack pkgName) + action [PersistText name, doc, PersistInt64 pkgId,PersistText decl,PersistText pkgName] = (DbModule (T.unpack name) (fromDbText doc) (DbPackageKey $ SqlBackendKey pkgId),T.unpack decl,T.unpack pkgName) action _ = error "This should not happen" -- |Executes a query.
src/Scion/PersistentBrowser/ToDb.hs view
@@ -1,11 +1,14 @@-{-# LANGUAGE RankNTypes, KindSignatures, CPP #-}+{-# LANGUAGE RankNTypes, KindSignatures, CPP, FunctionalDependencies, TypeFamilies #-} module Scion.PersistentBrowser.ToDb where +import Control.Monad.IO.Class+import Control.Monad.Trans.Reader import Data.Maybe (maybeToList) import qualified Data.Map as M import qualified Data.Text as T import Data.Version (showVersion) import Database.Persist+import Database.Persist.Sql import Distribution.Package hiding (Package) import Language.Haskell.Exts.Annotated.Syntax hiding (String) import Language.Haskell.Exts.Pretty@@ -16,32 +19,27 @@ -- SAVING IN THE DATABASE -- ====================== --- savePackageToDb :: PersistBackend backend m => Documented Package -> backend m () savePackageToDb :: forall (m :: * -> *).- PersistStore m =>- Package Doc -> m ()+ MonadIO m =>+ Package Doc+ -> ReaderT+ SqlBackend m () savePackageToDb (Package doc (PackageIdentifier (PackageName name) version) modules) = do pkgId <- insert $ DbPackage name (showVersion version) (docToString doc) mapM_ (saveModuleToDb pkgId) (M.elems modules) --- saveModuleToDb :: PersistBackend backend m => DbPackageId -> Documented Module -> backend m () saveModuleToDb :: forall (m :: * -> *).- PersistStore m =>- KeyBackend- (PersistMonadBackend m) (DbPackageGeneric (PersistMonadBackend m))- -> Module Doc -> m ()+ MonadIO m =>+ Key DbPackage -> Module Doc -> ReaderT SqlBackend m () saveModuleToDb pkgId (Module doc (Just (ModuleHead _ (ModuleName _ name)_ _)) _ _ decls) = do moduleId <- insert $ DbModule name (docToString doc) pkgId mapM_ (saveDeclToDb moduleId) decls saveModuleToDb _ m = error $ "saveModuleToDb: This should never happen" ++ (show m) --- saveDeclToDb :: PersistBackend backend m => DbModuleId -> Documented Decl -> backend m ()--- Datatypes+ saveDeclToDb :: forall (m :: * -> *).- PersistStore m =>- KeyBackend- (PersistMonadBackend m) (DbModuleGeneric (PersistMonadBackend m))- -> Decl Doc -> m ()+ MonadIO m =>+ Key DbModule -> Decl Doc -> ReaderT SqlBackend m () saveDeclToDb moduleId (GDataDecl doc (DataType _) ctx hd kind decls _) = do let (declName, declVars) = declHeadToDb hd declId <- insert $ DbDecl DbData declName (docToString doc)@@ -94,32 +92,27 @@ saveDeclToDb _ t = error $ "saveDeclToDb: This should never happen" ++ (show t) saveTyVarToDb :: forall (m :: * -> *).- PersistStore m =>- KeyBackend- (PersistMonadBackend m) (DbDeclGeneric (PersistMonadBackend m))- -> String -> m (Key (DbTyVarGeneric (PersistMonadBackend m)))+ MonadIO m =>+ Key DbDecl -> String -> ReaderT SqlBackend m (Key DbTyVar) saveTyVarToDb declId var = insert $ DbTyVar var declId + saveFunDepToDb :: forall (m :: * -> *).- PersistStore m =>- KeyBackend- (PersistMonadBackend m) (DbDeclGeneric (PersistMonadBackend m))- -> String -> m (Key (DbTyVarGeneric (PersistMonadBackend m)))+ MonadIO m =>+ Key DbDecl -> String -> ReaderT SqlBackend m (Key DbTyVar) saveFunDepToDb declId var = insert $ DbTyVar var declId + saveContextToDb :: forall (m :: * -> *).- PersistStore m =>- KeyBackend- (PersistMonadBackend m) (DbDeclGeneric (PersistMonadBackend m))- -> String -> m (Key (DbContextGeneric (PersistMonadBackend m)))+ MonadIO m =>+ Key DbDecl -> String -> ReaderT SqlBackend m (Key DbContext) saveContextToDb declId ctx = insert $ DbContext ctx declId + saveConstructorToDb :: forall (m :: * -> *) l.- (SrcInfo l, PersistStore m) =>- KeyBackend- (PersistMonadBackend m) (DbDeclGeneric (PersistMonadBackend m))- -> GadtDecl l- -> m (Key (DbConstructorGeneric (PersistMonadBackend m)))+ (SrcInfo l, MonadIO m) =>+ Key DbDecl+ -> GadtDecl l -> ReaderT SqlBackend m (Key DbConstructor) #if MIN_VERSION_haskell_src_exts(1,16,0) saveConstructorToDb declId (GadtDecl _ name _ ty) = insert $ DbConstructor (getNameString name) (singleLinePrettyPrint ty) declId #else@@ -129,38 +122,32 @@ -- ============================ deletePackageByInfo :: forall (m :: * -> *).- PersistQuery m =>- PackageIdentifier -> m ()+ MonadIO m =>+ PackageIdentifier -> ReaderT SqlBackend m () deletePackageByInfo (PackageIdentifier (PackageName name) version) = do Just pkg <- selectFirst [ DbPackageName ==. name, DbPackageVersion ==. showVersion version ] [] let pkgId = entityKey pkg deletePackage pkgId deletePackage :: forall (m :: * -> *).- PersistQuery m =>- KeyBackend- (PersistMonadBackend m) (DbPackageGeneric (PersistMonadBackend m))- -> m ()+ MonadIO m =>+ Key DbPackage -> ReaderT SqlBackend m () deletePackage pkgId = do modules <- selectList [ DbModulePackageId ==. pkgId ] [] mapM_ (deleteModule . entityKey) modules delete pkgId deleteModule :: forall (m :: * -> *).- PersistQuery m =>- KeyBackend- (PersistMonadBackend m) (DbModuleGeneric (PersistMonadBackend m))- -> m ()+ MonadIO m =>+ Key DbModule -> ReaderT SqlBackend m () deleteModule moduleId = do decls <- selectList [ DbDeclModuleId ==. moduleId ] [] mapM_ (deleteDecl . entityKey) decls delete moduleId deleteDecl :: forall (m :: * -> *).- PersistQuery m =>- KeyBackend- (PersistMonadBackend m) (DbDeclGeneric (PersistMonadBackend m))- -> m ()+ MonadIO m =>+ Key DbDecl -> ReaderT SqlBackend m () deleteDecl declId = do deleteWhere [ DbTyVarDeclId ==. declId ] deleteWhere [ DbFunDepDeclId ==. declId ]
src/Scion/PersistentHoogle/Parser.hs view
@@ -5,6 +5,7 @@ import Data.List (intercalate) import qualified Data.Text as T import Database.Persist +import Database.Persist.Sql import Language.Haskell.Exts.Annotated.Syntax import Scion.PersistentBrowser.DbTypes import Scion.PersistentBrowser.Parser.Internal @@ -112,9 +113,9 @@ ++ " AND DbModule.name = ?" mods <- queryDb sql [mname] action return $ if null mods then Nothing else Just (RModule mods) - where action [PersistText modName, modDoc, pkgId@(PersistInt64 _), PersistText pkgName, PersistText pkgVersion] = + where action [PersistText modName, modDoc, PersistInt64 pkgId, PersistText pkgName, PersistText pkgVersion] = ( DbPackageIdentifier (T.unpack pkgName) (T.unpack pkgVersion) - , DbModule (T.unpack modName) (fromDbText modDoc) (Key pkgId) ) + , DbModule (T.unpack modName) (fromDbText modDoc) (DbPackageKey $ SqlBackendKey pkgId) ) action _ = error "This should not happen" convertHalfToResult (HalfDecl mname dcl) = do let sql = "SELECT DbDecl.id, DbDecl.declType, DbDecl.name, DbDecl.doc, DbDecl.kind, DbDecl.signature, DbDecl.equals, DbDecl.moduleId" @@ -128,13 +129,13 @@ completeDecls <- mapM (\(pkgId, modName, dclKey, dclInfo) -> do complete <- getAllDeclInfo (dclKey, dclInfo) return (pkgId, modName, complete) ) decls return $ if null completeDecls then Nothing else Just (RDeclaration completeDecls) - where action [ declId@(PersistInt64 _), PersistText declType, PersistText declName - , declDoc, declKind, declSignature, declEquals, modId@(PersistInt64 _) + where action [ PersistInt64 declId, PersistText declType, PersistText declName + , declDoc, declKind, declSignature, declEquals, PersistInt64 modId , PersistText pkgName, PersistText pkgVersion ] = - let (innerDclKey :: DbDeclId) = Key declId + let (innerDclKey :: DbDeclId) = DbDeclKey $ SqlBackendKey declId innerDcl = DbDecl (read (T.unpack declType)) (T.unpack declName) (fromDbText declDoc) (fromDbText declKind) (fromDbText declSignature) (fromDbText declEquals) - (Key modId) + (DbModuleKey $ SqlBackendKey modId) in ( DbPackageIdentifier (T.unpack pkgName) (T.unpack pkgVersion) , mname , innerDclKey @@ -156,18 +157,18 @@ return (pkgId, modName, complete, cst) ) decls return $ if null completeDecls then Nothing else Just (RConstructor completeDecls) where action [ PersistText constName, PersistText constSignature - , declId@(PersistInt64 _), PersistText declType, PersistText declName - , declDoc, declKind, declSignature, declEquals, modId@(PersistInt64 _) + , PersistInt64 declId, PersistText declType, PersistText declName + , declDoc, declKind, declSignature, declEquals, PersistInt64 modId , PersistText pkgName, PersistText pkgVersion ] = - let (innerDclKey :: DbDeclId) = Key declId + let (innerDclKey :: DbDeclId) = DbDeclKey $ SqlBackendKey declId innerDcl = DbDecl (read (T.unpack declType)) (T.unpack declName) (fromDbText declDoc) (fromDbText declKind) (fromDbText declSignature) (fromDbText declEquals) - (Key modId) + (DbModuleKey $ SqlBackendKey modId) in ( DbPackageIdentifier (T.unpack pkgName) (T.unpack pkgVersion) , mname , innerDclKey , innerDcl - , DbConstructor (T.unpack constName) (T.unpack constSignature) (Key declId) + , DbConstructor (T.unpack constName) (T.unpack constSignature) (DbDeclKey $ SqlBackendKey declId) ) action _ = error "This should not happen"