Skip to content
Browse files

remove tabs, make GHC7 ready, clean style

  • Loading branch information...
1 parent 1eb5eb6 commit 9e3b6ed3528a94dfe0ae522ac69eb0e0a43f6097 @JPMoresmau committed Mar 18, 2011
View
3 lib/Scion.hs
@@ -21,6 +21,7 @@ module Scion
import Scion.Types
import Scion.Session
import Scion.Cabal
+import Scion.Types.Notes
import Scion.Utils
import GHC
@@ -49,7 +50,7 @@ runScion m = do
runScion' :: [String] -> ScionM a -> IO a
runScion' static_flags act = do
let fname = fsLit "<api-client>"
- lflags = [ L (mkSrcSpan (mkSrcLoc fname line 0) (mkSrcLoc fname line (length s))) s
+ lflags = [ L (mkSrcSpan (mkSrcLoc fname line (scionColToGhcCol 0)) (mkSrcLoc fname line (scionColToGhcCol $ length s))) s
| (s,line) <- zip static_flags [1..] ]
(_leftovers, warnings) <- parseStaticFlags lflags
forM_ warnings $ \(L region msg) ->
View
12 lib/Scion/Cabal.hs
@@ -333,7 +333,7 @@ dependencies cabal_file pd pkgs=let
in DM.assocs $ DM.fromListWith (++) $ ((map (\(a,b)->(a,[b])) cpkgs) ++ (map (\(a,_)->(a,[])) pkgs))
where
#if CABAL_VERSION == 106
- sourcePackageId = package
+ sourcePackageId = package
#endif
buildPkgMap :: (FilePath,[InstalledPackageInfo]) -> DM.Map String [(FilePath,InstalledPackageInfo)] -> DM.Map String [(FilePath,InstalledPackageInfo)]
buildPkgMap (fp,ipis) m=foldr (\i dm->let
@@ -509,8 +509,8 @@ instance JSON CabalPackage where
fromJSON _ = fail "CabalPackage"
toJSON (CabalPackage n v e ds mns)=Dic.makeObject [(Dic.name,JSString (S.pack n)),(Dic.version,JSString (S.pack v)),(Dic.exposed,JSBool e),(Dic.dependent,toJSON ds),(Dic.modules,toJSON mns)]
-instance (Data a) => JSON (PD.ParseResult a) where
- fromJSON _= undefined
- toJSON (PD.ParseFailed pf)=Dic.makeObject [(Dic.error,JSString (S.pack $ show pf))]
- toJSON (PD.ParseOk wrns _)=Dic.makeObject [(Dic.warnings,JSArray (map (JSString . S.pack . show) wrns)),
- (Dic.result,JSObject DM.empty)] --toJSON a
+--instance (Data a) => JSON (PD.ParseResult a) where
+-- fromJSON _= undefined
+-- toJSON (PD.ParseFailed pf)=Dic.makeObject [(Dic.error,JSString (S.pack $ show pf))]
+-- toJSON (PD.ParseOk wrns _)=Dic.makeObject [(Dic.warnings,JSArray (map (JSString . S.pack . show) wrns)),
+-- (Dic.result,JSObject DM.empty)] --toJSON a
View
14 lib/Scion/Inspect.hs
@@ -272,13 +272,13 @@ hsConDeclsNames cons
= snd (foldl do_one ([], []) cons)
where
do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname, con_details = RecCon flds }))
- = (map unLoc new_flds ++ flds_seen, lname : new_flds ++ acc)
- where
- new_flds = filterOut (\f -> unLoc f `elem` flds_seen)
- (map cd_fld_name flds)
+ = (map unLoc new_flds ++ flds_seen, lname : new_flds ++ acc)
+ where
+ new_flds = filterOut (\f -> unLoc f `elem` flds_seen)
+ (map cd_fld_name flds)
do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname }))
- = (flds_seen, lname:acc)
+ = (flds_seen, lname:acc)
#endif
valBinds :: FilePath -> HsGroup Name -> [OutlineDef]
@@ -388,7 +388,7 @@ ghctokensArbitrary base_dir contents = do
let dflags1 = List.foldl' dopt_set dflags0 lexerFlags
#endif
--let dflags1 = dflags0{flags=(Opt_TemplateHaskell:(flags dflags0))}
- let prTS = lexTokenStream sb (mkSrcLoc (mkFastString "<interactive>") 1 0) dflags1
+ let prTS = lexTokenStream sb (mkSrcLoc (mkFastString "<interactive>") 1 (scionColToGhcCol 0)) dflags1
--setSessionDynFlags dflags0
case prTS of
POk _ toks -> return $ Right $ (filter ofInterest toks)
@@ -741,7 +741,7 @@ tokenType ITscc_prag="P"
tokenType ITgenerated_prag="P"
tokenType ITcore_prag="P" -- hdaume: core annotations
tokenType ITunpack_prag="P"
-#if __GLASGOW_HASKELL__ >= 612 && __GLASGOW_HASKELL__ < 700
+#if __GLASGOW_HASKELL__ >= 612
tokenType ITann_prag="P"
#endif
tokenType ITclose_prag="P"
View
35 lib/Scion/Inspect/Find.hs
@@ -14,7 +14,7 @@
--
module Scion.Inspect.Find
( findHsThing, SearchResult(..), SearchResults, Search
- , PosTree(..), PosForest, deepestLeaf, pathToDeepest
+ , PosTree(..), PosForest, deepestLeaf, pathToDeepest, searchBindBag
, surrounds, overlaps
#ifdef SCION_DEBUG
, prop_invCmpOverlap
@@ -180,7 +180,7 @@ only r = S.singleton (Node r S.empty)
above :: SearchResult id -> SearchResults id -> SearchResults id
above r rest = S.singleton (Node r rest)
-instance Search Id Id where
+instance Search id Id where
search _ _ i = only (FoundId i)
instance Search Name Name where
@@ -195,6 +195,22 @@ instance Search id HsLit where
instance Search id id => Search id (IPName id) where
search p s (IPName i) = search p s i
+--instance Search id id => Search id (Located (HsBindLR id id)) where
+-- search p s (L _ a@AbsBinds{})= search p s a
+-- search p _ (L s a)
+-- | p s = search p s a
+-- | otherwise = mempty
+
+-- at least in GHC7 if you have a AbsBind with a type signature the SrcSpan of the AbsBind covers only the type signature...
+searchBindBag :: Search id id => (SrcSpan -> Bool) -> SrcSpan -> Bag (Located (HsBindLR id id)) -> SearchResults id
+searchBindBag p s bs = mconcat $ fmap (searchBinds p s) (F.toList bs)
+
+searchBinds :: Search id id => (SrcSpan -> Bool) -> SrcSpan -> (Located (HsBindLR id id)) -> SearchResults id
+searchBinds p s (L _ a@AbsBinds{})= search p s a -- ignore location of the absbinds
+searchBinds p _ (L s a)
+ | p s = search p s a
+ | otherwise = mempty
+
instance Search id a => Search id (Located a) where
search p _ (L s a)
| p s = search p s a
@@ -222,10 +238,11 @@ instance (Search id id) => Search id (HsBindLR id id) where
case b of
FunBind { fun_id = i, fun_matches = ms } ->
search p s i `mappend` search p s ms
- AbsBinds { abs_binds = bs } -> search p s bs
+ AbsBinds { abs_binds = bs } -> searchBindBag p s bs
PatBind { pat_lhs = lhs, pat_rhs = rhs } ->
search p s lhs `mappend` search p s rhs
- _ -> mempty
+ VarBind { var_rhs = rhs } -> search p s rhs
+
instance (Search id id) => Search id (MatchGroup id) where
search p s (MatchGroup ms _) = search p s ms
@@ -346,7 +363,7 @@ instance (Search id id) => Search id (HsLocalBindsLR id id) where
instance (Search id id) => Search id (HsValBindsLR id id) where
search p s (ValBindsOut rec_binds _) =
- mconcat $ fmap (search p s . snd) rec_binds
+ mconcat $ fmap (searchBindBag p s . snd) rec_binds
search _ _ _ = mempty
instance (Search id id) => Search id (HsCmdTop id) where
@@ -373,7 +390,7 @@ instance (Search id id) => Search id (StmtLR id id) where
GroupStmt ss _ g gg -> search p s ss `mappend` search p s g
`mappend` either (search p s) (const mempty) gg
#endif
- stm | isRecStmt stm -> search p s (recS_stmts stm)
+ RecStmt{recS_stmts=sts} -> search p s sts
--
-- Note [SearchRecStmt]
@@ -462,12 +479,12 @@ instance (Search id id) => Search id (TyClDecl id) where
`mappend` search p s v
`mappend` search p s fd
`mappend` search p s sg
- `mappend` search p s m
+ `mappend` searchBindBag p s m
`mappend` search p s tt
`mappend` search p s dc
instance (Search id id) => Search id (InstDecl id) where
- search p s (InstDecl t b sg dc) = search p s t `mappend` search p s b
+ search p s (InstDecl t b sg dc) = search p s t `mappend` searchBindBag p s b
`mappend` search p s sg
`mappend` search p s dc
@@ -476,7 +493,7 @@ instance (Search id id) => Search id (DerivDecl id) where
instance (Search id id) => Search id (Sig id) where
search p s (TypeSig n t) = search p s n `mappend` search p s t
- search _ _ (IdSig i) = only (FoundId i)
+ search p s (IdSig i) = search p s i
search p s (FixSig n) = search p s n
search p s (InlineSig n _) = search p s n
search p s (SpecSig n t _) = search p s n `mappend` search p s t
View
29 lib/Scion/Inspect/IFaceLoader.hs
@@ -154,7 +154,7 @@ updateModules (m:mods) mCache
>>= updateModules mods
| otherwise
= case Map.lookup m mCache of
- (Just mData) ->
+ (Just mData) ->do
ifM (moduleChanged m (lastModTime mData))
(modDebugMsg m "Updating "
>> cacheIFaceModule m mCache
@@ -169,16 +169,15 @@ unknownPackageId = stringToPackageId "*unknown*"
-- Predicate for detecting if the module's time/date stamp has changed
moduleChanged :: Module -- ^ The module to test
- -> IO ClockTime -- ^ Existing last-modified time of the module
+ -> ClockTime -- ^ Existing last-modified time of the module
-> ScionM Bool -- ^ The result
moduleChanged m modTime = getSession >>= compareMTimes
where
compareMTimes hsc = liftIO (findExactModule hsc m >>= checkMTimes)
-- May return True or False
checkMTimes (Found loc _) =
- modTime
- >>= (\mcMTime -> getModificationTime (ml_hi_file loc)
- >>= (\hiMTime -> return (diffClockTimes mcMTime hiMTime /= noTimeDiff)))
+ getModificationTime (ml_hi_file loc)
+ >>= (\hiMTime -> return (diffClockTimes modTime hiMTime /= noTimeDiff))
-- Ensure that we leave the interface file alone if it cannot be found.
checkMTimes _ = return False
@@ -207,12 +206,13 @@ cacheIFaceModule m cache = getInterfaceFile m >>= readIFace
, hiddenMods = Set.empty
, otherMods = Set.empty
}
- updateModSyms mstate =
+ updateModSyms mstate = do
let fixedMState = fixPrelude m mstate
updMSyms = modSyms fixedMState
- in debugModSymData (exportSyms fixedMState) updMSyms
+ mcd <- liftIO (mkModCacheData fpath updMSyms)
+ debugModSymData (exportSyms fixedMState) updMSyms
>> reportProblems m fixedMState
- >> (return $ Map.insert m (mkModCacheData fpath updMSyms) cache)
+ >> (return $ Map.insert m mcd cache)
in collectInterface initialMState iface
>>= updateModSyms
@@ -252,7 +252,7 @@ cacheHomePackageModule m cache = withSession readHomePackageModule
where
readHomePackageModule hsc =
case lookupUFM (hsc_HPT hsc) (moduleName m) of
- (Just hmi) ->
+ (Just hmi) -> do
let iface = hm_iface hmi
eSet = exportSet iface
initialMState = ModStateT {
@@ -264,12 +264,13 @@ cacheHomePackageModule m cache = withSession readHomePackageModule
, hiddenMods = Set.empty
, otherMods = Set.empty
}
- in collectInterface initialMState iface
- >>= (\mstate ->
+ collectInterface initialMState iface
+ >>= (\mstate ->do
let updMSyms = modSyms mstate
- in (debugModSymData (exportSyms mstate) updMSyms)
+ mcd <- liftIO (mkModCacheData "" updMSyms)
+ (debugModSymData (exportSyms mstate) updMSyms)
>> (reportProblems m mstate)
- >> (return $ Map.insert m (mkModCacheData "" updMSyms) cache))
+ >> (return $ Map.insert m mcd cache))
Nothing -> return cache
-- | Collect declarations from a Haskell interface's mi_usages module usage list.
@@ -431,7 +432,7 @@ unknownModule :: ModuleName
unknownModule = mkModule unknownPackageId
-- | Update a module's type constructor cache. This function extracts the current typechecked module's
--- type constrctors and stashes the resulting completion tuples in the session's module cache. N.B.:
+-- type constructors and stashes the resulting completion tuples in the session's module cache. N.B.:
-- we assume that the current typecheck completed successfully, although that particular case is
-- handled by @extractHomeModuleTyCons@.
updateHomeModuleTyCons :: Maybe BgTcCache
View
2 lib/Scion/Inspect/TypeOf.hs
@@ -36,6 +36,8 @@ typeOf (FoundId ident, path) =
#else
-- unwrap (WpEvApp v) t = AppTy t (TyVarTy v)
unwrap (WpEvLam v) t = ForAllTy v t
+ unwrap (WpEvApp _) t = t
+ unwrap (WpLet _) t = t
#endif
-- unwrap (WpLet _bs) t = t
#ifdef WPINLINE
View
4 lib/Scion/Session.hs
@@ -141,11 +141,11 @@ setComponentTargets (Component c) = setTargets =<< componentTargets c
-- contain the specified component.
--
loadComponent :: Component
- -> ScionM CompilationResult
+ -> ScionM CompilationResult
loadComponent comp = loadComponent' comp defaultLoadOptions
loadComponent' :: Component
- -> LoadOptions -- ^ Should we build on disk?, etc
+ -> LoadOptions -- ^ Should we build on disk?, etc
-> ScionM CompilationResult -- ^ The compilation result.
loadComponent' comp options = do
-- TODO: group warnings by file
View
27 lib/Scion/Types.hs
@@ -462,7 +462,7 @@ type ModuleCache = Map.Map Module ModCacheData
-- | Name to module symbol data associations
data ModCacheData =
ModCacheData {
- lastModTime :: IO ClockTime -- ^ Last modified time for Haskell interface files
+ lastModTime :: ClockTime -- ^ Last modified time for Haskell interface files
, modSymData :: ModSymData -- ^ Module symbol data
, importDecls :: [ImportDecl RdrName] -- ^ Import declarations for home modules
, tyCons :: CompletionTuples -- ^ Last known good type constructor completion tuples
@@ -523,22 +523,27 @@ emptyModuleCache = Map.empty
emptyModCacheData :: ModCacheData
emptyModCacheData =
ModCacheData {
- lastModTime = return (TOD 0 0)
+ lastModTime = TOD 0 0
, modSymData = Map.empty
, importDecls = []
, tyCons = []
}
-- | Make a new module cache record
-mkModCacheData :: FilePath -> ModSymData -> ModCacheData
-mkModCacheData fpath msymData =
- ModCacheData {
- lastModTime = getModificationTime fpath
- , modSymData = msymData
- , importDecls = []
- , tyCons = []
- }
-
+mkModCacheData :: FilePath -> ModSymData -> IO ModCacheData
+mkModCacheData fpath msymData =do
+ mt<-getModificationTime fpath
+ return $
+ ModCacheData {
+ lastModTime = mt
+ , modSymData = msymData
+ , importDecls = []
+ , tyCons = []
+ }
+
+moduleCacheSize :: ModuleCache -> Int
+moduleCacheSize mc=foldr (\(ModCacheData _ msd ids tc) cnt->cnt+(sz msd)+(length ids)+(length tc)) 0 (Map.elems mc)
+ where sz msd=foldr (\s cnt2->cnt2+(Set.size s)) 0 (Map.elems msd)
-- Various predicates for 'ModDeclSymbols'
-- | Does the mod declaration set have a 'MTypeDecl'?
View
19 lib/Scion/Types/Notes.hs
@@ -19,7 +19,7 @@ module Scion.Types.Notes
, overlapLoc
, AbsFilePath(toFilePath), mkAbsFilePath
, Note(..), NoteKind(..), Notes
- , ghcSpanToLocation, ghcErrMsgToNote, ghcWarnMsgToNote
+ , ghcSpanToLocation, ghcErrMsgToNote, ghcWarnMsgToNote, scionColToGhcCol
, ghcMessagesToNotes, trimFile
)
where
@@ -333,17 +333,24 @@ ghcSpanToLocation baseDir sp
| GHC.isGoodSrcSpan sp =
mkLocation (mkLocFile baseDir (GHC.unpackFS (GHC.srcSpanFile sp)))
(GHC.srcSpanStartLine sp)
- (ghcCol2ScionCol $ GHC.srcSpanStartCol sp)
+ (ghcColToScionCol $ GHC.srcSpanStartCol sp)
(GHC.srcSpanEndLine sp)
- (ghcCol2ScionCol $ GHC.srcSpanEndCol sp)
+ (ghcColToScionCol $ GHC.srcSpanEndCol sp)
| otherwise =
mkNoLoc (GHC.showSDoc (GHC.ppr sp))
-ghcCol2ScionCol :: Int -> Int
+ghcColToScionCol :: Int -> Int
#if __GLASGOW_HASKELL__ < 700
-ghcCol2ScionCol c=c -- GHC 6.x starts at 0 for columns
+ghcColToScionCol c=c -- GHC 6.x starts at 0 for columns
#else
-ghcCol2ScionCol c=c-1 -- GHC 7 starts at 1 for columns
+ghcColToScionCol c=c-1 -- GHC 7 starts at 1 for columns
+#endif
+
+scionColToGhcCol :: Int -> Int
+#if __GLASGOW_HASKELL__ < 700
+scionColToGhcCol c=c -- GHC 6.x starts at 0 for columns
+#else
+scionColToGhcCol c=c+1 -- GHC 7 starts at 1 for columns
#endif
-- | Construct a LocSource from a file name, converting the file name to an absolute path when necessary.
View
4 lib/Scion/Types/Outline.hs
@@ -39,8 +39,8 @@ data TokenDef = TokenDef {
extractNames:: [OutlineDef] -> [SDoc]
extractNames
= foldl' (\l od -> case od_name od of
- Left n -> n:l
- Right _ -> l)
+ Left n -> n:l
+ Right _ -> l)
[]
trimLocationFile:: [OutlineDef] -> [OutlineDef]
View
4 lib/Test/GHC/Gen.hs
@@ -17,8 +17,8 @@ instance Arbitrary SrcSpan where
c_len <- choose (1, s+1)
return $
mkSrcSpan
- (mkSrcLoc file l_from c_from)
- (mkSrcLoc file (l_from+l_len) (c_from+c_len))
+ (mkSrcLoc file l_from (scionColToGhcCol c_from))
+ (mkSrcLoc file (l_from+l_len) (scionColToGhcCol $ c_from+c_len))
-- XXX: if l_len > 0 then c_len + c_from >= 0 is enough
{-
instance Show SrcSpan where
View
2 lib/Test/InspectTest.hs
@@ -152,7 +152,7 @@ functionAtLine line=do
r<-runScion $ do
loadComponent' (Component $ FileComp file) (LoadOptions False False)
backgroundTypecheckFile file
- let loc = srcLocSpan $ mkSrcLoc (fsLit file) line 13
+ let loc = srcLocSpan $ mkSrcLoc (fsLit file) line (scionColToGhcCol 13)
tc_res <- getSessionSelector bgTcCache
let s= showSDocForUser O.neverQualify --showSDocDebug
l<-case tc_res of
View
11 server/Scion/Server/Commands.hs
@@ -562,7 +562,7 @@ cmdThingAtPoint =
fileNameArg <&> lineColumnArgs <&> optArg' "qualify" False decodeBool <&> optArg' "typed" True decodeBool $ cmd
where
cmd fname line col qual typed= do
- let loc = srcLocSpan $ mkSrcLoc (fsLit fname) line col
+ let loc = srcLocSpan $ mkSrcLoc (fsLit fname) line (scionColToGhcCol col)
tc_res <- getSessionSelector bgTcCache
case tc_res of
Just (Typechecked tcm) -> do
@@ -573,13 +573,14 @@ cmdThingAtPoint =
-- else doThingAtPointTyped (renamedSource tcm) loc qual tcm
return $ Just tap
_ -> return Nothing
- doThingAtPointTyped :: Search Id a => a -> SrcSpan -> Bool -> TypecheckedModule -> ScionM String
+ doThingAtPointTyped :: TypecheckedSource -> SrcSpan -> Bool -> TypecheckedModule -> ScionM String
doThingAtPointTyped src loc qual tcm=do
let in_range = overlaps loc
- let r = findHsThing in_range src
+ let r = searchBindBag in_range noSrcSpan src
unqual <- if qual
then return $ O.alwaysQualify
else unqualifiedForModule tcm
+ --liftIO $ putStrLn $ showData TypeChecker 2 src
return $ case pathToDeepest r of
Nothing -> "no info"
Just (x,xs) ->
@@ -725,6 +726,8 @@ cmdNameDefinitions :: Cmd
cmdNameDefinitions =
Cmd "name-definitions" $ reqArg' "name" S.toString $ cmd
where cmd nm = do
+-- mc<-getSessionSelector moduleCache
+-- liftIO $ putStrLn $ ("moduleCache values:" ++ (show $ moduleCacheSize mc))
db <- getSessionSelector defSiteDB
let nms=comps nm
--liftIO $ putStrLn $ last nms
@@ -795,7 +798,7 @@ cmdCompletionVarIds = Cmd "completion-varIds" $ fileNameArg $ generateCompletion
-- | Class type name completions: generate the list of class names currently visible within the
-- current module. The IDE is repsonsible for prefix or name filering.
--- FIXME: Use focused_mod here, when available, mimicing bgTypeCheck.
+-- FIXME: Use focused_mod here, when available, mimicking bgTypeCheck.
cmdCompletionClassTypeNames :: Cmd
cmdCompletionClassTypeNames = Cmd "completion-classTypeNames" $ fileNameArg $ generateCompletions getClassTypeNameCompletions

0 comments on commit 9e3b6ed

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