diff --git a/Ariadne.hs b/Ariadne.hs --- a/Ariadne.hs +++ b/Ariadne.hs @@ -3,68 +3,64 @@ import Ariadne.GlobalNameIndex import Ariadne.Index +import Ariadne.Types import qualified Ariadne.SrcMap as SrcMap +import Ariadne.ModuleDB import Language.Haskell.Names import Language.Haskell.Names.Interfaces import Language.Haskell.Names.SyntaxUtils import Language.Haskell.Names.Imports -import Language.Haskell.Exts.Annotated +import qualified Language.Haskell.Names.GlobalSymbolTable as Global +import Language.Haskell.Exts.Annotated hiding (parse) +import Language.Haskell.Exts.Annotated.CPP import Distribution.HaskellSuite.Packages +import Distribution.Simple.Compiler (PackageDB(..)) import Control.Applicative import Control.Monad.Trans import Control.Monad import Control.Exception +import Control.Monad.State import Text.Printf +import System.FilePath +import System.Directory +import System.Environment +import qualified Data.Map as Map +import qualified System.Log.Logger as L +import Data.Maybe +import qualified Data.Foldable as F +import Data.Proxy import Data.BERT import Network.BERT.Server import Network.BERT.Transport import qualified Data.ByteString.Lazy.UTF8 as UTF8 --- these should probably come from the Cabal file -defaultLang = Haskell2010 -defaultExts = [] - -work :: String -> Int -> Int -> IO (Maybe Origin) -work mod line col = handleExceptions $ do - parseResult <- - parseFileWithMode - defaultParseMode { parseFilename = mod } - mod - - case parseResult of - ParseFailed loc msg -> - return $ Just $ ResolveError $ printf "%s: %s" (prettyPrint loc) msg +main = do + lookupEnv "ARIADNE_DEBUG" >>= \v -> + when (isJust v) $ do + logger <- L.getRootLogger + L.updateGlobalLogger L.rootLoggerName (L.setLevel L.DEBUG) - ParseOk parsed -> do + L.debugM "ariadne" "Ariadne started" - let pkgs = [] - (resolved, impTbl) <- - flip evalNamesModuleT pkgs $ do - -- computeInterfaces lang exts mod - let extSet = moduleExtensions defaultLang defaultExts parsed - (,) <$> - (annotateModule defaultLang defaultExts parsed) <*> - (fmap snd $ processImports extSet $ getImports parsed) + t <- tcpServer 39014 - let - gIndex = mkGlobalNameIndex impTbl (getPointLoc <$> parsed) - srcMap = mkSrcMap gIndex (fmap srcInfoSpan <$> resolved) + withModuleDB $ \mdb -> serve t (dispatch mdb) - return $ SrcMap.lookup noLoc { srcLine = line, srcColumn = col } srcMap where - handleExceptions a = - try (a >>= evaluate) >>= either (\e -> return $ Just $ ResolveError $ show (e::SomeException)) return - -main = do - t <- tcpServer 39014 - serve t dispatch - where - -- dispatch _ _ args = do print args; return $ Success $ NilTerm - dispatch "ariadne" "find" [BinaryTerm file, IntTerm line, IntTerm col] = - work (UTF8.toString file) line col >>= \result -> return . Success $ + dispatch mdb mod fn args = do + L.debugM "ariadne.server" $ + printf "request: %s %s %s" mod fn (show args) + response <- handle mdb mod fn args + L.debugM "ariadne.server" $ + printf "response: %s" (show response) + return response + handle mdb "ariadne" "find" [BinaryTerm file, IntTerm line, IntTerm col] = do + let filestr = UTF8.toString file + sendRequestSync mdb (Include filestr) + answer mdb filestr line col >>= \result -> return . Success $ case result of Nothing -> TupleTerm [AtomTerm "no_name"] Just (LocKnown (SrcLoc file' line' col')) -> @@ -84,4 +80,4 @@ [ AtomTerm "error" , BinaryTerm (UTF8.fromString er) ] - dispatch _ _ _ = return NoSuchFunction + handle _ _ _ _ = return NoSuchFunction diff --git a/Ariadne/GlobalNameIndex.hs b/Ariadne/GlobalNameIndex.hs --- a/Ariadne/GlobalNameIndex.hs +++ b/Ariadne/GlobalNameIndex.hs @@ -1,4 +1,6 @@ {-# LANGUAGE TupleSections, TypeFamilies #-} +-- | Construction of the global name index. See 'GlobalNameIndex' for the +-- description. module Ariadne.GlobalNameIndex (mkGlobalNameIndex) where import Language.Haskell.Names @@ -12,6 +14,15 @@ import Ariadne.Types +-- | Create the global name index for a given module. +-- +-- This function assumes that the module's import table is calculated +-- somewhere outside (probably using 'processImports'). + +-- Why we don't calculate the import table right here? First, it would +-- bring all the complexity of ModuleT here. Second, what about recursive +-- modules? Third, this avoids double cost of resolution if it's needed +-- somewhere else too. mkGlobalNameIndex :: Global.Table -> Module SrcLoc -> GlobalNameIndex mkGlobalNameIndex tbl mod = @@ -22,7 +33,7 @@ names = concatMap (indexDecl tbl) ds in - Map.fromList + Map.fromListWith (const id) -- prefer earlier names [ ((OrigName Nothing (GName modname (nameToString n)), level), ann n) | (n, level) <- names ] @@ -30,11 +41,11 @@ indexDecl :: Global.Table -> Decl SrcLoc -> [(Name SrcLoc, NameLevel)] indexDecl tbl d = case d of - TypeDecl _ dh _ -> [(hname dh, TypeLevel)] - TypeFamDecl _ dh _ -> [(hname dh, TypeLevel)] + TypeDecl _ dh _ -> [(getDeclHeadName dh, TypeLevel)] + TypeFamDecl _ dh _ -> [(getDeclHeadName dh, TypeLevel)] DataDecl _ _ _ dh qualConDecls _ -> - ((hname dh, TypeLevel) :) . map (, ValueLevel) $ do -- list monad + ((getDeclHeadName dh, TypeLevel) :) . map (, ValueLevel) $ do -- list monad QualConDecl _ _ _ conDecl <- qualConDecls case conDecl of @@ -50,9 +61,10 @@ -- DataDecl case. -- (Also keep in mind that GHC doesn't create selectors for fields -- with existential type variables.) - (hname dh, TypeLevel) : + -- TODO HSE 1.16 now supports GADT records + (getDeclHeadName dh, TypeLevel) : [ (cn, ValueLevel) - | GadtDecl _ cn _ <- gadtDecls + | GadtDecl _ cn names _ <- gadtDecls ] ClassDecl _ _ dh _ mds -> @@ -60,17 +72,15 @@ ms = getBound tbl d cdecls = fromMaybe [] mds in - (hname dh, TypeLevel) : - [ (hname dh, TypeLevel) | ClsTyFam _ dh _ <- cdecls ] ++ - [ (hname dh, TypeLevel) | ClsDataFam _ _ dh _ <- cdecls ] ++ + (getDeclHeadName dh, TypeLevel) : + [ (getDeclHeadName dh, TypeLevel) | ClsTyFam _ dh _ <- cdecls ] ++ + [ (getDeclHeadName dh, TypeLevel) | ClsDataFam _ _ dh _ <- cdecls ] ++ [ (mn, ValueLevel) | mn <- ms ] FunBind _ ms -> map (, ValueLevel) $ getBound tbl ms - PatBind _ p _ _ _ -> map (, ValueLevel) $ getBound tbl p + PatBind _ p _ _ -> map (, ValueLevel) $ getBound tbl p ForImp _ _ _ _ fn _ -> [(fn, ValueLevel)] _ -> [] - where - hname = fst . splitDeclHead diff --git a/Ariadne/Index.hs b/Ariadne/Index.hs --- a/Ariadne/Index.hs +++ b/Ariadne/Index.hs @@ -12,12 +12,6 @@ import Ariadne.Types import qualified Ariadne.SrcMap as SrcMap -data Origin - = LocKnown SrcLoc - | LocUnknown ModuleNameS - | ResolveError String - deriving Show - mkSrcMap :: Foldable a => GlobalNameIndex diff --git a/Ariadne/ModuleDB.hs b/Ariadne/ModuleDB.hs new file mode 100644 --- /dev/null +++ b/Ariadne/ModuleDB.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-} + +module Ariadne.ModuleDB + ( sendRequestAsync + , sendRequestSync + , Request(..) + , answer + , withModuleDB + ) + where + +import Ariadne.Types +import qualified Ariadne.SrcMap as SrcMap +import Ariadne.ModuleDB.Types +import Ariadne.ModuleDB.ParseResolve + +import Language.Haskell.Names +import Language.Haskell.Exts.Annotated hiding (parse) + +import Control.Monad.Trans +import Control.Monad +import Control.Exception +import Control.Monad.State +import Text.Printf +import System.Directory +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified System.Log.Logger as L +import Data.Maybe +import Data.Proxy + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Concurrent.STM + +import Data.Lens + +-- | Send a request and wait for its completion +sendRequestSync :: ModuleDB -> Request -> IO () +sendRequestSync (ModuleDB { requestChan = chan }) req = do + mvar <- newEmptyMVar + let cb = putMVar mvar () + writeChan chan (req, cb) + takeMVar mvar + +-- | Send a request and return immediately +sendRequestAsync :: ModuleDB -> Request -> IO () +sendRequestAsync (ModuleDB { requestChan = chan }) req = + writeChan chan (req, return ()) + +-- | A ModuleDB create/destroy bracket +withModuleDB :: (ModuleDB -> IO a) -> IO a +withModuleDB act = do + chan <- newChan + storageV <- atomically $ newTVar emptyStorage + withAsync (respond chan storageV) $ \asy -> + act $ ModuleDB { requestChan = chan, storage = storageV } + +respond :: Chan (Request, Callback) -> TVar Storage -> IO () +respond chan storageV = forever $ do + storage <- atomically $ readTVar storageV + (req, cb) <- readChan chan + storage' <- execStateT (actOn req) storage + atomically $ writeTVar storageV storage' + cb + +-- | Handle a request, operating with the Storage in the State monad +-- (a helper for respond) +actOn :: Request -> StateT Storage IO () +actOn (Include path) = include path +actOn (Update path) = update path + +-- | Get the current state of ModuleDB's location -> origin map +getSrcMap :: ModuleDB -> FilePath -> IO (Maybe (SrcMap.SrcMap Origin)) +getSrcMap (ModuleDB { storage = storageV }) path = do + storage <- atomically $ readTVar storageV + return $ Map.lookup path $ storage ^. moduleSrcMaps + +-- | Compute a result for the query +answer :: ModuleDB -> String -> Int -> Int -> IO (Maybe Origin) +answer moduleDB path line col = do + mbSrcMap <- getSrcMap moduleDB path + return $ + maybe + (Just $ ResolveError "No information about this module") + (SrcMap.lookup noLoc { srcLine = line, srcColumn = col }) + mbSrcMap diff --git a/Ariadne/ModuleDB/ParseResolve.hs b/Ariadne/ModuleDB/ParseResolve.hs new file mode 100644 --- /dev/null +++ b/Ariadne/ModuleDB/ParseResolve.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-} +module Ariadne.ModuleDB.ParseResolve where + +import Ariadne.GlobalNameIndex +import Ariadne.Index +import Ariadne.Types +import qualified Ariadne.SrcMap as SrcMap +import Ariadne.ModuleDB.Types + + +import Language.Haskell.Names +import Language.Haskell.Names.Interfaces +import Language.Haskell.Names.SyntaxUtils +import Language.Haskell.Names.Imports +import qualified Language.Haskell.Names.GlobalSymbolTable as Global +import Language.Haskell.Exts.Annotated hiding (parse) +import Language.Haskell.Exts.Annotated.CPP +import Distribution.HaskellSuite.Packages +import Distribution.Simple.Compiler (PackageDB(..)) + +import Control.Applicative +import Control.Arrow +import Control.Monad.Trans +import Control.Monad +import Control.Monad.State +import Control.Exception +import Text.Printf +import System.FilePath +import System.Directory +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified System.Log.Logger as L +import Data.Maybe +import qualified Data.Foldable as F +import Data.Proxy +import Data.Lens + +-- | Start to watch the path, and if/when it exists, parse and record it +include :: (MonadState Storage m, MonadIO m) => FilePath -> m () +include path = do + alreadyPresent <- gets (Set.member path . getL watchedFiles) + unless alreadyPresent $ do + liftIO . L.debugM "ariadne.moduledb" $ printf "Including %s in the set of watched files" path + exists <- liftIO $ doesFileExist path + watchedFiles %= Set.insert path + when exists $ update path + +-- | Read/parse/analyse the given path and update the internal state +-- (Storage) accordingly +update + :: (MonadState Storage m, MonadIO m) + => FilePath -- the file to update + -> m () +update path = do + readSources path + + (paths, sources) <- (Map.keys &&& Map.elems) `liftM` access moduleSources + + pkgs <- liftIO $ + ((F.fold <$> mapM (getInstalledPackages (Proxy :: Proxy NamesDB)) [GlobalPackageDB, UserPackageDB]) + :: IO Packages) + + (resolved, impTbls) <- liftIO (liftM unzip $ + (flip evalNamesModuleT pkgs $ do + errs <- computeInterfaces defaultLang defaultExts sources + forM sources $ \parsed -> do + let extSet = moduleExtensions defaultLang defaultExts parsed + impTbl <- fmap snd $ processImports extSet $ getImports parsed + resolved <- annotateModule defaultLang defaultExts parsed + return (resolved, impTbl)) + :: IO ([Module (Scoped SrcSpan)], [Global.Table])) + + let + gIndex :: GlobalNameIndex + gIndex = Map.unions $ + zipWith + (\src impTbl -> mkGlobalNameIndex impTbl (getPointLoc <$> src)) + sources impTbls + + srcMaps :: [SrcMap.SrcMap Origin] + srcMaps = map (mkSrcMap gIndex) resolved + + moduleSrcMaps ~= Map.fromAscList (zip paths srcMaps) + + return () + +-- | Helper for update. Reads/parses the source and also calls include on +-- every imprted module +readSources + :: (MonadState Storage m, MonadIO m) + => FilePath -- the file to update + -> m () +readSources path = do + exists <- liftIO $ doesFileExist path + if not exists + then do + {-liftIO . L.debugM "ariadne.parser" $ + printf "%s: not found at %s" modname path-} + return () + else do + parseResult <- liftIO $ parse path + case parseResult of + ParseFailed loc msg -> do + liftIO . L.warningM "ariadne.parser" $ + printf "Failed to parse %s (%s: %s)" path (prettyPrint loc) msg + return () + ParseOk parsed -> do + let + modname@(ModuleName _ modnameS) = getModuleName parsed + root = rootPath path modname + liftIO . L.debugM "ariadne.parser" $ + printf "Parsed %s at %s" modnameS path + moduleSources %= Map.insert path (srcInfoSpan <$> parsed) + mapM_ (include . modNameToPath root) (importedModules parsed) + +-- these should probably come from the Cabal file +defaultLang = Haskell2010 +defaultExts = [] + +parse :: FilePath -> IO (ParseResult (Module SrcSpanInfo)) +parse path = do + ast <- fmap fst <$> + parseFileWithCommentsAndCPP + defaultCpphsOptions + defaultParseMode + { parseFilename = path + , ignoreLinePragmas = False + , fixities = Just [] } + path + -- Sometimes the AST throws an exception when forcing the result, such + -- as "Ambiguous infix expression". Very annoying! + catch (evaluate ast) $ \e -> + return $ ParseFailed noLoc { srcFilename = path } (show (e :: ErrorCall)) + +-- | Get the module's root path, based on its path and the module name +rootPath :: FilePath -> ModuleName l -> FilePath +rootPath path (ModuleName _ modname) = + -- the algorithm is simple: count the number of components in the module + -- name, and go that number of levels up + let + numLevels = length $ filter (== '.') modname + root = (foldr (.) id $ replicate (numLevels+1) takeDirectory) path + in root + +-- FIXME support lhs etc. +modNameToPath + :: FilePath -- ^ root path + -> ModuleNameS -- ^ module name + -> FilePath -- ^ module path +modNameToPath root name = root map dotToSlash name <.> "hs" + where + dotToSlash '.' = '/' + dotToSlash c = c + +importedModules :: Module a -> [ModuleNameS] +importedModules mod = + map ((\(ModuleName _ s) -> s) . importModule) $ getImports mod diff --git a/Ariadne/ModuleDB/Types.hs b/Ariadne/ModuleDB/Types.hs new file mode 100644 --- /dev/null +++ b/Ariadne/ModuleDB/Types.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE TemplateHaskell #-} +module Ariadne.ModuleDB.Types where + +import qualified Ariadne.SrcMap as SrcMap +import Ariadne.Types + +import Control.Concurrent +import Control.Concurrent.STM +import Data.Monoid +import qualified Data.Set as Set +import qualified Data.Map as Map +import Data.Lens.Template +import Language.Haskell.Exts.Annotated hiding (parse) + +data Request + = Include FilePath + | Update FilePath + +type Callback = IO () + +-- ModuleDB's moduleData should only be modified in the ModuleDB's own +-- thread. Outside, it can only be read. This is inforced by the module +-- system. +data ModuleDB = ModuleDB + { requestChan :: Chan (Request, Callback) + , storage :: TVar Storage + } + +data Storage = Storage + { _watchedFiles :: Set.Set FilePath + , _moduleSources :: Map.Map FilePath (Module SrcSpan) + , _moduleSrcMaps :: Map.Map FilePath (SrcMap.SrcMap Origin) + } + +emptyStorage = Storage mempty mempty mempty + +makeLenses [''Storage] diff --git a/Ariadne/Types.hs b/Ariadne/Types.hs --- a/Ariadne/Types.hs +++ b/Ariadne/Types.hs @@ -1,11 +1,14 @@ module Ariadne.Types where import Language.Haskell.Names +import qualified Language.Haskell.Names.GlobalSymbolTable as Global import Language.Haskell.Exts.Annotated import Distribution.HaskellSuite.Packages import qualified Distribution.ModuleName as Cabal import qualified Data.Map as Map +import qualified Ariadne.SrcMap as SrcMap + data NameLevel = TypeLevel | ValueLevel deriving (Ord, Eq, Show, Enum, Bounded) @@ -16,17 +19,17 @@ -- | Data about a module for which we have source code data ModuleData = ModuleData - { moduleSource :: Module SrcSpan + { modulePath :: FilePath + , moduleSource :: Module SrcSpan , moduleSymbols :: Symbols + , moduleImpTbl :: Global.Table + , moduleResolved :: Module (Scoped SrcSpanInfo) + , moduleGIndex :: GlobalNameIndex + , moduleSrcMap :: SrcMap.SrcMap Origin } --- | A module collection roughly corresponds to a single Cabal package, --- although it doesn't have to be cabalized. --- --- The important thing is that all modules in the collection share the --- same set of package dependencies (including their versions), and --- recursive modules have to be in the same collection. -data ModuleCollection = ModuleCollection - { collectionDeps :: Packages - , collectionModuleData :: Map.Map Cabal.ModuleName ModuleData - } +data Origin + = LocKnown SrcLoc + | LocUnknown ModuleNameS + | ResolveError String + deriving Show diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -20,6 +20,7 @@ Currently, the following editor/IDE plugins exist: * [vim](https://github.com/feuerbach/ariadne-vim) +* [emacs](https://github.com/manzyuk/ariadne-el) Limitations ----------- @@ -60,8 +61,8 @@ find(file, line, column) where `file` is a binary string, `line` and `column` are integers. `file` must -contain the full path to the Haskell source file. It is assumed to be UTF-8 -encoded, although this may improve in the future. +contain the full and canonical path to the Haskell source file. It is assumed to +be UTF-8 encoded, although this may improve in the future. The `line` and `column` should probably be the current cursor position. Ariadne will look up the name at that location. Lines and columns are numbered starting @@ -94,3 +95,11 @@ The message is a binary UTF-8 encoded text, possibly spanning multiple lines. Other requests and responses will probably be added in the future versions. + +Maintainers +----------- + +[Roman Cheplyaka](https://github.com/feuerbach) is the primary maintainer. + +[Oleksandr Manzyuk](https://github.com/manzyuk) is the backup maintainer. Please +get in touch with him if the primary maintainer cannot be reached. diff --git a/ariadne.cabal b/ariadne.cabal --- a/ariadne.cabal +++ b/ariadne.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: ariadne -version: 0.1.2.1 +version: 0.1.2.2 synopsis: Go-to-definition for Haskell description: See homepage: https://github.com/feuerbach/ariadne @@ -27,14 +27,48 @@ Ariadne.SrcMap Ariadne.Index Ariadne.Types + Ariadne.ModuleDB + Ariadne.ModuleDB.Types + Ariadne.ModuleDB.ParseResolve build-depends: base >=4 && <5, - haskell-names >=0.3, - haskell-src-exts >=1.14, + haskell-names >=0.4.1, + haskell-src-exts >=1.16, haskell-packages >=0.2, + hse-cpp >= 0.1, mtl >=2.1, bert >=1.2, utf8-string >=0.3, containers >=0.4, - Cabal >=1.18 + Cabal >=1.16, + hslogger >= 1.2, + filepath, + directory, + tagged, + data-lens, + data-lens-fd, + data-lens-template, + stm, + async, + transformers default-language: Haskell2010 + +Test-suite test + Default-language: + Haskell2010 + Type: + exitcode-stdio-1.0 + Hs-source-dirs: + tests . + Main-is: + test.hs + Build-depends: + base >= 4 && < 5 + , tasty >= 0.7 + , tasty-hunit >= 0.4 + , utf8-string + , filepath + , directory + , bert + , haskell-src-exts + , containers diff --git a/tests/test.hs b/tests/test.hs new file mode 100644 --- /dev/null +++ b/tests/test.hs @@ -0,0 +1,6 @@ +import Test.Tasty +import SrcMapTests +import InvocationTests + +main = defaultMain $ + testGroup "Tests" [srcMapTests, invocationTests]