module ParseUtil (
parseError -- String -> Pa
, cbot -- a
- , splitForConApp -- RdrNameHsType -> [RdrNameBangType]
- -- -> P (RdrName, [RdrNameBangType])
+ , mkVanillaCon, mkRecCon,
, mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp
, groupBindings
-- , checkExpr -- HsExp -> P HsExp
, checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
, checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
-
-
- -- some built-in names (all :: RdrName)
- , unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR
- , tupleCon_RDR, tupleTyCon_RDR, ubxTupleCon_RDR, ubxTupleTyCon_RDR
- , funTyCon_RDR
-
- -- pseudo-keywords, in var and tyvar forms (all :: RdrName)
- , as_var_RDR, hiding_var_RDR, qualified_var_RDR, forall_var_RDR
- , export_var_RDR, label_var_RDR, dynamic_var_RDR, unsafe_var_RDR
- , stdcall_var_RDR, ccall_var_RDR
-
- , as_tyvar_RDR, hiding_tyvar_RDR, qualified_tyvar_RDR
- , export_tyvar_RDR, label_tyvar_RDR, dynamic_tyvar_RDR
- , unsafe_tyvar_RDR, stdcall_tyvar_RDR, ccall_tyvar_RDR
-
- , minus_RDR, pling_RDR, dot_RDR
-
) where
#include "HsVersions.h"
import Lex
-import HsSyn
+import HsSyn -- Lots of it
import SrcLoc
-import RdrHsSyn
+import RdrHsSyn ( RdrBinding(..),
+ RdrNameHsType, RdrNameBangType, RdrNameContext,
+ RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr, RdrNameGRHSs,
+ RdrNameHsRecordBinds, RdrNameMonoBinds, RdrNameConDetails
+ )
import RdrName
+import PrelNames ( unitTyCon_RDR, minus_RDR )
import CallConv
-import PrelNames ( pRELUDE_Name, mkTupNameStr )
-import OccName ( dataName, tcName, varName, tvName, setOccNameSpace, occNameUserString )
-import CmdLineOpts ( opt_NoImplicitPrelude )
-import StringBuffer ( lexemeToString )
+import OccName ( dataName, varName, tcClsName,
+ occNameSpace, setOccNameSpace, occNameUserString )
import FastString ( unpackFS )
-import BasicTypes ( Boxity(..) )
import UniqFM ( UniqFM, listToUFM, lookupUFM )
import Outputable
cbot = panic "CCall:result_ty"
-----------------------------------------------------------------------------
--- splitForConApp
+-- mkVanillaCon
-- 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.
-splitForConApp :: RdrNameHsType -> [RdrNameBangType]
- -> P (RdrName, [RdrNameBangType])
+mkVanillaCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails)
-splitForConApp t ts = split t ts
+mkVanillaCon ty tys
+ = split ty tys
where
- split (HsAppTy t u) ts = split t (Unbanged u : ts)
-
- split (HsTyVar t) ts = returnP (con, ts)
- where t_occ = rdrNameOcc t
- con = setRdrNameOcc t (setOccNameSpace t_occ dataName)
+ split (HsAppTy t u) ts = split t (Unbanged u : ts)
+ split (HsTyVar tc) ts = tyConToDataCon tc `thenP` \ data_con ->
+ returnP (data_con, VanillaCon ts)
+ split _ _ = parseError "Illegal data/newtype declaration"
+
+mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails)
+mkRecCon con fields
+ = tyConToDataCon con `thenP` \ data_con ->
+ returnP (data_con, RecCon fields)
+
+tyConToDataCon :: RdrName -> P RdrName
+tyConToDataCon tc
+ | occNameSpace tc_occ == tcClsName
+ = returnP (setRdrNameOcc tc (setOccNameSpace tc_occ dataName))
+ | otherwise
+ = parseError (showSDoc (text "not a constructor:" <+> quotes (ppr tc)))
+ where
+ tc_occ = rdrNameOcc tc
- split _ _ = parseError "Illegal data/newtype declaration"
----------------------------------------------------------------------------
-- Various Syntactic Checks
checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
checkDictTy _ _ = parseError "Illegal class assertion"
+-- Put more comments!
+-- Checks that the lhs of a datatype declaration
+-- is of the form Context => T a b ... z
checkDataHeader :: RdrNameHsType
-> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
+
checkDataHeader (HsForAllTy Nothing cs t) =
checkSimple t [] `thenP` \(c,ts) ->
returnP (cs,c,map UserTyVar ts)
checkSimple t [] `thenP` \(c,ts) ->
returnP ([],c,map UserTyVar ts)
+-- Checks the type part of the lhs of a datatype declaration
checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
checkSimple (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a
= checkSimple l (a:xs)
-checkSimple (HsTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs)
-checkSimple t _ = trace (showSDoc (ppr t)) $ parseError "Illegal data/newtype declaration"
+checkSimple (HsTyVar tycon) xs | not (isRdrTyVar tycon) = returnP (tycon,xs)
+
+checkSimple (HsOpTy (HsTyVar t1) tycon (HsTyVar t2)) []
+ | not (isRdrTyVar tycon) && isRdrTyVar t1 && isRdrTyVar t2
+ = returnP (tycon,[t1,t2])
+
+checkSimple t _ = parseError "Illegal left hand side in data/newtype declaration"
---------------------------------------------------------------------------
-- Checking Patterns.
-- We parse patterns as expressions and check for valid patterns below,
--- nverting the expression into a pattern at the same time.
+-- converting the expression into a pattern at the same time.
checkPattern :: RdrNameHsExpr -> P RdrNamePat
checkPattern e = checkPat e []
EWildPat -> returnP WildPatIn
HsVar x -> returnP (VarPatIn x)
HsLit l -> returnP (LitPatIn l)
+ HsOverLit l -> returnP (NPatIn l)
ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPatIn)
EAsPat n e -> checkPat e [] `thenP` (returnP . AsPatIn n)
ExprWithTySig e t -> checkPat e [] `thenP` \e ->
- -- pattern signatures are parsed as sigtypes,
+ -- Pattern signatures are parsed as sigtypes,
-- but they aren't explicit forall points. Hence
-- we have to remove the implicit forall here.
let t' = case t of
in
returnP (SigPatIn e t')
- OpApp (HsVar n) (HsVar plus) _ (HsLit k@(HsInt _)) | plus == plus_RDR
- -> returnP (NPlusKPatIn n k)
+ OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral k _))
+ | plus == plus_RDR
+ -> returnP (NPlusKPatIn n lit minus_RDR)
+ where
+ plus_RDR = mkUnqual varName SLIT("+") -- Hack
OpApp l op fix r -> checkPat l [] `thenP` \l ->
checkPat r [] `thenP` \r ->
HsVar c -> returnP (ConOpPatIn l c fix r)
_ -> patFail
- NegApp l r -> checkPat l [] `thenP` (returnP . NegPatIn)
HsPar e -> checkPat e [] `thenP` (returnP . ParPatIn)
ExplicitList es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
returnP (ListPatIn ps)
+
ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
returnP (TuplePatIn ps b)
+
RecordCon c fs -> mapP checkPatField fs `thenP` \fs ->
returnP (RecPatIn c fs)
+-- Generics
+ HsType ty -> returnP (TypePatIn ty)
_ -> patFail
checkPat _ _ = patFail
patFail = parseError "Parse error in pattern"
----------------------------------------------------------------------------
--- Check Expression Syntax
-
-{-
-We can get away without checkExpr if the renamer generates errors for
-pattern syntax used in expressions (wildcards, as patterns and lazy
-patterns).
-
-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
- OpApp e1 e2 fix e3 -> checkExpr e1 `thenP` \e1 ->
- checkExpr e2 `thenP` \e2 ->
- checkExpr e3 `thenP` \e3 ->
- returnP (OpApp e1 e2 fix e3)
- NegApp e neg -> checkExpr e `thenP` \e ->
- returnP (NegApp e neg)
- HsPar e -> check1Expr e HsPar
- SectionL e1 e2 -> check2Exprs e1 e2 SectionL
- SectionR e1 e2 -> check2Exprs e1 e2 SectionR
- HsCase e alts -> mapP checkMatch alts `thenP` \alts ->
- checkExpr e `thenP` \e ->
- returnP (HsCase e alts)
- HsIf e1 e2 e3 -> check3Exprs e1 e2 e3 HsIf
-
- HsLet bs e -> check1Expr e (HsLet bs)
- HsDo stmts -> mapP checkStmt stmts `thenP` (returnP . HsDo)
- HsTuple es -> checkManyExprs es HsTuple
- HsList es -> checkManyExprs es HsList
- HsRecConstr c fields -> mapP checkField fields `thenP` \fields ->
- returnP (HsRecConstr c fields)
- HsRecUpdate e fields -> mapP checkField fields `thenP` \fields ->
- checkExpr e `thenP` \e ->
- returnP (HsRecUpdate e fields)
- HsEnumFrom e -> check1Expr e HsEnumFrom
- HsEnumFromTo e1 e2 -> check2Exprs e1 e2 HsEnumFromTo
- HsEnumFromThen e1 e2 -> check2Exprs e1 e2 HsEnumFromThen
- HsEnumFromThenTo e1 e2 e3 -> check3Exprs e1 e2 e3 HsEnumFromThenTo
- HsListComp e stmts -> mapP checkStmt stmts `thenP` \stmts ->
- checkExpr e `thenP` \e ->
- returnP (HsListComp e stmts)
- RdrNameHsExprTypeSig loc e ty -> checkExpr e `thenP` \e ->
- returnP (RdrNameHsExprTypeSig loc e ty)
- _ -> parseError "parse error in expression"
-
--- type signature for polymorphic recursion!!
-check1Expr :: RdrNameHsExpr -> (RdrNameHsExpr -> a) -> P a
-check1Expr e f = checkExpr e `thenP` (returnP . f)
-
-check2Exprs :: RdrNameHsExpr -> RdrNameHsExpr -> (RdrNameHsExpr -> RdrNameHsExpr -> a) -> P a
-check2Exprs e1 e2 f =
- checkExpr e1 `thenP` \e1 ->
- checkExpr e2 `thenP` \e2 ->
- returnP (f e1 e2)
-
-check3Exprs :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -> (RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -> a) -> P a
-check3Exprs e1 e2 e3 f =
- checkExpr e1 `thenP` \e1 ->
- checkExpr e2 `thenP` \e2 ->
- checkExpr e3 `thenP` \e3 ->
- returnP (f e1 e2 e3)
-
-checkManyExprs es f =
- mapP checkExpr es `thenP` \es ->
- returnP (f es)
-
-checkAlt (HsAlt loc p galts bs)
- = checkGAlts galts `thenP` \galts -> returnP (HsAlt loc p galts bs)
-
-checkGAlts (HsUnGuardedAlt e) = check1Expr e HsUnGuardedAlt
-checkGAlts (HsGuardedAlts galts)
- = mapP checkGAlt galts `thenP` (returnP . HsGuardedAlts)
-
-checkGAlt (HsGuardedAlt loc e1 e2) = check2Exprs e1 e2 (HsGuardedAlt loc)
-
-checkStmt (HsGenerator p e) = check1Expr e (HsGenerator p)
-checkStmt (HsQualifier e) = check1Expr e HsQualifier
-checkStmt s@(HsLetStmt bs) = returnP s
-
-checkField (HsFieldUpdate n e) = check1Expr e (HsFieldUpdate n)
-checkField e = returnP e
--}
+
---------------------------------------------------------------------------
-- Check Equation Syntax
-- A variable binding is parsed as an RdrNameFunMonoBind.
-- See comments with HsBinds.MonoBinds
+isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op)
= Just (op, True, (l:r:es))
isFunLhs (HsVar f) es | not (isRdrDataCon f)
-- 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 (_PK_ (occNameUserString (rdrNameOcc rdrNm)))
Nothing
= case bind of
RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds
other -> bind `RdrAndBindings` group Nothing binds
-
------------------------------------------------------------------------------
--- Built-in names
-
-unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR :: RdrName
-tupleCon_RDR, tupleTyCon_RDR :: Int -> RdrName
-ubxTupleCon_RDR, ubxTupleTyCon_RDR :: Int -> RdrName
-
-unitCon_RDR
- | opt_NoImplicitPrelude = mkSrcUnqual dataName unitName
- | otherwise = mkPreludeQual dataName pRELUDE_Name unitName
-
-unitTyCon_RDR
- | opt_NoImplicitPrelude = mkSrcUnqual tcName unitName
- | otherwise = mkPreludeQual tcName pRELUDE_Name unitName
-
-nilCon_RDR
- | opt_NoImplicitPrelude = mkSrcUnqual dataName listName
- | otherwise = mkPreludeQual dataName pRELUDE_Name listName
-
-listTyCon_RDR
- | opt_NoImplicitPrelude = mkSrcUnqual tcName listName
- | otherwise = mkPreludeQual tcName pRELUDE_Name listName
-
-funTyCon_RDR
- | opt_NoImplicitPrelude = mkSrcUnqual tcName funName
- | otherwise = mkPreludeQual tcName pRELUDE_Name funName
-
-tupleCon_RDR arity
- | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr Boxed arity))
- | otherwise = mkPreludeQual dataName pRELUDE_Name
- (snd (mkTupNameStr Boxed arity))
-
-tupleTyCon_RDR arity
- | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr Boxed arity))
- | otherwise = mkPreludeQual tcName pRELUDE_Name
- (snd (mkTupNameStr Boxed arity))
-
-
-ubxTupleCon_RDR arity
- | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr Unboxed arity))
- | otherwise = mkPreludeQual dataName pRELUDE_Name
- (snd (mkTupNameStr Unboxed arity))
-
-ubxTupleTyCon_RDR arity
- | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr Unboxed arity))
- | otherwise = mkPreludeQual tcName pRELUDE_Name
- (snd (mkTupNameStr Unboxed arity))
-
-unitName = SLIT("()")
-funName = SLIT("(->)")
-listName = SLIT("[]")
-
-asName = SLIT("as")
-hidingName = SLIT("hiding")
-qualifiedName = SLIT("qualified")
-forallName = SLIT("forall")
-exportName = SLIT("export")
-labelName = SLIT("label")
-dynamicName = SLIT("dynamic")
-unsafeName = SLIT("unsafe")
-stdcallName = SLIT("stdcall")
-ccallName = SLIT("ccall")
-
-as_var_RDR = mkSrcUnqual varName asName
-hiding_var_RDR = mkSrcUnqual varName hidingName
-qualified_var_RDR = mkSrcUnqual varName qualifiedName
-forall_var_RDR = mkSrcUnqual varName forallName
-export_var_RDR = mkSrcUnqual varName exportName
-label_var_RDR = mkSrcUnqual varName labelName
-dynamic_var_RDR = mkSrcUnqual varName dynamicName
-unsafe_var_RDR = mkSrcUnqual varName unsafeName
-stdcall_var_RDR = mkSrcUnqual varName stdcallName
-ccall_var_RDR = mkSrcUnqual varName ccallName
-
-as_tyvar_RDR = mkSrcUnqual tvName asName
-hiding_tyvar_RDR = mkSrcUnqual tvName hidingName
-qualified_tyvar_RDR = mkSrcUnqual tvName qualifiedName
-export_tyvar_RDR = mkSrcUnqual tvName exportName
-label_tyvar_RDR = mkSrcUnqual tvName labelName
-dynamic_tyvar_RDR = mkSrcUnqual tvName dynamicName
-unsafe_tyvar_RDR = mkSrcUnqual tvName unsafeName
-stdcall_tyvar_RDR = mkSrcUnqual tvName stdcallName
-ccall_tyvar_RDR = mkSrcUnqual tvName ccallName
-
-minus_RDR = mkSrcUnqual varName SLIT("-")
-pling_RDR = mkSrcUnqual varName SLIT("!")
-dot_RDR = mkSrcUnqual varName SLIT(".")
-
-plus_RDR = mkSrcUnqual varName SLIT("+")
\end{code}
projects / ghc-hetmet.git / blobdiff