mkHsOpApp,
mkHsIntegral, mkHsFractional, mkHsIsString,
- mkHsDo, mkHsSplice,
+ mkHsDo, mkHsSplice, mkTopSpliceDecl,
mkClassDecl, mkTyData, mkTyFamily, mkTySynonym,
- splitCon, mkInlineSpec,
+ splitCon, mkInlinePragma,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
cvBindGroup,
cvBindsAndSigs,
cvTopDecls,
findSplice, checkDecBrGroup,
+ placeHolderPunRhs,
-- Stuff to do with Foreign declarations
- CallConv(..),
- mkImport, -- CallConv -> Safety
- -- -> (FastString, RdrName, RdrNameHsType)
- -- -> P RdrNameHsDecl
+ mkImport,
parseCImport,
- mkExport, -- CallConv
- -- -> (FastString, RdrName, RdrNameHsType)
- -- -> P RdrNameHsDecl
+ mkExport,
mkExtName, -- RdrName -> CLabelString
mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
mkSimpleConDecl,
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]
import Class ( FunDep )
import TypeRep ( Kind )
import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
- isRdrDataCon, isUnqual, getRdrName, isQual,
- setRdrNameSpace, showRdrName )
-import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo,
- InlinePragma(..), InlineSpec(..),
- alwaysInlineSpec, neverInlineSpec )
+ isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
+import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo,
+ InlinePragma(..) )
import Lexer
import TysWiredIn ( unitTyCon )
-import ForeignCall ( CCallConv(..), Safety, CCallTarget(..), CExportSpec(..),
- DNCallSpec(..), DNKind(..), CLabelString )
+import ForeignCall
import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
occNameString )
import PrelNames ( forall_tv_RDR )
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}
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) $
= 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}
%************************************************************************
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.
"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]
checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
checkAPat dynflags loc e = case e of
- EWildPat -> return (WildPat placeHolderType)
- HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
- ++ showRdrName x)
- | otherwise -> return (VarPat x)
- HsLit l -> return (LitPat l)
+ EWildPat -> return (WildPat placeHolderType)
+ HsVar x -> return (VarPat x)
+ HsLit l -> return (LitPat l)
-- Overloaded numeric patterns (e.g. f 0 x = x)
-- Negation is recorded separately, so that the literal is zero or +ve
HsType ty -> return (TypePat ty)
_ -> patFail loc
-plus_RDR, bang_RDR :: RdrName
+placeHolderPunRhs :: HsExpr RdrName
+-- The RHS of a punned record field will be filled in by the renamer
+-- It's better not to make it an error, in case we want to print it when debugging
+placeHolderPunRhs = HsVar pun_RDR
+
+plus_RDR, bang_RDR, pun_RDR :: RdrName
plus_RDR = mkUnqual varName (fsLit "+") -- Hack
bang_RDR = mkUnqual varName (fsLit "!") -- Hack
+pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side")
checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
-> Located (GRHSs RdrName)
-> P (HsBind RdrName)
checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
- | isQual (unLoc fun)
- = parseErrorSDoc (getLoc fun)
- (ptext (sLit "Qualified name in function definition:") <+> ppr (unLoc fun))
- | otherwise
= do ps <- checkPatterns pats
let match_span = combineSrcSpans lhs_loc rhs_span
return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
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
--- supported calling conventions
---
-data CallConv = CCall CCallConv -- ccall or stdcall
- | DNCall -- .NET
-
-- construct a foreign import declaration
--
-mkImport :: CallConv
+mkImport :: CCallConv
-> Safety
-> (Located FastString, Located RdrName, LHsType RdrName)
-> P (HsDecl RdrName)
-mkImport (CCall cconv) safety (L loc entity, v, ty)
+mkImport cconv safety (L loc entity, v, ty)
| cconv == PrimCallConv = do
let funcTarget = CFunction (StaticTarget entity)
importSpec = CImport PrimCallConv safety nilFS funcTarget
case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
Nothing -> parseError loc "Malformed entity string"
Just importSpec -> return (ForD (ForeignImport v ty importSpec))
-mkImport (DNCall ) _ (entity, v, ty) = do
- spec <- parseDImport entity
- return $ ForD (ForeignImport v ty (DNImport spec))
-- the string "foo" is ambigous: either a header or a C identifier. The
-- C identifier case comes first in the alternatives below, so we pick
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)
return (mkFastString (c:cs)))
---
--- Unravel a dotnet spec string.
---
-parseDImport :: Located FastString -> P DNCallSpec
-parseDImport (L loc entity) = parse0 comps
- where
- comps = words (unpackFS entity)
-
- parse0 [] = d'oh
- parse0 (x : xs)
- | x == "static" = parse1 True xs
- | otherwise = parse1 False (x:xs)
-
- parse1 _ [] = d'oh
- parse1 isStatic (x:xs)
- | x == "method" = parse2 isStatic DNMethod xs
- | x == "field" = parse2 isStatic DNField xs
- | x == "ctor" = parse2 isStatic DNConstructor xs
- parse1 isStatic xs = parse2 isStatic DNMethod xs
-
- parse2 _ _ [] = d'oh
- parse2 isStatic kind (('[':x):xs) =
- case x of
- [] -> d'oh
- vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
- _ -> d'oh
- parse2 isStatic kind xs = parse3 isStatic kind "" xs
-
- parse3 isStatic kind assem [x] =
- return (DNCallSpec isStatic kind assem x
- -- these will be filled in once known.
- (error "FFI-dotnet-args")
- (error "FFI-dotnet-result"))
- parse3 _ _ _ _ = d'oh
-
- d'oh = parseError loc "Malformed entity string"
-
-- construct a foreign export declaration
--
-mkExport :: CallConv
+mkExport :: CCallConv
-> (Located FastString, Located RdrName, LHsType RdrName)
-> P (HsDecl RdrName)
-mkExport (CCall cconv) (L _ entity, v, ty) = return $
+mkExport cconv (L _ entity, v, ty) = return $
ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
where
entity' | nullFS entity = mkExtName (unLoc v)
| otherwise = entity
-mkExport DNCall (L _ _, v, _) =
- parseError (getLoc v){-TODO: not quite right-}
- "Foreign export is not yet supported for .NET"
-- Supplying the ext_name in a foreign decl is optional; if it
-- isn't there, the Haskell name is assumed. Note that no transformation
projects / ghc-hetmet.git / blobdiff