X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FRdrHsSyn.lhs;h=6ff15e772b87a11c71db01bbfbcc396daadbf11e;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=8ba09c0a04e463aed404f3bea6cb357658e5d2cf;hpb=a7ecdf96844404b7bc8273d4ff6d85759278427c;p=ghc-hetmet.git

diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index 8ba09c0..6ff15e7 100644
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -11,7 +11,7 @@ module RdrHsSyn (
 	mkHsOpApp, mkClassDecl, 
 	mkHsNegApp, mkHsIntegral, mkHsFractional,
 	mkHsDo, mkHsSplice,
-        mkTyData, mkPrefixCon, mkRecCon,
+        mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,	
 	mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
 
 	cvBindGroup,
@@ -28,14 +28,15 @@ module RdrHsSyn (
 			      -- -> (FastString, RdrName, RdrNameHsType)
 			      -- -> P RdrNameHsDecl
 	mkExtName,           -- RdrName -> CLabelString
+	mkGadtDecl,          -- Located RdrName -> LHsType RdrName -> ConDecl RdrName
 			      
 	-- Bunch of functions in the parser monad for 
 	-- checking and constructing values
 	checkPrecP, 	      -- Int -> P Int
 	checkContext,	      -- HsType -> P HsContext
 	checkPred,	      -- HsType -> P HsPred
-	checkTyClHdr,
-	checkSynHdr,	
+	checkTyClHdr,         -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
+	checkSynHdr,	      -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
 	checkInstType,	      -- HsType -> P HsType
 	checkPattern,	      -- HsExp -> P HsPat
 	checkPatterns,	      -- SrcLoc -> [HsExp] -> P [HsPat]
@@ -52,13 +53,13 @@ import HsSyn		-- Lots of it
 import RdrName		( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, 
 			  isRdrDataCon, isUnqual, getRdrName, isQual,
 			  setRdrNameSpace )
-import BasicTypes	( maxPrecedence )
+import BasicTypes	( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
 import Lexer		( P, failSpanMsgP )
 import TysWiredIn	( unitTyCon ) 
 import ForeignCall	( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
 			  DNCallSpec(..), DNKind(..), CLabelString )
 import OccName  	( srcDataName, varName, isDataOcc, isTcOcc, 
-			  occNameUserString )
+			  occNameString )
 import SrcLoc
 import OrdList		( OrdList, fromOL )
 import Bag		( Bag, emptyBag, snocBag, consBag, foldrBag )
@@ -157,7 +158,7 @@ mkClassDecl (cxt, cname, tyvars) fds sigs mbinds
 		tcdMeths = mbinds
 		}
 
-mkTyData new_or_data (L _ (context, tname, tyvars)) ksig data_cons maybe_deriv
+mkTyData new_or_data (context, tname, tyvars) ksig data_cons maybe_deriv
   = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
 	     tcdTyVars = tyvars,  tcdCons = data_cons, 
 	     tcdKindSig = ksig, tcdDerivs = maybe_deriv }
@@ -600,10 +601,35 @@ checkValSig
 	:: LHsExpr RdrName
 	-> LHsType RdrName
 	-> P (Sig RdrName)
-checkValSig (L l (HsVar v)) ty | isUnqual v = return (Sig (L l v) ty)
+checkValSig (L l (HsVar v)) ty | isUnqual v = return (TypeSig (L l v) ty)
 checkValSig (L l other)     ty
   = parseError l "Type signature given for an expression"
 
+mkGadtDecl
+        :: Located RdrName
+        -> LHsType RdrName -- assuming HsType
+        -> ConDecl RdrName
+mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = ConDecl
+  { con_name     = name
+  , con_explicit = Implicit
+  , con_qvars    = qvars
+  , con_cxt      = cxt
+  , con_details  = PrefixCon args
+  , con_res      = ResTyGADT res
+  }
+  where
+  (args, res) = splitHsFunType ty
+mkGadtDecl name ty = ConDecl
+  { con_name     = name
+  , con_explicit = Implicit
+  , con_qvars    = []
+  , con_cxt      = noLoc []
+  , con_details  = PrefixCon args
+  , con_res      = ResTyGADT res
+  }
+  where
+  (args, res) = splitHsFunType ty
+
 -- A variable binding is parsed as a FunBind.
 
 isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName]
@@ -645,6 +671,13 @@ mkRecConstrOrUpdate exp loc fs@(_:_)
 mkRecConstrOrUpdate _ loc []
   = parseError loc "Empty record update"
 
+mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
+-- The Maybe is becuase the user can omit the activation spec (and usually does)
+mkInlineSpec Nothing 	True  = alwaysInlineSpec	-- INLINE
+mkInlineSpec Nothing 	False = neverInlineSpec		-- NOINLINE
+mkInlineSpec (Just act) inl   = Inline act inl
+
+
 -----------------------------------------------------------------------------
 -- utilities for foreign declarations
 
@@ -767,8 +800,8 @@ mkExport :: CallConv
 mkExport (CCall  cconv) (L loc entity, v, ty) = return $ 
   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False)
   where
-    entity' | nullFastString entity = mkExtName (unLoc v)
-	    | otherwise		    = entity
+    entity' | nullFS entity = mkExtName (unLoc v)
+	    | otherwise     = entity
 mkExport DNCall (L loc entity, v, ty) =
   parseError (getLoc v){-TODO: not quite right-}
 	"Foreign export is not yet supported for .NET"
@@ -778,10 +811,9 @@ mkExport DNCall (L loc entity, v, ty) =
 -- of the Haskell name is then performed, so if you foreign export (++),
 -- it's external name will be "++". Too bad; it's important because we don't
 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
--- (This is why we use occNameUserString.)
 --
 mkExtName :: RdrName -> CLabelString
-mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
+mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
 \end{code}