[project @ 2004-09-30 10:35:15 by simonpj]

[ghc-hetmet.git] / ghc / compiler / parser / RdrHsSyn.lhs

diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index b011c39..ae10007 100644 (file)
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -61,13 +61,12 @@ import Kind         ( liftedTypeKind )
 import HscTypes                ( GenAvailInfo(..) )
 import TysWiredIn      ( unitTyCon ) 
 import ForeignCall     ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
 import HscTypes                ( GenAvailInfo(..) )
 import TysWiredIn      ( unitTyCon ) 
 import ForeignCall     ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),

-                         DNCallSpec(..), DNKind(..))
+                         DNCallSpec(..), DNKind(..), CLabelString )

 import OccName         ( OccName, srcDataName, varName, isDataOcc, isTcOcc, 
                          occNameUserString, isValOcc )
 import BasicTypes      ( initialVersion, StrictnessMark(..) )
 import Module          ( ModuleName )
 import SrcLoc
 import OccName         ( OccName, srcDataName, varName, isDataOcc, isTcOcc, 
                          occNameUserString, isValOcc )
 import BasicTypes      ( initialVersion, StrictnessMark(..) )
 import Module          ( ModuleName )
 import SrcLoc

-import CStrings                ( CLabelString )

 import CmdLineOpts     ( opt_InPackage )
 import OrdList         ( OrdList, fromOL )
 import Bag             ( Bag, emptyBag, snocBag, consBag, foldrBag )
 import CmdLineOpts     ( opt_InPackage )
 import OrdList         ( OrdList, fromOL )
 import Bag             ( Bag, emptyBag, snocBag, consBag, foldrBag )

@@ -108,6 +107,7 @@ extract_lty (L loc (HsTyVar tv)) acc
   | otherwise = acc
 extract_lty ty acc = extract_ty (unLoc ty) acc
 
   | otherwise = acc
 extract_lty ty acc = extract_ty (unLoc ty) acc
 

+extract_ty (HsBangTy _ ty)           acc = extract_lty ty acc

 extract_ty (HsAppTy ty1 ty2)         acc = extract_lty ty1 (extract_lty ty2 acc)
 extract_ty (HsListTy ty)             acc = extract_lty ty acc
 extract_ty (HsPArrTy ty)             acc = extract_lty ty acc
 extract_ty (HsAppTy ty1 ty2)         acc = extract_lty ty1 (extract_lty ty2 acc)
 extract_ty (HsListTy ty)             acc = extract_lty ty acc
 extract_ty (HsPArrTy ty)             acc = extract_lty ty acc

@@ -132,8 +132,8 @@ extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
 extractGenericPatTyVars binds
   = nubBy eqLocated (foldrBag get [] binds)
   where
 extractGenericPatTyVars binds
   = nubBy eqLocated (foldrBag get [] binds)
   where

-    get (L _ (FunBind _ _ ms)) acc = foldr (get_m.unLoc) acc ms
-    get other                 acc = acc
+    get (L _ (FunBind _ _ (MatchGroup ms _))) acc = foldr (get_m.unLoc) acc ms
+    get other                                acc = acc

 
     get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
     get_m other                                           acc = acc
 
     get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
     get_m other                                           acc = acc

@@ -188,9 +188,11 @@ mkHsNegApp (L loc e) = f e
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-mkBootIface, and its boring helper functions, have two purposes:
+mkBootIface, and its deeply boring helper functions, have two purposes:
+

 a) HsSyn to IfaceSyn.  The parser parses the former, but we're reading
        an hi-boot file, and interfaces consist of the latter
 a) HsSyn to IfaceSyn.  The parser parses the former, but we're reading
        an hi-boot file, and interfaces consist of the latter

+

 b) Convert unqualifed names from the "current module" to qualified Orig
    names.  E.g.
        module This where
 b) Convert unqualifed names from the "current module" to qualified Orig
    names.  E.g.
        module This where

@@ -198,7 +200,10 @@ b) Convert unqualifed names from the "current module" to qualified Orig
    becomes
         This.foo :: GHC.Base.Int -> GHC.Base.Int
 
    becomes
         This.foo :: GHC.Base.Int -> GHC.Base.Int
 

-It assumes that everything is well kinded, of course.
+It assumes that everything is well kinded, of course.  Failure causes a
+fatal error using pgmError, rather than a monadic error.  You're supposed
+to get hi-boot files right!
+

 
 \begin{code}
 mkBootIface :: ModuleName -> [HsDecl RdrName] -> ModIface
 
 \begin{code}
 mkBootIface :: ModuleName -> [HsDecl RdrName] -> ModIface

@@ -234,6 +239,14 @@ hsIfaceDecl (SigD (Sig name ty))
              ifType = hsIfaceLType ty,
              ifIdInfo = NoInfo }
 
              ifType = hsIfaceLType ty,
              ifIdInfo = NoInfo }
 

+hsIfaceDecl (TyClD decl@(ClassDecl {}))
+  = IfaceClass { ifName = rdrNameOcc (tcdName decl), 
+                ifTyVars = hsIfaceTvs (tcdTyVars decl), 
+                ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
+                ifFDs = hsIfaceFDs (map unLoc (tcdFDs decl)),
+                ifSigs = [],   -- Is this right??
+                ifRec = NonRecursive, ifVrcs = [] }
+

 hsIfaceDecl (TyClD decl@(TySynonym {}))
   = IfaceSyn { ifName = rdrNameOcc (tcdName decl), 
               ifTyVars = hsIfaceTvs (tcdTyVars decl), 
 hsIfaceDecl (TyClD decl@(TySynonym {}))
   = IfaceSyn { ifName = rdrNameOcc (tcdName decl), 
               ifTyVars = hsIfaceTvs (tcdTyVars decl), 

@@ -242,50 +255,62 @@ hsIfaceDecl (TyClD decl@(TySynonym {}))
 
 hsIfaceDecl (TyClD decl@(TyData {}))
   = IfaceData { ifName = rdrNameOcc (tcdName decl), 
 
 hsIfaceDecl (TyClD decl@(TyData {}))
   = IfaceData { ifName = rdrNameOcc (tcdName decl), 

-               ifTyVars = hsIfaceTvs (tcdTyVars decl), 
-               ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
-               ifCons = hsIfaceCons (tcdND decl) (tcdCons decl), 
+               ifTyVars = tvs,
+               ifCons = hsIfaceCons tvs decl,

                ifRec = NonRecursive,
                ifVrcs = [], ifGeneric = False }
        -- I'm not sure that [] is right for ifVrcs, but
        -- since we don't use them I'm not going to fiddle
                ifRec = NonRecursive,
                ifVrcs = [], ifGeneric = False }
        -- I'm not sure that [] is right for ifVrcs, but
        -- since we don't use them I'm not going to fiddle

-
-hsIfaceDecl (TyClD decl@(ClassDecl {}))
-  = IfaceClass { ifName = rdrNameOcc (tcdName decl), 
-                ifTyVars = hsIfaceTvs (tcdTyVars decl), 
-                ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
-                ifFDs = hsIfaceFDs (map unLoc (tcdFDs decl)),
-                ifSigs = [],   -- Is this right??
-                ifRec = NonRecursive, ifVrcs = [] }
-
-hsIfaceDecl decl = pprPanic "hsIfaceDecl" (ppr decl)
-
-hsIfaceCons :: NewOrData -> [LConDecl RdrName] -> IfaceConDecls
-hsIfaceCons DataType []        -- data T a, meaning "constructors unspecified", 
-  = IfAbstractTyCon    -- not "no constructors"
-
-hsIfaceCons DataType cons      -- data type
-  = IfDataTyCon (map (hsIfaceCon . unLoc) cons)
-
-hsIfaceCons NewType [con]      -- newtype
-  = IfNewTyCon (hsIfaceCon (unLoc con))
-
-
-hsIfaceCon :: ConDecl RdrName -> IfaceConDecl
-hsIfaceCon (ConDecl lname ex_tvs ex_ctxt details)
-  = IfaceConDecl (get_occ lname)
-                (hsIfaceTvs ex_tvs)
-                (hsIfaceCtxt (unLoc ex_ctxt))
-                (map (hsIfaceLType . getBangType       . unLoc) args)
-                (map (hsStrictMark . getBangStrictness . unLoc) args)
-                flds

   where
   where

-    (args, flds) = case details of
-                       PrefixCon args -> (args, [])
-                       InfixCon a1 a2 -> ([a1,a2], [])
-                       RecCon fs      -> (map snd fs, map (get_occ . fst) fs)
+    tvs = hsIfaceTvs (tcdTyVars decl)
+
+hsIfaceDecl decl = pprPgmError "Illegal declaration in hi-boot file:" (ppr decl)
+
+hsIfaceCons :: [IfaceTvBndr] -> TyClDecl RdrName -> IfaceConDecls
+hsIfaceCons tvs decl@(TyData {tcdCtxt = L _ stupid_ctxt})
+  | not (null stupid_ctxt)     -- Keep it simple: no data type contexts
+                               -- Else we'll have to do "thinning"; sigh
+  = pprPgmError "Can't do data type contexts in hi-boot file:" (ppr decl)
+
+hsIfaceCons tvs (TyData {tcdND = DataType, tcdCons = []})
+  =    -- data T a, meaning "constructors unspecified", 
+    IfAbstractTyCon            -- not "no constructors"
+
+hsIfaceCons tvs (TyData {tcdND = DataType, tcdCons = cons})
+  = IfDataTyCon Nothing (map (hsIfaceCon tvs . unLoc) cons)
+
+hsIfaceCons tvs (TyData {tcdND = NewType, tcdCons = [con]})
+  = IfNewTyCon (hsIfaceCon tvs (unLoc con))
+
+hsIfaceCons tvs decl = pprPgmError "Illegal declaration in hi-boot file:" (ppr decl)
+
+
+hsIfaceCon :: [IfaceTvBndr] -> ConDecl RdrName -> IfaceConDecl
+hsIfaceCon tvs (ConDecl lname ex_tvs ex_ctxt details)
+  | null ex_tvs && null (unLoc ex_ctxt)
+  = IfVanillaCon { ifConOcc = get_occ lname,
+                  ifConInfix = is_infix,
+                  ifConArgTys = map hsIfaceLType args,
+                  ifConStricts = map (hsStrictMark . getBangStrictness) args,
+                  ifConFields = flds }
+  | null flds
+  = IfGadtCon    { ifConOcc = get_occ lname,
+                  ifConTyVars = tvs ++ hsIfaceTvs ex_tvs,
+                  ifConCtxt = hsIfaceCtxt (unLoc ex_ctxt),
+                  ifConArgTys = map hsIfaceLType args,
+                  ifConResTys = map (IfaceTyVar . fst) tvs,
+                  ifConStricts = map (hsStrictMark . getBangStrictness) args }
+  | otherwise = pprPgmError "Fields illegal in existential" (ppr (unLoc lname))
+  where
+    (is_infix, args, flds) = case details of
+                               PrefixCon args -> (False, args, [])
+                               InfixCon a1 a2 -> (True, [a1,a2], [])
+                               RecCon fs      -> (False, map snd fs, map (get_occ . fst) fs)

     get_occ lname = rdrNameOcc (unLoc lname)
 
     get_occ lname = rdrNameOcc (unLoc lname)
 

+hsIfaceCon _tvs (GadtDecl lname con_ty)        -- Not yet
+  = pprPgmError "Can't use GADTs in hi-boot files (yet)" (ppr (unLoc lname))
+

 hsStrictMark :: HsBang -> StrictnessMark
 -- Warning: in source files the {-# UNPACK #-} pragma (HsUnbox) is a request
 --         but in an hi-boot file it's interpreted as the Truth!
 hsStrictMark :: HsBang -> StrictnessMark
 -- Warning: in source files the {-# UNPACK #-} pragma (HsUnbox) is a request
 --         but in an hi-boot file it's interpreted as the Truth!

@@ -319,10 +344,11 @@ hsIfaceType (HsPArrTy t)       = IfaceTyConApp IfacePArrTc [hsIfaceLType t]
 hsIfaceType (HsTupleTy bx ts)  = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts)
 hsIfaceType (HsOpTy t1 tc t2)  = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2])
 hsIfaceType (HsParTy t)               = hsIfaceLType t
 hsIfaceType (HsTupleTy bx ts)  = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts)
 hsIfaceType (HsOpTy t1 tc t2)  = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2])
 hsIfaceType (HsParTy t)               = hsIfaceLType t

+hsIfaceType (HsBangTy _ t)     = hsIfaceLType t

 hsIfaceType (HsPredTy p)       = IfacePredTy (hsIfacePred p)
 hsIfaceType (HsKindSig t _)    = hsIfaceLType t
 hsIfaceType (HsPredTy p)       = IfacePredTy (hsIfacePred p)
 hsIfaceType (HsKindSig t _)    = hsIfaceLType t

-hsIfaceType (HsNumTy n)               = panic "hsIfaceType:HsNum"
-hsIfaceType (HsSpliceTy _)     = panic "hsIfaceType:HsSpliceTy"
+hsIfaceType ty                = pprPanic "hsIfaceType" (ppr ty)
+                               -- HsNumTy, HsSpliceTy

 
 -----------
 hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys
 
 -----------
 hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys

@@ -348,6 +374,7 @@ hs_tc_app (HsTyVar n) args
 hs_tc_app ty args         = foldl IfaceAppTy (hsIfaceType ty) args
 
 -----------
 hs_tc_app ty args         = foldl IfaceAppTy (hsIfaceType ty) args
 
 -----------

+hsIfaceTvs :: [LHsTyVarBndr RdrName] -> [IfaceTvBndr]

 hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs
 
 -----------
 hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs
 
 -----------

@@ -415,15 +442,16 @@ getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
 --
 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
 
 --
 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
 

-getMonoBind (L loc (FunBind lf@(L _ f) inf mtchs)) binds
+-- gaw 2004
+getMonoBind (L loc (FunBind lf@(L _ f) inf (MatchGroup mtchs _))) binds

   | has_args mtchs
   = go mtchs loc binds
   where
   | has_args mtchs
   = go mtchs loc binds
   where

-    go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 mtchs2)) : binds)
+    go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 (MatchGroup mtchs2 _))) : binds)

        | f == unLoc f2 = go (mtchs2++mtchs1) loc binds
        where loc = combineSrcSpans loc1 loc2
     go mtchs1 loc binds
        | f == unLoc f2 = go (mtchs2++mtchs1) loc binds
        where loc = combineSrcSpans loc1 loc2
     go mtchs1 loc binds

-       = (L loc (FunBind lf inf (reverse mtchs1)), binds)
+       = (L loc (FunBind lf inf (mkMatchGroup (reverse mtchs1))), binds)

        -- reverse the final matches, to get it back in the right order
 
 getMonoBind bind binds = (bind, binds)
        -- reverse the final matches, to get it back in the right order
 
 getMonoBind bind binds = (bind, binds)

@@ -521,7 +549,7 @@ mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
 mkPrefixCon ty tys
  = split ty tys
  where
 mkPrefixCon ty tys
  = split ty tys
  where

-   split (L _ (HsAppTy t u)) ts = split t (unbangedType u : ts)
+   split (L _ (HsAppTy t u)) ts = split t (u : ts)

    split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
                                     return (data_con, PrefixCon ts)
    split (L l _) _             = parseError l "parse error in data/newtype declaration"
    split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
                                     return (data_con, PrefixCon ts)
    split (L l _) _             = parseError l "parse error in data/newtype declaration"

@@ -763,20 +791,22 @@ patFail loc = parseError loc "Parse error in pattern"
 checkValDef 
        :: LHsExpr RdrName
        -> Maybe (LHsType RdrName)
 checkValDef 
        :: LHsExpr RdrName
        -> Maybe (LHsType RdrName)

-       -> GRHSs RdrName
+       -> Located (GRHSs RdrName)

        -> P (HsBind RdrName)
 
        -> P (HsBind RdrName)
 

-checkValDef lhs opt_sig grhss
+checkValDef lhs opt_sig (L rhs_span grhss)

   | Just (f,inf,es)  <- isFunLhs lhs []
   = if isQual (unLoc f)
        then parseError (getLoc f) ("Qualified name in function definition: "  ++ 
                                        showRdrName (unLoc f))
        else do ps <- checkPatterns es
   | Just (f,inf,es)  <- isFunLhs lhs []
   = if isQual (unLoc f)
        then parseError (getLoc f) ("Qualified name in function definition: "  ++ 
                                        showRdrName (unLoc f))
        else do ps <- checkPatterns es

-               return (FunBind f inf [L (getLoc f) (Match ps opt_sig grhss)])
-                       -- TODO: span is wrong
+               let match_span = combineSrcSpans (getLoc lhs) rhs_span
+               return (FunBind f inf (mkMatchGroup [L match_span (Match ps opt_sig grhss)]))
+       -- The span of the match covers the entire equation.  
+       -- That isn't quite right, but it'll do for now.

   | otherwise = do
        lhs <- checkPattern lhs
   | otherwise = do
        lhs <- checkPattern lhs

-       return (PatBind lhs grhss)
+       return (PatBind lhs grhss placeHolderType)

 
 checkValSig
        :: LHsExpr RdrName
 
 checkValSig
        :: LHsExpr RdrName