Functions over HsSyn specialised to RdrName.
\begin{code}
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
--- 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/Commentary/CodingStyle#Warnings
--- for details
-
module RdrHsSyn (
extractHsTyRdrTyVars,
extractHsRhoRdrTyVars, extractGenericPatTyVars,
- mkHsOpApp, mkClassDecl,
+ mkHsOpApp,
mkHsIntegral, mkHsFractional, mkHsIsString,
- mkHsDo, mkHsSplice,
- mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,
+ mkHsDo, mkHsSplice, mkTopSpliceDecl,
+ mkClassDecl, mkTyData, mkTyFamily, mkTySynonym,
+ 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
- mkExport, -- CallConv
- -- -> (FastString, RdrName, RdrNameHsType)
- -- -> P RdrNameHsDecl
+ mkImport,
+ parseCImport,
+ mkExport,
mkExtName, -- RdrName -> CLabelString
- mkGadtDecl, -- Located RdrName -> LHsType RdrName -> ConDecl RdrName
-
+ mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
+ mkSimpleConDecl,
+ mkDeprecatedGadtRecordDecl,
+
-- Bunch of functions in the parser monad for
-- checking and constructing values
checkPrecP, -- Int -> P Int
checkContext, -- HsType -> P HsContext
checkPred, -- HsType -> P HsPred
- checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
checkTyVars, -- [LHsType RdrName] -> P ()
- checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
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]
checkMDo, -- [Stmt] -> P [Stmt]
checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
- parseError, -- String -> Pa
+ checkDoAndIfThenElse,
+ parseError,
+ parseErrorSDoc,
) where
import HsSyn -- Lots of it
import Class ( FunDep )
import TypeRep ( Kind )
import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
- isRdrDataCon, isUnqual, getRdrName, isQual,
- setRdrNameSpace, showRdrName )
-import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
-import Lexer ( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled )
+ isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
+import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo,
+ InlinePragma(..), InlineSpec(..) )
+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 DynFlags
import SrcLoc
import OrdList ( OrdList, fromOL )
-import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
+import Bag ( Bag, emptyBag, consBag, foldrBag )
import Outputable
import FastString
+import Maybes
-import List ( isSuffixOf, nubBy )
-import Monad ( unless )
+import Control.Applicative ((<$>))
+import Control.Monad
+import Text.ParserCombinators.ReadP as ReadP
+import Data.List ( nubBy )
+import Data.Char
+
+#include "HsVersions.h"
\end{code}
extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
+extractHsTysRdrTyVars :: [LHsType RdrName] -> [Located RdrName]
+extractHsTysRdrTyVars ty = nubBy eqLocated (extract_ltys ty [])
+
extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
-- This one takes the context and tau-part of a
-- sigma type and returns their free type variables
extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
-extract_pred (HsClassP _ tys) acc = foldr extract_lty acc tys
+extract_pred (HsClassP _ tys) acc = extract_ltys tys acc
extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
extract_pred (HsIParam _ ty ) acc = extract_lty ty acc
+extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName]
+extract_ltys tys acc = foldr extract_lty acc tys
+
extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
extract_lty (L loc ty) acc
= case ty of
HsTyVar tv -> extract_tv loc tv acc
HsBangTy _ ty -> extract_lty ty acc
+ HsRecTy flds -> foldr (extract_lty . cd_fld_type) acc flds
HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
HsListTy ty -> extract_lty ty acc
HsPArrTy ty -> extract_lty ty acc
- HsTupleTy _ tys -> foldr extract_lty acc tys
+ HsModalBoxType ecn ty -> extract_lty ty acc
+ HsTupleTy _ tys -> extract_ltys tys acc
HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
HsPredTy p -> extract_pred p 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
+ HsNumTy {} -> acc
+ HsCoreTy {} -> acc -- The type is closed
+ HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables
+ HsSpliceTy {} -> 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) $
*** See "THE NAMING STORY" in HsDecls ****
\begin{code}
-mkClassDecl :: (LHsContext name, Located name, [LHsTyVarBndr name])
- -> [Located (FunDep name)]
- -> [LSig name]
- -> LHsBinds name
- -> [LTyClDecl name]
- -> [LDocDecl name]
- -> TyClDecl name
-mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats docs
- = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
- tcdFDs = fds,
- tcdSigs = sigs,
- tcdMeths = mbinds,
- tcdATs = ats,
- tcdDocs = docs
- }
-
-mkTyData :: NewOrData
- -> (LHsContext name,
- Located name,
- [LHsTyVarBndr name],
- Maybe [LHsType name])
+mkClassDecl :: SrcSpan
+ -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
+ -> Located [Located (FunDep RdrName)]
+ -> Located (OrdList (LHsDecl RdrName))
+ -> P (LTyClDecl RdrName)
+
+mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
+ = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
+ ; let cxt = fromMaybe (noLoc []) mcxt
+ ; (cls, tparams) <- checkTyClHdr tycl_hdr
+ ; tyvars <- checkTyVars tparams -- Only type vars allowed
+ ; checkKindSigs ats
+ ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
+ tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
+ tcdATs = ats, tcdDocs = docs })) }
+
+mkTyData :: SrcSpan
+ -> NewOrData
+ -> Bool -- True <=> data family instance
+ -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
-> Maybe Kind
- -> [LConDecl name]
- -> Maybe [LHsType name]
- -> TyClDecl name
-mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
- = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
- tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons,
- tcdKindSig = ksig, tcdDerivs = maybe_deriv }
+ -> [LConDecl RdrName]
+ -> Maybe [LHsType RdrName]
+ -> P (LTyClDecl RdrName)
+mkTyData loc new_or_data is_family (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
+ = do { (tc, tparams) <- checkTyClHdr tycl_hdr
+
+ ; checkDatatypeContext mcxt
+ ; let cxt = fromMaybe (noLoc []) mcxt
+ ; (tyvars, typats) <- checkTParams is_family tparams
+ ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
+ tcdTyVars = tyvars, tcdTyPats = typats,
+ tcdCons = data_cons,
+ tcdKindSig = ksig, tcdDerivs = maybe_deriv })) }
+
+mkTySynonym :: SrcSpan
+ -> Bool -- True <=> type family instances
+ -> LHsType RdrName -- LHS
+ -> LHsType RdrName -- RHS
+ -> P (LTyClDecl RdrName)
+mkTySynonym loc is_family lhs rhs
+ = do { (tc, tparams) <- checkTyClHdr lhs
+ ; (tyvars, typats) <- checkTParams is_family tparams
+ ; return (L loc (TySynonym tc tyvars typats rhs)) }
+
+mkTyFamily :: SrcSpan
+ -> FamilyFlavour
+ -> LHsType RdrName -- LHS
+ -> Maybe Kind -- Optional kind signature
+ -> P (LTyClDecl RdrName)
+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
+-- [pads| ... ] then return a QuasiQuoteD
+-- $(e) then return a SpliceD
+-- but if she wrote, say,
+-- f x then behave as if she'd written $(f x)
+-- ie a SpliceD
+mkTopSpliceDecl (L _ (HsQuasiQuoteE qq)) = QuasiQuoteD qq
+mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr Explicit)
+mkTopSpliceDecl other_expr = SpliceD (SpliceDecl other_expr Implicit)
\end{code}
%************************************************************************
cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
cvBindGroup binding
= case cvBindsAndSigs binding of
- (mbs, sigs, [], _) -> -- list of type decls *always* empty
- ValBindsIn mbs sigs
+ (mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
+ 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.
where
go [] = (emptyBag, [], [], [])
go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
- where (bs, ss, ts, docs) = go ds
+ where (bs, ss, ts, docs) = go ds
go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
- where (b', ds') = getMonoBind (L l b) ds
- (bs, ss, ts, docs) = go ds'
+ where (b', ds') = getMonoBind (L l b) ds
+ (bs, ss, ts, docs) = go ds'
go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
- where (bs, ss, ts, docs) = go ds
- go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
- where (bs, ss, ts, docs) = go ds
+ where (bs, ss, ts, docs) = go ds
+ go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
+ where (bs, ss, ts, docs) = go ds
+ go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d)
-----------------------------------------------------------------------------
-- Group function bindings into equation groups
getMonoBind bind binds = (bind, binds)
has_args :: [LMatch RdrName] -> Bool
+has_args [] = panic "RdrHsSyn:has_args"
has_args ((L _ (Match args _ _)) : _) = not (null args)
-- Don't group together FunBinds if they have
-- no arguments. This is necessary now that variable bindings
-- than pattern bindings (tests/rename/should_fail/rnfail002).
\end{code}
-\begin{code}
-findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
-findSplice ds = addl emptyRdrGroup ds
-
-checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a)
--- Turn the body of a [d| ... |] into a HsGroup
--- There should be no splices in the "..."
-checkDecBrGroup decls
- = case addl emptyRdrGroup decls of
- (group, Nothing) -> return group
- (_, Just (SpliceDecl (L loc _), _)) ->
- parseError loc "Declaration splices are not permitted inside declaration brackets"
- -- Why not? See Section 7.3 of the TH paper.
-
-addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
- -- This stuff reverses the declarations (again) but it doesn't matter
-
--- Base cases
-addl gp [] = (gp, Nothing)
-addl gp (L l d : ds) = add gp l d ds
-
-
-add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
- -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
-
-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})
- l (TyClD d) ds
- | isClassDecl d =
- let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
- addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
- | otherwise =
- addl (gp { hs_tyclds = L l d : ts }) ds
-
--- Signatures: fixity sigs go a different place than all others
-add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
- = addl (gp {hs_fixds = L l f : ts}) ds
-add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
- = addl (gp {hs_valds = add_sig (L l d) ts}) ds
-
--- Value declarations: use add_bind
-add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
- = addl (gp { hs_valds = add_bind (L l d) ts }) ds
-
--- The rest are routine
-add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
- = addl (gp { hs_instds = L l d : ts }) ds
-add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
- = addl (gp { hs_derivds = L l d : ts }) ds
-add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
- = addl (gp { hs_defds = L l d : ts }) ds
-add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
- = addl (gp { hs_fords = L l d : ts }) ds
-add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
- = addl (gp { hs_warnds = L l d : ts }) ds
-add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
- = addl (gp { hs_annds = L l d : ts }) ds
-add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
- = addl (gp { hs_ruleds = L l d : ts }) ds
-
-add gp l (DocD d) ds
- = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
-
-add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
-add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
-
-add_sig :: LSig a -> HsValBinds a -> HsValBinds a
-add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
-\end{code}
-
%************************************************************************
%* *
\subsection[PrefixToHS-utils]{Utilities for conversion}
\begin{code}
-----------------------------------------------------------------------------
--- mkPrefixCon
+-- splitCon
-- When parsing data declarations, we sometimes inadvertently parse
-- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
-- This function splits up the type application, adds any pending
-- arguments, and converts the type constructor back into a data constructor.
-mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
- -> P (Located RdrName, HsConDeclDetails RdrName)
-mkPrefixCon ty tys
- = split ty tys
+splitCon :: LHsType RdrName
+ -> P (Located RdrName, HsConDeclDetails RdrName)
+-- This gets given a "type" that should look like
+-- C Int Bool
+-- or C { x::Int, y::Bool }
+-- and returns the pieces
+splitCon ty
+ = split ty []
where
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"
+ return (data_con, mk_rest ts)
+ split (L l _) _ = parseErrorSDoc l (text "parse error in constructor in data/newtype declaration:" <+> ppr ty)
+
+ mk_rest [L _ (HsRecTy flds)] = RecCon flds
+ mk_rest ts = PrefixCon ts
+
+mkDeprecatedGadtRecordDecl :: SrcSpan
+ -> Located RdrName
+ -> [ConDeclField RdrName]
+ -> LHsType RdrName
+ -> P (LConDecl RdrName)
+-- This one uses the deprecated syntax
+-- C { x,y ::Int } :: T a b
+-- We give it a RecCon details right away
+mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
+ = do { data_con <- tyConToDataCon con_loc con
+ ; return (L loc (ConDecl { con_old_rec = True
+ , con_name = data_con
+ , con_explicit = Implicit
+ , con_qvars = []
+ , con_cxt = noLoc []
+ , con_details = RecCon flds
+ , con_res = ResTyGADT res_ty
+ , con_doc = Nothing })) }
+
+mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
+ -> LHsContext RdrName -> HsConDeclDetails RdrName
+ -> ConDecl RdrName
+
+mkSimpleConDecl name qvars cxt details
+ = ConDecl { con_old_rec = False
+ , con_name = name
+ , con_explicit = Explicit
+ , con_qvars = qvars
+ , con_cxt = cxt
+ , con_details = details
+ , con_res = ResTyH98
+ , con_doc = Nothing }
-mkRecCon :: Located RdrName ->
- [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] ->
- P (Located RdrName, HsConDeclDetails RdrName)
-mkRecCon (L loc con) fields
- = do data_con <- tyConToDataCon loc con
- return (data_con, RecCon [ ConDeclField l t d | (ls, t, d) <- fields, l <- ls ])
+mkGadtDecl :: [Located RdrName]
+ -> LHsType RdrName -- Always a HsForAllTy
+ -> [ConDecl RdrName]
+-- We allow C,D :: ty
+-- and expand it as if it had been
+-- C :: ty; D :: ty
+-- (Just like type signatures in general.)
+mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau))
+ = [mk_gadt_con name | name <- names]
+ where
+ (details, res_ty) -- See Note [Sorting out the result type]
+ = case tau of
+ L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds, res_ty)
+ _other -> (PrefixCon [], tau)
+
+ mk_gadt_con name
+ = ConDecl { con_old_rec = False
+ , con_name = name
+ , con_explicit = imp
+ , con_qvars = qvars
+ , con_cxt = cxt
+ , con_details = details
+ , con_res = ResTyGADT res_ty
+ , con_doc = Nothing }
+mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
tyConToDataCon loc tc
extra | tc == forall_tv_RDR
= text "Perhaps you intended to use -XExistentialQuantification"
| otherwise = empty
+\end{code}
+Note [Sorting out the result type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a GADT declaration which is not a record, we put the whole constr
+type into the ResTyGADT for now; the renamer will unravel it once it
+has sorted out operator fixities. Consider for example
+ C :: a :*: b -> a :*: b -> a :+: b
+Initially this type will parse as
+ a :*: (b -> (a :*: (b -> (a :+: b))))
+
+so it's hard to split up the arguments until we've done the precedence
+resolution (in the renamer) On the other hand, for a record
+ { x,y :: Int } -> a :*: b
+there is no doubt. AND we need to sort records out so that
+we can bring x,y into scope. So:
+ * For PrefixCon we keep all the args in the ResTyGADT
+ * For RecCon we do not
+
+\begin{code}
----------------------------------------------------------------------------
-- Various Syntactic Checks
checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
checkDictTy (L spn ty) = check ty []
where
- check (HsTyVar t) args | not (isRdrTyVar t)
- = return (L spn (HsPredTy (HsClassP t args)))
+ check (HsTyVar tc) args | isRdrTc tc = done tc args
+ check (HsOpTy t1 (L _ tc) t2) args | isRdrTc tc = done tc (t1:t2:args)
check (HsAppTy l r) args = check (unLoc l) (r:args)
check (HsParTy t) args = check (unLoc t) args
- check _ _ = parseError spn "Malformed instance header"
+ check _ _ = parseErrorSDoc spn (text "Malformed instance header:" <+> ppr ty)
+ done tc args = return (L spn (HsPredTy (HsClassP tc args)))
+
+checkTParams :: Bool -- Type/data family
+ -> [LHsType RdrName]
+ -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
+-- checkTParams checks the type parameters of a data/newtype declaration
+-- There are two cases:
+--
+-- a) Vanilla data/newtype decl. In that case
+-- - the type parameters should all be type variables
+-- - they may have a kind annotation
+--
+-- b) Family data/newtype decl. In that case
+-- - The type parameters may be arbitrary types
+-- - We find the type-varaible binders by find the
+-- free type vars of those types
+-- - We make them all kind-sig-free binders (UserTyVar)
+-- If there are kind sigs in the type parameters, they
+-- will fix the binder's kind when we kind-check the
+-- type parameters
+checkTParams is_family tparams
+ | not is_family -- Vanilla case (a)
+ = do { tyvars <- checkTyVars tparams
+ ; return (tyvars, Nothing) }
+ | otherwise -- Family case (b)
+ = do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars tparams)
+ ; return (tyvars, Just tparams) }
+
+checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
-- Check whether the given list of type parameters are all type variables
-- (possibly with a kind signature). If the second argument is `False',
-- only type variables are allowed and we raise an error on encountering a
-- non-variable; otherwise, we allow non-variable arguments and return the
-- entire list of parameters.
---
-checkTyVars :: [LHsType RdrName] -> P ()
-checkTyVars tparms = mapM_ chk tparms
+checkTyVars tparms = mapM chk tparms
where
-- Check that the name space is correct!
- chk (L _ (HsKindSig (L _ (HsTyVar tv)) _))
- | isRdrTyVar tv = return ()
- chk (L _ (HsTyVar tv))
- | isRdrTyVar tv = return ()
- chk (L l _) =
- 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 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?
- -> P (Located RdrName, -- head symbol
- [LHsTyVarBndr RdrName], -- parameters
- [LHsType RdrName]) -- type patterns
-checkSynHdr ty isTyInst =
- do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
- ; unless isTyInst $ checkTyVars tparms
- ; return (tc, tvs, tparms) }
-
-
+ chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
+ | isRdrTyVar tv = return (L l (KindedTyVar tv k))
+ chk (L l (HsTyVar tv))
+ | isRdrTyVar tv = return (L l (UserTyVar tv placeHolderKind))
+ chk t@(L l _) =
+ parseErrorSDoc l (text "Type found:" <+> ppr t
+ $$ text "where type variable expected, in:" <+>
+ sep (map (pprParendHsType . unLoc) tparms))
+
+checkDatatypeContext :: Maybe (LHsContext RdrName) -> P ()
+checkDatatypeContext Nothing = return ()
+checkDatatypeContext (Just (L loc c))
+ = do allowed <- extension datatypeContextsEnabled
+ unless allowed $
+ parseErrorSDoc loc
+ (text "Illegal datatype context (use -XDatatypeContexts):" <+>
+ pprHsContext c)
+
+checkTyClHdr :: LHsType RdrName
+ -> P (Located RdrName, -- the head symbol (type or class name)
+ [LHsType RdrName]) -- parameters of head symbol
-- Well-formedness check and decomposition of type and class heads.
---
-checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
- -> P (LHsContext RdrName, -- the type context
- Located RdrName, -- the head symbol (type or class name)
- [LHsTyVarBndr RdrName], -- free variables of the non-context part
- [LHsType RdrName]) -- parameters of head symbol
--- The header of a type or class decl should look like
--- (C a, D b) => T a b
--- or T a b
--- or a + b
--- 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]
--- we return
--- ('()', 'T', ['a'], ['Int', '[a]'])
-checkTyClHdr (L l cxt) ty
- = do (tc, tvs, parms) <- gol ty []
- mapM_ chk_pred cxt
- return (L l cxt, tc, tvs, parms)
+-- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn])
+-- Int :*: Bool into (:*:, [Int, Bool])
+-- returning the pieces
+checkTyClHdr ty
+ = goL ty []
where
- gol (L l ty) acc = go l ty acc
+ goL (L l ty) acc = go l ty acc
go l (HsTyVar tc) acc
- | isRdrTc tc = do tvs <- extractTyVars acc
- return (L l tc, tvs, acc)
+ | isRdrTc tc = return (L l tc, acc)
+
go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
- | isRdrTc tc = do tvs <- extractTyVars (t1:t2:acc)
- return (ltc, tvs, t1:t2:acc)
- go _ (HsParTy ty) acc = gol ty acc
- go _ (HsAppTy t1 t2) acc = gol t1 (t2:acc)
- go l _ _ =
- parseError l "Malformed head of type or class declaration"
-
- -- The predicates in a type or class decl must be class predicates or
- -- equational constraints. They need not all have variable-only
- -- arguments, even in Haskell 98.
- -- E.g. class (Monad m, Monad (t m)) => MonadT t m
- chk_pred (L _ (HsClassP _ _)) = return ()
- chk_pred (L _ (HsEqualP _ _)) = return ()
- chk_pred (L l _)
- = parseError l "Malformed context in type or class declaration"
-
--- Extract the type variables of a list of type parameters.
---
--- * Type arguments can be complex type terms (needed for associated type
--- declarations).
---
-extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
-extractTyVars tvs = collects tvs []
- where
- -- Collect all variables (2nd arg serves as an accumulator)
- collect :: LHsType RdrName -> [LHsTyVarBndr RdrName]
- -> P [LHsTyVarBndr RdrName]
- collect (L l (HsForAllTy _ _ _ _)) =
- const $ parseError l "Forall type not allowed as type parameter"
- collect (L l (HsTyVar tv))
- | isRdrTyVar tv = return . (L l (UserTyVar tv) :)
- | otherwise = return
- collect (L l (HsBangTy _ _ )) =
- const $ parseError l "Bang-style type annotations not allowed as type parameter"
- collect (L _ (HsAppTy t1 t2 )) = collect t2 >=> collect t1
- collect (L _ (HsFunTy t1 t2 )) = collect t2 >=> collect t1
- collect (L _ (HsListTy t )) = collect t
- collect (L _ (HsPArrTy t )) = collect t
- collect (L _ (HsTupleTy _ ts )) = collects ts
- collect (L _ (HsOpTy t1 _ t2 )) = collect t2 >=> collect t1
- collect (L _ (HsParTy t )) = collect t
- collect (L _ (HsNumTy _ )) = return
- collect (L l (HsPredTy _ )) =
- const $ parseError l "Predicate not allowed as type parameter"
- collect (L l (HsKindSig (L _ (HsTyVar tv)) k))
- | isRdrTyVar tv =
- return . (L l (KindedTyVar tv k) :)
- | otherwise =
- const $ parseError l "Kind signature only allowed for type variables"
- collect (L l (HsSpliceTy _ )) =
- const $ parseError l "Splice not allowed as type parameter"
-
- -- Collect all variables of a list of types
- collects [] = return
- collects (t:ts) = collects ts >=> collect t
-
- (f >=> g) x = f x >>= g
+ | isRdrTc tc = return (ltc, t1:t2:acc)
+ go _ (HsParTy ty) acc = goL ty acc
+ go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
+ go l _ _ = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty)
-- Check that associated type declarations of a class are all kind signatures.
--
| isFamilyDecl tydecl
|| isSynDecl tydecl = return ()
| otherwise =
- parseError l "Type declaration in a class must be a kind signature or synonym default"
+ parseErrorSDoc l (text "Type declaration in a class must be a kind signature or synonym default:" $$ ppr tydecl)
checkContext :: LHsType RdrName -> P (LHsContext RdrName)
checkContext (L l t)
check _loc (HsAppTy l r) args = checkl l (r:args)
check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
check _loc (HsParTy t) args = checkl t args
- check loc _ _ = parseError loc
- "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)"
+ check loc _ _ = parseErrorSDoc loc
+ (text "malformed class assertion:" <+> ppr ty)
---------------------------------------------------------------------------
-- Checking statements in a do-expression
checkMDo = checkDoMDo "an " "'mdo'"
checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
-checkDoMDo _ nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
+checkDoMDo _ nm loc [] = parseErrorSDoc loc (text ("Empty " ++ nm ++ " construct"))
checkDoMDo pre nm _ ss = do
check ss
where
+ check [] = panic "RdrHsSyn:checkDoMDo"
check [L _ (ExprStmt e _ _)] = return ([], e)
- check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
- " construct must be an expression")
+ check [L l e] = parseErrorSDoc l
+ (text ("The last statement in " ++ pre ++ nm ++
+ " construct must be an expression:")
+ $$ ppr e)
check (s:ss) = do
(ss',e') <- check ss
return ((s:ss'),e')
checkPat loc (L _ (HsApp f x)) args
= do { x <- checkLPat x; checkPat loc f (x:args) }
checkPat loc (L _ e) []
- = do { p <- checkAPat loc e; return (L loc p) }
-checkPat loc _ _
- = patFail loc
-
-checkAPat :: SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
-checkAPat 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)
+ = do { pState <- getPState
+ ; p <- checkAPat (dflags pState) loc e
+ ; return (L loc p) }
+checkPat loc e _
+ = patFail loc (unLoc e)
+
+checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
+checkAPat dynflags loc e0 = case e0 of
+ 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
| bang == bang_RDR
-> do { bang_on <- extension bangPatEnabled
; if bang_on then checkLPat e >>= (return . BangPat)
- else parseError loc "Illegal bang-pattern (use -XBangPatterns)" }
+ else parseErrorSDoc loc (text "Illegal bang-pattern (use -XBangPatterns):" $$ ppr e0) }
ELazyPat e -> checkLPat e >>= (return . LazyPat)
EAsPat n e -> checkLPat e >>= (return . AsPat n)
-- n+k patterns
OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
(L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
- | plus == plus_RDR
+ | xopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
-> return (mkNPlusKPat (L nloc n) lit)
OpApp l op _fix r -> do l <- checkLPat l
case op of
L cl (HsVar c) | isDataOcc (rdrNameOcc c)
-> return (ConPatIn (L cl c) (InfixCon l r))
- _ -> patFail loc
+ _ -> patFail loc e0
HsPar e -> checkLPat e >>= (return . ParPat)
ExplicitList _ es -> do ps <- mapM checkLPat es
ExplicitPArr _ es -> do ps <- mapM checkLPat es
return (PArrPat ps placeHolderType)
- ExplicitTuple es b -> do ps <- mapM checkLPat es
- return (TuplePat ps b placeHolderType)
+ ExplicitTuple es b
+ | all tupArgPresent es -> do ps <- mapM checkLPat [e | Present e <- es]
+ return (TuplePat ps b placeHolderType)
+ | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
RecordCon c _ (HsRecFields fs dd)
-> do fs <- mapM checkPatField fs
HsQuasiQuoteE q -> return (QuasiQuotePat q)
-- Generics
HsType ty -> return (TypePat ty)
- _ -> patFail loc
+ _ -> patFail loc e0
+
+placeHolderPunRhs :: LHsExpr 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 = noLoc (HsVar pun_RDR)
-plus_RDR, bang_RDR :: RdrName
+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)
; return (fld { hsRecFieldArg = p }) }
-patFail :: SrcSpan -> P a
-patFail loc = parseError loc "Parse error in pattern"
+patFail :: SrcSpan -> HsExpr RdrName -> P a
+patFail loc e = parseErrorSDoc loc (text "Parse error in pattern:" <+> ppr e)
---------------------------------------------------------------------------
-> 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)])
:: LHsExpr RdrName
-> LHsType RdrName
-> P (Sig RdrName)
+checkValSig (L l (HsHetMetBrak _ e)) ty
+ = checkValSig e ty
checkValSig (L l (HsVar v)) ty
| isUnqual v && not (isDataOcc (rdrNameOcc v))
= return (TypeSig (L l v) ty)
-checkValSig (L l _) _
- = parseError l "Invalid type signature"
-
-mkGadtDecl :: Located RdrName
- -> LHsType RdrName -- assuming HsType
- -> ConDecl RdrName
-mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
-mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty
-
-mk_gadt_con :: Located RdrName
- -> [LHsTyVarBndr RdrName]
- -> LHsContext RdrName
- -> LHsType RdrName
- -> ConDecl RdrName
-mk_gadt_con name qvars cxt ty
- = ConDecl { con_name = name
- , con_explicit = Implicit
- , con_qvars = qvars
- , con_cxt = cxt
- , con_details = PrefixCon []
- , con_res = ResTyGADT ty
- , con_doc = Nothing }
- -- NB: we put the whole constr type into the ResTyGADT for now;
- -- the renamer will unravel it once it has sorted out
- -- operator fixities
-
--- A variable binding is parsed as a FunBind.
+checkValSig lhs@(L l _) ty
+ = parseErrorSDoc l ((text "Invalid type signature:" <+>
+ ppr lhs <+> text "::" <+> ppr ty)
+ $$ text hint)
+ where
+ hint = if looks_like_foreign lhs
+ then "Perhaps you meant to use -XForeignFunctionInterface?"
+ else "Should be of form <variable> :: <type>"
+ -- A common error is to forget the ForeignFunctionInterface flag
+ -- so check for that, and suggest. cf Trac #3805
+ -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
+ looks_like_foreign (L _ (HsVar v)) = v == foreign_RDR
+ looks_like_foreign (L _ (HsApp lhs _)) = looks_like_foreign lhs
+ looks_like_foreign _ = False
+
+ foreign_RDR = mkUnqual varName (fsLit "foreign")
+
+checkDoAndIfThenElse :: LHsExpr RdrName
+ -> Bool
+ -> LHsExpr RdrName
+ -> Bool
+ -> LHsExpr RdrName
+ -> P ()
+checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
+ | semiThen || semiElse
+ = do pState <- getPState
+ unless (xopt Opt_DoAndIfThenElse (dflags pState)) $ do
+ parseErrorSDoc (combineLocs guardExpr elseExpr)
+ (text "Unexpected semi-colons in conditional:"
+ $$ nest 4 expr
+ $$ text "Perhaps you meant to use -XDoAndIfThenElse?")
+ | otherwise = return ()
+ where pprOptSemi True = semi
+ pprOptSemi False = empty
+ expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+>
+ text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+>
+ text "else" <+> ppr elseExpr
+\end{code}
+\begin{code}
-- The parser left-associates, so there should
-- not be any OpApps inside the e's
splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
isFunLhs :: LHsExpr RdrName
-> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
+-- A variable binding is parsed as a FunBind.
-- Just (fun, is_infix, arg_pats) if e is a function LHS
--
-- The whole LHS is parsed as a single expression.
checkPrecP :: Located Int -> P Int
checkPrecP (L l i)
| 0 <= i && i <= maxPrecedence = return i
- | otherwise = parseError l "Precedence out of range"
+ | otherwise
+ = parseErrorSDoc l (text ("Precedence out of range: " ++ show i))
mkRecConstrOrUpdate
:: LHsExpr RdrName
mkRecConstrOrUpdate (L l (HsVar c)) _ (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"
+ | null fs = parseErrorSDoc loc (text "Empty record update of:" <+> ppr exp)
| otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
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 -> Bool -> InlineSpec
--- The Maybe is becuase the user can omit the activation spec (and usually does)
-mkInlineSpec Nothing True = alwaysInlineSpec -- INLINE
-mkInlineSpec Nothing False = neverInlineSpec -- NOINLINE
-mkInlineSpec (Just act) inl = Inline act inl
-
+mkInlinePragma :: (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma
+-- The Maybe is because the user can omit the activation spec (and usually does)
+mkInlinePragma (inl, match_info) mb_act
+ = InlinePragma { inl_inline = inl
+ , inl_sat = Nothing
+ , inl_act = act
+ , inl_rule = match_info }
+ where
+ act = case mb_act of
+ Just act -> act
+ Nothing -> -- No phase specified
+ case inl of
+ NoInline -> NeverActive
+ _other -> AlwaysActive
-----------------------------------------------------------------------------
-- 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 (entity, v, ty) = do
- importSpec <- parseCImport entity cconv safety v
+mkImport cconv safety (L loc entity, v, ty)
+ | cconv == PrimCallConv = do
+ let funcTarget = CFunction (StaticTarget entity Nothing)
+ importSpec = CImport PrimCallConv safety nilFS funcTarget
return (ForD (ForeignImport v ty importSpec))
-mkImport (DNCall ) _ (entity, v, ty) = do
- spec <- parseDImport entity
- return $ ForD (ForeignImport v ty (DNImport spec))
-
--- parse the entity string of a foreign import declaration for the `ccall' or
--- `stdcall' calling convention'
---
-parseCImport :: Located FastString
- -> CCallConv
- -> Safety
- -> Located RdrName
- -> P ForeignImport
-parseCImport (L loc entity) cconv safety v
- -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
- | entity == fsLit "dynamic" =
- return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
- | entity == fsLit "wrapper" =
- return $ CImport cconv safety nilFS nilFS CWrapper
- | otherwise = parse0 (unpackFS entity)
- where
- -- using the static keyword?
- parse0 (' ': rest) = parse0 rest
- parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
- parse0 rest = parse1 rest
- -- check for header file name
- parse1 "" = parse4 "" nilFS False nilFS
- parse1 (' ':rest) = parse1 rest
- parse1 str@('&':_ ) = parse2 str nilFS
- parse1 str@('[':_ ) = parse3 str nilFS False
- parse1 str
- | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
- | otherwise = parse4 str nilFS False nilFS
- where
- (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
- -- check for address operator (indicating a label import)
- parse2 "" header = parse4 "" header False nilFS
- parse2 (' ':rest) header = parse2 rest header
- parse2 ('&':rest) header = parse3 rest header True
- parse2 str@('[':_ ) header = parse3 str header False
- parse2 str header = parse4 str header False nilFS
- -- check for library object name
- parse3 (' ':rest) header isLbl = parse3 rest header isLbl
- parse3 ('[':rest) header isLbl =
- case break (== ']') rest of
- (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
- _ -> parseError loc "Missing ']' in entity"
- parse3 str header isLbl = parse4 str header isLbl nilFS
- -- check for name of C function
- parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
- parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
- parse4 str header isLbl lib
- | all (== ' ') rest = build (mkFastString first) header isLbl lib
- | otherwise = parseError loc "Malformed entity string"
- where
- (first, rest) = break (== ' ') str
- --
- build cid header False lib = return $
- CImport cconv safety header lib (CFunction (StaticTarget cid))
- build cid header True lib = return $
- CImport cconv safety header lib (CLabel cid )
---
--- Unravel a dotnet spec string.
---
-parseDImport :: Located FastString -> P DNCallSpec
-parseDImport (L loc entity) = parse0 comps
+ | otherwise = do
+ case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
+ Nothing -> parseErrorSDoc loc (text "Malformed entity string")
+ Just importSpec -> return (ForD (ForeignImport v ty importSpec))
+
+-- 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
+-- that one.
+parseCImport :: CCallConv -> Safety -> FastString -> String
+ -> Maybe ForeignImport
+parseCImport cconv safety nm str =
+ listToMaybe $ map fst $ filter (null.snd) $
+ readP_to_S parse str
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"
-
+ parse = do
+ skipSpaces
+ r <- choice [
+ string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)),
+ string "wrapper" >> return (mk nilFS CWrapper),
+ optional (string "static" >> skipSpaces) >>
+ (mk nilFS <$> cimp nm) +++
+ (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm)
+ ]
+ skipSpaces
+ return r
+
+ mk = CImport cconv safety
+
+ 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)
+ +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid)
+ where
+ cid = return nm +++
+ (do c <- satisfy (\c -> isAlpha c || c == '_')
+ cs <- many (satisfy id_char)
+ return (mkFastString (c:cs)))
+
+
-- 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