module ParseUtil (
parseError -- String -> Pa
, cbot -- a
- , splitForConApp -- RdrNameHsType -> [RdrNameBangType]
- -- -> P (RdrName, [RdrNameBangType])
+ , mkVanillaCon, mkRecCon,
, mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp
, groupBindings
import Lex
import HsSyn -- Lots of it
import SrcLoc
-import RdrHsSyn ( mkNPlusKPatIn, unitTyCon_RDR,
- RdrBinding(..),
+import RdrHsSyn ( RdrBinding(..),
RdrNameHsType, RdrNameBangType, RdrNameContext,
RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr, RdrNameGRHSs,
- RdrNameHsRecordBinds, RdrNameMonoBinds
+ RdrNameHsRecordBinds, RdrNameMonoBinds, RdrNameConDetails
)
import RdrName
+import PrelNames ( unitTyCon_RDR, minus_RDR )
import CallConv
import OccName ( dataName, varName, tcClsName,
occNameSpace, setOccNameSpace, occNameUserString )
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 (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 (HsTyVar t) ts =
- -- check that we've got a type constructor at the head
- if occNameSpace t_occ /= tcClsName
- then parseError
- (showSDoc (text "not a constructor: `" <>
- ppr t <> char '\''))
- else returnP (con, ts)
- where t_occ = rdrNameOcc t
- con = setRdrNameOcc t (setOccNameSpace t_occ dataName)
-
- split _ _ = parseError "Illegal data/newtype declaration"
----------------------------------------------------------------------------
-- Various Syntactic Checks
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"
+checkDictTy _ _ = parseError "Malformed context in instance header"
+-- 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 []
OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral k _))
| plus == plus_RDR
- -> returnP (mkNPlusKPatIn n lit)
+ -> 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 ->
RecordCon c fs -> mapP checkPatField fs `thenP` \fs ->
returnP (RecPatIn c fs)
+-- Generics
+ HsType ty -> returnP (TypePatIn ty)
_ -> patFail
checkPat _ _ = patFail
-- 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
-
-plus_RDR = mkSrcUnqual varName SLIT("+")
\end{code}
projects / ghc-hetmet.git / blobdiff