\begin{code}
module ParseUtil (
parseError -- String -> Pa
- , srcParseErr -- StringBuffer -> SrcLoc -> Message
, cbot -- a
, splitForConApp -- RdrNameHsType -> [RdrNameBangType]
-- -> P (RdrName, [RdrNameBangType])
, checkPrec -- String -> P String
, checkContext -- HsType -> P HsContext
, checkInstType -- HsType -> P HsType
- , checkAssertion -- HsType -> P HsAsst
, checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName])
, checkSimple -- HsType -> [HsName] -> P ((HsName,[HsName]))
, checkPattern -- HsExp -> P HsPat
, checkPatterns -- [HsExp] -> P [HsPat]
-- , checkExpr -- HsExp -> P HsExp
, checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
+ , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
-- some built-in names (all :: RdrName)
import RdrHsSyn
import RdrName
import CallConv
-import PrelMods ( pRELUDE_Name, mkUbxTupNameStr, mkTupNameStr )
-import OccName ( dataName, tcName, varName, tvName, setOccNameSpace, occNameFS )
+import PrelNames ( pRELUDE_Name, mkTupNameStr )
+import OccName ( dataName, tcName, varName, tvName, setOccNameSpace, occNameUserString )
import CmdLineOpts ( opt_NoImplicitPrelude )
import StringBuffer ( lexemeToString )
import FastString ( unpackFS )
+import BasicTypes ( Boxity(..) )
import ErrUtils
import UniqFM ( UniqFM, listToUFM, lookupUFM )
import Outputable
getSrcLocP `thenP` \ loc ->
failMsgP (hcat [ppr loc, text ": ", text s])
-srcParseErr :: StringBuffer -> SrcLoc -> Message
-srcParseErr s l
- = hcat [ppr l,
- if null token
- then ptext SLIT(": parse error (possibly incorrect indentation)")
- else hcat [ptext SLIT(": parse error on input "),
- char '`', text token, char '\'']
- ]
- where
- token = lexemeToString s
-
cbot = panic "CCall:result_ty"
-----------------------------------------------------------------------------
splitForConApp t ts = split t ts
where
- split (MonoTyApp t u) ts = split t (Unbanged u : ts)
+ split (HsAppTy t u) ts = split t (Unbanged u : ts)
- split (MonoTyVar t) ts = returnP (con, ts)
+ split (HsTyVar t) ts = returnP (con, ts)
where t_occ = rdrNameOcc t
con = setRdrNameOcc t (setOccNameSpace t_occ dataName)
checkInstType t
= case t of
HsForAllTy tvs ctxt ty ->
- checkAssertion ty [] `thenP` \(c,ts)->
- returnP (HsForAllTy tvs ctxt (MonoDictTy c ts))
+ checkDictTy ty [] `thenP` \ dict_ty ->
+ returnP (HsForAllTy tvs ctxt dict_ty)
- ty -> checkAssertion ty [] `thenP` \(c,ts)->
- returnP (HsForAllTy Nothing [] (MonoDictTy c ts))
+ ty -> checkDictTy ty [] `thenP` \ dict_ty->
+ returnP (HsForAllTy Nothing [] dict_ty)
checkContext :: RdrNameHsType -> P RdrNameContext
-checkContext (MonoTupleTy ts True)
- = mapP (\t -> checkAssertion t []) ts `thenP` \cs ->
- returnP cs
-checkContext (MonoTyVar t) -- empty contexts are allowed
+checkContext (HsTupleTy _ ts)
+ = mapP (\t -> checkPred t []) ts `thenP` \ps ->
+ returnP ps
+checkContext (HsTyVar t) -- empty contexts are allowed
| t == unitTyCon_RDR = returnP []
checkContext t
- = checkAssertion t [] `thenP` \c ->
- returnP [c]
-
-checkAssertion :: RdrNameHsType -> [RdrNameHsType]
- -> P (ClassAssertion RdrName)
-checkAssertion (MonoTyVar t) args@(_:_) | not (isRdrTyVar t)
- = returnP (t,args)
-checkAssertion (MonoTyApp l r) args = checkAssertion l (r:args)
-checkAssertion _ _ = parseError "Illegal class assertion"
+ = checkPred t [] `thenP` \p ->
+ returnP [p]
+
+checkPred :: RdrNameHsType -> [RdrNameHsType]
+ -> P (HsPred RdrName)
+checkPred (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
+ = returnP (HsPClass t args)
+checkPred (HsAppTy l r) args = checkPred l (r:args)
+checkPred (HsPredTy (HsPIParam n ty)) [] = returnP (HsPIParam n ty)
+checkPred _ _ = parseError "Illegal class assertion"
+
+checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
+checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
+ = returnP (mkHsDictTy t args)
+checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
+checkDictTy _ _ = parseError "Illegal class assertion"
checkDataHeader :: RdrNameHsType
-> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
returnP ([],c,map UserTyVar ts)
checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
-checkSimple (MonoTyApp l (MonoTyVar a)) xs | isRdrTyVar a
+checkSimple (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a
= checkSimple l (a:xs)
-checkSimple (MonoTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs)
+checkSimple (HsTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs)
checkSimple t _ = trace (showSDoc (ppr t)) $ parseError "Illegal data/newtype declaration"
---------------------------------------------------------------------------
checkPat e [] = case e of
EWildPat -> returnP WildPatIn
HsVar x -> returnP (VarPatIn x)
- HsLit l -> returnP (LitPatIn l)
+ HsLit l -> returnP (LitPatIn l)
ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPatIn)
EAsPat n e -> checkPat e [] `thenP` (returnP . AsPatIn n)
ExprWithTySig e t -> checkPat e [] `thenP` \e ->
checkExpr :: RdrNameHsExpr -> P RdrNameHsExpr
checkExpr e = case e of
HsVar _ -> returnP e
+ HsIPVar _ -> returnP e
HsLit _ -> returnP e
HsLam match -> checkMatch match `thenP` (returnP.HsLam)
HsApp e1 e2 -> check2Exprs e1 e2 HsApp
-> Maybe RdrNameHsType
-> RdrNameGRHSs
-> SrcLoc
- -> P RdrNameMonoBinds
+ -> P RdrBinding
checkValDef lhs opt_sig grhss loc
= case isFunLhs lhs [] of
Just (f,inf,es) ->
checkPatterns es `thenP` \ps ->
- returnP (FunMonoBind f inf [Match [] ps opt_sig grhss] loc)
+ returnP (RdrValBinding (FunMonoBind f inf [Match [] ps opt_sig grhss] loc))
Nothing ->
checkPattern lhs `thenP` \lhs ->
- returnP (PatMonoBind lhs grhss loc)
+ returnP (RdrValBinding (PatMonoBind lhs grhss loc))
+
+checkValSig
+ :: RdrNameHsExpr
+ -> RdrNameHsType
+ -> SrcLoc
+ -> P RdrBinding
+checkValSig (HsVar v) ty loc = returnP (RdrSig (Sig v ty loc))
+checkValSig other ty loc = parseError "Type signature given for an expression"
+
--- A variable binding is parsed as an RdrNamePatBind.
+-- A variable binding is parsed as an RdrNameFunMonoBind.
+-- See comments with HsBinds.MonoBinds
-isFunLhs (OpApp l (HsVar op) fix r) [] | not (isRdrDataCon op)
- = Just (op, True, [l,r])
-isFunLhs (HsVar f) es@(_:_) | not (isRdrDataCon f)
+isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op)
+ = Just (op, True, (l:r:es))
+isFunLhs (HsVar f) es | not (isRdrDataCon f)
= Just (f,False,es)
isFunLhs (HsApp f e) es = isFunLhs f (e:es)
isFunLhs (HsPar e) es = isFunLhs e es
mkRecConstrOrUpdate _ _
= parseError "Empty record update"
--- supplying the ext_name in a foreign decl is optional ; if it
+-- Supplying the ext_name in a foreign decl is optional ; if it
-- isn't there, the Haskell name is assumed. Note that no transformation
-- of the Haskell name is then performed, so if you foreign export (++),
--- it's external name will be "++". Too bad.
+-- it's external name will be "++". Too bad; it's important because we don't
+-- want z-encoding (e.g. names with z's in them shouldn't be doubled)
+-- (This is why we use occNameUserString.)
mkExtName :: Maybe ExtName -> RdrName -> ExtName
-mkExtName Nothing rdrNm = ExtName (occNameFS (rdrNameOcc rdrNm)) Nothing
+mkExtName Nothing rdrNm = ExtName (_PK_ (occNameUserString (rdrNameOcc rdrNm)))
+ Nothing
mkExtName (Just x) _ = x
-----------------------------------------------------------------------------
| otherwise = mkPreludeQual tcName pRELUDE_Name funName
tupleCon_RDR arity
- | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr arity))
+ | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr Boxed arity))
| otherwise = mkPreludeQual dataName pRELUDE_Name
- (snd (mkTupNameStr arity))
+ (snd (mkTupNameStr Boxed arity))
tupleTyCon_RDR arity
- | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr arity))
+ | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr Boxed arity))
| otherwise = mkPreludeQual tcName pRELUDE_Name
- (snd (mkTupNameStr arity))
+ (snd (mkTupNameStr Boxed arity))
ubxTupleCon_RDR arity
- | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkUbxTupNameStr arity))
+ | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr Unboxed arity))
| otherwise = mkPreludeQual dataName pRELUDE_Name
- (snd (mkUbxTupNameStr arity))
+ (snd (mkTupNameStr Unboxed arity))
ubxTupleTyCon_RDR arity
- | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkUbxTupNameStr arity))
+ | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr Unboxed arity))
| otherwise = mkPreludeQual tcName pRELUDE_Name
- (snd (mkUbxTupNameStr arity))
+ (snd (mkTupNameStr Unboxed arity))
unitName = SLIT("()")
funName = SLIT("(->)")
projects / ghc-hetmet.git / blobdiff