Make the alternative layout rule cope with file pragmas

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

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index e8d00a2..9af7e2f 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -10,9 +10,9 @@ module RdrHsSyn (
  
        mkHsOpApp, 
        mkHsIntegral, mkHsFractional, mkHsIsString,
-       mkHsDo, mkHsSplice,
+       mkHsDo, mkHsSplice, mkTopSpliceDecl,
         mkClassDecl, mkTyData, mkTyFamily, mkTySynonym,
-        splitCon, mkInlineSpec,        
+        splitCon, mkInlinePragma,      
        mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
 
        cvBindGroup,
@@ -38,7 +38,6 @@ module RdrHsSyn (
        checkTyVars,          -- [LHsType RdrName] -> P ()
        checkKindSigs,        -- [LTyClDecl RdrName] -> P ()
        checkInstType,        -- HsType -> P HsType
-        checkDerivDecl,       -- LDerivDecl RdrName -> P (LDerivDecl RdrName)
        checkPattern,         -- HsExp -> P HsPat
        bang_RDR,
        checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
@@ -55,9 +54,8 @@ import Class            ( FunDep )
 import TypeRep          ( Kind )
 import RdrName         ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, 
                          isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
-import BasicTypes      ( maxPrecedence, Activation, RuleMatchInfo,
-                          InlinePragma(..),  InlineSpec(..),
-                          alwaysInlineSpec, neverInlineSpec )
+import BasicTypes      ( maxPrecedence, Activation(..), RuleMatchInfo,
+                          InlinePragma(..) )
 import Lexer
 import TysWiredIn      ( unitTyCon ) 
 import ForeignCall
@@ -75,7 +73,7 @@ import Maybes
 import Control.Applicative ((<$>))       
 import Text.ParserCombinators.ReadP as ReadP
 import Data.List        ( nubBy )
-import Data.Char        ( isAscii, isAlphaNum, isAlpha )
+import Data.Char
 
 #include "HsVersions.h"
 \end{code}
@@ -129,7 +127,8 @@ extract_lty (L loc ty) acc
       HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
       HsParTy ty                       -> extract_lty ty acc
       HsNumTy _                 -> acc
-      HsSpliceTy _                     -> acc  -- Type splices mention no type variables
+      HsSpliceTy {}            -> acc  -- Type splices mention no type variables
+      HsSpliceTyOut {}                 -> acc  -- Type splices mention no type variables
       HsKindSig ty _            -> extract_lty ty acc
       HsForAllTy _ [] cx ty     -> extract_lctxt cx (extract_lty ty acc)
       HsForAllTy _ tvs cx ty    -> acc ++ (filter ((`notElem` locals) . unLoc) $
@@ -224,6 +223,20 @@ mkTyFamily loc flavour lhs ksig
   = do { (tc, tparams) <- checkTyClHdr lhs
        ; tyvars <- checkTyVars tparams
        ; return (L loc (TyFamily flavour tc tyvars ksig)) }
+
+mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
+-- If the user wrote
+--     $(e)
+-- then that's the splice, but if she wrote, say,
+--      f x
+-- then behave as if she'd written
+--      $(f x)
+mkTopSpliceDecl expr
+  = SpliceD (SpliceDecl expr')
+  where
+    expr' = case expr of
+              (L _ (HsSpliceE (HsSplice _ expr))) -> expr
+              _other                              -> expr
 \end{code}
 
 %************************************************************************
@@ -256,7 +269,7 @@ cvBindGroup binding
                                 ValBindsIn mbs sigs
 
 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
-  -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName])
+  -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl])
 -- Input decls contain just value bindings and signatures
 -- and in case of class or instance declarations also
 -- associated type declarations. They might also contain Haddock comments.
@@ -659,15 +672,6 @@ checkPred (L spn ty)
                                                "malformed class assertion"
 
 ---------------------------------------------------------------------------
--- Checking stand-alone deriving declarations
-
-checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
-checkDerivDecl d@(L loc _) = 
-    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
 --     We parse   do { e1 ; e2 ; }
 --     as [ExprStmt e1, ExprStmt e2]
@@ -955,13 +959,20 @@ mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
 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 -> RuleMatchInfo -> Bool -> InlineSpec
--- The Maybe is becuase the user can omit the activation spec (and usually does)
-mkInlineSpec Nothing    match_info True  = alwaysInlineSpec match_info
-                                                                -- INLINE
-mkInlineSpec Nothing   match_info False = neverInlineSpec  match_info
-                                                                -- NOINLINE
-mkInlineSpec (Just act) match_info inl   = Inline (InlinePragma act match_info) inl
+mkInlinePragma :: Maybe Activation -> RuleMatchInfo -> Bool -> InlinePragma
+-- The Maybe is because the user can omit the activation spec (and usually does)
+mkInlinePragma mb_act match_info inl 
+  = InlinePragma { inl_inline = inl
+                 , inl_act    = act
+                 , inl_rule   = match_info }
+  where
+    act = case mb_act of
+            Just act -> act
+            Nothing | inl       -> AlwaysActive
+                    | otherwise -> NeverActive
+        -- If no specific phase is given then:
+       --   NOINLINE => NeverActive
+        --   INLINE   => Active
 
 -----------------------------------------------------------------------------
 -- utilities for foreign declarations
@@ -1001,7 +1012,9 @@ parseCImport cconv safety nm str =
 
    mk = CImport cconv safety
 
-   hdr_char c = isAscii c && (isAlphaNum c || c `elem` "._")
+   hdr_char c = not (isSpace c) -- header files are filenames, which can contain
+                                -- pretty much any char (depending on the platform),
+                                -- so just accept any non-space character
    id_char  c = isAlphaNum c || c == '_'
 
    cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)