diff --git a/Ariadne.hs b/Ariadne.hs new file mode 100644 --- /dev/null +++ b/Ariadne.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE ViewPatterns, OverloadedStrings #-} +module Main where + +import Ariadne.GlobalNameIndex +import Ariadne.Index +import qualified Ariadne.SrcMap as SrcMap + +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 Distribution.HaskellSuite.Packages + +import Control.Applicative +import Control.Monad.Trans +import Control.Monad +import Control.Exception +import Text.Printf + +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 + + ParseOk parsed -> do + + 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) + + let + gIndex = mkGlobalNameIndex impTbl (getPointLoc <$> parsed) + srcMap = mkSrcMap gIndex (fmap srcInfoSpan <$> resolved) + + 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 <- fromHostPort "" 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 $ + case result of + Nothing -> TupleTerm [AtomTerm "no_name"] + Just (LocKnown (SrcLoc file' line' col')) -> + TupleTerm + [ AtomTerm "loc_known" + , BinaryTerm (UTF8.fromString file') + , IntTerm line' + , IntTerm col' + ] + Just (LocUnknown modName) -> + TupleTerm + [ AtomTerm "loc_unknown" + , BinaryTerm (UTF8.fromString modName) + ] + Just (ResolveError er) -> + TupleTerm + [ AtomTerm "error" + , BinaryTerm (UTF8.fromString er) + ] + dispatch _ _ _ = return NoSuchFunction diff --git a/Ariadne/GlobalNameIndex.hs b/Ariadne/GlobalNameIndex.hs new file mode 100644 --- /dev/null +++ b/Ariadne/GlobalNameIndex.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE TupleSections, TypeFamilies #-} +module Ariadne.GlobalNameIndex (mkGlobalNameIndex) where + +import Language.Haskell.Names +import qualified Language.Haskell.Names.GlobalSymbolTable as Global +import Language.Haskell.Names.SyntaxUtils +import Language.Haskell.Names.GetBound +import Language.Haskell.Exts.Annotated +import Distribution.HaskellSuite.Modules +import qualified Data.Map as Map +import Data.Maybe + +import Ariadne.Types + +mkGlobalNameIndex + :: Global.Table -> Module SrcLoc -> GlobalNameIndex +mkGlobalNameIndex tbl mod = + let + Module _ _ _ _ ds = mod + ModuleName _ modname = getModuleName mod + + names = concatMap (indexDecl tbl) ds + + in + Map.fromList + [ ((OrigName Nothing (GName modname (nameToString n)), level), ann n) + | (n, level) <- names + ] + +indexDecl :: Global.Table -> Decl SrcLoc -> [(Name SrcLoc, NameLevel)] +indexDecl tbl d = + case d of + TypeDecl _ dh _ -> [(hname dh, TypeLevel)] + TypeFamDecl _ dh _ -> [(hname dh, TypeLevel)] + + DataDecl _ _ _ dh qualConDecls _ -> + ((hname dh, TypeLevel) :) . map (, ValueLevel) $ do -- list monad + + QualConDecl _ _ _ conDecl <- qualConDecls + case conDecl of + ConDecl _ n _ -> return n + InfixConDecl _ _ n _ -> return n + RecDecl _ n fields -> + n : + [f | FieldDecl _ fNames _ <- fields, f <- fNames] + + GDataDecl _ dataOrNew _ dh _ gadtDecls _ -> + -- As of 1.14.0, HSE doesn't support GADT records. + -- When it does, this code should be rewritten similarly to the + -- DataDecl case. + -- (Also keep in mind that GHC doesn't create selectors for fields + -- with existential type variables.) + (hname dh, TypeLevel) : + [ (cn, ValueLevel) + | GadtDecl _ cn _ <- gadtDecls + ] + + ClassDecl _ _ dh _ mds -> + (hname dh, TypeLevel) : + let + ms = getBound tbl d + cdecls = fromMaybe [] mds + in + (hname dh, TypeLevel) : + [ (hname dh, TypeLevel) | ClsTyFam _ dh _ <- cdecls ] ++ + [ (hname dh, TypeLevel) | ClsDataFam _ _ dh _ <- cdecls ] ++ + [ (mn, ValueLevel) | mn <- ms ] + + FunBind _ ms -> map (, ValueLevel) $ getBound tbl ms + + 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 new file mode 100644 --- /dev/null +++ b/Ariadne/Index.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ScopedTypeVariables, ViewPatterns #-} + +module Ariadne.Index where + +import Language.Haskell.Names +import qualified Language.Haskell.Names.GlobalSymbolTable as Global +import Language.Haskell.Exts.Annotated +import Data.Foldable +import Data.Maybe +import qualified Data.Map as Map + +import Ariadne.Types +import qualified Ariadne.SrcMap as SrcMap + +data Origin + = LocKnown SrcLoc + | LocUnknown ModuleNameS + | ResolveError String + deriving Show + +mkSrcMap + :: Foldable a + => GlobalNameIndex + -> a (Scoped SrcSpan) + -> SrcMap.SrcMap Origin +mkSrcMap gIndex = + foldMap $ \(Scoped nameInfo span) -> + case nameInfo of + LocalValue bindingLoc -> + SrcMap.singleton span (LocKnown bindingLoc) + GlobalValue (sv_origName -> orig) -> + SrcMap.singleton span $ findGlobal ValueLevel orig + GlobalType (st_origName -> orig) -> + SrcMap.singleton span $ findGlobal TypeLevel orig + ScopeError er -> + SrcMap.singleton span $ ResolveError $ ppError er + _ -> SrcMap.empty + where + findGlobal level orig = + maybe + (LocUnknown $ gModule . origGName $ orig) + LocKnown + (Map.lookup (orig, level) gIndex) diff --git a/Ariadne/SrcMap.hs b/Ariadne/SrcMap.hs new file mode 100644 --- /dev/null +++ b/Ariadne/SrcMap.hs @@ -0,0 +1,66 @@ +-- | A map indexed by 'SrcSpan' and addressable by 'SrcLoc'. +-- +-- Notes: +-- +-- * the 'srcFilename' component is ignored +-- +-- * when some of the inserted intervals are overlapping, the behaviour is +-- undefined +{-# LANGUAGE ViewPatterns #-} +module Ariadne.SrcMap + ( SrcMap + , insert + , lookup + , union + , empty + , singleton + ) where + +import Prelude hiding (lookup) +import Language.Haskell.Exts.SrcLoc hiding (Loc(..)) +import qualified Data.Map as Map +import Data.Monoid + +-- | @Loc line column@ +data Loc = Loc !Int !Int + deriving (Eq, Ord, Show) + +newtype SrcMap a = + SrcMap + { unSrcMap :: Map.Map {- end -} Loc ({- start -} Loc, a) + } deriving Show + +instance Monoid (SrcMap a) where + mempty = empty + mappend = union + +spanStart, spanEnd :: SrcSpan -> Loc +spanStart = uncurry Loc . srcSpanStart +spanEnd = uncurry Loc . srcSpanEnd + +fromSrcLoc :: SrcLoc -> Loc +fromSrcLoc SrcLoc { srcLine = line, srcColumn = col } = Loc line col + +insert :: SrcSpan -> a -> SrcMap a -> SrcMap a +insert span value (SrcMap m) = + SrcMap $ Map.insert (spanEnd span) (spanStart span, value) m + +lookup :: SrcLoc -> SrcMap a -> Maybe a +lookup (fromSrcLoc -> loc) (SrcMap map) = + case Map.split loc map of + (_less, greater) + | Map.null greater -> Nothing + | otherwise -> + case Map.findMin greater of + (_, (start, value)) + | start <= loc -> Just value + | otherwise -> Nothing + +union :: SrcMap a -> SrcMap a -> SrcMap a +union (SrcMap a) (SrcMap b) = SrcMap (a `Map.union` b) + +empty :: SrcMap a +empty = SrcMap Map.empty + +singleton :: SrcSpan -> a -> SrcMap a +singleton span value = insert span value empty diff --git a/Ariadne/Types.hs b/Ariadne/Types.hs new file mode 100644 --- /dev/null +++ b/Ariadne/Types.hs @@ -0,0 +1,32 @@ +module Ariadne.Types where + +import Language.Haskell.Names +import Language.Haskell.Exts.Annotated +import Distribution.HaskellSuite.Packages +import qualified Distribution.ModuleName as Cabal +import qualified Data.Map as Map + +data NameLevel = TypeLevel | ValueLevel + deriving (Ord, Eq, Show, Enum, Bounded) + +-- | Global name index records the correspondence between global names and +-- their definition sites. Not every available global name is necessarily +-- in the index. +type GlobalNameIndex = Map.Map (OrigName, NameLevel) SrcLoc + +-- | Data about a module for which we have source code +data ModuleData = ModuleData + { moduleSource :: Module SrcSpan + , moduleSymbols :: Symbols + } + +-- | 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 + } diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +The MIT License (MIT) + +Copyright (c) 2013 Roman Cheplyaka + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of +the Software, and to permit persons to whom the Software is furnished to do so, +subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR +COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,94 @@ +Ariadne +======= + +Ariadne provides a "go-to-definition" functionality for Haskell. + +Usage +----- + +To use Ariadne, you need two things: + +* install this package, `ariadne`, which includes the `ariadne-server` + executable, and make sure this executable is running; +* find and install a plugin for your editor or IDE of choice. + +Editor plugins +-------------- + +Currently, the following editor/IDE plugins exist: + +* [vim](https://github.com/feuerbach/ariadne-vim) + +Limitations +----------- + +As of v0.1, Ariadne only knows about the current file. It won't find definitions +in other files in the same directory, or in the installed packages. It also +won't look in the Cabal file for the language extensions, and a file may fail to +parse because of that. + +These will be addressed in the future versions. + +Creating a plugin +----------------- + +Writing a new Ariadne plugin should be straightforward (assuming you +know how to extend your editor/IDE). + +If you write a new plugin, let me know so I can update the list above, and also +notify you when the protocol changes. + +[bert]: http://bert-rpc.org/ + +### Conventions + +In the protocol description below, we don't use Erlang's upper-case/lower-case +convention, because it would confuse anyone except Erlang or Prolog programmers. +Instead, variables and functions are written lowercase, and atoms are prefixed +with the colon, e.g. `:atom`. + +### Protocol + +You communicate with the Ariadne server via the [BERT-RPC protocol][bert] over +TCP. The server listens on the local TCP port 39014. The BERT-RPC module is +`ariadne`. + +The request has form + + 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. + +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 +from 1. + +The possible responses are: + + { :no_name } + +This means that there's no recognized name at the +given position. The plugin should probably do nothing in this case. + + { :loc_known, file, line, column } + +This means that the name is defined at the given file, line, and column. The +`file` is again a binary UTF-8 encoded full path. The plugin should probably +jump at that location. + + { :loc_unknown, modname } + +We don't know where the name is defined, but we know it comes from the given +module (binary UTF-8 encoded name). The plugin may want to show this +information to the user. + + { :error, message } + +Some error has occurred. For example, the file has a syntax or scoping error. +The plugin is expected to present the error message to the user. + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ariadne.cabal b/ariadne.cabal new file mode 100644 --- /dev/null +++ b/ariadne.cabal @@ -0,0 +1,40 @@ +-- Initial ariadne.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: ariadne +version: 0.1 +synopsis: Go-to-definition for Haskell +description: See https://github.com/feuerbach/ariadne#ariadne +homepage: https://github.com/feuerbach/ariadne +license: MIT +license-file: LICENSE +author: Roman Cheplyaka +maintainer: roma@ro-che.info +-- copyright: +category: Language +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +source-repository head + type: git + location: git@github.com:feuerbach/ariadne.git + +executable ariadne-server + main-is: Ariadne.hs + other-modules: + Ariadne.GlobalNameIndex + Ariadne.SrcMap + Ariadne.Index + Ariadne.Types + build-depends: + base >=4 && <5, + haskell-names >=0.3, + haskell-src-exts >=1.14, + haskell-packages >=0.2, + mtl >=2.1, + bert >=1.1, + utf8-string >=0.3, + containers >=0.5, + Cabal >=1.18 + default-language: Haskell2010