aboutsummaryrefslogtreecommitdiff
path: root/src/HsParseUtils.lhs
diff options
context:
space:
mode:
authordavve <davve@dtek.chalmers.se>2006-07-20 17:48:30 +0000
committerdavve <davve@dtek.chalmers.se>2006-07-20 17:48:30 +0000
commitde580ba29f412239c2f922e9bd67eea2ccdd8bc7 (patch)
tree9c2176220825037424f79b848e9ff65d7bcedd15 /src/HsParseUtils.lhs
parentbbf12d02cb9fc17624bab24ba9c3ab0bfb2804d5 (diff)
More progress -- still on phase1
Diffstat (limited to 'src/HsParseUtils.lhs')
-rw-r--r--src/HsParseUtils.lhs326
1 files changed, 0 insertions, 326 deletions
diff --git a/src/HsParseUtils.lhs b/src/HsParseUtils.lhs
deleted file mode 100644
index 29999588..00000000
--- a/src/HsParseUtils.lhs
+++ /dev/null
@@ -1,326 +0,0 @@
------------------------------------------------------------------------------
--- $Id: HsParseUtils.lhs,v 1.6 2003/10/20 17:19:23 sof Exp $
---
--- (c) The GHC Team 1997-2000
---
--- Utilities for the Haskell parser.
---
------------------------------------------------------------------------------
-
-ToDo: Polish readInteger, readRational
-
-\begin{code}
-module HsParseUtils (
- parseError -- String -> Pa
- , splitTyConApp -- HsType -> P (HsName,[HsType])
- , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp
- , checkPrec -- String -> P String
- , checkContext -- HsType -> P HsIPContext
- , checkIPContext -- HsIPContext -> P HsContext
- , checkAssertion -- HsType -> P HsAsst
- , checkInstHeader -- HsType -> P (HsContext, HsAsst)
- , checkClassHeader -- HsType -> P (HsContext, HsName, [HsType])
- , checkDataHeader -- HsType -> P (HsContext,HsName,[HsName])
- , checkPattern -- HsExp -> P HsPat
- , checkPatterns -- [HsExp] -> P [HsPat]
- , checkExpr -- HsExp -> P HsExp
- , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
- , checkUnQual -- HsQName -> P HsName
- , readInteger -- String -> Integer
- , readRational -- String -> Rational
-
- , toVarHsName -- HsName -> HsName
- , toTyClsHsName -- HsName -> HsName
- ) where
-
-import HsSyn2
-import HsParseMonad
-
-import Char(isDigit,isOctDigit,isHexDigit,digitToInt)
-import List(partition)
-import Ratio
-\end{code}
-
-\begin{code}
-parseError :: String -> P a
-parseError s = \r (SrcLoc y x f) ->
- failP (show f ++ ": " ++ show y ++ ":" ++ show x ++ ": " ++ s) r (SrcLoc y x f)
-
-splitTyConApp :: HsType -> P (HsName,[HsType])
-splitTyConApp t0 = split t0 []
- where
- split :: HsType -> [HsType] -> P (HsName,[HsType])
- split (HsTyApp t u) ts = split t (u:ts)
- split (HsTyCon (UnQual t)) ts = returnP (t,ts)
- -- to cope with data [] = [] | a:[a]
- split (HsTyCon (Qual _ t)) ts = returnP (t,ts)
- split _ _ = parseError "Illegal data/newtype declaration"
-
------------------------------------------------------------------------------
--- Various Syntactic Checks
-
-checkContext :: HsType -> P HsIPContext
-checkContext (HsTyTuple True ts) = mapP checkCtxt ts
- where
- checkCtxt (HsTyIP n ty) = returnP (HsIP n ty)
- checkCtxt t0 =
- checkAssertion t0 `thenP` \ c ->
- returnP (HsAssump c)
-checkContext (HsTyIP n t) = returnP [HsIP n t]
-checkContext t =
- checkAssertion t `thenP` \c ->
- returnP [HsAssump c]
-
-checkIPContext :: HsIPContext -> P HsContext
-checkIPContext ls =
- case partition isIP ls of
- ([],cs) -> returnP (map (\ (HsAssump c) -> c) cs)
- (_,_) -> parseError "Unexpected implicit parameter in context"
- where
- isIP HsIP{} = True
- isIP _ = False
-
--- Changed for multi-parameter type classes
-
-checkAssertion :: HsType -> P HsAsst
-checkAssertion = checkAssertion' []
- where checkAssertion' ts (HsTyCon c) = returnP (c,ts)
- checkAssertion' ts (HsTyApp a t) = checkAssertion' (t:ts) a
- checkAssertion' _ _ = parseError "Illegal class assertion"
-
-checkInstHeader :: HsType -> P (HsContext, HsAsst)
-checkInstHeader (HsForAllType Nothing ctxt ty) =
- checkAssertion ty `thenP` \asst ->
- checkIPContext ctxt `thenP` \ctxt' ->
- returnP (ctxt', asst)
-checkInstHeader ty =
- checkAssertion ty `thenP` \asst ->
- returnP ([], asst)
-
-checkDataHeader :: HsType -> P (HsContext,HsName,[HsName])
-checkDataHeader (HsForAllType Nothing cs t) =
- checkSimple "data/newtype" t [] `thenP` \(c,ts) ->
- checkIPContext cs `thenP` \cs' ->
- returnP (cs',c,ts)
-checkDataHeader ty =
- checkSimple "data/newtype" ty [] `thenP` \(c,ts) ->
- returnP ([],c,ts)
-
-checkClassHeader :: HsType -> P (HsContext,HsName,[HsName])
-checkClassHeader (HsForAllType Nothing cs t) =
- checkSimple "class" t [] `thenP` \(c,ts) ->
- checkIPContext cs `thenP` \cs' ->
- returnP (cs',c,ts)
-checkClassHeader ty =
- checkSimple "class" ty [] `thenP` \(c,ts) ->
- returnP ([],c,ts)
-
-checkSimple :: String -> HsType -> [HsName] -> P ((HsName,[HsName]))
-checkSimple kw (HsTyApp l (HsTyVar a)) xs = checkSimple kw l (a:xs)
-checkSimple _kw (HsTyCon (UnQual t)) xs = returnP (t,xs)
-checkSimple _ (HsTyCon (Qual m t)) xs
- | m == prelude_mod = returnP (t,xs) -- for "special" declarations
-checkSimple kw _ _ = failP ("Illegal " ++ kw ++ " declaration")
-
------------------------------------------------------------------------------
--- Checking Patterns.
-
--- We parse patterns as expressions and check for valid patterns below,
--- converting the expression into a pattern at the same time.
-
-checkPattern :: HsExp -> P HsPat
-checkPattern e = checkPat e []
-
-checkPatterns :: [HsExp] -> P [HsPat]
-checkPatterns es = mapP checkPattern es
-
-checkPat :: HsExp -> [HsPat] -> P HsPat
-checkPat (HsCon c) args = returnP (HsPApp c args)
-checkPat (HsApp f x0) args = checkPat x0 [] `thenP` \x -> checkPat f (x:args)
-checkPat e0 [] = case e0 of
- HsVar (UnQual x) -> returnP (HsPVar x)
- HsLit l -> returnP (HsPLit l)
- HsInfixApp l0 op r0 -> checkPat l0 [] `thenP` \l ->
- checkPat r0 [] `thenP` \r ->
- case op of
- HsCon c -> returnP (HsPInfixApp l c r)
- _ -> patFail
- HsTuple b es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
- returnP (HsPTuple b ps)
- HsList es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
- returnP (HsPList ps)
- HsParen e -> checkPat e [] `thenP` (returnP . HsPParen)
- HsAsPat n e -> checkPat e [] `thenP` (returnP . HsPAsPat n)
- HsWildCard -> returnP HsPWildCard
- HsIrrPat e -> checkPat e [] `thenP` (returnP . HsPIrrPat)
- HsRecConstr c fs0 -> mapP checkPatField fs0 `thenP` \fs ->
- returnP (HsPRec c fs)
- HsNegApp (HsLit l) -> returnP (HsPNeg (HsPLit l))
- HsExpTypeSig _ e1 ty -> checkPat e1 [] `thenP` \e ->
- returnP (HsPTypeSig e ty)
- _ -> patFail
-
-checkPat _ _ = patFail
-
-checkPatField :: HsFieldUpdate -> P HsPatField
-checkPatField (HsFieldUpdate n e) =
- checkPat e [] `thenP` \p ->returnP (HsPFieldPat n p)
-
-patFail :: P a
-patFail = parseError "Parse error in pattern"
-
------------------------------------------------------------------------------
--- Check Expression Syntax
-
-checkExpr :: HsExp -> P HsExp
-checkExpr e0 = case e0 of
- HsVar _ -> returnP e0
- HsIPVar _ -> returnP e0
- HsCon _ -> returnP e0
- HsLit _ -> returnP e0
- HsInfixApp e1 e2 e3 -> check3Exprs e1 e2 e3 HsInfixApp
- HsApp e1 e2 -> check2Exprs e1 e2 HsApp
- HsNegApp e -> check1Expr e HsNegApp
- HsLambda ps e -> check1Expr e (HsLambda ps)
- HsLet bs e -> check1Expr e (HsLet bs)
- HsIf e1 e2 e3 -> check3Exprs e1 e2 e3 HsIf
- HsCase e1 alts0 -> mapP checkAlt alts0 `thenP` \alts ->
- checkExpr e1 `thenP` \e ->
- returnP (HsCase e alts)
- HsDo stmts -> mapP checkStmt stmts `thenP` (returnP . HsDo)
- HsTuple b es -> checkManyExprs es (HsTuple b)
- HsList es -> checkManyExprs es HsList
- HsParen e -> check1Expr e HsParen
- HsLeftSection e1 e2 -> check2Exprs e1 e2 HsLeftSection
- HsRightSection e1 e2 -> check2Exprs e1 e2 HsRightSection
- HsRecConstr c fields0 -> mapP checkField fields0 `thenP` \fields ->
- returnP (HsRecConstr c fields)
- HsRecUpdate e1 fields0 -> mapP checkField fields0 `thenP` \fields ->
- checkExpr e1 `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 e1 stmts0 -> mapP checkStmt stmts0 `thenP` \stmts ->
- checkExpr e1 `thenP` \e ->
- returnP (HsListComp e stmts)
- HsExpTypeSig loc e1 ty -> checkExpr e1 `thenP` \e ->
- returnP (HsExpTypeSig loc e ty)
- _ -> parseError "parse error in expression"
-
--- type signature for polymorphic recursion!!
-check1Expr :: HsExp -> (HsExp -> a) -> P a
-check1Expr e f = checkExpr e `thenP` (returnP . f)
-
-check2Exprs :: HsExp -> HsExp -> (HsExp -> HsExp -> a) -> P a
-check2Exprs e1 e2 f =
- checkExpr e1 `thenP` \e1' ->
- checkExpr e2 `thenP` \e2' ->
- returnP (f e1' e2')
-
-check3Exprs :: HsExp -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp -> 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 :: [HsExp] -> ([HsExp] -> HsExp) -> P HsExp
-checkManyExprs es0 f =
- mapP checkExpr es0 `thenP` \es ->
- returnP (f es)
-
-checkAlt :: HsAlt -> P HsAlt
-checkAlt (HsAlt loc p galts0 bs)
- = checkGAlts galts0 `thenP` \galts -> returnP (HsAlt loc p galts bs)
-
-checkGAlts :: HsGuardedAlts -> P HsGuardedAlts
-checkGAlts (HsUnGuardedAlt e) = check1Expr e HsUnGuardedAlt
-checkGAlts (HsGuardedAlts galts)
- = mapP checkGAlt galts `thenP` (returnP . HsGuardedAlts)
-
-checkGAlt :: HsGuardedAlt -> P HsGuardedAlt
-checkGAlt (HsGuardedAlt loc stmts0 e0) =
- mapP checkStmt stmts0 `thenP` \stmts ->
- checkExpr e0 `thenP` \e ->
- returnP (HsGuardedAlt loc stmts e)
-
-checkStmt :: HsStmt -> P HsStmt
-checkStmt (HsGenerator p e) = check1Expr e (HsGenerator p)
-checkStmt (HsParStmt ss) = mapP checkStmt ss `thenP` \ ss1 -> returnP (HsParStmt ss1)
-checkStmt (HsQualifier e) = check1Expr e HsQualifier
-checkStmt s@(HsLetStmt _) = returnP s
-
-checkField :: HsFieldUpdate -> P HsFieldUpdate
-checkField (HsFieldUpdate n e) = check1Expr e (HsFieldUpdate n)
-
------------------------------------------------------------------------------
--- Check Equation Syntax
-
-checkValDef :: (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
-checkValDef (srcloc, lhs0, rhs, whereBinds) =
- case isFunLhs lhs0 [] of
- Just (f,es) -> checkPatterns es `thenP` \ps ->
- returnP (HsFunBind [HsMatch srcloc f ps rhs whereBinds])
- Nothing -> checkPattern lhs0 `thenP` \lhs ->
- returnP (HsPatBind srcloc lhs rhs whereBinds)
-
--- A variable binding is parsed as an HsPatBind.
-
-isFunLhs :: HsExp -> [HsExp] -> Maybe (HsQName, [HsExp])
-isFunLhs (HsInfixApp l (HsVar op) r) es = Just (op, l:r:es)
-isFunLhs (HsApp (HsVar f) e) es = Just (f,e:es)
-isFunLhs (HsApp (HsParen f) e) es = isFunLhs f (e:es)
-isFunLhs (HsApp f e) es = isFunLhs f (e:es)
-isFunLhs _ _ = Nothing
-
------------------------------------------------------------------------------
--- Check that an identifier or symbol is unqualified.
--- For occasions when doing this in the grammar would cause conflicts.
-
-checkUnQual :: HsQName -> P HsName
-checkUnQual (Qual _ _) = parseError "Illegal qualified name"
-checkUnQual (UnQual n) = returnP n
-
------------------------------------------------------------------------------
--- Miscellaneous utilities
-
-toVarHsName :: HsName -> HsName
-toVarHsName (HsTyClsName n) = HsVarName n
-toVarHsName n = n
-
-toTyClsHsName :: HsName -> HsName
-toTyClsHsName (HsVarName n) = HsTyClsName n
-toTyClsHsName n = n
-
-checkPrec :: Integer -> P ()
-checkPrec i | i >= 0 && i <= 9 = returnP ()
-checkPrec i = parseError ("Illegal precedence: " ++ show i)
-
--- Stolen from Hugs' Prelude
-
-readInteger :: String -> Integer
-readInteger ('0':'o':ds) = readInteger2 8 isOctDigit ds
-readInteger ('0':'x':ds) = readInteger2 16 isHexDigit ds
-readInteger ds = readInteger2 10 isDigit ds
-
-readInteger2 :: Integer -> (Char -> Bool) -> String -> Integer
-readInteger2 radix isDig ds
- | and $ map isDig ds
- = foldl1 (\n d -> n * radix + d) (map (fromIntegral . digitToInt) ds)
- | otherwise = error $ "readInteger2:expected all digits, got " ++ show ds
-
--- Hack...
-
-readRational :: String -> Rational
-readRational xs = (readInteger (i++m))%1 * 10^^(case e of {[] -> 0; ('+':e2) -> read e2; _ -> read e} - length m)
- where (i,r1) = span isDigit xs
- (m,r2) = span isDigit (dropWhile (=='.') r1)
- e = dropWhile (=='e') r2
-
-mkRecConstrOrUpdate :: HsExp -> [HsFieldUpdate] -> P HsExp
-mkRecConstrOrUpdate (HsCon c) fs = returnP (HsRecConstr c fs)
-mkRecConstrOrUpdate exp0 fs@(_:_) = returnP (HsRecUpdate exp0 fs)
-mkRecConstrOrUpdate _ _ = parseError "Empty record update"
-\end{code}