/ghc-patch/0001-Initial-patch-containing-basic-goal-collection-code.patch

From 23b4e9bc9caf3aa0af0e586a818610c8dcb9959d Mon Sep 17 00:00:00 2001
From: Sebastiaan Visser <sfvisser@cs.uu.nl>
Date: Sun, 19 Apr 2009 21:31:08 +0200
Subject: [PATCH] Initial patch containing basic goal collection code and integration with GHCi.

---
 compiler/ghc.cabal.in          |    4 +-
 compiler/ghci/InteractiveUI.hs |   29 +++-
 compiler/main/GoalCollector.hs |  109 ++++++++++
 compiler/utils/SybUtils.hs     |  431 ++++++++++++++++++++++++++++++++++++++++
 4 files changed, 571 insertions(+), 2 deletions(-)
 create mode 100644 compiler/main/GoalCollector.hs
 create mode 100644 compiler/utils/SybUtils.hs

diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 483303d..a55e92f 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -78,7 +78,7 @@ Library
     GHC-Options: -Wall -fno-warn-name-shadowing -fno-warn-orphans
 
     if flag(ghci)
-        Build-Depends: template-haskell
+        Build-Depends: template-haskell, syb
         CPP-Options: -DGHCI
         Include-Dirs: ../libffi/build/include
 
@@ -425,6 +425,7 @@ Library
         GraphColor
         GraphOps
         GraphPpr
+        GoalCollector
         IOEnv
         Interval
         LazyUniqFM
@@ -438,6 +439,7 @@ Library
         Serialized
         State
         StringBuffer
+        SybUtils
         UniqFM
         UniqSet
         Util
diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index 327cf14..22c1d1d 100644
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -25,6 +25,7 @@ import GHC              ( LoadHowMuch(..), Target(..),  TargetId(..),
                           Module, ModuleName, TyThing(..), Phase,
                           BreakIndex, SrcSpan, Resume, SingleStep,
                           Ghc, handleSourceError )
+import GoalCollector
 import PprTyThing
 import DynFlags
 
@@ -120,6 +121,7 @@ builtin_commands = [
   ("cd",    	keepGoing changeDirectory,	Just filenameWordBreakChars, completeFilename),
   ("check",	keepGoing checkModule,		Nothing, completeHomeModule),
   ("continue",  keepGoing continueCmd,          Nothing, completeNone),
+  ("goals",     keepGoing goalsCmd,             Nothing, completeIdentifier),
   ("cmd",       keepGoing cmdCmd,               Nothing, completeIdentifier),
   ("ctags",	keepGoing createCTagsFileCmd, 	Just filenameWordBreakChars, completeFilename),
   ("def",	keepGoing (defineMacro False),  Nothing, completeIdentifier),
@@ -985,7 +987,6 @@ editFile str =
 chooseEditFile :: GHCi String
 chooseEditFile =
   do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
-
      graph <- GHC.getModuleGraph
      failed_graph <- filterM hasFailed graph
      let order g  = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
@@ -1208,6 +1209,32 @@ modulesLoadedMsg ok mods = do
     Succeeded  ->
        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 
+goalsCmd :: String -> GHCi ()
+goalsCmd s
+  = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
+       let strs = words s
+       dflags <- getDynFlags
+       let pefas = dopt Opt_PrintExplicitForalls dflags
+       case strs of
+         [] -> contextAll dflags ["undefined"]
+         _  -> contextAll dflags strs
+  where
+    contextAll dflags strs = do
+      mods <- getLoadedModules
+      case mods of
+        []    -> io (putStrLn (showSDoc (text "Failed, no loaded modules to query for goals.")))
+        mod:_ ->
+          do prev_context <- GHC.getContext
+             r <- GHC.typecheckModule =<< GHC.parseModule mod
+             let types = goalsFor r strs
+                 pefas = dopt Opt_PrintExplicitForalls dflags
+             mapM_ (\(n, s, ts) -> printForUser $ sep [text n, nest 2 (dcolon <+> pprTypeSpecForUser pefas ts), text " -- Used in", ppr s]) types
+
+pprTypeSpecForUser pefas (ts, ty) =
+  (if null ts
+    then empty
+    else parens (pprWithCommas (pprTypeForUser pefas) ts) <+> text "=>")
+  <+> pprTypeForUser pefas ty
 
 typeOfExpr :: String -> GHCi ()
 typeOfExpr str 
diff --git a/compiler/main/GoalCollector.hs b/compiler/main/GoalCollector.hs
new file mode 100644
index 0000000..b2c1c4e
--- /dev/null
+++ b/compiler/main/GoalCollector.hs
@@ -0,0 +1,109 @@
+module GoalCollector (
+    TypeSpec
+  , GoalInfo
+  , goalsFor
+  ) where
+
+import SrcLoc
+import Var
+import HsSyn
+import NameSet
+import Name hiding (varName)
+import HsTypes
+import Data.Data
+import VarEnv
+import SybUtils
+import Type
+import TypeRep
+import GHC (typecheckedSource, TypecheckedModule)
+
+type TypeSpec =
+  ( [Type] -- ^ Predicate information.
+  , Type   -- ^ The actual goal type.
+  )
+
+type GoalInfo = (String, SrcSpan, TypeSpec)
+
+goalsFor :: TypecheckedModule -> [String] -> [GoalInfo]
+goalsFor mod names =
+     map (\(n, s, ts) -> (n, s, cleanupTypeSpec ts))
+   $ collectGoalInfo names (error "no top-level SrcSpan found") [] (typecheckedSource mod)
+
+cleanupTypeSpec :: TypeSpec -> TypeSpec
+cleanupTypeSpec (preds, ty) = (map tidy preds, tidy ty)
+  where tidy = tidyType emptyTidyEnv
+
+collectGoalInfo :: [String] -> SrcSpan -> [DictId] -> GenericQ [GoalInfo]
+collectGoalInfo goalNames loc dicts x
+        | excluded x = []         
+        | otherwise  = (topQuery `catQ` recQuery)
+                                 `extQ` locChangeCase
+                                 `extQ` predChangeCase $ x
+     where catQ r s x =  r x ++  s x
+           topQuery = mkQ [] (collectGoalInfoVar goalNames loc dicts)
+           recQuery :: GenericQ [GoalInfo]
+           recQuery = concat . gmapQ (collectGoalInfo goalNames loc dicts)
+           locChangeCase :: LHsExpr Id -> [GoalInfo]
+           locChangeCase (L newloc child) = collectGoalInfo goalNames newloc dicts child
+           excluded  = False `mkQ` ((const True) :: NameSet -> Bool)
+           predChangeCase :: HsBind Id -> [GoalInfo]
+           predChangeCase (AbsBinds _ newdicts child1 child2) =
+             let f :: GenericQ [GoalInfo]
+                 f = collectGoalInfo goalNames loc newdicts
+             in f child1 ++ f child2
+           predChangeCase x = recQuery x
+
+collectGoalInfoVar :: [String] -> SrcSpan -> [DictId] -> HsExpr Id -> [GoalInfo]
+collectGoalInfoVar goalNames loc dicts ((HsWrap wrap (HsVar var)))
+  | varNameString var `elem` goalNames = [(varNameString var, loc, typeSpec)]
+  where typeSpec = (map varType dicts, reduceUnwrap wrap (varType var)) 
+collectGoalInfoVar _ _ _ _             = []
+
+varNameString :: Var -> String
+varNameString var = occNameString . nameOccName . varName $ var
+
+reduceUnwrap :: HsWrapper -> Type -> Type
+reduceUnwrap wr ty = reduce_type $ unwrap wr ty
+
+unwrap :: HsWrapper -> Type -> Type
+unwrap WpHole t = t
+unwrap (WpCompose w1 w2) t = unwrap w1 (unwrap w2 t)
+unwrap (WpCast _) t = t -- XXX: really?
+unwrap (WpTyApp t') t = AppTy t t'
+unwrap (WpTyLam tv) t = ForAllTy tv t
+-- do something else with coercion/dict vars?
+unwrap (WpApp v) t = AppTy t (TyVarTy v)
+unwrap (WpLam v) t = ForAllTy v t
+
+-- | Reduce a top-level type application if possible. That is, we perform the
+-- following simplification step:
+-- @
+-- (forall v . t) t' ==> t [t'/v]
+-- @
+-- where @[t'/v]@ is the substitution of @t'@ for @v@.
+--
+reduce_type :: Type -> Type
+reduce_type (AppTy (ForAllTy tv b) t) = reduce_type (subst_type tv t b)
+reduce_type (AppTy a               t) = reduce_type (AppTy (reduce_type a) (reduce_type t))
+reduce_type t = t
+
+subst_type :: TyVar -> Type -> Type -> Type
+subst_type v t' t0 = go t0
+  where
+    go t = case t of
+      TyVarTy tv
+        | tv == v -> t'
+        | otherwise -> t
+      AppTy t1 t2 -> AppTy (go t1) (go t2)
+      TyConApp c ts -> TyConApp c (map go ts)
+      FunTy t1 t2 -> FunTy (go t1) (go t2)
+      ForAllTy v' bt
+        | v == v' -> t
+        | otherwise -> ForAllTy v' (go bt)
+      PredTy pt -> PredTy (go_pt pt)
+
+   -- XXX: this is probably not right
+    go_pt (ClassP c ts) = ClassP c (map go ts)
+    go_pt (IParam i t) = IParam i (go t)
+    go_pt (EqPred t1 t2) = EqPred (go t1) (go t2)
+
diff --git a/compiler/utils/SybUtils.hs b/compiler/utils/SybUtils.hs
new file mode 100644
index 0000000..d589225
--- /dev/null
+++ b/compiler/utils/SybUtils.hs
@@ -0,0 +1,431 @@
+{-# LANGUAGE StandaloneDeriving
+           , DeriveDataTypeable
+           #-}
+module SybUtils where
+
+import SrcLoc
+import RdrName
+import FastString
+import Bag
+import Module
+import BasicTypes
+import Var
+import ForeignCall
+
+import Data.Data
+import NameSet
+import TypeRep
+import qualified TyCon
+
+import HsSyn
+import Name
+import DataCon
+import Class
+
+#include "Typeable.h"
+
+type GenericQ r = forall a. Data a => a -> r
+
+-- | A variation of 'everything', using a 'GenericQ Bool' to skip
+--   parts of the input 'Data'.
+everythingBut :: GenericQ Bool -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r
+everythingBut q k z f x 
+  | q x       = z
+  | otherwise = foldl k (f x) (gmapQ (everythingBut q k z f) x)
+
+-- | The type constructor used in definition of gmapQr
+newtype Qr r a = Qr { unQr  :: r -> r }
+
+-- | Make a generic query;
+--   start from a type-specific case;
+--   return a constant otherwise
+--
+mkQ :: ( Typeable a
+       , Typeable b
+       )
+    => r
+    -> (b -> r)
+    -> a
+    -> r
+(r `mkQ` br) a = case cast a of
+                        Just b  -> br b
+                        Nothing -> r
+
+-- | Extend a generic query by a type-specific case
+extQ :: ( Typeable a
+        , Typeable b
+        )
+     => (a -> q)
+     -> (b -> q)
+     -> a
+     -> q
+extQ f g a = maybe (f a) g (cast a)
+
+-- | A generic query with a right-associative binary operator
+-- gmapQr :: (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r
+-- gmapQr o r0 f x0 = unQr (gfoldl k (const (Qr id)) x0) r0
+--   where
+--     k (Qr c) x = Qr (\r -> c (f x `o` r))
+
+-- | A generic query that processes the immediate subterms and returns a list
+-- of results.  The list is given in the same order as originally specified
+-- in the declaratoin of the data constructors.
+-- gmapQ :: (forall d. Data d => d -> u) -> a -> [u]
+-- gmapQ f = gmapQr (:) [] f
+
+
+
+
+
+-- TODO: good for generalized show, but is this sound in general?
+abstractConstr :: String -> Constr
+abstractConstr   n = mkConstr (abstractDataType n) ("{abstract:"++n++"}") [] Prefix
+
+abstractDataType :: String -> DataType
+abstractDataType n = mkDataType n [abstractConstr n]
+
+-- Typeable0
+
+INSTANCE_TYPEABLE0(SrcSpan,srcSpanTc,"SrcSpan")
+instance Data SrcSpan where
+  -- don't traverse?
+  toConstr _   = abstractConstr "SrcSpan"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "SrcSpan"
+
+INSTANCE_TYPEABLE0(Module,moduleTc,"Module")
+instance Data Module where
+  -- don't traverse?
+  toConstr _   = abstractConstr "Module"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "Module"
+
+INSTANCE_TYPEABLE0(ModuleName,moduleNameTc,"ModuleName")
+instance Data ModuleName where
+  -- don't traverse?
+  toConstr _   = abstractConstr "ModuleName"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "ModuleName"
+
+deriving instance Typeable RdrName
+deriving instance Data RdrName
+
+INSTANCE_TYPEABLE0(OccName,occNameTc,"OccName")
+instance Data OccName where
+  -- don't traverse?
+  toConstr _   = abstractConstr "OccName"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "OccName"
+
+INSTANCE_TYPEABLE0(Name,nameTc,"Name")
+instance Data Name where
+  -- don't traverse?
+  toConstr _   = abstractConstr "Name"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "Name"
+
+deriving instance Typeable FastString
+instance Data FastString where
+  -- don't traverse?
+  toConstr _   = abstractConstr "FastString"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "FastString"
+
+deriving instance Typeable HsExplicitForAll
+deriving instance Data HsExplicitForAll
+
+deriving instance Typeable HsBang
+deriving instance Data HsBang
+
+deriving instance Typeable Boxity
+deriving instance Data Boxity
+
+deriving instance Typeable OverLitVal
+deriving instance Data OverLitVal
+
+deriving instance Typeable RecFlag
+deriving instance Data RecFlag
+
+deriving instance Typeable BasicTypes.Fixity
+deriving instance Data BasicTypes.Fixity
+
+deriving instance Typeable HsArrAppType
+deriving instance Data HsArrAppType
+
+deriving instance Typeable FixityDirection
+deriving instance Data FixityDirection
+
+INSTANCE_TYPEABLE0(DataCon,dataConTc,"DataCon")
+instance Data DataCon where
+  -- don't traverse?
+  toConstr _   = abstractConstr "DataCon"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "DataCon"
+
+INSTANCE_TYPEABLE0(Var,varTc,"Var")
+instance Data Var where
+  -- don't traverse?
+  toConstr _   = abstractConstr "Var"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "Var"
+
+deriving instance Typeable InlineSpec
+deriving instance Data InlineSpec
+
+deriving instance Typeable InlinePragma
+deriving instance Data InlinePragma
+
+deriving instance Typeable RuleMatchInfo
+deriving instance Data RuleMatchInfo
+
+deriving instance Typeable ForeignImport
+deriving instance Data ForeignImport
+
+deriving instance Typeable ForeignExport
+deriving instance Data ForeignExport
+
+deriving instance Typeable CImportSpec
+deriving instance Data CImportSpec
+
+deriving instance Typeable CExportSpec
+deriving instance Data CExportSpec
+
+deriving instance Typeable DNCallSpec
+deriving instance Data DNCallSpec
+
+deriving instance Typeable Safety
+deriving instance Data Safety
+
+deriving instance Typeable CCallConv
+deriving instance Data CCallConv
+
+deriving instance Typeable DNKind
+deriving instance Data DNKind
+
+deriving instance Typeable DNType
+deriving instance Data DNType
+
+deriving instance Typeable CCallTarget
+deriving instance Data CCallTarget
+
+deriving instance Typeable Activation
+deriving instance Data Activation
+
+INSTANCE_TYPEABLE0(NameSet,nameSetTc,"NameSet")
+instance Data NameSet where
+  gfoldl k z s = z mkNameSet `k` nameSetToList s -- traverse abstractly
+  toConstr _   = abstractConstr "NameSet"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "NameSet"
+
+deriving instance Typeable FoType
+deriving instance Data FoType
+
+deriving instance Typeable FamilyFlavour
+deriving instance Data FamilyFlavour
+
+deriving instance Typeable NewOrData
+deriving instance Data NewOrData
+
+INSTANCE_TYPEABLE0(TyCon.TyCon,tyConTc,"TyCon")
+instance Data TyCon.TyCon where
+  -- don't traverse?
+  toConstr _   = abstractConstr "TyCon.TyCon"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "TyCon.TyCon"
+
+INSTANCE_TYPEABLE0(Class,classTc,"Class")
+instance Data Class where
+  -- don't traverse?
+  toConstr _   = abstractConstr "Class"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "Class"
+
+deriving instance Typeable Prag
+deriving instance Data Prag
+
+deriving instance Typeable HsWrapper
+deriving instance Data HsWrapper
+
+deriving instance Typeable PredType
+deriving instance Data PredType
+
+deriving instance Typeable Type
+deriving instance Data Type
+
+deriving instance Typeable HsLit
+deriving instance Data HsLit
+
+-- Typeable1
+
+deriving instance Typeable1 Located
+deriving instance Data e => Data (Located e)
+
+deriving instance Typeable1 HsModule
+deriving instance Data a => Data (HsModule a)
+
+deriving instance Typeable1 HsDoc
+deriving instance Data a => Data (HsDoc a)
+
+deriving instance Typeable1 HaddockModInfo
+deriving instance Data a => Data (HaddockModInfo a)
+
+deriving instance Typeable1 HsDecl
+deriving instance Data a => Data (HsDecl a)
+
+deriving instance Typeable1 ImportDecl
+deriving instance Data a => Data (ImportDecl a)
+
+deriving instance Typeable1 IE
+deriving instance Data a => Data (IE a)
+
+deriving instance Typeable1 TyClDecl
+deriving instance Data a => Data (TyClDecl a)
+
+deriving instance Typeable1 DocDecl
+deriving instance Data a => Data (DocDecl a)
+
+deriving instance Typeable1 SpliceDecl
+deriving instance Data a => Data (SpliceDecl a)
+
+deriving instance Typeable1 RuleDecl
+deriving instance Data a => Data (RuleDecl a)
+
+deriving instance Typeable WarningTxt
+deriving instance Data WarningTxt
+
+deriving instance Typeable1 WarnDecl
+deriving instance Data a => Data (WarnDecl a)
+
+deriving instance Typeable1 ForeignDecl
+deriving instance Data a => Data (ForeignDecl a)
+
+deriving instance Typeable1 DefaultDecl
+deriving instance Data a => Data (DefaultDecl a)
+
+deriving instance Typeable1 Sig
+deriving instance Data a => Data (Sig a)
+
+deriving instance Typeable1 DerivDecl
+deriving instance Data a => Data (DerivDecl a)
+
+deriving instance Typeable1 InstDecl
+deriving instance Data a => Data (InstDecl a)
+
+deriving instance Typeable1 HsPred
+deriving instance Data a => Data (HsPred a)
+
+deriving instance Typeable1 HsType
+deriving instance Data a => Data (HsType a)
+
+deriving instance Typeable1 ConDecl
+deriving instance Data a => Data (ConDecl a)
+
+INSTANCE_TYPEABLE1(Bag,bagTc,"Bag")
+instance Data a => Data (Bag a) where
+  gfoldl k z b = z listToBag `k` bagToList b -- traverse abstract type abstractly
+  toConstr _   = abstractConstr $ "Bag("++show (typeOf (undefined::a))++")"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "Bag"
+
+deriving instance Typeable1 HsTyVarBndr
+deriving instance Data a => Data (HsTyVarBndr a)
+
+deriving instance Typeable1 ResType
+deriving instance Data a => Data (ResType a)
+
+deriving instance Typeable1 HsSplice
+deriving instance Data a => Data (HsSplice a)
+
+deriving instance Typeable1 ConDeclField
+deriving instance Data a => Data (ConDeclField a)
+
+deriving instance Typeable1 IPName
+deriving instance Data a => Data (IPName a)
+
+deriving instance Typeable1 MatchGroup
+deriving instance Data a => Data (MatchGroup a)
+
+deriving instance Typeable1 Pat
+deriving instance Data a => Data (Pat a)
+
+deriving instance Typeable1 GRHSs
+deriving instance Data a => Data (GRHSs a)
+
+deriving instance Typeable1 HsExpr
+deriving instance Data a => Data (HsExpr a)
+
+deriving instance Typeable1 HsQuasiQuote
+deriving instance Data a => Data (HsQuasiQuote a)
+
+deriving instance Typeable1 HsOverLit
+deriving instance Data a => Data (HsOverLit a)
+
+deriving instance Typeable1 ArithSeqInfo
+deriving instance Data a => Data (ArithSeqInfo a)
+
+deriving instance Typeable1 HsBracket
+deriving instance Data a => Data (HsBracket a)
+
+deriving instance Typeable1 HsCmdTop
+deriving instance Data a => Data (HsCmdTop a)
+
+deriving instance Typeable1 HsGroup
+deriving instance Data a => Data (HsGroup a)
+
+deriving instance Typeable1 FixitySig
+deriving instance Data a => Data (FixitySig a)
+
+deriving instance Typeable1 HsIPBinds
+deriving instance Data a => Data (HsIPBinds a)
+
+deriving instance Typeable1 IPBind
+deriving instance Data a => Data (IPBind a)
+
+deriving instance Typeable1 GroupByClause
+deriving instance Data a => Data (GroupByClause a)
+
+deriving instance Typeable1 HsStmtContext
+deriving instance Data a => Data (HsStmtContext a)
+
+deriving instance Typeable1 HsMatchContext
+deriving instance Data a => Data (HsMatchContext a)
+
+deriving instance Typeable1 GRHS
+deriving instance Data a => Data (GRHS a)
+
+deriving instance Typeable1 Match
+deriving instance Data a => Data (Match a)
+
+deriving instance Typeable1 RuleBndr
+deriving instance Data a => Data (RuleBndr a)
+
+-- Typeable2
+
+deriving instance Typeable2 HsBindLR
+deriving instance (Data a,Data b) => Data (HsBindLR a b)
+
+deriving instance Typeable2 StmtLR
+deriving instance (Data a,Data b) => Data (StmtLR a b)
+
+deriving instance Typeable2 HsLocalBindsLR
+deriving instance (Data a,Data b) => Data (HsLocalBindsLR a b)
+
+deriving instance Typeable2 HsValBindsLR
+deriving instance (Data a,Data b) => Data (HsValBindsLR a b)
+
+deriving instance Typeable2 HsConDetails
+deriving instance (Data a,Data b) => Data (HsConDetails a b)
+
+deriving instance Typeable2 HsRecFields
+deriving instance (Data a,Data b) => Data (HsRecFields a b)
+
+deriving instance Typeable2 HsRecField
+deriving instance (Data a,Data b) => Data (HsRecField a b)
+
+deriving instance Data a => Data (AnnDecl a)
+deriving instance Typeable1 AnnDecl
+
+deriving instance Data a => Data (AnnProvenance a)
+deriving instance Typeable1 AnnProvenance
+
-- 
1.5.4.5