X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FConvert.lhs;h=7343a8baa49f7203a8433a00be9baac60ed85c39;hb=ff845ab59d1d465d874d3908fd0cdd61b8594da2;hp=03abd3c25e8878c525e6cf720450e15a58fd0531;hpb=76fcd85d57595f9d864dea60f4d738ff59959326;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs
index 03abd3c..7343a8b 100644
--- a/ghc/compiler/hsSyn/Convert.lhs
+++ b/ghc/compiler/hsSyn/Convert.lhs
@@ -10,10 +10,11 @@ module Convert( convertToHsExpr, convertToHsDecls, convertToHsType ) where
 
 #include "HsVersions.h"
 
-import Language.Haskell.TH as TH
+import Language.Haskell.TH as TH hiding (sigP)
 import Language.Haskell.TH.Syntax as TH
 
 import HsSyn as Hs
+import qualified Class (FunDep)
 import RdrName	( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, nameRdrName, getRdrName )
 import Module   ( ModuleName, mkModuleName )
 import RdrHsSyn	( mkHsIntegral, mkHsFractional, mkClassDecl, mkTyData )
@@ -42,7 +43,9 @@ import Outputable
 convertToHsDecls :: [TH.Dec] -> [Either (LHsDecl RdrName) Message]
 convertToHsDecls ds = map cvt_ltop ds
 
-mk_con con = L loc0 $ case con of
+mk_con con = L loc0 $ mk_nlcon con
+  where
+    mk_nlcon con = case con of
 	NormalC c strtys
 	 -> ConDecl (noLoc (cName c)) noExistentials noContext
 		  (PrefixCon (map mk_arg strtys))
@@ -52,17 +55,22 @@ mk_con con = L loc0 $ case con of
 	InfixC st1 c st2
 	 -> ConDecl (noLoc (cName c)) noExistentials noContext
 		  (InfixCon (mk_arg st1) (mk_arg st2))
-  where
-    mk_arg (IsStrict, ty)  = noLoc $ BangType HsStrict (cvtType ty)
-    mk_arg (NotStrict, ty) = noLoc $ BangType HsNoBang (cvtType ty)
+	ForallC tvs ctxt (ForallC tvs' ctxt' con')
+	 -> mk_nlcon (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
+	ForallC tvs ctxt con' -> case mk_nlcon con' of
+				ConDecl l [] (L _ []) x ->
+				    ConDecl l (cvt_tvs tvs) (cvt_context ctxt) x
+				c -> panic "ForallC: Can't happen"
+    mk_arg (IsStrict, ty)  = noLoc $ HsBangTy HsStrict (cvtType ty)
+    mk_arg (NotStrict, ty) = cvtType ty
 
     mk_id_arg (i, IsStrict, ty)
-        = (noLoc (vName i), noLoc $ BangType HsStrict (cvtType ty))
+        = (noLoc (vName i), noLoc $ HsBangTy HsStrict (cvtType ty))
     mk_id_arg (i, NotStrict, ty)
-        = (noLoc (vName i), noLoc $ BangType HsNoBang (cvtType ty))
+        = (noLoc (vName i), cvtType ty)
 
 mk_derivs [] = Nothing
-mk_derivs cs = Just [noLoc $ HsPredTy $ noLoc $ HsClassP (tconName c) [] | c <- cs]
+mk_derivs cs = Just [noLoc $ HsPredTy $ HsClassP (tconName c) [] | c <- cs]
 
 cvt_ltop  :: TH.Dec -> Either (LHsDecl RdrName) Message
 cvt_ltop d = case cvt_top d of
@@ -78,20 +86,23 @@ cvt_top (TySynD tc tvs rhs)
 
 cvt_top (DataD ctxt tc tvs constrs derivs)
   = Left $ TyClD (mkTyData DataType 
-                           (cvt_context ctxt, noLoc (tconName tc), cvt_tvs tvs)
-                           (map mk_con constrs)
+                           (noLoc (cvt_context ctxt, noLoc (tconName tc), cvt_tvs tvs))
+                           Nothing (map mk_con constrs)
                            (mk_derivs derivs))
 
 cvt_top (NewtypeD ctxt tc tvs constr derivs)
   = Left $ TyClD (mkTyData NewType 
-                           (cvt_context ctxt, noLoc (tconName tc), cvt_tvs tvs)
-                           [mk_con constr]
+                           (noLoc (cvt_context ctxt, noLoc (tconName tc), cvt_tvs tvs))
+                           Nothing [mk_con constr]
                            (mk_derivs derivs))
 
-cvt_top (ClassD ctxt cl tvs decs)
-  = Left $ TyClD (mkClassDecl (cvt_context ctxt, noLoc (tconName cl), cvt_tvs tvs)
-                              noFunDeps sigs
-			      binds)
+cvt_top (ClassD ctxt cl tvs fds decs)
+  = Left $ TyClD $ mkClassDecl (cvt_context ctxt,
+                                noLoc (tconName cl),
+                                cvt_tvs tvs)
+                               (map (noLoc . cvt_fundep) fds)
+                               sigs
+                               binds
   where
     (binds,sigs) = cvtBindsAndSigs decs
 
@@ -126,6 +137,9 @@ cvt_top (ForeignD (ExportF callconv as nm typ))
                           CCall -> CCallConv
                           StdCall -> StdCallConv
 
+cvt_fundep :: FunDep -> Class.FunDep RdrName
+cvt_fundep (FunDep xs ys) = (map tName xs, map tName ys)
+
 parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec)
 parse_ccall_impent nm s
  = case lex_ccall_impent s of
@@ -168,7 +182,6 @@ lex_ccall_impent xs = case span is_valid xs of
 
 noContext      = noLoc []
 noExistentials = []
-noFunDeps      = []
 
 -------------------------------------------------------------------
 convertToHsExpr :: TH.Exp -> LHsExpr RdrName
@@ -183,12 +196,12 @@ cvt (LitE l)
   | otherwise	    = HsLit (cvtLit l)
 
 cvt (AppE x y)     = HsApp (cvtl x) (cvtl y)
-cvt (LamE ps e)    = HsLam (mkSimpleMatch (map cvtlp ps) (cvtl e) void)
+cvt (LamE ps e)    = HsLam (mkMatchGroup [mkSimpleMatch (map cvtlp ps) (cvtl e)])
 cvt (TupE [e])	  = cvt e
 cvt (TupE es)	  = ExplicitTuple(map cvtl es) Boxed
 cvt (CondE x y z)  = HsIf (cvtl x) (cvtl y) (cvtl z)
 cvt (LetE ds e)	  = HsLet (cvtdecs ds) (cvtl e)
-cvt (CaseE e ms)   = HsCase (cvtl e) (map cvtm ms)
+cvt (CaseE e ms)   = HsCase (cvtl e) (mkMatchGroup (map cvtm ms))
 cvt (DoE ss)	  = HsDo DoExpr (cvtstmts ss) [] void
 cvt (CompE ss)     = HsDo ListComp (cvtstmts ss) [] void
 cvt (ArithSeqE dd) = ArithSeqIn (cvtdd dd)
@@ -223,11 +236,11 @@ cvtd :: TH.Dec -> LHsBind RdrName
 -- Used only for declarations in a 'let/where' clause,
 -- not for top level decls
 cvtd (TH.ValD (TH.VarP s) body ds) 
-  = noLoc $ FunBind (noLoc (vName s)) False [cvtclause (Clause [] body ds)]
+  = noLoc $ FunBind (noLoc (vName s)) False (mkMatchGroup [cvtclause (Clause [] body ds)])
 cvtd (FunD nm cls)
-  = noLoc $ FunBind (noLoc (vName nm)) False (map cvtclause cls)
+  = noLoc $ FunBind (noLoc (vName nm)) False (mkMatchGroup (map cvtclause cls))
 cvtd (TH.ValD p body ds)
-  = noLoc $ PatBind (cvtlp p) (GRHSs (cvtguard body) (cvtdecs ds) void)
+  = noLoc $ PatBind (cvtlp p) (GRHSs (cvtguard body) (cvtdecs ds)) void
 
 cvtd d = cvtPanic "Illegal kind of declaration in where clause" 
 		  (text (TH.pprint d))
@@ -235,7 +248,7 @@ cvtd d = cvtPanic "Illegal kind of declaration in where clause"
 
 cvtclause :: TH.Clause -> Hs.LMatch RdrName
 cvtclause (Clause ps body wheres)
-    = noLoc $ Hs.Match (map cvtlp ps) Nothing (GRHSs (cvtguard body) (cvtdecs wheres) void)
+    = noLoc $ Hs.Match (map cvtlp ps) Nothing (GRHSs (cvtguard body) (cvtdecs wheres))
 
 
 
@@ -256,15 +269,16 @@ cvtstmts (TH.ParS dss : ss)  = nlParStmt [(cvtstmts ds, undefined) | ds <- dss]
 
 cvtm :: TH.Match -> Hs.LMatch RdrName
 cvtm (TH.Match p body wheres)
-    = noLoc (Hs.Match [cvtlp p] Nothing (GRHSs (cvtguard body) (cvtdecs wheres) void))
+    = noLoc (Hs.Match [cvtlp p] Nothing (GRHSs (cvtguard body) (cvtdecs wheres)))
 
 cvtguard :: TH.Body -> [LGRHS RdrName]
 cvtguard (GuardedB pairs) = map cvtpair pairs
 cvtguard (NormalB e) 	 = [noLoc (GRHS [  nlResultStmt (cvtl e) ])]
 
-cvtpair :: (TH.Exp,TH.Exp) -> LGRHS RdrName
-cvtpair (x,y) = noLoc (GRHS [nlBindStmt truePat (cvtl x),
-		      	nlResultStmt (cvtl y)])
+cvtpair :: (TH.Guard,TH.Exp) -> LGRHS RdrName
+cvtpair (NormalG x,y) = noLoc (GRHS [nlBindStmt truePat (cvtl x),
+                               nlResultStmt (cvtl y)])
+cvtpair (PatG x,y) = noLoc (GRHS (cvtstmts x ++ [nlResultStmt (cvtl y)]))
 
 cvtOverLit :: Lit -> HsOverLit
 cvtOverLit (IntegerL i)  = mkHsIntegral i
@@ -292,11 +306,14 @@ cvtp (TH.VarP s)     = Hs.VarPat(vName s)
 cvtp (TupP [p])   = cvtp p
 cvtp (TupP ps)    = TuplePat (map cvtlp ps) Boxed
 cvtp (ConP s ps)  = ConPatIn (noLoc (cName s)) (PrefixCon (map cvtlp ps))
+cvtp (InfixP p1 s p2)
+                  = ConPatIn (noLoc (cName s)) (InfixCon (cvtlp p1) (cvtlp p2))
 cvtp (TildeP p)   = LazyPat (cvtlp p)
 cvtp (TH.AsP s p) = AsPat (noLoc (vName s)) (cvtlp p)
 cvtp TH.WildP   = WildPat void
 cvtp (RecP c fs)  = ConPatIn (noLoc (cName c)) $ Hs.RecCon (map (\(s,p) -> (noLoc (vName s),cvtlp p)) fs)
 cvtp (ListP ps)   = ListPat (map cvtlp ps) void
+cvtp (SigP p t)   = SigPatIn (cvtlp p) (cvtType t)
 
 -----------------------------------------------------------
 --	Types and type variables
@@ -305,12 +322,12 @@ cvt_tvs :: [TH.Name] -> [LHsTyVarBndr RdrName]
 cvt_tvs tvs = map (noLoc . UserTyVar . tName) tvs
 
 cvt_context :: Cxt -> LHsContext RdrName 
-cvt_context tys = noLoc (map cvt_pred tys)
+cvt_context tys = noLoc (map (noLoc . cvt_pred) tys)
 
-cvt_pred :: TH.Type -> LHsPred RdrName
+cvt_pred :: TH.Type -> HsPred RdrName
 cvt_pred ty = case split_ty_app ty of
-	   	(ConT tc, tys) -> noLoc (HsClassP (tconName tc) (map cvtType tys))
-	   	(VarT tv, tys) -> noLoc (HsClassP (tName tv) (map cvtType tys))
+	   	(ConT tc, tys) -> HsClassP (tconName tc) (map cvtType tys)
+	   	(VarT tv, tys) -> HsClassP (tName tv) (map cvtType tys)
 		other -> cvtPanic "Malformed predicate" (text (TH.pprint ty))
 
 convertToHsType = cvtType
@@ -395,7 +412,7 @@ thRdrName :: OccName.NameSpace -> TH.Name -> RdrName
 -- "x_77" etc, but that could conceivably clash.)
 
 thRdrName ns (TH.Name occ (TH.NameG ns' mod))  = mkOrig (mk_mod mod) (mk_occ ns occ)
-thRdrName ns (TH.Name occ TH.NameS)            = mkRdrUnqual (mk_occ ns occ)
+thRdrName ns (TH.Name occ TH.NameS)            = mkDynName ns occ
 thRdrName ns (TH.Name occ (TH.NameU uniq))     = nameRdrName (mkInternalName (mk_uniq uniq) (mk_occ ns occ) noSrcLoc)
 
 mk_uniq :: Int# -> Unique
@@ -407,5 +424,22 @@ mk_occ ns occ = OccName.mkOccFS ns (mkFastString (TH.occString occ))
 
 mk_mod :: TH.ModName -> ModuleName
 mk_mod mod = mkModuleName (TH.modString mod)
+
+mkDynName :: OccName.NameSpace -> TH.OccName -> RdrName
+-- Parse the string to see if it has a "." in it
+-- so we know whether to generate a qualified or unqualified name
+-- It's a bit tricky because we need to parse 
+--	Foo.Baz.x as Qual Foo.Baz x
+-- So we parse it from back to front
+
+mkDynName ns th_occ
+  = split [] (reverse (TH.occString th_occ))
+  where
+    split occ []        = mkRdrUnqual (mk_occ occ)
+    split occ ('.':rev)	= mkRdrQual (mk_mod (reverse rev)) (mk_occ occ)
+    split occ (c:rev)   = split (c:occ) rev
+
+    mk_occ occ = OccName.mkOccFS ns (mkFastString occ)
+    mk_mod mod = mkModuleName mod
 \end{code}