scion-browser 0.2.7 → 0.2.8
raw patch · 25 files changed
+3171/−3086 lines, 25 filessetup-changed
Files
- Setup.hs +2/−2
- docs/LICENSE +29/−29
- scion-browser.cabal +237/−237
- src/Main.hs +50/−50
- src/Scion/Packages.hs +200/−200
- src/Scion/PersistentBrowser.hs +9/−9
- src/Scion/PersistentBrowser/Build.hs +224/−201
- src/Scion/PersistentBrowser/DbTypes.hs +60/−60
- src/Scion/PersistentBrowser/FileUtil.hs +101/−93
- src/Scion/PersistentBrowser/FromMissingH.hs +98/−98
- src/Scion/PersistentBrowser/Instances/Json.hs +101/−101
- src/Scion/PersistentBrowser/Parser.hs +83/−83
- src/Scion/PersistentBrowser/Parser/Documentable.hs +88/−88
- src/Scion/PersistentBrowser/Parser/Internal.hs +545/−545
- src/Scion/PersistentBrowser/Query.hs +262/−220
- src/Scion/PersistentBrowser/TempFile.hs +220/−220
- src/Scion/PersistentBrowser/ToDb.hs +143/−143
- src/Scion/PersistentBrowser/Types.hs +90/−90
- src/Scion/PersistentBrowser/Util.hs +51/−51
- src/Scion/PersistentHoogle.hs +57/−54
- src/Scion/PersistentHoogle/Instances/Json.hs +34/−34
- src/Scion/PersistentHoogle/Parser.hs +168/−165
- src/Scion/PersistentHoogle/Types.hs +14/−14
- src/Scion/PersistentHoogle/Util.hs +129/−129
- src/Server/PersistentCommands.hs +176/−170
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple +main = defaultMain
docs/LICENSE view
@@ -1,29 +1,29 @@-Copyright 2011, Alejandro Serrano-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--- Redistributions of source code must retain the above copyright notice,-this list of conditions and the following disclaimer.- -- Redistributions in binary form must reproduce the above copyright notice,-this list of conditions and the following disclaimer in the documentation-and/or other materials provided with the distribution.- -- Neither name of the author nor the names of its contributors may be-used to endorse or promote products derived from this software without-specific prior written permission. --THIS SOFTWARE IS PROVIDED BY THE AUTHOR(S) AND THE CONTRIBUTORS "AS-IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED-TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A-PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY-COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE FOR-ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE-GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS-INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER-IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR-OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF-ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+Copyright 2011, Alejandro Serrano +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the author nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR(S) AND THE CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY +COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
scion-browser.cabal view
@@ -1,237 +1,237 @@-name: scion-browser-version: 0.2.7-cabal-version: >= 1.8-build-type: Simple-license: BSD3-license-file: docs/LICENSE-author: Alejandro Serrano <trupill@gmail.com>-maintainer: Alejandro Serrano <trupill@gmail.com>-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 >= 0.7,- persistent-sqlite >= 0.7,- persistent-template >= 0.7,- conduit,- 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 >= 0.7,- persistent-sqlite >= 0.7,- persistent-template >= 0.7,- conduit,- 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 >= 0.7,--- persistent-sqlite >= 0.7,--- persistent-template >= 0.7,--- conduit,--- 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.8 +cabal-version: >= 1.8 +build-type: Simple +license: BSD3 +license-file: docs/LICENSE +author: Alejandro Serrano <trupill@gmail.com> +maintainer: Alejandro Serrano <trupill@gmail.com>, JP Moresmau (jpmoresmau@gmail.com) +homepage: http://github.com/JPMoresmau/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/JPMoresmau/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 >= 0.7, + persistent-sqlite >= 0.7, + persistent-template >= 0.7, + conduit, + 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 >= 0.7, + persistent-sqlite >= 0.7, + persistent-template >= 0.7, + conduit, + 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 >= 0.7, +-- persistent-sqlite >= 0.7, +-- persistent-template >= 0.7, +-- conduit, +-- 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) + + +
src/Main.hs view
@@ -1,50 +1,50 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}--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, stderr)-import System.Environment (getArgs)-import Data.Version (showVersion)-import Paths_scion_browser-import Scion.PersistentBrowser.Util (logToStdout)--import GHC.IO.Handle (hDuplicate,hDuplicateTo)--main :: IO ()-main = do args <- getArgs - case args of- ("--version":_) -> 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 -> (liftIO $ logToStdout ("error in command: " ++ e)) >> loop- Atto.Partial _ -> (liftIO $ logToStdout ("incomplete data error in command: ")) >> loop- Atto.Done _ value -> case T.parse parseJSON value of- Error e -> (liftIO $ logToStdout ("error in command: " ++ e)) >> loop- Success cmd -> do - stdout_excl <- liftIO $ hDuplicate stdout- liftIO $ hDuplicateTo stderr stdout -- redirect stdout to stderr- (res, continue) <- lift $ executeCommand cmd- liftIO $ hDuplicateTo stdout_excl stdout -- redirect stdout to original stdout- let encoded = LBS.append (encode res) "\n"- 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, TemplateHaskell #-} + +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.ByteString as Atto +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.ByteString.UTF8 as BSU(fromString) +import Server.PersistentCommands +import System.Console.Haskeline +import System.IO (hFlush, stdout, stderr) +import System.Environment (getArgs) +import Data.Version (showVersion) +import Paths_scion_browser +import Scion.PersistentBrowser.Util (logToStdout) + +import GHC.IO.Handle (hDuplicate,hDuplicateTo) + +main :: IO () +main = do args <- getArgs + case args of + ("--version":_) -> 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 (BSU.fromString line) of + Atto.Fail _ _ e -> (liftIO $ logToStdout ("error in command: " ++ e)) >> loop + Atto.Partial _ -> (liftIO $ logToStdout ("incomplete data error in command: ")) >> loop + Atto.Done _ value -> case T.parse parseJSON value of + Error e -> (liftIO $ logToStdout ("error in command: " ++ e)) >> loop + Success cmd -> do + stdout_excl <- liftIO $ hDuplicate stdout + liftIO $ hDuplicateTo stderr stdout -- redirect stdout to stderr + (res, continue) <- lift $ executeCommand cmd + liftIO $ hDuplicateTo stdout_excl stdout -- redirect stdout to original stdout + let encoded = LBS.append (encode res) "\n" + compressed = Zlib.compressWith Zlib.defaultCompressParams { Zlib.compressLevel = Zlib.bestSpeed } encoded + liftIO $ LBS.putStr compressed + liftIO $ hFlush stdout + if continue then loop else return () +
src/Scion/Packages.hs view
@@ -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
src/Scion/PersistentBrowser.hs view
@@ -1,9 +1,9 @@-module Scion.PersistentBrowser-( module Scion.PersistentBrowser.Types-, module Scion.PersistentBrowser.DbTypes-) where--import Scion.PersistentBrowser.Types-import Scion.PersistentBrowser.DbTypes-import Scion.PersistentBrowser.Instances.Json ()-+module Scion.PersistentBrowser +( module Scion.PersistentBrowser.Types +, module Scion.PersistentBrowser.DbTypes +) where + +import Scion.PersistentBrowser.Types +import Scion.PersistentBrowser.DbTypes +import Scion.PersistentBrowser.Instances.Json () +
src/Scion/PersistentBrowser/Build.hs view
@@ -1,201 +1,224 @@-{-# 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 . entityVal) 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 "<package>" cnts- Just cnts -> return $ parseHoogleString "<package>" 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 +import Network.Browser +import Network.HTTP +import Network.HTTP.Proxy + +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 + withSqliteConn (T.pack file) (runSqlConn (mapM_ savePackageToDb db)) + --mapM_ (\pkg -> withSqliteConn (T.pack file) (runSqlConn (savePackageToDb pkg))) db + +-- | Downloads the information for the entire Hackage database +-- 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 . entityVal) 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) + -- commented out for now (see https://github.com/haskell/HTTP/pull/26) +-- pr<-fetchProxy False + -- download everything in one browser session +-- hooglePkgs<- browse $ do +-- setErrHandler logToStdout +-- setOutHandler logToStdout +-- setMaxErrorRetries (Just 10) +-- setProxy pr +-- mapM (\pid -> do +-- db <- getCabalHoogle ghcVersion pid ifFailCreateEmpty tmp +-- return (pkgString pid, db)) pkgs +-- --eitherHooglePkgs <- withThreaded $ \pool -> parallelInterleavedE pool [toExecute] +-- let -- hooglePkgs = rights $ map snd $ eitherHooglePkgs +-- (db, errors) = partitionPackages hooglePkgs +-- return (db, errors) +-- called actions should be: BrowserAction (HandleStream String) +-- no liftIO but ioAction $ + +-- | Get the database from a Cabal package. +getCabalHoogle :: Version -> PackageIdentifier -> Bool -> FilePath -> IO(Either ParseError (Documented Package)) +getCabalHoogle ghcVersion pid ifFailCreateEmpty tmp = 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 "<package>" cnts + Just cnts -> return $ parseHoogleString "<package>" 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 +
src/Scion/PersistentBrowser/DbTypes.hs view
@@ -1,60 +1,60 @@-{-# 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- UniqueVersion name version-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 + UniqueVersion name version +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] +
src/Scion/PersistentBrowser/FileUtil.hs view
@@ -1,93 +1,101 @@-{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface #-}--module Scion.PersistentBrowser.FileUtil where--import qualified Codec.Archive.Tar as Tar-import qualified Codec.Compression.GZip as GZip-import Control.Exception (bracket)-import qualified Data.ByteString as SBS-import qualified Data.ByteString.Char8 as SBS8-import qualified Data.ByteString.Lazy as LBS-import qualified Data.ByteString.Lazy.Char8 as LBS8-import Data.List (isPrefixOf)-import Network.Browser-import Network.HTTP-import Network.HTTP.Proxy-import System.Directory-import System.FilePath-import Scion.PersistentBrowser.TempFile-import Scion.PersistentBrowser.Util (logToStdout)---- |Takes out the "." and ".." special directory--- entries from a list of file paths.-filterDots :: [FilePath] -> [FilePath]-filterDots = filter (\d -> d /= "." && d /= "..")---- |Downloads a file from the internet.-downloadFileLazy :: String -> IO (Maybe LBS.ByteString)-downloadFileLazy url = do - response <- fetchURL url- return $ Just (LBS8.pack response)---- |Downloads a file from the internet.-downloadFileStrict :: String -> IO (Maybe SBS.ByteString)-downloadFileStrict url = do - response <- fetchURL url- return $ Just (SBS8.pack response)---- |Downloads a file from the internet and check it's a Hoogle file.-downloadHoogleFile :: String -> IO (Maybe SBS.ByteString)-downloadHoogleFile url = do - response <- fetchURL url- 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 + return $ getHoogleFile response + +downloadHoogleFile' :: String -> BrowserAction (HandleStream String) (Maybe SBS.ByteString) +downloadHoogleFile' url = do + (_,res) <- request $ getRequest url + return $ getHoogleFile $ rspBody res + +getHoogleFile :: String -> Maybe SBS.ByteString +getHoogleFile response=if "-- Hoogle documentation" `isPrefixOf` response + then Just (SBS8.pack response) + else Nothing + +-- |Downloads a file from the internet, using the system proxy +fetchURL :: String -> IO (String) +fetchURL url=do + pr<-fetchProxy False + (_,res) <- browse $ do + setErrHandler logToStdout + setOutHandler logToStdout + setProxy pr + request $ getRequest url + return $ rspBody res + +-- |Un-gzip and un-tar a file into a folder. +unTarGzip :: LBS.ByteString -> FilePath -> IO () +unTarGzip cnts folder = let ungzip = GZip.decompress cnts + entries = Tar.read ungzip + in do createDirectories entries + Tar.unpack folder entries + where createDirectories Tar.Done = return () + createDirectories (Tar.Fail _) = return () + createDirectories (Tar.Next e es) = + case Tar.entryContent e of + Tar.NormalFile _ _ -> do let dir = folder </> takeDirectory (Tar.entryPath e) + createDirectoryIfMissing True dir + createDirectories es + Tar.Directory -> do let dir = folder </> Tar.entryPath e + createDirectoryIfMissing True dir + createDirectories es + _ -> createDirectories es + +-- HACK: Taken from Unixutils. +-- The version in Hackage conflicts with some of our packages. + +-- |temporarily change the working directory to |dir| while running |action| +withWorkingDirectory :: FilePath -> IO a -> IO a +withWorkingDirectory dir action = + bracket getCurrentDirectory setCurrentDirectory (\ _ -> setCurrentDirectory dir >> action) + +-- |create a temporary directory, run the action, remove the temporary directory +-- the directory will be created inside the system temporary directory (cf bug 3413186) +-- the temporary directory will be automatically removed afterwards. +-- your working directory is not altered +withTemporaryDirectory :: (FilePath -> IO a) -> IO a +withTemporaryDirectory f = + do home <- getTemporaryDirectory + bracket (createTempDirectory home ".scion") + removeDirectoryRecursive + f +
src/Scion/PersistentBrowser/FromMissingH.hs view
@@ -1,98 +1,98 @@--- |Utility functions that were first used from package MissingH.--- But MissingH does not build in 7.2.1 yet, so I included them here.-module Scion.PersistentBrowser.FromMissingH where--import Data.List (intersperse, isPrefixOf)---- From Data.List.Utils--{- | Adds the specified (key, value) pair to the given list, removing any-existing pair with the same key already present. -}-addToAL :: Eq key => [(key, elt)] -> key -> elt -> [(key, elt)]-addToAL l key value = (key, value) : delFromAL l key--{- | Removes all (key, value) pairs from the given list where the key-matches the given one. -}-delFromAL :: Eq key => [(key, a)] -> key -> [(key, a)]-delFromAL l key = filter (\a -> (fst a) /= key) l----- From Data.String.Utils--{- | Returns true if the given list starts with the specified elements;-false otherwise. (This is an alias for "Data.List.isPrefixOf".)--Example:--> startswith "He" "Hello" -> True---}--startswith :: Eq a => [a] -> [a] -> Bool-startswith = isPrefixOf--{- | Similar to Data.List.span, but performs the test on the entire remaining-list instead of just one element. --@spanList p xs@ is the same as @(takeWhileList p xs, dropWhileList p xs)@ --}-spanList :: ([a] -> Bool) -> [a] -> ([a], [a])--spanList _ [] = ([],[])-spanList func list@(x:xs) =- if func list- then (x:ys,zs)- else ([],list)- where (ys,zs) = spanList func xs--{- | Similar to Data.List.break, but performs the test on the entire remaining-list instead of just one element.--}-breakList :: ([a] -> Bool) -> [a] -> ([a], [a])-breakList func = spanList (not . func)--{- | Given a delimiter and a list (or string), split into components.--Example:--> split "," "foo,bar,,baz," -> ["foo", "bar", "", "baz", ""]--> split "ba" ",foo,bar,,baz," -> [",foo,","r,,","z,"]--}-split :: Eq a => [a] -> [a] -> [[a]]-split _ [] = []-split delim str =- let (firstline, remainder) = breakList (startswith delim) str- in - firstline : case remainder of- [] -> []- x -> if x == delim- then [] : []- else split delim - (drop (length delim) x)--{- | Given a list and a replacement list, replaces each occurance of the search-list with the replacement list in the operation list.--Example:-->replace "," "." "127,0,0,1" -> "127.0.0.1"--This could logically be thought of as:-->replace old new l = join new . split old $ l--}--replace :: Eq a => [a] -> [a] -> [a] -> [a]-replace old new l = join new . split old $ l--{- | Given a delimiter and a list of items (or strings), join the items-by using the delimiter.--Example:--> join "|" ["foo", "bar", "baz"] -> "foo|bar|baz"--}-join :: [a] -> [[a]] -> [a]-join delim l = concat (intersperse delim l)-+-- |Utility functions that were first used from package MissingH. +-- But MissingH does not build in 7.2.1 yet, so I included them here. +module Scion.PersistentBrowser.FromMissingH where + +import Data.List (intersperse, isPrefixOf) + +-- From Data.List.Utils + +{- | Adds the specified (key, value) pair to the given list, removing any +existing pair with the same key already present. -} +addToAL :: Eq key => [(key, elt)] -> key -> elt -> [(key, elt)] +addToAL l key value = (key, value) : delFromAL l key + +{- | Removes all (key, value) pairs from the given list where the key +matches the given one. -} +delFromAL :: Eq key => [(key, a)] -> key -> [(key, a)] +delFromAL l key = filter (\a -> (fst a) /= key) l + + +-- From Data.String.Utils + +{- | Returns true if the given list starts with the specified elements; +false otherwise. (This is an alias for "Data.List.isPrefixOf".) + +Example: + +> startswith "He" "Hello" -> True + +-} + +startswith :: Eq a => [a] -> [a] -> Bool +startswith = isPrefixOf + +{- | Similar to Data.List.span, but performs the test on the entire remaining +list instead of just one element. + +@spanList p xs@ is the same as @(takeWhileList p xs, dropWhileList p xs)@ +-} +spanList :: ([a] -> Bool) -> [a] -> ([a], [a]) + +spanList _ [] = ([],[]) +spanList func list@(x:xs) = + if func list + then (x:ys,zs) + else ([],list) + where (ys,zs) = spanList func xs + +{- | Similar to Data.List.break, but performs the test on the entire remaining +list instead of just one element. +-} +breakList :: ([a] -> Bool) -> [a] -> ([a], [a]) +breakList func = spanList (not . func) + +{- | Given a delimiter and a list (or string), split into components. + +Example: + +> split "," "foo,bar,,baz," -> ["foo", "bar", "", "baz", ""] + +> split "ba" ",foo,bar,,baz," -> [",foo,","r,,","z,"] +-} +split :: Eq a => [a] -> [a] -> [[a]] +split _ [] = [] +split delim str = + let (firstline, remainder) = breakList (startswith delim) str + in + firstline : case remainder of + [] -> [] + x -> if x == delim + then [] : [] + else split delim + (drop (length delim) x) + +{- | Given a list and a replacement list, replaces each occurance of the search +list with the replacement list in the operation list. + +Example: + +>replace "," "." "127,0,0,1" -> "127.0.0.1" + +This could logically be thought of as: + +>replace old new l = join new . split old $ l +-} + +replace :: Eq a => [a] -> [a] -> [a] -> [a] +replace old new l = join new . split old $ l + +{- | Given a delimiter and a list of items (or strings), join the items +by using the delimiter. + +Example: + +> join "|" ["foo", "bar", "baz"] -> "foo|bar|baz" +-} +join :: [a] -> [[a]] -> [a] +join delim l = concat (intersperse delim l) +
src/Scion/PersistentBrowser/Instances/Json.hs view
@@ -1,101 +1,101 @@-{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}--- FlexibleInstances needed for GHC 7.2--module Scion.PersistentBrowser.Instances.Json where--import Control.Applicative-import Control.Monad-import Data.Aeson-import Data.Aeson.Types-import qualified Data.Text as T-import Scion.PersistentBrowser.DbTypes--instance ToJSON DbPackage where- toJSON (DbPackage name version doc) = object [ "id" .= object [ "name" .= T.pack name- , "version" .= T.pack version- ]- , "doc" .= doc- ]--instance ToJSON DbPackageIdentifier where- toJSON (DbPackageIdentifier name version) = object [ "name" .= T.pack name- , "version" .= T.pack version- ]--instance FromJSON DbPackageIdentifier where- parseJSON (Object v) = DbPackageIdentifier <$> (T.unpack <$> v .: "name")- <*> (T.unpack <$> v .: "version")- parseJSON _ = mzero--instance ToJSON (DbModule) where- toJSON (DbModule name doc _) = object [ "name" .= T.pack name- , "doc" .= doc- ]--instance ToJSON DbCompleteDecl where- toJSON (DbCompleteDecl (DbDecl DbData name doc kind _ _ _) context vars _ decls) =- object [ "doc" .= doc- , "type" .= T.pack "data"- , "context" .= context- , "head" .= object [ "name" .= name- , "vars" .= vars- ]- , "kind" .= kind- , "decls" .= decls- ]- toJSON (DbCompleteDecl (DbDecl DbNewType name doc kind _ _ _) context vars _ decls) =- object [ "doc" .= doc- , "type" .= T.pack "newtype"- , "context" .= context- , "head" .= object [ "name" .= name- , "vars" .= vars- ]- , "kind" .= kind- , "decls" .= decls- ]- toJSON (DbCompleteDecl (DbDecl DbClass name doc _ _ _ _) context vars fundeps _) =- object [ "doc" .= doc- , "type" .= T.pack "class"- , "context" .= context- , "head" .= object [ "name" .= name- , "vars" .= vars- ]- , "fundeps" .= fundeps- ]- toJSON (DbCompleteDecl (DbDecl DbInstance name doc _ _ _ _) context vars _ _) =- object [ "doc" .= doc- , "type" .= T.pack "instance"- , "context" .= context- , "head" .= object [ "name" .= name- , "vars" .= vars- ]- ]- toJSON (DbCompleteDecl (DbDecl DbSignature name doc _ signature _ _) _ _ _ _) =- object [ "doc" .= doc- , "type" .= T.pack "signature"- , "name" .= [ name ]- , "signature" .= signature- ]- toJSON (DbCompleteDecl (DbDecl DbType name doc _ _ equals _) _ vars _ _) =- object [ "doc" .= doc- , "type" .= T.pack "type"- , "head" .= object [ "name" .= name- , "vars" .= vars- ]- , "equals" .= equals- ]--instance ToJSON DbContext where- toJSON (DbContext shown _) = String $ T.pack shown--instance ToJSON DbTyVar where- toJSON (DbTyVar name _) = String $ T.pack name--instance ToJSON DbFunDep where- toJSON (DbFunDep name _) = String $ T.pack name--instance ToJSON DbConstructor where- toJSON (DbConstructor name signature _) = object [ "name" .= name- , "type" .= signature- ]-+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-} +-- FlexibleInstances needed for GHC 7.2 + +module Scion.PersistentBrowser.Instances.Json where + +import Control.Applicative +import Control.Monad +import Data.Aeson +import 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 + ] +
src/Scion/PersistentBrowser/Parser.hs view
@@ -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 ((</>))-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:--- --- <root>--- / 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 _ =- 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 ((</>)) +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: +-- +-- <root> +-- / 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 _ = + 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 +
src/Scion/PersistentBrowser/Parser/Documentable.hs view
@@ -1,88 +1,88 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-}--module Scion.PersistentBrowser.Parser.Documentable where--import Scion.PersistentBrowser.Types-import qualified Language.Haskell.Exts.Syntax as S-import qualified Language.Haskell.Exts.Annotated.Syntax as A--class Documentable a b | a -> b where- document :: Doc -> a -> (Documented b)--instance Documentable S.Type A.Type where- document d (S.TyForall b c t) = A.TyForall d (fmap (fmap (document d)) b)- (Just (document d c))- (document d t)- document d (S.TyFun t1 t2) = A.TyFun d (document d t1)- (document d t2)- document d (S.TyTuple b t) = A.TyTuple d (documentBoxed d b)- (fmap (document d) t)- document d (S.TyList t) = A.TyList d (document d t)- document d (S.TyApp t1 t2) = A.TyApp d (document d t1)- (document d t2)- document d (S.TyVar n) = A.TyVar d (document d n)- document d (S.TyCon c) = A.TyCon d (document d c)- document d (S.TyParen t) = A.TyParen d (document d t)- document d (S.TyInfix l n r) = A.TyInfix d (document d l)- (document d n)- (document d r)- document d (S.TyKind t k) = A.TyKind d (document d t)- (document d k)--instance Documentable S.TyVarBind A.TyVarBind where- document d (S.KindedVar n k) = A.KindedVar d (document d n)- (document d k)- document d (S.UnkindedVar n) = A.UnkindedVar d (document d n)--instance Documentable S.Context A.Context where- document d [a] = A.CxSingle d (document d a)- document d v = A.CxTuple d (fmap (document d) v)--instance Documentable S.Asst A.Asst where- document d (S.ClassA q t) = A.ClassA d (document d q)- (fmap (document d) t)- document d (S.InfixA l q r) = A.InfixA d (document d l)- (document d q)- (document d r)- document d (S.IParam n t) = A.IParam d (document d n)- (document d t)- document d (S.EqualP t1 t2) = A.EqualP d (document d t1)- (document d t2)--instance Documentable S.Name A.Name where- document d (S.Ident s) = A.Ident d s- document d (S.Symbol s) = A.Symbol d s--instance Documentable S.QName A.QName where- document d (S.Qual mn n) = A.Qual d (document d mn)- (document d n)- document d (S.UnQual n) = A.UnQual d (document d n)- document d (S.Special c) = A.Special d (document d c)--instance Documentable S.ModuleName A.ModuleName where- document d (S.ModuleName n) = A.ModuleName d n--instance Documentable S.IPName A.IPName where- document d (S.IPDup s) = A.IPDup d s- document d (S.IPLin s) = A.IPLin d s--instance Documentable S.SpecialCon A.SpecialCon where- document d S.UnitCon = A.UnitCon d- document d S.ListCon = A.ListCon d- document d S.FunCon = A.FunCon d- document d (S.TupleCon b n) = A.TupleCon d (documentBoxed d b) n- document d S.Cons = A.Cons d- document d S.UnboxedSingleCon = A.UnboxedSingleCon d--instance Documentable S.Kind A.Kind where- document d S.KindStar = A.KindStar d- document d S.KindBang = A.KindBang d- document d (S.KindFn k1 k2) = A.KindFn d (document d k1)- (document d k2)- document d (S.KindParen k) = A.KindParen d (document d k)- document d (S.KindVar n) = A.KindVar d (document d n)--documentBoxed :: Doc -> S.Boxed -> A.Boxed-documentBoxed _ S.Boxed = A.Boxed-documentBoxed _ S.Unboxed = A.Unboxed-+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-} + +module Scion.PersistentBrowser.Parser.Documentable where + +import Scion.PersistentBrowser.Types +import qualified Language.Haskell.Exts.Syntax as S +import qualified Language.Haskell.Exts.Annotated.Syntax as A + +class Documentable a b | a -> b where + document :: Doc -> a -> (Documented b) + +instance Documentable S.Type A.Type where + document d (S.TyForall b c t) = A.TyForall d (fmap (fmap (document d)) b) + (Just (document d c)) + (document d t) + document d (S.TyFun t1 t2) = A.TyFun d (document d t1) + (document d t2) + document d (S.TyTuple b t) = A.TyTuple d (documentBoxed d b) + (fmap (document d) t) + document d (S.TyList t) = A.TyList d (document d t) + document d (S.TyApp t1 t2) = A.TyApp d (document d t1) + (document d t2) + document d (S.TyVar n) = A.TyVar d (document d n) + document d (S.TyCon c) = A.TyCon d (document d c) + document d (S.TyParen t) = A.TyParen d (document d t) + document d (S.TyInfix l n r) = A.TyInfix d (document d l) + (document d n) + (document d r) + document d (S.TyKind t k) = A.TyKind d (document d t) + (document d k) + +instance Documentable S.TyVarBind A.TyVarBind where + document d (S.KindedVar n k) = A.KindedVar d (document d n) + (document d k) + document d (S.UnkindedVar n) = A.UnkindedVar d (document d n) + +instance Documentable S.Context A.Context where + document d [a] = A.CxSingle d (document d a) + document d v = A.CxTuple d (fmap (document d) v) + +instance Documentable S.Asst A.Asst where + document d (S.ClassA q t) = A.ClassA d (document d q) + (fmap (document d) t) + document d (S.InfixA l q r) = A.InfixA d (document d l) + (document d q) + (document d r) + document d (S.IParam n t) = A.IParam d (document d n) + (document d t) + document d (S.EqualP t1 t2) = A.EqualP d (document d t1) + (document d t2) + +instance Documentable S.Name A.Name where + document d (S.Ident s) = A.Ident d s + document d (S.Symbol s) = A.Symbol d s + +instance Documentable S.QName A.QName where + document d (S.Qual mn n) = A.Qual d (document d mn) + (document d n) + document d (S.UnQual n) = A.UnQual d (document d n) + document d (S.Special c) = A.Special d (document d c) + +instance Documentable S.ModuleName A.ModuleName where + document d (S.ModuleName n) = A.ModuleName d n + +instance Documentable S.IPName A.IPName where + document d (S.IPDup s) = A.IPDup d s + document d (S.IPLin s) = A.IPLin d s + +instance Documentable S.SpecialCon A.SpecialCon where + document d S.UnitCon = A.UnitCon d + document d S.ListCon = A.ListCon d + document d S.FunCon = A.FunCon d + document d (S.TupleCon b n) = A.TupleCon d (documentBoxed d b) n + document d S.Cons = A.Cons d + document d S.UnboxedSingleCon = A.UnboxedSingleCon d + +instance Documentable S.Kind A.Kind where + document d S.KindStar = A.KindStar d + document d S.KindBang = A.KindBang d + document d (S.KindFn k1 k2) = A.KindFn d (document d k1) + (document d k2) + document d (S.KindParen k) = A.KindParen d (document d k) + document d (S.KindVar n) = A.KindVar d (document d n) + +documentBoxed :: Doc -> S.Boxed -> A.Boxed +documentBoxed _ S.Boxed = A.Boxed +documentBoxed _ S.Unboxed = A.Unboxed +
src/Scion/PersistentBrowser/Parser/Internal.hs view
@@ -1,545 +1,545 @@-{-# 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 ((TyParen _ inner):xs) = toKindedVars (inner: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 ((TyParen _ inner):xs) = toKindedVars (inner:xs) +toKindedVars (x:_) = error $ show x +
src/Scion/PersistentBrowser/Query.hs view
@@ -1,220 +1,262 @@-{-# LANGUAGE TypeSynonymInstances, OverloadedStrings , FlexibleInstances #-}--- FlexibleInstances needed for GHC 7.2--module Scion.PersistentBrowser.Query where--import qualified Data.Text as T-import Database.Persist-import Database.Persist.Sqlite-import Database.Persist.Store-import Database.Persist.GenericSql.Raw (withStmt, execute)-import Scion.PersistentBrowser.DbTypes-import Scion.PersistentBrowser.Util (logToStdout)-import Control.Monad.IO.Class (liftIO)-import Data.Conduit-import qualified Data.Conduit.List as CL---- |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 entityVal 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 entityVal 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 entityVal 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 entityVal 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 = ?"- ++ " AND DbPackage.name = ?"- ++ " AND DbPackage.version = ?"- queryDb sql [name, pkgName, pkgVersion] 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 = ?"- ++ " AND DbPackage.version = ?"- queryDb sql [pkgName, pkgVersion] moduleAction-getSubmodules modName Nothing =- do let sql = "SELECT name, doc, packageId FROM DbModule WHERE name LIKE ?"- queryDb sql [modName ++ ".%"] moduleAction-getSubmodules modName (Just (DbPackageIdentifier pkgName pkgVersion)) =- do let sql = "SELECT DbModule.name, DbModule.doc, DbModule.packageId FROM DbModule, DbPackage"- ++ " WHERE name LIKE ?"- ++ " AND DbModule.packageId = DbPackage.id "- ++ " AND DbPackage.name = ?"- ++ " AND DbPackage.version = ?"- queryDb sql [modName ++ ".%", pkgName, pkgVersion] 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 = ?"- queryDb sql [name] 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 = ?"- ++ " AND DbPackage.name = ?"- ++ " AND DbPackage.version = ?"- queryDb sql [name, pkgName, pkgVersion] 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"---createIndexes :: SqlPersist IO()-createIndexes=do- liftIO $ logToStdout "creating indexes"- let idxs = [ "create index if not exists module_pkgid_name on DbModule (packageId,name)"- , "create index if not exists decl_modid on DbDecl (moduleId)"- , "create index if not exists decl_name on DbDecl (name)"- , "create index if not exists cons_name on DbConstructor (name)"- , "create index if not exists cons_declid on DbConstructor (declId)"- , "create index if not exists tyvar_declid on DbTyVar (declId)"- , "create index if not exists fundep_declid on DbFunDep (declId)"- , "create index if not exists context_declid on DbContext (declId)"- ]- mapM_ (\x -> execute x []) idxs- execute "analyze" []---- |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 _ -> " AND DbPackage.name = ? AND DbPackage.version = ?"- 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 = ?"- ++ pkg- let args = case pkgId of- Nothing -> [modName]- Just (DbPackageIdentifier pkgName pkgVersion) -> [modName, pkgName, pkgVersion]- elts <- queryDb sql args 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 entityVal ctxs'- tyvars' <- selectList [ DbTyVarDeclId ==. declId] []- let tyvars = map entityVal tyvars'- fundeps' <- selectList [ DbFunDepDeclId ==. declId] []- let fundeps = map entityVal fundeps'- consts' <- selectList [ DbConstructorDeclId ==. declId] []- let consts = map entityVal 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 entityVal 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 = ?"- 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 = ?"- decls <- queryDb sqlDecl [declName] action- cons <- queryDb sqlCons [declName] 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 -> [String] -> ([PersistValue] -> a) -> SqlPersist IO [a]-queryDb sql params action = runResourceT (withStmt (T.pack sql) (map toPersistValue params) $= CL.map action $$ CL.consume)---- |Gets information from a text value.-fromDbText :: PersistValue -> Maybe String-fromDbText (PersistText value) = Just (T.unpack value)-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, OverloadedStrings , FlexibleInstances #-} +-- FlexibleInstances needed for GHC 7.2 + +module Scion.PersistentBrowser.Query where + +import qualified Data.Text as T +import Database.Persist +import Database.Persist.Sqlite +import Database.Persist.Store +import Database.Persist.GenericSql.Raw (withStmt, execute) +import Scion.PersistentBrowser.DbTypes +import Scion.PersistentBrowser.Util (logToStdout) +import Control.Monad.IO.Class (liftIO) +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.List (isPrefixOf) +import Data.Char (toUpper) + +-- |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 entityVal 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 entityVal 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 entityVal 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 entityVal 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 = ?" + ++ " AND DbPackage.name = ?" + ++ " AND DbPackage.version = ?" + queryDb sql [name, pkgName, pkgVersion] 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 = ?" + ++ " AND DbPackage.version = ?" + queryDb sql [pkgName, pkgVersion] moduleAction +getSubmodules modName Nothing = + do let sql = "SELECT name, doc, packageId FROM DbModule WHERE name LIKE ?" + queryDb sql [modName ++ ".%"] moduleAction +getSubmodules modName (Just (DbPackageIdentifier pkgName pkgVersion)) = + do let sql = "SELECT DbModule.name, DbModule.doc, DbModule.packageId FROM DbModule, DbPackage" + ++ " WHERE name LIKE ?" + ++ " AND DbModule.packageId = DbPackage.id " + ++ " AND DbPackage.name = ?" + ++ " AND DbPackage.version = ?" + queryDb sql [modName ++ ".%", pkgName, pkgVersion] 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 = ?" + queryDb sql [name] 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 = ?" + ++ " AND DbPackage.name = ?" + ++ " AND DbPackage.version = ?" + queryDb sql [name, pkgName, pkgVersion] 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" + + +createIndexes :: SqlPersist IO() +createIndexes=do + liftIO $ logToStdout "creating indexes" + let idxs = [ "create index if not exists module_pkgid_name on DbModule (packageId,name)" + , "create index if not exists decl_modid on DbDecl (moduleId)" + , "create index if not exists decl_name on DbDecl (name)" + , "create index if not exists cons_name on DbConstructor (name)" + , "create index if not exists cons_declid on DbConstructor (declId)" + , "create index if not exists tyvar_declid on DbTyVar (declId)" + , "create index if not exists fundep_declid on DbFunDep (declId)" + , "create index if not exists context_declid on DbContext (declId)" + ] + mapM_ (\x -> execute x []) idxs + execute "analyze" [] + +-- |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 _ -> " AND DbPackage.name = ? AND DbPackage.version = ?" + 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 = ?" + ++ pkg + let args = case pkgId of + Nothing -> [modName] + Just (DbPackageIdentifier pkgName pkgVersion) -> [modName, pkgName, pkgVersion] + elts <- queryDb sql args 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" + +-- | list declarations matching the given prefix, useful for content assist +-- the prefix either matches the declaration itself or any constructor +getDeclsFromPrefix :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [(DbPackageIdentifier, DbModule, DbCompleteDecl)] +getDeclsFromPrefix prefix pkgId = + do let pkg = case pkgId of + Nothing -> "" + Just _ -> " AND DbPackage.name = ? AND DbPackage.version = ?" + let sql = "SELECT DbDecl.id, DbDecl.declType, DbDecl.name, DbDecl.doc, DbDecl.kind, DbDecl.signature, DbDecl.equals, DbDecl.moduleId, " + ++ "DbModule.name, DbPackage.name, DbPackage.version" + ++ " FROM DbDecl, DbModule, DbPackage" + ++ " WHERE DbDecl.moduleId = DbModule.id AND DbModule.packageId = DbPackage.id" + ++ " AND (DbDecl.name LIKE '" + ++ prefix ++ "%' or DbDecl.id in (select DbConstructor.declId from DbConstructor where DbConstructor.name LIKE '" + ++ prefix ++ "%'))" + ++ pkg + let args = case pkgId of + Nothing -> [] + Just (DbPackageIdentifier pkgName pkgVersion) -> [pkgName, pkgVersion] + elts <- queryDb sql args action + completeElts <- mapM (\(dclId, dcl, p,m) -> do cs <- consts dclId + let dclAll=DbCompleteDecl dcl [] [] [] cs + return (p,m, dclAll)) elts + return completeElts + where action :: [PersistValue] -> (DbDeclId, DbDecl, DbPackageIdentifier, DbModule) + action [declId@(PersistInt64 _), PersistText declType, PersistText name + , doc, kind, signature, equals, modId@(PersistInt64 _) + , PersistText modName, 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) + , DbModule (T.unpack modName) Nothing (Key modId) + ) + action _ = error "This should not happen" + consts declId=do + consts' <- selectList [ DbConstructorDeclId ==. declId] [] + -- we do case insensitive match here to be consistent with LIKE above + return $ filter (\(DbConstructor name _ _)->isPrefixOf (map toUpper prefix) (map toUpper name)) $ map entityVal consts' + +getAllDeclInfo :: (DbDeclId, DbDecl) -> SqlPersist IO DbCompleteDecl +getAllDeclInfo (declId, decl) = + do ctxs' <- selectList [ DbContextDeclId ==. declId] [] + let ctxs = map entityVal ctxs' + tyvars' <- selectList [ DbTyVarDeclId ==. declId] [] + let tyvars = map entityVal tyvars' + fundeps' <- selectList [ DbFunDepDeclId ==. declId] [] + let fundeps = map entityVal fundeps' + consts' <- selectList [ DbConstructorDeclId ==. declId] [] + let consts = map entityVal 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 entityVal consts + +-- | Gets a list of modules where a declaration may live +getModulesWhereDeclarationIs :: String -> SqlPersist IO [(DbModule,String)] +getModulesWhereDeclarationIs declName = + do let sqlDecl = "SELECT DbModule.name, DbModule.doc, DbModule.packageId,''" + ++ " FROM DbDecl, DbModule" + ++ " WHERE DbDecl.moduleId = DbModule.id AND DbDecl.name = ?" + sqlCons = "SELECT DbModule.name, DbModule.doc, DbModule.packageId,DbDecl.name" + ++ " FROM DbConstructor, DbDecl, DbModule" + ++ " WHERE DbConstructor.declId = DbDecl.id AND DbDecl.moduleId = DbModule.id" + ++ " AND DbConstructor.name = ?" + decls <- queryDb sqlDecl [declName] action + cons <- queryDb sqlCons [declName] action + return (decls ++ cons) + where action :: [PersistValue] -> (DbModule,String) + action [PersistText name, doc, pkgId@(PersistInt64 _),PersistText decl] = (DbModule (T.unpack name) (fromDbText doc) (Key pkgId),T.unpack decl) + action _ = error "This should not happen" + +-- |Executes a query. +queryDb :: String -> [String] -> ([PersistValue] -> a) -> SqlPersist IO [a] +queryDb sql params action = runResourceT (withStmt (T.pack sql) (map toPersistValue params) $= CL.map action $$ CL.consume) + +-- |Gets information from a text value. +fromDbText :: PersistValue -> Maybe String +fromDbText (PersistText value) = Just (T.unpack value) +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 +
src/Scion/PersistentBrowser/TempFile.hs view
@@ -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
src/Scion/PersistentBrowser/ToDb.hs view
@@ -1,143 +1,143 @@-{-# LANGUAGE RankNTypes, KindSignatures #-}-module Scion.PersistentBrowser.ToDb where--import qualified Data.Map as M-import qualified Data.Text as T-import Data.Version (showVersion)-import Database.Persist-import Distribution.Package hiding (Package)-import Language.Haskell.Exts.Annotated.Syntax hiding (String)-import Language.Haskell.Exts.Pretty-import Scion.PersistentBrowser.DbTypes-import Scion.PersistentBrowser.Types---- SAVING IN THE DATABASE--- ======================---- savePackageToDb :: PersistBackend backend m => Documented Package -> backend m ()-savePackageToDb (Package doc (PackageIdentifier (PackageName name) version) modules) = - do pkgId <- insert $ DbPackage name (showVersion version) (docToString doc)- mapM_ (saveModuleToDb pkgId) (M.elems modules)- --- saveModuleToDb :: PersistBackend backend m => DbPackageId -> Documented Module -> backend m ()-saveModuleToDb pkgId (Module doc (Just (ModuleHead _ (ModuleName _ name) _ _)) _ _ decls) =- do moduleId <- insert $ DbModule name (docToString doc) pkgId- mapM_ (saveDeclToDb moduleId) decls-saveModuleToDb _ _ = error "This should never happen"---- saveDeclToDb :: PersistBackend backend m => DbModuleId -> Documented Decl -> backend m ()--- Datatypes-saveDeclToDb moduleId (GDataDecl doc (DataType _) ctx hd kind decls _) =- do let (declName, declVars) = declHeadToDb hd- declId <- insert $ DbDecl DbData declName (docToString doc)- (fmap singleLinePrettyPrint kind) Nothing Nothing moduleId- mapM_ (saveTyVarToDb declId) declVars- mapM_ (saveContextToDb declId) (contextToDb (maybeEmptyContext ctx))- mapM_ (saveConstructorToDb declId) decls--- Newtypes-saveDeclToDb moduleId (GDataDecl doc (NewType _) ctx hd kind decls _) =- do let (declName, declVars) = declHeadToDb hd- declId <- insert $ DbDecl DbNewType declName (docToString doc)- (fmap singleLinePrettyPrint kind) Nothing Nothing moduleId- mapM_ (saveTyVarToDb declId) declVars- mapM_ (saveContextToDb declId) (contextToDb (maybeEmptyContext ctx))- mapM_ (saveConstructorToDb declId) decls--- Classes-saveDeclToDb moduleId (ClassDecl doc ctx hd fdeps _) =- do let (declName, declVars) = declHeadToDb hd- declId <- insert $ DbDecl DbClass declName (docToString doc)- Nothing Nothing Nothing moduleId- mapM_ (saveTyVarToDb declId) declVars- mapM_ (saveContextToDb declId) (contextToDb (maybeEmptyContext ctx))- mapM_ (saveFunDepToDb declId) (map singleLinePrettyPrint fdeps)--- Instances-saveDeclToDb moduleId (InstDecl doc ctx hd _) =- do let (declName, declVars) = instHeadToDb hd- declId <- insert $ DbDecl DbInstance declName (docToString doc)- Nothing Nothing Nothing moduleId- mapM_ (saveTyVarToDb declId) declVars- mapM_ (saveContextToDb declId) (contextToDb (maybeEmptyContext ctx))--- Signatures-saveDeclToDb moduleId (TypeSig doc names ty) =- do mapM_ saveSignatureToDb names- where saveSignatureToDb name = do- insert $ DbDecl DbSignature (getNameString name) (docToString doc) - Nothing (Just (singleLinePrettyPrint ty)) Nothing moduleId--- Types-saveDeclToDb moduleId (TypeDecl doc hd ty) =- do let (declName, declVars) = declHeadToDb hd- declId <- insert $ DbDecl DbType declName (docToString doc) - Nothing Nothing (Just (singleLinePrettyPrint ty)) moduleId- mapM_ (saveTyVarToDb declId) declVars--- Other-saveDeclToDb _ _ = error "This should never happen"---- saveTyVarToDb :: PersistBackend backend m => DbDeclId -> String -> backend m ()-saveTyVarToDb declId var = insert $ DbTyVar var declId---- saveFunDepToDb :: PersistBackend backend m => DbDeclId -> String -> backend m ()-saveFunDepToDb declId var = insert $ DbTyVar var declId---- saveContextToDb :: PersistBackend backend m => DbDeclId -> String -> backend m ()-saveContextToDb declId ctx = insert $ DbContext ctx declId---- saveConstructorToDb :: PersistBackend backend m => DbDeclId -> Documented GadtDecl -> backend m ()-saveConstructorToDb declId (GadtDecl _ name ty) = insert $ DbConstructor (getNameString name) (singleLinePrettyPrint ty) declId---- DELETE PACKAGE FROM DATABASE--- ============================---- deletePackageByInfo :: PersistBackend backend m => PackageIdentifier -> backend m ()-deletePackageByInfo (PackageIdentifier (PackageName name) version) =- do Just pkg <- selectFirst [ DbPackageName ==. name, DbPackageVersion ==. showVersion version ] []- let pkgId = entityKey pkg- deletePackage pkgId---- deletePackage :: PersistBackend backend m => DbPackageId -> backend m ()-deletePackage pkgId =- do modules <- selectList [ DbModulePackageId ==. pkgId ] []- mapM_ (deleteModule . entityKey) modules- delete pkgId---- deleteModule :: PersistBackend backend m => DbModuleId -> backend m ()-deleteModule moduleId =- do decls <- selectList [ DbDeclModuleId ==. moduleId ] []- mapM_ (deleteDecl . entityKey) decls- delete moduleId---- deleteDecl :: PersistBackend backend m => DbModuleId -> backend m ()-deleteDecl declId =- do deleteWhere [ DbTyVarDeclId ==. declId ]- deleteWhere [ DbFunDepDeclId ==. declId ]- deleteWhere [ DbContextDeclId ==. declId ]- deleteWhere [ DbConstructorDeclId ==. declId ]- delete declId---- UTILITIES FOR CONVERTING TO STRINGS--- ===================================--docToString :: Doc -> Maybe String-docToString NoDoc = Nothing-docToString (Doc doc) = Just (T.unpack doc)--declHeadToDb :: DeclHead l -> (String, [String])-declHeadToDb (DHead _ name vars) = (getNameString name, map singleLinePrettyPrint vars)-declHeadToDb _ = error "This should never happen"--instHeadToDb :: InstHead l -> (String, [String])-instHeadToDb (IHead _ name vars) = (getQNameString name, map singleLinePrettyPrint vars)-instHeadToDb _ = error "This should never happen"--singleLinePrettyPrint :: Pretty a => a -> String-singleLinePrettyPrint = prettyPrintWithMode $ defaultMode { layout = PPNoLayout }--maybeEmptyContext :: Maybe (Documented Context) -> Documented Context-maybeEmptyContext Nothing = CxEmpty NoDoc-maybeEmptyContext (Just ctx) = ctx--contextToDb :: Context l -> [String]-contextToDb (CxSingle _ a) = [ singleLinePrettyPrint a ]-contextToDb (CxTuple _ as) = map singleLinePrettyPrint as-contextToDb (CxParen _ ctx) = contextToDb ctx-contextToDb (CxEmpty _) = []-+{-# LANGUAGE RankNTypes, KindSignatures #-} +module Scion.PersistentBrowser.ToDb where + +import qualified Data.Map as M +import qualified Data.Text as T +import Data.Version (showVersion) +import Database.Persist +import Distribution.Package hiding (Package) +import Language.Haskell.Exts.Annotated.Syntax hiding (String) +import Language.Haskell.Exts.Pretty +import Scion.PersistentBrowser.DbTypes +import Scion.PersistentBrowser.Types + +-- SAVING IN THE DATABASE +-- ====================== + +-- savePackageToDb :: PersistBackend backend m => Documented Package -> backend m () +savePackageToDb (Package doc (PackageIdentifier (PackageName name) version) modules) = + do pkgId <- insert $ DbPackage name (showVersion version) (docToString doc) + mapM_ (saveModuleToDb pkgId) (M.elems modules) + +-- saveModuleToDb :: PersistBackend backend m => DbPackageId -> Documented Module -> backend m () +saveModuleToDb pkgId (Module doc (Just (ModuleHead _ (ModuleName _ name) _ _)) _ _ decls) = + do moduleId <- insert $ DbModule name (docToString doc) pkgId + mapM_ (saveDeclToDb moduleId) decls +saveModuleToDb _ _ = error "This should never happen" + +-- saveDeclToDb :: PersistBackend backend m => DbModuleId -> Documented Decl -> backend m () +-- Datatypes +saveDeclToDb moduleId (GDataDecl doc (DataType _) ctx hd kind decls _) = + do let (declName, declVars) = declHeadToDb hd + declId <- insert $ DbDecl DbData declName (docToString doc) + (fmap singleLinePrettyPrint kind) Nothing Nothing moduleId + mapM_ (saveTyVarToDb declId) declVars + mapM_ (saveContextToDb declId) (contextToDb (maybeEmptyContext ctx)) + mapM_ (saveConstructorToDb declId) decls +-- Newtypes +saveDeclToDb moduleId (GDataDecl doc (NewType _) ctx hd kind decls _) = + do let (declName, declVars) = declHeadToDb hd + declId <- insert $ DbDecl DbNewType declName (docToString doc) + (fmap singleLinePrettyPrint kind) Nothing Nothing moduleId + mapM_ (saveTyVarToDb declId) declVars + mapM_ (saveContextToDb declId) (contextToDb (maybeEmptyContext ctx)) + mapM_ (saveConstructorToDb declId) decls +-- Classes +saveDeclToDb moduleId (ClassDecl doc ctx hd fdeps _) = + do let (declName, declVars) = declHeadToDb hd + declId <- insert $ DbDecl DbClass declName (docToString doc) + Nothing Nothing Nothing moduleId + mapM_ (saveTyVarToDb declId) declVars + mapM_ (saveContextToDb declId) (contextToDb (maybeEmptyContext ctx)) + mapM_ (saveFunDepToDb declId) (map singleLinePrettyPrint fdeps) +-- Instances +saveDeclToDb moduleId (InstDecl doc ctx hd _) = + do let (declName, declVars) = instHeadToDb hd + declId <- insert $ DbDecl DbInstance declName (docToString doc) + Nothing Nothing Nothing moduleId + mapM_ (saveTyVarToDb declId) declVars + mapM_ (saveContextToDb declId) (contextToDb (maybeEmptyContext ctx)) +-- Signatures +saveDeclToDb moduleId (TypeSig doc names ty) = + do mapM_ saveSignatureToDb names + where saveSignatureToDb name = do + insert $ DbDecl DbSignature (getNameString name) (docToString doc) + Nothing (Just (singleLinePrettyPrint ty)) Nothing moduleId +-- Types +saveDeclToDb moduleId (TypeDecl doc hd ty) = + do let (declName, declVars) = declHeadToDb hd + declId <- insert $ DbDecl DbType declName (docToString doc) + Nothing Nothing (Just (singleLinePrettyPrint ty)) moduleId + mapM_ (saveTyVarToDb declId) declVars +-- Other +saveDeclToDb _ _ = error "This should never happen" + +-- saveTyVarToDb :: PersistBackend backend m => DbDeclId -> String -> backend m () +saveTyVarToDb declId var = insert $ DbTyVar var declId + +-- saveFunDepToDb :: PersistBackend backend m => DbDeclId -> String -> backend m () +saveFunDepToDb declId var = insert $ DbTyVar var declId + +-- saveContextToDb :: PersistBackend backend m => DbDeclId -> String -> backend m () +saveContextToDb declId ctx = insert $ DbContext ctx declId + +-- saveConstructorToDb :: PersistBackend backend m => DbDeclId -> Documented GadtDecl -> backend m () +saveConstructorToDb declId (GadtDecl _ name ty) = insert $ DbConstructor (getNameString name) (singleLinePrettyPrint ty) declId + +-- DELETE PACKAGE FROM DATABASE +-- ============================ + +-- deletePackageByInfo :: PersistBackend backend m => PackageIdentifier -> backend m () +deletePackageByInfo (PackageIdentifier (PackageName name) version) = + do Just pkg <- selectFirst [ DbPackageName ==. name, DbPackageVersion ==. showVersion version ] [] + let pkgId = entityKey pkg + deletePackage pkgId + +-- deletePackage :: PersistBackend backend m => DbPackageId -> backend m () +deletePackage pkgId = + do modules <- selectList [ DbModulePackageId ==. pkgId ] [] + mapM_ (deleteModule . entityKey) modules + delete pkgId + +-- deleteModule :: PersistBackend backend m => DbModuleId -> backend m () +deleteModule moduleId = + do decls <- selectList [ DbDeclModuleId ==. moduleId ] [] + mapM_ (deleteDecl . entityKey) decls + delete moduleId + +-- deleteDecl :: PersistBackend backend m => DbModuleId -> backend m () +deleteDecl declId = + do deleteWhere [ DbTyVarDeclId ==. declId ] + deleteWhere [ DbFunDepDeclId ==. declId ] + deleteWhere [ DbContextDeclId ==. declId ] + deleteWhere [ DbConstructorDeclId ==. declId ] + delete declId + +-- UTILITIES FOR CONVERTING TO STRINGS +-- =================================== + +docToString :: Doc -> Maybe String +docToString NoDoc = Nothing +docToString (Doc doc) = Just (T.unpack doc) + +declHeadToDb :: DeclHead l -> (String, [String]) +declHeadToDb (DHead _ name vars) = (getNameString name, map singleLinePrettyPrint vars) +declHeadToDb _ = error "This should never happen" + +instHeadToDb :: InstHead l -> (String, [String]) +instHeadToDb (IHead _ name vars) = (getQNameString name, map singleLinePrettyPrint vars) +instHeadToDb _ = error "This should never happen" + +singleLinePrettyPrint :: Pretty a => a -> String +singleLinePrettyPrint = prettyPrintWithMode $ defaultMode { layout = PPNoLayout } + +maybeEmptyContext :: Maybe (Documented Context) -> Documented Context +maybeEmptyContext Nothing = CxEmpty NoDoc +maybeEmptyContext (Just ctx) = ctx + +contextToDb :: Context l -> [String] +contextToDb (CxSingle _ a) = [ singleLinePrettyPrint a ] +contextToDb (CxTuple _ as) = map singleLinePrettyPrint as +contextToDb (CxParen _ ctx) = contextToDb ctx +contextToDb (CxEmpty _) = [] +
src/Scion/PersistentBrowser/Types.hs view
@@ -1,90 +1,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 +
src/Scion/PersistentBrowser/Util.hs view
@@ -1,51 +1,51 @@-{-# LANGUAGE CPP #-}-module Scion.PersistentBrowser.Util where--import Control.Concurrent.ParallelIO.Local-import Scion.PersistentBrowser.Types-import System.Exit (ExitCode)-import System.IO (hPutStrLn, hFlush, stderr)-import System.Process-import Text.Parsec.Error (ParseError)-import GHC.Conc (numCapabilities)--withThreaded :: (Pool -> IO a) -> IO a-withThreaded = withPool numCapabilities---- |Executes a command in a directory.-executeCommand :: FilePath -- ^Working directory.- -> String -- ^Executable to run.- -> [String] -- ^Arguments.- -> Bool -- ^Show output- -> IO ExitCode-executeCommand tmp exe args showOutput =- do let cproc = CreateProcess (RawCommand exe args)- (Just tmp)- Nothing- Inherit - (if showOutput then Inherit else CreatePipe)- (if showOutput then Inherit else CreatePipe)- True-#if __GLASGOW_HASKELL__ >= 702- False -#endif- (_, _, _, h) <- createProcess cproc- waitForProcess h---- |Converts a list of parsed packages into a complete database,--- and merges a list of errors.-partitionPackages :: [(FilePath, Either ParseError (Documented Package))] -> ([Documented Package], [(FilePath, ParseError)])-partitionPackages [] = ([], [])-partitionPackages ((fname, Left err):xs) = let (db, errors) = partitionPackages xs- in (db, (fname, err):errors)-partitionPackages ((_, Right pkg):xs) = let (db, errors) = partitionPackages xs- in (pkg:db, errors)--logToStdout :: String -> IO ()-logToStdout msg = hPutStrLn stderr msg >> hFlush stderr--escapeSql :: String -> String-escapeSql [] = ""-escapeSql ('\'':cs) = '\'':'\'':(escapeSql cs)-escapeSql (c:cs) = c:(escapeSql cs)-+{-# LANGUAGE CPP #-} +module Scion.PersistentBrowser.Util where + +import Control.Concurrent.ParallelIO.Local +import Scion.PersistentBrowser.Types +import System.Exit (ExitCode) +import System.IO (hPutStrLn, hFlush, stderr) +import System.Process +import Text.Parsec.Error (ParseError) +import GHC.Conc (numCapabilities) + +withThreaded :: (Pool -> IO a) -> IO a +withThreaded = withPool numCapabilities + +-- |Executes a command in a directory. +executeCommand :: FilePath -- ^Working directory. + -> String -- ^Executable to run. + -> [String] -- ^Arguments. + -> Bool -- ^Show output + -> IO ExitCode +executeCommand tmp exe args showOutput = + do let cproc = CreateProcess (RawCommand exe args) + (Just tmp) + Nothing + Inherit + (if showOutput then Inherit else CreatePipe) + (if showOutput then Inherit else CreatePipe) + True +#if __GLASGOW_HASKELL__ >= 702 + False +#endif + (_, _, _, h) <- createProcess cproc + waitForProcess h + +-- |Converts a list of parsed packages into a complete database, +-- and merges a list of errors. +partitionPackages :: [(FilePath, Either ParseError (Documented Package))] -> ([Documented Package], [(FilePath, ParseError)]) +partitionPackages [] = ([], []) +partitionPackages ((fname, Left err):xs) = let (db, errors) = partitionPackages xs + in (db, (fname, err):errors) +partitionPackages ((_, Right pkg):xs) = let (db, errors) = partitionPackages xs + in (pkg:db, errors) + +logToStdout :: String -> IO () +logToStdout msg = hPutStrLn stderr msg >> hFlush stderr + +escapeSql :: String -> String +escapeSql [] = "" +escapeSql ('\'':cs) = '\'':'\'':(escapeSql cs) +escapeSql (c:cs) = c:(escapeSql cs) +
src/Scion/PersistentHoogle.hs view
@@ -1,54 +1,57 @@-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.PersistentBrowser.Util--import Scion.PersistentHoogle.Types-import Scion.PersistentHoogle.Instances.Json ()-import Scion.PersistentHoogle.Parser-import Scion.PersistentHoogle.Util-import Scion.PersistentBrowser.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 perr -> do- liftIO $ logToStdout $ show perr -- I like to see the error in the log- return []- _ -> do liftIO $ logToStdout err -- I like to see the error in the log- return []--downloadData :: Maybe String -> IO Bool-downloadData p = do mpath <- findHoogleBinPath p- case mpath of- Nothing -> return False- Just path -> do logToStdout "Downloading 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.PersistentBrowser.Util + +import Scion.PersistentHoogle.Types +import Scion.PersistentHoogle.Instances.Json () +import Scion.PersistentHoogle.Parser +import Scion.PersistentHoogle.Util +import Scion.PersistentBrowser.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 + liftIO $ logToStdout q + liftIO $ logToStdout output + let search = runP hoogleElements () "hoogle-output" (output) + case search of + Right result -> do dbResult <- result + return dbResult + Left perr -> do + liftIO $ logToStdout $ show perr -- I like to see the error in the log + return [] + _ -> do liftIO $ logToStdout err -- I like to see the error in the log + return [] + +downloadData :: Maybe String -> IO Bool +downloadData p = do mpath <- findHoogleBinPath p + case mpath of + Nothing -> return False + Just path -> do logToStdout "Downloading 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) +
src/Scion/PersistentHoogle/Instances/Json.hs view
@@ -1,34 +1,34 @@-{-# LANGUAGE OverloadedStrings, TypeSynonymInstances #-}--module Scion.PersistentHoogle.Instances.Json where--import Control.Applicative-import Data.Aeson hiding (Result)-import qualified Data.Text as T-import Scion.PersistentBrowser ()-import Scion.PersistentHoogle.Types---- instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where--- toJSON (a,b,c,d) = toJSON [toJSON a, toJSON b, toJSON c, toJSON d]--- {-# INLINE toJSON #-}--instance ToJSON (Result) where- toJSON (RPackage pids) = object [ "type" .= T.pack "package"- , "results" .= pids- ]- toJSON (RModule mds) = object [ "type" .= T.pack "module"- , "results" .= mds- ]- toJSON (RDeclaration decls) = object [ "type" .= T.pack "declaration"- , "results" .= decls- ]- toJSON (RConstructor decls) = object [ "type" .= T.pack "constructor"- , "results" .= decls- ]- toJSON (RKeyword kw) = object [ "type" .= T.pack "keyword"- , "name" .= kw- ]--instance FromJSON (Query) where- parseJSON q = Query <$> parseJSON q-+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances #-} + +module Scion.PersistentHoogle.Instances.Json where + +import Control.Applicative +import Data.Aeson hiding (Result) +import qualified Data.Text as T +import Scion.PersistentBrowser () +import Scion.PersistentHoogle.Types + +-- instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where +-- toJSON (a,b,c,d) = toJSON [toJSON a, toJSON b, toJSON c, toJSON d] +-- {-# INLINE toJSON #-} + +instance ToJSON (Result) where + toJSON (RPackage pids) = object [ "type" .= T.pack "package" + , "results" .= pids + ] + toJSON (RModule mds) = object [ "type" .= T.pack "module" + , "results" .= mds + ] + toJSON (RDeclaration decls) = object [ "type" .= T.pack "declaration" + , "results" .= decls + ] + toJSON (RConstructor decls) = object [ "type" .= T.pack "constructor" + , "results" .= decls + ] + toJSON (RKeyword kw) = object [ "type" .= T.pack "keyword" + , "name" .= kw + ] + +instance FromJSON (Query) where + parseJSON q = Query <$> parseJSON q +
src/Scion/PersistentHoogle/Parser.hs view
@@ -1,165 +1,168 @@-{-# 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 Database.Persist.Store-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)- | HalfKeyword String--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 pname <- hoogleKeyword- return $ HalfKeyword 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---- | handle a keyword. For example searching for 'id' gives 'keyword hiding' in the results-hoogleKeyword :: BSParser String-hoogleKeyword = do string "keyword"- spaces1- name <- restOfLine- spaces0- return name--convertHalfToResult :: HalfResult -> SqlPersist IO (Maybe Result)-convertHalfToResult (HalfKeyword kw) =- return $ Just (RKeyword kw)-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 = ?"- mods <- queryDb sql [mname] action- return $ if null mods then Nothing else Just (RModule mods)- where action [PersistText modName, modDoc, pkgId@(PersistInt64 _), PersistText pkgName, PersistText pkgVersion] =- ( 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 = ?"- ++ " AND DbModule.name = ?"- decls <- queryDb sql [getName dcl, mname] 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 = ?"- ++ " AND DbModule.name = ?"- decls <- queryDb sql [getName dcl, mname] 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 Database.Persist.Store +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) + | HalfKeyword String + +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 + optional $ try (do + string "No results found" + spacesOrEol0) + 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 pname <- hoogleKeyword + return $ HalfKeyword 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 + +-- | handle a keyword. For example searching for 'id' gives 'keyword hiding' in the results +hoogleKeyword :: BSParser String +hoogleKeyword = do string "keyword" + spaces1 + name <- restOfLine + spaces0 + return name + +convertHalfToResult :: HalfResult -> SqlPersist IO (Maybe Result) +convertHalfToResult (HalfKeyword kw) = + return $ Just (RKeyword kw) +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 = ?" + mods <- queryDb sql [mname] action + return $ if null mods then Nothing else Just (RModule mods) + where action [PersistText modName, modDoc, pkgId@(PersistInt64 _), PersistText pkgName, PersistText pkgVersion] = + ( 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 = ?" + ++ " AND DbModule.name = ?" + decls <- queryDb sql [getName dcl, mname] 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 = ?" + ++ " AND DbModule.name = ?" + decls <- queryDb sql [getName dcl, mname] 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" +
src/Scion/PersistentHoogle/Types.hs view
@@ -1,14 +1,14 @@-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)]- | RKeyword String--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)] + | RKeyword String + +data Query = Query String +
src/Scion/PersistentHoogle/Util.hs view
@@ -1,129 +1,129 @@-{-# LANGUAGE CPP #-}--module Scion.PersistentHoogle.Util-( findHoogleBinPath-) where--import Data.List (find)-import Data.Maybe-import Distribution.Compiler-import Distribution.InstalledPackageInfo-import Distribution.Package-import Distribution.Simple.InstallDirs-import Scion.Packages-import System.FilePath-import System.Directory (doesFileExist, getAppUserDataDirectory, getHomeDirectory)---- Functions for finding Hoogle in the system--findHoogleBinPath :: Maybe String -> IO (Maybe String)-findHoogleBinPath extraPath = do- p1 <- findHoogleBinInLibrary getHoogleBinPath1- p2 <- findHoogleBinInLibrary getHoogleBinPath2- p3 <- getHoogleBinPathCabalAPI- p4 <- getHoogleBinPathCabalDir- p5 <- getHoogleBinPathMacOsDir- let placesToSearch = (catMaybes [extraPath, p1, p2]) ++ [p4, p5] ++ p3- findPathsAndCheck placesToSearch--findPathsAndCheck :: [String] -> IO (Maybe String)-findPathsAndCheck [] = return Nothing-findPathsAndCheck (f:fs) = do r <- findPathAndCheck f- case r of- Nothing -> findPathsAndCheck fs- _ -> return r--findPathAndCheck :: String -> IO (Maybe String)-findPathAndCheck path = do - exists <- doesFileExist path- if exists- then return (Just path)- else return Nothing--findHoogleBinInLibrary :: (String -> String) -> IO (Maybe String)-findHoogleBinInLibrary f = do minfo <- findHoogleInfo- case minfo of- Nothing -> return Nothing- Just info -> let [libDir] = libraryDirs info- in return $ Just (f libDir)--findHoogleInfo :: IO (Maybe InstalledPackageInfo)-findHoogleInfo = do infos' <- getPkgInfos- let infos = removeSmallVersions $ concat $ map snd infos'- return $ find (\m -> (pkgName (sourcePackageId m)) == PackageName "hoogle") infos--removeSmallVersions :: [InstalledPackageInfo] -> [InstalledPackageInfo]-removeSmallVersions pids = filter- (not . (\InstalledPackageInfo { sourcePackageId = (PackageIdentifier name version) } -> - any (\InstalledPackageInfo { sourcePackageId = (PackageIdentifier name' version') } ->- name' == name && version' > version)- pids))- pids--getHoogleBinPath1 :: String -> String-getHoogleBinPath1 path = let (_:(_:(_:rest))) = reverse $ splitDirectories path- in (joinPath $ reverse ("bin":rest)) </> "hoogle" <.> exeExtension--getHoogleBinPath2 :: String -> String-getHoogleBinPath2 path = let (_:(_:rest)) = reverse $ splitDirectories path- in (joinPath $ reverse ("bin":rest)) </> "hoogle" <.> exeExtension--getHoogleBinPathCabalAPI :: IO [String]-getHoogleBinPathCabalAPI = do- let ci=buildCompilerFlavor- mapM (getBinDir ci) [True,False]- -getBinDir :: CompilerFlavor -> Bool -> IO FilePath-getBinDir ci user=do- ids<-defaultInstallDirs ci user True- let env=installDirsTemplateEnv ids- return $ fromPathTemplate $ substPathTemplate env $ bindir ids --getHoogleBinPathCabalDir :: IO String-getHoogleBinPathCabalDir = do - cabalDir <- getAppUserDataDirectory "cabal"- return (cabalDir </> "bin" </> "hoogle" <.> exeExtension)--getHoogleBinPathMacOsDir :: IO String-getHoogleBinPathMacOsDir = do - homeDir <- getHomeDirectory- return (homeDir </> "Library" </> "Haskell" </> "bin" </> "hoogle" <.> exeExtension)--exeExtension :: String-#ifdef mingw32_HOST_OS-exeExtension = "exe"-#else-exeExtension = ""-#endif---- This part is commented out because Cabal does not work--- well linking with the Hoogle library.--- Instead, `hoogle` is called directly and the results--- are parsed and converted into database items.--{---- |Loads the Hoogle search database into memory.--- If no database is found, an empty one is returned.-getHoogleDatabases :: IO H.Database-getHoogleDatabases = do path <- findHoogleDatabasesPath- case path of- Nothing -> return mempty- Just p -> do files <- getDirectoryContents p- hooFiles <- filterM (\f -> do exists <- doesFileExist f- let isHoo = takeExtension f == ".hoo"- return $ exists && isHoo)- files- dbs <- mapM H.loadDatabase hooFiles- return $ mconcat dbs--findHoogleDatabasesPath :: IO (Maybe String)-findHoogleDatabasesPath = do minfo <- findHoogleInfo- case minfo of- Nothing -> return Nothing- Just info -> let [libDir] = libraryDirs info- in return $ Just (getDatabasesDir libDir)--getDatabasesDir :: String -> String-getDatabasesDir path = let (_:(hoogleV:(_:rest))) = reverse $ splitDirectories path- in (joinPath $ reverse (hoogleV:("share":rest))) </> "databases"--}+{-# LANGUAGE CPP #-} + +module Scion.PersistentHoogle.Util +( findHoogleBinPath +) where + +import Data.List (find) +import Data.Maybe +import Distribution.Compiler +import Distribution.InstalledPackageInfo +import Distribution.Package +import Distribution.Simple.InstallDirs +import Scion.Packages +import System.FilePath +import System.Directory (doesFileExist, getAppUserDataDirectory, getHomeDirectory) + +-- Functions for finding Hoogle in the system + +findHoogleBinPath :: Maybe String -> IO (Maybe String) +findHoogleBinPath extraPath = do + p1 <- findHoogleBinInLibrary getHoogleBinPath1 + p2 <- findHoogleBinInLibrary getHoogleBinPath2 + p3 <- getHoogleBinPathCabalAPI + p4 <- getHoogleBinPathCabalDir + p5 <- getHoogleBinPathMacOsDir + let placesToSearch = (catMaybes [extraPath, p1, p2]) ++ [p4, p5] ++ p3 + findPathsAndCheck placesToSearch + +findPathsAndCheck :: [String] -> IO (Maybe String) +findPathsAndCheck [] = return Nothing +findPathsAndCheck (f:fs) = do r <- findPathAndCheck f + case r of + Nothing -> findPathsAndCheck fs + _ -> return r + +findPathAndCheck :: String -> IO (Maybe String) +findPathAndCheck path = do + exists <- doesFileExist path + if exists + then return (Just path) + else return Nothing + +findHoogleBinInLibrary :: (String -> String) -> IO (Maybe String) +findHoogleBinInLibrary f = do minfo <- findHoogleInfo + case minfo of + Nothing -> return Nothing + Just info -> let [libDir] = libraryDirs info + in return $ Just (f libDir) + +findHoogleInfo :: IO (Maybe InstalledPackageInfo) +findHoogleInfo = do infos' <- getPkgInfos + let infos = removeSmallVersions $ concat $ map snd infos' + return $ find (\m -> (pkgName (sourcePackageId m)) == PackageName "hoogle") infos + +removeSmallVersions :: [InstalledPackageInfo] -> [InstalledPackageInfo] +removeSmallVersions pids = filter + (not . (\InstalledPackageInfo { sourcePackageId = (PackageIdentifier name version) } -> + any (\InstalledPackageInfo { sourcePackageId = (PackageIdentifier name' version') } -> + name' == name && version' > version) + pids)) + pids + +getHoogleBinPath1 :: String -> String +getHoogleBinPath1 path = let (_:(_:(_:rest))) = reverse $ splitDirectories path + in (joinPath $ reverse ("bin":rest)) </> "hoogle" <.> exeExtension + +getHoogleBinPath2 :: String -> String +getHoogleBinPath2 path = let (_:(_:rest)) = reverse $ splitDirectories path + in (joinPath $ reverse ("bin":rest)) </> "hoogle" <.> exeExtension + +getHoogleBinPathCabalAPI :: IO [String] +getHoogleBinPathCabalAPI = do + let ci=buildCompilerFlavor + mapM (getBinDir ci) [True,False] + +getBinDir :: CompilerFlavor -> Bool -> IO FilePath +getBinDir ci user=do + ids<-defaultInstallDirs ci user True + let env=installDirsTemplateEnv ids + return $ fromPathTemplate $ substPathTemplate env $ bindir ids + +getHoogleBinPathCabalDir :: IO String +getHoogleBinPathCabalDir = do + cabalDir <- getAppUserDataDirectory "cabal" + return (cabalDir </> "bin" </> "hoogle" <.> exeExtension) + +getHoogleBinPathMacOsDir :: IO String +getHoogleBinPathMacOsDir = do + homeDir <- getHomeDirectory + return (homeDir </> "Library" </> "Haskell" </> "bin" </> "hoogle" <.> exeExtension) + +exeExtension :: String +#ifdef mingw32_HOST_OS +exeExtension = "exe" +#else +exeExtension = "" +#endif + +-- This part is commented out because Cabal does not work +-- well linking with the Hoogle library. +-- Instead, `hoogle` is called directly and the results +-- are parsed and converted into database items. + +{- +-- |Loads the Hoogle search database into memory. +-- If no database is found, an empty one is returned. +getHoogleDatabases :: IO H.Database +getHoogleDatabases = do path <- findHoogleDatabasesPath + case path of + Nothing -> return mempty + Just p -> do files <- getDirectoryContents p + hooFiles <- filterM (\f -> do exists <- doesFileExist f + let isHoo = takeExtension f == ".hoo" + return $ exists && isHoo) + files + dbs <- mapM H.loadDatabase hooFiles + return $ mconcat dbs + +findHoogleDatabasesPath :: IO (Maybe String) +findHoogleDatabasesPath = do minfo <- findHoogleInfo + case minfo of + Nothing -> return Nothing + Just info -> let [libDir] = libraryDirs info + in return $ Just (getDatabasesDir libDir) + +getDatabasesDir :: String -> String +getDatabasesDir path = let (_:(hoogleV:(_:rest))) = reverse $ splitDirectories path + in (joinPath $ reverse (hoogleV:("share":rest))) </> "databases" +-}
src/Server/PersistentCommands.hs view
@@ -1,170 +1,176 @@-{-# 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 CurrentDatabase- | GetModules CurrentDatabase String- | GetDeclarations CurrentDatabase String - | HoogleQuery CurrentDatabase String- | HoogleDownloadData- | HoogleCheckDatabase- | GetDeclarationModules CurrentDatabase String- | SetExtraHooglePath String- | Quit--data CurrentDatabase = AllPackages- | HackageDatabase- | LocalDatabase- | APackage DbPackageIdentifier--data BrowserState = BrowserState- { localDb :: Maybe FilePath- , hackageDb :: Maybe FilePath- , extraHooglePath :: Maybe String- }---initialState :: BrowserState-initialState = BrowserState Nothing Nothing Nothing --True True Nothing--useLocal :: CurrentDatabase -> Bool-useLocal HackageDatabase=False-useLocal _=True--useHackage :: CurrentDatabase -> Bool-useHackage LocalDatabase=False-useHackage _=True--filterPackage :: CurrentDatabase -> Maybe DbPackageIdentifier-filterPackage (APackage pkgId)=Just pkgId-filterPackage _ = Nothing--runWithState :: BrowserState -> CurrentDatabase -> (Maybe DbPackageIdentifier -> SqlPersist IO [a]) -> IO [a]-runWithState (BrowserState lDb hDb _) cdb action =- do - let filterPkg=filterPackage cdb- localThings <- runWithState' (useLocal cdb) lDb (action filterPkg)- hackageThings <- runWithState' (useHackage cdb) 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 :: CurrentDatabase -> (Maybe DbPackageIdentifier -> SqlPersist IO [a]) -> BrowserM [a]-runDb cdb action = - do - st <- get- lift $ runWithState st cdb 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 $ do- runMigration migrateAll- createIndexes- 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 { localDb = Nothing })- return (String "ok", True) -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 $ do- runMigration migrateAll- createIndexes- 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 })- return (String "ok", True) -executeCommand (GetPackages cdb) = do pkgs <- runDb cdb allPackages- return (toJSON pkgs, True)-executeCommand (GetModules cdb mname) = - do smods <- runDb cdb (getSubmodules mname)- return (toJSON smods, True)-executeCommand (GetDeclarations cdb mname) = - do decls <- runDb cdb (getDeclsInModule mname)- return (toJSON decls, True)-executeCommand (HoogleQuery cdb query) = - do extraH <- fmap extraHooglePath get- results <- runDb cdb (\_ -> 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 cdb d) = - do mods <- runDb cdb (\_ -> 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" -> GetPackages <$> v .: "db"- "get-modules" -> GetModules <$> v .: "db"- <*> v .: "module"- "get-declarations" -> GetDeclarations <$>v .: "db"- <*> v .: "module"- "hoogle-query" -> HoogleQuery <$> v .: "db"- <*> v .: "query"- "hoogle-data" -> pure HoogleDownloadData- "hoogle-check" -> pure HoogleCheckDatabase- "extra-hoogle-path" -> SetExtraHooglePath <$> v .: "path"- "get-decl-module" -> GetDeclarationModules <$> v .: "db"- <*> 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 CurrentDatabase + | GetModules CurrentDatabase String + | GetDeclarations CurrentDatabase String + | HoogleQuery CurrentDatabase String + | HoogleDownloadData + | HoogleCheckDatabase + | GetDeclarationModules CurrentDatabase String + | SetExtraHooglePath String + | GetDeclarationsFromPrefix CurrentDatabase String + | Quit + +data CurrentDatabase = AllPackages + | HackageDatabase + | LocalDatabase + | APackage DbPackageIdentifier + +data BrowserState = BrowserState + { localDb :: Maybe FilePath + , hackageDb :: Maybe FilePath + , extraHooglePath :: Maybe String + } + + +initialState :: BrowserState +initialState = BrowserState Nothing Nothing Nothing --True True Nothing + +useLocal :: CurrentDatabase -> Bool +useLocal HackageDatabase=False +useLocal _=True + +useHackage :: CurrentDatabase -> Bool +useHackage LocalDatabase=False +useHackage _=True + +filterPackage :: CurrentDatabase -> Maybe DbPackageIdentifier +filterPackage (APackage pkgId)=Just pkgId +filterPackage _ = Nothing + +runWithState :: BrowserState -> CurrentDatabase -> (Maybe DbPackageIdentifier -> SqlPersist IO [a]) -> IO [a] +runWithState (BrowserState lDb hDb _) cdb action = + do + let filterPkg=filterPackage cdb + localThings <- runWithState' (useLocal cdb) lDb (action filterPkg) + hackageThings <- runWithState' (useHackage cdb) 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 :: CurrentDatabase -> (Maybe DbPackageIdentifier -> SqlPersist IO [a]) -> BrowserM [a] +runDb cdb action = + do + st <- get + lift $ runWithState st cdb 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 $ do + runMigration migrateAll + createIndexes + 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 { localDb = Nothing }) + return (String "ok", True) +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 $ do + runMigration migrateAll + createIndexes + 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 }) + return (String "ok", True) +executeCommand (GetPackages cdb) = do pkgs <- runDb cdb allPackages + return (toJSON pkgs, True) +executeCommand (GetModules cdb mname) = + do smods <- runDb cdb (getSubmodules mname) + return (toJSON smods, True) +executeCommand (GetDeclarations cdb mname) = + do decls <- runDb cdb (getDeclsInModule mname) + return (toJSON decls, True) +executeCommand (GetDeclarationsFromPrefix cdb prefix) = + do decls <- runDb cdb (getDeclsFromPrefix prefix) + return (toJSON decls, True) +executeCommand (HoogleQuery cdb query) = + do extraH <- fmap extraHooglePath get + results <- runDb cdb (\_ -> 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 cdb d) = + do mods <- runDb cdb (\_ -> 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" -> GetPackages <$> v .: "db" + "get-modules" -> GetModules <$> v .: "db" + <*> v .: "module" + "get-declarations" -> GetDeclarations <$>v .: "db" + <*> v .: "module" + "get-decl-prefix" -> GetDeclarationsFromPrefix <$>v .: "db" + <*> v .: "prefix" + "hoogle-query" -> HoogleQuery <$> v .: "db" + <*> v .: "query" + "hoogle-data" -> pure HoogleDownloadData + "hoogle-check" -> pure HoogleCheckDatabase + "extra-hoogle-path" -> SetExtraHooglePath <$> v .: "path" + "get-decl-module" -> GetDeclarationModules <$> v .: "db" + <*> 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