[project @ 2005-10-26 10:23:47 by simonpj]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcSplice.lhs
index 4b2c7e5..1262674 100644 (file)
@@ -22,30 +22,30 @@ import HsSyn                ( HsBracket(..), HsExpr(..), HsSplice(..), LHsExpr, LHsDecl,
 import Convert         ( convertToHsExpr, convertToHsDecls, convertToHsType, thRdrName )
 import RnExpr          ( rnLExpr )
 import RnEnv           ( lookupFixityRn, lookupSrcOcc_maybe, lookupImportedName )
-import RdrName         ( RdrName, mkRdrQual, mkRdrUnqual, lookupLocalRdrEnv, isSrcRdrName )
+import RdrName         ( RdrName, lookupLocalRdrEnv, isSrcRdrName )
 import RnTypes         ( rnLHsType )
 import TcExpr          ( tcCheckRho, tcMonoExpr )
-import TcHsSyn         ( mkHsLet, zonkTopLExpr )
+import TcHsSyn         ( mkHsDictLet, zonkTopLExpr )
 import TcSimplify      ( tcSimplifyTop, tcSimplifyBracket )
 import TcUnify         ( Expected, zapExpectedTo, zapExpectedType )
 import TcType          ( TcType, TcKind, liftedTypeKind, mkAppTy, tcSplitSigmaTy )
 import TcEnv           ( spliceOK, tcMetaTy, bracketOK )
-import TcMType         ( newTyFlexiVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType, zonkTcTyVar )
+import TcMType         ( newTyFlexiVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType )
 import TcHsType                ( tcHsSigType, kcHsType )
 import TcIface         ( tcImportDecl )
 import TypeRep         ( Type(..), PredType(..), TyThing(..) ) -- For reification
 import Name            ( Name, NamedThing(..), nameOccName, nameModule, isExternalName, 
-                         mkInternalName, nameIsLocalOrFrom )
+                         nameIsLocalOrFrom )
 import NameEnv         ( lookupNameEnv )
 import HscTypes                ( lookupType, ExternalPackageState(..), emptyModDetails )
 import OccName
 import Var             ( Id, TyVar, idType )
-import Module          ( moduleUserString, mkModule )
+import Module          ( moduleUserString )
 import TcRnMonad
 import IfaceEnv                ( lookupOrig )
 import Class           ( Class, classExtraBigSig )
-import TyCon           ( TyCon, AlgTyConRhs(..), tyConTyVars, getSynTyConDefn, 
-                         isSynTyCon, isNewTyCon, tyConDataCons, algTyConRhs, isPrimTyCon, isFunTyCon,
+import TyCon           ( TyCon, tyConTyVars, getSynTyConDefn, 
+                         isSynTyCon, isNewTyCon, tyConDataCons, isPrimTyCon, isFunTyCon,
                          tyConArity, tyConStupidTheta, isUnLiftedTyCon )
 import DataCon         ( DataCon, dataConTyCon, dataConOrigArgTys, dataConStrictMarks, 
                          dataConName, dataConFieldLabels, dataConWrapId, dataConIsInfix, 
@@ -55,7 +55,7 @@ import IdInfo         ( GlobalIdDetails(..) )
 import TysWiredIn      ( mkListTy )
 import DsMeta          ( expQTyConName, typeQTyConName, decTyConName, qTyConName, nameTyConName )
 import ErrUtils                ( Message )
-import SrcLoc          ( noLoc, unLoc, getLoc, noSrcLoc )
+import SrcLoc          ( noLoc, unLoc, getLoc )
 import Outputable
 import Unique          ( Unique, Uniquable(..), getKey, mkUniqueGrimily )
 
@@ -65,7 +65,6 @@ import FastString     ( LitString )
 
 import GHC.Base                ( unsafeCoerce#, Int#, Int(..) )        -- Should have a better home in the module hierarchy
 import Monad           ( liftM )
-import Maybes          ( orElse )
 
 #ifdef GHCI
 import FastString      ( mkFastString )
@@ -126,8 +125,7 @@ tcBracket brack res_ty
 
 tc_bracket :: HsBracket Name -> TcM TcType
 tc_bracket (VarBr v) 
-  = tcMetaTy nameTyConName
-       -- Result type is Var (not Q-monadic)
+  = tcMetaTy nameTyConName     -- Result type is Var (not Q-monadic)
 
 tc_bracket (ExpBr expr) 
   = newTyFlexiVarTy liftedTypeKind     `thenM` \ any_ty ->
@@ -141,14 +139,15 @@ tc_bracket (TypBr typ)
        -- Result type is Type (= Q Typ)
 
 tc_bracket (DecBr decls)
-  = tcTopSrcDecls emptyModDetails decls                `thenM_`
+  = do { tcTopSrcDecls emptyModDetails decls
        -- Typecheck the declarations, dicarding the result
        -- We'll get all that stuff later, when we splice it in
 
-    tcMetaTy decTyConName      `thenM` \ decl_ty ->
-    tcMetaTy qTyConName                `thenM` \ q_ty ->
-    returnM (mkAppTy q_ty (mkListTy decl_ty))
+       ; decl_ty <- tcMetaTy decTyConName
+       ; q_ty    <- tcMetaTy qTyConName
+       ; return (mkAppTy q_ty (mkListTy decl_ty))
        -- Result type is Q [Dec]
+    }
 \end{code}
 
 
@@ -213,7 +212,7 @@ tcTopSplice expr res_ty
        -- simple_expr :: TH.Exp
 
        expr2 :: LHsExpr RdrName
-       expr2 = convertToHsExpr simple_expr 
+       expr2 = convertToHsExpr (getLoc expr) simple_expr 
     in
     traceTc (text "Got result" <+> ppr expr2)  `thenM_`
 
@@ -246,7 +245,7 @@ tcTopSpliceExpr expr meta_ty
        ; const_binds <- tcSimplifyTop lie
        
        -- And zonk it
-       ; zonkTopLExpr (mkHsLet const_binds expr') }
+       ; zonkTopLExpr (mkHsDictLet const_binds expr') }
 \end{code}
 
 
@@ -301,7 +300,7 @@ kcTopSpliceType expr
   
        ; let   -- simple_ty :: TH.Type
                hs_ty2 :: LHsType RdrName
-               hs_ty2 = convertToHsType simple_ty
+               hs_ty2 = convertToHsType (getLoc expr) simple_ty
         
        ; traceTc (text "Got result" <+> ppr hs_ty2)
 
@@ -323,6 +322,8 @@ kcTopSpliceType expr
 
 \begin{code}
 -- Always at top level
+-- Type sig at top of file:
+--     tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
 tcSpliceDecls expr
   = do { meta_dec_ty <- tcMetaTy decTyConName
        ; meta_q_ty <- tcMetaTy qTyConName
@@ -335,10 +336,11 @@ tcSpliceDecls expr
 
            -- simple_expr :: [TH.Dec]
            -- decls :: [RdrNameHsDecl]
-       ; decls <- handleErrors (convertToHsDecls simple_expr)
+       ; decls <- handleErrors (convertToHsDecls (getLoc expr) simple_expr)
        ; traceTc (text "Got result" <+> vcat (map ppr decls))
        ; showSplice "declarations"
-                    zonked_q_expr (vcat (map ppr decls))
+                    zonked_q_expr 
+                    (ppr (getLoc expr) $$ (vcat (map ppr decls)))
        ; returnM decls }
 
   where handleErrors :: [Either a Message] -> TcM [a]
@@ -516,9 +518,6 @@ tcLookupTh name
                -- if not, we fail hard in tcImportDecl
     }}}}
 
-mk_uniq :: Int# -> Unique
-mk_uniq u = mkUniqueGrimily (I# u)
-
 notInScope :: TH.Name -> SDoc
 notInScope th_name = quotes (text (TH.pprint th_name)) <+> 
                     ptext SLIT("is not in scope at a reify")
@@ -574,18 +573,14 @@ reifyTyCon tc
        ; return (TH.TyConI $ TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
 
 reifyTyCon tc
-  = case algTyConRhs tc of
-      NewTyCon data_con _ _ 
-       -> do   { cxt <- reifyCxt (tyConStupidTheta tc)
-               ; con <- reifyDataCon data_con
-               ; return (TH.TyConI $ TH.NewtypeD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc))
-                                                 con [{- Don't know about deriving -}]) }
-
-      DataTyCon cons _
-       -> do   { cxt <- reifyCxt (tyConStupidTheta tc)
-               ; cons <- mapM reifyDataCon (tyConDataCons tc)
-               ; return (TH.TyConI $ TH.DataD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc))
-                                              cons [{- Don't know about deriving -}]) }
+  = do         { cxt <- reifyCxt (tyConStupidTheta tc)
+       ; cons <- mapM reifyDataCon (tyConDataCons tc)
+       ; let name = reifyName tc
+             tvs  = reifyTyVars (tyConTyVars tc)
+             deriv = []        -- Don't know about deriving
+             decl | isNewTyCon tc = TH.NewtypeD cxt name tvs (head cons) deriv
+                  | otherwise     = TH.DataD    cxt name tvs cons        deriv
+       ; return (TH.TyConI decl) }
 
 reifyDataCon :: DataCon -> TcM TH.Con
 reifyDataCon dc
@@ -602,7 +597,7 @@ reifyDataCon dc
          else
          if dataConIsInfix dc then
             ASSERT( length arg_tys == 2 )
-            return (TH.InfixC (s1,a1) name (s1,a2))
+            return (TH.InfixC (s1,a1) name (s2,a2))
          else
             return (TH.NormalC name (stricts `zip` arg_tys)) }
   | otherwise