Skip to content
This repository
Browse code

resolved merging conflicts

darcs-hash:20080428191910-34f1c-193e77f8b45910516ba281925ea197876faecabd.gz
  • Loading branch information...
commit 5bf3231416c9dabcff12400f1b0f1e146ab10ae6 1 parent 3c9a492
Leif Frenzel leiffrenzel authored
2  net.sf.eclipsefp.haskell.core/INTERNAL/cohatoe/cohatoe.cabal
@@ -6,4 +6,4 @@ Version: 1.106.0
6 6 Build-depends: base, cohatoe-api, mtl, containers, parsec, array, Cabal, network
7 7 Hs-Source-Dirs: ../../hs-src
8 8 Ghc-options: -Wall -package-name main
9   -Exposed-modules: MakePointFree, ValidateCabalFile, ManipulateCabalFile, GHCOutputParser, ParseGHCOutput, Rename, Marshal, SrcLoc
  9 +Exposed-modules: OrganizeImports, MakePointFree, ValidateCabalFile, ManipulateCabalFile, GHCOutputParser, ParseGHCOutput, EclipseFP.Haskell.Core.Refactor.Rename, EclipseFP.Haskell.Core.Marshal, EclipseFP.Haskell.Core.SrcLoc
6 net.sf.eclipsefp.haskell.ui/INTERNAL/cohatoe/cohatoe.cabal
@@ -3,7 +3,7 @@
3 3 -- sources (in hs-src/).
4 4 Name: cohatoe-plugin
5 5 Version: 1.106.0
6   -Build-depends: base, cohatoe-api, array, containers
7   -Hs-Source-Dirs: ../../hs-src, ../../../net.sf.eclipsefp.haskell.core
  6 +Build-depends: base, cohatoe-api, array, containers, mtl, ghc, filepath, process
  7 +Hs-Source-Dirs: ../../hs-src, ../../../net.sf.eclipsefp.haskell.core/hs-src
8 8 Ghc-options: -Wall -package-name main
9   -Exposed-modules: MarkOccurrences, CodeFolding, HaskellOutline
  9 +Exposed-modules: MarkOccurrences, CodeFolding, HaskellOutline, EclipseFP.Haskell.UI.Hover.EditorTextHover, TypeSignature
217 net.sf.eclipsefp.haskell.ui/hs-src/CodeFolding.hs
... ... @@ -1,148 +1,69 @@
1   -{-# OPTIONS -fglasgow-exts #-}
2   --- | code folding ( ansatz, J. Waldmann )
3   --- version one: using Language.Haskell machinery, NOT GHC API
4   --- that means: parsing, but no import chasing, type checking etc.
5   -module CodeFolding where
6   -
7   -import qualified Language.Haskell.Syntax as S
8   -import qualified Language.Haskell.Parser as P
9   -
10   -import qualified Data.Tree as T
11   -
12   -import Data.Maybe
13   -import System.IO
14   -
15   -import Cohatoe.API
16   -
17   -resource :: Interface
18   -resource = plugin {
19   - pluginMain = performCodeFolding
20   -}
21   -
22   -performCodeFolding :: [String] -> IO [String]
23   -performCodeFolding [] = return []
24   -performCodeFolding (content:_) = return $ marshal $ computeFoldingRegions content
25   -
26   -marshal :: [FoldingRegion] -> [String]
27   -marshal = concatMap mfr where
28   - mfr (NoFoldingRegion) = []
29   - mfr (FoldingRegion start end) = [show start, show end]
30   -
31   --- | see http://leiffrenzel.de/eclipse/wiki/doku.php?id=editorcodefolding
32   -data FoldingRegion
33   - = FoldingRegion Int Int -- ^ start and end line region
34   - | NoFoldingRegion
35   - deriving ( Eq, Show )
36   -
37   -computeFoldingRegions :: String -> [FoldingRegion]
38   -computeFoldingRegions buffer =
39   - let mm = P.parseModuleWithMode ( P.ParseMode { P.parseFilename = "input" } ) buffer
40   - in case mm of
41   - P.ParseFailed loc msg -> error msg
42   - P.ParseOk m ->
43   - let ls = lines buffer
44   - t = rangeInfo ( length ls ) $ Node m
45   - in filter isFoldingRegion $ map fst $ T.flatten t
46   -
47   -isFoldingRegion :: FoldingRegion -> Bool
48   -isFoldingRegion x = case x of
49   - FoldingRegion {} -> True
50   - _ -> False
51   -
52   -
53   -
54   ---------------------------------------------------------------------------------------------
55   -
56   --- | uniform representation of AST nodes
57   -class Show n => NodeC n where
58   - -- | source location ( possibly )
59   - location :: n -> Maybe S.SrcLoc
60   -
61   - -- | children, in order
62   - children :: n -> [ Node ]
63   - children _ = []
64   -
65   -data Node = forall a . NodeC a => Node a
66   -
67   -instance Show Node where
68   - show ( Node n ) = head $ words $ show n
69   -
70   -instance NodeC Node where
71   - location ( Node n ) = location n
72   - children ( Node n ) = children n
73   -
74   -instance NodeC S.HsModule where
75   - location ( S.HsModule p _ _ _ _ ) = Just p
76   - children ( S.HsModule _ name mexports imports decls )
77   - = []
78   - ++ ( map Node $ imports )
79   - ++ ( map Node $ decls )
80   -
81   -instance NodeC S.HsExportSpec where
82   - location x = Nothing
83   -
84   -instance NodeC S.HsImportDecl where
85   - location = Just . S.importLoc
86   -
87   -instance NodeC S.HsDecl where
88   - location x = case x of
89   - S.HsTypeDecl p _ _ _ -> Just p
90   - S.HsDataDecl p _ _ _ _ _ -> Just p
91   - S.HsInfixDecl p _ _ _ -> Just p
92   - S.HsNewTypeDecl p _ _ _ _ _ -> Just p
93   - S.HsClassDecl p _ _ _ _ -> Just p
94   - S.HsInstDecl p _ _ _ _ -> Just p
95   - S.HsDefaultDecl p _ -> Just p
96   - S.HsTypeSig p _ _ -> Just p
97   - S.HsFunBind _ -> Nothing
98   - S.HsPatBind p _ _ _ -> Just p
99   - S.HsForeignImport p _ _ _ _ _ -> Just p
100   - S.HsForeignExport p _ _ _ _ -> Just p
101   - children x = case x of
102   - S.HsDataDecl p _ _ _ cons quals ->
103   - map Node cons -- FIXME: quals do not have srcloc?
104   - S.HsNewTypeDecl p _ _ _ con quals ->
105   - [ Node con ] -- FIXME: quals do not have srcloc?
106   - S.HsClassDecl p _ _ _ decls ->
107   - map Node decls
108   - S.HsInstDecl p _ _ _ decls ->
109   - map Node decls
110   - S.HsFunBind matches ->
111   - map Node matches
112   - S.HsPatBind p _ _ decls ->
113   - map Node decls
114   - _ -> []
115   -
116   -
117   -instance NodeC S.HsConDecl where
118   - location x = case x of
119   - S.HsConDecl p _ _ -> Just p
120   - S.HsRecDecl p _ _ -> Just p
121   -
122   -
123   -instance NodeC S.HsMatch where
124   - location x = case x of
125   - S.HsMatch p _ _ _ _ -> Just p
126   -
127   -
128   ---------------------------------------------------------------------------------------------
129   -
130   --- | given the line number of the next item (or the end-of-file),
131   --- annotate each node by its range
132   -rangeInfo :: Int -> Node -> T.Tree ( FoldingRegion , Node )
133   -rangeInfo end n =
134   - let ( _, [ n' ] ) = rangeInfos end [n]
135   - in n'
136   -
137   -rangeInfos :: Int -> [ Node ] -> ( Int, [ T.Tree ( FoldingRegion , Node ) ] )
138   -rangeInfos end [] = ( end, [] )
139   -rangeInfos end ( n : ns ) =
140   - let ( end', ns' ) = rangeInfos end ns
141   - ( _ , sub ) = rangeInfos end' $ children n
142   - ( start, n' ) = case location n of
143   - Nothing -> ( end', T.Node ( NoFoldingRegion , n ) sub )
144   - Just p -> let here = S.srcLine p
145   - in ( here, T.Node ( FoldingRegion here ( end' - 1) , n ) sub )
146   - in ( start, n' : ns' )
147   -
148   -
  1 +module CodeFolding where
  2 +
  3 +import Control.Monad( liftM )
  4 +import Control.Monad.Error (runErrorT, ErrorT, liftIO, )
  5 +
  6 +import Bag (bagToList, )
  7 +import qualified Data.List as List
  8 +import Data.Maybe (mapMaybe, )
  9 +
  10 +import System.FilePath ((</>))
  11 +
  12 +import qualified Var
  13 +import HsBinds (LHsBinds, )
  14 +import SrcLoc (Located(L), )
  15 +import qualified SrcLoc
  16 +
  17 +import Cohatoe.API
  18 +
  19 +import EclipseFP.Haskell.Core.GHC.Session( getSession )
  20 +import EclipseFP.Haskell.Core.GHC.TypeCheck( typeCheckFiles )
  21 +
  22 +resource :: Interface
  23 +resource = plugin {
  24 + pluginMain = performCodeFolding
  25 +}
  26 +
  27 +-- start and end line of region
  28 +data FoldingRegion = FoldingRegion Int Int deriving (Eq, Show)
  29 +
  30 +performCodeFolding :: [String] -> IO [String]
  31 +performCodeFolding (libDir:srcRoot:file:_) = liftM marshal (computeFoldingRegions libDir srcRoot file)
  32 +performCodeFolding _ = return []
  33 +
  34 +computeFoldingRegions :: FilePath -> FilePath -> FilePath -> IO [FoldingRegion]
  35 +computeFoldingRegions ghcLibDir srcRoot fileName =
  36 + fmap (either (const []) (findFoldingRegions)) $
  37 + runErrorT $
  38 + do session <- liftIO $ getSession ghcLibDir srcRoot
  39 + ghcmods <- typeCheckFiles session [srcRoot </> fileName]
  40 + -- TODO: Is the current module always the last one?
  41 + let (_, _, (_,_,typeCheckedMod,_)) = last ghcmods
  42 + return typeCheckedMod
  43 +
  44 +marshal :: [FoldingRegion] -> [String]
  45 +marshal =
  46 + concatMap (\(FoldingRegion line column) -> [show line, show column])
  47 +
  48 +findFoldingRegions :: -- (OutputableBndr id) =>
  49 + LHsBinds Var.Var -> -- Bag (Located (HsBinds.HsBind id)) ->
  50 + [FoldingRegion]
  51 +findFoldingRegions typeCheckedMod =
  52 + mapMaybe
  53 + (\(L srcSpan _) ->
  54 + if SrcLoc.isGoodSrcSpan srcSpan &&
  55 + not (SrcLoc.isOneLineSpan srcSpan)
  56 + then Just (FoldingRegion
  57 + (SrcLoc.srcSpanStartLine srcSpan)
  58 + (SrcLoc.srcSpanEndLine srcSpan))
  59 + else Nothing) $
  60 + bagToList typeCheckedMod
  61 +
  62 +{-
  63 + (\(L srcSpan _) ->
  64 + case srcSpan of
  65 + SrcSpanMultiLine _ _ _ _ _ ->
  66 + Just $ FoldingRegion
  67 + (srcSpanSLine srcSpan) (srcSpanELine srcSpan)
  68 + _ -> Nothing) $
  69 +-}
45 net.sf.eclipsefp.haskell.ui/hs-src/EclipseFP/Haskell/Core/GHC/Session.hs
... ... @@ -1,8 +1,4 @@
1   -
2   -module Typecheck (
3   - CheckedMod, typecheckFiles, getSysLibDir, getSession,
4   -) where
5   -
  1 +module EclipseFP.Haskell.Core.GHC.Session (getSession, loadModules) where
6 2
7 3 import BasicTypes(failed)
8 4 import Digraph(flattenSCC)
@@ -38,42 +34,9 @@ loadModules session files = do
38 34 when (failed flag)
39 35 (throwError $ "Failed to load all needed modules")
40 36
41   - modgraph <- liftIO $ getModuleGraph session
42   -
43   - let mods = concatMap flattenSCC $ topSortModuleGraph False modgraph Nothing
44   - getModFile = fromJust . ml_hs_file . ms_location
45   - mods'= [ (ms_mod modsum, getModFile modsum) |
46   - modsum <- mods ]
47   -
48   - -- typecheck the argument modules
49   -
50   - forM mods' $ \(mod, file) -> do
51   - mbMod <- liftIO $ checkModule session (moduleName mod) False
52   - case mbMod of
53   - Just (CheckedModule a (Just b) (Just c) (Just d) _)
54   - -> return (mod, file, (a,b,c,d))
55   - _ -> throwError $ "Failed to check module: " ++ moduleString mod
56   -
57   -
58   -
59   -moduleString :: Module -> String
60   -moduleString = moduleNameString . moduleName
61   -
62   -
63   -getSysLibDir :: IO FilePath
64   -getSysLibDir = do
65   - (_, out, _, pid) <- runInteractiveProcess "ghc" ["--print-libdir"] Nothing Nothing
66   - libDir <- hGetLine out
67   - let libDir2 = if ord (last libDir) == 13 -- Windows!
68   - then init libDir
69   - else libDir
70   - waitForProcess pid
71   - return (FilePath.normalise libDir2)
72   -
73   -getSession :: FilePath -> IO Session
74   -getSession srcRoot =
75   - do libDir <- getSysLibDir
76   - session <- newSession (Just libDir)
  37 +getSession :: FilePath -> FilePath -> IO Session
  38 +getSession ghcLibDir srcRoot =
  39 + do session <- newSession (Just ghcLibDir)
77 40 -- we must do that otherwise GHC crashes
78 41 -- getSessionDynFlags session >>= setSessionDynFlags session
79 42 dynFlags0 <- getSessionDynFlags session

0 comments on commit 5bf3231

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