diff --git a/Analyse/Visualise.hs b/Analyse/Visualise.hs --- a/Analyse/Visualise.hs +++ b/Analyse/Visualise.hs @@ -29,18 +29,19 @@ -} module Analyse.Visualise where -import Parsing.Types +import Analyse.Colors import Analyse.GraphRepr import Analyse.Utils -import Analyse.Colors +import Parsing.Types -import Data.Graph.Analysis hiding (Bold) +import Data.Graph.Analysis hiding (Bold) import Data.GraphViz -import Data.GraphViz.Attributes.Complete(Attribute(Margin), DPoint(PVal), createPoint) +import Data.GraphViz.Attributes.Complete (Attribute (Margin), DPoint (PVal), + createPoint) -import Data.Maybe(isNothing) -import Data.List(find) -import qualified Data.Set as S +import Data.List (find) +import Data.Maybe (isNothing) +import qualified Data.Set as S -- ----------------------------------------------------------------------------- @@ -249,7 +250,7 @@ edgeCol :: GData n e -> Edge -> X11Color edgeCol d e = maybe defaultEdgeColor snd - . find hasEdge + . find hasE $ edgeCols d where - hasEdge = S.member e . fst + hasE = S.member e . fst diff --git a/CabalInfo.hs b/CabalInfo.hs --- a/CabalInfo.hs +++ b/CabalInfo.hs @@ -29,13 +29,13 @@ -} module CabalInfo(parseCabal) where -import Distribution.Compiler (CompilerId) +import Distribution.Compiler (CompilerInfo) import Distribution.ModuleName (toFilePath) import Distribution.Package import Distribution.PackageDescription hiding (author) import Distribution.PackageDescription.Configuration import Distribution.PackageDescription.Parse -import Distribution.Simple.Compiler (compilerId) +import Distribution.Simple.Compiler (compilerInfo) import Distribution.Simple.GHC (configure) import Distribution.Simple.Program (defaultProgramConfiguration) import Distribution.System (buildPlatform) @@ -49,8 +49,8 @@ -- ----------------------------------------------------------------------------- -ghcID :: IO CompilerId -ghcID = liftM (compilerId . getCompiler) +ghcID :: IO CompilerInfo +ghcID = liftM (compilerInfo . getCompiler) $ configure silent Nothing Nothing defaultProgramConfiguration where getCompiler (comp,_mplat,_progconfig) = comp diff --git a/Parsing/ParseModule.hs b/Parsing/ParseModule.hs --- a/Parsing/ParseModule.hs +++ b/Parsing/ParseModule.hs @@ -42,7 +42,7 @@ import Data.Char (isUpper) import Data.Foldable (foldrM) import qualified Data.Map as M -import Data.Maybe (catMaybes, fromJust, fromMaybe) +import Data.Maybe (catMaybes, fromJust, fromMaybe, maybeToList) import Data.MultiSet (MultiSet) import qualified Data.MultiSet as MS import Data.Set (Set) @@ -115,7 +115,7 @@ -- | Guesstimate the correct 'Entity' designation for those from -- external modules. createEnt :: ModName -> ImportSpec -> [Entity] -createEnt mn (IVar n) = [Ent mn (nameOf n) NormalEntity] +createEnt mn (IVar _ n) = [Ent mn (nameOf n) NormalEntity] createEnt mn (IThingWith n cs) = map (\c -> Ent mn c (eT c)) cs' where n' = nameOf n @@ -131,7 +131,7 @@ -- | Determine the correct 'Entity' designation for the listed import item. listedEnt :: ParsedModule -> EntityLookup -> ImportSpec -> [Entity] -listedEnt _ el (IVar n) = [lookupEntity' el $ nameOf n] +listedEnt _ el (IVar _ n) = [lookupEntity' el $ nameOf n] listedEnt _ _ IAbs{} = [] listedEnt pm _ (IThingAll n) = esFrom dataDecls ++ esFrom classDecls -- one will be empty @@ -164,7 +164,7 @@ -- Doesn't work on re-exported Class/Data specs. listedExp :: ParsedModule -> EntityLookup -> ExportSpec -> [Entity] -listedExp _ el (EVar qn) = maybe [] (return . lookupEntity el) +listedExp _ el (EVar _ qn) = maybe [] (return . lookupEntity el) $ qName qn listedExp _ _ EAbs{} = [] listedExp pm _ (EThingAll qn) = esFrom dataDecls ++ esFrom classDecls @@ -228,7 +228,7 @@ cl' = M.insert c el $ classDecls pm put $ pm { classDecls = cl' } -- Instance of a class - parseInfo (InstDecl _ _ n ts ids) + parseInfo (InstDecl _ _ _ _ n ts ids) = do let c = snd . fromJust $ qName n d = unwords $ map prettyPrint ts mapM_ (addInstDecl c d) ids @@ -302,7 +302,7 @@ addGConstructors :: ModName -> DataType -> [GadtDecl] -> EntityLookup addGConstructors m d = mkEl . map addGConst where - addGConst (GadtDecl _ n _) = Ent m (nameOf n) (Constructor d) + addGConst (GadtDecl _ n _ _) = Ent m (nameOf n) (Constructor d) -- ----------------------------------------------------------------------------- -- Class declaration @@ -499,8 +499,6 @@ getPat (PVar n) = return $ onlyVar n -- Literal value getPat PLit{} = return noEnts --- Negation of a Pat value -getPat (PNeg p) = getPat p -- n + k pattern getPat (PNPlusK n _) = return $ onlyVar n -- e.g. a : as @@ -552,7 +550,7 @@ -- Record wildcards: nothing returned getPField :: PatField -> PState DefCalled getPField (PFieldPat qn p) = liftM (second $ insQName qn) $ getPat p -getPField (PFieldPun n) = return (S.empty, MS.singleton $ nameOf' n) +getPField (PFieldPun n) = return (S.empty, MS.fromList . maybeToList $ qName n) getPField PFieldWildcard = return noEnts -- Still have to take care of function calls here somewhere... @@ -568,12 +566,12 @@ getDecl :: Decl -> PState DefCalled getDecl (FunBind ms) = liftM sMsUnions $ mapM getMatch ms -getDecl (PatBind _ p _ r bs) = do (pd,pc) <- getPat p - rc <- getRHS r - (bd,bc) <- getBindings bs - let fs = MS.unions [pc, rc, bc] - cs = defElsewhere fs bd - return (pd, cs) +getDecl (PatBind _ p r bs) = do (pd,pc) <- getPat p + rc <- getRHS r + (bd,bc) <- getBindings bs + let fs = MS.unions [pc, rc, bc] + cs = defElsewhere fs bd + return (pd, cs) getDecl _ = return noEnts @@ -666,25 +664,16 @@ getFUpdate :: FieldUpdate -> PState Called getFUpdate (FieldUpdate qn e) = liftM (MS.union (maybeEnt qn)) $ getExp e -getFUpdate (FieldPun n) = return . MS.singleton $ nameOf' n +getFUpdate (FieldPun n) = return . MS.fromList . maybeToList $ qName n getFUpdate _ = return MS.empty getAlt :: Alt -> PState Called getAlt (Alt _ p gas bs) = do (pd,pc) <- getPat p - gc <- getGAlts gas + gc <- getRHS gas (bd,bc) <- getBindings bs let d = pd `S.union` bd c = pc `MS.union` gc `MS.union` bc return $ defElsewhere c d - -getGAlts :: GuardedAlts -> PState Called -getGAlts (UnGuardedAlt e) = getExp e -getGAlts (GuardedAlts gas) = liftM MS.unions $ mapM getGAlt gas - -getGAlt :: GuardedAlt -> PState Called -getGAlt (GuardedAlt _ ss e) = do (sf, sc) <- getStmts ss - ec <- getExp e - return $ defElsewhere' sf (MS.union sc ec) getStmt :: Stmt -> PState DefCalled getStmt (Generator _ p e) = do (pf,pc) <- getPat p diff --git a/Parsing/State.hs b/Parsing/State.hs --- a/Parsing/State.hs +++ b/Parsing/State.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} {- Copyright (C) 2009 Ivan Lazar Miljenovic @@ -45,6 +45,10 @@ import Control.Monad.RWS +#if !(MIN_VERSION_base (4,8,0)) +import Control.Applicative (Applicative) +#endif + -- ----------------------------------------------------------------------------- runPState :: ParsedModules -> ModuleNames @@ -68,7 +72,7 @@ = PS { runPS :: RWS ModuleData ModuleWrite ParsedModule value } -- Note: don't derive MonadReader, etc. as don't want anything -- outside this module to get the actual types used. - deriving (Monad, MonadState ParsedModule, MonadWriter ModuleWrite) + deriving (Functor, Applicative, Monad, MonadState ParsedModule, MonadWriter ModuleWrite) asks' :: (ModuleData -> a) -> PState a asks' = PS . asks diff --git a/SourceGraph.cabal b/SourceGraph.cabal --- a/SourceGraph.cabal +++ b/SourceGraph.cabal @@ -1,5 +1,5 @@ Name: SourceGraph -Version: 0.7.0.6 +Version: 0.7.0.7 Synopsis: Static code analysis using graph-theoretic techniques. Description: { Statically analyse Haskell source code using graph-theoretic @@ -42,9 +42,12 @@ Extra-Source-Files: TODO ChangeLog +Tested-With: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, + GHC == 7.10.2, GHC == 7.11.* + Source-Repository head - Type: darcs - Location: http://code.haskell.org/SourceGraph + Type: git + Location: https://github.com/ivan-m/SourceGraph Executable SourceGraph { @@ -65,7 +68,7 @@ Analyse.Everything, Paths_SourceGraph Ghc-Options: -Wall - Ghc-Prof-Options: -prof -auto-all + Ghc-Prof-Options: -prof Build-Depends: base == 4.*, containers, @@ -76,7 +79,7 @@ mtl, fgl == 5.5.*, Graphalyze >= 0.14.1.0 && < 0.15, - graphviz >= 2999.15.0.0 && < 2999.18, - Cabal >= 1.18.0 && < 1.21, - haskell-src-exts == 1.15.* + graphviz >= 2999.15.0.0 && < 2999.19, + Cabal == 1.22.*, + haskell-src-exts == 1.16.* }