packages feed

ariadne 0.1.2.1 → 0.1.2.2

raw patch · 10 files changed

+407/−74 lines, 10 filesdep +asyncdep +data-lensdep +data-lens-fddep ~Cabaldep ~bertdep ~containers

Dependencies added: async, data-lens, data-lens-fd, data-lens-template, directory, filepath, hse-cpp, hslogger, stm, tagged, tasty, tasty-hunit, transformers

Dependency ranges changed: Cabal, bert, containers, haskell-names, haskell-src-exts, utf8-string

Files

Ariadne.hs view
@@ -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
Ariadne/GlobalNameIndex.hs view
@@ -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
Ariadne/Index.hs view
@@ -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
+ Ariadne/ModuleDB.hs view
@@ -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
+ Ariadne/ModuleDB/ParseResolve.hs view
@@ -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
+ Ariadne/ModuleDB/Types.hs view
@@ -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]
Ariadne/Types.hs view
@@ -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
README.md view
@@ -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.
ariadne.cabal view
@@ -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 <https://github.com/feuerbach/ariadne#ariadne> 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
+ tests/test.hs view
@@ -0,0 +1,6 @@+import Test.Tasty+import SrcMapTests+import InvocationTests++main = defaultMain $+  testGroup "Tests" [srcMapTests, invocationTests]