Add {-# OPTIONS_GHC -w #-} and some blurb to all compiler modules

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

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 9cc6c65..f03a50e 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -4,6 +4,13 @@
 Functions over HsSyn specialised to RdrName.
 
 \begin{code}
+{-# OPTIONS_GHC -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
+-- for details
+
 module RdrHsSyn (
        extractHsTyRdrTyVars, 
        extractHsRhoRdrTyVars, extractGenericPatTyVars,
@@ -58,7 +65,7 @@ import RdrName                ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
                          isRdrDataCon, isUnqual, getRdrName, isQual,
                          setRdrNameSpace )
 import BasicTypes      ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
-import Lexer           ( P, failSpanMsgP, extension, glaExtsEnabled, bangPatEnabled )
+import Lexer           ( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled )
 import TysWiredIn      ( unitTyCon ) 
 import ForeignCall     ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
                          DNCallSpec(..), DNKind(..), CLabelString )
@@ -348,7 +355,7 @@ add_sig  s (ValBindsIn bs sigs) = ValBindsIn bs                   (s:sigs)
 -- arguments, and converts the type constructor back into a data constructor.
 
 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
-  -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
+           -> P (Located RdrName, HsConDeclDetails RdrName)
 mkPrefixCon ty tys
  = split ty tys
  where
@@ -359,10 +366,10 @@ mkPrefixCon ty tys
 
 mkRecCon :: Located RdrName -> 
             [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] ->
-            P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
+            P (Located RdrName, HsConDeclDetails RdrName)
 mkRecCon (L loc con) fields
   = do data_con <- tyConToDataCon loc con
-       return (data_con, RecCon [ (HsRecField l t d) | (ls, t, d) <- fields, l <- ls ])
+       return (data_con, RecCon [ ConDeclField l t d | (ls, t, d) <- fields, l <- ls ])
 
 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
 tyConToDataCon loc tc
@@ -413,9 +420,9 @@ checkTyVars tparms = mapM_ chk tparms
          parseError l "Type found where type variable expected"
 
 -- Check whether the type arguments in a type synonym head are simply
--- variables.  If not, we have a type equation of a type function and return
--- all patterns.  If yes, we return 'Nothing' as the third component to
--- indicate a vanilla type synonym.
+-- variables.  If not, we have a type family instance and return all patterns.
+-- If yes, we return 'Nothing' as the third component to indicate a vanilla
+-- type synonym. 
 --
 checkSynHdr :: LHsType RdrName 
            -> Bool                             -- is type instance?
@@ -442,6 +449,7 @@ checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
 -- etc
 -- With associated types, we can also have non-variable parameters; ie,
 --      T Int [a]
+-- or   Int :++: [a]
 -- The unaltered parameter list is returned in the fourth component of the
 -- result.  Eg, for
 --      T Int [a]
@@ -459,7 +467,7 @@ checkTyClHdr (L l cxt) ty
                                     return (L l tc, tvs, acc)
     go l (HsOpTy t1 ltc@(L _ tc) t2) acc
        | isRdrTc tc            = do tvs <- extractTyVars (t1:t2:acc)
-                                    return (ltc, tvs, acc)
+                                    return (ltc, tvs, t1:t2:acc)
     go l (HsParTy ty)    acc    = gol ty acc
     go l (HsAppTy t1 t2) acc    = gol t1 (t2:acc)
     go l other          acc    = 
@@ -577,9 +585,9 @@ checkPred (L spn ty)
 
 checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
 checkDerivDecl d@(L loc _) = 
-    do glaExtOn <- extension glaExtsEnabled
-       if glaExtOn then return d
-        else parseError loc "Illegal stand-alone deriving declaration (use -fglasgow-exts)"
+    do stDerivOn <- extension standaloneDerivingEnabled
+       if stDerivOn then return d
+        else parseError loc "Illegal stand-alone deriving declaration (use -XStandaloneDeriving)"
 
 ---------------------------------------------------------------------------
 -- Checking statements in a do-expression
@@ -689,8 +697,9 @@ checkAPat loc e = case e of
    ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
                         return (TuplePat ps b placeHolderType)
    
-   RecordCon c _ (HsRecordBinds fs)   -> mapM checkPatField fs >>= \fs ->
-                        return (ConPatIn c (RecCon (map (uncurry mkRecField) fs)))
+   RecordCon c _ (HsRecFields fs dd) 
+                     -> mapM checkPatField fs >>= \fs ->
+                        return (ConPatIn c (RecCon (HsRecFields fs dd)))
 -- Generics 
    HsType ty          -> return (TypePat ty) 
    _                  -> patFail loc
@@ -699,10 +708,9 @@ plus_RDR, bang_RDR :: RdrName
 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
 bang_RDR = mkUnqual varName FSLIT("!") -- Hack
 
-checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
-checkPatField (n,e) = do
-  p <- checkLPat e
-  return (n,p)
+checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
+checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
+                       ; return (fld { hsRecFieldArg = p }) }
 
 patFail loc = parseError loc "Parse error in pattern"
 
@@ -852,15 +860,17 @@ checkPrecP (L l i)
 mkRecConstrOrUpdate 
        :: LHsExpr RdrName 
        -> SrcSpan
-       -> HsRecordBinds RdrName
+       -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
        -> P (HsExpr RdrName)
 
-mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
-  = return (RecordCon (L l c) noPostTcExpr fs)
-mkRecConstrOrUpdate exp loc fs@(HsRecordBinds (_:_))
-  = return (RecordUpd exp fs [] [] [])
-mkRecConstrOrUpdate _ loc (HsRecordBinds [])
-  = parseError loc "Empty record update"
+mkRecConstrOrUpdate (L l (HsVar c)) loc (fs,dd) | isRdrDataCon c
+  = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
+mkRecConstrOrUpdate exp loc (fs,dd)
+  | null fs   = parseError loc "Empty record update"
+  | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
+
+mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
+mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
 
 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
 -- The Maybe is becuase the user can omit the activation spec (and usually does)