diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/docs/LICENSE b/docs/LICENSE --- a/docs/LICENSE +++ b/docs/LICENSE @@ -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. diff --git a/scion-browser.cabal b/scion-browser.cabal --- a/scion-browser.cabal +++ b/scion-browser.cabal @@ -1,234 +1,234 @@ -name: scion-browser -version: 0.2.2 -cabal-version: >= 1.8 -build-type: Simple -license: BSD3 -license-file: docs/LICENSE -author: Alejandro Serrano -maintainer: Alejandro Serrano -homepage: http://github.com/serras/scion-class-browser -category: Development -synopsis: Command-line interface for browsing and searching packages documentation -description: Scion Browser aims to be a command-line interface for getting information about installed Haskell packages, that could be later used by development environments. It also provides integration with Hoogle. By now, it has been integrated in EclipseFP. - -source-repository head - type: git - location: https://github.com/serras/scion-class-browser - -library - hs-source-dirs: src - build-depends: - attoparsec >= 0.10, - base == 4.*, - mtl >= 2, - derive >= 2.5 && < 3, - text == 0.11.*, - parsec >= 3 && < 4, - Cabal >= 0.10, - haskell-src-exts >= 1.11 && < 2, - process >= 1 && < 2, - tar == 0.3.*, - zlib == 0.5.*, - HTTP >= 4000 && < 5000, - deepseq >= 1.1 && < 2, - aeson >= 0.4, - parallel-io >= 0.3, - utf8-string, - persistent, - persistent-sqlite >= 0.6, - persistent-template, - transformers, - unordered-containers >= 0.1.3, - zlib, - ghc-paths == 0.1.* - - if !os(mingw32) - build-depends: - unix >= 2 && < 3 - - if impl(ghc >= 7.0) - build-depends: - containers >= 0.2 && < 0.5, - directory == 1.1.*, - filepath == 1.2.*, - bytestring, - -- For Scion.Packages (provisional) - ghc >= 7 - else - build-depends: - containers >= 0.2 && < 0.4, - directory == 1.0.*, - filepath == 1.1.*, - bytestring, - -- For Scion.Packages (provisional) - ghc >= 6.10 && < 6.13 - - -- if !os(mingw32) - -- extra-libraries: tinfo - - exposed-modules: - Scion.PersistentBrowser, - Scion.PersistentBrowser.Query, - Scion.PersistentBrowser.Build, - Scion.PersistentHoogle - - ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -fno-warn-orphans - other-modules: - Scion.Packages, - Scion.PersistentBrowser.DbTypes, - Scion.PersistentBrowser.FileUtil, - Scion.PersistentBrowser.FromMissingH, - Scion.PersistentBrowser.Instances.Json, - Scion.PersistentBrowser.Parser, - Scion.PersistentBrowser.Parser.Documentable, - Scion.PersistentBrowser.Parser.Internal, - Scion.PersistentBrowser.TempFile, - Scion.PersistentBrowser.ToDb, - Scion.PersistentBrowser.Types, - Scion.PersistentBrowser.Util, - Scion.PersistentHoogle.Instances.Json, - Scion.PersistentHoogle.Parser, - Scion.PersistentHoogle.Types, - Scion.PersistentHoogle.Util - -executable scion-browser - hs-source-dirs: src - main-is: Main.hs - build-depends: - haskeline >= 0.6, - attoparsec >= 0.10, - base == 4.*, - mtl >= 2, - derive >= 2.5 && < 3, - text == 0.11.*, - parsec >= 3 && < 4, - Cabal >= 0.10, - haskell-src-exts >= 1.11 && < 2, - process >= 1 && < 2, - tar == 0.3.*, - zlib == 0.5.*, - HTTP >= 4000 && < 5000, - deepseq >= 1.1 && < 2, - aeson >= 0.4, - parallel-io >= 0.3, - utf8-string, - persistent, - persistent-sqlite >= 0.6, - persistent-template, - transformers, - unordered-containers >= 0.1.3, - zlib, - ghc-paths == 0.1.* - - if !os(mingw32) - build-depends: - unix >= 2 && < 3 - - if impl(ghc >= 7.0) - build-depends: - containers >= 0.2 && < 0.5, - directory == 1.1.*, - filepath == 1.2.*, - bytestring, - -- For Scion.Packages (provisional) - ghc >= 7 - else - build-depends: - containers >= 0.2 && < 0.4, - directory == 1.0.*, - filepath == 1.1.*, - bytestring, - -- For Scion.Packages (provisional) - ghc >= 6.10 && < 6.13 - - -- if !os(mingw32) - -- extra-libraries: tinfo - - ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -fno-warn-orphans -threaded - other-modules: - Scion.Packages, - Scion.PersistentBrowser, - Scion.PersistentBrowser.Build, - Scion.PersistentBrowser.DbTypes, - Scion.PersistentBrowser.FileUtil, - Scion.PersistentBrowser.FromMissingH, - Scion.PersistentBrowser.Instances.Json, - Scion.PersistentBrowser.Parser, - Scion.PersistentBrowser.Parser.Documentable, - Scion.PersistentBrowser.Parser.Internal, - Scion.PersistentBrowser.Query, - Scion.PersistentBrowser.TempFile, - Scion.PersistentBrowser.ToDb, - Scion.PersistentBrowser.Types, - Scion.PersistentBrowser.Util, - Scion.PersistentHoogle, - Scion.PersistentHoogle.Instances.Json, - Scion.PersistentHoogle.Parser, - Scion.PersistentHoogle.Types, - Scion.PersistentHoogle.Util, - Server.PersistentCommands - ---test-suite BrowserTests --- main-is: Test.hs --- type: exitcode-stdio-1.0 --- x-uses-tf: true --- ghc-options: -Wall -rtsopts --- hs-source-dirs: src, test --- other-modules: Scion.Browser.Parser.Documentable, Scion.Browser.Parser.Internal, Scion.Browser.Parser, Scion.Browser.ParserTests, Scion.PersistentHoogle.Util --- --- build-depends: --- HUnit >= 1.2 && < 2, --- QuickCheck >= 2.4, --- test-framework >= 0.4.1, --- test-framework-quickcheck2, --- test-framework-hunit, --- split, --- haskeline >= 0.6, --- -- From library --- attoparsec >= 0.10, --- base == 4.*, --- mtl >= 2, --- derive >= 2.5 && < 3, --- text == 0.11.*, --- parsec >= 3 && < 4, --- Cabal >= 0.10, --- haskell-src-exts >= 1.11 && < 2, --- process >= 1 && < 2, --- tar == 0.3.*, --- zlib == 0.5.*, --- HTTP >= 4000 && < 5000, --- deepseq >= 1.1 && < 2, --- aeson >= 0.4, --- parallel-io >= 0.3, --- utf8-string , --- persistent, --- persistent-sqlite >= 0.6, --- persistent-template, --- transformers, --- unordered-containers >= 0.1.3, --- zlib, --- -- For Scion.packages (provisional) --- ghc-paths == 0.1.* --- --- if !os(mingw32) --- build-depends: --- unix >= 2 && < 3 --- --- if impl(ghc >= 7.0) --- build-depends: --- containers >= 0.2 && < 0.5, --- directory == 1.1.*, --- filepath == 1.2.*, --- bytestring, --- -- For Scion.Packages (provisional) --- ghc >= 7 --- else --- build-depends: --- containers >= 0.2 && < 0.4, --- directory == 1.0.*, --- filepath == 1.1.*, --- bytestring, --- -- For Scion.Packages (provisional) - - - +name: scion-browser +version: 0.2.3 +cabal-version: >= 1.8 +build-type: Simple +license: BSD3 +license-file: docs/LICENSE +author: Alejandro Serrano +maintainer: Alejandro Serrano +homepage: http://github.com/serras/scion-class-browser +category: Development +synopsis: Command-line interface for browsing and searching packages documentation +description: Scion Browser aims to be a command-line interface for getting information about installed Haskell packages, that could be later used by development environments. It also provides integration with Hoogle. By now, it has been integrated in EclipseFP. + +source-repository head + type: git + location: https://github.com/serras/scion-class-browser + +library + hs-source-dirs: src + build-depends: + attoparsec >= 0.10, + base == 4.*, + mtl >= 2, + derive >= 2.5 && < 3, + text == 0.11.*, + parsec >= 3 && < 4, + Cabal >= 0.10, + haskell-src-exts >= 1.11 && < 2, + process >= 1 && < 2, + tar == 0.3.*, + zlib == 0.5.*, + HTTP >= 4000 && < 5000, + deepseq >= 1.1 && < 2, + aeson >= 0.4, + parallel-io >= 0.3, + utf8-string, + persistent, + persistent-sqlite >= 0.6, + persistent-template, + transformers, + unordered-containers >= 0.1.3, + zlib, + ghc-paths == 0.1.* + + if !os(mingw32) + build-depends: + unix >= 2 && < 3 + + if impl(ghc >= 7.0) + build-depends: + containers >= 0.2 && < 0.5, + directory == 1.1.*, + filepath == 1.2.*, + bytestring, + -- For Scion.Packages (provisional) + ghc >= 7 + else + build-depends: + containers >= 0.2 && < 0.4, + directory == 1.0.*, + filepath == 1.1.*, + bytestring, + -- For Scion.Packages (provisional) + ghc >= 6.10 && < 6.13 + + -- if !os(mingw32) + -- extra-libraries: tinfo + + exposed-modules: + Scion.PersistentBrowser, + Scion.PersistentBrowser.Query, + Scion.PersistentBrowser.Build, + Scion.PersistentHoogle + + ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -fno-warn-orphans + other-modules: + Scion.Packages, + Scion.PersistentBrowser.DbTypes, + Scion.PersistentBrowser.FileUtil, + Scion.PersistentBrowser.FromMissingH, + Scion.PersistentBrowser.Instances.Json, + Scion.PersistentBrowser.Parser, + Scion.PersistentBrowser.Parser.Documentable, + Scion.PersistentBrowser.Parser.Internal, + Scion.PersistentBrowser.TempFile, + Scion.PersistentBrowser.ToDb, + Scion.PersistentBrowser.Types, + Scion.PersistentBrowser.Util, + Scion.PersistentHoogle.Instances.Json, + Scion.PersistentHoogle.Parser, + Scion.PersistentHoogle.Types, + Scion.PersistentHoogle.Util + +executable scion-browser + hs-source-dirs: src + main-is: Main.hs + build-depends: + haskeline >= 0.6, + attoparsec >= 0.10, + base == 4.*, + mtl >= 2, + derive >= 2.5 && < 3, + text == 0.11.*, + parsec >= 3 && < 4, + Cabal >= 0.10, + haskell-src-exts >= 1.11 && < 2, + process >= 1 && < 2, + tar == 0.3.*, + zlib == 0.5.*, + HTTP >= 4000 && < 5000, + deepseq >= 1.1 && < 2, + aeson >= 0.4, + parallel-io >= 0.3, + utf8-string, + persistent, + persistent-sqlite >= 0.6, + persistent-template, + transformers, + unordered-containers >= 0.1.3, + zlib, + ghc-paths == 0.1.* + + if !os(mingw32) + build-depends: + unix >= 2 && < 3 + + if impl(ghc >= 7.0) + build-depends: + containers >= 0.2 && < 0.5, + directory == 1.1.*, + filepath == 1.2.*, + bytestring, + -- For Scion.Packages (provisional) + ghc >= 7 + else + build-depends: + containers >= 0.2 && < 0.4, + directory == 1.0.*, + filepath == 1.1.*, + bytestring, + -- For Scion.Packages (provisional) + ghc >= 6.10 && < 6.13 + + -- if !os(mingw32) + -- extra-libraries: tinfo + + ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -fno-warn-orphans -threaded + other-modules: + Scion.Packages, + Scion.PersistentBrowser, + Scion.PersistentBrowser.Build, + Scion.PersistentBrowser.DbTypes, + Scion.PersistentBrowser.FileUtil, + Scion.PersistentBrowser.FromMissingH, + Scion.PersistentBrowser.Instances.Json, + Scion.PersistentBrowser.Parser, + Scion.PersistentBrowser.Parser.Documentable, + Scion.PersistentBrowser.Parser.Internal, + Scion.PersistentBrowser.Query, + Scion.PersistentBrowser.TempFile, + Scion.PersistentBrowser.ToDb, + Scion.PersistentBrowser.Types, + Scion.PersistentBrowser.Util, + Scion.PersistentHoogle, + Scion.PersistentHoogle.Instances.Json, + Scion.PersistentHoogle.Parser, + Scion.PersistentHoogle.Types, + Scion.PersistentHoogle.Util, + Server.PersistentCommands + +--test-suite BrowserTests +-- main-is: Test.hs +-- type: exitcode-stdio-1.0 +-- x-uses-tf: true +-- ghc-options: -Wall -rtsopts +-- hs-source-dirs: src, test +-- other-modules: Scion.Browser.Parser.Documentable, Scion.Browser.Parser.Internal, Scion.Browser.Parser, Scion.Browser.ParserTests, Scion.PersistentHoogle.Util +-- +-- build-depends: +-- HUnit >= 1.2 && < 2, +-- QuickCheck >= 2.4, +-- test-framework >= 0.4.1, +-- test-framework-quickcheck2, +-- test-framework-hunit, +-- split, +-- haskeline >= 0.6, +-- -- From library +-- attoparsec >= 0.10, +-- base == 4.*, +-- mtl >= 2, +-- derive >= 2.5 && < 3, +-- text == 0.11.*, +-- parsec >= 3 && < 4, +-- Cabal >= 0.10, +-- haskell-src-exts >= 1.11 && < 2, +-- process >= 1 && < 2, +-- tar == 0.3.*, +-- zlib == 0.5.*, +-- HTTP >= 4000 && < 5000, +-- deepseq >= 1.1 && < 2, +-- aeson >= 0.4, +-- parallel-io >= 0.3, +-- utf8-string , +-- persistent, +-- persistent-sqlite >= 0.6, +-- persistent-template, +-- transformers, +-- unordered-containers >= 0.1.3, +-- zlib, +-- -- For Scion.packages (provisional) +-- ghc-paths == 0.1.* +-- +-- if !os(mingw32) +-- build-depends: +-- unix >= 2 && < 3 +-- +-- if impl(ghc >= 7.0) +-- build-depends: +-- containers >= 0.2 && < 0.5, +-- directory == 1.1.*, +-- filepath == 1.2.*, +-- bytestring, +-- -- For Scion.Packages (provisional) +-- ghc >= 7 +-- else +-- build-depends: +-- containers >= 0.2 && < 0.4, +-- directory == 1.0.*, +-- filepath == 1.1.*, +-- bytestring, +-- -- For Scion.Packages (provisional) + + + diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,45 +1,45 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Main where - -import qualified Codec.Compression.Zlib as Zlib -import Control.Monad.State -import Data.Aeson -import qualified Data.Aeson.Types as T -import qualified Data.Attoparsec.Char8 as Atto -import qualified Data.Attoparsec.Types as Atto -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as LBS -import Server.PersistentCommands -import System.Console.Haskeline -import System.IO (hFlush, stdout) -import System.Environment (getArgs) -import Data.Version (showVersion) -import Paths_scion_browser - -main :: IO () -main = do - args<-getArgs - case args of - ("--version":_)->do - putStrLn ("scion-browser executable, version "++ (showVersion version)) - _-> do - runStateT (runInputT defaultSettings loop) initialState - return () - -loop :: InputT BrowserM () -loop = do maybeLine <- getInputLine "" - case maybeLine of - Nothing -> return () -- ctrl+D or EOF - Just line -> do - case Atto.parse json (BS.pack line) of - Atto.Fail _ _ e -> outputStrLn ("error in command: " ++ e) >> loop - Atto.Done _ value -> case T.parse parseJSON value of - Error e -> outputStrLn ("error in command: " ++ e) >> loop - Success cmd -> do (res, continue) <- lift $ executeCommand cmd - let encoded = encode res - compressed = Zlib.compressWith Zlib.defaultCompressParams { Zlib.compressLevel = Zlib.bestSpeed } encoded - liftIO $ LBS.putStr compressed - liftIO $ hFlush stdout - if continue then loop else return () - +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import qualified Codec.Compression.Zlib as Zlib +import Control.Monad.State +import Data.Aeson +import qualified Data.Aeson.Types as T +import qualified Data.Attoparsec.Char8 as Atto +import qualified Data.Attoparsec.Types as Atto +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LBS +import Server.PersistentCommands +import System.Console.Haskeline +import System.IO (hFlush, stdout) +import System.Environment (getArgs) +import Data.Version (showVersion) +import Paths_scion_browser + +main :: IO () +main = do + args<-getArgs + case args of + ("--version":_)->do + putStrLn ("scion-browser executable, version "++ (showVersion version)) + _-> do + runStateT (runInputT defaultSettings loop) initialState + return () + +loop :: InputT BrowserM () +loop = do maybeLine <- getInputLine "" + case maybeLine of + Nothing -> return () -- ctrl+D or EOF + Just line -> do + case Atto.parse json (BS.pack line) of + Atto.Fail _ _ e -> outputStrLn ("error in command: " ++ e) >> loop + Atto.Done _ value -> case T.parse parseJSON value of + Error e -> outputStrLn ("error in command: " ++ e) >> loop + Success cmd -> do (res, continue) <- lift $ executeCommand cmd + let encoded = encode res + compressed = Zlib.compressWith Zlib.defaultCompressParams { Zlib.compressLevel = Zlib.bestSpeed } encoded + liftIO $ LBS.putStr compressed + liftIO $ hFlush stdout + if continue then loop else return () + diff --git a/src/Scion/Packages.hs b/src/Scion/Packages.hs --- a/src/Scion/Packages.hs +++ b/src/Scion/Packages.hs @@ -1,200 +1,200 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Scion.Packages --- Author : Thiago Arrais --- Copyright : (c) Thiago Arrais 2009 --- License : BSD-style --- Url : http://stackoverflow.com/questions/1522104/how-to-programmatically-retrieve-ghc-package-information --- --- Maintainer : nominolo@gmail.com --- Stability : experimental --- Portability : portable --- --- Cabal-related functionality. -module Scion.Packages ( getPkgInfos ) where - -import Prelude hiding (Maybe) -import qualified Config -import qualified System.Info -import Data.List -import Data.Maybe -import Control.Monad -import Distribution.InstalledPackageInfo -import Distribution.Text -import System.Directory -import System.Environment (getEnv) -import System.FilePath -import System.IO -import System.IO.Error - -import GHC.Paths - -import qualified Control.Exception as Exception - --- This was borrowed from the ghc-pkg source: -type InstalledPackageInfoString = InstalledPackageInfo_ String - --- | Types of cabal package databases -data CabalPkgDBType = - PkgDirectory FilePath - | PkgFile FilePath - -type InstalledPackagesList = [(FilePath, [InstalledPackageInfo])] - --- | Fetch the installed package info from the global and user package.conf --- databases, mimicking the functionality of ghc-pkg. - -getPkgInfos :: IO InstalledPackagesList -getPkgInfos = - let - -- | Test for package database's presence in a given directory - -- NB: The directory is returned for later scanning by listConf, - -- which parses the actual package database file(s). - lookForPackageDBIn :: FilePath -> IO (Maybe InstalledPackagesList) - lookForPackageDBIn dir = - let - path_dir = dir "package.conf.d" - path_file = dir "package.conf" - in do - exists_dir <- doesDirectoryExist path_dir - if exists_dir - then do - pkgs <- readContents (PkgDirectory path_dir) - return $ Just pkgs - else do - exists_file <- doesFileExist path_file - if exists_file - then do - pkgs <- readContents (PkgFile path_file) - return $ Just pkgs - else return Nothing - - currentArch :: String - currentArch = System.Info.arch - - currentOS :: String - currentOS = System.Info.os - - ghcVersion :: String - ghcVersion = Config.cProjectVersion - in do - -- Get the global package configuration database: - global_conf <- do - r <- lookForPackageDBIn getLibDir - case r of - Nothing -> ioError $ userError ("Can't find package database in " ++ getLibDir) - Just pkgs -> return $ pkgs - - -- Get the user package configuration database - e_appdir <- try $ getAppUserDataDirectory "ghc" - user_conf <- do - case e_appdir of - Left _ -> return [] - Right appdir -> do - let subdir = currentArch ++ '-':currentOS ++ '-':ghcVersion - dir = appdir subdir - r <- lookForPackageDBIn dir - case r of - Nothing -> return [] - Just pkgs -> return pkgs - - -- Process GHC_PACKAGE_PATH, if present: - e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH") - env_stack <- do - case e_pkg_path of - Left _ -> return [] - Right path -> do - pkgs <- mapM readContents [(PkgDirectory pkg) | pkg <- splitSearchPath path] - return $ concat pkgs - - -- Send back the combined installed packages list: - return (env_stack ++ user_conf ++ global_conf) - --- | Read the contents of the given directory, searching for ".conf" files, and parse the --- package contents. Returns a singleton list (directory, [installed packages]) - -readContents :: CabalPkgDBType -- ^ The package database - -> IO [(FilePath, [InstalledPackageInfo])] -- ^ Installed packages - -readContents pkgdb = - let - -- | List package configuration files that might live in the given directory - listConf :: FilePath -> IO [FilePath] - listConf dbdir = do - conf_dir_exists <- doesDirectoryExist dbdir - if conf_dir_exists - then do - files <- getDirectoryContents dbdir - return [ dbdir file | file <- files, isSuffixOf ".conf" file] - else return [] - - -- | Read a file, ensuring that UTF8 coding is used for GCH >= 6.12 - readUTF8File :: FilePath -> IO String - readUTF8File file = do - h <- openFile file ReadMode -#if __GLASGOW_HASKELL__ >= 612 - -- fix the encoding to UTF-8 - hSetEncoding h utf8 - catch (hGetContents h) (\_ -> do - -- logInfo $ ioeGetErrorString err - hClose h - h' <- openFile file ReadMode - hSetEncoding h' localeEncoding - hGetContents h' - ) -#else - hGetContents h -#endif - - - -- | This function was lifted directly from ghc-pkg. Its sole purpose is - -- parsing an input package description string and producing an - -- InstalledPackageInfo structure. - convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo - convertPackageInfoIn - (pkgconf@(InstalledPackageInfo { exposedModules = e, - hiddenModules = h })) = - pkgconf{ exposedModules = map convert e, - hiddenModules = map convert h } - where convert = fromJust . simpleParse - - -- | Utility function that just flips the arguments to Control.Exception.catch - catchError :: IO a -> (String -> IO a) -> IO a - catchError io handler = io `Exception.catch` handler' - where handler' (Exception.ErrorCall err) = handler err - - -- | Slightly different approach in Cabal 1.8 series, with the package.conf.d - -- directories, where individual package configuration files are association - -- pairs. - pkgInfoReader :: FilePath - -> IO [InstalledPackageInfo] - pkgInfoReader f = - catch ( - do - pkgStr <- readUTF8File f - let pkgInfo = parseInstalledPackageInfo pkgStr - case pkgInfo of - ParseOk _ info -> return [info] - ParseFailed _ -> do - -- logInfo (show err) - return [emptyInstalledPackageInfo] - ) (\_->return [emptyInstalledPackageInfo]) - - in case pkgdb of - (PkgDirectory pkgdbDir) -> do - confs <- listConf pkgdbDir - pkgInfoList <- mapM pkgInfoReader confs - return [(pkgdbDir, join pkgInfoList)] - - (PkgFile dbFile) -> do - pkgStr <- readUTF8File dbFile - let pkgs = map convertPackageInfoIn $ read pkgStr - pkgInfoList <- - Exception.evaluate pkgs - `catchError` - (\e-> ioError $ userError $ "parsing " ++ dbFile ++ ": " ++ (show e)) - return [(takeDirectory dbFile, pkgInfoList)] - --- GHC.Path sets libdir for us... -getLibDir :: String -getLibDir = libdir +{-# LANGUAGE CPP #-} +-- | +-- Module : Scion.Packages +-- Author : Thiago Arrais +-- Copyright : (c) Thiago Arrais 2009 +-- License : BSD-style +-- Url : http://stackoverflow.com/questions/1522104/how-to-programmatically-retrieve-ghc-package-information +-- +-- Maintainer : nominolo@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Cabal-related functionality. +module Scion.Packages ( getPkgInfos ) where + +import Prelude hiding (Maybe) +import qualified Config +import qualified System.Info +import Data.List +import Data.Maybe +import Control.Monad +import Distribution.InstalledPackageInfo +import Distribution.Text +import System.Directory +import System.Environment (getEnv) +import System.FilePath +import System.IO +import System.IO.Error + +import GHC.Paths + +import qualified Control.Exception as Exception + +-- This was borrowed from the ghc-pkg source: +type InstalledPackageInfoString = InstalledPackageInfo_ String + +-- | Types of cabal package databases +data CabalPkgDBType = + PkgDirectory FilePath + | PkgFile FilePath + +type InstalledPackagesList = [(FilePath, [InstalledPackageInfo])] + +-- | Fetch the installed package info from the global and user package.conf +-- databases, mimicking the functionality of ghc-pkg. + +getPkgInfos :: IO InstalledPackagesList +getPkgInfos = + let + -- | Test for package database's presence in a given directory + -- NB: The directory is returned for later scanning by listConf, + -- which parses the actual package database file(s). + lookForPackageDBIn :: FilePath -> IO (Maybe InstalledPackagesList) + lookForPackageDBIn dir = + let + path_dir = dir "package.conf.d" + path_file = dir "package.conf" + in do + exists_dir <- doesDirectoryExist path_dir + if exists_dir + then do + pkgs <- readContents (PkgDirectory path_dir) + return $ Just pkgs + else do + exists_file <- doesFileExist path_file + if exists_file + then do + pkgs <- readContents (PkgFile path_file) + return $ Just pkgs + else return Nothing + + currentArch :: String + currentArch = System.Info.arch + + currentOS :: String + currentOS = System.Info.os + + ghcVersion :: String + ghcVersion = Config.cProjectVersion + in do + -- Get the global package configuration database: + global_conf <- do + r <- lookForPackageDBIn getLibDir + case r of + Nothing -> ioError $ userError ("Can't find package database in " ++ getLibDir) + Just pkgs -> return $ pkgs + + -- Get the user package configuration database + e_appdir <- try $ getAppUserDataDirectory "ghc" + user_conf <- do + case e_appdir of + Left _ -> return [] + Right appdir -> do + let subdir = currentArch ++ '-':currentOS ++ '-':ghcVersion + dir = appdir subdir + r <- lookForPackageDBIn dir + case r of + Nothing -> return [] + Just pkgs -> return pkgs + + -- Process GHC_PACKAGE_PATH, if present: + e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH") + env_stack <- do + case e_pkg_path of + Left _ -> return [] + Right path -> do + pkgs <- mapM readContents [(PkgDirectory pkg) | pkg <- splitSearchPath path] + return $ concat pkgs + + -- Send back the combined installed packages list: + return (env_stack ++ user_conf ++ global_conf) + +-- | Read the contents of the given directory, searching for ".conf" files, and parse the +-- package contents. Returns a singleton list (directory, [installed packages]) + +readContents :: CabalPkgDBType -- ^ The package database + -> IO [(FilePath, [InstalledPackageInfo])] -- ^ Installed packages + +readContents pkgdb = + let + -- | List package configuration files that might live in the given directory + listConf :: FilePath -> IO [FilePath] + listConf dbdir = do + conf_dir_exists <- doesDirectoryExist dbdir + if conf_dir_exists + then do + files <- getDirectoryContents dbdir + return [ dbdir file | file <- files, isSuffixOf ".conf" file] + else return [] + + -- | Read a file, ensuring that UTF8 coding is used for GCH >= 6.12 + readUTF8File :: FilePath -> IO String + readUTF8File file = do + h <- openFile file ReadMode +#if __GLASGOW_HASKELL__ >= 612 + -- fix the encoding to UTF-8 + hSetEncoding h utf8 + catch (hGetContents h) (\_ -> do + -- logInfo $ ioeGetErrorString err + hClose h + h' <- openFile file ReadMode + hSetEncoding h' localeEncoding + hGetContents h' + ) +#else + hGetContents h +#endif + + + -- | This function was lifted directly from ghc-pkg. Its sole purpose is + -- parsing an input package description string and producing an + -- InstalledPackageInfo structure. + convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo + convertPackageInfoIn + (pkgconf@(InstalledPackageInfo { exposedModules = e, + hiddenModules = h })) = + pkgconf{ exposedModules = map convert e, + hiddenModules = map convert h } + where convert = fromJust . simpleParse + + -- | Utility function that just flips the arguments to Control.Exception.catch + catchError :: IO a -> (String -> IO a) -> IO a + catchError io handler = io `Exception.catch` handler' + where handler' (Exception.ErrorCall err) = handler err + + -- | Slightly different approach in Cabal 1.8 series, with the package.conf.d + -- directories, where individual package configuration files are association + -- pairs. + pkgInfoReader :: FilePath + -> IO [InstalledPackageInfo] + pkgInfoReader f = + catch ( + do + pkgStr <- readUTF8File f + let pkgInfo = parseInstalledPackageInfo pkgStr + case pkgInfo of + ParseOk _ info -> return [info] + ParseFailed _ -> do + -- logInfo (show err) + return [emptyInstalledPackageInfo] + ) (\_->return [emptyInstalledPackageInfo]) + + in case pkgdb of + (PkgDirectory pkgdbDir) -> do + confs <- listConf pkgdbDir + pkgInfoList <- mapM pkgInfoReader confs + return [(pkgdbDir, join pkgInfoList)] + + (PkgFile dbFile) -> do + pkgStr <- readUTF8File dbFile + let pkgs = map convertPackageInfoIn $ read pkgStr + pkgInfoList <- + Exception.evaluate pkgs + `catchError` + (\e-> ioError $ userError $ "parsing " ++ dbFile ++ ": " ++ (show e)) + return [(takeDirectory dbFile, pkgInfoList)] + +-- GHC.Path sets libdir for us... +getLibDir :: String +getLibDir = libdir diff --git a/src/Scion/PersistentBrowser.hs b/src/Scion/PersistentBrowser.hs --- a/src/Scion/PersistentBrowser.hs +++ b/src/Scion/PersistentBrowser.hs @@ -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 () + diff --git a/src/Scion/PersistentBrowser/Build.hs b/src/Scion/PersistentBrowser/Build.hs --- a/src/Scion/PersistentBrowser/Build.hs +++ b/src/Scion/PersistentBrowser/Build.hs @@ -1,201 +1,201 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module Scion.PersistentBrowser.Build -( saveHackageDatabase -, createHackageDatabase -, updateDatabase -, createCabalDatabase -, getCabalHoogle -) where - -import Control.Concurrent.ParallelIO.Local -import Control.Exception as E (catch, SomeException) -import Control.Monad.IO.Class (liftIO) -import Data.Either (rights) -import Data.List ((\\), nub) -import qualified Data.Map as M -import qualified Data.Text as T -import Data.Version (Version, showVersion, parseVersion) -import Database.Persist.Sqlite -import Distribution.InstalledPackageInfo -import Distribution.Package hiding (Package) -import Scion.PersistentBrowser.DbTypes -import Scion.PersistentBrowser.FileUtil -import Scion.PersistentBrowser.Parser -import Scion.PersistentBrowser.ToDb -import Scion.PersistentBrowser.Types -import Scion.PersistentBrowser.Util -import System.Directory -import System.Exit -import System.FilePath -import Text.Parsec.Error (ParseError) -import Text.ParserCombinators.Parsec.Error (newErrorMessage, Message(..)) -import Text.ParserCombinators.Parsec.Pos (newPos) -import Text.ParserCombinators.ReadP - - -baseDbUrl :: String -baseDbUrl = "http://haskell.org/hoogle/base.txt" - -ghcDbUrl :: String -ghcDbUrl = "http://www.haskell.org/ghc/docs/latest/html/libraries/ghc/ghc.txt" - -hoogleDbUrl :: String -hoogleDbUrl = "http://hackage.haskell.org/packages/archive/00-hoogle.tar.gz" - --- | Gets the url of a package from Hackage -getPackageUrlHackage :: PackageIdentifier -> String -getPackageUrlHackage (PackageIdentifier (PackageName name) version) = - "http://hackage.haskell.org/packages/archive/" ++ name ++ "/" ++ showVersion version ++ "/doc/html/" ++ name ++ ".txt" - --- | Gets the version of GHC used -getGhcInstalledVersion :: [PackageIdentifier] -> Version -getGhcInstalledVersion [] = error "No GHC found" -getGhcInstalledVersion ((PackageIdentifier (PackageName "ghc") version):_) = version -getGhcInstalledVersion (_:xs) = getGhcInstalledVersion xs - --- | Gets the url of a package from GHC libraries -getPackageUrlGhcLibs :: Version -> PackageIdentifier -> String -getPackageUrlGhcLibs ghcVersion (PackageIdentifier (PackageName name) version) = - "http://www.haskell.org/ghc/docs/" ++ showVersion ghcVersion ++ "/html/libraries/" ++ name ++ "-" ++ showVersion version ++ "/" ++ name ++ ".txt" - --- | Downloads the information for the entire Hackage database --- and saves it to the specified location. -saveHackageDatabase :: FilePath -> IO () -saveHackageDatabase file = withTemporaryDirectory (saveHackageDatabaseWithTmp file) - -saveHackageDatabaseWithTmp :: FilePath -> FilePath -> IO () -saveHackageDatabaseWithTmp file tmp = do (db, _) <- createHackageDatabase tmp - mapM_ (\pkg -> withSqliteConn (T.pack file) (runSqlConn (savePackageToDb pkg))) db - --- | Downloads the information for the entire Hackage database --- creating an in-memory database with it. --- It needs a temporary directory to work on. -createHackageDatabase :: FilePath -> IO ([Documented Package], [(FilePath, ParseError)]) -createHackageDatabase tmp = - do let hoogleDbDir = tmp "hoogle-db" - tmpDir = tmp "tmp-db" - -- Parse Hoogle database - createDirectoryIfMissing True hoogleDbDir - logToStdout "Started downloading Hoogle database" - Just 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 - --let (pkgs, errors) = ([], []) - {- - -- Parse base package - Just baseDownloaded <- downloadFileStrict baseDbUrl - logToStdout "Base database successfully downloaded" - -- Parse ghc package - Just ghcDownloaded <- downloadFileStrict ghcDbUrl - logToStdout "GHC database successfully downloaded" - let (dbBase, errorsBase) = case parseHoogleString "base.txt" baseDownloaded of - Right b -> (b:pkgs, errors) - Left e -> (pkgs, ("base.txt", e):errors) - let (dbGhc, errorsGhc) = case parseHoogleString "ghc.txt" ghcDownloaded of - Right b -> (b:dbBase, errorsBase) - Left e -> (dbBase, ("ghc.txt", e):errorsBase) - return (pkgListToDb dbGhc, errorsGhc) - -} - return (pkgs, errors) - --- | Updates a database with changes in the installed package base. -updateDatabase :: FilePath -> [InstalledPackageInfo] -> IO () -updateDatabase file pkgInfo = withSqliteConn (T.pack file) $ runSqlConn $ updateDatabase' pkgInfo - -updateDatabase' :: [InstalledPackageInfo] -> SqlPersist IO () -updateDatabase' pkgInfo = - do dbPersistent <- selectList ([] :: [Filter DbPackage]) [] - let dbList = map (fromDbToPackageIdentifier . snd) dbPersistent - installedList = nub $ removeSmallVersions $ map sourcePackageId pkgInfo - toRemove = dbList \\ installedList - toAdd = installedList \\ dbList - liftIO $ logToStdout $ "Removing " ++ show (map (\(PackageIdentifier (PackageName name) _) -> name) toRemove) - mapM_ deletePackageByInfo toRemove - liftIO $ logToStdout $ "Adding " ++ show (map (\(PackageIdentifier (PackageName name) _) -> name) toAdd) - let ghcVersion = getGhcInstalledVersion installedList - (addedDb, errors) <- liftIO $ createCabalDatabase' ghcVersion toAdd True - mapM_ savePackageToDb addedDb - liftIO $ logToStdout $ show errors - -fromDbToPackageIdentifier :: DbPackage -> PackageIdentifier -fromDbToPackageIdentifier (DbPackage name version _) = PackageIdentifier (PackageName name) - (getVersion version) -getVersion :: String -> Version -getVersion version = (fst . last . readP_to_S parseVersion) version - -removeSmallVersions :: [PackageIdentifier] -> [PackageIdentifier] -removeSmallVersions pids = filter - (not . (\(PackageIdentifier name version) -> - any (\(PackageIdentifier name' version') -> name' == name && version' > version) pids)) - pids - --- | Get the database from a set of Cabal packages. -createCabalDatabase :: Version -> [PackageIdentifier] -> IO ([Documented Package], [(String, ParseError)]) -createCabalDatabase ghcVersion pkgs = createCabalDatabase' ghcVersion pkgs False - --- | Get the database from a set of Cabal packages. --- If `ifFailCreateEmpty' is set, when a package gives a parse error, --- it is converted into an empty package with a note. -createCabalDatabase' :: Version -> [PackageIdentifier] -> Bool -> IO ([Documented Package], [(String, ParseError)]) -createCabalDatabase' ghcVersion pkgs ifFailCreateEmpty = - withTemporaryDirectory $ \tmp -> - do let toExecute = map (\pid -> do db <- getCabalHoogle ghcVersion pid ifFailCreateEmpty tmp - return (pkgString pid, db)) - pkgs - eitherHooglePkgs <- withThreaded $ \pool -> parallelInterleavedE pool toExecute - let hooglePkgs = rights eitherHooglePkgs - (db, errors) = partitionPackages hooglePkgs - return (db, errors) - --- | Get the database from a Cabal package. -getCabalHoogle :: Version -> PackageIdentifier -> Bool -> FilePath -> IO (Either ParseError (Documented Package)) -getCabalHoogle ghcVersion pid ifFailCreateEmpty tmp = - E.catch (do result <- getCabalHoogle' ghcVersion pid tmp - case result of - Left e -> return $ failure e - Right (Package doc _ info) -> return $ Right (Package doc pid info)) - (\(e :: E.SomeException) -> return $ failure (newErrorMessage (Message "error parsing") - (newPos "" 0 0))) - where failure e = if ifFailCreateEmpty - then Right (Package NoDoc pid M.empty) - else Left e - --- | Get the database from a Cabal package. -getCabalHoogle' :: Version -> PackageIdentifier -> FilePath -> IO (Either ParseError (Documented Package)) -getCabalHoogle' ghcVersion pid tmp = do let downUrl1 = getPackageUrlHackage pid - logToStdout $ "Download " ++ downUrl1 - tryDownload1 <- downloadHoogleFile downUrl1 - case tryDownload1 of - Nothing -> do let downUrl2 = getPackageUrlGhcLibs ghcVersion pid - logToStdout $ "Download " ++ downUrl2 - tryDownload2 <- downloadHoogleFile downUrl2 - case tryDownload2 of - Nothing -> getCabalHoogleLocal pid tmp - Just cnts -> return $ parseHoogleString "" cnts - Just cnts -> return $ parseHoogleString "" cnts - --- | Get the database from a locally installed Cabal package. -getCabalHoogleLocal :: PackageIdentifier -> FilePath -> IO (Either ParseError (Documented Package)) -getCabalHoogleLocal pid tmp = - do let pkgV = pkgString pid - (PackageName pkg) = pkgName pid - logToStdout $ "Parsing " ++ pkgV - code <- executeCommand tmp "cabal" ["unpack", pkgV] True - case code of - ExitFailure _ -> return $ Left (newErrorMessage (Message "package not found") - (newPos pkgV 0 0)) - ExitSuccess -> - do let pkgdir = tmp pkgV - withWorkingDirectory pkgdir $ - do executeCommand pkgdir "cabal" ["configure"] True - executeCommand pkgdir "cabal" ["haddock", "--hoogle"] True - let hoogleFile = pkgdir "dist" "doc" "html" pkg (pkg ++ ".txt") - parseHoogleFile hoogleFile - -pkgString :: PackageIdentifier -> String -pkgString (PackageIdentifier (PackageName name) version) = name ++ "-" ++ showVersion version - +{-# LANGUAGE ScopedTypeVariables #-} + +module Scion.PersistentBrowser.Build +( saveHackageDatabase +, createHackageDatabase +, updateDatabase +, createCabalDatabase +, getCabalHoogle +) where + +import Control.Concurrent.ParallelIO.Local +import Control.Exception as E (catch, SomeException) +import Control.Monad.IO.Class (liftIO) +import Data.Either (rights) +import Data.List ((\\), nub) +import qualified Data.Map as M +import qualified Data.Text as T +import Data.Version (Version, showVersion, parseVersion) +import Database.Persist.Sqlite +import Distribution.InstalledPackageInfo +import Distribution.Package hiding (Package) +import Scion.PersistentBrowser.DbTypes +import Scion.PersistentBrowser.FileUtil +import Scion.PersistentBrowser.Parser +import Scion.PersistentBrowser.ToDb +import Scion.PersistentBrowser.Types +import Scion.PersistentBrowser.Util +import System.Directory +import System.Exit +import System.FilePath +import Text.Parsec.Error (ParseError) +import Text.ParserCombinators.Parsec.Error (newErrorMessage, Message(..)) +import Text.ParserCombinators.Parsec.Pos (newPos) +import Text.ParserCombinators.ReadP + + +baseDbUrl :: String +baseDbUrl = "http://haskell.org/hoogle/base.txt" + +ghcDbUrl :: String +ghcDbUrl = "http://www.haskell.org/ghc/docs/latest/html/libraries/ghc/ghc.txt" + +hoogleDbUrl :: String +hoogleDbUrl = "http://hackage.haskell.org/packages/archive/00-hoogle.tar.gz" + +-- | Gets the url of a package from Hackage +getPackageUrlHackage :: PackageIdentifier -> String +getPackageUrlHackage (PackageIdentifier (PackageName name) version) = + "http://hackage.haskell.org/packages/archive/" ++ name ++ "/" ++ showVersion version ++ "/doc/html/" ++ name ++ ".txt" + +-- | Gets the version of GHC used +getGhcInstalledVersion :: [PackageIdentifier] -> Version +getGhcInstalledVersion [] = error "No GHC found" +getGhcInstalledVersion ((PackageIdentifier (PackageName "ghc") version):_) = version +getGhcInstalledVersion (_:xs) = getGhcInstalledVersion xs + +-- | Gets the url of a package from GHC libraries +getPackageUrlGhcLibs :: Version -> PackageIdentifier -> String +getPackageUrlGhcLibs ghcVersion (PackageIdentifier (PackageName name) version) = + "http://www.haskell.org/ghc/docs/" ++ showVersion ghcVersion ++ "/html/libraries/" ++ name ++ "-" ++ showVersion version ++ "/" ++ name ++ ".txt" + +-- | Downloads the information for the entire Hackage database +-- and saves it to the specified location. +saveHackageDatabase :: FilePath -> IO () +saveHackageDatabase file = withTemporaryDirectory (saveHackageDatabaseWithTmp file) + +saveHackageDatabaseWithTmp :: FilePath -> FilePath -> IO () +saveHackageDatabaseWithTmp file tmp = do (db, _) <- createHackageDatabase tmp + mapM_ (\pkg -> withSqliteConn (T.pack file) (runSqlConn (savePackageToDb pkg))) db + +-- | Downloads the information for the entire Hackage database +-- creating an in-memory database with it. +-- It needs a temporary directory to work on. +createHackageDatabase :: FilePath -> IO ([Documented Package], [(FilePath, ParseError)]) +createHackageDatabase tmp = + do let hoogleDbDir = tmp "hoogle-db" + tmpDir = tmp "tmp-db" + -- Parse Hoogle database + createDirectoryIfMissing True hoogleDbDir + logToStdout "Started downloading Hoogle database" + Just 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 + --let (pkgs, errors) = ([], []) + {- + -- Parse base package + Just baseDownloaded <- downloadFileStrict baseDbUrl + logToStdout "Base database successfully downloaded" + -- Parse ghc package + Just ghcDownloaded <- downloadFileStrict ghcDbUrl + logToStdout "GHC database successfully downloaded" + let (dbBase, errorsBase) = case parseHoogleString "base.txt" baseDownloaded of + Right b -> (b:pkgs, errors) + Left e -> (pkgs, ("base.txt", e):errors) + let (dbGhc, errorsGhc) = case parseHoogleString "ghc.txt" ghcDownloaded of + Right b -> (b:dbBase, errorsBase) + Left e -> (dbBase, ("ghc.txt", e):errorsBase) + return (pkgListToDb dbGhc, errorsGhc) + -} + return (pkgs, errors) + +-- | Updates a database with changes in the installed package base. +updateDatabase :: FilePath -> [InstalledPackageInfo] -> IO () +updateDatabase file pkgInfo = withSqliteConn (T.pack file) $ runSqlConn $ updateDatabase' pkgInfo + +updateDatabase' :: [InstalledPackageInfo] -> SqlPersist IO () +updateDatabase' pkgInfo = + do dbPersistent <- selectList ([] :: [Filter DbPackage]) [] + let dbList = map (fromDbToPackageIdentifier . snd) dbPersistent + installedList = nub $ removeSmallVersions $ map sourcePackageId pkgInfo + toRemove = dbList \\ installedList + toAdd = installedList \\ dbList + liftIO $ logToStdout $ "Removing " ++ show (map (\(PackageIdentifier (PackageName name) _) -> name) toRemove) + mapM_ deletePackageByInfo toRemove + liftIO $ logToStdout $ "Adding " ++ show (map (\(PackageIdentifier (PackageName name) _) -> name) toAdd) + let ghcVersion = getGhcInstalledVersion installedList + (addedDb, errors) <- liftIO $ createCabalDatabase' ghcVersion toAdd True + mapM_ savePackageToDb addedDb + liftIO $ logToStdout $ show errors + +fromDbToPackageIdentifier :: DbPackage -> PackageIdentifier +fromDbToPackageIdentifier (DbPackage name version _) = PackageIdentifier (PackageName name) + (getVersion version) +getVersion :: String -> Version +getVersion version = (fst . last . readP_to_S parseVersion) version + +removeSmallVersions :: [PackageIdentifier] -> [PackageIdentifier] +removeSmallVersions pids = filter + (not . (\(PackageIdentifier name version) -> + any (\(PackageIdentifier name' version') -> name' == name && version' > version) pids)) + pids + +-- | Get the database from a set of Cabal packages. +createCabalDatabase :: Version -> [PackageIdentifier] -> IO ([Documented Package], [(String, ParseError)]) +createCabalDatabase ghcVersion pkgs = createCabalDatabase' ghcVersion pkgs False + +-- | Get the database from a set of Cabal packages. +-- If `ifFailCreateEmpty' is set, when a package gives a parse error, +-- it is converted into an empty package with a note. +createCabalDatabase' :: Version -> [PackageIdentifier] -> Bool -> IO ([Documented Package], [(String, ParseError)]) +createCabalDatabase' ghcVersion pkgs ifFailCreateEmpty = + withTemporaryDirectory $ \tmp -> + do let toExecute = map (\pid -> do db <- getCabalHoogle ghcVersion pid ifFailCreateEmpty tmp + return (pkgString pid, db)) + pkgs + eitherHooglePkgs <- withThreaded $ \pool -> parallelInterleavedE pool toExecute + let hooglePkgs = rights eitherHooglePkgs + (db, errors) = partitionPackages hooglePkgs + return (db, errors) + +-- | Get the database from a Cabal package. +getCabalHoogle :: Version -> PackageIdentifier -> Bool -> FilePath -> IO (Either ParseError (Documented Package)) +getCabalHoogle ghcVersion pid ifFailCreateEmpty tmp = + E.catch (do result <- getCabalHoogle' ghcVersion pid tmp + case result of + Left e -> return $ failure e + Right (Package doc _ info) -> return $ Right (Package doc pid info)) + (\(e :: E.SomeException) -> return $ failure (newErrorMessage (Message "error parsing") + (newPos "" 0 0))) + where failure e = if ifFailCreateEmpty + then Right (Package NoDoc pid M.empty) + else Left e + +-- | Get the database from a Cabal package. +getCabalHoogle' :: Version -> PackageIdentifier -> FilePath -> IO (Either ParseError (Documented Package)) +getCabalHoogle' ghcVersion pid tmp = do let downUrl1 = getPackageUrlHackage pid + logToStdout $ "Download " ++ downUrl1 + tryDownload1 <- downloadHoogleFile downUrl1 + case tryDownload1 of + Nothing -> do let downUrl2 = getPackageUrlGhcLibs ghcVersion pid + logToStdout $ "Download " ++ downUrl2 + tryDownload2 <- downloadHoogleFile downUrl2 + case tryDownload2 of + Nothing -> getCabalHoogleLocal pid tmp + Just cnts -> return $ parseHoogleString "" cnts + Just cnts -> return $ parseHoogleString "" cnts + +-- | Get the database from a locally installed Cabal package. +getCabalHoogleLocal :: PackageIdentifier -> FilePath -> IO (Either ParseError (Documented Package)) +getCabalHoogleLocal pid tmp = + do let pkgV = pkgString pid + (PackageName pkg) = pkgName pid + logToStdout $ "Parsing " ++ pkgV + code <- executeCommand tmp "cabal" ["unpack", pkgV] True + case code of + ExitFailure _ -> return $ Left (newErrorMessage (Message "package not found") + (newPos pkgV 0 0)) + ExitSuccess -> + do let pkgdir = tmp pkgV + withWorkingDirectory pkgdir $ + do executeCommand pkgdir "cabal" ["configure"] True + executeCommand pkgdir "cabal" ["haddock", "--hoogle"] True + let hoogleFile = pkgdir "dist" "doc" "html" pkg (pkg ++ ".txt") + parseHoogleFile hoogleFile + +pkgString :: PackageIdentifier -> String +pkgString (PackageIdentifier (PackageName name) version) = name ++ "-" ++ showVersion version + diff --git a/src/Scion/PersistentBrowser/DbTypes.hs b/src/Scion/PersistentBrowser/DbTypes.hs --- a/src/Scion/PersistentBrowser/DbTypes.hs +++ b/src/Scion/PersistentBrowser/DbTypes.hs @@ -1,59 +1,59 @@ -{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls #-} - -module Scion.PersistentBrowser.DbTypes where - -import Database.Persist -import Database.Persist.Base -import Database.Persist.Sqlite -import Database.Persist.TH - -data DbDeclType = DbData | DbNewType | DbClass | DbInstance | DbSignature | DbType - deriving (Show, Read, Eq) -derivePersistField "DbDeclType" - -share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persist| -DbPackage - name String - version String - doc String Maybe -DbModule - name String - doc String Maybe - packageId DbPackageId -DbDecl - declType DbDeclType - name String - doc String Maybe - -- Depending on the type of decl, - -- it will have some of these - kind String Maybe - signature String Maybe - equals String Maybe - moduleId DbModuleId -DbTyVar - name String - declId DbDeclId -DbFunDep - name String - declId DbDeclId -DbContext - shown String - declId DbDeclId -DbConstructor - name String - -- Called 'type' in Json output - signature String - declId DbDeclId -|] - --- |Information needed to search a package. -data DbPackageIdentifier = DbPackageIdentifier String String -- name, version - deriving Eq - -dbPackageToIdentifier :: DbPackage -> DbPackageIdentifier -dbPackageToIdentifier (DbPackage name version _) = DbPackageIdentifier name version - --- |Complete information for a declaration. --- Look at its ToJSON instance to know which one is used in each kind of declaration. -data DbCompleteDecl = DbCompleteDecl DbDecl [DbContext] [DbTyVar] [DbFunDep] [DbConstructor] - +{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls #-} + +module Scion.PersistentBrowser.DbTypes where + +import Database.Persist +import Database.Persist.Base +import Database.Persist.Sqlite +import Database.Persist.TH + +data DbDeclType = DbData | DbNewType | DbClass | DbInstance | DbSignature | DbType + deriving (Show, Read, Eq) +derivePersistField "DbDeclType" + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persist| +DbPackage + name String + version String + doc String Maybe +DbModule + name String + doc String Maybe + packageId DbPackageId +DbDecl + declType DbDeclType + name String + doc String Maybe + -- Depending on the type of decl, + -- it will have some of these + kind String Maybe + signature String Maybe + equals String Maybe + moduleId DbModuleId +DbTyVar + name String + declId DbDeclId +DbFunDep + name String + declId DbDeclId +DbContext + shown String + declId DbDeclId +DbConstructor + name String + -- Called 'type' in Json output + signature String + declId DbDeclId +|] + +-- |Information needed to search a package. +data DbPackageIdentifier = DbPackageIdentifier String String -- name, version + deriving Eq + +dbPackageToIdentifier :: DbPackage -> DbPackageIdentifier +dbPackageToIdentifier (DbPackage name version _) = DbPackageIdentifier name version + +-- |Complete information for a declaration. +-- Look at its ToJSON instance to know which one is used in each kind of declaration. +data DbCompleteDecl = DbCompleteDecl DbDecl [DbContext] [DbTyVar] [DbFunDep] [DbConstructor] + diff --git a/src/Scion/PersistentBrowser/FileUtil.hs b/src/Scion/PersistentBrowser/FileUtil.hs --- a/src/Scion/PersistentBrowser/FileUtil.hs +++ b/src/Scion/PersistentBrowser/FileUtil.hs @@ -1,93 +1,93 @@ -{-# 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 - if "-- Hoogle documentation" `isPrefixOf` response - then return $ Just (SBS8.pack response) - else return 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 + if "-- Hoogle documentation" `isPrefixOf` response + then return $ Just (SBS8.pack response) + else return 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 + diff --git a/src/Scion/PersistentBrowser/FromMissingH.hs b/src/Scion/PersistentBrowser/FromMissingH.hs --- a/src/Scion/PersistentBrowser/FromMissingH.hs +++ b/src/Scion/PersistentBrowser/FromMissingH.hs @@ -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) + diff --git a/src/Scion/PersistentBrowser/Instances/Json.hs b/src/Scion/PersistentBrowser/Instances/Json.hs --- a/src/Scion/PersistentBrowser/Instances/Json.hs +++ b/src/Scion/PersistentBrowser/Instances/Json.hs @@ -1,100 +1,100 @@ -{-# LANGUAGE OverloadedStrings, TypeSynonymInstances #-} - -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 #-} + +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 + ] + diff --git a/src/Scion/PersistentBrowser/Parser.hs b/src/Scion/PersistentBrowser/Parser.hs --- a/src/Scion/PersistentBrowser/Parser.hs +++ b/src/Scion/PersistentBrowser/Parser.hs @@ -1,83 +1,83 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module Scion.PersistentBrowser.Parser -( parseHoogleString -, parseHoogleFile -, parseDirectory -) where - -import Control.Concurrent.ParallelIO.Local -import Control.Monad -import qualified Data.ByteString as BS -import qualified Data.ByteString.UTF8 as BSU -import Data.Either (rights) -import Scion.PersistentBrowser.Types -import Scion.PersistentBrowser.Parser.Internal (hoogleParser) -import Scion.PersistentBrowser.FileUtil -import Scion.PersistentBrowser.Util -import System.Directory -import System.FilePath ((), takeFileName) -import System.IO -import Text.Parsec.Error (Message(..), newErrorMessage) -import Text.Parsec.Prim (runP) --- import Text.Parsec.ByteString as BS -import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Pos (newPos) - --- | Parses the contents of a string containing the --- Hoogle file contents. -parseHoogleString :: String -> BS.ByteString -> Either ParseError (Documented Package) -parseHoogleString name contents = runP hoogleParser () name (BSU.toString contents) - --- | Parses a file in Hoogle documentation format, returning --- the documentation of the entire package, or the corresponding --- error during the parsing. -parseHoogleFile :: FilePath -> IO (Either ParseError (Documented Package)) -parseHoogleFile fname = (withFile fname ReadMode $ - \hnd -> do c <- BS.hGetContents hnd - return $ parseHoogleString fname c - ) - `catch` - (\_ -> return $ Left (newErrorMessage (Message "error reading file") - (newPos fname 0 0))) - --- | Parses a entire directory of Hoogle documentation files --- which must be following the format of the Hackage --- Hoogle library, specifically: --- --- --- / package-name --- / version --- /doc/html/package-name.txt --- -parseDirectory :: FilePath -> FilePath -> IO ([Documented Package], [(FilePath, ParseError)]) -parseDirectory dir tmpdir = - do contents' <- getDirectoryContents dir - let contents = map (\d -> dir d) (filterDots contents') - dirs <- filterM doesDirectoryExist contents - vDirs <- mapM getVersionDirectory dirs - let innerDirs = map (\d -> d "doc" "html") (concat vDirs) - -- Parse directories recursively - let toExecute = map (\innerDir -> parseDirectoryFiles innerDir tmpdir) innerDirs - eitherDPackages <- withThreaded $ \pool -> parallelInterleavedE pool toExecute - let dPackages = rights eitherDPackages - dbs = concat $ map fst dPackages - errors = concat $ map snd dPackages - return (dbs, errors) - -getVersionDirectory :: FilePath -> IO [FilePath] -getVersionDirectory dir = do contents' <- getDirectoryContents dir - let contents = map (\d -> dir d) (filterDots contents') - filterM doesDirectoryExist contents - -parseDirectoryFiles :: FilePath -> FilePath -> IO ([Documented Package], [(FilePath, ParseError)]) -parseDirectoryFiles dir tmpdir = - do contents' <- getDirectoryContents dir - let contents = map (\d -> dir d) (filterDots contents') - files <- filterM doesFileExist contents - fPackages <- mapM (\fname -> do hPutChar stderr '.' >> hFlush stderr - p <- parseHoogleFile fname - return (fname, p) ) - files - return $ partitionPackages fPackages - +{-# LANGUAGE ScopedTypeVariables #-} + +module Scion.PersistentBrowser.Parser +( parseHoogleString +, parseHoogleFile +, parseDirectory +) where + +import Control.Concurrent.ParallelIO.Local +import Control.Monad +import qualified Data.ByteString as BS +import qualified Data.ByteString.UTF8 as BSU +import Data.Either (rights) +import Scion.PersistentBrowser.Types +import Scion.PersistentBrowser.Parser.Internal (hoogleParser) +import Scion.PersistentBrowser.FileUtil +import Scion.PersistentBrowser.Util +import System.Directory +import System.FilePath ((), takeFileName) +import System.IO +import Text.Parsec.Error (Message(..), newErrorMessage) +import Text.Parsec.Prim (runP) +-- import Text.Parsec.ByteString as BS +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Pos (newPos) + +-- | Parses the contents of a string containing the +-- Hoogle file contents. +parseHoogleString :: String -> BS.ByteString -> Either ParseError (Documented Package) +parseHoogleString name contents = runP hoogleParser () name (BSU.toString contents) + +-- | Parses a file in Hoogle documentation format, returning +-- the documentation of the entire package, or the corresponding +-- error during the parsing. +parseHoogleFile :: FilePath -> IO (Either ParseError (Documented Package)) +parseHoogleFile fname = (withFile fname ReadMode $ + \hnd -> do c <- BS.hGetContents hnd + return $ parseHoogleString fname c + ) + `catch` + (\_ -> return $ Left (newErrorMessage (Message "error reading file") + (newPos fname 0 0))) + +-- | Parses a entire directory of Hoogle documentation files +-- which must be following the format of the Hackage +-- Hoogle library, specifically: +-- +-- +-- / package-name +-- / version +-- /doc/html/package-name.txt +-- +parseDirectory :: FilePath -> FilePath -> IO ([Documented Package], [(FilePath, ParseError)]) +parseDirectory dir tmpdir = + do contents' <- getDirectoryContents dir + let contents = map (\d -> dir d) (filterDots contents') + dirs <- filterM doesDirectoryExist contents + vDirs <- mapM getVersionDirectory dirs + let innerDirs = map (\d -> d "doc" "html") (concat vDirs) + -- Parse directories recursively + let toExecute = map (\innerDir -> parseDirectoryFiles innerDir tmpdir) innerDirs + eitherDPackages <- withThreaded $ \pool -> parallelInterleavedE pool toExecute + let dPackages = rights eitherDPackages + dbs = concat $ map fst dPackages + errors = concat $ map snd dPackages + return (dbs, errors) + +getVersionDirectory :: FilePath -> IO [FilePath] +getVersionDirectory dir = do contents' <- getDirectoryContents dir + let contents = map (\d -> dir d) (filterDots contents') + filterM doesDirectoryExist contents + +parseDirectoryFiles :: FilePath -> FilePath -> IO ([Documented Package], [(FilePath, ParseError)]) +parseDirectoryFiles dir tmpdir = + do contents' <- getDirectoryContents dir + let contents = map (\d -> dir d) (filterDots contents') + files <- filterM doesFileExist contents + fPackages <- mapM (\fname -> do hPutChar stderr '.' >> hFlush stderr + p <- parseHoogleFile fname + return (fname, p) ) + files + return $ partitionPackages fPackages + diff --git a/src/Scion/PersistentBrowser/Parser/Documentable.hs b/src/Scion/PersistentBrowser/Parser/Documentable.hs --- a/src/Scion/PersistentBrowser/Parser/Documentable.hs +++ b/src/Scion/PersistentBrowser/Parser/Documentable.hs @@ -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 + diff --git a/src/Scion/PersistentBrowser/Parser/Internal.hs b/src/Scion/PersistentBrowser/Parser/Internal.hs --- a/src/Scion/PersistentBrowser/Parser/Internal.hs +++ b/src/Scion/PersistentBrowser/Parser/Internal.hs @@ -1,544 +1,544 @@ -{-# LANGUAGE RankNTypes #-} -module Scion.PersistentBrowser.Parser.Internal where - --- import Debug.Trace (trace) -import Control.Monad -import Data.Char (isControl, isLatin1, isUpper, ord) -import Data.List (intercalate) -import qualified Data.Map as M -import Distribution.Package (PackageIdentifier(..), PackageName(..)) -import Distribution.Version -import Language.Haskell.Exts.Annotated.Syntax -import Language.Haskell.Exts.Extension -import qualified Language.Haskell.Exts.Parser as Parser -import Scion.PersistentBrowser.Types -import Scion.PersistentBrowser.FromMissingH (replace) -import Scion.PersistentBrowser.Parser.Documentable -import Text.Parsec.String as BS -import Text.Parsec.Char -import Text.Parsec.Combinator -import Text.Parsec.Prim - -type BSParser a = forall st. BS.GenParser Char st a - -hoogleParser :: BSParser (Documented Package) -hoogleParser = do spaces - many initialComment - spaces - pkgDoc <- docComment - spacesOrEol1 - pkgN <- package - spacesOrEol1 - pkgV <- version - spaces0 - modules <- many $ try (spacesOrEol0 >> documented module_) - spaces - eof - return $ Package (docFromString pkgDoc) - (PackageIdentifier (PackageName pkgN) - pkgV) - (M.fromList $ map (\m -> (getModuleName m, m)) modules) - -initialComment :: BSParser String -initialComment = do try $ string "-- " >> notFollowedBy (char '|') - restOfLine - eol - -docComment :: BSParser String -docComment = do string "-- | " - initialLine <- restOfLine - restOfLines <- many $ try (eol >> string "-- ") >> restOfLine - return $ intercalate "\n" (initialLine:restOfLines) - -documented :: (Doc -> BSParser a) -> BSParser a -documented p = try (do d <- try docComment - try eol - p (docFromString d)) - <|> try (p NoDoc) - -package :: BSParser String -package = do string "@package" - spaces1 - name <- restOfLine - spaces0 - return name - -version :: BSParser Version -version = try (do string "@version" - spaces1 - numbers <- number `sepBy` char '.' - restOfLine - return $ Version numbers []) - <|> (return $ Version [] []) - -module_ :: Doc -> BSParser (Documented Module) -module_ doc = do string "module" - spaces1 - name <- moduleName - spaces0 - decls <- many $ try (spacesOrEol0 >> documented decl) - return $ Module doc - (Just (ModuleHead NoDoc name Nothing Nothing)) - [] - [] - (concat decls) - -moduleName :: BSParser (Documented ModuleName) -moduleName = do cons <- conid `sepBy` char '.' - let name = intercalate "." (map getid cons) - return $ ModuleName NoDoc name - -getModuleName :: Documented Module -> String -getModuleName (Module _ (Just (ModuleHead _ (ModuleName _ name) _ _)) _ _ _) = name -getModuleName _ = error "This should never happen" - -decl :: Doc -> BSParser [Documented Decl] -decl doc = choice [ listed $ function doc - , listed $ instance_ doc - , listed $ class_ doc - , listed $ type_ doc - , listedPair $ data_ doc - , listedPair $ newtype_ doc - , lonelyComment - ] - -listed :: BSParser a -> BSParser [a] -listed p = do result <- try p - return [result] - -listedPair :: BSParser (a, [a]) -> BSParser [a] -listedPair p = do (h, t) <- p - return (h:t) - -lonelyComment :: BSParser [Documented Decl] -lonelyComment = try (docComment >> return []) - -parseTypeMode :: Parser.ParseMode -parseTypeMode = Parser.ParseMode "" knownExtensions False False Nothing - -parseType :: String -> BSParser (Documented Type) -parseType st = return (parseType' st) - -parseType' :: String -> Documented Type -parseType' st = let parseString = eliminateUnwanted st - nonAsciiChars = filter (not . isLatin1) parseString - noHashString = (theReplacements . generateLatinReplacements nonAsciiChars) parseString - -- Parse using haskell-src-exts - parsed = Parser.parseTypeWithMode parseTypeMode noHashString - in case parsed of - Parser.ParseFailed _ _ -> TyVar NoDoc (Ident NoDoc "not parsed") - Parser.ParseOk ty -> mapOnNames (theInverseReplacements . generateInverseLatinReplacements nonAsciiChars) (document NoDoc ty) - -theReplacements :: String -> String -theReplacements = (replace "#" "__HASH__") . (replace "[:" "__GHC_ARR_OPEN__") . (replace ":]" "__GHC_ARR_CLOSE__") . (replace "!" "BANG__") - -theInverseReplacements :: String -> String -theInverseReplacements = (replace "__HASH__" "#") . (replace "__GHC_ARR_OPEN__" "[:") . (replace "__GHC_ARR_CLOSE__" ":]") . (replace "BANG__" "!") - -generateLatinReplacements :: [Char] -> (String -> String) -generateLatinReplacements [] = id -generateLatinReplacements (c:cs) | isUpper c = (replace [c] ("UNICODE_SYMBOL_" ++ (show $ ord c) ++ "__")) . (generateLatinReplacements cs) - | otherwise = (replace [c] ("unicode_symbol_" ++ (show $ ord c) ++ "__")) . (generateLatinReplacements cs) - -generateInverseLatinReplacements :: [Char] -> (String -> String) -generateInverseLatinReplacements [] = id -generateInverseLatinReplacements (c:cs) | isUpper c = (replace ("UNICODE_SYMBOL_" ++ (show $ ord c) ++ "__") [c]) . (generateInverseLatinReplacements cs) - | otherwise = (replace ("unicode_symbol_" ++ (show $ ord c) ++ "__") [c]) . (generateInverseLatinReplacements cs) - --- HACK: Types with ! are not parsed by haskell-src-exts --- HACK: Control characters (like EOF) may appear --- HACK: {-# UNPACK #-} comments and greek letters may appear --- HACK: Greek letters may appear -eliminateUnwanted :: String -> String -eliminateUnwanted "" = "" -eliminateUnwanted ('{':('-':('#':(' ':('U':('N':('P':('A':('C':('K':(' ':('#':('-':('}': xs)))))))))))))) = eliminateUnwanted xs -eliminateUnwanted (x:xs) | isControl x = eliminateUnwanted xs - | otherwise = x : (eliminateUnwanted xs) - -mapOnNames :: (String -> String) -> Documented Type -> Documented Type -mapOnNames f (TyForall doc vars context ty) = TyForall doc - (fmap (fmap (mapOnNamesTyVar f)) vars) - (fmap (mapOnNamesContext f) context) - (mapOnNames f ty) -mapOnNames f (TyFun doc t1 t2) = TyFun doc (mapOnNames f t1) (mapOnNames f t2) -mapOnNames f (TyTuple doc boxed tys) = TyTuple doc boxed (fmap (mapOnNames f) tys) -mapOnNames f (TyList doc ty) = TyList doc (mapOnNames f ty) -mapOnNames f (TyApp doc t1 t2) = TyApp doc (mapOnNames f t1) (mapOnNames f t2) -mapOnNames f (TyVar doc name) = TyVar doc (mapOnNamesName f name) -mapOnNames f (TyCon doc name) = TyCon doc (mapOnNamesQName f name) -mapOnNames f (TyParen doc ty) = TyParen doc (mapOnNames f ty) -mapOnNames f (TyInfix doc t1 name t2) = TyInfix doc (mapOnNames f t1) (mapOnNamesQName f name) (mapOnNames f t2) -mapOnNames f (TyKind doc ty k) = TyKind doc (mapOnNames f ty) k - -mapOnNamesTyVar :: (String -> String) -> Documented TyVarBind -> Documented TyVarBind -mapOnNamesTyVar f (KindedVar doc name k) = KindedVar doc (mapOnNamesName f name) k -mapOnNamesTyVar f (UnkindedVar doc name) = UnkindedVar doc (mapOnNamesName f name) - -mapOnNamesName :: (String -> String) -> Documented Name -> Documented Name -mapOnNamesName f (Ident doc s) = Ident doc (f s) -mapOnNamesName f (Symbol doc s) = Symbol doc (f s) - -mapOnNamesQName :: (String -> String) -> Documented QName -> Documented QName -mapOnNamesQName f (Qual doc mname name) = Qual doc mname (mapOnNamesName f name) -mapOnNamesQName f (UnQual doc name) = UnQual doc (mapOnNamesName f name) -mapOnNamesQName _ q@(Special _ _) = q - -mapOnNamesContext :: (String -> String) -> Documented Context -> Documented Context -mapOnNamesContext f (CxSingle doc asst) = CxSingle doc (mapOnNamesAsst f asst) -mapOnNamesContext f (CxTuple doc assts) = CxTuple doc (fmap (mapOnNamesAsst f) assts) -mapOnNamesContext f (CxParen doc ctx) = CxParen doc (mapOnNamesContext f ctx) -mapOnNamesContext _ (CxEmpty doc) = CxEmpty doc - -mapOnNamesAsst :: (String -> String) -> Documented Asst -> Documented Asst -mapOnNamesAsst f (ClassA doc name tys) = ClassA doc (mapOnNamesQName f name) (fmap (mapOnNames f) tys) -mapOnNamesAsst f (InfixA doc ty1 name ty2) = InfixA doc (mapOnNames f ty1) (mapOnNamesQName f name) (mapOnNames f ty2) -mapOnNamesAsst f (IParam doc name ty) = IParam doc (mapOnNamesIPName f name) (mapOnNames f ty) -mapOnNamesAsst f (EqualP doc ty1 ty2) = EqualP doc (mapOnNames f ty1) (mapOnNames f ty2) - -mapOnNamesIPName :: (String -> String) -> Documented IPName -> Documented IPName -mapOnNamesIPName f (IPDup doc s) = IPDup doc (f s) -mapOnNamesIPName f (IPLin doc s) = IPLin doc (f s) - -multipleNames :: BSParser (Documented Name) ->BSParser [Documented Name] -multipleNames p=sepBy1 p (try $ do - spaces0 - char ',' - spaces0) - -functionLike :: BSParser (Documented Name) -> BSParser ([Documented Name], Documented Type) -functionLike p = do names <- choice [ - (try $ do - char '(' - ns<-multipleNames p - char ')' - return ns), - (multipleNames p) - ] - spaces0 - string "::" - spaces0 - rest <- restOfLine - ty <- parseType rest - return (names, ty) - -function :: Doc -> BSParser (Documented Decl) -function doc = do (names, ty) <- functionLike varid - return $ TypeSig doc names ty - -constructor :: Doc -> BSParser (Documented GadtDecl) -constructor doc = do (names, ty) <- functionLike conid - return $ GadtDecl doc (head names) ty - -constructorOrFunction :: Doc -> BSParser (Either (Documented Decl) (Documented GadtDecl)) -constructorOrFunction doc = do f <- function doc - return $ Left f - <|> - do c <- constructor doc - return $ Right c - -kind :: BSParser (Documented Kind) -kind = try (do k1 <- kindL - spaces0 - string "->" - spaces0 - k2 <- kind - return $ KindFn NoDoc k1 k2) - <|> kindL - -kindL :: BSParser (Documented Kind) -kindL = (do char '(' - spaces0 - k <- kind - spaces0 - char ')' - return $ KindParen NoDoc k) - <|> - (do char '*' - return $ KindStar NoDoc) - <|> - (do char '!' - return $ KindBang NoDoc) - <|> - (do n <- varid - return $ KindVar NoDoc n) - -instance_ :: Doc -> BSParser (Documented Decl) -instance_ doc = do string "instance" - -- HACK: in some Hoogle files things like [overlap ok] appear - optional $ try (do spaces0 - char '[' - many $ noneOf "]\r\n" - char ']') - spaces1 - rest <- restOfLine - ty' <- parseType rest - let (ctx, ty) = getContextAndType ty' - (qhead:params) = lineariseType ty - case qhead of - TyCon _ qname -> return $ InstDecl doc ctx (IHead NoDoc qname params) Nothing - _ -> return $ InstDecl doc ctx (IHead NoDoc (UnQual NoDoc (Ident NoDoc "#unparsed#")) params) Nothing - -type_ :: Doc -> BSParser (Documented Decl) -type_ doc = do string "type" - spaces1 - con <- conid - vars <- many (try (spaces1 >> tyVarBind)) - spaces0 - char '=' - spaces0 - rest <- restOfLine - ty <- parseType rest - return $ TypeDecl doc (DHead NoDoc con vars) ty - -tyVarBind :: BSParser (Documented TyVarBind) -tyVarBind = (do char '(' - spaces0 - var <- varid - spaces0 - string "::" - spaces0 - k <- kind - spaces0 - char ')' - return $ KindedVar NoDoc var k) - <|> - (do var <- varid - return $ UnkindedVar NoDoc var) - --- Here we return not only the datatype or newtype, --- but also functions around them, that are put --- between constructors when using record syntax. -dataOrNewType :: String -> (Documented DataOrNew) -> Doc -> BSParser (Documented Decl, [Documented Decl]) -dataOrNewType keyword dOrN doc = do string keyword - spaces0 - rests <- many1 possibleKind - let rest = concat $ map fst rests - k = snd (last rests) - {- rest <- many $ allButDoubleColon - k <- optionMaybe (do string "::" - spaces0 - kind) -} - ty <- parseType rest - let (ctx, hd) = typeToContextAndHead ty - consAndFns <- many $ try (spacesOrEol0 >> documented constructorOrFunction) - let (fns, cons) = divideConstructorAndFunctions consAndFns - return $ (GDataDecl doc dOrN ctx hd k cons Nothing, fns) - -divideConstructorAndFunctions :: [Either (Documented Decl) (Documented GadtDecl)] -> ([Documented Decl], [Documented GadtDecl]) -divideConstructorAndFunctions [] = ([], []) -divideConstructorAndFunctions (x:xs) = let (fns, cons) = divideConstructorAndFunctions xs - in case x of - Left fn -> (fn:fns, cons) - Right con -> (fns, con:cons) - -possibleKind :: BSParser (String, Maybe (Documented Kind)) -possibleKind = do rest <- many1 $ allButDoubleColon - k <- optionMaybe (do string "::" - spaces0 - kind) - return (rest, k) - -allButDoubleColon :: BSParser Char -allButDoubleColon = try (do char ':' - notFollowedBy $ char ':' - return ':') - <|> (noneOf ":\r\n") - -data_ :: Doc -> BSParser (Documented Decl, [Documented Decl]) -data_ = dataOrNewType "data" (DataType NoDoc) - -newtype_ :: Doc -> BSParser (Documented Decl, [Documented Decl]) -newtype_ = dataOrNewType "newtype" (NewType NoDoc) - -dataOrNewTypeHead :: String -> (Documented DataOrNew) -> Doc -> BSParser (Documented Decl) -dataOrNewTypeHead keyword dOrN doc = do string keyword - spaces0 - rests <- many1 possibleKind - let rest = concat $ map fst rests - k = snd (last rests) - {- rest <- many $ allButDoubleColon - k <- optionMaybe (do string "::" - spaces0 - kind) -} - ty <- parseType rest - let (ctx, hd) = typeToContextAndHead ty - return $ GDataDecl doc dOrN ctx hd k [] Nothing - -dataHead :: Doc -> BSParser (Documented Decl) -dataHead = dataOrNewTypeHead "data" (DataType NoDoc) - -newtypeHead :: Doc -> BSParser (Documented Decl) -newtypeHead = dataOrNewTypeHead "newtype" (NewType NoDoc) - -class_ :: Doc -> BSParser (Documented Decl) -class_ doc = do string "class" - spaces0 - rest <- many $ allButWhereColonPipe - fd' <- optionMaybe (do string "|" - spaces0 - iFunDep <- funDep - rFunDep <- many $ try (spaces0 >> char ',' >> spaces0 >> funDep) - return $ iFunDep:rFunDep) - -- HACK: if a type family is introduced here, just discard it - optional $ string "where" >> restOfLine - -- HACK: in some Hoogle files, kinds are added to the class - optional $ string "::" >> restOfLine - ty <- parseType rest - let (ctx, hd) = typeToContextAndHead ty - fd = maybe [] id fd' - return $ ClassDecl doc ctx hd fd Nothing - -allButWhereColonPipe :: BSParser Char -allButWhereColonPipe = try (do char ':' - notFollowedBy $ char ':' - return ':') - <|> - try (do char 'w' - notFollowedBy $ string "here" - return 'w') - <|> (noneOf "w|:\r\n") - -funDep :: BSParser (Documented FunDep) -funDep = do iVarLeft <- varid - rVarLeft <- many $ try (spaces1 >> varid) - spaces0 - string "->" - spaces0 - iVarRight <- varid - rVarRight <- many $ try (spaces1 >> varid) - return $ FunDep NoDoc (iVarLeft:rVarLeft) (iVarRight:rVarRight) - -{- -qualifiedVarid :: BSParser [String] -qualifiedVarid = do id <- varid - return [id] - <|> do mod <- many1 (do m <- conid - char '.' - return m) - id <- varid - return $ mod ++ [id] - -qualifiedConid :: BSParser [String] -qualifiedConid = conid `sepBy` char '.' --} - -varid :: BSParser (Documented Name) -varid = try (do initial <- lower <|> char '_' - rest <- many $ alphaNum <|> oneOf allowedSpecialCharactersInIds - let var = initial:rest - guard $ not (var `elem` haskellKeywords) - return $ Ident NoDoc var) - <|> --- try (do --initial <- oneOf (tail specialCharacters) --- var <- many1 (oneOf specialCharacters) --- --let var = initial:rest --- guard $ not (var `elem` haskellReservedOps) --- return $ Symbol NoDoc var) --- <|> - try (do string "()" - return $ Symbol NoDoc "()") - <|> - try (do char '(' - s<-many1 (char ',') - char ')' - return $ Symbol NoDoc s) - <|> - try (do char '(' - var <- varid - char ')' - return var) - <|> - try (do var <- many1 (noneOf [',',')','(',' ','\r','\n','\t']) - guard $ not (isUpper $ head var) - guard $ not (var `elem` haskellReservedOps) - return $ Symbol NoDoc var) - - -conid :: BSParser (Documented Name) -conid = (do initial <- upper - rest <- many $ alphaNum <|> oneOf allowedSpecialCharactersInIds - return $ Ident NoDoc (initial:rest)) - <|> - try (do initial <- char ':' - rest <- many (oneOf specialCharacters) - let con = initial:rest - guard $ not (con `elem` haskellReservedOps) - return $ Symbol NoDoc con) - <|> - try (do char '(' - con <- conid - char ')' - return con) - -getid :: Documented Name -> String -getid (Ident _ s) = s -getid (Symbol _ s) = '(' : (s ++ ")" ) - -haskellKeywords :: [String] -haskellKeywords = [ "case", "class", "data", "default", "deriving", "do" - , "else", "foreign", "if", "import", "in", "infix", "infixl" - , "infixr", "instance", "let", "module", "newtype", "of" - , "then", "type", "where", "_" ] - -haskellReservedOps :: [String] -haskellReservedOps = [ "..", ":", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>" ] - -allowedSpecialCharactersInIds :: [Char] -allowedSpecialCharactersInIds = "_'-[]#" - -specialCharacters :: [Char] -specialCharacters = ":!#$%&*+./<=>?@\\^|-~" - -restOfLine :: BSParser String -restOfLine = many $ noneOf "\r\n" - -eol :: BSParser String -eol = try (string "\r\n") - <|> try (string "\r") - <|> string "\n" - -- <|> (lookAhead eof >> return "\n") - "new line" - -number :: BSParser Int -number = do n <- many1 digit - return $ read n - -spaces0 :: BSParser String -spaces0 = many $ char ' ' - -spaces1 :: BSParser String -spaces1 = many1 $ char ' ' - -spacesOrEol0 :: BSParser String -spacesOrEol0 = many $ oneOf " \r\n\t" - -spacesOrEol1 :: BSParser String -spacesOrEol1 = many1 $ oneOf " \r\n\t" - --- working with types - -getContextAndType :: (Documented Type) -> (Maybe (Documented Context), Documented Type) -getContextAndType (TyForall _ _ ctx ty) = (ctx, ty) -getContextAndType ty = (Nothing, ty) - -lineariseType :: Documented Type -> [Documented Type] -lineariseType (TyApp _ x y) = (lineariseType x) ++ [y] -lineariseType ty = [ty] - -typeToContextAndHead :: (Documented Type) -> (Maybe (Documented Context), Documented DeclHead) -typeToContextAndHead t = let (ctx, ty) = getContextAndType t - (name,vars) = case lineariseType ty of - ((TyCon _ (UnQual _ name')):params) -> (name', toKindedVars params) - ((TyCon _ (Qual _ _ name')):params) -> (name', toKindedVars params) - ((TyCon _ (Special l _)):params) -> (Symbol l "", toKindedVars params) - (_:params) -> (Ident NoDoc "#unparsed#", toKindedVars params) - [] -> error "This should never happen" - in (ctx, DHead NoDoc name vars) - -toKindedVars :: [Type Doc] -> [TyVarBind Doc] -toKindedVars [] = [] -toKindedVars ((TyVar d (Ident _ n1)):( (TyList _ (TyVar _ (Ident _ n2))): xs )) = - (UnkindedVar d (Ident NoDoc $ n1 ++ "[" ++ n2 ++ "]")) : toKindedVars xs -toKindedVars ((TyVar d n):xs) = (UnkindedVar d n) : toKindedVars xs -toKindedVars (x:_) = error $ show x - +{-# LANGUAGE RankNTypes #-} +module Scion.PersistentBrowser.Parser.Internal where + +-- import Debug.Trace (trace) +import Control.Monad +import Data.Char (isControl, isLatin1, isUpper, ord) +import Data.List (intercalate) +import qualified Data.Map as M +import Distribution.Package (PackageIdentifier(..), PackageName(..)) +import Distribution.Version +import Language.Haskell.Exts.Annotated.Syntax +import Language.Haskell.Exts.Extension +import qualified Language.Haskell.Exts.Parser as Parser +import Scion.PersistentBrowser.Types +import Scion.PersistentBrowser.FromMissingH (replace) +import Scion.PersistentBrowser.Parser.Documentable +import Text.Parsec.String as BS +import Text.Parsec.Char +import Text.Parsec.Combinator +import Text.Parsec.Prim + +type BSParser a = forall st. BS.GenParser Char st a + +hoogleParser :: BSParser (Documented Package) +hoogleParser = do spaces + many initialComment + spaces + pkgDoc <- docComment + spacesOrEol1 + pkgN <- package + spacesOrEol1 + pkgV <- version + spaces0 + modules <- many $ try (spacesOrEol0 >> documented module_) + spaces + eof + return $ Package (docFromString pkgDoc) + (PackageIdentifier (PackageName pkgN) + pkgV) + (M.fromList $ map (\m -> (getModuleName m, m)) modules) + +initialComment :: BSParser String +initialComment = do try $ string "-- " >> notFollowedBy (char '|') + restOfLine + eol + +docComment :: BSParser String +docComment = do string "-- | " + initialLine <- restOfLine + restOfLines <- many $ try (eol >> string "-- ") >> restOfLine + return $ intercalate "\n" (initialLine:restOfLines) + +documented :: (Doc -> BSParser a) -> BSParser a +documented p = try (do d <- try docComment + try eol + p (docFromString d)) + <|> try (p NoDoc) + +package :: BSParser String +package = do string "@package" + spaces1 + name <- restOfLine + spaces0 + return name + +version :: BSParser Version +version = try (do string "@version" + spaces1 + numbers <- number `sepBy` char '.' + restOfLine + return $ Version numbers []) + <|> (return $ Version [] []) + +module_ :: Doc -> BSParser (Documented Module) +module_ doc = do string "module" + spaces1 + name <- moduleName + spaces0 + decls <- many $ try (spacesOrEol0 >> documented decl) + return $ Module doc + (Just (ModuleHead NoDoc name Nothing Nothing)) + [] + [] + (concat decls) + +moduleName :: BSParser (Documented ModuleName) +moduleName = do cons <- conid `sepBy` char '.' + let name = intercalate "." (map getid cons) + return $ ModuleName NoDoc name + +getModuleName :: Documented Module -> String +getModuleName (Module _ (Just (ModuleHead _ (ModuleName _ name) _ _)) _ _ _) = name +getModuleName _ = error "This should never happen" + +decl :: Doc -> BSParser [Documented Decl] +decl doc = choice [ listed $ function doc + , listed $ instance_ doc + , listed $ class_ doc + , listed $ type_ doc + , listedPair $ data_ doc + , listedPair $ newtype_ doc + , lonelyComment + ] + +listed :: BSParser a -> BSParser [a] +listed p = do result <- try p + return [result] + +listedPair :: BSParser (a, [a]) -> BSParser [a] +listedPair p = do (h, t) <- p + return (h:t) + +lonelyComment :: BSParser [Documented Decl] +lonelyComment = try (docComment >> return []) + +parseTypeMode :: Parser.ParseMode +parseTypeMode = Parser.ParseMode "" knownExtensions False False Nothing + +parseType :: String -> BSParser (Documented Type) +parseType st = return (parseType' st) + +parseType' :: String -> Documented Type +parseType' st = let parseString = eliminateUnwanted st + nonAsciiChars = filter (not . isLatin1) parseString + noHashString = (theReplacements . generateLatinReplacements nonAsciiChars) parseString + -- Parse using haskell-src-exts + parsed = Parser.parseTypeWithMode parseTypeMode noHashString + in case parsed of + Parser.ParseFailed _ _ -> TyVar NoDoc (Ident NoDoc "not parsed") + Parser.ParseOk ty -> mapOnNames (theInverseReplacements . generateInverseLatinReplacements nonAsciiChars) (document NoDoc ty) + +theReplacements :: String -> String +theReplacements = (replace "#" "__HASH__") . (replace "[:" "__GHC_ARR_OPEN__") . (replace ":]" "__GHC_ARR_CLOSE__") . (replace "!" "BANG__") + +theInverseReplacements :: String -> String +theInverseReplacements = (replace "__HASH__" "#") . (replace "__GHC_ARR_OPEN__" "[:") . (replace "__GHC_ARR_CLOSE__" ":]") . (replace "BANG__" "!") + +generateLatinReplacements :: [Char] -> (String -> String) +generateLatinReplacements [] = id +generateLatinReplacements (c:cs) | isUpper c = (replace [c] ("UNICODE_SYMBOL_" ++ (show $ ord c) ++ "__")) . (generateLatinReplacements cs) + | otherwise = (replace [c] ("unicode_symbol_" ++ (show $ ord c) ++ "__")) . (generateLatinReplacements cs) + +generateInverseLatinReplacements :: [Char] -> (String -> String) +generateInverseLatinReplacements [] = id +generateInverseLatinReplacements (c:cs) | isUpper c = (replace ("UNICODE_SYMBOL_" ++ (show $ ord c) ++ "__") [c]) . (generateInverseLatinReplacements cs) + | otherwise = (replace ("unicode_symbol_" ++ (show $ ord c) ++ "__") [c]) . (generateInverseLatinReplacements cs) + +-- HACK: Types with ! are not parsed by haskell-src-exts +-- HACK: Control characters (like EOF) may appear +-- HACK: {-# UNPACK #-} comments and greek letters may appear +-- HACK: Greek letters may appear +eliminateUnwanted :: String -> String +eliminateUnwanted "" = "" +eliminateUnwanted ('{':('-':('#':(' ':('U':('N':('P':('A':('C':('K':(' ':('#':('-':('}': xs)))))))))))))) = eliminateUnwanted xs +eliminateUnwanted (x:xs) | isControl x = eliminateUnwanted xs + | otherwise = x : (eliminateUnwanted xs) + +mapOnNames :: (String -> String) -> Documented Type -> Documented Type +mapOnNames f (TyForall doc vars context ty) = TyForall doc + (fmap (fmap (mapOnNamesTyVar f)) vars) + (fmap (mapOnNamesContext f) context) + (mapOnNames f ty) +mapOnNames f (TyFun doc t1 t2) = TyFun doc (mapOnNames f t1) (mapOnNames f t2) +mapOnNames f (TyTuple doc boxed tys) = TyTuple doc boxed (fmap (mapOnNames f) tys) +mapOnNames f (TyList doc ty) = TyList doc (mapOnNames f ty) +mapOnNames f (TyApp doc t1 t2) = TyApp doc (mapOnNames f t1) (mapOnNames f t2) +mapOnNames f (TyVar doc name) = TyVar doc (mapOnNamesName f name) +mapOnNames f (TyCon doc name) = TyCon doc (mapOnNamesQName f name) +mapOnNames f (TyParen doc ty) = TyParen doc (mapOnNames f ty) +mapOnNames f (TyInfix doc t1 name t2) = TyInfix doc (mapOnNames f t1) (mapOnNamesQName f name) (mapOnNames f t2) +mapOnNames f (TyKind doc ty k) = TyKind doc (mapOnNames f ty) k + +mapOnNamesTyVar :: (String -> String) -> Documented TyVarBind -> Documented TyVarBind +mapOnNamesTyVar f (KindedVar doc name k) = KindedVar doc (mapOnNamesName f name) k +mapOnNamesTyVar f (UnkindedVar doc name) = UnkindedVar doc (mapOnNamesName f name) + +mapOnNamesName :: (String -> String) -> Documented Name -> Documented Name +mapOnNamesName f (Ident doc s) = Ident doc (f s) +mapOnNamesName f (Symbol doc s) = Symbol doc (f s) + +mapOnNamesQName :: (String -> String) -> Documented QName -> Documented QName +mapOnNamesQName f (Qual doc mname name) = Qual doc mname (mapOnNamesName f name) +mapOnNamesQName f (UnQual doc name) = UnQual doc (mapOnNamesName f name) +mapOnNamesQName _ q@(Special _ _) = q + +mapOnNamesContext :: (String -> String) -> Documented Context -> Documented Context +mapOnNamesContext f (CxSingle doc asst) = CxSingle doc (mapOnNamesAsst f asst) +mapOnNamesContext f (CxTuple doc assts) = CxTuple doc (fmap (mapOnNamesAsst f) assts) +mapOnNamesContext f (CxParen doc ctx) = CxParen doc (mapOnNamesContext f ctx) +mapOnNamesContext _ (CxEmpty doc) = CxEmpty doc + +mapOnNamesAsst :: (String -> String) -> Documented Asst -> Documented Asst +mapOnNamesAsst f (ClassA doc name tys) = ClassA doc (mapOnNamesQName f name) (fmap (mapOnNames f) tys) +mapOnNamesAsst f (InfixA doc ty1 name ty2) = InfixA doc (mapOnNames f ty1) (mapOnNamesQName f name) (mapOnNames f ty2) +mapOnNamesAsst f (IParam doc name ty) = IParam doc (mapOnNamesIPName f name) (mapOnNames f ty) +mapOnNamesAsst f (EqualP doc ty1 ty2) = EqualP doc (mapOnNames f ty1) (mapOnNames f ty2) + +mapOnNamesIPName :: (String -> String) -> Documented IPName -> Documented IPName +mapOnNamesIPName f (IPDup doc s) = IPDup doc (f s) +mapOnNamesIPName f (IPLin doc s) = IPLin doc (f s) + +multipleNames :: BSParser (Documented Name) ->BSParser [Documented Name] +multipleNames p=sepBy1 p (try $ do + spaces0 + char ',' + spaces0) + +functionLike :: BSParser (Documented Name) -> BSParser ([Documented Name], Documented Type) +functionLike p = do names <- choice [ + (try $ do + char '(' + ns<-multipleNames p + char ')' + return ns), + (multipleNames p) + ] + spaces0 + string "::" + spaces0 + rest <- restOfLine + ty <- parseType rest + return (names, ty) + +function :: Doc -> BSParser (Documented Decl) +function doc = do (names, ty) <- functionLike varid + return $ TypeSig doc names ty + +constructor :: Doc -> BSParser (Documented GadtDecl) +constructor doc = do (names, ty) <- functionLike conid + return $ GadtDecl doc (head names) ty + +constructorOrFunction :: Doc -> BSParser (Either (Documented Decl) (Documented GadtDecl)) +constructorOrFunction doc = do f <- function doc + return $ Left f + <|> + do c <- constructor doc + return $ Right c + +kind :: BSParser (Documented Kind) +kind = try (do k1 <- kindL + spaces0 + string "->" + spaces0 + k2 <- kind + return $ KindFn NoDoc k1 k2) + <|> kindL + +kindL :: BSParser (Documented Kind) +kindL = (do char '(' + spaces0 + k <- kind + spaces0 + char ')' + return $ KindParen NoDoc k) + <|> + (do char '*' + return $ KindStar NoDoc) + <|> + (do char '!' + return $ KindBang NoDoc) + <|> + (do n <- varid + return $ KindVar NoDoc n) + +instance_ :: Doc -> BSParser (Documented Decl) +instance_ doc = do string "instance" + -- HACK: in some Hoogle files things like [overlap ok] appear + optional $ try (do spaces0 + char '[' + many $ noneOf "]\r\n" + char ']') + spaces1 + rest <- restOfLine + ty' <- parseType rest + let (ctx, ty) = getContextAndType ty' + (qhead:params) = lineariseType ty + case qhead of + TyCon _ qname -> return $ InstDecl doc ctx (IHead NoDoc qname params) Nothing + _ -> return $ InstDecl doc ctx (IHead NoDoc (UnQual NoDoc (Ident NoDoc "#unparsed#")) params) Nothing + +type_ :: Doc -> BSParser (Documented Decl) +type_ doc = do string "type" + spaces1 + con <- conid + vars <- many (try (spaces1 >> tyVarBind)) + spaces0 + char '=' + spaces0 + rest <- restOfLine + ty <- parseType rest + return $ TypeDecl doc (DHead NoDoc con vars) ty + +tyVarBind :: BSParser (Documented TyVarBind) +tyVarBind = (do char '(' + spaces0 + var <- varid + spaces0 + string "::" + spaces0 + k <- kind + spaces0 + char ')' + return $ KindedVar NoDoc var k) + <|> + (do var <- varid + return $ UnkindedVar NoDoc var) + +-- Here we return not only the datatype or newtype, +-- but also functions around them, that are put +-- between constructors when using record syntax. +dataOrNewType :: String -> (Documented DataOrNew) -> Doc -> BSParser (Documented Decl, [Documented Decl]) +dataOrNewType keyword dOrN doc = do string keyword + spaces0 + rests <- many1 possibleKind + let rest = concat $ map fst rests + k = snd (last rests) + {- rest <- many $ allButDoubleColon + k <- optionMaybe (do string "::" + spaces0 + kind) -} + ty <- parseType rest + let (ctx, hd) = typeToContextAndHead ty + consAndFns <- many $ try (spacesOrEol0 >> documented constructorOrFunction) + let (fns, cons) = divideConstructorAndFunctions consAndFns + return $ (GDataDecl doc dOrN ctx hd k cons Nothing, fns) + +divideConstructorAndFunctions :: [Either (Documented Decl) (Documented GadtDecl)] -> ([Documented Decl], [Documented GadtDecl]) +divideConstructorAndFunctions [] = ([], []) +divideConstructorAndFunctions (x:xs) = let (fns, cons) = divideConstructorAndFunctions xs + in case x of + Left fn -> (fn:fns, cons) + Right con -> (fns, con:cons) + +possibleKind :: BSParser (String, Maybe (Documented Kind)) +possibleKind = do rest <- many1 $ allButDoubleColon + k <- optionMaybe (do string "::" + spaces0 + kind) + return (rest, k) + +allButDoubleColon :: BSParser Char +allButDoubleColon = try (do char ':' + notFollowedBy $ char ':' + return ':') + <|> (noneOf ":\r\n") + +data_ :: Doc -> BSParser (Documented Decl, [Documented Decl]) +data_ = dataOrNewType "data" (DataType NoDoc) + +newtype_ :: Doc -> BSParser (Documented Decl, [Documented Decl]) +newtype_ = dataOrNewType "newtype" (NewType NoDoc) + +dataOrNewTypeHead :: String -> (Documented DataOrNew) -> Doc -> BSParser (Documented Decl) +dataOrNewTypeHead keyword dOrN doc = do string keyword + spaces0 + rests <- many1 possibleKind + let rest = concat $ map fst rests + k = snd (last rests) + {- rest <- many $ allButDoubleColon + k <- optionMaybe (do string "::" + spaces0 + kind) -} + ty <- parseType rest + let (ctx, hd) = typeToContextAndHead ty + return $ GDataDecl doc dOrN ctx hd k [] Nothing + +dataHead :: Doc -> BSParser (Documented Decl) +dataHead = dataOrNewTypeHead "data" (DataType NoDoc) + +newtypeHead :: Doc -> BSParser (Documented Decl) +newtypeHead = dataOrNewTypeHead "newtype" (NewType NoDoc) + +class_ :: Doc -> BSParser (Documented Decl) +class_ doc = do string "class" + spaces0 + rest <- many $ allButWhereColonPipe + fd' <- optionMaybe (do string "|" + spaces0 + iFunDep <- funDep + rFunDep <- many $ try (spaces0 >> char ',' >> spaces0 >> funDep) + return $ iFunDep:rFunDep) + -- HACK: if a type family is introduced here, just discard it + optional $ string "where" >> restOfLine + -- HACK: in some Hoogle files, kinds are added to the class + optional $ string "::" >> restOfLine + ty <- parseType rest + let (ctx, hd) = typeToContextAndHead ty + fd = maybe [] id fd' + return $ ClassDecl doc ctx hd fd Nothing + +allButWhereColonPipe :: BSParser Char +allButWhereColonPipe = try (do char ':' + notFollowedBy $ char ':' + return ':') + <|> + try (do char 'w' + notFollowedBy $ string "here" + return 'w') + <|> (noneOf "w|:\r\n") + +funDep :: BSParser (Documented FunDep) +funDep = do iVarLeft <- varid + rVarLeft <- many $ try (spaces1 >> varid) + spaces0 + string "->" + spaces0 + iVarRight <- varid + rVarRight <- many $ try (spaces1 >> varid) + return $ FunDep NoDoc (iVarLeft:rVarLeft) (iVarRight:rVarRight) + +{- +qualifiedVarid :: BSParser [String] +qualifiedVarid = do id <- varid + return [id] + <|> do mod <- many1 (do m <- conid + char '.' + return m) + id <- varid + return $ mod ++ [id] + +qualifiedConid :: BSParser [String] +qualifiedConid = conid `sepBy` char '.' +-} + +varid :: BSParser (Documented Name) +varid = try (do initial <- lower <|> char '_' + rest <- many $ alphaNum <|> oneOf allowedSpecialCharactersInIds + let var = initial:rest + guard $ not (var `elem` haskellKeywords) + return $ Ident NoDoc var) + <|> +-- try (do --initial <- oneOf (tail specialCharacters) +-- var <- many1 (oneOf specialCharacters) +-- --let var = initial:rest +-- guard $ not (var `elem` haskellReservedOps) +-- return $ Symbol NoDoc var) +-- <|> + try (do string "()" + return $ Symbol NoDoc "()") + <|> + try (do char '(' + s<-many1 (char ',') + char ')' + return $ Symbol NoDoc s) + <|> + try (do char '(' + var <- varid + char ')' + return var) + <|> + try (do var <- many1 (noneOf [',',')','(',' ','\r','\n','\t']) + guard $ not (isUpper $ head var) + guard $ not (var `elem` haskellReservedOps) + return $ Symbol NoDoc var) + + +conid :: BSParser (Documented Name) +conid = (do initial <- upper + rest <- many $ alphaNum <|> oneOf allowedSpecialCharactersInIds + return $ Ident NoDoc (initial:rest)) + <|> + try (do initial <- char ':' + rest <- many (oneOf specialCharacters) + let con = initial:rest + guard $ not (con `elem` haskellReservedOps) + return $ Symbol NoDoc con) + <|> + try (do char '(' + con <- conid + char ')' + return con) + +getid :: Documented Name -> String +getid (Ident _ s) = s +getid (Symbol _ s) = '(' : (s ++ ")" ) + +haskellKeywords :: [String] +haskellKeywords = [ "case", "class", "data", "default", "deriving", "do" + , "else", "foreign", "if", "import", "in", "infix", "infixl" + , "infixr", "instance", "let", "module", "newtype", "of" + , "then", "type", "where", "_" ] + +haskellReservedOps :: [String] +haskellReservedOps = [ "..", ":", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>" ] + +allowedSpecialCharactersInIds :: [Char] +allowedSpecialCharactersInIds = "_'-[]#" + +specialCharacters :: [Char] +specialCharacters = ":!#$%&*+./<=>?@\\^|-~" + +restOfLine :: BSParser String +restOfLine = many $ noneOf "\r\n" + +eol :: BSParser String +eol = try (string "\r\n") + <|> try (string "\r") + <|> string "\n" + -- <|> (lookAhead eof >> return "\n") + "new line" + +number :: BSParser Int +number = do n <- many1 digit + return $ read n + +spaces0 :: BSParser String +spaces0 = many $ char ' ' + +spaces1 :: BSParser String +spaces1 = many1 $ char ' ' + +spacesOrEol0 :: BSParser String +spacesOrEol0 = many $ oneOf " \r\n\t" + +spacesOrEol1 :: BSParser String +spacesOrEol1 = many1 $ oneOf " \r\n\t" + +-- working with types + +getContextAndType :: (Documented Type) -> (Maybe (Documented Context), Documented Type) +getContextAndType (TyForall _ _ ctx ty) = (ctx, ty) +getContextAndType ty = (Nothing, ty) + +lineariseType :: Documented Type -> [Documented Type] +lineariseType (TyApp _ x y) = (lineariseType x) ++ [y] +lineariseType ty = [ty] + +typeToContextAndHead :: (Documented Type) -> (Maybe (Documented Context), Documented DeclHead) +typeToContextAndHead t = let (ctx, ty) = getContextAndType t + (name,vars) = case lineariseType ty of + ((TyCon _ (UnQual _ name')):params) -> (name', toKindedVars params) + ((TyCon _ (Qual _ _ name')):params) -> (name', toKindedVars params) + ((TyCon _ (Special l _)):params) -> (Symbol l "", toKindedVars params) + (_:params) -> (Ident NoDoc "#unparsed#", toKindedVars params) + [] -> error "This should never happen" + in (ctx, DHead NoDoc name vars) + +toKindedVars :: [Type Doc] -> [TyVarBind Doc] +toKindedVars [] = [] +toKindedVars ((TyVar d (Ident _ n1)):( (TyList _ (TyVar _ (Ident _ n2))): xs )) = + (UnkindedVar d (Ident NoDoc $ n1 ++ "[" ++ n2 ++ "]")) : toKindedVars xs +toKindedVars ((TyVar d n):xs) = (UnkindedVar d n) : toKindedVars xs +toKindedVars (x:_) = error $ show x + diff --git a/src/Scion/PersistentBrowser/Query.hs b/src/Scion/PersistentBrowser/Query.hs --- a/src/Scion/PersistentBrowser/Query.hs +++ b/src/Scion/PersistentBrowser/Query.hs @@ -1,206 +1,207 @@ -{-# LANGUAGE TypeSynonymInstances #-} - -module Scion.PersistentBrowser.Query where - -import qualified Data.Text as T -import Database.Persist -import Database.Persist.Base -import Database.Persist.Sqlite -import Database.Persist.GenericSql.Raw (withStmt) -import Database.Persist.GenericSql.Internal (RowPopper) -import Scion.PersistentBrowser.DbTypes - --- |Get the identifiers of all packages in the database. -allPackageIds :: Maybe DbPackageIdentifier -> SqlPersist IO [DbPackageIdentifier] -allPackageIds pkgs = do packages <- allPackages pkgs - return $ map dbPackageToIdentifier packages - --- |Get information of all packages in the database. -allPackages :: Maybe DbPackageIdentifier -> SqlPersist IO [DbPackage] -allPackages _ = do packages <- selectList ([] :: [Filter DbPackage]) [] - return $ map snd packages - --- |Get information of all versions of the package with that name. -packagesByName :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [DbPackage] -packagesByName name _ = do packages <- selectList [ DbPackageName ==. name ] [] - return $ map snd packages - --- |Get information about a package in the database. -getPackage :: DbPackageIdentifier -> SqlPersist IO (Maybe (DbPackage)) -getPackage (DbPackageIdentifier name version) = do package <- selectFirst [ DbPackageName ==. name, DbPackageVersion ==. version ] [] - return $ fmap snd package - --- |Get information about all modules with that name. -modulesByName :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [DbModule] -modulesByName name Nothing = do mods <- selectList [ DbModuleName ==. name ] [] - return $ map snd mods -modulesByName name (Just (DbPackageIdentifier pkgName pkgVersion)) = - do let sql = "SELECT DbModule.name, DbModule.doc, DbModule.packageId FROM DbModule, DbPackage" - ++ " WHERE DbModule.packageId = DbPackage.id " - ++ " AND DbModule.name = '" ++ name ++ "'" - ++ " AND DbPackage.name = '" ++ pkgName ++ "'" - ++ " AND DbPackage.version = '" ++ pkgVersion ++ "'" - queryDb sql moduleAction - --- |Get all the modules hierarchically inside the specified one. --- For getting the entire list of modules modules, use "" as initial name. -getSubmodules :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [DbModule] -getSubmodules "" Nothing = - do let sql = "SELECT name, doc, packageId FROM DbModule" - queryDb sql moduleAction -getSubmodules "" (Just (DbPackageIdentifier pkgName pkgVersion)) = - do let sql = "SELECT DbModule.name, DbModule.doc, DbModule.packageId FROM DbModule, DbPackage" - ++ " WHERE DbModule.packageId = DbPackage.id " - ++ " AND DbPackage.name = '" ++ pkgName ++ "'" - ++ " AND DbPackage.version = '" ++ pkgVersion ++ "'" - queryDb sql moduleAction -getSubmodules modName Nothing = - do let sql = "SELECT name, doc, packageId FROM DbModule WHERE name LIKE '" ++ modName ++ ".%'" - queryDb sql moduleAction -getSubmodules modName (Just (DbPackageIdentifier pkgName pkgVersion)) = - do let sql = "SELECT DbModule.name, DbModule.doc, DbModule.packageId FROM DbModule, DbPackage" - ++ " WHERE name LIKE '" ++ modName ++ ".%'" - ++ " AND DbModule.packageId = DbPackage.id " - ++ " AND DbPackage.name = '" ++ pkgName ++ "'" - ++ " AND DbPackage.version = '" ++ pkgVersion ++ "'" - queryDb sql moduleAction - -moduleAction :: [PersistValue] -> DbModule -moduleAction [PersistText name, doc, pkgId@(PersistInt64 _)] = DbModule (T.unpack name) (fromDbText doc) (Key pkgId) -moduleAction _ = error "This should not happen" - --- |Get information about all declaration with that name. -declsByName :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [DbDecl] -declsByName name Nothing = - do let sql = "SELECT DbDecl.declType, DbDecl.name, DbDecl.doc, DbDecl.kind, DbDecl.signature, DbDecl.equals, DbDecl.moduleId" - ++ " FROM DbDecl, DbModule" - ++ " WHERE DbModule.name ='" ++ name ++ "'" - queryDb sql declAction -declsByName name (Just (DbPackageIdentifier pkgName pkgVersion)) = - do let sql = "SELECT DbDecl.declType, DbDecl.name, DbDecl.doc, DbDecl.kind, DbDecl.signature, DbDecl.equals, DbDecl.moduleId" - ++ " FROM DbDecl, DbModule, DbPackage" - ++ " WHERE DbDecl.moduleId = DbModule.id AND DbModule.packageId = DbPackage.id" - ++ " AND DbModule.name = '" ++ name ++ "'" - ++ " AND DbPackage.name = '" ++ pkgName ++ "'" - ++ " AND DbPackage.version = '" ++ pkgVersion ++ "'" - queryDb sql declAction - -declAction :: [PersistValue] -> DbDecl -declAction [PersistText declType, PersistText name , doc, kind, signature, equals, modId@(PersistInt64 _)] = - DbDecl (read (T.unpack declType)) (T.unpack name) (fromDbText doc) - (fromDbText kind) (fromDbText signature) (fromDbText equals) - (Key modId) -declAction _ = error "This should not happen" - --- |Gets the declarations inside some module, --- along with information about which package it lives. -getDeclsInModule :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [(DbPackageIdentifier, DbCompleteDecl)] -getDeclsInModule modName pkgId = - do let pkg = case pkgId of - Nothing -> "" - Just (DbPackageIdentifier pkgName pkgVersion) -> " AND DbPackage.name = '" ++ pkgName ++ "'" - ++ " AND DbPackage.version = '" ++ pkgVersion ++ "'" - let sql = "SELECT DbDecl.id, DbDecl.declType, DbDecl.name, DbDecl.doc, DbDecl.kind, DbDecl.signature, DbDecl.equals, DbDecl.moduleId" - ++ ", DbPackage.name, DbPackage.version" - ++ " FROM DbDecl, DbModule, DbPackage" - ++ " WHERE DbDecl.moduleId = DbModule.id AND DbModule.packageId = DbPackage.id" - ++ " AND DbModule.name = '" ++ modName ++ "'" - ++ pkg - elts <- queryDb sql action - completeElts <- mapM (\(dclId, dcl, p) -> do dclAll <- getAllDeclInfo (dclId, dcl) - return (p, dclAll)) elts - return completeElts - where action :: [PersistValue] -> (DbDeclId, DbDecl, DbPackageIdentifier) - action [declId@(PersistInt64 _), PersistText declType, PersistText name - , doc, kind, signature, equals, modId@(PersistInt64 _) - , PersistText pkgName, PersistText pkgVersion] = - ( Key declId - , DbDecl (read (T.unpack declType)) (T.unpack name) (fromDbText doc) - (fromDbText kind) (fromDbText signature) (fromDbText equals) - (Key modId) - , DbPackageIdentifier (T.unpack pkgName) (T.unpack pkgVersion) - ) - action _ = error "This should not happen" - -getAllDeclInfo :: (DbDeclId, DbDecl) -> SqlPersist IO DbCompleteDecl -getAllDeclInfo (declId, decl) = - do ctxs' <- selectList [ DbContextDeclId ==. declId] [] - let ctxs = map snd ctxs' - tyvars' <- selectList [ DbTyVarDeclId ==. declId] [] - let tyvars = map snd tyvars' - fundeps' <- selectList [ DbFunDepDeclId ==. declId] [] - let fundeps = map snd fundeps' - consts' <- selectList [ DbConstructorDeclId ==. declId] [] - let consts = map snd consts' - return $ DbCompleteDecl decl ctxs tyvars fundeps consts - --- |Get information about all constructors with that name. -constructorsByName :: String -> SqlPersist IO [DbConstructor] -constructorsByName name = do consts <- selectList [ DbConstructorName ==. name ] [] - return $ map snd consts - --- | Gets a list of modules where a declaration may live -getModulesWhereDeclarationIs :: String -> SqlPersist IO [DbModule] -getModulesWhereDeclarationIs declName = - do let sqlDecl = "SELECT DbModule.name, DbModule.doc, DbModule.packageId" - ++ " FROM DbDecl, DbModule" - ++ " WHERE DbDecl.moduleId = DbModule.id AND DbDecl.name = '" ++ declName ++ "'" - sqlCons = "SELECT DbModule.name, DbModule.doc, DbModule.packageId" - ++ " FROM DbConstructor, DbDecl, DbModule" - ++ " WHERE DbConstructor.declId = DbDecl.id AND DbDecl.moduleId = DbModule.id" - ++ " AND DbConstructor.name = '" ++ declName ++ "'" - decls <- queryDb sqlDecl action - cons <- queryDb sqlCons action - return (decls ++ cons) - where action :: [PersistValue] -> DbModule - action [PersistText name, doc, pkgId@(PersistInt64 _)] = DbModule (T.unpack name) (fromDbText doc) (Key pkgId) - action _ = error "This should not happen" - --- |Executes a query. -queryDb :: String -> ([PersistValue] -> a) -> SqlPersist IO [a] -queryDb sql action = withStmt (T.pack sql) [] (withPopper action) - --- |Builds information from a database query. -withPopper :: ([PersistValue] -> a) -> RowPopper (SqlPersist IO) -> SqlPersist IO [a] -withPopper f popper = loop [] - where loop list = do mrow <- popper - case mrow of - Nothing -> return list - Just values -> loop ((f values):list) - --- |Gets information from a text value. -fromDbText :: PersistValue -> Maybe String -fromDbText (PersistText value) = Just (T.unpack value) -fromDbText PersistNull = Nothing -fromDbText _ = error "This should not happen" - --- |Things that reside on a package. -class HasDbPackage d where - getDbPackage :: d -> SqlPersist IO DbPackage - -instance HasDbPackage DbPackage where - getDbPackage = return - -instance HasDbPackage DbModule where - getDbPackage (DbModule _ _ pkgId) = do Just pkg <- get pkgId - return pkg - -instance HasDbPackage DbDecl where - getDbPackage (DbDecl _ _ _ _ _ _ modId) = do Just md <- get modId - getDbPackage md - --- |Things that reside on a module. -class HasDbModule d where - getDbModule :: d -> SqlPersist IO DbModule - -instance HasDbModule DbModule where - getDbModule = return - -instance HasDbModule DbDecl where - getDbModule (DbDecl _ _ _ _ _ _ modId) = do Just md <- get modId - return md - -instance HasDbModule DbConstructor where - getDbModule (DbConstructor _ _ declId) = do Just dc <- get declId - getDbModule dc - +{-# LANGUAGE TypeSynonymInstances #-} + +module Scion.PersistentBrowser.Query where + +import qualified Data.Text as T +import Database.Persist +import Database.Persist.Base +import Database.Persist.Sqlite +import Database.Persist.GenericSql.Raw (withStmt) +import Database.Persist.GenericSql.Internal (RowPopper) +import Scion.PersistentBrowser.DbTypes +import Scion.PersistentBrowser.Util (escapeSql) + +-- |Get the identifiers of all packages in the database. +allPackageIds :: Maybe DbPackageIdentifier -> SqlPersist IO [DbPackageIdentifier] +allPackageIds pkgs = do packages <- allPackages pkgs + return $ map dbPackageToIdentifier packages + +-- |Get information of all packages in the database. +allPackages :: Maybe DbPackageIdentifier -> SqlPersist IO [DbPackage] +allPackages _ = do packages <- selectList ([] :: [Filter DbPackage]) [] + return $ map snd packages + +-- |Get information of all versions of the package with that name. +packagesByName :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [DbPackage] +packagesByName name _ = do packages <- selectList [ DbPackageName ==. name ] [] + return $ map snd packages + +-- |Get information about a package in the database. +getPackage :: DbPackageIdentifier -> SqlPersist IO (Maybe (DbPackage)) +getPackage (DbPackageIdentifier name version) = do package <- selectFirst [ DbPackageName ==. name, DbPackageVersion ==. version ] [] + return $ fmap snd package + +-- |Get information about all modules with that name. +modulesByName :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [DbModule] +modulesByName name Nothing = do mods <- selectList [ DbModuleName ==. name ] [] + return $ map snd mods +modulesByName name (Just (DbPackageIdentifier pkgName pkgVersion)) = + do let sql = "SELECT DbModule.name, DbModule.doc, DbModule.packageId FROM DbModule, DbPackage" + ++ " WHERE DbModule.packageId = DbPackage.id " + ++ " AND DbModule.name = '" ++ (escapeSql name) ++ "'" + ++ " AND DbPackage.name = '" ++ (escapeSql pkgName) ++ "'" + ++ " AND DbPackage.version = '" ++ (escapeSql pkgVersion) ++ "'" + queryDb sql moduleAction + +-- |Get all the modules hierarchically inside the specified one. +-- For getting the entire list of modules modules, use "" as initial name. +getSubmodules :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [DbModule] +getSubmodules "" Nothing = + do let sql = "SELECT name, doc, packageId FROM DbModule" + queryDb sql moduleAction +getSubmodules "" (Just (DbPackageIdentifier pkgName pkgVersion)) = + do let sql = "SELECT DbModule.name, DbModule.doc, DbModule.packageId FROM DbModule, DbPackage" + ++ " WHERE DbModule.packageId = DbPackage.id " + ++ " AND DbPackage.name = '" ++ (escapeSql pkgName) ++ "'" + ++ " AND DbPackage.version = '" ++ (escapeSql pkgVersion) ++ "'" + queryDb sql moduleAction +getSubmodules modName Nothing = + do let sql = "SELECT name, doc, packageId FROM DbModule WHERE name LIKE '" ++ (escapeSql modName) ++ ".%'" + queryDb sql moduleAction +getSubmodules modName (Just (DbPackageIdentifier pkgName pkgVersion)) = + do let sql = "SELECT DbModule.name, DbModule.doc, DbModule.packageId FROM DbModule, DbPackage" + ++ " WHERE name LIKE '" ++ (escapeSql modName) ++ ".%'" + ++ " AND DbModule.packageId = DbPackage.id " + ++ " AND DbPackage.name = '" ++ (escapeSql pkgName) ++ "'" + ++ " AND DbPackage.version = '" ++ (escapeSql pkgVersion) ++ "'" + queryDb sql moduleAction + +moduleAction :: [PersistValue] -> DbModule +moduleAction [PersistText name, doc, pkgId@(PersistInt64 _)] = DbModule (T.unpack name) (fromDbText doc) (Key pkgId) +moduleAction _ = error "This should not happen" + +-- |Get information about all declaration with that name. +declsByName :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [DbDecl] +declsByName name Nothing = + do let sql = "SELECT DbDecl.declType, DbDecl.name, DbDecl.doc, DbDecl.kind, DbDecl.signature, DbDecl.equals, DbDecl.moduleId" + ++ " FROM DbDecl, DbModule" + ++ " WHERE DbModule.name ='" ++ (escapeSql name) ++ "'" + queryDb sql declAction +declsByName name (Just (DbPackageIdentifier pkgName pkgVersion)) = + do let sql = "SELECT DbDecl.declType, DbDecl.name, DbDecl.doc, DbDecl.kind, DbDecl.signature, DbDecl.equals, DbDecl.moduleId" + ++ " FROM DbDecl, DbModule, DbPackage" + ++ " WHERE DbDecl.moduleId = DbModule.id AND DbModule.packageId = DbPackage.id" + ++ " AND DbModule.name = '" ++ (escapeSql name) ++ "'" + ++ " AND DbPackage.name = '" ++ (escapeSql pkgName) ++ "'" + ++ " AND DbPackage.version = '" ++ (escapeSql pkgVersion) ++ "'" + queryDb sql declAction + +declAction :: [PersistValue] -> DbDecl +declAction [PersistText declType, PersistText name , doc, kind, signature, equals, modId@(PersistInt64 _)] = + DbDecl (read (T.unpack declType)) (T.unpack name) (fromDbText doc) + (fromDbText kind) (fromDbText signature) (fromDbText equals) + (Key modId) +declAction _ = error "This should not happen" + +-- |Gets the declarations inside some module, +-- along with information about which package it lives. +getDeclsInModule :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [(DbPackageIdentifier, DbCompleteDecl)] +getDeclsInModule modName pkgId = + do let pkg = case pkgId of + Nothing -> "" + Just (DbPackageIdentifier pkgName pkgVersion) -> " AND DbPackage.name = '" ++ (escapeSql pkgName) ++ "'" + ++ " AND DbPackage.version = '" ++ (escapeSql pkgVersion) ++ "'" + let sql = "SELECT DbDecl.id, DbDecl.declType, DbDecl.name, DbDecl.doc, DbDecl.kind, DbDecl.signature, DbDecl.equals, DbDecl.moduleId" + ++ ", DbPackage.name, DbPackage.version" + ++ " FROM DbDecl, DbModule, DbPackage" + ++ " WHERE DbDecl.moduleId = DbModule.id AND DbModule.packageId = DbPackage.id" + ++ " AND DbModule.name = '" ++ (escapeSql modName) ++ "'" + ++ pkg + elts <- queryDb sql action + completeElts <- mapM (\(dclId, dcl, p) -> do dclAll <- getAllDeclInfo (dclId, dcl) + return (p, dclAll)) elts + return completeElts + where action :: [PersistValue] -> (DbDeclId, DbDecl, DbPackageIdentifier) + action [declId@(PersistInt64 _), PersistText declType, PersistText name + , doc, kind, signature, equals, modId@(PersistInt64 _) + , PersistText pkgName, PersistText pkgVersion] = + ( Key declId + , DbDecl (read (T.unpack declType)) (T.unpack name) (fromDbText doc) + (fromDbText kind) (fromDbText signature) (fromDbText equals) + (Key modId) + , DbPackageIdentifier (T.unpack pkgName) (T.unpack pkgVersion) + ) + action _ = error "This should not happen" + +getAllDeclInfo :: (DbDeclId, DbDecl) -> SqlPersist IO DbCompleteDecl +getAllDeclInfo (declId, decl) = + do ctxs' <- selectList [ DbContextDeclId ==. declId] [] + let ctxs = map snd ctxs' + tyvars' <- selectList [ DbTyVarDeclId ==. declId] [] + let tyvars = map snd tyvars' + fundeps' <- selectList [ DbFunDepDeclId ==. declId] [] + let fundeps = map snd fundeps' + consts' <- selectList [ DbConstructorDeclId ==. declId] [] + let consts = map snd consts' + return $ DbCompleteDecl decl ctxs tyvars fundeps consts + +-- |Get information about all constructors with that name. +constructorsByName :: String -> SqlPersist IO [DbConstructor] +constructorsByName name = do consts <- selectList [ DbConstructorName ==. name ] [] + return $ map snd consts + +-- | Gets a list of modules where a declaration may live +getModulesWhereDeclarationIs :: String -> SqlPersist IO [DbModule] +getModulesWhereDeclarationIs declName = + do let sqlDecl = "SELECT DbModule.name, DbModule.doc, DbModule.packageId" + ++ " FROM DbDecl, DbModule" + ++ " WHERE DbDecl.moduleId = DbModule.id AND DbDecl.name = '" ++ (escapeSql declName) ++ "'" + sqlCons = "SELECT DbModule.name, DbModule.doc, DbModule.packageId" + ++ " FROM DbConstructor, DbDecl, DbModule" + ++ " WHERE DbConstructor.declId = DbDecl.id AND DbDecl.moduleId = DbModule.id" + ++ " AND DbConstructor.name = '" ++ (escapeSql declName) ++ "'" + decls <- queryDb sqlDecl action + cons <- queryDb sqlCons action + return (decls ++ cons) + where action :: [PersistValue] -> DbModule + action [PersistText name, doc, pkgId@(PersistInt64 _)] = DbModule (T.unpack name) (fromDbText doc) (Key pkgId) + action _ = error "This should not happen" + +-- |Executes a query. +queryDb :: String -> ([PersistValue] -> a) -> SqlPersist IO [a] +queryDb sql action = withStmt (T.pack sql) [] (withPopper action) + +-- |Builds information from a database query. +withPopper :: ([PersistValue] -> a) -> RowPopper (SqlPersist IO) -> SqlPersist IO [a] +withPopper f popper = loop [] + where loop list = do mrow <- popper + case mrow of + Nothing -> return list + Just values -> loop ((f values):list) + +-- |Gets information from a text value. +fromDbText :: PersistValue -> Maybe String +fromDbText (PersistText value) = Just (T.unpack value) +fromDbText PersistNull = Nothing +fromDbText _ = error "This should not happen" + +-- |Things that reside on a package. +class HasDbPackage d where + getDbPackage :: d -> SqlPersist IO DbPackage + +instance HasDbPackage DbPackage where + getDbPackage = return + +instance HasDbPackage DbModule where + getDbPackage (DbModule _ _ pkgId) = do Just pkg <- get pkgId + return pkg + +instance HasDbPackage DbDecl where + getDbPackage (DbDecl _ _ _ _ _ _ modId) = do Just md <- get modId + getDbPackage md + +-- |Things that reside on a module. +class HasDbModule d where + getDbModule :: d -> SqlPersist IO DbModule + +instance HasDbModule DbModule where + getDbModule = return + +instance HasDbModule DbDecl where + getDbModule (DbDecl _ _ _ _ _ _ modId) = do Just md <- get modId + return md + +instance HasDbModule DbConstructor where + getDbModule (DbConstructor _ _ declId) = do Just dc <- get declId + getDbModule dc + diff --git a/src/Scion/PersistentBrowser/TempFile.hs b/src/Scion/PersistentBrowser/TempFile.hs --- a/src/Scion/PersistentBrowser/TempFile.hs +++ b/src/Scion/PersistentBrowser/TempFile.hs @@ -1,220 +1,220 @@ --- Taken from Cabal source --- http://hackage.haskell.org/package/Cabal-1.10.2.0 - -{-# OPTIONS -cpp #-} --- OPTIONS required for ghc-6.4.x compat, and must appear first -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -cpp #-} -{-# OPTIONS_NHC98 -cpp #-} -{-# OPTIONS_JHC -fcpp #-} --- #hide -module Scion.PersistentBrowser.TempFile ( - openTempFile, - openBinaryTempFile, - openNewBinaryFile, - createTempDirectory, - ) where - - -import System.FilePath (()) -import Foreign.C (eEXIST) - -#if __NHC__ || __HUGS__ -import System.IO (openFile, openBinaryFile, - Handle, IOMode(ReadWriteMode)) -import System.Directory (doesFileExist) -import System.FilePath ((<.>), splitExtension) -import System.IO.Error (try, isAlreadyExistsError) -#else -import System.IO (Handle, openTempFile, openBinaryTempFile) -import Data.Bits ((.|.)) -import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR, - o_BINARY, o_NONBLOCK, o_NOCTTY) -import System.IO.Error (try, isAlreadyExistsError) -#if __GLASGOW_HASKELL__ >= 611 -import System.Posix.Internals (withFilePath) -#else -import Foreign.C (withCString) -#endif -import Foreign.C (CInt) -#if __GLASGOW_HASKELL__ >= 611 -import GHC.IO.Handle.FD (fdToHandle) -#else -import GHC.Handle (fdToHandle) -#endif -#endif -import Foreign.C (getErrno, errnoToIOError) - -#if __NHC__ -import System.Posix.Types (CPid(..)) -foreign import ccall unsafe "getpid" c_getpid :: IO CPid -#else -import System.Posix.Internals (c_getpid) -#endif - -#ifdef mingw32_HOST_OS -import System.Directory ( createDirectory ) -#else -import qualified System.Posix -#endif - -#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610)) -#define NEW_EXCEPTION -#endif - -import qualified Control.Exception as Exception - -onException :: IO a -> IO b -> IO a -#ifdef NEW_EXCEPTION -onException = Exception.onException -#else -onException io what = io `Exception.catch` \e -> do what - Exception.throw e -#endif - --- ------------------------------------------------------------ --- * temporary files --- ------------------------------------------------------------ - --- This is here for Haskell implementations that do not come with --- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9. --- TODO: Not sure about jhc - -#if __NHC__ || __HUGS__ --- use a temporary filename that doesn't already exist. --- NB. *not* secure (we don't atomically lock the tmp file we get) -openTempFile :: FilePath -> String -> IO (FilePath, Handle) -openTempFile tmp_dir template - = do x <- getProcessID - findTempName x - where - (templateBase, templateExt) = splitExtension template - findTempName :: Int -> IO (FilePath, Handle) - findTempName x - = do let path = tmp_dir (templateBase ++ "-" ++ show x) <.> templateExt - b <- doesFileExist path - if b then findTempName (x+1) - else do hnd <- openFile path ReadWriteMode - return (path, hnd) - -openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle) -openBinaryTempFile tmp_dir template - = do x <- getProcessID - findTempName x - where - (templateBase, templateExt) = splitExtension template - findTempName :: Int -> IO (FilePath, Handle) - findTempName x - = do let path = tmp_dir (templateBase ++ show x) <.> templateExt - b <- doesFileExist path - if b then findTempName (x+1) - else do hnd <- openBinaryFile path ReadWriteMode - return (path, hnd) - -openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) -openNewBinaryFile = openBinaryTempFile - -getProcessID :: IO Int -getProcessID = fmap fromIntegral c_getpid -#else --- This is a copy/paste of the openBinaryTempFile definition, but --- if uses 666 rather than 600 for the permissions. The base library --- needs to be changed to make this better. -openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) -openNewBinaryFile dir template = do - pid <- c_getpid - findTempName pid - where - -- We split off the last extension, so we can use .foo.ext files - -- for temporary files (hidden on Unix OSes). Unfortunately we're - -- below filepath in the hierarchy here. - (prefix,suffix) = - case break (== '.') $ reverse template of - -- First case: template contains no '.'s. Just re-reverse it. - (rev_suffix, "") -> (reverse rev_suffix, "") - -- Second case: template contains at least one '.'. Strip the - -- dot from the prefix and prepend it to the suffix (if we don't - -- do this, the unique number will get added after the '.' and - -- thus be part of the extension, which is wrong.) - (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) - -- Otherwise, something is wrong, because (break (== '.')) should - -- always return a pair with either the empty string or a string - -- beginning with '.' as the second component. - _ -> error "bug in System.IO.openTempFile" - - oflags = rw_flags .|. o_EXCL .|. o_BINARY - -#if __GLASGOW_HASKELL__ < 611 - withFilePath = withCString -#endif - - findTempName x = do - fd <- withFilePath filepath $ \ f -> - c_open f oflags 0o666 - if fd < 0 - then do - errno <- getErrno - if errno == eEXIST - then findTempName (x+1) - else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) - else do - -- TODO: We want to tell fdToHandle what the filepath is, - -- as any exceptions etc will only be able to report the - -- fd currently - h <- -#if __GLASGOW_HASKELL__ >= 609 - fdToHandle fd -#elif __GLASGOW_HASKELL__ <= 606 && defined(mingw32_HOST_OS) - -- fdToHandle is borked on Windows with ghc-6.6.x - openFd (fromIntegral fd) Nothing False filepath - ReadWriteMode True -#else - fdToHandle (fromIntegral fd) -#endif - `onException` c_close fd - return (filepath, h) - where - filename = prefix ++ show x ++ suffix - filepath = dir `combine` filename - - -- FIXME: bits copied from System.FilePath - combine a b - | null b = a - | null a = b - | last a == pathSeparator = a ++ b - | otherwise = a ++ [pathSeparator] ++ b - --- FIXME: Should use filepath library -pathSeparator :: Char -#ifdef mingw32_HOST_OS -pathSeparator = '\\' -#else -pathSeparator = '/' -#endif - --- FIXME: Copied from GHC.Handle -std_flags, output_flags, rw_flags :: CInt -std_flags = o_NONBLOCK .|. o_NOCTTY -output_flags = std_flags .|. o_CREAT -rw_flags = output_flags .|. o_RDWR -#endif - -createTempDirectory :: FilePath -> String -> IO FilePath -createTempDirectory dir template = do - pid <- c_getpid - findTempName pid - where - findTempName x = do - let dirpath = dir template ++ show x - r <- try $ mkPrivateDir dirpath - case r of - Right _ -> return dirpath - Left e | isAlreadyExistsError e -> findTempName (x+1) - | otherwise -> ioError e - -mkPrivateDir :: String -> IO () -#ifdef mingw32_HOST_OS -mkPrivateDir s = createDirectory s -#else -mkPrivateDir s = System.Posix.createDirectory s 0o700 -#endif +-- Taken from Cabal source +-- http://hackage.haskell.org/package/Cabal-1.10.2.0 + +{-# OPTIONS -cpp #-} +-- OPTIONS required for ghc-6.4.x compat, and must appear first +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp #-} +-- #hide +module Scion.PersistentBrowser.TempFile ( + openTempFile, + openBinaryTempFile, + openNewBinaryFile, + createTempDirectory, + ) where + + +import System.FilePath (()) +import Foreign.C (eEXIST) + +#if __NHC__ || __HUGS__ +import System.IO (openFile, openBinaryFile, + Handle, IOMode(ReadWriteMode)) +import System.Directory (doesFileExist) +import System.FilePath ((<.>), splitExtension) +import System.IO.Error (try, isAlreadyExistsError) +#else +import System.IO (Handle, openTempFile, openBinaryTempFile) +import Data.Bits ((.|.)) +import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR, + o_BINARY, o_NONBLOCK, o_NOCTTY) +import System.IO.Error (try, isAlreadyExistsError) +#if __GLASGOW_HASKELL__ >= 611 +import System.Posix.Internals (withFilePath) +#else +import Foreign.C (withCString) +#endif +import Foreign.C (CInt) +#if __GLASGOW_HASKELL__ >= 611 +import GHC.IO.Handle.FD (fdToHandle) +#else +import GHC.Handle (fdToHandle) +#endif +#endif +import Foreign.C (getErrno, errnoToIOError) + +#if __NHC__ +import System.Posix.Types (CPid(..)) +foreign import ccall unsafe "getpid" c_getpid :: IO CPid +#else +import System.Posix.Internals (c_getpid) +#endif + +#ifdef mingw32_HOST_OS +import System.Directory ( createDirectory ) +#else +import qualified System.Posix +#endif + +#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610)) +#define NEW_EXCEPTION +#endif + +import qualified Control.Exception as Exception + +onException :: IO a -> IO b -> IO a +#ifdef NEW_EXCEPTION +onException = Exception.onException +#else +onException io what = io `Exception.catch` \e -> do what + Exception.throw e +#endif + +-- ------------------------------------------------------------ +-- * temporary files +-- ------------------------------------------------------------ + +-- This is here for Haskell implementations that do not come with +-- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9. +-- TODO: Not sure about jhc + +#if __NHC__ || __HUGS__ +-- use a temporary filename that doesn't already exist. +-- NB. *not* secure (we don't atomically lock the tmp file we get) +openTempFile :: FilePath -> String -> IO (FilePath, Handle) +openTempFile tmp_dir template + = do x <- getProcessID + findTempName x + where + (templateBase, templateExt) = splitExtension template + findTempName :: Int -> IO (FilePath, Handle) + findTempName x + = do let path = tmp_dir (templateBase ++ "-" ++ show x) <.> templateExt + b <- doesFileExist path + if b then findTempName (x+1) + else do hnd <- openFile path ReadWriteMode + return (path, hnd) + +openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle) +openBinaryTempFile tmp_dir template + = do x <- getProcessID + findTempName x + where + (templateBase, templateExt) = splitExtension template + findTempName :: Int -> IO (FilePath, Handle) + findTempName x + = do let path = tmp_dir (templateBase ++ show x) <.> templateExt + b <- doesFileExist path + if b then findTempName (x+1) + else do hnd <- openBinaryFile path ReadWriteMode + return (path, hnd) + +openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) +openNewBinaryFile = openBinaryTempFile + +getProcessID :: IO Int +getProcessID = fmap fromIntegral c_getpid +#else +-- This is a copy/paste of the openBinaryTempFile definition, but +-- if uses 666 rather than 600 for the permissions. The base library +-- needs to be changed to make this better. +openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) +openNewBinaryFile dir template = do + pid <- c_getpid + findTempName pid + where + -- We split off the last extension, so we can use .foo.ext files + -- for temporary files (hidden on Unix OSes). Unfortunately we're + -- below filepath in the hierarchy here. + (prefix,suffix) = + case break (== '.') $ reverse template of + -- First case: template contains no '.'s. Just re-reverse it. + (rev_suffix, "") -> (reverse rev_suffix, "") + -- Second case: template contains at least one '.'. Strip the + -- dot from the prefix and prepend it to the suffix (if we don't + -- do this, the unique number will get added after the '.' and + -- thus be part of the extension, which is wrong.) + (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) + -- Otherwise, something is wrong, because (break (== '.')) should + -- always return a pair with either the empty string or a string + -- beginning with '.' as the second component. + _ -> error "bug in System.IO.openTempFile" + + oflags = rw_flags .|. o_EXCL .|. o_BINARY + +#if __GLASGOW_HASKELL__ < 611 + withFilePath = withCString +#endif + + findTempName x = do + fd <- withFilePath filepath $ \ f -> + c_open f oflags 0o666 + if fd < 0 + then do + errno <- getErrno + if errno == eEXIST + then findTempName (x+1) + else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) + else do + -- TODO: We want to tell fdToHandle what the filepath is, + -- as any exceptions etc will only be able to report the + -- fd currently + h <- +#if __GLASGOW_HASKELL__ >= 609 + fdToHandle fd +#elif __GLASGOW_HASKELL__ <= 606 && defined(mingw32_HOST_OS) + -- fdToHandle is borked on Windows with ghc-6.6.x + openFd (fromIntegral fd) Nothing False filepath + ReadWriteMode True +#else + fdToHandle (fromIntegral fd) +#endif + `onException` c_close fd + return (filepath, h) + where + filename = prefix ++ show x ++ suffix + filepath = dir `combine` filename + + -- FIXME: bits copied from System.FilePath + combine a b + | null b = a + | null a = b + | last a == pathSeparator = a ++ b + | otherwise = a ++ [pathSeparator] ++ b + +-- FIXME: Should use filepath library +pathSeparator :: Char +#ifdef mingw32_HOST_OS +pathSeparator = '\\' +#else +pathSeparator = '/' +#endif + +-- FIXME: Copied from GHC.Handle +std_flags, output_flags, rw_flags :: CInt +std_flags = o_NONBLOCK .|. o_NOCTTY +output_flags = std_flags .|. o_CREAT +rw_flags = output_flags .|. o_RDWR +#endif + +createTempDirectory :: FilePath -> String -> IO FilePath +createTempDirectory dir template = do + pid <- c_getpid + findTempName pid + where + findTempName x = do + let dirpath = dir template ++ show x + r <- try $ mkPrivateDir dirpath + case r of + Right _ -> return dirpath + Left e | isAlreadyExistsError e -> findTempName (x+1) + | otherwise -> ioError e + +mkPrivateDir :: String -> IO () +#ifdef mingw32_HOST_OS +mkPrivateDir s = createDirectory s +#else +mkPrivateDir s = System.Posix.createDirectory s 0o700 +#endif diff --git a/src/Scion/PersistentBrowser/ToDb.hs b/src/Scion/PersistentBrowser/ToDb.hs --- a/src/Scion/PersistentBrowser/ToDb.hs +++ b/src/Scion/PersistentBrowser/ToDb.hs @@ -1,142 +1,142 @@ -{-# 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 = - 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 (pkgId, _) <- selectFirst [ DbPackageName ==. name, DbPackageVersion ==. showVersion version ] [] - deletePackage pkgId - --- deletePackage :: PersistBackend backend m => DbPackageId -> backend m () -deletePackage pkgId = - do modules <- selectList [ DbModulePackageId ==. pkgId ] [] - mapM_ (\(moduleId, _) -> deleteModule moduleId) modules - delete pkgId - --- deleteModule :: PersistBackend backend m => DbModuleId -> backend m () -deleteModule moduleId = - do decls <- selectList [ DbDeclModuleId ==. moduleId ] [] - mapM_ (\(declId, _) -> deleteDecl declId) 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 = + 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 (pkgId, _) <- selectFirst [ DbPackageName ==. name, DbPackageVersion ==. showVersion version ] [] + deletePackage pkgId + +-- deletePackage :: PersistBackend backend m => DbPackageId -> backend m () +deletePackage pkgId = + do modules <- selectList [ DbModulePackageId ==. pkgId ] [] + mapM_ (\(moduleId, _) -> deleteModule moduleId) modules + delete pkgId + +-- deleteModule :: PersistBackend backend m => DbModuleId -> backend m () +deleteModule moduleId = + do decls <- selectList [ DbDeclModuleId ==. moduleId ] [] + mapM_ (\(declId, _) -> deleteDecl declId) 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 _) = [] + diff --git a/src/Scion/PersistentBrowser/Types.hs b/src/Scion/PersistentBrowser/Types.hs --- a/src/Scion/PersistentBrowser/Types.hs +++ b/src/Scion/PersistentBrowser/Types.hs @@ -1,90 +1,90 @@ -{-# 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 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 + diff --git a/src/Scion/PersistentBrowser/Util.hs b/src/Scion/PersistentBrowser/Util.hs --- a/src/Scion/PersistentBrowser/Util.hs +++ b/src/Scion/PersistentBrowser/Util.hs @@ -1,46 +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 - +{-# 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) + diff --git a/src/Scion/PersistentHoogle.hs b/src/Scion/PersistentHoogle.hs --- a/src/Scion/PersistentHoogle.hs +++ b/src/Scion/PersistentHoogle.hs @@ -1,49 +1,49 @@ -module Scion.PersistentHoogle -( query -, downloadData -, checkDatabase -, module Scion.PersistentHoogle.Types -) where - -import Control.Monad -import Control.Monad.IO.Class (liftIO) -import Database.Persist.Sqlite -import Scion.PersistentBrowser () -import Scion.PersistentHoogle.Types -import Scion.PersistentHoogle.Instances.Json () -import Scion.PersistentHoogle.Parser -import Scion.PersistentHoogle.Util -import System.Exit (ExitCode(..)) -import System.Process -import Text.Parsec.Prim (runP) - -query :: Maybe String -> String -> SqlPersist IO [Result] -query p q = do mpath <- liftIO $ findHoogleBinPath p - case mpath of - Nothing -> return [] - Just path -> do (exitCode, output, err) <- liftIO $ readProcessWithExitCode path [q] "" - case exitCode of - ExitSuccess -> do let search = runP hoogleElements () "hoogle-output" (output) - case search of - Right result -> do dbResult <- result - return dbResult - Left _ -> return [] - _ -> do liftIO $ putStrLn err - return [] - -downloadData :: Maybe String -> IO Bool -downloadData p = do mpath <- findHoogleBinPath p - case mpath of - Nothing -> return False - Just path -> do putStrLn "Running hoogle data..." - (ec, _, err) <- readProcessWithExitCode path ["data"] "" - when (ec/= ExitSuccess) (putStrLn err) - return (ec == ExitSuccess) - -checkDatabase :: Maybe String -> IO Bool -checkDatabase p = do mpath <- findHoogleBinPath p - case mpath of - Nothing -> return False - Just path -> do (exitCode, _, _) <- readProcessWithExitCode path ["fmap"] "" - return (exitCode == ExitSuccess) - +module Scion.PersistentHoogle +( query +, downloadData +, checkDatabase +, module Scion.PersistentHoogle.Types +) where + +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Database.Persist.Sqlite +import Scion.PersistentBrowser () +import Scion.PersistentHoogle.Types +import Scion.PersistentHoogle.Instances.Json () +import Scion.PersistentHoogle.Parser +import Scion.PersistentHoogle.Util +import System.Exit (ExitCode(..)) +import System.Process +import Text.Parsec.Prim (runP) + +query :: Maybe String -> String -> SqlPersist IO [Result] +query p q = do mpath <- liftIO $ findHoogleBinPath p + case mpath of + Nothing -> return [] + Just path -> do (exitCode, output, err) <- liftIO $ readProcessWithExitCode path [q] "" + case exitCode of + ExitSuccess -> do let search = runP hoogleElements () "hoogle-output" (output) + case search of + Right result -> do dbResult <- result + return dbResult + Left _ -> return [] + _ -> do liftIO $ putStrLn err + return [] + +downloadData :: Maybe String -> IO Bool +downloadData p = do mpath <- findHoogleBinPath p + case mpath of + Nothing -> return False + Just path -> do putStrLn "Running hoogle data..." + (ec, _, err) <- readProcessWithExitCode path ["data"] "" + when (ec/= ExitSuccess) (putStrLn err) + return (ec == ExitSuccess) + +checkDatabase :: Maybe String -> IO Bool +checkDatabase p = do mpath <- findHoogleBinPath p + case mpath of + Nothing -> return False + Just path -> do (exitCode, _, _) <- readProcessWithExitCode path ["fmap"] "" + return (exitCode == ExitSuccess) + diff --git a/src/Scion/PersistentHoogle/Instances/Json.hs b/src/Scion/PersistentHoogle/Instances/Json.hs --- a/src/Scion/PersistentHoogle/Instances/Json.hs +++ b/src/Scion/PersistentHoogle/Instances/Json.hs @@ -1,31 +1,31 @@ -{-# 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 - ] - -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 + ] + +instance FromJSON (Query) where + parseJSON q = Query <$> parseJSON q + diff --git a/src/Scion/PersistentHoogle/Parser.hs b/src/Scion/PersistentHoogle/Parser.hs --- a/src/Scion/PersistentHoogle/Parser.hs +++ b/src/Scion/PersistentHoogle/Parser.hs @@ -1,151 +1,152 @@ -{-# LANGUAGE RankNTypes, ImpredicativeTypes, ScopedTypeVariables #-} - -module Scion.PersistentHoogle.Parser where - -import Data.List (intercalate) -import qualified Data.Text as T -import Database.Persist -import Database.Persist.Base -import Database.Persist.Sqlite -import Language.Haskell.Exts.Annotated.Syntax -import Scion.PersistentBrowser.DbTypes -import Scion.PersistentBrowser.Parser.Internal -import Scion.PersistentBrowser.Query -import Scion.PersistentBrowser.Types -import Scion.PersistentHoogle.Types -import Text.Parsec.Char -import Text.Parsec.Combinator -import Text.Parsec.Prim - -data HalfResult = HalfPackage String - | HalfModule String (Documented Module) - | HalfDecl String (Documented Decl) - | HalfGadtDecl String (Documented GadtDecl) - -hoogleElements :: BSParser (SqlPersist IO [Result]) -hoogleElements = do elts <- hoogleElements' - let results = catMaybesM $ map convertHalfToResult elts - return results - -catMaybesM :: Monad m => [m (Maybe a)] -> m [a] -catMaybesM [] = return [] -catMaybesM (x:xs) = do y <- x - zs <- catMaybesM xs - case y of - Nothing -> return zs - Just z -> return (z:zs) - -hoogleElements' :: BSParser [HalfResult] -hoogleElements' = try (do spaces0 - eof - return []) - <|> (do first <- hoogleElement - rest <- many $ try (try eol >> try hoogleElement) - spaces - eof - return $ first:rest) - -hoogleElement :: BSParser HalfResult -hoogleElement = try (do pname <- hooglePackageName - return $ HalfPackage pname) - <|> try (do (mname, m) <- moduled (module_ NoDoc) - return $ HalfModule mname m) - <|> try (do (mname, d) <- moduled (function NoDoc) - return $ HalfDecl mname d) - <|> try (do (mname, d) <- moduled (dataHead NoDoc) - return $ HalfDecl mname d) - <|> try (do (mname, d) <- moduled (newtypeHead NoDoc) - return $ HalfDecl mname d) - <|> try (do (mname, d) <- moduled (type_ NoDoc) - return $ HalfDecl mname d) - <|> try (do (mname, d) <- moduled (class_ NoDoc) - return $ HalfDecl mname d) - <|> try (do (mname, d) <- moduled (constructor NoDoc) - return $ HalfGadtDecl mname d) - -moduled :: BSParser a -> BSParser (String, a) -moduled p = try (do mname <- try conid `sepBy` char '.' - let name = intercalate "." (map getid mname) - try spaces1 - rest <- p - return (name, rest)) - -hooglePackageName :: BSParser String -hooglePackageName = do string "package" - spaces1 - name <- restOfLine - spaces0 - return name - -convertHalfToResult :: HalfResult -> SqlPersist IO (Maybe Result) -convertHalfToResult (HalfPackage pname) = - do pkgs <- packagesByName pname Nothing - case pkgs of - [] -> return Nothing - p -> return $ Just (RPackage p) -convertHalfToResult (HalfModule mname _) = - do let sql = "SELECT DbModule.name, DbModule.doc, DbModule.packageId, DbPackage.name, DbPackage.version" - ++ " FROM DbModule, DbPackage" - ++ " WHERE DbModule.packageId = DbPackage.id" - ++ " AND DbModule.name = '" ++ mname ++ "'" - mods <- queryDb sql action - return $ if null mods then Nothing else Just (RModule mods) - where action [PersistText modName, modDoc, pkgId@(PersistInt64 _), PersistText pkgName, PersistText pkgVersion] = - ( DbPackageIdentifier (T.unpack pkgName) (T.unpack pkgVersion) - , DbModule (T.unpack modName) (fromDbText modDoc) (Key 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" - ++ ", DbPackage.name, DbPackage.version" - ++ " FROM DbDecl, DbModule, DbPackage" - ++ " WHERE DbDecl.moduleId = DbModule.id" - ++ " AND DbModule.packageId = DbPackage.id" - ++ " AND DbDecl.name = '" ++ (getName dcl) ++ "'" - ++ " AND DbModule.name = '" ++ mname ++ "'" - decls <- queryDb sql action - 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 _) - , PersistText pkgName, PersistText pkgVersion ] = - let (innerDclKey :: DbDeclId) = Key declId - innerDcl = DbDecl (read (T.unpack declType)) (T.unpack declName) (fromDbText declDoc) - (fromDbText declKind) (fromDbText declSignature) (fromDbText declEquals) - (Key modId) - in ( DbPackageIdentifier (T.unpack pkgName) (T.unpack pkgVersion) - , mname - , innerDclKey - , innerDcl - ) - action _ = error "This should not happen" -convertHalfToResult (HalfGadtDecl mname dcl) = - do let sql = "SELECT DbConstructor.name, DbConstructor.signature" - ++ ", DbDecl.id, DbDecl.declType, DbDecl.name, DbDecl.doc, DbDecl.kind, DbDecl.signature, DbDecl.equals, DbDecl.moduleId" - ++ ", DbPackage.name, DbPackage.version" - ++ " FROM DbConstructor, DbDecl, DbModule, DbPackage" - ++ " WHERE DbConstructor.declId = DbDecl.id" - ++ " AND DbDecl.moduleId = DbModule.id" - ++ " AND DbModule.packageId = DbPackage.id" - ++ " AND DbDecl.name = '" ++ (getName dcl) ++ "'" - ++ " AND DbModule.name = '" ++ mname ++ "'" - decls <- queryDb sql action - completeDecls <- mapM (\(pkgId, modName, dclKey, dclInfo, cst) -> do complete <- getAllDeclInfo (dclKey, dclInfo) - 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 _) - , PersistText pkgName, PersistText pkgVersion ] = - let (innerDclKey :: DbDeclId) = Key declId - innerDcl = DbDecl (read (T.unpack declType)) (T.unpack declName) (fromDbText declDoc) - (fromDbText declKind) (fromDbText declSignature) (fromDbText declEquals) - (Key modId) - in ( DbPackageIdentifier (T.unpack pkgName) (T.unpack pkgVersion) - , mname - , innerDclKey - , innerDcl - , DbConstructor (T.unpack constName) (T.unpack constSignature) (Key declId) - ) - action _ = error "This should not happen" - +{-# LANGUAGE RankNTypes, ImpredicativeTypes, ScopedTypeVariables #-} + +module Scion.PersistentHoogle.Parser where + +import Data.List (intercalate) +import qualified Data.Text as T +import Database.Persist +import Database.Persist.Base +import Database.Persist.Sqlite +import Language.Haskell.Exts.Annotated.Syntax +import Scion.PersistentBrowser.DbTypes +import Scion.PersistentBrowser.Parser.Internal +import Scion.PersistentBrowser.Query +import Scion.PersistentBrowser.Types +import Scion.PersistentBrowser.Util (escapeSql) +import Scion.PersistentHoogle.Types +import Text.Parsec.Char +import Text.Parsec.Combinator +import Text.Parsec.Prim + +data HalfResult = HalfPackage String + | HalfModule String (Documented Module) + | HalfDecl String (Documented Decl) + | HalfGadtDecl String (Documented GadtDecl) + +hoogleElements :: BSParser (SqlPersist IO [Result]) +hoogleElements = do elts <- hoogleElements' + let results = catMaybesM $ map convertHalfToResult elts + return results + +catMaybesM :: Monad m => [m (Maybe a)] -> m [a] +catMaybesM [] = return [] +catMaybesM (x:xs) = do y <- x + zs <- catMaybesM xs + case y of + Nothing -> return zs + Just z -> return (z:zs) + +hoogleElements' :: BSParser [HalfResult] +hoogleElements' = try (do spaces0 + eof + return []) + <|> (do first <- hoogleElement + rest <- many $ try (try eol >> try hoogleElement) + spaces + eof + return $ first:rest) + +hoogleElement :: BSParser HalfResult +hoogleElement = try (do pname <- hooglePackageName + return $ HalfPackage pname) + <|> try (do (mname, m) <- moduled (module_ NoDoc) + return $ HalfModule mname m) + <|> try (do (mname, d) <- moduled (function NoDoc) + return $ HalfDecl mname d) + <|> try (do (mname, d) <- moduled (dataHead NoDoc) + return $ HalfDecl mname d) + <|> try (do (mname, d) <- moduled (newtypeHead NoDoc) + return $ HalfDecl mname d) + <|> try (do (mname, d) <- moduled (type_ NoDoc) + return $ HalfDecl mname d) + <|> try (do (mname, d) <- moduled (class_ NoDoc) + return $ HalfDecl mname d) + <|> try (do (mname, d) <- moduled (constructor NoDoc) + return $ HalfGadtDecl mname d) + +moduled :: BSParser a -> BSParser (String, a) +moduled p = try (do mname <- try conid `sepBy` char '.' + let name = intercalate "." (map getid mname) + try spaces1 + rest <- p + return (name, rest)) + +hooglePackageName :: BSParser String +hooglePackageName = do string "package" + spaces1 + name <- restOfLine + spaces0 + return name + +convertHalfToResult :: HalfResult -> SqlPersist IO (Maybe Result) +convertHalfToResult (HalfPackage pname) = + do pkgs <- packagesByName pname Nothing + case pkgs of + [] -> return Nothing + p -> return $ Just (RPackage p) +convertHalfToResult (HalfModule mname _) = + do let sql = "SELECT DbModule.name, DbModule.doc, DbModule.packageId, DbPackage.name, DbPackage.version" + ++ " FROM DbModule, DbPackage" + ++ " WHERE DbModule.packageId = DbPackage.id" + ++ " AND DbModule.name = '" ++ (escapeSql mname) ++ "'" + mods <- queryDb sql action + return $ if null mods then Nothing else Just (RModule mods) + where action [PersistText modName, modDoc, pkgId@(PersistInt64 _), PersistText pkgName, PersistText pkgVersion] = + ( DbPackageIdentifier (T.unpack pkgName) (T.unpack pkgVersion) + , DbModule (T.unpack modName) (fromDbText modDoc) (Key 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" + ++ ", DbPackage.name, DbPackage.version" + ++ " FROM DbDecl, DbModule, DbPackage" + ++ " WHERE DbDecl.moduleId = DbModule.id" + ++ " AND DbModule.packageId = DbPackage.id" + ++ " AND DbDecl.name = '" ++ (escapeSql (getName dcl)) ++ "'" + ++ " AND DbModule.name = '" ++ (escapeSql mname) ++ "'" + decls <- queryDb sql action + 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 _) + , PersistText pkgName, PersistText pkgVersion ] = + let (innerDclKey :: DbDeclId) = Key declId + innerDcl = DbDecl (read (T.unpack declType)) (T.unpack declName) (fromDbText declDoc) + (fromDbText declKind) (fromDbText declSignature) (fromDbText declEquals) + (Key modId) + in ( DbPackageIdentifier (T.unpack pkgName) (T.unpack pkgVersion) + , mname + , innerDclKey + , innerDcl + ) + action _ = error "This should not happen" +convertHalfToResult (HalfGadtDecl mname dcl) = + do let sql = "SELECT DbConstructor.name, DbConstructor.signature" + ++ ", DbDecl.id, DbDecl.declType, DbDecl.name, DbDecl.doc, DbDecl.kind, DbDecl.signature, DbDecl.equals, DbDecl.moduleId" + ++ ", DbPackage.name, DbPackage.version" + ++ " FROM DbConstructor, DbDecl, DbModule, DbPackage" + ++ " WHERE DbConstructor.declId = DbDecl.id" + ++ " AND DbDecl.moduleId = DbModule.id" + ++ " AND DbModule.packageId = DbPackage.id" + ++ " AND DbDecl.name = '" ++ (escapeSql (getName dcl)) ++ "'" + ++ " AND DbModule.name = '" ++ (escapeSql mname) ++ "'" + decls <- queryDb sql action + completeDecls <- mapM (\(pkgId, modName, dclKey, dclInfo, cst) -> do complete <- getAllDeclInfo (dclKey, dclInfo) + 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 _) + , PersistText pkgName, PersistText pkgVersion ] = + let (innerDclKey :: DbDeclId) = Key declId + innerDcl = DbDecl (read (T.unpack declType)) (T.unpack declName) (fromDbText declDoc) + (fromDbText declKind) (fromDbText declSignature) (fromDbText declEquals) + (Key modId) + in ( DbPackageIdentifier (T.unpack pkgName) (T.unpack pkgVersion) + , mname + , innerDclKey + , innerDcl + , DbConstructor (T.unpack constName) (T.unpack constSignature) (Key declId) + ) + action _ = error "This should not happen" + diff --git a/src/Scion/PersistentHoogle/Types.hs b/src/Scion/PersistentHoogle/Types.hs --- a/src/Scion/PersistentHoogle/Types.hs +++ b/src/Scion/PersistentHoogle/Types.hs @@ -1,13 +1,13 @@ -module Scion.PersistentHoogle.Types where - -import Scion.PersistentBrowser.DbTypes - -type Results = [Result] - -data Result = RPackage [DbPackage] - | RModule [(DbPackageIdentifier, DbModule)] - | RDeclaration [(DbPackageIdentifier, String, DbCompleteDecl)] - | RConstructor [(DbPackageIdentifier, String, DbCompleteDecl, DbConstructor)] - -data Query = Query String - +module Scion.PersistentHoogle.Types where + +import Scion.PersistentBrowser.DbTypes + +type Results = [Result] + +data Result = RPackage [DbPackage] + | RModule [(DbPackageIdentifier, DbModule)] + | RDeclaration [(DbPackageIdentifier, String, DbCompleteDecl)] + | RConstructor [(DbPackageIdentifier, String, DbCompleteDecl, DbConstructor)] + +data Query = Query String + diff --git a/src/Scion/PersistentHoogle/Util.hs b/src/Scion/PersistentHoogle/Util.hs --- a/src/Scion/PersistentHoogle/Util.hs +++ b/src/Scion/PersistentHoogle/Util.hs @@ -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" +-} diff --git a/src/Server/PersistentCommands.hs b/src/Server/PersistentCommands.hs --- a/src/Server/PersistentCommands.hs +++ b/src/Server/PersistentCommands.hs @@ -1,157 +1,157 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Server.PersistentCommands where - -import Control.Applicative -import Control.Monad -import Control.Monad.State -import Data.Aeson -import qualified Data.HashMap.Lazy as M -import Data.Maybe (isJust, fromJust) -import qualified Data.Text as T -import Database.Persist.Sqlite hiding (get) -import Scion.PersistentBrowser -import Scion.PersistentBrowser.Build -import Scion.PersistentBrowser.Query -import Scion.PersistentBrowser.Util (logToStdout) -import qualified Scion.PersistentHoogle as H -import Scion.Packages -import System.Directory - -data Command = LoadLocalDatabase FilePath Bool - | LoadHackageDatabase FilePath Bool - | GetPackages - | SetCurrentDatabase CurrentDatabase - | GetModules String - | GetDeclarations String - | HoogleQuery String - | HoogleDownloadData - | HoogleCheckDatabase - | GetDeclarationModules String - | SetExtraHooglePath String - | Quit - -data CurrentDatabase = AllPackages - | HackageDatabase - | LocalDatabase - | APackage DbPackageIdentifier - -data BrowserState = BrowserState - { localDb :: Maybe FilePath - , hackageDb :: Maybe FilePath - , useLocal :: Bool - , useHackage :: Bool - , filterPackage :: Maybe DbPackageIdentifier - , extraHooglePath :: Maybe String - } - -initialState :: BrowserState -initialState = BrowserState Nothing Nothing True True Nothing Nothing - -runWithState :: BrowserState -> (Maybe DbPackageIdentifier -> SqlPersist IO [a]) -> IO [a] -runWithState (BrowserState lDb hDb useL useH filterPkg _) action = - do localThings <- runWithState' useL lDb (action filterPkg) - hackageThings <- runWithState' useH hDb (action filterPkg) - return $ localThings ++ hackageThings - -runWithState' :: Bool -> Maybe FilePath -> SqlPersist IO [a] -> IO [a] -runWithState' use mpath action = if use && isJust mpath - then do let path = fromJust mpath - withSqliteConn (T.pack path) $ runSqlConn action - else return [] - -runDb :: (Maybe DbPackageIdentifier -> SqlPersist IO [a]) -> BrowserM [a] -runDb action = do st <- get - lift $ runWithState st action - -type BrowserM = StateT BrowserState IO - -executeCommand :: Command -> BrowserM (Value, Bool) -- Bool indicates if continue receiving commands -executeCommand (LoadLocalDatabase path rebuild) = - do fileExists <- lift $ doesFileExist path - let fileExists' = fileExists `seq` fileExists - when rebuild $ - lift $ do withSqliteConn (T.pack path) $ runSqlConn $ runMigration migrateAll - pkgInfos' <- getPkgInfos - let pkgInfos = concat $ map snd pkgInfos' - updateDatabase path pkgInfos - if fileExists' || rebuild -- If the file already existed or was rebuilt - then do modify (\s -> s { localDb = Just path }) - lift $ logToStdout "Local database loaded" - else modify (\s -> s { hackageDb = Nothing }) - executeCommand (SetCurrentDatabase LocalDatabase) -executeCommand (LoadHackageDatabase path rebuild) = - do fileExists <- lift $ doesFileExist path - let fileExists' = fileExists `seq` fileExists - when (not fileExists' || rebuild) $ - lift $ do when fileExists' (removeFile path) - logToStdout "Rebuilding Hackage database" - withSqliteConn (T.pack path) $ runSqlConn $ runMigration migrateAll - saveHackageDatabase path - if fileExists' || rebuild -- If the file already existed or was rebuilt - then do modify (\s -> s { hackageDb = Just path }) - lift $ logToStdout "Hackage database loaded" - else modify (\s -> s { hackageDb = Nothing }) - executeCommand (SetCurrentDatabase HackageDatabase) -executeCommand (SetCurrentDatabase db) = - do case db of - AllPackages -> do modify (\s -> s { useLocal = True, useHackage = True, filterPackage = Nothing }) - return (String "ok", True) - LocalDatabase -> do modify (\s -> s { useLocal = True, useHackage = False, filterPackage = Nothing }) - return (String "ok", True) - HackageDatabase -> do modify (\s -> s { useLocal = False, useHackage = True, filterPackage = Nothing }) - return (String "ok", True) - APackage pid -> do modify (\s -> s { useLocal = True, useHackage = True, filterPackage = Just pid }) - return (String "ok", True) -executeCommand GetPackages = do pkgs <- runDb allPackages - return (toJSON pkgs, True) -executeCommand (GetModules mname) = do smods <- runDb (getSubmodules mname) - return (toJSON smods, True) -executeCommand (GetDeclarations mname) = do decls <- runDb (getDeclsInModule mname) - return (toJSON decls, True) -executeCommand (HoogleQuery query) = do extraH <- fmap extraHooglePath get - results <- runDb (\_ -> H.query extraH query) - return (toJSON results, True) -executeCommand HoogleDownloadData = do extraH <- fmap extraHooglePath get - _ <- lift $ H.downloadData extraH - return (String "ok", True) -executeCommand HoogleCheckDatabase = do extraH <- fmap extraHooglePath get - present <- lift $ H.checkDatabase extraH - return (Bool present, True) -executeCommand (SetExtraHooglePath p) = do modify (\s -> s { extraHooglePath = Just p }) - return (String "ok", True) -executeCommand (GetDeclarationModules d) = do mods <- runDb (\_ -> getModulesWhereDeclarationIs d) - return (toJSON mods, True) -executeCommand Quit = return (String "ok", False) - - -instance FromJSON Command where - parseJSON (Object v) = case M.lookup (T.pack "command") v of - Just (String e) -> - case T.unpack e of - "load-local-db" -> LoadLocalDatabase <$> v .: "filepath" - <*> v .: "rebuild" - "load-hackage-db" -> LoadHackageDatabase <$> v .: "filepath" - <*> v .: "rebuild" - "get-packages" -> pure GetPackages - "set-current-db" -> SetCurrentDatabase <$> v .: "new-db" - "get-modules" -> GetModules <$> v .: "module" - "get-declarations" -> GetDeclarations <$> v .: "module" - "hoogle-query" -> HoogleQuery <$> v .: "query" - "hoogle-data" -> pure HoogleDownloadData - "hoogle-check" -> pure HoogleCheckDatabase - "extra-hoogle-path" -> SetExtraHooglePath <$> v .: "path" - "get-decl-module" -> GetDeclarationModules <$> v .: "decl" - "quit" -> pure Quit - _ -> mzero - _ -> mzero - parseJSON _ = mzero - -instance FromJSON CurrentDatabase where - parseJSON (String new) = case T.unpack new of - "_all" -> pure AllPackages - "_hackage" -> pure HackageDatabase - "_local" -> pure LocalDatabase - _ -> mzero - parseJSON other = APackage <$> parseJSON other - +{-# LANGUAGE OverloadedStrings #-} + +module Server.PersistentCommands where + +import Control.Applicative +import Control.Monad +import Control.Monad.State +import Data.Aeson +import qualified Data.HashMap.Lazy as M +import Data.Maybe (isJust, fromJust) +import qualified Data.Text as T +import Database.Persist.Sqlite hiding (get) +import Scion.PersistentBrowser +import Scion.PersistentBrowser.Build +import Scion.PersistentBrowser.Query +import Scion.PersistentBrowser.Util (logToStdout) +import qualified Scion.PersistentHoogle as H +import Scion.Packages +import System.Directory + +data Command = LoadLocalDatabase FilePath Bool + | LoadHackageDatabase FilePath Bool + | GetPackages + | SetCurrentDatabase CurrentDatabase + | GetModules String + | GetDeclarations String + | HoogleQuery String + | HoogleDownloadData + | HoogleCheckDatabase + | GetDeclarationModules String + | SetExtraHooglePath String + | Quit + +data CurrentDatabase = AllPackages + | HackageDatabase + | LocalDatabase + | APackage DbPackageIdentifier + +data BrowserState = BrowserState + { localDb :: Maybe FilePath + , hackageDb :: Maybe FilePath + , useLocal :: Bool + , useHackage :: Bool + , filterPackage :: Maybe DbPackageIdentifier + , extraHooglePath :: Maybe String + } + +initialState :: BrowserState +initialState = BrowserState Nothing Nothing True True Nothing Nothing + +runWithState :: BrowserState -> (Maybe DbPackageIdentifier -> SqlPersist IO [a]) -> IO [a] +runWithState (BrowserState lDb hDb useL useH filterPkg _) action = + do localThings <- runWithState' useL lDb (action filterPkg) + hackageThings <- runWithState' useH hDb (action filterPkg) + return $ localThings ++ hackageThings + +runWithState' :: Bool -> Maybe FilePath -> SqlPersist IO [a] -> IO [a] +runWithState' use mpath action = if use && isJust mpath + then do let path = fromJust mpath + withSqliteConn (T.pack path) $ runSqlConn action + else return [] + +runDb :: (Maybe DbPackageIdentifier -> SqlPersist IO [a]) -> BrowserM [a] +runDb action = do st <- get + lift $ runWithState st action + +type BrowserM = StateT BrowserState IO + +executeCommand :: Command -> BrowserM (Value, Bool) -- Bool indicates if continue receiving commands +executeCommand (LoadLocalDatabase path rebuild) = + do fileExists <- lift $ doesFileExist path + let fileExists' = fileExists `seq` fileExists + when rebuild $ + lift $ do withSqliteConn (T.pack path) $ runSqlConn $ runMigration migrateAll + pkgInfos' <- getPkgInfos + let pkgInfos = concat $ map snd pkgInfos' + updateDatabase path pkgInfos + if fileExists' || rebuild -- If the file already existed or was rebuilt + then do modify (\s -> s { localDb = Just path }) + lift $ logToStdout "Local database loaded" + else modify (\s -> s { hackageDb = Nothing }) + executeCommand (SetCurrentDatabase LocalDatabase) +executeCommand (LoadHackageDatabase path rebuild) = + do fileExists <- lift $ doesFileExist path + let fileExists' = fileExists `seq` fileExists + when (not fileExists' || rebuild) $ + lift $ do when fileExists' (removeFile path) + logToStdout "Rebuilding Hackage database" + withSqliteConn (T.pack path) $ runSqlConn $ runMigration migrateAll + saveHackageDatabase path + if fileExists' || rebuild -- If the file already existed or was rebuilt + then do modify (\s -> s { hackageDb = Just path }) + lift $ logToStdout "Hackage database loaded" + else modify (\s -> s { hackageDb = Nothing }) + executeCommand (SetCurrentDatabase HackageDatabase) +executeCommand (SetCurrentDatabase db) = + do case db of + AllPackages -> do modify (\s -> s { useLocal = True, useHackage = True, filterPackage = Nothing }) + return (String "ok", True) + LocalDatabase -> do modify (\s -> s { useLocal = True, useHackage = False, filterPackage = Nothing }) + return (String "ok", True) + HackageDatabase -> do modify (\s -> s { useLocal = False, useHackage = True, filterPackage = Nothing }) + return (String "ok", True) + APackage pid -> do modify (\s -> s { useLocal = True, useHackage = True, filterPackage = Just pid }) + return (String "ok", True) +executeCommand GetPackages = do pkgs <- runDb allPackages + return (toJSON pkgs, True) +executeCommand (GetModules mname) = do smods <- runDb (getSubmodules mname) + return (toJSON smods, True) +executeCommand (GetDeclarations mname) = do decls <- runDb (getDeclsInModule mname) + return (toJSON decls, True) +executeCommand (HoogleQuery query) = do extraH <- fmap extraHooglePath get + results <- runDb (\_ -> H.query extraH query) + return (toJSON results, True) +executeCommand HoogleDownloadData = do extraH <- fmap extraHooglePath get + _ <- lift $ H.downloadData extraH + return (String "ok", True) +executeCommand HoogleCheckDatabase = do extraH <- fmap extraHooglePath get + present <- lift $ H.checkDatabase extraH + return (Bool present, True) +executeCommand (SetExtraHooglePath p) = do modify (\s -> s { extraHooglePath = Just p }) + return (String "ok", True) +executeCommand (GetDeclarationModules d) = do mods <- runDb (\_ -> getModulesWhereDeclarationIs d) + return (toJSON mods, True) +executeCommand Quit = return (String "ok", False) + + +instance FromJSON Command where + parseJSON (Object v) = case M.lookup (T.pack "command") v of + Just (String e) -> + case T.unpack e of + "load-local-db" -> LoadLocalDatabase <$> v .: "filepath" + <*> v .: "rebuild" + "load-hackage-db" -> LoadHackageDatabase <$> v .: "filepath" + <*> v .: "rebuild" + "get-packages" -> pure GetPackages + "set-current-db" -> SetCurrentDatabase <$> v .: "new-db" + "get-modules" -> GetModules <$> v .: "module" + "get-declarations" -> GetDeclarations <$> v .: "module" + "hoogle-query" -> HoogleQuery <$> v .: "query" + "hoogle-data" -> pure HoogleDownloadData + "hoogle-check" -> pure HoogleCheckDatabase + "extra-hoogle-path" -> SetExtraHooglePath <$> v .: "path" + "get-decl-module" -> GetDeclarationModules <$> v .: "decl" + "quit" -> pure Quit + _ -> mzero + _ -> mzero + parseJSON _ = mzero + +instance FromJSON CurrentDatabase where + parseJSON (String new) = case T.unpack new of + "_all" -> pure AllPackages + "_hackage" -> pure HackageDatabase + "_local" -> pure LocalDatabase + _ -> mzero + parseJSON other = APackage <$> parseJSON other +