scion-browser 0.1.3.1 → 0.1.3.2
raw patch · 26 files changed
+3189/−3358 lines, 26 filessetup-changednew-uploader
Files
- Setup.hs +2/−2
- docs/LICENSE +29/−29
- scion-browser.cabal +117/−117
- scion-browser.cabal~ +0/−173
- src/Main.hs +28/−28
- src/Scion/Browser.hs +35/−35
- src/Scion/Browser/Build.hs +184/−184
- src/Scion/Browser/FileUtil.hs +90/−90
- src/Scion/Browser/FromMissingH.hs +98/−98
- src/Scion/Browser/Instances/Json.hs +131/−131
- src/Scion/Browser/Instances/NFData.hs +85/−85
- src/Scion/Browser/Instances/Serialize.hs +498/−498
- src/Scion/Browser/Parser.hs +98/−98
- src/Scion/Browser/Parser/Documentable.hs +88/−88
- src/Scion/Browser/Parser/Internal.hs +543/−543
- src/Scion/Browser/Query.hs +110/−110
- src/Scion/Browser/TempFile.hs +220/−220
- src/Scion/Browser/Types.hs +90/−90
- src/Scion/Browser/Util.hs +52/−48
- src/Scion/Hoogle.hs +46/−46
- src/Scion/Hoogle/Instances/Json.hs +28/−28
- src/Scion/Hoogle/Parser.hs +122/−122
- src/Scion/Hoogle/Types.hs +15/−15
- src/Scion/Hoogle/Util.hs +117/−117
- src/Scion/Packages.hs +200/−200
- src/Server/Commands.hs +163/−163
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,117 +1,117 @@-name: scion-browser-version: 0.1.3.1-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: - base == 4.*,- mtl >= 2,- derive >= 2.5 && < 3,- text == 0.11.*,- parsec >= 3 && < 4,- cereal == 0.3.*,- 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-native >= 0.3.2,- parallel-io >= 0.3,- utf8-string ,- -- 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.*,- -- For Scion.Packages (provisional)- ghc >= 6.10 && < 6.13- - exposed-modules:- Scion.Browser,- Scion.Browser.Query,- Scion.Browser.Build,- Scion.Hoogle- - ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -fno-warn-orphans- other-modules: Scion.Browser.Instances.Json, Scion.Browser.Instances.NFData, Scion.Browser.Instances.Serialize, Scion.Browser.Parser.Documentable, Scion.Browser.Parser.Internal, Scion.Browser.FileUtil, Scion.Browser.Parser, Scion.Browser.TempFile, Scion.Browser.Types, Scion.Browser.Util, Scion.Hoogle.Instances.Json, Scion.Hoogle.Parser, Scion.Hoogle.Types, Scion.Hoogle.Util, Scion.Packages, Scion.Browser.FromMissingH--executable scion-browser- hs-source-dirs: src- main-is: Main.hs- build-depends:- haskeline >= 0.6,- attoparsec >= 0.8,- -- From library- base == 4.*,- mtl >= 2,- derive >= 2.5 && < 3,- text == 0.11.*,- parsec >= 3 && < 4,- cereal == 0.3.*,- 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-native >= 0.3.2,- parallel-io >= 0.3,- utf8-string ,- -- 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.*,- -- For Scion.Packages (provisional)- ghc >= 6.10 && < 6.13- - ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -fno-warn-orphans -threaded- other-modules: Server.Commands, Scion.Browser.Instances.Json, Scion.Browser.Instances.NFData, Scion.Browser.Instances.Serialize, Scion.Browser.Parser.Documentable, Scion.Browser.Parser.Internal, Scion.Browser.Build, Scion.Browser.FileUtil, Scion.Browser.Parser, Scion.Browser.Query, Scion.Browser.TempFile, Scion.Browser.Types, Scion.Browser.Util, Scion.Hoogle.Instances.Json, Scion.Hoogle.Parser, Scion.Hoogle.Types, Scion.Hoogle.Util, Scion.Browser, Scion.Hoogle, Scion.Packages, Scion.Browser.FromMissingH-+name: scion-browser +version: 0.1.3.2 +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: + base == 4.*, + mtl >= 2, + derive >= 2.5 && < 3, + text == 0.11.*, + parsec >= 3 && < 4, + cereal == 0.3.*, + 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-native >= 0.3.2, + parallel-io >= 0.3, + utf8-string , + -- 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.*, + -- For Scion.Packages (provisional) + ghc >= 6.10 && < 6.13 + + exposed-modules: + Scion.Browser, + Scion.Browser.Query, + Scion.Browser.Build, + Scion.Hoogle + + ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -fno-warn-orphans + other-modules: Scion.Browser.Instances.Json, Scion.Browser.Instances.NFData, Scion.Browser.Instances.Serialize, Scion.Browser.Parser.Documentable, Scion.Browser.Parser.Internal, Scion.Browser.FileUtil, Scion.Browser.Parser, Scion.Browser.TempFile, Scion.Browser.Types, Scion.Browser.Util, Scion.Hoogle.Instances.Json, Scion.Hoogle.Parser, Scion.Hoogle.Types, Scion.Hoogle.Util, Scion.Packages, Scion.Browser.FromMissingH + +executable scion-browser + hs-source-dirs: src + main-is: Main.hs + build-depends: + haskeline >= 0.6, + attoparsec >= 0.8, + -- From library + base == 4.*, + mtl >= 2, + derive >= 2.5 && < 3, + text == 0.11.*, + parsec >= 3 && < 4, + cereal == 0.3.*, + 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-native >= 0.3.2, + parallel-io >= 0.3, + utf8-string , + -- 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.*, + -- For Scion.Packages (provisional) + ghc >= 6.10 && < 6.13 + + ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -fno-warn-orphans -threaded + other-modules: Server.Commands, Scion.Browser.Instances.Json, Scion.Browser.Instances.NFData, Scion.Browser.Instances.Serialize, Scion.Browser.Parser.Documentable, Scion.Browser.Parser.Internal, Scion.Browser.Build, Scion.Browser.FileUtil, Scion.Browser.Parser, Scion.Browser.Query, Scion.Browser.TempFile, Scion.Browser.Types, Scion.Browser.Util, Scion.Hoogle.Instances.Json, Scion.Hoogle.Parser, Scion.Hoogle.Types, Scion.Hoogle.Util, Scion.Browser, Scion.Hoogle, Scion.Packages, Scion.Browser.FromMissingH +
− scion-browser.cabal~
@@ -1,173 +0,0 @@-name: scion-browser-version: 0.1.3.1-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: - base == 4.*,- mtl >= 2,- derive >= 2.5 && < 3,- text == 0.11.*,- parsec >= 3 && < 4,- cereal == 0.3.*,- 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-native >= 0.3.2,- parallel-io >= 0.3,- utf8-string ,- -- 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.*,- -- For Scion.Packages (provisional)- ghc >= 6.10 && < 6.13- - exposed-modules:- Scion.Browser,- Scion.Browser.Query,- Scion.Browser.Build,- Scion.Hoogle- - ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -fno-warn-orphans- other-modules: Scion.Browser.Instances.Json, Scion.Browser.Instances.NFData, Scion.Browser.Instances.Serialize, Scion.Browser.Parser.Documentable, Scion.Browser.Parser.Internal, Scion.Browser.FileUtil, Scion.Browser.Parser, Scion.Browser.TempFile, Scion.Browser.Types, Scion.Browser.Util, Scion.Hoogle.Instances.Json, Scion.Hoogle.Parser, Scion.Hoogle.Types, Scion.Hoogle.Util, Scion.Packages, Scion.Browser.FromMissingH--executable scion-browser- hs-source-dirs: src- main-is: Main.hs- build-depends:- haskeline >= 0.6,- attoparsec >= 0.8,- -- From library- base == 4.*,- mtl >= 2,- derive >= 2.5 && < 3,- text == 0.11.*,- parsec >= 3 && < 4,- cereal == 0.3.*,- 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-native >= 0.3.2,- parallel-io >= 0.3,- utf8-string ,- -- 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.*,- -- For Scion.Packages (provisional)- ghc >= 6.10 && < 6.13- - ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -fno-warn-orphans -threaded- other-modules: Server.Commands, Scion.Browser.Instances.Json, Scion.Browser.Instances.NFData, Scion.Browser.Instances.Serialize, Scion.Browser.Parser.Documentable, Scion.Browser.Parser.Internal, Scion.Browser.Build, Scion.Browser.FileUtil, Scion.Browser.Parser, Scion.Browser.Query, Scion.Browser.TempFile, Scion.Browser.Types, Scion.Browser.Util, Scion.Hoogle.Instances.Json, Scion.Hoogle.Parser, Scion.Hoogle.Types, Scion.Hoogle.Util, Scion.Browser, Scion.Hoogle, Scion.Packages, Scion.Browser.FromMissingH--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- - build-depends:- HUnit >= 1.2 && < 2,- QuickCheck >= 2.4,- test-framework >= 0.4.1,- test-framework-quickcheck2,- test-framework-hunit,- split,- haskeline >= 0.6,- attoparsec >= 0.8,- -- From library- base == 4.*,- mtl >= 2,- derive >= 2.5 && < 3,- text == 0.11.*,- parsec >= 3 && < 4,- cereal == 0.3.*,- 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-native >= 0.3.2,- parallel-io >= 0.3,- utf8-string ,- -- 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.*,- -- For Scion.Packages (provisional)- ghc >= 6.10 && < 6.13
src/Main.hs view
@@ -1,28 +1,28 @@-module Main where--import Control.Monad.State-import Data.Aeson-import qualified Data.Aeson.Types as T-import qualified Data.Attoparsec.Char8 as Atto-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy.Char8 as LBS-import Server.Commands-import System.Console.Haskeline--main :: IO ()-main = do runStateT (runInputT defaultSettings loop) initialState- return ()--loop :: InputT BrowserM ()-loop = do maybeLine <- getInputLine ""- case maybeLine of- Nothing -> return () -- ctrl+D or EOF- Just line -> do- case Atto.parse json (BS.pack line) of- Atto.Fail _ _ e -> outputStrLn ("error in command: " ++ e) >> loop- Atto.Done _ value -> case T.parse parseJSON value of- Error e -> outputStrLn ("error in command: " ++ e) >> loop- Success cmd -> do (res, continue) <- lift $ executeCommand cmd- liftIO $ LBS.putStrLn $ encode res- if continue then loop else return ()-+module Main where + +import Control.Monad.State +import Data.Aeson +import qualified Data.Aeson.Types as T +import qualified Data.Attoparsec.Char8 as Atto +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LBS +import Server.Commands +import System.Console.Haskeline + +main :: IO () +main = do runStateT (runInputT defaultSettings loop) initialState + return () + +loop :: InputT BrowserM () +loop = do maybeLine <- getInputLine "" + case maybeLine of + Nothing -> return () -- ctrl+D or EOF + Just line -> do + case Atto.parse json (BS.pack line) of + Atto.Fail _ _ e -> outputStrLn ("error in command: " ++ e) >> loop + Atto.Done _ value -> case T.parse parseJSON value of + Error e -> outputStrLn ("error in command: " ++ e) >> loop + Success cmd -> do (res, continue) <- lift $ executeCommand cmd + liftIO $ LBS.putStrLn $ encode res + if continue then loop else return () +
src/Scion/Browser.hs view
@@ -1,35 +1,35 @@-module Scion.Browser-( saveDatabase-, loadDatabase-, singletonDatabase-, module Scion.Browser.Types-, module Scion.Browser.Instances.Json--- , module Scion.Browser.Instances.NFData-, module Scion.Browser.Instances.Serialize-) where--import Control.DeepSeq-import qualified Data.ByteString as BS-import qualified Data.Map as M-import Data.Serialize-import Scion.Browser.Types-import Scion.Browser.Instances.Json-import Scion.Browser.Instances.NFData ()-import Scion.Browser.Instances.Serialize-import System.IO--saveDatabase :: FilePath -> Database -> IO ()-saveDatabase fpath db = withFile fpath WriteMode $- \hnd -> do BS.hPut hnd (encode db)- hFlush hnd--loadDatabase :: FilePath -> IO (Maybe Database)-loadDatabase fpath = withFile fpath ReadMode $- \hnd -> do s <- BS.hGetContents hnd- return $ case decode s of- Left _ -> Nothing- Right p -> p `deepseq` Just p--singletonDatabase :: Documented Package -> Database-singletonDatabase pkg@(Package _ pid _) = M.singleton pid pkg-+module Scion.Browser +( saveDatabase +, loadDatabase +, singletonDatabase +, module Scion.Browser.Types +, module Scion.Browser.Instances.Json +-- , module Scion.Browser.Instances.NFData +, module Scion.Browser.Instances.Serialize +) where + +import Control.DeepSeq +import qualified Data.ByteString as BS +import qualified Data.Map as M +import Data.Serialize +import Scion.Browser.Types +import Scion.Browser.Instances.Json +import Scion.Browser.Instances.NFData () +import Scion.Browser.Instances.Serialize +import System.IO + +saveDatabase :: FilePath -> Database -> IO () +saveDatabase fpath db = withFile fpath WriteMode $ + \hnd -> do BS.hPut hnd (encode db) + hFlush hnd + +loadDatabase :: FilePath -> IO (Maybe Database) +loadDatabase fpath = withFile fpath ReadMode $ + \hnd -> do s <- BS.hGetContents hnd + return $ case decode s of + Left _ -> Nothing + Right p -> p `deepseq` Just p + +singletonDatabase :: Documented Package -> Database +singletonDatabase pkg@(Package _ pid _) = M.singleton pid pkg +
src/Scion/Browser/Build.hs view
@@ -1,184 +1,184 @@-{-# LANGUAGE ScopedTypeVariables #-}--module Scion.Browser.Build-( saveHackageDatabase-, createHackageDatabase-, updateDatabase-, createCabalDatabase-, getCabalHoogle-) where--import Control.Concurrent.ParallelIO.Local-import Control.DeepSeq-import Control.Exception as E (catch, SomeException)-import Data.Either (rights)-import Data.List ((\\), nub)-import qualified Data.Map as M-import Data.Version (Version, showVersion)-import Distribution.InstalledPackageInfo-import Distribution.Package hiding (Package)-import Scion.Browser-import Scion.Browser.Parser-import Scion.Browser.FileUtil-import Scion.Browser.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)---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- saveDatabase file 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 (Database, [(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 (pkgListToDb pkgs, errors)---- | Updates a database with changes in the installed package base.-updateDatabase :: Database -> [InstalledPackageInfo] -> IO Database-updateDatabase oldDb pkgInfo = do let dbList = nub $ map fst $ M.toList oldDb- installedList = nub $ removeSmallVersions $ map sourcePackageId pkgInfo- toRemove = dbList \\ installedList- toAdd = installedList \\ dbList- filteredDb = foldr (\pid db -> M.delete pid db) oldDb toRemove- let ghcVersion = getGhcInstalledVersion installedList- logToStdout $ "Adding " ++ show (map (\(PackageIdentifier (PackageName name) _) -> name) toAdd)- (addedDb, errors) <- createCabalDatabase' ghcVersion toAdd True- logToStdout $ show errors- return $ M.union filteredDb addedDb--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 (Database, [(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 (Database, [(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 `deepseq` pkgListToDb 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.Browser.Build +( saveHackageDatabase +, createHackageDatabase +, updateDatabase +, createCabalDatabase +, getCabalHoogle +) where + +import Control.Concurrent.ParallelIO.Local +import Control.DeepSeq +import Control.Exception as E (catch, SomeException) +import Data.Either (rights) +import Data.List ((\\), nub) +import qualified Data.Map as M +import Data.Version (Version, showVersion) +import Distribution.InstalledPackageInfo +import Distribution.Package hiding (Package) +import Scion.Browser +import Scion.Browser.Parser +import Scion.Browser.FileUtil +import Scion.Browser.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) + + +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 + saveDatabase file 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 (Database, [(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 (pkgListToDb pkgs, errors) + +-- | Updates a database with changes in the installed package base. +updateDatabase :: Database -> [InstalledPackageInfo] -> IO Database +updateDatabase oldDb pkgInfo = do let dbList = nub $ map fst $ M.toList oldDb + installedList = nub $ removeSmallVersions $ map sourcePackageId pkgInfo + toRemove = dbList \\ installedList + toAdd = installedList \\ dbList + filteredDb = foldr (\pid db -> M.delete pid db) oldDb toRemove + let ghcVersion = getGhcInstalledVersion installedList + logToStdout $ "Adding " ++ show (map (\(PackageIdentifier (PackageName name) _) -> name) toAdd) + (addedDb, errors) <- createCabalDatabase' ghcVersion toAdd True + logToStdout $ show errors + return $ M.union filteredDb addedDb + +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 (Database, [(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 (Database, [(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 `deepseq` pkgListToDb 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 +
src/Scion/Browser/FileUtil.hs view
@@ -1,90 +1,90 @@-{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface #-}--module Scion.Browser.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.Browser.TempFile---- |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 - 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.Browser.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.Browser.TempFile + +-- |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 + 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/Browser/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.Browser.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.Browser.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/Browser/Instances/Json.hs view
@@ -1,131 +1,131 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}--module Scion.Browser.Instances.Json where--import Control.Applicative-import Control.Monad-import Data.Aeson-import Data.Version-import qualified Data.Text as T-import Distribution.Package hiding (Package)-import Scion.Browser.Types-import Language.Haskell.Exts.Annotated.Syntax hiding (String)-import Language.Haskell.Exts.Pretty-import Text.ParserCombinators.ReadP--instance ToJSON (Documented Package) where- toJSON (Package doc pid _) = object [ T.pack "id" .= pid- , T.pack "doc" .= doc- ]--instance ToJSON PackageIdentifier where- toJSON (PackageIdentifier (PackageName name) version) = object [ T.pack "name" .= name- , T.pack "version" .= version- ]-instance FromJSON PackageIdentifier where- parseJSON (Object v) = PackageIdentifier <$> (PackageName <$> v .: T.pack "name")- <*> v .: T.pack "version"- parseJSON _ = mzero--instance ToJSON Version where- toJSON = String . T.pack . showVersion--instance FromJSON Version where- parseJSON version = (fst . last . readP_to_S parseVersion . T.unpack) <$> parseJSON version--instance ToJSON Doc where- toJSON (NoDoc) = Null- toJSON (Doc txt) = String txt--instance ToJSON (Name l) where- toJSON = String . T.pack . getNameString--instance ToJSON (QName l) where- toJSON = String . T.pack . getQNameString--singleLinePrettyPrint :: Pretty a => a -> String-singleLinePrettyPrint = prettyPrintWithMode $ defaultMode { layout = PPNoLayout }--instance ToJSON (Kind l) where- toJSON = String . T.pack . singleLinePrettyPrint--instance ToJSON (Type l) where- toJSON = String . T.pack . singleLinePrettyPrint--instance ToJSON (Documented Module) where- toJSON (Module doc (Just (ModuleHead _ (ModuleName _ name) _ _)) _ _ _) = object [ T.pack "doc" .= doc- , T.pack "name" .= name- ]- toJSON _ = Null--maybeEmptyContext :: Maybe (Documented Context) -> Documented Context-maybeEmptyContext Nothing = CxEmpty NoDoc-maybeEmptyContext (Just ctx) = ctx--instance ToJSON (Documented Decl) where- toJSON (GDataDecl doc dOrM ctx hd kind decls _) = object [ T.pack "doc" .= doc- , T.pack "type" .= dOrM- , T.pack "context" .= maybeEmptyContext ctx- , T.pack "head" .= hd- , T.pack "kind" .= kind- , T.pack "decls" .= decls- ]- toJSON (ClassDecl doc ctx hd fdeps _) = object [ T.pack "doc" .= doc- , T.pack "type" .= T.pack "class"- , T.pack "context" .= maybeEmptyContext ctx- , T.pack "head" .= hd- , T.pack "fundeps" .= fdeps- ]- toJSON (InstDecl doc ctx hd _) = object [ T.pack "doc" .= doc- , T.pack "type" .= T.pack "instance"- , T.pack "context" .= maybeEmptyContext ctx- , T.pack "head" .= hd- ]- toJSON (TypeSig doc names ty) = object [ T.pack "doc" .= doc- , T.pack "type" .= T.pack "signature"- , T.pack "name" .= names- , T.pack "signature" .= ty- ]- toJSON (TypeDecl doc hd ty) = object [ T.pack "doc" .= doc- , T.pack "type" .= T.pack "type"- , T.pack "head" .= hd- , T.pack "equals" .= ty- ]- toJSON _ = Null--instance ToJSON (Context l) where- toJSON (CxSingle _ a) = toJSON [a]- toJSON (CxTuple _ as) = toJSON as- toJSON (CxParen _ ctx) = toJSON ctx- toJSON (CxEmpty _) = toJSON ([] :: [Asst l])--instance ToJSON (Asst l) where- toJSON = String . T.pack . singleLinePrettyPrint--instance ToJSON (DataOrNew l) where- toJSON (DataType _) = String $ T.pack "data"- toJSON (NewType _) = String $ T.pack "newtype"--instance ToJSON (DeclHead l) where- toJSON (DHead _ name vars) = object [ T.pack "name" .= name- , T.pack "vars" .= vars- ]- toJSON _ = Null--instance ToJSON (TyVarBind l) where- toJSON = String . T.pack . singleLinePrettyPrint--instance ToJSON (FunDep l) where- toJSON = String . T.pack . singleLinePrettyPrint--instance ToJSON (InstHead l) where- toJSON (IHead _ name vars) = object [ T.pack "name" .= name- , T.pack "vars" .= vars- ]- toJSON _ = Null--instance ToJSON (Documented GadtDecl) where- toJSON (GadtDecl _ name ty) = object [ T.pack "name" .= name- , T.pack "type" .= ty- ]-+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} + +module Scion.Browser.Instances.Json where + +import Control.Applicative +import Control.Monad +import Data.Aeson +import Data.Version +import qualified Data.Text as T +import Distribution.Package hiding (Package) +import Scion.Browser.Types +import Language.Haskell.Exts.Annotated.Syntax hiding (String) +import Language.Haskell.Exts.Pretty +import Text.ParserCombinators.ReadP + +instance ToJSON (Documented Package) where + toJSON (Package doc pid _) = object [ T.pack "id" .= pid + , T.pack "doc" .= doc + ] + +instance ToJSON PackageIdentifier where + toJSON (PackageIdentifier (PackageName name) version) = object [ T.pack "name" .= name + , T.pack "version" .= version + ] +instance FromJSON PackageIdentifier where + parseJSON (Object v) = PackageIdentifier <$> (PackageName <$> v .: T.pack "name") + <*> v .: T.pack "version" + parseJSON _ = mzero + +instance ToJSON Version where + toJSON = String . T.pack . showVersion + +instance FromJSON Version where + parseJSON version = (fst . last . readP_to_S parseVersion . T.unpack) <$> parseJSON version + +instance ToJSON Doc where + toJSON (NoDoc) = Null + toJSON (Doc txt) = String txt + +instance ToJSON (Name l) where + toJSON = String . T.pack . getNameString + +instance ToJSON (QName l) where + toJSON = String . T.pack . getQNameString + +singleLinePrettyPrint :: Pretty a => a -> String +singleLinePrettyPrint = prettyPrintWithMode $ defaultMode { layout = PPNoLayout } + +instance ToJSON (Kind l) where + toJSON = String . T.pack . singleLinePrettyPrint + +instance ToJSON (Type l) where + toJSON = String . T.pack . singleLinePrettyPrint + +instance ToJSON (Documented Module) where + toJSON (Module doc (Just (ModuleHead _ (ModuleName _ name) _ _)) _ _ _) = object [ T.pack "doc" .= doc + , T.pack "name" .= name + ] + toJSON _ = Null + +maybeEmptyContext :: Maybe (Documented Context) -> Documented Context +maybeEmptyContext Nothing = CxEmpty NoDoc +maybeEmptyContext (Just ctx) = ctx + +instance ToJSON (Documented Decl) where + toJSON (GDataDecl doc dOrM ctx hd kind decls _) = object [ T.pack "doc" .= doc + , T.pack "type" .= dOrM + , T.pack "context" .= maybeEmptyContext ctx + , T.pack "head" .= hd + , T.pack "kind" .= kind + , T.pack "decls" .= decls + ] + toJSON (ClassDecl doc ctx hd fdeps _) = object [ T.pack "doc" .= doc + , T.pack "type" .= T.pack "class" + , T.pack "context" .= maybeEmptyContext ctx + , T.pack "head" .= hd + , T.pack "fundeps" .= fdeps + ] + toJSON (InstDecl doc ctx hd _) = object [ T.pack "doc" .= doc + , T.pack "type" .= T.pack "instance" + , T.pack "context" .= maybeEmptyContext ctx + , T.pack "head" .= hd + ] + toJSON (TypeSig doc names ty) = object [ T.pack "doc" .= doc + , T.pack "type" .= T.pack "signature" + , T.pack "name" .= names + , T.pack "signature" .= ty + ] + toJSON (TypeDecl doc hd ty) = object [ T.pack "doc" .= doc + , T.pack "type" .= T.pack "type" + , T.pack "head" .= hd + , T.pack "equals" .= ty + ] + toJSON _ = Null + +instance ToJSON (Context l) where + toJSON (CxSingle _ a) = toJSON [a] + toJSON (CxTuple _ as) = toJSON as + toJSON (CxParen _ ctx) = toJSON ctx + toJSON (CxEmpty _) = toJSON ([] :: [Asst l]) + +instance ToJSON (Asst l) where + toJSON = String . T.pack . singleLinePrettyPrint + +instance ToJSON (DataOrNew l) where + toJSON (DataType _) = String $ T.pack "data" + toJSON (NewType _) = String $ T.pack "newtype" + +instance ToJSON (DeclHead l) where + toJSON (DHead _ name vars) = object [ T.pack "name" .= name + , T.pack "vars" .= vars + ] + toJSON _ = Null + +instance ToJSON (TyVarBind l) where + toJSON = String . T.pack . singleLinePrettyPrint + +instance ToJSON (FunDep l) where + toJSON = String . T.pack . singleLinePrettyPrint + +instance ToJSON (InstHead l) where + toJSON (IHead _ name vars) = object [ T.pack "name" .= name + , T.pack "vars" .= vars + ] + toJSON _ = Null + +instance ToJSON (Documented GadtDecl) where + toJSON (GadtDecl _ name ty) = object [ T.pack "name" .= name + , T.pack "type" .= ty + ] +
src/Scion/Browser/Instances/NFData.hs view
@@ -1,85 +1,85 @@-{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-}--module Scion.Browser.Instances.NFData where--import Control.DeepSeq-import Data.DeriveTH-import Distribution.Package hiding (Package)-import Distribution.Version-import Language.Haskell.Exts.Annotated.Syntax-import Scion.Browser.Types--$( derive makeNFData ''Doc )-$( derive makeNFData ''Package )-$( derive makeNFData ''PackageIdentifier )-$( derive makeNFData ''PackageName )-$( derive makeNFData ''Version )---- derive NFData instances for haskell-src-exts-$( derive makeNFData ''Module )-$( derive makeNFData ''ModuleHead )-$( derive makeNFData ''WarningText )-$( derive makeNFData ''ExportSpecList )-$( derive makeNFData ''ExportSpec )-$( derive makeNFData ''ImportDecl )-$( derive makeNFData ''ImportSpecList )-$( derive makeNFData ''ImportSpec )-$( derive makeNFData ''Assoc )-$( derive makeNFData ''Decl )-$( derive makeNFData ''DeclHead )-$( derive makeNFData ''InstHead )-$( derive makeNFData ''Binds )-$( derive makeNFData ''IPBind )-$( derive makeNFData ''ClassDecl )-$( derive makeNFData ''InstDecl )-$( derive makeNFData ''Deriving )-$( derive makeNFData ''DataOrNew )-$( derive makeNFData ''ConDecl )-$( derive makeNFData ''FieldDecl )-$( derive makeNFData ''QualConDecl )-$( derive makeNFData ''GadtDecl )-$( derive makeNFData ''BangType )-$( derive makeNFData ''Match )-$( derive makeNFData ''Rhs )-$( derive makeNFData ''GuardedRhs )-$( derive makeNFData ''Context )-$( derive makeNFData ''FunDep )-$( derive makeNFData ''Asst )-$( derive makeNFData ''Type )-$( derive makeNFData ''Boxed )-$( derive makeNFData ''Kind )-$( derive makeNFData ''TyVarBind )-$( derive makeNFData ''Exp )-$( derive makeNFData ''Stmt )-$( derive makeNFData ''QualStmt )-$( derive makeNFData ''FieldUpdate )-$( derive makeNFData ''Alt )-$( derive makeNFData ''GuardedAlts )-$( derive makeNFData ''GuardedAlt )-$( derive makeNFData ''XAttr )-$( derive makeNFData ''Pat )-$( derive makeNFData ''PatField )-$( derive makeNFData ''PXAttr )-$( derive makeNFData ''RPat )-$( derive makeNFData ''RPatOp )-$( derive makeNFData ''Literal )-$( derive makeNFData ''ModuleName )-$( derive makeNFData ''QName )-$( derive makeNFData ''Name )-$( derive makeNFData ''QOp )-$( derive makeNFData ''Op )-$( derive makeNFData ''SpecialCon )-$( derive makeNFData ''CName )-$( derive makeNFData ''IPName )-$( derive makeNFData ''XName )-$( derive makeNFData ''Bracket )-$( derive makeNFData ''Splice )-$( derive makeNFData ''Safety )-$( derive makeNFData ''CallConv )-$( derive makeNFData ''ModulePragma )-$( derive makeNFData ''Tool )-$( derive makeNFData ''Rule )-$( derive makeNFData ''RuleVar )-$( derive makeNFData ''Activation )-$( derive makeNFData ''Annotation )-+{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-} + +module Scion.Browser.Instances.NFData where + +import Control.DeepSeq +import Data.DeriveTH +import Distribution.Package hiding (Package) +import Distribution.Version +import Language.Haskell.Exts.Annotated.Syntax +import Scion.Browser.Types + +$( derive makeNFData ''Doc ) +$( derive makeNFData ''Package ) +$( derive makeNFData ''PackageIdentifier ) +$( derive makeNFData ''PackageName ) +$( derive makeNFData ''Version ) + +-- derive NFData instances for haskell-src-exts +$( derive makeNFData ''Module ) +$( derive makeNFData ''ModuleHead ) +$( derive makeNFData ''WarningText ) +$( derive makeNFData ''ExportSpecList ) +$( derive makeNFData ''ExportSpec ) +$( derive makeNFData ''ImportDecl ) +$( derive makeNFData ''ImportSpecList ) +$( derive makeNFData ''ImportSpec ) +$( derive makeNFData ''Assoc ) +$( derive makeNFData ''Decl ) +$( derive makeNFData ''DeclHead ) +$( derive makeNFData ''InstHead ) +$( derive makeNFData ''Binds ) +$( derive makeNFData ''IPBind ) +$( derive makeNFData ''ClassDecl ) +$( derive makeNFData ''InstDecl ) +$( derive makeNFData ''Deriving ) +$( derive makeNFData ''DataOrNew ) +$( derive makeNFData ''ConDecl ) +$( derive makeNFData ''FieldDecl ) +$( derive makeNFData ''QualConDecl ) +$( derive makeNFData ''GadtDecl ) +$( derive makeNFData ''BangType ) +$( derive makeNFData ''Match ) +$( derive makeNFData ''Rhs ) +$( derive makeNFData ''GuardedRhs ) +$( derive makeNFData ''Context ) +$( derive makeNFData ''FunDep ) +$( derive makeNFData ''Asst ) +$( derive makeNFData ''Type ) +$( derive makeNFData ''Boxed ) +$( derive makeNFData ''Kind ) +$( derive makeNFData ''TyVarBind ) +$( derive makeNFData ''Exp ) +$( derive makeNFData ''Stmt ) +$( derive makeNFData ''QualStmt ) +$( derive makeNFData ''FieldUpdate ) +$( derive makeNFData ''Alt ) +$( derive makeNFData ''GuardedAlts ) +$( derive makeNFData ''GuardedAlt ) +$( derive makeNFData ''XAttr ) +$( derive makeNFData ''Pat ) +$( derive makeNFData ''PatField ) +$( derive makeNFData ''PXAttr ) +$( derive makeNFData ''RPat ) +$( derive makeNFData ''RPatOp ) +$( derive makeNFData ''Literal ) +$( derive makeNFData ''ModuleName ) +$( derive makeNFData ''QName ) +$( derive makeNFData ''Name ) +$( derive makeNFData ''QOp ) +$( derive makeNFData ''Op ) +$( derive makeNFData ''SpecialCon ) +$( derive makeNFData ''CName ) +$( derive makeNFData ''IPName ) +$( derive makeNFData ''XName ) +$( derive makeNFData ''Bracket ) +$( derive makeNFData ''Splice ) +$( derive makeNFData ''Safety ) +$( derive makeNFData ''CallConv ) +$( derive makeNFData ''ModulePragma ) +$( derive makeNFData ''Tool ) +$( derive makeNFData ''Rule ) +$( derive makeNFData ''RuleVar ) +$( derive makeNFData ''Activation ) +$( derive makeNFData ''Annotation ) +
src/Scion/Browser/Instances/Serialize.hs view
@@ -1,498 +1,498 @@-{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables #-}--module Scion.Browser.Instances.Serialize where--import Control.DeepSeq-import Control.Monad (liftM)-import Data.DeriveTH-import Data.Serialize-import Data.IORef-import qualified Data.Map as M-import qualified Data.Text as T-import qualified Data.Text.Encoding as E-import Distribution.Package hiding (Package)-import Distribution.Version-import Language.Haskell.Exts.Annotated.Syntax-import Scion.Browser.Types-import Scion.Browser.Instances.NFData ()-import System.IO.Unsafe--$( derive makeSerialize ''Doc )-$( derive makeSerialize ''Package )-$( derive makeSerialize ''PackageIdentifier )-$( derive makeSerialize ''PackageName )-$( derive makeSerialize ''Version )--instance Serialize T.Text where- put = put . E.encodeUtf8- get = liftM E.decodeUtf8 get---- Lookup table (yes, it uses unsafePerformIO)--lookupNameTable :: IORef (M.Map String (Documented Name))-lookupNameTable = unsafePerformIO $ newIORef M.empty--getNameInLookupTable :: String -> Bool {- is symbol? -} -> Documented Name-getNameInLookupTable name isSymbol = - unsafePerformIO $ do table <- readIORef lookupNameTable- case M.lookup name table of- Just v -> return v- Nothing -> do let element = if isSymbol - then (Symbol noDoc name)- else (Ident noDoc name)- modifyIORef lookupNameTable (M.insert name element)- return element--lookupQNameTable :: IORef (M.Map String (Documented QName))-lookupQNameTable = unsafePerformIO $ newIORef M.empty--getQNameInLookupTable :: Documented QName -> Documented QName-getQNameInLookupTable qname = - unsafePerformIO $ do table <- readIORef lookupQNameTable- let rname = getQNameString qname- case M.lookup rname table of- Just v -> return v- Nothing -> do modifyIORef lookupQNameTable (M.insert rname qname)- return qname--lookupTyVarTable :: IORef (M.Map String (Documented Type))-lookupTyVarTable = unsafePerformIO $ newIORef M.empty--getTyVarInLookupTable :: Documented Name -> Documented Type-getTyVarInLookupTable name = - unsafePerformIO $ do table <- readIORef lookupTyVarTable- let rname = getNameString name- case M.lookup rname table of- Just v -> return v- Nothing -> do let element = TyVar noDoc name - modifyIORef lookupTyVarTable (M.insert rname element)- return element--lookupTyConTable :: IORef (M.Map String (Documented Type))-lookupTyConTable = unsafePerformIO $ newIORef M.empty--getTyConInLookupTable :: Documented QName -> Documented Type-getTyConInLookupTable name = - unsafePerformIO $ do table <- readIORef lookupTyConTable- let rname = getQNameString name- case M.lookup rname table of- Just v -> return v- Nothing -> do let element = TyCon noDoc name - modifyIORef lookupTyConTable (M.insert rname element)- return element---- Serialize instances for haskell-src-exts--noDoc :: Doc-noDoc = NoDoc--nothing :: Maybe a-nothing = Nothing--instance Serialize (Documented Module) where- -- Only possible value- -- Module l (Maybe (ModuleHead l)) [ModulePragma l] [ImportDecl l] [Decl l]- put (Module doc (Just hd) _ _ decls) = do put doc- put hd- put decls- put _ = error "Not allowed Module"- get = do doc <- get- hd <- get- decls <- get- return $ decls `deepseq` Module doc (Just hd) [] [] decls--instance Serialize (Documented ModuleHead) where- -- Only possible value- -- ModuleHead l (ModuleName l) (Maybe (WarningText l)) (Maybe (ExportSpecList l))- put (ModuleHead _ (ModuleName _ name) _ _) = do put name- get = do name <- get- return $ ModuleHead noDoc (ModuleName noDoc name) nothing nothing--dataType :: Documented DataOrNew-dataType = DataType noDoc--newType :: Documented DataOrNew-newType = NewType noDoc--instance Serialize (Documented Decl) where- -- Possible values- -- GDataDecl l (DataOrNew l) (Maybe (Context l)) (DeclHead l) (Maybe (Kind l)) [GadtDecl l] (Maybe (Deriving l))- -- ClassDecl l (Maybe (Context l)) (DeclHead l) [FunDep l] (Maybe [ClassDecl l])- -- InstDecl l (Maybe (Context l)) (InstHead l) (Maybe [InstDecl l])- -- TypeSig l [Name l] (Type l)- -- TypeDecl l (DeclHead l) (Type l)- put (GDataDecl doc dOrM ctx hd kind decls _) = do put doc- putWord8 0- case dOrM of- DataType _ -> putWord8 0- NewType _ -> putWord8 1- put ctx- put hd- put kind- put decls- put (ClassDecl doc ctx hd fdeps _) = do put doc- putWord8 1- put ctx- put hd- put fdeps- put (InstDecl doc ctx hd _) = do put doc- putWord8 2- put ctx- put hd- put (TypeSig doc names ty) = do - put doc- putWord8 3- put names- put ty- put (TypeDecl doc hd ty) = do put doc- putWord8 4- put hd- put ty- put _ = error "Not allowed Decl"- get = do doc <- get- tag <- getWord8- case tag of- 0 -> do dOrM' <- getWord8- let dOrM = case dOrM' of- 0 -> dataType- _ -> newType- ctx <- get- hd <- get- kind <- get- decls <- get- return $ GDataDecl doc dOrM ctx hd kind decls nothing- 1 -> do ctx <- get- hd <- get- fdeps <- get- return $ ClassDecl doc ctx hd fdeps nothing- 2 -> do ctx <- get- hd <- get- return $ InstDecl doc ctx hd nothing- 3 -> do names <- get- ty <- get- return $ TypeSig doc names ty- _ -> do hd <- get- ty <- get- return $ TypeDecl doc hd ty--cxEmpty :: Documented Context-cxEmpty = CxEmpty noDoc--instance Serialize (Documented Context) where- -- Possible values- -- CxSingle l (Asst l) - -- CxTuple l [Asst l] - -- CxParen l (Context l) - -- CxEmpty l- put (CxSingle _ a) = put [a]- put (CxTuple _ as) = put as- put (CxParen _ ctx) = put ctx- put (CxEmpty _) = put ([] :: [Documented Asst])- get = do (as :: [Documented Asst]) <- get- return $ case as of- [] -> cxEmpty- [a] -> CxSingle noDoc a- ass -> CxTuple noDoc ass--instance Serialize (Documented Asst) where- -- Possible values- -- ClassA l (QName l) [Type l]- -- InfixA l (Type l) (QName l) (Type l) - -- IParam l (IPName l) (Type l) - -- EqualP l (Type l) (Type l)- put (ClassA _ name tys) = do putWord8 0- put name- put tys- put (InfixA _ ty1 name ty2) = do putWord8 1- put ty1- put name- put ty2- put (IParam _ ipname ty) = do putWord8 2- put ipname- put ty- put (EqualP _ ty1 ty2) = do putWord8 3- put ty1- put ty2- get = do tag <- getWord8- case tag of- 0 -> do name <- get- tys <- get- return $ ClassA noDoc name tys- 1 -> do ty1 <- get- name <- get- ty2 <- get- return $ InfixA noDoc ty1 name ty2- 2 -> do ipname <- get- ty <- get- return $ IParam noDoc ipname ty- _ -> do ty1 <- get- ty2 <- get- return $ EqualP noDoc ty1 ty2--instance Serialize (Documented DeclHead) where- -- Only possible value- -- DHead l (Name l) [TyVarBind l]- put (DHead _ name vars) = do put name- put vars- put _ = error "Not allowed DeclHead"- get = do name <- get- vars <- get- return $ DHead noDoc name vars--instance Serialize (Documented TyVarBind) where- -- Possible values- -- KindedVar l (Name l) (Kind l)- -- UnkindedVar l (Name l)- put (KindedVar _ name kind) = do put name- putWord8 0- put kind- put (UnkindedVar _ name) = do put name- putWord8 1- get = do name <- get- tag <- getWord8- case tag of- 0 -> do kind <- get- return $ KindedVar noDoc name kind- _ -> return $ UnkindedVar noDoc name--kindStar :: Documented Kind-kindStar = KindStar noDoc--kindBang :: Documented Kind-kindBang = KindBang noDoc--instance Serialize (Documented Kind) where- -- Possible values- -- KindStar l- -- KindBang l- -- KindFn l (Kind l) (Kind l)- -- KindParen l (Kind l)- -- KindVar l (Name l)- put (KindStar _) = putWord8 0- put (KindBang _) = putWord8 1- put (KindFn _ k1 k2) = do putWord8 2- put k1- put k2- put (KindParen _ k) = do putWord8 3- put k- put (KindVar _ name) = do putWord8 4- put name- get = do tag <- getWord8- case tag of- 0 -> return kindStar- 1 -> return kindBang- 2 -> do k1 <- get- k2 <- get- return $ KindFn noDoc k1 k2- 3 -> do k <- get- return $ KindParen noDoc k- _ -> do name <- get- return $ KindVar noDoc name--instance Serialize (Documented FunDep) where- -- Only possible value- -- FunDep l [Name l] [Name l]- put (FunDep _ n1 n2) = do put n1- put n2- get = do n1 <- get- n2 <- get- return $ FunDep noDoc n1 n2--instance Serialize (Documented GadtDecl) where- -- Only possible value- -- GadtDecl l (Name l) (Type l)- put (GadtDecl _ name ty) = do put name- put ty- get = do name <- get- ty <- get- return $ GadtDecl noDoc name ty--instance Serialize (Documented InstHead) where- -- Only possible value- -- IHead l (QName l) [Type l]- put (IHead _ qname tys) = do put qname- put tys- put _ = error "Not allowed IHead"- get = do qname <- get- tys <- get- return $ IHead noDoc qname tys--instance Serialize (Documented Type) where- -- Possible values- -- TyForall l (Maybe [TyVarBind l]) (Maybe (Context l)) (Type l)- -- TyFun l (Type l) (Type l)- -- TyTuple l Boxed [Type l]- -- TyList l (Type l)- -- TyApp l (Type l) (Type l)- -- TyVar l (Name l)- -- TyCon l (QName l)- -- TyParen l (Type l)- -- TyInfix l (Type l) (QName l) (Type l)- -- TyKind l (Type l) (Kind l)- put (TyForall _ vars ctx ty) = do putWord8 0- put vars- put ctx- put ty- put (TyFun _ ty1 ty2) = do putWord8 1- put ty1- put ty2- put (TyTuple _ boxed tys) = do putWord8 2- put boxed- put tys- put (TyList _ ty) = do putWord8 3- put ty- put (TyApp _ ty1 ty2) = do putWord8 4- put ty1- put ty2- put (TyVar _ name) = do putWord8 5- put name- put (TyCon _ qname) = do putWord8 6- put qname- put (TyParen _ ty) = do putWord8 7- put ty- put (TyInfix _ ty1 qname ty2) = do putWord8 8- put ty1- put qname- put ty2- put (TyKind _ ty k) = do putWord8 9- put ty- put k- get = do tag <- getWord8- case tag of- 0 -> do vars <- get- ctx <- get- ty <- get- return $ TyForall noDoc vars ctx ty- 1 -> do ty1 <- get- ty2 <- get- return $ TyFun noDoc ty1 ty2- 2 -> do boxed <- get- tys <- get- return $ TyTuple noDoc boxed tys- 3 -> do ty <- get- return $ TyList noDoc ty- 4 -> do ty1 <- get- ty2 <- get- return $ TyApp noDoc ty1 ty2- 5 -> do name <- get- return $ getTyVarInLookupTable name- 6 -> do qname <- get- return $ getTyConInLookupTable qname- 7 -> do ty <- get- return $ TyParen noDoc ty- 8 -> do ty1 <- get- qname <- get- ty2 <- get- return $ TyInfix noDoc ty1 qname ty2- _ -> do ty <- get- k <- get- return $ TyKind noDoc ty k--boxed_ :: Boxed-boxed_ = Boxed--unboxed_ :: Boxed-unboxed_ = Unboxed--instance Serialize Boxed where- -- Possible values- -- Boxed- -- Unboxed- put Boxed = putWord8 0- put Unboxed = putWord8 1- get = do tag <- getWord8- return $ case tag of- 0 -> boxed_- _ -> unboxed_--instance Serialize (Documented Name) where- -- Possible values- -- Ident l String- -- Symbol l String- put (Ident _ s) = do putWord8 0- put s- put (Symbol _ s) = do putWord8 1- put s- get = do tag <- getWord8- s <- get- let isSymbol = tag /= 0- return $ getNameInLookupTable s isSymbol--instance Serialize (Documented QName) where- -- Possible values- -- Qual l (ModuleName l) (Name l)- -- UnQual l (Name l)- -- Special l (SpecialCon l)- put (Qual _ (ModuleName _ mn) name) = do putWord8 0- put mn- put name- put (UnQual _ name) = do putWord8 1- put name- put (Special _ scon) = do putWord8 2- put scon- get = do tag <- getWord8- case tag of- 0 -> do mn <- get- name <- get- return $ getQNameInLookupTable $ Qual noDoc (ModuleName noDoc mn) name- 1 -> do name <- get- return $ getQNameInLookupTable $ UnQual noDoc name- _ -> do scon <- get- return $ getQNameInLookupTable $ Special noDoc scon--instance Serialize (Documented IPName) where- -- Possible values- -- IPDup l String- -- IPLin l String- put (IPDup _ s) = do put s- putWord8 0- put (IPLin _ s) = do put s- putWord8 1- get = do s <- get- tag <- getWord8- case tag of- 0 -> return $ IPDup noDoc s- _ -> return $ IPLin noDoc s--unitCon :: Documented SpecialCon-unitCon = UnitCon noDoc--listCon :: Documented SpecialCon-listCon = ListCon noDoc--funCon :: Documented SpecialCon-funCon = FunCon noDoc--cons_ :: Documented SpecialCon-cons_ = Cons noDoc--unboxedSingleCon :: Documented SpecialCon-unboxedSingleCon = UnboxedSingleCon noDoc--instance Serialize (Documented SpecialCon) where- -- Possible values- -- UnitCon l- -- ListCon l- -- FunCon l- -- Cons l- -- UnboxedSingleCon l- -- TupleCon l Boxed Int- put (UnitCon _) = putWord8 0- put (ListCon _) = putWord8 1- put (FunCon _) = putWord8 2- put (Cons _) = putWord8 3- put (UnboxedSingleCon _) = putWord8 4- put (TupleCon _ boxed n) = do putWord8 5- put boxed- put n- get = do tag <- getWord8- case tag of- 0 -> return unitCon- 1 -> return listCon- 2 -> return funCon- 3 -> return cons_- 4 -> return unboxedSingleCon- _ -> do boxed <- get- n <- get- return $ TupleCon noDoc boxed n-+{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables #-} + +module Scion.Browser.Instances.Serialize where + +import Control.DeepSeq +import Control.Monad (liftM) +import Data.DeriveTH +import Data.Serialize +import Data.IORef +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import Distribution.Package hiding (Package) +import Distribution.Version +import Language.Haskell.Exts.Annotated.Syntax +import Scion.Browser.Types +import Scion.Browser.Instances.NFData () +import System.IO.Unsafe + +$( derive makeSerialize ''Doc ) +$( derive makeSerialize ''Package ) +$( derive makeSerialize ''PackageIdentifier ) +$( derive makeSerialize ''PackageName ) +$( derive makeSerialize ''Version ) + +instance Serialize T.Text where + put = put . E.encodeUtf8 + get = liftM E.decodeUtf8 get + +-- Lookup table (yes, it uses unsafePerformIO) + +lookupNameTable :: IORef (M.Map String (Documented Name)) +lookupNameTable = unsafePerformIO $ newIORef M.empty + +getNameInLookupTable :: String -> Bool {- is symbol? -} -> Documented Name +getNameInLookupTable name isSymbol = + unsafePerformIO $ do table <- readIORef lookupNameTable + case M.lookup name table of + Just v -> return v + Nothing -> do let element = if isSymbol + then (Symbol noDoc name) + else (Ident noDoc name) + modifyIORef lookupNameTable (M.insert name element) + return element + +lookupQNameTable :: IORef (M.Map String (Documented QName)) +lookupQNameTable = unsafePerformIO $ newIORef M.empty + +getQNameInLookupTable :: Documented QName -> Documented QName +getQNameInLookupTable qname = + unsafePerformIO $ do table <- readIORef lookupQNameTable + let rname = getQNameString qname + case M.lookup rname table of + Just v -> return v + Nothing -> do modifyIORef lookupQNameTable (M.insert rname qname) + return qname + +lookupTyVarTable :: IORef (M.Map String (Documented Type)) +lookupTyVarTable = unsafePerformIO $ newIORef M.empty + +getTyVarInLookupTable :: Documented Name -> Documented Type +getTyVarInLookupTable name = + unsafePerformIO $ do table <- readIORef lookupTyVarTable + let rname = getNameString name + case M.lookup rname table of + Just v -> return v + Nothing -> do let element = TyVar noDoc name + modifyIORef lookupTyVarTable (M.insert rname element) + return element + +lookupTyConTable :: IORef (M.Map String (Documented Type)) +lookupTyConTable = unsafePerformIO $ newIORef M.empty + +getTyConInLookupTable :: Documented QName -> Documented Type +getTyConInLookupTable name = + unsafePerformIO $ do table <- readIORef lookupTyConTable + let rname = getQNameString name + case M.lookup rname table of + Just v -> return v + Nothing -> do let element = TyCon noDoc name + modifyIORef lookupTyConTable (M.insert rname element) + return element + +-- Serialize instances for haskell-src-exts + +noDoc :: Doc +noDoc = NoDoc + +nothing :: Maybe a +nothing = Nothing + +instance Serialize (Documented Module) where + -- Only possible value + -- Module l (Maybe (ModuleHead l)) [ModulePragma l] [ImportDecl l] [Decl l] + put (Module doc (Just hd) _ _ decls) = do put doc + put hd + put decls + put _ = error "Not allowed Module" + get = do doc <- get + hd <- get + decls <- get + return $ decls `deepseq` Module doc (Just hd) [] [] decls + +instance Serialize (Documented ModuleHead) where + -- Only possible value + -- ModuleHead l (ModuleName l) (Maybe (WarningText l)) (Maybe (ExportSpecList l)) + put (ModuleHead _ (ModuleName _ name) _ _) = do put name + get = do name <- get + return $ ModuleHead noDoc (ModuleName noDoc name) nothing nothing + +dataType :: Documented DataOrNew +dataType = DataType noDoc + +newType :: Documented DataOrNew +newType = NewType noDoc + +instance Serialize (Documented Decl) where + -- Possible values + -- GDataDecl l (DataOrNew l) (Maybe (Context l)) (DeclHead l) (Maybe (Kind l)) [GadtDecl l] (Maybe (Deriving l)) + -- ClassDecl l (Maybe (Context l)) (DeclHead l) [FunDep l] (Maybe [ClassDecl l]) + -- InstDecl l (Maybe (Context l)) (InstHead l) (Maybe [InstDecl l]) + -- TypeSig l [Name l] (Type l) + -- TypeDecl l (DeclHead l) (Type l) + put (GDataDecl doc dOrM ctx hd kind decls _) = do put doc + putWord8 0 + case dOrM of + DataType _ -> putWord8 0 + NewType _ -> putWord8 1 + put ctx + put hd + put kind + put decls + put (ClassDecl doc ctx hd fdeps _) = do put doc + putWord8 1 + put ctx + put hd + put fdeps + put (InstDecl doc ctx hd _) = do put doc + putWord8 2 + put ctx + put hd + put (TypeSig doc names ty) = do + put doc + putWord8 3 + put names + put ty + put (TypeDecl doc hd ty) = do put doc + putWord8 4 + put hd + put ty + put _ = error "Not allowed Decl" + get = do doc <- get + tag <- getWord8 + case tag of + 0 -> do dOrM' <- getWord8 + let dOrM = case dOrM' of + 0 -> dataType + _ -> newType + ctx <- get + hd <- get + kind <- get + decls <- get + return $ GDataDecl doc dOrM ctx hd kind decls nothing + 1 -> do ctx <- get + hd <- get + fdeps <- get + return $ ClassDecl doc ctx hd fdeps nothing + 2 -> do ctx <- get + hd <- get + return $ InstDecl doc ctx hd nothing + 3 -> do names <- get + ty <- get + return $ TypeSig doc names ty + _ -> do hd <- get + ty <- get + return $ TypeDecl doc hd ty + +cxEmpty :: Documented Context +cxEmpty = CxEmpty noDoc + +instance Serialize (Documented Context) where + -- Possible values + -- CxSingle l (Asst l) + -- CxTuple l [Asst l] + -- CxParen l (Context l) + -- CxEmpty l + put (CxSingle _ a) = put [a] + put (CxTuple _ as) = put as + put (CxParen _ ctx) = put ctx + put (CxEmpty _) = put ([] :: [Documented Asst]) + get = do (as :: [Documented Asst]) <- get + return $ case as of + [] -> cxEmpty + [a] -> CxSingle noDoc a + ass -> CxTuple noDoc ass + +instance Serialize (Documented Asst) where + -- Possible values + -- ClassA l (QName l) [Type l] + -- InfixA l (Type l) (QName l) (Type l) + -- IParam l (IPName l) (Type l) + -- EqualP l (Type l) (Type l) + put (ClassA _ name tys) = do putWord8 0 + put name + put tys + put (InfixA _ ty1 name ty2) = do putWord8 1 + put ty1 + put name + put ty2 + put (IParam _ ipname ty) = do putWord8 2 + put ipname + put ty + put (EqualP _ ty1 ty2) = do putWord8 3 + put ty1 + put ty2 + get = do tag <- getWord8 + case tag of + 0 -> do name <- get + tys <- get + return $ ClassA noDoc name tys + 1 -> do ty1 <- get + name <- get + ty2 <- get + return $ InfixA noDoc ty1 name ty2 + 2 -> do ipname <- get + ty <- get + return $ IParam noDoc ipname ty + _ -> do ty1 <- get + ty2 <- get + return $ EqualP noDoc ty1 ty2 + +instance Serialize (Documented DeclHead) where + -- Only possible value + -- DHead l (Name l) [TyVarBind l] + put (DHead _ name vars) = do put name + put vars + put _ = error "Not allowed DeclHead" + get = do name <- get + vars <- get + return $ DHead noDoc name vars + +instance Serialize (Documented TyVarBind) where + -- Possible values + -- KindedVar l (Name l) (Kind l) + -- UnkindedVar l (Name l) + put (KindedVar _ name kind) = do put name + putWord8 0 + put kind + put (UnkindedVar _ name) = do put name + putWord8 1 + get = do name <- get + tag <- getWord8 + case tag of + 0 -> do kind <- get + return $ KindedVar noDoc name kind + _ -> return $ UnkindedVar noDoc name + +kindStar :: Documented Kind +kindStar = KindStar noDoc + +kindBang :: Documented Kind +kindBang = KindBang noDoc + +instance Serialize (Documented Kind) where + -- Possible values + -- KindStar l + -- KindBang l + -- KindFn l (Kind l) (Kind l) + -- KindParen l (Kind l) + -- KindVar l (Name l) + put (KindStar _) = putWord8 0 + put (KindBang _) = putWord8 1 + put (KindFn _ k1 k2) = do putWord8 2 + put k1 + put k2 + put (KindParen _ k) = do putWord8 3 + put k + put (KindVar _ name) = do putWord8 4 + put name + get = do tag <- getWord8 + case tag of + 0 -> return kindStar + 1 -> return kindBang + 2 -> do k1 <- get + k2 <- get + return $ KindFn noDoc k1 k2 + 3 -> do k <- get + return $ KindParen noDoc k + _ -> do name <- get + return $ KindVar noDoc name + +instance Serialize (Documented FunDep) where + -- Only possible value + -- FunDep l [Name l] [Name l] + put (FunDep _ n1 n2) = do put n1 + put n2 + get = do n1 <- get + n2 <- get + return $ FunDep noDoc n1 n2 + +instance Serialize (Documented GadtDecl) where + -- Only possible value + -- GadtDecl l (Name l) (Type l) + put (GadtDecl _ name ty) = do put name + put ty + get = do name <- get + ty <- get + return $ GadtDecl noDoc name ty + +instance Serialize (Documented InstHead) where + -- Only possible value + -- IHead l (QName l) [Type l] + put (IHead _ qname tys) = do put qname + put tys + put _ = error "Not allowed IHead" + get = do qname <- get + tys <- get + return $ IHead noDoc qname tys + +instance Serialize (Documented Type) where + -- Possible values + -- TyForall l (Maybe [TyVarBind l]) (Maybe (Context l)) (Type l) + -- TyFun l (Type l) (Type l) + -- TyTuple l Boxed [Type l] + -- TyList l (Type l) + -- TyApp l (Type l) (Type l) + -- TyVar l (Name l) + -- TyCon l (QName l) + -- TyParen l (Type l) + -- TyInfix l (Type l) (QName l) (Type l) + -- TyKind l (Type l) (Kind l) + put (TyForall _ vars ctx ty) = do putWord8 0 + put vars + put ctx + put ty + put (TyFun _ ty1 ty2) = do putWord8 1 + put ty1 + put ty2 + put (TyTuple _ boxed tys) = do putWord8 2 + put boxed + put tys + put (TyList _ ty) = do putWord8 3 + put ty + put (TyApp _ ty1 ty2) = do putWord8 4 + put ty1 + put ty2 + put (TyVar _ name) = do putWord8 5 + put name + put (TyCon _ qname) = do putWord8 6 + put qname + put (TyParen _ ty) = do putWord8 7 + put ty + put (TyInfix _ ty1 qname ty2) = do putWord8 8 + put ty1 + put qname + put ty2 + put (TyKind _ ty k) = do putWord8 9 + put ty + put k + get = do tag <- getWord8 + case tag of + 0 -> do vars <- get + ctx <- get + ty <- get + return $ TyForall noDoc vars ctx ty + 1 -> do ty1 <- get + ty2 <- get + return $ TyFun noDoc ty1 ty2 + 2 -> do boxed <- get + tys <- get + return $ TyTuple noDoc boxed tys + 3 -> do ty <- get + return $ TyList noDoc ty + 4 -> do ty1 <- get + ty2 <- get + return $ TyApp noDoc ty1 ty2 + 5 -> do name <- get + return $ getTyVarInLookupTable name + 6 -> do qname <- get + return $ getTyConInLookupTable qname + 7 -> do ty <- get + return $ TyParen noDoc ty + 8 -> do ty1 <- get + qname <- get + ty2 <- get + return $ TyInfix noDoc ty1 qname ty2 + _ -> do ty <- get + k <- get + return $ TyKind noDoc ty k + +boxed_ :: Boxed +boxed_ = Boxed + +unboxed_ :: Boxed +unboxed_ = Unboxed + +instance Serialize Boxed where + -- Possible values + -- Boxed + -- Unboxed + put Boxed = putWord8 0 + put Unboxed = putWord8 1 + get = do tag <- getWord8 + return $ case tag of + 0 -> boxed_ + _ -> unboxed_ + +instance Serialize (Documented Name) where + -- Possible values + -- Ident l String + -- Symbol l String + put (Ident _ s) = do putWord8 0 + put s + put (Symbol _ s) = do putWord8 1 + put s + get = do tag <- getWord8 + s <- get + let isSymbol = tag /= 0 + return $ getNameInLookupTable s isSymbol + +instance Serialize (Documented QName) where + -- Possible values + -- Qual l (ModuleName l) (Name l) + -- UnQual l (Name l) + -- Special l (SpecialCon l) + put (Qual _ (ModuleName _ mn) name) = do putWord8 0 + put mn + put name + put (UnQual _ name) = do putWord8 1 + put name + put (Special _ scon) = do putWord8 2 + put scon + get = do tag <- getWord8 + case tag of + 0 -> do mn <- get + name <- get + return $ getQNameInLookupTable $ Qual noDoc (ModuleName noDoc mn) name + 1 -> do name <- get + return $ getQNameInLookupTable $ UnQual noDoc name + _ -> do scon <- get + return $ getQNameInLookupTable $ Special noDoc scon + +instance Serialize (Documented IPName) where + -- Possible values + -- IPDup l String + -- IPLin l String + put (IPDup _ s) = do put s + putWord8 0 + put (IPLin _ s) = do put s + putWord8 1 + get = do s <- get + tag <- getWord8 + case tag of + 0 -> return $ IPDup noDoc s + _ -> return $ IPLin noDoc s + +unitCon :: Documented SpecialCon +unitCon = UnitCon noDoc + +listCon :: Documented SpecialCon +listCon = ListCon noDoc + +funCon :: Documented SpecialCon +funCon = FunCon noDoc + +cons_ :: Documented SpecialCon +cons_ = Cons noDoc + +unboxedSingleCon :: Documented SpecialCon +unboxedSingleCon = UnboxedSingleCon noDoc + +instance Serialize (Documented SpecialCon) where + -- Possible values + -- UnitCon l + -- ListCon l + -- FunCon l + -- Cons l + -- UnboxedSingleCon l + -- TupleCon l Boxed Int + put (UnitCon _) = putWord8 0 + put (ListCon _) = putWord8 1 + put (FunCon _) = putWord8 2 + put (Cons _) = putWord8 3 + put (UnboxedSingleCon _) = putWord8 4 + put (TupleCon _ boxed n) = do putWord8 5 + put boxed + put n + get = do tag <- getWord8 + case tag of + 0 -> return unitCon + 1 -> return listCon + 2 -> return funCon + 3 -> return cons_ + 4 -> return unboxedSingleCon + _ -> do boxed <- get + n <- get + return $ TupleCon noDoc boxed n +
src/Scion/Browser/Parser.hs view
@@ -1,98 +1,98 @@-{-# LANGUAGE ScopedTypeVariables #-}--module Scion.Browser.Parser-( parseHoogleString-, parseHoogleFile-, parseDirectory-) where--import Control.Concurrent.ParallelIO.Local-import Control.DeepSeq-import Control.Monad-import qualified Data.ByteString as BS-import qualified Data.ByteString.UTF8 as BSU-import Data.Either (rights)-import Data.Serialize-import Scion.Browser-import Scion.Browser.Parser.Internal (hoogleParser)-import Scion.Browser.FileUtil-import Scion.Browser.Util-import System.Directory-import System.FilePath ((</>), takeFileName)-import System.IO-import Text.Parsec.Error (Message(..), newErrorMessage)-import Text.Parsec.Prim (runP)--- import Text.Parsec.ByteString as BS-import Text.ParserCombinators.Parsec-import Text.ParserCombinators.Parsec.Pos (newPos)---- | Parses the contents of a string containing the --- Hoogle file contents.-parseHoogleString :: String -> BS.ByteString -> Either ParseError (Documented Package)-parseHoogleString name contents = case runP hoogleParser () name (BSU.toString contents) of- Right pkg -> pkg `deepseq` (Right pkg)- Left err -> Left err---- | 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 tmpdir =- do contents' <- getDirectoryContents dir- let contents = map (\d -> dir </> d) (filterDots contents')- files <- filterM doesFileExist contents- fPackages <- mapM (\fname -> do putChar '.'- hFlush stdout- p <- parseHoogleFile fname- -- return (fname, p)- case p of- Left _ -> return (fname, p)- Right pkg -> do let tmpFile = tmpdir </> takeFileName fname- withFile tmpFile WriteMode $- \hnd -> BS.hPut hnd (encode pkg)- s <- withFile tmpFile ReadMode $- \hnd -> do s <- BS.hGetContents hnd- return s- let Right (pkg' :: Documented Package) = decode s- return (fname, Right pkg') )- files- return $ partitionPackages fPackages-+{-# LANGUAGE ScopedTypeVariables #-} + +module Scion.Browser.Parser +( parseHoogleString +, parseHoogleFile +, parseDirectory +) where + +import Control.Concurrent.ParallelIO.Local +import Control.DeepSeq +import Control.Monad +import qualified Data.ByteString as BS +import qualified Data.ByteString.UTF8 as BSU +import Data.Either (rights) +import Data.Serialize +import Scion.Browser +import Scion.Browser.Parser.Internal (hoogleParser) +import Scion.Browser.FileUtil +import Scion.Browser.Util +import System.Directory +import System.FilePath ((</>), takeFileName) +import System.IO +import Text.Parsec.Error (Message(..), newErrorMessage) +import Text.Parsec.Prim (runP) +-- import Text.Parsec.ByteString as BS +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Pos (newPos) + +-- | Parses the contents of a string containing the +-- Hoogle file contents. +parseHoogleString :: String -> BS.ByteString -> Either ParseError (Documented Package) +parseHoogleString name contents = case runP hoogleParser () name (BSU.toString contents) of + Right pkg -> pkg `deepseq` (Right pkg) + Left err -> Left err + +-- | 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 tmpdir = + do contents' <- getDirectoryContents dir + let contents = map (\d -> dir </> d) (filterDots contents') + files <- filterM doesFileExist contents + fPackages <- mapM (\fname -> do putChar '.' + hFlush stdout + p <- parseHoogleFile fname + -- return (fname, p) + case p of + Left _ -> return (fname, p) + Right pkg -> do let tmpFile = tmpdir </> takeFileName fname + withFile tmpFile WriteMode $ + \hnd -> BS.hPut hnd (encode pkg) + s <- withFile tmpFile ReadMode $ + \hnd -> do s <- BS.hGetContents hnd + return s + let Right (pkg' :: Documented Package) = decode s + return (fname, Right pkg') ) + files + return $ partitionPackages fPackages +
src/Scion/Browser/Parser/Documentable.hs view
@@ -1,88 +1,88 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances #-}--module Scion.Browser.Parser.Documentable where--import Scion.Browser-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.Browser.Parser.Documentable where + +import Scion.Browser +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/Browser/Parser/Internal.hs view
@@ -1,543 +1,543 @@-{-# LANGUAGE RankNTypes #-}-module Scion.Browser.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.Browser-import Scion.Browser.FromMissingH (replace)-import Scion.Browser.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)- in (ctx, DHead NoDoc name vars)--toKindedVars :: [Type Doc] -> [TyVarBind Doc]-toKindedVars [] = []-toKindedVars ((TyVar d (Ident _ n1)):( (TyList _ (TyVar _ (Ident _ n2))): xs )) =- (UnkindedVar d (Ident NoDoc $ n1 ++ "[" ++ n2 ++ "]")) : toKindedVars xs-toKindedVars ((TyVar d n):xs) = (UnkindedVar d n) : toKindedVars xs-toKindedVars (x:_) = error $ show x-+{-# LANGUAGE RankNTypes #-} +module Scion.Browser.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.Browser +import Scion.Browser.FromMissingH (replace) +import Scion.Browser.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) + in (ctx, DHead NoDoc name vars) + +toKindedVars :: [Type Doc] -> [TyVarBind Doc] +toKindedVars [] = [] +toKindedVars ((TyVar d (Ident _ n1)):( (TyList _ (TyVar _ (Ident _ n2))): xs )) = + (UnkindedVar d (Ident NoDoc $ n1 ++ "[" ++ n2 ++ "]")) : toKindedVars xs +toKindedVars ((TyVar d n):xs) = (UnkindedVar d n) : toKindedVars xs +toKindedVars (x:_) = error $ show x +
src/Scion/Browser/Query.hs view
@@ -1,110 +1,110 @@-module Scion.Browser.Query-( allPackageIds-, allPackages-, packagesByName-, getPackage-, getSingletonDatabase-, getModules-, getSubmodules-, getDeclsInModule-, getModulesWhereDeclarationIs-) where--import Data.List (isPrefixOf, stripPrefix)-import qualified Data.Map as M-import Distribution.Package hiding (Package)-import Language.Haskell.Exts.Annotated.Syntax-import Scion.Browser-import Scion.Browser.FromMissingH (addToAL)---- |Get the identifiers of all packages in the database.-allPackageIds :: Database -> [PackageIdentifier]-allPackageIds = M.keys---- |Get information of all packages in the database.-allPackages :: Database -> [Documented Package]-allPackages = M.elems---- |Get information of all versions of the package with that name.-packagesByName :: String -> Database -> [Documented Package]-packagesByName name db = M.foldlWithKey (\lst k v -> let PackageName pkgN = pkgName k- in if pkgN == name then v:lst else lst)- [] db---- |Get information about a package in the database.-getPackage :: PackageIdentifier -> Database -> Maybe (Documented Package)-getPackage = M.lookup---- |Builds a database with only the specified package.-getSingletonDatabase :: PackageIdentifier -> Database -> Maybe Database-getSingletonDatabase pid db = case getPackage pid db of- Nothing -> Nothing- Just pkg -> Just $ singletonDatabase pkg--type ModuleWithPackage = (PackageIdentifier, Documented Module)---- |Get all the modules hierarchically inside the specified one.--- This function only goes one level deep, for the entire list--- use getSubmodules.--- For getting the upper modules, use "" as initial name.-getModules :: String -> Database -> [(String, [ModuleWithPackage])]-getModules = getSubmodules' getModulesFromPackage---- |Get all the modules hierarchically inside the specified one.--- For getting the entire list of modules modules, use "" as initial name.-getSubmodules :: String -> Database -> [(String, [ModuleWithPackage])]-getSubmodules = getSubmodules' getSubmodulesFromPackage--getSubmodules' :: (String -> Documented Package -> [Documented Module]) -> String -> Database -> [(String, [ModuleWithPackage])]-getSubmodules' f mname db = M.foldrWithKey (\pid pkg current -> mergeModules pid (f mname pkg) current) [] db--mergeModules :: PackageIdentifier -> [Documented Module] -> [(String, [ModuleWithPackage])] -> [(String, [ModuleWithPackage])]-mergeModules pid mods initial = foldr (\md current -> mergeModule pid md current) initial mods--mergeModule :: PackageIdentifier -> Documented Module -> [(String, [ModuleWithPackage])] -> [(String, [ModuleWithPackage])]-mergeModule pid md current = let mname = getName md- in case lookup mname current of- Nothing -> (mname, [(pid, md)]) : current- Just mods -> addToAL current mname ((pid, md):mods)--getModulesFromPackage :: String -> Documented Package -> [Documented Module]-getModulesFromPackage "" (Package _ _ modMap) =- M.foldlWithKey (\lst k v -> if '.' `elem` k then lst else v:lst) [] modMap-getModulesFromPackage initial (Package _ _ modMap) = - M.foldlWithKey (\lst k v -> if include k then v:lst else lst) [] modMap- where minitial = initial ++ "."- include k = case stripPrefix minitial k of- Nothing -> False- Just mn -> not ('.' `elem` mn)--getSubmodulesFromPackage :: String -> Documented Package -> [Documented Module]-getSubmodulesFromPackage "" (Package _ _ modMap) = M.elems modMap-getSubmodulesFromPackage initial (Package _ _ modMap) = - let minitial = initial ++ "."- in M.foldlWithKey (\lst k v -> if minitial `isPrefixOf` k then v:lst else lst) [] modMap---- |Gets the declarations inside some module,--- along with information about which package it lives.-getDeclsInModule :: String -> Database -> [(PackageIdentifier, [Documented Decl])]-getDeclsInModule modName db = M.foldrWithKey (\k v lst -> (k, getDeclsInModuleFromPackage modName v):lst) [] db--getDeclsInModuleFromPackage :: String -> Documented Package -> [Documented Decl]-getDeclsInModuleFromPackage modName (Package _ _ modMap) =- case M.lookup modName modMap of- Just (Module _ _ _ _ decls) -> decls- _ -> []---- | Gets a list of modules where a declaration may live-getModulesWhereDeclarationIs :: String -> Database -> [Documented Module]-getModulesWhereDeclarationIs decl db = M.fold (\v lst -> (getModulesWhereDeclarationIsInPackage decl v) ++ lst) [] db--getModulesWhereDeclarationIsInPackage :: String -> Documented Package -> [Documented Module]-getModulesWhereDeclarationIsInPackage decl (Package _ _ modMap) = M.elems $ M.filter (moduleHasDecl decl) modMap--moduleHasDecl :: String -> Documented Module -> Bool-moduleHasDecl decl (Module _ _ _ _ decls) = isDeclName decls- where isDeclName [] = False- isDeclName (x:xs) = getName x == decl || isChildName (getChildren x) || isDeclName xs- isChildName [] = False- isChildName (x:xs) = getName x == decl || isChildName xs-+module Scion.Browser.Query +( allPackageIds +, allPackages +, packagesByName +, getPackage +, getSingletonDatabase +, getModules +, getSubmodules +, getDeclsInModule +, getModulesWhereDeclarationIs +) where + +import Data.List (isPrefixOf, stripPrefix) +import qualified Data.Map as M +import Distribution.Package hiding (Package) +import Language.Haskell.Exts.Annotated.Syntax +import Scion.Browser +import Scion.Browser.FromMissingH (addToAL) + +-- |Get the identifiers of all packages in the database. +allPackageIds :: Database -> [PackageIdentifier] +allPackageIds = M.keys + +-- |Get information of all packages in the database. +allPackages :: Database -> [Documented Package] +allPackages = M.elems + +-- |Get information of all versions of the package with that name. +packagesByName :: String -> Database -> [Documented Package] +packagesByName name db = M.foldlWithKey (\lst k v -> let PackageName pkgN = pkgName k + in if pkgN == name then v:lst else lst) + [] db + +-- |Get information about a package in the database. +getPackage :: PackageIdentifier -> Database -> Maybe (Documented Package) +getPackage = M.lookup + +-- |Builds a database with only the specified package. +getSingletonDatabase :: PackageIdentifier -> Database -> Maybe Database +getSingletonDatabase pid db = case getPackage pid db of + Nothing -> Nothing + Just pkg -> Just $ singletonDatabase pkg + +type ModuleWithPackage = (PackageIdentifier, Documented Module) + +-- |Get all the modules hierarchically inside the specified one. +-- This function only goes one level deep, for the entire list +-- use getSubmodules. +-- For getting the upper modules, use "" as initial name. +getModules :: String -> Database -> [(String, [ModuleWithPackage])] +getModules = getSubmodules' getModulesFromPackage + +-- |Get all the modules hierarchically inside the specified one. +-- For getting the entire list of modules modules, use "" as initial name. +getSubmodules :: String -> Database -> [(String, [ModuleWithPackage])] +getSubmodules = getSubmodules' getSubmodulesFromPackage + +getSubmodules' :: (String -> Documented Package -> [Documented Module]) -> String -> Database -> [(String, [ModuleWithPackage])] +getSubmodules' f mname db = M.foldrWithKey (\pid pkg current -> mergeModules pid (f mname pkg) current) [] db + +mergeModules :: PackageIdentifier -> [Documented Module] -> [(String, [ModuleWithPackage])] -> [(String, [ModuleWithPackage])] +mergeModules pid mods initial = foldr (\md current -> mergeModule pid md current) initial mods + +mergeModule :: PackageIdentifier -> Documented Module -> [(String, [ModuleWithPackage])] -> [(String, [ModuleWithPackage])] +mergeModule pid md current = let mname = getName md + in case lookup mname current of + Nothing -> (mname, [(pid, md)]) : current + Just mods -> addToAL current mname ((pid, md):mods) + +getModulesFromPackage :: String -> Documented Package -> [Documented Module] +getModulesFromPackage "" (Package _ _ modMap) = + M.foldlWithKey (\lst k v -> if '.' `elem` k then lst else v:lst) [] modMap +getModulesFromPackage initial (Package _ _ modMap) = + M.foldlWithKey (\lst k v -> if include k then v:lst else lst) [] modMap + where minitial = initial ++ "." + include k = case stripPrefix minitial k of + Nothing -> False + Just mn -> not ('.' `elem` mn) + +getSubmodulesFromPackage :: String -> Documented Package -> [Documented Module] +getSubmodulesFromPackage "" (Package _ _ modMap) = M.elems modMap +getSubmodulesFromPackage initial (Package _ _ modMap) = + let minitial = initial ++ "." + in M.foldlWithKey (\lst k v -> if minitial `isPrefixOf` k then v:lst else lst) [] modMap + +-- |Gets the declarations inside some module, +-- along with information about which package it lives. +getDeclsInModule :: String -> Database -> [(PackageIdentifier, [Documented Decl])] +getDeclsInModule modName db = M.foldrWithKey (\k v lst -> (k, getDeclsInModuleFromPackage modName v):lst) [] db + +getDeclsInModuleFromPackage :: String -> Documented Package -> [Documented Decl] +getDeclsInModuleFromPackage modName (Package _ _ modMap) = + case M.lookup modName modMap of + Just (Module _ _ _ _ decls) -> decls + _ -> [] + +-- | Gets a list of modules where a declaration may live +getModulesWhereDeclarationIs :: String -> Database -> [Documented Module] +getModulesWhereDeclarationIs decl db = M.fold (\v lst -> (getModulesWhereDeclarationIsInPackage decl v) ++ lst) [] db + +getModulesWhereDeclarationIsInPackage :: String -> Documented Package -> [Documented Module] +getModulesWhereDeclarationIsInPackage decl (Package _ _ modMap) = M.elems $ M.filter (moduleHasDecl decl) modMap + +moduleHasDecl :: String -> Documented Module -> Bool +moduleHasDecl decl (Module _ _ _ _ decls) = isDeclName decls + where isDeclName [] = False + isDeclName (x:xs) = getName x == decl || isChildName (getChildren x) || isDeclName xs + isChildName [] = False + isChildName (x:xs) = getName x == decl || isChildName xs +
src/Scion/Browser/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.Browser.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.Browser.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/Browser/Types.hs view
@@ -1,90 +1,90 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}--module Scion.Browser.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.Browser.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/Browser/Util.hs view
@@ -1,48 +1,52 @@-module Scion.Browser.Util where--import Control.Concurrent.ParallelIO.Local-import qualified Data.Map as M-import Distribution.Package hiding (Package)-import Scion.Browser-import System.Exit (ExitCode)-import System.IO (hFlush, stdout)-import System.Process-import Text.Parsec.Error (ParseError)-import GHC.Conc.Sync (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- (_, _, _, 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)---- |Converts a list of packages to a database-pkgListToDb :: [Documented Package] -> Database-pkgListToDb pkgs = M.fromList (map (\pkg -> (packageId pkg, pkg)) pkgs)--logToStdout :: String -> IO ()-logToStdout msg = putStrLn msg >> hFlush stdout-+{-# LANGUAGE CPP #-} +module Scion.Browser.Util where + +import Control.Concurrent.ParallelIO.Local +import qualified Data.Map as M +import Distribution.Package hiding (Package) +import Scion.Browser +import System.Exit (ExitCode) +import System.IO (hFlush, stdout) +import System.Process +import Text.Parsec.Error (ParseError) +import GHC.Conc.Sync (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) + +-- |Converts a list of packages to a database +pkgListToDb :: [Documented Package] -> Database +pkgListToDb pkgs = M.fromList (map (\pkg -> (packageId pkg, pkg)) pkgs) + +logToStdout :: String -> IO () +logToStdout msg = putStrLn msg >> hFlush stdout +
src/Scion/Hoogle.hs view
@@ -1,46 +1,46 @@-module Scion.Hoogle-( query-, downloadData-, checkDatabase-, module Scion.Hoogle.Types-) where--import qualified Data.ByteString.Char8 as BS8-import Control.Monad-import Scion.Browser-import Scion.Hoogle.Types-import Scion.Hoogle.Instances.Json ()-import Scion.Hoogle.Parser-import Scion.Hoogle.Util-import System.Exit (ExitCode(..))-import System.Process-import Text.Parsec.Prim (runP)--query :: Database -> String -> IO [Result]-query db q = do mpath <- findHoogleBinPath- case mpath of- Nothing -> return []- Just path -> do (exitCode, output, err) <- readProcessWithExitCode path [q] ""- case exitCode of- ExitSuccess -> case runP (hoogleElements db) () "hoogle-output" (output) of- Right result -> return result- Left _ -> return []- _ -> do putStrLn err- return []--downloadData :: IO Bool-downloadData = do mpath <- findHoogleBinPath- case mpath of- Nothing -> return False- Just path -> do putStrLn "Running hoogle data..."- (ec, _, err) <- readProcessWithExitCode path ["data"] ""- when (ec/= ExitSuccess) (putStrLn err)- return (ec == ExitSuccess)--checkDatabase :: IO Bool-checkDatabase = do mpath <- findHoogleBinPath- case mpath of- Nothing -> return False- Just path -> do (exitCode, _, _) <- readProcessWithExitCode path ["fmap"] ""- return (exitCode == ExitSuccess)-+module Scion.Hoogle +( query +, downloadData +, checkDatabase +, module Scion.Hoogle.Types +) where + +import qualified Data.ByteString.Char8 as BS8 +import Control.Monad +import Scion.Browser +import Scion.Hoogle.Types +import Scion.Hoogle.Instances.Json () +import Scion.Hoogle.Parser +import Scion.Hoogle.Util +import System.Exit (ExitCode(..)) +import System.Process +import Text.Parsec.Prim (runP) + +query :: Database -> String -> IO [Result] +query db q = do mpath <- findHoogleBinPath + case mpath of + Nothing -> return [] + Just path -> do (exitCode, output, err) <- readProcessWithExitCode path [q] "" + case exitCode of + ExitSuccess -> case runP (hoogleElements db) () "hoogle-output" (output) of + Right result -> return result + Left _ -> return [] + _ -> do putStrLn err + return [] + +downloadData :: IO Bool +downloadData = do mpath <- findHoogleBinPath + case mpath of + Nothing -> return False + Just path -> do putStrLn "Running hoogle data..." + (ec, _, err) <- readProcessWithExitCode path ["data"] "" + when (ec/= ExitSuccess) (putStrLn err) + return (ec == ExitSuccess) + +checkDatabase :: IO Bool +checkDatabase = do mpath <- findHoogleBinPath + case mpath of + Nothing -> return False + Just path -> do (exitCode, _, _) <- readProcessWithExitCode path ["fmap"] "" + return (exitCode == ExitSuccess) +
src/Scion/Hoogle/Instances/Json.hs view
@@ -1,28 +1,28 @@-module Scion.Hoogle.Instances.Json where--import Control.Applicative-import Data.Aeson hiding (Result)-import qualified Data.Text as T-import Scion.Hoogle.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 [ T.pack "type" .= "package"- , T.pack "results" .= pids- ]- toJSON (RModule mds) = object [ T.pack "type" .= "module"- , T.pack "results" .= mds- ]- toJSON (RDeclaration decls) = object [ T.pack "type" .= "declaration"- , T.pack "results" .= decls- ]- toJSON (RConstructor decls) = object [ T.pack "type" .= "constructor"- , T.pack "results" .= decls- ]--instance FromJSON (Query) where- parseJSON q = Query <$> parseJSON q-+module Scion.Hoogle.Instances.Json where + +import Control.Applicative +import Data.Aeson hiding (Result) +import qualified Data.Text as T +import Scion.Hoogle.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 [ T.pack "type" .= "package" + , T.pack "results" .= pids + ] + toJSON (RModule mds) = object [ T.pack "type" .= "module" + , T.pack "results" .= mds + ] + toJSON (RDeclaration decls) = object [ T.pack "type" .= "declaration" + , T.pack "results" .= decls + ] + toJSON (RConstructor decls) = object [ T.pack "type" .= "constructor" + , T.pack "results" .= decls + ] + +instance FromJSON (Query) where + parseJSON q = Query <$> parseJSON q +
src/Scion/Hoogle/Parser.hs view
@@ -1,122 +1,122 @@-{-# LANGUAGE RankNTypes #-}--module Scion.Hoogle.Parser where--import Data.List (find, intercalate)-import qualified Data.Map as M-import Data.Maybe (fromJust, catMaybes)-import Distribution.Package hiding (Package)-import Language.Haskell.Exts.Annotated.Syntax-import Scion.Browser-import Scion.Browser.Parser.Internal-import Scion.Browser.Query-import Scion.Hoogle.Types-import Text.Parsec.Char-import Text.Parsec.Combinator-import Text.Parsec.Prim--data HalfResult = HalfPackage String- | HalfModule String (Documented Module)- | HalfDecl String (Documented Decl)- | HalfGadtDecl String (Documented GadtDecl)--hoogleElements :: Database -> BSParser [Result]-hoogleElements db = do elts <- hoogleElements'- return $ catMaybes $ map (convertHalfToResult db) elts--hoogleElements' :: BSParser [HalfResult]-hoogleElements' = try (do spaces0- eof- return [])- <|> (do first <- hoogleElement- rest <- many $ try (try eol >> try hoogleElement)- spaces- eof- return $ first:rest)--hoogleElement :: BSParser HalfResult-hoogleElement = try (do pname <- hooglePackageName- return $ HalfPackage pname)- <|> try (do (mname, m) <- moduled (module_ NoDoc)- return $ HalfModule mname m)- <|> try (do (mname, d) <- moduled (function NoDoc)- return $ HalfDecl mname d)- <|> try (do (mname, d) <- moduled (dataHead NoDoc)- return $ HalfDecl mname d)- <|> try (do (mname, d) <- moduled (newtypeHead NoDoc)- return $ HalfDecl mname d)- <|> try (do (mname, d) <- moduled (type_ NoDoc)- return $ HalfDecl mname d)- <|> try (do (mname, d) <- moduled (class_ NoDoc)- return $ HalfDecl mname d)- <|> try (do (mname, d) <- moduled (constructor NoDoc)- return $ HalfGadtDecl mname d)--moduled :: BSParser a -> BSParser (String, a)-moduled p = try (do mname <- try conid `sepBy` char '.'- let name = intercalate "." (map getid mname)- try spaces1- rest <- p- return (name, rest))--hooglePackageName :: BSParser String-hooglePackageName = do string "package"- spaces1- name <- restOfLine- spaces0- return name--convertHalfToResult :: Database -> HalfResult -> Maybe Result-convertHalfToResult db (HalfPackage pname) = case packagesByName pname db of- [] -> Nothing- pkgs -> Just $ RPackage pkgs-convertHalfToResult db (HalfModule mname _) = case findPackagesForModule db mname of- [] -> Nothing- mds -> Just $ RModule mds-convertHalfToResult db (HalfDecl mname dcl) = let pidMods = findPackagesForModule db mname- in case findDeclsInModules pidMods dcl of- [] -> Nothing- decls -> Just $ RDeclaration decls-convertHalfToResult db (HalfGadtDecl mname dcl) = let pidMods = findPackagesForModule db mname- gadts = concatMap filterGadtStyleItems pidMods- in case findConstructorsInGadts gadts (getName dcl) of- [] -> Nothing- decls -> Just $ RConstructor decls--findPackagesForModule :: Database -> String -> [(PackageIdentifier, Documented Module)]-findPackagesForModule db md = let pkgs = M.filter (\(Package _ _ mds) -> M.member md mds) db- in M.toAscList $ M.map (\(Package _ _ mds) -> fromJust $ M.lookup md mds) pkgs--findDeclsInModules :: [(PackageIdentifier, Documented Module)] -> Documented Decl -> [(PackageIdentifier, String, Documented Decl)]-findDeclsInModules pidMods declName = foldr (\pidMod lst -> case findDeclInModule pidMod declName of- Nothing -> lst- Just d -> d:lst)- [] pidMods--findDeclInModule :: (PackageIdentifier, Documented Module) -> Documented Decl -> Maybe (PackageIdentifier, String, Documented Decl)-findDeclInModule (pid, md@(Module _ _ _ _ decls)) dname = case find (\d -> (fmap (const "") d) == (fmap (const "") dname)) decls of- Nothing -> Nothing- Just d -> Just (pid, getName md, d)-findDeclInModule _ _ = error "The impossible happened"--filterGadtStyleItems :: (PackageIdentifier, Documented Module) -> [(PackageIdentifier, String, Documented Decl)]-filterGadtStyleItems (pid, md@(Module _ _ _ _ decls)) = - map (\d -> (pid, getName md, d)) $ filter (\x -> case x of - (GDataDecl _ _ _ _ _ _ _) -> True- _ -> False)- decls-filterGadtStyleItems _ = error "The impossible happened"--findConstructorsInGadts :: [(PackageIdentifier, String, Documented Decl)] -> String -> [(PackageIdentifier, String, Documented Decl, Documented GadtDecl)]-findConstructorsInGadts gadts conName = foldr (\gadt lst -> case findConstructorInGadt gadt conName of- Nothing -> lst- Just c -> c:lst)- [] gadts--findConstructorInGadt :: (PackageIdentifier, String, Documented Decl) -> String -> Maybe (PackageIdentifier, String, Documented Decl, Documented GadtDecl)-findConstructorInGadt (pid, mdName, gadt@(GDataDecl _ _ _ _ _ decls _)) cname = - case find (\c -> (getName c) == cname) decls of- Nothing -> Nothing- Just c -> Just (pid, mdName, gadt, c)-findConstructorInGadt _ _ = error "The impossible happened"-+{-# LANGUAGE RankNTypes #-} + +module Scion.Hoogle.Parser where + +import Data.List (find, intercalate) +import qualified Data.Map as M +import Data.Maybe (fromJust, catMaybes) +import Distribution.Package hiding (Package) +import Language.Haskell.Exts.Annotated.Syntax +import Scion.Browser +import Scion.Browser.Parser.Internal +import Scion.Browser.Query +import Scion.Hoogle.Types +import Text.Parsec.Char +import Text.Parsec.Combinator +import Text.Parsec.Prim + +data HalfResult = HalfPackage String + | HalfModule String (Documented Module) + | HalfDecl String (Documented Decl) + | HalfGadtDecl String (Documented GadtDecl) + +hoogleElements :: Database -> BSParser [Result] +hoogleElements db = do elts <- hoogleElements' + return $ catMaybes $ map (convertHalfToResult db) elts + +hoogleElements' :: BSParser [HalfResult] +hoogleElements' = try (do spaces0 + eof + return []) + <|> (do first <- hoogleElement + rest <- many $ try (try eol >> try hoogleElement) + spaces + eof + return $ first:rest) + +hoogleElement :: BSParser HalfResult +hoogleElement = try (do pname <- hooglePackageName + return $ HalfPackage pname) + <|> try (do (mname, m) <- moduled (module_ NoDoc) + return $ HalfModule mname m) + <|> try (do (mname, d) <- moduled (function NoDoc) + return $ HalfDecl mname d) + <|> try (do (mname, d) <- moduled (dataHead NoDoc) + return $ HalfDecl mname d) + <|> try (do (mname, d) <- moduled (newtypeHead NoDoc) + return $ HalfDecl mname d) + <|> try (do (mname, d) <- moduled (type_ NoDoc) + return $ HalfDecl mname d) + <|> try (do (mname, d) <- moduled (class_ NoDoc) + return $ HalfDecl mname d) + <|> try (do (mname, d) <- moduled (constructor NoDoc) + return $ HalfGadtDecl mname d) + +moduled :: BSParser a -> BSParser (String, a) +moduled p = try (do mname <- try conid `sepBy` char '.' + let name = intercalate "." (map getid mname) + try spaces1 + rest <- p + return (name, rest)) + +hooglePackageName :: BSParser String +hooglePackageName = do string "package" + spaces1 + name <- restOfLine + spaces0 + return name + +convertHalfToResult :: Database -> HalfResult -> Maybe Result +convertHalfToResult db (HalfPackage pname) = case packagesByName pname db of + [] -> Nothing + pkgs -> Just $ RPackage pkgs +convertHalfToResult db (HalfModule mname _) = case findPackagesForModule db mname of + [] -> Nothing + mds -> Just $ RModule mds +convertHalfToResult db (HalfDecl mname dcl) = let pidMods = findPackagesForModule db mname + in case findDeclsInModules pidMods dcl of + [] -> Nothing + decls -> Just $ RDeclaration decls +convertHalfToResult db (HalfGadtDecl mname dcl) = let pidMods = findPackagesForModule db mname + gadts = concatMap filterGadtStyleItems pidMods + in case findConstructorsInGadts gadts (getName dcl) of + [] -> Nothing + decls -> Just $ RConstructor decls + +findPackagesForModule :: Database -> String -> [(PackageIdentifier, Documented Module)] +findPackagesForModule db md = let pkgs = M.filter (\(Package _ _ mds) -> M.member md mds) db + in M.toAscList $ M.map (\(Package _ _ mds) -> fromJust $ M.lookup md mds) pkgs + +findDeclsInModules :: [(PackageIdentifier, Documented Module)] -> Documented Decl -> [(PackageIdentifier, String, Documented Decl)] +findDeclsInModules pidMods declName = foldr (\pidMod lst -> case findDeclInModule pidMod declName of + Nothing -> lst + Just d -> d:lst) + [] pidMods + +findDeclInModule :: (PackageIdentifier, Documented Module) -> Documented Decl -> Maybe (PackageIdentifier, String, Documented Decl) +findDeclInModule (pid, md@(Module _ _ _ _ decls)) dname = case find (\d -> (fmap (const "") d) == (fmap (const "") dname)) decls of + Nothing -> Nothing + Just d -> Just (pid, getName md, d) +findDeclInModule _ _ = error "The impossible happened" + +filterGadtStyleItems :: (PackageIdentifier, Documented Module) -> [(PackageIdentifier, String, Documented Decl)] +filterGadtStyleItems (pid, md@(Module _ _ _ _ decls)) = + map (\d -> (pid, getName md, d)) $ filter (\x -> case x of + (GDataDecl _ _ _ _ _ _ _) -> True + _ -> False) + decls +filterGadtStyleItems _ = error "The impossible happened" + +findConstructorsInGadts :: [(PackageIdentifier, String, Documented Decl)] -> String -> [(PackageIdentifier, String, Documented Decl, Documented GadtDecl)] +findConstructorsInGadts gadts conName = foldr (\gadt lst -> case findConstructorInGadt gadt conName of + Nothing -> lst + Just c -> c:lst) + [] gadts + +findConstructorInGadt :: (PackageIdentifier, String, Documented Decl) -> String -> Maybe (PackageIdentifier, String, Documented Decl, Documented GadtDecl) +findConstructorInGadt (pid, mdName, gadt@(GDataDecl _ _ _ _ _ decls _)) cname = + case find (\c -> (getName c) == cname) decls of + Nothing -> Nothing + Just c -> Just (pid, mdName, gadt, c) +findConstructorInGadt _ _ = error "The impossible happened" +
src/Scion/Hoogle/Types.hs view
@@ -1,15 +1,15 @@-module Scion.Hoogle.Types where--import Distribution.Package hiding (Package)-import Language.Haskell.Exts.Annotated.Syntax-import Scion.Browser--type Results = [Result]--data Result = RPackage [Documented Package]- | RModule [(PackageIdentifier, Documented Module)]- | RDeclaration [(PackageIdentifier, String, Documented Decl)]- | RConstructor [(PackageIdentifier, String, Documented Decl, Documented GadtDecl)]--data Query = Query String-+module Scion.Hoogle.Types where + +import Distribution.Package hiding (Package) +import Language.Haskell.Exts.Annotated.Syntax +import Scion.Browser + +type Results = [Result] + +data Result = RPackage [Documented Package] + | RModule [(PackageIdentifier, Documented Module)] + | RDeclaration [(PackageIdentifier, String, Documented Decl)] + | RConstructor [(PackageIdentifier, String, Documented Decl, Documented GadtDecl)] + +data Query = Query String +
src/Scion/Hoogle/Util.hs view
@@ -1,117 +1,117 @@-{-# OPTIONS -cpp #-}--module Scion.Hoogle.Util-( findHoogleBinPath-) where--import Data.List (find)-import Distribution.InstalledPackageInfo-import Distribution.Package-import Scion.Packages-import System.FilePath-import System.Directory (doesFileExist)--#ifdef mingw32_HOST_OS-import System.Directory (getAppUserDataDirectory)-#endif---- Functions for finding Hoogle in the system--findHoogleBinPath :: IO (Maybe String)-findHoogleBinPath = findPathsAndCheck placesToSearch- where placesToSearch = [ findHoogleBinInLibrary getHoogleBinPath1- , findHoogleBinInLibrary getHoogleBinPath2-#ifdef mingw32_HOST_OS- , getHoogleBinPath3-#endif- ]--findPathsAndCheck :: [IO (Maybe String)] -> IO (Maybe String)-findPathsAndCheck [] = return Nothing-findPathsAndCheck (f:fs) = do r <- findPathAndCheck f- case r of- Nothing -> findPathsAndCheck fs- _ -> return r--findPathAndCheck :: IO (Maybe String) -> IO (Maybe String)-findPathAndCheck f = do p <- f- case p of- Nothing -> return Nothing- Just 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--#ifdef mingw32_HOST_OS-getHoogleBinPath3 :: IO (Maybe String)-getHoogleBinPath3 = do cabalDir <- getAppUserDataDirectory "cabal"- return $ Just (cabalDir </> "bin" </> "hoogle" <.> exeExtension)-#endif--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"--}-+{-# OPTIONS -cpp #-} + +module Scion.Hoogle.Util +( findHoogleBinPath +) where + +import Data.List (find) +import Distribution.InstalledPackageInfo +import Distribution.Package +import Scion.Packages +import System.FilePath +import System.Directory (doesFileExist) + +#ifdef mingw32_HOST_OS +import System.Directory (getAppUserDataDirectory) +#endif + +-- Functions for finding Hoogle in the system + +findHoogleBinPath :: IO (Maybe String) +findHoogleBinPath = findPathsAndCheck placesToSearch + where placesToSearch = [ findHoogleBinInLibrary getHoogleBinPath1 + , findHoogleBinInLibrary getHoogleBinPath2 +#ifdef mingw32_HOST_OS + , getHoogleBinPath3 +#endif + ] + +findPathsAndCheck :: [IO (Maybe String)] -> IO (Maybe String) +findPathsAndCheck [] = return Nothing +findPathsAndCheck (f:fs) = do r <- findPathAndCheck f + case r of + Nothing -> findPathsAndCheck fs + _ -> return r + +findPathAndCheck :: IO (Maybe String) -> IO (Maybe String) +findPathAndCheck f = do p <- f + case p of + Nothing -> return Nothing + Just 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 + +#ifdef mingw32_HOST_OS +getHoogleBinPath3 :: IO (Maybe String) +getHoogleBinPath3 = do cabalDir <- getAppUserDataDirectory "cabal" + return $ Just (cabalDir </> "bin" </> "hoogle" <.> exeExtension) +#endif + +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/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/Server/Commands.hs view
@@ -1,163 +1,163 @@-{-# LANGUAGE OverloadedStrings #-}--module Server.Commands where--import Control.Applicative-import Control.Monad-import Control.Monad.State-import Data.Aeson-import Data.Maybe (fromMaybe)-import qualified Data.Map as M-import qualified Data.Text as T-import Distribution.Package hiding (Package)-import Language.Haskell.Exts.Annotated.Syntax hiding (String)-import Scion.Browser-import Scion.Browser.Build (saveHackageDatabase, updateDatabase)-import Scion.Browser.Query-import Scion.Browser.Util (logToStdout)-import qualified Scion.Hoogle as H-import Scion.Packages-import System.Directory--data Command = LoadLocalDatabase FilePath Bool- | LoadHackageDatabase FilePath Bool- | GetPackages- | SetCurrentDatabase CurrentDatabase- | GetModules String- | GetDeclarations String- | HoogleQuery String- | HoogleDownloadData- | HoogleCheckDatabase- | GetDeclarationModules String- | Quit--data CurrentDatabase = AllPackages- | HackageDatabase- | LocalDatabase- | APackage PackageIdentifier--data BrowserState = BrowserState- { allDb :: Database- , localDb :: Database- , hackageDb :: Database- , currentDb :: Database- }--initialState :: BrowserState-initialState = BrowserState M.empty M.empty M.empty M.empty--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- curDb <- (if not fileExists'- then return M.empty- else do maybeDb <- lift $ loadDatabase path- case maybeDb of- Nothing -> return M.empty- Just theDb -> return theDb)- lift $ logToStdout "Local database loaded"- newDb <- if not rebuild- then return curDb- else do pkgInfos' <- lift $ getPkgInfos- let pkgInfos = concat $ map snd pkgInfos'- newDb <- lift $ updateDatabase curDb pkgInfos- lift $ logToStdout ("Saving on " ++ path)- lift $ saveDatabase path newDb- return newDb- modify (\s -> s { allDb = newDb `M.union` hackageDb s, localDb = newDb, currentDb = newDb })- return (String "ok", True)-executeCommand (LoadHackageDatabase path rebuild) =- do fileExists <- lift $ doesFileExist path- let fileExists' = fileExists `seq` fileExists- if not fileExists' || rebuild- then do lift $ logToStdout "Rebuilding Hackage database"- lift $ saveHackageDatabase path- else return ()- maybeDb <- lift $ loadDatabase path- lift $ logToStdout "Hackage database loaded"- let db = fromMaybe M.empty maybeDb- modify (\s -> s { allDb = localDb s `M.union` db, hackageDb = db, currentDb = db })- return (String "ok", True)-executeCommand (SetCurrentDatabase db) =- do case db of- AllPackages -> do modify (\s -> s { currentDb = allDb s })- return (String "ok", True)- LocalDatabase -> do modify (\s -> s { currentDb = localDb s })- return (String "ok", True)- HackageDatabase -> do modify (\s -> s { currentDb = hackageDb s })- return (String "ok", True)- APackage pid -> do st <- get- case getSingletonDatabase pid (allDb st) of- Nothing -> return (String "error", True)- Just newDb -> do modify (\s -> s { currentDb = newDb })- return (String "ok", True)-executeCommand GetPackages = do db <- getCurrentDatabase- return (toJSON (allPackages db), True)-executeCommand (GetModules mname) = do db <- getCurrentDatabase- let smods = getDocumentedModules (getSubmodules mname db)- return (toJSON smods, True)-executeCommand (GetDeclarations mname) = do db <- getCurrentDatabase- -- let decls = concat $ map snd (getDeclsInModule mname db)- let decls = getDeclsInModule mname db- return (toJSON decls, True)-executeCommand (HoogleQuery query) = do db <- getCurrentDatabase- results <- lift $ H.query db query- return (toJSON results, True)-executeCommand HoogleDownloadData = do _ <- lift $ H.downloadData- return (String "ok", True)-executeCommand HoogleCheckDatabase = do present <- lift $ H.checkDatabase- return (Bool present, True)-executeCommand (GetDeclarationModules d) = do db <- getCurrentDatabase- let mods = getModulesWhereDeclarationIs d db- return (toJSON mods, True)-executeCommand Quit = return (String "ok", False)--getCurrentDatabase :: BrowserM Database-getCurrentDatabase = do s <- get- return $ currentDb s--getEntireDatabase :: BrowserM Database-getEntireDatabase = do s <- get- return $ allDb s--getDocumentedModules :: [(String, [(PackageIdentifier, Documented Module)])] -> [Documented Module]-getDocumentedModules = map (getDocumentedModule . snd)--getDocumentedModule :: [(PackageIdentifier, Documented Module)] -> Documented Module-getDocumentedModule [(_, md)] = md-getDocumentedModule mds@((_, Module _ hd _ _ _):_) = let decls = concat $ map (\(Module _ _ _ _ decl) -> decl) $ map snd mds- in Module NoDoc hd [] [] decls-getDocumentedModule _ = error "The impossible happened"--instance FromJSON Command where- parseJSON (Object v) = case M.lookup (T.pack "command") v of- Just (String e) ->- case T.unpack e of- "load-local-db" -> LoadLocalDatabase <$> v .: "filepath"- <*> v .: "rebuild"- "load-hackage-db" -> LoadHackageDatabase <$> v .: "filepath"- <*> v .: "rebuild"- "get-packages" -> pure GetPackages- "set-current-db" -> SetCurrentDatabase <$> v .: "new-db"- "get-modules" -> GetModules <$> v .: "module"- "get-declarations" -> GetDeclarations <$> v .: "module"- "hoogle-query" -> HoogleQuery <$> v .: "query"- "hoogle-data" -> pure HoogleDownloadData- "hoogle-check" -> pure HoogleCheckDatabase- "get-decl-module" -> GetDeclarationModules <$> v .: "decl"- "quit" -> pure Quit- _ -> mzero- _ -> mzero- parseJSON _ = mzero--instance FromJSON CurrentDatabase where- parseJSON (String new) = case T.unpack new of- "_all" -> pure AllPackages- "_hackage" -> pure HackageDatabase- "_local" -> pure LocalDatabase- _ -> mzero- parseJSON other = APackage <$> parseJSON other-+{-# LANGUAGE OverloadedStrings #-} + +module Server.Commands where + +import Control.Applicative +import Control.Monad +import Control.Monad.State +import Data.Aeson +import Data.Maybe (fromMaybe) +import qualified Data.Map as M +import qualified Data.Text as T +import Distribution.Package hiding (Package) +import Language.Haskell.Exts.Annotated.Syntax hiding (String) +import Scion.Browser +import Scion.Browser.Build (saveHackageDatabase, updateDatabase) +import Scion.Browser.Query +import Scion.Browser.Util (logToStdout) +import qualified Scion.Hoogle as H +import Scion.Packages +import System.Directory + +data Command = LoadLocalDatabase FilePath Bool + | LoadHackageDatabase FilePath Bool + | GetPackages + | SetCurrentDatabase CurrentDatabase + | GetModules String + | GetDeclarations String + | HoogleQuery String + | HoogleDownloadData + | HoogleCheckDatabase + | GetDeclarationModules String + | Quit + +data CurrentDatabase = AllPackages + | HackageDatabase + | LocalDatabase + | APackage PackageIdentifier + +data BrowserState = BrowserState + { allDb :: Database + , localDb :: Database + , hackageDb :: Database + , currentDb :: Database + } + +initialState :: BrowserState +initialState = BrowserState M.empty M.empty M.empty M.empty + +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 + curDb <- (if not fileExists' + then return M.empty + else do maybeDb <- lift $ loadDatabase path + case maybeDb of + Nothing -> return M.empty + Just theDb -> return theDb) + lift $ logToStdout "Local database loaded" + newDb <- if not rebuild + then return curDb + else do pkgInfos' <- lift $ getPkgInfos + let pkgInfos = concat $ map snd pkgInfos' + newDb <- lift $ updateDatabase curDb pkgInfos + lift $ logToStdout ("Saving on " ++ path) + lift $ saveDatabase path newDb + return newDb + modify (\s -> s { allDb = newDb `M.union` hackageDb s, localDb = newDb, currentDb = newDb }) + return (String "ok", True) +executeCommand (LoadHackageDatabase path rebuild) = + do fileExists <- lift $ doesFileExist path + let fileExists' = fileExists `seq` fileExists + if not fileExists' || rebuild + then do lift $ logToStdout "Rebuilding Hackage database" + lift $ saveHackageDatabase path + else return () + maybeDb <- lift $ loadDatabase path + lift $ logToStdout "Hackage database loaded" + let db = fromMaybe M.empty maybeDb + modify (\s -> s { allDb = localDb s `M.union` db, hackageDb = db, currentDb = db }) + return (String "ok", True) +executeCommand (SetCurrentDatabase db) = + do case db of + AllPackages -> do modify (\s -> s { currentDb = allDb s }) + return (String "ok", True) + LocalDatabase -> do modify (\s -> s { currentDb = localDb s }) + return (String "ok", True) + HackageDatabase -> do modify (\s -> s { currentDb = hackageDb s }) + return (String "ok", True) + APackage pid -> do st <- get + case getSingletonDatabase pid (allDb st) of + Nothing -> return (String "error", True) + Just newDb -> do modify (\s -> s { currentDb = newDb }) + return (String "ok", True) +executeCommand GetPackages = do db <- getCurrentDatabase + return (toJSON (allPackages db), True) +executeCommand (GetModules mname) = do db <- getCurrentDatabase + let smods = getDocumentedModules (getSubmodules mname db) + return (toJSON smods, True) +executeCommand (GetDeclarations mname) = do db <- getCurrentDatabase + -- let decls = concat $ map snd (getDeclsInModule mname db) + let decls = getDeclsInModule mname db + return (toJSON decls, True) +executeCommand (HoogleQuery query) = do db <- getCurrentDatabase + results <- lift $ H.query db query + return (toJSON results, True) +executeCommand HoogleDownloadData = do _ <- lift $ H.downloadData + return (String "ok", True) +executeCommand HoogleCheckDatabase = do present <- lift $ H.checkDatabase + return (Bool present, True) +executeCommand (GetDeclarationModules d) = do db <- getCurrentDatabase + let mods = getModulesWhereDeclarationIs d db + return (toJSON mods, True) +executeCommand Quit = return (String "ok", False) + +getCurrentDatabase :: BrowserM Database +getCurrentDatabase = do s <- get + return $ currentDb s + +getEntireDatabase :: BrowserM Database +getEntireDatabase = do s <- get + return $ allDb s + +getDocumentedModules :: [(String, [(PackageIdentifier, Documented Module)])] -> [Documented Module] +getDocumentedModules = map (getDocumentedModule . snd) + +getDocumentedModule :: [(PackageIdentifier, Documented Module)] -> Documented Module +getDocumentedModule [(_, md)] = md +getDocumentedModule mds@((_, Module _ hd _ _ _):_) = let decls = concat $ map (\(Module _ _ _ _ decl) -> decl) $ map snd mds + in Module NoDoc hd [] [] decls +getDocumentedModule _ = error "The impossible happened" + +instance FromJSON Command where + parseJSON (Object v) = case M.lookup (T.pack "command") v of + Just (String e) -> + case T.unpack e of + "load-local-db" -> LoadLocalDatabase <$> v .: "filepath" + <*> v .: "rebuild" + "load-hackage-db" -> LoadHackageDatabase <$> v .: "filepath" + <*> v .: "rebuild" + "get-packages" -> pure GetPackages + "set-current-db" -> SetCurrentDatabase <$> v .: "new-db" + "get-modules" -> GetModules <$> v .: "module" + "get-declarations" -> GetDeclarations <$> v .: "module" + "hoogle-query" -> HoogleQuery <$> v .: "query" + "hoogle-data" -> pure HoogleDownloadData + "hoogle-check" -> pure HoogleCheckDatabase + "get-decl-module" -> GetDeclarationModules <$> v .: "decl" + "quit" -> pure Quit + _ -> mzero + _ -> mzero + parseJSON _ = mzero + +instance FromJSON CurrentDatabase where + parseJSON (String new) = case T.unpack new of + "_all" -> pure AllPackages + "_hackage" -> pure HackageDatabase + "_local" -> pure LocalDatabase + _ -> mzero + parseJSON other = APackage <$> parseJSON other +