6 files changed, 54 insertions, 7 deletions
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 79f630ef79..a0bc89e535 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -12,7 +12,7 @@ module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
                  PragFun, tcSpecPrags, tcVectDecls, mkPragFun,
                  TcSigInfo(..), TcSigFun,
                  instTcTySig, instTcTySigFromId, findScopedTyVars,
-                 badBootDeclErr ) where
+                 badBootDeclErr, mkExport ) where
 
 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
 import {-# SOURCE #-} TcExpr  ( tcMonoExpr )
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 9503d2b950..9a60ffb8ba 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -487,6 +487,28 @@ tcExpr (HsProc pat cmd) res_ty
   = do  { (pat', cmd', coi) <- tcProc pat cmd res_ty
         ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
 
+tcExpr (HsStatic expr) res_ty
+  = do  { staticPtrTyCon  <- tcLookupTyCon staticPtrTyConName
+        ; (co, [expr_ty]) <- matchExpectedTyConApp staticPtrTyCon res_ty
+        ; (expr', lie)    <- captureConstraints $
+            addErrCtxt (hang (ptext (sLit "In the body of a static form:"))
+                             2 (ppr expr)
+                       ) $
+            tcPolyExprNC expr expr_ty
+        -- Require the type of the argument to be Typeable.
+        -- The evidence is not used, but asking the constraint ensures that
+        -- the current implementation is as restrictive as future versions
+        -- of the StaticPointers extension.
+        ; typeableClass <- tcLookupClass typeableClassName
+        ; _ <- emitWanted StaticOrigin $
+                  mkTyConApp (classTyCon typeableClass)
+                             [liftedTypeKind, expr_ty]
+        -- Insert the static form in a global list for later validation.
+        ; stWC <- tcg_static_wc <$> getGblEnv
+        ; updTcRef stWC (andWC lie)
+        ; return $ mkHsWrapCo co $ HsStatic expr'
+        }
+
 {-
 Note [Rebindable syntax for if]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 8ad8fe2ca0..f14c490844 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -749,6 +749,10 @@ zonkExpr env (HsProc pat body)
         ; new_body <- zonkCmdTop env1 body
         ; return (HsProc new_pat new_body) }
 
+-- StaticPointers extension
+zonkExpr env (HsStatic expr)
+  = HsStatic <$> zonkLExpr env expr
+
 zonkExpr env (HsWrap co_fn expr)
   = do (env1, new_co_fn) <- zonkCoFn env co_fn
        new_expr <- zonkExpr env1 expr
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 6a52de9cae..8ad52ba069 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -464,6 +464,8 @@ tcRnSrcDecls boot_iface exports decls
       ; traceTc "Tc8" empty ;
       ; setEnvs (tcg_env, tcl_env) $
    do {
+        -- wanted constraints from static forms
+        stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ;
 
              --         Finish simplifying class constraints
              --
@@ -480,7 +482,7 @@ tcRnSrcDecls boot_iface exports decls
              --  * the local env exposes the local Ids to simplifyTop,
              --    so that we get better error messages (monomorphism restriction)
         new_ev_binds <- {-# SCC "simplifyTop" #-}
-                        simplifyTop lie ;
+                        simplifyTop (andWC stWC lie) ;
         traceTc "Tc9" empty ;
 
         failIfErrsM ;   -- Don't zonk if there have been errors
@@ -1669,9 +1671,12 @@ tcGhciStmts stmts
                         -- Look up the names right in the middle,
                         -- where they will all be in scope
 
+        -- wanted constraints from static forms
+        stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ;
+
         -- Simplify the context
         traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
-        const_binds <- checkNoErrs (simplifyInteractive lie) ;
+        const_binds <- checkNoErrs (simplifyInteractive (andWC stWC lie)) ;
                 -- checkNoErrs ensures that the plan fails if context redn fails
 
         traceTc "TcRnDriver.tcGhciStmts: done" empty ;
@@ -1756,7 +1761,11 @@ tcRnExpr hsc_env rdr_expr
                                                     False {- No MR for now -}
                                                     [(fresh_it, res_ty)]
                                                     lie ;
-    _ <- simplifyInteractive lie_top ;       -- Ignore the dicionary bindings
+    -- wanted constraints from static forms
+    stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ;
+
+    -- Ignore the dictionary bindings
+    _ <- simplifyInteractive (andWC stWC lie_top) ;
 
     let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
     zonkTcType all_expr_ty
@@ -1833,7 +1842,11 @@ tcRnDeclsi hsc_env local_decls =
         captureConstraints $ tc_rn_src_decls emptyModDetails local_decls
     setEnvs (tcg_env, tclcl_env) $ do
 
-    new_ev_binds <- simplifyTop lie
+    -- wanted constraints from static forms
+    stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef
+
+    new_ev_binds <- simplifyTop (andWC stWC lie)
+
     failIfErrsM
     let TcGblEnv { tcg_type_env  = type_env,
                    tcg_binds     = binds,
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index 2672067cbc..dbc8b41a92 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -94,6 +94,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                            Nothing             -> newIORef emptyNameEnv } ;
 
         dependent_files_var <- newIORef [] ;
+        static_wc_var       <- newIORef emptyWC ;
 #ifdef GHCI
         th_topdecls_var      <- newIORef [] ;
         th_topnames_var      <- newIORef emptyNameSet ;
@@ -161,7 +162,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                 tcg_main           = Nothing,
                 tcg_safeInfer      = infer_var,
                 tcg_dependent_files = dependent_files_var,
-                tcg_tc_plugins     = []
+                tcg_tc_plugins     = [],
+                tcg_static_wc      = static_wc_var
              } ;
              lcl_env = TcLclEnv {
                 tcl_errs       = errs_var,
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 9bc793a831..17d84cbfda 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -91,6 +91,7 @@ module TcRnTypes(
 #include "HsVersions.h"
 
 import HsSyn
+import CoreSyn
 import HscTypes
 import TcEvidence
 import Type
@@ -381,7 +382,10 @@ data TcGblEnv
                                              -- as -XSafe (Safe Haskell)
 
         -- | A list of user-defined plugins for the constraint solver.
-        tcg_tc_plugins :: [TcPluginSolver]
+        tcg_tc_plugins :: [TcPluginSolver],
+
+        tcg_static_wc :: TcRef WantedConstraints
+          -- ^ Wanted constraints of static forms.
     }
 
 -- Note [Signature parameters in TcGblEnv and DynFlags]
@@ -1904,6 +1908,7 @@ data CtOrigin
   | HoleOrigin
   | UnboundOccurrenceOf RdrName
   | ListOrigin          -- An overloaded list
+  | StaticOrigin        -- A static form
 
 ctoHerald :: SDoc
 ctoHerald = ptext (sLit "arising from")
@@ -1975,6 +1980,7 @@ pprCtO (TypeEqOrigin t1 t2)  = ptext (sLit "a type equality") <+> sep [ppr t1, c
 pprCtO AnnOrigin             = ptext (sLit "an annotation")
 pprCtO HoleOrigin            = ptext (sLit "a use of") <+> quotes (ptext $ sLit "_")
 pprCtO ListOrigin            = ptext (sLit "an overloaded list")
+pprCtO StaticOrigin          = ptext (sLit "a static form")
 pprCtO _                     = panic "pprCtOrigin"
 
 {-