Commit 9541ef34 authored by simonmar's avatar simonmar

[project @ 2003-09-08 11:52:24 by simonmar]

Replace the handwritten lexer with one generated by Alex.

YOU NOW NEED ALEX (v 2.0 or later) TO COMPILE GHC FROM CVS.

Highlights:

  - Faster than the previous lexer (about 10% of total parse time,
    depending on the token mix).

  - More correct than the previous lexer: a couple of minor wibbles
    in the syntax were fixed.

  - Completely accurate source spans for each token are now collected.
    This information isn't used yet, but it will be used to give much
    more accurate error messages in the future.

  - SrcLoc now contains a column field as well as a line number,
    although this is currently ignored when printing out SrcLocs.

  - StringBuffer is now based on a ByteArray# rather than a Ptr, which
    means that StringBuffers are now garbage collected.  Previously
    StringBuffers were hardly ever released, so a GHCi session would
    leak space as more source files were loaded in.

  - Code size reduction: Lexer.x is about the same size as the old
    Lex.lhs, but StringBuffer.lhs is significantly shorter and
    simpler.  Sadly I wasn't able to get rid of parser/Ctypes.hs
    (yet).
parent 74fce831
......@@ -411,6 +411,8 @@ endif
# Required due to use of Concurrent.myThreadId
utils/Panic_HC_OPTS += -fvia-C
parser/Lexer_HC_OPTS += -funbox-strict-fields
# ghc_strlen percolates through so many modules that it is easier to get its
# prototype via a global option instead of a myriad of per-file OPTIONS
SRC_HC_OPTS += '-\#include "hschooks.h"'
......@@ -473,12 +475,6 @@ primop-usage.hs-incl: prelude/primops.txt
$(GENPOC) --usage < $< > $@
# ----------------------------------------------------------------------------
# Parsers/lexers
SRC_HAPPY_OPTS += +RTS -K2m -H16m -RTS
#-----------------------------------------------------------------------------
# Linking
......@@ -518,45 +514,47 @@ endif
# ----------------------------------------------------------------------------
# profiling.
rename/RnBinds_HC_OPTS += -auto-all
rename/RnEnv_HC_OPTS += -auto-all
rename/RnExpr_HC_OPTS += -auto-all
rename/RnHiFiles_HC_OPTS += -auto-all
rename/RnHsSyn_HC_OPTS += -auto-all
rename/Rename_HC_OPTS += -auto-all
rename/RnIfaces_HC_OPTS += -auto-all
rename/RnNames_HC_OPTS += -auto-all
rename/RnSource_HC_OPTS += -auto-all
rename/RnTypes_HC_OPTS += -auto-all
typecheck/Inst_HC_OPTS += -auto-all
typecheck/TcBinds_HC_OPTS += -auto-all
typecheck/TcClassDcl_HC_OPTS += -auto-all
typecheck/TcDefaults_HC_OPTS += -auto-all
typecheck/TcDeriv_HC_OPTS += -auto-all
typecheck/TcEnv_HC_OPTS += -auto-all
typecheck/TcExpr_HC_OPTS += -auto-all
typecheck/TcForeign_HC_OPTS += -auto-all
typecheck/TcGenDeriv_HC_OPTS += -auto-all
typecheck/TcHsSyn_HC_OPTS += -auto-all
typecheck/TcIfaceSig_HC_OPTS += -auto-all
typecheck/TcInstDcls_HC_OPTS += -auto-all
typecheck/TcMatches_HC_OPTS += -auto-all
typecheck/TcMonoType_HC_OPTS += -auto-all
typecheck/TcMType_HC_OPTS += -auto-all
typecheck/TcPat_HC_OPTS += -auto-all
typecheck/TcRnDriver_HC_OPTS += -auto-all
#typecheck/TcRnMonad_HC_OPTS += -auto-all
#typecheck/TcRnTypes_HC_OPTS += -auto-all
typecheck/TcRules_HC_OPTS += -auto-all
typecheck/TcSimplify_HC_OPTS += -auto-all
typecheck/TcSplice_HC_OPTS += -auto-all
typecheck/TcTyClsDecls_HC_OPTS += -auto-all
typecheck/TcTyDecls_HC_OPTS += -auto-all
typecheck/TcType_HC_OPTS += -auto-all
typecheck/TcUnify_HC_OPTS += -auto-all
absCSyn/PprAbsC_HC_OPTS += -auto-all
# rename/RnBinds_HC_OPTS += -auto-all
# rename/RnEnv_HC_OPTS += -auto-all
# rename/RnExpr_HC_OPTS += -auto-all
# rename/RnHiFiles_HC_OPTS += -auto-all
# rename/RnHsSyn_HC_OPTS += -auto-all
# rename/Rename_HC_OPTS += -auto-all
# rename/RnIfaces_HC_OPTS += -auto-all
# rename/RnNames_HC_OPTS += -auto-all
# rename/RnSource_HC_OPTS += -auto-all
# rename/RnTypes_HC_OPTS += -auto-all
#
# typecheck/Inst_HC_OPTS += -auto-all
# typecheck/TcBinds_HC_OPTS += -auto-all
# typecheck/TcClassDcl_HC_OPTS += -auto-all
# typecheck/TcDefaults_HC_OPTS += -auto-all
# typecheck/TcDeriv_HC_OPTS += -auto-all
# typecheck/TcEnv_HC_OPTS += -auto-all
# typecheck/TcExpr_HC_OPTS += -auto-all
# typecheck/TcForeign_HC_OPTS += -auto-all
# typecheck/TcGenDeriv_HC_OPTS += -auto-all
# typecheck/TcHsSyn_HC_OPTS += -auto-all
# typecheck/TcIfaceSig_HC_OPTS += -auto-all
# typecheck/TcInstDcls_HC_OPTS += -auto-all
# typecheck/TcMatches_HC_OPTS += -auto-all
# typecheck/TcMonoType_HC_OPTS += -auto-all
# typecheck/TcMType_HC_OPTS += -auto-all
# typecheck/TcPat_HC_OPTS += -auto-all
# typecheck/TcRnDriver_HC_OPTS += -auto-all
# #typecheck/TcRnMonad_HC_OPTS += -auto-all
# #typecheck/TcRnTypes_HC_OPTS += -auto-all
# typecheck/TcRules_HC_OPTS += -auto-all
# typecheck/TcSimplify_HC_OPTS += -auto-all
# typecheck/TcSplice_HC_OPTS += -auto-all
# typecheck/TcTyClsDecls_HC_OPTS += -auto-all
# typecheck/TcTyDecls_HC_OPTS += -auto-all
# typecheck/TcType_HC_OPTS += -auto-all
# typecheck/TcUnify_HC_OPTS += -auto-all
#
# absCSyn/PprAbsC_HC_OPTS += -auto-all
coreSyn/CorePrep_HC_OPTS += -auto-all
#-----------------------------------------------------------------------------
# clean
......
......@@ -4,5 +4,5 @@ data IdInfo
data GlobalIdDetails
notGlobalId :: GlobalIdDetails
seqIdInfo :: IdInfo -> GHC.Base.()
seqIdInfo :: IdInfo -> ()
vanillaIdInfo :: IdInfo
......@@ -13,15 +13,15 @@ module SrcLoc (
mkSrcLoc, isGoodSrcLoc, isWiredInLoc,
noSrcLoc, -- "I'm sorry, I haven't a clue"
advanceSrcLoc,
importedSrcLoc, -- Unknown place in an interface
wiredInSrcLoc, -- Something wired into the compiler
generatedSrcLoc, -- Code generated within the compiler
incSrcLine, replaceSrcLine,
srcLocFile, -- return the file name part.
srcLocLine -- return the line part.
srcLocFile, -- return the file name part
srcLocLine, -- return the line part
srcLocCol, -- return the column part
) where
#include "HsVersions.h"
......@@ -32,7 +32,7 @@ import FastString ( unpackFS )
import FastTypes
import FastString
import GLAEXTS ( (+#) )
import GLAEXTS ( (+#), quotInt# )
\end{code}
%************************************************************************
......@@ -52,9 +52,24 @@ data SrcLoc
-- isWiredInName
| SrcLoc FastString -- A precise location (file name)
FastInt
FastInt -- line
FastInt -- column
| UnhelpfulSrcLoc FastString -- Just a general indication
{-
data SrcSpan
= WiredInSpan
-- A precise source file span
| SrcSpan FastString -- file name
FastInt -- beginning line
FastInt -- beginning column
FastInt -- end line
FastInt -- end column
| UnhelpfulSrcSpan FastString -- Just a general indication
-}
\end{code}
Note that an entity might be imported via more than one route, and
......@@ -70,30 +85,35 @@ rare case.
Things to make 'em:
\begin{code}
mkSrcLoc x y = SrcLoc x (iUnbox y)
mkSrcLoc x line col = SrcLoc x (iUnbox line) (iUnbox col)
wiredInSrcLoc = WiredInLoc
noSrcLoc = UnhelpfulSrcLoc FSLIT("<No locn>")
importedSrcLoc = UnhelpfulSrcLoc FSLIT("<imported>")
generatedSrcLoc = UnhelpfulSrcLoc FSLIT("<compiler-generated-code>")
isGoodSrcLoc (SrcLoc _ _) = True
isGoodSrcLoc (SrcLoc _ _ _) = True
isGoodSrcLoc other = False
isWiredInLoc WiredInLoc = True
isWiredInLoc other = False
srcLocFile :: SrcLoc -> FastString
srcLocFile (SrcLoc fname _) = fname
srcLocFile (SrcLoc fname _ _) = fname
srcLocLine :: SrcLoc -> Int
srcLocLine (SrcLoc _ l c) = iBox l
srcLocLine :: SrcLoc -> FastInt
srcLocLine (SrcLoc _ l) = l
srcLocCol :: SrcLoc -> Int
srcLocCol (SrcLoc _ l c) = iBox c
incSrcLine :: SrcLoc -> SrcLoc
incSrcLine (SrcLoc s l) = SrcLoc s (l +# 1#)
incSrcLine loc = loc
advanceSrcLoc :: SrcLoc -> Char -> SrcLoc
advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (tab c)
advanceSrcLoc (SrcLoc f l c) '\n' = SrcLoc f (l +# 1#) 0#
advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c +# 1#)
replaceSrcLine :: SrcLoc -> FastInt -> SrcLoc
replaceSrcLine (SrcLoc s _) l = SrcLoc s l
-- Advance to the next tab stop. Tabs are at column positions 0, 8, 16, etc.
tab :: FastInt -> FastInt
tab c = (c `quotInt#` 8# +# 1#) *# 8#
\end{code}
%************************************************************************
......@@ -118,19 +138,23 @@ cmpSrcLoc WiredInLoc other = LT
cmpSrcLoc (UnhelpfulSrcLoc s1) (UnhelpfulSrcLoc s2) = s1 `compare` s2
cmpSrcLoc (UnhelpfulSrcLoc s1) other = GT
cmpSrcLoc (SrcLoc s1 l1) WiredInLoc = GT
cmpSrcLoc (SrcLoc s1 l1) (UnhelpfulSrcLoc _) = LT
cmpSrcLoc (SrcLoc s1 l1) (SrcLoc s2 l2) = (s1 `compare` s2) `thenCmp` (l1 `cmpline` l2)
where
l1 `cmpline` l2 | l1 <# l2 = LT
| l1 ==# l2 = EQ
| otherwise = GT
cmpSrcLoc (SrcLoc _ _ _) WiredInLoc = GT
cmpSrcLoc (SrcLoc _ _ _) (UnhelpfulSrcLoc _) = LT
cmpSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2)
= (s1 `compare` s2) `thenCmp` (l1 `cmpline` l2) `thenCmp` (c1 `cmpline` c2)
where
l1 `cmpline` l2 | l1 <# l2 = LT
| l1 ==# l2 = EQ
| otherwise = GT
instance Outputable SrcLoc where
ppr (SrcLoc src_path src_line)
ppr (SrcLoc src_path src_line src_col)
= getPprStyle $ \ sty ->
if userStyle sty || debugStyle sty then
hcat [ ftext src_path, char ':', int (iBox src_line) ]
hcat [ ftext src_path, char ':',
int (iBox src_line)
{- TODO: char ':', int (iBox src_col) -}
]
else
hcat [text "{-# LINE ", int (iBox src_line), space,
char '\"', ftext src_path, text " #-}"]
......
......@@ -36,9 +36,10 @@ import CoreLint ( lintUnfolding )
import HsSyn
import RdrName ( nameRdrName )
import StringBuffer ( hGetStringBuffer, freeStringBuffer )
import StringBuffer ( hGetStringBuffer )
import Parser
import Lex ( ParseResult(..), ExtFlags(..), mkPState )
import Lexer ( P(..), ParseResult(..), ExtFlags(..),
mkPState, showPFailed )
import SrcLoc ( mkSrcLoc )
import TcRnDriver ( checkOldIface, tcRnModule, tcRnExtCore, tcRnIface )
import RnEnv ( extendOrigNameCache )
......@@ -152,7 +153,8 @@ hscNoRecomp hsc_env pcs_ch have_object
showModMsg have_object mod location);
-- Typecheck
(pcs_tc, maybe_tc_result) <- tcRnIface hsc_env pcs_ch old_iface ;
(pcs_tc, maybe_tc_result) <- _scc_ "tcRnIface"
tcRnIface hsc_env pcs_ch old_iface ;
case maybe_tc_result of {
Nothing -> return (HscFail pcs_tc);
......@@ -387,13 +389,12 @@ myParseModule dflags src_filename
buf <- hGetStringBuffer src_filename
let exts = mkExtFlags dflags
loc = mkSrcLoc (mkFastString src_filename) 1
loc = mkSrcLoc (mkFastString src_filename) 1 0
case parseModule buf (mkPState loc exts) of {
case unP parseModule (mkPState buf loc exts) of {
PFailed err -> do { hPutStrLn stderr (showSDoc err);
freeStringBuffer buf;
return Nothing };
PFailed l1 l2 err -> do { hPutStrLn stderr (showPFailed l1 l2 err);
return Nothing };
POk _ rdr_module -> do {
......@@ -510,13 +511,12 @@ hscParseStmt dflags str
buf <- stringToStringBuffer str
let exts = mkExtFlags dflags
loc = mkSrcLoc FSLIT("<interactive>") 1
loc = mkSrcLoc FSLIT("<interactive>") 1 0
case parseStmt buf (mkPState loc exts) of {
case unP parseStmt (mkPState buf loc exts) of {
PFailed err -> do { hPutStrLn stderr (showSDoc err);
-- Not yet implemented in <4.11 freeStringBuffer buf;
return Nothing };
PFailed l1 l2 err -> do { hPutStrLn stderr (showPFailed l1 l2 err);
return Nothing };
-- no stmt: the line consisted of just space or comments
POk _ Nothing -> return Nothing;
......@@ -525,7 +525,6 @@ hscParseStmt dflags str
--ToDo: can't free the string buffer until we've finished this
-- compilation sweep and all the identifiers have gone away.
--freeStringBuffer buf;
dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_stmt);
return (Just rdr_stmt)
}}
......@@ -568,16 +567,14 @@ myParseIdentifier dflags str
= do buf <- stringToStringBuffer str
let exts = mkExtFlags dflags
loc = mkSrcLoc FSLIT("<interactive>") 1
loc = mkSrcLoc FSLIT("<interactive>") 1 0
case parseIdentifier buf (mkPState loc exts) of
case unP parseIdentifier (mkPState buf loc exts) of
PFailed err -> do { hPutStrLn stderr (showSDoc err);
freeStringBuffer buf;
return Nothing }
PFailed l1 l2 err -> do { hPutStrLn stderr (showPFailed l1 l2 err);
return Nothing }
POk _ rdr_name -> do { --should, but can't: freeStringBuffer buf;
return (Just rdr_name) }
POk _ rdr_name -> return (Just rdr_name)
#endif
\end{code}
......
......@@ -4,7 +4,7 @@ module ParsePkgConf( loadPackageConfig ) where
#include "HsVersions.h"
import Packages ( PackageConfig(..), defaultPackageConfig )
import Lex
import Lexer
import FastString
import StringBuffer
import SrcLoc
......@@ -15,18 +15,18 @@ import EXCEPTION ( throwDyn )
}
%token
'{' { ITocurly }
'}' { ITccurly }
'[' { ITobrack }
']' { ITcbrack }
',' { ITcomma }
'=' { ITequal }
VARID { ITvarid $$ }
CONID { ITconid $$ }
STRING { ITstring $$ }
%monad { P } { thenP } { returnP }
%lexer { lexer } { ITeof }
'{' { T _ _ ITocurly }
'}' { T _ _ ITccurly }
'[' { T _ _ ITobrack }
']' { T _ _ ITcbrack }
',' { T _ _ ITcomma }
'=' { T _ _ ITequal }
VARID { T _ _ (ITvarid $$) }
CONID { T _ _ (ITconid $$) }
STRING { T _ _ (ITstring $$) }
%monad { P } { >>= } { return }
%lexer { lexer } { T _ _ ITeof }
%name parse
%tokentype { Token }
%%
......@@ -49,7 +49,7 @@ fields :: { PackageConfig -> PackageConfig }
field :: { PackageConfig -> PackageConfig }
: VARID '=' STRING
{% case unpackFS $1 of {
"name" -> returnP (\ p -> p{name = unpackFS $3});
"name" -> return (\ p -> p{name = unpackFS $3});
_ -> happyError } }
| VARID '=' bool
......@@ -84,29 +84,27 @@ strs :: { [String] }
bool :: { Bool }
: CONID {% case unpackFS $1 of {
"True" -> returnP True;
"False" -> returnP False;
"True" -> return True;
"False" -> return False;
_ -> happyError } }
{
happyError :: P a
happyError buf PState{ loc = loc } = PFailed (srcParseErr buf loc)
happyError = srcParseFail
loadPackageConfig :: FilePath -> IO [PackageConfig]
loadPackageConfig conf_filename = do
buf <- hGetStringBuffer conf_filename
let loc = mkSrcLoc (mkFastString conf_filename) 1
let loc = mkSrcLoc (mkFastString conf_filename) 1 0
exts = ExtFlags {glasgowExtsEF = False,
ffiEF = False,
arrowsEF = False,
withEF = False,
parrEF = False}
case parse buf (mkPState loc exts) of
PFailed err -> do
freeStringBuffer buf
throwDyn (InstallationError (showSDoc err))
case unP parse (mkPState buf loc exts) of
PFailed l1 l2 err -> do
throwDyn (InstallationError (showPFailed l1 l2 err))
POk _ pkg_details -> do
freeStringBuffer buf
return pkg_details
}
......@@ -15,7 +15,6 @@ module Ctype
import DATA_INT ( Int32 )
import DATA_BITS ( Bits((.&.)) )
import GLAEXTS ( Char#, Char(..) )
\end{code}
Bit masks
......@@ -36,10 +35,10 @@ at the big case below.
\begin{code}
{-# INLINE is_ctype #-}
is_ctype :: Int -> Char# -> Bool
is_ctype mask c = (fromIntegral (charType (C# c)) .&. fromIntegral mask) /= (0::Int32)
is_ctype :: Int -> Char -> Bool
is_ctype mask c = (fromIntegral (charType c) .&. fromIntegral mask) /= (0::Int32)
is_ident, is_symbol, is_any, is_space, is_lower, is_upper, is_digit :: Char# -> Bool
is_ident, is_symbol, is_any, is_space, is_lower, is_upper, is_digit :: Char -> Bool
is_ident = is_ctype cIdent
is_symbol = is_ctype cSymbol
is_any = is_ctype cAny
......@@ -65,7 +64,7 @@ charType c = case c of
'\7' -> 0 -- \007
'\8' -> 0 -- \010
'\9' -> cAny + cSpace -- \t
'\10' -> cAny + cSpace -- \n
'\10' -> cSpace -- \n (not allowed in strings, so !cAny)
'\11' -> cAny + cSpace -- \v
'\12' -> cAny + cSpace -- \f
'\13' -> cAny + cSpace -- ^M
......
This diff is collapsed.
This diff is collapsed.
......@@ -99,7 +99,7 @@ import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, mkUnqual, rdrNameOcc,
setRdrNameSpace )
import BasicTypes ( RecFlag(..), FixitySig(..), maxPrecedence )
import Class ( DefMeth (..) )
import Lex ( P, mapP, setSrcLocP, thenP, returnP, getSrcLocP, failMsgP )
import Lexer ( P, setSrcLocFor, getSrcLoc, failLocMsgP )
import HscTypes ( RdrAvailInfo, GenAvailInfo(..) )
import TysWiredIn ( unitTyCon )
import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
......@@ -484,19 +484,19 @@ mkPrefixCon ty tys
= split ty tys
where
split (HsAppTy t u) ts = split t (unbangedType u : ts)
split (HsTyVar tc) ts = tyConToDataCon tc `thenP` \ data_con ->
returnP (data_con, PrefixCon ts)
split (HsTyVar tc) ts = tyConToDataCon tc >>= \ data_con ->
return (data_con, PrefixCon 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 [ (l,t) | (ls,t) <- fields, l <- ls ])
= tyConToDataCon con >>= \ data_con ->
return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
tyConToDataCon :: RdrName -> P RdrName
tyConToDataCon tc
| isTcOcc (rdrNameOcc tc)
= returnP (setRdrNameSpace tc srcDataName)
= return (setRdrNameSpace tc srcDataName)
| otherwise
= parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
......@@ -507,21 +507,21 @@ checkInstType :: RdrNameHsType -> P RdrNameHsType
checkInstType t
= case t of
HsForAllTy tvs ctxt ty ->
checkDictTy ty [] `thenP` \ dict_ty ->
returnP (HsForAllTy tvs ctxt dict_ty)
checkDictTy ty [] >>= \ dict_ty ->
return (HsForAllTy tvs ctxt dict_ty)
HsParTy ty -> checkInstType ty
ty -> checkDictTy ty [] `thenP` \ dict_ty->
returnP (HsForAllTy Nothing [] dict_ty)
ty -> checkDictTy ty [] >>= \ dict_ty->
return (HsForAllTy Nothing [] dict_ty)
checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar]
checkTyVars tvs
= mapP chk tvs
= mapM chk tvs
where
-- Check that the name space is correct!
chk (HsKindSig (HsTyVar tv) k) | isRdrTyVar tv = returnP (IfaceTyVar tv k)
chk (HsTyVar tv) | isRdrTyVar tv = returnP (UserTyVar tv)
chk (HsKindSig (HsTyVar tv) k) | isRdrTyVar tv = return (IfaceTyVar tv k)
chk (HsTyVar tv) | isRdrTyVar tv = return (UserTyVar tv)
chk other = parseError "Type found where type variable expected"
checkTyClHdr :: RdrNameHsType -> P (RdrName, [RdrNameHsTyVar])
......@@ -534,46 +534,46 @@ checkTyClHdr ty
= go ty []
where
go (HsTyVar tc) acc
| not (isRdrTyVar tc) = checkTyVars acc `thenP` \ tvs ->
returnP (tc, tvs)
| not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs ->
return (tc, tvs)
go (HsOpTy t1 (HsTyOp tc) t2) acc
= checkTyVars (t1:t2:acc) `thenP` \ tvs ->
returnP (tc, tvs)
= checkTyVars (t1:t2:acc) >>= \ tvs ->
return (tc, tvs)
go (HsParTy ty) acc = go ty acc
go (HsAppTy t1 t2) acc = go t1 (t2:acc)
go other acc = parseError "Malformed LHS to type of class declaration"
checkContext :: RdrNameHsType -> P RdrNameContext
checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
= mapP checkPred ts
= mapM checkPred ts
checkContext (HsParTy ty) -- to be sure HsParTy doesn't get into the way
= checkContext ty
checkContext (HsTyVar t) -- Empty context shows up as a unit type ()
| t == getRdrName unitTyCon = returnP []
| t == getRdrName unitTyCon = return []
checkContext t
= checkPred t `thenP` \p ->
returnP [p]
= checkPred t >>= \p ->
return [p]
checkPred :: RdrNameHsType -> P (HsPred RdrName)
-- Watch out.. in ...deriving( Show )... we use checkPred on
-- the list of partially applied predicates in the deriving,
-- so there can be zero args.
checkPred (HsPredTy (HsIParam n ty)) = returnP (HsIParam n ty)
checkPred (HsPredTy (HsIParam n ty)) = return (HsIParam n ty)
checkPred ty
= go ty []
where
go (HsTyVar t) args | not (isRdrTyVar t)
= returnP (HsClassP t args)
= return (HsClassP t args)
go (HsAppTy l r) args = go l (r:args)
go (HsParTy t) args = go t args
go _ _ = parseError "Illegal class assertion"
checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
= returnP (mkHsDictTy t args)
= return (mkHsDictTy t args)
checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
checkDictTy (HsParTy t) args = checkDictTy t args
checkDictTy _ _ = parseError "Malformed context in instance header"
......@@ -591,37 +591,37 @@ checkDo = checkDoMDo "a " "'do'"
checkMDo = checkDoMDo "an " "'mdo'"
checkDoMDo _ nm [] = parseError $ "Empty " ++ nm ++ " construct"
checkDoMDo _ _ [ExprStmt e _ l] = returnP [ResultStmt e l]
checkDoMDo _ _ [ExprStmt e _ l] = return [ResultStmt e l]
checkDoMDo pre nm [s] = parseError $ "The last statement in " ++ pre ++ nm ++ " construct must be an expression"
checkDoMDo pre nm (s:ss) = checkDoMDo pre nm ss `thenP` \ ss' ->
returnP (s:ss')
checkDoMDo pre nm (s:ss) = checkDoMDo pre nm ss >>= \ ss' ->
return (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 :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat
checkPattern loc e = setSrcLocP loc (checkPat e [])
checkPattern loc e = setSrcLocFor loc (checkPat e [])
checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
checkPatterns loc es = mapP (checkPattern loc) es
checkPatterns loc es = mapM (checkPattern loc) es
checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c (PrefixCon args))
checkPat (HsVar c) args | isRdrDataCon c = return (ConPatIn c (PrefixCon args))
checkPat (HsApp f x) args =
checkPat x [] `thenP` \x ->
checkPat x [] >>= \x ->
checkPat f (x:args)
checkPat e [] = case e of
EWildPat -> returnP (WildPat placeHolderType)
EWildPat -> return (WildPat placeHolderType)
HsVar x | isQual x -> parseError ("Qualified variable in pattern: " ++ showRdrName x)
| otherwise -> returnP (VarPat x)
HsLit l -> returnP (LitPat l)
HsOverLit l -> returnP (NPatIn l Nothing)
ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPat)
EAsPat n e -> checkPat e [] `thenP` (returnP . AsPat n)
ExprWithTySig e t -> checkPat e [] `thenP` \e ->
| otherwise -> return (VarPat x)
HsLit l -> return (LitPat l)
HsOverLit l -> return (NPatIn l Nothing)
ELazyPat e -> checkPat e [] >>= (return . LazyPat)
EAsPat n e -> checkPat e [] >>= (return . AsPat n)
ExprWithTySig e t -> checkPat e [] >>= \e ->
-- Pattern signatures are parsed as sigtypes,
-- but they aren't explicit forall points. Hence
-- we have to remove the implicit forall here.
......@@ -629,48 +629,48 @@ checkPat e [] = case e of
HsForAllTy Nothing [] ty -> ty
other -> other
in
returnP (SigPatIn e t')
return (SigPatIn e t')
-- Translate out NegApps of literals in patterns. We negate
-- the Integer here, and add back the call to 'negate' when
-- we typecheck the pattern.
-- NB. Negative *primitive* literals are already handled by
-- RdrHsSyn.mkHsNegApp
NegApp (HsOverLit lit) neg -> returnP (NPatIn lit (Just neg))
NegApp (HsOverLit lit) neg -> return (NPatIn lit (Just neg))
OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _))
| plus == plus_RDR
-> returnP (mkNPlusKPat n lit)
-> return (mkNPlusKPat n lit)
where
plus_RDR = mkUnqual varName FSLIT("+") -- Hack
OpApp l op fix r -> checkPat l [] `thenP` \l ->
checkPat r [] `thenP` \r ->
OpApp l op fix r -> checkPat l [] >>= \l ->
checkPat r [] >>= \r ->
case op of
HsVar c | isDataOcc (rdrNameOcc c)
-> returnP (ConPatIn c (InfixCon l r))
-> return (ConPatIn c (InfixCon l r))
_ -> patFail
HsPar e -> checkPat e [] `thenP` (returnP . ParPat)
ExplicitList _ es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
returnP (ListPat ps placeHolderType)
ExplicitPArr _ es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
returnP (PArrPat ps placeHolderType)
HsPar e -> checkPat e [] >>= (return . ParPat)
ExplicitList _ es -> mapM (\e -> checkPat e []) es >>= \ps ->
return (ListPat ps placeHolderType)
ExplicitPArr _ es -> mapM (\e -> checkPat e []) es >>= \ps ->
return (PArrPat ps placeHolderType)
ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
returnP (TuplePat ps b)