scion-browser 0.2.14 → 0.2.15
raw patch · 18 files changed
+919/−920 lines, 18 filesdep ~conduitdep ~monad-loggerdep ~persistentsetup-changed
Dependency ranges changed: conduit, monad-logger, persistent, persistent-sqlite, persistent-template
Files
- Setup.hs +2/−2
- docs/LICENSE +29/−29
- scion-browser.cabal +11/−11
- src/Scion/PersistentBrowser.hs +9/−9
- src/Scion/PersistentBrowser/Build.hs +4/−3
- src/Scion/PersistentBrowser/DbTypes.hs +6/−10
- src/Scion/PersistentBrowser/FileUtil.hs +101/−101
- src/Scion/PersistentBrowser/FromMissingH.hs +98/−98
- src/Scion/PersistentBrowser/Instances/Json.hs +101/−101
- src/Scion/PersistentBrowser/Parser/Documentable.hs +88/−88
- src/Scion/PersistentBrowser/Query.hs +12/−13
- src/Scion/PersistentBrowser/ToDb.hs +143/−143
- src/Scion/PersistentBrowser/Types.hs +96/−90
- src/Scion/PersistentBrowser/Util.hs +51/−51
- src/Scion/PersistentHoogle/Instances/Json.hs +34/−34
- src/Scion/PersistentHoogle/Parser.hs +0/−3
- src/Scion/PersistentHoogle/Util.hs +129/−129
- src/Server/PersistentCommands.hs +5/−5
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
docs/LICENSE view
@@ -1,29 +1,29 @@-Copyright 2011, Alejandro Serrano -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -- Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. - -- Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution. - -- Neither name of the author nor the names of its contributors may be -used to endorse or promote products derived from this software without -specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE AUTHOR(S) AND THE CONTRIBUTORS "AS -IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY -COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE FOR -ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE -GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER -IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Copyright 2011, Alejandro Serrano+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.+ +- Neither name of the author nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE AUTHOR(S) AND THE CONTRIBUTORS "AS+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A+PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY+COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE+GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER+IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR+OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
scion-browser.cabal view
@@ -1,5 +1,5 @@ name: scion-browser -version: 0.2.14 +version: 0.2.15 cabal-version: >= 1.8 build-type: Simple license: BSD3 @@ -34,15 +34,15 @@ aeson >= 0.4, parallel-io >= 0.3, utf8-string, - persistent >= 0.7, - persistent-sqlite >= 0.7, - persistent-template >= 0.7, - conduit, + persistent >= 1.2, + persistent-sqlite >= 1.2, + persistent-template >= 1.2, + conduit>=1.0, transformers, unordered-containers >= 0.1.3, zlib, ghc-paths == 0.1.*, - monad-logger >= 0.2.2 + monad-logger >= 0.3 if !os(mingw32) build-depends: @@ -114,15 +114,15 @@ aeson >= 0.4, parallel-io >= 0.3, utf8-string, - persistent >= 0.7, - persistent-sqlite >= 0.7, - persistent-template >= 0.7, - conduit, + persistent >= 1.2, + persistent-sqlite >= 1.2, + persistent-template >= 1.2, + conduit>=1.0, transformers, unordered-containers >= 0.1.3, zlib, ghc-paths == 0.1.*, - monad-logger >= 0.2.2 + monad-logger >= 0.3 if !os(mingw32) build-depends:
src/Scion/PersistentBrowser.hs view
@@ -1,9 +1,9 @@-module Scion.PersistentBrowser -( module Scion.PersistentBrowser.Types -, module Scion.PersistentBrowser.DbTypes -) where - -import Scion.PersistentBrowser.Types -import Scion.PersistentBrowser.DbTypes -import Scion.PersistentBrowser.Instances.Json () - +module Scion.PersistentBrowser+( module Scion.PersistentBrowser.Types+, module Scion.PersistentBrowser.DbTypes+) where++import Scion.PersistentBrowser.Types+import Scion.PersistentBrowser.DbTypes+import Scion.PersistentBrowser.Instances.Json ()+
src/Scion/PersistentBrowser/Build.hs view
@@ -33,7 +33,7 @@ import Text.ParserCombinators.ReadP import Control.Monad (when) import Data.Conduit (runResourceT) -import Control.Monad.Logger (runStderrLoggingT) +import Control.Monad.Logger (runNoLoggingT) --runStderrLoggingT, baseDbUrl :: String baseDbUrl = "http://haskell.org/hoogle/base.txt" @@ -67,7 +67,7 @@ saveHackageDatabaseWithTmp :: FilePath -> FilePath -> IO () saveHackageDatabaseWithTmp file tmp = do (db, _) <- createHackageDatabase tmp - runResourceT $ runStderrLoggingT $ withSqliteConn (T.pack file) (runSqlConn (mapM_ savePackageToDb db)) + runResourceT $ runNoLoggingT $ withSqliteConn (T.pack file) (runSqlConn (mapM_ savePackageToDb db)) --mapM_ (\pkg -> withSqliteConn (T.pack file) (runSqlConn (savePackageToDb pkg))) db -- | Downloads the information for the entire Hackage database @@ -106,7 +106,8 @@ -- | Updates a database with changes in the installed package base. updateDatabase :: FilePath -> [InstalledPackageInfo] -> IO () -updateDatabase file pkgInfo = runResourceT $ runStderrLoggingT $ withSqliteConn (T.pack file) $ runSqlConn $ updateDatabase' pkgInfo +updateDatabase file pkgInfo = runResourceT $ runNoLoggingT $ withSqliteConn (T.pack file) $ runSqlConn $ updateDatabase' pkgInfo +-- runStderrLoggingT $ updateDatabase' :: [InstalledPackageInfo] -> SQL () updateDatabase' pkgInfo =
src/Scion/PersistentBrowser/DbTypes.hs view
@@ -1,21 +1,17 @@-{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls, FlexibleInstances #-} module Scion.PersistentBrowser.DbTypes where -import Database.Persist --- import Database.Persist.Base +import Scion.PersistentBrowser.Types + import Database.Persist.Sqlite import Database.Persist.TH import Data.Conduit (ResourceT) -import Control.Monad.Logger (LoggingT(..)) - -type SQL a= SqlPersist (LoggingT (ResourceT IO)) a +import Control.Monad.Logger (NoLoggingT(..)) -- LoggingT(..), -data DbDeclType = DbData | DbNewType | DbClass | DbInstance | DbSignature | DbType - deriving (Show, Read, Eq) -derivePersistField "DbDeclType" +type SQL a= SqlPersistT (NoLoggingT (ResourceT IO)) a -share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persist| +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| DbPackage name String version String
src/Scion/PersistentBrowser/FileUtil.hs view
@@ -1,101 +1,101 @@-{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface #-} - -module Scion.PersistentBrowser.FileUtil where - -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Compression.GZip as GZip -import Control.Exception (bracket) -import qualified Data.ByteString as SBS -import qualified Data.ByteString.Char8 as SBS8 -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as LBS8 -import Data.List (isPrefixOf) -import Network.Browser -import Network.HTTP -import Network.HTTP.Proxy -import System.Directory -import System.FilePath -import Scion.PersistentBrowser.TempFile -import Scion.PersistentBrowser.Util (logToStdout) - --- |Takes out the "." and ".." special directory --- entries from a list of file paths. -filterDots :: [FilePath] -> [FilePath] -filterDots = filter (\d -> d /= "." && d /= "..") - --- |Downloads a file from the internet. -downloadFileLazy :: String -> IO (Maybe LBS.ByteString) -downloadFileLazy url = do - response <- fetchURL url - return $ Just (LBS8.pack response) - --- |Downloads a file from the internet. -downloadFileStrict :: String -> IO (Maybe SBS.ByteString) -downloadFileStrict url = do - response <- fetchURL url - return $ Just (SBS8.pack response) - --- |Downloads a file from the internet and check it's a Hoogle file. -downloadHoogleFile :: String -> IO (Maybe SBS.ByteString) -downloadHoogleFile url = do - response <- fetchURL url - return $ getHoogleFile response - -downloadHoogleFile' :: String -> BrowserAction (HandleStream String) (Maybe SBS.ByteString) -downloadHoogleFile' url = do - (_,res) <- request $ getRequest url - return $ getHoogleFile $ rspBody res - -getHoogleFile :: String -> Maybe SBS.ByteString -getHoogleFile response=if "-- Hoogle documentation" `isPrefixOf` response - then Just (SBS8.pack response) - else Nothing - --- |Downloads a file from the internet, using the system proxy -fetchURL :: String -> IO (String) -fetchURL url=do - pr<-fetchProxy False - (_,res) <- browse $ do - setErrHandler logToStdout - setOutHandler logToStdout - setProxy pr - request $ getRequest url - return $ rspBody res - --- |Un-gzip and un-tar a file into a folder. -unTarGzip :: LBS.ByteString -> FilePath -> IO () -unTarGzip cnts folder = let ungzip = GZip.decompress cnts - entries = Tar.read ungzip - in do createDirectories entries - Tar.unpack folder entries - where createDirectories Tar.Done = return () - createDirectories (Tar.Fail _) = return () - createDirectories (Tar.Next e es) = - case Tar.entryContent e of - Tar.NormalFile _ _ -> do let dir = folder </> takeDirectory (Tar.entryPath e) - createDirectoryIfMissing True dir - createDirectories es - Tar.Directory -> do let dir = folder </> Tar.entryPath e - createDirectoryIfMissing True dir - createDirectories es - _ -> createDirectories es - --- HACK: Taken from Unixutils. --- The version in Hackage conflicts with some of our packages. - --- |temporarily change the working directory to |dir| while running |action| -withWorkingDirectory :: FilePath -> IO a -> IO a -withWorkingDirectory dir action = - bracket getCurrentDirectory setCurrentDirectory (\ _ -> setCurrentDirectory dir >> action) - --- |create a temporary directory, run the action, remove the temporary directory --- the directory will be created inside the system temporary directory (cf bug 3413186) --- the temporary directory will be automatically removed afterwards. --- your working directory is not altered -withTemporaryDirectory :: (FilePath -> IO a) -> IO a -withTemporaryDirectory f = - do home <- getTemporaryDirectory - bracket (createTempDirectory home ".scion") - removeDirectoryRecursive - f - +{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface #-}++module Scion.PersistentBrowser.FileUtil where++import qualified Codec.Archive.Tar as Tar+import qualified Codec.Compression.GZip as GZip+import Control.Exception (bracket)+import qualified Data.ByteString as SBS+import qualified Data.ByteString.Char8 as SBS8+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.Char8 as LBS8+import Data.List (isPrefixOf)+import Network.Browser+import Network.HTTP+import Network.HTTP.Proxy+import System.Directory+import System.FilePath+import Scion.PersistentBrowser.TempFile+import Scion.PersistentBrowser.Util (logToStdout)++-- |Takes out the "." and ".." special directory+-- entries from a list of file paths.+filterDots :: [FilePath] -> [FilePath]+filterDots = filter (\d -> d /= "." && d /= "..")++-- |Downloads a file from the internet.+downloadFileLazy :: String -> IO (Maybe LBS.ByteString)+downloadFileLazy url = do + response <- fetchURL url+ return $ Just (LBS8.pack response)++-- |Downloads a file from the internet.+downloadFileStrict :: String -> IO (Maybe SBS.ByteString)+downloadFileStrict url = do + response <- fetchURL url+ return $ Just (SBS8.pack response)++-- |Downloads a file from the internet and check it's a Hoogle file.+downloadHoogleFile :: String -> IO (Maybe SBS.ByteString)+downloadHoogleFile url = do + response <- fetchURL url+ return $ getHoogleFile response++downloadHoogleFile' :: String -> BrowserAction (HandleStream String) (Maybe SBS.ByteString)+downloadHoogleFile' url = do + (_,res) <- request $ getRequest url+ return $ getHoogleFile $ rspBody res++getHoogleFile :: String -> Maybe SBS.ByteString+getHoogleFile response=if "-- Hoogle documentation" `isPrefixOf` response+ then Just (SBS8.pack response)+ else Nothing++-- |Downloads a file from the internet, using the system proxy+fetchURL :: String -> IO (String)+fetchURL url=do+ pr<-fetchProxy False+ (_,res) <- browse $ do + setErrHandler logToStdout+ setOutHandler logToStdout+ setProxy pr + request $ getRequest url+ return $ rspBody res+ +-- |Un-gzip and un-tar a file into a folder.+unTarGzip :: LBS.ByteString -> FilePath -> IO ()+unTarGzip cnts folder = let ungzip = GZip.decompress cnts+ entries = Tar.read ungzip+ in do createDirectories entries+ Tar.unpack folder entries+ where createDirectories Tar.Done = return ()+ createDirectories (Tar.Fail _) = return ()+ createDirectories (Tar.Next e es) =+ case Tar.entryContent e of+ Tar.NormalFile _ _ -> do let dir = folder </> takeDirectory (Tar.entryPath e)+ createDirectoryIfMissing True dir+ createDirectories es+ Tar.Directory -> do let dir = folder </> Tar.entryPath e+ createDirectoryIfMissing True dir+ createDirectories es+ _ -> createDirectories es++-- HACK: Taken from Unixutils.+-- The version in Hackage conflicts with some of our packages.++-- |temporarily change the working directory to |dir| while running |action|+withWorkingDirectory :: FilePath -> IO a -> IO a+withWorkingDirectory dir action = + bracket getCurrentDirectory setCurrentDirectory (\ _ -> setCurrentDirectory dir >> action)++-- |create a temporary directory, run the action, remove the temporary directory+-- the directory will be created inside the system temporary directory (cf bug 3413186)+-- the temporary directory will be automatically removed afterwards.+-- your working directory is not altered+withTemporaryDirectory :: (FilePath -> IO a) -> IO a+withTemporaryDirectory f =+ do home <- getTemporaryDirectory + bracket (createTempDirectory home ".scion")+ removeDirectoryRecursive+ f+
src/Scion/PersistentBrowser/FromMissingH.hs view
@@ -1,98 +1,98 @@--- |Utility functions that were first used from package MissingH. --- But MissingH does not build in 7.2.1 yet, so I included them here. -module Scion.PersistentBrowser.FromMissingH where - -import Data.List (intersperse, isPrefixOf) - --- From Data.List.Utils - -{- | Adds the specified (key, value) pair to the given list, removing any -existing pair with the same key already present. -} -addToAL :: Eq key => [(key, elt)] -> key -> elt -> [(key, elt)] -addToAL l key value = (key, value) : delFromAL l key - -{- | Removes all (key, value) pairs from the given list where the key -matches the given one. -} -delFromAL :: Eq key => [(key, a)] -> key -> [(key, a)] -delFromAL l key = filter (\a -> (fst a) /= key) l - - --- From Data.String.Utils - -{- | Returns true if the given list starts with the specified elements; -false otherwise. (This is an alias for "Data.List.isPrefixOf".) - -Example: - -> startswith "He" "Hello" -> True - --} - -startswith :: Eq a => [a] -> [a] -> Bool -startswith = isPrefixOf - -{- | Similar to Data.List.span, but performs the test on the entire remaining -list instead of just one element. - -@spanList p xs@ is the same as @(takeWhileList p xs, dropWhileList p xs)@ --} -spanList :: ([a] -> Bool) -> [a] -> ([a], [a]) - -spanList _ [] = ([],[]) -spanList func list@(x:xs) = - if func list - then (x:ys,zs) - else ([],list) - where (ys,zs) = spanList func xs - -{- | Similar to Data.List.break, but performs the test on the entire remaining -list instead of just one element. --} -breakList :: ([a] -> Bool) -> [a] -> ([a], [a]) -breakList func = spanList (not . func) - -{- | Given a delimiter and a list (or string), split into components. - -Example: - -> split "," "foo,bar,,baz," -> ["foo", "bar", "", "baz", ""] - -> split "ba" ",foo,bar,,baz," -> [",foo,","r,,","z,"] --} -split :: Eq a => [a] -> [a] -> [[a]] -split _ [] = [] -split delim str = - let (firstline, remainder) = breakList (startswith delim) str - in - firstline : case remainder of - [] -> [] - x -> if x == delim - then [] : [] - else split delim - (drop (length delim) x) - -{- | Given a list and a replacement list, replaces each occurance of the search -list with the replacement list in the operation list. - -Example: - ->replace "," "." "127,0,0,1" -> "127.0.0.1" - -This could logically be thought of as: - ->replace old new l = join new . split old $ l --} - -replace :: Eq a => [a] -> [a] -> [a] -> [a] -replace old new l = join new . split old $ l - -{- | Given a delimiter and a list of items (or strings), join the items -by using the delimiter. - -Example: - -> join "|" ["foo", "bar", "baz"] -> "foo|bar|baz" --} -join :: [a] -> [[a]] -> [a] -join delim l = concat (intersperse delim l) - +-- |Utility functions that were first used from package MissingH.+-- But MissingH does not build in 7.2.1 yet, so I included them here.+module Scion.PersistentBrowser.FromMissingH where++import Data.List (intersperse, isPrefixOf)++-- From Data.List.Utils++{- | Adds the specified (key, value) pair to the given list, removing any+existing pair with the same key already present. -}+addToAL :: Eq key => [(key, elt)] -> key -> elt -> [(key, elt)]+addToAL l key value = (key, value) : delFromAL l key++{- | Removes all (key, value) pairs from the given list where the key+matches the given one. -}+delFromAL :: Eq key => [(key, a)] -> key -> [(key, a)]+delFromAL l key = filter (\a -> (fst a) /= key) l+++-- From Data.String.Utils++{- | Returns true if the given list starts with the specified elements;+false otherwise. (This is an alias for "Data.List.isPrefixOf".)++Example:++> startswith "He" "Hello" -> True++-}++startswith :: Eq a => [a] -> [a] -> Bool+startswith = isPrefixOf++{- | Similar to Data.List.span, but performs the test on the entire remaining+list instead of just one element. ++@spanList p xs@ is the same as @(takeWhileList p xs, dropWhileList p xs)@ +-}+spanList :: ([a] -> Bool) -> [a] -> ([a], [a])++spanList _ [] = ([],[])+spanList func list@(x:xs) =+ if func list+ then (x:ys,zs)+ else ([],list)+ where (ys,zs) = spanList func xs++{- | Similar to Data.List.break, but performs the test on the entire remaining+list instead of just one element.+-}+breakList :: ([a] -> Bool) -> [a] -> ([a], [a])+breakList func = spanList (not . func)++{- | Given a delimiter and a list (or string), split into components.++Example:++> split "," "foo,bar,,baz," -> ["foo", "bar", "", "baz", ""]++> split "ba" ",foo,bar,,baz," -> [",foo,","r,,","z,"]+-}+split :: Eq a => [a] -> [a] -> [[a]]+split _ [] = []+split delim str =+ let (firstline, remainder) = breakList (startswith delim) str+ in + firstline : case remainder of+ [] -> []+ x -> if x == delim+ then [] : []+ else split delim + (drop (length delim) x)++{- | Given a list and a replacement list, replaces each occurance of the search+list with the replacement list in the operation list.++Example:++>replace "," "." "127,0,0,1" -> "127.0.0.1"++This could logically be thought of as:++>replace old new l = join new . split old $ l+-}++replace :: Eq a => [a] -> [a] -> [a] -> [a]+replace old new l = join new . split old $ l++{- | Given a delimiter and a list of items (or strings), join the items+by using the delimiter.++Example:++> join "|" ["foo", "bar", "baz"] -> "foo|bar|baz"+-}+join :: [a] -> [[a]] -> [a]+join delim l = concat (intersperse delim l)+
src/Scion/PersistentBrowser/Instances/Json.hs view
@@ -1,101 +1,101 @@-{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-} --- FlexibleInstances needed for GHC 7.2 - -module Scion.PersistentBrowser.Instances.Json where - -import Control.Applicative -import Control.Monad -import Data.Aeson -import Data.Aeson.Types -import qualified Data.Text as T -import Scion.PersistentBrowser.DbTypes - -instance ToJSON DbPackage where - toJSON (DbPackage name version doc) = object [ "id" .= object [ "name" .= T.pack name - , "version" .= T.pack version - ] - , "doc" .= doc - ] - -instance ToJSON DbPackageIdentifier where - toJSON (DbPackageIdentifier name version) = object [ "name" .= T.pack name - , "version" .= T.pack version - ] - -instance FromJSON DbPackageIdentifier where - parseJSON (Object v) = DbPackageIdentifier <$> (T.unpack <$> v .: "name") - <*> (T.unpack <$> v .: "version") - parseJSON _ = mzero - -instance ToJSON (DbModule) where - toJSON (DbModule name doc _) = object [ "name" .= T.pack name - , "doc" .= doc - ] - -instance ToJSON DbCompleteDecl where - toJSON (DbCompleteDecl (DbDecl DbData name doc kind _ _ _) context vars _ decls) = - object [ "doc" .= doc - , "type" .= T.pack "data" - , "context" .= context - , "head" .= object [ "name" .= name - , "vars" .= vars - ] - , "kind" .= kind - , "decls" .= decls - ] - toJSON (DbCompleteDecl (DbDecl DbNewType name doc kind _ _ _) context vars _ decls) = - object [ "doc" .= doc - , "type" .= T.pack "newtype" - , "context" .= context - , "head" .= object [ "name" .= name - , "vars" .= vars - ] - , "kind" .= kind - , "decls" .= decls - ] - toJSON (DbCompleteDecl (DbDecl DbClass name doc _ _ _ _) context vars fundeps _) = - object [ "doc" .= doc - , "type" .= T.pack "class" - , "context" .= context - , "head" .= object [ "name" .= name - , "vars" .= vars - ] - , "fundeps" .= fundeps - ] - toJSON (DbCompleteDecl (DbDecl DbInstance name doc _ _ _ _) context vars _ _) = - object [ "doc" .= doc - , "type" .= T.pack "instance" - , "context" .= context - , "head" .= object [ "name" .= name - , "vars" .= vars - ] - ] - toJSON (DbCompleteDecl (DbDecl DbSignature name doc _ signature _ _) _ _ _ _) = - object [ "doc" .= doc - , "type" .= T.pack "signature" - , "name" .= [ name ] - , "signature" .= signature - ] - toJSON (DbCompleteDecl (DbDecl DbType name doc _ _ equals _) _ vars _ _) = - object [ "doc" .= doc - , "type" .= T.pack "type" - , "head" .= object [ "name" .= name - , "vars" .= vars - ] - , "equals" .= equals - ] - -instance ToJSON DbContext where - toJSON (DbContext shown _) = String $ T.pack shown - -instance ToJSON DbTyVar where - toJSON (DbTyVar name _) = String $ T.pack name - -instance ToJSON DbFunDep where - toJSON (DbFunDep name _) = String $ T.pack name - -instance ToJSON DbConstructor where - toJSON (DbConstructor name signature _) = object [ "name" .= name - , "type" .= signature - ] - +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}+-- FlexibleInstances needed for GHC 7.2++module Scion.PersistentBrowser.Instances.Json where++import Control.Applicative+import Control.Monad+import Data.Aeson+import qualified Data.Text as T+import Scion.PersistentBrowser.Types+import Scion.PersistentBrowser.DbTypes++instance ToJSON DbPackage where+ toJSON (DbPackage name version doc) = object [ "id" .= object [ "name" .= T.pack name+ , "version" .= T.pack version+ ]+ , "doc" .= doc+ ]++instance ToJSON DbPackageIdentifier where+ toJSON (DbPackageIdentifier name version) = object [ "name" .= T.pack name+ , "version" .= T.pack version+ ]++instance FromJSON DbPackageIdentifier where+ parseJSON (Object v) = DbPackageIdentifier <$> (T.unpack <$> v .: "name")+ <*> (T.unpack <$> v .: "version")+ parseJSON _ = mzero++instance ToJSON (DbModule) where+ toJSON (DbModule name doc _) = object [ "name" .= T.pack name+ , "doc" .= doc+ ]++instance ToJSON DbCompleteDecl where+ toJSON (DbCompleteDecl (DbDecl DbData name doc kind _ _ _) context vars _ decls) =+ object [ "doc" .= doc+ , "type" .= T.pack "data"+ , "context" .= context+ , "head" .= object [ "name" .= name+ , "vars" .= vars+ ]+ , "kind" .= kind+ , "decls" .= decls+ ]+ toJSON (DbCompleteDecl (DbDecl DbNewType name doc kind _ _ _) context vars _ decls) =+ object [ "doc" .= doc+ , "type" .= T.pack "newtype"+ , "context" .= context+ , "head" .= object [ "name" .= name+ , "vars" .= vars+ ]+ , "kind" .= kind+ , "decls" .= decls+ ]+ toJSON (DbCompleteDecl (DbDecl DbClass name doc _ _ _ _) context vars fundeps _) =+ object [ "doc" .= doc+ , "type" .= T.pack "class"+ , "context" .= context+ , "head" .= object [ "name" .= name+ , "vars" .= vars+ ]+ , "fundeps" .= fundeps+ ]+ toJSON (DbCompleteDecl (DbDecl DbInstance name doc _ _ _ _) context vars _ _) =+ object [ "doc" .= doc+ , "type" .= T.pack "instance"+ , "context" .= context+ , "head" .= object [ "name" .= name+ , "vars" .= vars+ ]+ ]+ toJSON (DbCompleteDecl (DbDecl DbSignature name doc _ signature _ _) _ _ _ _) =+ object [ "doc" .= doc+ , "type" .= T.pack "signature"+ , "name" .= [ name ]+ , "signature" .= signature+ ]+ toJSON (DbCompleteDecl (DbDecl DbType name doc _ _ equals _) _ vars _ _) =+ object [ "doc" .= doc+ , "type" .= T.pack "type"+ , "head" .= object [ "name" .= name+ , "vars" .= vars+ ]+ , "equals" .= equals+ ]++instance ToJSON DbContext where+ toJSON (DbContext shown _) = String $ T.pack shown++instance ToJSON DbTyVar where+ toJSON (DbTyVar name _) = String $ T.pack name++instance ToJSON DbFunDep where+ toJSON (DbFunDep name _) = String $ T.pack name++instance ToJSON DbConstructor where+ toJSON (DbConstructor name signature _) = object [ "name" .= name+ , "type" .= signature+ ]+
src/Scion/PersistentBrowser/Parser/Documentable.hs view
@@ -1,88 +1,88 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-} - -module Scion.PersistentBrowser.Parser.Documentable where - -import Scion.PersistentBrowser.Types -import qualified Language.Haskell.Exts.Syntax as S -import qualified Language.Haskell.Exts.Annotated.Syntax as A - -class Documentable a b | a -> b where - document :: Doc -> a -> (Documented b) - -instance Documentable S.Type A.Type where - document d (S.TyForall b c t) = A.TyForall d (fmap (fmap (document d)) b) - (Just (document d c)) - (document d t) - document d (S.TyFun t1 t2) = A.TyFun d (document d t1) - (document d t2) - document d (S.TyTuple b t) = A.TyTuple d (documentBoxed d b) - (fmap (document d) t) - document d (S.TyList t) = A.TyList d (document d t) - document d (S.TyApp t1 t2) = A.TyApp d (document d t1) - (document d t2) - document d (S.TyVar n) = A.TyVar d (document d n) - document d (S.TyCon c) = A.TyCon d (document d c) - document d (S.TyParen t) = A.TyParen d (document d t) - document d (S.TyInfix l n r) = A.TyInfix d (document d l) - (document d n) - (document d r) - document d (S.TyKind t k) = A.TyKind d (document d t) - (document d k) - -instance Documentable S.TyVarBind A.TyVarBind where - document d (S.KindedVar n k) = A.KindedVar d (document d n) - (document d k) - document d (S.UnkindedVar n) = A.UnkindedVar d (document d n) - -instance Documentable S.Context A.Context where - document d [a] = A.CxSingle d (document d a) - document d v = A.CxTuple d (fmap (document d) v) - -instance Documentable S.Asst A.Asst where - document d (S.ClassA q t) = A.ClassA d (document d q) - (fmap (document d) t) - document d (S.InfixA l q r) = A.InfixA d (document d l) - (document d q) - (document d r) - document d (S.IParam n t) = A.IParam d (document d n) - (document d t) - document d (S.EqualP t1 t2) = A.EqualP d (document d t1) - (document d t2) - -instance Documentable S.Name A.Name where - document d (S.Ident s) = A.Ident d s - document d (S.Symbol s) = A.Symbol d s - -instance Documentable S.QName A.QName where - document d (S.Qual mn n) = A.Qual d (document d mn) - (document d n) - document d (S.UnQual n) = A.UnQual d (document d n) - document d (S.Special c) = A.Special d (document d c) - -instance Documentable S.ModuleName A.ModuleName where - document d (S.ModuleName n) = A.ModuleName d n - -instance Documentable S.IPName A.IPName where - document d (S.IPDup s) = A.IPDup d s - document d (S.IPLin s) = A.IPLin d s - -instance Documentable S.SpecialCon A.SpecialCon where - document d S.UnitCon = A.UnitCon d - document d S.ListCon = A.ListCon d - document d S.FunCon = A.FunCon d - document d (S.TupleCon b n) = A.TupleCon d (documentBoxed d b) n - document d S.Cons = A.Cons d - document d S.UnboxedSingleCon = A.UnboxedSingleCon d - -instance Documentable S.Kind A.Kind where - document d S.KindStar = A.KindStar d - document d S.KindBang = A.KindBang d - document d (S.KindFn k1 k2) = A.KindFn d (document d k1) - (document d k2) - document d (S.KindParen k) = A.KindParen d (document d k) - document d (S.KindVar n) = A.KindVar d (document d n) - -documentBoxed :: Doc -> S.Boxed -> A.Boxed -documentBoxed _ S.Boxed = A.Boxed -documentBoxed _ S.Unboxed = A.Unboxed - +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-}++module Scion.PersistentBrowser.Parser.Documentable where++import Scion.PersistentBrowser.Types+import qualified Language.Haskell.Exts.Syntax as S+import qualified Language.Haskell.Exts.Annotated.Syntax as A++class Documentable a b | a -> b where+ document :: Doc -> a -> (Documented b)++instance Documentable S.Type A.Type where+ document d (S.TyForall b c t) = A.TyForall d (fmap (fmap (document d)) b)+ (Just (document d c))+ (document d t)+ document d (S.TyFun t1 t2) = A.TyFun d (document d t1)+ (document d t2)+ document d (S.TyTuple b t) = A.TyTuple d (documentBoxed d b)+ (fmap (document d) t)+ document d (S.TyList t) = A.TyList d (document d t)+ document d (S.TyApp t1 t2) = A.TyApp d (document d t1)+ (document d t2)+ document d (S.TyVar n) = A.TyVar d (document d n)+ document d (S.TyCon c) = A.TyCon d (document d c)+ document d (S.TyParen t) = A.TyParen d (document d t)+ document d (S.TyInfix l n r) = A.TyInfix d (document d l)+ (document d n)+ (document d r)+ document d (S.TyKind t k) = A.TyKind d (document d t)+ (document d k)++instance Documentable S.TyVarBind A.TyVarBind where+ document d (S.KindedVar n k) = A.KindedVar d (document d n)+ (document d k)+ document d (S.UnkindedVar n) = A.UnkindedVar d (document d n)++instance Documentable S.Context A.Context where+ document d [a] = A.CxSingle d (document d a)+ document d v = A.CxTuple d (fmap (document d) v)++instance Documentable S.Asst A.Asst where+ document d (S.ClassA q t) = A.ClassA d (document d q)+ (fmap (document d) t)+ document d (S.InfixA l q r) = A.InfixA d (document d l)+ (document d q)+ (document d r)+ document d (S.IParam n t) = A.IParam d (document d n)+ (document d t)+ document d (S.EqualP t1 t2) = A.EqualP d (document d t1)+ (document d t2)++instance Documentable S.Name A.Name where+ document d (S.Ident s) = A.Ident d s+ document d (S.Symbol s) = A.Symbol d s++instance Documentable S.QName A.QName where+ document d (S.Qual mn n) = A.Qual d (document d mn)+ (document d n)+ document d (S.UnQual n) = A.UnQual d (document d n)+ document d (S.Special c) = A.Special d (document d c)++instance Documentable S.ModuleName A.ModuleName where+ document d (S.ModuleName n) = A.ModuleName d n++instance Documentable S.IPName A.IPName where+ document d (S.IPDup s) = A.IPDup d s+ document d (S.IPLin s) = A.IPLin d s++instance Documentable S.SpecialCon A.SpecialCon where+ document d S.UnitCon = A.UnitCon d+ document d S.ListCon = A.ListCon d+ document d S.FunCon = A.FunCon d+ document d (S.TupleCon b n) = A.TupleCon d (documentBoxed d b) n+ document d S.Cons = A.Cons d+ document d S.UnboxedSingleCon = A.UnboxedSingleCon d++instance Documentable S.Kind A.Kind where+ document d S.KindStar = A.KindStar d+ document d S.KindBang = A.KindBang d+ document d (S.KindFn k1 k2) = A.KindFn d (document d k1)+ (document d k2)+ document d (S.KindParen k) = A.KindParen d (document d k)+ document d (S.KindVar n) = A.KindVar d (document d n)++documentBoxed :: Doc -> S.Boxed -> A.Boxed+documentBoxed _ S.Boxed = A.Boxed+documentBoxed _ S.Unboxed = A.Unboxed+
src/Scion/PersistentBrowser/Query.hs view
@@ -5,9 +5,7 @@ import qualified Data.Text as T import Database.Persist -import Database.Persist.Sqlite -import Database.Persist.Store -import Database.Persist.GenericSql.Raw (withStmt, execute) +import Database.Persist.Sql import Scion.PersistentBrowser.DbTypes import Data.Conduit import qualified Data.Conduit.List as CL @@ -30,7 +28,7 @@ return $ map entityVal packages -- |Get information about a package in the database. -getPackage :: DbPackageIdentifier -> SQL (Maybe (DbPackage)) +getPackage :: DbPackageIdentifier -> SQL (Maybe DbPackage) getPackage (DbPackageIdentifier name version) = do package <- selectFirst [ DbPackageName ==. name, DbPackageVersion ==. version ] [] return $ fmap entityVal package @@ -109,8 +107,8 @@ , "create index if not exists fundep_declid on DbFunDep (declId)" , "create index if not exists context_declid on DbContext (declId)" ] - mapM_ (\x -> execute x []) idxs - execute "analyze" [] + mapM_ (\x -> rawExecute x []) idxs + rawExecute "analyze" [] -- |Gets the declarations inside some module, -- along with information about which package it lives. @@ -155,9 +153,10 @@ ++ "DbModule.name, DbPackage.name, DbPackage.version" ++ " FROM DbDecl, DbModule, DbPackage" ++ " WHERE DbDecl.moduleId = DbModule.id AND DbModule.packageId = DbPackage.id" - ++ " AND (DbDecl.name LIKE '" + + ++ (if null prefix then "" else (" AND (DbDecl.name LIKE '" ++ prefix ++ "%' or DbDecl.id in (select DbConstructor.declId from DbConstructor where DbConstructor.name LIKE '" - ++ prefix ++ "%'))" + ++ prefix ++ "%'))")) ++ pkg let args = case pkgId of Nothing -> [] @@ -220,8 +219,10 @@ -- |Executes a query. queryDb :: String -> [String] -> ([PersistValue] -> a) -> SQL [a] -queryDb sql params action = runResourceT (withStmt (T.pack sql) (map toPersistValue params) $= CL.map action $$ CL.consume) +queryDb sql params action = rawQuery (T.pack sql) (map toPersistValue params) $= CL.map action+ $$ CL.consume + -- |Gets information from a text value. fromDbText :: PersistValue -> Maybe String fromDbText (PersistText value) = Just (T.unpack value) @@ -236,8 +237,7 @@ getDbPackage = return instance HasDbPackage DbModule where - getDbPackage (DbModule _ _ pkgId) = do pkg <- getJust pkgId - return pkg + getDbPackage (DbModule _ _ pkgId) = getJust pkgId instance HasDbPackage DbDecl where getDbPackage (DbDecl _ _ _ _ _ _ modId) = do md <- getJust modId @@ -251,8 +251,7 @@ getDbModule = return instance HasDbModule DbDecl where - getDbModule (DbDecl _ _ _ _ _ _ modId) = do md <- getJust modId - return md + getDbModule (DbDecl _ _ _ _ _ _ modId) = getJust modId instance HasDbModule DbConstructor where getDbModule (DbConstructor _ _ declId) = do
src/Scion/PersistentBrowser/ToDb.hs view
@@ -1,143 +1,143 @@-{-# LANGUAGE RankNTypes, KindSignatures #-} -module Scion.PersistentBrowser.ToDb where - -import qualified Data.Map as M -import qualified Data.Text as T -import Data.Version (showVersion) -import Database.Persist -import Distribution.Package hiding (Package) -import Language.Haskell.Exts.Annotated.Syntax hiding (String) -import Language.Haskell.Exts.Pretty -import Scion.PersistentBrowser.DbTypes -import Scion.PersistentBrowser.Types - --- SAVING IN THE DATABASE --- ====================== - --- savePackageToDb :: PersistBackend backend m => Documented Package -> backend 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 pkgId (Module doc (Just (ModuleHead _ (ModuleName _ name) _ _)) _ _ decls) = - do moduleId <- insert $ DbModule name (docToString doc) pkgId - mapM_ (saveDeclToDb moduleId) decls -saveModuleToDb _ _ = error "This should never happen" - --- saveDeclToDb :: PersistBackend backend m => DbModuleId -> Documented Decl -> backend m () --- Datatypes -saveDeclToDb moduleId (GDataDecl doc (DataType _) ctx hd kind decls _) = - do let (declName, declVars) = declHeadToDb hd - declId <- insert $ DbDecl DbData declName (docToString doc) - (fmap singleLinePrettyPrint kind) Nothing Nothing moduleId - mapM_ (saveTyVarToDb declId) declVars - mapM_ (saveContextToDb declId) (contextToDb (maybeEmptyContext ctx)) - mapM_ (saveConstructorToDb declId) decls --- Newtypes -saveDeclToDb moduleId (GDataDecl doc (NewType _) ctx hd kind decls _) = - do let (declName, declVars) = declHeadToDb hd - declId <- insert $ DbDecl DbNewType declName (docToString doc) - (fmap singleLinePrettyPrint kind) Nothing Nothing moduleId - mapM_ (saveTyVarToDb declId) declVars - mapM_ (saveContextToDb declId) (contextToDb (maybeEmptyContext ctx)) - mapM_ (saveConstructorToDb declId) decls --- Classes -saveDeclToDb moduleId (ClassDecl doc ctx hd fdeps _) = - do let (declName, declVars) = declHeadToDb hd - declId <- insert $ DbDecl DbClass declName (docToString doc) - Nothing Nothing Nothing moduleId - mapM_ (saveTyVarToDb declId) declVars - mapM_ (saveContextToDb declId) (contextToDb (maybeEmptyContext ctx)) - mapM_ (saveFunDepToDb declId) (map singleLinePrettyPrint fdeps) --- Instances -saveDeclToDb moduleId (InstDecl doc ctx hd _) = - do let (declName, declVars) = instHeadToDb hd - declId <- insert $ DbDecl DbInstance declName (docToString doc) - Nothing Nothing Nothing moduleId - mapM_ (saveTyVarToDb declId) declVars - mapM_ (saveContextToDb declId) (contextToDb (maybeEmptyContext ctx)) --- Signatures -saveDeclToDb moduleId (TypeSig doc names ty) = - do mapM_ saveSignatureToDb names - where saveSignatureToDb name = do - insert $ DbDecl DbSignature (getNameString name) (docToString doc) - Nothing (Just (singleLinePrettyPrint ty)) Nothing moduleId --- Types -saveDeclToDb moduleId (TypeDecl doc hd ty) = - do let (declName, declVars) = declHeadToDb hd - declId <- insert $ DbDecl DbType declName (docToString doc) - Nothing Nothing (Just (singleLinePrettyPrint ty)) moduleId - mapM_ (saveTyVarToDb declId) declVars --- Other -saveDeclToDb _ _ = error "This should never happen" - --- saveTyVarToDb :: PersistBackend backend m => DbDeclId -> String -> backend m () -saveTyVarToDb declId var = insert $ DbTyVar var declId - --- saveFunDepToDb :: PersistBackend backend m => DbDeclId -> String -> backend m () -saveFunDepToDb declId var = insert $ DbTyVar var declId - --- saveContextToDb :: PersistBackend backend m => DbDeclId -> String -> backend m () -saveContextToDb declId ctx = insert $ DbContext ctx declId - --- saveConstructorToDb :: PersistBackend backend m => DbDeclId -> Documented GadtDecl -> backend m () -saveConstructorToDb declId (GadtDecl _ name ty) = insert $ DbConstructor (getNameString name) (singleLinePrettyPrint ty) declId - --- DELETE PACKAGE FROM DATABASE --- ============================ - --- deletePackageByInfo :: PersistBackend backend m => PackageIdentifier -> backend m () -deletePackageByInfo (PackageIdentifier (PackageName name) version) = - do Just pkg <- selectFirst [ DbPackageName ==. name, DbPackageVersion ==. showVersion version ] [] - let pkgId = entityKey pkg - deletePackage pkgId - --- deletePackage :: PersistBackend backend m => DbPackageId -> backend m () -deletePackage pkgId = - do modules <- selectList [ DbModulePackageId ==. pkgId ] [] - mapM_ (deleteModule . entityKey) modules - delete pkgId - --- deleteModule :: PersistBackend backend m => DbModuleId -> backend m () -deleteModule moduleId = - do decls <- selectList [ DbDeclModuleId ==. moduleId ] [] - mapM_ (deleteDecl . entityKey) decls - delete moduleId - --- deleteDecl :: PersistBackend backend m => DbModuleId -> backend m () -deleteDecl declId = - do deleteWhere [ DbTyVarDeclId ==. declId ] - deleteWhere [ DbFunDepDeclId ==. declId ] - deleteWhere [ DbContextDeclId ==. declId ] - deleteWhere [ DbConstructorDeclId ==. declId ] - delete declId - --- UTILITIES FOR CONVERTING TO STRINGS --- =================================== - -docToString :: Doc -> Maybe String -docToString NoDoc = Nothing -docToString (Doc doc) = Just (T.unpack doc) - -declHeadToDb :: DeclHead l -> (String, [String]) -declHeadToDb (DHead _ name vars) = (getNameString name, map singleLinePrettyPrint vars) -declHeadToDb _ = error "This should never happen" - -instHeadToDb :: InstHead l -> (String, [String]) -instHeadToDb (IHead _ name vars) = (getQNameString name, map singleLinePrettyPrint vars) -instHeadToDb _ = error "This should never happen" - -singleLinePrettyPrint :: Pretty a => a -> String -singleLinePrettyPrint = prettyPrintWithMode $ defaultMode { layout = PPNoLayout } - -maybeEmptyContext :: Maybe (Documented Context) -> Documented Context -maybeEmptyContext Nothing = CxEmpty NoDoc -maybeEmptyContext (Just ctx) = ctx - -contextToDb :: Context l -> [String] -contextToDb (CxSingle _ a) = [ singleLinePrettyPrint a ] -contextToDb (CxTuple _ as) = map singleLinePrettyPrint as -contextToDb (CxParen _ ctx) = contextToDb ctx -contextToDb (CxEmpty _) = [] - +{-# LANGUAGE RankNTypes, KindSignatures #-}+module Scion.PersistentBrowser.ToDb where++import qualified Data.Map as M+import qualified Data.Text as T+import Data.Version (showVersion)+import Database.Persist+import Distribution.Package hiding (Package)+import Language.Haskell.Exts.Annotated.Syntax hiding (String)+import Language.Haskell.Exts.Pretty+import Scion.PersistentBrowser.DbTypes+import Scion.PersistentBrowser.Types++-- SAVING IN THE DATABASE+-- ======================++-- savePackageToDb :: PersistBackend backend m => Documented Package -> backend 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 pkgId (Module doc (Just (ModuleHead _ (ModuleName _ name) _ _)) _ _ decls) =+ do moduleId <- insert $ DbModule name (docToString doc) pkgId+ mapM_ (saveDeclToDb moduleId) decls+saveModuleToDb _ _ = error "This should never happen"++-- saveDeclToDb :: PersistBackend backend m => DbModuleId -> Documented Decl -> backend m ()+-- Datatypes+saveDeclToDb moduleId (GDataDecl doc (DataType _) ctx hd kind decls _) =+ do let (declName, declVars) = declHeadToDb hd+ declId <- insert $ DbDecl DbData declName (docToString doc)+ (fmap singleLinePrettyPrint kind) Nothing Nothing moduleId+ mapM_ (saveTyVarToDb declId) declVars+ mapM_ (saveContextToDb declId) (contextToDb (maybeEmptyContext ctx))+ mapM_ (saveConstructorToDb declId) decls+-- Newtypes+saveDeclToDb moduleId (GDataDecl doc (NewType _) ctx hd kind decls _) =+ do let (declName, declVars) = declHeadToDb hd+ declId <- insert $ DbDecl DbNewType declName (docToString doc)+ (fmap singleLinePrettyPrint kind) Nothing Nothing moduleId+ mapM_ (saveTyVarToDb declId) declVars+ mapM_ (saveContextToDb declId) (contextToDb (maybeEmptyContext ctx))+ mapM_ (saveConstructorToDb declId) decls+-- Classes+saveDeclToDb moduleId (ClassDecl doc ctx hd fdeps _) =+ do let (declName, declVars) = declHeadToDb hd+ declId <- insert $ DbDecl DbClass declName (docToString doc)+ Nothing Nothing Nothing moduleId+ mapM_ (saveTyVarToDb declId) declVars+ mapM_ (saveContextToDb declId) (contextToDb (maybeEmptyContext ctx))+ mapM_ (saveFunDepToDb declId) (map singleLinePrettyPrint fdeps)+-- Instances+saveDeclToDb moduleId (InstDecl doc ctx hd _) =+ do let (declName, declVars) = instHeadToDb hd+ declId <- insert $ DbDecl DbInstance declName (docToString doc)+ Nothing Nothing Nothing moduleId+ mapM_ (saveTyVarToDb declId) declVars+ mapM_ (saveContextToDb declId) (contextToDb (maybeEmptyContext ctx))+-- Signatures+saveDeclToDb moduleId (TypeSig doc names ty) =+ do mapM_ saveSignatureToDb names+ where saveSignatureToDb name = do+ insert $ DbDecl DbSignature (getNameString name) (docToString doc) + Nothing (Just (singleLinePrettyPrint ty)) Nothing moduleId+-- Types+saveDeclToDb moduleId (TypeDecl doc hd ty) =+ do let (declName, declVars) = declHeadToDb hd+ declId <- insert $ DbDecl DbType declName (docToString doc) + Nothing Nothing (Just (singleLinePrettyPrint ty)) moduleId+ mapM_ (saveTyVarToDb declId) declVars+-- Other+saveDeclToDb _ _ = error "This should never happen"++-- saveTyVarToDb :: PersistBackend backend m => DbDeclId -> String -> backend m ()+saveTyVarToDb declId var = insert $ DbTyVar var declId++-- saveFunDepToDb :: PersistBackend backend m => DbDeclId -> String -> backend m ()+saveFunDepToDb declId var = insert $ DbTyVar var declId++-- saveContextToDb :: PersistBackend backend m => DbDeclId -> String -> backend m ()+saveContextToDb declId ctx = insert $ DbContext ctx declId++-- saveConstructorToDb :: PersistBackend backend m => DbDeclId -> Documented GadtDecl -> backend m ()+saveConstructorToDb declId (GadtDecl _ name ty) = insert $ DbConstructor (getNameString name) (singleLinePrettyPrint ty) declId++-- DELETE PACKAGE FROM DATABASE+-- ============================++-- deletePackageByInfo :: PersistBackend backend m => PackageIdentifier -> backend m ()+deletePackageByInfo (PackageIdentifier (PackageName name) version) =+ do Just pkg <- selectFirst [ DbPackageName ==. name, DbPackageVersion ==. showVersion version ] []+ let pkgId = entityKey pkg+ deletePackage pkgId++-- deletePackage :: PersistBackend backend m => DbPackageId -> backend m ()+deletePackage pkgId =+ do modules <- selectList [ DbModulePackageId ==. pkgId ] []+ mapM_ (deleteModule . entityKey) modules+ delete pkgId++-- deleteModule :: PersistBackend backend m => DbModuleId -> backend m ()+deleteModule moduleId =+ do decls <- selectList [ DbDeclModuleId ==. moduleId ] []+ mapM_ (deleteDecl . entityKey) decls+ delete moduleId++-- deleteDecl :: PersistBackend backend m => DbModuleId -> backend m ()+deleteDecl declId =+ do deleteWhere [ DbTyVarDeclId ==. declId ]+ deleteWhere [ DbFunDepDeclId ==. declId ]+ deleteWhere [ DbContextDeclId ==. declId ]+ deleteWhere [ DbConstructorDeclId ==. declId ]+ delete declId++-- UTILITIES FOR CONVERTING TO STRINGS+-- ===================================++docToString :: Doc -> Maybe String+docToString NoDoc = Nothing+docToString (Doc doc) = Just (T.unpack doc)++declHeadToDb :: DeclHead l -> (String, [String])+declHeadToDb (DHead _ name vars) = (getNameString name, map singleLinePrettyPrint vars)+declHeadToDb _ = error "This should never happen"++instHeadToDb :: InstHead l -> (String, [String])+instHeadToDb (IHead _ name vars) = (getQNameString name, map singleLinePrettyPrint vars)+instHeadToDb _ = error "This should never happen"++singleLinePrettyPrint :: Pretty a => a -> String+singleLinePrettyPrint = prettyPrintWithMode $ defaultMode { layout = PPNoLayout }++maybeEmptyContext :: Maybe (Documented Context) -> Documented Context+maybeEmptyContext Nothing = CxEmpty NoDoc+maybeEmptyContext (Just ctx) = ctx++contextToDb :: Context l -> [String]+contextToDb (CxSingle _ a) = [ singleLinePrettyPrint a ]+contextToDb (CxTuple _ as) = map singleLinePrettyPrint as+contextToDb (CxParen _ ctx) = contextToDb ctx+contextToDb (CxEmpty _) = []+
src/Scion/PersistentBrowser/Types.hs view
@@ -1,90 +1,96 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} - -module Scion.PersistentBrowser.Types where - -import Data.List (find, intersperse) -import qualified Data.Map as M -import qualified Data.Text as T -import Distribution.Package hiding (Package) -import qualified Distribution.Package as P -import Language.Haskell.Exts.Annotated.Syntax - --- |Documentation for an item. --- Now it is simply a Text element. -data Doc = NoDoc - | Doc T.Text - deriving Show - -docFromString :: String -> Doc -docFromString s = Doc (T.pack s) - --- |A documented item. -type Documented a = a Doc - --- |A package. -data Package l = Package l - PackageIdentifier - (M.Map String (Documented Module)) - deriving Show - -instance P.Package (Package l) where - packageId (Package _ i _) = i - --- |A Database saves a list of packages. -type Database = M.Map PackageIdentifier (Documented Package) - - --- |Gets the name inside a Name constructor. -getNameString :: Name l -> String -getNameString (Ident _ s) = s -getNameString (Symbol _ s) = "(" ++ s ++ ")" - --- |Gets the qualified name as a string. -getQNameString :: QName l -> String -getQNameString (Qual _ (ModuleName _ "") ename) = getNameString ename -getQNameString (Qual _ (ModuleName _ mname) ename) = mname ++ "." ++ getNameString ename -getQNameString (UnQual _ ename) = getNameString ename -getQNameString (Special _ (UnitCon _)) = "()" -getQNameString (Special _ (ListCon _)) = "[]" -getQNameString (Special _ (FunCon _)) = "(->)" -getQNameString (Special _ (TupleCon _ box n)) = case box of - Boxed -> "(" ++ replicate (n-1) ',' ++ ")" - Unboxed -> "(#" ++ replicate (n-1) ',' ++ "#)" -getQNameString (Special _ (Cons _)) = "(:)" -getQNameString (Special _ (UnboxedSingleCon _)) = "(# #)" - --- ------------------------------ --- Datatypes for traversing docs. --- ------------------------------ - -class Annotated e => Named e where - getName :: Show l => (e l) -> String - -class (Named parent, Named child) => DocItem parent child | parent -> child where - getChildren :: Show l => (parent l) -> [child l] - getChild :: Show l => (parent l) -> String -> Maybe (child l) - getChild p name = find (\d -> (getName d) == name) (getChildren p) - -instance Named Module where - getName (Module _ (Just (ModuleHead _ (ModuleName _ name) _ _)) _ _ _) = name - getName v = error $ "This should not be possible: " ++ show v - -instance DocItem Module Decl where - getChildren (Module _ _ _ _ decls) = decls - getChildren _ = [] - -instance Named Decl where - getName (TypeDecl _ (DHead _ name _) _) = getNameString name - getName (GDataDecl _ _ _ (DHead _ name _) _ _ _) = getNameString name - getName (ClassDecl _ _ (DHead _ name _) _ _) = getNameString name - getName (InstDecl _ _ (IHead _ name _) _) = getQNameString name - getName (TypeSig _ name _) = concat $ intersperse "," $ map getNameString name - getName v = error $ "This should not be possible: " ++ show v - -instance DocItem Decl GadtDecl where - getChildren (GDataDecl _ _ _ _ _ cons _) = cons - getChildren _ = [] - -instance Named GadtDecl where - getName (GadtDecl _ name _) = getNameString name - +{-# LANGUAGE QuasiQuotes, TemplateHaskell,MultiParamTypeClasses, FunctionalDependencies #-}++module Scion.PersistentBrowser.Types where++import Data.List (find, intersperse)+import qualified Data.Map as M+import qualified Data.Text as T+import Distribution.Package hiding (Package)+import qualified Distribution.Package as P+import Language.Haskell.Exts.Annotated.Syntax++import Database.Persist.TH++data DbDeclType = DbData | DbNewType | DbClass | DbInstance | DbSignature | DbType+ deriving (Show, Read, Eq)+derivePersistField "DbDeclType"++-- |Documentation for an item.+-- Now it is simply a Text element.+data Doc = NoDoc+ | Doc T.Text+ deriving Show++docFromString :: String -> Doc+docFromString s = Doc (T.pack s)++-- |A documented item.+type Documented a = a Doc++-- |A package.+data Package l = Package l+ PackageIdentifier+ (M.Map String (Documented Module))+ deriving Show++instance P.Package (Package l) where+ packageId (Package _ i _) = i++-- |A Database saves a list of packages. +type Database = M.Map PackageIdentifier (Documented Package)+++-- |Gets the name inside a Name constructor.+getNameString :: Name l -> String+getNameString (Ident _ s) = s+getNameString (Symbol _ s) = "(" ++ s ++ ")"++-- |Gets the qualified name as a string.+getQNameString :: QName l -> String+getQNameString (Qual _ (ModuleName _ "") ename) = getNameString ename+getQNameString (Qual _ (ModuleName _ mname) ename) = mname ++ "." ++ getNameString ename+getQNameString (UnQual _ ename) = getNameString ename+getQNameString (Special _ (UnitCon _)) = "()"+getQNameString (Special _ (ListCon _)) = "[]"+getQNameString (Special _ (FunCon _)) = "(->)"+getQNameString (Special _ (TupleCon _ box n)) = case box of+ Boxed -> "(" ++ replicate (n-1) ',' ++ ")"+ Unboxed -> "(#" ++ replicate (n-1) ',' ++ "#)"+getQNameString (Special _ (Cons _)) = "(:)"+getQNameString (Special _ (UnboxedSingleCon _)) = "(# #)"++-- ------------------------------+-- Datatypes for traversing docs.+-- ------------------------------++class Annotated e => Named e where+ getName :: Show l => (e l) -> String++class (Named parent, Named child) => DocItem parent child | parent -> child where+ getChildren :: Show l => (parent l) -> [child l]+ getChild :: Show l => (parent l) -> String -> Maybe (child l)+ getChild p name = find (\d -> (getName d) == name) (getChildren p)++instance Named Module where+ getName (Module _ (Just (ModuleHead _ (ModuleName _ name) _ _)) _ _ _) = name+ getName v = error $ "This should not be possible: " ++ show v++instance DocItem Module Decl where+ getChildren (Module _ _ _ _ decls) = decls+ getChildren _ = []++instance Named Decl where+ getName (TypeDecl _ (DHead _ name _) _) = getNameString name+ getName (GDataDecl _ _ _ (DHead _ name _) _ _ _) = getNameString name+ getName (ClassDecl _ _ (DHead _ name _) _ _) = getNameString name+ getName (InstDecl _ _ (IHead _ name _) _) = getQNameString name+ getName (TypeSig _ name _) = concat $ intersperse "," $ map getNameString name+ getName v = error $ "This should not be possible: " ++ show v++instance DocItem Decl GadtDecl where+ getChildren (GDataDecl _ _ _ _ _ cons _) = cons+ getChildren _ = []++instance Named GadtDecl where+ getName (GadtDecl _ name _) = getNameString name+
src/Scion/PersistentBrowser/Util.hs view
@@ -1,51 +1,51 @@-{-# LANGUAGE CPP #-} -module Scion.PersistentBrowser.Util where - -import Control.Concurrent.ParallelIO.Local -import Scion.PersistentBrowser.Types -import System.Exit (ExitCode) -import System.IO (hPutStrLn, hFlush, stderr) -import System.Process -import Text.Parsec.Error (ParseError) -import GHC.Conc (numCapabilities) - -withThreaded :: (Pool -> IO a) -> IO a -withThreaded = withPool numCapabilities - --- |Executes a command in a directory. -executeCommand :: FilePath -- ^Working directory. - -> String -- ^Executable to run. - -> [String] -- ^Arguments. - -> Bool -- ^Show output - -> IO ExitCode -executeCommand tmp exe args showOutput = - do let cproc = CreateProcess (RawCommand exe args) - (Just tmp) - Nothing - Inherit - (if showOutput then Inherit else CreatePipe) - (if showOutput then Inherit else CreatePipe) - True -#if __GLASGOW_HASKELL__ >= 702 - False -#endif - (_, _, _, h) <- createProcess cproc - waitForProcess h - --- |Converts a list of parsed packages into a complete database, --- and merges a list of errors. -partitionPackages :: [(FilePath, Either ParseError (Documented Package))] -> ([Documented Package], [(FilePath, ParseError)]) -partitionPackages [] = ([], []) -partitionPackages ((fname, Left err):xs) = let (db, errors) = partitionPackages xs - in (db, (fname, err):errors) -partitionPackages ((_, Right pkg):xs) = let (db, errors) = partitionPackages xs - in (pkg:db, errors) - -logToStdout :: String -> IO () -logToStdout msg = hPutStrLn stderr msg >> hFlush stderr - -escapeSql :: String -> String -escapeSql [] = "" -escapeSql ('\'':cs) = '\'':'\'':(escapeSql cs) -escapeSql (c:cs) = c:(escapeSql cs) - +{-# LANGUAGE CPP #-}+module Scion.PersistentBrowser.Util where++import Control.Concurrent.ParallelIO.Local+import Scion.PersistentBrowser.Types+import System.Exit (ExitCode)+import System.IO (hPutStrLn, hFlush, stderr)+import System.Process+import Text.Parsec.Error (ParseError)+import GHC.Conc (numCapabilities)++withThreaded :: (Pool -> IO a) -> IO a+withThreaded = withPool numCapabilities++-- |Executes a command in a directory.+executeCommand :: FilePath -- ^Working directory.+ -> String -- ^Executable to run.+ -> [String] -- ^Arguments.+ -> Bool -- ^Show output+ -> IO ExitCode+executeCommand tmp exe args showOutput =+ do let cproc = CreateProcess (RawCommand exe args)+ (Just tmp)+ Nothing+ Inherit + (if showOutput then Inherit else CreatePipe)+ (if showOutput then Inherit else CreatePipe)+ True+#if __GLASGOW_HASKELL__ >= 702+ False +#endif+ (_, _, _, h) <- createProcess cproc+ waitForProcess h++-- |Converts a list of parsed packages into a complete database,+-- and merges a list of errors.+partitionPackages :: [(FilePath, Either ParseError (Documented Package))] -> ([Documented Package], [(FilePath, ParseError)])+partitionPackages [] = ([], [])+partitionPackages ((fname, Left err):xs) = let (db, errors) = partitionPackages xs+ in (db, (fname, err):errors)+partitionPackages ((_, Right pkg):xs) = let (db, errors) = partitionPackages xs+ in (pkg:db, errors)++logToStdout :: String -> IO ()+logToStdout msg = hPutStrLn stderr msg >> hFlush stderr++escapeSql :: String -> String+escapeSql [] = ""+escapeSql ('\'':cs) = '\'':'\'':(escapeSql cs)+escapeSql (c:cs) = c:(escapeSql cs)+
src/Scion/PersistentHoogle/Instances/Json.hs view
@@ -1,34 +1,34 @@-{-# LANGUAGE OverloadedStrings, TypeSynonymInstances #-} - -module Scion.PersistentHoogle.Instances.Json where - -import Control.Applicative -import Data.Aeson hiding (Result) -import qualified Data.Text as T -import Scion.PersistentBrowser () -import Scion.PersistentHoogle.Types - --- instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where --- toJSON (a,b,c,d) = toJSON [toJSON a, toJSON b, toJSON c, toJSON d] --- {-# INLINE toJSON #-} - -instance ToJSON (Result) where - toJSON (RPackage pids) = object [ "type" .= T.pack "package" - , "results" .= pids - ] - toJSON (RModule mds) = object [ "type" .= T.pack "module" - , "results" .= mds - ] - toJSON (RDeclaration decls) = object [ "type" .= T.pack "declaration" - , "results" .= decls - ] - toJSON (RConstructor decls) = object [ "type" .= T.pack "constructor" - , "results" .= decls - ] - toJSON (RKeyword kw) = object [ "type" .= T.pack "keyword" - , "name" .= kw - ] - -instance FromJSON (Query) where - parseJSON q = Query <$> parseJSON q - +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances #-}++module Scion.PersistentHoogle.Instances.Json where++import Control.Applicative+import Data.Aeson hiding (Result)+import qualified Data.Text as T+import Scion.PersistentBrowser ()+import Scion.PersistentHoogle.Types++-- instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where+-- toJSON (a,b,c,d) = toJSON [toJSON a, toJSON b, toJSON c, toJSON d]+-- {-# INLINE toJSON #-}++instance ToJSON (Result) where+ toJSON (RPackage pids) = object [ "type" .= T.pack "package"+ , "results" .= pids+ ]+ toJSON (RModule mds) = object [ "type" .= T.pack "module"+ , "results" .= mds+ ]+ toJSON (RDeclaration decls) = object [ "type" .= T.pack "declaration"+ , "results" .= decls+ ]+ toJSON (RConstructor decls) = object [ "type" .= T.pack "constructor"+ , "results" .= decls+ ]+ toJSON (RKeyword kw) = object [ "type" .= T.pack "keyword"+ , "name" .= kw+ ]++instance FromJSON (Query) where+ parseJSON q = Query <$> parseJSON q+
src/Scion/PersistentHoogle/Parser.hs view
@@ -5,9 +5,6 @@ import Data.List (intercalate) import qualified Data.Text as T import Database.Persist --- import Database.Persist.Base -import Database.Persist.Sqlite -import Database.Persist.Store import Language.Haskell.Exts.Annotated.Syntax import Scion.PersistentBrowser.DbTypes import Scion.PersistentBrowser.Parser.Internal
src/Scion/PersistentHoogle/Util.hs view
@@ -1,129 +1,129 @@-{-# LANGUAGE CPP #-} - -module Scion.PersistentHoogle.Util -( findHoogleBinPath -) where - -import Data.List (find) -import Data.Maybe -import Distribution.Compiler -import Distribution.InstalledPackageInfo -import Distribution.Package -import Distribution.Simple.InstallDirs -import Scion.Packages -import System.FilePath -import System.Directory (doesFileExist, getAppUserDataDirectory, getHomeDirectory) - --- Functions for finding Hoogle in the system - -findHoogleBinPath :: Maybe String -> IO (Maybe String) -findHoogleBinPath extraPath = do - p1 <- findHoogleBinInLibrary getHoogleBinPath1 - p2 <- findHoogleBinInLibrary getHoogleBinPath2 - p3 <- getHoogleBinPathCabalAPI - p4 <- getHoogleBinPathCabalDir - p5 <- getHoogleBinPathMacOsDir - let placesToSearch = (catMaybes [extraPath, p1, p2]) ++ [p4, p5] ++ p3 - findPathsAndCheck placesToSearch - -findPathsAndCheck :: [String] -> IO (Maybe String) -findPathsAndCheck [] = return Nothing -findPathsAndCheck (f:fs) = do r <- findPathAndCheck f - case r of - Nothing -> findPathsAndCheck fs - _ -> return r - -findPathAndCheck :: String -> IO (Maybe String) -findPathAndCheck path = do - exists <- doesFileExist path - if exists - then return (Just path) - else return Nothing - -findHoogleBinInLibrary :: (String -> String) -> IO (Maybe String) -findHoogleBinInLibrary f = do minfo <- findHoogleInfo - case minfo of - Nothing -> return Nothing - Just info -> let [libDir] = libraryDirs info - in return $ Just (f libDir) - -findHoogleInfo :: IO (Maybe InstalledPackageInfo) -findHoogleInfo = do infos' <- getPkgInfos - let infos = removeSmallVersions $ concat $ map snd infos' - return $ find (\m -> (pkgName (sourcePackageId m)) == PackageName "hoogle") infos - -removeSmallVersions :: [InstalledPackageInfo] -> [InstalledPackageInfo] -removeSmallVersions pids = filter - (not . (\InstalledPackageInfo { sourcePackageId = (PackageIdentifier name version) } -> - any (\InstalledPackageInfo { sourcePackageId = (PackageIdentifier name' version') } -> - name' == name && version' > version) - pids)) - pids - -getHoogleBinPath1 :: String -> String -getHoogleBinPath1 path = let (_:(_:(_:rest))) = reverse $ splitDirectories path - in (joinPath $ reverse ("bin":rest)) </> "hoogle" <.> exeExtension - -getHoogleBinPath2 :: String -> String -getHoogleBinPath2 path = let (_:(_:rest)) = reverse $ splitDirectories path - in (joinPath $ reverse ("bin":rest)) </> "hoogle" <.> exeExtension - -getHoogleBinPathCabalAPI :: IO [String] -getHoogleBinPathCabalAPI = do - let ci=buildCompilerFlavor - mapM (getBinDir ci) [True,False] - -getBinDir :: CompilerFlavor -> Bool -> IO FilePath -getBinDir ci user=do - ids<-defaultInstallDirs ci user True - let env=installDirsTemplateEnv ids - return $ fromPathTemplate $ substPathTemplate env $ bindir ids - -getHoogleBinPathCabalDir :: IO String -getHoogleBinPathCabalDir = do - cabalDir <- getAppUserDataDirectory "cabal" - return (cabalDir </> "bin" </> "hoogle" <.> exeExtension) - -getHoogleBinPathMacOsDir :: IO String -getHoogleBinPathMacOsDir = do - homeDir <- getHomeDirectory - return (homeDir </> "Library" </> "Haskell" </> "bin" </> "hoogle" <.> exeExtension) - -exeExtension :: String -#ifdef mingw32_HOST_OS -exeExtension = "exe" -#else -exeExtension = "" -#endif - --- This part is commented out because Cabal does not work --- well linking with the Hoogle library. --- Instead, `hoogle` is called directly and the results --- are parsed and converted into database items. - -{- --- |Loads the Hoogle search database into memory. --- If no database is found, an empty one is returned. -getHoogleDatabases :: IO H.Database -getHoogleDatabases = do path <- findHoogleDatabasesPath - case path of - Nothing -> return mempty - Just p -> do files <- getDirectoryContents p - hooFiles <- filterM (\f -> do exists <- doesFileExist f - let isHoo = takeExtension f == ".hoo" - return $ exists && isHoo) - files - dbs <- mapM H.loadDatabase hooFiles - return $ mconcat dbs - -findHoogleDatabasesPath :: IO (Maybe String) -findHoogleDatabasesPath = do minfo <- findHoogleInfo - case minfo of - Nothing -> return Nothing - Just info -> let [libDir] = libraryDirs info - in return $ Just (getDatabasesDir libDir) - -getDatabasesDir :: String -> String -getDatabasesDir path = let (_:(hoogleV:(_:rest))) = reverse $ splitDirectories path - in (joinPath $ reverse (hoogleV:("share":rest))) </> "databases" --} +{-# LANGUAGE CPP #-}++module Scion.PersistentHoogle.Util+( findHoogleBinPath+) where++import Data.List (find)+import Data.Maybe+import Distribution.Compiler+import Distribution.InstalledPackageInfo+import Distribution.Package+import Distribution.Simple.InstallDirs+import Scion.Packages+import System.FilePath+import System.Directory (doesFileExist, getAppUserDataDirectory, getHomeDirectory)++-- Functions for finding Hoogle in the system++findHoogleBinPath :: Maybe String -> IO (Maybe String)+findHoogleBinPath extraPath = do+ p1 <- findHoogleBinInLibrary getHoogleBinPath1+ p2 <- findHoogleBinInLibrary getHoogleBinPath2+ p3 <- getHoogleBinPathCabalAPI+ p4 <- getHoogleBinPathCabalDir+ p5 <- getHoogleBinPathMacOsDir+ let placesToSearch = (catMaybes [extraPath, p1, p2]) ++ [p4, p5] ++ p3+ findPathsAndCheck placesToSearch++findPathsAndCheck :: [String] -> IO (Maybe String)+findPathsAndCheck [] = return Nothing+findPathsAndCheck (f:fs) = do r <- findPathAndCheck f+ case r of+ Nothing -> findPathsAndCheck fs+ _ -> return r++findPathAndCheck :: String -> IO (Maybe String)+findPathAndCheck path = do + exists <- doesFileExist path+ if exists+ then return (Just path)+ else return Nothing++findHoogleBinInLibrary :: (String -> String) -> IO (Maybe String)+findHoogleBinInLibrary f = do minfo <- findHoogleInfo+ case minfo of+ Nothing -> return Nothing+ Just info -> let [libDir] = libraryDirs info+ in return $ Just (f libDir)++findHoogleInfo :: IO (Maybe InstalledPackageInfo)+findHoogleInfo = do infos' <- getPkgInfos+ let infos = removeSmallVersions $ concat $ map snd infos'+ return $ find (\m -> (pkgName (sourcePackageId m)) == PackageName "hoogle") infos++removeSmallVersions :: [InstalledPackageInfo] -> [InstalledPackageInfo]+removeSmallVersions pids = filter+ (not . (\InstalledPackageInfo { sourcePackageId = (PackageIdentifier name version) } -> + any (\InstalledPackageInfo { sourcePackageId = (PackageIdentifier name' version') } ->+ name' == name && version' > version)+ pids))+ pids++getHoogleBinPath1 :: String -> String+getHoogleBinPath1 path = let (_:(_:(_:rest))) = reverse $ splitDirectories path+ in (joinPath $ reverse ("bin":rest)) </> "hoogle" <.> exeExtension++getHoogleBinPath2 :: String -> String+getHoogleBinPath2 path = let (_:(_:rest)) = reverse $ splitDirectories path+ in (joinPath $ reverse ("bin":rest)) </> "hoogle" <.> exeExtension++getHoogleBinPathCabalAPI :: IO [String]+getHoogleBinPathCabalAPI = do+ let ci=buildCompilerFlavor+ mapM (getBinDir ci) [True,False]+ +getBinDir :: CompilerFlavor -> Bool -> IO FilePath+getBinDir ci user=do+ ids<-defaultInstallDirs ci user True+ let env=installDirsTemplateEnv ids+ return $ fromPathTemplate $ substPathTemplate env $ bindir ids ++getHoogleBinPathCabalDir :: IO String+getHoogleBinPathCabalDir = do + cabalDir <- getAppUserDataDirectory "cabal"+ return (cabalDir </> "bin" </> "hoogle" <.> exeExtension)++getHoogleBinPathMacOsDir :: IO String+getHoogleBinPathMacOsDir = do + homeDir <- getHomeDirectory+ return (homeDir </> "Library" </> "Haskell" </> "bin" </> "hoogle" <.> exeExtension)++exeExtension :: String+#ifdef mingw32_HOST_OS+exeExtension = "exe"+#else+exeExtension = ""+#endif++-- This part is commented out because Cabal does not work+-- well linking with the Hoogle library.+-- Instead, `hoogle` is called directly and the results+-- are parsed and converted into database items.++{-+-- |Loads the Hoogle search database into memory.+-- If no database is found, an empty one is returned.+getHoogleDatabases :: IO H.Database+getHoogleDatabases = do path <- findHoogleDatabasesPath+ case path of+ Nothing -> return mempty+ Just p -> do files <- getDirectoryContents p+ hooFiles <- filterM (\f -> do exists <- doesFileExist f+ let isHoo = takeExtension f == ".hoo"+ return $ exists && isHoo)+ files+ dbs <- mapM H.loadDatabase hooFiles+ return $ mconcat dbs++findHoogleDatabasesPath :: IO (Maybe String)+findHoogleDatabasesPath = do minfo <- findHoogleInfo+ case minfo of+ Nothing -> return Nothing+ Just info -> let [libDir] = libraryDirs info+ in return $ Just (getDatabasesDir libDir)++getDatabasesDir :: String -> String+getDatabasesDir path = let (_:(hoogleV:(_:rest))) = reverse $ splitDirectories path+ in (joinPath $ reverse (hoogleV:("share":rest))) </> "databases"+-}
src/Server/PersistentCommands.hs view
@@ -12,14 +12,14 @@ import Database.Persist.Sqlite hiding (get) import Scion.PersistentBrowser import Scion.PersistentBrowser.Build -import Scion.PersistentBrowser.DbTypes +--import Scion.PersistentBrowser.DbTypes import Scion.PersistentBrowser.Query import Scion.PersistentBrowser.Util (logToStdout) import qualified Scion.PersistentHoogle as H import Scion.Packages import System.Directory import Data.Conduit (runResourceT) -import Control.Monad.Logger (runStderrLoggingT) +import Control.Monad.Logger (runNoLoggingT) --runStderrLoggingT, data Command = LoadLocalDatabase FilePath Bool | LoadHackageDatabase FilePath Bool @@ -72,7 +72,7 @@ runWithState' :: Bool -> Maybe FilePath -> SQL[a] -> IO [ a] runWithState' use mpath action = if use && isJust mpath then do let path = fromJust mpath - runResourceT $ runStderrLoggingT $ withSqliteConn (T.pack path) $ runSqlConn action + runResourceT $ runNoLoggingT $ withSqliteConn (T.pack path) $ runSqlConn action else return [] runDb :: CurrentDatabase -> (Maybe DbPackageIdentifier -> SQL [a]) -> BrowserM [a] @@ -88,7 +88,7 @@ do fileExists <- lift $ doesFileExist path let fileExists' = fileExists `seq` fileExists when rebuild $ - lift $ do runResourceT $ runStderrLoggingT $ withSqliteConn (T.pack path) $ runSqlConn $ do + lift $ do runResourceT $ runNoLoggingT $ withSqliteConn (T.pack path) $ runSqlConn $ do runMigration migrateAll createIndexes pkgInfos' <- getPkgInfos @@ -105,7 +105,7 @@ when (not fileExists' || rebuild) $ lift $ do when fileExists' (removeFile path) logToStdout "Rebuilding Hackage database" - runResourceT $ runStderrLoggingT $ withSqliteConn (T.pack path) $ runSqlConn $ do + runResourceT $ runNoLoggingT $ withSqliteConn (T.pack path) $ runSqlConn $ do runMigration migrateAll createIndexes saveHackageDatabase path