This commit replaces the old yacc parser with a Happy-generated one.
Notes:
- The generated .hs file is *big*. Best to use a recent
version of Happy, and even better to add the -c flag
to use unsafeCoerce# with ghc (versions 4.02+ please).
- The lexer has grown all sorts of unsightly growths and
should be put down as soon as possible.
- Parse errors may result in strange diagnostics. I'm looking
into this.
- HsSyn now contains a few extra constructors due to the way
patterns are parsed as expressions in the parser.
- The layout rule is implemented according to the Haskell
report. I found a couple of places in the libraries where
we previously weren't adhering to this - in particular the
rule about "nested contexts must be more indented than
outer contexts". The rule is necessary to disambiguate
in the presence of empty declaration lists.
# -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.59 1999/05/18 16:38:23 simonpj Exp $
+# $Id: Makefile,v 1.60 1999/06/01 16:40:41 simonmar Exp $
TOP = ..
include $(TOP)/mk/boilerplate.mk
# -----------------------------------------------------------------------------
# Set HS_PROG, LIBRARY
-# Setting HS_PROG and LIBRARY causes all targets in target.mk
-# (included below) to kick in.
-LIBRARY=libhsp.a
-
-#
# Note: there have been reports of people running up against the ARG_MAX limit
# when linking hsc with all its constituent object files. The likely source of
# the problem is that the environment is a bit too big, so a workaround could
DIRS = \
utils basicTypes types hsSyn prelude rename typecheck deSugar coreSyn \
specialise simplCore stranal stgSyn simplStg codeGen absCSyn main \
- reader profiling parser usageSP cprAnalysis
+ profiling parser usageSP cprAnalysis
ifeq ($(GhcWithNativeCodeGen),YES)
endif
-HS_SRCS = $(SRCS_UGNHS) \
- $(foreach dir,$(DIRS),$(wildcard $(dir)/*.lhs))
+HS_SRCS = $(foreach dir,$(DIRS),$(wildcard $(dir)/*.lhs))
ifneq "$(GhcWithHscBuiltViaC)" "YES"
-HS_SRCS += rename/ParseIface.hs
+HS_SRCS += rename/ParseIface.hs parser/Parser.hs
endif
-# NB: it's no good to include *.hs in the top-line wildcard, because the .hs files
-# in parser/ may not have been created at that point.
-
HCS = $(patsubst %.lhs, %.hc, $(patsubst %.hs, %.hc, $(HS_SRCS)))
# ParseIface.hs ain't part of HS_SRCS when this is on..
ifeq "$(GhcWithHscBuiltViaC)" "YES"
-HCS += rename/ParseIface.hc
+HCS += rename/ParseIface.hc parser/Parser.hc
endif
HS_OBJS = \
$(patsubst %.hc, %.o, $(HCS)) \
- parser/hsclink.o parser/hschooks.o libhsp.a
+ parser/ctypes.o parser/hschooks.o
DESTDIR = $(INSTALL_LIBRARY_DIR_GHC)
-SRCS_UGN = $(wildcard parser/*.ugn)
-SRCS_UGNC = $(patsubst %.ugn, %.c, $(SRCS_UGN))
-SRCS_UGNH = $(patsubst %.ugn, %.h, $(SRCS_UGN))
-SRCS_UGNHS = $(patsubst parser/%.ugn, parser/U_%.hs, $(SRCS_UGN))
-SRCS_UGN_OBJS = $(patsubst %.c, %.o, $(SRCS_UGNC))
-
-#
-# Add the generated C files to the C_SRCS, so as to let `depend'
-# generate correct dependencies for them.
-#
-C_SRCS += $(SRCS_UGNC)
#
# Add misc .c helper code (used by the frontend.)
#
-C_SRCS += parser/ctypes.c parser/hschooks.c parser/hsclink.c \
- parser/id.c parser/infix.c parser/main.c parser/printtree.c \
- parser/syntax.c parser/type2context.c parser/util.c
+C_SRCS += parser/ctypes.c parser/hschooks.c
#
# Big Fudge to get around inherent problem that Makefile setup
#
SRC_MKDEPENDC_OPTS += -D__GLASGOW_HASKELL__=$(ProjectVersionInt)
-LIBOBJS = \
- $(SRCS_UGN_OBJS) parser/hslexer.o parser/hsparser.tab.o \
- parser/id.o parser/infix.o parser/syntax.o parser/type2context.o \
- parser/util.o parser/ctypes.o
-
# stuff you get for free in a source distribution
#
# SRC_DIST_FILES += rename/ParseIface.hs \
nativeGen/PprMach_HC_OPTS = -K2m
nativeGen/MachMisc_HC_OPTS = -K2m -fvia-C
nativeGen/MachCode_HC_OPTS = -H10m
-parser/UgenAll_HC_OPTS = -fvia-C '-\#include"hspincl.h"'
-parser/UgenUtil_HC_OPTS = -fvia-C '-\#include"hspincl.h"'
-parser/U_binding_HC_OPTS = -fvia-C '-\#include"hspincl.h"'
-parser/U_constr_HC_OPTS = -fvia-C '-\#include"hspincl.h"'
-parser/U_either_HC_OPTS = -fvia-C '-\#include"hspincl.h"'
-parser/U_entidt_HC_OPTS = -fvia-C '-\#include"hspincl.h"'
-parser/U_gdexp_HC_OPTS = -fvia-C '-\#include"hspincl.h"'
-parser/U_grhsb_HC_OPTS = -fvia-C '-\#include"hspincl.h"'
-parser/U_list_HC_OPTS = -fvia-C '-\#include"hspincl.h"'
-parser/U_literal_HC_OPTS = -fvia-C '-\#include"hspincl.h"'
-parser/U_match_HC_OPTS = -fvia-C '-\#include"hspincl.h"'
-parser/U_maybe_HC_OPTS = -fvia-C '-\#include"hspincl.h"'
-parser/U_qid_HC_OPTS = -fvia-C '-\#include"hspincl.h"'
-parser/U_rulevar_HC_OPTS = -fvia-C '-\#include"hspincl.h"'
-parser/U_tree_HC_OPTS = -H12m -fvia-C '-\#include"hspincl.h"'
-parser/U_ttype_HC_OPTS = -fvia-C '-\#include"hspincl.h"'
# Avoids Bug in 3.02, it seems
usageSP/UsageSPInf_HC_OPTS = -Onot
prelude/PrimOp_HC_OPTS = -H12m -K3m
-reader/Lex_HC_OPTS = -K2m -H16m -fvia-C
-
-# Heap was 6m with 2.10
-reader/ReadPrefix_HC_OPTS = -fvia-C '-\#include"hspincl.h"' -H10m
+parser/Lex_HC_OPTS = -K2m -H16m -fvia-C
-rename/ParseIface_HC_OPTS += -Onot -H45m -dcore-lint -fno-warn-incomplete-patterns
+# -dcore-lint is *temporary* to work around ghc space leak.
+rename/ParseIface_HC_OPTS += -Onot -H45m -dcore-lint -fno-warn-incomplete-patterns -dcore-lint
rename/ParseIface_HAPPY_OPTS += -g
+parser/Parser_HC_OPTS += -Onot -H45m -dcore-lint -fno-warn-incomplete-patterns -dcore-lint
+parser/Parser_HAPPY_OPTS += -g
+
ifeq "$(TARGETPLATFORM)" "hppa1.1-hp-hpux9"
rename/RnMonad_HC_OPTS = -fvia-C -O2 -O2-for-C
endif
# ----------------------------------------------------------------------------
# C compilations
-SRC_C_OPTS += -O -Iparser -I. -IcodeGen
+SRC_C_OPTS += -O -I. -IcodeGen
# ----------------------------------------------------------------------------
# Parsers/lexers
-# Main parser uses Yacc/Bison
-SRC_YACC_OPTS += -d -v
-# Suppress the generation of a default rule
-SRC_FLEX_OPTS += -s
-
-#
-# Want to keep the intermediate (included in src distribs).
-#
-.PRECIOUS: %.tab.c %.tab.h parser/hslexer.c
-
parser/hschooks.o : parser/hschooks.c
@$(RM) $@
$(HC) -c -o $@ -I$(GHC_INCLUDE_DIR) $(HC_OPTS) parser/hschooks.c
$(HAPPY) $(HAPPY_OPTS) -g rename/ParseIface.y
@chmod 444 rename/ParseIface.hs
-#----------------------------------------------------------------------
-#
-# Building the stand-alone parser
-#
-all :: hsp
-
-hsp: parser/printtree.o parser/main.o libhsp.a
- $(CC) -o $@ $(CC_OPTS) $^
-
-CLEAN_FILES += hsp
+parser/Parser.hs : parser/Parser.y
+ @$(RM) parser/Parser.hs parser/ParseIface.hinfo
+ $(HAPPY) $(HAPPY_OPTS) -g parser/Parser.y
+ @chmod 444 parser/Parser.hs
#-----------------------------------------------------------------------------
# Linking
# but put it together with the libraries.
# Also don't want any interface files intstalled
-INSTALL_LIBEXECS += hsc hsp
+INSTALL_LIBEXECS += hsc
#-----------------------------------------------------------------------------
# depend
#
# Before doing `make depend', need to build all derived Haskell source files
#
-depend :: $(LOOPS) $(SRCS_UGNHS)
+depend :: $(LOOPS)
ifneq "$(GhcWithHscBuiltViaC)" "YES"
depend :: rename/ParseIface.hs
#-----------------------------------------------------------------------------
# clean
-CLEAN_FILES += $(wildcard */*.$(way_)o */*.$(way_)hi) \
- $(SRCS_UGNC) $(SRCS_UGNH) \
- $(SRCS_UGNHS)\
- parser/hslexer.c parser/hsparser.tab.h parser/hsparser.tab.c
+CLEAN_FILES += $(wildcard */*.$(way_)o */*.$(way_)hi)
# Extra tidy, remove the .hc files (if you've got them).
MAINTAINER_CLEAN_FILES += $(wildcard */*.hc)
include $(TOP)/mk/target.mk
+parser/%.o : parser/%.c
-#
-# Special extra dependencies for yukky ugen stuff
-#
-
-parser/%.o : parser/%.c $(SRCS_UGNH)
-parser/hslexer.o : parser/hslexer.c parser/hsparser.tab.h
-
-parser/hspincl.h : $(SRCS_UGNH)
-parser/UgenAll.o : parser/hspincl.h
-parser/UgenUtil.o : parser/hspincl.h
-parser/U_constr.o : parser/hspincl.h
-parser/U_binding.o : parser/hspincl.h
-parser/U_pbinding.o : parser/hspincl.h
-parser/U_entidt.o : parser/hspincl.h
-parser/U_list.o : parser/hspincl.h
-parser/U_literal.o : parser/hspincl.h
-parser/U_maybe.o : parser/hspincl.h
-parser/U_either.o : parser/hspincl.h
-parser/U_qid.o : parser/hspincl.h
-parser/U_tree.o : parser/hspincl.h
-parser/U_ttype.o : parser/hspincl.h
-parser/printtree.o : parser/hspincl.h
-reader/ReadPrefix.o : parser/hspincl.h
text "out of range",
brackets (ppr range_min <+> text ".."
<+> ppr range_max)])
+ -- in interface files, parenthesize raw negative ints.
+ -- this avoids problems like {-1} being interpreted
+ -- as a comment starter.
+ | ifaceStyle sty && i < 0 -> parens (integer i)
| otherwise -> integer i
where
MachFloat f | code_style -> ptext SLIT("(StgFloat)") <> rational f
| otherwise -> ptext SLIT("__float") <+> rational f
- MachDouble d -> rational d
+ MachDouble d | ifaceStyle sty && d < 0 -> parens (rational d)
+ | otherwise -> rational d
MachAddr p | code_style -> ptext SLIT("(void*)") <> integer p
| otherwise -> ptext SLIT("__addr") <+> integer p
dummyRdrVarName, dummyRdrTcName,
-- Destruction
- rdrNameModule, rdrNameOcc,
+ rdrNameModule, rdrNameOcc, setRdrNameOcc,
isRdrDataCon, isRdrTyVar, isQual, isUnqual
) where
rdrNameOcc :: RdrName -> OccName
rdrNameOcc (RdrName _ occ) = occ
+
+setRdrNameOcc :: RdrName -> OccName -> RdrName
+setRdrNameOcc (RdrName q _) occ = RdrName q occ
\end{code}
\begin{code}
mkGeneratedSrcLoc, -- Code generated within the compiler
- incSrcLine,
+ incSrcLine, replaceSrcLine,
- srcLocFile -- return the file name part.
+ srcLocFile, -- return the file name part.
+ srcLocLine -- return the line part.
) where
#include "HsVersions.h"
srcLocFile :: SrcLoc -> FAST_STRING
srcLocFile (SrcLoc fname _) = fname
+srcLocLine :: SrcLoc -> FAST_INT
+srcLocLine (SrcLoc _ l) = l
+
incSrcLine :: SrcLoc -> SrcLoc
incSrcLine (SrcLoc s l) = SrcLoc s (l +# 1#)
incSrcLine loc = loc
+
+replaceSrcLine :: SrcLoc -> FAST_INT -> SrcLoc
+replaceSrcLine (SrcLoc s _) l = SrcLoc s l
\end{code}
%************************************************************************
(HsExpr id pat) -- expr whose cost is to be measured
\end{code}
+These constructors only appear temporarily in the parser.
+
+\begin{code}
+ | EWildPat -- wildcard
+
+ | EAsPat id -- as pattern
+ (HsExpr id pat)
+
+ | ELazyPat (HsExpr id pat) -- ~ pattern
+\end{code}
+
Everything from here on appears only in typechecker output.
\begin{code}
intSwitchSet,
switchIsOn,
+ src_filename,
+
-- debugging opts
opt_D_dump_absC,
opt_D_dump_asm,
import Argv
import Constants -- Default values for some flags
+import FastString ( headFS )
import Maybes ( assocMaybe, firstJust, maybeToBool )
import Panic ( panic, panic# )
\end{code}
\begin{code}
+src_filename :: FAST_STRING
+src_filename = case argv of
+ filename : rest | headFS filename /= '-' -> filename
+ otherwise -> panic "no filename"
+\end{code}
+
+\begin{code}
-- debugging opts
opt_D_dump_absC = lookUp SLIT("-ddump-absC")
opt_D_dump_asm = lookUp SLIT("-ddump-asm")
import HsSyn
import BasicTypes ( NewOrData(..) )
-import ReadPrefix ( rdModule )
+import RdrHsSyn ( RdrNameHsModule )
+import FastString ( mkFastCharString, unpackFS )
+import StringBuffer ( hGetStringBuffer )
+import Parser ( parse )
+import Lex ( PState(..), P, ParseResult(..) )
+import SrcLoc ( mkSrcLoc )
+
import Rename ( renameModule )
import MkIface ( startIface, ifaceDecls, endIface )
\end{code}
\begin{code}
+parseModule :: IO (ModuleName, RdrNameHsModule)
+parseModule = do
+ buf <- hGetStringBuffer True{-expand tabs-} (unpackFS src_filename)
+ case parse buf PState{ bol = 0#, atbol = 1#,
+ context = [], glasgow_exts = glaexts,
+ loc = mkSrcLoc src_filename 1 } of
+
+ PFailed err -> do
+ printErrs err
+ ghcExit 1
+ return (error "parseModule") -- just to get the types right
+
+ POk _ m@(HsModule mod _ _ _ _ _) ->
+ return (mod, m)
+ where
+ glaexts | opt_GlasgowExts = 1#
+ | otherwise = 0#
+\end{code}
+
+\begin{code}
doIt :: ([CoreToDo], [StgToDo]) -> IO ()
doIt (core_cmds, stg_cmds)
-------------------------- Reader ----------------
show_pass "Reader" >>
_scc_ "Reader"
- rdModule >>= \ (mod_name, rdr_module) ->
+ parseModule >>= \ (mod_name, rdr_module) ->
dumpIfSet opt_D_source_stats "Source Statistics"
(ppSourceStats False rdr_module) >>
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[Lexical analysis]{Lexical analysis}
+
+--------------------------------------------------------
+[Jan 98]
+There's a known bug in here:
+
+ If an interface file ends prematurely, Lex tries to
+ do headFS of an empty FastString.
+
+An example that provokes the error is
+
+ f _:_ _forall_ [a] <<<END OF FILE>>>
+--------------------------------------------------------
+
+\begin{code}
+{-# OPTIONS -#include "ctypes.h" #-}
+
+module Lex (
+
+ ifaceParseErr,
+
+ -- Monad for parser
+ Token(..), lexer, ParseResult(..), PState(..),
+ checkVersion,
+ StringBuffer,
+
+ P, thenP, thenP_, returnP, mapP, failP, failMsgP,
+ getSrcLocP, getSrcFile,
+ layoutOn, layoutOff, pushContext, popContext
+ ) where
+
+#include "HsVersions.h"
+
+import Char ( ord, isSpace )
+import List ( isSuffixOf )
+
+import IdInfo ( InlinePragInfo(..), CprInfo(..) )
+import Name ( isLowerISO, isUpperISO )
+import PrelMods ( mkTupNameStr, mkUbxTupNameStr )
+import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_HiVersion, opt_NoHiCheck )
+import Demand ( Demand(..) {- instance Read -} )
+import UniqFM ( UniqFM, listToUFM, lookupUFM)
+import BasicTypes ( NewOrData(..) )
+import SrcLoc ( SrcLoc, incSrcLine, srcLocFile, srcLocLine,
+ replaceSrcLine, mkSrcLoc )
+
+import Maybes ( MaybeErr(..) )
+import ErrUtils ( Message )
+import Outputable
+
+import FastString
+import StringBuffer
+import GlaExts
+import ST ( runST )
+
+#if __GLASGOW_HASKELL__ >= 303
+import Bits
+import Word
+#endif
+
+import Char ( chr )
+import Addr
+import PrelRead ( readRational__ ) -- Glasgow non-std
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Data types}
+%* *
+%************************************************************************
+
+The token data type, fairly un-interesting except from one
+constructor, @ITidinfo@, which is used to lazily lex id info (arity,
+strictness, unfolding etc).
+
+The Idea/Observation here is that the renamer needs to scan through
+all of an interface file before it can continue. But only a fraction
+of the information contained in the file turns out to be useful, so
+delaying as much as possible of the scanning and parsing of an
+interface file Makes Sense (Heap profiles of the compiler
+show a reduction in heap usage by at least a factor of two,
+post-renamer).
+
+Hence, the interface file lexer spots when value declarations are
+being scanned and return the @ITidinfo@ and @ITtype@ constructors
+for the type and any other id info for that binding (unfolding, strictness
+etc). These constructors are applied to the result of lexing these sub-chunks.
+
+The lexing of the type and id info is all done lazily, of course, so
+the scanning (and subsequent parsing) will be done *only* on the ids the
+renamer finds out that it is interested in. The rest will just be junked.
+Laziness, you know it makes sense :-)
+
+\begin{code}
+data Token
+ = ITas -- Haskell keywords
+ | ITcase
+ | ITclass
+ | ITdata
+ | ITdefault
+ | ITderiving
+ | ITdo
+ | ITelse
+ | IThiding
+ | ITif
+ | ITimport
+ | ITin
+ | ITinfix
+ | ITinfixl
+ | ITinfixr
+ | ITinstance
+ | ITlet
+ | ITmodule
+ | ITnewtype
+ | ITof
+ | ITqualified
+ | ITthen
+ | ITtype
+ | ITwhere
+
+ | ITforall -- GHC extension keywords
+ | ITforeign
+ | ITexport
+ | ITlabel
+ | ITdynamic
+ | ITunsafe
+
+ | ITinterface -- interface keywords
+ | IT__export
+ | ITdepends
+ | IT__forall
+ | ITletrec
+ | ITcoerce
+ | ITinlineMe
+ | ITinlineCall
+ | ITccall (Bool,Bool,Bool) -- (is_dyn, is_casm, may_gc)
+ | ITdefaultbranch
+ | ITbottom
+ | ITinteger_lit
+ | ITfloat_lit
+ | ITrational_lit
+ | ITaddr_lit
+ | ITlit_lit
+ | ITstring_lit
+ | ITtypeapp
+ | ITonce
+ | ITmany
+ | ITarity
+ | ITspecialise
+ | ITnocaf
+ | ITunfold InlinePragInfo
+ | ITstrict ([Demand], Bool)
+ | ITrules
+ | ITcprinfo (CprInfo)
+ | ITscc
+ | ITsccAllCafs
+
+ | ITspecialise_prag -- Pragmas
+ | ITsource_prag
+ | ITinline_prag
+ | ITnoinline_prag
+ | ITrules_prag
+ | ITline_prag
+ | ITclose_prag
+
+ | ITdotdot -- reserved symbols
+ | ITdcolon
+ | ITequal
+ | ITlam
+ | ITvbar
+ | ITlarrow
+ | ITrarrow
+ | ITat
+ | ITtilde
+ | ITdarrow
+ | ITminus
+ | ITbang
+ | ITdot
+
+ | ITbiglam -- GHC-extension symbols
+
+ | ITocurly -- special symbols
+ | ITccurly
+ | ITvccurly
+ | ITobrack
+ | ITcbrack
+ | IToparen
+ | ITcparen
+ | IToubxparen
+ | ITcubxparen
+ | ITsemi
+ | ITcomma
+ | ITunderscore
+ | ITbackquote
+
+ | ITvarid FAST_STRING -- identifiers
+ | ITconid FAST_STRING
+ | ITvarsym FAST_STRING
+ | ITconsym FAST_STRING
+ | ITqvarid (FAST_STRING,FAST_STRING)
+ | ITqconid (FAST_STRING,FAST_STRING)
+ | ITqvarsym (FAST_STRING,FAST_STRING)
+ | ITqconsym (FAST_STRING,FAST_STRING)
+
+ | ITpragma StringBuffer
+
+ | ITchar Char
+ | ITstring FAST_STRING
+ | ITinteger Integer
+ | ITrational Rational
+
+ | ITprimchar Char
+ | ITprimstring FAST_STRING
+ | ITprimint Integer
+ | ITprimfloat Rational
+ | ITprimdouble Rational
+ | ITlitlit FAST_STRING
+
+ | ITunknown String -- Used when the lexer can't make sense of it
+ | ITeof -- end of file token
+ deriving Text -- debugging
+\end{code}
+
+-----------------------------------------------------------------------------
+Keyword Lists
+
+\begin{code}
+pragmaKeywordsFM = listToUFM $
+ map (\ (x,y) -> (_PK_ x,y))
+ [( "SPECIALISE", ITspecialise_prag ),
+ ( "SPECIALIZE", ITspecialise_prag ),
+ ( "SOURCE", ITsource_prag ),
+ ( "INLINE", ITinline_prag ),
+ ( "NOINLINE", ITnoinline_prag ),
+ ( "LINE", ITline_prag ),
+ ( "RULES", ITrules_prag ),
+ ( "RULEZ", ITrules_prag ) -- american spelling :-)
+ ]
+
+haskellKeywordsFM = listToUFM $
+ map (\ (x,y) -> (_PK_ x,y))
+ [( "_", ITunderscore ),
+ ( "as", ITas ),
+ ( "case", ITcase ),
+ ( "class", ITclass ),
+ ( "data", ITdata ),
+ ( "default", ITdefault ),
+ ( "deriving", ITderiving ),
+ ( "do", ITdo ),
+ ( "else", ITelse ),
+ ( "hiding", IThiding ),
+ ( "if", ITif ),
+ ( "import", ITimport ),
+ ( "in", ITin ),
+ ( "infix", ITinfix ),
+ ( "infixl", ITinfixl ),
+ ( "infixr", ITinfixr ),
+ ( "instance", ITinstance ),
+ ( "let", ITlet ),
+ ( "module", ITmodule ),
+ ( "newtype", ITnewtype ),
+ ( "of", ITof ),
+ ( "qualified", ITqualified ),
+ ( "then", ITthen ),
+ ( "type", ITtype ),
+ ( "where", ITwhere )
+ ]
+
+
+ghcExtensionKeywordsFM = listToUFM $
+ map (\ (x,y) -> (_PK_ x,y))
+ [ ( "forall", ITforall ),
+ ( "foreign", ITforeign ),
+ ( "export", ITexport ),
+ ( "label", ITlabel ),
+ ( "dynamic", ITdynamic ),
+ ( "unsafe", ITunsafe ),
+ ("_ccall_", ITccall (False, False, False)),
+ ("_ccall_GC_", ITccall (False, False, True)),
+ ("_casm_", ITccall (False, True, False)),
+ ("_casm_GC_", ITccall (False, True, True)),
+
+ -- interface keywords
+ ("__interface", ITinterface),
+ ("__export", IT__export),
+ ("__depends", ITdepends),
+ ("__forall", IT__forall),
+ ("__letrec", ITletrec),
+ ("__coerce", ITcoerce),
+ ("__inline_me", ITinlineMe),
+ ("__inline_call", ITinlineCall),
+ ("__depends", ITdepends),
+ ("__DEFAULT", ITdefaultbranch),
+ ("__bot", ITbottom),
+ ("__integer", ITinteger_lit),
+ ("__float", ITfloat_lit),
+ ("__rational", ITrational_lit),
+ ("__addr", ITaddr_lit),
+ ("__litlit", ITlit_lit),
+ ("__string", ITstring_lit),
+ ("__a", ITtypeapp),
+ ("__o", ITonce),
+ ("__m", ITmany),
+ ("__A", ITarity),
+ ("__P", ITspecialise),
+ ("__C", ITnocaf),
+ ("__R", ITrules),
+ ("__u", ITunfold NoInlinePragInfo),
+
+ ("__ccall", ITccall (False, False, False)),
+ ("__ccall_GC", ITccall (False, False, True)),
+ ("__dyn_ccall", ITccall (True, False, False)),
+ ("__dyn_ccall_GC", ITccall (True, False, True)),
+ ("__casm", ITccall (False, True, False)),
+ ("__dyn_casm", ITccall (True, True, False)),
+ ("__casm_GC", ITccall (False, True, True)),
+ ("__dyn_casm_GC", ITccall (True, True, True)),
+
+ ("/\\", ITbiglam)
+ ]
+
+
+haskellKeySymsFM = listToUFM $
+ map (\ (x,y) -> (_PK_ x,y))
+ [ ("..", ITdotdot)
+ ,("::", ITdcolon)
+ ,("=", ITequal)
+ ,("\\", ITlam)
+ ,("|", ITvbar)
+ ,("<-", ITlarrow)
+ ,("->", ITrarrow)
+ ,("@", ITat)
+ ,("~", ITtilde)
+ ,("=>", ITdarrow)
+ ,("-", ITminus)
+ ,("!", ITbang)
+ ,(".", ITdot) -- sadly, for 'forall a . t'
+ ]
+\end{code}
+
+-----------------------------------------------------------------------------
+The lexical analyser
+
+Lexer state:
+
+ - (glaexts) lexing an interface file or -fglasgow-exts
+ - (bol) pointer to beginning of line (for column calculations)
+ - (buf) pointer to beginning of token
+ - (buf) pointer to current char
+ - (atbol) flag indicating whether we're at the beginning of a line
+
+\begin{code}
+lexer :: (Token -> P a) -> P a
+lexer cont buf s@(PState{
+ loc = loc,
+ glasgow_exts = glaexts,
+ bol = bol,
+ atbol = atbol,
+ context = ctx
+ })
+
+ -- first, start a new lexeme and lose all the whitespace
+ = tab line bol atbol (stepOverLexeme buf)
+ where
+ line = srcLocLine loc
+
+ tab y bol atbol buf = --trace ("tab: " ++ show (I# y) ++ " : " ++ show (currentChar buf)) $
+ case currentChar# buf of
+
+ '\NUL'# ->
+ if bufferExhausted (stepOn buf)
+ then cont ITeof buf s'
+ else trace "lexer: misplaced NUL?" $
+ tab y bol atbol (stepOn buf)
+
+ '\n'# -> let buf' = stepOn buf
+ in tab (y +# 1#) (currentIndex# buf') 1# buf'
+
+ -- find comments. This got harder in Haskell 98.
+ '-'# -> let trundle n =
+ let next = lookAhead# buf n in
+ if next `eqChar#` '-'# then trundle (n +# 1#)
+ else if is_symbol next || n <# 2#
+ then is_a_token
+ else case untilChar# (stepOnBy# buf n) '\n'# of
+ { buf' -> tab y bol atbol (stepOverLexeme buf')
+ }
+ in trundle 1#
+
+ -- comments and pragmas. We deal with LINE pragmas here,
+ -- and throw out any unrecognised pragmas as comments. Any
+ -- pragmas we know about are dealt with later (after any layout
+ -- processing if necessary).
+
+ '{'# | lookAhead# buf 1# `eqChar#` '-'# ->
+ if lookAhead# buf 2# `eqChar#` '#'# then
+ if lookAhead# buf 3# `eqChar#` '#'# then is_a_token else
+ case expandWhile# is_space (setCurrentPos# buf 3#) of { buf1->
+ case expandWhile# is_ident (stepOverLexeme buf1) of { buf2->
+ let lexeme = lexemeToFastString buf2 in
+ case lookupUFM pragmaKeywordsFM lexeme of
+ Just ITline_prag -> line_prag (lexer cont) buf2 s'
+ Just other -> is_a_token
+ Nothing -> skip_to_end (stepOnBy# buf 2#)
+ }}
+
+ else skip_to_end (stepOnBy# buf 2#)
+ where
+ skip_to_end buf = nested_comment (lexer cont) buf s'
+
+ -- tabs have been expanded beforehand
+ c | is_space c -> tab y bol atbol (stepOn buf)
+ | otherwise -> is_a_token
+
+ where s' = s{loc = replaceSrcLine loc y,
+ bol = bol,
+ atbol = atbol}
+
+ is_a_token | atbol /=# 0# = lexBOL cont buf s'
+ | otherwise = lexToken cont glaexts buf s'
+
+-- {-# LINE .. #-} pragmas. yeuch.
+line_prag cont buf =
+ case expandWhile# is_space buf of { buf1 ->
+ case scanNumLit 0 (stepOverLexeme buf1) of { (line,buf2) ->
+ -- subtract one: the line number refers to the *following* line.
+ let real_line = line - 1 in
+ case fromInteger real_line of { i@(I# l) ->
+ case expandWhile# is_space buf2 of { buf3 ->
+ case currentChar# buf3 of
+ '\"'#{-"-} ->
+ case untilEndOfString# (stepOn (stepOverLexeme buf3)) of { buf4 ->
+ let file = lexemeToFastString buf4 in
+ \s@PState{loc=loc} -> skipToEnd buf4 s{loc = mkSrcLoc file i}
+ }
+ other -> \s@PState{loc=loc} -> skipToEnd buf3 s{loc = replaceSrcLine loc l}
+ }}}}
+ where
+ skipToEnd buf = nested_comment cont buf
+
+nested_comment :: P a -> P a
+nested_comment cont buf = loop buf
+ where
+ loop buf =
+ case currentChar# buf of
+ '\NUL'# | bufferExhausted (stepOn buf) ->
+ lexError "unterminated `{-'" buf
+
+ '-'# | lookAhead# buf 1# `eqChar#` '}'# ->
+ cont (stepOnBy# buf 2#)
+
+ '{'# | lookAhead# buf 1# `eqChar#` '-'# ->
+ nested_comment (nested_comment cont) (stepOnBy# buf 2#)
+
+ '\n'# -> \ s@PState{loc=loc} ->
+ let buf' = stepOn buf in
+ nested_comment cont buf'
+ s{loc = incSrcLine loc, bol = currentIndex# buf',
+ atbol = 1#}
+
+ _ -> nested_comment cont (stepOn buf)
+
+-- When we are lexing the first token of a line, check whether we need to
+-- insert virtual semicolons or close braces due to layout.
+
+lexBOL :: (Token -> P a) -> P a
+lexBOL cont buf s@(PState{
+ loc = loc,
+ glasgow_exts = glaexts,
+ bol = bol,
+ atbol = atbol,
+ context = ctx
+ }) =
+ if need_close_curly then
+ --trace ("col = " ++ show (I# col) ++ ", layout: inserting '}'") $
+ cont ITvccurly buf s{atbol = 1#, context = tail ctx}
+ else if need_semi_colon then
+ --trace ("col = " ++ show (I# col) ++ ", layout: inserting ';'") $
+ cont ITsemi buf s{atbol = 0#}
+ else
+ lexToken cont glaexts buf s{atbol = 0#}
+ where
+ col = currentIndex# buf -# bol
+
+ need_close_curly =
+ case ctx of
+ [] -> False
+ (i:_) -> case i of
+ NoLayout -> False
+ Layout n -> col <# n
+ need_semi_colon =
+ case ctx of
+ [] -> False
+ (i:_) -> case i of
+ NoLayout -> False
+ Layout n -> col ==# n
+
+
+lexToken :: (Token -> P a) -> Int# -> P a
+lexToken cont glaexts buf =
+ --trace "lexToken" $
+ _scc_ "Lexer"
+ case currentChar# buf of
+
+ -- special symbols ----------------------------------------------------
+ '('# | flag glaexts && lookAhead# buf 1# `eqChar#` '#'#
+ -> cont IToubxparen (setCurrentPos# buf 2#)
+ | otherwise
+ -> cont IToparen (incLexeme buf)
+
+ ')'# -> cont ITcparen (incLexeme buf)
+ '['# -> cont ITobrack (incLexeme buf)
+ ']'# -> cont ITcbrack (incLexeme buf)
+ ','# -> cont ITcomma (incLexeme buf)
+ ';'# -> cont ITsemi (incLexeme buf)
+
+ '}'# -> \ s@PState{context = ctx} ->
+ case ctx of
+ (_:ctx') -> cont ITccurly (incLexeme buf) s{context=ctx'}
+ _ -> lexError "too many '}'s" buf s
+
+ '#'# | flag glaexts
+ -> case lookAhead# buf 1# of
+ ')'# -> cont ITcubxparen (setCurrentPos# buf 2#)
+ '-'# -> case lookAhead# buf 2# of
+ '}'# -> cont ITclose_prag (setCurrentPos# buf 3#)
+ _ -> lex_sym cont (incLexeme buf)
+ _ -> lex_sym cont (incLexeme buf)
+
+ '`'# | flag glaexts && lookAhead# buf 1# `eqChar#` '`'#
+ -> lex_cstring cont (setCurrentPos# buf 2#)
+ | otherwise
+ -> cont ITbackquote (incLexeme buf)
+
+ '{'# -> -- look for "{-##" special iface pragma
+ case lookAhead# buf 1# of
+ '-'# -> case lookAhead# buf 2# of
+ '#'# -> case lookAhead# buf 3# of
+ '#'# ->
+ let (lexeme, buf')
+ = doDiscard False (stepOnBy# (stepOverLexeme buf) 4#) in
+ cont (ITpragma lexeme) buf'
+ _ -> lex_prag cont (setCurrentPos# buf 3#)
+ _ -> cont ITocurly (incLexeme buf)
+ _ -> (layoutOff `thenP_` cont ITocurly) (incLexeme buf)
+
+ -- strings/characters -------------------------------------------------
+ '\"'#{-"-} -> lex_string cont glaexts "" (incLexeme buf)
+ '\''# -> lex_char (char_end cont) glaexts (incLexeme buf)
+
+ -- strictness and cpr pragmas and __scc treated specially.
+ '_'# | flag glaexts ->
+ case lookAhead# buf 1# of
+ '_'# -> case lookAhead# buf 2# of
+ 'S'# ->
+ lex_demand cont (stepOnUntil (not . isSpace)
+ (stepOnBy# buf 3#)) -- past __S
+ 'M'# ->
+ lex_cpr cont (stepOnUntil (not . isSpace)
+ (stepOnBy# buf 3#)) -- past __M
+ 's'# ->
+ case prefixMatch (stepOnBy# buf 3#) "cc" of
+ Just buf' -> lex_scc cont (stepOverLexeme buf')
+ Nothing -> lex_id cont glaexts buf
+ _ -> lex_id cont glaexts buf
+ _ -> lex_id cont glaexts buf
+
+ -- Hexadecimal and octal constants
+ '0'# | (ch `eqChar#` 'x'# || ch `eqChar#` 'X'#) && is_hexdigit ch2
+ -> readNum (after_lexnum cont glaexts) buf' is_hexdigit 16 hex
+ | (ch `eqChar#` 'o'# || ch `eqChar#` 'O'#) && is_octdigit ch2
+ -> readNum (after_lexnum cont glaexts) buf' is_octdigit 8 oct_or_dec
+ where ch = lookAhead# buf 1#
+ ch2 = lookAhead# buf 2#
+ buf' = setCurrentPos# buf 2#
+
+ '\NUL'# ->
+ if bufferExhausted (stepOn buf) then
+ cont ITeof buf
+ else
+ trace "lexIface: misplaced NUL?" $
+ cont (ITunknown "\NUL") (stepOn buf)
+
+ c | is_digit c -> lex_num cont glaexts 0 buf
+ | is_symbol c -> lex_sym cont buf
+ | is_upper c -> lex_con cont glaexts buf
+ | is_ident c -> lex_id cont glaexts buf
+
+-- Int# is unlifted, and therefore faster than Bool for flags.
+{-# INLINE flag #-}
+flag :: Int# -> Bool
+flag 0# = False
+flag _ = True
+
+-------------------------------------------------------------------------------
+-- Pragmas
+
+lex_prag cont buf
+ = case expandWhile# is_space buf of { buf1 ->
+ case expandWhile# is_ident (stepOverLexeme buf1) of { buf2 ->
+ let lexeme = lexemeToFastString buf2 in
+ case lookupUFM pragmaKeywordsFM lexeme of
+ Just kw -> cont kw (mergeLexemes buf buf2)
+ Nothing -> panic "lex_prag"
+ }}
+
+-------------------------------------------------------------------------------
+-- Strings & Chars
+
+lex_string cont glaexts s buf
+ = case currentChar# buf of
+ '"'#{-"-} ->
+ let buf' = incLexeme buf; s' = mkFastString (reverse s) in
+ case currentChar# buf' of
+ '#'# | flag glaexts -> cont (ITprimstring s') (incLexeme buf')
+ _ -> cont (ITstring s') buf'
+
+ -- ignore \& in a string, deal with string gaps
+ '\\'# | next_ch `eqChar#` '&'#
+ -> lex_string cont glaexts s (setCurrentPos# buf 2#)
+ | is_space next_ch
+ -> lex_stringgap cont glaexts s buf'
+
+ where next_ch = lookAhead# buf 1#
+ buf' = setCurrentPos# buf 2#
+
+ _ -> lex_char (lex_next_string cont s) glaexts buf
+
+lex_stringgap cont glaexts s buf
+ = let buf' = incLexeme buf in
+ case currentChar# buf of
+ '\n'# -> \st@PState{loc = loc} -> lex_stringgap cont glaexts s buf'
+ st{loc = incSrcLine loc}
+ '\\'# -> lex_string cont glaexts s buf'
+ c | is_space c -> lex_stringgap cont glaexts s buf'
+ other -> charError buf'
+
+lex_next_string cont s glaexts c buf = lex_string cont glaexts (c:s) buf
+
+lex_char :: (Int# -> Char -> P a) -> Int# -> P a
+lex_char cont glaexts buf
+ = case currentChar# buf of
+ '\\'# -> lex_escape (cont glaexts) (incLexeme buf)
+ c | is_any c -> cont glaexts (C# c) (incLexeme buf)
+ other -> charError buf
+
+char_end cont glaexts c buf
+ = case currentChar# buf of
+ '\''# -> let buf' = incLexeme buf in
+ case currentChar# buf' of
+ '#'# | flag glaexts
+ -> cont (ITprimchar c) (incLexeme buf')
+ _ -> cont (ITchar c) buf'
+ _ -> charError buf
+
+lex_escape cont buf
+ = let buf' = incLexeme buf in
+ case currentChar# buf of
+ 'a'# -> cont '\a' buf'
+ 'b'# -> cont '\b' buf'
+ 'f'# -> cont '\f' buf'
+ 'n'# -> cont '\n' buf'
+ 'r'# -> cont '\r' buf'
+ 't'# -> cont '\t' buf'
+ 'v'# -> cont '\v' buf'
+ '\\'# -> cont '\\' buf'
+ '"'# -> cont '\"' buf'
+ '\''# -> cont '\'' buf'
+ '^'# -> let c = currentChar# buf' in
+ if c `geChar#` '@'# && c `leChar#` '_'#
+ then cont (C# (chr# (ord# c -# ord# '@'#))) (incLexeme buf')
+ else charError buf'
+
+ 'x'# -> readNum (after_charnum cont) buf' is_hexdigit 16 hex
+ 'o'# -> readNum (after_charnum cont) buf' is_octdigit 8 oct_or_dec
+ x | is_digit x
+ -> readNum (after_charnum cont) buf is_digit 10 oct_or_dec
+
+ _ -> case [ (c,buf2) | (p,c) <- silly_escape_chars,
+ Just buf2 <- [prefixMatch buf p] ] of
+ (c,buf2):_ -> cont c buf2
+ [] -> charError buf'
+
+after_charnum cont i buf
+ = let int = fromInteger i in
+ if i >= 0 && i <= 255
+ then cont (chr int) buf
+ else charError buf
+
+readNum cont buf is_digit base conv = read buf 0
+ where read buf i
+ = case currentChar# buf of { c ->
+ if is_digit c
+ then read (incLexeme buf) (i*base + (toInteger (I# (conv c))))
+ else cont i buf
+ }
+
+is_hexdigit c
+ = is_digit c
+ || (c `geChar#` 'a'# && c `leChar#` 'h'#)
+ || (c `geChar#` 'A'# && c `leChar#` 'H'#)
+
+hex c | is_digit c = ord# c -# ord# '0'#
+ | otherwise = ord# (to_lower c) -# ord# 'a'# +# 10#
+oct_or_dec c = ord# c -# ord# '0'#
+
+is_octdigit c = c `geChar#` '0'# && c `leChar#` '7'#
+
+to_lower c
+ | c `geChar#` 'A'# && c `leChar#` 'Z'#
+ = chr# (ord# c -# (ord# 'A'# -# ord# 'a'#))
+ | otherwise = c
+
+charError buf = lexError "error in character literal" buf
+
+silly_escape_chars = [
+ ("NUL", '\NUL'),
+ ("SOH", '\SOH'),
+ ("STX", '\STX'),
+ ("ETX", '\ETX'),
+ ("EOT", '\EOT'),
+ ("ENQ", '\ENQ'),
+ ("ACK", '\ACK'),
+ ("BEL", '\BEL'),
+ ("BS", '\BS'),
+ ("HT", '\HT'),
+ ("LF", '\LF'),
+ ("VT", '\VT'),
+ ("FF", '\FF'),
+ ("CR", '\CR'),
+ ("SO", '\SO'),
+ ("SI", '\SI'),
+ ("DLE", '\DLE'),
+ ("DC1", '\DC1'),
+ ("DC2", '\DC2'),
+ ("DC3", '\DC3'),
+ ("DC4", '\DC4'),
+ ("NAK", '\NAK'),
+ ("SYN", '\SYN'),
+ ("ETB", '\ETB'),
+ ("CAN", '\CAN'),
+ ("EM", '\EM'),
+ ("SUB", '\SUB'),
+ ("ESC", '\ESC'),
+ ("FS", '\FS'),
+ ("GS", '\GS'),
+ ("RS", '\RS'),
+ ("US", '\US'),
+ ("SP", '\SP'),
+ ("DEL", '\DEL')
+ ]
+
+-------------------------------------------------------------------------------
+
+lex_demand cont buf =
+ case read_em [] buf of { (ls,buf') ->
+ case currentChar# buf' of
+ 'B'# -> cont (ITstrict (ls, True )) (incLexeme buf')
+ _ -> cont (ITstrict (ls, False)) buf'
+ }
+ where
+ -- code snatched from Demand.lhs
+ read_em acc buf =
+ case currentChar# buf of
+ 'L'# -> read_em (WwLazy False : acc) (stepOn buf)
+ 'A'# -> read_em (WwLazy True : acc) (stepOn buf)
+ 'S'# -> read_em (WwStrict : acc) (stepOn buf)
+ 'P'# -> read_em (WwPrim : acc) (stepOn buf)
+ 'E'# -> read_em (WwEnum : acc) (stepOn buf)
+ ')'# -> (reverse acc, stepOn buf)
+ 'U'# -> do_unpack DataType True acc (stepOnBy# buf 2#)
+ 'u'# -> do_unpack DataType False acc (stepOnBy# buf 2#)
+ 'N'# -> do_unpack NewType True acc (stepOnBy# buf 2#)
+ 'n'# -> do_unpack NewType False acc (stepOnBy# buf 2#)
+ _ -> (reverse acc, buf)
+
+ do_unpack new_or_data wrapper_unpacks acc buf
+ = case read_em [] buf of
+ (stuff, rest) -> read_em (WwUnpack new_or_data wrapper_unpacks stuff : acc) rest
+
+lex_cpr cont buf =
+ case read_em [] buf of { (cpr_inf,buf') ->
+ ASSERT ( null (tail cpr_inf) )
+ cont (ITcprinfo $ head cpr_inf) buf'
+ }
+ where
+ -- code snatched from lex_demand above
+ read_em acc buf =
+ case currentChar# buf of
+ '-'# -> read_em (NoCPRInfo : acc) (stepOn buf)
+ '('# -> do_unpack acc (stepOn buf)
+ ')'# -> (reverse acc, stepOn buf)
+ _ -> (reverse acc, buf)
+
+ do_unpack acc buf
+ = case read_em [] buf of
+ (stuff, rest) -> read_em ((CPRInfo stuff) : acc) rest
+
+------------------
+lex_scc cont buf =
+ case currentChar# buf of
+ 'C'# -> cont ITsccAllCafs (incLexeme buf)
+ other -> cont ITscc buf
+
+-----------------------------------------------------------------------------
+-- Numbers
+
+lex_num :: (Token -> P a) -> Int# -> Integer -> P a
+lex_num cont glaexts acc buf =
+ case scanNumLit acc buf of
+ (acc',buf') ->
+ case currentChar# buf' of
+ '.'# | is_digit (lookAhead# buf' 1#) ->
+ -- this case is not optimised at all, as the
+ -- presence of floating point numbers in interface
+ -- files is not that common. (ToDo)
+ case expandWhile# is_digit (incLexeme buf') of
+ buf2 -> -- points to first non digit char
+
+ let l = case currentChar# buf2 of
+ 'E'# -> do_exponent
+ 'e'# -> do_exponent
+ _ -> buf2
+
+ do_exponent
+ = let buf3 = incLexeme buf2 in
+ case currentChar# buf3 of
+ '-'# -> expandWhile# is_digit (incLexeme buf3)
+ '+'# -> expandWhile# is_digit (incLexeme buf3)
+ x | is_digit x -> expandWhile# is_digit buf3
+ _ -> buf2
+
+ v = readRational__ (lexemeToString l)
+
+ in case currentChar# l of -- glasgow exts only
+ '#'# | flag glaexts -> let l' = incLexeme l in
+ case currentChar# l' of
+ '#'# -> cont (ITprimdouble v) (incLexeme l')
+ _ -> cont (ITprimfloat v) l'
+ _ -> cont (ITrational v) l
+
+ _ -> after_lexnum cont glaexts acc' buf'
+
+after_lexnum cont glaexts i buf
+ = case currentChar# buf of
+ '#'# | flag glaexts -> cont (ITprimint i) (incLexeme buf)
+ _ -> cont (ITinteger i) buf
+
+-----------------------------------------------------------------------------
+-- C "literal literal"s (i.e. things like ``NULL'', ``stdout'' etc.)
+
+-- we lexemeToFastString on the bit between the ``''s, but include the
+-- quotes in the full lexeme.
+
+lex_cstring cont buf =
+ case expandUntilMatch (stepOverLexeme buf) "\'\'" of
+ buf' -> cont (ITlitlit (lexemeToFastString
+ (setCurrentPos# buf' (negateInt# 2#))))
+ (mergeLexemes buf buf')
+
+------------------------------------------------------------------------------
+-- Character Classes
+
+is_ident, is_symbol, is_any, is_upper, is_digit :: Char# -> Bool
+
+{-# INLINE is_ctype #-}
+#if __GLASGOW_HASKELL__ >= 303
+is_ctype :: Word8 -> Char# -> Bool
+is_ctype mask = \c ->
+ (indexWord8OffAddr (``char_types'' :: Addr) (ord (C# c)) .&. mask) /= 0
+#else
+is_ctype :: Int -> Char# -> Bool
+is_ctype (I# mask) = \c ->
+ let (A# ctype) = ``char_types'' :: Addr
+ flag_word = int2Word# (ord# (indexCharOffAddr# ctype (ord# c)))
+ in
+ (flag_word `and#` (int2Word# mask)) `neWord#` (int2Word# 0#)
+#endif
+
+is_ident = is_ctype 1
+is_symbol = is_ctype 2
+is_any = is_ctype 4
+is_space = is_ctype 8
+is_upper = is_ctype 16
+is_digit = is_ctype 32
+
+-----------------------------------------------------------------------------
+-- identifiers, symbols etc.
+
+lex_id cont glaexts buf =
+ case expandWhile# is_ident buf of { buf1 ->
+
+ case (if flag glaexts
+ then expandWhile# (eqChar# '#'#) buf1 -- slurp trailing hashes
+ else buf1) of { buf' ->
+
+ let lexeme = lexemeToFastString buf' in
+
+ case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
+ Just kwd_token -> --trace ("hkeywd: "++_UNPK_(lexeme)) $
+ cont kwd_token buf';
+ Nothing ->
+
+ let var_token = cont (mk_var_token lexeme) buf' in
+
+ if not (flag glaexts)
+ then var_token
+ else
+
+ case lookupUFM ghcExtensionKeywordsFM lexeme of {
+ Just kwd_token -> cont kwd_token buf';
+ Nothing -> var_token
+
+ }}}}
+
+lex_sym cont buf =
+ case expandWhile# is_symbol buf of
+ buf' -> case lookupUFM haskellKeySymsFM lexeme of {
+ Just kwd_token -> --trace ("keysym: "++unpackFS lexeme) $
+ cont kwd_token buf' ;
+ Nothing -> --trace ("sym: "++unpackFS lexeme) $
+ cont (mk_var_token lexeme) buf'
+ }
+ where lexeme = lexemeToFastString buf'
+
+
+lex_con cont glaexts buf =
+ case expandWhile# is_ident buf of { buf1 ->
+ case slurp_trailing_hashes buf1 glaexts of { buf' ->
+
+ case currentChar# buf' of
+ '.'# -> munch
+ _ -> just_a_conid
+
+ where
+ just_a_conid = --trace ("con: "++unpackFS lexeme) $
+ cont (ITconid lexeme) buf'
+ lexeme = lexemeToFastString buf'
+ munch = lex_qid cont glaexts lexeme (incLexeme buf') just_a_conid
+ }}
+
+lex_qid cont glaexts mod buf just_a_conid =
+ case currentChar# buf of
+ '['# -> -- Special case for []
+ case lookAhead# buf 1# of
+ ']'# -> cont (ITqconid (mod,SLIT("[]"))) (setCurrentPos# buf 2#)
+ _ -> just_a_conid
+
+ '('# -> -- Special case for (,,,)
+ -- This *is* necessary to deal with e.g. "instance C PrelBase.(,,)"
+ case lookAhead# buf 1# of
+ '#'# | flag glaexts -> case lookAhead# buf 2# of
+ ','# -> lex_ubx_tuple cont mod (setCurrentPos# buf 3#)
+ just_a_conid
+ _ -> just_a_conid
+ ')'# -> cont (ITqconid (mod,SLIT("()"))) (setCurrentPos# buf 2#)
+ ','# -> lex_tuple cont mod (setCurrentPos# buf 2#) just_a_conid
+ _ -> just_a_conid
+
+ '-'# -> case lookAhead# buf 1# of
+ '>'# -> cont (ITqconid (mod,SLIT("->"))) (setCurrentPos# buf 2#)
+ _ -> lex_id3 cont glaexts mod buf just_a_conid
+ _ -> lex_id3 cont glaexts mod buf just_a_conid
+
+lex_id3 cont glaexts mod buf just_a_conid
+ | is_symbol (currentChar# buf) =
+ let
+ start_new_lexeme = stepOverLexeme buf
+ in
+ case expandWhile# is_symbol start_new_lexeme of { buf' ->
+ let
+ lexeme = lexemeToFastString buf'
+ -- real lexeme is M.<sym>
+ new_buf = mergeLexemes buf buf'
+ in
+ case lookupUFM haskellKeySymsFM lexeme of {
+ Just kwd_token -> just_a_conid; -- avoid M.:: etc.
+ Nothing -> cont (mk_qvar_token mod lexeme) new_buf
+ }}
+
+ | otherwise =
+ let
+ start_new_lexeme = stepOverLexeme buf
+ in
+ case expandWhile# is_ident start_new_lexeme of { buf1 ->
+ if emptyLexeme buf1
+ then just_a_conid
+ else
+
+ case slurp_trailing_hashes buf1 glaexts of { buf' ->
+
+ let
+ lexeme = lexemeToFastString buf'
+ new_buf = mergeLexemes buf buf'
+ in
+ case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
+ Just kwd_token -> just_a_conid; -- avoid M.where etc.
+ Nothing ->
+ if flag glaexts
+ then case lookupUFM ghcExtensionKeywordsFM lexeme of {
+ Just kwd_token -> just_a_conid;
+ Nothing -> cont (mk_qvar_token mod lexeme) new_buf }
+ else just_a_conid
+ }}}
+
+
+slurp_trailing_hashes buf glaexts
+ | flag glaexts = expandWhile# (`eqChar#` '#'#) buf
+ | otherwise = buf
+
+
+mk_var_token pk_str
+ | is_upper f = ITconid pk_str
+ -- _[A-Z] is treated as a constructor in interface files.
+ | f `eqChar#` '_'# && not (_NULL_ tl)
+ && (case _HEAD_ tl of { C# g -> is_upper g }) = ITconid pk_str
+ | is_ident f = ITvarid pk_str
+ | f `eqChar#` ':'# = ITconsym pk_str
+ | otherwise = ITvarsym pk_str
+ where
+ (C# f) = _HEAD_ pk_str
+ tl = _TAIL_ pk_str
+
+mk_qvar_token m token =
+ case mk_var_token token of
+ ITconid n -> ITqconid (m,n)
+ ITvarid n -> ITqvarid (m,n)
+ ITconsym n -> ITqconsym (m,n)
+ ITvarsym n -> ITqvarsym (m,n)
+ _ -> ITunknown (show token)
+\end{code}
+
+----------------------------------------------------------------------------
+Horrible stuff for dealing with M.(,,,)
+
+\begin{code}
+lex_tuple cont mod buf back_off =
+ go 2 buf
+ where
+ go n buf =
+ case currentChar# buf of
+ ','# -> go (n+1) (stepOn buf)
+ ')'# -> cont (ITqconid (mod, snd (mkTupNameStr n))) (stepOn buf)
+ _ -> back_off
+
+lex_ubx_tuple cont mod buf back_off =
+ go 2 buf
+ where
+ go n buf =
+ case currentChar# buf of
+ ','# -> go (n+1) (stepOn buf)
+ '#'# -> case lookAhead# buf 1# of
+ ')'# -> cont (ITqconid (mod, snd (mkUbxTupNameStr n)))
+ (stepOnBy# buf 2#)
+ _ -> back_off
+ _ -> back_off
+\end{code}
+
+-----------------------------------------------------------------------------
+doDiscard rips along really fast, looking for a '#-}',
+indicating the end of the pragma we're skipping
+
+\begin{code}
+doDiscard inStr buf =
+ case currentChar# buf of
+ '#'# | not inStr ->
+ case lookAhead# buf 1# of { '#'# ->
+ case lookAhead# buf 2# of { '-'# ->
+ case lookAhead# buf 3# of { '}'# ->
+ (lexemeToBuffer buf, stepOverLexeme (setCurrentPos# buf 4#));
+ _ -> doDiscard inStr (incLexeme buf) };
+ _ -> doDiscard inStr (incLexeme buf) };
+ _ -> doDiscard inStr (incLexeme buf) }
+ '"'# ->
+ let
+ odd_slashes buf flg i# =
+ case lookAhead# buf i# of
+ '\\'# -> odd_slashes buf (not flg) (i# -# 1#)
+ _ -> flg
+ in
+ case lookAhead# buf (negateInt# 1#) of --backwards, actually
+ '\\'# -> -- escaping something..
+ if odd_slashes buf True (negateInt# 2#) then
+ -- odd number of slashes, " is escaped.
+ doDiscard inStr (incLexeme buf)
+ else
+ -- even number of slashes, \ is escaped.
+ doDiscard (not inStr) (incLexeme buf)
+ _ -> case inStr of -- forced to avoid build-up
+ True -> doDiscard False (incLexeme buf)
+ False -> doDiscard True (incLexeme buf)
+ _ -> doDiscard inStr (incLexeme buf)
+
+\end{code}
+
+-----------------------------------------------------------------------------
+
+\begin{code}
+data LayoutContext
+ = NoLayout
+ | Layout Int#
+
+data ParseResult a
+ = POk PState a
+ | PFailed Message
+
+data PState = PState {
+ loc :: SrcLoc,
+ glasgow_exts :: Int#,
+ bol :: Int#,
+ atbol :: Int#,
+ context :: [LayoutContext]
+ }
+
+type P a = StringBuffer -- Input string
+ -> PState
+ -> ParseResult a
+
+returnP :: a -> P a
+returnP a buf s = POk s a
+
+thenP :: P a -> (a -> P b) -> P b
+m `thenP` k = \ buf s ->
+ case m buf s of
+ POk s1 a -> k a buf s1
+ PFailed err -> PFailed err
+
+thenP_ :: P a -> P b -> P b
+m `thenP_` k = m `thenP` \_ -> k
+
+mapP :: (a -> P b) -> [a] -> P [b]
+mapP f [] = returnP []
+mapP f (a:as) =
+ f a `thenP` \b ->
+ mapP f as `thenP` \bs ->
+ returnP (b:bs)
+
+failP :: String -> P a
+failP msg buf s = PFailed (text msg)
+
+failMsgP :: Message -> P a
+failMsgP msg buf s = PFailed msg
+
+lexError :: String -> P a
+lexError str buf s@PState{ loc = loc }
+ = failMsgP (hcat [ppr loc, text ": ", text str]) buf s
+
+getSrcLocP :: P SrcLoc
+getSrcLocP buf s@(PState{ loc = loc }) = POk s loc
+
+getSrcFile :: P FAST_STRING
+getSrcFile buf s@(PState{ loc = loc }) = POk s (srcLocFile loc)
+
+getContext :: P [LayoutContext]
+getContext buf s@(PState{ context = ctx }) = POk s ctx
+
+pushContext :: LayoutContext -> P ()
+pushContext ctxt buf s@(PState{ context = ctx }) = POk s{context = ctxt:ctx} ()
+
+{-
+
+This special case in layoutOn is to handle layout contexts with are
+indented the same or less than the current context. This is illegal
+according to the Haskell spec, so we have to arrange to close the
+current context. eg.
+
+class Foo a where
+class Bar a
+
+after the first 'where', the sequence of events is:
+
+ - layout system inserts a ';' (column 0)
+ - parser begins a new context at column 0
+ - parser shifts ';' (legal empty declaration)
+ - parser sees 'class': parse error (we're still in the inner context)
+
+trouble is, by the time we know we need a new context, the lexer has
+already generated the ';'. Hacky solution is as follows: since we
+know the column of the next token (it's the column number of the new
+context), we set the ACTUAL column number of the new context to this
+numer plus one. Hence the next time the lexer is called, a '}' will
+be generated to close the new context straight away. Furthermore, we
+have to set the atbol flag so that the ';' that the parser shifted as
+part of the new context is re-generated.
+
+when the new context is *less* indented than the current one:
+
+f = f where g = g where
+h = h
+
+ - current context: column 12.
+ - on seeing 'h' (column 0), the layout system inserts '}'
+ - parser starts a new context, column 0
+ - parser sees '}', uses it to close new context
+ - we still need to insert another '}' followed by a ';',
+ hence the atbol trick.
+
+-}
+
+layoutOn :: P ()
+layoutOn buf s@(PState{ bol = bol, context = ctx }) =
+ let offset = lexemeIndex buf -# bol in
+ case ctx of
+ Layout prev_off : _ | prev_off >=# offset ->
+ --trace ("layout on, column: " ++ show (I# offset)) $
+ POk s{ context = Layout (offset +# 1#) : ctx, atbol = 1# } ()
+ other ->
+ --trace ("layout on, column: " ++ show (I# offset)) $
+ POk s{ context = Layout offset : ctx } ()
+
+layoutOff :: P ()
+layoutOff buf s@(PState{ context = ctx }) =
+ POk s{ context = NoLayout:ctx } ()
+
+popContext :: P ()
+popContext = \ buf s@(PState{ context = ctx }) ->
+ case ctx of
+ (_:tl) -> POk s{ context = tl } ()
+ [] -> panic "Lex.popContext: empty context"
+
+{-
+ Note that if the name of the file we're processing ends
+ with `hi-boot', we accept it on faith as having the right
+ version. This is done so that .hi-boot files that comes
+ with hsc don't have to be updated before every release,
+ *and* it allows us to share .hi-boot files with versions
+ of hsc that don't have .hi version checking (e.g., ghc-2.10's)
+
+ If the version number is 0, the checking is also turned off.
+ (needed to deal with GHC.hi only!)
+
+ Once we can assume we're compiling with a version of ghc that
+ supports interface file checking, we can drop the special
+ pleading
+-}
+checkVersion :: Maybe Integer -> P ()
+checkVersion mb@(Just v) buf s@(PState{loc = loc})
+ | (v==0) || (v == fromInt opt_HiVersion) || opt_NoHiCheck = POk s ()
+ | otherwise = PFailed (ifaceVersionErr mb loc ([]::[Token]){-Todo-})
+checkVersion mb@Nothing buf s@(PState{loc = loc})
+ | "hi-boot" `isSuffixOf` (_UNPK_ (srcLocFile loc)) = POk s ()
+ | otherwise = PFailed (ifaceVersionErr mb loc ([]::[Token]){-Todo-})
+
+-----------------------------------------------------------------
+
+ifaceParseErr :: StringBuffer -> SrcLoc -> Message
+ifaceParseErr s l
+ = hsep [ppr l, ptext SLIT("Interface file parse error; on input `"),
+ text (lexemeToString s), char '\'']
+
+ifaceVersionErr hi_vers l toks
+ = hsep [ppr l, ptext SLIT("Interface file version error;"),
+ ptext SLIT("Expected"), int opt_HiVersion,
+ ptext SLIT("found "), pp_version]
+ where
+ pp_version =
+ case hi_vers of
+ Nothing -> ptext SLIT("pre ghc-3.02 version")
+ Just v -> ptext SLIT("version") <+> integer v
+
+\end{code}
+++ /dev/null
-Return-Path: mattson@dcs.gla.ac.uk
-Return-Path: <mattson@dcs.gla.ac.uk>
-Received: from starbuck.dcs.gla.ac.uk by goggins.dcs.gla.ac.uk
- with LOCAL SMTP (PP) id <02535-0@goggins.dcs.gla.ac.uk>;
- Thu, 18 Nov 1993 09:59:57 +0000
-To: Robert.Corbett@Eng.Sun.COM
-cc: partain@dcs.gla.ac.uk
-Subject: Re: [Robert.Corbett@Eng.Sun.COM: Re: possible bug, byacc 1.9]
-In-reply-to: Your message from 9:46 AM GMT
-Date: Thu, 18 Nov 93 09:59:53 +0000
-From: Jim Mattson <mattson@dcs.gla.ac.uk>
-
-It's clear that this feature improves error detection, but it's not
-clear to me how it improves the scope of possible error recoveries.
-
-If I understand your explanation, it sounds like the only alternative
-(short of changing the byacc source) is to add tens or hundreds of
-error productions sprinkled throughout the code anywhere that an
-unexpected symbol may appear, since no intervening reductions are
-allowed.
-
-Although the addition of all of these error productions increases the
-scope of possible error recoveries, the same functionality (with, in fact,
-the same approach) is provided by other versions of yacc. The apparent
-advantage of other versions of yacc is that they provide a facility by
-which a single _default_ error production can handle a number of
-possibilities (after some possibly illegal reductions have been performed).
-
-Am I missing something?
-
---jim
---------
-In reply to the following message:
---------
-
-------- Forwarded Message
-
-Date: Wed, 17 Nov 93 22:33:44 PST
-From: Robert.Corbett@Eng.Sun.COM (Robert Corbett)
-Message-Id: <9311180633.AA07545@lupa.Eng.Sun.COM>
-To: partain@dcs.gla.ac.uk
-Subject: Re: possible bug, byacc 1.9
-
-It is a feature. One difference between Berkeley Yacc and its
-predecessors is that the parsers Berkeley Yacc produces detect
-errors as soon as possible. That will lead to different behavior.
-
-In this particular case, the token "IN" is not a permitted
-lookahead symbol in state 390. AT&T Yacc parsers will not detect
-the error until after doing more reductions than Berkeley Yacc
-parsers. Doing reductions in illegal contexts limits the scope of
-recoveries that are possible (unless backtracking is possible).
-
-I am sorry that my attempt to provide better error detection is
-causing you trouble. You can get the AT&T Yacc behavior by
-replacing the routine sole_reduction in mkpar.c with a routine
-that returns the most frequently occurring reduction.
-
- Yours truly,
- Bob Corbett
-
-- ----- Begin Included Message -----
-
->From partain@dcs.gla.ac.uk Wed Nov 17 05:03:44 1993
-To: robert.corbett@Eng
-Subject: possible bug, byacc 1.9
-Date: Wed, 17 Nov 93 12:33:42 +0000
-From: Will Partain <partain@dcs.gla.ac.uk>
-
-Sadly, it's in a *HUGE* grammar, which I will send you if you have the
-stomach for it.
-
-The problem occurs where {Sun's /usr/lang/yacc, bison} say:
-
- state 390
-
- aexp -> var . (rule 356)
- aexp -> var . AT aexp (rule 366)
-
- AT shift, and go to state 508
- $default reduce using rule 356 (aexp)
-
-but byacc says
-
- state 396
- aexp : var . (356)
- aexp : var . AT aexp (366)
-
- AT shift 511
- error reduce 356
- VARID reduce 356
- CONID reduce 356
- VARSYM reduce 356
- CONSYM reduce 356
- MINUS reduce 356
- INTEGER reduce 356
- FLOAT reduce 356
- CHAR reduce 356
- STRING reduce 356
- CHARPRIM reduce 356
- INTPRIM reduce 356
- FLOATPRIM reduce 356
- DOUBLEPRIM reduce 356
- CLITLIT reduce 356
- VOIDPRIM reduce 356
- CCURLY reduce 356
- VCCURLY reduce 356
- SEMI reduce 356
- OBRACK reduce 356
- CBRACK reduce 356
- OPAREN reduce 356
- CPAREN reduce 356
- COMMA reduce 356
- BQUOTE reduce 356
- RARROW reduce 356
- VBAR reduce 356
- EQUAL reduce 356
- DOTDOT reduce 356
- DCOLON reduce 356
- LARROW reduce 356
- WILDCARD reduce 356
- LAZY reduce 356
- WHERE reduce 356
- OF reduce 356
- THEN reduce 356
- ELSE reduce 356
- PLUS reduce 356
-
-The token that comes in is "IN"; bison/sun-yacc-generated parser
-tickles the default, reduces to "aexp", but byacc-generated tickles
-"error" and the rest is history.
-
-Maybe this is enough for you to exclaim, "Oh yes, that's a feature."
-
-As I say, more info if you want it.
-
-Will Partain
-
-
-- ----- End Included Message -----
-
-
-
-------- End of Forwarded Message
-
---------
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1999
+%
+\section[ParseUtil]{Parser Utilities}
+
+\begin{code}
+module ParseUtil (
+ parseError -- String -> Pa
+ , srcParseErr -- StringBuffer -> SrcLoc -> Message
+ , cbot -- a
+ , splitForConApp -- RdrNameHsType -> [RdrNameBangType]
+ -- -> P (RdrName, [RdrNameBangType])
+
+ , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp
+ , groupBindings
+
+ , checkPrec -- String -> P String
+ , checkCallConv -- FAST_STRING -> P CallConv
+ , checkContext -- HsType -> P HsContext
+ , checkInstType -- HsType -> P HsType
+ , checkAssertion -- HsType -> P HsAsst
+ , checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName])
+ , checkSimple -- HsType -> [HsName] -> P ((HsName,[HsName]))
+ , checkPattern -- HsExp -> P HsPat
+ , checkPatterns -- [HsExp] -> P [HsPat]
+ -- , checkExpr -- HsExp -> P HsExp
+ , checkValDef -- (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
+
+ , as_tyvar_RDR, hiding_tyvar_RDR, qualified_tyvar_RDR
+ , export_tyvar_RDR, label_tyvar_RDR, dynamic_tyvar_RDR
+ , unsafe_tyvar_RDR
+
+ , minus_RDR, pling_RDR, dot_RDR
+
+ ) where
+
+#include "HsVersions.h"
+
+import Lex
+import HsSyn
+import SrcLoc
+import RdrHsSyn
+import RdrName
+import CallConv
+import PrelMods ( pRELUDE_Name, mkUbxTupNameStr, mkTupNameStr )
+import OccName ( dataName, tcName, varName, tvName, setOccNameSpace )
+import CmdLineOpts ( opt_NoImplicitPrelude )
+import StringBuffer ( lexemeToString )
+import FastString ( unpackFS )
+import ErrUtils
+import UniqFM ( UniqFM, listToUFM, lookupUFM )
+import Outputable
+
+-----------------------------------------------------------------------------
+-- Misc utils
+
+parseError :: String -> P a
+parseError s =
+ getSrcLocP `thenP` \ loc ->
+ failMsgP (hcat [ppr loc, text ": ", text s])
+
+srcParseErr :: StringBuffer -> SrcLoc -> Message
+srcParseErr s l
+ = hcat [ppr l, ptext SLIT(": parse error on input "),
+ char '`', text (lexemeToString s), char '\'']
+
+cbot = panic "CCall:result_ty"
+
+-----------------------------------------------------------------------------
+-- splitForConApp
+
+-- 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])
+
+splitForConApp t ts = split t ts
+ where
+ split (MonoTyApp t u) ts = split t (Unbanged u : ts)
+
+ split (MonoTyVar t) ts = returnP (con, ts)
+ where t_occ = rdrNameOcc t
+ con = setRdrNameOcc t (setOccNameSpace t_occ dataName)
+
+ 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
+ HsForAllTy tvs ctxt ty ->
+ checkAssertion ty [] `thenP` \(c,ts)->
+ returnP (HsForAllTy tvs ctxt (MonoDictTy c ts))
+
+ ty -> checkAssertion ty [] `thenP` \(c,ts)->
+ returnP (HsForAllTy Nothing [] (MonoDictTy c ts))
+
+checkContext :: RdrNameHsType -> P RdrNameContext
+checkContext (MonoTupleTy ts True)
+ = mapP (\t -> checkAssertion t []) ts `thenP` \cs ->
+ returnP cs
+checkContext (MonoTyVar t) -- empty contexts are allowed
+ | t == unitTyCon_RDR = returnP []
+checkContext t
+ = checkAssertion t [] `thenP` \c ->
+ returnP [c]
+
+checkAssertion :: RdrNameHsType -> [RdrNameHsType]
+ -> P (ClassAssertion RdrName)
+checkAssertion (MonoTyVar t) args@(_:_) | not (isRdrTyVar t)
+ = returnP (t,args)
+checkAssertion (MonoTyApp l r) args = checkAssertion l (r:args)
+checkAssertion _ _ = parseError "Illegal class assertion"
+
+checkDataHeader :: RdrNameHsType
+ -> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
+checkDataHeader (HsForAllTy Nothing cs t) =
+ checkSimple t [] `thenP` \(c,ts) ->
+ returnP (cs,c,map UserTyVar ts)
+checkDataHeader t =
+ checkSimple t [] `thenP` \(c,ts) ->
+ returnP ([],c,map UserTyVar ts)
+
+checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
+checkSimple (MonoTyApp l (MonoTyVar a)) xs | isRdrTyVar a
+ = checkSimple l (a:xs)
+checkSimple (MonoTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs)
+checkSimple t _ = trace (showSDoc (ppr t)) $ parseError "Illegal 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.
+
+checkPattern :: RdrNameHsExpr -> P RdrNamePat
+checkPattern e = checkPat e []
+
+checkPatterns :: [RdrNameHsExpr] -> P [RdrNamePat]
+checkPatterns es = mapP checkPattern es
+
+checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
+checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args)
+checkPat (HsApp f x) args =
+ checkPat x [] `thenP` \x ->
+ checkPat f (x:args)
+checkPat e [] = case e of
+ EWildPat -> returnP WildPatIn
+ HsVar x -> returnP (VarPatIn x)
+ HsLit l -> returnP (LitPatIn l)
+ ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPatIn)
+ EAsPat n e -> checkPat e [] `thenP` (returnP . AsPatIn n)
+ ExprWithTySig e t -> checkPat e [] `thenP` \e ->
+ returnP (SigPatIn e t)
+
+ OpApp (HsVar n) (HsVar plus) _ (HsLit k@(HsInt _)) | plus == plus_RDR
+ -> returnP (NPlusKPatIn n k)
+
+ OpApp l op fix r -> checkPat l [] `thenP` \l ->
+ checkPat r [] `thenP` \r ->
+ case op of
+ 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)
+ _ -> patFail
+
+checkPat _ _ = patFail
+
+checkPatField :: (RdrName, RdrNameHsExpr, Bool)
+ -> P (RdrName, RdrNamePat, Bool)
+checkPatField (n,e,b) =
+ checkPat e [] `thenP` \p ->
+ returnP (n,p,b)
+
+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
+ 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
+
+checkValDef
+ :: RdrNameHsExpr
+ -> Maybe RdrNameHsType
+ -> RdrNameGRHSs
+ -> SrcLoc
+ -> P RdrNameMonoBinds
+
+checkValDef lhs opt_sig grhss loc
+ = case isFunLhs lhs [] of
+ Just (f,inf,es) ->
+ checkPatterns es `thenP` \ps ->
+ returnP (FunMonoBind f inf [Match [] ps opt_sig grhss] loc)
+
+ Nothing ->
+ checkPattern lhs `thenP` \lhs ->
+ returnP (PatMonoBind lhs grhss loc)
+
+-- A variable binding is parsed as an RdrNamePatBind.
+
+isFunLhs (OpApp l (HsVar op) fix r) [] | not (isRdrDataCon op)
+ = Just (op, True, [l,r])
+isFunLhs (HsVar f) es@(_:_) | not (isRdrDataCon f)
+ = Just (f,False,es)
+isFunLhs (HsApp f e) es = isFunLhs f (e:es)
+isFunLhs (HsPar e) es = isFunLhs e es
+isFunLhs _ _ = Nothing
+
+---------------------------------------------------------------------------
+-- Miscellaneous utilities
+
+checkPrec :: Integer -> P ()
+checkPrec i | 0 <= i && i <= 9 = returnP ()
+ | otherwise = parseError "precedence out of range"
+
+mkRecConstrOrUpdate
+ :: RdrNameHsExpr
+ -> RdrNameHsRecordBinds
+ -> P RdrNameHsExpr
+
+mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
+ = returnP (RecordCon c fs)
+mkRecConstrOrUpdate exp fs@(_:_)
+ = returnP (RecordUpd exp fs)
+mkRecConstrOrUpdate _ _
+ = parseError "Empty record update"
+
+-----------------------------------------------------------------------------
+-- group function bindings into equation groups
+
+-- we assume the bindings are coming in reverse order, so we take the srcloc
+-- from the *last* binding in the group as the srcloc for the whole group.
+
+groupBindings :: [RdrBinding] -> RdrBinding
+groupBindings binds = group Nothing binds
+ where group :: Maybe RdrNameMonoBinds -> [RdrBinding] -> RdrBinding
+ group (Just bind) [] = RdrValBinding bind
+ group Nothing [] = RdrNullBind
+ group (Just (FunMonoBind f inf1 mtchs ignore_srcloc))
+ (RdrValBinding (FunMonoBind f' _ [mtch] loc) : binds)
+ | f == f' = group (Just (FunMonoBind f inf1 (mtch:mtchs) loc)) binds
+
+ group (Just so_far) binds
+ = RdrValBinding so_far `RdrAndBindings` group Nothing binds
+ group Nothing (bind:binds)
+ = 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 arity))
+ | otherwise = mkPreludeQual dataName pRELUDE_Name
+ (snd (mkTupNameStr arity))
+
+tupleTyCon_RDR arity
+ | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr arity))
+ | otherwise = mkPreludeQual tcName pRELUDE_Name
+ (snd (mkTupNameStr arity))
+
+
+ubxTupleCon_RDR arity
+ | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkUbxTupNameStr arity))
+ | otherwise = mkPreludeQual dataName pRELUDE_Name
+ (snd (mkUbxTupNameStr arity))
+
+ubxTupleTyCon_RDR arity
+ | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkUbxTupNameStr arity))
+ | otherwise = mkPreludeQual tcName pRELUDE_Name
+ (snd (mkUbxTupNameStr 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")
+
+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
+
+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
+
+minus_RDR = mkSrcUnqual varName SLIT("-")
+pling_RDR = mkSrcUnqual varName SLIT("!")
+dot_RDR = mkSrcUnqual varName SLIT(".")
+
+plus_RDR = mkSrcUnqual varName SLIT("+")
+\end{code}
--- /dev/null
+{-
+-----------------------------------------------------------------------------
+$Id: Parser.y,v 1.1 1999/06/01 16:40:48 simonmar Exp $
+
+Haskell grammar.
+
+Author(s): Simon Marlow, Sven Panne 1997, 1998, 1999
+-----------------------------------------------------------------------------
+-}
+
+{
+module Parser ( parse ) where
+
+import HsSyn
+import HsPragmas
+
+import RdrHsSyn
+import Lex
+import ParseUtil
+import RdrName
+import PrelMods ( mAIN_Name )
+import OccName ( varName, dataName, tcClsName, tvName )
+import SrcLoc ( SrcLoc )
+import Module
+import CallConv
+import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..) )
+import Panic
+
+import GlaExts
+
+#include "HsVersions.h"
+}
+
+{-
+-----------------------------------------------------------------------------
+Conflicts: 13 shift/reduce
+
+8 for abiguity in 'if x then y else z + 1'
+ (shift parses as 'if x then y else (z + 1)', as per longest-parse rule)
+1 for ambiguity in 'if x then y else z :: T'
+ (shift parses as 'if x then y else (z :: T)', as per longest-parse rule)
+3 for ambiguity in 'case x of y :: a -> b'
+ (don't know whether to reduce 'a' as a btype or shift the '->'.
+ conclusion: bogus expression anyway, doesn't matter)
+
+1 for ambiguity in '{-# RULES "name" forall = ... #-}'
+ since 'forall' is a valid variable name, we don't know whether
+ to treat a forall on the input as the beginning of a quantifier
+ or the beginning of the rule itself. Resolving to shift means
+ it's always treated as a quantifier, hence the above is disallowed.
+ This saves explicitly defining a grammar for the rule lhs that
+ doesn't include 'forall'.
+
+-----------------------------------------------------------------------------
+-}
+
+%token
+ '_' { ITunderscore } -- Haskell keywords
+ 'as' { ITas }
+ 'case' { ITcase }
+ 'class' { ITclass }
+ 'data' { ITdata }
+ 'default' { ITdefault }
+ 'deriving' { ITderiving }
+ 'do' { ITdo }
+ 'else' { ITelse }
+ 'hiding' { IThiding }
+ 'if' { ITif }
+ 'import' { ITimport }
+ 'in' { ITin }
+ 'infix' { ITinfix }
+ 'infixl' { ITinfixl }
+ 'infixr' { ITinfixr }
+ 'instance' { ITinstance }
+ 'let' { ITlet }
+ 'module' { ITmodule }
+ 'newtype' { ITnewtype }
+ 'of' { ITof }
+ 'qualified' { ITqualified }
+ 'then' { ITthen }
+ 'type' { ITtype }
+ 'where' { ITwhere }
+
+ 'forall' { ITforall } -- GHC extension keywords
+ 'foreign' { ITforeign }
+ 'export' { ITexport }
+ 'label' { ITlabel }
+ 'dynamic' { ITdynamic }
+ 'unsafe' { ITunsafe }
+ '_ccall_' { ITccall (False, False, False) }
+ '_ccall_GC_' { ITccall (False, False, True) }
+ '_casm_' { ITccall (False, True, False) }
+ '_casm_GC_' { ITccall (False, True, True) }
+
+ '{-# SPECIALISE' { ITspecialise_prag }
+ '{-# SOURCE' { ITsource_prag }
+ '{-# INLINE' { ITinline_prag }
+ '{-# NOINLINE' { ITnoinline_prag }
+ '{-# RULES' { ITrules_prag }
+ '#-}' { ITclose_prag }
+
+{-
+ '__interface' { ITinterface } -- interface keywords
+ '__export' { IT__export }
+ '__instimport' { ITinstimport }
+ '__forall' { IT__forall }
+ '__letrec' { ITletrec }
+ '__coerce' { ITcoerce }
+ '__depends' { ITdepends }
+ '__inline' { ITinline }
+ '__DEFAULT' { ITdefaultbranch }
+ '__bot' { ITbottom }
+ '__integer' { ITinteger_lit }
+ '__float' { ITfloat_lit }
+ '__rational' { ITrational_lit }
+ '__addr' { ITaddr_lit }
+ '__litlit' { ITlit_lit }
+ '__string' { ITstring_lit }
+ '__ccall' { ITccall $$ }
+ '__scc' { ITscc }
+ '__sccC' { ITsccAllCafs }
+
+ '__A' { ITarity }
+ '__P' { ITspecialise }
+ '__C' { ITnocaf }
+ '__U' { ITunfold $$ }
+ '__S' { ITstrict $$ }
+ '__M' { ITcprinfo $$ }
+-}
+
+ '..' { ITdotdot } -- reserved symbols
+ '::' { ITdcolon }
+ '=' { ITequal }
+ '\\' { ITlam }
+ '|' { ITvbar }
+ '<-' { ITlarrow }
+ '->' { ITrarrow }
+ '@' { ITat }
+ '~' { ITtilde }
+ '=>' { ITdarrow }
+ '-' { ITminus }
+ '!' { ITbang }
+ '.' { ITdot }
+
+ '/\\' { ITbiglam } -- GHC-extension symbols
+
+ '{' { ITocurly } -- special symbols
+ '}' { ITccurly }
+ vccurly { ITvccurly } -- virtual close curly (from layout)
+ '[' { ITobrack }
+ ']' { ITcbrack }
+ '(' { IToparen }
+ ')' { ITcparen }
+ '(#' { IToubxparen }
+ '#)' { ITcubxparen }
+ ';' { ITsemi }
+ ',' { ITcomma }
+ '`' { ITbackquote }
+
+ VARID { ITvarid $$ } -- identifiers
+ CONID { ITconid $$ }
+ VARSYM { ITvarsym $$ }
+ CONSYM { ITconsym $$ }
+ QVARID { ITqvarid $$ }
+ QCONID { ITqconid $$ }
+ QVARSYM { ITqvarsym $$ }
+ QCONSYM { ITqconsym $$ }
+
+ PRAGMA { ITpragma $$ }
+
+ CHAR { ITchar $$ }
+ STRING { ITstring $$ }
+ INTEGER { ITinteger $$ }
+ RATIONAL { ITrational $$ }
+
+ PRIMCHAR { ITprimchar $$ }
+ PRIMSTRING { ITprimstring $$ }
+ PRIMINTEGER { ITprimint $$ }
+ PRIMFLOAT { ITprimfloat $$ }
+ PRIMDOUBLE { ITprimdouble $$ }
+ CLITLIT { ITlitlit $$ }
+
+ UNKNOWN { ITunknown $$ }
+
+%monad { P } { thenP } { returnP }
+%lexer { lexer } { ITeof }
+%name parse
+%tokentype { Token }
+%%
+
+-----------------------------------------------------------------------------
+-- Module Header
+
+module :: { RdrNameHsModule }
+ : srcloc 'module' modid maybeexports 'where' body
+ { HsModule $3 Nothing $4 (fst $6) (snd $6) $1 }
+ | srcloc body
+ { HsModule mAIN_Name Nothing Nothing (fst $2) (snd $2) $1 }
+
+body :: { ([RdrNameImportDecl], [RdrNameHsDecl]) }
+ : '{' top '}' { $2 }
+ | layout_on top close { $2 }
+
+top :: { ([RdrNameImportDecl], [RdrNameHsDecl]) }
+ : importdecls ';' cvtopdecls { (reverse $1,$3) }
+ | importdecls { (reverse $1,[]) }
+ | cvtopdecls { ([],$1) }
+
+cvtopdecls :: { [RdrNameHsDecl] }
+ : topdecls { cvTopDecls (groupBindings $1)}
+
+-----------------------------------------------------------------------------
+-- The Export List
+
+maybeexports :: { Maybe [RdrNameIE] }
+ : '(' exportlist ')' { Just $2 }
+ | {- empty -} { Nothing }
+
+exportlist :: { [RdrNameIE] }
+ : exportlist ',' export { $3 : $1 }
+ | exportlist ',' { $1 }
+ | export { [$1] }
+ | {- empty -} { [] }
+
+ -- GHC extension: we allow things like [] and (,,,) to be exported
+export :: { RdrNameIE }
+ : qvar { IEVar $1 }
+ | gtycon { IEThingAbs $1 }
+ | gtycon '(' '..' ')' { IEThingAll $1 }
+ | gtycon '(' ')' { IEThingWith $1 [] }
+ | gtycon '(' qcnames ')' { IEThingWith $1 (reverse $3) }
+ | 'module' modid { IEModuleContents $2 }
+
+qcnames :: { [RdrName] }
+ : qcnames ',' qcname { $3 : $1 }
+ | qcname { [$1] }
+
+qcname :: { RdrName }
+ : qvar { $1 }
+ | gcon { $1 }
+
+-----------------------------------------------------------------------------
+-- Import Declarations
+
+-- import decls can be *empty*, or even just a string of semicolons
+-- whereas topdecls must contain at least one topdecl.
+
+importdecls :: { [RdrNameImportDecl] }
+ : importdecls ';' importdecl { $3 : $1 }
+ | importdecls ';' { $1 }
+ | importdecl { [ $1 ] }
+ | {- empty -} { [] }
+
+importdecl :: { RdrNameImportDecl }
+ : 'import' srcloc maybe_src optqualified CONID maybeas maybeimpspec
+ { ImportDecl (mkSrcModuleFS $5) $3 $4 $6 $7 $2 }
+
+maybe_src :: { WhereFrom }
+ : '{-# SOURCE' '#-}' { ImportByUserSource }
+ | {- empty -} { ImportByUser }
+
+optqualified :: { Bool }
+ : 'qualified' { True }
+ | {- empty -} { False }
+
+maybeas :: { Maybe ModuleName }
+ : 'as' modid { Just $2 }
+ | {- empty -} { Nothing }
+
+maybeimpspec :: { Maybe (Bool, [RdrNameIE]) }
+ : impspec { Just $1 }
+ | {- empty -} { Nothing }
+
+impspec :: { (Bool, [RdrNameIE]) }
+ : '(' exportlist ')' { (False, reverse $2) }
+ | 'hiding' '(' exportlist ')' { (True, reverse $3) }
+
+-----------------------------------------------------------------------------
+-- Fixity Declarations
+
+prec :: { Int }
+ : {- empty -} { 9 }
+ | INTEGER {% checkPrec $1 `thenP_`
+ returnP (fromInteger $1) }
+
+infix :: { FixityDirection }
+ : 'infix' { InfixN }
+ | 'infixl' { InfixL }
+ | 'infixr' { InfixR }
+
+ops :: { [RdrName] }
+ : ops ',' op { $3 : $1 }
+ | op { [$1] }
+
+-----------------------------------------------------------------------------
+-- Top-Level Declarations
+
+topdecls :: { [RdrBinding] }
+ : topdecls ';' topdecl { ($3 : $1) }
+ | topdecls ';' { $1 }
+ | topdecl { [$1] }
+
+topdecl :: { RdrBinding }
+ : srcloc 'type' simpletype '=' type
+ { RdrHsDecl (TyClD (TySynonym (fst $3) (snd $3) $5 $1)) }
+
+ | srcloc 'data' ctype '=' constrs deriving
+ {% checkDataHeader $3 `thenP` \(cs,c,ts) ->
+ returnP (RdrHsDecl (TyClD
+ (TyData DataType cs c ts (reverse $5) $6
+ NoDataPragmas $1))) }
+
+ | srcloc 'newtype' ctype '=' newconstr deriving
+ {% checkDataHeader $3 `thenP` \(cs,c,ts) ->
+ returnP (RdrHsDecl (TyClD
+ (TyData NewType cs c ts [$5] $6
+ NoDataPragmas $1))) }
+
+ | srcloc 'class' ctype where
+ {% checkDataHeader $3 `thenP` \(cs,c,ts) ->
+ let (binds,sigs)
+ = cvMonoBindsAndSigs cvClassOpSig
+ (groupBindings $4)
+ in
+ returnP (RdrHsDecl (TyClD
+ (mkClassDecl cs c ts sigs binds
+ NoClassPragmas $1))) }
+
+ | srcloc 'instance' inst_type where
+ { let (binds,sigs)
+ = cvMonoBindsAndSigs cvInstDeclSig
+ (groupBindings $4)
+ in RdrHsDecl (InstD
+ (InstDecl $3 binds sigs dummyRdrVarName $1)) }
+
+ | srcloc 'default' '(' types0 ')'
+ { RdrHsDecl (DefD (DefaultDecl $4 $1)) }
+
+ | srcloc 'foreign' 'import' callconv ext_name
+ unsafe_flag varid_no_unsafe '::' sigtype
+ { RdrHsDecl (ForD (ForeignDecl $7 (FoImport $6) $9 $5 $4 $1)) }
+
+ | srcloc 'foreign' 'export' callconv ext_name varid '::' sigtype
+ { RdrHsDecl (ForD (ForeignDecl $6 FoExport $8 $5 $4 $1)) }
+
+ | srcloc 'foreign' 'label' ext_name varid '::' sigtype
+ { RdrHsDecl (ForD (ForeignDecl $5 FoLabel $7 $4
+ defaultCallConv $1)) }
+
+ | decl { $1 }
+
+decls :: { [RdrBinding] }
+ : decls ';' decl { $3 : $1 }
+ | decls ';' { $1 }
+ | decl { [$1] }
+ | {- empty -} { [] }
+
+decl :: { RdrBinding }
+ : signdecl { $1 }
+ | fixdecl { $1 }
+ | valdef { RdrValBinding $1 }
+ | '{-# INLINE' srcloc qvar '#-}' { RdrSig (InlineSig $3 $2) }
+ | '{-# NOINLINE' srcloc qvar '#-}' { RdrSig (NoInlineSig $3 $2) }
+ | '{-# SPECIALISE' srcloc qvar '::' sigtypes '#-}'
+ { foldr1 RdrAndBindings
+ (map (\t -> RdrSig (SpecSig $3 t $2)) $5) }
+ | '{-# SPECIALISE' srcloc 'instance' inst_type '#-}'
+ { RdrSig (SpecInstSig $4 $2) }
+ | '{-# RULES' rules '#-}' { $2 }
+
+sigtypes :: { [RdrNameHsType] }
+ : sigtype { [ $1 ] }
+ | sigtypes ',' sigtype { $3 : $1 }
+
+wherebinds :: { RdrNameHsBinds }
+ : where { cvBinds cvValSig (groupBindings $1) }
+
+where :: { [RdrBinding] }
+ : 'where' decllist { $2 }
+ | {- empty -} { [] }
+
+declbinds :: { RdrNameHsBinds }
+ : decllist { cvBinds cvValSig (groupBindings $1) }
+
+decllist :: { [RdrBinding] }
+ : '{' decls '}' { $2 }
+ | layout_on decls close { $2 }
+
+fixdecl :: { RdrBinding }
+ : srcloc infix prec ops { foldr1 RdrAndBindings
+ [ RdrSig (FixSig (FixitySig n
+ (Fixity $3 $2) $1))
+ | n <- $4 ] }
+
+signdecl :: { RdrBinding }
+ : vars srcloc '::' sigtype { foldr1 RdrAndBindings
+ [ RdrSig (Sig n $4 $2) | n <- $1 ] }
+
+sigtype :: { RdrNameHsType }
+ : ctype { case $1 of
+ HsForAllTy _ _ _ -> $1
+ other -> HsForAllTy Nothing [] $1 }
+
+{-
+ ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var
+ instead of qvar, we get another shift/reduce-conflict. Consider the
+ following programs:
+
+ { (+) :: ... } only var
+ { (+) x y = ... } could (incorrectly) be qvar
+
+ We re-use expressions for patterns, so a qvar would be allowed in patterns
+ instead of a var only (which would be correct). But deciding what the + is,
+ would require more lookahead. So let's check for ourselves...
+-}
+
+vars :: { [RdrName] }
+ : vars ',' var { $3 : $1 }
+ | qvar { [ $1 ] }
+
+-----------------------------------------------------------------------------
+-- Transformation Rules
+
+rules :: { RdrBinding }
+ : rules ';' rule { $1 `RdrAndBindings` $3 }
+ | rules ';' { $1 }
+ | rule { $1 }
+ | {- empty -} { RdrNullBind }
+
+rule :: { RdrBinding }
+ : STRING rule_forall fexp '=' srcloc exp
+ { RdrHsDecl (RuleD (RuleDecl $1 (error "rule tyvars")
+ $2 $3 $6 $5)) }
+
+rule_forall :: { [RdrNameRuleBndr] }
+ : 'forall' rule_var_list '.' { $2 }
+ | {- empty -} { [] }
+
+rule_var_list :: { [RdrNameRuleBndr] }
+ : rule_var { [$1] }
+ | rule_var ',' rule_var_list { $1 : $3 }
+
+rule_var :: { RdrNameRuleBndr }
+ : varid { RuleBndr $1 }
+ | varid '::' ctype { RuleBndrSig $1 $3 }
+
+-----------------------------------------------------------------------------
+-- Foreign import/export
+
+callconv :: { Int }
+ : VARID {% checkCallConv $1 }
+ | {- empty -} { defaultCallConv }
+
+unsafe_flag :: { Bool }
+ : 'unsafe' { True }
+ | {- empty -} { False }
+
+ext_name :: { ExtName }
+ : 'dynamic' { Dynamic }
+ | STRING { ExtName $1 Nothing }
+ | STRING STRING { ExtName $2 (Just $1) }
+
+-----------------------------------------------------------------------------
+-- Types
+
+{- ToDo: forall stuff -}
+
+type :: { RdrNameHsType }
+ : btype '->' type { MonoFunTy $1 $3 }
+ | btype { $1 }
+
+btype :: { RdrNameHsType }
+ : btype atype { MonoTyApp $1 $2 }
+ | atype { $1 }
+
+atype :: { RdrNameHsType }
+ : gtycon { MonoTyVar $1 }
+ | tyvar { MonoTyVar $1 }
+ | '(' type ',' types ')' { MonoTupleTy ($2 : reverse $4) True }
+ | '(#' types '#)' { MonoTupleTy (reverse $2) False }
+ | '[' type ']' { MonoListTy $2 }
+ | '(' ctype ')' { $2 }
+
+gtycon :: { RdrName }
+ : qtycon { $1 }
+ | '(' ')' { unitTyCon_RDR }
+ | '(' '->' ')' { funTyCon_RDR }
+ | '[' ']' { listTyCon_RDR }
+ | '(' commas ')' { tupleTyCon_RDR $2 }
+
+-- An inst_type is what occurs in the head of an instance decl
+-- e.g. (Foo a, Gaz b) => Wibble a b
+-- It's kept as a single type, with a MonoDictTy at the right
+-- hand corner, for convenience.
+inst_type :: { RdrNameHsType }
+ : ctype {% checkInstType $1 }
+
+ctype :: { RdrNameHsType }
+ : 'forall' tyvars '.' btype '=>' type
+ {% checkContext $4 `thenP` \c ->
+ returnP (HsForAllTy (Just $2) c $6) }
+ | 'forall' tyvars '.' type { HsForAllTy (Just $2) [] $4 }
+ | btype '=>' type {% checkContext $1 `thenP` \c ->
+ returnP (HsForAllTy Nothing c $3) }
+ | type { $1 }
+
+types0 :: { [RdrNameHsType] }
+ : types { $1 }
+ | {- empty -} { [] }
+
+types :: { [RdrNameHsType] }
+ : type { [$1] }
+ | types ',' type { $3 : $1 }
+
+simpletype :: { (RdrName, [RdrNameHsTyVar]) }
+ : tycon tyvars { ($1, reverse $2) }
+
+tyvars :: { [RdrNameHsTyVar] }
+ : tyvars tyvar { UserTyVar $2 : $1 }
+ | {- empty -} { [] }
+
+-----------------------------------------------------------------------------
+-- Datatype declarations
+
+constrs :: { [RdrNameConDecl] }
+ : constrs '|' constr { $3 : $1 }
+ | constr { [$1] }
+
+{- ToDo: existential stuff -}
+
+constr :: { RdrNameConDecl }
+ : srcloc scontype
+ { ConDecl (fst $2) [] [] (VanillaCon (snd $2)) $1 }
+ | srcloc sbtype conop sbtype
+ { ConDecl $3 [] [] (InfixCon $2 $4) $1 }
+ | srcloc con '{' fielddecls '}'
+ { ConDecl $2 [] [] (RecCon (reverse $4)) $1 }
+
+newconstr :: { RdrNameConDecl }
+ : srcloc conid atype { ConDecl $2 [] [] (NewCon $3 Nothing) $1 }
+ | srcloc conid '{' var '::' type '}'
+ { ConDecl $2 [] [] (NewCon $6 (Just $4)) $1 }
+
+scontype :: { (RdrName, [RdrNameBangType]) }
+ : btype {% splitForConApp $1 [] }
+ | scontype1 { $1 }
+
+scontype1 :: { (RdrName, [RdrNameBangType]) }
+ : btype '!' atype {% splitForConApp $1 [Banged $3] }
+ | scontype1 satype { (fst $1, snd $1 ++ [$2] ) }
+
+satype :: { RdrNameBangType }
+ : atype { Unbanged $1 }
+ | '!' atype { Banged $2 }
+
+sbtype :: { RdrNameBangType }
+ : btype { Unbanged $1 }
+ | '!' atype { Banged $2 }
+
+fielddecls :: { [([RdrName],RdrNameBangType)] }
+ : fielddecls ',' fielddecl { $3 : $1 }
+ | fielddecl { [$1] }
+
+fielddecl :: { ([RdrName],RdrNameBangType) }
+ : vars '::' stype { (reverse $1, $3) }
+
+stype :: { RdrNameBangType }
+ : type { Unbanged $1 }
+ | '!' atype { Banged $2 }
+
+deriving :: { Maybe [RdrName] }
+ : {- empty -} { Nothing }
+ | 'deriving' qtycls { Just [$2] }
+ | 'deriving' '(' ')' { Just [] }
+ | 'deriving' '(' dclasses ')' { Just (reverse $3) }
+
+dclasses :: { [RdrName] }
+ : dclasses ',' qtycls { $3 : $1 }
+ | qtycls { [$1] }
+
+-----------------------------------------------------------------------------
+-- Value definitions
+
+valdef :: { RdrNameMonoBinds }
+ : infixexp {-ToDo: opt_sig-} srcloc rhs
+ {% checkValDef $1 Nothing $3 $2 }
+
+rhs :: { RdrNameGRHSs }
+ : '=' srcloc exp wherebinds { GRHSs (unguardedRHS $3 $2)
+ $4 Nothing}
+ | gdrhs wherebinds { GRHSs (reverse $1) $2 Nothing }
+
+gdrhs :: { [RdrNameGRHS] }
+ : gdrhs gdrh { $2 : $1 }
+ | gdrh { [$1] }
+
+gdrh :: { RdrNameGRHS }
+ : '|' srcloc quals '=' exp { GRHS (reverse
+ (ExprStmt $5 $2 : $3)) $2 }
+
+-----------------------------------------------------------------------------
+-- Expressions
+
+exp :: { RdrNameHsExpr }
+ : infixexp '::' sigtype { ExprWithTySig $1 $3 }
+ | infixexp { $1 }
+
+infixexp :: { RdrNameHsExpr }
+ : exp10 { $1 }
+ | infixexp qop exp10 { OpApp $1 $2 (panic "fixity") $3 }
+
+exp10 :: { RdrNameHsExpr }
+ : '\\' aexp aexps opt_asig '->' srcloc exp
+ {% checkPatterns ($2 : reverse $3) `thenP` \ ps ->
+ returnP (HsLam (Match [] ps $4
+ (GRHSs (unguardedRHS $7 $6)
+ EmptyBinds Nothing))) }
+ | 'let' declbinds 'in' exp { HsLet $2 $4 }
+ | 'if' srcloc exp 'then' exp 'else' exp { HsIf $3 $5 $7 $2 }
+ | 'case' srcloc exp 'of' altslist { HsCase $3 $5 $2 }
+ | '-' fexp { NegApp $2 (error "NegApp") }
+ | srcloc 'do' stmtlist { HsDo DoStmt $3 $1 }
+
+ | '_ccall_' ccallid aexps0 { CCall $2 $3 False False cbot }
+ | '_ccall_GC_' ccallid aexps0 { CCall $2 $3 True False cbot }
+ | '_casm_' CLITLIT aexps0 { CCall $2 $3 False True cbot }
+ | '_casm_GC_' CLITLIT aexps0 { CCall $2 $3 True True cbot }
+
+ | fexp { $1 }
+
+ccallid :: { FAST_STRING }
+ : VARID { $1 }
+ | CONID { $1 }
+
+fexp :: { RdrNameHsExpr }
+ : fexp aexp { HsApp $1 $2 }
+ | aexp { $1 }
+
+aexps0 :: { [RdrNameHsExpr] }
+ : aexps { reverse $1 }
+
+aexps :: { [RdrNameHsExpr] }
+ : aexps aexp { $2 : $1 }
+ | {- empty -} { [] }
+
+aexp :: { RdrNameHsExpr }
+ : aexp '{' fbinds '}' {% mkRecConstrOrUpdate $1 (reverse $3) }
+ | aexp1 { $1 }
+
+aexp1 :: { RdrNameHsExpr }
+ : qvar { HsVar $1 }
+ | gcon { HsVar $1 }
+ | literal { HsLit $1 }
+ | '(' exp ')' { HsPar $2 }
+ | '(' exp ',' texps ')' { ExplicitTuple ($2 : reverse $4) True }
+ | '(#' texps '#)' { ExplicitTuple (reverse $2) False }
+ | '[' list ']' { $2 }
+ | '(' infixexp qop ')' { SectionL $2 $3 }
+ | '(' qopm infixexp ')' { SectionR $2 $3 }
+ | qvar '@' aexp1 { EAsPat $1 $3 }
+ | '_' { EWildPat }
+ | '~' aexp1 { ELazyPat $2 }
+
+commas :: { Int }
+ : commas ',' { $1 + 1 }
+ | ',' { 2 }
+
+texps :: { [RdrNameHsExpr] }
+ : texps ',' exp { $3 : $1 }
+ | exp { [$1] }
+
+-----------------------------------------------------------------------------
+-- List expressions
+
+-- The rules below are little bit contorted to keep lexps left-recursive while
+-- avoiding another shift/reduce-conflict.
+
+list :: { RdrNameHsExpr }
+ : exp { ExplicitList [$1] }
+ | lexps { ExplicitList (reverse $1) }
+ | exp '..' { ArithSeqIn (From $1) }
+ | exp ',' exp '..' { ArithSeqIn (FromThen $1 $3) }
+ | exp '..' exp { ArithSeqIn (FromTo $1 $3) }
+ | exp ',' exp '..' exp { ArithSeqIn (FromThenTo $1 $3 $5) }
+ | exp srcloc '|' quals { HsDo ListComp (reverse
+ (ReturnStmt $1 : $4)) $2 }
+
+lexps :: { [RdrNameHsExpr] }
+ : lexps ',' exp { $3 : $1 }
+ | exp ',' exp { [$3,$1] }
+
+-----------------------------------------------------------------------------
+-- List Comprehensions
+
+quals :: { [RdrNameStmt] }
+ : quals ',' qual { $3 : $1 }
+ | qual { [$1] }
+
+qual :: { RdrNameStmt }
+ : srcloc infixexp '<-' exp {% checkPattern $2 `thenP` \p ->
+ returnP (BindStmt p $4 $1) }
+ | srcloc exp { GuardStmt $2 $1 }
+ | srcloc 'let' declbinds { LetStmt $3 }
+
+-----------------------------------------------------------------------------
+-- Case alternatives
+
+altslist :: { [RdrNameMatch] }
+ : '{' alts '}' { reverse $2 }
+ | layout_on alts close { reverse $2 }
+
+
+alts :: { [RdrNameMatch] }
+ : alts ';' alt { $3 : $1 }
+ | alts ';' { $1 }
+ | alt { [$1] }
+ | {- empty -} { [] }
+
+alt :: { RdrNameMatch }
+ : infixexp opt_sig ralt wherebinds
+ {% checkPattern $1 `thenP` \p ->
+ returnP (Match [] [p] $2
+ (GRHSs $3 $4 Nothing)) }
+
+opt_sig :: { Maybe RdrNameHsType }
+ : {- empty -} { Nothing }
+ | '::' type { Just $2 }
+
+opt_asig :: { Maybe RdrNameHsType }
+ : {- empty -} { Nothing }
+ | '::' atype { Just $2 }
+
+ralt :: { [RdrNameGRHS] }
+ : '->' srcloc exp { [GRHS [ExprStmt $3 $2] $2] }
+ | gdpats { (reverse $1) }
+
+gdpats :: { [RdrNameGRHS] }
+ : gdpats gdpat { $2 : $1 }
+ | gdpat { [$1] }
+
+gdpat :: { RdrNameGRHS }
+ : srcloc '|' quals '->' exp { GRHS (reverse (ExprStmt $5 $1:$3)) $1}
+
+-----------------------------------------------------------------------------
+-- Statement sequences
+
+stmtlist :: { [RdrNameStmt] }
+ : '{' stmts '}' { reverse $2 }
+ | layout_on stmts close { reverse $2 }
+
+stmts :: { [RdrNameStmt] }
+ : stmts ';' stmt { $3 : $1 }
+ | stmts ';' { $1 }
+ | stmt { [$1] }
+ | {- empty -} { [] }
+
+stmt :: { RdrNameStmt }
+ : srcloc infixexp '<-' exp {% checkPattern $2 `thenP` \p ->
+ returnP (BindStmt p $4 $1) }
+ | srcloc exp { ExprStmt $2 $1 }
+ | srcloc 'let' declbinds { LetStmt $3 }
+
+-----------------------------------------------------------------------------
+-- Record Field Update/Construction
+
+fbinds :: { RdrNameHsRecordBinds }
+ : fbinds ',' fbind { $3 : $1 }
+ | fbinds ',' { $1 }
+ | fbind { [$1] }
+ | {- empty -} { [] }
+
+fbind :: { (RdrName, RdrNameHsExpr, Bool) }
+ : qvar '=' exp { ($1,$3,False) }
+
+-----------------------------------------------------------------------------
+-- Variables, Constructors and Operators.
+
+gcon :: { RdrName }
+ : '(' ')' { unitCon_RDR }
+ | '[' ']' { nilCon_RDR }
+ | '(' commas ')' { tupleCon_RDR $2 }
+ | qcon { $1 }
+
+var :: { RdrName }
+ : varid { $1 }
+ | '(' varsym ')' { $2 }
+
+qvar :: { RdrName }
+ : qvarid { $1 }
+ | '(' qvarsym ')' { $2 }
+
+con :: { RdrName }
+ : conid { $1 }
+ | '(' consym ')' { $2 }
+
+qcon :: { RdrName }
+ : qconid { $1 }
+ | '(' qconsym ')' { $2 }
+
+varop :: { RdrName }
+ : varsym { $1 }
+ | '`' varid '`' { $2 }
+
+qvarop :: { RdrName }
+ : qvarsym { $1 }
+ | '`' qvarid '`' { $2 }
+
+qvaropm :: { RdrName }
+ : qvarsymm { $1 }
+ | '`' qvarid '`' { $2 }
+
+conop :: { RdrName }
+ : consym { $1 }
+ | '`' conid '`' { $2 }
+
+qconop :: { RdrName }
+ : qconsym { $1 }
+ | '`' qconid '`' { $2 }
+
+-----------------------------------------------------------------------------
+-- Any operator
+
+op :: { RdrName } -- used in infix decls
+ : varop { $1 }
+ | conop { $1 }
+
+qop :: { RdrNameHsExpr } -- used in sections
+ : qvarop { HsVar $1 }
+ | qconop { HsVar $1 }
+
+qopm :: { RdrNameHsExpr } -- used in sections
+ : qvaropm { HsVar $1 }
+ | qconop { HsVar $1 }
+
+-----------------------------------------------------------------------------
+-- VarIds
+
+qvarid :: { RdrName }
+ : varid { $1 }
+ | QVARID { case $1 of { (mod,n) ->
+ mkSrcQual varName mod n } }
+
+varid :: { RdrName }
+ : VARID { mkSrcUnqual varName $1 }
+ | 'as' { as_var_RDR }
+ | 'qualified' { qualified_var_RDR }
+ | 'hiding' { hiding_var_RDR }
+ | 'forall' { forall_var_RDR }
+ | 'export' { export_var_RDR }
+ | 'label' { label_var_RDR }
+ | 'dynamic' { dynamic_var_RDR }
+ | 'unsafe' { unsafe_var_RDR }
+
+varid_no_unsafe :: { RdrName }
+ : VARID { mkSrcUnqual varName $1 }
+ | 'as' { as_var_RDR }
+ | 'qualified' { qualified_var_RDR }
+ | 'hiding' { hiding_var_RDR }
+ | 'forall' { forall_var_RDR }
+ | 'export' { export_var_RDR }
+ | 'label' { label_var_RDR }
+ | 'dynamic' { dynamic_var_RDR }
+
+-----------------------------------------------------------------------------
+-- ConIds
+
+qconid :: { RdrName }
+ : conid { $1 }
+ | QCONID { case $1 of { (mod,n) ->
+ mkSrcQual dataName mod n } }
+
+conid :: { RdrName }
+ : CONID { mkSrcUnqual dataName $1 }
+
+-----------------------------------------------------------------------------
+-- ConSyms
+
+qconsym :: { RdrName }
+ : consym { $1 }
+ | QCONSYM { case $1 of { (mod,n) ->
+ mkSrcQual dataName mod n } }
+
+consym :: { RdrName }
+ : CONSYM { mkSrcUnqual dataName $1 }
+
+-----------------------------------------------------------------------------
+-- VarSyms
+
+qvarsym :: { RdrName }
+ : varsym { $1 }
+ | qvarsym1 { $1 }
+
+qvarsymm :: { RdrName }
+ : varsymm { $1 }
+ | qvarsym1 { $1 }
+
+varsym :: { RdrName }
+ : VARSYM { mkSrcUnqual varName $1 }
+ | '-' { minus_RDR }
+ | '!' { pling_RDR }
+ | '.' { dot_RDR }
+
+varsymm :: { RdrName } -- varsym not including '-'
+ : VARSYM { mkSrcUnqual varName $1 }
+ | '!' { pling_RDR }
+ | '.' { dot_RDR }
+
+qvarsym1 :: { RdrName }
+ : QVARSYM { case $1 of { (mod,n) ->
+ mkSrcQual varName mod n } }
+
+literal :: { HsLit }
+ : INTEGER { HsInt $1 }
+ | CHAR { HsChar $1 }
+ | RATIONAL { HsFrac $1 }
+ | STRING { HsString $1 }
+
+ | PRIMINTEGER { HsIntPrim $1 }
+ | PRIMCHAR { HsCharPrim $1 }
+ | PRIMSTRING { HsStringPrim $1 }
+ | PRIMFLOAT { HsFloatPrim $1 }
+ | PRIMDOUBLE { HsDoublePrim $1 }
+ | CLITLIT { HsLitLit $1 }
+
+srcloc :: { SrcLoc } : {% getSrcLocP }
+
+-----------------------------------------------------------------------------
+-- Layout
+
+close :: { () }
+ : vccurly { () } -- context popped in lexer.
+ | error {% popContext }
+
+layout_on :: { () } : {% layoutOn }
+
+-----------------------------------------------------------------------------
+-- Miscellaneous (mostly renamings)
+
+modid :: { ModuleName }
+ : CONID { mkSrcModuleFS $1 }
+
+tycon :: { RdrName }
+ : CONID { mkSrcUnqual tcClsName $1 }
+
+qtycon :: { RdrName }
+ : tycon { $1 }
+ | QCONID { case $1 of { (mod,n) ->
+ mkSrcQual tcClsName mod n } }
+
+qtycls :: { RdrName }
+ : qtycon { $1 }
+
+tyvar :: { RdrName }
+ : VARID { mkSrcUnqual tvName $1 }
+ | 'as' { as_tyvar_RDR }
+ | 'qualified' { qualified_tyvar_RDR }
+ | 'hiding' { hiding_tyvar_RDR }
+ | 'export' { export_var_RDR }
+ | 'label' { label_var_RDR }
+ | 'dynamic' { dynamic_var_RDR }
+ | 'unsafe' { unsafe_var_RDR }
+ -- NOTE: no 'forall'
+
+-----------------------------------------------------------------------------
+
+{
+happyError :: P a
+happyError buf PState{ loc = loc } = PFailed (srcParseErr buf loc)
+}
+++ /dev/null
-If you want to debug...
-
-* the lexer:
-
- run "flex" with the -d flag; compile as normal thereafter
-
-* the parser:
-
- compile hsparser.tab.c and main.c with EXTRA_CC_OPTS=-DHSP_DEBUG
-
- run hsp with -D; it's dumping the output into *stdout*,
- so you have to do something weird to look at it.
RdrNameMonoBinds,
RdrNamePat,
RdrNameHsType,
+ RdrNameHsTyVar,
RdrNameSig,
RdrNameStmt,
RdrNameTyClDecl,
- RdrNameRuleBndr,
RdrNameRuleDecl,
+ RdrNameRuleBndr,
+ RdrNameHsRecordBinds,
+
+ RdrBinding(..),
+ RdrMatch(..),
+ SigConverter,
RdrNameClassOpPragmas,
RdrNameClassPragmas,
RdrNameInstancePragmas,
extractHsTyRdrNames,
extractPatsTyVars, extractRuleBndrsTyVars,
+
+ mkOpApp, mkClassDecl, mkClassOpSig,
- mkOpApp, mkClassDecl, mkClassOpSig
+ cvBinds,
+ cvMonoBindsAndSigs,
+ cvTopDecls,
+ cvValSig, cvClassOpSig, cvInstDeclSig
) where
#include "HsVersions.h"
import HsSyn
+import Name ( mkClassTyConOcc, mkClassDataConOcc )
import OccName ( mkClassTyConOcc, mkClassDataConOcc,
- mkSuperDictSelOcc, mkDefaultMethodOcc
- )
+ mkSuperDictSelOcc, mkDefaultMethodOcc
+ )
import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc )
import Util ( thenCmp )
-import HsPragmas ( GenPragmas, ClassPragmas, DataPragmas, ClassOpPragmas, InstancePragmas )
+import HsPragmas
import List ( nub )
+import BasicTypes ( RecFlag(..) )
import Outputable
\end{code}
type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat
type RdrNamePat = InPat RdrName
type RdrNameHsType = HsType RdrName
+type RdrNameHsTyVar = HsTyVar RdrName
type RdrNameSig = Sig RdrName
type RdrNameStmt = Stmt RdrName RdrNamePat
type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat
-type RdrNameRuleBndr = RuleBndr RdrName
-type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat
+type RdrNameRuleBndr = RuleBndr RdrName
+type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat
+
+type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat
type RdrNameClassOpPragmas = ClassOpPragmas RdrName
type RdrNameClassPragmas = ClassPragmas RdrName
%************************************************************************
%* *
\subsection{A few functions over HsSyn at RdrName}
-%* *
+%* *
%************************************************************************
@extractHsTyRdrNames@ finds the free variables of a HsType
extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName]
extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
- where
- go (RuleBndr _) acc = acc
- go (RuleBndrSig _ ty) acc = extract_ty ty acc
+ where
+ go (RuleBndr _) acc = acc
+ go (RuleBndrSig _ ty) acc = extract_ty ty acc
extractHsCtxtRdrNames :: Context RdrName -> [RdrName]
extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
extract_ctxt ctxt acc = foldr extract_ass acc ctxt
- where
- extract_ass (cls, tys) acc = foldr extract_ty (cls : acc) tys
+ where
+ extract_ass (cls, tys) acc = foldr extract_ty (cls : acc) tys
-extract_ty (MonoTyApp ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (MonoListTy ty) acc = extract_ty ty acc
+extract_ty (MonoTyApp ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (MonoListTy ty) acc = extract_ty ty acc
extract_ty (MonoTupleTy tys _) acc = foldr extract_ty acc tys
-extract_ty (MonoFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (MonoDictTy cls tys) acc = foldr extract_ty (cls : acc) tys
-extract_ty (MonoUsgTy usg ty) acc = extract_ty ty acc
+extract_ty (MonoFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (MonoDictTy cls tys) acc = foldr extract_ty (cls : acc) tys
+extract_ty (MonoUsgTy usg ty) acc = extract_ty ty acc
extract_ty (MonoTyVar tv) acc = tv : acc
extract_ty (HsForAllTy (Just tvs) ctxt ty)
- acc = acc ++
- (filter (`notElem` locals) $
+ acc = acc ++
+ (filter (`notElem` locals) $
extract_ctxt ctxt (extract_ty ty []))
where
locals = map getTyVarName tvs
extract_pat (RecPatIn c fields) acc = foldr (\ (f,pat,_) acc -> extract_pat pat acc) acc fields
\end{code}
-
-A useful function for building @OpApps@. The operator is always a variable,
-and we don't know the fixity yet.
-
-\begin{code}
-mkOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
-\end{code}
-
mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
by deriving them from the name of the class. We fill in the names for the
tycon and datacon corresponding to the class, by deriving them from the
file (which would be equally good).
Similarly for mkClassOpSig and default-method names.
-
+
\begin{code}
mkClassDecl cxt cname tyvars sigs mbinds prags loc
= ClassDecl cxt cname tyvars sigs mbinds prags tname dname sc_sel_names loc
cls_occ = rdrNameOcc cname
dname = mkRdrUnqual (mkClassDataConOcc cls_occ)
tname = mkRdrUnqual (mkClassTyConOcc cls_occ)
- sc_sel_names = [mkRdrUnqual (mkSuperDictSelOcc n cls_occ) | n <- [1..length cxt]]
- -- We number off the superclass selectors, 1, 2, 3 etc so that we can construct
- -- names for the selectors. Thus
- -- class (C a, C b) => D a b where ...
- -- gives superclass selectors
- -- D_sc1, D_sc2
- -- (We used to call them D_C, but now we can have two different
- -- superclasses both called C!)
+ sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ)
+ | n <- [1..length cxt]]
+ -- We number off the superclass selectors, 1, 2, 3 etc so that we
+ -- can construct names for the selectors. Thus
+ -- class (C a, C b) => D a b where ...
+ -- gives superclass selectors
+ -- D_sc1, D_sc2
+ -- (We used to call them D_C, but now we can have two different
+ -- superclasses both called C!)
mkClassOpSig has_default_method op ty loc
- | not has_default_method = ClassOpSig op Nothing ty loc
- | otherwise = ClassOpSig op (Just dm_rn) ty loc
+ | not has_default_method = ClassOpSig op Nothing ty loc
+ | otherwise = ClassOpSig op (Just dm_rn) ty loc
where
dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
\end{code}
+
+A useful function for building @OpApps@. The operator is always a variable,
+and we don't know the fixity yet.
+
+\begin{code}
+mkOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[rdrBinding]{Bindings straight out of the parser}
+%* *
+%************************************************************************
+
+\begin{code}
+data RdrBinding
+ = -- On input we use the Empty/And form rather than a list
+ RdrNullBind
+ | RdrAndBindings RdrBinding RdrBinding
+
+ -- Value bindings havn't been united with their
+ -- signatures yet
+ | RdrValBinding RdrNameMonoBinds
+
+ -- Signatures are mysterious; we can't
+ -- tell if its a Sig or a ClassOpSig,
+ -- so we just save the pieces:
+ | RdrSig RdrNameSig
+
+ -- The remainder all fit into the main HsDecl form
+ | RdrHsDecl RdrNameHsDecl
+
+type SigConverter = RdrNameSig -> RdrNameSig
+\end{code}
+
+\begin{code}
+data RdrMatch
+ = RdrMatch
+ [RdrNamePat]
+ (Maybe RdrNameHsType)
+ RdrNameGRHSs
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[cvDecls]{Convert various top-level declarations}
+%* *
+%************************************************************************
+
+We make a point not to throw any user-pragma ``sigs'' at
+these conversion functions:
+
+\begin{code}
+cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
+
+cvValSig sig = sig
+
+cvInstDeclSig sig = sig
+
+cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var Nothing poly_ty src_loc
+cvClassOpSig sig = sig
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
+%* *
+%************************************************************************
+
+Function definitions are restructured here. Each is assumed to be recursive
+initially, and non recursive definitions are discovered by the dependency
+analyser.
+
+\begin{code}
+cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds
+ -- The mysterious SigConverter converts Sigs to ClassOpSigs
+ -- in class declarations. Mostly it's just an identity function
+
+cvBinds sig_cvtr binding
+ = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) ->
+ MonoBind mbs sigs Recursive
+ }
+\end{code}
+
+\begin{code}
+cvMonoBindsAndSigs :: SigConverter
+ -> RdrBinding
+ -> (RdrNameMonoBinds, [RdrNameSig])
+
+cvMonoBindsAndSigs sig_cvtr fb
+ = mangle_bind (EmptyMonoBinds, []) fb
+ where
+ mangle_bind acc RdrNullBind
+ = acc
+
+ mangle_bind acc (RdrAndBindings fb1 fb2)
+ = mangle_bind (mangle_bind acc fb1) fb2
+
+ mangle_bind (b_acc, s_acc) (RdrSig sig)
+ = (b_acc, sig_cvtr sig : s_acc)
+
+ mangle_bind (b_acc, s_acc) (RdrValBinding binding)
+ = (b_acc `AndMonoBinds` binding, s_acc)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[PrefixToHS-utils]{Utilities for conversion}
+%* *
+%************************************************************************
+
+Separate declarations into all the various kinds:
+
+\begin{code}
+cvTopDecls :: RdrBinding -> [RdrNameHsDecl]
+cvTopDecls bind
+ = let
+ (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind
+ in
+ (ValD (MonoBind mono_binds sigs Recursive) : top_decls)
+ where
+ go acc RdrNullBind = acc
+ go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
+ go (topds, mbs, sigs) (RdrHsDecl d) = (d : topds, mbs, sigs)
+ go (topds, mbs, sigs) (RdrSig (FixSig d)) = (FixD d : topds, mbs, sigs)
+ go (topds, mbs, sigs) (RdrSig sig) = (topds, mbs, sig:sigs)
+ go (topds, mbs, sigs) (RdrValBinding bind) = (topds, mbs `AndMonoBinds` bind, sigs)
+\end{code}
+++ /dev/null
-Stuff the Ugenny things show to the parser.
-
-\begin{code}
-module UgenAll (
- -- stuff defined in utils module
- module UgenUtil,
-
- -- re-exported ugen-generated stuff
- module U_binding,
- module U_constr,
- module U_entidt,
- module U_list,
- module U_literal,
- module U_maybe,
- module U_either,
- module U_grhsb,
- module U_gdexp,
- module U_match,
- module U_qid,
- module U_rulevar,
- module U_tree,
- module U_ttype
- ) where
-
-#include "HsVersions.h"
-
-import GlaExts
-
--- friends:
-import U_binding
-import U_constr
-import U_entidt
-import U_list
-import U_literal
-import U_maybe
-import U_either
-import U_gdexp
-import U_grhsb
-import U_match
-import U_qid
-import U_tree
-import U_ttype
-import U_rulevar
-
-import UgenUtil
-\end{code}
+++ /dev/null
-Glues lots of things together for ugen-generated
-.hs files here
-
-\begin{code}
-module UgenUtil (
- -- stuff defined here
- module UgenUtil,
- Addr
- ) where
-
-#include "HsVersions.h"
-
-import GlaExts
-import Module ( Module, mkSrcModule )
-import SrcLoc ( mkSrcLoc, noSrcLoc, SrcLoc )
-import FastString ( FastString, mkFastCharString, mkFastCharString2 )
-\end{code}
-
-\begin{code}
-type UgnM a
- = (FastString,SrcLoc) -- file, and src_loc carried down
- -> IO a
-
-{-# INLINE returnUgn #-}
-{-# INLINE thenUgn #-}
-
-returnUgn x stuff = return x
-
-thenUgn x y stuff
- = x stuff >>= \ z ->
- y z stuff
-
-initUgn :: UgnM a -> IO a
-initUgn action = action (SLIT(""),noSrcLoc)
-
-ioToUgnM :: IO a -> UgnM a
-ioToUgnM x stuff = x
-\end{code}
-
-\begin{code}
-type ParseTree = Addr
-
-type U_VOID_STAR = Addr
-rdU_VOID_STAR :: Addr -> UgnM U_VOID_STAR
-rdU_VOID_STAR x = returnUgn x
-
-type U_long = Int
-rdU_long :: Int -> UgnM U_long
-rdU_long x = returnUgn x
-
-type U_stringId = FastString
-rdU_stringId :: Addr -> UgnM U_stringId
-{-# INLINE rdU_stringId #-}
-rdU_stringId s = returnUgn (mkFastCharString s)
-
-type U_numId = Int -- ToDo: Int
-rdU_numId :: Addr -> UgnM U_numId
-rdU_numId i = rdU_stringId i `thenUgn` \ y -> returnUgn ((read (_UNPK_ y))::Int)
-
-type U_hstring = FastString
-rdU_hstring :: Addr -> UgnM U_hstring
-rdU_hstring x
- = ioToUgnM (_ccall_ get_hstring_len x) `thenUgn` \ len ->
- ioToUgnM (_ccall_ get_hstring_bytes x) `thenUgn` \ bytes ->
- returnUgn (mkFastCharString2 bytes len)
-\end{code}
-
-\begin{code}
-setSrcFileUgn :: FastString -> UgnM a -> UgnM a
-setSrcFileUgn file action stuff@(_,loc) = action (file,loc)
-
-getSrcFileUgn :: UgnM FastString
-getSrcFileUgn stuff@(file,loc) = returnUgn file stuff
-
-mkSrcLocUgn :: U_long -> (SrcLoc -> UgnM a) -> UgnM a
-mkSrcLocUgn ln action (file,_)
- = action loc (file,loc)
- where
- loc = mkSrcLoc file ln
-
-getSrcLocUgn :: UgnM SrcLoc
-getSrcLocUgn stuff@(file,loc) = returnUgn loc stuff
-\end{code}
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_binding where
-
-#include "HsVersions.h"
-
-import UgenUtil
-
-import U_constr
-import U_list
-import U_maybe
-import U_qid
-import U_ttype
-%}}
-type binding;
- nullbind : < >;
-
- /* And-bind; just concat two decl blobs together */
- abind : < gabindfst : binding;
- gabindsnd : binding; >;
-
- /* Import decl */
- import : < gibindimod : stringId;
- gibindqual : long;
- gibindas : maybe;
- gibindspec : maybe;
- gibindsource : long;
- gibindline : long; >;
-
- /* Fixity decl */
- fixd : < gfixop : qid;
- gfixinfx : long;
- gfixprec : long;
- gfixline : long; >;
-
-
- /* Class declaration */
- cbind : < gcbindc : list;
- gcbindid : ttype;
- gcbindw : binding;
- gcline : long; >;
-
- /* Instance declaration */
- ibind : < gibindi : ttype;
- gibindw : binding;
- giline : long; >;
-
- /* data type declaration */
- tbind : < gtbindc : list; /* [context entries] */
- gtbindid : ttype; /* applied tycon */
- gtbindl : list; /* [constr] */
- gtbindd : maybe; /* Maybe [deriving] */
- gtline : long; >;
-
- /* newtype declaration */
- ntbind : < gntbindc : list; /* [context entries] */
- gntbindid : ttype; /* applied tycon */
- gntbindcty : list; /* [constr] (only 1 constrnew) */
- gntbindd : maybe; /* Maybe [deriving] */
- gntline : long; >;
-
- /* type synonym declaration */
- nbind : < gnbindid : ttype;
- gnbindas : ttype;
- gnline : long; >;
-
- /* Pattern binding */
- pbind : < gpbindl : VOID_STAR; /* The pattern, of type tree;
- we can't say 'tree' because
- that gives mutual recursion in the C */
- gpbindr : VOID_STAR; /* The RHS, of type grhsb; same nonsense */
- gpline : long; >;
- /* Function binding */
- fbind : < gfbindm : list; /* List of matches */
- /* The match encodes the LHS as well as RHS */
- gfline : long; >;
-
- /* Default decl */
- dbind : < gdbindts : list;
- gdline : long; >;
-
- /* Type signature */
- sbind : < gsbindids : list;
- gsbindid : ttype;
- gsline : long; >;
-
- /* FFI declarations */
- fobind : < gfobind_id : qid;
- gfobind_ty : ttype;
- gfobind_ext : maybe;
- gfobind_flag : long;
- gfobind_cc : long;
- gfobind_kind : long;
- gfobind_line : long; >;
-
-
- /* user-specified pragmas:XXXX */
-
- vspec_uprag : < gvspec_id : qid;
- gvspec_tys : list; /* Of type */
- gvspec_line : long; >;
-
- vspec_ty_and_id : < gvspec_ty : ttype;
- gvspec_tyid : maybe; /* nil or singleton */ >;
-
- ispec_uprag : < gispec_ty : ttype;
- gispec_line : long; >;
-
- inline_uprag: < ginline_id : qid;
- ginline_line : long; >;
-
- noinline_uprag: < gnoinline_id : qid;
- gnoinline_line : long; >;
-
- magicuf_uprag:< gmagicuf_id : qid;
- gmagicuf_str : stringId;
- gmagicuf_line : long; >;
-
- dspec_uprag : < gdspec_id : qid;
- gdspec_tys : list;
- gdspec_line : long; >;
-
- /* Transformation rule */
- rule_prag : < grule_name : hstring;
- grule_forall : list;
- grule_lhs : VOID_STAR; /* Really tree, but mutual recursion problem in C */
- grule_rhs : VOID_STAR; /* Really tree, but mutual recursion problem in C */
- grule_line : long; >;
-end;
+++ /dev/null
-/*
- Include File for the Lexical Analyser and Parser.
-
- 19/11/91 kh Created.
-*/
-
-
-#ifndef __CONSTANTS_H
-#define __CONSTANTS_H
-
-/*
- Important Literal Constants.
-*/
-
-#define MODNAME_SIZE 512 /* Size of Module Name buffers */
-#define FILENAME_SIZE 4096 /* Size of File buffers */
-#define ERR_BUF_SIZE 512 /* Size of error buffers */
-
-#ifdef YYLMAX /* Get rid of YYLMAX */
-#undef YYLMAX /* Ugly -- but necessary */
-#endif
-
-#define YYLMAX 8192 /* Size of yytext -- limits strings, identifiers etc. */
-
-
-#define HASH_TABLE_SIZE 993 /* Default number of entries in the hash table. */
-
-#define MAX_CONTEXTS 100 /* Maximum nesting of wheres, cases etc */
-
-#define MAX_INFIX 500 /* Maximum number of infix operators */
-
-
-#ifdef TRUE
-#undef TRUE
-#endif
-
-#ifdef FALSE
-#undef FALSE
-#endif
-
-#define TRUE 1
-#define FALSE 0
-typedef int BOOLEAN;
-
-#endif /* __CONSTANTS_H */
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-
-module U_constr where
-
-#include "HsVersions.h"
-
-import UgenUtil
-
-import U_maybe
-import U_list
-import U_qid
-import U_ttype
-%}}
-type constr;
- /* constr in prefix form: */
- constrpre : < gconcid : qid;
- gconctypel : list; /* [ttype] */
- gconcline : long; >;
-
- /* constr in infix form: */
- constrinf : < gconity1 : ttype;
- gconiop : qid;
- gconity2 : ttype;
- gconiline : long; >;
-
- /* constr in record form: */
- constrrec : < gconrid : qid;
- gconrfieldl : list; /* [field] */
- gconrline : long; >;
-
- /* constr in simple "newtype" form: */
- constrnew : < gconnid : qid;
- gconnty : ttype;
- gconnla : maybe; /* Maybe qvar */
- gconnline : long; >;
-
- /* constr with a existential prefixed context C => ... */
- constrex : < gcontvs : list; /* tyvars */
- gconcxt : list; /* theta */
- gconcon : constr; >;
-
- field : < gfieldn : list;
- gfieldt : ttype; >;
-end;
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-
-module U_either where
-
-#include "HsVersions.h"
-
-import UgenUtil
-%}}
-
-type either;
- left : < gleft : VOID_STAR; > ;
- right : < gright : VOID_STAR; > ;
-end;
-
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_entidt where
-
-#include "HsVersions.h"
-
-import UgenUtil
-
-import U_list
-import U_qid
-%}}
-type entidt;
- entid : < gentid : qid; >;
- enttype : < gtentid : qid; >;
- enttypeall : < gaentid : qid; >;
- enttypenamed : < gnentid : qid;
- gnentnames : list; >;
- entmod : < gmentid : stringId; >;
-end;
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_gdexp where
-
-#include "HsVersions.h"
-
-import UgenUtil
-
-import U_list
-import U_tree
-%}}
-
-type gdexp;
- pgdexp : < gpguard : list /* of quals */ ; /* Experimental change: guards are lists of quals */
- gpgline : long; /* Line number of '=' sign */
- gpexp : tree; >;
-end;
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_grhsb where
-
-#include "HsVersions.h"
-
-import UgenUtil
-
-import U_binding
-import U_list
-%}}
-
-/* Guarded right hand sides and bindings */
-type grhsb;
- pguards : < ggrhss : list; /* of gdexp */
- ggbind1 : binding; >;
- pnoguards : < gnogline : long; /* Line number of '=' sign */
- grhs : VOID_STAR; /* The rhs, of type tree; can't say 'tree' because
- that leads to mutual recursion in the C */
- ggbind2 : binding; >;
-end;
-
+++ /dev/null
-/* This is the "top-level" file for the *linked-into-the-compiler* parser.
- See also main.c. (WDP 94/10)
-*/
-
-#include <stdio.h>
-
-#include "hspincl.h"
-#include "constants.h"
-#include "utils.h"
-
-/**********************************************************************
-* *
-* *
-* The main program *
-* *
-* *
-**********************************************************************/
-
-extern long prog_argc;
-extern char **prog_argv;
-
-#define MAX_HSP_ARGS 64
-long hsp_argc;
-char *hsp_argv[MAX_HSP_ARGS]; /* sigh */
-
-tree
-hspmain()
-{
- int hsp_i, prog_i;
-
- Lnil = mklnil(); /* The null list -- used in lsing, etc. */
-
- /* copy the args we're interested in (first char: comma)
- to hsp_argv; arrange to point after the comma!
- */
- hsp_i = 0;
- for (prog_i = 0; prog_i < prog_argc; prog_i++) {
- if (prog_argv[prog_i][0] == ',') {
- hsp_argv[hsp_i] = &(prog_argv[prog_i][1]);
- hsp_i++;
- }
- }
- hsp_argc = hsp_i; /* set count */
-
- process_args(hsp_argc, hsp_argv); /* HACK */
-
- hash_init();
- yyinit();
-
- if (yyparse() != 0) {
- /* There was a syntax error. */
- printf("\n");
- exit(1);
- }
-
- return(root);
-}
+++ /dev/null
-%{
-/**********************************************************************
-* *
-* *
-* FLEX for Haskell. *
-* ----------------- *
-* *
-**********************************************************************/
-
-/* The includes/config.h one */
-#include "config.h"
-
-#include <stdio.h>
-
-#if defined(STDC_HEADERS) || defined(HAVE_STRING_H)
-#include <string.h>
-/* An ANSI string.h and pre-ANSI memory.h might conflict. */
-#if !defined(STDC_HEADERS) && defined(HAVE_MEMORY_H)
-#include <memory.h>
-#endif /* not STDC_HEADERS and HAVE_MEMORY_H */
-#define index strchr
-#define rindex strrchr
-#define bcopy(s, d, n) memcpy ((d), (s), (n))
-#define bcmp(s1, s2, n) memcmp ((s1), (s2), (n))
-#define bzero(s, n) memset ((s), 0, (n))
-#else /* not STDC_HEADERS and not HAVE_STRING_H */
-#include <strings.h>
-/* memory.h and strings.h conflict on some systems. */
-#endif /* not STDC_HEADERS and not HAVE_STRING_H */
-
-#include "hspincl.h"
-#include "hsparser.tab.h"
-#include "constants.h"
-#include "utils.h"
-
-/* Our substitute for <ctype.h> */
-
-#define NCHARS 256
-#define _S 0x1
-#define _D 0x2
-#define _H 0x4
-#define _O 0x8
-#define _C 0x10
-
-static unsigned char CharTable[NCHARS] = {
-/* nul */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* bs */ 0, _S, _S, _S, _S, 0, 0, 0,
-/* dle */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* can */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* sp */ _S, 0, 0, 0, 0, 0, 0, 0,
-/* '(' */ _C, 0, 0, 0, 0, 0, 0, 0,
-/* '0' */ _D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,
-/* '8' */ _D|_H, _D|_H, _C, 0, 0, 0, 0, 0,
-/* '@' */ 0, _H|_C, _H|_C, _H|_C, _H|_C, _H|_C, _H|_C, _C,
-/* 'H' */ _C, _C, _C, _C, _C, _C, _C, _C,
-/* 'P' */ _C, _C, _C, _C, _C, _C, _C, _C,
-/* 'X' */ _C, _C, _C, _C, 0, 0, 0, 0,
-/* '`' */ 0, _H, _H, _H, _H, _H, _H, 0,
-/* 'h' */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* 'p' */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* 'x' */ 0, 0, 0, 0, 0, 0, 0, 0,
-
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-};
-
-BOOLEAN
-isconstr (char *s)
-{
- return(CharTable[*s]&(_C));
-}
-
-/**********************************************************************
-* *
-* *
-* Declarations *
-* *
-* *
-**********************************************************************/
-
-char *input_filename = NULL; /* Always points to a dynamically allocated string */
-
-/*
- * For my own sanity, things that are not part of the flex skeleton
- * have been renamed as hsXXXXX rather than yyXXXXX. --JSM
- */
-
-static int hslineno = 0; /* Line number at end of token */
-int hsplineno = 0; /* Line number at end of previous token */
-
-static int hscolno = 0; /* Column number at end of token */
-int hspcolno = 0; /* Column number at end of previous token */
-static int hsmlcolno = 0; /* Column number for multiple-rule lexemes */
-
-int modulelineno = -1; /* The line number where the module starts */
-int startlineno = 0; /* The line number where something starts */
-int endlineno = 0; /* The line number where something ends */
-
-static BOOLEAN noGap = TRUE; /* For checking string gaps */
-static BOOLEAN forgetindent = FALSE; /* Don't bother applying indentation rules */
-
-static int nested_comments; /* For counting comment nesting depth */
-static int comment_start;
-
-/* OLD: Hacky definition of yywrap: see flex doc.
-
- If we don't do this, then we'll have to get the default
- yywrap from the flex library, which is often something
- we are not good at locating. This avoids that difficulty.
- (Besides which, this is the way old flexes (pre 2.4.x) did it.)
- WDP 94/09/05
-#define yywrap() 1
-*/
-
-/* Essential forward declarations */
-
-static void hsnewid PROTO((char *, int));
-static void layout_input PROTO((char *, int));
-static void cleartext (NO_ARGS);
-static void addtext PROTO((char *, unsigned));
-static void addchar PROTO((char));
-static char *fetchtext PROTO((unsigned *));
-static void new_filename PROTO((char *));
-static int Return PROTO((int));
-static void hsentercontext PROTO((int));
-
-static BOOLEAN is_commment PROTO((char*, int));
-
-/* Special file handling for IMPORTS */
-/* Note: imports only ever go *one deep* (hence no need for a stack) WDP 94/09 */
-
-static YY_BUFFER_STATE hsbuf_save = NULL; /* Saved input buffer */
-static char *filename_save; /* File Name */
-static int hslineno_save = 0, /* Line Number */
- hsplineno_save = 0, /* Line Number of Prev. token */
- hscolno_save = 0, /* Indentation */
- hspcolno_save = 0; /* Left Indentation */
-static short icontexts_save = 0; /* Indent Context Level */
-
-static BOOLEAN etags_save; /* saved: whether doing etags stuff or not */
-extern BOOLEAN etags; /* that which is saved */
-
-extern BOOLEAN nonstandardFlag; /* Glasgow extensions allowed */
-
-static int hssttok = -1; /* Stacked Token: -1 -- no token; -ve -- ";"
- * inserted before token +ve -- "}" inserted before
- * token */
-
-short icontexts = 0; /* Which context we're in */
-
-/*
- Table of indentations: right bit indicates whether to use
- indentation rules (1 = use rules; 0 = ignore)
-
- partain:
- push one of these "contexts" at every "case" or "where"; the right bit says
- whether user supplied braces, etc., or not. pop appropriately (hsendindent).
-
- ALSO, a push/pop when enter/exit a new file (e.g., on importing). A -1 is
- pushed (the "column" for "module", "interface" and EOF). The -1 from the initial
- push is shown just below.
-
-*/
-
-
-static short indenttab[MAX_CONTEXTS] = {-1};
-
-#define INDENTPT (indenttab[icontexts]>>1)
-#define INDENTON (indenttab[icontexts]&1)
-
-#define RETURN(tok) return(Return(tok))
-
-#undef YY_DECL
-#define YY_DECL int yylex1()
-
-/* We should not peek at yy_act, but flex calls us even for the internal action
- triggered on 'end-of-buffer' (This is not true of flex 2.4.4 and up, but
- to support older versions of flex, we'll continue to peek for now.
- */
-#define YY_USER_ACTION \
- if (yy_act != YY_END_OF_BUFFER) layout_input(yytext, yyleng);
-
-#if 0/*debug*/
-#undef YY_BREAK
-#define YY_BREAK if (etags) fprintf(stderr,"%d %d / %d %d / %d\n",hsplineno,hspcolno,hslineno,hscolno,startlineno); break;
-#endif
-
-/* Each time we enter a new start state, we push it onto the state stack.
-*/
-#define PUSH_STATE(n) yy_push_state(n)
-#define POP_STATE yy_pop_state()
-
-%}
-/* Options:
- 8bit (8-bit input)
- noyywrap (do not call yywrap on end of file; avoid use of -lfl)
- never-interactive (to go a bit faster)
- stack (use a start-condition stack)
-*/
-%option 8bit
-%option noyywrap
-%option never-interactive
-%option stack
-
-/* The start states are:
- Code -- normal Haskell code (principal lexer)
- GlaExt -- Haskell code with Glasgow extensions
- Comment -- Nested comment processing
- String -- Inside a string literal with backslashes
- StringEsc -- Immediately following a backslash in a string literal
- Char -- Inside a character literal with backslashes
- CharEsc -- Immediately following a backslash in a character literal
-
- Note that the INITIAL state is unused. Also note that these states
- are _exclusive_. All rules should be prefixed with an appropriate
- list of start states.
- */
-
-%x Char CharEsc Code Comment GlaExt UserPragma String StringEsc
-
-isoS [\xa1-\xbf\xd7\xf7]
-isoL [\xc0-\xd6\xd8-\xde]
-isol [\xdf-\xf6\xf8-\xff]
-isoA [\xa1-\xff]
-
-D [0-9]
-O [0-7]
-H [0-9A-Fa-f]
-N {D}+
-F {N}"."{N}(("e"|"E")("+"|"-")?{N})?
-S [!#$%&*+./<=>?@\\^|\-~:\xa1-\xbf\xd7\xf7]
-SId {S}{S}*
-L [A-Z\xc0-\xd6\xd8-\xde]
-l [a-z_\xdf-\xf6\xf8-\xff]
-I {L}|{l}
-i {L}|{l}|[0-9'_]
-Id {I}{i}*
-Mod {L}{i}*
-CHAR [ !#$%&()*+,\-./0-9:;<=>?@A-Z\[\]^_`a-z{|}~\xa1-\xff]
-CNTRL [@A-Z\[\\\]^_]
-WS [ \t\n\r\f\v]
-NL [\n\r]
-
-%%
-
-%{
- /*
- * Simple comments and whitespace. Normally, we would just ignore these, but
- * in case we're processing a string escape, we need to note that we've seen
- * a gap.
- *
- * Note that we cater for a comment line that *doesn't* end in a newline.
- * This is incorrect, strictly speaking, but seems like the right thing
- * to do. Reported by Rajiv Mirani. (WDP 95/08)
- *
- * Hackily moved up here so that --<<EOF>> will match -- SOF 5/97
- */
-%}
-
-<Code,GlaExt,UserPragma,StringEsc>{WS}+ { noGap = FALSE; }
-
-%{
- /*
- * Special GHC pragma rules. Do we need a start state for interface files,
- * so these won't be matched in source files? --JSM
- */
-
-%}
-
-%{
-/* I believe the next rule is not ever matched.
-
- The '#line ' rule is un-cool, recognising a cpp directive inside hs source.
- Driver has now been modified to output `standard' {-# LINE ..-} pragmas
- where possible, so the lexer should now never see cpp directives
- like '# ' and '#line'.
-
- -- SOF
-
-<Code,GlaExt>^"# ".*{NL} {
- char tempf[FILENAME_SIZE];
- sscanf(yytext+1, "%d \"%[^\"]", &hslineno, tempf);
- new_filename(tempf);
- hsplineno = hslineno; hscolno = 0; hspcolno = 0;
- }
-
-<Code,GlaExt>^"#line ".*{NL} {
- char tempf[FILENAME_SIZE];
- sscanf(yytext+5, "%d \"%[^\"]", &hslineno, tempf);
- new_filename(tempf);
- hsplineno = hslineno; hscolno = 0; hspcolno = 0;
- }
-*/
-%}
-
-<Code,GlaExt>"{-# LINE ".*"-}"{NL} {
- /* partain: pragma-style line directive */
- char tempf[FILENAME_SIZE];
- sscanf(yytext+9, "%d \"%[^\"]", &hslineno, tempf);
- new_filename(tempf);
- hsplineno = hslineno; hscolno = 0; hspcolno = 0;
- }
-
-<Code,GlaExt>"{-#"{WS}*"INTERFACE" {
- PUSH_STATE(UserPragma);
- RETURN(INTERFACE_UPRAGMA);
- }
-<Code,GlaExt>"{-#"{WS}*"SPECIALI"[SZ]E {
- PUSH_STATE(UserPragma);
- RETURN(SPECIALISE_UPRAGMA);
- }
-<Code,GlaExt>"{-#"{WS}*"speciali"[sz]e {
- PUSH_STATE(UserPragma);
- RETURN(SPECIALISE_UPRAGMA);
- }
-<Code,GlaExt>"{-#"{WS}*"INLINE" {
- PUSH_STATE(UserPragma);
- RETURN(INLINE_UPRAGMA);
- }
-<Code,GlaExt>"{-#"{WS}*"RULES" {
- PUSH_STATE(Code); /* I'm not sure about this */
- RETURN(RULES_UPRAGMA);
- }
-<Code,GlaExt>"{-#"{WS}*"inline" {
- PUSH_STATE(UserPragma);
- RETURN(INLINE_UPRAGMA);
- }
-<Code,GlaExt>"{-#"{WS}*"NOINLINE" {
- PUSH_STATE(UserPragma);
- RETURN(NOINLINE_UPRAGMA);
- }
-<Code,GlaExt>"{-#"{WS}*"notInline" {
- PUSH_STATE(UserPragma);
- RETURN(NOINLINE_UPRAGMA);
- }
-<Code,GlaExt>"{-#"{WS}*"MAGIC_UNFOLDING" {
- PUSH_STATE(UserPragma);
- RETURN(MAGIC_UNFOLDING_UPRAGMA);
- }
-<Code,GlaExt>"{-#"{WS}*"GENERATE_SPECS" {
- /* these are handled by hscpp */
- nested_comments =1; comment_start = hsplineno;
- PUSH_STATE(Comment);
- }
-<Code,GlaExt>"{-#"{WS}*"OPTIONS" {
- /* these are for the driver! */
- nested_comments =1; comment_start = hsplineno;
- PUSH_STATE(Comment);
- }
-<Code,GlaExt>"{-#"{WS}*"SOURCE"{WS}*"#"?"-}" {
- /* these are used by `make depend' and the
- compiler to indicate that a module should
- be imported from source */
- nested_comments =1; comment_start = hsplineno;
- RETURN(SOURCE_UPRAGMA);
- }
-
-<Code,GlaExt>"{-#"{WS}*[a-zA-Z_]+ {
- fprintf(stderr, "%s:%d: Warning: Unrecognised pragma '",
- input_filename, hsplineno);
- format_string(stderr, (unsigned char *) yytext, yyleng);
- fputs("'\n", stderr);
- nested_comments = 1; comment_start = hsplineno;
- PUSH_STATE(Comment);
- }
-<Code,GlaExt,UserPragma>"#-}" { POP_STATE; RETURN(END_UPRAGMA); }
-
-%{
- /*
- * Haskell keywords. `scc' is actually a Glasgow extension, but it is
- * intentionally accepted as a keyword even for normal <Code>.
- */
-%}
-
-<Code,GlaExt>"case" { RETURN(CASE); }
-<Code,GlaExt>"class" { RETURN(CLASS); }
-<Code,GlaExt,UserPragma>"data" { RETURN(DATA); }
-<Code,GlaExt>"default" { RETURN(DEFAULT); }
-<Code,GlaExt>"deriving" { RETURN(DERIVING); }
-<Code,GlaExt>"do" { RETURN(DO); }
-<Code,GlaExt>"else" { RETURN(ELSE); }
-<Code,GlaExt>"if" { RETURN(IF); }
-<Code,GlaExt>"import" { RETURN(IMPORT); }
-<Code,GlaExt>"in" { RETURN(IN); }
-<Code,GlaExt>"infix" { RETURN(INFIX); }
-<Code,GlaExt>"infixl" { RETURN(INFIXL); }
-<Code,GlaExt>"infixr" { RETURN(INFIXR); }
-<Code,GlaExt,UserPragma>"instance" { RETURN(INSTANCE); }
-<Code,GlaExt>"let" { RETURN(LET); }
-<Code,GlaExt>"module" { RETURN(MODULE); }
-<Code,GlaExt>"newtype" { RETURN(NEWTYPE); }
-<Code,GlaExt>"of" { RETURN(OF); }
-<Code,GlaExt>"then" { RETURN(THEN); }
-<Code,GlaExt>"type" { RETURN(TYPE); }
-<Code,GlaExt>"where" { RETURN(WHERE); }
-
-<Code,GlaExt>"as" { RETURN(AS); }
-<Code,GlaExt>"hiding" { RETURN(HIDING); }
-<Code,GlaExt>"qualified" { RETURN(QUALIFIED); }
-
-<Code,GlaExt>"forall" { RETURN(FORALL); }
-
-<Code,GlaExt>"_scc_" { RETURN(SCC); }
-<GlaExt>"_ccall_" { RETURN(CCALL); }
-<GlaExt>"_ccall_GC_" { RETURN(CCALL_GC); }
-<GlaExt>"_casm_" { RETURN(CASM); }
-<GlaExt>"_casm_GC_" { RETURN(CASM_GC); }
-<GlaExt>"(#" { RETURN(OUNBOXPAREN); }
-<GlaExt>"#)" { RETURN(CUNBOXPAREN); }
-<GlaExt>"foreign" { RETURN(FOREIGN); }
-<GlaExt>"export" { RETURN(EXPORT); }
-<GlaExt>"label" { RETURN(LABEL); }
-<GlaExt>"unsafe" { RETURN(UNSAFE); }
-<GlaExt>"_stdcall" { RETURN(STDCALL); }
-<GlaExt>"_ccall" { RETURN(C_CALL); }
-<GlaExt>"_pascal" { RETURN(PASCAL); }
-<GlaExt>"stdcall" { RETURN(STDCALL); }
-<GlaExt>"ccall" { RETURN(C_CALL); }
-<GlaExt>"pascal" { RETURN(PASCAL); }
-<GlaExt>"dynamic" { RETURN(DYNAMIC); }
-
-%{
- /*
- * Haskell operators: special, reservedops and useful varsyms
- */
-%}
-
-<Code,GlaExt,UserPragma>"(" { RETURN(OPAREN); }
-<Code,GlaExt,UserPragma>")" { RETURN(CPAREN); }
-<Code,GlaExt,UserPragma>"[" { RETURN(OBRACK); }
-<Code,GlaExt,UserPragma>"]" { RETURN(CBRACK); }
-<Code,GlaExt>"{" { RETURN(OCURLY); }
-<Code,GlaExt>"}" { RETURN(CCURLY); }
-<Code,GlaExt,UserPragma>"," { RETURN(COMMA); }
-<Code,GlaExt>";" { RETURN(SEMI); }
-<Code,GlaExt>"`" { RETURN(BQUOTE); }
-
-<Code,GlaExt>"." { RETURN(DOT); }
-<Code,GlaExt>".." { RETURN(DOTDOT); }
-<Code,GlaExt,UserPragma>"::" { RETURN(DCOLON); }
-<Code,GlaExt,UserPragma>"=" { RETURN(EQUAL); }
-<Code,GlaExt>"\\" { RETURN(LAMBDA); }
-<Code,GlaExt>"|" { RETURN(VBAR); }
-<Code,GlaExt>"<-" { RETURN(LARROW); }
-<Code,GlaExt,UserPragma>"->" { RETURN(RARROW); }
-<Code,GlaExt>"-" { RETURN(MINUS); }
-<Code,GlaExt>"+" { RETURN(PLUS); }
-
-<Code,GlaExt,UserPragma>"=>" { RETURN(DARROW); }
-<Code,GlaExt>"@" { RETURN(AT); }
-<Code,GlaExt>"!" { RETURN(BANG); }
-<Code,GlaExt>"~" { RETURN(LAZY); }
-
-%{
- /*
- * Integers and (for Glasgow extensions) primitive integers. Note that
- * we pass all of the text on to the parser, because flex/C can't handle
- * arbitrary precision numbers.
- */
-%}
-
-<GlaExt>("-")?"0"[Oo]{O}+"#" { /* octal */
- yylval.uid = xstrndup(yytext, yyleng - 1);
- RETURN(INTPRIM);
- }
-<Code,GlaExt>"0"[Oo]{O}+ { /* octal */
- yylval.uid = xstrndup(yytext, yyleng);
- RETURN(INTEGER);
- }
-<GlaExt>("-")?"0"[Xx]{H}+"#" { /* hexadecimal */
- yylval.uid = xstrndup(yytext, yyleng - 1);
- RETURN(INTPRIM);
- }
-<Code,GlaExt>"0"[Xx]{H}+ { /* hexadecimal */
- yylval.uid = xstrndup(yytext, yyleng);
- RETURN(INTEGER);
- }
-<GlaExt>("-")?{N}"#" {
- yylval.uid = xstrndup(yytext, yyleng - 1);
- RETURN(INTPRIM);
- }
-<Code,GlaExt,UserPragma>{N} {
- yylval.uid = xstrndup(yytext, yyleng);
- RETURN(INTEGER);
- }
-
-%{
- /*
- * Floats and (for Glasgow extensions) primitive floats/doubles.
- */
-%}
-
-<GlaExt>("-")?{F}"##" {
- yylval.uid = xstrndup(yytext, yyleng - 2);
- RETURN(DOUBLEPRIM);
- }
-<GlaExt>("-")?{F}"#" {
- yylval.uid = xstrndup(yytext, yyleng - 1);
- RETURN(FLOATPRIM);
- }
-<Code,GlaExt>{F} {
- yylval.uid = xstrndup(yytext, yyleng);
- RETURN(FLOAT);
- }
-
-%{
- /*
- * Funky ``foo'' style C literals for Glasgow extensions
- */
-%}
-
-<GlaExt>"``"[^']+"''" {
- hsnewid(yytext + 2, yyleng - 4);
- RETURN(CLITLIT);
- }
-
-%{
- /*
- * Identifiers, both variables and operators. The trailing hash is allowed
- * for Glasgow extensions.
- */
-%}
-
-
-%{
-/* These SHOULDNAE work in "Code" (sigh) */
-%}
-<GlaExt,UserPragma>{Id}"#" {
- if (! nonstandardFlag) {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "Non-standard identifier (trailing `#'): %s\n", yytext);
- hsperror(errbuf);
- }
- hsnewid(yytext, yyleng);
- RETURN(isconstr(yytext) ? CONID : VARID);
- }
-<Code,GlaExt,UserPragma>{Id} {
- hsnewid(yytext, yyleng);
- RETURN(isconstr(yytext) ? CONID : VARID);
- }
-<Code,GlaExt,UserPragma>{SId} {
- if (is_commment(yytext,yyleng)) {
- int c;
- while ((c = input()) != '\n' && c != '\r' && c!= EOF )
- ;
- if (c != EOF)
- unput(c);
- } else {
- hsnewid(yytext, yyleng);
- RETURN(isconstr(yytext) ? CONSYM : VARSYM);
- }
- }
-<Code,GlaExt,UserPragma>{Mod}"."{Id}"#" {
- BOOLEAN is_constr;
- if (! nonstandardFlag) {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "Non-standard identifier (trailing `#'): %s\n", yytext);
- hsperror(errbuf);
- }
- is_constr = hsnewqid(yytext, yyleng);
- RETURN(is_constr ? QCONID : QVARID);
- }
-<Code,GlaExt,UserPragma>{Mod}"."{Id} {
- BOOLEAN is_constr = hsnewqid(yytext, yyleng);
- RETURN(is_constr ? QCONID : QVARID);
- }
-<Code,GlaExt,UserPragma>{Mod}"."{SId} {
- BOOLEAN is_constr = hsnewqid(yytext, yyleng);
- RETURN(is_constr ? QCONSYM : QVARSYM);
- }
-
-%{
- /* Why is `{Id}#` matched this way, and `{Id}` lexed as three tokens? --JSM */
-
- /* Because we can make the former well-behaved (we defined them).
-
- Sadly, the latter is defined by Haskell, which allows such
- la-la land constructs as `{-a 900-line comment-} foo`. (WDP 94/12)
- */
-%}
-
-<GlaExt,UserPragma>"`"{Id}"#`" {
- hsnewid(yytext + 1, yyleng - 2);
- RETURN(isconstr(yytext+1) ? CONSYM : VARSYM);
- }
-
-%{
- /*
- * Character literals. The first form is the quick form, for character
- * literals that don't contain backslashes. Literals with backslashes are
- * lexed through multiple rules. First, we match the open ' and as many
- * normal characters as possible. This puts us into the <Char> state, where
- * a backslash is legal. Then, we match the backslash and move into the
- * <CharEsc> state. When we drop out of <CharEsc>, we collect more normal
- * characters and the close '. We may end up with too many characters, but
- * this allows us to easily share the lex rules with strings. Excess characters
- * are ignored with a warning.
- */
-%}
-
-<GlaExt>'({CHAR}|"\"")"'#" {
- yylval.uhstring = installHstring(1, yytext+1);
- RETURN(CHARPRIM);
- }
-<Code,GlaExt>'({CHAR}|"\"")' {
- yylval.uhstring = installHstring(1, yytext+1);
- RETURN(CHAR);
- }
-<Code,GlaExt>'' {char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "'' is not a valid character (or string) literal\n");
- hsperror(errbuf);
- }
-<Code,GlaExt>'({CHAR}|"\"")* {
- hsmlcolno = hspcolno;
- cleartext();
- addtext(yytext+1, yyleng-1);
- PUSH_STATE(Char);
- }
-<Char>({CHAR}|"\"")*'# {
- unsigned length;
- char *text;
-
- addtext(yytext, yyleng - 2);
- text = fetchtext(&length);
-
- if (! nonstandardFlag) {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "`Char-hash' literals are non-standard: %s\n", text);
- hsperror(errbuf);
- }
-
- if (length > 1) {
- fprintf(stderr, "%s:%d:%d: Unboxed character literal '",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) text, length);
- fputs("' too long\n", stderr);
- hsperror("");
- }
- yylval.uhstring = installHstring(1, text);
- hspcolno = hsmlcolno;
- POP_STATE;
- RETURN(CHARPRIM);
- }
-<Char>({CHAR}|"\"")*' {
- unsigned length;
- char *text;
-
- addtext(yytext, yyleng - 1);
- text = fetchtext(&length);
-
- if (length > 1) {
- fprintf(stderr, "%s:%d:%d: Character literal '",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) text, length);
- fputs("' too long\n", stderr);
- hsperror("");
- }
- yylval.uhstring = installHstring(1, text);
- hspcolno = hsmlcolno;
- POP_STATE;
- RETURN(CHAR);
- }
-<Char>({CHAR}|"\"")+ { addtext(yytext, yyleng); }
-
-
-%{
- /*
- * String literals. The first form is the quick form, for string literals
- * that don't contain backslashes. Literals with backslashes are lexed
- * through multiple rules. First, we match the open " and as many normal
- * characters as possible. This puts us into the <String> state, where
- * a backslash is legal. Then, we match the backslash and move into the
- * <StringEsc> state. When we drop out of <StringEsc>, we collect more normal
- * characters, moving back and forth between <String> and <StringEsc> as more
- * backslashes are encountered. (We may even digress into <Comment> mode if we
- * find a comment in a gap between backslashes.) Finally, we read the last chunk
- * of normal characters and the close ".
- */
-%}
-
-<GlaExt>"\""({CHAR}|"'")*"\""# {
- yylval.uhstring = installHstring(yyleng-3, yytext+1);
- /* the -3 accounts for the " on front, "# on the end */
- RETURN(STRINGPRIM);
- }
-<Code,GlaExt>"\""({CHAR}|"'")*"\"" {
- yylval.uhstring = installHstring(yyleng-2, yytext+1);
- RETURN(STRING);
- }
-<Code,GlaExt>"\""({CHAR}|"'")* {
- hsmlcolno = hspcolno;
- cleartext();
- addtext(yytext+1, yyleng-1);
- PUSH_STATE(String);
- }
-<String>({CHAR}|"'")*"\"#" {
- unsigned length;
- char *text;
-
- addtext(yytext, yyleng-2);
- text = fetchtext(&length);
-
- if (! nonstandardFlag) {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "`String-hash' literals are non-standard: %s\n", text);
- hsperror(errbuf);
- }
-
- yylval.uhstring = installHstring(length, text);
- hspcolno = hsmlcolno;
- POP_STATE;
- RETURN(STRINGPRIM);
- }
-<String>({CHAR}|"'")*"\"" {
- unsigned length;
- char *text;
-
- addtext(yytext, yyleng-1);
- text = fetchtext(&length);
-
- yylval.uhstring = installHstring(length, text);
- hspcolno = hsmlcolno;
- POP_STATE;
- RETURN(STRING);
- }
-<String>({CHAR}|"'")+ { addtext(yytext, yyleng); }
-
-%{
- /*
- * Character and string escapes are roughly the same, but strings have the
- * extra `\&' sequence which is not allowed for characters. Also, comments
- * are allowed in the <StringEsc> state. (See the comment section much
- * further down.)
- *
- * NB: Backslashes and tabs are stored in strings as themselves.
- * But if we print them (in printtree.c), they must go out as
- * "\\\\" and "\\t" respectively. (This is because of the bogus
- * intermediate format that the parser produces. It uses '\t' fpr end of
- * string, so it needs to be able to escape tabs, which means that it
- * also needs to be able to escape the escape character ('\\'). Sigh.
- */
-%}
-
-<Char>\\ { PUSH_STATE(CharEsc); }
-<String>\\& /* Ignore */ ;
-<String>\\ { PUSH_STATE(StringEsc); noGap = TRUE; }
-
-<CharEsc>\\ { addchar(*yytext); POP_STATE; }
-<StringEsc>\\ { if (noGap) { addchar(*yytext); } POP_STATE; }
-
-%{
-/*
- Not 100% correct, tokenizes "foo \ --<>--
- \ bar"
-
- as "foo bar", but this is not correct as per Haskell 98 report and its
- maximal munch rule for "--"-style comments.
-
- For the moment, not deemed worthy to fix.
-*/
-%}
-<StringEsc>"--"[^\n\r]*{NL}?{WS}* { noGap=FALSE; }
-
-<CharEsc,StringEsc>["'] { addchar(*yytext); POP_STATE; }
-<CharEsc,StringEsc>NUL { addchar('\000'); POP_STATE; }
-<CharEsc,StringEsc>SOH { addchar('\001'); POP_STATE; }
-<CharEsc,StringEsc>STX { addchar('\002'); POP_STATE; }
-<CharEsc,StringEsc>ETX { addchar('\003'); POP_STATE; }
-<CharEsc,StringEsc>EOT { addchar('\004'); POP_STATE; }
-<CharEsc,StringEsc>ENQ { addchar('\005'); POP_STATE; }
-<CharEsc,StringEsc>ACK { addchar('\006'); POP_STATE; }
-<CharEsc,StringEsc>BEL |
-<CharEsc,StringEsc>a { addchar('\007'); POP_STATE; }
-<CharEsc,StringEsc>BS |
-<CharEsc,StringEsc>b { addchar('\010'); POP_STATE; }
-<CharEsc,StringEsc>HT |
-<CharEsc,StringEsc>t { addchar('\011'); POP_STATE; }
-<CharEsc,StringEsc>LF |
-<CharEsc,StringEsc>n { addchar('\012'); POP_STATE; }
-<CharEsc,StringEsc>VT |
-<CharEsc,StringEsc>v { addchar('\013'); POP_STATE; }
-<CharEsc,StringEsc>FF |
-<CharEsc,StringEsc>f { addchar('\014'); POP_STATE; }
-<CharEsc,StringEsc>CR |
-<CharEsc,StringEsc>r { addchar('\015'); POP_STATE; }
-<CharEsc,StringEsc>SO { addchar('\016'); POP_STATE; }
-<CharEsc,StringEsc>SI { addchar('\017'); POP_STATE; }
-<CharEsc,StringEsc>DLE { addchar('\020'); POP_STATE; }
-<CharEsc,StringEsc>DC1 { addchar('\021'); POP_STATE; }
-<CharEsc,StringEsc>DC2 { addchar('\022'); POP_STATE; }
-<CharEsc,StringEsc>DC3 { addchar('\023'); POP_STATE; }
-<CharEsc,StringEsc>DC4 { addchar('\024'); POP_STATE; }
-<CharEsc,StringEsc>NAK { addchar('\025'); POP_STATE; }
-<CharEsc,StringEsc>SYN { addchar('\026'); POP_STATE; }
-<CharEsc,StringEsc>ETB { addchar('\027'); POP_STATE; }
-<CharEsc,StringEsc>CAN { addchar('\030'); POP_STATE; }
-<CharEsc,StringEsc>EM { addchar('\031'); POP_STATE; }
-<CharEsc,StringEsc>SUB { addchar('\032'); POP_STATE; }
-<CharEsc,StringEsc>ESC { addchar('\033'); POP_STATE; }
-<CharEsc,StringEsc>FS { addchar('\034'); POP_STATE; }
-<CharEsc,StringEsc>GS { addchar('\035'); POP_STATE; }
-<CharEsc,StringEsc>RS { addchar('\036'); POP_STATE; }
-<CharEsc,StringEsc>US { addchar('\037'); POP_STATE; }
-<CharEsc,StringEsc>SP { addchar('\040'); POP_STATE; }
-<CharEsc,StringEsc>DEL { addchar('\177'); POP_STATE; }
-<CharEsc,StringEsc>"^"{CNTRL} { char c = yytext[1] - '@'; addchar(c); POP_STATE; }
-<CharEsc,StringEsc>{D}+ {
- int i = strtol(yytext, NULL, 10);
- if (i < NCHARS) {
- addchar((char) i);
- } else {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "Numeric escape \"\\%s\" out of range\n",
- yytext);
- hsperror(errbuf);
- }
- POP_STATE;
- }
-<CharEsc,StringEsc>o{O}+ {
- int i = strtol(yytext + 1, NULL, 8);
- if (i < NCHARS) {
- addchar((char) i);
- } else {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "Numeric escape \"\\%s\" out of range\n",
- yytext);
- hsperror(errbuf);
- }
- POP_STATE;
- }
-<CharEsc,StringEsc>x{H}+ {
- int i = strtol(yytext + 1, NULL, 16);
- if (i < NCHARS) {
- addchar((char) i);
- } else {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "Numeric escape \"\\%s\" out of range\n",
- yytext);
- hsperror(errbuf);
- }
- POP_STATE;
- }
-
-
-%{
- /*
- * Nested comments. The major complication here is in trying to match the
- * longest lexemes possible, for better performance. (See the flex document.)
- * That's why the rules look so bizarre.
- */
-%}
-
-<Code,GlaExt,UserPragma,StringEsc>"{-" {
- noGap = FALSE; nested_comments = 1; comment_start = hsplineno; PUSH_STATE(Comment);
- }
-
-<Comment>[^-{]* |
-<Comment>"-"+[^-{}]+ |
-<Comment>"{"+[^-{}]+ ;
-<Comment>"{-" { nested_comments++; }
-<Comment>"-}" { if (--nested_comments == 0) POP_STATE; }
-<Comment>(.|\n) ;
-
-
-%{
- /*
- * Illegal characters. This used to be a single rule, but we might as well
- * pass on as much information as we have, so now we indicate our state in
- * the error message.
- */
-%}
-
-<INITIAL,Code,GlaExt,UserPragma>(.|\n) {
- fprintf(stderr, "%s:%d:%d: Illegal character: `",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) yytext, 1);
- fputs("'\n", stderr);
- hsperror("");
- }
-<Char>(.|\n) {
- fprintf(stderr, "%s:%d:%d: Illegal character: `",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) yytext, 1);
- fputs("' in a character literal\n", stderr);
- hsperror("");
- }
-<CharEsc>(.|\n) {
- fprintf(stderr, "%s:%d:%d: Illegal character escape: `\\",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) yytext, 1);
- fputs("'\n", stderr);
- hsperror("");
- }
-<String>(.|\n) { if (nonstandardFlag) {
- addtext(yytext, yyleng);
- } else {
- fprintf(stderr, "%s:%d:%d: Illegal character: `",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) yytext, 1);
- fputs("' in a string literal\n", stderr);
- hsperror("");
- }
- }
-<StringEsc>(.|\n) {
- if (noGap) {
- fprintf(stderr, "%s:%d:%d: Illegal string escape: `\\",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) yytext, 1);
- fputs("'\n", stderr);
- hsperror("");
- } else {
- fprintf(stderr, "%s:%d:%d: Illegal character: `",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) yytext, 1);
- fputs("' in a string gap\n", stderr);
- hsperror("");
- }
- }
-
-%{
- /*
- * End of file. In any sub-state, this is an error. However, for the primary
- * <Code> and <GlaExt> states, this is perfectly normal. We just return an EOF
- * and let the yylex() wrapper deal with whatever has to be done next (e.g.
- * adding virtual close curlies, or closing an interface and returning to the
- * primary source file.
- *
- * Note that flex does not call YY_USER_ACTION for <<EOF>> rules. Hence the
- * line/column advancement has to be done by hand.
- */
-%}
-
-<Char,CharEsc><<EOF>> {
- hsplineno = hslineno; hspcolno = hscolno;
- hsperror("unterminated character literal");
- }
-<Comment><<EOF>> {
- char errbuf[ERR_BUF_SIZE];
- hsplineno = hslineno; hspcolno = hscolno;
- sprintf(errbuf, "unterminated comment (which started on line %d)", comment_start);
- hsperror(errbuf);
- }
-<String,StringEsc><<EOF>> {
- hsplineno = hslineno; hspcolno = hscolno;
- hsperror("unterminated string literal");
- }
-<UserPragma><<EOF>> {
- hsplineno = hslineno; hspcolno = hscolno;
- hsperror("unterminated user-specified pragma");
- }
-<Code,GlaExt><<EOF>> { hsplineno = hslineno; hspcolno = hscolno; return(EOF); }
-
-%%
-
-/**********************************************************************
-* *
-* *
-* YACC/LEX Initialisation etc. *
-* *
-* *
-**********************************************************************/
-
-/*
- We initialise input_filename to "<stdin>".
- This allows unnamed sources to be piped into the parser.
-*/
-
-void
-yyinit(void)
-{
- input_filename = xstrdup("<stdin>");
-
- /* We must initialize the input buffer _now_, because we call
- setyyin _before_ calling yylex for the first time! */
- yy_switch_to_buffer(yy_create_buffer(stdin, YY_BUF_SIZE));
-
- if (nonstandardFlag)
- PUSH_STATE(GlaExt);
- else
- PUSH_STATE(Code);
-}
-
-static void
-new_filename(char *f) /* This looks pretty dodgy to me (WDP) */
-{
- if (input_filename != NULL)
- free(input_filename);
- input_filename = xstrdup(f);
-}
-
-/**********************************************************************
-* *
-* *
-* Layout Processing *
-* *
-* *
-**********************************************************************/
-
-/*
- The following section deals with Haskell Layout conventions
- forcing insertion of ; or } as appropriate
-*/
-
-#ifdef HSP_DEBUG
-#define LAYOUT_DEBUG
-#endif
-
-
-static BOOLEAN
-hsshouldindent(void)
-{
- return (!forgetindent && INDENTON);
-}
-
-
-/* Enter new context and set new indentation level */
-void
-hssetindent(void)
-{
-#ifdef LAYOUT_DEBUG
- fprintf(stderr, "hssetindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT);
-#endif
-
- /*
- * partain: first chk that new indent won't be less than current one; this code
- * doesn't make sense to me; hscolno tells the position of the _end_ of the
- * current token; what that has to do with indenting, I don't know.
- */
-
-
- if (hscolno - 1 <= INDENTPT) {
- if (INDENTPT == -1)
- return; /* Empty input OK for Haskell 1.1 */
- else {
- char errbuf[ERR_BUF_SIZE];
-
- sprintf(errbuf, "Layout error -- indentation should be > %d cols", INDENTPT);
- hsperror(errbuf);
- }
- }
- hsentercontext((hspcolno << 1) | 1);
-}
-
-
-/* Enter a new context without changing the indentation level */
-void
-hsincindent(void)
-{
-#ifdef LAYOUT_DEBUG
- fprintf(stderr, "hsincindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT);
-#endif
- hsentercontext(indenttab[icontexts] & ~1);
-}
-
-
-/* Turn off indentation processing, usually because an explicit "{" has been seen */
-void
-hsindentoff(void)
-{
- forgetindent = TRUE;
-}
-
-
-/* Enter a new layout context. */
-static void
-hsentercontext(int indent)
-{
- /* Enter new context and set indentation as specified */
- if (++icontexts >= MAX_CONTEXTS) {
- char errbuf[ERR_BUF_SIZE];
-
- sprintf(errbuf, "`wheres' and `cases' nested too deeply (>%d)", MAX_CONTEXTS - 1);
- hsperror(errbuf);
- }
- forgetindent = FALSE;
- indenttab[icontexts] = indent;
-#ifdef LAYOUT_DEBUG
- fprintf(stderr, "hsentercontext:indent=%d,hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", indent, hscolno, hspcolno, icontexts, INDENTPT);
-#endif
-}
-
-
-/* Exit a layout context */
-void
-hsendindent(void)
-{
- --icontexts;
-#ifdef LAYOUT_DEBUG
- fprintf(stderr, "hsendindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT);
-#endif
-}
-
-/*
- * Return checks the indentation level and returns ;, } or the specified token.
- */
-static int
-Return(int tok)
-{
-#ifdef HSP_DEBUG
- extern int yyleng;
-#endif
- if (hsshouldindent()) {
- if (hspcolno < INDENTPT) {
-#ifdef HSP_DEBUG
- fprintf(stderr, "inserted '}' before %d (%d:%d:%d:%d)\n", tok, hspcolno, hscolno, yyleng, INDENTPT);
-#endif
- hssttok = tok;
- return (VCCURLY);
- } else if (hspcolno == INDENTPT) {
-#ifdef HSP_DEBUG
- fprintf(stderr, "inserted ';' before %d (%d:%d)\n", tok, hspcolno, INDENTPT);
-#endif
- hssttok = -tok;
- return (SEMI);
- }
- }
-
- hssttok = -1;
-#ifdef HSP_DEBUG
- fprintf(stderr, "returning %d (%d:%d)\n", tok, hspcolno, INDENTPT);
-#endif
- return (tok);
-}
-
-
-/*
- * Redefine yylex to check for stacked tokens, yylex1() is the original yylex()
- */
-int
-yylex()
-{
- int tok;
- static BOOLEAN eof = FALSE;
-
- if (!eof) {
- if (hssttok != -1) {
- if (hssttok < 0) {
- tok = -hssttok;
- hssttok = -1;
- return tok;
- }
- RETURN(hssttok);
- } else {
- endlineno = hslineno;
- if ((tok = yylex1()) != EOF)
- return tok;
- else
- eof = TRUE;
- }
- }
- if (icontexts > icontexts_save) {
- if (INDENTON) {
- eof = TRUE;
- indenttab[icontexts] = 0;
- return (VCCURLY);
- } else
- hsperror("missing '}' at end of file");
- } else if (hsbuf_save != NULL) {
- fclose(yyin);
- yy_delete_buffer(YY_CURRENT_BUFFER);
- yy_switch_to_buffer(hsbuf_save);
- hsbuf_save = NULL;
- new_filename(filename_save);
- free(filename_save);
- hslineno = hslineno_save;
- hsplineno = hsplineno_save;
- hscolno = hscolno_save;
- hspcolno = hspcolno_save;
- etags = etags_save;
- icontexts = icontexts_save - 1;
- icontexts_save = 0;
-#ifdef HSP_DEBUG
- fprintf(stderr, "finished reading interface (%d:%d:%d)\n", hscolno, hspcolno, INDENTPT);
-#endif
- eof = FALSE;
-
- /* RETURN(LEOF); */
- hsperror("No longer using yacc to parse interface files");
-
- } else {
- yyterminate();
- }
- abort(); /* should never get here! */
- return(0);
-}
-
-/**********************************************************************
-* *
-* *
-* Input Processing for Interfaces -- Not currently used !!! *
-* *
-* *
-**********************************************************************/
-
-/* setyyin(file) open file as new lex input buffer */
-extern FILE *yyin;
-
-void
-setyyin(char *file)
-{
- hsbuf_save = YY_CURRENT_BUFFER;
- if ((yyin = fopen(file, "r")) == NULL) {
- char errbuf[ERR_BUF_SIZE];
-
- sprintf(errbuf, "can't read \"%-.50s\"", file);
- hsperror(errbuf);
- }
- yy_switch_to_buffer(yy_create_buffer(yyin, YY_BUF_SIZE));
-
- hslineno_save = hslineno;
- hsplineno_save = hsplineno;
- hslineno = hsplineno = 1;
-
- filename_save = input_filename;
- input_filename = NULL;
- new_filename(file);
- hscolno_save = hscolno;
- hspcolno_save = hspcolno;
- hscolno = hspcolno = 0;
- etags_save = etags; /* do not do "etags" stuff in interfaces */
- etags = 0; /* We remember whether we are doing it in
- the module, so we can restore it later [WDP 94/09] */
- hsentercontext(-1); /* partain: changed this from 0 */
- icontexts_save = icontexts;
-#ifdef HSP_DEBUG
- fprintf(stderr, "reading %s (%d:%d:%d)\n", input_filename, hscolno_save, hspcolno_save, INDENTPT);
-#endif
-}
-
-static void
-layout_input(char *text, int len)
-{
-#ifdef HSP_DEBUG
- fprintf(stderr, "Scanning \"%s\"\n", text);
-#endif
-
- hsplineno = hslineno;
- hspcolno = hscolno;
-
- while (len-- > 0) {
- switch (*text++) {
- case '\n':
- case '\r':
- case '\f':
- hslineno++;
- hscolno = 0;
- break;
- case '\t':
- hscolno += 8 - (hscolno % 8); /* Tabs stops are 8 columns apart */
- break;
- case '\v':
- break;
- default:
- ++hscolno;
- break;
- }
- }
-}
-
-void
-setstartlineno(void)
-{
- startlineno = hsplineno;
-
- if (modulelineno == 0) {
- modulelineno = startlineno;
- }
-
-#if 1/*etags*/
-#else
- if (etags)
- fprintf(stderr,"%u\tsetstartlineno (col %u)\n",startlineno,hscolno);
-#endif
-}
-
-/**********************************************************************
-* *
-* *
-* Text Caching *
-* *
-* *
-**********************************************************************/
-
-#define CACHE_SIZE YY_BUF_SIZE
-
-static struct {
- unsigned allocated;
- unsigned next;
- char *text;
-} textcache = { 0, 0, NULL };
-
-static void
-cleartext(void)
-{
-/* fprintf(stderr, "cleartext\n"); */
- textcache.next = 0;
- if (textcache.allocated == 0) {
- textcache.allocated = CACHE_SIZE;
- textcache.text = xmalloc(CACHE_SIZE);
- }
-}
-
-static void
-addtext(char *text, unsigned length)
-{
-/* fprintf(stderr, "addtext: %d %s\n", length, text); */
-
- if (length == 0)
- return;
-
- if (textcache.next + length + 1 >= textcache.allocated) {
- textcache.allocated += length + CACHE_SIZE;
- textcache.text = xrealloc(textcache.text, textcache.allocated);
- }
- bcopy(text, textcache.text + textcache.next, length);
- textcache.next += length;
-}
-
-static void
-addchar(char c)
-{
-/* fprintf(stderr, "addchar: %c\n", c); */
-
- if (textcache.next + 2 >= textcache.allocated) {
- textcache.allocated += CACHE_SIZE;
- textcache.text = xrealloc(textcache.text, textcache.allocated);
- }
- textcache.text[textcache.next++] = c;
-}
-
-static char *
-fetchtext(unsigned *length)
-{
-/* fprintf(stderr, "fetchtext: %d\n", textcache.next); */
-
- *length = textcache.next;
- textcache.text[textcache.next] = '\0';
- return textcache.text;
-}
-
-/**********************************************************************
-* *
-* *
-* Identifier Processing *
-* *
-* *
-**********************************************************************/
-
-/*
- hsnewid Enters an id of length n into the symbol table.
-*/
-
-static void
-hsnewid(char *name, int length)
-{
- char save = name[length];
-
- name[length] = '\0';
- yylval.uid = installid(name);
- name[length] = save;
-}
-
-BOOLEAN
-hsnewqid(char *name, int length)
-{
- char* dot;
- char save = name[length];
- name[length] = '\0';
-
- dot = strchr(name, '.');
- *dot = '\0';
- yylval.uqid = mkaqual(installid(name),installid(dot+1));
- *dot = '.';
- name[length] = save;
-
- return isconstr(dot+1);
-}
-
-static
-BOOLEAN
-is_commment(char* lexeme, int len)
-{
- char* ptr;
- int i;
-
- if (len < 2) {
- return FALSE;
- }
-
- for(i=0;i<len;i++) {
- if (lexeme[i] != '-') return FALSE;
- }
- return TRUE;
-}
-
+++ /dev/null
-/**************************************************************************
-* File: hsparser.y *
-* *
-* Author: Maria M. Gutierrez *
-* Modified by: Kevin Hammond *
-* Last date revised: December 13 1991. KH. *
-* Modification: Haskell 1.1 Syntax. *
-* *
-* *
-* Description: This file contains the LALR(1) grammar for Haskell. *
-* *
-* Entry Point: module *
-* *
-* Problems: None known. *
-* *
-* *
-* LALR(1) Syntax for Haskell 1.2 *
-* *
-**************************************************************************/
-
-
-%{
-#ifdef HSP_DEBUG
-# define YYDEBUG 1
-#endif
-
-#include <stdio.h>
-#include <ctype.h>
-#include <string.h>
-#include "hspincl.h"
-#include "constants.h"
-#include "utils.h"
-
-/**********************************************************************
-* *
-* *
-* Imported Variables and Functions *
-* *
-* *
-**********************************************************************/
-
-static BOOLEAN expect_ccurly = FALSE; /* Used to signal that a CCURLY could be inserted here */
-extern BOOLEAN etags;
-
-extern char *input_filename;
-static char *the_module_name;
-static maybe module_exports;
-
-extern list Lnil;
-extern list reverse_list();
-extern tree root;
-
-/* For FN, SAMEFN macros */
-extern qid fns[];
-extern BOOLEAN samefn[];
-extern short icontexts;
-
-/* Line Numbers */
-extern int hsplineno, hspcolno;
-extern int modulelineno;
-extern int startlineno;
-extern int endlineno;
-
-/* Local helper functions */
-static void checkinpat PROTO((void));
-static void punningNowIllegal PROTO((void));
-
-
-/**********************************************************************
-* *
-* *
-* Fixity and Precedence Declarations *
-* *
-* *
-**********************************************************************/
-
-static int Fixity = 0, Precedence = 0;
-
-char *ineg PROTO((char *));
-
-long source_version = 0;
-BOOLEAN pat_check=TRUE;
-
-%}
-
-%union {
- tree utree;
- list ulist;
- ttype uttype;
- constr uconstr;
- binding ubinding;
- match umatch;
- gdexp ugdexp;
- grhsb ugrhsb;
- entidt uentid;
- id uid;
- qid uqid;
- rulevar urulevar;
- literal uliteral;
- maybe umaybe;
- either ueither;
- long ulong;
- float ufloat;
- char *ustring;
- hstring uhstring;
-}
-
-
-/**********************************************************************
-* *
-* *
-* These are lexemes. *
-* *
-* *
-**********************************************************************/
-
-
-%token VARID CONID QVARID QCONID
- VARSYM CONSYM QVARSYM QCONSYM
-
-%token INTEGER FLOAT CHAR STRING
- CHARPRIM STRINGPRIM INTPRIM FLOATPRIM
- DOUBLEPRIM CLITLIT
-
-
-
-/**********************************************************************
-* *
-* *
-* Special Symbols *
-* *
-* *
-**********************************************************************/
-
-%token OCURLY CCURLY VCCURLY
-%token COMMA SEMI OBRACK CBRACK
-%token BQUOTE OPAREN CPAREN
-%token OUNBOXPAREN CUNBOXPAREN
-
-
-/**********************************************************************
-* *
-* *
-* Reserved Operators *
-* *
-* *
-**********************************************************************/
-
-%token DOTDOT DCOLON EQUAL LAMBDA
-%token VBAR RARROW LARROW
-%token AT LAZY DARROW
-
-
-/**********************************************************************
-* *
-* *
-* Reserved Identifiers *
-* *
-* *
-**********************************************************************/
-
-%token CASE CLASS DATA
-%token DEFAULT DERIVING DO
-%token ELSE IF IMPORT
-%token IN INFIX INFIXL
-%token INFIXR INSTANCE LET
-%token MODULE NEWTYPE OF
-%token THEN TYPE WHERE
-
-%token SCC
-%token CCALL CCALL_GC CASM CASM_GC
-
-%token DOT FORALL
-%token EXPORT UNSAFE STDCALL C_CALL LABEL
-%token PASCAL FASTCALL FOREIGN DYNAMIC
-
-/**********************************************************************
-* *
-* *
-* Special symbols/identifiers which need to be recognised *
-* *
-* *
-**********************************************************************/
-
-%token MINUS BANG PLUS
-%token AS HIDING QUALIFIED
-
-
-/**********************************************************************
-* *
-* *
-* Special Symbols for the Lexer *
-* *
-* *
-**********************************************************************/
-
-%token INTERFACE_UPRAGMA SPECIALISE_UPRAGMA
-%token INLINE_UPRAGMA NOINLINE_UPRAGMA MAGIC_UNFOLDING_UPRAGMA RULES_UPRAGMA
-%token END_UPRAGMA
-%token SOURCE_UPRAGMA
-
-/**********************************************************************
-* *
-* *
-* Precedences of the various tokens *
-* *
-* *
-**********************************************************************/
-
-
-%left CASE LET IN
- IF ELSE LAMBDA
- SCC CASM CCALL CASM_GC CCALL_GC
-
-%left VARSYM CONSYM QVARSYM QCONSYM
- MINUS BQUOTE BANG DARROW PLUS
-
-%left DCOLON
-
-%left SEMI COMMA
-
-%left OCURLY OBRACK OPAREN
-
-%left EQUAL
-
-%right RARROW
-
-/**********************************************************************
-* *
-* *
-* Type Declarations *
-* *
-* *
-**********************************************************************/
-
-
-%type <ulist> caserest alts quals
- dorest stmts stmt
- rbinds rbinds1 rpats rpats1 list_exps list_rest
- qvarsk qvars_list
- constrs fields conargatypes
- tautypes polytypes atypes
- pats simple_context simple_context_list
- export_list enames
- import_list inames
- impdecls maybeimpdecls impdecl
- dtyclses dtycls_list
- gdrhs gdpat
- lampats aexps gd texps
- var_list constr_context forall
- rule_forall rule_var_list
-
-%type <umatch> alt
-
-%type <ugrhsb> valrhs altrhs
-
-%type <umaybe> maybeexports impspec deriving
- ext_name opt_sig opt_asig
-
-%type <uliteral> lit_constant
-
-%type <utree> exp oexp dexp kexp fexp aexp rbind
- expL oexpL kexpL expLno oexpLno dexpLno kexpLno
- funlhs funlhs1 funlhs2 funlhs3 qual leftexp
- pat dpat cpat bpat apat apatc conpat rpat
- patk bpatk apatck conpatk
-
-
-%type <urulevar> rule_var
-
-%type <uid> MINUS PLUS DARROW AS LAZY
- VARID CONID VARSYM CONSYM
- var con varop conop op
- vark varid varsym varsym_nominus
- tycon modid ccallid tyvar
- varid_noforall
-
-%type <uqid> QVARID QCONID QVARSYM QCONSYM
- qvarid qconid qvarsym qconsym
- qvar qcon qvarop qconop qop
- qvark qconk qtycon qtycls
- gcon gconk gtycon itycon qop1 qvarop1
- ename iname
-
-%type <ubinding> topdecl topdecls letdecls
- typed datad newtd classd instd defaultd foreignd
- decl decls non_empty_decls fixdecl fix_op fix_ops valdef
- maybe_where where_body
- ruled rules rule
-
-%type <uttype> polytype
- conargatype conapptype
- tautype
- apptype
- atype polyatype
- simple_con_app simple_con_app1 inst_type
-
-%type <uconstr> constr constr_after_context field constr1
-
-%type <ustring> FLOAT INTEGER INTPRIM
- FLOATPRIM DOUBLEPRIM CLITLIT
-
-%type <uhstring> STRING STRINGPRIM CHAR CHARPRIM
-
-%type <uentid> export import
-
-%type <ulong> commas importkey get_line_no
- unsafe_flag callconv
-
-
-/**********************************************************************
-* *
-* *
-* Start Symbol for the Parser *
-* *
-* *
-**********************************************************************/
-
-%start module
-
-%%
-module : modulekey modid maybeexports
- {
- modulelineno = startlineno;
- the_module_name = $2;
- module_exports = $3;
- }
- WHERE body
- | {
- modulelineno = 0;
- the_module_name = install_literal("Main");
- module_exports = mknothing();
- }
- body
- ;
-
-body : ocurly { setstartlineno(); } main_body ccurly
- | vocurly main_body vccurly
- ;
-
-main_body : interface_pragma maybeimpdecls topdecls
- {
- root = mkhmodule(the_module_name, $2, module_exports,
- $3, source_version,modulelineno);
- }
- | interface_pragma impdecls
- {
- root = mkhmodule(the_module_name, $2, module_exports,
- mknullbind(), source_version, modulelineno);
- }
-
-interface_pragma : /* empty */
- | INTERFACE_UPRAGMA INTEGER END_UPRAGMA SEMI
- {
- source_version = atoi($2);
- }
- ;
-
-maybeexports : /* empty */ { $$ = mknothing(); }
- | OPAREN CPAREN { $$ = mkjust(Lnil); }
- | OPAREN export_list CPAREN { $$ = mkjust($2); }
- | OPAREN export_list COMMA CPAREN { $$ = mkjust($2); }
- ;
-
-export_list:
- export { $$ = lsing($1); }
- | export_list COMMA export { $$ = lapp($1, $3); }
- ;
-
-export : qvar { $$ = mkentid($1); }
- | gtycon { $$ = mkenttype($1); }
- | gtycon OPAREN DOTDOT CPAREN { $$ = mkenttypeall($1); }
- | gtycon OPAREN CPAREN { $$ = mkenttypenamed($1,Lnil); }
- | gtycon OPAREN enames CPAREN { $$ = mkenttypenamed($1,$3); }
- | MODULE modid { $$ = mkentmod($2); }
- ;
-
-enames : ename { $$ = lsing($1); }
- | enames COMMA ename { $$ = lapp($1,$3); }
- ;
-ename : qvar
- | gcon
- ;
-
-
-maybeimpdecls : /* empty */ { $$ = Lnil; }
- | impdecls SEMI { $$ = $1; }
- ;
-
-impdecls: impdecl { $$ = $1; }
- | impdecls SEMI impdecl { $$ = lconc($1,$3); }
- ;
-
-
-impdecl : importkey modid impspec
- { $$ = lsing(mkimport($2,0,mknothing(),$3,$1,startlineno)); }
- | importkey QUALIFIED modid impspec
- { $$ = lsing(mkimport($3,1,mknothing(),$4,$1,startlineno)); }
- | importkey QUALIFIED modid AS modid impspec
- { $$ = lsing(mkimport($3,1,mkjust($5),$6,$1,startlineno)); }
- | importkey modid AS modid impspec
- { $$ = lsing(mkimport($3,1,mkjust($4),$5,$1,startlineno)); }
- ;
-
-impspec : /* empty */ { $$ = mknothing(); }
- | OPAREN CPAREN { $$ = mkjust(mkleft(Lnil)); }
- | OPAREN import_list CPAREN { $$ = mkjust(mkleft($2)); }
- | OPAREN import_list COMMA CPAREN { $$ = mkjust(mkleft($2)); }
- | HIDING OPAREN CPAREN { $$ = mkjust(mkright(Lnil)); }
- | HIDING OPAREN import_list CPAREN { $$ = mkjust(mkright($3)); }
- | HIDING OPAREN import_list COMMA CPAREN { $$ = mkjust(mkright($3)); }
- ;
-
-import_list:
- import { $$ = lsing($1); }
- | import_list COMMA import { $$ = lapp($1, $3); }
- ;
-
-import : var { $$ = mkentid(mknoqual($1)); }
- | itycon { $$ = mkenttype($1); }
- | itycon OPAREN DOTDOT CPAREN { $$ = mkenttypeall($1); }
- | itycon OPAREN CPAREN { $$ = mkenttypenamed($1,Lnil);}
- | itycon OPAREN inames CPAREN { $$ = mkenttypenamed($1,$3); }
- ;
-
-itycon : tycon { $$ = mknoqual($1); }
- | OBRACK CBRACK { $$ = creategid(NILGID); }
- | OPAREN CPAREN { $$ = creategid(UNITGID); }
- | OPAREN commas CPAREN { $$ = creategid($2); }
- ;
-
-inames : iname { $$ = lsing($1); }
- | inames COMMA iname { $$ = lapp($1,$3); }
- ;
-iname : var { $$ = mknoqual($1); }
- | con { $$ = mknoqual($1); }
- ;
-
-/**********************************************************************
-* *
-* *
-* Fixes and Decls etc *
-* *
-* *
-**********************************************************************/
-
-topdecls : /* empty */ { $$ = mknullbind(); }
- | topdecl
- | topdecls SEMI { $$ = $1; }
- | topdecls SEMI topdecl
- {
- if($1 != NULL)
- if($3 != NULL)
- if(SAMEFN)
- {
- extendfn($1,$3);
- $$ = $1;
- }
- else
- $$ = mkabind($1,$3);
- else
- $$ = $1;
- else
- $$ = $3;
- SAMEFN = 0;
- }
- ;
-
-topdecl : typed { $$ = $1; FN = NULL; SAMEFN = 0; }
- | datad { $$ = $1; FN = NULL; SAMEFN = 0; }
- | newtd { $$ = $1; FN = NULL; SAMEFN = 0; }
- | classd { $$ = $1; FN = NULL; SAMEFN = 0; }
- | instd { $$ = $1; FN = NULL; SAMEFN = 0; }
- | defaultd { $$ = $1; FN = NULL; SAMEFN = 0; }
- | foreignd { $$ = $1; FN = NULL; SAMEFN = 0; }
- | ruled { $$ = $1; FN = NULL; SAMEFN = 0; }
- | decl { $$ = $1; }
- ;
-
-/* *********************************************************** */
-/* Transformation rules */
-
-ruled : RULES_UPRAGMA rules END_UPRAGMA { $$ = $2; }
- ;
-
-rules : /* empty */ { $$ = mknullbind(); }
- | rule { $$ = $1; }
- | rule SEMI rules { $$ = mkabind($1,$3); }
- | SEMI rules { $$ = $2; }
- ;
-
-rule : STRING rule_forall fexp
- EQUAL get_line_no exp { $$ = mkrule_prag($1,$2,$3,$6,$5); }
-
-rule_forall : FORALL rule_var_list DOT { $$ = $2; }
- | /* Empty */ { $$ = Lnil; }
- ;
-
-rule_var_list : /* Empty */ { $$ = Lnil; }
- | rule_var { $$ = lsing($1); }
- | rule_var COMMA rule_var_list { $$ = mklcons($1,$3); }
- ;
-
-rule_var : varid { $$ = mkprulevar( $1 ); }
- | varid DCOLON polytype { $$ = mkprulevarsig( $1, $3 ); }
- ;
-
-/* *********************************************************** */
-
-typed : typekey simple_con_app EQUAL tautype { $$ = mknbind($2,$4,startlineno); }
- ;
-
-
-datad : datakey simple_con_app EQUAL constrs deriving
- { $$ = mktbind(Lnil,$2,$4,$5,startlineno); }
- | datakey simple_context DARROW simple_con_app EQUAL constrs deriving
- { $$ = mktbind($2,$4,$6,$7,startlineno); }
- ;
-
-newtd : newtypekey simple_con_app EQUAL constr1 deriving
- { $$ = mkntbind(Lnil,$2,lsing($4),$5,startlineno); }
- | newtypekey simple_context DARROW simple_con_app EQUAL constr1 deriving
- { $$ = mkntbind($2,$4,lsing($6),$7,startlineno); }
- ;
-
-deriving: /* empty */ { $$ = mknothing(); }
- | DERIVING dtyclses { $$ = mkjust($2); }
- ;
-
-classd : classkey apptype DARROW simple_con_app1 maybe_where
- /* Context can now be more than simple_context */
- { $$ = mkcbind(type2context($2),$4,$5,startlineno); }
- | classkey apptype maybe_where
- /* We have to say apptype rather than simple_con_app1, else
- we get reduce/reduce errs */
- { check_class_decl_head($2);
- $$ = mkcbind(Lnil,$2,$3,startlineno); }
- ;
-
-instd : instkey inst_type maybe_where { $$ = mkibind($2,$3,startlineno); }
- ;
-
-/* Compare polytype */
-/* [July 98: first production was tautype DARROW tautype, but I can't see why.] */
-inst_type : apptype DARROW apptype { is_context_format( $3, 0 ); /* Check the instance head */
- $$ = mkimp_forall(type2context($1),$3); }
- | apptype { is_context_format( $1, 0 ); /* Check the instance head */
- $$ = $1; }
- ;
-
-
-defaultd: defaultkey OPAREN tautypes CPAREN { $$ = mkdbind($3,startlineno); }
- | defaultkey OPAREN CPAREN { $$ = mkdbind(Lnil,startlineno); }
- ;
-
-/* FFI primitive declarations - GHC/Hugs specific */
-foreignd: foreignkey IMPORT callconv ext_name unsafe_flag qvarid DCOLON tautype
- { $$ = mkfobind($6,$8,$4,$5,$3,FOREIGN_IMPORT,startlineno); }
- | foreignkey EXPORT callconv ext_name qvarid DCOLON tautype
- { $$ = mkfobind($5,$7,$4,0,$3,FOREIGN_EXPORT,startlineno); }
- | foreignkey LABEL ext_name qvarid DCOLON tautype
- { $$ = mkfobind($4,$6,$3,0,-1,FOREIGN_LABEL,startlineno); }
- ;
-
-callconv: STDCALL { $$ = CALLCONV_STDCALL; }
- | C_CALL { $$ = CALLCONV_CCALL; }
- | PASCAL { $$ = CALLCONV_PASCAL; }
- | FASTCALL { $$ = CALLCONV_FASTCALL; }
-/* If you leave out the specification of a calling convention, you'll (probably) get C's. */
- | /*empty*/ { $$ = CALLCONV_NONE; }
- ;
-
-ext_name: STRING { $$ = mkjust(lsing($1)); }
- | STRING STRING { $$ = mkjust(mklcons ($1,lsing($2))); }
- | DYNAMIC { $$ = mknothing(); }
-
-unsafe_flag: UNSAFE { $$ = 1; }
- | /*empty*/ { $$ = 0; }
- ;
-
-decls : /* empty */ { $$ = mknullbind(); }
- | decl
- | decls SEMI { $$ = $1; }
- | decls SEMI decl
- {
- if(SAMEFN)
- {
- extendfn($1,$3);
- $$ = $1;
- }
- else
- $$ = mkabind($1,$3);
- }
- ;
-
-non_empty_decls : decl
- | non_empty_decls SEMI { $$ = $1; }
- | non_empty_decls SEMI decl
- {
- if(SAMEFN)
- {
- extendfn($1,$3);
- $$ = $1;
- }
- else
- $$ = mkabind($1,$3);
- }
- ;
-
-/*
- Note: if there is an iclasop_pragma here, then we must be
- doing a class-op in an interface -- unless the user is up
- to real mischief (ugly, but likely to work).
-*/
-
-decl : fixdecl
-
- | qvarsk DCOLON polytype
- { $$ = mksbind($1,$3,startlineno);
- FN = NULL; SAMEFN = 0;
- }
-
- | qvark DCOLON polytype
- { $$ = mksbind(lsing($1),$3,startlineno);
- FN = NULL; SAMEFN = 0;
- }
-
- /* User-specified pragmas come in as "signatures"...
- They are similar in that they can appear anywhere in the module,
- and have to be "joined up" with their related entity.
-
- Have left out the case specialising to an overloaded type.
- Let's get real, OK? (WDP)
- */
- | SPECIALISE_UPRAGMA qvark DCOLON polytypes END_UPRAGMA
- {
- $$ = mkvspec_uprag($2, $4, startlineno);
- FN = NULL; SAMEFN = 0;
- }
-
- | SPECIALISE_UPRAGMA INSTANCE inst_type END_UPRAGMA
- {
- $$ = mkispec_uprag($3, startlineno);
- FN = NULL; SAMEFN = 0;
- }
-
- | SPECIALISE_UPRAGMA DATA gtycon atypes END_UPRAGMA
- {
- $$ = mkdspec_uprag($3, $4, startlineno);
- FN = NULL; SAMEFN = 0;
- }
-
- | INLINE_UPRAGMA qvark END_UPRAGMA
- {
- $$ = mkinline_uprag($2, startlineno);
- FN = NULL; SAMEFN = 0;
- }
-
- | NOINLINE_UPRAGMA qvark END_UPRAGMA
- {
- $$ = mknoinline_uprag($2, startlineno);
- FN = NULL; SAMEFN = 0;
- }
-
- | MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA
- {
- $$ = mkmagicuf_uprag($2, $3, startlineno);
- FN = NULL; SAMEFN = 0;
- }
-
- /* end of user-specified pragmas */
-
- | valdef
- ;
-
-fixdecl : INFIXL INTEGER { Precedence = checkfixity($2); Fixity = INFIXL; }
- fix_ops { $$ = $4; }
- | INFIXR INTEGER { Precedence = checkfixity($2); Fixity = INFIXR; }
- fix_ops { $$ = $4; }
- | INFIX INTEGER { Precedence = checkfixity($2); Fixity = INFIX; }
- fix_ops { $$ = $4; }
- | INFIXL { Fixity = INFIXL; Precedence = 9; }
- fix_ops { $$ = $3; }
- | INFIXR { Fixity = INFIXR; Precedence = 9; }
- fix_ops { $$ = $3; }
- | INFIX { Fixity = INFIX; Precedence = 9; }
- fix_ops { $$ = $3; }
- ;
-
-/* Grotesque global-variable hack to
- make a separate fixity decl for each op */
-fix_ops : fix_op
- | fix_ops COMMA fix_op { $$ = mkabind($1,$3); }
- ;
-
-fix_op : op { $$ = mkfixd(mknoqual($1),infixint(Fixity),Precedence,startlineno); }
- ;
-
-qvarsk : qvark COMMA qvars_list { $$ = mklcons($1,$3); }
- ;
-
-qvars_list: qvar { $$ = lsing($1); }
- | qvars_list COMMA qvar { $$ = lapp($1,$3); }
- ;
-
-
-/**********************************************************************
-* *
-* *
-* Types etc *
-* *
-* *
-**********************************************************************/
-
-/* "DCOLON context => tautype" vs "DCOLON tautype" is a problem,
- because you can't distinguish between
-
- foo :: (Baz a, Baz a)
- bar :: (Baz a, Baz a) => [a] -> [a] -> [a]
-
- with one token of lookahead. The HACK is to have "DCOLON apptype"
- in the first case, then check that it has the right
- form C a, or (C1 a, C2 b, ... Cn z) and convert it into a
- context. Blaach!
-*/
-
-/* --------------------------- */
-
-polyatype : atype
- ;
-
-polytype : FORALL var_list DOT
- apptype DARROW tautype { $$ = mkforall($2, type2context($4), $6); }
- | FORALL var_list DOT tautype { $$ = mkforall($2, Lnil, $4); }
- | apptype DARROW tautype { $$ = mkimp_forall( type2context($1), $3); }
- | tautype
- ;
-
-polytypes : polytype { $$ = lsing($1); }
- | polytypes COMMA polytype { $$ = lapp($1,$3); }
- ;
-
-/* --------------------------- */
-/* tautype is just a monomorphic type.
- But it may have nested for-alls if we're in a rank-2 type */
-
-tautype : apptype RARROW tautype { $$ = mktfun($1,$3); }
- | apptype { $$ = $1; }
- ;
-
-tautypes : tautype { $$ = lsing($1); }
- | tautypes COMMA tautype { $$ = lapp($1,$3); }
- ;
-
-/* --------------------------- */
-/* apptype: type application */
-
-apptype : apptype atype { $$ = mktapp($1,$2); }
- | atype { $$ = $1; }
- ;
-
-/* --------------------------- */
-/* atype: an atomic or bracketed type: T, x, [ty], tuple ty */
-
-atypes : atype { $$ = lsing($1); }
- | atype atypes { $$ = mklcons($1,$2); }
- ;
-
-atype : gtycon { $$ = mktname($1); }
- | tyvar { $$ = mknamedtvar($1); }
-
- | OPAREN tautype COMMA
- tautypes CPAREN { $$ = mkttuple(mklcons($2,$4)); }
-
- | OUNBOXPAREN tautype COMMA
- tautypes CUNBOXPAREN { $$ = mktutuple(mklcons($2,$4)); }
-
- | OBRACK tautype CBRACK { $$ = mktllist($2); }
- | OPAREN polytype CPAREN { $$ = $2; }
- ;
-
-/* --------------------------- */
-gtycon : qtycon
- | OPAREN RARROW CPAREN { $$ = creategid(ARROWGID); }
- | OBRACK CBRACK { $$ = creategid(NILGID); }
- | OPAREN CPAREN { $$ = creategid(UNITGID); }
- | OPAREN commas CPAREN { $$ = creategid($2); }
- ;
-
-commas : COMMA { $$ = 1; }
- | commas COMMA { $$ = $1 + 1; }
- ;
-
-/**********************************************************************
-* *
-* *
-* Declaration stuff *
-* *
-* *
-**********************************************************************/
-
-/* C a b c, where a,b,c are type variables */
-/* C can be a class or tycon */
-
-/* simple_con_app can have no args; simple_con_app1 must have at least one */
-simple_con_app: gtycon { $$ = mktname($1); }
- | simple_con_app1 { $$ = $1; }
- ;
-
-simple_con_app1: gtycon tyvar { $$ = mktapp(mktname($1),mknamedtvar($2)); }
- | simple_con_app1 tyvar { $$ = mktapp($1, mknamedtvar($2)); }
- ;
-
-simple_context : OPAREN simple_context_list CPAREN { $$ = $2; }
- | OPAREN CPAREN { $$ = Lnil; }
- | simple_con_app1 { $$ = lsing($1); }
- ;
-
-simple_context_list : simple_con_app1 { $$ = lsing($1); }
- | simple_context_list COMMA simple_con_app1 { $$ = lapp($1,$3); }
- ;
-
-constrs : constr { $$ = lsing($1); }
- | constrs VBAR constr { $$ = lapp($1,$3); }
- ;
-
-constr : forall constr_context DARROW constr_after_context { $$ = mkconstrex ( $1, $2, $4 ); }
- | forall constr_after_context { $$ = mkconstrex ( $1, Lnil, $2 ); }
- ;
-
-constr_context
- : conapptype conargatype { $$ = type2context( mktapp($1,$2) ); }
- | conargatype { $$ = type2context( $1 ); }
- ;
-
-constr_after_context :
-
- /* We have to parse the constructor application as a *type*, else we get
- into terrible ambiguity problems. Consider the difference between
-
- data T = S Int Int Int `R` Int
- and
- data T = S Int Int Int
-
- It isn't till we get to the operator that we discover that the "S" is
- part of a type in the first, but part of a constructor application in the
- second.
- */
-
-/* Con !Int (Tree a) */
- conapptype { qid tyc; list tys;
- splittyconapp($1, &tyc, &tys);
- $$ = mkconstrpre(tyc,tys,hsplineno); }
-
-/* (::) (Tree a) Int */
- | OPAREN qconsym CPAREN conargatypes { $$ = mkconstrpre($2,$4,hsplineno); }
-
-/* !Int `Con` Tree a */
- | conargatype qconop conargatype { $$ = mkconstrinf($1,$2,$3,hsplineno); }
-
-/* Con { op1 :: Int } */
- | qtycon OCURLY CCURLY { $$ = mkconstrrec($1,Lnil,hsplineno); }
- | qtycon OCURLY fields CCURLY { $$ = mkconstrrec($1,$3,hsplineno); }
- | OPAREN qconsym CPAREN OCURLY fields CCURLY { $$ = mkconstrrec($2,$5,hsplineno); }
- ;
- /* 1 S/R conflict on OCURLY -> shift */
-
-
-conapptype : gtycon { $$ = mktname($1); }
- | conapptype conargatype { $$ = mktapp($1, $2); }
- ;
-
-conargatype : polyatype { $$ = $1; }
- | BANG polyatype { $$ = mktbang( $2 ); }
- ;
-
-conargatypes : { $$ = Lnil; }
- | conargatype conargatypes { $$ = mklcons($1,$2); }
- ;
-
-fields : field { $$ = lsing($1); }
- | fields COMMA field { $$ = lapp($1,$3); }
- ;
-
-field : qvars_list DCOLON polytype { $$ = mkfield($1,$3); }
- | qvars_list DCOLON BANG polyatype { $$ = mkfield($1,mktbang($4)); }
- ;
-
-constr1 : gtycon conargatype { $$ = mkconstrnew($1,$2,mknothing(),hsplineno); }
- | gtycon OCURLY qvar DCOLON polytype CCURLY { $$ = mkconstrnew($1,$5,mkjust($3),hsplineno); }
- ;
-
-
-dtyclses: OPAREN dtycls_list CPAREN { $$ = $2; }
- | OPAREN CPAREN { $$ = Lnil; }
- | qtycls { $$ = lsing($1); }
- ;
-
-dtycls_list: qtycls { $$ = lsing($1); }
- | dtycls_list COMMA qtycls { $$ = lapp($1,$3); }
- ;
-
-valdef : funlhs opt_sig { checksamefn($1); }
- get_line_no valrhs { $$ = mkfbind( lsing(mkpmatch( lsing($1), $2, $5 )), $4); }
-
-/* Special case for f :: type = e
- We treat it as a special kind of pattern binding */
- | qvark DCOLON tautype
- get_line_no valrhs { $$ = mkpbind( mkrestr( mkident($1), $3 ), $5, $4 );
- FN = NULL; SAMEFN = 0; }
-
- | patk
- get_line_no valrhs { $$ = mkpbind($1, $3, $2);
- FN = NULL; SAMEFN = 0; }
-
-get_line_no : { $$ = hsplineno; /* startlineno; */ }
- ;
-/* This grammar still isn't quite right
- If you say
- (x + 2) y = e
- you should get a function binding, but actually the (x+3) will
- parse as a pattern, and you'll get a parse error. */
-
-funlhs : patk qvarop cpat { $$ = mkinfixap($2,$1,$3); }
- | funlhs1 apat { $$ = mkap( $1, $2 ); }
-
-funlhs1 : oparenkey funlhs2 CPAREN { $$ = mkpar($2); }
- | funlhs1 apat { $$ = mkap( $1, $2 ); }
- | qvark { $$ = mkident($1); }
- ;
-
-funlhs2 : cpat qvarop cpat { $$ = mkinfixap($2,$1,$3); }
- | funlhs3 apat { $$ = mkap( $1, $2 ); }
-
-funlhs3 : OPAREN funlhs2 CPAREN { $$ = mkpar($2); }
- | funlhs3 apat { $$ = mkap( $1, $2 ); }
- | qvar { $$ = mkident($1); }
- ;
-
-opt_sig : { $$ = mknothing(); }
- | DCOLON tautype { $$ = mkjust($2); }
- ;
-
-/* opt_asig is the same, but with a parenthesised type */
-opt_asig : { $$ = mknothing(); }
- | DCOLON atype { $$ = mkjust($2); }
- ;
-
-valrhs : EQUAL get_line_no exp maybe_where { $$ = mkpnoguards($2, $3, $4); }
- | gdrhs maybe_where { $$ = mkpguards($1, $2); }
- ;
-
-gdrhs : gd EQUAL get_line_no exp { $$ = lsing(mkpgdexp($1,$3,$4)); }
- | gd EQUAL get_line_no exp gdrhs { $$ = mklcons(mkpgdexp($1,$3,$4),$5); }
- ;
-
-maybe_where: /* empty */ { $$ = mknullbind(); }
- | WHERE where_body { $$ = $2; }
- | WHERE { $$ = mknullbind(); }
- ;
-
-where_body : ocurly decls ccurly { $$ = $2; }
- | vocurly non_empty_decls vccurly { $$ = $2; }
- ;
-
-gd : VBAR quals { $$ = $2; }
- ;
-
-
-/**********************************************************************
-* *
-* *
-* Expressions *
-* *
-* *
-**********************************************************************/
-
-exp : oexp DCOLON polytype { $$ = mkrestr($1,$3); }
- | oexp
- ;
-
-/*
- Operators must be left-associative at the same precedence for
- precedence parsing to work.
-*/
- /* 10 S/R conflicts on qop -> shift */
-oexp : oexp qop dexp %prec MINUS { $$ = mkinfixap($2,$1,$3); }
- | dexp
- ;
-
-/*
- This comes here because of the funny precedence rules concerning
- prefix minus.
-*/
-dexp : MINUS kexp { $$ = mknegate($2); }
- | kexp
- ;
-
-/*
- We need to factor out a leading let expression so we can set
- pat_check=FALSE when parsing (non let) expressions inside stmts and quals
-*/
-expLno : oexpLno DCOLON polytype { $$ = mkrestr($1,$3); }
- | oexpLno
- ;
-oexpLno : oexpLno qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); }
- | dexpLno
- ;
-dexpLno : MINUS kexp { $$ = mknegate($2); }
- | kexpLno
- ;
-
-expL : oexpL DCOLON polytype { $$ = mkrestr($1,$3); }
- | oexpL
- ;
-oexpL : oexpL qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); }
- | kexpL
- ;
-
-/*
- let/if/lambda/case have higher precedence than infix operators.
-*/
-
-kexp : kexpL
- | kexpLno
- ;
-
-/* kexpL = a let expression */
-kexpL : letdecls IN exp { $$ = mklet($1,$3); }
- ;
-
-/* kexpLno = any other expression more tightly binding than operator application */
-kexpLno : LAMBDA
- { hsincindent(); /* push new context for FN = NULL; */
- FN = NULL; /* not actually concerned about indenting */
- }
- lampats opt_asig
- { hsendindent(); }
-
- RARROW get_line_no exp /* lambda abstraction */
- { $$ = mklambda( mkpmatch( $3, $4, mkpnoguards( $7, $8, mknullbind() ) ) ); }
-
- /* If Expression */
- | IF {$<ulong>$ = hsplineno;}
- exp THEN exp ELSE exp { $$ = mkife($3,$5,$7,$<ulong>2); }
-
- /* Case Expression */
- | CASE {$<ulong>$ = hsplineno;}
- exp OF caserest { $$ = mkcasee($3,$5,$<ulong>2); }
-
- /* Do Expression */
- | DO {$<ulong>$ = hsplineno;}
- dorest { $$ = mkdoe($3,$<ulong>2); }
-
- /* CCALL/CASM Expression */
- | CCALL ccallid aexps { $$ = mkccall($2,install_literal("n"),$3); }
- | CCALL_GC ccallid aexps { $$ = mkccall($2,install_literal("p"),$3); }
- | CASM CLITLIT aexps { $$ = mkccall($2,install_literal("N"),$3); }
- | CASM_GC CLITLIT aexps { $$ = mkccall($2,install_literal("P"),$3); }
-
- /* SCC Expression */
- | SCC STRING exp
- { if (ignoreSCC) {
- if (warnSCC) {
- fprintf(stderr,
- "\"%s\":%d: _scc_ (`set [profiling] cost centre') ignored\n",
- input_filename, hsplineno);
- }
- $$ = mkpar($3); /* Note the mkpar(). If we don't have it, then
- (x >> _scc_ y >> z) parses as (x >> (y >> z)),
- right associated. But the precedence reorganiser expects
- the parser to *left* associate all operators unless there
- are explicit parens. The _scc_ acts like an explicit paren,
- so if we omit it we'd better add explicit parens instead. */
- } else {
- $$ = mkscc($2, $3);
- }
- }
- | fexp
- ;
-
-fexp : fexp aexp { $$ = mkap($1,$2); }
- | aexp
- ;
-
- /* simple expressions */
-aexp : qvar { $$ = mkident($1); }
- | gcon { $$ = mkident($1); }
- | lit_constant { $$ = mklit($1); }
- | OPAREN exp CPAREN { $$ = mkpar($2); } /* mkpar: stop infix parsing at ()'s */
- | qcon OCURLY rbinds CCURLY { $$ = mkrecord($1,$3); } /* 1 S/R conflict on OCURLY -> shift */
- | OBRACK list_exps CBRACK { $$ = mkllist($2); }
- | OPAREN exp COMMA texps CPAREN { $$ = mktuple(mklcons($2,$4)); }
- /* unboxed tuples */
- | OUNBOXPAREN texps CUNBOXPAREN { $$ = mkutuple($2); }
-
- /* only in expressions ... */
- | aexp OCURLY rbinds1 CCURLY { $$ = mkrupdate($1,$3); }
- | OBRACK exp VBAR quals CBRACK { $$ = mkcomprh($2,$4); }
- | OBRACK exp COMMA exp DOTDOT exp CBRACK {$$= mkeenum($2,mkjust($4),mkjust($6)); }
- | OBRACK exp COMMA exp DOTDOT CBRACK { $$ = mkeenum($2,mkjust($4),mknothing()); }
- | OBRACK exp DOTDOT exp CBRACK { $$ = mkeenum($2,mknothing(),mkjust($4)); }
- | OBRACK exp DOTDOT CBRACK { $$ = mkeenum($2,mknothing(),mknothing()); }
- | OPAREN oexp qop CPAREN { $$ = mklsection($2,$3); }
- | OPAREN qop1 oexp CPAREN { $$ = mkrsection($2,$3); }
-
- /* only in patterns ... */
- /* these add 2 S/R conflict with with aexp . OCURLY rbinds CCURLY */
- | qvar AT aexp { checkinpat(); $$ = mkas($1,$3); }
- | LAZY aexp { checkinpat(); $$ = mklazyp($2); }
- ;
-
- /* ccall arguments */
-aexps : aexps aexp { $$ = lapp($1,$2); }
- | /* empty */ { $$ = Lnil; }
- ;
-
-caserest: ocurly alts ccurly { $$ = $2; }
- | vocurly alts vccurly { $$ = $2; }
-
-dorest : ocurly stmts ccurly { checkdostmts($2); $$ = $2; }
- | vocurly stmts vccurly { checkdostmts($2); $$ = $2; }
- ;
-
-rbinds : /* empty */ { $$ = Lnil; }
- | rbinds1
- ;
-
-rbinds1 : rbind { $$ = lsing($1); }
- | rbinds1 COMMA rbind { $$ = lapp($1,$3); }
- ;
-
-rbind : qvar { punningNowIllegal(); }
- | qvar EQUAL exp { $$ = mkrbind($1,mkjust($3)); }
- ;
-
-texps : exp { $$ = lsing($1); }
- | exp COMMA texps { $$ = mklcons($1, $3) }
- /* right recursion? WDP */
- ;
-
-list_exps :
- exp { $$ = lsing($1); }
- | exp COMMA exp { $$ = mklcons( $1, lsing($3) ); }
- | exp COMMA exp COMMA list_rest { $$ = mklcons( $1, mklcons( $3, reverse_list( $5 ))); }
- ;
-
-/* Use left recusion for list_rest, because we sometimes get programs with
- very long explicit lists. */
-list_rest : exp { $$ = lsing($1); }
- | list_rest COMMA exp { $$ = mklcons( $3, $1 ); }
- ;
-
-/*
- exp { $$ = lsing($1); }
- | exp COMMA list_exps { $$ = mklcons($1, $3); }
-*/
- /* right recursion? (WDP)
-
- It has to be this way, though, otherwise you
- may do the wrong thing to distinguish between...
-
- [ e1 , e2 .. ] -- an enumeration ...
- [ e1 , e2 , e3 ] -- a list
-
- (In fact, if you change the grammar and throw yacc/bison
- at it, it *will* do the wrong thing [WDP 94/06])
- */
-
-letdecls: LET { pat_check = TRUE; } ocurly decls ccurly { $$ = $4; }
- | LET { pat_check = TRUE; } vocurly decls vccurly { $$ = $4; }
- ;
-
-/*
- When parsing patterns inside do stmt blocks or quals, we have
- to tentatively parse them as expressions, since we don't know at
- the time of parsing `p' whether it will be part of "p <- e" (pat)
- or "p" (expr). When we eventually can tell the difference, the parse
- of `p' is examined to see if it consitutes a syntactically legal pattern
- or expression.
-
- The expr rule used to parse the pattern/expression do contain
- pattern-special productions (e.g., _ , a@pat, etc.), which are
- illegal in expressions. Since we don't know whether what
- we're parsing is an expression rather than a pattern, we turn off
- the check and instead do it later.
-
- The rather clumsy way that this check is turned on/off is there
- to work around a Bison feature/shortcoming. Turning the flag
- on/off just around the relevant nonterminal by decorating it
- with simple semantic actions, e.g.,
-
- {pat_check = FALSE; } expLNo { pat_check = TRUE; }
-
- causes Bison to generate a parser where in one state it either
- has to reduce/perform a semantic action ( { pat_check = FALSE; })
- or reduce an error (the error production used to implement
- vccurly.) Bison picks the semantic action, which it ideally shouldn't.
- The work around is to lift out the setting of { pat_check = FALSE; }
- and then later reset pat_check. Not pretty.
-
-*/
-
-
-quals : { pat_check = FALSE;} qual { pat_check = TRUE; $$ = lsing($2); }
- | quals COMMA { pat_check = FALSE; } qual { pat_check = TRUE; $$ = lapp($1,$4); }
- ;
-
-qual : letdecls { $$ = mkseqlet($1); }
- | expL { expORpat(LEGIT_EXPR,$1); $$ = $1; }
- | expLno { pat_check = TRUE; } leftexp
- { if ($3 == NULL) {
- expORpat(LEGIT_EXPR,$1);
- $$ = mkguard($1);
- } else {
- expORpat(LEGIT_PATT,$1);
- $$ = mkqual($1,$3);
- }
- }
- ;
-
-alts : /* empty */ { $$ = Lnil; }
- | alt { $$ = lsing($1); }
- | alt SEMI alts { $$ = mklcons($1,$3); }
- | SEMI alts { $$ = $2; }
- ;
-
-alt : dpat opt_sig altrhs { $$ = mkpmatch( lsing($1), $2, $3 ); }
- ;
-
-altrhs : RARROW get_line_no exp maybe_where { $$ = mkpnoguards($2, $3, $4); }
- | gdpat maybe_where { $$ = mkpguards($1, $2); }
- ;
-
-gdpat : gd RARROW get_line_no exp { $$ = lsing(mkpgdexp($1,$3,$4)); }
- | gd RARROW get_line_no exp gdpat { $$ = mklcons(mkpgdexp($1,$3,$4),$5); }
- ;
-
-stmts : {pat_check = FALSE;} stmt {pat_check=TRUE; $$ = $2; }
- | stmts SEMI {pat_check=FALSE;} stmt {pat_check=TRUE; $$ = lconc($1,$4); }
- ;
-
-stmt : /* empty */ { $$ = Lnil; }
- | letdecls { $$ = lsing(mkseqlet($1)); }
- | expL { expORpat(LEGIT_EXPR,$1); $$ = lsing(mkdoexp($1,hsplineno)); }
- | expLno {pat_check=TRUE;} leftexp
- { if ($3 == NULL) {
- expORpat(LEGIT_EXPR,$1);
- $$ = lsing(mkdoexp($1,endlineno));
- } else {
- expORpat(LEGIT_PATT,$1);
- $$ = lsing(mkdobind($1,$3,endlineno));
- }
- }
- ;
-
-
-leftexp : LARROW exp { $$ = $2; }
- | /* empty */ { $$ = NULL; }
- ;
-
-/**********************************************************************
-* *
-* *
-* Patterns *
-* *
-* *
-**********************************************************************/
-
-pat : dpat DCOLON tautype { $$ = mkrestr($1,$3); }
- | dpat
- ;
-
-dpat : qvar PLUS INTEGER { $$ = mkplusp($1, mkinteger($3)); }
- | cpat
- ;
-
-cpat : cpat qconop bpat { $$ = mkinfixap($2,$1,$3); }
- | bpat
- ;
-
-bpat : apatc
- | conpat
- | qcon OCURLY rpats CCURLY { $$ = mkrecord($1,$3); }
- | MINUS INTEGER { $$ = mknegate(mklit(mkinteger($2))); }
- | MINUS FLOAT { $$ = mknegate(mklit(mkfloatr($2))); }
- ;
-
-conpat : gcon { $$ = mkident($1); }
- | conpat apat { $$ = mkap($1,$2); }
- ;
-
-apat : gcon { $$ = mkident($1); }
- | qcon OCURLY rpats CCURLY { $$ = mkrecord($1,$3); }
- | apatc
- ;
-
-apatc : qvar { $$ = mkident($1); }
- | qvar AT apat { $$ = mkas($1,$3); }
- | lit_constant { $$ = mklit($1); }
- | OPAREN pat CPAREN { $$ = mkpar($2); }
- | OPAREN pat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); }
- | OUNBOXPAREN pats CUNBOXPAREN { $$ = mkutuple($2); }
- | OBRACK pats CBRACK { $$ = mkllist($2); }
- | LAZY apat { $$ = mklazyp($2); }
- ;
-
-lit_constant:
- INTEGER { $$ = mkinteger($1); }
- | FLOAT { $$ = mkfloatr($1); }
- | CHAR { $$ = mkcharr($1); }
- | STRING { $$ = mkstring($1); }
- | CHARPRIM { $$ = mkcharprim($1); }
- | STRINGPRIM { $$ = mkstringprim($1); }
- | INTPRIM { $$ = mkintprim($1); }
- | FLOATPRIM { $$ = mkfloatprim($1); }
- | DOUBLEPRIM { $$ = mkdoubleprim($1); }
- | CLITLIT /* yurble yurble */ { $$ = mkclitlit($1); }
- ;
-
-/* Sequence of apats for a lambda abstraction */
-lampats : apat lampats { $$ = mklcons($1,$2); }
- | apat { $$ = lsing($1); }
- /* right recursion? (WDP) */
- ;
-
-/* Comma-separated sequence of pats */
-pats : pat COMMA pats { $$ = mklcons($1, $3); }
- | pat { $$ = lsing($1); }
- /* right recursion? (WDP) */
- ;
-
-/* Comma separated sequence of record patterns, each of form 'field=pat' */
-rpats : /* empty */ { $$ = Lnil; }
- | rpats1
- ;
-
-rpats1 : rpat { $$ = lsing($1); }
- | rpats1 COMMA rpat { $$ = lapp($1,$3); }
- ;
-
-rpat : qvar { punningNowIllegal(); }
- | qvar EQUAL pat { $$ = mkrbind($1,mkjust($3)); }
- ;
-
-
-/* I can't figure out just what these ...k patterns are for.
- It seems to have something to do with recording the line number */
-
-/* Corresponds to a cpat */
-patk : patk qconop bpat { $$ = mkinfixap($2,$1,$3); }
- | bpatk
- ;
-
-bpatk : apatck
- | conpatk
- | qconk OCURLY rpats CCURLY { $$ = mkrecord($1,$3); }
- | minuskey INTEGER { $$ = mknegate(mklit(mkinteger($2))); }
- | minuskey FLOAT { $$ = mknegate(mklit(mkfloatr($2))); }
- ;
-
-conpatk : gconk { $$ = mkident($1); }
- | conpatk apat { $$ = mkap($1,$2); }
- ;
-
-apatck : qvark { $$ = mkident($1); }
- | qvark AT apat { $$ = mkas($1,$3); }
- | lit_constant { $$ = mklit($1); setstartlineno(); }
- | oparenkey pat CPAREN { $$ = mkpar($2); }
- | oparenkey pat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); }
- | ounboxparenkey pat COMMA pats CUNBOXPAREN
- { $$ = mkutuple(mklcons($2,$4)); }
- | obrackkey pats CBRACK { $$ = mkllist($2); }
- | lazykey apat { $$ = mklazyp($2); }
- ;
-
-
-gcon : qcon
- | OBRACK CBRACK { $$ = creategid(NILGID); }
- | OPAREN CPAREN { $$ = creategid(UNITGID); }
- | OPAREN commas CPAREN { $$ = creategid($2); }
- ;
-
-gconk : qconk
- | obrackkey CBRACK { $$ = creategid(NILGID); }
- | oparenkey CPAREN { $$ = creategid(UNITGID); }
- | oparenkey commas CPAREN { $$ = creategid($2); }
- ;
-
-/**********************************************************************
-* *
-* *
-* Keywords which record the line start *
-* *
-* *
-**********************************************************************/
-
-importkey: IMPORT { setstartlineno(); $$ = 0; }
- | IMPORT SOURCE_UPRAGMA { setstartlineno(); $$ = 1; }
- ;
-
-datakey : DATA { setstartlineno();
- if(etags)
-#if 1/*etags*/
- printf("%u\n",startlineno);
-#else
- fprintf(stderr,"%u\tdata\n",startlineno);
-#endif
- }
- ;
-
-typekey : TYPE { setstartlineno();
- if(etags)
-#if 1/*etags*/
- printf("%u\n",startlineno);
-#else
- fprintf(stderr,"%u\ttype\n",startlineno);
-#endif
- }
- ;
-
-newtypekey : NEWTYPE { setstartlineno();
- if(etags)
-#if 1/*etags*/
- printf("%u\n",startlineno);
-#else
- fprintf(stderr,"%u\tnewtype\n",startlineno);
-#endif
- }
- ;
-
-instkey : INSTANCE { setstartlineno();
-#if 1/*etags*/
-/* OUT: if(etags)
- printf("%u\n",startlineno);
-*/
-#else
- fprintf(stderr,"%u\tinstance\n",startlineno);
-#endif
- }
- ;
-
-defaultkey: DEFAULT { setstartlineno(); }
- ;
-
-foreignkey: FOREIGN { setstartlineno(); }
- ;
-
-classkey: CLASS { setstartlineno();
- if(etags)
-#if 1/*etags*/
- printf("%u\n",startlineno);
-#else
- fprintf(stderr,"%u\tclass\n",startlineno);
-#endif
- }
- ;
-
-modulekey: MODULE { setstartlineno();
- if(etags)
-#if 1/*etags*/
- printf("%u\n",startlineno);
-#else
- fprintf(stderr,"%u\tmodule\n",startlineno);
-#endif
- }
- ;
-
-oparenkey: OPAREN { setstartlineno(); }
- ;
-
-ounboxparenkey: OUNBOXPAREN { setstartlineno(); }
- ;
-
-obrackkey: OBRACK { setstartlineno(); }
- ;
-
-lazykey : LAZY { setstartlineno(); }
- ;
-
-minuskey: MINUS { setstartlineno(); }
- ;
-
-
-/**********************************************************************
-* *
-* *
-* Basic qualified/unqualified ids/ops *
-* *
-* *
-**********************************************************************/
-
-qvar : qvarid
- | OPAREN qvarsym CPAREN { $$ = $2; }
- ;
-qcon : qconid
- | OPAREN qconsym CPAREN { $$ = $2; }
- ;
-qvarop : qvarsym
- | BQUOTE qvarid BQUOTE { $$ = $2; }
- ;
-qconop : qconsym
- | BQUOTE qconid BQUOTE { $$ = $2; }
- ;
-qop : qconop
- | qvarop
- ;
-
-/* Non "-" op, used in right sections */
-qop1 : qconop
- | qvarop1
- ;
-
-/* Non "-" varop, used in right sections */
-qvarop1 : QVARSYM
- | varsym_nominus { $$ = mknoqual($1); }
- | BQUOTE qvarid BQUOTE { $$ = $2; }
- ;
-
-
-var : varid
- | OPAREN varsym CPAREN { $$ = $2; }
- ;
-con : tycon /* using tycon removes conflicts */
- | OPAREN CONSYM CPAREN { $$ = $2; }
- ;
-varop : varsym
- | BQUOTE varid BQUOTE { $$ = $2; }
- ;
-conop : CONSYM
- | BQUOTE CONID BQUOTE { $$ = $2; }
- ;
-op : conop
- | varop
- ;
-
-qvark : qvarid { setstartlineno(); $$ = $1; }
- | oparenkey qvarsym CPAREN { $$ = $2; }
- ;
-qconk : qconid { setstartlineno(); $$ = $1; }
- | oparenkey qconsym CPAREN { $$ = $2; }
- ;
-vark : varid { setstartlineno(); $$ = $1; }
- | oparenkey varsym CPAREN { $$ = $2; }
- ;
-
-qvarid : QVARID
- | varid { $$ = mknoqual($1); }
- ;
-qvarsym : QVARSYM
- | varsym { $$ = mknoqual($1); }
- ;
-qconid : QCONID
- | tycon { $$ = mknoqual($1); } /* using tycon removes conflicts */
- ;
-qconsym : QCONSYM
- | CONSYM { $$ = mknoqual($1); }
- ;
-qtycon : QCONID
- | tycon { $$ = mknoqual($1); } /* using tycon removes conflicts */
- ;
-qtycls : QCONID
- | tycon { $$ = mknoqual($1); } /* using tycon removes conflicts */
- ;
-
-varsym : varsym_nominus
- | MINUS { $$ = install_literal("-"); }
- ;
-
-/* PLUS, BANG are valid varsyms */
-varsym_nominus : VARSYM
- | PLUS { $$ = install_literal("+"); }
- | BANG { $$ = install_literal("!"); }
- | DOT { $$ = install_literal("."); }
- ;
-
-/* AS HIDING QUALIFIED are valid varids */
-varid : varid_noforall
- | FORALL { $$ = install_literal("forall"); }
- ;
-
-varid_noforall
- : VARID
- | AS { $$ = install_literal("as"); }
- | HIDING { $$ = install_literal("hiding"); }
- | QUALIFIED { $$ = install_literal("qualified"); }
-/* The rest of these guys are used by the FFI decls, a ghc (and hugs) extension. */
- | EXPORT { $$ = install_literal("export"); }
- | UNSAFE { $$ = install_literal("unsafe"); }
- | DYNAMIC { $$ = install_literal("dynamic"); }
- | LABEL { $$ = install_literal("label"); }
- | C_CALL { $$ = install_literal("ccall"); }
- | STDCALL { $$ = install_literal("stdcall"); }
- | PASCAL { $$ = install_literal("pascal"); }
- ;
-
-ccallid : VARID
- | CONID
- ;
-
-tycon : CONID
- ;
-modid : CONID
- ;
-
-/* ---------------------------------------------- */
-tyvar : varid_noforall { $$ = $1; }
- ;
-
-/* var_list: At least one var; used mainly for tyvars */
-var_list : varid_noforall { $$ = lsing($1); }
- | varid_noforall var_list { $$ = mklcons($1,$2); }
- ;
-
-forall : /* Empty */ { $$ = Lnil }
- | FORALL var_list DOT { $$ = $2; }
- ;
-
-
-/**********************************************************************
-* *
-* *
-* Stuff to do with layout *
-* *
-* *
-**********************************************************************/
-
-ocurly : layout OCURLY { hsincindent(); }
-
-vocurly : layout { hssetindent(); }
- ;
-
-layout : { hsindentoff(); }
- ;
-
-ccurly :
- CCURLY
- {
- FN = NULL; SAMEFN = 0;
- hsendindent();
- }
- ;
-
-vccurly : { expect_ccurly = 1; } vccurly1 { expect_ccurly = 0; }
- ;
-
-vccurly1:
- VCCURLY
- {
- FN = NULL; SAMEFN = 0;
- hsendindent();
- }
- | error
- {
- yyerrok;
- FN = NULL; SAMEFN = 0;
- hsendindent();
- }
- ;
-
-%%
-
-/**********************************************************************
-* *
-* Error Processing and Reporting *
-* *
-* (This stuff is here in case we want to use Yacc macros and such.) *
-* *
-**********************************************************************/
-
-
-static void checkinpat()
-{
- if(pat_check)
- hsperror("pattern syntax used in expression");
-}
-
-static void punningNowIllegal()
-{
- hsperror("Haskell 98 does not support 'punning' on records");
-}
-
-
-/* The parser calls "hsperror" when it sees a
- `report this and die' error. It sets the stage
- and calls "yyerror".
-
- There should be no direct calls in the parser to
- "yyerror", except for the one from "hsperror". Thus,
- the only other calls will be from the error productions
- introduced by yacc/bison/whatever.
-
- We need to be able to recognise the from-error-production
- case, because we sometimes want to say, "Oh, never mind",
- because the layout rule kicks into action and may save
- the day. [WDP]
-*/
-
-static BOOLEAN error_and_I_mean_it = FALSE;
-
-void
-hsperror(s)
- char *s;
-{
- error_and_I_mean_it = TRUE;
- yyerror(s);
-}
-
-extern char *yytext;
-extern int yyleng;
-
-void
-yyerror(s)
- char *s;
-{
- /* We want to be able to distinguish 'error'-raised yyerrors
- from yyerrors explicitly coded by the parser hacker.
- */
- if ( expect_ccurly && ! error_and_I_mean_it ) {
- /*NOTHING*/;
-
- } else {
- fprintf(stderr, "%s:%d:%d: %s on input: ",
- input_filename, hsplineno, hspcolno + 1, s);
-
- if (yyleng == 1 && *yytext == '\0')
- fprintf(stderr, "<EOF>");
-
- else {
- fputc('"', stderr);
- format_string(stderr, (unsigned char *) yytext, yyleng);
- fputc('"', stderr);
- }
- fputc('\n', stderr);
-
- /* a common problem */
- if (strcmp(yytext, "#") == 0)
- fprintf(stderr, "\t(Perhaps you forgot a `-cpp' or `-fglasgow-exts' flag?)\n");
-
- exit(1);
- }
-}
-
-void
-format_string(fp, s, len)
- FILE *fp;
- unsigned char *s;
- int len;
-{
- while (len-- > 0) {
- switch (*s) {
- case '\0': fputs("\\NUL", fp); break;
- case '\007': fputs("\\a", fp); break;
- case '\010': fputs("\\b", fp); break;
- case '\011': fputs("\\t", fp); break;
- case '\012': fputs("\\n", fp); break;
- case '\013': fputs("\\v", fp); break;
- case '\014': fputs("\\f", fp); break;
- case '\015': fputs("\\r", fp); break;
- case '\033': fputs("\\ESC", fp); break;
- case '\034': fputs("\\FS", fp); break;
- case '\035': fputs("\\GS", fp); break;
- case '\036': fputs("\\RS", fp); break;
- case '\037': fputs("\\US", fp); break;
- case '\177': fputs("\\DEL", fp); break;
- default:
- if (*s >= ' ')
- fputc(*s, fp);
- else
- fprintf(fp, "\\^%c", *s + '@');
- break;
- }
- s++;
- }
-}
+++ /dev/null
-#ifndef HSPINCL_H
-#define HSPINCL_H
-
-#include "config.h"
-
-#if __STDC__
-#define PROTO(x) x
-#define NO_ARGS void
-#define CONST const
-#define VOID void
-#define VOID_STAR void *
-#define VOLATILE volatile
-#else
-#define PROTO(x) ()
-#define NO_ARGS /* no args */
-#define CONST /* no const */
-#define VOID void /* hope for the best... */
-#define VOID_STAR long *
-#define VOLATILE /* no volatile */
-#endif /* ! __STDC__ */
-
-#if defined(STDC_HEADERS) || defined(HAVE_STRING_H)
-#include <string.h>
-/* An ANSI string.h and pre-ANSI memory.h might conflict. */
-#if !defined(STDC_HEADERS) && defined(HAVE_MEMORY_H)
-#include <memory.h>
-#endif /* not STDC_HEADERS and HAVE_MEMORY_H */
-#define index strchr
-#define rindex strrchr
-#define bcopy(s, d, n) memcpy ((d), (s), (n))
-#define bcmp(s1, s2, n) memcmp ((s1), (s2), (n))
-#define bzero(s, n) memset ((s), 0, (n))
-#else /* not STDC_HEADERS and not HAVE_STRING_H */
-#include <strings.h>
-/* memory.h and strings.h conflict on some systems. */
-#endif /* not STDC_HEADERS and not HAVE_STRING_H */
-
-#ifdef HAVE_MALLOC_H
-#include <malloc.h>
-#endif
-#ifdef HAVE_STDLIB_H
-#include <stdlib.h>
-#endif
-
-#include "id.h"
-#include "qid.h"
-#include "literal.h"
-#include "list.h"
-#include "maybe.h"
-#include "either.h"
-#include "ttype.h"
-#include "constr.h"
-#include "binding.h"
-#include "grhsb.h"
-#include "match.h"
-#include "tree.h"
-#include "entidt.h"
-#include "gdexp.h"
-#include "rulevar.h"
-
-extern char *input_filename;
-extern tree hspmain();
-
-#endif /* HSPINCL_H */
+++ /dev/null
-/**********************************************************************
-* *
-* *
-* Identifier Processing *
-* *
-* *
-**********************************************************************/
-
-#include <stdio.h>
-
-#include "hspincl.h"
-#include "constants.h"
-#include "id.h"
-#include "utils.h"
-
-/* partain: special version for strings that may have NULs (etc) in them
- (used in UgenUtil.lhs)
-*/
-long
-get_hstring_len(hs)
- hstring hs;
-{
- return(hs->len);
-}
-
-char *
-get_hstring_bytes(hs)
- hstring hs;
-{
- return(hs->bytes);
-}
-
-hstring
-installHstring(length, s)
- int length;
- char *s;
-{
- char *p;
- hstring str;
- int i;
-
-/* fprintf(stderr, "installHstring: %d, %s\n",length, s); */
-
- if (length > 999999) { /* too long */
- fprintf(stderr,"String length more than six digits\n");
- exit(1);
- } else if (length < 0) { /* too short */
- fprintf(stderr,"String length < 0 !!\n");
- abort();
- }
-
- /* alloc the struct and store the length */
- str = (hstring) xmalloc(sizeof(Hstring));
- str->len = length;
-
- if (length == 0) {
- str->bytes = "";
-
- } else {
- p = xmalloc(length);
-
- /* now store the string */
- for (i = 0; i < length; i++) {
- p[i] = s[i];
- }
- str->bytes = p;
- }
- return str;
-}
-
-
-/**********************************************************************
-* *
-* *
-* Hashed Identifiers *
-* *
-* *
-**********************************************************************/
-
-
-extern BOOLEAN hashIds; /* Whether to use hashed ids. */
-
-unsigned hash_table_size = HASH_TABLE_SIZE;
-
-static char **hashtab = NULL;
-
-static unsigned max_hash_table_entries = 0;
-
-void
-hash_init()
-{
- if(!hashIds) {
- /*NOTHING*/;
-
- } else {
-
- /* Create an initialised hash table */
- hashtab = (char **) calloc( hash_table_size, sizeof(char *) );
- if(hashtab == NULL)
- {
- fprintf(stderr,"Cannot allocate a hash table with %d entries -- insufficient memory\n",hash_table_size);
- exit(1);
- }
-#ifdef HSP_DEBUG
- fprintf(stderr,"hashtab = %x\n",hashtab);
-#endif
-
- /* Allow no more than 90% occupancy -- Divide first to avoid overflows with BIG tables! */
- max_hash_table_entries = (hash_table_size / 10) * 9;
- }
-}
-
-void
-print_hash_table()
-{
- if(hashIds)
- {
- unsigned i;
-
- printf("%u ",hash_table_size);
-
- for(i=0; i < hash_table_size; ++i)
- if(hashtab[i] != NULL)
- printf("(%u,%s) ",i,hashtab[i]);
- }
-}
-
-
-long int
-hash_index(ident)
- id ident;
-{
- return((char **) /* YURGH */ ident - hashtab);
-}
-
-
-/*
- The hash function. Returns 0 for Null strings.
-*/
-
-static unsigned hash_fn(char *ident)
-{
- unsigned len = (unsigned) strlen(ident);
- unsigned res;
-
- if(*ident == '\0')
- return( 0 );
-
- /* does not work well for hash tables with more than 35K elements */
- res = (((unsigned)ident[0]*631)+((unsigned)ident[len/2-1]*217)+((unsigned)ident[len-1]*43)+len)
- % hash_table_size;
-
-#ifdef HSP_DEBUG
- fprintf(stderr,"\"%s\" hashes to %d\n",ident,res);
-#endif
- return(res);
-}
-
-
-/*
- Install a literal identifier, such as "+" in hsparser.
- If we are not using hashing, just return the string.
-*/
-
-id
-install_literal(s)
- char *s;
-{
- return( hashIds? installid(s): s);
-}
-
-
-char *
-id_to_string(sp)
- id sp;
-{
- return( hashIds? *(char **)sp: (char *)sp );
-}
-
-id
-installid(s)
- char *s;
-{
- unsigned hash, count;
-
- if(!hashIds)
- return(xstrdup(s));
-
- for(hash = hash_fn(s),count=0; count<max_hash_table_entries; ++hash,++count)
- {
- if (hash >= hash_table_size) hash = 0;
-
- if(hashtab[hash] == NULL)
- {
- hashtab[hash] = xstrdup(s);
-#ifdef HSP_DEBUG
- fprintf(stderr,"New Hash Entry %x\n",(char *)&hashtab[hash]);
-#endif
- if ( count >= 100 ) {
- fprintf(stderr, "installid: %d collisions for %s\n", count, s);
- }
-
- return((char *)&hashtab[hash]);
- }
-
- if(strcmp(hashtab[hash],s) == 0)
- {
-#ifdef HSP_DEBUG
- fprintf(stderr,"Old Hash Entry %x (%s)\n",(char *)&hashtab[hash],hashtab[hash]);
-#endif
- if ( count >= 100 ) {
- fprintf(stderr, "installid: %d collisions for %s\n", count, s);
- }
-
- return((char *)&hashtab[hash]);
- }
- }
- fprintf(stderr,"Hash Table Contains more than %d entries -- make larger?\n",max_hash_table_entries);
- exit(1);
-}
-
-/**********************************************************************
-* *
-* *
-* Qualified Ids *
-* *
-* *
-**********************************************************************/
-
-id
-qid_to_id(q)
- qid q;
-{
- switch(tqid(q))
- {
- case noqual:
- return(gnoqual((struct Snoqual *)q));
- case aqual:
- return(gqualname((struct Saqual *)q));
- case gid:
- return(gidname((struct Sgid *)q));
- }
-}
-
-char *
-qid_to_string(q)
- qid q;
-{
- return(id_to_string(qid_to_id(q)));
-}
-
-char *
-qid_to_mod(q)
- qid q;
-{
- switch(tqid(q))
- {
- case noqual:
- return(NULL);
- case aqual:
- return(id_to_string(gqualmod((struct Saqual *)q)));
- case gid:
- return(NULL);
- }
-}
-
-char *
-qid_to_pmod(q)
- qid q;
-{
- char *mod = qid_to_mod(q);
- if (mod == NULL) mod = "?";
- return mod;
-}
-
-/* Darkly mysterious function used to construct "special-syntax"
- identifiers. These mean their prelude versions regardless of
- context, which is why they are distinguished.
-
- We build a gid node (rather than a qual or non-qual name node;
- look at qid.ugn) with a key (number) and a string. Here's the
- deal
-
- key
-
- ARROWCON function arrow ->
- LISTCON list type constructor [], or the empty list []
- UNITCON unit type constructor (), or the unit value ()
- n n-tuple type constructor (,,,)
-*/
-
-qid
-creategid(i)
- long i;
-{
- switch(i) {
- case ARROWGID:
- return(mkgid(i,install_literal("(->)")));
- case NILGID:
- return(mkgid(i,install_literal("[]")));
- case UNITGID:
- return(mkgid(i,install_literal("()")));
- default:
- {
- char tmp[64]; int c = 0;
- tmp[c++] = '(';
- while (c <= i) tmp[c++] = ',';
- tmp[c++] = ')';
- tmp[c] = '\0';
- return(mkgid(i,installid(tmp)));
- }
- }
-}
-
-/**********************************************************************
-* *
-* *
-* Memory Allocation *
-* *
-* *
-**********************************************************************/
-
-/* Malloc with error checking */
-
-char *
-xmalloc(length)
-unsigned length;
-{
- char *stuff = malloc(length);
-
- if (stuff == NULL) {
- fprintf(stderr, "xmalloc failed on a request for %d bytes\n", length);
- exit(1);
- }
- return (stuff);
-}
-
-char *
-xrealloc(ptr, length)
-char *ptr;
-unsigned length;
-{
- char *stuff = realloc(ptr, length);
-
- if (stuff == NULL) {
- fprintf(stderr, "xrealloc failed on a request for %d bytes\n", length);
- exit(1);
- }
- return (stuff);
-}
-
-/* Strdup with error checking */
-
-char *
-xstrdup(s)
-char *s;
-{
- unsigned len = strlen(s);
- return xstrndup(s, len);
-}
-
-/*
- * Strdup for possibly unterminated strings (e.g. substrings of longer strings)
- * with error checking. Handles NULs as well.
- */
-
-char *
-xstrndup(s, len)
-char *s;
-unsigned len;
-{
- char *p = xmalloc(len + 1);
-
- bcopy(s, p, len);
- p[len] = '\0';
-
- return (p);
-}
+++ /dev/null
-#ifndef ID_H
-#define ID_H
-
-typedef char *id;
-typedef id unkId; /* synonym */
-typedef id stringId; /* synonym */
-typedef id numId; /* synonym, for now */
-
-typedef struct { long len; char *bytes; } Hstring;
-typedef Hstring *hstring;
-
-long get_hstring_len PROTO((hstring));
-char *get_hstring_bytes PROTO((hstring));
-
-id installid PROTO((char *)); /* Create a new identifier */
-hstring installHstring PROTO((int, char *)); /* Create a new literal string */
-
-/* defines for special-syntax ids, see comment next
- to creategid()
-*/
-#define ARROWGID (-2)
-#define NILGID (-1)
-#define UNITGID (0)
-
-
-#endif
+++ /dev/null
-/*
- * Infix operator stuff -- modified from LML
- */
-
-#include <stdio.h>
-
-#include "hspincl.h"
-#include "hsparser.tab.h"
-#include "constants.h"
-#include "utils.h"
-
-static struct infix {
- char *imod;
- char *iop;
- short thismod;
- short unqualok;
- short ifixity;
- short iprecedence;
-} infixtab[MAX_INFIX];
-
-static int ninfix = 0;
-
-void
-makeinfix(opid, fixity, precedence, modid, imported,
- withas, impmodid, impasid, withqual,
- withspec, withhiding, importspec)
- id opid;
- int fixity, precedence;
- long imported, withas, withqual, withspec, withhiding;
- id modid, impmodid, impasid;
- list importspec;
-/*
- ToDo: Throw away infix operator if hidden by importspec!
-*/
-{
- int i;
- char *op = id_to_string(opid);
- char *mod = id_to_string(imported ? (withas ? impasid : impmodid) : modid);
- short thismod = ! imported;
- short unqualok = ! (imported && withqual);
-
- for(i=0; i < ninfix; ++i)
- {
- if(strcmp(op,infixtab[i].iop)==0 &&
- strcmp(mod,infixtab[i].imod)==0 &&
- unqualok==infixtab[i].unqualok)
- {
- /* Allow duplicate definitions if they are identical */
- if (infixtab[i].ifixity==fixity &&
- infixtab[i].iprecedence==precedence)
- {
- return;
- }
-
- /* Allow local definition to override an import */
- else if(thismod && !infixtab[i].thismod)
- {
- /*continue*/
- }
-
- else
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"%s.%s %s already declared to be %s %d\n",
- mod, op, unqualok ? "(unqualified)" : "(qualified)",
- infixstr(infixtab[i].ifixity),
- infixtab[i].iprecedence);
- hsperror(errbuf);
- }
- }
- }
-
- if (ninfix >= MAX_INFIX) {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"Too many Infix identifiers (> %d)",MAX_INFIX);
- hsperror(errbuf);
- }
-
-#ifdef HSP_DEBUG
- fprintf(stderr,"makeinfix: %s.%s, fixity=%d prec=%d\n",mod,op,infixint(fixity),precedence);
-#endif
- infixtab[ninfix].imod = mod;
- infixtab[ninfix].iop = op;
- infixtab[ninfix].thismod = thismod;
- infixtab[ninfix].unqualok = unqualok;
- infixtab[ninfix].ifixity = fixity;
- infixtab[ninfix].iprecedence = precedence;
- ninfix++;
-}
-
-struct infix *
-infixlookup(name)
- qid name;
-{
- int i;
- struct infix *found = NULL;
- char *op = qid_to_string(name);
- char *mod = qid_to_mod(name);
- short unqual = mod == NULL;
-
- for(i = 0; i < ninfix; i++)
- {
- if(strcmp(op,infixtab[i].iop)==0 &&
- ( (unqual && infixtab[i].unqualok) ||
- (!unqual && strcmp(mod,infixtab[i].imod)==0)
- ))
- {
- if (! found)
- {
- /* first find */
- found = infixtab+i;
- }
- else if (found && ! found->thismod && infixtab[i].thismod)
- {
- /* new find for this module; overrides */
- found = infixtab+i;
- }
- else if (found && found->thismod && ! infixtab[i].thismod)
- {
- /* prev find for this module */
- }
- else if (found->ifixity == infixtab[i].ifixity &&
- found->iprecedence == infixtab[i].iprecedence)
- {
- /* finds are identical */
- }
- else
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"conflicting infix declarations for %s.%s\n %s.%s %s (%s,%d) and %s.%s %s (%s,%d)\n",
- qid_to_pmod(name), op,
- found->imod, found->iop, found->unqualok ? "(unqualified)" : "(qualified)",
- infixstr(found->ifixity),found->iprecedence,
- infixtab[i].imod, infixtab[i].iop, infixtab[i].unqualok ? "(unqualified)" : "(qualified)",
- infixstr(infixtab[i].ifixity),infixtab[i].iprecedence);
- hsperror(errbuf);
-
- }
- }
- }
-
-#ifdef HSP_DEBUG
- fprintf(stderr,"infixlookup: %s.%s = fixity=%d prec=%d\n",qid_to_pmod(name),op,infixint(pfixity(found)),pprecedence(found));
-#endif
-
- return(found);
-}
-
-int
-pfixity(ip)
- struct infix *ip;
-{
- return(ip == NULL? INFIXL: ip->ifixity);
-}
-
-int
-pprecedence(ip)
- struct infix *ip;
-{
- return(ip == NULL? 9: ip->iprecedence);
-}
-
-char *
-infixstr(n)
- int n;
-{
- switch(n) {
- case INFIXL:
- return "infixl";
-
- case INFIXR:
- return "infixr";
-
- case INFIX:
- return "infix";
-
- default:
- hsperror("infixstr");
- }
-}
-
-long
-infixint(n)
- int n;
-{
- switch(n) {
- case INFIXL:
- return -1;
-
- case INFIX:
- return 0;
-
- case INFIXR:
- return 1;
-
- default:
- hsperror("infixint");
- }
-}
-
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_list where
-
-#include "HsVersions.h"
-
-import UgenUtil
-%}}
-type list;
- lcons : < lhd : VOID_STAR;
- ltl : list; >;
- lnil : <>;
-end;
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_literal where
-
-#include "HsVersions.h"
-
-import UgenUtil
-%}}
-type literal;
- integer : < ginteger : stringId; >;
- intprim : < gintprim : stringId; >;
- floatr : < gfloatr : stringId; >;
- doubleprim : < gdoubleprim : stringId; >;
- floatprim : < gfloatprim : stringId; >;
- charr : < gchar : hstring; >;
- charprim : < gcharprim : hstring; >;
- string : < gstring : hstring; >;
- stringprim : < gstringprim : hstring; >;
- clitlit : < gclitlit : stringId; >;
-end;
+++ /dev/null
-/* This is the "top-level" file for the *standalone* hsp parser.
- See also hsclink.c. (WDP 94/10)
-*/
-
-#include <stdio.h>
-
-#include "hspincl.h"
-#include "constants.h"
-#include "utils.h"
-
-/*OLD:static char *progname;*/ /* The name of the program. */
-
-
-/**********************************************************************
-* *
-* *
-* The main program *
-* *
-* *
-**********************************************************************/
-
-int
-main(int argc, char **argv)
-{
- Lnil = mklnil(); /* The null list -- used in lsing, etc. */
-
- argv++; argc--;
- process_args(argc,argv);
-
- hash_init();
- yyinit();
-
- if(yyparse() == 0 && !etags)
- {
- /* No syntax errors. */
- pprogram(root);
- printf("\n");
- exit(0);
- }
- else if(etags)
- {
- exit(0);
- }
- else
- {
- /* There was a syntax error. */
- printf("\n");
- exit(1);
- }
-}
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_match where
-
-#include "HsVersions.h"
-
-import UgenUtil
-
-import U_list
-import U_maybe
-import U_grhsb
-%}}
-
-/* For case we have pmatch [pat] sig grhsb
- For lambda we have pmatch pats sig grhsb
- For a function binding we have pamtch [pat] sig grhsb
- In the function binding case, the 'pat' is actually
- an appliation of form (f p1 .. pn), or perhaps
- (p1 `op` p2) p3 ... pn
-*/
-
-type match;
- pmatch : < gmpats : list; /* of patterns */
- gmsig : maybe; /* maybe sig */
- gmrhsb : grhsb; /* guarded RHSs */
- >;
-end;
-
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_maybe where
-
-#include "HsVersions.h"
-
-import UgenUtil
-%}}
-type maybe;
- nothing : <> ;
- just : < gthing : VOID_STAR; > ;
-end;
+++ /dev/null
-/**********************************************************************
-* *
-* *
-* Syntax Tree Printing Routines *
-* *
-* *
-**********************************************************************/
-
-
-#define COMPACT TRUE /* No spaces in output -- #undef this for debugging */
-
-
-#include <stdio.h>
-
-#include "hspincl.h"
-#include "constants.h"
-#include "utils.h"
-
-/* fwd decls, necessary and otherwise */
-static void pbool PROTO( (BOOLEAN) );
-static void pconstr PROTO( (constr) );
-/* static void pcoresyn PROTO((coresyn)); */
-static void pentid PROTO( (entidt) );
-static void pgrhses PROTO( (list) );
-static void pid PROTO( (id) );
-static void plist PROTO( (void (*)(/*NOT WORTH IT: void * */), list) );
-static void pmaybe PROTO( (void (*)(), maybe) );
-static void pmaybe_list PROTO( (void (*)(), maybe) );
-/* static void ppragma PROTO( (hpragma) ); */
-static void pqid PROTO( (qid) );
-static void prbind PROTO( (binding) );
-static void pstr PROTO( (char *) );
-static void ptree PROTO( (tree) );
-static void ppgdexp PROTO( (gdexp) );
-static void pgrhsb PROTO( (grhsb) );
-static void ppmatch PROTO( (match) );
-static void pttype PROTO( (ttype) );
-static void plineno PROTO( (long) );
-
-extern char *input_filename;
-extern BOOLEAN hashIds;
-
-/* How to print tags */
-
-#if COMPACT
-#define PUTTAG(c) putchar(c);
-#define PUTTAGSTR(s) printf("%s",(s));
-#else
-#define PUTTAG(c) putchar(c); \
- putchar(' ');
-#define PUTTAGSTR(s) printf("%s",(s)); \
- putchar(' ');
-#endif
-
-
-/* Performs a post order walk of the tree
- to print it.
-*/
-
-void
-pprogram(t)
- tree t;
-{
- print_hash_table();
- ptree(t);
-}
-
-/* print_string: we must escape \t and \\, as described in
- char/string lexer comments. (WDP 94/11)
-*/
-static void
-print_string(hstring str)
-{
- char *gs;
- char c;
- int i, str_length;
-
- putchar('#');
- str_length = str->len;
- gs = str->bytes;
-
- for (i = 0; i < str_length; i++) {
- c = gs[i];
- if ( c == '\t' ) {
- putchar('\\');
- putchar('t');
- } else if ( c == '\\' ) {
- putchar('\\');
- putchar('\\');
- } else {
- putchar(gs[i]);
- }
- }
- putchar('\t');
-}
-
-static void
-plineno (l)
-long l;
-{
- printf("#%lu\t",l);
- return;
-}
-
-
-static int
-get_character(hstring str)
-{
- int c = (int)((str->bytes)[0]);
-
- if (str->len != 1) { /* ToDo: assert */
- fprintf(stderr, "get_character: length != 1? (%ld: %s)\n", str->len, str->bytes);
- }
-
- if (c < 0) {
- c += 256; /* "This is not a hack" -- KH */
- }
-
- return(c);
-}
-
-static void
-pliteral(literal t)
-{
- switch(tliteral(t)) {
- case integer:
- PUTTAG('4');
- pstr(ginteger(t));
- break;
- case intprim:
- PUTTAG('H');
- pstr(gintprim(t));
- break;
- case floatr:
- PUTTAG('F');
- pstr(gfloatr(t));
- break;
- case doubleprim:
- PUTTAG('J');
- pstr(gdoubleprim(t));
- break;
- case floatprim:
- PUTTAG('K');
- pstr(gfloatprim(t));
- break;
- case charr:
- PUTTAG('C');
- /* Changed %d to %u, since negative chars
- make little sense -- KH @ 16/4/91
- */
- printf("#%u\t", get_character(gchar(t)));
- break;
- case charprim:
- PUTTAG('P');
- printf("#%u\t", get_character(gcharprim(t)));
- break;
- case string:
- PUTTAG('S');
- print_string(gstring(t));
- break;
- case stringprim:
- PUTTAG('V');
- print_string(gstringprim(t));
- break;
- case clitlit:
- PUTTAG('Y');
- pstr(gclitlit(t));
- /* pstr(gclitlit_kind(t)); */
- break;
- default:
- error("Bad pliteral");
- }
-}
-
-static void
-ptree(t)
- tree t;
-{
-again:
- switch(ttree(t)) {
- case hmodule:
- PUTTAG('M');
- plineno(ghmodline(t));
- pid(ghname(t));
- printf("#%lu\t",ghversion(t));
- pstr(input_filename);
- prbind(ghmodlist(t));
- /* pfixes(); */
- plist(prbind, ghimplist(t));
- pmaybe_list(pentid, ghexplist(t));
- break;
- case ident:
- PUTTAG('i');
- pqid(gident(t));
- break;
- case lit:
- PUTTAG('C');
- pliteral(glit(t));
- break;
-
- case ap:
- PUTTAG('a');
- ptree(gfun(t));
- ptree(garg(t));
- break;
- case infixap:
- PUTTAG('@');
- pqid(ginffun(t));
- ptree(ginfarg1(t));
- ptree(ginfarg2(t));
- break;
- case negate:
- PUTTAG('-');
- ptree(gnexp(t));
- break;
- case lambda:
- PUTTAG('l');
- ppmatch(glammatch(t));
- break;
-
- case let:
- PUTTAG('E');
- prbind(gletvdefs(t));
- ptree(gletvexpr(t));
- break;
- case casee:
- PUTTAG('c');
- plineno(gcaseline(t));
- ptree(gcaseexpr(t));
- plist(ppmatch, gcasebody(t));
- break;
- case ife:
- PUTTAG('b');
- ptree(gifpred(t));
- ptree(gifthen(t));
- ptree(gifelse(t));
- break;
- case doe:
- PUTTAG('O');
- plineno(gdoline(t));
- plist(ptree, gdo(t));
- break;
- case dobind:
- PUTTAG('Q');
- plineno(gdobindline(t));
- ptree(gdobindpat(t));
- ptree(gdobindexp(t));
- break;
- case doexp:
- PUTTAG('R');
- plineno(gdoexpline(t));
- ptree(gdoexp(t));
- break;
- case seqlet:
- PUTTAG('U');
- prbind(gseqlet(t));
- break;
- case record:
- PUTTAG('d');
- pqid(grcon(t));
- plist(prbind,grbinds(t));
- break;
-
- case rupdate:
- PUTTAG('h');
- ptree(gupdexp(t));
- plist(prbind,gupdbinds(t));
- break;
-
- case rbind:
- PUTTAG('o');
- pqid(grbindvar(t));
- pmaybe(ptree,grbindexp(t));
- break;
-
- case par: t = gpare(t); goto again;
-
- case as:
- PUTTAG('s');
- pqid(gasid(t));
- ptree(gase(t));
- break;
- case lazyp:
- PUTTAG('~');
- ptree(glazyp(t));
- break;
- case wildp:
- PUTTAG('_');
- break;
-
- case restr:
- PUTTAG('R');
- ptree(grestre(t));
- pttype(grestrt(t));
- break;
- case tuple:
- PUTTAG(',');
- plist(ptree,gtuplelist(t));
- break;
- case llist:
- PUTTAG(':');
- plist(ptree,gllist(t));
- break;
- case eenum:
- PUTTAG('.');
- ptree(gefrom(t));
- pmaybe(ptree,gestep(t));
- pmaybe(ptree,geto(t));
- break;
- case comprh:
- PUTTAG('Z');
- ptree(gcexp(t));
- plist(ptree,gcquals(t));
- break;
- case qual:
- PUTTAG('G');
- ptree(gqpat(t));
- ptree(gqexp(t));
- break;
- case guard:
- PUTTAG('g');
- ptree(ggexp(t));
- break;
- case lsection:
- PUTTAG('(');
- ptree(glsexp(t));
- pqid(glsop(t));
- break;
- case rsection:
- PUTTAG(')');
- pqid(grsop(t));
- ptree(grsexp(t));
- break;
- case ccall:
- PUTTAG('j');
- pstr(gccid(t));
- pstr(gccinfo(t));
- plist(ptree,gccargs(t));
- break;
- case scc:
- PUTTAG('k');
- print_string(gsccid(t));
- ptree(gsccexp(t));
- break;
- default:
- error("Bad ptree");
- }
-}
-
-static void
-plist(fun, l)
- void (*fun)(/* NOT WORTH IT: void * */);
- list l;
-{
- if (tlist(l) == lnil) {
- PUTTAG('N');
- } else {
- PUTTAG('L');
- (*fun)(lhd(l));
- plist(fun, ltl(l));
- }
-}
-
-static void
-pmaybe(fun, m)
- void (*fun)(/* NOT WORTH IT: void * */);
- maybe m;
-{
- if (tmaybe(m) == nothing) {
- PUTTAG('N');
- } else {
- PUTTAG('J');
- (*fun)(gthing(m));
- }
-}
-
-static void
-pmaybe_list(fun, m)
- void (*fun)(/* NOT WORTH IT: void * */);
- maybe m;
-{
- if (tmaybe(m) == nothing) {
- PUTTAG('N');
- } else {
- PUTTAG('J');
- plist(fun, gthing(m));
- }
-}
-
-static void
-pid(i)
- id i;
-{
- if(hashIds)
- printf("!%lu\t", hash_index(i));
- else
- printf("#%s\t", id_to_string(i));
-}
-
-static void
-pqid(i)
- qid i;
-{
- if(hashIds)
- printf("!%lu\t", hash_index(qid_to_id(i)));
- else
- printf("#%s\t", qid_to_string(i));
-}
-
-static void
-pstr(i)
- char *i;
-{
- printf("#%s\t", i);
-}
-
-static void
-prbind(b)
- binding b;
-{
- switch(tbinding(b)) {
- case tbind:
- PUTTAG('t');
- plineno(gtline(b));
- plist(pttype, gtbindc(b));
- pmaybe_list(pid, gtbindd(b));
- pttype(gtbindid(b));
- plist(pconstr, gtbindl(b));
- break;
- case ntbind:
- PUTTAG('q');
- plineno(gntline(b));
- plist(pttype,gntbindcty(b));
- pmaybe_list(pid, gntbindd(b));
- pttype(gntbindid(b));
- plist(pconstr, gntbindcty(b));
- break;
- case nbind :
- PUTTAG('n');
- plineno(gnline(b));
- pttype(gnbindid(b));
- pttype(gnbindas(b));
- break;
- case pbind :
- PUTTAG('p');
- ptree( gpbindl(b) );
- pgrhsb( gpbindr(b) );
- plineno(gpline(b));
- break;
- case fbind :
- PUTTAG('f');
- plist(ppmatch, gfbindm(b));
- plineno(gfline(b));
- break;
- case abind :
- PUTTAG('A');
- prbind(gabindfst(b));
- prbind(gabindsnd(b));
- break;
- case ibind :
- PUTTAG('%');
- plineno(giline(b));
- pttype(gibindi(b));
- prbind(gibindw(b));
- /* ppragma(gipragma(b)); */
- break;
- case dbind :
- PUTTAG('D');
- plineno(gdline(b));
- plist(pttype,gdbindts(b));
- break;
-
- case cbind :
- PUTTAG('$');
- plineno(gcline(b));
- plist(pttype,gcbindc(b));
- pttype(gcbindid(b));
- prbind(gcbindw(b));
- break;
-
- /* signature(-like) things, including user pragmas */
- case sbind :
- PUTTAG('r');
- plineno(gsline(b));
- plist(pqid,gsbindids(b));
- pttype(gsbindid(b));
- break;
-
- case nullbind :
- PUTTAG('B');
- break;
-
- case fixd:
- PUTTAG('I');
- pqid(gfixop(b));
- printf("%lu\t%lu",gfixinfx(b),gfixprec(b));
- break;
-
- case import:
- PUTTAG('e');
- plineno(gibindline(b));
- /* pid(gibindfile(b)); */
- pid(gibindimod(b));
- printf("#%lu\t",gibindqual(b)); /* 1 -- qualified */
- printf("#%lu\t",gibindsource(b)); /* 1 -- from source */
- pmaybe(pid, gibindas(b));
- pmaybe(pconstr, gibindspec(b));
- /* plist(pentid,giebindexp(b)); ??? */
- /* prbind(giebinddef(b)); ???? */
- break;
-
- /* User pragmas till the end */
-
- case vspec_uprag:
- PUTTAGSTR("Ss");
- plineno(gvspec_line(b));
- pqid(gvspec_id(b));
- plist(pttype,gvspec_tys(b));
- break;
- case vspec_ty_and_id:
- PUTTAGSTR("St");
- pttype(gvspec_ty(b));
- pmaybe(pttype,gvspec_tyid(b));
- break;
-
- case ispec_uprag:
- PUTTAGSTR("SS");
- plineno(gispec_line(b));
- pttype(gispec_ty(b));
- break;
- case inline_uprag:
- PUTTAGSTR("Si");
- plineno(ginline_line(b));
- pqid(ginline_id(b));
- break;
- case magicuf_uprag:
- PUTTAGSTR("Su");
- plineno(gmagicuf_line(b));
- pqid(gmagicuf_id(b));
- pid(gmagicuf_str(b));
- break;
- case dspec_uprag:
- PUTTAGSTR("Sd");
- plineno(gdspec_line(b));
- pqid(gdspec_id(b));
- plist(pttype,gdspec_tys(b));
- break;
-
- /* end of signature(-like) things */
-/* not used:
- case mbind:
- PUTTAG('7');
- plineno(gmline(b));
- pid(gmbindmodn(b));
- plist(pentid,gmbindimp(b));
- break;
-*/
- default : error("Bad prbind");
- break;
- }
-}
-
-static void
-pttype(t)
- ttype t;
-{
- switch (tttype(t)) {
- case tname : PUTTAG('T');
- pqid(gtypeid(t));
- break;
- case namedtvar : PUTTAG('y');
- pstr(gnamedtvar(t));
- break;
- case tllist : PUTTAG(':');
- pttype(gtlist(t));
- break;
- case ttuple : PUTTAG(',');
- plist(pttype,gttuple(t));
- break;
- case tfun : PUTTAG('>');
- pttype(gtin(t));
- pttype(gtout(t));
- break;
- case tapp : PUTTAG('@');
- pttype(gtapp(t));
- pttype(gtarg(t));
- break;
- case tbang : PUTTAG('!');
- pttype(gtbang(t));
- break;
- case forall : PUTTAG('3');
- plist(pstr, gtforalltv(t));
- plist(pttype,gtforallctxt(t));
- pttype(gtforallt(t));
- break;
- default : error("bad pttype");
- }
-}
-
-static void
-pconstr(a)
- constr a;
-{
- switch (tconstr(a)) {
- case constrpre :
- PUTTAG('1');
- plineno(gconcline(a));
- pqid(gconcid(a));
- plist(pttype, gconctypel(a));
- break;
- case constrinf :
- PUTTAG('2');
- plineno(gconiline(a));
- pqid(gconiop(a));
- pttype(gconity1(a));
- pttype(gconity2(a));
- break;
-
- case constrrec :
- PUTTAG('u');
- plineno(gconrline(a));
- pqid(gconrid(a));
- plist(pqid,gconrfieldl(a));
- break;
- case constrnew :
- PUTTAG('v');
- plineno(gconnline(a));
- pqid(gconnid(a));
- pttype(gconnty(a));
- break;
- case field :
- PUTTAG('5');
- plist(pqid,gfieldn(a));
- pttype(gfieldt(a));
- break;
- default : fprintf(stderr, "Bad tag in abstree %d\n", tconstr(a));
- exit(1);
- }
-}
-
-
-static void
-pentid(i)
- entidt i;
-{
- switch (tentidt(i)) {
- case entid : PUTTAG('x');
- pqid(gentid(i));
- break;
- case enttype : PUTTAG('X');
- pqid(gtentid(i));
- break;
- case enttypeall : PUTTAG('z');
- pqid(gaentid(i));
- break;
- case enttypenamed:PUTTAG('8');
- pqid(gnentid(i));
- plist(pqid,gnentnames(i));
- break;
- case entmod : PUTTAG('m');
- pid(gmentid(i));
- break;
- default :
- error("Bad pentid");
- }
-}
-
-
-static void ppmatch(l) match l; { fprintf( stderr, "printtree.c: ppmatch" ); }
-static void ppgdexp(l) gdexp l; { fprintf( stderr, "printtree.c: ppgdexp" ); }
-static void pgrhsb(l) grhsb l; { fprintf( stderr, "printtree.c: pgrhsb" ); }
-
-static void
-pgrhses(l)
- list l;
-{
- ptree(lhd(l)); /* Guard */
- ptree(lhd(ltl(l))); /* Expression */
-}
-/*
-static void
-ppragma(p)
- hpragma p;
-{
- switch(thpragma(p)) {
- case no_pragma: PUTTAGSTR("PN");
- break;
- case idata_pragma: PUTTAGSTR("Pd");
- plist(pconstr, gprag_data_constrs(p));
- plist(ppragma, gprag_data_specs(p));
- break;
- case itype_pragma: PUTTAGSTR("Pt");
- break;
- case iclas_pragma: PUTTAGSTR("Pc");
- plist(ppragma, gprag_clas(p));
- break;
- case iclasop_pragma: PUTTAGSTR("Po");
- ppragma(gprag_dsel(p));
- ppragma(gprag_defm(p));
- break;
-
- case iinst_simpl_pragma: PUTTAGSTR("Pis");
-/ * pid(gprag_imod_simpl(p));
-* / ppragma(gprag_dfun_simpl(p));
- break;
- case iinst_const_pragma: PUTTAGSTR("Pic");
-/ * pid(gprag_imod_const(p));
-* / ppragma(gprag_dfun_const(p));
- plist(ppragma, gprag_constms(p));
- break;
-
- case igen_pragma: PUTTAGSTR("Pg");
- ppragma(gprag_arity(p));
- ppragma(gprag_update(p));
- ppragma(gprag_strictness(p));
- ppragma(gprag_unfolding(p));
- plist(ppragma, gprag_specs(p));
- break;
- case iarity_pragma: PUTTAGSTR("PA");
- pid(gprag_arity_val(p));
- break;
- case iupdate_pragma: PUTTAGSTR("Pu");
- pid(gprag_update_val(p));
- break;
- case istrictness_pragma: PUTTAGSTR("PS");
- print_string(gprag_strict_spec(p));
- ppragma(gprag_strict_wrkr(p));
- break;
- case imagic_unfolding_pragma: PUTTAGSTR("PM");
- pid(gprag_magic_str(p));
- break;
-
- case iunfolding_pragma: PUTTAGSTR("PU");
- ppragma(gprag_unfold_guide(p));
- pcoresyn(gprag_unfold_core(p));
- break;
-
- case iunfold_always: PUTTAGSTR("Px");
- break;
- case iunfold_if_args: PUTTAGSTR("Py");
- pid(gprag_unfold_if_t_args(p));
- pid(gprag_unfold_if_v_args(p));
- pid(gprag_unfold_if_con_args(p));
- pid(gprag_unfold_if_size(p));
- break;
-
- case iname_pragma_pr: PUTTAGSTR("P1");
- pid(gprag_name_pr1(p));
- ppragma(gprag_name_pr2(p));
- break;
- case itype_pragma_pr: PUTTAGSTR("P2");
- plist(pttype, gprag_type_pr1(p));
- pid(gprag_type_pr2(p));
- ppragma(gprag_type_pr3(p));
- break;
-
- case idata_pragma_4s: PUTTAGSTR("P4");
- plist(pttype, gprag_data_spec(p));
- break;
-
- default: error("Bad Pragma");
- }
-}
-*/
-
-static void
-pbool(b)
- BOOLEAN b;
-{
- if (b) {
- putchar('T');
- } else {
- putchar('F');
- }
-}
-
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_qid where
-
-#include "HsVersions.h"
-
-import UgenUtil
-%}}
-type qid;
- noqual : < gnoqual : stringId; >;
- aqual : < gqualmod : stringId;
- gqualname : stringId; >;
- gid : < ggid : long;
- gidname : stringId; >;
-end;
-
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_rulevar where
-
-#include "HsVersions.h"
-
-import UgenUtil
-
-import U_ttype
-import U_list
-import U_tree
-%}}
-
-type rulevar;
- prulevar : < gpvar : stringId ; >; /* Variable without signature */
-
- prulevarsig : < gpsigvar : stringId ; /* With signature */
- gpsigsig : ttype ; >;
-end;
+++ /dev/null
-/**********************************************************************
-* *
-* *
-* Syntax-related Utility Functions *
-* *
-* *
-**********************************************************************/
-
-#include <stdio.h>
-#include <ctype.h>
-
-#include "hspincl.h"
-#include "constants.h"
-#include "utils.h"
-#include "tree.h"
-#include "list.h"
-
-#include "hsparser.tab.h"
-
-/* Imported values */
-extern short icontexts;
-extern list Lnil;
-extern unsigned endlineno, startlineno;
-extern BOOLEAN hashIds, etags;
-
-/* Forward Declarations */
-
-char *ineg PROTO((char *));
-static tree unparen PROTO((tree));
-static void is_conapp_patt PROTO((int, tree, tree));
-static void rearrangeprec PROTO((tree, tree));
-static void error_if_expr_wanted PROTO((int, char *));
-static void error_if_patt_wanted PROTO((int, char *));
-
-qid fns[MAX_CONTEXTS] = { NULL };
-BOOLEAN samefn[MAX_CONTEXTS] = { FALSE };
-tree prevpatt[MAX_CONTEXTS] = { NULL };
-
-static BOOLEAN checkorder2 PROTO((binding, BOOLEAN));
-static BOOLEAN checksig PROTO((BOOLEAN, binding));
-
-/*
- check infix value in range 0..9
-*/
-
-
-int
-checkfixity(vals)
- char *vals;
-{
- int value;
- sscanf(vals,"%d",&value);
-
- if (value < 0 || value > 9)
- {
- int oldvalue = value;
- value = value < 0 ? 0 : 9;
- fprintf(stderr,"Precedence must be between 0 and 9 (value given: %d, changed to %d)\n",
- oldvalue,value);
- }
- return(value);
-}
-
-
-/*
- We've found a function definition. See if it defines the
- same function as the previous definition (at this indentation level).
- If so, set SAMEFN.
- Set FN to the name of the function.
-*/
-
-void
-checksamefn(lhs)
- tree lhs;
-{
- tree fn;
- qid fn_id;
- char *this, *was;
-
- fn = function(lhs);
-
- if (ttree(fn) == ident) {
- fn_id = gident((struct Sident *) fn);
- }
- else if (ttree(fn) == infixap) {
- fn_id = ginffun((struct Sinfixap *) fn);
- }
- else {
- fprintf( stderr, "Wierd funlhs" );
- return;
- }
-
- this = qid_to_string(fn_id);
- was = (FN==NULL) ? NULL : qid_to_string(FN);
- SAMEFN = (was != NULL && strcmp(this,was) == 0);
- FN = fn_id;
-
- if(!SAMEFN && etags)
-#if 1/*etags*/
- printf("%u\n",startlineno);
-#else
- fprintf(stderr,"%u\tchecksamefn:%s\n",startlineno,this);
-#endif
-}
-
-
-/* ------------------------------------------------------------------------
-*/
-
-void
-expORpat(int wanted, tree e)
-{
- switch(ttree(e))
- {
- case ident: /* a pattern or expr */
- break;
-
- case wildp:
- error_if_expr_wanted(wanted, "wildcard in expression");
- break;
-
- case as:
- error_if_expr_wanted(wanted, "`as'-pattern instead of an expression");
- expORpat(wanted, gase(e));
- break;
-
- case lazyp:
- error_if_expr_wanted(wanted, "irrefutable pattern instead of an expression");
- expORpat(wanted, glazyp(e));
- break;
-
- case plusp:
- break;
-
- case lit:
- switch (tliteral(glit(e))) {
- case integer:
- case intprim:
- case floatr:
- case doubleprim:
- case floatprim:
- case string:
- case stringprim:
- case charr:
- case charprim:
- break; /* pattern or expr */
-
- case clitlit:
- error_if_patt_wanted(wanted, "``literal-literal'' in pattern");
- break;
-
- default: /* the others only occur in pragmas */
- hsperror("not a valid literal pattern or expression");
- }
- break;
-
- case negate:
- { tree sub = gnexp(e);
- if (ttree(sub) != lit) {
- error_if_patt_wanted(wanted, "\"-\" applied to a non-literal");
- } else {
- literal l = glit(sub);
-
- if (tliteral(l) != integer && tliteral(l) != floatr) {
- error_if_patt_wanted(wanted, "\"-\" applied to a non-number");
- }
- }
- expORpat(wanted, sub);
- }
- break;
-
- case ap:
- {
- tree f = gfun(e);
- tree a = garg(e);
-
- is_conapp_patt(wanted, f, a); /* does nothing unless wanted == LEGIT_PATT */
- expORpat(wanted, f);
- expORpat(wanted, a);
- }
- break;
-
- case infixap:
- {
- qid f = ginffun ((struct Sinfixap *)e);
- tree a1 = ginfarg1((struct Sinfixap *)e);
- tree a2 = ginfarg2((struct Sinfixap *)e);
-
- expORpat(wanted, a1);
- expORpat(wanted, a2);
-
- if (wanted == LEGIT_PATT && !isconstr(qid_to_string(f)))
- hsperror("variable application in pattern");
- }
- break;
-
- case record:
- {
- list field;
- for (field = grbinds(e); tlist(field) == lcons; field = ltl(field)) {
- expORpat(wanted, lhd(field));
- }
- }
- break;
-
- case rbind:
- if (tmaybe(grbindexp(e)) == just)
- expORpat(wanted, gthing(grbindexp(e)));
- break;
-
- case tuple:
- {
- list tup;
- for (tup = gtuplelist(e); tlist(tup) == lcons; tup = ltl(tup)) {
- expORpat(wanted, lhd(tup));
- }
- }
- break;
-
- case utuple:
- {
- list tup;
- for (tup = gutuplelist(e); tlist(tup) == lcons; tup = ltl(tup)) {
- expORpat(wanted, lhd(tup));
- }
- }
- break;
-
- case llist:
- {
- list l;
- for (l = gllist(e); tlist(l) == lcons; l = ltl(l)) {
- expORpat(wanted, lhd(l));
- }
- }
- break;
-
- case restr: /* type sig */
- expORpat(wanted, grestre(e));
- break;
-
- case par: /* parenthesised */
- expORpat(wanted, gpare(e));
- break;
-
- case lambda:
- case let:
- case casee:
- case ife:
- case doe:
- case ccall:
- case scc:
- case rupdate:
- case comprh:
- case eenum:
- case lsection:
- case rsection:
- error_if_patt_wanted(wanted, "unexpected construct in a pattern");
- break;
-
- default:
- hsperror("not a pattern or expression");
- }
-}
-
-static void
-is_conapp_patt(int wanted, tree f, tree a)
-{
- if (wanted == LEGIT_EXPR)
- return; /* that was easy */
-
- switch(ttree(f))
- {
- case ident:
- if (isconstr(qid_to_string(gident(f))))
- {
- expORpat(wanted, a);
- return;
- }
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"not a constructor application -- %s",qid_to_string(gident(f)));
- hsperror(errbuf);
- }
-
- case ap:
- is_conapp_patt(wanted, gfun(f), garg(f));
- expORpat(wanted, a);
- return;
-
- case par:
- is_conapp_patt(wanted, gpare(f), a);
- break;
-
- case tuple:
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"tuple pattern `applied' to arguments (missing comma?)");
- hsperror(errbuf);
- }
- break;
-
- default:
- hsperror("not a constructor application");
- }
-}
-
-static void
-error_if_expr_wanted(int wanted, char *msg)
-{
- if (wanted == LEGIT_EXPR)
- hsperror(msg);
-}
-
-static void
-error_if_patt_wanted(int wanted, char *msg)
-{
- if (wanted == LEGIT_PATT)
- hsperror(msg);
-}
-
-/* ---------------------------------------------------------------------- */
-
-
-BOOLEAN /* return TRUE if LHS is a pattern */
-lhs_is_patt(tree e)
-{
- switch(ttree(e))
- {
- case lit:
- switch (tliteral(glit(e))) {
- case integer:
- case intprim:
- case floatr:
- case doubleprim:
- case floatprim:
- case string:
- case charr:
- case charprim:
- case stringprim:
- return TRUE;
- default:
- hsperror("Literal is not a valid LHS");
- }
-
- case wildp:
- return TRUE;
-
- case as:
- case lazyp:
- case llist:
- case tuple:
- case negate:
- case record:
- expORpat(LEGIT_PATT, e);
- return TRUE;
-
- case ident:
- return(TRUE);
-
- case ap:
- {
- tree f = function(e);
-
-/* These lines appear to duplicate what's in function(e).
- Nuked SLPJ May 97
-
- tree a = garg(e); -- do not "unparen", otherwise the error
- -- fromInteger ((x,y) {-no comma-} z)
- -- will be missed.
-
- -- definitions must have pattern arguments
- expORpat(LEGIT_PATT, a);
-*/
-
- if(ttree(f) == ident)
- return(isconstr(qid_to_string(gident(f))));
-
- else if(ttree(f) == infixap)
- return(lhs_is_patt(f));
-
- else
- hsperror("Syntax error: not a legal pattern binding in LHS");
- }
-
- case infixap:
- {
- qid f = ginffun((struct Sinfixap *)e);
- tree a1 = unparen(ginfarg1((struct Sinfixap *)e)),
- a2 = unparen(ginfarg2((struct Sinfixap *)e));
-
- /* definitions must have pattern arguments */
- expORpat(LEGIT_PATT, a1);
- expORpat(LEGIT_PATT, a2);
-
- return(isconstr(qid_to_string(f)));
- }
-
- case par:
- return(lhs_is_patt(gpare(e)));
-
- /* Anything else must be an illegal LHS */
- default:
- hsperror("Syntax error: not a valid LHS");
- }
-
- abort(); /* should never get here */
- return(FALSE);
-}
-
-
-/*
- Return the function at the root of a series of applications,
- checking on the way that the arguments are patterns.
-*/
-
-tree
-function(e)
- tree e;
-{
- switch (ttree(e))
- {
- case ap:
- expORpat(LEGIT_PATT, garg(e));
- return(function(gfun(e)));
-
- case par:
- return(function(gpare(e)));
-
- default:
- return(e);
- }
-}
-
-
-static tree
-unparen(e)
- tree e;
-{
- while (ttree(e) == par)
- e = gpare(e);
-
- return(e);
-}
-
-
-/*
- Extend a function by adding a new definition to its list of bindings.
-*/
-
-void
-extendfn(bind,rule)
-binding bind;
-binding rule;
-{
-/* fprintf(stderr,"extending binding (%d)\n",tbinding(bind));*/
- if(tbinding(bind) == abind)
- bind = gabindsnd(bind);
-
- /* if(tbinding(bind) == pbind)
- gpbindl(bind) = lconc(gpbindl(bind), gpbindl(rule));
-
- else */
-
- if(tbinding(bind) == fbind)
- gfbindm(bind) = lconc(gfbindm(bind), gfbindm(rule));
- else
- fprintf(stderr,"bind error in decl (%d)\n",tbinding(bind));
-}
-
-
-char *
-ineg(i)
- char *i;
-{
- char *p = xmalloc(strlen(i)+2);
-
- *p = '-';
- strcpy(p+1,i);
- return(p);
-}
-
-/*
- Check the ordering of declarations in a cbody.
- All signatures must appear before any declarations.
-*/
-
-void
-checkorder(decls)
- binding decls;
-{
- /* The ordering must be correct for a singleton */
- if(tbinding(decls)!=abind)
- return;
-
- checkorder2(decls,TRUE);
-}
-
-static BOOLEAN
-checkorder2(decls,sigs)
- binding decls;
- BOOLEAN sigs;
-{
- while(tbinding(decls)==abind)
- {
- /* Perform a left-traversal if necessary */
- binding left = gabindfst(decls);
- if(tbinding(left)==abind)
- sigs = checkorder2(left,sigs);
- else
- sigs = checksig(sigs,left);
- decls = gabindsnd(decls);
- }
-
- return(checksig(sigs,decls));
-}
-
-static BOOLEAN
-checksig(sig,decl)
- BOOLEAN sig;
- binding decl;
-{
- BOOLEAN issig = tbinding(decl) == sbind || tbinding(decl) == nullbind;
- if(!sig && issig)
- hsperror("Signature appears after definition in class body");
-
- return(issig);
-}
-
-
-/*
- Check the last expression in a list of do statements.
-*/
-
-void
-checkdostmts(stmts)
- list stmts;
-{
- if (tlist(stmts) == lnil)
- hsperror("do expression with no statements");
-
- for(; tlist(ltl(stmts)) != lnil; stmts = ltl(stmts))
- ;
- if (ttree(lhd(stmts)) != doexp)
- hsperror("do statements must end with expression");
-}
-
-
-/*
- Checks there are no bangs in a tycon application.
-*/
-
-void
-checknobangs(app)
- ttype app;
-{
- if(tttype(app) == tapp)
- {
- if(tttype(gtarg((struct Stapp *)app)) == tbang)
- hsperror("syntax error: unexpected ! in type");
-
- checknobangs(gtapp((struct Stapp *)app));
- }
-}
-
-/* Check that a type is of the form
- C a1 a2 .. an
- where n>=1, and the ai are all type variables
- This is used to check that a class decl is well formed.
-*/
-void
-check_class_decl_head_help( app, n )
- ttype app;
- int n; /* Number of args so far */
-{
- switch (tttype(app)) {
- case tapp:
- /* Check the arg is a type variable */
- switch (tttype (gtarg((struct Stapp *) app))) {
- case namedtvar: break;
- default: hsperror("Class declaration head must use only type variables");
- }
-
- /* Check the fun part */
- check_class_decl_head_help( gtapp((struct Stapp *) app), n+1 );
- break;
-
- case tname:
- /* Class name; check there is at least one argument */
- if (n==0) {
- hsperror("Class must have at least one argument");
- }
- break;
-
- default:
- hsperror("Illegal syntax in class declaration head");
- }
-}
-
-void
-check_class_decl_head( app )
- ttype app;
-{ check_class_decl_head_help( app, 0 ); }
-
-
-
-/*
- Splits a tycon application into its constructor and a list of types.
-*/
-
-void
-splittyconapp(app, tyc, tys)
- ttype app;
- qid *tyc;
- list *tys;
-{
- switch (tttype(app)) {
- case tapp:
- splittyconapp(gtapp((struct Stapp *)app), tyc, tys);
- *tys = lapp(*tys, gtarg((struct Stapp *)app));
- break;
-
- case tname:
- case namedtvar:
- *tyc = gtypeid((struct Stname *)app);
- *tys = Lnil;
- break;
-
- default:
- hsperror("bad left argument to constructor op");
- }
-}
-
-
-#if 0
-
-Precedence Parsing Is Now Done In The Compiler !!!
-
-/*
-
- Precedence Parser for Haskell. By default operators are left-associative,
- so it is only necessary to rearrange the parse tree where the new operator
- has a greater precedence than the existing one, or where two operators have
- the same precedence and are both right-associative. Error conditions are
- handled.
-
- Note: Prefix negation has the same precedence as infix minus.
- The algorithm must thus take account of explicit negates.
-*/
-
-void
-precparse(tree t)
-{
- if(ttree(t) == infixap)
- {
- tree left = ginfarg1(t);
-
- if(ttree(left) == negate)
- {
- struct infix *ttabpos = infixlookup(ginffun(t));
- struct infix *ntabpos = infixlookup(mknoqual(install_literal("-")));
-
- if(pprecedence(ntabpos) < pprecedence(ttabpos))
- {
- /* (-x)*y ==> -(x*y) */
- qid lop = ginffun(t);
- tree arg1 = gnexp(left);
- tree arg2 = ginfarg2(t);
-
- t->tag = negate;
- gnexp(t) = left;
- gnxxx1(t) = NULL;
- gnxxx2(t) = NULL;
-
- left->tag = infixap;
- ginffun(left) = lop;
- ginfarg1(left) = arg1;
- ginfarg2(left) = arg2;
-
- precparse(left);
- }
- }
-
- else if(ttree(left) == infixap)
- {
- struct infix *ttabpos = infixlookup(ginffun(t));
- struct infix *lefttabpos = infixlookup(ginffun(left));
-
- if(pprecedence(lefttabpos) < pprecedence(ttabpos))
- rearrangeprec(left,t);
-
- else if(pprecedence(lefttabpos) == pprecedence(ttabpos))
- {
- if(pfixity(lefttabpos) == INFIXR && pfixity(ttabpos) == INFIXR)
- rearrangeprec(left,t);
-
- else if(pfixity(lefttabpos) == INFIXL && pfixity(ttabpos) == INFIXL)
- /* SKIP */;
-
- else
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"Cannot mix %s and %s in the same infix expression",
- qid_to_string(ginffun(left)), qid_to_string(ginffun(t)));
- hsperror(errbuf);
- }
- }
- }
- }
-}
-
-
-/*
- Rearrange a tree to effectively insert an operator in the correct place.
-
- x+y*z ==parsed== (x+y)*z ==> x+(y*z)
-
- The recursive call to precparse ensures this filters down as necessary.
-*/
-
-static void
-rearrangeprec(tree left, tree t)
-{
- qid top = ginffun(left);
- qid lop = ginffun(t);
- tree arg1 = ginfarg1(left);
- tree arg2 = ginfarg2(left);
- tree arg3 = ginfarg2(t);
-
- ginffun(t) = top;
- ginfarg1(t) = arg1;
- ginfarg2(t) = left;
-
- ginffun(left) = lop;
- ginfarg1(left) = arg2;
- ginfarg2(left) = arg3;
-
- precparse(left);
-}
-
-
-/*
- Check the precedence of a pattern or expression to ensure that
- sections and function definitions have the correct parse.
-*/
-
-void
-checkprec(exp,qfn,right)
- tree exp;
- qid qfn;
- BOOLEAN right;
-{
- if(ttree(exp) == infixap)
- {
- struct infix *ftabpos = infixlookup(qfn);
- struct infix *etabpos = infixlookup(ginffun(exp));
-
- if (pprecedence(etabpos) > pprecedence(ftabpos) ||
- (pprecedence(etabpos) == pprecedence(ftabpos) &&
- ((pfixity(etabpos) == INFIXR && pfixity(ftabpos) == INFIXR && right) ||
- ((pfixity(etabpos) == INFIXL && pfixity(ftabpos) == INFIXL && !right)))))
- /* SKIP */;
- else
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"Cannot mix %s and %s on a LHS or in a section",
- qid_to_string(qfn), qid_to_string(ginffun(exp)));
- hsperror(errbuf);
- }
- }
-}
-
-#endif /* 0 */
-
-
-
-/* Reverse a list, in place */
-
-list reverse_list( l )
- list l;
-{
- list temp, acc = Lnil;
-
- while (tlist( l ) != lnil) {
- temp = ltl( l );
- ltl( l ) = acc;
- acc = l;
- l = temp;
- }
- return( acc );
-}
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_tree where
-
-#include "HsVersions.h"
-
-import UgenUtil
-
-import U_constr ( U_constr ) -- interface only
-import U_binding
-import U_match
-import U_list
-import U_literal
-import U_maybe
-import U_qid
-import U_ttype
-%}}
-type tree;
- hmodule : < ghname : stringId;
- ghimplist : list; /* [import] */
- ghexplist : maybe; /* Maybe [entity] */
- ghmodlist : binding;
- ghversion : long;
- ghmodline : long; >;
-
- ident : < gident : qid; >;
- lit : < glit : literal; >;
-
- ap : < gfun : tree;
- garg : tree; >;
- infixap : < ginffun : qid;
- ginfarg1 : tree;
- ginfarg2 : tree; >;
- negate : < gnexp : tree; >;
-
- lambda : < glammatch : match;>;
-
- let : < gletvdefs : binding;
- gletvexpr : tree; >;
- casee : < gcaseexpr : tree;
- gcasebody : list; /* Of match */
- gcaseline : long; >;
- ife : < gifpred : tree;
- gifthen : tree;
- gifelse : tree;
- gifline : long; >;
- doe : < gdo : list;
- gdoline : long; >;
-
- dobind : < gdobindpat : tree;
- gdobindexp : tree;
- gdobindline : long; >;
- doexp : < gdoexp : tree;
- gdoexpline : long; >;
- seqlet : < gseqlet : binding; >;
-
- record : < grcon : qid;
- grbinds : list; >; /* [rbind] */
- rupdate : < gupdexp : tree;
- gupdbinds : list; >; /* [rbind] */
- rbind : < grbindvar : qid;
- grbindexp : maybe; >; /* Maybe expr */
-
- par : < gpare : tree; >;
- as : < gasid : qid;
- gase : tree; >;
- lazyp : < glazyp : tree; >;
- plusp : < gplusp : qid;
- gplusi : literal; >;
- wildp : < >;
- restr : < grestre : tree; /* type signature */
- grestrt : ttype; >;
-
- tuple : < gtuplelist : list; >;
- utuple : < gutuplelist : list; >;
- llist : < gllist : list; >;
- eenum : < gefrom : tree;
- gestep : maybe;
- geto : maybe; >;
- comprh : < gcexp : tree;
- gcquals : list; >;
- qual : < gqpat : tree;
- gqexp : tree; >;
- guard : < ggexp : tree; >;
-
- lsection: < glsexp : tree;
- glsop : qid; >;
- rsection: < grsop : qid;
- grsexp : tree; >;
-
- ccall : < gccid : stringId;
- gccinfo : stringId;
- gccargs : list; >;
- scc : < gsccid : hstring;
- gsccexp : tree; >;
-end;
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_ttype where
-
-#include "HsVersions.h"
-
-import UgenUtil
-
-import U_list
-import U_qid
-%}}
-type ttype;
- tname : < gtypeid : qid; >; /* tycon */
- namedtvar : < gnamedtvar : stringId; >; /* tvar */
- tllist : < gtlist : ttype; >;
- ttuple : < gttuple : list; >;
- tutuple : < gtutuple : list; >;
- tfun : < gtin : ttype;
- gtout : ttype; >;
- tapp : < gtapp : ttype;
- gtarg : ttype; >;
- tbang : < gtbang : ttype; >;
- forall : < gtforalltv : list; /* tyvars */
- gtforallctxt : list; /* theta */
- gtforallt : ttype; >;
- imp_forall : < gtiforallctxt : list ; /* Implicit forall; no explicit tyvars */
- gtiforallt : ttype; >;
-end;
-
+++ /dev/null
-/**********************************************************************
-* *
-* *
-* Convert Types to Contexts *
-* *
-* *
-**********************************************************************/
-
-
-#include <stdio.h>
-#include "hspincl.h"
-#include "constants.h"
-#include "utils.h"
-
-/*
- partain: see also the comment by "decl" in hsparser.y.
-
- Here, we've been given a type that must be of the form
- "C a" or "(C1 a, C2 a, ...)" [otherwise an error]
-
- Convert it to a list.
-*/
-
-
-list
-type2context(t)
- ttype t;
-{
- list args;
-
- switch (tttype(t)) {
- case ttuple:
- /* returning the list is OK, but ensure items are right format */
- args = gttuple(t);
-
- if (tlist(args) == lnil)
- hsperror ("type2context: () found instead of a context");
-
- while (tlist(args) != lnil)
- {
- is_context_format(lhd(args), 0);
- args = ltl(args);
- }
-
- return(gttuple(t)); /* args */
-
- case tname:
- switch(tqid(gtypeid(t))) {
- case gid:
- if (strcmp("()",gidname(gtypeid(t))) == 0)
- return (Lnil);
- default: ;
- }
- case tapp:
- /* a single item, ensure correct format */
- is_context_format(t, 0);
- return(lsing(t));
-
- case namedtvar:
- hsperror ("type2context: unexpected namedtvar found in a context");
-
- case tllist:
- hsperror ("type2context: list constructor found in a context");
-
- case tfun:
- hsperror ("type2context: arrow (->) constructor found in a context");
-
- default:
- hsperror ("type2context: totally unexpected input");
- }
- abort(); /* should never get here! */
-}
-
-
-/* is_context_format is the same as "type2context" except that it just performs checking */
-/* ttype is either "tycon" [class] or "tycon (named)tvar" [class var] */
-
-void
-is_context_format(t, tyvars)
- ttype t;
- int tyvars;
-{
- list rest_args;
- ttype first_arg;
-
- switch (tttype(t))
- {
- case tname :
- /* should be just: ":: C a =>" */
-
- if (tyvars == 0)
- hsperror("is_context_format: type missing after class name");
-
- /* tyvars > 0; everything is cool */
- break;
-
- case tapp:
- is_context_format(gtapp(t), tyvars+1);
- break;
-
- case ttuple:
- hsperror ("is_context_format: tuple found in a context");
-
- case namedtvar:
- hsperror ("is_context_format: unexpected namedtvar found in a context");
-
- case tllist:
- hsperror ("is_context_format: list constructor found in a context");
-
- case tfun:
- hsperror ("is_context_format: arrow (->) constructor found in a context");
- default:
- hsperror ("is_context_format: totally unexpected input");
- }
-}
-
-
+++ /dev/null
-/**********************************************************************
-* *
-* *
-* Declarations *
-* *
-* *
-**********************************************************************/
-
-#include "hspincl.h"
-#include "constants.h"
-#include "utils.h"
-
-tree root; /* The root of the built syntax tree. */
-list Lnil;
-
-BOOLEAN nonstandardFlag = FALSE; /* Set if non-std Haskell extensions to be used. */
-BOOLEAN etags = FALSE; /* Set if we're parsing only to produce tags. */
-BOOLEAN hashIds = FALSE; /* Set if Identifiers should be hashed. */
-
-BOOLEAN ignoreSCC = TRUE; /* Set if we ignore/filter scc expressions. */
-BOOLEAN warnSCC = FALSE; /* Set if we want to inform the user what _scc_s are
- being ignored. */
-
-/**********************************************************************
-* *
-* *
-* Utility Functions *
-* *
-* *
-**********************************************************************/
-
-# include <stdio.h>
-# include "constants.h"
-# include "hspincl.h"
-# include "utils.h"
-
-void
-process_args(argc,argv)
- int argc;
- char **argv;
-{
- BOOLEAN keep_munging_option = FALSE;
-
- while (argc > 0 && argv[0][0] == '-') {
-
- keep_munging_option = TRUE;
-
- while (keep_munging_option && *++*argv != '\0') {
- switch(**argv) {
-
- case 'D':
-#ifdef HSP_DEBUG
- { extern int yydebug;
- yydebug = 1;
- }
-#endif
- break;
-
- case 'E':
- etags = TRUE;
- break;
-
- /* -Hn -- Use Hash Table, Size n (if given) */
- case 'H':
- hashIds = TRUE;
- if(*(*argv+1)!= '\0')
- hash_table_size = atoi(*argv+1);
- break;
- case 'N':
- nonstandardFlag = TRUE;
- break;
-
- case 'S':
- ignoreSCC = FALSE;
- break;
-
- case 'W':
- warnSCC = TRUE;
- break;
-
- }
- }
- argc--, argv++;
- }
-
- if(argc >= 1 && freopen(argv[0], "r", stdin) == NULL) {
- fprintf(stderr, "Cannot open %s.\n", argv[0]);
- exit(1);
- }
-
- if(argc >= 2 && freopen(argv[1], "w", stdout) == NULL) {
- fprintf(stderr, "Cannot open %s.\n", argv[1]);
- exit(1);
- }
-}
-
-void
-error(s)
- char *s;
-{
- fprintf(stderr, "PARSER: Error %s\n", s);
- exit(1);
-}
-
-/* lconc l1 l2 appends l2 to the end of l1 */
-list
-lconc(l1, l2)
- list l1;
- list l2;
-{
- list t;
-
- if (tlist(l1) == lnil)
- return(l2);
- for(t = l1; tlist(ltl(t)) != lnil; t = ltl(t))
- ;
- ltl(t) = l2;
- return(l1);
-}
-
-/* lapp( l, x ) appends [x] to the end of list l */
-list
-lapp(list l1, VOID_STAR l2)
-{
- list t;
-
- if (tlist(l1) == lnil)
- return(mklcons(l2, mklnil()));
- for(t = l1; tlist(ltl(t)) != lnil; t = ltl(t))
- ;
- ltl(t) = mklcons(l2, mklnil());
- return(l1);
-}
+++ /dev/null
-/*
- Utility Definitions.
-*/
-
-#ifndef __UTILS_H
-#define __UTILS_H
-
-/* stuff from util.c */
-extern tree root;
-extern list Lnil;
-extern list all;
-
-extern BOOLEAN nonstandardFlag;
-extern BOOLEAN hashIds;
-extern BOOLEAN etags;
-
-extern BOOLEAN ignoreSCC;
-extern BOOLEAN warnSCC;
-
-extern unsigned hash_table_size;
-
-void process_args PROTO((int, char **));
-
-/* end of util.c stuff */
-
-list mklcons PROTO((void *h, list t)); /* if we have PROTO, we have "void *" */
-list lapp PROTO((list l1, void *l2));
-list lconc PROTO((list l1, list l2));
-
-#define lsing(l) mklcons(l, Lnil) /* Singleton Lists */
-#define ldub(l1, l2) mklcons(l1, lsing(l2)) /* Two-element Lists */
-
-#define FN fns[icontexts]
-#define SAMEFN samefn[icontexts]
-#define PREVPATT prevpatt[icontexts]
-
-id installid PROTO((char *)); /* Create a new identifier */
-hstring installHstring PROTO((int, char *)); /* Create a new literal string */
-
-id install_literal PROTO((char *));
-char *id_to_string PROTO((id));
-
-id qid_to_id PROTO((qid));
-char *qid_to_string PROTO((qid));
-char *qid_to_mod PROTO((qid)); /* NULL if unqual */
-char *qid_to_pmod PROTO((qid)); /* "?" if unqual */
-qid creategid PROTO((long));
-
-/* partain additions */
-
-char *xmalloc PROTO((unsigned)); /* just a GNU-style error-checking malloc */
-int printf PROTO((const char *, ...));
-int fprintf PROTO((FILE *, const char *, ...));
-/*varies (sun/alpha): int fputc PROTO((char, FILE *)); */
-int fputs PROTO((const char *, FILE *));
-int sscanf PROTO((const char *, const char *, ...));
-long strtol PROTO((const char *, char **, int));
-size_t fread PROTO((void *, size_t, size_t, FILE *));
-int fclose PROTO((FILE *));
-int isatty PROTO((int));
-/*extern ??? _filbuf */
-/*extern ??? _flsbuf */
-
-void pprogram PROTO((tree));
-
-void format_string PROTO((FILE *, unsigned char *, int));
-list type2context PROTO((ttype));
-void is_context_format PROTO((ttype, int));
-void process_args PROTO((int, char **));
-void hash_init PROTO((void));
-void print_hash_table PROTO((void));
-long int hash_index PROTO((id));
-void yyinit PROTO((void));
-int yyparse PROTO((void));
-int yylex PROTO((void));
-void setyyin PROTO((char *));
-void yyerror PROTO((char *));
-void error PROTO((char *));
-void hsperror PROTO((char *));
-
-void makeinfix PROTO((id, int, int, id, long, long, id, id, long, long, long, list));
-struct infix *infixlookup PROTO((qid));
-int pprecedence PROTO((struct infix *));
-int pfixity PROTO((struct infix *));
-char * infixstr PROTO((int));
-long infixint PROTO((int));
-
-void hsincindent PROTO((void));
-void hssetindent PROTO((void));
-void hsendindent PROTO((void));
-void hsindentoff PROTO((void));
-
-int checkfixity PROTO((char *));
-void checksamefn PROTO((tree));
-
-void expORpat PROTO((int,tree));
-/* the "int" arg says what we want; it is one of: */
-#define LEGIT_PATT 1
-#define LEGIT_EXPR 2
-
-BOOLEAN lhs_is_patt PROTO((tree));
-tree function PROTO((tree));
-void extendfn PROTO((binding, binding));
-void checkorder PROTO((binding));
-
-void checkdostmts PROTO((list));
-void checknobangs PROTO((ttype));
-void splittyconapp PROTO((ttype, qid *, list *));
-
-/*
-void precparse PROTO((tree));
-void checkprec PROTO((tree, qid, BOOLEAN));
-*/
-
-/* FFI predefines */
-#define CALLCONV_NONE (-1)
-#define CALLCONV_STDCALL 0
-#define CALLCONV_CCALL 1
-#define CALLCONV_PASCAL 2
-#define CALLCONV_FASTCALL 3
-
-#define FOREIGN_IMPORT 0
-#define FOREIGN_EXPORT 1
-#define FOREIGN_LABEL 2
-
-BOOLEAN isconstr PROTO((char *));
-void setstartlineno PROTO((void));
-
-/* mattson additions */
-char *xstrdup PROTO((char *)); /* Duplicate a string */
-char *xstrndup PROTO((char *, unsigned)); /* Duplicate a substring */
-char *xrealloc PROTO((char *, unsigned)); /* Re-allocate a string */
-
-#endif /* __UTILS_H */
\end{code}
\begin{code}
-pRELUDE_Name = mkSrcModule "Prelude"
+pRELUDE_Name = mkSrcModule "Prelude"
pREL_GHC_Name = mkSrcModule "PrelGHC" -- Primitive types and values
pREL_BASE_Name = mkSrcModule "PrelBase"
pREL_ENUM_Name = mkSrcModule "PrelEnum"
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[Lexical analysis]{Lexical analysis}
-
---------------------------------------------------------
-[Jan 98]
-There's a known bug in here:
-
- If an interface file ends prematurely, Lex tries to
- do headFS of an empty FastString.
-
-An example that provokes the error is
-
- f _:_ _forall_ [a] <<<END OF FILE>>>
---------------------------------------------------------
-
-\begin{code}
-{-# OPTIONS -#include "ctypes.h" #-}
-
-module Lex (
-
- ifaceParseErr,
-
- -- Monad for parser
- IfaceToken(..), lexIface, IfM, thenIf, returnIf, getSrcLocIf,
- checkVersion,
- happyError,
- StringBuffer
-
- ) where
-
-#include "HsVersions.h"
-
-import Char ( ord, isSpace )
-import List ( isSuffixOf )
-
-import IdInfo ( InlinePragInfo(..), CprInfo(..) )
-import Name ( isLowerISO, isUpperISO )
-import PrelMods ( mkTupNameStr, mkUbxTupNameStr )
-import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_HiVersion, opt_NoHiCheck )
-import Demand ( Demand(..) {- instance Read -} )
-import UniqFM ( UniqFM, listToUFM, lookupUFM)
-import BasicTypes ( NewOrData(..) )
-import SrcLoc ( SrcLoc, incSrcLine, srcLocFile )
-
-import Maybes ( MaybeErr(..) )
-import ErrUtils ( Message )
-import Outputable
-
-import FastString
-import StringBuffer
-import GlaExts
-import ST ( runST )
-
-#if __GLASGOW_HASKELL__ >= 303
-import Bits
-import Word
-#endif
-
-import Addr
-import PrelRead ( readRational__ ) -- Glasgow non-std
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Data types}
-%* *
-%************************************************************************
-
-The token data type, fairly un-interesting except from one
-constructor, @ITidinfo@, which is used to lazily lex id info (arity,
-strictness, unfolding etc).
-
-The Idea/Observation here is that the renamer needs to scan through
-all of an interface file before it can continue. But only a fraction
-of the information contained in the file turns out to be useful, so
-delaying as much as possible of the scanning and parsing of an
-interface file Makes Sense (Heap profiles of the compiler
-show a reduction in heap usage by at least a factor of two,
-post-renamer).
-
-Hence, the interface file lexer spots when value declarations are
-being scanned and return the @ITidinfo@ and @ITtype@ constructors
-for the type and any other id info for that binding (unfolding, strictness
-etc). These constructors are applied to the result of lexing these sub-chunks.
-
-The lexing of the type and id info is all done lazily, of course, so
-the scanning (and subsequent parsing) will be done *only* on the ids the
-renamer finds out that it is interested in. The rest will just be junked.
-Laziness, you know it makes sense :-)
-
-\begin{code}
-data IfaceToken
- = ITcase -- Haskell keywords
- | ITclass
- | ITdata
- | ITdefault
- | ITderiving
- | ITdo
- | ITelse
- | ITif
- | ITimport
- | ITin
- | ITinfix
- | ITinfixl
- | ITinfixr
- | ITinstance
- | ITlet
- | ITmodule
- | ITnewtype
- | ITof
- | ITthen
- | ITtype
- | ITwhere
- | ITas
- | ITqualified
- | IThiding
-
- | ITinterface -- GHC-extension keywords
- | ITexport
- | ITdepends
- | ITforall
- | ITletrec
- | ITcoerce
- | ITinlineCall
- | ITinlineMe
- | ITccall (Bool,Bool,Bool) -- (is_dyn, is_casm, may_gc)
- | ITdefaultbranch
- | ITbottom
- | ITinteger_lit
- | ITfloat_lit
- | ITrational_lit
- | ITaddr_lit
- | ITlit_lit
- | ITstring_lit
- | ITtypeapp
- | ITonce -- usage annotations
- | ITmany
- | ITarity
- | ITrules
- | ITspecialise
- | ITnocaf
- | ITunfold InlinePragInfo
- | ITstrict ([Demand], Bool)
- | ITcprinfo (CprInfo)
- | ITscc
- | ITsccAllCafs
-
- | ITdotdot -- reserved symbols
- | ITdcolon
- | ITequal
- | ITlam
- | ITvbar
- | ITlarrow
- | ITrarrow
- | ITat
- | ITtilde
- | ITdarrow
- | ITminus
- | ITbang
-
- | ITbiglam -- GHC-extension symbols
-
- | ITocurly -- special symbols
- | ITccurly
- | ITobrack
- | ITcbrack
- | IToparen
- | ITcparen
- | IToubxparen
- | ITcubxparen
- | ITsemi
- | ITcomma
-
- | ITvarid FAST_STRING -- identifiers
- | ITconid FAST_STRING
- | ITvarsym FAST_STRING
- | ITconsym FAST_STRING
- | ITqvarid (FAST_STRING,FAST_STRING)
- | ITqconid (FAST_STRING,FAST_STRING)
- | ITqvarsym (FAST_STRING,FAST_STRING)
- | ITqconsym (FAST_STRING,FAST_STRING)
-
- | ITpragma StringBuffer
-
- | ITchar Char
- | ITstring FAST_STRING
- | ITinteger Integer
- | ITrational Rational
-
- | ITunknown String -- Used when the lexer can't make sense of it
- | ITeof -- end of file token
- deriving Text -- debugging
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The lexical analyser}
-%* *
-%************************************************************************
-
-\begin{code}
-lexIface :: (IfaceToken -> IfM a) -> IfM a
-lexIface cont buf =
- _scc_ "Lexer"
--- if bufferExhausted buf then
--- []
--- else
--- trace ("Lexer: '"++[C# (currentChar# buf)]++"'") $
- case currentChar# buf of
- -- whitespace and comments, ignore.
- ' '# -> lexIface cont (stepOn buf)
- '\t'# -> lexIface cont (stepOn buf)
- '\n'# -> \ loc -> lexIface cont (stepOn buf) (incSrcLine loc)
-
--- Numbers and comments
- '-'# ->
- case lookAhead# buf 1# of
--- '-'# -> lex_comment cont (stepOnBy# buf 2#)
- c ->
- if is_digit c
- then lex_num cont (negate) (ord# c -# ord# '0'#) (incLexeme (incLexeme buf))
- else lex_sym cont buf
-
- '{'# -> -- look for "{-##" special iface pragma
- case lookAhead# buf 1# of
- '-'# -> case lookAhead# buf 2# of
- '#'# -> case lookAhead# buf 3# of
- '#'# ->
- let (lexeme, buf')
- = doDiscard False (stepOnBy# buf 4#) in
- cont (ITpragma lexeme) buf'
- _ -> lex_nested_comment (lexIface cont) buf
- _ -> cont ITocurly (stepOn buf)
- -- lex_nested_comment (lexIface cont) buf
- _ -> cont ITocurly (stepOn buf)
-
- -- special symbols ----------------------------------------------------
- '('# ->
- case prefixMatch (stepOn buf) "..)" of
- Just buf' -> cont ITdotdot (stepOverLexeme buf')
- Nothing ->
- case lookAhead# buf 1# of
- '#'# -> cont IToubxparen (stepOnBy# buf 2#)
- _ -> cont IToparen (stepOn buf)
- ')'# -> cont ITcparen (stepOn buf)
- '}'# -> cont ITccurly (stepOn buf)
- '#'# -> case lookAhead# buf 1# of
- ')'# -> cont ITcubxparen (stepOnBy# buf 2#)
- _ -> lex_sym cont (incLexeme buf)
- '['# -> cont ITobrack (stepOn buf)
- ']'# -> cont ITcbrack (stepOn buf)
- ','# -> cont ITcomma (stepOn buf)
- ';'# -> cont ITsemi (stepOn buf)
-
- -- strings/characters -------------------------------------------------
- '\"'#{-"-} -> case untilEndOfString# (stepOn buf) of
- buf' ->
- -- the string literal does *not* include the dquotes
- case lexemeToFastString buf' of
- v -> cont (ITstring v) (stepOn (stepOverLexeme buf'))
-
- '\''# -> --
- -- untilEndOfChar# extends the current lexeme until
- -- it hits a non-escaped single quote. The lexeme of the
- -- StringBuffer returned does *not* include the closing quote,
- -- hence we augment the lexeme and make sure to add the
- -- starting quote, before `read'ing the string.
- --
- case untilEndOfChar# (stepOn buf) of
- buf' -> case reads ('\'':lexemeToString (incLexeme buf')) of
- [ (ch, rest)] -> cont (ITchar ch) (stepOverLexeme (incLexeme buf'))
-
- -- strictness and cpr pragmas and __scc treated specially.
- '_'# ->
- case lookAhead# buf 1# of
- '_'# -> case lookAhead# buf 2# of
- 'S'# ->
- lex_demand cont (stepOnUntil (not . isSpace)
- (stepOnBy# buf 3#)) -- past __S
- 'M'# ->
- lex_cpr cont (stepOnUntil (not . isSpace)
- (stepOnBy# buf 3#)) -- past __M
- 's'# ->
- case prefixMatch (stepOnBy# buf 3#) "cc" of
- Just buf' -> lex_scc cont (stepOverLexeme buf')
- Nothing -> lex_id cont buf
- _ -> lex_id cont buf
- _ -> lex_id cont buf
-
--- ``thingy'' form for casm
- '`'# ->
- case lookAhead# buf 1# of
- '`'# -> lex_cstring cont (stepOnBy# buf 2#) -- remove the `s and go.
- _ -> lex_sym cont (incLexeme buf) -- add ` to lexeme and assume
- -- scanning an id of some sort.
-
- '\NUL'# ->
- if bufferExhausted (stepOn buf) then
- cont ITeof buf
- else
- trace "lexIface: misplaced NUL?" $
- cont (ITunknown "\NUL") (stepOn buf)
-
- c | is_digit c -> lex_num cont (id) (ord# c -# ord# '0'#) (incLexeme buf)
- | is_symbol c -> lex_sym cont buf
- | is_upper c -> lex_con cont buf
- | is_ident c -> lex_id cont buf
-
--- where
-lex_comment cont buf =
--- _trace ("comment: "++[C# (currentChar# buf)]) $
- case untilChar# buf '\n'# of {buf' -> lexIface cont (stepOverLexeme buf')}
-
--------------------------------------------------------------------------------
-
-lex_nested_comment cont buf =
- case currentChar# buf of
- '-'# -> case lookAhead# buf 1# of
- '}'# -> cont (stepOnBy# buf 2#)
- _ -> lex_nested_comment cont (stepOn buf)
-
- '{'# -> case lookAhead# buf 1# of
- '-'# -> lex_nested_comment
- (lex_nested_comment cont)
- (stepOnBy# buf 2#)
- _ -> lex_nested_comment cont (stepOn buf)
-
- _ -> lex_nested_comment cont (stepOn buf)
-
--------------------------------------------------------------------------------
-
-lex_demand cont buf =
- case read_em [] buf of { (ls,buf') ->
- case currentChar# buf' of
- 'B'# -> cont (ITstrict (ls, True )) (stepOverLexeme (stepOn buf'))
- _ -> cont (ITstrict (ls, False)) (stepOverLexeme buf')
- }
- where
- -- code snatched from Demand.lhs
- read_em acc buf =
- case currentChar# buf of
- 'L'# -> read_em (WwLazy False : acc) (stepOn buf)
- 'A'# -> read_em (WwLazy True : acc) (stepOn buf)
- 'S'# -> read_em (WwStrict : acc) (stepOn buf)
- 'P'# -> read_em (WwPrim : acc) (stepOn buf)
- 'E'# -> read_em (WwEnum : acc) (stepOn buf)
- ')'# -> (reverse acc, stepOn buf)
- 'U'# -> do_unpack DataType True acc (stepOnBy# buf 2#)
- 'u'# -> do_unpack DataType False acc (stepOnBy# buf 2#)
- 'N'# -> do_unpack NewType True acc (stepOnBy# buf 2#)
- 'n'# -> do_unpack NewType False acc (stepOnBy# buf 2#)
- _ -> (reverse acc, buf)
-
- do_unpack new_or_data wrapper_unpacks acc buf
- = case read_em [] buf of
- (stuff, rest) -> read_em (WwUnpack new_or_data wrapper_unpacks stuff : acc) rest
-
-lex_cpr cont buf =
- case read_em [] buf of { (cpr_inf,buf') ->
- ASSERT ( null (tail cpr_inf) )
- cont (ITcprinfo $ head cpr_inf) (stepOverLexeme buf')
- }
- where
- -- code snatched from lex_demand above
- read_em acc buf =
- case currentChar# buf of
- '-'# -> read_em (NoCPRInfo : acc) (stepOn buf)
- '('# -> do_unpack acc (stepOn buf)
- ')'# -> (reverse acc, stepOn buf)
- _ -> (reverse acc, buf)
-
- do_unpack acc buf
- = case read_em [] buf of
- (stuff, rest) -> read_em ((CPRInfo stuff) : acc) rest
-
-------------------
-lex_scc cont buf =
- case currentChar# buf of
- 'C'# -> cont ITsccAllCafs (stepOverLexeme (stepOn buf))
- other -> cont ITscc buf
-
------------
-lex_num :: (IfaceToken -> IfM a) -> (Int -> Int) -> Int# -> IfM a
-lex_num cont minus acc# buf =
- --trace ("lex_num: "++[C# (currentChar# buf)]) $
- case scanNumLit (I# acc#) buf of
- (acc',buf') ->
- case currentChar# buf' of
- '.'# ->
- -- this case is not optimised at all, as the
- -- presence of floating point numbers in interface
- -- files is not that common. (ToDo)
- case expandWhile# is_digit (incLexeme buf') of
- buf2 -> -- points to first non digit char
- let l = case currentChar# buf2 of
- 'e'# -> let buf3 = incLexeme buf2 in
- case currentChar# buf3 of
- '-'# -> expandWhile# is_digit (incLexeme buf3)
- _ -> expandWhile# is_digit buf3
- _ -> buf2
- in let v = readRational__ (lexemeToString l) in
- cont (ITrational v) (stepOverLexeme l)
-
- _ -> cont (ITinteger (fromInt (minus acc'))) (stepOverLexeme buf')
-
------------
-lex_cstring cont buf =
- case expandUntilMatch buf "\'\'" of
- buf' -> cont (ITstring (lexemeToFastString (setCurrentPos# buf' (negateInt# 2#))))
- (stepOverLexeme buf')
-
-------------------------------------------------------------------------------
--- Character Classes
-
-is_ident, is_symbol, is_any, is_upper, is_digit :: Char# -> Bool
-
-{-# INLINE is_ctype #-}
-#if __GLASGOW_HASKELL__ >= 303
-is_ctype :: Word8 -> Char# -> Bool
-is_ctype mask = \c ->
- (indexWord8OffAddr (``char_types'' :: Addr) (ord (C# c)) .&. mask) /= 0
-#else
-is_ctype :: Int -> Char# -> Bool
-is_ctype (I# mask) = \c ->
- let (A# ctype) = ``char_types'' :: Addr
- flag_word = int2Word# (ord# (indexCharOffAddr# ctype (ord# c)))
- in
- (flag_word `and#` (int2Word# mask)) `neWord#` (int2Word# 0#)
-#endif
-
-is_ident = is_ctype 1
-is_symbol = is_ctype 2
-is_any = is_ctype 4
-is_space = is_ctype 8
-is_upper = is_ctype 16
-is_digit = is_ctype 32
-
------------------------------------------------------------------------------
--- identifiers, symbols etc.
-
-lex_id cont buf =
- case expandWhile# is_ident buf of { buf1 ->
- case expandWhile# (eqChar# '#'#) buf1 of { buf' -> -- only if GHC extns on
- let new_buf = stepOverLexeme buf'
- lexeme = lexemeToFastString buf'
- in
- case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
- Just kwd_token -> --trace ("hkeywd: "++_UNPK_(lexeme)) $
- cont kwd_token new_buf;
- Nothing ->
- case lookupUFM ifaceKeywordsFM lexeme of {
- Just kwd_token -> --trace ("ifacekeywd: "++_UNPK_(lexeme)) $
- cont kwd_token new_buf;
- Nothing -> --trace ("id: "++_UNPK_(lexeme)) $
- cont (mk_var_token lexeme) new_buf
- }}}}
-
-lex_sym cont buf =
- case expandWhile# is_symbol buf of
- buf'
- | is_comment lexeme -> lex_comment cont new_buf
- | otherwise ->
- case lookupUFM haskellKeySymsFM lexeme of {
- Just kwd_token -> --trace ("keysym: "++unpackFS lexeme) $
- cont kwd_token new_buf ;
- Nothing -> --trace ("sym: "++unpackFS lexeme) $
- cont (mk_var_token lexeme) new_buf
- }
- where lexeme = lexemeToFastString buf'
- new_buf = stepOverLexeme buf'
-
- is_comment fs
- | len < 2 = False
- | otherwise = trundle 0
- where
- len = lengthFS fs
-
- trundle n | n == len = True
- | otherwise = indexFS fs n == '-' && trundle (n+1)
-
-lex_con cont buf =
- case expandWhile# is_ident buf of { buf1 ->
- case expandWhile# (eqChar# '#'#) buf1 of { buf' ->
- case currentChar# buf' of
- '.'# -> lex_qid cont lexeme (stepOn new_buf) just_a_conid
- _ -> just_a_conid
-
- where
- just_a_conid = --trace ("con: "++unpackFS lexeme) $
- cont (ITconid lexeme) new_buf
- lexeme = lexemeToFastString buf'
- new_buf = stepOverLexeme buf'
- }}
-
-lex_qid cont mod buf just_a_conid =
- case currentChar# buf of
- '['# -> -- Special case for []
- case lookAhead# buf 1# of
- ']'# -> cont (ITqconid (mod,SLIT("[]"))) (stepOnBy# buf 2#)
- _ -> just_a_conid
-
- '('# -> -- Special case for (,,,)
- -- This *is* necessary to deal with e.g. "instance C PrelBase.(,,)"
- case lookAhead# buf 1# of
- '#'# -> case lookAhead# buf 2# of
- ','# -> lex_ubx_tuple cont mod (stepOnBy# buf 3#)
- just_a_conid
- _ -> just_a_conid
- ')'# -> cont (ITqconid (mod,SLIT("()"))) (stepOnBy# buf 2#)
- ','# -> lex_tuple cont mod (stepOnBy# buf 2#) just_a_conid
- _ -> just_a_conid
-
- '-'# -> case lookAhead# buf 1# of
- '>'# -> cont (ITqconid (mod,SLIT("->"))) (stepOnBy# buf 2#)
- _ -> lex_id3 cont mod buf just_a_conid
- _ -> lex_id3 cont mod buf just_a_conid
-
-lex_id3 cont mod buf just_a_conid
- | is_symbol c =
- case expandWhile# is_symbol buf of { buf' ->
- let
- lexeme = lexemeToFastString buf'
- new_buf = stepOverLexeme buf'
- in
- case lookupUFM haskellKeySymsFM lexeme of {
- Just kwd_token -> just_a_conid; -- avoid M.:: etc.
- Nothing -> cont (mk_qvar_token mod lexeme) new_buf
- }}
-
- | otherwise =
- case expandWhile# is_ident buf of { buf1 ->
- if emptyLexeme buf1
- then just_a_conid
- else
- case expandWhile# (eqChar# '#'#) buf1 of { buf' -> -- only if GHC extns on
- let
- lexeme = lexemeToFastString buf'
- new_buf = stepOverLexeme buf'
- in
- case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
- Just kwd_token -> just_a_conid; -- avoid M.where etc.
- Nothing ->
- case lookupUFM ifaceKeywordsFM lexeme of { -- only for iface files
- Just kwd_token -> just_a_conid;
- Nothing -> cont (mk_qvar_token mod lexeme) new_buf
- }}}}
- where c = currentChar# buf
-
-mk_var_token pk_str
- | is_upper f = ITconid pk_str
- -- _[A-Z] is treated as a constructor in interface files.
- | f `eqChar#` '_'# && not (_NULL_ tl)
- && (case _HEAD_ tl of { C# g -> is_upper g }) = ITconid pk_str
- | is_ident f = ITvarid pk_str
- | f `eqChar#` ':'# = ITconsym pk_str
- | otherwise = ITvarsym pk_str
- where
- (C# f) = _HEAD_ pk_str
- tl = _TAIL_ pk_str
-
-mk_qvar_token m token =
- case mk_var_token token of
- ITconid n -> ITqconid (m,n)
- ITvarid n -> ITqvarid (m,n)
- ITconsym n -> ITqconsym (m,n)
- ITvarsym n -> ITqvarsym (m,n)
- _ -> ITunknown (show token)
-\end{code}
-
-----------------------------------------------------------------------------
-Horrible stuff for dealing with M.(,,,)
-
-\begin{code}
-lex_tuple cont mod buf back_off =
- go 2 buf
- where
- go n buf =
- case currentChar# buf of
- ','# -> go (n+1) (stepOn buf)
- ')'# -> cont (ITqconid (mod, snd (mkTupNameStr n))) (stepOn buf)
- _ -> back_off
-
-lex_ubx_tuple cont mod buf back_off =
- go 2 buf
- where
- go n buf =
- case currentChar# buf of
- ','# -> go (n+1) (stepOn buf)
- '#'# -> case lookAhead# buf 1# of
- ')'# -> cont (ITqconid (mod, snd (mkUbxTupNameStr n)))
- (stepOnBy# buf 2#)
- _ -> back_off
- _ -> back_off
-\end{code}
-
------------------------------------------------------------------------------
-Keyword Lists
-
-\begin{code}
-ifaceKeywordsFM :: UniqFM IfaceToken
-ifaceKeywordsFM = listToUFM $
- map (\ (x,y) -> (_PK_ x,y))
- [ ("__interface", ITinterface),
- ("__export", ITexport),
- ("__depends", ITdepends),
- ("__forall", ITforall),
- ("__letrec", ITletrec),
- ("__coerce", ITcoerce),
- ("__inline_me", ITinlineMe),
- ("__inline_call", ITinlineCall),
- ("__DEFAULT", ITdefaultbranch),
- ("__bot", ITbottom),
- ("__integer", ITinteger_lit),
- ("__float", ITfloat_lit),
- ("__rational", ITrational_lit),
- ("__addr", ITaddr_lit),
- ("__litlit", ITlit_lit),
- ("__string", ITstring_lit),
- ("__R", ITrules),
- ("__a", ITtypeapp),
- ("__o", ITonce),
- ("__m", ITmany),
- ("__A", ITarity),
- ("__P", ITspecialise),
- ("__C", ITnocaf),
- ("__u", ITunfold NoInlinePragInfo),
-
- ("__ccall", ITccall (False, False, False)),
- ("__ccall_GC", ITccall (False, False, True)),
- ("__dyn_ccall", ITccall (True, False, False)),
- ("__dyn_ccall_GC", ITccall (True, False, True)),
- ("__casm", ITccall (False, True, False)),
- ("__dyn_casm", ITccall (True, True, False)),
- ("__casm_GC", ITccall (False, True, True)),
- ("__dyn_casm_GC", ITccall (True, True, True)),
-
- ("/\\", ITbiglam)
- ]
-
-haskellKeywordsFM = listToUFM $
- map (\ (x,y) -> (_PK_ x,y))
- [( "case", ITcase ),
- ( "class", ITclass ),
- ( "data", ITdata ),
- ( "default", ITdefault ),
- ( "deriving", ITderiving ),
- ( "do", ITdo ),
- ( "else", ITelse ),
- ( "if", ITif ),
- ( "import", ITimport ),
- ( "in", ITin ),
- ( "infix", ITinfix ),
- ( "infixl", ITinfixl ),
- ( "infixr", ITinfixr ),
- ( "instance", ITinstance ),
- ( "let", ITlet ),
- ( "module", ITmodule ),
- ( "newtype", ITnewtype ),
- ( "of", ITof ),
- ( "then", ITthen ),
- ( "type", ITtype ),
- ( "where", ITwhere )
-
--- These three aren't Haskell keywords at all
--- and 'as' is often used as a variable name
--- ( "as", ITas ),
--- ( "qualified", ITqualified ),
--- ( "hiding", IThiding )
-
- ]
-
-haskellKeySymsFM = listToUFM $
- map (\ (x,y) -> (_PK_ x,y))
- [ ("..", ITdotdot)
- ,("::", ITdcolon)
- ,("=", ITequal)
- ,("\\", ITlam)
- ,("|", ITvbar)
- ,("<-", ITlarrow)
- ,("->", ITrarrow)
- ,("@", ITat)
- ,("~", ITtilde)
- ,("=>", ITdarrow)
- ,("-", ITminus)
- ,("!", ITbang)
- ]
-\end{code}
-
------------------------------------------------------------------------------
-doDiscard rips along really fast, looking for a '#-}',
-indicating the end of the pragma we're skipping
-
-\begin{code}
-doDiscard inStr buf =
- case currentChar# buf of
- '#'# | not inStr ->
- case lookAhead# buf 1# of { '#'# ->
- case lookAhead# buf 2# of { '-'# ->
- case lookAhead# buf 3# of { '}'# ->
- (lexemeToBuffer buf, stepOverLexeme (setCurrentPos# buf 4#));
- _ -> doDiscard inStr (incLexeme buf) };
- _ -> doDiscard inStr (incLexeme buf) };
- _ -> doDiscard inStr (incLexeme buf) }
- '"'# ->
- let
- odd_slashes buf flg i# =
- case lookAhead# buf i# of
- '\\'# -> odd_slashes buf (not flg) (i# -# 1#)
- _ -> flg
- in
- case lookAhead# buf (negateInt# 1#) of --backwards, actually
- '\\'# -> -- escaping something..
- if odd_slashes buf True (negateInt# 2#) then
- -- odd number of slashes, " is escaped.
- doDiscard inStr (incLexeme buf)
- else
- -- even number of slashes, \ is escaped.
- doDiscard (not inStr) (incLexeme buf)
- _ -> case inStr of -- forced to avoid build-up
- True -> doDiscard False (incLexeme buf)
- False -> doDiscard True (incLexeme buf)
- _ -> doDiscard inStr (incLexeme buf)
-
-\end{code}
-
------------------------------------------------------------------------------
-
-\begin{code}
-type IfM a = StringBuffer -- Input string
- -> SrcLoc
- -> MaybeErr a {-error-}Message
-
-returnIf :: a -> IfM a
-returnIf a s l = Succeeded a
-
-thenIf :: IfM a -> (a -> IfM b) -> IfM b
-m `thenIf` k = \s l ->
- case m s l of
- Succeeded a -> k a s l
- Failed err -> Failed err
-
-getSrcLocIf :: IfM SrcLoc
-getSrcLocIf s l = Succeeded l
-
-happyError :: IfM a
-happyError s l = Failed (ifaceParseErr s l)
-
-
-{-
- Note that if the name of the file we're processing ends
- with `hi-boot', we accept it on faith as having the right
- version. This is done so that .hi-boot files that comes
- with hsc don't have to be updated before every release,
- *and* it allows us to share .hi-boot files with versions
- of hsc that don't have .hi version checking (e.g., ghc-2.10's)
-
- If the version number is 0, the checking is also turned off.
- (needed to deal with GHC.hi only!)
-
- Once we can assume we're compiling with a version of ghc that
- supports interface file checking, we can drop the special
- pleading
--}
-checkVersion :: Maybe Integer -> IfM ()
-checkVersion mb@(Just v) s l
- | (v==0) || (v == fromInt opt_HiVersion) || opt_NoHiCheck = Succeeded ()
- | otherwise = Failed (ifaceVersionErr mb l ([]::[IfaceToken]){-Todo-})
-checkVersion mb@Nothing s l
- | "hi-boot" `isSuffixOf` (_UNPK_ (srcLocFile l)) = Succeeded ()
- | otherwise = Failed (ifaceVersionErr mb l ([]::[IfaceToken]){-Todo-})
-
------------------------------------------------------------------
-
-ifaceParseErr :: StringBuffer -> SrcLoc -> Message
-ifaceParseErr s l
- = hsep [ppr l, ptext SLIT("Interface-file parse error;"),
- ptext SLIT("current input ="), text first_bit]
- where
- first_bit = lexemeToString (stepOnBy# s 100#)
-
-ifaceVersionErr hi_vers l toks
- = hsep [ppr l, ptext SLIT("Interface file version error;"),
- ptext SLIT("Expected"), int opt_HiVersion,
- ptext SLIT("found "), pp_version]
- where
- pp_version =
- case hi_vers of
- Nothing -> ptext SLIT("pre ghc-3.02 version")
- Just v -> ptext SLIT("version") <+> integer v
-
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[PrefixSyn]{``Prefix-form'' syntax}
-
-This module contains an algebraic data type into which a prefix form
-string from the current Haskell parser is converted. Given in an
-order that follows the \tr{Prefix_Form} document.
-
-\begin{code}
-module PrefixSyn (
- RdrBinding(..),
- RdrMatch(..),
- SigConverter,
- SrcFile,
- SrcFun,
- SrcLine,
-
- readInteger
- ) where
-
-#include "HsVersions.h"
-
-import HsSyn
-import RdrHsSyn
-import RdrName ( RdrName )
-import Panic ( panic )
-import Char ( isDigit, ord )
-
-
---UNUSED: type RdrId = RdrName
-type SrcLine = Int
-type SrcFile = FAST_STRING
-type SrcFun = RdrName
-\end{code}
-
-\begin{code}
-data RdrBinding
- = -- On input we use the Empty/And form rather than a list
- RdrNullBind
- | RdrAndBindings RdrBinding RdrBinding
-
- -- Value bindings havn't been united with their
- -- signatures yet
- | RdrValBinding RdrNameMonoBinds
-
- -- Signatures are mysterious; we can't
- -- tell if its a Sig or a ClassOpSig,
- -- so we just save the pieces:
- | RdrSig RdrNameSig
-
- -- The remainder all fit into the main HsDecl form
- | RdrHsDecl RdrNameHsDecl
-
-type SigConverter = RdrNameSig -> RdrNameSig
-\end{code}
-
-\begin{code}
-data RdrMatch
- = RdrMatch
- [RdrNamePat]
- (Maybe RdrNameHsType)
- RdrNameGRHSs
-\end{code}
-
-Unscramble strings representing oct/dec/hex integer literals:
-\begin{code}
-readInteger :: String -> Integer
-
-readInteger ('-' : xs) = - (readInteger xs)
-readInteger ('0' : 'o' : xs) = chk (stoo 0 xs)
-readInteger ('0' : 'x' : xs) = chk (stox 0 xs)
-readInteger ['0'] = 0 -- efficiency shortcut?
-readInteger ['1'] = 1 -- ditto?
-readInteger xs = chk (stoi 0 xs)
-
-chk (i, "") = i
-chk (i, junk) = panic ("readInteger: junk after reading:"++junk)
-
-stoo, stoi, stox :: Integer -> String -> (Integer, String)
-
-stoo a (c:cs) | is_oct c = stoo (a*8 + ord_ c - ord_0) cs
-stoo a cs = (a, cs)
-
-stoi a (c:cs) | isDigit c = stoi (a*10 + ord_ c - ord_0) cs
-stoi a cs = (a, cs)
-
-stox a (c:cs) | isDigit c = stox (a_16_ord_c - ord_0) cs
- | is_hex c = stox (a_16_ord_c - ord_a + 10) cs
- | is_Hex c = stox (a_16_ord_c - ord_A + 10) cs
- where a_16_ord_c = a*16 + ord_ c
-stox a cs = (a, cs)
-
-is_oct c = c >= '0' && c <= '7'
-is_hex c = c >= 'a' && c <= 'f'
-is_Hex c = c >= 'A' && c <= 'F'
-
-ord_ c = toInteger (ord c)
-
-ord_0, ord_a, ord_A :: Integer
-ord_0 = ord_ '0'; ord_a = ord_ 'a'; ord_A = ord_ 'A'
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[PrefixToHS]{Support routines for converting ``prefix form'' to Haskell abstract syntax}
-
-Support routines for reading prefix-form from the Lex/Yacc parser.
-
-\begin{code}
-module PrefixToHs (
- cvBinds,
- cvMonoBindsAndSigs,
- cvTopDecls,
- cvValSig, cvClassOpSig, cvInstDeclSig
- ) where
-
-#include "HsVersions.h"
-
-import PrefixSyn -- and various syntaxen.
-import HsSyn
-import RdrHsSyn
-
-import BasicTypes ( RecFlag(..) )
-import SrcLoc ( mkSrcLoc )
-import Util ( mapAndUnzip )
-import Panic ( panic, assertPanic )
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[cvDecls]{Convert various top-level declarations}
-%* *
-%************************************************************************
-
-We make a point not to throw any user-pragma ``sigs'' at
-these conversion functions:
-
-\begin{code}
-cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
-
-cvValSig sig = sig
-
-cvInstDeclSig sig = sig
-
-cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var Nothing poly_ty src_loc
-cvClassOpSig sig = sig
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
-%* *
-%************************************************************************
-
-Function definitions are restructured here. Each is assumed to be recursive
-initially, and non recursive definitions are discovered by the dependency
-analyser.
-
-\begin{code}
-cvBinds :: SrcFile -> SigConverter -> RdrBinding -> RdrNameHsBinds
- -- The mysterious SigConverter converts Sigs to ClassOpSigs
- -- in class declarations. Mostly it's just an identity function
-
-cvBinds sf sig_cvtr binding
- = case (cvMonoBindsAndSigs sf sig_cvtr binding) of { (mbs, sigs) ->
- MonoBind mbs sigs Recursive
- }
-\end{code}
-
-\begin{code}
-cvMonoBindsAndSigs :: SrcFile
- -> SigConverter
- -> RdrBinding
- -> (RdrNameMonoBinds, [RdrNameSig])
-
-cvMonoBindsAndSigs sf sig_cvtr fb
- = mangle_bind (EmptyMonoBinds, []) fb
- where
- mangle_bind acc RdrNullBind
- = acc
-
- mangle_bind acc (RdrAndBindings fb1 fb2)
- = mangle_bind (mangle_bind acc fb1) fb2
-
- mangle_bind (b_acc, s_acc) (RdrSig sig)
- = (b_acc, sig_cvtr sig : s_acc)
-
- mangle_bind (b_acc, s_acc) (RdrValBinding binding)
- = (b_acc `AndMonoBinds` binding, s_acc)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[PrefixToHS-utils]{Utilities for conversion}
-%* *
-%************************************************************************
-
-Separate declarations into all the various kinds:
-
-\begin{code}
-cvTopDecls :: SrcFile -> RdrBinding -> [RdrNameHsDecl]
-cvTopDecls srcfile bind
- = let
- (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind
- in
- (ValD (MonoBind mono_binds sigs Recursive) : top_decls)
- where
- go acc RdrNullBind = acc
- go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
- go (topds, mbs, sigs) (RdrHsDecl d) = (d : topds, mbs, sigs)
- go (topds, mbs, sigs) (RdrSig (FixSig d)) = (FixD d : topds, mbs, sigs)
- go (topds, mbs, sigs) (RdrSig sig) = (topds, mbs, sig:sigs)
- go (topds, mbs, sigs) (RdrValBinding bind) = (topds, mbs `AndMonoBinds` bind, sigs)
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994-1998
-%
-\section{Read parse tree built by Yacc parser}
-
-\begin{code}
-module ReadPrefix ( rdModule ) where
-
-#include "HsVersions.h"
-
-import UgenAll -- all Yacc parser gumpff...
-import PrefixSyn -- and various syntaxen.
-import HsSyn
-import HsTypes ( HsTyVar(..) )
-import HsPragmas ( noDataPragmas, noClassPragmas )
-import RdrHsSyn
-import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..) )
-import PrelMods ( pRELUDE_Name )
-import PrefixToHs
-import CallConv
-
-import CmdLineOpts ( opt_NoImplicitPrelude, opt_GlasgowExts, opt_D_dump_rdr )
-import Module ( ModuleName, mkSrcModuleFS, WhereFrom(..) )
-import OccName ( NameSpace, tcName, clsName, tcClsName, varName, dataName, tvName,
- isLexCon
- )
-import RdrName ( RdrName, isRdrDataCon, mkSrcQual, mkSrcUnqual, mkPreludeQual,
- dummyRdrVarName
- )
-import Outputable
-import ErrUtils ( dumpIfSet )
-import SrcLoc ( SrcLoc )
-import FastString ( mkFastCharString )
-import PrelRead ( readRational__ )
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[rdModule]{@rdModule@: reads in a Haskell module}
-%* *
-%************************************************************************
-
-\begin{code}
-rdModule :: IO (ModuleName, -- this module's name
- RdrNameHsModule) -- the main goods
-
-rdModule
- = -- call the Yacc parser!
- _ccall_ hspmain >>= \ pt ->
-
- -- Read from the Yacc tree
- initUgn (read_module pt) >>= \ (mod_name, rdr_module) ->
-
- -- Dump if reqd
- dumpIfSet opt_D_dump_rdr "Reader"
- (ppr rdr_module) >>
-
- -- And return
- return (mod_name, rdr_module)
-
-read_module :: ParseTree -> UgnM (ModuleName, RdrNameHsModule)
-read_module pt
- = rdU_tree pt `thenUgn` \ (U_hmodule mod_fs himplist hexplist
- hmodlist srciface_version srcline) ->
- let
- srcfile = mkFastCharString ``input_filename'' -- What A Great Hack! (TM)
- mod_name = mkSrcModuleFS mod_fs
- in
-
- setSrcFileUgn srcfile $
- mkSrcLocUgn srcline $ \ src_loc ->
-
- wlkMaybe rdEntities hexplist `thenUgn` \ exports ->
- wlkList rdImport himplist `thenUgn` \ imports ->
- wlkBinding hmodlist `thenUgn` \ binding ->
-
- let
- top_decls = cvTopDecls srcfile binding
- rdr_module = HsModule mod_name
- (case srciface_version of { 0 -> Nothing; n -> Just n })
- exports
- imports
- top_decls
- src_loc
- in
- returnUgn (mod_name, rdr_module)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[wlkExprOrPat]{@wlkExpr@ and @wlkPat@}
-%* *
-%************************************************************************
-
-\begin{code}
-rdExpr :: ParseTree -> UgnM RdrNameHsExpr
-rdPat :: ParseTree -> UgnM RdrNamePat
-
-rdExpr pt = rdU_tree pt `thenUgn` wlkExpr
-rdPat pt = rdU_tree pt `thenUgn` wlkPat
-
-wlkExpr :: U_tree -> UgnM RdrNameHsExpr
-wlkPat :: U_tree -> UgnM RdrNamePat
-
-wlkExpr expr
- = case expr of
- U_par pexpr -> -- parenthesised expr
- wlkExpr pexpr `thenUgn` \ expr ->
- returnUgn (HsPar expr)
-
- U_lsection lsexp lop -> -- left section
- wlkExpr lsexp `thenUgn` \ expr ->
- wlkVarId lop `thenUgn` \ op ->
- returnUgn (SectionL expr (HsVar op))
-
- U_rsection rop rsexp -> -- right section
- wlkVarId rop `thenUgn` \ op ->
- wlkExpr rsexp `thenUgn` \ expr ->
- returnUgn (SectionR (HsVar op) expr)
-
- U_ccall fun flavor ccargs -> -- ccall/casm
- wlkList rdExpr ccargs `thenUgn` \ args ->
- let
- tag = _HEAD_ flavor
- in
- returnUgn (CCall fun args
- (tag == 'p' || tag == 'P') -- may invoke GC
- (tag == 'N' || tag == 'P') -- really a "casm"
- (panic "CCall:result_ty"))
-
- U_scc label sccexp -> -- scc (set-cost-centre) expression
- wlkExpr sccexp `thenUgn` \ expr ->
- returnUgn (HsSCC label expr)
-
- U_lambda match -> -- lambda expression
- wlkMatch match `thenUgn` \ match' ->
- returnUgn (HsLam match')
-
- U_casee caseexpr casebody srcline -> -- case expression
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkExpr caseexpr `thenUgn` \ expr ->
- wlkList rdMatch casebody `thenUgn` \ mats ->
- returnUgn (HsCase expr mats src_loc)
-
- U_ife ifpred ifthen ifelse srcline -> -- if expression
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkExpr ifpred `thenUgn` \ e1 ->
- wlkExpr ifthen `thenUgn` \ e2 ->
- wlkExpr ifelse `thenUgn` \ e3 ->
- returnUgn (HsIf e1 e2 e3 src_loc)
-
- U_let letvdefs letvexpr -> -- let expression
- wlkLocalBinding letvdefs `thenUgn` \ binding ->
- wlkExpr letvexpr `thenUgn` \ expr ->
- returnUgn (HsLet binding expr)
-
- U_doe gdo srcline -> -- do expression
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkList rd_stmt gdo `thenUgn` \ stmts ->
- returnUgn (HsDo DoStmt stmts src_loc)
- where
- rd_stmt pt
- = rdU_tree pt `thenUgn` \ bind ->
- case bind of
- U_doexp exp srcline ->
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkExpr exp `thenUgn` \ expr ->
- returnUgn (ExprStmt expr src_loc)
-
- U_dobind pat exp srcline ->
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkPat pat `thenUgn` \ patt ->
- wlkExpr exp `thenUgn` \ expr ->
- returnUgn (BindStmt patt expr src_loc)
-
- U_seqlet seqlet ->
- wlkLocalBinding seqlet `thenUgn` \ binds ->
- returnUgn (LetStmt binds)
-
- U_comprh cexp cquals -> -- list comprehension
- wlkExpr cexp `thenUgn` \ expr ->
- wlkQuals cquals `thenUgn` \ quals ->
- getSrcLocUgn `thenUgn` \ loc ->
- returnUgn (HsDo ListComp (quals ++ [ReturnStmt expr]) loc)
-
- U_eenum efrom estep eto -> -- arithmetic sequence
- wlkExpr efrom `thenUgn` \ e1 ->
- wlkMaybe rdExpr estep `thenUgn` \ es2 ->
- wlkMaybe rdExpr eto `thenUgn` \ es3 ->
- returnUgn (cv_arith_seq e1 es2 es3)
- where
- cv_arith_seq e1 Nothing Nothing = ArithSeqIn (From e1)
- cv_arith_seq e1 Nothing (Just e3) = ArithSeqIn (FromTo e1 e3)
- cv_arith_seq e1 (Just e2) Nothing = ArithSeqIn (FromThen e1 e2)
- cv_arith_seq e1 (Just e2) (Just e3) = ArithSeqIn (FromThenTo e1 e2 e3)
-
- U_restr restre restrt -> -- expression with type signature
- wlkExpr restre `thenUgn` \ expr ->
- wlkHsSigType restrt `thenUgn` \ ty ->
- returnUgn (ExprWithTySig expr ty)
-
- --------------------------------------------------------------
- -- now the prefix items that can either be an expression or
- -- pattern, except we know they are *expressions* here
- -- (this code could be commoned up with the pattern version;
- -- but it probably isn't worth it)
- --------------------------------------------------------------
- U_lit lit ->
- wlkLiteral lit `thenUgn` \ lit ->
- returnUgn (HsLit lit)
-
- U_ident n -> -- simple identifier
- wlkVarId n `thenUgn` \ var ->
- returnUgn (HsVar var)
-
- U_ap fun arg -> -- application
- wlkExpr fun `thenUgn` \ expr1 ->
- wlkExpr arg `thenUgn` \ expr2 ->
- returnUgn (HsApp expr1 expr2)
-
- U_infixap fun arg1 arg2 -> -- infix application
- wlkVarId fun `thenUgn` \ op ->
- wlkExpr arg1 `thenUgn` \ expr1 ->
- wlkExpr arg2 `thenUgn` \ expr2 ->
- returnUgn (mkOpApp expr1 op expr2)
-
- U_negate nexp -> -- prefix negation
- wlkExpr nexp `thenUgn` \ expr ->
- returnUgn (NegApp expr (HsVar dummyRdrVarName))
-
- U_llist llist -> -- explicit list
- wlkList rdExpr llist `thenUgn` \ exprs ->
- returnUgn (ExplicitList exprs)
-
- U_tuple tuplelist -> -- explicit tuple
- wlkList rdExpr tuplelist `thenUgn` \ exprs ->
- returnUgn (ExplicitTuple exprs True)
-
- U_utuple tuplelist -> -- explicit tuple
- wlkList rdExpr tuplelist `thenUgn` \ exprs ->
- returnUgn (ExplicitTuple exprs False)
-
- U_record con rbinds -> -- record construction
- wlkDataId con `thenUgn` \ rcon ->
- wlkList rdRbind rbinds `thenUgn` \ recbinds ->
- returnUgn (RecordCon rcon recbinds)
-
- U_rupdate updexp updbinds -> -- record update
- wlkExpr updexp `thenUgn` \ aexp ->
- wlkList rdRbind updbinds `thenUgn` \ recbinds ->
- returnUgn (RecordUpd aexp recbinds)
-
-#ifdef DEBUG
- U_hmodule _ _ _ _ _ _ -> error "U_hmodule"
- U_as _ _ -> error "U_as"
- U_lazyp _ -> error "U_lazyp"
- U_qual _ _ -> error "U_qual"
- U_guard _ -> error "U_guard"
- U_seqlet _ -> error "U_seqlet"
- U_dobind _ _ _ -> error "U_dobind"
- U_doexp _ _ -> error "U_doexp"
- U_rbind _ _ -> error "U_rbind"
-#endif
-
-rdRbind pt
- = rdU_tree pt `thenUgn` \ (U_rbind var exp) ->
- wlkVarId var `thenUgn` \ rvar ->
- wlkMaybe rdExpr exp `thenUgn` \ expr_maybe ->
- returnUgn (
- case expr_maybe of
- Nothing -> (rvar, HsVar rvar, True{-pun-})
- Just re -> (rvar, re, False)
- )
-
-wlkQuals cquals
- = wlkList rd_qual cquals
- where
- rd_qual pt
- = rdU_tree pt `thenUgn` \ qual ->
- wlk_qual qual
-
- wlk_qual qual
- = case qual of
- U_guard exp ->
- wlkExpr exp `thenUgn` \ expr ->
- getSrcLocUgn `thenUgn` \ loc ->
- returnUgn (GuardStmt expr loc)
-
- U_qual qpat qexp ->
- wlkPat qpat `thenUgn` \ pat ->
- wlkExpr qexp `thenUgn` \ expr ->
- getSrcLocUgn `thenUgn` \ loc ->
- returnUgn (BindStmt pat expr loc)
-
- U_seqlet seqlet ->
- wlkLocalBinding seqlet `thenUgn` \ binds ->
- returnUgn (LetStmt binds)
-
- U_let letvdefs letvexpr ->
- wlkLocalBinding letvdefs `thenUgn` \ binds ->
- wlkExpr letvexpr `thenUgn` \ expr ->
- getSrcLocUgn `thenUgn` \ loc ->
- returnUgn (GuardStmt (HsLet binds expr) loc)
-\end{code}
-
-Patterns: just bear in mind that lists of patterns are represented as
-a series of ``applications''.
-\begin{code}
-wlkPat pat
- = case pat of
- U_par ppat -> -- parenthesised pattern
- wlkPat ppat `thenUgn` \ pat ->
- -- tidy things up a little:
- returnUgn (
- case pat of
- VarPatIn _ -> pat
- WildPatIn -> pat
- other -> ParPatIn pat
- )
-
- U_as avar as_pat -> -- "as" pattern
- wlkVarId avar `thenUgn` \ var ->
- wlkPat as_pat `thenUgn` \ pat ->
- returnUgn (AsPatIn var pat)
-
- U_restr pat ty ->
- wlkPat pat `thenUgn` \ pat' ->
- wlkHsType ty `thenUgn` \ ty' ->
- returnUgn (SigPatIn pat' ty')
-
- U_lazyp lazyp -> -- irrefutable ("twiddle") pattern
- wlkPat lazyp `thenUgn` \ pat ->
- returnUgn (LazyPatIn pat)
-
- U_plusp avar lit ->
- wlkVarId avar `thenUgn` \ var ->
- wlkLiteral lit `thenUgn` \ lit ->
- returnUgn (NPlusKPatIn var lit)
-
- U_lit lit -> -- literal pattern
- wlkLiteral lit `thenUgn` \ lit ->
- returnUgn (LitPatIn lit)
-
- U_ident (U_noqual s) | s == SLIT("_")-> returnUgn WildPatIn -- Wild-card pattern
-
- U_ident nn -> -- simple identifier
- wlkVarId nn `thenUgn` \ n ->
- returnUgn (
- if isRdrDataCon n then
- ConPatIn n []
- else
- VarPatIn n
- )
-
- U_ap l r -> -- "application": there's a list of patterns lurking here!
- wlkPat r `thenUgn` \ rpat ->
- collect_pats l [rpat] `thenUgn` \ (lpat,lpats) ->
- (case lpat of
- VarPatIn x -> returnUgn (x, lpats)
- ConPatIn x [] -> returnUgn (x, lpats)
- ConOpPatIn x op _ y -> returnUgn (op, x:y:lpats)
- _ -> getSrcLocUgn `thenUgn` \ loc ->
- pprPanic "Illegal pattern `application'"
- (ppr loc <> colon <+> hsep (map ppr (lpat:lpats)))
-
- ) `thenUgn` \ (n, arg_pats) ->
- returnUgn (ConPatIn n arg_pats)
- where
- collect_pats pat acc
- = case pat of
- U_ap l r ->
- wlkPat r `thenUgn` \ rpat ->
- collect_pats l (rpat:acc)
- U_par l ->
- collect_pats l acc
- other ->
- wlkPat other `thenUgn` \ pat ->
- returnUgn (pat,acc)
-
- U_infixap fun arg1 arg2 -> -- infix pattern
- wlkVarId fun `thenUgn` \ op ->
- wlkPat arg1 `thenUgn` \ pat1 ->
- wlkPat arg2 `thenUgn` \ pat2 ->
- returnUgn (ConOpPatIn pat1 op (error "ConOpPatIn:fixity") pat2)
-
- U_negate npat -> -- negated pattern
- wlkPat npat `thenUgn` \ pat ->
- returnUgn (NegPatIn pat)
-
- U_llist llist -> -- explicit list
- wlkList rdPat llist `thenUgn` \ pats ->
- returnUgn (ListPatIn pats)
-
- U_tuple tuplelist -> -- explicit tuple
- wlkList rdPat tuplelist `thenUgn` \ pats ->
- returnUgn (TuplePatIn pats True)
-
- U_utuple tuplelist -> -- explicit tuple
- wlkList rdPat tuplelist `thenUgn` \ pats ->
- returnUgn (TuplePatIn pats False)
-
- U_record con rpats -> -- record destruction
- wlkDataId con `thenUgn` \ rcon ->
- wlkList rdRpat rpats `thenUgn` \ recpats ->
- returnUgn (RecPatIn rcon recpats)
- where
- rdRpat pt
- = rdU_tree pt `thenUgn` \ (U_rbind var pat) ->
- wlkVarId var `thenUgn` \ rvar ->
- wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
- returnUgn (
- case pat_maybe of
- Nothing -> (rvar, VarPatIn rvar, True{-pun-})
- Just rp -> (rvar, rp, False)
- )
-\end{code}
-
-\begin{code}
-wlkLiteral :: U_literal -> UgnM HsLit
-
-wlkLiteral ulit
- = returnUgn (
- case ulit of
- U_integer s -> HsInt (as_integer s)
- U_floatr s -> HsFrac (as_rational s)
- U_intprim s -> HsIntPrim (as_integer s)
- U_doubleprim s -> HsDoublePrim (as_rational s)
- U_floatprim s -> HsFloatPrim (as_rational s)
- U_charr s -> HsChar (as_char s)
- U_charprim s -> HsCharPrim (as_char s)
- U_string s -> HsString (as_string s)
- U_stringprim s -> HsStringPrim (as_string s)
- U_clitlit s -> HsLitLit (as_string s)
- )
- where
- as_char s = _HEAD_ s
- as_integer s = readInteger (_UNPK_ s)
- as_rational s = readRational__ (_UNPK_ s) -- use non-std readRational__
- -- to handle rationals with leading '-'
- as_string s = s
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{wlkBinding}
-%* *
-%************************************************************************
-
-\begin{code}
-wlkLocalBinding bind
- = wlkBinding bind `thenUgn` \ bind' ->
- getSrcFileUgn `thenUgn` \ sf ->
- returnUgn (cvBinds sf cvValSig bind')
-
-wlkBinding :: U_binding -> UgnM RdrBinding
-
-wlkBinding binding
- = case binding of
- -- null binding
- U_nullbind ->
- returnUgn RdrNullBind
-
- -- "and" binding (just glue, really)
- U_abind a b ->
- wlkBinding a `thenUgn` \ binding1 ->
- wlkBinding b `thenUgn` \ binding2 ->
- returnUgn (RdrAndBindings binding1 binding2)
-
- -- fixity declaration
- U_fixd op dir_n prec srcline ->
- let
- dir = case dir_n of
- (-1) -> InfixL
- 0 -> InfixN
- 1 -> InfixR
- in
- wlkVarId op `thenUgn` \ op ->
- mkSrcLocUgn srcline $ \ src_loc ->
- returnUgn (RdrSig (FixSig (FixitySig op (Fixity prec dir) src_loc)))
-
-
- -- "data" declaration
- U_tbind tctxt ttype tcons tderivs srcline ->
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkContext tctxt `thenUgn` \ ctxt ->
- wlkConAndTyVars ttype `thenUgn` \ (tycon, tyvars) ->
- wlkList rdConDecl tcons `thenUgn` \ cons ->
- wlkDerivings tderivs `thenUgn` \ derivings ->
- returnUgn (RdrHsDecl (TyClD (TyData DataType ctxt tycon tyvars cons
- derivings noDataPragmas src_loc)))
-
- -- "newtype" declaration
- U_ntbind ntctxt nttype ntcon ntderivs srcline ->
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkContext ntctxt `thenUgn` \ ctxt ->
- wlkConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
- wlkList rdConDecl ntcon `thenUgn` \ cons ->
- wlkDerivings ntderivs `thenUgn` \ derivings ->
- returnUgn (RdrHsDecl (TyClD (TyData NewType ctxt tycon tyvars cons
- derivings noDataPragmas src_loc)))
-
- -- "type" declaration
- U_nbind nbindid nbindas srcline ->
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
- wlkHsType nbindas `thenUgn` \ expansion ->
- returnUgn (RdrHsDecl (TyClD (TySynonym tycon tyvars expansion src_loc)))
-
- -- function binding
- U_fbind fbindm srcline ->
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkList rdMatch fbindm `thenUgn` \ matches ->
- returnUgn (RdrValBinding (mkRdrFunctionBinding matches src_loc))
-
- -- pattern binding
- U_pbind pbindl pbindr srcline ->
- mkSrcLocUgn srcline $ \ src_loc ->
- rdPat pbindl `thenUgn` \ pat ->
- rdGRHSs pbindr `thenUgn` \ grhss ->
- returnUgn (RdrValBinding (PatMonoBind pat grhss src_loc))
-
- -- "class" declaration
- U_cbind cbindc cbindid cbindw srcline ->
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkContext cbindc `thenUgn` \ ctxt ->
- wlkConAndTyVars cbindid `thenUgn` \ (clas, tyvars) ->
- wlkBinding cbindw `thenUgn` \ binding ->
- getSrcFileUgn `thenUgn` \ sf ->
- let
- (final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding
- in
- returnUgn (RdrHsDecl (TyClD (mkClassDecl ctxt clas tyvars final_sigs
- final_methods noClassPragmas src_loc)))
-
- -- "instance" declaration
- U_ibind ty ibindw srcline ->
- -- The "ty" contains the instance context too
- -- So for "instance Eq a => Eq [a]" the type will be
- -- Eq a => Eq [a]
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkInstType ty `thenUgn` \ inst_ty ->
- wlkBinding ibindw `thenUgn` \ binding ->
- getSrcFileUgn `thenUgn` \ sf ->
- let
- (binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding
- in
- returnUgn (RdrHsDecl (InstD (InstDecl inst_ty binds uprags
- dummyRdrVarName {- No dfun id yet -}
- src_loc)))
-
- -- "default" declaration
- U_dbind dbindts srcline ->
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkList rdMonoType dbindts `thenUgn` \ tys ->
- returnUgn (RdrHsDecl (DefD (DefaultDecl tys src_loc)))
-
- -- "foreign" declaration
- U_fobind id ty ext_name unsafe_flag cconv imp_exp srcline ->
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkVarId id `thenUgn` \ h_id ->
- wlkHsSigType ty `thenUgn` \ h_ty ->
- wlkExtName ext_name `thenUgn` \ h_ext_name ->
- rdCallConv cconv `thenUgn` \ h_cconv ->
- rdForKind imp_exp (cvFlag unsafe_flag) `thenUgn` \ h_imp_exp ->
- returnUgn (RdrHsDecl (ForD (ForeignDecl h_id h_imp_exp h_ty h_ext_name h_cconv src_loc)))
-
- U_sbind sbindids sbindid srcline ->
- -- Type signature
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkList rdVarId sbindids `thenUgn` \ vars ->
- wlkHsSigType sbindid `thenUgn` \ poly_ty ->
- returnUgn (foldr1 RdrAndBindings [RdrSig (Sig var poly_ty src_loc) | var <- vars])
-
- U_vspec_uprag uvar vspec_tys srcline ->
- -- value specialisation user-pragma
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkVarId uvar `thenUgn` \ var ->
- wlkList rdHsSigType vspec_tys `thenUgn` \ tys ->
- returnUgn (foldr1 RdrAndBindings [ RdrSig (SpecSig var ty src_loc)
- | ty <- tys ])
-
- U_ispec_uprag ispec_ty srcline ->
- -- instance specialisation user-pragma
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkInstType ispec_ty `thenUgn` \ ty ->
- returnUgn (RdrSig (SpecInstSig ty src_loc))
-
- U_inline_uprag ivar srcline ->
- -- value inlining user-pragma
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkVarId ivar `thenUgn` \ var ->
- returnUgn (RdrSig (InlineSig var src_loc))
-
- U_noinline_uprag ivar srcline ->
- -- No-inline pragma
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkVarId ivar `thenUgn` \ var ->
- returnUgn (RdrSig (NoInlineSig var src_loc))
-
- U_rule_prag name ivars ilhs irhs srcline ->
- -- Transforamation rule
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkList rdRuleBndr ivars `thenUgn` \ vars ->
- rdExpr ilhs `thenUgn` \ lhs ->
- rdExpr irhs `thenUgn` \ rhs ->
- returnUgn (RdrHsDecl (RuleD (RuleDecl name [] vars lhs rhs src_loc)))
-
-mkRdrFunctionBinding :: [RdrNameMatch] -> SrcLoc -> RdrNameMonoBinds
-mkRdrFunctionBinding fun_matches src_loc
- = FunMonoBind (head fns) (head infs) matches src_loc
- where
- (fns, infs, matches) = unzip3 (map de_fun_match fun_matches)
-
- de_fun_match (Match _ [ConPatIn fn pats] sig grhss) = (fn, False, Match [] pats sig grhss)
- de_fun_match (Match _ [ConOpPatIn p1 fn _ p2] sig grhss) = (fn, True, Match [] [p1,p2] sig grhss)
-
-
-rdRuleBndr :: ParseTree -> UgnM RdrNameRuleBndr
-rdRuleBndr pt = rdU_rulevar pt `thenUgn` wlkRuleBndr
-
-wlkRuleBndr :: U_rulevar -> UgnM RdrNameRuleBndr
-wlkRuleBndr (U_prulevar v)
- = returnUgn (RuleBndr (mkSrcUnqual varName v))
-wlkRuleBndr (U_prulevarsig v ty)
- = wlkHsType ty `thenUgn` \ ty' ->
- returnUgn (RuleBndrSig (mkSrcUnqual varName v) ty')
-
-
-
-rdGRHSs :: ParseTree -> UgnM RdrNameGRHSs
-rdGRHSs pt = rdU_grhsb pt `thenUgn` wlkGRHSs
-
-wlkGRHSs :: U_grhsb -> UgnM RdrNameGRHSs
-wlkGRHSs (U_pguards rhss bind)
- = wlkList rdGdExp rhss `thenUgn` \ gdexps ->
- wlkLocalBinding bind `thenUgn` \ bind' ->
- returnUgn (GRHSs gdexps bind' Nothing)
-wlkGRHSs (U_pnoguards srcline rhs bind)
- = mkSrcLocUgn srcline $ \ src_loc ->
- rdExpr rhs `thenUgn` \ rhs' ->
- wlkLocalBinding bind `thenUgn` \ bind' ->
- returnUgn (GRHSs (unguardedRHS rhs' src_loc) bind' Nothing)
-
-
-rdGdExp :: ParseTree -> UgnM RdrNameGRHS
-rdGdExp pt = rdU_gdexp pt `thenUgn` \ (U_pgdexp guards srcline rhs) ->
- wlkQuals guards `thenUgn` \ guards' ->
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkExpr rhs `thenUgn` \ expr' ->
- returnUgn (GRHS (guards' ++ [ExprStmt expr' src_loc]) src_loc)
-\end{code}
-
-\begin{code}
-wlkDerivings :: U_maybe -> UgnM (Maybe [RdrName])
-
-wlkDerivings (U_nothing) = returnUgn Nothing
-wlkDerivings (U_just pt)
- = rdU_list pt `thenUgn` \ ds ->
- wlkList rdTCId ds `thenUgn` \ derivs ->
- returnUgn (Just derivs)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
-%* *
-%************************************************************************
-
-\begin{code}
-rdHsSigType :: ParseTree -> UgnM RdrNameHsType
-rdHsType :: ParseTree -> UgnM RdrNameHsType
-rdMonoType :: ParseTree -> UgnM RdrNameHsType
-
-rdHsSigType pt = rdU_ttype pt `thenUgn` wlkHsSigType
-rdHsType pt = rdU_ttype pt `thenUgn` wlkHsType
-rdMonoType pt = rdU_ttype pt `thenUgn` wlkHsType
-
-wlkHsConstrArgType ttype
- -- Used for the argument types of contructors
- -- Only an implicit quantification point if -fglasgow-exts
- | opt_GlasgowExts = wlkHsSigType ttype
- | otherwise = wlkHsType ttype
-
- -- wlkHsSigType is used for type signatures: any place there
- -- should be *implicit* quantification
-wlkHsSigType ttype
- = wlkHsType ttype `thenUgn` \ ty ->
- -- This is an implicit quantification point, so
- -- make sure it starts with a ForAll
- case ty of
- HsForAllTy _ _ _ -> returnUgn ty
- other -> returnUgn (HsForAllTy Nothing [] ty)
-
-wlkHsType :: U_ttype -> UgnM RdrNameHsType
-wlkHsType ttype
- = case ttype of
- U_forall u_tyvars u_theta u_ty -> -- Explicit forall
- wlkList rdTvId u_tyvars `thenUgn` \ tyvars ->
- wlkContext u_theta `thenUgn` \ theta ->
- wlkHsType u_ty `thenUgn` \ ty ->
- returnUgn (HsForAllTy (Just (map UserTyVar tyvars)) theta ty)
-
- U_imp_forall u_theta u_ty -> -- Implicit forall
- wlkContext u_theta `thenUgn` \ theta ->
- wlkHsType u_ty `thenUgn` \ ty ->
- returnUgn (HsForAllTy Nothing theta ty)
-
- U_namedtvar tv -> -- type variable
- wlkTvId tv `thenUgn` \ tyvar ->
- returnUgn (MonoTyVar tyvar)
-
- U_tname tcon -> -- type constructor
- wlkTcId tcon `thenUgn` \ tycon ->
- returnUgn (MonoTyVar tycon)
-
- U_tapp t1 t2 ->
- wlkHsType t1 `thenUgn` \ ty1 ->
- wlkHsType t2 `thenUgn` \ ty2 ->
- returnUgn (MonoTyApp ty1 ty2)
-
- U_tllist tlist -> -- list type
- wlkHsType tlist `thenUgn` \ ty ->
- returnUgn (MonoListTy ty)
-
- U_ttuple ttuple ->
- wlkList rdMonoType ttuple `thenUgn` \ tys ->
- returnUgn (MonoTupleTy tys True)
-
- U_tutuple ttuple ->
- wlkList rdMonoType ttuple `thenUgn` \ tys ->
- returnUgn (MonoTupleTy tys False)
-
- U_tfun tfun targ ->
- wlkHsType tfun `thenUgn` \ ty1 ->
- wlkHsType targ `thenUgn` \ ty2 ->
- returnUgn (MonoFunTy ty1 ty2)
-
-wlkInstType ttype
- = case ttype of
- U_forall u_tyvars u_theta inst_head ->
- wlkList rdTvId u_tyvars `thenUgn` \ tyvars ->
- wlkContext u_theta `thenUgn` \ theta ->
- wlkClsTys inst_head `thenUgn` \ (clas, tys) ->
- returnUgn (HsForAllTy (Just (map UserTyVar tyvars)) theta (MonoDictTy clas tys))
-
- U_imp_forall u_theta inst_head ->
- wlkContext u_theta `thenUgn` \ theta ->
- wlkClsTys inst_head `thenUgn` \ (clas, tys) ->
- returnUgn (HsForAllTy Nothing theta (MonoDictTy clas tys))
-
- other -> -- something else
- wlkClsTys other `thenUgn` \ (clas, tys) ->
- returnUgn (HsForAllTy Nothing [] (MonoDictTy clas tys))
-\end{code}
-
-\begin{code}
-wlkConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
-wlkConAndTyVars ttype
- = wlkHsType ttype `thenUgn` \ ty ->
- let
- split (MonoTyApp fun (MonoTyVar arg)) args = split fun (UserTyVar arg : args)
- split (MonoTyVar tycon) args = (tycon,args)
- split other args = pprPanic "ERROR: malformed type: "
- (ppr other)
- in
- returnUgn (split ty [])
-
-
-wlkContext :: U_list -> UgnM RdrNameContext
-rdClsTys :: ParseTree -> UgnM (RdrName, [HsType RdrName])
-
-wlkContext list = wlkList rdClsTys list
-
-rdClsTys pt = rdU_ttype pt `thenUgn` wlkClsTys
-
-wlkClsTys ttype
- = go ttype []
- where
- go (U_tname tcon) tys = wlkClsId tcon `thenUgn` \ cls ->
- returnUgn (cls, tys)
-
- go (U_tapp t1 t2) tys = wlkHsType t2 `thenUgn` \ ty2 ->
- go t1 (ty2 : tys)
-\end{code}
-
-\begin{code}
-rdConDecl :: ParseTree -> UgnM RdrNameConDecl
-rdConDecl pt = rdU_constr pt `thenUgn` wlkConDecl
-
-wlkConDecl :: U_constr -> UgnM RdrNameConDecl
-
-wlkConDecl (U_constrex u_tvs ccxt ccdecl)
- = wlkList rdTvId u_tvs `thenUgn` \ tyvars ->
- wlkContext ccxt `thenUgn` \ theta ->
- wlkConDecl ccdecl `thenUgn` \ (ConDecl con _ _ details loc) ->
- returnUgn (ConDecl con (map UserTyVar tyvars) theta details loc)
-
-wlkConDecl (U_constrpre ccon ctys srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
- wlkDataId ccon `thenUgn` \ con ->
- wlkList rdBangType ctys `thenUgn` \ tys ->
- returnUgn (ConDecl con [] [] (VanillaCon tys) src_loc)
-
-wlkConDecl (U_constrinf cty1 cop cty2 srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
- wlkBangType cty1 `thenUgn` \ ty1 ->
- wlkDataId cop `thenUgn` \ op ->
- wlkBangType cty2 `thenUgn` \ ty2 ->
- returnUgn (ConDecl op [] [] (InfixCon ty1 ty2) src_loc)
-
-wlkConDecl (U_constrnew ccon cty mb_lab srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
- wlkDataId ccon `thenUgn` \ con ->
- wlkHsSigType cty `thenUgn` \ ty ->
- wlkMaybe rdVarId mb_lab `thenUgn` \ mb_lab ->
- returnUgn (ConDecl con [] [] (NewCon ty mb_lab) src_loc)
-
-wlkConDecl (U_constrrec ccon cfields srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
- wlkDataId ccon `thenUgn` \ con ->
- wlkList rd_field cfields `thenUgn` \ fields_lists ->
- returnUgn (ConDecl con [] [] (RecCon fields_lists) src_loc)
- where
- rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
- rd_field pt =
- rdU_constr pt `thenUgn` \ (U_field fvars fty) ->
- wlkList rdVarId fvars `thenUgn` \ vars ->
- wlkBangType fty `thenUgn` \ ty ->
- returnUgn (vars, ty)
-
------------------
-rdBangType pt = rdU_ttype pt `thenUgn` wlkBangType
-
-wlkBangType :: U_ttype -> UgnM (BangType RdrName)
-
-wlkBangType (U_tbang bty) = wlkHsConstrArgType bty `thenUgn` \ ty ->
- returnUgn (Banged ty)
-wlkBangType uty = wlkHsConstrArgType uty `thenUgn` \ ty ->
- returnUgn (Unbanged ty)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Read a ``match''}
-%* *
-%************************************************************************
-
-\begin{code}
-rdMatch :: ParseTree -> UgnM RdrNameMatch
-rdMatch pt = rdU_match pt `thenUgn` wlkMatch
-
-wlkMatch :: U_match -> UgnM RdrNameMatch
-wlkMatch (U_pmatch pats sig grhsb)
- = wlkList rdPat pats `thenUgn` \ pats' ->
- wlkMaybe rdHsType sig `thenUgn` \ maybe_ty ->
- wlkGRHSs grhsb `thenUgn` \ grhss' ->
- returnUgn (Match [] pats' maybe_ty grhss')
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[rdImport]{Read an import decl}
-%* *
-%************************************************************************
-
-\begin{code}
-rdImport :: ParseTree
- -> UgnM RdrNameImportDecl
-
-rdImport pt
- = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec isrc srcline) ->
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as ->
- wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec ->
- returnUgn (ImportDecl (mkSrcModuleFS imod)
- (cvImportSource isrc)
- (cvFlag iqual)
- (case maybe_as of { Just m -> Just (mkSrcModuleFS m); Nothing -> Nothing })
- maybe_spec src_loc)
- where
- rd_spec pt = rdU_either pt `thenUgn` \ spec ->
- case spec of
- U_left pt -> rdEntities pt `thenUgn` \ ents ->
- returnUgn (False, ents)
- U_right pt -> rdEntities pt `thenUgn` \ ents ->
- returnUgn (True, ents)
-
-cvImportSource 0 = ImportByUser -- No pragam
-cvImportSource 1 = ImportByUserSource -- {-# SOURCE #-}
-\end{code}
-
-\begin{code}
-rdEntities pt = rdU_list pt `thenUgn` wlkList rdEntity
-
-rdEntity :: ParseTree -> UgnM (IE RdrName)
-
-rdEntity pt
- = rdU_entidt pt `thenUgn` \ entity ->
- case entity of
- U_entid evar -> -- just a value
- wlkEntId evar `thenUgn` \ var ->
- returnUgn (IEVar var)
-
- U_enttype x -> -- abstract type constructor/class
- wlkTcClsId x `thenUgn` \ thing ->
- returnUgn (IEThingAbs thing)
-
- U_enttypeall x -> -- non-abstract type constructor/class
- wlkTcClsId x `thenUgn` \ thing ->
- returnUgn (IEThingAll thing)
-
- U_enttypenamed x ns -> -- non-abstract type constructor/class
- -- with specified constrs/methods
- wlkTcClsId x `thenUgn` \ thing ->
- wlkList rdVarId ns `thenUgn` \ names ->
- returnUgn (IEThingWith thing names)
-
- U_entmod mod -> -- everything provided unqualified by a module
- returnUgn (IEModuleContents (mkSrcModuleFS mod))
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[rdExtName]{Read an external name}
-%* *
-%************************************************************************
-
-\begin{code}
-wlkExtName :: U_maybe -> UgnM ExtName
-wlkExtName (U_nothing) = returnUgn Dynamic
-wlkExtName (U_just pt)
- = rdU_list pt `thenUgn` \ ds ->
- wlkList rdU_hstring ds `thenUgn` \ ss ->
- case ss of
- [nm] -> returnUgn (ExtName nm Nothing)
- [mod,nm] -> returnUgn (ExtName nm (Just mod))
-
-rdCallConv :: Int -> UgnM CallConv
-rdCallConv x =
- -- this tracks the #defines in parser/utils.h
- case x of
- (-1) -> -- no calling convention specified, use default.
- returnUgn defaultCallConv
- _ -> returnUgn x
-
-rdForKind :: Int -> Bool -> UgnM ForKind
-rdForKind 0 isUnsafe = -- foreign import
- returnUgn (FoImport isUnsafe)
-rdForKind 1 _ = -- foreign export
- returnUgn FoExport
-rdForKind 2 _ = -- foreign label
- returnUgn FoLabel
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[ReadPrefix-help]{Help Functions}
-%* *
-%************************************************************************
-
-\begin{code}
-wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a]
-
-wlkList wlk_it U_lnil = returnUgn []
-
-wlkList wlk_it (U_lcons hd tl)
- = wlk_it hd `thenUgn` \ hd_it ->
- wlkList wlk_it tl `thenUgn` \ tl_it ->
- returnUgn (hd_it : tl_it)
-\end{code}
-
-\begin{code}
-wlkMaybe :: (U_VOID_STAR -> UgnM a) -> U_maybe -> UgnM (Maybe a)
-
-wlkMaybe wlk_it U_nothing = returnUgn Nothing
-wlkMaybe wlk_it (U_just x)
- = wlk_it x `thenUgn` \ it ->
- returnUgn (Just it)
-\end{code}
-
-\begin{code}
-wlkTcClsId = wlkQid (\_ -> tcClsName)
-wlkTcId = wlkQid (\_ -> tcName)
-wlkClsId = wlkQid (\_ -> clsName)
-wlkVarId = wlkQid (\occ -> if isLexCon occ
- then dataName
- else varName)
-wlkDataId = wlkQid (\_ -> dataName)
-wlkEntId = wlkQid (\occ -> if isLexCon occ
- then tcClsName
- else varName)
-
-wlkQid :: (FAST_STRING -> NameSpace) -> U_qid -> UgnM RdrName
-
--- There are three kinds of qid:
--- qualified name (aqual) A.x
--- unqualified name (noqual) x
--- special name (gid) [], (), ->, (,,,)
--- The special names always mean "Prelude.whatever"; that's why
--- they are distinct. So if you write "()", it's just as if you
--- had written "Prelude.()".
--- NB: The (qualified) prelude is always in scope, so the renamer will find it.
-
--- EXCEPT: when we're compiling with -fno-implicit-prelude, in which
--- case we need to unqualify these things. -- SDM.
-
-wlkQid mk_name_space (U_noqual name)
- = returnUgn (mkSrcUnqual (mk_name_space name) name)
-wlkQid mk_name_space (U_aqual mod name)
- = returnUgn (mkSrcQual (mk_name_space name) mod name)
-wlkQid mk_name_space (U_gid n name) -- Built in Prelude things
- | opt_NoImplicitPrelude
- = returnUgn (mkSrcUnqual (mk_name_space name) name)
- | otherwise
- = returnUgn (mkPreludeQual (mk_name_space name) pRELUDE_Name name)
-
-
-rdTCId pt = rdU_qid pt `thenUgn` wlkTcId
-rdVarId pt = rdU_qid pt `thenUgn` wlkVarId
-
-rdTvId pt = rdU_stringId pt `thenUgn` \ string -> wlkTvId string
-wlkTvId string = returnUgn (mkSrcUnqual tvName string)
-
--- Unqualified variables, used in the 'forall' of a RULE
-rdUVarId pt = rdU_stringId pt `thenUgn` \ string -> wlkUVarId string
-wlkUVarId string = returnUgn (mkSrcUnqual varName string)
-
-cvFlag :: U_long -> Bool
-cvFlag 0 = False
-cvFlag 1 = True
-\end{code}
-
}
%name parseIface
-%tokentype { IfaceToken }
-%monad { IfM }{ thenIf }{ returnIf }
-%lexer { lexIface } { ITeof }
+%tokentype { Token }
+%monad { P }{ thenP }{ returnP }
+%lexer { lexer } { ITeof }
%token
'case' { ITcase } -- Haskell keywords
'qualified' { ITqualified }
'hiding' { IThiding }
+ 'export' { ITexport }
+ 'label' { ITlabel }
+ 'dynamic' { ITdynamic }
+ 'unsafe' { ITunsafe }
'__interface' { ITinterface } -- GHC-extension keywords
- '__export' { ITexport }
+ '__export' { IT__export }
+ '__forall' { IT__forall }
'__depends' { ITdepends }
- '__forall' { ITforall }
'__letrec' { ITletrec }
'__coerce' { ITcoerce }
'__inline_call'{ ITinlineCall }
maybe_idinfo :: { RdrName -> [HsIdInfo RdrName] }
maybe_idinfo : {- empty -} { \_ -> [] }
| src_loc PRAGMA { \x ->
- case parseIface $2 $1 of
- Succeeded (PIdInfo id_info) -> id_info
- Failed err -> pprPanic "IdInfo parse failed"
- (vcat [ppr x, err])
+ case parseIface $2
+ PState{bol = 0#, atbol = 1#,
+ context = [],
+ glasgow_exts = 1#,
+ loc = $1 } of
+ POk _ (PIdInfo id_info) -> id_info
+ PFailed err ->
+ pprPanic "IdInfo parse failed"
+ (vcat [ppr x, err])
}
-----------------------------------------------------------------------------
rules_part :: { [RdrNameRuleDecl] }
rules_part : {- empty -} { [] }
- | src_loc PRAGMA { case parseIface $2 $1 of
- Succeeded (PRules rules) -> rules
- Failed err -> pprPanic "Rules parse failed" err
+ | src_loc PRAGMA { case parseIface $2
+ PState{bol = 0#, atbol = 1#,
+ context = [],
+ glasgow_exts = 1#,
+ loc = $1 } of
+ POk _ (PRules rules) -> rules
+ PFailed err ->
+ pprPanic "Rules parse failed" err
}
rules :: { [RdrNameRuleDecl] }
decl_context : { [] }
| '{' context_list1 '}' '=>' { $2 }
-----------------------------------------------------------------
+----------------------------------------------------------------------------
constrs :: { [RdrNameConDecl] {- empty for handwritten abstract -} }
: { [] }
var_fs :: { EncodedFS }
: VARID { $1 }
| VARSYM { $1 }
- | '-' { SLIT("-") }
| '!' { SLIT("!") }
-
+ | 'as' { SLIT("as") }
+ | 'qualified' { SLIT("qualified") }
+ | 'hiding' { SLIT("hiding") }
+ | 'export' { SLIT("export") }
+ | 'label' { SLIT("label") }
+ | 'dynamic' { SLIT("dynamic") }
+ | 'unsafe' { SLIT("unsafe") }
qvar_fs :: { (EncodedFS, EncodedFS) }
: QVARID { $1 }
| var_name ',' comma_var_names1 { $1 : $3 }
core_lit :: { Literal }
-core_lit : INTEGER { mkMachInt_safe $1 }
+core_lit : integer { mkMachInt_safe $1 }
| CHAR { MachChar $1 }
| STRING { MachStr $1 }
| '__string' STRING { NoRepStr $2 (panic "NoRepStr type") }
- | RATIONAL { MachDouble $1 }
- | '__float' RATIONAL { MachFloat $2 }
+ | rational { MachDouble $1 }
+ | '__float' rational { MachFloat $2 }
- | '__integer' INTEGER { NoRepInteger $2 (panic "NoRepInteger type")
+ | '__integer' integer { NoRepInteger $2 (panic "NoRepInteger type")
-- The type checker will add the types
}
- | '__rational' INTEGER INTEGER { NoRepRational ($2 % $3)
+ | '__rational' integer integer { NoRepRational ($2 % $3)
(panic "NoRepRational type")
-- The type checker will add the type
}
- | '__addr' INTEGER { MachAddr $2 }
+ | '__addr' integer { MachAddr $2 }
+
+integer :: { Integer }
+ : INTEGER { $1 }
+ | '-' INTEGER { (-$2) }
+
+rational :: { Rational }
+ : RATIONAL { $1 }
+ | '-' RATIONAL { (-$2) }
core_bndr :: { UfBinder RdrName }
core_bndr : core_val_bndr { $1 }
-------------------------------------------------------------------
src_loc :: { SrcLoc }
-src_loc : {% getSrcLocIf }
+src_loc : {% getSrcLocP }
checkVersion :: { () }
: {-empty-} {% checkVersion Nothing }
-- Haskell code
{
+happyError :: P a
+happyError buf PState{ loc = loc } = PFailed (ifaceParseErr buf loc)
data IfaceStuff = PIface EncodedFS{-.hi module name-} ParsedIface
| PIdInfo [HsIdInfo RdrName]
rnPat pat `thenRn` \ (pat', fvs) ->
returnRn (NegPatIn pat', fvs)
where
- valid_neg_pat (LitPatIn (HsInt _)) = True
- valid_neg_pat (LitPatIn (HsFrac _)) = True
- valid_neg_pat _ = False
+ valid_neg_pat (LitPatIn (HsInt _)) = True
+ valid_neg_pat (LitPatIn (HsIntPrim _)) = True
+ valid_neg_pat (LitPatIn (HsFrac _)) = True
+ valid_neg_pat (LitPatIn (HsFloatPrim _)) = True
+ valid_neg_pat (LitPatIn (HsDoublePrim _)) = True
+ valid_neg_pat _ = False
rnPat (ParPatIn pat)
= rnPat pat `thenRn` \ (pat', fvs) ->
returnRn (final_e,
fv_e1 `plusFV` fv_op `plusFV` fv_e2)
+-- constant-fold some negate applications on unboxed literals. Since
+-- negate is a polymorphic function, we have to do these here.
+rnExpr (NegApp (HsLit (HsIntPrim i)) _) = rnExpr (HsLit (HsIntPrim (-i)))
+rnExpr (NegApp (HsLit (HsFloatPrim i)) _) = rnExpr (HsLit (HsFloatPrim (-i)))
+rnExpr (NegApp (HsLit (HsDoublePrim i)) _) = rnExpr (HsLit (HsDoublePrim (-i)))
+
rnExpr (NegApp e n)
= rnExpr e `thenRn` \ (e', fv_e) ->
lookupImplicitOccRn negate_RDR `thenRn` \ neg ->
import Unique ( Unique )
import StringBuffer ( StringBuffer, hGetStringBuffer )
import FastString ( mkFastString )
+import Lex
import Outputable
import IO ( isDoesNotExistError )
-- Nothing <=> file not found, or unreadable, or illegible
-- Just x <=> successfully found and parsed
readIface the_mod file_path
- = ioToRnM (hGetStringBuffer file_path) `thenRn` \ read_result ->
+ = ioToRnM (hGetStringBuffer False file_path) `thenRn` \ read_result ->
case read_result of
Right contents ->
- case parseIface contents (mkSrcLoc (mkFastString file_path) 1) of
- Failed err -> failWithRn Nothing err
- Succeeded (PIface mod_nm iface) ->
+ case parseIface contents
+ PState{ bol = 0#, atbol = 1#,
+ context = [],
+ glasgow_exts = 1#,
+ loc = mkSrcLoc (mkFastString file_path) 1 } of
+ PFailed err -> failWithRn Nothing err
+ POk _ (PIface mod_nm iface) ->
warnCheckRn (mod_nm == moduleName the_mod)
(hsep [ ptext SLIT("Something is amiss; requested module name")
, pprModule the_mod
tcPat tc_bndr (NegPatIn pat) pat_ty
= tcPat tc_bndr (negate_lit pat) pat_ty
where
- negate_lit (LitPatIn (HsInt i)) = LitPatIn (HsInt (-i))
- negate_lit (LitPatIn (HsFrac f)) = LitPatIn (HsFrac (-f))
- negate_lit _ = panic "TcPat:negate_pat"
+ negate_lit (LitPatIn (HsInt i)) = LitPatIn (HsInt (-i))
+ negate_lit (LitPatIn (HsIntPrim i)) = LitPatIn (HsIntPrim (-i))
+ negate_lit (LitPatIn (HsFrac f)) = LitPatIn (HsFrac (-f))
+ negate_lit (LitPatIn (HsFloatPrim f)) = LitPatIn (HsFloatPrim (-f))
+ negate_lit (LitPatIn (HsDoublePrim f)) = LitPatIn (HsDoublePrim (-f))
+ negate_lit _ = panic "TcPat:negate_pat"
tcPat tc_bndr (ParPatIn parend_pat) pat_ty
= tcPat tc_bndr parend_pat pat_ty
nullFastString (CharStr _ l#) = l# ==# 0#
unpackFS :: FastString -> String
-unpackFS (FastString _ l# ba#) = unpackCStringBA# ba# l#
+unpackFS (FastString _ l# ba#) = unpackNBytesBA# ba# l#
unpackFS (CharStr addr len#) =
unpack 0#
where
Buffers for scanning string input stored in external arrays.
\begin{code}
-{-# OPTIONS -fno-prune-tydecls #-}
+{-# OPTIONS -fno-prune-tydecls -#include "../lib/std/cbits/stgio.h" #-}
module StringBuffer
(
StringBuffer,
lookAhead, -- :: StringBuffer -> Int -> Char
lookAhead#, -- :: StringBuffer -> Int# -> Char#
+ -- offsets
+ currentIndex#, -- :: StringBuffer -> Int#
+ lexemeIndex, -- :: StringBuffer -> Int#
+
-- moving the end point of the current lexeme.
setCurrentPos#, -- :: StringBuffer -> Int# -> StringBuffer
incLexeme, -- :: StringBuffer -> StringBuffer
stepOnUntil, -- :: (Char -> Bool) -> StringBuffer -> StringBuffer
stepOverLexeme, -- :: StringBuffer -> StringBuffer
scanNumLit, -- :: Int -> StringBuffer -> (Int, StringBuffer)
+ squeezeLexeme, -- :: StringBuffer -> Int# -> StringBuffer
+ mergeLexemes, -- :: StringBuffer -> StringBuffer -> StringBuffer
expandWhile, -- :: (Char -> Bool) -> StringBuffer -> StringBuffer
expandWhile#, -- :: (Char# -> Bool) -> StringBuffer -> StringBuffer
expandUntilMatch, -- :: StrinBuffer -> String -> StringBuffer
-- matching
prefixMatch, -- :: StringBuffer -> String -> Bool
untilEndOfString#, -- :: StringBuffer -> Int#
- untilEndOfChar#, -- :: StringBuffer -> Int#
untilChar#, -- :: StringBuffer -> Char# -> Int#
-- conversion
import Addr ( Addr(..) )
import Foreign
import ST
+import Char ( chr )
#if __GLASGOW_HASKELL__ >= 303
-import IO ( slurpFile )
+import IO ( openFile, slurpFile )
+import PrelIOBase
+import PrelHandle
+import Addr
+#include "../lib/std/cbits/error.h"
+-- urk!
#else
import IO ( openFile, hFileSize, hClose, IOMode(..) )
#endif
import PrelPack ( unpackCStringBA )
#endif
+#if __GLASGOW_HASKELL__ < 402
+import Util ( bracket )
+#else
+import Exception ( bracket )
+#endif
+
import PrimPacked
import FastString
import Char (isDigit)
\end{code}
\begin{code}
-hGetStringBuffer :: FilePath -> IO StringBuffer
-hGetStringBuffer fname =
+hGetStringBuffer :: Bool -> FilePath -> IO StringBuffer
+hGetStringBuffer expand_tabs fname =
#if __GLASGOW_HASKELL__ >= 303
- slurpFile fname >>= \ (a , read) ->
+ (if expand_tabs
+ then slurpFileExpandTabs fname
+ else slurpFile fname)
+ >>= \ (a , read) ->
let (A# a#) = a
(I# read#) = read
in
)
\end{code}
+-----------------------------------------------------------------------------
+This very disturbing bit of code is used for expanding the tabs in a
+file before we start parsing it. Expanding the tabs early makes the
+lexer a lot simpler: we only have to record the beginning of the line
+in order to be able to calculate the column offset of the current
+token.
+
+We guess the size of the buffer required as 20% extra for
+expanded tabs, and enlarge it if necessary.
+
+\begin{code}
+slurpFileExpandTabs :: FilePath -> IO (Addr, Int)
+slurpFileExpandTabs fname = do
+ bracket (openFile fname ReadMode) (hClose)
+ (\ handle ->
+ do sz <- hFileSize handle
+ if sz > toInteger (maxBound::Int)
+ then ioError (userError "slurpFile: file too big")
+ else do
+ let sz_i = fromInteger sz
+ sz_i' = (sz_i * 12) `div` 10 -- add 20% for tabs
+ chunk <- allocMem sz_i'
+ trySlurp handle sz_i' chunk
+ )
+
+trySlurp :: Handle -> Int -> Addr -> IO (Addr, Int)
+trySlurp handle sz_i chunk =
+ wantReadableHandle "hGetChar" handle $ \ handle_ ->
+ let
+ fo = haFO__ handle_
+
+ (I# chunk_sz) = sz_i
+
+ tAB_SIZE = 8#
+
+ slurpFile :: Int# -> Int# -> Addr -> Int# -> Int# -> IO Int
+ slurpFile c off chunk chunk_sz max_off = slurp c off
+ where
+
+ slurp :: Int# -> Int# -> IO Int
+ slurp c off | off >=# max_off = do
+ let new_sz = chunk_sz *# 2#
+ chunk' <- reAllocMem chunk (I# new_sz)
+ slurpFile c off chunk' new_sz (new_sz -# tAB_SIZE)
+ slurp c off = do
+ intc <- mayBlock fo (_ccall_ fileGetc fo)
+ if intc == ((-1)::Int)
+ then do errtype <- _ccall_ getErrType__
+ if errtype == (ERR_EOF :: Int)
+ then return (I# off)
+ else constructErrorAndFail "slurpFile"
+ else case chr intc of
+ '\t' -> tabIt c off
+ ch -> do writeCharOffAddr chunk (I# off) ch
+ let c' | ch == '\n' = 0#
+ | otherwise = c +# 1#
+ slurp c' (off +# 1#)
+
+ tabIt :: Int# -> Int# -> IO Int
+ -- can't run out of buffer in here, because we reserved an
+ -- extra tAB_SIZE bytes at the end earlier.
+ tabIt c off = do
+ writeCharOffAddr chunk (I# off) ' '
+ let c' = c +# 1#
+ off' = off +# 1#
+ if c' `remInt#` tAB_SIZE ==# 0#
+ then slurp c' off'
+ else tabIt c' off'
+ in do
+
+ -- allow space for a full tab at the end of the buffer
+ -- (that's what the max_off thing is for)
+ rc <- slurpFile 0# 0# chunk chunk_sz (chunk_sz -# tAB_SIZE)
+ writeHandle handle handle_
+ if rc < (0::Int)
+ then constructErrorAndFail "slurpFile"
+ else return (chunk, rc)
+
+
+reAllocMem :: Addr -> Int -> IO Addr
+reAllocMem ptr sz = do
+ chunk <- _ccall_ realloc ptr sz
+ if chunk == nullAddr
+ then constructErrorAndFail "reAllocMem"
+ else return chunk
+
+allocMem :: Int -> IO Addr
+allocMem sz = do
+ chunk <- _ccall_ allocMemory__ sz
+ if chunk == nullAddr
+ then constructErrorAndFail "allocMem"
+ else return chunk
+\end{code}
+
Lookup
\begin{code}
-- relative lookup, i.e, currentChar = lookAhead 0
lookAhead# (StringBuffer fo# _ _ c#) i# = indexCharOffAddr# fo# (c# +# i#)
+currentIndex# :: StringBuffer -> Int#
+currentIndex# (StringBuffer fo# _ _ c#) = c#
+
+lexemeIndex :: StringBuffer -> Int#
+lexemeIndex (StringBuffer fo# _ c# _) = c#
\end{code}
moving the start point of the current lexeme.
stepOnTo# :: StringBuffer -> Int# -> StringBuffer
stepOnTo# (StringBuffer fo l _ _) s# = StringBuffer fo l s# s#
+squeezeLexeme :: StringBuffer -> Int# -> StringBuffer
+squeezeLexeme (StringBuffer fo l s# c#) i# = StringBuffer fo l (s# +# i#) c#
+
+mergeLexemes :: StringBuffer -> StringBuffer -> StringBuffer
+mergeLexemes (StringBuffer fo l s# _) (StringBuffer _ _ _ c#)
+ = StringBuffer fo l s# c#
+
stepOnUntil :: (Char -> Bool) -> StringBuffer -> StringBuffer
stepOnUntil pred (StringBuffer fo l# s# c#) =
| ch# `eqChar#` '\NUL'# && c# >=# l# -> StringBuffer fo l# s# c# -- EOB, return immediately.
| otherwise -> StringBuffer fo l# s# c#
-scanNumLit :: Int -> StringBuffer -> (Int,StringBuffer)
-scanNumLit (I# acc#) (StringBuffer fo l# s# c#) =
- loop acc# c#
+scanNumLit :: Integer -> StringBuffer -> (Integer,StringBuffer)
+scanNumLit acc (StringBuffer fo l# s# c#) =
+ loop acc c#
where
- loop acc# c# =
+ loop acc c# =
case indexCharOffAddr# fo c# of
- ch# | isDigit (C# ch#) -> loop (acc# *# 10# +# (ord# ch# -# ord# '0'#)) (c# +# 1#)
- | ch# `eqChar#` '\NUL'# && c# >=# l# -> (I# acc#, StringBuffer fo l# s# c#) -- EOB, return immediately.
- | otherwise -> (I# acc#,StringBuffer fo l# s# c#)
+ ch# | isDigit (C# ch#) -> loop (acc*10 + (toInteger (I# (ord# ch# -# ord# '0'#)))) (c# +# 1#)
+ | ch# `eqChar#` '\NUL'# && c# >=# l# -> (acc, StringBuffer fo l# s# c#) -- EOB, return immediately.
+ | otherwise -> (acc,StringBuffer fo l# s# c#)
expandUntilMatch :: StringBuffer -> String -> StringBuffer
_ -> loop (c# +# 1#)
-untilEndOfChar# :: StringBuffer -> StringBuffer
-untilEndOfChar# (StringBuffer fo l# s# c#) =
- loop c#
- where
- getch# i# = indexCharOffAddr# fo i#
-
- loop c# =
- case getch# c# of
- '\''# ->
- case getch# (c# -# 1#) of
- '\\'# ->
- case getch# (c# -# 2#) of
- '\\'# -> -- end of char
- StringBuffer fo l# s# c#
- _ -> loop (c# +# 1#) -- false alarm
- _ -> StringBuffer fo l# s# c#
- '\NUL'# ->
- if c# >=# l# then -- hit sentinel, this doesn't look too good..
- StringBuffer fo l# l# l#
- else
- loop (c# +# 1#)
- _ -> loop (c# +# 1#)
-
untilChar# :: StringBuffer -> Char# -> StringBuffer
untilChar# (StringBuffer fo l# s# c#) x# =
loop c#
where
loop c#
- | indexCharOffAddr# fo c# `eqChar#` x#
+ | c# >=# l# || indexCharOffAddr# fo c# `eqChar#` x#
= StringBuffer fo l# s# c#
| otherwise
= loop (c# +# 1#)
f $! x = x `seq` f x
#endif
\end{code}
+
+\begin{code}
+#if __GLASGOW_HASKELL__ < 402
+bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
+bracket before after thing = do
+ a <- before
+ (thing a) `catch` (\err -> after a >>= fail err)
+ after a
+#endif
+\end{code}
projects / ghc-hetmet.git / commitdiff