Skip to content
Browse files

resolved merging conflicts

darcs-hash:20080428191910-34f1c-193e77f8b45910516ba281925ea197876faecabd.gz
  • Loading branch information...
1 parent 3c9a492 commit 5bf3231416c9dabcff12400f1b0f1e146ab10ae6 @leiffrenzel leiffrenzel committed Apr 28, 2008
View
2 net.sf.eclipsefp.haskell.core/INTERNAL/cohatoe/cohatoe.cabal
@@ -6,4 +6,4 @@ Version: 1.106.0
Build-depends: base, cohatoe-api, mtl, containers, parsec, array, Cabal, network
Hs-Source-Dirs: ../../hs-src
Ghc-options: -Wall -package-name main
-Exposed-modules: MakePointFree, ValidateCabalFile, ManipulateCabalFile, GHCOutputParser, ParseGHCOutput, Rename, Marshal, SrcLoc
+Exposed-modules: OrganizeImports, MakePointFree, ValidateCabalFile, ManipulateCabalFile, GHCOutputParser, ParseGHCOutput, EclipseFP.Haskell.Core.Refactor.Rename, EclipseFP.Haskell.Core.Marshal, EclipseFP.Haskell.Core.SrcLoc
View
6 net.sf.eclipsefp.haskell.ui/INTERNAL/cohatoe/cohatoe.cabal
@@ -3,7 +3,7 @@
-- sources (in hs-src/).
Name: cohatoe-plugin
Version: 1.106.0
-Build-depends: base, cohatoe-api, array, containers
-Hs-Source-Dirs: ../../hs-src, ../../../net.sf.eclipsefp.haskell.core
+Build-depends: base, cohatoe-api, array, containers, mtl, ghc, filepath, process
+Hs-Source-Dirs: ../../hs-src, ../../../net.sf.eclipsefp.haskell.core/hs-src
Ghc-options: -Wall -package-name main
-Exposed-modules: MarkOccurrences, CodeFolding, HaskellOutline
+Exposed-modules: MarkOccurrences, CodeFolding, HaskellOutline, EclipseFP.Haskell.UI.Hover.EditorTextHover, TypeSignature
View
217 net.sf.eclipsefp.haskell.ui/hs-src/CodeFolding.hs
@@ -1,148 +1,69 @@
-{-# OPTIONS -fglasgow-exts #-}
--- | code folding ( ansatz, J. Waldmann )
--- version one: using Language.Haskell machinery, NOT GHC API
--- that means: parsing, but no import chasing, type checking etc.
-module CodeFolding where
-
-import qualified Language.Haskell.Syntax as S
-import qualified Language.Haskell.Parser as P
-
-import qualified Data.Tree as T
-
-import Data.Maybe
-import System.IO
-
-import Cohatoe.API
-
-resource :: Interface
-resource = plugin {
- pluginMain = performCodeFolding
-}
-
-performCodeFolding :: [String] -> IO [String]
-performCodeFolding [] = return []
-performCodeFolding (content:_) = return $ marshal $ computeFoldingRegions content
-
-marshal :: [FoldingRegion] -> [String]
-marshal = concatMap mfr where
- mfr (NoFoldingRegion) = []
- mfr (FoldingRegion start end) = [show start, show end]
-
--- | see http://leiffrenzel.de/eclipse/wiki/doku.php?id=editorcodefolding
-data FoldingRegion
- = FoldingRegion Int Int -- ^ start and end line region
- | NoFoldingRegion
- deriving ( Eq, Show )
-
-computeFoldingRegions :: String -> [FoldingRegion]
-computeFoldingRegions buffer =
- let mm = P.parseModuleWithMode ( P.ParseMode { P.parseFilename = "input" } ) buffer
- in case mm of
- P.ParseFailed loc msg -> error msg
- P.ParseOk m ->
- let ls = lines buffer
- t = rangeInfo ( length ls ) $ Node m
- in filter isFoldingRegion $ map fst $ T.flatten t
-
-isFoldingRegion :: FoldingRegion -> Bool
-isFoldingRegion x = case x of
- FoldingRegion {} -> True
- _ -> False
-
-
-
---------------------------------------------------------------------------------------------
-
--- | uniform representation of AST nodes
-class Show n => NodeC n where
- -- | source location ( possibly )
- location :: n -> Maybe S.SrcLoc
-
- -- | children, in order
- children :: n -> [ Node ]
- children _ = []
-
-data Node = forall a . NodeC a => Node a
-
-instance Show Node where
- show ( Node n ) = head $ words $ show n
-
-instance NodeC Node where
- location ( Node n ) = location n
- children ( Node n ) = children n
-
-instance NodeC S.HsModule where
- location ( S.HsModule p _ _ _ _ ) = Just p
- children ( S.HsModule _ name mexports imports decls )
- = []
- ++ ( map Node $ imports )
- ++ ( map Node $ decls )
-
-instance NodeC S.HsExportSpec where
- location x = Nothing
-
-instance NodeC S.HsImportDecl where
- location = Just . S.importLoc
-
-instance NodeC S.HsDecl where
- location x = case x of
- S.HsTypeDecl p _ _ _ -> Just p
- S.HsDataDecl p _ _ _ _ _ -> Just p
- S.HsInfixDecl p _ _ _ -> Just p
- S.HsNewTypeDecl p _ _ _ _ _ -> Just p
- S.HsClassDecl p _ _ _ _ -> Just p
- S.HsInstDecl p _ _ _ _ -> Just p
- S.HsDefaultDecl p _ -> Just p
- S.HsTypeSig p _ _ -> Just p
- S.HsFunBind _ -> Nothing
- S.HsPatBind p _ _ _ -> Just p
- S.HsForeignImport p _ _ _ _ _ -> Just p
- S.HsForeignExport p _ _ _ _ -> Just p
- children x = case x of
- S.HsDataDecl p _ _ _ cons quals ->
- map Node cons -- FIXME: quals do not have srcloc?
- S.HsNewTypeDecl p _ _ _ con quals ->
- [ Node con ] -- FIXME: quals do not have srcloc?
- S.HsClassDecl p _ _ _ decls ->
- map Node decls
- S.HsInstDecl p _ _ _ decls ->
- map Node decls
- S.HsFunBind matches ->
- map Node matches
- S.HsPatBind p _ _ decls ->
- map Node decls
- _ -> []
-
-
-instance NodeC S.HsConDecl where
- location x = case x of
- S.HsConDecl p _ _ -> Just p
- S.HsRecDecl p _ _ -> Just p
-
-
-instance NodeC S.HsMatch where
- location x = case x of
- S.HsMatch p _ _ _ _ -> Just p
-
-
---------------------------------------------------------------------------------------------
-
--- | given the line number of the next item (or the end-of-file),
--- annotate each node by its range
-rangeInfo :: Int -> Node -> T.Tree ( FoldingRegion , Node )
-rangeInfo end n =
- let ( _, [ n' ] ) = rangeInfos end [n]
- in n'
-
-rangeInfos :: Int -> [ Node ] -> ( Int, [ T.Tree ( FoldingRegion , Node ) ] )
-rangeInfos end [] = ( end, [] )
-rangeInfos end ( n : ns ) =
- let ( end', ns' ) = rangeInfos end ns
- ( _ , sub ) = rangeInfos end' $ children n
- ( start, n' ) = case location n of
- Nothing -> ( end', T.Node ( NoFoldingRegion , n ) sub )
- Just p -> let here = S.srcLine p
- in ( here, T.Node ( FoldingRegion here ( end' - 1) , n ) sub )
- in ( start, n' : ns' )
-
-
+module CodeFolding where
+
+import Control.Monad( liftM )
+import Control.Monad.Error (runErrorT, ErrorT, liftIO, )
+
+import Bag (bagToList, )
+import qualified Data.List as List
+import Data.Maybe (mapMaybe, )
+
+import System.FilePath ((</>))
+
+import qualified Var
+import HsBinds (LHsBinds, )
+import SrcLoc (Located(L), )
+import qualified SrcLoc
+
+import Cohatoe.API
+
+import EclipseFP.Haskell.Core.GHC.Session( getSession )
+import EclipseFP.Haskell.Core.GHC.TypeCheck( typeCheckFiles )
+
+resource :: Interface
+resource = plugin {
+ pluginMain = performCodeFolding
+}
+
+-- start and end line of region
+data FoldingRegion = FoldingRegion Int Int deriving (Eq, Show)
+
+performCodeFolding :: [String] -> IO [String]
+performCodeFolding (libDir:srcRoot:file:_) = liftM marshal (computeFoldingRegions libDir srcRoot file)
+performCodeFolding _ = return []
+
+computeFoldingRegions :: FilePath -> FilePath -> FilePath -> IO [FoldingRegion]
+computeFoldingRegions ghcLibDir srcRoot fileName =
+ fmap (either (const []) (findFoldingRegions)) $
+ runErrorT $
+ do session <- liftIO $ getSession ghcLibDir srcRoot
+ ghcmods <- typeCheckFiles session [srcRoot </> fileName]
+ -- TODO: Is the current module always the last one?
+ let (_, _, (_,_,typeCheckedMod,_)) = last ghcmods
+ return typeCheckedMod
+
+marshal :: [FoldingRegion] -> [String]
+marshal =
+ concatMap (\(FoldingRegion line column) -> [show line, show column])
+
+findFoldingRegions :: -- (OutputableBndr id) =>
+ LHsBinds Var.Var -> -- Bag (Located (HsBinds.HsBind id)) ->
+ [FoldingRegion]
+findFoldingRegions typeCheckedMod =
+ mapMaybe
+ (\(L srcSpan _) ->
+ if SrcLoc.isGoodSrcSpan srcSpan &&
+ not (SrcLoc.isOneLineSpan srcSpan)
+ then Just (FoldingRegion
+ (SrcLoc.srcSpanStartLine srcSpan)
+ (SrcLoc.srcSpanEndLine srcSpan))
+ else Nothing) $
+ bagToList typeCheckedMod
+
+{-
+ (\(L srcSpan _) ->
+ case srcSpan of
+ SrcSpanMultiLine _ _ _ _ _ ->
+ Just $ FoldingRegion
+ (srcSpanSLine srcSpan) (srcSpanELine srcSpan)
+ _ -> Nothing) $
+-}
View
45 net.sf.eclipsefp.haskell.ui/hs-src/EclipseFP/Haskell/Core/GHC/Session.hs
@@ -1,8 +1,4 @@
-
-module Typecheck (
- CheckedMod, typecheckFiles, getSysLibDir, getSession,
-) where
-
+module EclipseFP.Haskell.Core.GHC.Session (getSession, loadModules) where
import BasicTypes(failed)
import Digraph(flattenSCC)
@@ -38,42 +34,9 @@ loadModules session files = do
when (failed flag)
(throwError $ "Failed to load all needed modules")
- modgraph <- liftIO $ getModuleGraph session
-
- let mods = concatMap flattenSCC $ topSortModuleGraph False modgraph Nothing
- getModFile = fromJust . ml_hs_file . ms_location
- mods'= [ (ms_mod modsum, getModFile modsum) |
- modsum <- mods ]
-
- -- typecheck the argument modules
-
- forM mods' $ \(mod, file) -> do
- mbMod <- liftIO $ checkModule session (moduleName mod) False
- case mbMod of
- Just (CheckedModule a (Just b) (Just c) (Just d) _)
- -> return (mod, file, (a,b,c,d))
- _ -> throwError $ "Failed to check module: " ++ moduleString mod
-
-
-
-moduleString :: Module -> String
-moduleString = moduleNameString . moduleName
-
-
-getSysLibDir :: IO FilePath
-getSysLibDir = do
- (_, out, _, pid) <- runInteractiveProcess "ghc" ["--print-libdir"] Nothing Nothing
- libDir <- hGetLine out
- let libDir2 = if ord (last libDir) == 13 -- Windows!
- then init libDir
- else libDir
- waitForProcess pid
- return (FilePath.normalise libDir2)
-
-getSession :: FilePath -> IO Session
-getSession srcRoot =
- do libDir <- getSysLibDir
- session <- newSession (Just libDir)
+getSession :: FilePath -> FilePath -> IO Session
+getSession ghcLibDir srcRoot =
+ do session <- newSession (Just ghcLibDir)
-- we must do that otherwise GHC crashes
-- getSessionDynFlags session >>= setSessionDynFlags session
dynFlags0 <- getSessionDynFlags session

0 comments on commit 5bf3231

Please sign in to comment.
Something went wrong with that request. Please try again.