[project @ 2003-03-11 09:16:02 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 51bf7dd..cdb59b7 100644 (file)
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -92,7 +92,7 @@ module RdrHsSyn (
 
 import HsSyn           -- Lots of it
 import RdrName         ( RdrName, isRdrTyVar, mkRdrUnqual, mkUnqual, rdrNameOcc, 
-                         isRdrTyVar, isRdrDataCon, isUnqual, getRdrName,
+                         isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual,
                          setRdrNameSpace )
 import BasicTypes      ( RecFlag(..), FixitySig(..), maxPrecedence )
 import Class            ( DefMeth (..) )
@@ -101,7 +101,7 @@ import HscTypes             ( RdrAvailInfo, GenAvailInfo(..) )
 import TysWiredIn      ( unitTyCon )
 import ForeignCall     ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
                          DNCallSpec(..))
-import OccName         ( dataName, varName, isDataOcc, isTcOcc, occNameUserString,
+import OccName         ( srcDataName, varName, isDataOcc, isTcOcc, occNameUserString,
                          mkDefaultMethodOcc, mkVarOcc )
 import SrcLoc
 import CStrings                ( CLabelString )
@@ -281,7 +281,7 @@ mkHsDo ctxt stmts loc = HsDo ctxt stmts [] placeHolderType loc
 \end{code}
 
 \begin{code}
-mkHsSplice e = HsSplice unqualSplice e
+mkHsSplice e loc = HsSplice unqualSplice e loc
 
 unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
                -- A name (uniquified later) to
@@ -391,15 +391,15 @@ getMonoBind :: RdrNameMonoBinds -> [RdrBinding] -> (RdrNameMonoBinds, [RdrBindin
 --
 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
 
-getMonoBind (FunMonoBind f1 inf1 mtchs1 loc1) binds
-  | has_args mtchs1
-  = go mtchs1 loc1 binds
+getMonoBind (FunMonoBind f inf mtchs loc) binds
+  | has_args mtchs
+  = go mtchs loc binds
   where
-    go mtchs loc (RdrValBinding (FunMonoBind f2 inf2 mtchs2 loc2) : binds)
-       | f1 == f2 = go (mtchs2 ++ mtchs1) loc2 binds
+    go mtchs1 loc1 (RdrValBinding (FunMonoBind f2 inf2 mtchs2 loc2) : binds)
+       | f == f2 = go (mtchs2 ++ mtchs1) loc2 binds
        -- Remember binds is reversed, so glue mtchs2 on the front
        -- and use loc2 as the final location
-    go mtchs loc binds = (FunMonoBind f1 inf1 mtchs loc, binds)
+    go mtchs1 loc1 binds = (FunMonoBind f inf mtchs1 loc1, binds)
 
 getMonoBind bind binds = (bind, binds)
 
@@ -418,7 +418,7 @@ emptyGroup = HsGroup { hs_valds = MonoBind EmptyMonoBinds [] Recursive,
                       hs_fixds = [], hs_defds = [], hs_fords = [], 
                       hs_depds = [] ,hs_ruleds = [], hs_coreds = [] }
 
-findSplice :: [HsDecl a] -> (HsGroup a, Maybe (HsExpr a, [HsDecl a]))
+findSplice :: [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a]))
 findSplice ds = add emptyGroup ds
 
 mkGroup :: [HsDecl a] -> HsGroup a
@@ -430,7 +430,7 @@ addImpDecls group decls = case add group decls of
                                (group', Nothing) -> group'
                                other             -> panic "addImpDecls"
 
-add :: HsGroup a -> [HsDecl a] -> (HsGroup a, Maybe (HsExpr a, [HsDecl a]))
+add :: HsGroup a -> [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a]))
        -- This stuff reverses the declarations (again) but it doesn't matter
 
 -- Base cases
@@ -440,7 +440,7 @@ add gp (SpliceD e : ds) = (gp, Just (e, ds))
 -- Class declarations: pull out the fixity signatures to the top
 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) (TyClD d : ds)   
        | isClassDecl d = add (gp { hs_tyclds = d : ts, 
-                                   hs_fixds  = [f | FixSig f <- tcdSigs d] }) ds
+                                   hs_fixds  = [f | FixSig f <- tcdSigs d] ++ fs }) ds
        | otherwise     = add (gp { hs_tyclds = d : ts }) ds
 
 -- Signatures: fixity sigs go a different place than all others
@@ -496,7 +496,7 @@ mkRecCon con fields
 tyConToDataCon :: RdrName -> P RdrName
 tyConToDataCon tc
   | isTcOcc (rdrNameOcc tc)
-  = returnP (setRdrNameSpace tc dataName)
+  = returnP (setRdrNameSpace tc srcDataName)
   | otherwise
   = parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
 
@@ -516,11 +516,13 @@ checkInstType t
                returnP (HsForAllTy Nothing [] dict_ty)
 
 checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar]
-checkTyVars tvs = mapP chk tvs
-               where
-                 chk (HsKindSig (HsTyVar tv) k) = returnP (IfaceTyVar tv k)
-                 chk (HsTyVar tv)               = returnP (UserTyVar tv)
-                 chk other                      = parseError "Type found where type variable expected"
+checkTyVars tvs 
+  = mapP chk tvs
+  where
+       --  Check that the name space is correct!
+    chk (HsKindSig (HsTyVar tv) k) | isRdrTyVar tv = returnP (IfaceTyVar tv k)
+    chk (HsTyVar tv)              | isRdrTyVar tv = returnP (UserTyVar tv)
+    chk other                     = parseError "Type found where type variable expected"
 
 checkTyClHdr :: RdrNameHsType -> P (RdrName, [RdrNameHsTyVar])
 -- The header of a type or class decl should look like
@@ -612,8 +614,9 @@ checkPat (HsApp f x) args =
        checkPat x [] `thenP` \x ->
        checkPat f (x:args)
 checkPat e [] = case e of
-       EWildPat           -> returnP (WildPat placeHolderType)
-       HsVar x            -> returnP (VarPat x)
+       EWildPat            -> returnP (WildPat placeHolderType)
+       HsVar x | isQual x  -> parseError ("Qualified variable in pattern: " ++ showRdrName x)
+               | otherwise -> returnP (VarPat x)
        HsLit l            -> returnP (LitPat l)
        HsOverLit l        -> returnP (NPatIn l Nothing)
        ELazyPat e         -> checkPat e [] `thenP` (returnP . LazyPat)
@@ -684,8 +687,11 @@ checkValDef
 
 checkValDef lhs opt_sig grhss loc
  = case isFunLhs lhs [] of
-          Just (f,inf,es) -> 
-               checkPatterns loc es `thenP` \ps ->
+          Just (f,inf,es) 
+            | isQual f
+            -> parseError ("Qualified name in function definition: "  ++ showRdrName f)
+            | otherwise
+            -> checkPatterns loc es `thenP` \ps ->
                returnP (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc))
 
            Nothing ->
@@ -862,6 +868,9 @@ mkIfaceExports decls = map getExport decls
 -- Misc utils
 
 \begin{code}
+showRdrName :: RdrName -> String
+showRdrName r = showSDoc (ppr r)
+
 parseError :: String -> P a
 parseError s = 
   getSrcLocP `thenP` \ loc ->