\begin{code}
module ParseUtil (
parseError -- String -> Pa
- , cbot -- a
, mkVanillaCon, mkRecCon,
, mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp
, groupBindings
- , mkExtName -- Maybe ExtName -> RdrName -> ExtName
+ , mkExtName -- RdrName -> ExtName
, checkPrec -- String -> P String
, checkContext -- HsType -> P HsContext
, checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName])
, checkSimple -- HsType -> [HsName] -> P ((HsName,[HsName]))
, checkPattern -- HsExp -> P HsPat
- , checkPatterns -- [HsExp] -> P [HsPat]
- -- , checkExpr -- HsExp -> P HsExp
+ , checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat]
+ , checkDo -- [HsStmt] -> P [HsStmt]
, checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
, checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
) where
)
import RdrName
import PrelNames ( unitTyCon_RDR )
-import CallConv
import OccName ( dataName, varName, tcClsName,
occNameSpace, setOccNameSpace, occNameUserString )
+import CStrings ( CLabelString )
import FastString ( unpackFS )
-import UniqFM ( UniqFM, listToUFM, lookupUFM )
import Outputable
-----------------------------------------------------------------------------
getSrcLocP `thenP` \ loc ->
failMsgP (hcat [ppr loc, text ": ", text s])
-cbot = panic "CCall:result_ty"
-----------------------------------------------------------------------------
-- mkVanillaCon
mkVanillaCon ty tys
= split ty tys
where
- split (HsAppTy t u) ts = split t (Unbanged u : ts)
+ split (HsAppTy t u) ts = split t (unbangedType u : ts)
split (HsTyVar tc) ts = tyConToDataCon tc `thenP` \ data_con ->
returnP (data_con, VanillaCon ts)
split _ _ = parseError "Illegal data/newtype declaration"
----------------------------------------------------------------------------
-- Various Syntactic Checks
-callConvFM :: UniqFM CallConv
-callConvFM = listToUFM $
- map (\ (x,y) -> (_PK_ x,y))
- [ ("stdcall", stdCallConv),
- ("ccall", cCallConv)
--- ("pascal", pascalCallConv),
--- ("fastcall", fastCallConv)
- ]
-
-checkCallConv :: FAST_STRING -> P CallConv
-checkCallConv s =
- case lookupUFM callConvFM s of
- Nothing -> parseError ("unknown calling convention: `"
- ++ unpackFS s ++ "'")
- Just conv -> returnP conv
-
checkInstType :: RdrNameHsType -> P RdrNameHsType
checkInstType t
= case t of
checkSimple t _ = parseError "Illegal left hand side in data/newtype declaration"
---------------------------------------------------------------------------
+-- Checking statements in a do-expression
+-- We parse do { e1 ; e2 ; }
+-- as [ExprStmt e1, ExprStmt e2]
+-- checkDo (a) checks that the last thing is an ExprStmt
+-- (b) transforms it to a ResultStmt
+
+checkDo [] = parseError "Empty 'do' construct"
+checkDo [ExprStmt e _ l] = returnP [ResultStmt e l]
+checkDo [s] = parseError "The last statement in a 'do' construct must be an expression"
+checkDo (s:ss) = checkDo ss `thenP` \ ss' ->
+ returnP (s:ss')
+
+---------------------------------------------------------------------------
-- Checking Patterns.
-- We parse patterns as expressions and check for valid patterns below,
-- converting the expression into a pattern at the same time.
-checkPattern :: RdrNameHsExpr -> P RdrNamePat
-checkPattern e = checkPat e []
+checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat
+checkPattern loc e = setSrcLocP loc (checkPat e [])
-checkPatterns :: [RdrNameHsExpr] -> P [RdrNamePat]
-checkPatterns es = mapP checkPattern es
+checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
+checkPatterns loc es = mapP (checkPattern loc) es
checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args)
_ -> patFail
HsPar e -> checkPat e [] `thenP` (returnP . ParPatIn)
- ExplicitList es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
+ ExplicitList _ es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
returnP (ListPatIn ps)
ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
checkValDef lhs opt_sig grhss loc
= case isFunLhs lhs [] of
Just (f,inf,es) ->
- checkPatterns es `thenP` \ps ->
+ checkPatterns loc es `thenP` \ps ->
returnP (RdrValBinding (FunMonoBind f inf [Match [] ps opt_sig grhss] loc))
Nothing ->
- checkPattern lhs `thenP` \lhs ->
+ checkPattern loc lhs `thenP` \lhs ->
returnP (RdrValBinding (PatMonoBind lhs grhss loc))
checkValSig
isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op)
= Just (op, True, (l:r:es))
+ | otherwise
+ = case isFunLhs l es of
+ Just (op', True, j : k : es') ->
+ Just (op', True, j : OpApp k (HsVar op) fix r : es')
+ _ -> Nothing
isFunLhs (HsVar f) es | not (isRdrDataCon f)
= Just (f,False,es)
isFunLhs (HsApp f e) es = isFunLhs f (e:es)
-- 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
-mkExtName (Just x) _ = x
+mkExtName :: RdrName -> CLabelString
+mkExtName rdrNm = _PK_ (occNameUserString (rdrNameOcc rdrNm))
-----------------------------------------------------------------------------
-- group function bindings into equation groups