├── .gitignore ├── LICENSE ├── Language └── Haskell │ ├── GhcImportedFrom.hs │ └── GhcImportedFrom │ ├── Types.hs │ └── UtilsFromGhcMod.hs ├── README.md ├── Setup.hs ├── build_in_sandbox.sh ├── build_in_sandbox_scratch.sh ├── changelog.md ├── cp_to_dockers.sh ├── docker-testsuite ├── README.md ├── debian-cabal │ ├── Dockerfile │ ├── build.sh │ ├── build_and_test.sh │ └── go.sh ├── debian-stack │ ├── Dockerfile │ ├── build.sh │ ├── build_and_test.sh │ ├── go.sh │ └── sources.list ├── fedora-cabal │ ├── README.md │ ├── ___Dockerfile │ ├── build.sh │ ├── build_and_test.sh │ └── go.sh ├── fedora-stack │ ├── Dockerfile │ ├── build.sh │ └── go.sh ├── ubuntu-cabal │ ├── Dockerfile │ ├── build.sh │ ├── build_and_test.sh │ └── go.sh └── ubuntu-stack │ ├── Dockerfile │ ├── build.sh │ ├── build_and_test.sh │ └── go.sh ├── ghc-imported-from.cabal ├── quick_rebuild.sh ├── run_tests_cabal_sandbox.sh ├── run_tests_stack.sh ├── src ├── Main.hs └── fake-ghc-for-ghc-imported-from.hs ├── stack.yaml └── test ├── ImportedFromSpec.hs ├── Spec.hs └── data ├── Hiding.hs ├── Muddle.hs └── When.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox/ 2 | cabal.sandbox.config 3 | dist/ 4 | *.swp 5 | codex.tags 6 | tmp/* 7 | .stack-work/* 8 | docker-testsuite/debian-cabal/ghc-imported-from-*.tar.gz 9 | docker-testsuite/debian-stack/ghc-imported-from-*.tar.gz 10 | docker-testsuite/fedora-stack/ghc-imported-from-*.tar.gz 11 | docker-testsuite/ubuntu-cabal/ghc-imported-from-*.tar.gz 12 | docker-testsuite/fedora-cabal/ghc-imported-from-*.tar.gz 13 | docker-testsuite/ubuntu-stack/ghc-imported-from-*.tar.gz 14 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, Carlo Hamalainen 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Carlo Hamalainen nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Language/Haskell/GhcImportedFrom.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : GhcImportedFrom 9 | -- Copyright : Carlo Hamalainen 2013-2016 10 | -- License : BSD3 11 | -- 12 | -- Maintainer : carlo@carlo-hamalainen.net 13 | -- Stability : experimental 14 | -- Portability : portable 15 | -- 16 | -- Synopsis: Attempt to guess the location of the Haddock HTML 17 | -- documentation for a given symbol in a particular module, file, and 18 | -- line/col location. 19 | -- 20 | -- Latest development version: . 21 | 22 | module Language.Haskell.GhcImportedFrom ( 23 | QualifiedName 24 | , Symbol 25 | , GhcOptions(..) 26 | , GhcPkgOptions(..) 27 | , HaskellModule(..) 28 | , modifyDFlags 29 | , setDynamicFlags 30 | , getTextualImports 31 | , getSummary 32 | , toHaskellModule 33 | , symbolImportedFrom 34 | , postfixMatch 35 | , moduleOfQualifiedName 36 | , qualifiedName 37 | , ghcPkgFindModule 38 | , ghcPkgHaddockUrl 39 | , moduleNameToHtmlFile 40 | , matchToUrl 41 | , guessHaddockUrl 42 | , haddockUrl 43 | , getGhcOptionsViaCabalRepl 44 | 45 | -- Things from Language.Haskell.GhcImportedFrom.Types 46 | , Options (..) 47 | , defaultOptions 48 | , LineSeparator (..) 49 | ) where 50 | 51 | import Control.Applicative 52 | import Control.Monad 53 | import Data.Char (isAlpha) 54 | import Data.List 55 | import Data.Maybe 56 | import Data.Typeable() 57 | import Desugar() 58 | import FastString 59 | import GHC 60 | import GHC.Paths (libdir) 61 | import GHC.SYB.Utils() 62 | import HscTypes 63 | import Outputable 64 | import RdrName 65 | import System.Directory 66 | import System.Environment() 67 | import System.FilePath 68 | import System.IO 69 | import System.Process 70 | import TcRnTypes() 71 | import System.Process.Streaming 72 | import qualified Data.ByteString as B 73 | import qualified Data.ByteString.Lazy as BL 74 | import Data.ByteString.Internal (w2c) 75 | 76 | import qualified GhcMonad 77 | import qualified MonadUtils() 78 | import qualified Packages 79 | import qualified SrcLoc 80 | import qualified Safe 81 | 82 | import Language.Haskell.GhcMod ( 83 | findCradle 84 | , cradleRootDir 85 | , Cradle(..) 86 | ) 87 | 88 | import qualified Data.Map as M 89 | 90 | import Language.Haskell.GhcMod.Monad ( runGmOutT ) 91 | import qualified Language.Haskell.GhcMod.Types as GhcModTypes 92 | 93 | import Language.Haskell.GhcMod.Types (IOish) 94 | import Language.Haskell.GhcMod.Monad.Types (GhcModLog(..), GmOut(..)) 95 | import Control.Monad.Trans.Journal (runJournalT) 96 | 97 | import Language.Haskell.GhcImportedFrom.UtilsFromGhcMod 98 | import Language.Haskell.GhcImportedFrom.Types 99 | 100 | import Control.Exception (SomeException) 101 | 102 | import qualified Text.Parsec as TP 103 | import Data.Functor.Identity 104 | 105 | import qualified Documentation.Haddock as Haddock 106 | 107 | import Control.Exception 108 | import Control.Monad.Catch 109 | 110 | import qualified DynFlags() 111 | 112 | #if __GLASGOW_HASKELL__ >= 708 113 | import DynFlags ( unsafeGlobalDynFlags ) 114 | tdflags :: DynFlags 115 | tdflags = unsafeGlobalDynFlags 116 | #else 117 | import DynFlags ( tracingDynFlags ) 118 | tdflags :: DynFlags 119 | tdflags = tracingDynFlags 120 | #endif 121 | 122 | type GHCOption = String 123 | 124 | type QualifiedName = String -- ^ A qualified name, e.g. @Foo.bar@. 125 | 126 | type Symbol = String -- ^ A symbol, possibly qualified, e.g. @bar@ or @Foo.bar@. 127 | 128 | newtype GhcOptions 129 | -- | List of user-supplied GHC options, refer to @tets@ subdirectory for example usage. Note that 130 | -- GHC API and ghc-pkg have inconsistencies in the naming of options, see for more details. 131 | = GhcOptions [String] deriving (Show) 132 | 133 | --instance Monoid GhcOptions where 134 | -- mempty = GhcOptions [] 135 | -- (GhcOptions g) `mappend` (GhcOptions h) = GhcOptions $ g ++ h 136 | 137 | newtype GhcPkgOptions 138 | -- | List of user-supplied ghc-pkg options. 139 | = GhcPkgOptions [String] deriving (Show) 140 | 141 | data HaskellModule 142 | -- | Information about an import of a Haskell module. 143 | = HaskellModule { modName :: String 144 | , modQualifier :: Maybe String 145 | , modIsImplicit :: Bool 146 | , modHiding :: [String] 147 | , modImportedAs :: Maybe String 148 | , modSpecifically :: [String] 149 | } deriving (Show, Eq) 150 | 151 | 152 | -- trace' :: Show x => String -> x -> b -> b 153 | -- trace' m x = trace (m ++ ">>> " ++ show x) 154 | 155 | -- trace'' :: Outputable x => String -> x -> b -> b 156 | -- trace'' m x = trace (m ++ ">>> " ++ showSDoc tdflags (ppr x)) 157 | 158 | -- | Evaluate IO actions in sequence, returning the first that 159 | -- succeeds. 160 | shortcut :: [IO (Maybe a)] -> IO (Maybe a) 161 | shortcut [] = return Nothing 162 | shortcut (a:as) = do 163 | a' <- a 164 | 165 | case a' of 166 | a''@(Just _) -> return a'' 167 | Nothing -> shortcut as 168 | 169 | executeFallibly' :: String -> [String] -> IO (Maybe (String, String)) 170 | executeFallibly' cmd args = do 171 | x <- (executeFallibly (piped (proc cmd args)) ((,) <$> (foldOut intoLazyBytes) <*> (foldErr intoLazyBytes))) 172 | `catchIOError` -- FIXME Later, propagate the error so we can log it. Top level type should be an Either or something, not a Maybe. 173 | (\e -> return $ Left $ show e) 174 | 175 | return $ case x of 176 | Left e -> Nothing 177 | Right (a, b) -> Just $ (b2s a, b2s b) 178 | 179 | where 180 | 181 | b2s = map w2c . B.unpack . BL.toStrict 182 | 183 | -- | Use "stack path" to get the snapshot package db location. 184 | getStackSnapshotPkgDb :: IO (Maybe String) 185 | getStackSnapshotPkgDb = do 186 | putStrLn "getStackSnapshotPkgDb ..." 187 | 188 | x <- join <$> (fmap (fmap unwords . fmap words . Safe.headMay . lines) . fmap fst) <$> executeFallibly' "stack" ["path", "--snapshot-pkg-db"] 189 | 190 | return $ case x of 191 | Nothing -> Nothing 192 | Just "" -> Nothing 193 | Just x' -> Just x' 194 | 195 | -- | Use "stack path" to get the local package db location. 196 | getStackLocalPkgDb :: IO (Maybe String) 197 | getStackLocalPkgDb = do 198 | putStrLn "getStackLocalPkgDb ..." 199 | 200 | x <- join <$> (fmap (fmap unwords . fmap words . Safe.headMay . lines) . fmap fst) <$> executeFallibly' "stack" ["path", "--local-pkg-db"] 201 | 202 | return $ case x of 203 | Nothing -> Nothing 204 | Just "" -> Nothing 205 | Just x' -> Just x' 206 | 207 | -- | Use "stack ghci" with our fake ghc binary to get all the GHC options related 208 | -- to the local Stack configuration (if present). 209 | getGhcOptionsViaStack :: IO (Maybe [String]) 210 | getGhcOptionsViaStack = do 211 | putStrLn "getGhcOptionsViaStack..." 212 | 213 | stackSnapshotPkgDb <- fmap ("-package-db " ++) <$> getStackSnapshotPkgDb :: IO (Maybe String) 214 | stackLocalPkgDb <- fmap ("-package-db " ++) <$> getStackLocalPkgDb :: IO (Maybe String) 215 | 216 | case (stackSnapshotPkgDb, stackLocalPkgDb) of 217 | (Nothing, _) -> return Nothing 218 | (_, Nothing) -> return Nothing 219 | (Just stackSnapshotPkgDb', Just stackLocalPkgDb') -> do 220 | x <- executeFallibly' "stack" ["ghci", "--with-ghc=fake-ghc-for-ghc-imported-from"] 221 | 222 | let result = case x of 223 | Nothing -> [] 224 | Just (x', _) -> filter ("--interactive" `isPrefixOf`) . lines $ x' 225 | 226 | return $ case result of 227 | [r] -> Just $ filterOpts (words r) ++ [stackSnapshotPkgDb', stackLocalPkgDb'] 228 | _ -> Nothing 229 | 230 | -- | Use "cabal repl" with our fake ghc binary to get all the GHC options related 231 | -- to the local cabal sandbox (if present). 232 | getGhcOptionsViaCabalRepl :: IO (Maybe [String]) 233 | getGhcOptionsViaCabalRepl = do 234 | putStrLn "getGhcOptionsViaCabalRepl..." 235 | 236 | x <- executeFallibly' "cabal" ["repl", "--with-ghc=fake-ghc-for-ghc-imported-from"] 237 | 238 | let result = case x of 239 | Nothing -> [] 240 | Just (x', _) -> filter ("--interactive" `isPrefixOf`) . lines $ x' 241 | 242 | return $ case result of 243 | [r] -> Just $ filterOpts (words r) 244 | _ -> Nothing 245 | 246 | -- | GHC options that we don't use when partially compiling the source module. 247 | filterOpts :: [String] -> [String] 248 | filterOpts xs = filter (\x -> x /= "--interactive" && x /= "-fbuilding-cabal-package" && x /= "-Wall") $ dropModuleNames xs 249 | 250 | where 251 | 252 | dropModuleNames :: [String] -> [String] 253 | dropModuleNames = filter parseHelper 254 | 255 | parseHelper :: String -> Bool 256 | parseHelper s = case TP.parse (parseFullHaskellModuleName <* TP.eof) "" s of Right _ -> False 257 | Left _ -> True 258 | 259 | parseFullHaskellModuleName :: TP.ParsecT String u Data.Functor.Identity.Identity String 260 | parseFullHaskellModuleName = do 261 | h <- parseHaskellModuleName 262 | rest <- many parseDottedHaskellModuleName 263 | 264 | return $ intercalate "." (h:rest) 265 | 266 | parseHaskellModuleName :: TP.ParsecT String u Data.Functor.Identity.Identity String 267 | parseHaskellModuleName = do 268 | c <- TP.upper 269 | cs <- TP.many (TP.choice [TP.lower, TP.upper, TP.char '_', TP.digit]) 270 | return (c:cs) 271 | 272 | parseDottedHaskellModuleName :: TP.ParsecT String u Data.Functor.Identity.Identity String 273 | parseDottedHaskellModuleName = TP.char '.' >> parseHaskellModuleName 274 | 275 | 276 | parsePackageAndQualName :: forall u. TP.ParsecT String u Identity (String, String) 277 | parsePackageAndQualName = TP.choice [TP.try parsePackageAndQualNameWithHash, parsePackageAndQualNameNoHash] 278 | 279 | where 280 | 281 | -- Package with no hash (seems to be for internal packages?) 282 | -- base-4.8.2.0:Data.Foldable.length 283 | parsePackageAndQualNameNoHash :: TP.ParsecT String u Data.Functor.Identity.Identity (String, String) 284 | parsePackageAndQualNameNoHash = do 285 | packageName <- parsePackageName 286 | qName <- parsePackageFinalQualName 287 | 288 | return (packageName, qName) 289 | 290 | parsePackageName :: TP.ParsecT String u Data.Functor.Identity.Identity String 291 | parsePackageName = TP.anyChar `TP.manyTill` TP.char ':' 292 | 293 | parsePackageFinalQualName :: TP.ParsecT String u Data.Functor.Identity.Identity String 294 | parsePackageFinalQualName = TP.many1 TP.anyChar 295 | 296 | -- Parse the package name "containers-0.5.6.2" from a string like 297 | -- "containers-0.5.6.2@conta_2C3ZI8RgPO2LBMidXKTvIU:Data.Map.Base.fromList" 298 | parsePackageAndQualNameWithHash :: TP.ParsecT String u Data.Functor.Identity.Identity (String, String) 299 | parsePackageAndQualNameWithHash = do 300 | packageName <- parsePackageName 301 | _ <- parsePackageHash 302 | qName <- parsePackageFinalQualName 303 | 304 | return (packageName, qName) 305 | 306 | where 307 | 308 | parsePackageName :: TP.ParsecT String u Data.Functor.Identity.Identity String 309 | parsePackageName = TP.anyChar `TP.manyTill` TP.char '@' 310 | 311 | parsePackageHash :: TP.ParsecT String u Data.Functor.Identity.Identity String 312 | parsePackageHash = TP.anyChar `TP.manyTill` TP.char ':' 313 | 314 | parsePackageFinalQualName :: TP.ParsecT String u Data.Functor.Identity.Identity String 315 | parsePackageFinalQualName = TP.many1 TP.anyChar 316 | 317 | -- | Use "cabal repl" or "stack ghci" to try to get GHC options. Lots of things here, for 318 | -- example: 319 | -- 320 | -- --interactive -fbuilding-cabal-package -O0 -outputdir dist/build/rename-photos/rename-photos-tmp 321 | -- -odir dist/build/rename-photos/rename-photos-tmp -hidir dist/build/rename-photos/rename-photos-tmp 322 | -- -stubdir dist/build/rename-photos/rename-photos-tmp -i -idist/build/rename-photos/rename-photos-tmp 323 | -- -i. -idist/build/autogen -Idist/build/autogen -Idist/build/rename-photos/rename-photos-tmp 324 | -- -optP-include -optPdist/build/autogen/cabal_macros.h -dynload deploy 325 | -- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/array_67iodizgJQIIxYVTp4emlA 326 | -- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/base_HQfYBxpPvuw8OunzQu6JGM 327 | -- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/binar_3uXFWMoAGBg0xKP9MHKRwi 328 | -- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/rts 329 | -- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/bytes_6VWy06pWzJq9evDvK2d4w6 330 | -- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/conta_2C3ZI8RgPO2LBMidXKTvIU 331 | -- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/deeps_6vMKxt5sPFR0XsbRWvvq59 332 | -- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/direc_0hFG6ZxK1nk4zsyOqbNHfm 333 | -- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/filep_Ey7a1in9roBAE8bUFJ5R9m 334 | -- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/ghcpr_8TmvWUcS1U1IKHT0levwg3 335 | -- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/integ_2aU3IZNMF9a7mQ0OzsZ0dS 336 | -- -optl-Wl,-rpath,/scratch/sandboxes/camera-scripts/lib/x86_64-linux-ghc-7.10.3/mmorph-1.0.6-2Jm5FlYBlmjDhcU1ovZRKP 337 | -- -optl-Wl,-rpath,/scratch/sandboxes/camera-scripts/lib/x86_64-linux-ghc-7.10.3/mtl-2.2.1-Aue4leSeVkpKLsfHIV51E8 338 | -- -optl-Wl,-rpath,/scratch/sandboxes/camera-scripts/lib/x86_64-linux-ghc-7.10.3/parsec-3.1.9-EE5NO1mlYLh4J8mgDEshNv 339 | -- -optl-Wl,-rpath,/scratch/sandboxes/camera-scripts/lib/x86_64-linux-ghc-7.10.3/pipes-4.1.8-77ihSQ5c6PS0Tlq86aN8G4 340 | -- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/proce_52AgREEfSrnJLlkGV9YZZJ 341 | -- -optl-Wl,-rpath,/scratch/sandboxes/camera-scripts/lib/x86_64-linux-ghc-7.10.3/text-1.2.2.0-5c7VCmRXJenGcMPs3kwpkI 342 | -- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/time_FTheb6LSxyX1UABIbBXRfn 343 | -- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/trans_GZTjP9K5WFq01xC9BAGQpF 344 | -- -optl-Wl,-rpath,/scratch/sandboxes/camera-scripts/lib/x86_64-linux-ghc-7.10.3/transformers-compat-0.5.1.4-EfAx8JliEAN1Gu6x0L8GYr 345 | -- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/unix_KZL8h98IqDM57kQSPo1mKx 346 | -- -hide-all-packages 347 | -- -no-user-package-db 348 | -- -package-db /scratch/sandboxes/camera-scripts/x86_64-linux-ghc-7.10.3-packages.conf.d 349 | -- -package-db dist/package.conf.inplace 350 | -- -package-id base-4.8.2.0-0d6d1084fbc041e1cded9228e80e264d 351 | -- -package-id bytestring-0.10.6.0-c60f4c543b22c7f7293a06ae48820437 352 | -- -package-id containers-0.5.6.2-e59c9b78d840fa743d4169d4bea15592 353 | -- -package-id directory-1.2.2.0-f8e14a9d121b76a00a0f669ee724a732 354 | -- -package-id filepath-1.4.0.0-f97d1e4aebfd7a03be6980454fe31d6e 355 | -- -package-id parsec-3.1.9-a68c5d78bf2a63f486c525b960f2dddd 356 | -- -package-id pipes-4.1.8-394d3831f54f6d7e2c83d050d94ecb3a 357 | -- -package-id process-1.2.3.0-78f206acb2330ea8066c6c19c87356f0 358 | -- -package-id text-1.2.2.0-daec687352505adca80a15e023cbae5c 359 | -- -package-id transformers-0.4.2.0-81450cd8f86b36eaa8fa0cbaf6efc3a3 360 | -- -XHaskell98 361 | -- ./renamePhotos.hs 362 | getGhcOptionsViaCabalOrStack :: IO [String] 363 | getGhcOptionsViaCabalOrStack = do 364 | x <- fromMaybe [] <$> shortcut [getGhcOptionsViaStack, getGhcOptionsViaCabalRepl] 365 | putStrLn $ "getGhcOptionsViaCabalOrStack: " ++ show x 366 | return x 367 | 368 | -- | Add user-supplied GHC options. 369 | modifyDFlags :: [String] -> DynFlags -> IO ([GHCOption], DynFlags) 370 | modifyDFlags ghcOpts0 dflags0 = 371 | -- defaultErrorHandler defaultFatalMessager defaultFlushOut $ 372 | runGhc (Just libdir) $ do 373 | ghcOpts1 <- GhcMonad.liftIO getGhcOptionsViaCabalOrStack 374 | 375 | (dflags1, _, _) <- GHC.parseDynamicFlags dflags0 (map SrcLoc.noLoc $ ghcOpts0 ++ ghcOpts1) 376 | 377 | let dflags2 = dflags1 { hscTarget = HscInterpreted 378 | , ghcLink = LinkInMemory 379 | } 380 | 381 | return (ghcOpts0 ++ ghcOpts1, dflags2) 382 | 383 | -- | Set GHC options and run 'initPackages' in 'GhcMonad'. 384 | -- 385 | -- Typical use: 386 | -- 387 | -- > defaultErrorHandler defaultFatalMessager defaultFlushOut $ do 388 | -- > runGhc (Just libdir) $ do 389 | -- > getSessionDynFlags >>= setDynamicFlags (GhcOptions myGhcOptionList) 390 | -- > -- do stuff 391 | setDynamicFlags :: GhcMonad m => GhcOptions -> DynFlags -> m ([GHCOption], DynFlags) 392 | setDynamicFlags (GhcOptions extraGHCOpts) dflags0 = do 393 | (allGhcOpts, dflags1) <- GhcMonad.liftIO $ modifyDFlags extraGHCOpts dflags0 394 | 395 | void $ setSessionDynFlags dflags1 396 | _ <- GhcMonad.liftIO $ Packages.initPackages dflags1 397 | 398 | return (allGhcOpts, dflags1) 399 | 400 | -- |Read the textual imports in a file. 401 | -- 402 | -- Example: 403 | -- 404 | -- >>> (showSDoc tracingDynFlags) . ppr <$> getTextualImports "test/data/Hiding.hs" "Hiding" >>= putStrLn 405 | -- [ import (implicit) Prelude, import qualified Safe 406 | -- , import System.Environment ( getArgs ) 407 | -- , import Data.List hiding ( map ) 408 | -- ] 409 | -- 410 | -- See also 'toHaskellModule' and 'getSummary'. 411 | getTextualImports :: GhcMonad m => GhcOptions -> FilePath -> String -> m ([GHCOption], [SrcLoc.Located (ImportDecl RdrName)]) 412 | getTextualImports ghcopts targetFile targetModuleName = do 413 | GhcMonad.liftIO $ putStrLn $ "getTextualImports: " ++ show (targetFile, targetModuleName) 414 | (allGhcOpts, modSum) <- getSummary ghcopts targetFile targetModuleName 415 | 416 | GhcMonad.liftIO $ putStrLn $ "getTextualImports: allGhcOpts: " ++ show allGhcOpts 417 | 418 | -- graph <- getModuleGraph 419 | -- GhcMonad.liftIO $ error $ show $ map ms_hspp_file graph 420 | 421 | return (allGhcOpts, ms_textual_imps modSum) 422 | 423 | -- | Get the module summary for a particular file/module. The first and second components of the 424 | -- return value are @ghcOpts1@ and @ghcOpts2@; see 'setDynamicFlags'. 425 | getSummary :: GhcMonad m => GhcOptions -> FilePath -> String -> m ([GHCOption], ModSummary) 426 | getSummary ghcopts targetFile targetModuleName = do 427 | GhcMonad.liftIO $ putStrLn "getSummary, setting dynamic flags..." 428 | (allGhcOpts, _) <- getSessionDynFlags >>= setDynamicFlags ghcopts 429 | 430 | GhcMonad.liftIO $ putStrLn $ "getSummary, allGhcOpts: " ++ show allGhcOpts 431 | 432 | -- Load the target file (e.g. "Muddle.hs"). 433 | GhcMonad.liftIO $ putStrLn "getSummary, loading the target file..." 434 | target <- guessTarget targetFile Nothing 435 | setTargets [target] 436 | 437 | _ <- load LoadAllTargets 438 | 439 | -- Set the context by loading the module, e.g. "Muddle" which is in "Muddle.hs". 440 | GhcMonad.liftIO $ putStrLn "getSummary, setting the context..." 441 | 442 | setContext [(IIDecl . simpleImportDecl . mkModuleName) targetModuleName] 443 | `gcatch` (\(e :: SourceError) -> GhcMonad.liftIO (putStrLn $ "getSummary: setContext failed with a SourceError, trying to continue anyway..." ++ show e)) 444 | `gcatch` (\(g :: GhcApiError) -> GhcMonad.liftIO (putStrLn $ "getSummary: setContext failed with a GhcApiError, trying to continue anyway..." ++ show g)) 445 | `gcatch` (\(se :: SomeException) -> GhcMonad.liftIO (putStrLn $ "getSummary: setContext failed with a SomeException, trying to continue anyway..." ++ show se)) 446 | 447 | -- Extract the module summary. 448 | GhcMonad.liftIO $ putStrLn "getSummary, extracting the module summary..." 449 | modSum <- getModSummary (mkModuleName targetModuleName) 450 | 451 | -- graph <- GHC.depanal [] False 452 | -- -- graph <- getModuleGraph 453 | -- let graph_names = map (GHC.moduleNameString . GHC.ms_mod_name) graph 454 | -- GhcMonad.liftIO $ print $ "graph_names: " ++ show graph_names 455 | 456 | return (allGhcOpts, modSum) 457 | 458 | -- |Convenience function for converting an 'GHC.ImportDecl' to a 'HaskellModule'. 459 | -- 460 | -- Example: 461 | -- 462 | -- > -- Hiding.hs 463 | -- > module Hiding where 464 | -- > import Data.List hiding (map) 465 | -- > import System.Environment (getArgs) 466 | -- > import qualified Safe 467 | -- 468 | -- then: 469 | -- 470 | -- >>> map toHaskellModule <$> getTextualImports "tests/data/data/Hiding.hs" "Hiding" >>= print 471 | -- [ HaskellModule { modName = "Prelude" 472 | -- , modQualifier = Nothing 473 | -- , modIsImplicit = True 474 | -- , modHiding = [] 475 | -- , modImportedAs = Nothing 476 | -- , modSpecifically = [] 477 | -- } 478 | -- , HaskellModule {modName = "Safe" 479 | -- , modQualifier = Nothing 480 | -- , modIsImplicit = False 481 | -- , modHiding = [] 482 | -- , modImportedAs = Nothing 483 | -- , modSpecifically = [] 484 | -- } 485 | -- , HaskellModule { modName = "System.Environment" 486 | -- , modQualifier = Nothing 487 | -- , modIsImplicit = False 488 | -- , modHiding = [] 489 | -- , modImportedAs = Nothing 490 | -- , modSpecifically = ["getArgs"] 491 | -- } 492 | -- , HaskellModule { modName = "Data.List" 493 | -- , modQualifier = Nothing 494 | -- , modIsImplicit = False 495 | -- , modHiding = ["map"] 496 | -- , modImportedAs = Nothing 497 | -- , modSpecifically = [] 498 | -- } 499 | -- ] 500 | toHaskellModule :: SrcLoc.Located (GHC.ImportDecl GHC.RdrName) -> HaskellModule 501 | toHaskellModule idecl = HaskellModule name qualifier isImplicit hiding importedAs specifically 502 | where idecl' = SrcLoc.unLoc idecl 503 | name = showSDoc tdflags (ppr $ GHC.ideclName idecl') 504 | isImplicit = GHC.ideclImplicit idecl' 505 | qualifier = unpackFS <$> GHC.ideclPkgQual idecl' 506 | hiding = (catMaybes . parseHiding . GHC.ideclHiding) idecl' 507 | importedAs = (showSDoc tdflags . ppr) <$> ideclAs idecl' 508 | specifically = (parseSpecifically . GHC.ideclHiding) idecl' 509 | 510 | --grabNames :: GHC.Located (GHC.IE GHC.RdrName) -> String 511 | --grabNames loc = showSDoc tdflags (ppr names) 512 | -- where names = GHC.ieNames $ SrcLoc.unLoc loc 513 | 514 | grabNames' :: GHC.Located [GHC.LIE GHC.RdrName] -> [String] 515 | grabNames' loc = map (showSDoc tdflags . ppr) names 516 | where names :: [RdrName] 517 | names = map (ieName . SrcLoc.unLoc) $ SrcLoc.unLoc loc 518 | -- FIXME We are throwing away location info by using unLoc each time? 519 | -- Trace these things to see what we are losing. 520 | -- 521 | parseHiding :: Maybe (Bool, Located [LIE RdrName]) -> [Maybe String] 522 | parseHiding Nothing = [Nothing] 523 | 524 | -- If we do 525 | -- 526 | -- import System.Environment ( getArgs ) 527 | -- 528 | -- then we get ["getArgs"] here, but we don't really need it... 529 | parseHiding (Just (False, _)) = [] 530 | 531 | -- Actually hid names, e.g. 532 | -- 533 | -- import Data.List hiding (map) 534 | parseHiding (Just (True, h)) = map Just $ grabNames' h 535 | 536 | parseSpecifically :: Maybe (Bool, Located [LIE RdrName]) -> [String] 537 | parseSpecifically (Just (False, h)) = grabNames' h 538 | parseSpecifically _ = [] 539 | 540 | -- | List of possible modules which have resulted in 541 | -- the name being in the current scope. Using a 542 | -- global reader we get the provenance data and then 543 | -- get the list of import specs. 544 | symbolImportedFrom :: GlobalRdrElt -> [ModuleName] 545 | symbolImportedFrom occNameLookup = map importSpecModule whys 546 | where prov = gre_prov occNameLookup :: Provenance 547 | Imported (whys :: [ImportSpec]) = prov 548 | 549 | -- This definition of separateBy is taken 550 | -- from: http://stackoverflow.com/a/4978733 551 | separateBy :: Eq a => a -> [a] -> [[a]] 552 | separateBy chr = unfoldr sep' where 553 | sep' [] = Nothing 554 | sep' l = Just . fmap (drop 1) . break (==chr) $ l 555 | 556 | -- | Returns True if the 'Symbol' matches the end of the 'QualifiedName'. 557 | -- 558 | -- Example: 559 | -- 560 | -- >>> postfixMatch "bar" "Foo.bar" 561 | -- True 562 | -- >>> postfixMatch "bar" "Foo.baz" 563 | -- False 564 | -- >>> postfixMatch "bar" "bar" 565 | -- True 566 | postfixMatch :: Symbol -> QualifiedName -> Bool 567 | postfixMatch originalSymbol qName = endTerm `isSuffixOf` qName 568 | where endTerm = last $ separateBy '.' originalSymbol 569 | 570 | -- | Get the module part of a qualified name. 571 | -- 572 | -- Example: 573 | -- 574 | -- >>> moduleOfQualifiedName "Foo.bar" 575 | -- Just "Foo" 576 | -- >>> moduleOfQualifiedName "Foo" 577 | -- Nothing 578 | moduleOfQualifiedName :: QualifiedName -> Maybe String 579 | moduleOfQualifiedName qn = if null bits 580 | then Nothing 581 | else Just $ intercalate "." bits 582 | where bits = reverse $ drop 1 $ reverse $ separateBy '.' qn 583 | 584 | -- | Find the possible qualified names for the symbol at line/col in the given Haskell file and module. 585 | -- 586 | -- Example: 587 | -- 588 | -- >>> x <- qualifiedName "tests/data/data/Muddle.hs" "Muddle" 27 5 ["Data.Maybe", "Data.List", "Data.Map", "Safe"] 589 | -- >>> forM_ x print 590 | -- "AbsBinds [] []\n {Exports: [Muddle.h <= h\n <>]\n Exported types: Muddle.h\n :: Data.Map.Base.Map GHC.Base.String GHC.Base.String\n [LclId]\n Binds: h = Data.Map.Base.fromList [(\"x\", \"y\")]}" 591 | -- "h = Data.Map.Base.fromList [(\"x\", \"y\")]" 592 | -- "Data.Map.Base.fromList [(\"x\", \"y\")]" 593 | -- "Data.Map.Base.fromList" 594 | qualifiedName :: String -> Int -> Int -> [String] -> Ghc [String] 595 | qualifiedName targetModuleName lineNr colNr importList = do 596 | setContext (map (IIDecl . simpleImportDecl . mkModuleName) (targetModuleName:importList)) 597 | `gcatch` (\(s :: SourceError) -> do GhcMonad.liftIO $ putStrLn $ "qualifiedName: setContext failed with a SourceError, trying to continue anyway..." ++ show s 598 | setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList) 599 | `gcatch` (\(g :: GhcApiError) -> do GhcMonad.liftIO $ putStrLn $ "qualifiedName: setContext failed with a GhcApiError, trying to continue anyway..." ++ show g 600 | setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList) 601 | `gcatch` (\(se :: SomeException) -> do GhcMonad.liftIO $ putStrLn $ "qualifiedName: setContext failed with a SomeException, trying to continue anyway..." ++ show se 602 | setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList) 603 | 604 | modSummary <- getModSummary $ mkModuleName targetModuleName :: Ghc ModSummary 605 | p <- parseModule modSummary :: Ghc ParsedModule 606 | t <- typecheckModule p :: Ghc TypecheckedModule 607 | 608 | let TypecheckedModule{tm_typechecked_source = tcs} = t 609 | bs = listifySpans tcs (lineNr, colNr) :: [LHsBind Id] 610 | es = listifySpans tcs (lineNr, colNr) :: [LHsExpr Id] 611 | ps = listifySpans tcs (lineNr, colNr) :: [LPat Id] 612 | 613 | let foo x = showSDoc tdflags $ ppr x 614 | bs' = map foo bs 615 | es' = map foo es 616 | ps' = map foo ps 617 | 618 | return $ bs' ++ es' ++ ps' 619 | 620 | -- Like qualifiedName but uses 'reallyAlwaysQualify' to show the fully qualified name, e.g. 621 | -- "containers-0.5.6.2@conta_2C3ZI8RgPO2LBMidXKTvIU:Data.Map.Base.fromList" instead of 622 | -- "Data.Map.Base.fromList". Will probably replace qualifiedName once more testing has 623 | -- been done. If this works we can also remove 'ghcPkgFindModule' which uses a shell 624 | -- call to try to find the package name. 625 | qualifiedName' :: String -> Int -> Int -> String -> [String] -> Ghc [String] 626 | qualifiedName' targetModuleName lineNr colNr symbol importList = do 627 | setContext (map (IIDecl . simpleImportDecl . mkModuleName) (targetModuleName:importList)) 628 | `gcatch` (\(s :: SourceError) -> do GhcMonad.liftIO $ putStrLn $ "qualifiedName: setContext failed with a SourceError, trying to continue anyway..." ++ show s 629 | setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList) 630 | `gcatch` (\(g :: GhcApiError) -> do GhcMonad.liftIO $ putStrLn $ "qualifiedName: setContext failed with a GhcApiError, trying to continue anyway..." ++ show g 631 | setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList) 632 | `gcatch` (\(se :: SomeException) -> do GhcMonad.liftIO $ putStrLn $ "qualifiedName: setContext failed with a SomeException, trying to continue anyway..." ++ show se 633 | setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList) 634 | 635 | modSummary <- getModSummary $ mkModuleName targetModuleName :: Ghc ModSummary 636 | p <- parseModule modSummary :: Ghc ParsedModule 637 | t <- typecheckModule p :: Ghc TypecheckedModule 638 | 639 | let TypecheckedModule{tm_typechecked_source = tcs} = t 640 | bs = listifySpans tcs (lineNr, colNr) :: [LHsBind Id] 641 | es = listifySpans tcs (lineNr, colNr) :: [LHsExpr Id] 642 | ps = listifySpans tcs (lineNr, colNr) :: [LPat Id] 643 | -- ls0 = listifySpans tcs (lineNr, colNr) :: [LHsBindLR Id Id] 644 | -- ls1 = listifySpans tcs (lineNr, colNr) :: [LIPBind Id] 645 | -- ls2 = listifySpans tcs (lineNr, colNr) :: [LPat Id] 646 | -- ls3 = listifySpans tcs (lineNr, colNr) :: [LHsDecl Id] 647 | -- ls4 = listifySpans tcs (lineNr, colNr) :: [LHsExpr Id] 648 | -- ls5 = listifySpans tcs (lineNr, colNr) :: [LHsTupArg Id] 649 | -- ls6 = listifySpans tcs (lineNr, colNr) :: [LHsCmd Id] 650 | -- ls7 = listifySpans tcs (lineNr, colNr) :: [LHsCmdTop Id] 651 | 652 | let bs' = map (showSDocForUser tdflags reallyAlwaysQualify . ppr) bs 653 | es' = map (showSDocForUser tdflags reallyAlwaysQualify . ppr) es 654 | ps' = map (showSDocForUser tdflags reallyAlwaysQualify . ppr) ps 655 | 656 | return $ filter (postfixMatch symbol) $ concatMap words $ bs' ++ es' ++ ps' 657 | 658 | -- Read everything else available on a handle, and return the empty 659 | -- string if we have hit EOF. 660 | readRestOfHandle :: Handle -> IO String 661 | readRestOfHandle h = do 662 | ineof <- hIsEOF h 663 | if ineof 664 | then return "" 665 | else hGetContents h 666 | 667 | optsForGhcPkg :: [String] -> [String] 668 | optsForGhcPkg [] = [] 669 | optsForGhcPkg ("-no-user-package-db":rest) = "--no-user-package-db" : optsForGhcPkg rest 670 | optsForGhcPkg ("-package-db":pd:rest) = ("--package-db" ++ "=" ++ pd) : optsForGhcPkg rest 671 | optsForGhcPkg ("-package-conf":pc:rest) = ("--package-conf" ++ "=" ++ pc) : optsForGhcPkg rest 672 | optsForGhcPkg ("-no-user-package-conf":rest) = "--no-user-package-conf" : optsForGhcPkg rest 673 | optsForGhcPkg (_:rest) = optsForGhcPkg rest 674 | 675 | ghcPkgFindModule :: [String] -> GhcPkgOptions -> String -> IO (Maybe String) 676 | ghcPkgFindModule allGhcOptions (GhcPkgOptions extraGHCPkgOpts) m = 677 | shortcut [ stackGhcPkgFindModule m 678 | , hcPkgFindModule m 679 | , _ghcPkgFindModule allGhcOptions (GhcPkgOptions extraGHCPkgOpts) m 680 | ] 681 | 682 | -- | Call @ghc-pkg find-module@ to determine that package that provides a module, e.g. @Prelude@ is defined 683 | -- in @base-4.6.0.1@. 684 | _ghcPkgFindModule :: [String] -> GhcPkgOptions -> String -> IO (Maybe String) 685 | _ghcPkgFindModule allGhcOptions (GhcPkgOptions extraGHCPkgOpts) m = do 686 | let opts = ["find-module", m, "--simple-output"] ++ ["--global", "--user"] ++ optsForGhcPkg allGhcOptions ++ extraGHCPkgOpts 687 | putStrLn $ "ghc-pkg " ++ show opts 688 | 689 | x <- executeFallibly' "ghc-pkg" opts 690 | 691 | case x of 692 | Nothing -> return Nothing 693 | Just (output, err) -> do putStrLn $ "_ghcPkgFindModule stdout: " ++ show output 694 | putStrLn $ "_ghcPkgFindModule stderr: " ++ show err 695 | return $ join $ (Safe.lastMay . words) <$> (Safe.lastMay . lines) output 696 | 697 | -- | Call @cabal sandbox hc-pkg@ to find the package the provides a module. 698 | hcPkgFindModule :: String -> IO (Maybe String) 699 | hcPkgFindModule m = do 700 | let opts = ["sandbox", "hc-pkg", "find-module", m, "--", "--simple-output"] 701 | 702 | x <- executeFallibly' "cabal" opts 703 | 704 | case x of 705 | Nothing -> return Nothing 706 | Just (output, err) -> do putStrLn $ "hcPkgFindModule stdout: " ++ show output 707 | putStrLn $ "hcPkgFindModule stderr: " ++ show err 708 | return $ join $ (Safe.lastMay . words) <$> (Safe.lastMay . lines) output 709 | 710 | -- | Call @stack exec ghc-pkg@ to find the package the provides a module. 711 | stackGhcPkgFindModule :: String -> IO (Maybe String) 712 | stackGhcPkgFindModule m = do 713 | let opts = ["exec", "ghc-pkg", "find-module", m, "--", "--simple-output"] 714 | 715 | x <- executeFallibly' "stack" opts 716 | 717 | case x of 718 | Nothing -> return Nothing 719 | Just (output, err) -> do putStrLn $ "stackGhcPkgFindModule stdout: " ++ show output 720 | putStrLn $ "stackGhcPkgFindModule stderr: " ++ show err 721 | return $ join $ (Safe.lastMay . words) <$> (Safe.lastMay . lines) output 722 | 723 | ghcPkgHaddockUrl :: [String] -> GhcPkgOptions -> String -> IO (Maybe String) 724 | ghcPkgHaddockUrl allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p = 725 | shortcut [ stackPkgHaddockUrl p 726 | , sandboxPkgHaddockUrl p 727 | , _ghcPkgHaddockUrl allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p 728 | ] 729 | 730 | -- | Call @ghc-pkg field@ to get the @haddock-html@ field for a package. 731 | _ghcPkgHaddockUrl :: [String] -> GhcPkgOptions -> String -> IO (Maybe String) 732 | _ghcPkgHaddockUrl allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p = do 733 | let opts = ["field", p, "haddock-html"] ++ ["--global", "--user"] ++ optsForGhcPkg allGhcOptions ++ extraGHCPkgOpts 734 | putStrLn $ "ghc-pkg "++ show opts 735 | 736 | x <- executeFallibly' "ghc-pkg" opts 737 | 738 | case x of 739 | Nothing -> return Nothing 740 | Just (hout, _) -> return $ Safe.lastMay $ words $ reverse . dropWhile (== '\n') . reverse $ hout 741 | 742 | readHaddockHtmlOutput :: FilePath -> [String] -> IO (Maybe String) 743 | readHaddockHtmlOutput cmd opts = do 744 | x <- executeFallibly' cmd opts 745 | 746 | case x of 747 | Nothing -> return Nothing 748 | Just (hout, _) -> do let line = reverse . dropWhile (== '\n') . reverse $ hout 749 | print ("line", line) 750 | 751 | if "haddock-html:" `isInfixOf` line 752 | then do print ("line2", Safe.lastMay $ words line) 753 | return $ Safe.lastMay $ words line 754 | else return Nothing 755 | 756 | -- | Call cabal sandbox hc-pkg to find the haddock url. 757 | sandboxPkgHaddockUrl :: String -> IO (Maybe String) 758 | sandboxPkgHaddockUrl p = do 759 | let opts = ["sandbox", "hc-pkg", "field", p, "haddock-html"] 760 | putStrLn $ "cabal sandbox hc-pkg field " ++ p ++ " haddock-html" 761 | readHaddockHtmlOutput "cabal" opts 762 | 763 | -- | Call cabal stack to find the haddock url. 764 | stackPkgHaddockUrl :: String -> IO (Maybe String) 765 | stackPkgHaddockUrl p = do 766 | let opts = ["exec", "ghc-pkg", "field", p, "haddock-html"] 767 | putStrLn $ "stack exec hc-pkg field " ++ p ++ " haddock-html" 768 | readHaddockHtmlOutput "stack" opts 769 | 770 | ghcPkgHaddockInterface :: [String] -> GhcPkgOptions -> String -> IO (Maybe String) 771 | ghcPkgHaddockInterface allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p = 772 | shortcut [ stackGhcPkgHaddockInterface 773 | , cabalPkgHaddockInterface 774 | , _ghcPkgHaddockInterface 775 | ] 776 | 777 | where 778 | 779 | _ghcPkgHaddockInterface :: IO (Maybe String) 780 | _ghcPkgHaddockInterface = do 781 | let opts = ["field", p, "haddock-interfaces"] ++ ["--global", "--user"] ++ optsForGhcPkg allGhcOptions ++ extraGHCPkgOpts 782 | putStrLn $ "ghc-pkg "++ show opts 783 | 784 | x <- executeFallibly' "ghc-pkg" opts 785 | 786 | return $ case x of 787 | Nothing -> Nothing 788 | Just (hout, _) -> Safe.lastMay $ words $ reverse . dropWhile (== '\n') . reverse $ hout 789 | 790 | -- | Call cabal sandbox hc-pkg to find the haddock Interfaces. 791 | cabalPkgHaddockInterface :: IO (Maybe String) 792 | cabalPkgHaddockInterface = do 793 | let opts = ["sandbox", "hc-pkg", "field", p, "haddock-interfaces"] 794 | putStrLn $ "cabal sandbox hc-pkg field " ++ p ++ " haddock-interfaces" 795 | 796 | x <- executeFallibly' "cabal" opts 797 | 798 | case x of 799 | Nothing -> return Nothing 800 | Just (hout, _) -> do let line = reverse . dropWhile (== '\n') . reverse $ hout 801 | print ("ZZZZZZZZZZZZZ", line) 802 | 803 | return $ if "haddock-interfaces" `isInfixOf` line 804 | then Safe.lastMay $ words line 805 | else Nothing 806 | 807 | -- | Call stack to find the haddock Interfaces. 808 | stackGhcPkgHaddockInterface :: IO (Maybe String) 809 | stackGhcPkgHaddockInterface = do 810 | let opts = ["exec", "ghc-pkg", "field", p, "haddock-interfaces"] 811 | putStrLn $ "stack exec ghc-pkg field " ++ p ++ " haddock-interfaces" 812 | 813 | x <- executeFallibly' "stack" opts 814 | 815 | case x of 816 | Nothing -> return Nothing 817 | Just (hout, _) -> do let line = reverse . dropWhile (== '\n') . reverse $ hout 818 | print ("UUUUUUUUUUUUU", line, opts) 819 | 820 | return $ if "haddock-interfaces" `isInfixOf` line 821 | then Safe.lastMay $ words line 822 | else Nothing 823 | 824 | getVisibleExports :: [String] -> GhcPkgOptions -> String -> Ghc (Maybe (M.Map String [String])) 825 | getVisibleExports allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p = do 826 | haddockInterfaceFile <- GhcMonad.liftIO $ ghcPkgHaddockInterface allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p 827 | join <$> traverse getVisibleExports' haddockInterfaceFile 828 | 829 | where 830 | 831 | getVisibleExports' :: FilePath -> Ghc (Maybe (M.Map String [String])) 832 | getVisibleExports' ifile = do 833 | iface <- Haddock.readInterfaceFile Haddock.nameCacheFromGhc ifile 834 | 835 | case iface of 836 | Left _ -> GhcMonad.liftIO $ do putStrLn $ "Failed to read the Haddock interface file: " ++ ifile 837 | putStrLn "You probably installed packages without using the '--enable-documentation' flag." 838 | putStrLn "" 839 | putStrLn "Try something like:\n\n\tcabal install --enable-documentation p" 840 | error "No haddock interfaces file, giving up." 841 | Right iface' -> do let m = map (\ii -> (Haddock.instMod ii, Haddock.instVisibleExports ii)) $ Haddock.ifInstalledIfaces iface' :: [(Module, [Name])] 842 | m' = map (\(mname, names) -> (showSDoc tdflags $ ppr mname, map (showSDoc tdflags . ppr) names)) m :: [(String, [String])] 843 | return $ Just $ M.fromList m' 844 | 845 | 846 | 847 | -- | Convert a module name string, e.g. @Data.List@ to @Data-List.html@. 848 | moduleNameToHtmlFile :: String -> String 849 | moduleNameToHtmlFile m = map f m ++ ".html" 850 | where f :: Char -> Char 851 | f '.' = '-' 852 | f c = c 853 | 854 | {- 855 | I don't want to use this any more. The refiner works so much better with 856 | the local haddock interfaces file... 857 | 858 | -- | Convert a file path to a Hackage HTML file to its equivalent on @https://hackage.haskell.org@. 859 | toHackageUrl :: FilePath -> String -> String -> String 860 | toHackageUrl filepath package modulename = "https://hackage.haskell.org/package/" ++ package ++ "/" ++ "docs/" ++ modulename'' 861 | where filepath' = map repl filepath 862 | modulename' = head $ separateBy '.' $ head $ separateBy '-' modulename 863 | modulename'' = drop (fromJust $ substringP modulename' filepath') filepath' 864 | 865 | -- On Windows we get backslashes in the file path; convert 866 | -- to forward slashes for the URL. 867 | repl :: Char -> Char 868 | repl '\\' = '/' 869 | repl c = c 870 | 871 | -- Adapted from http://www.haskell.org/pipermail/haskell-cafe/2010-June/078702.html 872 | substringP :: String -> String -> Maybe Int 873 | substringP _ [] = Nothing 874 | substringP sub str = if sub `isPrefixOf` str then Just 0 else (+1) <$> substringP sub (tail str) 875 | 876 | -- | Convert our match to a URL, either @file://@ if the file exists, or to @hackage.org@ otherwise. 877 | matchToUrl :: (Maybe String, Maybe String, Maybe String, Maybe String) -> IO String 878 | matchToUrl (importedFrom, haddock, foundModule, base) = do 879 | when (isNothing importedFrom) $ error "importedFrom is Nothing :(" 880 | when (isNothing haddock) $ error "haddock is Nothing :(" 881 | when (isNothing foundModule) $ error "foundModule is Nothing :(" 882 | when (isNothing base) $ error "base is Nothing :(" 883 | 884 | let importedFrom' = fromJust importedFrom 885 | haddock' = fromJust haddock 886 | foundModule' = fromJust foundModule 887 | base' = fromJust base 888 | 889 | f = haddock' base' 890 | 891 | e <- doesFileExist f 892 | 893 | if e then return $ "file://" ++ f 894 | else do putStrLn $ "f: " ++ show f 895 | putStrLn $ "foundModule2: " ++ show foundModule' 896 | putStrLn $ "calling toHackageUrl with params: " ++ show (f, foundModule', importedFrom') 897 | return $ toHackageUrl f foundModule' importedFrom' 898 | -} 899 | 900 | -- | Convert our match to a URL of the form @file://@ so that we can open it in a web browser. 901 | matchToUrl :: (Maybe String, Maybe String, Maybe String, Maybe String) -> IO String 902 | matchToUrl (importedFrom, haddock, foundModule, base) = do 903 | when (isNothing importedFrom) $ error "importedFrom is Nothing :(" 904 | when (isNothing haddock) $ error "haddock is Nothing :(" 905 | when (isNothing foundModule) $ error "foundModule is Nothing :(" 906 | when (isNothing base) $ error "base is Nothing :(" 907 | 908 | let -- importedFrom' = fromJust importedFrom 909 | haddock' = fromJust haddock 910 | -- foundModule' = fromJust foundModule 911 | base' = fromJust base 912 | 913 | f = haddock' base' 914 | 915 | e <- doesFileExist f 916 | 917 | if e then return $ "file://" ++ f 918 | else do putStrLn "Please reinstall packages using the flag '--enable-documentation' for 'cabal install.\n" 919 | error $ "Could not find " ++ f 920 | 921 | filterMatchingQualifiedImport :: String -> [HaskellModule] -> [HaskellModule] 922 | filterMatchingQualifiedImport symbol hmodules = 923 | case moduleOfQualifiedName symbol of Nothing -> [] 924 | asBit@(Just _) -> filter (\z -> asBit == modImportedAs z) hmodules 925 | 926 | -- Copied from ghc-mod-5.5.0.0 927 | findCradleNoLog :: forall m. (IOish m, GmOut m) => m Cradle 928 | findCradleNoLog = fst <$> (runJournalT findCradle :: m (Cradle, GhcModLog)) 929 | 930 | getModuleExports :: GhcOptions 931 | -> GhcPkgOptions 932 | -> HaskellModule 933 | -> Ghc (Maybe ([String], String)) 934 | getModuleExports (GhcOptions gopts) ghcpkgOpts m = do 935 | minfo <- (findModule (mkModuleName $ modName m) Nothing >>= getModuleInfo) 936 | `gcatch` (\(_ :: SourceError) -> return Nothing) 937 | 938 | p <- GhcMonad.liftIO $ ghcPkgFindModule gopts ghcpkgOpts (modName m) 939 | 940 | case (minfo, p) of 941 | (Nothing, _) -> return Nothing 942 | (_, Nothing) -> return Nothing 943 | (Just minfo', Just p') -> return $ Just (map (showSDocForUser tdflags reallyAlwaysQualify . ppr) $ modInfoExports minfo', p') 944 | 945 | -- type UnqualifiedName = String -- ^ e.g. "Just" 946 | type FullyQualifiedName = String -- ^ e.g. e.g. "base-4.8.2.0:Data.Foldable.length" 947 | type StrModuleName = String -- ^ e.g. "Data.List" 948 | 949 | data MySymbol = MySymbolSysQualified String -- ^ e.g. "base-4.8.2.0:Data.Foldable.length" 950 | | MySymbolUserQualified String -- ^ e.g. "DL.length" with an import earlier like "import qualified Data.List as DL" 951 | deriving Show 952 | 953 | data ModuleExports = ModuleExports 954 | { mName :: StrModuleName -- ^ e.g. "Data.List" 955 | , mPackageName :: String -- ^ e.g. "snap-0.14.0.6" 956 | , mInfo :: HaskellModule -- ^ Our parse of the module import, with info like "hiding (map)". 957 | , qualifiedExports :: [FullyQualifiedName] -- ^ e.g. [ "base-4.8.2.0:GHC.Base.++" 958 | -- , "base-4.8.2.0:GHC.List.filter" 959 | -- , "base-4.8.2.0:GHC.List.zip" 960 | -- , ... 961 | -- ] 962 | } 963 | deriving Show 964 | 965 | pprModuleExports :: ModuleExports -> String 966 | pprModuleExports me = mName me ++ "\n" ++ show (mInfo me) ++ "\n" ++ unwords (map show $ qualifiedExports me) 967 | 968 | refineAs :: MySymbol -> [ModuleExports] -> [ModuleExports] 969 | 970 | -- User qualified the symbol, so we can filter out anything that doesn't have a matching 'modImportedAs'. 971 | refineAs (MySymbolUserQualified userQualSym) exports = filter f exports 972 | where 973 | f export = case modas of 974 | Nothing -> False 975 | Just modas' -> modas' == userQualAs 976 | where modas = modImportedAs $ mInfo export :: Maybe String 977 | 978 | -- e.g. "DL" 979 | userQualAs = fromMaybe (error $ "Expected a qualified name like 'DL.length' but got: " ++ userQualSym) 980 | (moduleOfQualifiedName userQualSym) 981 | 982 | -- User didn't qualify the symbol, so we have the full system qualified thing, so do nothing here. 983 | refineAs (MySymbolSysQualified _) exports = exports 984 | 985 | refineRemoveHiding :: [ModuleExports] -> [ModuleExports] 986 | refineRemoveHiding exports = map (\e -> e { qualifiedExports = f e }) exports 987 | where 988 | f export = filter (`notElem` hiding') thisExports 989 | where hiding = modHiding $ mInfo export :: [String] -- Things that this module hides. 990 | hiding' = map (qualifyName thisExports) hiding :: [String] -- Qualified version of hiding. 991 | thisExports = qualifiedExports export -- Things that this module exports. 992 | 993 | qualifyName :: [QualifiedName] -> Symbol -> QualifiedName 994 | qualifyName qualifiedNames name 995 | -- = case filter (postfixMatch name) qualifiedNames of 996 | = case nub (filter (name `f`) qualifiedNames) of 997 | [match] -> match 998 | m -> error $ "Could not qualify " ++ name ++ " from these exports: " ++ show qualifiedNames ++ "\n matches: " ++ show m 999 | 1000 | -- Time for some stringly typed rubbish. The previous test used 1001 | -- postfixMatch but this failed on an import that had "hiding (lines, unlines)" since 1002 | -- both lines and unlines matched. Prepending a dot doesn't work due to things like ".=" from 1003 | -- Control.Lens. So we manually check that the suffix matches, that the next symbol is a dot, 1004 | -- and then an alpha character, which hopefully is the end of a module name. Such a mess. 1005 | where f n qn = if length qn - length n - 2 >= 0 1006 | then n `isSuffixOf` qn && isAlpha (qn !! (length qn - length n - 2)) && (qn !! (length qn - length n - 1)) == '.' 1007 | else error $ "Internal error: trying to check if \"" ++ n ++ "\" is a match for \"" ++ qn ++ "\"" 1008 | 1009 | refineExportsIt :: String -> [ModuleExports] -> [ModuleExports] 1010 | refineExportsIt symbol exports = map (\e -> e { qualifiedExports = f symbol e }) exports 1011 | where 1012 | -- f symbol export = filter (symbol ==) thisExports 1013 | f sym export = filter (postfixMatch sym) thisExports 1014 | where thisExports = qualifiedExports export -- Things that this module exports. 1015 | 1016 | refineLeadingDot :: MySymbol -> [ModuleExports] -> [ModuleExports] 1017 | refineLeadingDot (MySymbolUserQualified _) exports = exports 1018 | refineLeadingDot (MySymbolSysQualified symb) exports = map (\e -> e { qualifiedExports = f leadingDot e }) exports 1019 | where 1020 | leadingDot :: String 1021 | leadingDot = '.' : last (separateBy '.' symb) 1022 | 1023 | -- f symbol export = filter (symbol ==) thisExports 1024 | f symbol export = filter (symbol `isSuffixOf`) thisExports 1025 | where thisExports = qualifiedExports export -- Things that this module exports. 1026 | 1027 | refineVisibleExports :: [String] -> GhcPkgOptions -> [ModuleExports] -> Ghc [ModuleExports] 1028 | refineVisibleExports allGhcOpts ghcpkgOptions exports = mapM f exports 1029 | where 1030 | f :: ModuleExports -> Ghc ModuleExports 1031 | f mexports = do 1032 | let pname = mPackageName mexports -- e.g. "base-4.8.2.0" 1033 | thisModuleName = mName mexports -- e.g. "Prelude" 1034 | qexports = qualifiedExports mexports -- e.g. ["base-4.8.2.0:GHC.Base.Just", ...] 1035 | visibleExportsMap <- getVisibleExports allGhcOpts ghcpkgOptions pname 1036 | GhcMonad.liftIO $ print visibleExportsMap 1037 | 1038 | let thisModVisibleExports = fromMaybe 1039 | (error $ "Could not get visible exports of " ++ pname) 1040 | (join $ traverse (M.lookup thisModuleName) visibleExportsMap) 1041 | 1042 | let qexports' = filter (hasPostfixMatch thisModVisibleExports) qexports 1043 | 1044 | GhcMonad.liftIO $ print (qexports, qexports') 1045 | 1046 | return $ mexports { qualifiedExports = qexports' } 1047 | 1048 | -- hasPostfixMatch "base-4.8.2.0:GHC.Base.Just" ["Just", "True", ...] -> True 1049 | hasPostfixMatch :: [String] -> String -> Bool 1050 | hasPostfixMatch xs s = last (separateBy '.' s) `elem` xs 1051 | 1052 | -- | The last thing with a single export must be the match? Iffy. 1053 | getLastMatch :: [ModuleExports] -> Maybe ModuleExports 1054 | getLastMatch exports = Safe.lastMay $ filter f exports 1055 | where 1056 | f me = length (qualifiedExports me) == 1 1057 | 1058 | -- | Attempt to guess the Haddock url, either a local file path or url to @hackage.haskell.org@ 1059 | -- for the symbol in the given file, module, at the specified line and column location. 1060 | -- 1061 | -- Example: 1062 | -- 1063 | -- >>> guessHaddockUrl "tests/data/data/Muddle.hs" "Muddle" "Maybe" 11 11 1064 | -- (lots of output) 1065 | -- SUCCESS: file:///home/carlo/opt/ghc-7.6.3_build/share/doc/ghc/html/libraries/base-4.6.0.1/Data-Maybe.html 1066 | 1067 | guessHaddockUrl :: FilePath -> String -> Symbol -> Int -> Int -> GhcOptions -> GhcPkgOptions -> IO (Either String String) 1068 | guessHaddockUrl _targetFile targetModule symbol lineNr colNr (GhcOptions ghcOpts0) ghcpkgOptions = do 1069 | cradle <- runGmOutT GhcModTypes.defaultOptions findCradleNoLog 1070 | let currentDir = cradleCurrentDir cradle 1071 | workDir = cradleRootDir cradle 1072 | setCurrentDirectory workDir 1073 | 1074 | let targetFile = currentDir _targetFile 1075 | 1076 | putStrLn $ "currentDir: " ++ currentDir 1077 | putStrLn $ "workDir: " ++ workDir 1078 | 1079 | putStrLn $ "targetFile: " ++ targetFile 1080 | putStrLn $ "targetModule: " ++ targetModule 1081 | putStrLn $ "symbol: " ++ show symbol 1082 | putStrLn $ "line nr: " ++ show lineNr 1083 | putStrLn $ "col nr: " ++ show colNr 1084 | 1085 | putStrLn $ "ghcOpts0: " ++ show ghcOpts0 1086 | putStrLn $ "ghcpkgOptions: " ++ show ghcpkgOptions 1087 | 1088 | runGhc (Just libdir) $ do 1089 | (allGhcOpts, textualImports) <- getTextualImports (GhcOptions ghcOpts0) targetFile targetModule 1090 | 1091 | let haskellModules0 = map toHaskellModule textualImports 1092 | haskellModuleNames0 = map modName haskellModules0 1093 | GhcMonad.liftIO $ putStrLn $ "haskellModuleNames0: " ++ show haskellModuleNames0 1094 | GhcMonad.liftIO $ putStrLn $ "haskellModuleNames0 (full detail): " ++ show haskellModules0 1095 | 1096 | -- If symbol is something like DM.lookup, then restrict haskellModuleNames to the 1097 | -- one that has modImportedAs == Just "DM". 1098 | let filterThings = filterMatchingQualifiedImport symbol haskellModules0 1099 | -- let haskellModules = if null filterThings then haskellModules0 else filterThings 1100 | let haskellModuleNames = if null filterThings then map modName haskellModules0 else map modName filterThings 1101 | 1102 | qnames <- filter (not . (' ' `elem`)) <$> qualifiedName targetModule lineNr colNr haskellModuleNames 1103 | GhcMonad.liftIO $ putStrLn $ "qualified names: " ++ show qnames 1104 | 1105 | qnames_with_qualified_printing <- filter (not . (' ' `elem`)) <$> qualifiedName' targetModule lineNr colNr symbol haskellModuleNames :: Ghc [String] 1106 | GhcMonad.liftIO $ putStrLn $ "qualified names with qualified printing: " ++ show qnames_with_qualified_printing 1107 | 1108 | let parsedPackagesAndQualNames :: [Either TP.ParseError (String, String)] 1109 | parsedPackagesAndQualNames = map (TP.parse parsePackageAndQualName "") qnames_with_qualified_printing 1110 | 1111 | GhcMonad.liftIO $ putStrLn $ "qqqqqq1: " ++ show parsedPackagesAndQualNames 1112 | 1113 | let symbolToUse :: String 1114 | symbolToUse = case (qnames_with_qualified_printing, qnames) of 1115 | (qq:_, _) -> qq -- We got a qualified name, with qualified printing. Qualified! 1116 | ([], qn:_) -> qn -- No qualified names (oh dear) so fall back to qnames list. 1117 | ([], []) -> error "Lists 'qnames' and 'qnames_with_qualified_printing' are both empty." 1118 | 1119 | GhcMonad.liftIO $ print ("symbolToUse", symbolToUse) 1120 | 1121 | -- Possible extra modules... 1122 | let extraModules :: [HaskellModule] 1123 | extraModules = case Safe.headMay parsedPackagesAndQualNames of 1124 | Just (Right (_, x)) -> case moduleOfQualifiedName x of Just x' -> [ HaskellModule { modName = x' 1125 | , modQualifier = Nothing 1126 | , modIsImplicit = False 1127 | , modHiding = [] 1128 | , modImportedAs = Nothing 1129 | , modSpecifically = [] 1130 | } 1131 | ] 1132 | Nothing -> [] 1133 | _ -> [] 1134 | 1135 | GhcMonad.liftIO $ print extraModules 1136 | 1137 | -- Try to use the qnames_with_qualified_printing case, which has something like "base-4.8.2.0:GHC.Base.map", 1138 | -- which will be more accurate to filter on. 1139 | 1140 | exports <- mapM (getModuleExports (GhcOptions ghcOpts0) ghcpkgOptions) (haskellModules0 ++ extraModules) 1141 | 1142 | -- Sometimes the modules in extraModules might be hidden or weird ones like GHC.Base that we can't 1143 | -- load, so filter out the successfully loaded ones. 1144 | let successes :: [(HaskellModule, Maybe ([String], String))] 1145 | successes = filter (isJust . snd) (zip (haskellModules0 ++ extraModules) exports) 1146 | 1147 | bubble :: (HaskellModule, Maybe ([FullyQualifiedName], String)) -> Maybe (HaskellModule, ([FullyQualifiedName], String)) 1148 | bubble (h, Just x) = Just (h, x) 1149 | bubble (_, Nothing) = Nothing 1150 | 1151 | successes' :: [(HaskellModule, ([String], String))] 1152 | successes' = mapMaybe bubble successes 1153 | 1154 | upToNow = map (\(m, (e, p)) -> ModuleExports 1155 | { mName = modName m 1156 | , mPackageName = p 1157 | , mInfo = m 1158 | , qualifiedExports = e 1159 | }) successes' 1160 | 1161 | GhcMonad.liftIO $ forM_ upToNow $ \x -> putStrLn $ pprModuleExports x 1162 | 1163 | -- Get all "as" imports. 1164 | let asImports :: [String] 1165 | asImports = mapMaybe (modImportedAs . mInfo) upToNow 1166 | 1167 | -- Can a user do "import xxx as Foo.Bar"??? Check this. 1168 | 1169 | let mySymbol = case moduleOfQualifiedName symbol of 1170 | Nothing -> MySymbolSysQualified symbolToUse 1171 | Just x -> if x `elem` asImports 1172 | then MySymbolUserQualified symbol 1173 | else MySymbolSysQualified symbolToUse 1174 | 1175 | GhcMonad.liftIO $ print mySymbol 1176 | 1177 | let upToNow0 = refineAs mySymbol upToNow 1178 | GhcMonad.liftIO $ putStrLn "upToNow0" 1179 | GhcMonad.liftIO $ forM_ upToNow0 $ \x -> putStrLn $ pprModuleExports x 1180 | 1181 | let upToNow1 = refineRemoveHiding upToNow0 1182 | GhcMonad.liftIO $ putStrLn "upToNow1" 1183 | GhcMonad.liftIO $ forM_ upToNow1 $ \x -> putStrLn $ pprModuleExports x 1184 | 1185 | let upToNow2 = refineExportsIt symbolToUse upToNow1 1186 | GhcMonad.liftIO $ putStrLn "upToNow2" 1187 | GhcMonad.liftIO $ forM_ upToNow2 $ \x -> putStrLn $ pprModuleExports x 1188 | 1189 | let upToNow3 = refineLeadingDot mySymbol upToNow2 1190 | GhcMonad.liftIO $ putStrLn "upToNow3" 1191 | GhcMonad.liftIO $ forM_ upToNow3 $ \x -> putStrLn $ pprModuleExports x 1192 | 1193 | upToNow4 <- refineVisibleExports allGhcOpts ghcpkgOptions upToNow3 1194 | GhcMonad.liftIO $ putStrLn "upToNow4" 1195 | GhcMonad.liftIO $ forM_ upToNow4 $ \x -> putStrLn $ pprModuleExports x 1196 | 1197 | let lastMatch3 = getLastMatch upToNow3 1198 | lastMatch4 = getLastMatch upToNow4 1199 | lastMatch = Safe.headMay $ catMaybes [lastMatch4, lastMatch3] 1200 | 1201 | GhcMonad.liftIO $ print $ "last match: " ++ show lastMatch 1202 | 1203 | -- "last match: Just (ModuleExports {mName = \"Control.Monad\", mInfo = HaskellModule {modName = \"Control.Monad\", modQualifier = Nothing, modIsImplicit = False, modHiding = [], modImportedAs = Nothing, modSpecifically = [\"forM_\",\"liftM\",\"filterM\",\"when\",\"unless\"]}, qualifiedExports = [\"base-4.8.2.0:GHC.Base.when\"]})" 1204 | 1205 | let matchedModule :: String 1206 | matchedModule = case mName <$> lastMatch of 1207 | Just modn -> modn 1208 | _ -> error $ "No nice match in lastMatch for module: " ++ show lastMatch 1209 | 1210 | let matchedPackageName :: String 1211 | matchedPackageName = case mPackageName <$> lastMatch of 1212 | Just p -> p 1213 | _ -> error $ "No nice match in lastMatch for package name: " ++ show lastMatch 1214 | 1215 | haddock <- GhcMonad.liftIO $ (maybe (return Nothing) (ghcPkgHaddockUrl allGhcOpts ghcpkgOptions) . Just) matchedPackageName 1216 | 1217 | GhcMonad.liftIO $ putStrLn $ "at the end now: " ++ show (matchedModule, moduleNameToHtmlFile matchedModule, matchedPackageName, haddock) 1218 | 1219 | url <- GhcMonad.liftIO $ matchToUrl (Just matchedModule, haddock, Just matchedModule, Just $ moduleNameToHtmlFile matchedModule) 1220 | 1221 | return $ Right url 1222 | 1223 | -- | Top level function; use this one from src/Main.hs. 1224 | haddockUrl :: Options -> FilePath -> String -> String -> Int -> Int -> IO String 1225 | haddockUrl opt file modstr symbol lineNr colNr = do 1226 | 1227 | let ghcopts = GhcOptions $ ghcOpts opt 1228 | let ghcpkgopts = GhcPkgOptions $ ghcPkgOpts opt 1229 | 1230 | res <- guessHaddockUrl file modstr symbol lineNr colNr ghcopts ghcpkgopts 1231 | print ("res", show res) 1232 | 1233 | case res of Right x -> return $ "SUCCESS: " ++ x ++ "\n" 1234 | Left err -> return $ "FAIL: " ++ show err ++ "\n" 1235 | -------------------------------------------------------------------------------- /Language/Haskell/GhcImportedFrom/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | -- Adapted from ghc-mod/Language/Haskell/GhcMod/Types.hs 4 | 5 | module Language.Haskell.GhcImportedFrom.Types where 6 | 7 | -- FIXME We don't support LineSeparator; might be handy for 8 | -- Windows (?) with CRLF encoding? 9 | newtype LineSeparator = LineSeparator String deriving (Show) 10 | 11 | data Options = Options { 12 | ghcOpts :: [String] 13 | , ghcPkgOpts :: [String] 14 | , lineSeparator :: LineSeparator 15 | } deriving (Show) 16 | 17 | defaultOptions :: Options 18 | defaultOptions = Options { 19 | ghcOpts = [] 20 | , ghcPkgOpts = [] 21 | , lineSeparator = LineSeparator "\0" 22 | } 23 | -------------------------------------------------------------------------------- /Language/Haskell/GhcImportedFrom/UtilsFromGhcMod.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types, OverloadedStrings, CPP #-} 2 | 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : UtilsFromGhcMod 7 | -- Copyright : Carlo Hamalainen 2013, 2014 8 | -- License : BSD3 9 | -- 10 | -- Maintainer : carlo@carlo-hamalainen.net 11 | -- Stability : experimental 12 | -- Portability : portable 13 | -- 14 | -- The ghc-mod project has some very useful functions that are not 15 | -- exported, so here I've pulled out the few that I need. Credit for 16 | -- the code in this file is due to Kazu Yamamoto . 17 | -- 18 | -- * 19 | -- 20 | -- * 21 | -- 22 | -- Hopefully this is ok since ghc-mod and this project are both licensed BSD3. 23 | -- If this package ever stabilises I may send a pull request to ghc-mod asking 24 | -- for some of these functions to be exported, perhaps in Language.Haskell.GhcMod.Internal. 25 | 26 | module Language.Haskell.GhcImportedFrom.UtilsFromGhcMod where 27 | 28 | import Data.Generics hiding (typeOf) 29 | import GHC 30 | import GHC.SYB.Utils 31 | 32 | -- ghcmod/Language/Haskell/GhcMod/Info.hs 33 | listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a] 34 | listifySpans tcs lc = listifyStaged TypeChecker p tcs 35 | where 36 | p (L spn _) = isGoodSrcSpan spn && spn `spans` lc 37 | 38 | -- ghcmod/Language/Haskell/GhcMod/Info.hs 39 | listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r] 40 | listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) 41 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ghc-imported-from 2 | 3 | For a given Haskell source file, determine the path to the Haddock documentation for a symbol at a particular line/col location. 4 | 5 | Example: on the file [src/Main.hs](https://github.com/carlohamalainen/ghc-imported-from/blob/master/src/Main.hs), 6 | 7 | ghc-imported-from src/Main.hs Main strOption 18 17 8 | 9 | says 10 | 11 | SUCCESS: file:///home/carlo/.stack/snapshots/x86_64-linux/lts-5.8/7.10.3/doc/optparse-applicative-0.12.1.0/Options-Applicative-Builder.html 12 | 13 | since the usage of ```strOption``` at line 18, column 17, is from the ```Options.Applicative.Builder``` module. 14 | 15 | Difficulties arise in resolving names because some symbols are exported from a certain 16 | package but defined in another, for example ```String``` is defined in 17 | ```GHC.Base``` but is exported from the standard prelude, the module 18 | ```Prelude```. There are other cases to deal with including qualified 19 | imports, selective imports, imports with hidden components, etc. 20 | 21 | ## Using with Stack 22 | 23 | [Stack](http://docs.haskellstack.org/en/stable/README/) makes everything easier. 24 | 25 | Build ghc-imported-from: 26 | 27 | git clone https://github.com/carlohamalainen/ghc-imported-from 28 | cd ghc-imported-from 29 | stack build 30 | 31 | then add 32 | 33 | `pwd`/.stack-work/install/x86_64-linux/lts-5.8/7.10.3/bin 34 | 35 | or similar to your ```$PATH```. 36 | 37 | Then in a project that you are working on: 38 | 39 | cd my-project 40 | stack build 41 | stack haddock # Must do this! 42 | ghc-imported-from some/file/Blah.hs Blah f 100 3 43 | 44 | ### Tests 45 | 46 | Run the tests using Stack: 47 | 48 | stack test 49 | 50 | ### ghcimportedfrom-vim 51 | 52 | For Vim users, 53 | follow the instructions at 54 | [https://github.com/carlohamalainen/ghcimportedfrom-vim](https://github.com/carlohamalainen/ghcimportedfrom-vim) 55 | to install the Vim plugin. 56 | 57 | ### ghc-imported-from-el 58 | 59 | For Emacs users, David Christiansen has written [ghc-imported-from-el](https://github.com/david-christiansen/ghc-imported-from-el). 60 | 61 | ## Usage 62 | 63 | See the ```tests``` subdirectory for some examples. Or load your favourite Haskell project and hit F4. 64 | 65 | Or watch the screencast (be sure to set 720p HD and then fullscreen): 66 | 67 | [https://www.youtube.com/watch?v=7yO_VGCWMu8](https://www.youtube.com/watch?v=7yO_VGCWMu8) 68 | 69 | ## Notes 70 | 71 | ```ghc-imported-from``` uses both GHC and ghc-pkg, which 72 | accept arguments in differing formats. For example GHC takes 73 | ```-package-db``` while ghc-pkg takes ```--package-db=```. For more 74 | details: [Storage and Identification of Cabalized Packages](https://www.cs.toronto.edu/~trebla/personal/haskell/sicp.xhtml). 75 | 76 | ## Debugging 77 | 78 | To see the GHC options that have been automatically detected, change into your project's directory and run: 79 | 80 | $ cd ~/ghc-imported-from 81 | $ cabal repl --with-ghc=fake-ghc-for-ghc-imported-from 82 | Preprocessing library ghc-imported-from-0.2.0.2... 83 | --interactive -fbuilding-cabal-package -O0 -outputdir dist/build -odir dist/build -hidir dist/build -stubdir dist/build -i -idist/build -i. -idist/build/autogen -Idist/build/autogen -Idist/build -optP-include -optPdist/build/autogen/cabal_macros.h -package-name ghc-imported-from-0.2.0.2 -hide-all-packages -no-user-package-db -package-db /home/user/ghc-imported-from/.cabal-sandbox/x86_64-linux-ghc-7.6.3-packages.conf.d -package-db dist/package.conf.inplace -package-id Cabal-1.16.0-c6e09e008cd04cf255c1ce0c59aba905 -package-id base-4.6.0.1-8aa5d403c45ea59dcd2c39f123e27d57 -package-id containers-0.5.0.0-ab1dae9a94cd3cc84e7b2805636ebfa2 -package-id directory-1.2.0.1-91a788fd88acd7f149f0f10f5f1e23f2 -package-id filepath-1.3.0.1-b12cbe18566fe1532a1fda4c85e31cbe -package-id ghc-7.6.3-18957ddbb817289f604552aa2da2e879 -package-id ghc-mod-4.1.0-a87501f2667239b3f0bef3e0f3753496 -package-id ghc-paths-0.1.0.9-3817f31ae510ed3b58554933ea527b74 -package-id ghc-syb-utils-0.2.1.2-bf72c1e71339c52f0af404a12449c9d2 -package-id mtl-2.2.0.1-ef91e0abcf7a4fb581ecb7fe83cdcba1 -package-id process-1.1.0.2-76e05340eb66705981411022731ca84a -package-id safe-0.3.4-ba52ca348aecad429ba90450e3aba4c4 -package-id syb-0.4.1-9469ffdd9c6a7ebbf035421c915a08ee -package-id transformers-0.4.1.0-42810d723884ebf2a2dd638e5b22e523 -XHaskell2010 Language.Haskell.GhcImportedFrom Language.Haskell.GhcImportedFrom.UtilsFromGhcMod Language.Haskell.GhcImportedFrom.Types -Wall 84 | 85 | ## Alternatives 86 | 87 | As far as I know the only alternative is the ```fpco/hoogle-doc``` function in 88 | [https://www.fpcomplete.com/page/api](https://www.fpcomplete.com/page/api). Or try Ctrl-i 89 | in the web version of FP Complete. 90 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /build_in_sandbox.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | PS4='($LINENO)+ ' 4 | set -x 5 | set -e 6 | 7 | rm -fr .cabal-sandbox cabal.sandbox.config dist 8 | 9 | cabal sandbox init 10 | 11 | export PATH=`pwd`/.cabal-sandbox/bin:$PATH 12 | 13 | cabal install --enable-documentation --haddock-hyperlink-source --dependencies-only # Is this necessary? Why not just cabal install? 14 | cabal install 15 | -------------------------------------------------------------------------------- /build_in_sandbox_scratch.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | PS4='($LINENO)+ ' 4 | set -x 5 | set -e 6 | 7 | export sandbox=/scratch/sandboxes/ghc-imported-from 8 | 9 | rm -fr $sandbox cabal.sandbox.config dist 10 | 11 | cabal sandbox init --sandbox=${sandbox} 12 | 13 | # cabal sandbox add-source /home/carlo/Desktop/ghc-mod 14 | 15 | cabal install --enable-documentation --haddock-hyperlink-source --dependencies-only # Is this necessary? Why not just cabal install? 16 | cabal install 17 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | 2016-06-01 v0.3.0.6 2 | 3 | * Bugfix - remove duplicates from result of qualifiedNames. 4 | 5 | 2016-04-12 v0.3.0.5 6 | 7 | * Remove upper bound on pipes-transduce. 8 | 9 | 2016-04-05 v0.3.0.4 10 | 11 | * Bugfix: upper bound on pipes-transduce to fix a build error. 12 | 13 | 2016-04-04 v0.3.0.3 14 | 15 | * Bugfix: was parsing stderr instead of stdout for some 'stack path' commands. 16 | * Build against process-streaming-0.9.1.0 instead of process-streaming-0.7.2.2. 17 | 18 | 2016-03-30 v0.3.0.2 19 | 20 | * Bugfix to the bugfix. 21 | 22 | 2016-03-30 v0.3.0.1 23 | 24 | * Bugfix: use process-streaming to avoid deadlock on Fedora 23. 25 | 26 | 2016-03-26 v0.3.0.0 27 | 28 | * New heuristics for resolving symbols. 29 | * Compatability with Stack! 30 | 31 | 2016-01-20 v0.2.1.1 32 | 33 | * Builds against ghc-mod-5.5.0.0. 34 | 35 | 2016-01-20 v0.2.1.0 36 | 37 | * Builds on GHC 7.10.3 with the latest version of ghc-mod 38 | that is available on Hackage. 39 | 40 | 2015-08-17 v0.2.0.7 41 | 42 | * Added a fall-back case when our resolved qualified name 43 | does not match anything. 44 | 45 | 2014-07-05 v0.2.0.6 46 | 47 | * Use optparse-applicative for argument parsing. 48 | * Allow digits and underscores in module names. 49 | 50 | 2014-06-01 v0.2.0.5 51 | 52 | * Version bound on ghc-mod. 53 | 54 | 2014-05-22 v0.2.0.4 55 | 56 | * Speedup: factor out calls to getGhcOptionsViaCabalRepl. 57 | * Bug fix: filter out haskell module names from the cabal options list. 58 | 59 | 2014-05-19 v0.2.0.3 60 | 61 | * Fixed test cases. 62 | * Added alternative heuristic for lookup. 63 | 64 | 2014-05-16 v0.2.0.2 65 | 66 | * Catch GHC panics. 67 | * Verbose debug output. 68 | * Handle case where source file may not have a validly define module name 69 | but parses correctly regardless. https://github.com/carlohamalainen/ghc-imported-from/issues/15 70 | 71 | 2014-05-15 v0.2.0.1 72 | 73 | * Link to changelog.md. 74 | 75 | 2014-05-15 v0.2.0.0 76 | 77 | * Builds with GHC 7.6.3 and 7.8.2. 78 | * Reduced dependencies on ghc-mod and Cabal internals. 79 | * GHC option discovery using a fake GHC binary. 80 | * Various tidyups via hlint. 81 | * Removed cabal constraints file. 82 | 83 | 2014-05-02 v0.1.0.4 84 | 85 | * Fix for hashed directory in sandbox dist/build; see also 86 | https://github.com/carlohamalainen/ghc-imported-from/issues/10 87 | 88 | 2014-03-03 v0.1.0.3 89 | 90 | * Fix build failure by pinning all package dependencies. 91 | 92 | 2014-01-26 v0.1.0.2 93 | 94 | * Use more of ghc-mod's API to set the correct GHC command 95 | line arguments. 96 | 97 | 2014-01-24 v0.1.0.1 98 | 99 | * Change module layout to Language.Haskell.GhcImportedFrom 100 | to comply with hackage.haskell.org guidelines. 101 | 102 | 2014-01-21 v0.1.0.0 103 | 104 | * First version on hackage.haskell.org 105 | -------------------------------------------------------------------------------- /cp_to_dockers.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | set -x 5 | 6 | find . -name ghc-imported-from-*.tar.gz -exec rm -v {} \; 7 | 8 | cabal sdist 9 | cp dist/ghc-imported-from-*.tar.gz docker-testsuite/debian-cabal/ 10 | cp dist/ghc-imported-from-*.tar.gz docker-testsuite/debian-stack/ 11 | cp dist/ghc-imported-from-*.tar.gz docker-testsuite/fedora-cabal/ 12 | cp dist/ghc-imported-from-*.tar.gz docker-testsuite/fedora-stack/ 13 | cp dist/ghc-imported-from-*.tar.gz docker-testsuite/ubuntu-cabal/ 14 | cp dist/ghc-imported-from-*.tar.gz docker-testsuite/ubuntu-stack/ 15 | -------------------------------------------------------------------------------- /docker-testsuite/README.md: -------------------------------------------------------------------------------- 1 | Docker containers for running tests on Debian, Ubuntu, and Fedora 2 | distros. 3 | 4 | debian-cabal Debian with repository's ghc, cabal. 5 | debian-stack Debian with repository's ghc, cabal PLUS Stack's tools. 6 | 7 | ubuntu-cabal Ubuntu with repository's ghc, cabal. 8 | ubuntu-stack Ubuntu with repository's ghc, cabal PLUS Stack's tools. 9 | 10 | fedora-cabal Fedora with repository's ghc, cabal 11 | fedora-stack Debian with repository's ghc, cabal PLUS Stack's tools. 12 | -------------------------------------------------------------------------------- /docker-testsuite/debian-cabal/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM debian:testing 2 | MAINTAINER Carlo Hamalainen 3 | 4 | RUN apt-get -qq update 5 | RUN apt-get -qqy install cabal-install ghc ghc-doc git wget happy zlib1g-dev 6 | 7 | RUN mkdir -p /opt 8 | WORKDIR /opt 9 | 10 | # RUN wget https://hackage.haskell.org/package/ghc-imported-from-0.3.0.6/ghc-imported-from-0.3.0.6.tar.gz 11 | # RUN tar zxf ghc-imported-from-0.3.0.6.tar.gz 12 | 13 | # RUN git clone https://github.com/carlohamalainen/ghc-imported-from.git /opt/ghc-imported-from 14 | 15 | ADD ghc-imported-from-0.3.0.6.tar.gz /opt/ghc-imported-from/ 16 | WORKDIR /opt/ghc-imported-from/ghc-imported-from-0.3.0.6 17 | 18 | ENV PATH /.cabal/bin:/opt/ghc-imported-from/.cabal-sandbox/bin:$PATH 19 | 20 | ADD build_and_test.sh /opt/ghc-imported-from/ghc-imported-from-0.3.0.6/ 21 | 22 | RUN bash build_and_test.sh 23 | 24 | CMD /bin/bash 25 | -------------------------------------------------------------------------------- /docker-testsuite/debian-cabal/build.sh: -------------------------------------------------------------------------------- 1 | docker build --no-cache -t='carlo/ghc-imported-from-debian-cabal' . 2 | -------------------------------------------------------------------------------- /docker-testsuite/debian-cabal/build_and_test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | set -x 5 | 6 | cabal update 7 | cabal sandbox init 8 | cabal install --enable-documentation --haddock-hyperlink-source --dependencies-only --verbose 9 | cabal install --verbose 10 | cabal configure --enable-tests --verbose && cabal build --verbose && cabal test 11 | cat dist/test/ghc-imported-from-*-spec.log 12 | -------------------------------------------------------------------------------- /docker-testsuite/debian-cabal/go.sh: -------------------------------------------------------------------------------- 1 | docker run -i -t carlo/ghc-imported-from-debian-cabal /bin/bash 2 | -------------------------------------------------------------------------------- /docker-testsuite/debian-stack/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM debian:testing 2 | MAINTAINER Carlo Hamalainen 3 | 4 | ADD sources.list /etc/apt/sources.list 5 | RUN apt-get -qq update 6 | RUN apt-get -qqy install cabal-install git wget happy 7 | 8 | RUN apt-key adv --keyserver keyserver.ubuntu.com --recv-keys 575159689BEFB442 9 | RUN echo 'deb http://download.fpcomplete.com/debian jessie main' | tee /etc/apt/sources.list.d/fpco.list 10 | 11 | RUN apt-get -qq update 12 | RUN apt-get -qqy install stack 13 | 14 | RUN mkdir -p /opt 15 | WORKDIR /opt 16 | 17 | ADD ghc-imported-from-0.3.0.6.tar.gz /opt/ghc-imported-from/ 18 | WORKDIR /opt/ghc-imported-from/ghc-imported-from-0.3.0.6 19 | 20 | ADD build_and_test.sh /opt/ghc-imported-from/ghc-imported-from-0.3.0.6/ 21 | RUN bash build_and_test.sh 22 | 23 | CMD /bin/bash 24 | -------------------------------------------------------------------------------- /docker-testsuite/debian-stack/build.sh: -------------------------------------------------------------------------------- 1 | docker build --no-cache -t='carlo/ghc-imported-from-debian-stack' . 2 | -------------------------------------------------------------------------------- /docker-testsuite/debian-stack/build_and_test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | set -x 5 | 6 | stack setup --install-ghc --no-system-ghc 7 | stack build --install-ghc --no-system-ghc 8 | stack haddock --install-ghc --no-system-ghc 9 | stack test --install-ghc --no-system-ghc 10 | -------------------------------------------------------------------------------- /docker-testsuite/debian-stack/go.sh: -------------------------------------------------------------------------------- 1 | docker run -i -t carlo/ghc-imported-from-debian-stack /bin/bash 2 | -------------------------------------------------------------------------------- /docker-testsuite/debian-stack/sources.list: -------------------------------------------------------------------------------- 1 | deb http://ftp.debian.org/debian testing main 2 | deb-src http://ftp.debian.org/debian testing main 3 | 4 | deb http://ftp.debian.org/debian testing-updates main 5 | deb-src http://ftp.debian.org/debian testing-updates main 6 | 7 | deb http://security.debian.org/ testing/updates main 8 | deb-src http://security.debian.org/ testing/updates main 9 | -------------------------------------------------------------------------------- /docker-testsuite/fedora-cabal/README.md: -------------------------------------------------------------------------------- 1 | ghc-imported-from doesn't build on Fedora 23 due to a too-low version of GHC, 2 | so currently this test is not supported. Build using Stack instead. 3 | -------------------------------------------------------------------------------- /docker-testsuite/fedora-cabal/___Dockerfile: -------------------------------------------------------------------------------- 1 | FROM fedora 2 | MAINTAINER Carlo Hamalainen 3 | 4 | RUN dnf -y install ghc happy wget git cabal-install zlib-devel 5 | 6 | RUN mkdir -p /opt 7 | WORKDIR /opt 8 | 9 | # RUN wget https://hackage.haskell.org/package/ghc-imported-from-0.3.0.5/ghc-imported-from-0.3.0.5.tar.gz 10 | # RUN tar zxf ghc-imported-from-0.3.0.5.tar.gz 11 | # WORKDIR /opt/ghc-imported-from-0.3.0.5 12 | 13 | # RUN git clone https://github.com/carlohamalainen/ghc-imported-from.git /opt/ghc-imported-from 14 | # WORKDIR /opt/ghc-imported-from 15 | 16 | RUN mkdir /opt/ghc_7.10.3 17 | WORKDIR /opt/ghc_7.10.3 18 | RUN wget http://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3-x86_64-centos67-linux.tar.xz 19 | 20 | 21 | #ADD ghc-imported-from-0.3.0.5.tar.gz /opt/ghc-imported-from/ 22 | #WORKDIR /opt/ghc-imported-from/ghc-imported-from-0.3.0.5 23 | 24 | #ENV PATH /.cabal/bin:/opt/ghc-imported-from/.cabal-sandbox/bin:$PATH 25 | 26 | #ADD build_and_test.sh /opt/ghc-imported-from/ghc-imported-from-0.3.0.5/ 27 | 28 | # RUN bash build_and_test.sh 29 | 30 | CMD /bin/bash 31 | -------------------------------------------------------------------------------- /docker-testsuite/fedora-cabal/build.sh: -------------------------------------------------------------------------------- 1 | docker build --no-cache -t='carlo/ghc-imported-from-fedora-cabal' . 2 | -------------------------------------------------------------------------------- /docker-testsuite/fedora-cabal/build_and_test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | set -x 5 | 6 | cabal update 7 | cabal sandbox init 8 | cabal install --enable-documentation --haddock-hyperlink-source --dependencies-only --verbose 9 | cabal install --verbose 10 | cabal configure --enable-tests --verbose && cabal build --verbose && cabal test 11 | cat dist/test/ghc-imported-from-*-spec.log 12 | -------------------------------------------------------------------------------- /docker-testsuite/fedora-cabal/go.sh: -------------------------------------------------------------------------------- 1 | docker run -i -t carlo/ghc-imported-from-fedora-cabal /bin/bash 2 | -------------------------------------------------------------------------------- /docker-testsuite/fedora-stack/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM fedora 2 | MAINTAINER Carlo Hamalainen 3 | 4 | RUN curl -sSL https://s3.amazonaws.com/download.fpcomplete.com/fedora/23/fpco.repo | tee /etc/yum.repos.d/fpco.repo 5 | 6 | RUN dnf -y install stack wget git cabal-install zlib-devel 7 | 8 | RUN mkdir -p /opt 9 | WORKDIR /opt 10 | 11 | # RUN wget https://hackage.haskell.org/package/ghc-imported-from-0.3.0.6/ghc-imported-from-0.3.0.6.tar.gz 12 | # RUN tar zxf ghc-imported-from-0.3.0.6.tar.gz 13 | # WORKDIR /opt/ghc-imported-from-0.3.0.6 14 | 15 | # RUN git clone https://github.com/carlohamalainen/ghc-imported-from.git /opt/ghc-imported-from 16 | # WORKDIR /opt/ghc-imported-from 17 | 18 | ADD ghc-imported-from-0.3.0.6.tar.gz /opt/ghc-imported-from/ 19 | WORKDIR /opt/ghc-imported-from/ghc-imported-from-0.3.0.6 20 | 21 | RUN stack setup 22 | RUN stack build 23 | RUN stack haddock 24 | RUN stack haddock 25 | RUN stack haddock 26 | RUN stack test 27 | 28 | CMD /bin/bash 29 | -------------------------------------------------------------------------------- /docker-testsuite/fedora-stack/build.sh: -------------------------------------------------------------------------------- 1 | docker build --no-cache -t='carlo/ghc-imported-from-fedora-stack' . 2 | -------------------------------------------------------------------------------- /docker-testsuite/fedora-stack/go.sh: -------------------------------------------------------------------------------- 1 | docker run -i -t carlo/ghc-imported-from-fedora-stack /bin/bash 2 | -------------------------------------------------------------------------------- /docker-testsuite/ubuntu-cabal/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ubuntu:15.10 2 | MAINTAINER Carlo Hamalainen 3 | 4 | RUN apt-get -qq update 5 | RUN apt-get -qqy install software-properties-common 6 | RUN add-apt-repository ppa:hvr/ghc 7 | RUN apt-get -qq update 8 | RUN apt-get -qqy install git wget happy zlib1g-dev 9 | RUN apt-get -qqy install ghc-7.10.3 ghc-7.10.3-prof ghc-7.10.3-dyn ghc-7.10.3-htmldocs cabal-install 10 | 11 | ENV PATH /opt/ghc/7.10.3/bin:$PATH 12 | 13 | RUN mkdir -p /opt 14 | WORKDIR /opt 15 | 16 | # RUN wget https://hackage.haskell.org/package/ghc-imported-from-0.3.0.6/ghc-imported-from-0.3.0.6.tar.gz 17 | # RUN tar zxf ghc-imported-from-0.3.0.6.tar.gz 18 | 19 | # RUN git clone https://github.com/carlohamalainen/ghc-imported-from.git /opt/ghc-imported-from 20 | 21 | ADD ghc-imported-from-0.3.0.6.tar.gz /opt/ghc-imported-from/ 22 | WORKDIR /opt/ghc-imported-from/ghc-imported-from-0.3.0.6 23 | 24 | ENV PATH /.cabal/bin:/opt/ghc-imported-from/.cabal-sandbox/bin:$PATH 25 | 26 | ADD build_and_test.sh /opt/ghc-imported-from/ghc-imported-from-0.3.0.6/ 27 | 28 | RUN bash build_and_test.sh 29 | 30 | CMD /bin/bash 31 | -------------------------------------------------------------------------------- /docker-testsuite/ubuntu-cabal/build.sh: -------------------------------------------------------------------------------- 1 | docker build --no-cache -t='carlo/ghc-imported-from-ubuntu-cabal' . 2 | -------------------------------------------------------------------------------- /docker-testsuite/ubuntu-cabal/build_and_test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | set -x 5 | 6 | cabal update 7 | cabal install cabal-install 8 | export PATH=$HOME/.cabal/bin:$PATH 9 | cabal sandbox init 10 | cabal install --enable-documentation --haddock-hyperlink-source --dependencies-only --verbose 11 | cabal install --verbose 12 | cabal configure --enable-tests --verbose && cabal build --verbose && cabal test 13 | cat dist/test/ghc-imported-from-*-spec.log 14 | -------------------------------------------------------------------------------- /docker-testsuite/ubuntu-cabal/go.sh: -------------------------------------------------------------------------------- 1 | docker run -i -t carlo/ghc-imported-from-ubuntu-cabal /bin/bash 2 | -------------------------------------------------------------------------------- /docker-testsuite/ubuntu-stack/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ubuntu 2 | MAINTAINER Carlo Hamalainen 3 | 4 | RUN apt-get -qq update 5 | RUN apt-get -qqy install cabal-install git wget happy 6 | 7 | RUN apt-key adv --keyserver keyserver.ubuntu.com --recv-keys 575159689BEFB442 8 | RUN echo 'deb http://download.fpcomplete.com/ubuntu wily main'|sudo tee /etc/apt/sources.list.d/fpco.list 9 | 10 | RUN apt-get -qq update 11 | RUN apt-get -qqy install stack 12 | 13 | RUN mkdir -p /opt 14 | WORKDIR /opt 15 | 16 | ADD ghc-imported-from-0.3.0.6.tar.gz /opt/ghc-imported-from/ 17 | WORKDIR /opt/ghc-imported-from/ghc-imported-from-0.3.0.6 18 | 19 | ADD build_and_test.sh /opt/ghc-imported-from/ghc-imported-from-0.3.0.6/ 20 | RUN bash build_and_test.sh 21 | 22 | CMD /bin/bash 23 | -------------------------------------------------------------------------------- /docker-testsuite/ubuntu-stack/build.sh: -------------------------------------------------------------------------------- 1 | docker build --no-cache -t='carlo/ghc-imported-from-ubuntu-stack' . 2 | -------------------------------------------------------------------------------- /docker-testsuite/ubuntu-stack/build_and_test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | set -x 5 | 6 | stack setup 7 | stack build 8 | stack haddock 9 | stack test 10 | -------------------------------------------------------------------------------- /docker-testsuite/ubuntu-stack/go.sh: -------------------------------------------------------------------------------- 1 | docker run -i -t carlo/ghc-imported-from-ubuntu-stack /bin/bash 2 | -------------------------------------------------------------------------------- /ghc-imported-from.cabal: -------------------------------------------------------------------------------- 1 | name: ghc-imported-from 2 | version: 0.3.0.6 3 | synopsis: Find the Haddock documentation for a symbol. 4 | description: Given a Haskell module and symbol, determine the URL to the Haddock documentation 5 | for that symbol. 6 | homepage: https://github.com/carlohamalainen/ghc-imported-from 7 | license: BSD3 8 | license-file: LICENSE 9 | author: Carlo Hamalainen 10 | maintainer: carlo@carlo-hamalainen.net 11 | -- copyright: 12 | category: Development 13 | build-type: Simple 14 | extra-source-files: README.md changelog.md stack.yaml 15 | 16 | cabal-version: >=1.10 17 | 18 | extra-source-files: test/*.hs 19 | test/data/*.hs 20 | 21 | library 22 | GHC-Options: -Wall 23 | exposed-modules: Language.Haskell.GhcImportedFrom 24 | other-modules: Language.Haskell.GhcImportedFrom.UtilsFromGhcMod 25 | Language.Haskell.GhcImportedFrom.Types 26 | 27 | other-extensions: CPP, Rank2Types 28 | build-depends: base >=4.0 && <5 29 | , syb 30 | , ghc 31 | , ghc-paths 32 | , ghc-syb-utils 33 | , ghc-mod == 5.5.0.0 34 | , monad-journal 35 | , filepath 36 | , safe 37 | , bytestring 38 | , process 39 | , process-streaming >= 0.9.0.0 40 | , directory 41 | , containers 42 | , mtl 43 | , transformers 44 | , parsec 45 | , optparse-applicative 46 | , haddock-api 47 | , hspec 48 | , hspec-discover 49 | , exceptions 50 | , pipes-transduce 51 | if impl(ghc < 7.7) 52 | Build-Depends: Cabal >= 1.10 && < 1.17 53 | else 54 | Build-Depends: Cabal >= 1.18 55 | 56 | default-language: Haskell2010 57 | 58 | executable fake-ghc-for-ghc-imported-from 59 | main-is: fake-ghc-for-ghc-imported-from.hs 60 | GHC-Options: -Wall 61 | hs-source-dirs: src 62 | build-depends: base >=4.0 && <5 63 | , process 64 | , process-streaming >= 0.9.0.0 65 | default-language: Haskell2010 66 | 67 | executable ghc-imported-from 68 | main-is: Main.hs 69 | GHC-Options: -Wall 70 | other-modules: Paths_ghc_imported_from 71 | other-extensions: CPP, Rank2Types 72 | build-depends: base >=4.0 && <5 73 | , syb 74 | , ghc 75 | , ghc-paths 76 | , ghc-syb-utils 77 | , ghc-mod == 5.5.0.0 78 | , monad-journal 79 | , ghc-imported-from 80 | , filepath 81 | , safe 82 | , bytestring 83 | , process 84 | , process-streaming >= 0.9.0.0 85 | , directory 86 | , containers 87 | , mtl 88 | , transformers 89 | , parsec 90 | , optparse-applicative 91 | , haddock-api 92 | , hspec 93 | , hspec-discover 94 | , exceptions 95 | 96 | if impl(ghc < 7.7) 97 | Build-Depends: Cabal >= 1.10 && < 1.17 98 | else 99 | Build-Depends: Cabal >= 1.18 100 | 101 | hs-source-dirs: src 102 | default-language: Haskell2010 103 | 104 | Test-Suite spec 105 | Default-Language: Haskell2010 106 | GHC-Options: -Wall 107 | Main-Is: Spec.hs 108 | Hs-Source-Dirs: test, . 109 | Type: exitcode-stdio-1.0 110 | Other-Modules: ImportedFromSpec 111 | Build-Depends: base >=4.0 && <5 112 | , syb 113 | , ghc 114 | , ghc-paths 115 | , ghc-syb-utils 116 | , ghc-mod == 5.5.0.0 117 | , monad-journal 118 | , filepath 119 | , safe 120 | , bytestring 121 | , process 122 | , process-streaming >= 0.9.0.0 123 | , directory 124 | , containers 125 | , mtl 126 | , transformers 127 | , parsec 128 | , optparse-applicative 129 | , hspec 130 | , hspec-discover 131 | , exceptions 132 | , haddock-api 133 | if impl(ghc < 7.7) 134 | Build-Depends: Cabal >= 1.10 && < 1.17 135 | else 136 | Build-Depends: Cabal >= 1.18 137 | -------------------------------------------------------------------------------- /quick_rebuild.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | cabal install --haddock-hyperlink-source --dependencies-only && cabal install --haddock-hyperlink-source 4 | -------------------------------------------------------------------------------- /run_tests_cabal_sandbox.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | cabal configure --enable-tests && cabal build && cabal test 4 | cat dist/test/ghc-imported-from-*-spec.log 5 | -------------------------------------------------------------------------------- /run_tests_stack.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | stack test 4 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Language.Haskell.GhcImportedFrom 4 | import Control.Monad.Writer 5 | import Options.Applicative 6 | 7 | data CmdOptions = CmdOptions { cmdGhcOptions :: [String] 8 | , cmdGhcPkgOptions :: [String] 9 | , cmdHaskellFile :: FilePath 10 | , cmdModuleName :: String 11 | , cmdSymbol :: String 12 | , cmdLineNr :: Int 13 | , cmdColNr :: Int 14 | } deriving Show 15 | 16 | parserOptions :: Parser CmdOptions 17 | parserOptions = CmdOptions 18 | <$> (many $ strOption ( long "ghc-options" <> help "GHC options" )) 19 | <*> (many $ strOption ( long "ghc-pkg-options" <> help "ghc-pkg options" )) 20 | <*> argument str (metavar "") 21 | <*> argument str (metavar "") 22 | <*> argument str (metavar "") 23 | <*> argument auto (metavar "") 24 | <*> argument auto (metavar "") 25 | 26 | main :: IO () 27 | main = do 28 | (CmdOptions gOpts gpkgOpts hfile mname sym line col) <- execParser opts 29 | haddockUrl (Options gOpts gpkgOpts (LineSeparator "\0")) hfile mname sym line col >>= putStr 30 | where 31 | opts = info (helper <*> parserOptions) 32 | (fullDesc <> header "ghc-imported-from - find the haddock url for a symbol in a Haskell file.\n\nExample: ghc-imported-from src/Main.hs Main getArgs 160 13\n") 33 | -------------------------------------------------------------------------------- /src/fake-ghc-for-ghc-imported-from.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | -- Fake ghc binary, used to extract the GHC command line options 4 | -- via the "cabal repl" command. Thanks to Herbert Valerio Riedel 5 | -- on haskell-cafe for the tip: 6 | -- 7 | -- http://www.haskell.org/pipermail/haskell-cafe/2014-May/114183.html 8 | 9 | -- If we are called with --numeric-version or --info then we lie and pretend 10 | -- to be the system's current default ghc binary. Will this cause problems if 11 | -- someone is using --with-ghc elsewhere to choose the ghc binary? 12 | 13 | import System.Cmd (rawSystem) 14 | import System.Environment (getArgs) 15 | 16 | main :: IO () 17 | main = do 18 | args <- getArgs 19 | 20 | if length args == 1 21 | then case head args of "--numeric-version" -> rawSystem "ghc" ["--numeric-version"] >> return () 22 | "--info" -> rawSystem "ghc" ["--info"] >> return () 23 | _ -> putStrLn $ unwords args 24 | else putStrLn $ unwords args 25 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - '.' 4 | extra-deps: 5 | - ghc-7.10.3 6 | - conceit-0.4.0.0 7 | - pipes-text-0.0.1.0 8 | - process-streaming-0.9.1.0 9 | - pipes-transduce-0.3.4.0 10 | resolver: lts-5.11 11 | -------------------------------------------------------------------------------- /test/ImportedFromSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | module ImportedFromSpec where 4 | 5 | import Language.Haskell.GhcImportedFrom 6 | import System.FilePath() 7 | import Test.Hspec 8 | 9 | import Control.Exception as E 10 | import Data.List (isPrefixOf) 11 | import System.Directory 12 | import System.FilePath (addTrailingPathSeparator) 13 | 14 | ------------------------------------------------------------------------------- 15 | -- withDirectory_, withDirectory, and toRelativeDir are copied 16 | -- from ghc-mod. 17 | withDirectory_ :: FilePath -> IO a -> IO a 18 | withDirectory_ dir action = bracket getCurrentDirectory 19 | setCurrentDirectory 20 | (\_ -> setCurrentDirectory dir >> action) 21 | 22 | withDirectory :: FilePath -> (FilePath -> IO a) -> IO a 23 | withDirectory dir action = bracket getCurrentDirectory 24 | setCurrentDirectory 25 | (\d -> setCurrentDirectory dir >> action d) 26 | 27 | toRelativeDir :: FilePath -> FilePath -> FilePath 28 | toRelativeDir dir file 29 | | dir' `isPrefixOf` file = drop len file 30 | | otherwise = file 31 | where 32 | dir' = addTrailingPathSeparator dir 33 | len = length dir' 34 | 35 | isRight :: forall a b. Either a b -> Bool 36 | isRight = either (const False) (const True) 37 | ------------------------------------------------------------------------------- 38 | 39 | -- Instead of shouldSatisfy isRight, these should check for the right module/package 40 | -- name turning up in the results. 41 | 42 | spec :: Spec 43 | spec = do 44 | describe "checkImportedFrom" $ do 45 | it "can look up Maybe" $ do 46 | withDirectory_ "test/data" $ do 47 | res <- guessHaddockUrl "Muddle.hs" "Muddle" "Maybe" 11 11 (GhcOptions []) (GhcPkgOptions []) 48 | res `shouldSatisfy` isRight 49 | 50 | it "can look up Just" $ do 51 | withDirectory_ "test/data" $ do 52 | res <- guessHaddockUrl "Muddle.hs" "Muddle" "Just" 12 7 (GhcOptions []) (GhcPkgOptions []) 53 | res `shouldSatisfy` isRight 54 | 55 | it "can look up Just" $ do 56 | withDirectory_ "test/data" $ do 57 | res <- guessHaddockUrl "Muddle.hs" "Muddle" "Just" 16 10 (GhcOptions []) (GhcPkgOptions []) 58 | res `shouldSatisfy` isRight 59 | 60 | it "can look up String" $ do 61 | withDirectory_ "test/data" $ do 62 | res <- guessHaddockUrl "Muddle.hs" "Muddle" "String" 20 14 (GhcOptions []) (GhcPkgOptions []) 63 | res `shouldSatisfy` isRight 64 | 65 | it "can look up Int" $ do 66 | withDirectory_ "test/data" $ do 67 | res <- guessHaddockUrl "Muddle.hs" "Muddle" "Int" 22 23 (GhcOptions []) (GhcPkgOptions []) 68 | res `shouldSatisfy` isRight 69 | 70 | it "can look up DL.length" $ do 71 | withDirectory_ "test/data" $ do 72 | res <- guessHaddockUrl "Muddle.hs" "Muddle" "DL.length" 23 5 (GhcOptions []) (GhcPkgOptions []) 73 | res `shouldSatisfy` isRight 74 | 75 | it "can look up print" $ do 76 | withDirectory_ "test/data" $ do 77 | res <- guessHaddockUrl "Muddle.hs" "Muddle" "print" 25 8 (GhcOptions []) (GhcPkgOptions []) 78 | res `shouldSatisfy` isRight 79 | 80 | it "can look up DM.fromList" $ do 81 | withDirectory_ "test/data" $ do 82 | res <- guessHaddockUrl "Muddle.hs" "Muddle" "DM.fromList" 27 5 (GhcOptions []) (GhcPkgOptions []) 83 | res `shouldSatisfy` isRight 84 | 85 | it "can look up Safe.headMay" $ do 86 | withDirectory_ "test/data" $ do 87 | res <- guessHaddockUrl "Muddle.hs" "Muddle" "Safe.headMay" 29 6 (GhcOptions []) (GhcPkgOptions []) 88 | res `shouldSatisfy` isRight 89 | 90 | it "can look up map" $ do 91 | withDirectory_ "test/data" $ do 92 | res <- guessHaddockUrl "Hiding.hs" "Hiding" "map" 14 5 (GhcOptions []) (GhcPkgOptions []) 93 | res `shouldSatisfy` isRight 94 | 95 | it "can look up head" $ do 96 | withDirectory_ "test/data" $ do 97 | res <- guessHaddockUrl "Hiding.hs" "Hiding" "head" 16 5 (GhcOptions []) (GhcPkgOptions []) 98 | res `shouldSatisfy` isRight 99 | 100 | it "can look up when" $ do 101 | withDirectory_ "test/data" $ do 102 | res <- guessHaddockUrl "When.hs" "When" "when" 15 5 (GhcOptions []) (GhcPkgOptions []) 103 | res `shouldSatisfy` isRight 104 | 105 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /test/data/Hiding.hs: -------------------------------------------------------------------------------- 1 | -- Hiding.hs 2 | 3 | module Hiding where 4 | 5 | import Data.List hiding (map) 6 | import System.Environment (getArgs) 7 | import qualified Safe 8 | 9 | 10 | 11 | 12 | 13 | 14 | m = map (+1) [1, 2, 3] 15 | 16 | h = head [1, 2, 3] 17 | 18 | h' = Safe.headMay [] 19 | 20 | -------------------------------------------------------------------------------- /test/data/Muddle.hs: -------------------------------------------------------------------------------- 1 | -- Muddle.hs 2 | 3 | module Muddle where 4 | 5 | import Data.Maybe 6 | import qualified Data.List as DL 7 | import qualified Data.Map as DM 8 | import qualified Safe 9 | -- import Data.List hiding (map) 10 | 11 | f :: a -> Maybe a 12 | f x = Just x 13 | 14 | g :: IO () 15 | g = do 16 | let (Just _, _) = (Just 3, Just 4) 17 | 18 | return () 19 | 20 | s = "boo" :: String 21 | s' = head s 22 | t = Just 100 :: Maybe Int 23 | r = DL.length [1, 2, 3] 24 | 25 | main = print "Hello, World!" 26 | 27 | h = DM.fromList [("x", "y")] 28 | 29 | sh = Safe.headMay [] 30 | 31 | i = 3 :: Int 32 | i' = 3 :: Integer 33 | 34 | -------------------------------------------------------------------------------- /test/data/When.hs: -------------------------------------------------------------------------------- 1 | -- When.hs 2 | 3 | module When where 4 | 5 | import Control.Monad ( forM_, liftM, filterM, when, unless ) 6 | import Control.Monad.Identity 7 | import Control.Monad.Reader 8 | import Control.Monad.Trans.Writer.Lazy 9 | 10 | 11 | 12 | 13 | 14 | main = do 15 | when True $ do print "hah" 16 | --------------------------------------------------------------------------------