From 1fb1ab5d53a09607e7f6d2450806760688396387 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 14 Mar 1997 08:11:17 +0000 Subject: [PATCH] [project @ 1997-03-14 07:52:06 by simonpj] Major update to more-or-less 2.02 --- ANNOUNCE-2.02 | 177 ++ Makefile | 105 +- configure.in | 1525 +---------- distrib/Makefile-bin.in | 137 + distrib/configure-bin.in | 133 + docs/Makefile | 8 + docs/installing.lit | 1730 +++++++++++++ ghc/CONTRIB/README | 19 - ghc/CONTRIB/fptags | 53 - ghc/CONTRIB/haskel.gif | Bin 5380 -> 0 bytes ghc/CONTRIB/haskell-modes/README | 55 - .../chalmers/original/haskell-mode.el | 543 ---- .../chalmers/sof/haskell-mode.el | 825 ------ .../chalmers/thiemann/haskell-mode.el | 764 ------ .../glasgow/original/haskell-mode.el | 1935 -------------- .../haskell-modes/glasgow/original/manual.dvi | Bin 25452 -> 0 bytes .../haskell-modes/glasgow/original/report.dvi | Bin 82272 -> 0 bytes .../haskell-modes/simonm/ghc/haskell.el | 185 -- .../haskell-modes/simonm/real/haskell.el | 202 -- .../haskell-modes/yale/chak/haskell.el | 1866 -------------- .../haskell-modes/yale/original/README | 5 - .../haskell-modes/yale/original/comint.el | 1524 ----------- .../yale/original/haskell-menu.el | 43 - .../haskell-modes/yale/original/haskell.el | 1710 ------------- .../yale/original/optimizer-help.txt | 6 - .../yale/original/printer-help.txt | 26 - ghc/CONTRIB/haskell_poem | 58 - ghc/CONTRIB/mira2hs | 364 --- ghc/CONTRIB/pphs/Jmakefile | 16 - ghc/CONTRIB/pphs/README | 18 - ghc/CONTRIB/pphs/docs/Code.tex | 53 - ghc/CONTRIB/pphs/docs/Error_Messages.tex | 36 - .../pphs/docs/External_Specification.tex | 117 - ghc/CONTRIB/pphs/docs/Faults.tex | 66 - ghc/CONTRIB/pphs/docs/Future_Work.tex | 30 - ghc/CONTRIB/pphs/docs/Haskell_char.tex | 7 - .../pphs/docs/Haskell_internalalign1.tex | 12 - .../pphs/docs/Haskell_internalalign2.tex | 4 - ghc/CONTRIB/pphs/docs/Haskell_leftindent1.tex | 7 - ghc/CONTRIB/pphs/docs/Haskell_leftindent2.tex | 9 - ghc/CONTRIB/pphs/docs/Haskell_math.tex | 5 - ghc/CONTRIB/pphs/docs/Haskell_simple.tex | 5 - ghc/CONTRIB/pphs/docs/Haskell_string1.tex | 8 - ghc/CONTRIB/pphs/docs/Haskell_typewriter.tex | 7 - ghc/CONTRIB/pphs/docs/How.tex | 465 ---- ghc/CONTRIB/pphs/docs/Introduction.tex | 137 - ghc/CONTRIB/pphs/docs/LaTeX-code_simple.tex | 12 - ghc/CONTRIB/pphs/docs/LaTeX_blankline.tex | 6 - ghc/CONTRIB/pphs/docs/LaTeX_char.tex | 9 - ghc/CONTRIB/pphs/docs/LaTeX_comment.tex | 3 - .../pphs/docs/LaTeX_internalalign1.tex | 13 - ghc/CONTRIB/pphs/docs/LaTeX_leftindent1.tex | 8 - ghc/CONTRIB/pphs/docs/LaTeX_leftindent2.tex | 8 - ghc/CONTRIB/pphs/docs/LaTeX_math.tex | 7 - ghc/CONTRIB/pphs/docs/LaTeX_simple.tex | 5 - ghc/CONTRIB/pphs/docs/LaTeX_string1.tex | 10 - ghc/CONTRIB/pphs/docs/LaTeX_string2.tex | 10 - ghc/CONTRIB/pphs/docs/LaTeX_wide-colons.tex | 9 - ghc/CONTRIB/pphs/docs/Problem_Definition.tex | 37 - ghc/CONTRIB/pphs/docs/Project_Documents.tex | 7 - ghc/CONTRIB/pphs/docs/Report.tex | 49 - .../pphs/docs/Statement_Of_Requirements.tex | 32 - ghc/CONTRIB/pphs/docs/Title.tex | 0 ghc/CONTRIB/pphs/docs/UserGuide.tex | 9 - ghc/CONTRIB/pphs/docs/UserGuide_Text.tex | 231 -- ghc/CONTRIB/pphs/docs/User_Documents.tex | 5 - ghc/CONTRIB/pphs/docs/Uses.tex | 262 -- ghc/CONTRIB/pphs/docs/What.tex | 136 - ghc/CONTRIB/pphs/docs/Wrapper.tex | 6 - ghc/CONTRIB/pphs/docs/char.hs | 5 - ghc/CONTRIB/pphs/docs/comment.hs | 1 - ghc/CONTRIB/pphs/docs/internalalign1.hs | 9 - ghc/CONTRIB/pphs/docs/leftindent1.hs | 4 - ghc/CONTRIB/pphs/docs/leftindent2.hs | 6 - ghc/CONTRIB/pphs/docs/math.hs | 3 - ghc/CONTRIB/pphs/docs/pphs.sty | 26 - ghc/CONTRIB/pphs/docs/rep.sty | 80 - ghc/CONTRIB/pphs/docs/simple.hs | 3 - ghc/CONTRIB/pphs/docs/string1.hs | 6 - ghc/CONTRIB/pphs/docs/string2.hs | 8 - ghc/CONTRIB/pphs/pphs.c | 1030 -------- ghc/Makefile | 92 +- ghc/compiler/HsVersions.h | 32 +- ghc/compiler/Makefile | 449 ++-- ghc/compiler/NOTES | 129 + ghc/compiler/absCSyn/CLabel.lhs | 4 +- ghc/compiler/absCSyn/Costs.lhs | 3 +- ghc/compiler/absCSyn/HeapOffs.lhs | 2 +- ghc/compiler/absCSyn/PprAbsC.lhs | 74 +- ghc/compiler/basicTypes/Id.hi-boot | 8 + ghc/compiler/basicTypes/Id.lhs | 12 +- ghc/compiler/basicTypes/IdLoop.lhi | 27 +- ghc/compiler/basicTypes/Literal.lhs | 16 +- ghc/compiler/basicTypes/Name.lhs | 40 +- ghc/compiler/basicTypes/SrcLoc.lhs | 13 +- ghc/compiler/basicTypes/UniqSupply.lhs | 6 +- ghc/compiler/basicTypes/Unique.lhs | 7 + ghc/compiler/codeGen/CgClosure.lhs | 5 +- ghc/compiler/codeGen/CgMonad.lhs | 10 +- ghc/compiler/codeGen/CodeGen.lhs | 7 +- ghc/compiler/coreSyn/CoreLint.lhs | 68 +- ghc/compiler/coreSyn/CoreSyn.lhs | 12 +- ghc/compiler/coreSyn/CoreUnfold.lhs | 61 +- ghc/compiler/coreSyn/PprCore.lhs | 72 +- ghc/compiler/deSugar/Desugar.lhs | 59 +- ghc/compiler/deSugar/DsBinds.lhs | 123 +- ghc/compiler/deSugar/DsExpr.lhs | 144 +- ghc/compiler/deSugar/DsGRHSs.lhs | 6 +- ghc/compiler/deSugar/DsHsSyn.lhs | 1 + ghc/compiler/deSugar/DsListComp.lhs | 150 +- ghc/compiler/deSugar/DsLoop.lhi | 2 +- ghc/compiler/deSugar/DsMonad.lhs | 51 +- ghc/compiler/deSugar/DsUtils.lhs | 19 +- ghc/compiler/deSugar/Match.lhs | 74 +- ghc/compiler/deSugar/MatchLit.lhs | 70 +- ghc/compiler/hsSyn/HsBasic.lhs | 6 +- ghc/compiler/hsSyn/HsBinds.lhs | 52 +- ghc/compiler/hsSyn/HsCore.lhs | 35 +- ghc/compiler/hsSyn/HsDecls.lhs | 43 +- ghc/compiler/hsSyn/HsExpr.lhs | 104 +- ghc/compiler/hsSyn/HsPat.lhs | 32 +- ghc/compiler/hsSyn/HsPragmas.lhs | 32 +- ghc/compiler/hsSyn/HsTypes.lhs | 8 +- ghc/compiler/main/CmdLineOpts.lhs | 9 +- ghc/compiler/main/LoopHack.lhc | 53 +- ghc/compiler/main/Main.lhs | 24 +- ghc/compiler/main/MkIface.lhs | 57 +- ghc/compiler/nativeGen/AsmCodeGen.lhs | 2 +- ghc/compiler/nativeGen/NCG.h | 2 +- ghc/compiler/nativeGen/PprMach.lhs | 10 +- ghc/compiler/parser/UgenUtil.lhs | 6 +- ghc/compiler/parser/hslexer.flex | 29 +- ghc/compiler/parser/hsparser.y | 110 +- ghc/compiler/parser/id.c | 2 +- ghc/compiler/parser/main.c | 1 + ghc/compiler/parser/syntax.c | 23 +- ghc/compiler/parser/tree.ugn | 3 +- ghc/compiler/prelude/PrelInfo.lhs | 12 +- ghc/compiler/prelude/PrelLoop.lhi | 3 +- ghc/compiler/prelude/PrelMods.lhs | 45 +- ghc/compiler/prelude/PrelVals.lhs | 2 +- ghc/compiler/prelude/PrimOp.lhs | 8 +- ghc/compiler/prelude/PrimRep.lhs | 57 +- ghc/compiler/profiling/CostCentre.lhs | 25 +- ghc/compiler/reader/Lex.lhs | 685 +++-- ghc/compiler/reader/PrefixToHs.lhs | 2 +- ghc/compiler/reader/RdrHsSyn.lhs | 18 +- ghc/compiler/reader/ReadPrefix.lhs | 20 +- ghc/compiler/rename/ParseIface.y | 231 +- ghc/compiler/rename/ParseType.y | 140 ++ ghc/compiler/rename/ParseUnfolding.y | 344 +++ ghc/compiler/rename/Rename.lhs | 119 +- ghc/compiler/rename/RnBinds.lhs | 42 +- ghc/compiler/rename/RnEnv.lhs | 245 +- ghc/compiler/rename/RnExpr.lhs | 151 +- ghc/compiler/rename/RnHsSyn.lhs | 1 - ghc/compiler/rename/RnIfaces.lhs | 463 ++-- ghc/compiler/rename/RnMonad.lhs | 118 +- ghc/compiler/rename/RnNames.lhs | 140 +- ghc/compiler/rename/RnSource.lhs | 104 +- ghc/compiler/simplCore/BinderInfo.lhs | 76 +- ghc/compiler/simplCore/FloatOut.lhs | 8 +- ghc/compiler/simplCore/OccurAnal.lhs | 67 +- ghc/compiler/simplCore/SetLevels.lhs | 4 +- ghc/compiler/simplCore/SimplCore.lhs | 68 +- ghc/compiler/simplCore/SimplEnv.lhs | 49 +- ghc/compiler/simplCore/SimplMonad.lhs | 47 +- ghc/compiler/simplCore/SimplPgm.lhs | 20 +- ghc/compiler/simplCore/SimplVar.lhs | 14 +- ghc/compiler/simplStg/LambdaLift.lhs | 37 +- ghc/compiler/simplStg/SimplStg.lhs | 184 +- ghc/compiler/specialise/SpecEnv.lhs | 7 +- ghc/compiler/specialise/SpecUtils.lhs | 58 +- ghc/compiler/specialise/Specialise.lhs | 219 +- ghc/compiler/stgSyn/StgLint.lhs | 42 +- ghc/compiler/stgSyn/StgSyn.lhs | 68 +- ghc/compiler/stranal/SaAbsInt.lhs | 8 +- ghc/compiler/stranal/SaLib.lhs | 16 +- ghc/compiler/stranal/StrictAnal.lhs | 8 +- ghc/compiler/stranal/WwLib.lhs | 2 +- ghc/compiler/tests/Makefile | 6 +- ghc/compiler/tests/deSugar/Makefile | 13 +- ghc/compiler/typecheck/GenSpecEtc.lhs | 451 ---- ghc/compiler/typecheck/Inst.lhs | 36 +- ghc/compiler/typecheck/TcBinds.lhs | 683 +++-- ghc/compiler/typecheck/TcClassDcl.lhs | 85 +- ghc/compiler/typecheck/TcDefaults.lhs | 6 +- ghc/compiler/typecheck/TcDeriv.lhs | 11 +- ghc/compiler/typecheck/TcEnv.lhs | 21 +- ghc/compiler/typecheck/TcExpr.lhs | 224 +- ghc/compiler/typecheck/TcGenDeriv.lhs | 64 +- ghc/compiler/typecheck/TcHsSyn.lhs | 78 +- ghc/compiler/typecheck/TcIfaceSig.lhs | 57 +- ghc/compiler/typecheck/TcInstDcls.lhs | 66 +- ghc/compiler/typecheck/TcInstUtil.lhs | 30 +- ghc/compiler/typecheck/TcKind.lhs | 28 +- ghc/compiler/typecheck/TcMatches.lhs | 6 +- ghc/compiler/typecheck/TcModule.lhs | 12 +- ghc/compiler/typecheck/TcMonad.lhs | 23 +- ghc/compiler/typecheck/TcMonoType.lhs | 2 +- ghc/compiler/typecheck/TcPat.lhs | 40 +- ghc/compiler/typecheck/TcSimplify.lhs | 16 +- ghc/compiler/typecheck/TcTyClsDecls.lhs | 8 +- ghc/compiler/typecheck/TcTyDecls.lhs | 14 +- ghc/compiler/typecheck/Unify.lhs | 24 +- ghc/compiler/types/Kind.lhs | 6 +- ghc/compiler/types/PprType.lhs | 18 +- ghc/compiler/types/TyCon.lhs | 14 +- ghc/compiler/types/TyLoop.lhi | 5 +- ghc/compiler/types/Type.lhs | 74 +- ghc/compiler/utils/Argv.lhs | 4 + ghc/compiler/utils/Bag.lhs | 26 +- ghc/compiler/utils/CharSeq.lhs | 3 +- ghc/compiler/utils/FastString.lhs | 505 ++++ ghc/compiler/utils/FiniteMap.lhs | 7 +- ghc/compiler/utils/HandleHack.lhi | 26 + ghc/compiler/utils/MatchEnv.lhs | 8 +- ghc/compiler/utils/PprStyle.lhs | 1 + ghc/compiler/utils/Pretty.lhs | 12 +- ghc/compiler/utils/PrimPacked.lhs | 279 +++ ghc/compiler/utils/StringBuffer.lhs | 318 +++ ghc/compiler/utils/Ubiq.lhi | 5 +- ghc/compiler/utils/UniqFM.lhs | 8 +- ghc/compiler/utils/Unpretty.lhs | 2 +- ghc/compiler/utils/Util.lhs | 4 +- ghc/docs/Makefile | 11 +- ghc/docs/install_guide/Makefile | 5 - ghc/docs/install_guide/installing.lit | 2177 ---------------- ghc/docs/release_notes/Makefile | 6 - ghc/docs/state_interface/Makefile | 9 - ghc/docs/state_interface/state-interface.verb | 1156 --------- .../2-01-notes.lit | 0 ghc/docs/users_guide/2-02-notes.lit | 112 + ghc/docs/users_guide/Makefile | 11 +- ghc/docs/users_guide/how_to_run.lit | 106 +- ghc/docs/users_guide/intro.lit | 16 +- ghc/docs/users_guide/libraries.lit | 2223 +++++++++-------- .../real-soon-now.lit | 0 ghc/docs/users_guide/recomp.lit | 14 +- .../release.lit | 0 ghc/docs/users_guide/user.lit | 3 +- ghc/driver/Makefile | 156 +- ghc/driver/ghc-consist.lprl | 2 +- ghc/driver/ghc-iface.lprl | 6 +- ghc/driver/ghc.lprl | 964 +++---- ghc/driver/prefix.txt | 12 + ghc/lib/cbits/getCPUTime.lc | 105 + ghc/lib/cbits/stgio.h | 9 +- ghc/lib/required/CPUTime.lhs | 51 + ghc/lib/tests/Array/arr001/Main.hs | 9 + ghc/lib/tests/Array/arr001/Makefile | 3 + ghc/lib/tests/Array/arr002/Main.hs | 23 + ghc/lib/tests/Array/arr002/Makefile | 3 + ghc/lib/tests/Array/arr003/Main.hs | 19 + ghc/lib/tests/Array/arr003/Makefile | 3 + ghc/lib/tests/Array/arr004/Main.hs | 15 + ghc/lib/tests/Array/arr004/Makefile | 3 + ghc/lib/tests/Array/arr005/Main.hs | 16 + ghc/lib/tests/Array/arr005/Makefile | 3 + ghc/lib/tests/Array/arr006/Main.hs | 11 + ghc/lib/tests/Array/arr006/Makefile | 3 + ghc/lib/tests/Array/arr007/Main.hs | 11 + ghc/lib/tests/Array/arr007/Makefile | 3 + ghc/lib/tests/Array/arr008/Main.hs | 14 + ghc/lib/tests/Array/arr008/Makefile | 3 + ghc/lib/tests/Array/arr009/Main.hs | 17 + ghc/lib/tests/Array/arr009/Makefile | 3 + ghc/lib/tests/Array/arr010/Main.hs | 19 + ghc/lib/tests/Array/arr010/Makefile | 3 + ghc/lib/tests/Array/arr011/Main.hs | 20 + ghc/lib/tests/Array/arr011/Makefile | 3 + ghc/lib/tests/Array/arr012/Main.hs | 19 + ghc/lib/tests/Array/arr012/Makefile | 3 + ghc/mk/boilerplate.mk | 34 + ghc/mk/buildflags.mk | 198 -- ghc/mk/ghc-opts.mk | 192 -- ghc/mk/ghc.mk | 14 - ghc/mk/ghcconfig.mk.in | 237 -- ghc/mk/paths.mk | 78 + ghc/mk/site-ghc.mk | 94 - ghc/mk/suffix.mk | 21 + ghc/mk/suffixes-ghc.mk | 40 - ghc/mk/target.mk | 14 + ghc/mk/ways.mk | 38 - ghc/utils/hstags/prefix.txt | 9 + glafp-utils/Makefile | 28 +- glafp-utils/fastmake/Makefile | 20 +- glafp-utils/fastmake/fastmake.prl | 9 +- glafp-utils/lndir/Makefile | 12 +- glafp-utils/ltx/Makefile | 15 +- glafp-utils/ltx/ltx.prl | 15 +- glafp-utils/mk/boilerplate.mk | 31 + glafp-utils/mk/opts.mk | 9 + glafp-utils/mkdependC/Makefile | 24 +- glafp-utils/mkdependC/mkdependC.prl | 12 +- glafp-utils/mkdirhier/Makefile | 15 +- glafp-utils/msub/Makefile | 17 +- glafp-utils/runstdtest/Makefile | 18 +- glafp-utils/runstdtest/runstdtest.prl | 18 +- mk/Cprog.mk | 42 - mk/HSprog.mk | 38 - mk/boilerplate.mk | 58 + mk/cdepend.mk | 14 - mk/clib.mk | 34 - mk/config.h.in | 182 ++ mk/config.mk.in | 688 +++++ mk/gen.mk | 37 - mk/hsdepend.mk | 14 - mk/install.mk.in | 83 - mk/lib.mk | 40 - mk/opts.mk | 115 + mk/paths.mk | 274 ++ mk/platform.mk.in | 22 - mk/rules.mk | 319 --- mk/script.mk | 53 - mk/subdir.mk | 101 - mk/suffix.mk | 365 +++ mk/target.mk | 873 +++++++ mk/utils.mk.in | 382 --- 319 files changed, 14097 insertions(+), 25084 deletions(-) create mode 100644 ANNOUNCE-2.02 create mode 100644 distrib/Makefile-bin.in create mode 100644 distrib/configure-bin.in create mode 100644 docs/Makefile create mode 100644 docs/installing.lit delete mode 100644 ghc/CONTRIB/README delete mode 100644 ghc/CONTRIB/fptags delete mode 100644 ghc/CONTRIB/haskel.gif delete mode 100644 ghc/CONTRIB/haskell-modes/README delete mode 100644 ghc/CONTRIB/haskell-modes/chalmers/original/haskell-mode.el delete mode 100644 ghc/CONTRIB/haskell-modes/chalmers/sof/haskell-mode.el delete mode 100644 ghc/CONTRIB/haskell-modes/chalmers/thiemann/haskell-mode.el delete mode 100644 ghc/CONTRIB/haskell-modes/glasgow/original/haskell-mode.el delete mode 100644 ghc/CONTRIB/haskell-modes/glasgow/original/manual.dvi delete mode 100644 ghc/CONTRIB/haskell-modes/glasgow/original/report.dvi delete mode 100644 ghc/CONTRIB/haskell-modes/simonm/ghc/haskell.el delete mode 100644 ghc/CONTRIB/haskell-modes/simonm/real/haskell.el delete mode 100644 ghc/CONTRIB/haskell-modes/yale/chak/haskell.el delete mode 100644 ghc/CONTRIB/haskell-modes/yale/original/README delete mode 100644 ghc/CONTRIB/haskell-modes/yale/original/comint.el delete mode 100644 ghc/CONTRIB/haskell-modes/yale/original/haskell-menu.el delete mode 100644 ghc/CONTRIB/haskell-modes/yale/original/haskell.el delete mode 100644 ghc/CONTRIB/haskell-modes/yale/original/optimizer-help.txt delete mode 100644 ghc/CONTRIB/haskell-modes/yale/original/printer-help.txt delete mode 100644 ghc/CONTRIB/haskell_poem delete mode 100644 ghc/CONTRIB/mira2hs delete mode 100644 ghc/CONTRIB/pphs/Jmakefile delete mode 100644 ghc/CONTRIB/pphs/README delete mode 100644 ghc/CONTRIB/pphs/docs/Code.tex delete mode 100644 ghc/CONTRIB/pphs/docs/Error_Messages.tex delete mode 100644 ghc/CONTRIB/pphs/docs/External_Specification.tex delete mode 100644 ghc/CONTRIB/pphs/docs/Faults.tex delete mode 100644 ghc/CONTRIB/pphs/docs/Future_Work.tex delete mode 100644 ghc/CONTRIB/pphs/docs/Haskell_char.tex delete mode 100644 ghc/CONTRIB/pphs/docs/Haskell_internalalign1.tex delete mode 100644 ghc/CONTRIB/pphs/docs/Haskell_internalalign2.tex delete mode 100644 ghc/CONTRIB/pphs/docs/Haskell_leftindent1.tex delete mode 100644 ghc/CONTRIB/pphs/docs/Haskell_leftindent2.tex delete mode 100644 ghc/CONTRIB/pphs/docs/Haskell_math.tex delete mode 100644 ghc/CONTRIB/pphs/docs/Haskell_simple.tex delete mode 100644 ghc/CONTRIB/pphs/docs/Haskell_string1.tex delete mode 100644 ghc/CONTRIB/pphs/docs/Haskell_typewriter.tex delete mode 100644 ghc/CONTRIB/pphs/docs/How.tex delete mode 100644 ghc/CONTRIB/pphs/docs/Introduction.tex delete mode 100644 ghc/CONTRIB/pphs/docs/LaTeX-code_simple.tex delete mode 100644 ghc/CONTRIB/pphs/docs/LaTeX_blankline.tex delete mode 100644 ghc/CONTRIB/pphs/docs/LaTeX_char.tex delete mode 100644 ghc/CONTRIB/pphs/docs/LaTeX_comment.tex delete mode 100644 ghc/CONTRIB/pphs/docs/LaTeX_internalalign1.tex delete mode 100644 ghc/CONTRIB/pphs/docs/LaTeX_leftindent1.tex delete mode 100644 ghc/CONTRIB/pphs/docs/LaTeX_leftindent2.tex delete mode 100644 ghc/CONTRIB/pphs/docs/LaTeX_math.tex delete mode 100644 ghc/CONTRIB/pphs/docs/LaTeX_simple.tex delete mode 100644 ghc/CONTRIB/pphs/docs/LaTeX_string1.tex delete mode 100644 ghc/CONTRIB/pphs/docs/LaTeX_string2.tex delete mode 100644 ghc/CONTRIB/pphs/docs/LaTeX_wide-colons.tex delete mode 100644 ghc/CONTRIB/pphs/docs/Problem_Definition.tex delete mode 100644 ghc/CONTRIB/pphs/docs/Project_Documents.tex delete mode 100644 ghc/CONTRIB/pphs/docs/Report.tex delete mode 100644 ghc/CONTRIB/pphs/docs/Statement_Of_Requirements.tex delete mode 100644 ghc/CONTRIB/pphs/docs/Title.tex delete mode 100644 ghc/CONTRIB/pphs/docs/UserGuide.tex delete mode 100644 ghc/CONTRIB/pphs/docs/UserGuide_Text.tex delete mode 100644 ghc/CONTRIB/pphs/docs/User_Documents.tex delete mode 100644 ghc/CONTRIB/pphs/docs/Uses.tex delete mode 100644 ghc/CONTRIB/pphs/docs/What.tex delete mode 100644 ghc/CONTRIB/pphs/docs/Wrapper.tex delete mode 100644 ghc/CONTRIB/pphs/docs/char.hs delete mode 100644 ghc/CONTRIB/pphs/docs/comment.hs delete mode 100644 ghc/CONTRIB/pphs/docs/internalalign1.hs delete mode 100644 ghc/CONTRIB/pphs/docs/leftindent1.hs delete mode 100644 ghc/CONTRIB/pphs/docs/leftindent2.hs delete mode 100644 ghc/CONTRIB/pphs/docs/math.hs delete mode 100644 ghc/CONTRIB/pphs/docs/pphs.sty delete mode 100644 ghc/CONTRIB/pphs/docs/rep.sty delete mode 100644 ghc/CONTRIB/pphs/docs/simple.hs delete mode 100644 ghc/CONTRIB/pphs/docs/string1.hs delete mode 100644 ghc/CONTRIB/pphs/docs/string2.hs delete mode 100644 ghc/CONTRIB/pphs/pphs.c create mode 100644 ghc/compiler/NOTES create mode 100644 ghc/compiler/basicTypes/Id.hi-boot create mode 100644 ghc/compiler/rename/ParseType.y create mode 100644 ghc/compiler/rename/ParseUnfolding.y delete mode 100644 ghc/compiler/typecheck/GenSpecEtc.lhs create mode 100644 ghc/compiler/utils/FastString.lhs create mode 100644 ghc/compiler/utils/HandleHack.lhi create mode 100644 ghc/compiler/utils/PrimPacked.lhs create mode 100644 ghc/compiler/utils/StringBuffer.lhs delete mode 100644 ghc/docs/install_guide/Makefile delete mode 100644 ghc/docs/install_guide/installing.lit delete mode 100644 ghc/docs/release_notes/Makefile delete mode 100644 ghc/docs/state_interface/Makefile delete mode 100644 ghc/docs/state_interface/state-interface.verb rename ghc/docs/{release_notes => users_guide}/2-01-notes.lit (100%) create mode 100644 ghc/docs/users_guide/2-02-notes.lit rename ghc/docs/{release_notes => users_guide}/real-soon-now.lit (100%) rename ghc/docs/{release_notes => users_guide}/release.lit (100%) create mode 100644 ghc/driver/prefix.txt create mode 100644 ghc/lib/cbits/getCPUTime.lc create mode 100644 ghc/lib/required/CPUTime.lhs create mode 100644 ghc/lib/tests/Array/arr001/Main.hs create mode 100644 ghc/lib/tests/Array/arr001/Makefile create mode 100644 ghc/lib/tests/Array/arr002/Main.hs create mode 100644 ghc/lib/tests/Array/arr002/Makefile create mode 100644 ghc/lib/tests/Array/arr003/Main.hs create mode 100644 ghc/lib/tests/Array/arr003/Makefile create mode 100644 ghc/lib/tests/Array/arr004/Main.hs create mode 100644 ghc/lib/tests/Array/arr004/Makefile create mode 100644 ghc/lib/tests/Array/arr005/Main.hs create mode 100644 ghc/lib/tests/Array/arr005/Makefile create mode 100644 ghc/lib/tests/Array/arr006/Main.hs create mode 100644 ghc/lib/tests/Array/arr006/Makefile create mode 100644 ghc/lib/tests/Array/arr007/Main.hs create mode 100644 ghc/lib/tests/Array/arr007/Makefile create mode 100644 ghc/lib/tests/Array/arr008/Main.hs create mode 100644 ghc/lib/tests/Array/arr008/Makefile create mode 100644 ghc/lib/tests/Array/arr009/Main.hs create mode 100644 ghc/lib/tests/Array/arr009/Makefile create mode 100644 ghc/lib/tests/Array/arr010/Main.hs create mode 100644 ghc/lib/tests/Array/arr010/Makefile create mode 100644 ghc/lib/tests/Array/arr011/Main.hs create mode 100644 ghc/lib/tests/Array/arr011/Makefile create mode 100644 ghc/lib/tests/Array/arr012/Main.hs create mode 100644 ghc/lib/tests/Array/arr012/Makefile create mode 100644 ghc/mk/boilerplate.mk delete mode 100644 ghc/mk/buildflags.mk delete mode 100644 ghc/mk/ghc-opts.mk delete mode 100644 ghc/mk/ghc.mk delete mode 100644 ghc/mk/ghcconfig.mk.in create mode 100644 ghc/mk/paths.mk delete mode 100644 ghc/mk/site-ghc.mk create mode 100644 ghc/mk/suffix.mk delete mode 100644 ghc/mk/suffixes-ghc.mk create mode 100644 ghc/mk/target.mk delete mode 100644 ghc/mk/ways.mk create mode 100644 ghc/utils/hstags/prefix.txt create mode 100644 glafp-utils/mk/boilerplate.mk create mode 100644 glafp-utils/mk/opts.mk delete mode 100644 mk/Cprog.mk delete mode 100644 mk/HSprog.mk create mode 100644 mk/boilerplate.mk delete mode 100644 mk/cdepend.mk delete mode 100644 mk/clib.mk create mode 100644 mk/config.h.in create mode 100644 mk/config.mk.in delete mode 100644 mk/gen.mk delete mode 100644 mk/hsdepend.mk delete mode 100644 mk/install.mk.in delete mode 100644 mk/lib.mk create mode 100644 mk/opts.mk create mode 100644 mk/paths.mk delete mode 100644 mk/platform.mk.in delete mode 100644 mk/rules.mk delete mode 100644 mk/script.mk delete mode 100644 mk/subdir.mk create mode 100644 mk/suffix.mk create mode 100644 mk/target.mk delete mode 100644 mk/utils.mk.in diff --git a/ANNOUNCE-2.02 b/ANNOUNCE-2.02 new file mode 100644 index 0000000000..38b6b5b3ab --- /dev/null +++ b/ANNOUNCE-2.02 @@ -0,0 +1,177 @@ + The Glasgow Haskell Compiler -- version 2.02 + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We are pleased to announce the first release of the Glasgow Haskell +Compiler (GHC, version 2.02) for *Haskell 1.4*. Sources and binaries +are freely available by anonymous FTP and on the World-Wide Web; +details below. + +Haskell is "the" standard lazy functional programming language; the +current language version is 1.3, agreed in May, 1996. The Haskell +Report is online at + + http://haskell.cs.yale.edu/1.4/haskell-report.html + +GHC 2.02 is a beta-quality release: + + * It is reliable. + It has been extensively tested against a large suite of Haskell 1.2 + programs, but not so extensively tested against Haskell 1.4 programs + because we don't have a comprehensive set (Donations of Haskell 1.4 + programs to our test suite are most welcome). + + * It should generate good code. + All the optimisations that GHC 0.29 used to do are back in, with + the exception of specialisation. It ought to be the case that + GHC 2.02 outperforms GHC 0.29, because it has a much better + handle on cross-module inlining, but there's a good chance that + there are performance "holes" lurking. We have yet to make + a systematic comparison. (Please send us programs where 2.02 + does noticeably worse than 0.29.) + + * It is more expensive than it should be. + GHC 2.02 has received even less attention to its own performance. + At present it eats more space and time than GHC 0.29, especially + for very small programs. We'll work on this. + + * A couple of Haskell 1.4 features are incompletely supported, + notably polymorphic strictness annotations, and Unicode. + +If you want to use Haskell 1.4, this is a good moment to switch. If +you don't need the Haskell 1.4 extensions, then stay with GHC 0.29. +If you want to hack on GHC itself, then 2.02 is definitely for you. +The release notes comment further on this point. + +GHC 2.02 is substantially changed from 2.01. Changes worth noting +include: + + * The whole front end, which deals with the module system, has + been rewritten. The interface file format has changed. + + * GHC 2.02 comes complete with Green Card, a C foreign language + interface for GHC. Green card is a pre-processor that + scans Haskell source files for Green Card directives, which + it expands into tons of "ccall" boilerplate that marshalls + your arguments to and from C. + + * GHC 2.02 is available for Windows NT. From now on, Windows NT + will be a fully supported platform for GHC. + + * GHC 2.02 supports full cross moudule inlining. Unlike 0.29 and + its predecessors, inlining can happen even if the inlined body + mentions a function or type that is not itself exported. This is + one place Haskell 1.4's new module system really pays off. + + * Like 2.01, GHC 2.02 aborts a compilation if it decides that + nothing that the module imports *and acually uses* has changed. + This decision is now taken by the compiler itself, rather than + by a Perl script (as in 2.01) which sometimes got it wrong. + + * The ghc/lib libraries are much more systematically organised. + + * There's a completely new "make" system. This will mainly affect people + who want the source distribution, who will hopefully find it much, much, + easier than grappling with the old Jmakefiles. Even for binary + installation, the procedure is a little simpler, though. + +Please see the release notes for a complete discussion of What's New. + +To run this release, you need a machine with 16+MB memory (more if +building from sources), GNU C (`gcc'), and `perl'. We have seen GHC +2.01 work on these platforms: alpha-dec-osf2, hppa1.1-hp-hpux9, +sparc-sun-{sunos4,solaris2}, mips-sgi-irix5, and +i386-unknown-{linux,solaris2,freebsd}. Similar platforms should work +with minimal hacking effort. The installer's guide give a full +what-ports-work report. + +Binaries are distributed in `bundles', e.g. a "profiling bundle" or a +"concurrency bundle" for your platform. Just grab the ones you need. + +Once you have the distribution, please follow the pointers in +ghc/README to find all of the documentation about this release. NB: +preserve modification times when un-tarring the files (no `m' option +for tar, please)! + +We run mailing lists for GHC users and bug reports; to subscribe, send +mail to majordomo@dcs.gla.ac.uk; the msg body should be: + + subscribe glasgow-haskell- Your Name + +Please send bug reports about GHC to glasgow-haskell-bugs@dcs.gla.ac.uk. + +Simon Peyton Jones + +Dated: February 1997 + +Relevant URLs on the World-Wide Web: + +GHC home page http://www.dcs.gla.ac.uk/fp/software/ghc/ +Glasgow FP group page http://www.dcs.gla.ac.uk/fp/ +comp.lang.functional FAQ http://www.cs.nott.ac.uk/Department/Staff/mpj/faq.html + +====================================================================== +How to get GHC 2.01: + +This release is available by anonymous FTP from the main Haskell +archive sites, in the directory pub/haskell/glasgow: + + ftp.dcs.gla.ac.uk (130.209.240.50) + ftp.cs.chalmers.se (129.16.227.140) + haskell.cs.yale.edu (128.36.11.43) + +The Glasgow site is mirrored by src.doc.ic.ac.uk (146.169.43.1), in +computing/programming/languages/haskell/glasgow. + +These are the available files (.gz files are gzipped) -- some are `on +demand', ask if you don't see them: + +ghc-2.01-src.tar.gz The source distribution; about 3MB. + +ghc-2.01.ANNOUNCE This file. + +ghc-2.01.{README,RELEASE-NOTES} From the distribution; for those who + want to peek before FTPing... + +ghc-2.01-ps-docs.tar.gz Main GHC documents in PostScript format; in + case your TeX setup doesn't agree with our + DVI files... + +ghc-2.01-.tar.gz Basic binary distribution for a particular + . Unpack and go: you can compile + and run Haskell programs with nothing but one + of these files. NB: does *not* include + profiling (see below). + + ==> alpha-dec-osf2 + hppa1.1-hp-hpux9 + i386-unknown-freebsd + i386-unknown-linux + i386-unknown-solaris2 + m68k-sun-sunos4 + mips-sgi-irix5 + sparc-sun-sunos4 + sparc-sun-solaris2 + +ghc-2.01--.tar.gz + + ==> as above + ==> prof (profiling) + conc (concurrent Haskell) + par (parallel) + gran (GranSim parallel simulator) + ticky (`ticky-ticky' counts -- for implementors) + prof-conc (profiling for "conc[urrent]") + prof-ticky (ticky for "conc[urrent]") + +ghc-2.01-hc-files.tar.gz Basic set of intermediate C (.hc) files for the + compiler proper, the prelude, and `Hello, + world'. Used for bootstrapping the system. + About 4MB. + +ghc-2.01--hc-files.tar.gz Further sets of .hc files, for + building other "bundles", e.g., profiling. + +ghc-2.01-hi-files-.tar.gz Sometimes it's more convenient to + use a different set of interface files than + the ones in *-src.tar.gz. (The installation + guide will advise you of this.) diff --git a/Makefile b/Makefile index b5fce9ccdf..eca7ef4076 100644 --- a/Makefile +++ b/Makefile @@ -1,23 +1,92 @@ -#----------------------------------------------------------------------------- -# $Id: Makefile,v 1.2 1996/11/21 16:45:54 simonm Exp $ +################################################################################# +# +# fptools/Makefile +# +# This is the main Makefile for fptools. +# +################################################################################# -TOP = . -SUBDIRS = glafp-utils ghc -include $(TOP)/mk/gen.mk -include $(TOP)/mk/subdir.mk +TOP=. +include $(TOP)/mk/boilerplate.mk +SRC_DIST_DIR=$(shell pwd)/$(SRC_DIST_NAME) -line = @echo "------------------------------------------------------------------------------" +SUBDIRS = $(ProjectsToBuild) -boot :: - @echo "Bootstrapping $(PROJECTNAME)..." - $(line) - @echo "Booting glafp-utils" - $(line) - @$(MAKE) -C glafp-utils boot +# +# Files to include in fptools source distribution +# +SRC_DIST_DIRS += mk $(ProjectsToBuild) +SRC_DIST_FILES += configure.in config.guess config.sub configure README ANNOUNCE NEWS INSTALL Makefile - $(line) - @echo "Booting ghc" - $(line) - @$(MAKE) -C ghc boot - @echo "Done!" +# +# Making a binary distribution +# +BIN_DIST_TMPDIR=$(shell pwd) +BIN_DIST_NAME=fptools + +# +# list of toplevel `projects' to include in binary distrib. +# +BIN_DIST_DIRS=ghc + +binary-dist:: binary-dist-pre + +BIN_DIST_TOP= distrib/Makefile-bin.in \ + distrib/configure-bin.in \ + distrib/README \ + distrib/INSTALL \ + distrib/ANNOUNCE + +binary-dist:: + @for i in $(BIN_DIST_TOP); do \ + @echo cp $$i $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME) \ + cp $$i $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME) \ + done; + +# +# Creating and copying the documentation into the bin-dist tree. +# +binary-dist:: + $(MKDIRHIER) $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/html + $(MKDIRHIER) $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/dvi + $(MKDIRHIER) $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/info + @echo "Making html documentation.." + $(MAKE) -C docs --no-print-directory $(MFLAGS) html + cp docs/html/* $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/html + @echo "Making dvi files.." + $(MAKE) -C docs --no-print-directory $(MFLAGS) dvi + cp docs/*.dvi $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/dvi + @echo "Making info files.." + $(MAKE) -C docs --no-print-directory $(MFLAGS) info + cp docs/*.info* $(BIN_DIST_TMPDIR)/$(BIN_DIST_NAME)/info + +dist :: dist-pre +include $(TOP)/mk/target.mk +dist :: dist-post + +# +# Automatically remake update configuration files +# (from autoconf manual) +# +configure: configure.in + autoconf +# +# autoheader might not change config.h.in, so touch a stamp file. +# +mk/config.h.in: mk/stamp-h.in +mk/stamp-h.in: configure.in + autoheader + echo timestamp > mk/stamp-h.in + +mk/config.h: mk/stamp-h +mk/stamp-h: mk/config.h.in config.status + ./config.status + +config.status: configure + ./config.status --recheck + +.PHONY: config + +config: config.status + @: diff --git a/configure.in b/configure.in index 94624cac42..12ed4cf11f 100644 --- a/configure.in +++ b/configure.in @@ -4,7 +4,7 @@ dnl dnl * INITIAL SETUP, CHOICE OF PLATFORM(S) #!/bin/sh # -# (c) The AQUA Project, Glasgow University, 1994-1995 +# (c) The AQUA Project, Glasgow University, 1994-1997 # # Configure script for the Glasgow functional programming tools # (created automagically by autoconf...do not edit by hand) @@ -12,163 +12,51 @@ dnl * INITIAL SETUP, CHOICE OF PLATFORM(S) # Do "./configure --help" to see what flags are available. # (Better yet, read the documentation!) # -AC_INIT(mk/platform.mk.in) +# First off, a distrib sanity check.. +AC_INIT(mk/config.mk.in) # ------------------------------------------------------------------------- # Prepare to generate the following header files # -AC_CONFIG_HEADER(ghc/includes/config.h literate/lit-deatify/config.h) +# +AC_CONFIG_HEADER(mk/config.h) # No, we don't do `--srcdir'... if test x"$srcdir" != 'x.' ; then - echo "This configuration does not support the \`--srcdir' option." + echo "This configuration does not support the \`--srcdir' option.." exit 1 fi +# +# Remove some automounter nonsense (Glasgow specific gruff) +# hardtop=`pwd` -hardtop=`echo $hardtop | sed 's|^/tmp_mnt/|/|' | sed 's|^/export/|/|' | sed 's|^/grasp_tmp|/local/grasp_tmp|'` +hardtop=`echo $hardtop | sed 's|^/tmp_mnt/|/|' | sed 's|^/grasp_tmp|/local/grasp_tmp|'` + +#OLD: hardtop=`echo $hardtop | sed 's|^/tmp_mnt/|/|' | sed 's|^/export/|/|' | sed 's|^/grasp_tmp|/local/grasp_tmp|'` + echo '' echo "*** The top of your build tree is: $hardtop" AC_SUBST(hardtop) -# ------------------------------------------------------------------------- -dnl ** choose what blobs to build (ghc,hslibs,haggis,happy,nofib,????) - -# set to the name for the dir if doing it, otherwise empty -DoingHsLibs='' -DoingNoFib='' -DoingHappy='' -DoingHaggis='' -MkWorldSetup='std' - -AC_ARG_ENABLE(hslibs, - [ -********************************************************************** -* Configuration options for the Glasgow functional-programming tools * -********************************************************************** - -First, select *which* of the tools you want to build, with ---{enable,disable}-{hslibs,nofib,happy,haggis}. (Currently, you have to -build ghc.) - -Second, you may set one of a few applies-in-all-cases options. For -example, --with-tmpdir=/usr/tmp. - -Then you may set various options which are specifically for the tools you -choose in step 1. For GHC, perhaps --enable-concurrent. For NoFib, -perhaps --enable-all-tests. And so on. - -The rest of this message lists all of the configure options. If the option -is enabled by default, the message says how to disable it. And vice versa. - -If you are confused, don't forget the installation documents that came with -the software! - -******************************************************************* -** FOR SELECTING WHICH GLASGOW FP TOOLS TO BUILD:] - [--enable-hslibs build suite of Haskell libraries], - [case "$enableval" in - yes) DoingHsLibs='hslibs' - ;; - no) DoingHsLibs='' - ;; - *) echo "I don't understand this option: --enable-hslibs=$enableval" - exit 1 - ;; - esac]) -if test "xxx$DoingHsLibs" = 'xxxhslibs' -a \( ! -d hslibs \) ; then - DoingHsLibs='' - echo 'Doing --disable-hslibs, as there is no hslibs directory' -fi - -AC_ARG_ENABLE(nofib, - [--enable-nofib build NoFib suite as part of Glasgow FP tools], - [case "$enableval" in - yes) DoingNoFib='nofib' - ;; - no) DoingNoFib='' - ;; - *) echo "I don't understand this option: --enable-nofib=$enableval" - exit 1 - ;; - esac]) -if test "xxx$DoingNoFib" = 'xxxnofib' -a \( ! -d nofib \) ; then - DoingNoFib='' - echo 'Doing --disable-nofib, as there is no nofib directory' -fi - -AC_ARG_ENABLE(happy, - [--enable-happy build Happy parser-generator as part of Glasgow FP tools], - [case "$enableval" in - yes) DoingHappy='happy' - ;; - no) DoingHappy='' - ;; - *) echo "I don't understand this option: --enable-happy=$enableval" - exit 1 - ;; - esac]) -if test "xxx$DoingHappy" = 'xxxhappy' -a \( ! -d happy \) ; then - DoingHappy='' - echo 'Doing --disable-happy, as there is no happy directory' -fi - -AC_ARG_ENABLE(haggis, - [--enable-haggis build Haggis GUI toolkit as part of Glasgow FP tools], - [case "$enableval" in - yes) DoingHaggis='haggis' - ;; - no) DoingHaggis='' - ;; - *) echo "I don't understand this option: --enable-haggis=$enableval" - exit 1 - ;; - esac]) -if test "xxx$DoingHaggis" = 'xxxhaggis' -a \( ! -d haggis \) ; then - DoingHaggis='' - echo 'Doing --disable-haggis, as there is no haggis directory' -fi - -AC_SUBST(DoingHsLibs) -AC_SUBST(DoingNoFib) -AC_SUBST(DoingHappy) -AC_SUBST(DoingHaggis) - # ------------------------------------------------------------------------- dnl ** choose host(/target/build) platform +# # Guess host/target/build platform(s) if necessary. -# Partly stolen from GCC "configure". # -if test "x$target" = xNONE ; then - if test "x$nonopt" != xNONE ; then - target=$nonopt - else - # This way of testing the result of a command substitution is - # defined by Posix.2 (section 3.9.1) as well as traditional shells. - if target=`$srcdir/config.guess` ; then - echo "Configuring for a ${target} host." 1>&2 - else - echo 'Config.guess failed to determine the host type. You need \ -to specify one.' 1>&2 - if test -r config.status ; then - tail +2 config.status 1>&2 - fi - exit 1 - fi - fi -fi +AC_CANONICAL_SYSTEM # "$host" defaults to "$target" if test "x$host" = xNONE ; then host=$target fi # "$build" defaults to "$host" -if test "x$build" = xNONE ; then - build=$host -else - echo "This configuration does not support the \`--build' option." - exit 1 -fi +#if test "x$build" = xNONE ; then +# build=$host +#else +# echo "This configuration does not support the \`--build' option." +# exit 1 +#fi dnl ** canonicalize platform names # Canonicali[sz]e those babies @@ -181,22 +69,23 @@ if test x"$TargetPlatform" != x"$HostPlatform" ; then exit 1 fi +# # The following will be more difficult when we *are* cross-compiling. # Suitable names to slam in *_CPP are in platform.h.in. # We also record the architecture, vendor, and operating system (OS) # separately. case $HostPlatform in alpha-dec-osf[[1234]]*) - HostPlatform=alpha-dec-osf1 # canonicalise for our purposes + HostPlatform=alpha-dec-osf1 # canonicalise for our purposes TargetPlatform=alpha-dec-osf1 # this will work for now... (hack) - BuildPlatform=alpha-dec-osf1 #hack + BuildPlatform=alpha-dec-osf1 # hack HostPlatform_CPP='alpha_dec_osf1' HostArch_CPP='alpha' HostVendor_CPP='dec' HostOS_CPP='osf1' ;; hppa1.1-hp-hpux*) - HostPlatform=hppa1.1-hp-hpux # canonicalise for our purposes (hack) + HostPlatform=hppa1.1-hp-hpux # canonicalise for our purposes (hack) TargetPlatform=hppa1.1-hp-hpux BuildPlatform=hppa1.1-hp-hpux HostPlatform_CPP='hppa1_1_hp_hpux' @@ -205,7 +94,7 @@ hppa1.1-hp-hpux*) HostOS_CPP='hpux' ;; i[[3456]]86-*-linuxaout*) - HostPlatform=i386-unknown-linuxaout # hack again + HostPlatform=i386-unknown-linuxaout # hack again TargetPlatform=i386-unknown-linuxaout BuildPlatform=i386-unknown-linuxaout HostPlatform_CPP='i386_unknown_linuxaout' @@ -249,6 +138,15 @@ i[[3456]]86-*-solaris2*) HostVendor_CPP='unknown' HostOS_CPP='solaris2' ;; +i[[3456]]86-*-cygwin32*) + HostPlatform=i386-unknown-cygwin32 # hack again + TargetPlatform=i386-unknown-cygwin32 + BuildPlatform=i386-unknown-cygwin32 + HostPlatform_CPP='i386_unknown_cygwin32' + HostArch_CPP='i386' + HostVendor_CPP='unknown' + HostOS_CPP='cygwin32' + ;; m68k-next-nextstep2) HostPlatform_CPP='m68k_next_nextstep2' HostArch_CPP='m68k' @@ -326,12 +224,9 @@ sparc-sun-solaris2*) exit 1 ;; esac - -test -n "$verbose" && echo "Host platform set to $HostPlatform" -test -n "$verbose" -a x"$HostPlatform" != x"$TargetPlatform" \ - && echo "Target platform set to $TargetPlatform" -test -n "$verbose" -a x"$BuildPlatform" != x"$HostPlatform" \ - && echo "Build platform set to $BuildPlatform" +echo "Which we'll canonicalise into: $HostPlatform" +test x"$HostPlatform" != x"$TargetPlatform" && echo "Target platform set to $TargetPlatform" +test x"$BuildPlatform" != x"$HostPlatform" && echo "Build platform set to $BuildPlatform" BuildPlatform_CPP=$HostPlatform_CPP TargetPlatform_CPP=$HostPlatform_CPP @@ -341,10 +236,11 @@ BuildOS_CPP=$HostOS_CPP TargetOS_CPP=$HostOS_CPP BuildVendor_CPP=$HostVendor_CPP TargetVendor_CPP=$HostVendor_CPP -dnl Cannot afford all these AC_SUBSTs (because of braindead seds w/ 99 cmd limits + +dnl Cannot afford all these SUBSTs (because of braindead seds w/ 99 cmd limits) dnl AC_SUBST(BuildPlatform) AC_SUBST(HostPlatform) -dnl AC_SUBST(TargetPlatform) +AC_SUBST(TargetPlatform) AC_SUBST(HostPlatform_CPP) dnl AC_SUBST(BuildPlatform_CPP) dnl AC_SUBST(TargetPlatform_CPP) @@ -364,6 +260,8 @@ dnl * _GENERAL_ CONFIGURATION CHECKS # dnl ** are we at Glasgow? # +# This stuff is in danger of going away.. +# if test -d /local/fp -a -d /users/fp/simonpj; then echo "Brilliant! You must be a Glaswegian." AT_GLASGOW=1 @@ -471,7 +369,8 @@ else rm -fr conftest* fi AC_SUBST(HaveGcc) -AC_C_CROSS + +# Deprecated (AC_PROG_CC does it): AC_C_CROSS # dnl ** figure out how to do context diffs # (NB: NeXTStep thinks diff'ing a file against itself is "trouble") @@ -507,7 +406,7 @@ if test -z "$YaccCmd"; then $WhatCmd $YaccCmd > conftest.out if egrep 'y1\.c 1\..*SMI' conftest.out >/dev/null 2>&1; then echo "I don't trust your $YaccCmd; it looks like an old Sun yacc" - if test -x /usr/lang/yacc; then + if test -f /usr/lang/yacc; then echo "I'm going to use /usr/lang/yacc instead" YaccCmd=/usr/lang/yacc else @@ -529,146 +428,6 @@ dnl ** Find lex command (lex or flex) and library (-ll or -lfl) # AC_PROG_LEX -#-------------------------------------------------------------- -WithHc='haskell-compiler-unspecified' -WithHcType='HC_UNSPECIFIED' - -AC_ARG_WITH(hc, - [ -******************************************************************* -** GENERAL OPTIONS WHICH APPLY TO ALL TOOLS: - ---with-hc= - ghc* => Glasgow Haskell invoked by the name given - hbc* => Chalmers HBC, invoked by the name given - nhc* => Niklas Rojemo's "nhc", invoked by the name given - C or c => Don't use a Haskell compiler; - build from intermediate C (.hc) files. - in-place => Use ghc/driver/ghc; i.e. you've built GHC - and you want to use it un-installed ("in-place"). - ], - [case "$withval" in - ghc* | glhc* ) - WithHc=$withval - ;; - hbc* ) WithHc=$withval - ;; - nhc* ) WithHc=$withval - ;; - c | C) WithHc='C' - ;; - in-place ) - WithHc='IN-PLACE' - ;; - *) echo "I don't understand this option: --with-hc=$withval" - exit 1 - ;; - esac]) - -# make sure that what they said makes sense.... set WithHcType -case $WithHc in - haskell-compiler-unspecified ) # maybe they will say something later... - ;; - ghc* | glhc* ) - WithHcType='HC_GLASGOW_GHC' - AC_CHECK_PROG(have_ghc,$WithHc,$ac_dir/$ac_word) - if test -z "$have_ghc"; then - echo "Can't find Glasgow Haskell to compile with: $WithHc" - exit 1 - fi - ;; - hbc* ) # Look for the dastardly competition - WithHcType='HC_CHALMERS_HBC' - AC_CHECK_PROG(have_hbc,$WithHc,YES,NO) - if test $have_hbc = 'NO' ; then - echo "Can't find Chalmers HBC to compile with: $WithHc" - exit 1 - fi - ;; - nhc* ) # Look for Niklas Rojemo's "nhc" - WithHcType='HC_ROJEMO_NHC' - AC_CHECK_PROG(have_nhc,$WithHc,YES,NO) - if test $have_nhc = 'NO' ; then - echo "Can't find Niklas Rojemo's NHC to compile with: $WithHc" - exit 1 - fi - ;; - c | C) WithHcType='HC_USE_HC_FILES' - ;; - IN-PLACE) WithHcType='HC_GLASGOW_GHC' - WithHc='$(TOP_PWD)/ghc/driver/ghc' - ;; -esac -AC_SUBST(WithHc) -AC_SUBST(WithHcType) - -dnl ** Possibly use something else instead of 'gcc'. -WhatGccIsCalled=gcc -AC_ARG_WITH(gcc, - [--with-gcc= - Use a different command instead of 'gcc' for the GNU C compiler.], - [HaveGcc=YES; WhatGccIsCalled="$withval"]) -AC_SUBST(WhatGccIsCalled) - -dnl ** Choose which make to use (default 'make') -MakeCmd='make' -AC_ARG_WITH(make, - [ ---with-make= - Use an alternate command instead of 'make'. This is useful - when GNU make is required (for instance when the default make - supplied by the system won't work, as is the case on FreeBSD - and NetBSD).], - [MakeCmd="$withval"]) -AC_SUBST(MakeCmd) - -dnl ** possibly choose a different tmpdir (default /tmp) -# let the user decide where the best tmpdir is -# /tmp is the default; /usr/tmp is sometimes a good choice. -# Very site-specific. -TmpDir='/tmp' -AC_ARG_WITH(tmpdir, - [ ---with-tmpdir= - Use an alternative directory for temporary files (presumably - because /tmp is too small).], - [TmpDir="$withval"]) -AC_SUBST(TmpDir) - -dnl ** possibly set a max heap for Haskell compilations -HcMaxHeapFlag='' -AC_ARG_WITH(max-heap, - [ ---with-max-heap= - Do all Haskell compilations with a heap of this size.], - [HcMaxHeapFlag="-H$withval"]) -AC_SUBST(HcMaxHeapFlag) - -dnl ** possibly set a max stack for Haskell compilations -HcMaxStackFlag='' -AC_ARG_WITH(max-stack, - [ ---with-max-stack= - Do all Haskell compilations with a stack of this size.], - [HcMaxStackFlag="-K$withval"]) -AC_SUBST(HcMaxStackFlag) - -dnl ** figure out about mkdependHS -MkDependHSCmd='mkdependHS' -if test -f ./ghc/utils/mkdependHS/mkdependHS \ - -o -f ./ghc/utils/mkdependHS/mkdependHS.prl ; then - MkDependHSCmd='TopDirPwd/ghc/utils/mkdependHS/mkdependHS' -fi -AC_ARG_WITH(mkdependHS, - [--with-mkdependHS= - Use a different command instead of 'mkdependHS'.], - [MkDependHSCmd="$withval"]) -dnl AC_CHECK_PROG(have_mkdependHS,$MkDependHSCmd,YES,NO) -dnl if test $have_mkdependHS = 'NO' ; then -dnl MkDependHSCmd=':' -dnl fi -AC_SUBST(MkDependHSCmd) - # ------------------------------------------------------------------------- # dnl ** figure out how to invoke cpp directly (gcc -E is no good) @@ -744,6 +503,59 @@ if test -n "$NeedRanLib"; then fi AC_SUBST(RANLIB) # +# +dnl ** Check to see whether ln -s works +# +AC_PROG_LN_S() +AC_SUBST(LN_S) +# +dnl ** Find the path to sed ** +AC_PATH_PROG(SedCmd,sed,$ac_dir/$ac_word) +# +# It better be around somewhere (we wouldn't +# exec this script properly if it wasn't!) +# +AC_SUBST(SedCmd) +# +dnl ** check for time command ** +AC_PATH_PROG(TimeCmd,time,$ac_dir/$ac_word) +# +AC_SUBST(TimeCmd) +# +dnl ** check for tar ** +# +# if GNU tar is named gtar, look for it first. +# +AC_PATH_PROGS(TarCmd,gtar tar,tar) +AC_SUBST(TarCmd) + +# +dnl ** check for gzip/compress ** +AC_PATH_PROGS(CompressCmd,gzip compress,gzip) + +compress_nm=`basename $CompressCmd` + +if test x"$compress_nm" = xgzip; then + CompressCmd="$CompressCmd -d" + CompressSuffix="gz" +else + CompressSuffix="Z" +fi +AC_SUBST(CompressCmd) +AC_SUBST(CompressSuffix) +# +dnl ** check for installed happy binary +# +AC_PATH_PROG(HappyCmd,happy) +AC_SUBST(HappyCmd) +# +# +dnl ** check for installed lx binary +# +AC_PATH_PROG(LxCmd,lx) +AC_SUBST(LxCmd) +# +# dnl ** check for full ANSI header (.h) files # AC_HEADER_STDC @@ -797,1137 +609,26 @@ char **argv; exit(1); }], LeadingUnderscore='YES', LeadingUnderscore='NO', LeadingUnderscore='YES') test -n "$verbose" && echo " setting LeadingUnderscore to $LeadingUnderscore" +AC_SUBST(LeadingUnderscore) -dnl ------------------------------------------------------- -dnl ** which builds to build? -dnl ** (applies to anything w/ libraries (ghc, hslibs, ???) -dnl ------------------------------------------------------- -# builds: normal = sequential _ap_o ; _p = profiling (sequential); -# _t = ticky; _u = unregisterized -Build_normal='YES' -Build_p='YES' -Build_t='NO' -Build_u='NO' -# _mc = concurrent; _mr = profiled concurrent; _mt = ticky concurrent -# _mp = parallel; _mg = gransim -Build_mc='NO' -Build_mr='NO' -Build_mt='NO' -Build_mp='NO' -Build_mg='NO' -# GC builds: _2s, _1s, _du (, _gn) -Build_2s='NO' -Build_1s='NO' -Build_du='NO' -# user builds: a...o -Build_a='NO' -Build_b='NO' -Build_c='NO' -Build_d='NO' -Build_e='NO' -Build_f='NO' -Build_g='NO' -Build_h='NO' -Build_i='NO' -Build_j='NO' -Build_k='NO' -Build_l='NO' -Build_m='NO' -Build_n='NO' -Build_o='NO' -Build_A='NO' -Build_B='NO' -# More could be added here... - -AC_ARG_ENABLE(normal-build, - [ -******************************************************************* -** \`GHC' (GLASGOW HASKELL COMPILER) OPTIONS: - -Choose all the \`builds' of GHC that you want: - ---disable-normal-build do *not* build GHC for normal sequential code], - [case "$enableval" in - yes) Build_normal='YES' - ;; - no) Build_normal='NO' - ;; - *) echo "I don't understand this option: --enable-normal-build=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(profiling, - [--disable-profiling do *not* build profiling features], - [case "$enableval" in - yes) Build_p='YES' - ;; - no) Build_p='NO' - ;; - *) echo "I don't understand this option: --enable-profiling=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(ticky, - [--enable-ticky build for \`ticky-ticky' profiling (for implementors)], - [case "$enableval" in - yes) Build_t='YES' - ;; - no) Build_t='NO' - ;; - *) echo "I don't understand this option: --enable-ticky=$enableval" - exit 1 - ;; - esac]) +AC_OUTPUT(mk/config.mk, echo timestamp > mk/stamp-h ) -AC_ARG_ENABLE(concurrent, - [--enable-concurrent turn on \`concurrent Haskell' features], - [case "$enableval" in - yes) Build_mc='YES' - ;; - no) Build_mc='NO' - ;; - *) echo "I don't understand this option: --enable-concurrent=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(profiled-concurrent, - [--enable-profiled-concurrent turn on profiling for \`concurrent Haskell'], - [case "$enableval" in - yes) Build_mr='YES' - ;; - no) Build_mr='NO' - ;; - *) echo "I don't understand this option: --enable-profiled-concurrent=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(ticky-concurrent, - [--enable-ticky-concurrent turn on \`ticky-ticky' profiling for \`concurrent Haskell'], - [case "$enableval" in - yes) Build_mt='YES' - ;; - no) Build_mt='NO' - ;; - *) echo "I don't understand this option: --enable-ticky-concurrent=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(parallel, - [--enable-parallel turn on \`parallel Haskell' features], - [case "$enableval" in - yes) Build_mp='YES'; - ;; - no) Build_mp='NO' - ;; - *) echo "I don't understand this option: --enable-parallel=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(gransim, - [--enable-gransim turn on GranSim parallel simulator], - [case "$enableval" in - yes) Build_mg='YES'; - ;; - no) Build_mg='NO' - ;; - *) echo "I don't understand this option: --enable-gransim=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(gc-2s, - [--enable-gc-2s a build with the 2-space copying garbage collector], - [case "$enableval" in - yes) Build_2s='YES' - ;; - no) Build_2s='NO' - ;; - *) echo "I don't understand this option: --enable-gc-2s=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(gc-1s, - [--enable-gc-1s a build with the 1-space compacting garbage collector], - [case "$enableval" in - yes) Build_1s='YES' - ;; - no) Build_1s='NO' - ;; - *) echo "I don't understand this option: --enable-gc-1s=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(gc-du, - [--enable-gc-du a build with \`dual-mode' (1s/2s) garbage collector], - [case "$enableval" in - yes) Build_du='YES' - ;; - no) Build_du='NO' - ;; - *) echo "I don't understand this option: --enable-gc-du=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-a, - [--enable-user-way-a build for \`user way a' (mostly for implementors)], - [case "$enableval" in - yes) Build_a='YES' - ;; - no) Build_a='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-a=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-b, - [--enable-user-way-b build for \`user way b' (mostly for implementors)], - [case "$enableval" in - yes) Build_b='YES' - ;; - no) Build_b='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-b=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-c, - [--enable-user-way-c build for \`user way c' (mostly for implementors)], - [case "$enableval" in - yes) Build_c='YES' - ;; - no) Build_c='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-c=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-d, - [--enable-user-way-d build for \`user way d' (mostly for implementors)], - [case "$enableval" in - yes) Build_d='YES' - ;; - no) Build_d='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-d=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-e, - [--enable-user-way-e build for \`user way e' (mostly for implementors)], - [case "$enableval" in - yes) Build_e='YES' - ;; - no) Build_e='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-e=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-f, - [--enable-user-way-f build for \`user way f' (mostly for implementors)], - [case "$enableval" in - yes) Build_f='YES' - ;; - no) Build_f='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-f=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-g, - [--enable-user-way-g build for \`user way g' (mostly for implementors)], - [case "$enableval" in - yes) Build_g='YES' - ;; - no) Build_g='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-g=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-h, - [--enable-user-way-h build for \`user way h' (mostly for implementors)], - [case "$enableval" in - yes) Build_h='YES' - ;; - no) Build_h='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-h=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-i, - [--enable-user-way-i build for \`user way i' (mostly for implementors)], - [case "$enableval" in - yes) Build_i='YES' - ;; - no) Build_i='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-i=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-j, - [--enable-user-way-j build for \`user way j' (mostly for implementors)], - [case "$enableval" in - yes) Build_j='YES' - ;; - no) Build_j='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-j=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-k, - [--enable-user-way-k build for \`user way k' (mostly for implementors)], - [case "$enableval" in - yes) Build_k='YES' - ;; - no) Build_k='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-k=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-l, - [--enable-user-way-l build for \`user way l' (mostly for implementors)], - [case "$enableval" in - yes) Build_l='YES' - ;; - no) Build_l='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-l=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-m, - [--enable-user-way-m build for \`user way m' (mostly for implementors)], - [case "$enableval" in - yes) Build_m='YES' - ;; - no) Build_m='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-m=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-n, - [--enable-user-way-n build for \`user way n' (mostly for implementors)], - [case "$enableval" in - yes) Build_n='YES' - ;; - no) Build_n='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-n=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-o, - [--enable-user-way-o build for \`user way o' (mostly for implementors)], - [case "$enableval" in - yes) Build_o='YES' - ;; - no) Build_o='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-o=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-A, - [--enable-user-way-A build for \`user way A' (mostly for implementors)], - [case "$enableval" in - yes) Build_A='YES' - ;; - no) Build_A='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-A=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(user-way-B, - [--enable-user-way-B build for \`user way B' (mostly for implementors)], - [case "$enableval" in - yes) Build_B='YES' - ;; - no) Build_B='NO' - ;; - *) echo "I don't understand this option: --enable-user-way-B=$enableval" - exit 1 - ;; - esac]) - -dnl We do not use AC_SUBST to communicate the Build_* info, -dnl as some seds (notably OSF) only allow 99 commands (!!!). -dnl We will do the equivalent by a HACK further down. - -# ------------------------------------------------------------------------- -dnl GHC CONFIGURATION STUFF - -dnl ** which Haskell compiler to bootstrap GHC with? -# Figure out what Haskell compiler(s) to use for booting -# -# first, the defaults... -WithGhcHc='haskell-compiler-unspecified' -WithGhcHcType='HC_UNSPECIFIED' -GhcBuilderVersion='28' - -AC_ARG_WITH(hc-for-ghc, - [ -The Haskell compiler for bootstrapping GHC (if any); this option, -if used, overrides --with-hc=<...>: - - --with-hc-for-ghc= - ghc* => Glasgow Haskell invoked by the name given - C or c => Don't use a Haskell compiler; - build from intermediate C (.hc) files. - ], - [case "$withval" in - ghc* | glhc* ) - WithGhcHc=$withval - ;; - hbc* ) echo "HBC will not compile GHC 0.26 as is (sigh)" - exit 1 - ;; - c | C) WithGhcHc='C' - WithGhcHcType='HC_USE_HC_FILES' - ;; - *) echo "I don't understand this option: --with-hc-for-ghc=$withval" - exit 1 - ;; - esac]) - -# make sure that what they said makes sense.... set WithGhcHcType -case $WithGhcHc in - haskell-compiler-unspecified ) # maybe they said something earlier... - if test $WithHc = 'haskell-compiler-unspecified' ; then - echo "Neither --with-hc nor --with-hc-for-ghc was properly set" - exit 1 - fi - if test $WithHcType = 'HC_GLASGOW_GHC' ; then - touch conftest.o - $WithHc -v -C conftest.o > conftest.out 2>&1 - echo '/version (\d+)\.(\d+)/ && print ($1*100+$2);' > conftest.pl - GhcBuilderVersion=`eval $PerlCmd -n conftest.pl conftest.out` - rm -rf conftest* - fi - ;; - ghc* | glhc* ) - WithGhcHcType='HC_GLASGOW_GHC' - AC_CHECK_PROG(have_ghc_ghc,$WithGhcHc,$ac_dir/$ac_word) - if test -z "$have_ghc_ghc"; then - echo "Can't find Glasgow Haskell to compile GHC with: $WithGhcHc" - exit 1 - else - touch conftest.o - $WithGhcHc -v -C conftest.o > conftest.out 2>&1 - echo '/version (\d+)\.(\d+)/ && print ($1*100+$2);' > conftest.pl - GhcBuilderVersion=`eval $PerlCmd -n conftest.pl conftest.out` - rm -rf conftest* - fi - ;; - c | C) WithGhcHcType='HC_USE_HC_FILES' - ;; -esac -AC_SUBST(GhcBuilderVersion) -AC_SUBST(WithGhcHc) -AC_SUBST(WithGhcHcType) - -dnl ** use portable (slow) C? -- preferably not -GhcWithRegisterised='YES' -AC_ARG_ENABLE(portable-C, - [Other things for GHC: - ---enable-portable-C use portable C (slow), not \`registerised' (fast)], - [case "$enableval" in - yes) GhcWithRegisterised='NO' - ;; - no) GhcWithRegisterised='YES' - ;; - *) echo "I don't understand this option: --enable-portable-C=$enableval" - exit 1 - ;; - esac]) - -if test $GhcWithRegisterised = 'YES'; then - case $HostPlatform in - alpha-* | hppa1.1-* | i386-* | m68k-* | mips-* | powerpc-* | sparc-* ) - ;; - *) - echo "Don't know non-portable C tricks for this platform: $HostPlatform" - GhcWithRegisterised='NO' - ;; - esac -fi -AC_SUBST(GhcWithRegisterised) - -if test $GhcWithRegisterised = 'NO'; then - Build_u='YES' - Build_normal='NO' - Build_p='NO' -fi -# ToDo: make sure we can do concurrent for platform/circs... -# ToDo: make sure we can do profiling for platform/circs... -# ToDo: make sure we can do parallel for platform/circs... -# ToDo: make sure we can do gransim for platform/circs... - -dnl ** build GHC compiler proper (\`hsc') from .hc files? -GhcWithHscBuiltViaC='NO' -AC_ARG_ENABLE(hsc-built-via-C, - [--enable-hsc-built-via-C build compiler proper (hsc) from intermediate .hc - files (disabled by default)], - [case "$enableval" in - yes) GhcWithHscBuiltViaC='YES' - ;; - no) GhcWithHscBuiltViaC='NO' - ;; - *) echo "I don't understand this option: --enable-hsc-built-via-C=$enableval" - exit 1 - ;; - esac]) -case $WithGhcHc in - haskell-compiler-unspecified ) # maybe they said something earlier... - if test $WithHcType = 'HC_USE_HC_FILES' ; then - GhcWithHscBuiltViaC='YES' - fi - ;; - c | C) GhcWithHscBuiltViaC='YES' - ;; - *) ;; -esac -AC_SUBST(GhcWithHscBuiltViaC) - -dnl ** build \`hsc' with -O? -GhcWithHscOptimised='YES' -AC_ARG_ENABLE(hsc-optimised, - [--disable-hsc-optimised don't build compiler proper (hsc) with -O], - [case "$enableval" in - yes) GhcWithHscOptimised='YES' - ;; - no) GhcWithHscOptimised='NO' - ;; - *) echo "I don't understand this option: --enable-hsc-optimised=$enableval" - exit 1 - ;; - esac]) -AC_SUBST(GhcWithHscOptimised) - -dnl ** build \`hsc' with -DDEBUG? -GhcWithHscDebug='NO' -AC_ARG_ENABLE(hsc-debug, - [--enable-hsc-debug build compiler proper (hsc) with -DDEBUG], - [case "$enableval" in - yes) GhcWithHscDebug='YES' - ;; - no) GhcWithHscDebug='NO' - ;; - *) echo "I don't understand this option: --enable-hsc-debug=$enableval" - exit 1 - ;; - esac]) -AC_SUBST(GhcWithHscDebug) - -dnl ** omit native-code generator from \`hsc'? -GhcWithNativeCodeGen='YES' -AC_ARG_ENABLE(native-code-generator, - [--enable-native-code-generator build an n.c.g. - [enabled for supported platforms]], - [case "$enableval" in - yes) GhcWithNativeCodeGen='YES' - ;; - no) GhcWithNativeCodeGen='NO' - ;; - *) echo "I don't understand this option: --enable-native-code-generator=$enableval" - exit 1 - ;; - esac]) -if test $GhcWithNativeCodeGen = 'YES'; then - case $TargetPlatform in - i386-* | alpha-* | sparc-* ) - ;; - *) - echo "Don't have a native-code generator for this platform: $TargetPlatform" - GhcWithNativeCodeGen='NO' - ;; - esac -fi -AC_SUBST(GhcWithNativeCodeGen) - -dnl ** include Marlow's deforester in \`hsc'? -GhcWithDeforester='NO' -AC_ARG_ENABLE(deforester, - [--enable-deforester build deforester into compiler (HACKERS ONLY)], - [case "$enableval" in - yes) GhcWithDeforester='YES' - ;; - no) GhcWithDeforester='NO' - ;; - *) echo "I don't understand this option: --enable-deforester=$enableval" - exit 1 - ;; - esac]) -AC_SUBST(GhcWithDeforester) - -dnl ** include Readline library? -GhcWithReadline='NO' -AC_ARG_ENABLE(readline-library, - [--enable-readline-library include (GNU) readline library in -syslib GHC], - [case "$enableval" in - yes) GhcWithReadline='YES' - ;; - no) GhcWithReadline='NO' - ;; - *) echo "I don't understand this option: --enable-readline-library=$enableval" - exit 1 - ;; - esac]) -AC_SUBST(GhcWithReadline) - -dnl ** include Sockets library? -GhcWithSockets='NO' -AC_ARG_ENABLE(sockets-library, - [--enable-sockets-library include the network-interface (sockets) library in -syslib GHC], - [case "$enableval" in - yes) GhcWithSockets='YES' - ;; - no) GhcWithSockets='NO' - ;; - *) echo "I don't understand this option: --enable-sockets-library=$enableval" - exit 1 - ;; - esac]) -AC_SUBST(GhcWithSockets) - -# Here, by HACK means, we dump all the Build_ info -# into a file. See comment above. -rm -f ghc/mk/buildinfo.mk -echo creating ghc/mk/buildinfo.mk -touch ghc/mk/buildinfo.mk -for xx in normal p t u mc mr mt mp mg 2s 1s du a b c d e f g h i j k l m n o A B ; do - eval "yy=\$Build_$xx" - echo "Build_$xx = $yy" >> ghc/mk/buildinfo.mk -done - -# ------------------------------------------------------------------------- -dnl -dnl * `HsLibs' CONFIGURATION STUFF - -if test "xxx$DoingHsLibs" = 'xxxhslibs' ; then -# a very big "if"! - -dnl ** which Haskell compiler to use on hslibs? -WithHsLibsHc='haskell-compiler-unspecified' -WithHsLibsHcType='HC_UNSPECIFIED' - -AC_ARG_WITH(hc-for-hslibs, - [ -******************************************************************* -** \`HsLibs' HASKELL LIBRARIES OPTIONS: - -The Haskell compiler to compile the Haskell Libraries suite; this -option, if used, overrides --with-hc=<...>: - - --with-hc-for-hslibs= - ghc* => Glasgow Haskell invoked by the name given - and you want to use it un-installed ("in-place").], - [case "$withval" in - ghc* | glhc* ) - WithHsLibsHc=$withval - ;; - in-place ) - WithHsLibsHc='IN-PLACE' - ;; - *) echo "I don't understand this option: --with-hc-for-hslibs=$withval" - exit 1 - ;; - esac]) - -# make sure that what they said makes sense.... set WithHsLibsHcType -case $WithHsLibsHc in - haskell-compiler-unspecified ) # maybe they said something earlier... - if test $WithHc = 'haskell-compiler-unspecified' ; then - echo "Neither --with-hc nor --with-hc-for-hslibs was properly set" - exit 1 - fi - ;; - ghc* | glhc* ) - WithHsLibsHcType='HC_GLASGOW_GHC' - AC_CHECK_PROG(have_ghc_hslibs,$WithHsLibsHc,$ac_dir/$ac_word) - if test -z "$have_ghc_hslibs"; then - echo "Can't find Glasgow Haskell to compile HsLibs with: $WithHsLibsHc" - exit 1 - fi - ;; - IN-PLACE) WithHsLibsHcType='HC_GLASGOW_GHC' - WithHsLibsHc='$(TOP_PWD)/ghc/driver/ghc' - ;; -esac -AC_SUBST(WithHsLibsHc) -AC_SUBST(WithHsLibsHcType) - -# Here, by HACK means, we dump all the Build_ info -# into a file. See comment above. -rm -f hslibs/mk/buildinfo.mk -echo creating hslibs/mk/buildinfo.mk -cat > hslibs/mk/buildinfo.mk <> hslibs/mk/buildinfo.mk -done - - -# here ends a very big if DoingHsLibs = 'hslibs' ... -fi -# -# ------------------------------------------------------------------------- -dnl -dnl * `Happy' CONFIGURATION STUFF - -if test "xxx$DoingHappy" = 'xxxhappy' ; then -# a very big "if"! - -dnl ** which Haskell compiler to use on happy? -WithHappyHc='haskell-compiler-unspecified' -WithHappyHcType='HC_UNSPECIFIED' - -AC_ARG_WITH(hc-for-happy, - [ -******************************************************************* -** \`Happy' PARSER-GENERATOR OPTIONS: - -The Haskell compiler to compile Happy; this option, if used, overrides ---with-hc=<...>: - - --with-hc-for-happy= - ghc* => Glasgow Haskell invoked by the name given - hbc* => Chalmers HBC, invoked by the name given - nhc* => Niklas Rojemo's "nhc", invoked by the name given - in-place => Use ghc/driver/ghc; i.e. you've built GHC - and you want to use it un-installed ("in-place").], - [case "$withval" in - ghc* | glhc* ) - WithHappyHc=$withval - ;; - hbc* ) WithHappyHc=$withval - ;; - nhc* ) WithHappyHc=$withval - ;; - in-place ) - WithHappyHc='IN-PLACE' - ;; - *) echo "I don't understand this option: --with-hc-for-happy=$withval" - exit 1 - ;; - esac]) - -# make sure that what they said makes sense.... set WithHappyHcType -case $WithHappyHc in - haskell-compiler-unspecified ) # maybe they said something earlier... - if test $WithHc = 'haskell-compiler-unspecified' ; then - echo "Neither --with-hc nor --with-hc-for-happy was properly set" - exit 1 - fi - ;; - ghc* | glhc* ) - WithHappyHcType='HC_GLASGOW_GHC' - AC_CHECK_PROG(have_ghc_happy,$WithHappyHc,$ac_dir/$ac_word) - if test -z "$have_ghc_happy"; then - echo "Can't find Glasgow Haskell to compile Happy with: $WithHappyHc" - exit 1 - fi - ;; - hbc* ) # Look for the dastardly competition - WithHappyHcType='HC_CHALMERS_HBC' - AC_CHECK_PROG(have_hbc,$WithHappyHc,YES,NO) - if test $have_hbc = 'NO' ; then - echo "Can't find Chalmers HBC to compile with: $WithHappyHc" - exit 1 - fi - ;; - nhc* ) # Look for Niklas Rojemo's "nhc" - WithHappyHcType='HC_ROJEMO_NHC' - AC_CHECK_PROG(have_nhc,$WithHappyHc,YES,NO) - if test $have_nhc = 'NO' ; then - echo "Can't find Niklas Rojemo's NHC to compile with: $WithHappyHc" - exit 1 - fi - ;; - IN-PLACE) WithHappyHcType='HC_GLASGOW_GHC' - WithHappyHc='$(TOP_PWD)/ghc/driver/ghc' - ;; -esac -AC_SUBST(WithHappyHc) -AC_SUBST(WithHappyHcType) - -# here ends a very big if DoingHappy = 'happy' ... -fi # -# ------------------------------------------------------------------------- -dnl -dnl * `Haggis' CONFIGURATION STUFF - -if test "xxx$DoingHaggis" = 'xxxhaggis' ; then -# a very big "if"! - -dnl ** which Haskell compiler to use on haggis? -WithHaggisHc='haskell-compiler-unspecified' -WithHaggisHcType='HC_UNSPECIFIED' - -AC_ARG_WITH(hc-for-haggis, - [ -******************************************************************* -** \`Haggis' HASKELL GUI TOOLKIT OPTIONS: - -The Haskell compiler to compile the Haggis toolkit; this option, if -used, overrides --with-hc=<...>: - - --with-hc-for-haggis= - ghc* => Glasgow Haskell invoked by the name given - and you want to use it un-installed ("in-place").], - [case "$withval" in - ghc* | glhc* ) - WithHaggisHc=$withval - ;; - in-place ) - WithHaggicHs='IN-PLACE' - ;; - *) echo "I don't understand this option: --with-hc-for-haggis=$withval" - exit 1 - ;; - esac]) - -# make sure that what they said makes sense.... set WithHaggisHcType -case $WithHaggisHc in - haskell-compiler-unspecified ) # maybe they said something earlier... - if test $WithHc = 'haskell-compiler-unspecified' ; then - echo "Neither --with-hc nor --with-hc-for-haggis was properly set" - exit 1 - fi - ;; - ghc* | glhc* ) - WithHaggisHcType='HC_GLASGOW_GHC' - AC_CHECK_PROG(have_ghc_haggis,$WithHaggisHc,$ac_dir/$ac_word) - if test -z "$have_ghc_haggis"; then - echo "Can't find Glasgow Haskell to compile Haggis with: $WithHaggisHc" - exit 1 - fi - ;; - IN-PLACE) WithHaggisHcType='HC_GLASGOW_GHC' - WithHaggisHc='$(TOP_PWD)/ghc/driver/ghc' - ;; -esac -AC_SUBST(WithHaggisHc) -AC_SUBST(WithHaggisHcType) - -# builds stuff?? ToDo - -# here ends a very big if DoingHaggis = 'haggis' ... -fi +# It'll break soon enough if it didn't, but we perform a sanity +# check here on the generated config.mk file to see if the +# sed that was used is of the well-behaved sort. # -# ------------------------------------------------------------------------- -dnl -dnl * `NoFib' CONFIGURATION STUFF - -if test "xxx$DoingNoFib" = 'xxxnofib' ; then -# a very big "if"! - -dnl ** which Haskell compiler to test with NoFib? -WithNoFibHc='haskell-compiler-unspecified' -WithNoFibHcType='HC_UNSPECIFIED' - -AC_ARG_WITH(hc-for-nofib, - [ -******************************************************************* -** NoFib HASKELL BENCHMARK SUITE OPTIONS: - -The Haskell compiler to compile the NoFib programs; this option, if -used, overrides --with-hc=<...>: - - --with-hc-for-nofib= - ghc* => Glasgow Haskell invoked by the name given - hbc* => Chalmers HBC, invoked by the name given - nhc* => Niklas Rojemo's "nhc", invoked by the name given - in-place => Use ghc/driver/ghc; i.e. you've built GHC - and you want to use it un-installed ("in-place"). - ], - [case "$withval" in - ghc* | glhc* ) - WithNoFibHc=$withval - ;; - hbc* ) WithNoFibHc=$withval - ;; - nhc* ) WithNoFibHc=$withval - ;; - in-place ) - WithNoFibHc='IN-PLACE' - ;; - *) echo "I don't understand this option: --with-hc-for-nofib=$withval" - exit 1 - ;; - esac]) - -# make sure that what they said makes sense.... set WithHappyHcType -case $WithNoFibHc in - haskell-compiler-unspecified ) # maybe they said something earlier... - if test $WithHc = 'haskell-compiler-unspecified' ; then - echo "Neither --with-hc nor --with-hc-for-nofib was properly set" - exit 1 - fi - ;; - ghc* | glhc* ) - WithNoFibHcType='HC_GLASGOW_GHC' - AC_CHECK_PROG(have_ghc_nofib,$WithNoFibHc,$ac_dir/$ac_word) - if test -z "$have_ghc_nofib"; then - echo "Can't find Glasgow Haskell to compile NoFib with: $WithNoFibHc" - exit 1 - fi - ;; - hbc* ) # Look for the dastardly competition - WithNoFibHcType='HC_CHALMERS_HBC' - AC_CHECK_PROG(have_hbc,$WithNoFibHc,YES,NO) - if test $have_hbc = 'NO' ; then - echo "Can't find Chalmers HBC to compile NoFib with: $WithNoFibHc" - exit 1 - fi - ;; - nhc* ) # Look for Niklas Rojemo's "nhc" - WithNoFibHcType='HC_ROJEMO_NHC' - AC_CHECK_PROG(have_nhc,$WithNoFibHc,YES,NO) - if test $have_nhc = 'NO' ; then - echo "Can't find Niklas Rojemo's NHC to compile NoFib with: $WithNoFibHc" - exit 1 - fi - ;; - IN-PLACE) WithNoFibHcType='HC_GLASGOW_GHC' - WithNoFibHc='$(TOP_PWD)/ghc/driver/ghc' - ;; -esac -AC_SUBST(WithNoFibHc) -AC_SUBST(WithNoFibHcType) - -dnl ** what mkworld \`setup' should be used? -AC_ARG_WITH(setup, - [ ---with-setup= : What mkworld \`setup' should be used? - Choices: ghc, hbc, nhc -], - [case "$withval" in - ghc ) MkWorldSetup='ghc' - ;; - hbc ) MkWorldSetup='hbc' - ;; - nhc ) MkWorldSetup='nhc' - ;; - *) echo "I don't understand this option: --with-setup=$withval" - exit 1 - ;; - esac]) - -if test $MkWorldSetup = 'std' ; then - echo 'You must do --with-setup=... (one of: ghc, hbc, or nhc) for NoFib' - exit 1 -fi - -# --------------------------------------- -# What sets of tests should be run. -# -IncludeRealNoFibTests='YES' # defaults -IncludeSpectralNoFibTests='YES' -IncludeImaginaryNoFibTests='YES' -IncludeSpecialiseNoFibTests='NO' -IncludeGHC_ONLYNoFibTests='NO' -IncludePRIVATENoFibTests='NO' -IncludeParallelNoFibTests='NO' - -dnl ** should *all* NoFib tests be run? -# special catch-all variant -AC_ARG_ENABLE(all-tests, - [Possibly turn on *all* of the possible tests (a sane choice -only if using GHC): - ---enable-all-tests do *all* tests], - [case "$enableval" in - yes) IncludeGHC_ONLYNoFibTests='YES' - IncludeSpecialiseNoFibTests='YES' - IncludePRIVATENoFibTests='YES' - IncludeParallelNoFibTests='YES' - ;; - no) IncludeGHC_ONLYNoFibTests='NO' - IncludeSpecialiseNoFibTests='NO' - IncludePRIVATENoFibTests='NO' - IncludeParallelNoFibTests='NO' - - IncludeRealNoFibTests='NO' - IncludeSpectralNoFibTests='NO' - IncludeImaginaryNoFibTests='NO' - ;; - *) echo "I don't understand this option: --enable-all-tests=$enableval" - exit 1 - ;; - esac]) - -dnl ** turn on/off individual categories of tests... -# individual categories -AC_ARG_ENABLE(imaginary-tests, - [ -Enable/disable individual categories of tests: - ---disable-imaginary-tests do *not* include imaginary tests], - [case "$enableval" in - yes) IncludeImaginaryNoFibTests='YES' - ;; - no) IncludeImaginaryNoFibTests='NO' - ;; - *) echo "I don't understand this option: --enable-imaginary-tests=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(spectral-tests, - [--disable-spectral-tests do *not* include spectral tests], - [case "$enableval" in - yes) IncludeSpectralNoFibTests='YES' - ;; - no) IncludeSpectralNoFibTests='NO' - ;; - *) echo "I don't understand this option: --enable-spectral-tests=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(real-tests, - [--disable-real-tests do *not* include real tests], - [case "$enableval" in - yes) IncludeRealNoFibTests='YES' - ;; - no) IncludeRealNoFibTests='NO' - ;; - *) echo "I don't understand this option: --enable-real-tests=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(GHC-ONLY-tests, - [--enable-GHC-ONLY-tests include GHC_ONLY tests], - [case "$enableval" in - yes) IncludeGHC_ONLYNoFibTests='YES' - ;; - no) IncludeGHC_ONLYNoFibTests='NO' - ;; - *) echo "I don't understand this option: --enable-GHC-ONLY-tests=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(specialise-tests, - [--enable-specialise-tests include specialisation tests], - [case "$enableval" in - yes) IncludeSpecialiseNoFibTests='YES' - ;; - no) IncludeSpecialiseNoFibTests='NO' - ;; - *) echo "I don't understand this option: --enable-specialise-tests=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(PRIVATE-tests, - [--enable-PRIVATE-tests include PRIVATE tests], - [case "$enableval" in - yes) IncludePRIVATENoFibTests='YES' - ;; - no) IncludePRIVATENoFibTests='NO' - ;; - *) echo "I don't understand this option: --enable-PRIVATE-tests=$enableval" - exit 1 - ;; - esac]) - -AC_ARG_ENABLE(parallel-tests, - [--enable-parallel-tests include parallel tests -], - [case "$enableval" in - yes) IncludeParallelNoFibTests='YES' - ;; - no) IncludeParallelNoFibTests='NO' - ;; - *) echo "I don't understand this option: --enable-parallel-tests=$enableval" - exit 1 - ;; - esac]) - -dnl not AC_SUBSTd because of 99-command seds (sigh) -dnl (See what follows instead) -dnl AC_SUBST(IncludeRealNoFibTests) -dnl AC_SUBST(IncludeSpectralNoFibTests) -dnl AC_SUBST(IncludeImaginaryNoFibTests) -dnl AC_SUBST(IncludeGHC_ONLYNoFibTests) -dnl AC_SUBST(IncludeSpecialiseNoFibTests) -dnl AC_SUBST(IncludePRIVATENoFibTests) -dnl AC_SUBST(IncludeParallelNoFibTests) - -# Here, by HACK means, we dump all the Include*NoFibTests info -# into a file. See comment above. -rm -f nofib/mk/buildinfo.mk -echo creating nofib/mk/buildinfo.mk -cat > nofib/mkworld/buildinfo.jm <> nofib/mk/buildinfo.mk -done - -# Here, by HACK means, we add all the Build_ info -# into a file. See comment above. - -for xx in normal p t u mc mr mt mp mg 2s 1s du a b c d e f g h i j k l m n o A B ; do - eval "yy=\$Build_$xx" - echo "Build_$xx = $yy" >> nofib/mk/buildinfo.mk -done - -# here ends a very big if DoingNoFib = 'nofib' ... +grep @ mk/config.mk > conftest.out +if grep -v '# enclosed in @at-signs@.' conftest.out >/dev/null 2>&1; then + : +else + echo 'Hmm..suspicious, did the configure script perform all the @..@ substitutions in mk/config.mk?..'; + grep -v '# enclosed in @at-signs@.' conftest.out /dev/null fi -# -# ------------------------------------------------------------------------- -dnl -dnl * extract non-header files with substitution (end) -# -AC_SUBST(MkWorldSetup) - -AC_OUTPUT(mk/platform.mk mk/utils.mk mk/install.mk ghc/mk/ghcconfig.mk ghc/includes/platform.h) +rm -f conftest* +echo '' echo '************************************************' -echo '*** NOW DO: make boot; make all' +echo '*** NOW DO: gmake boot followed by gmake all' echo '************************************************' exit 0 diff --git a/distrib/Makefile-bin.in b/distrib/Makefile-bin.in new file mode 100644 index 0000000000..404f4d126b --- /dev/null +++ b/distrib/Makefile-bin.in @@ -0,0 +1,137 @@ +# Instructions for configuring an fptools package. +# +# There are two ways you can get started with an fptools package, either +# by using the unpacked distribution tree in-situ or by installing the +# package. +# +# Using the package directly is easy, just do `make config', i.e., +# the distribution will *not* work out-of-the-box, you'll have to do +# this first. +# +# To install the package, you'll have to set one or more of the +# following variables: +# +# * bindir +# path to directory of where you want the executables +# to be installed. +# * libdir +# where you want the library archives to go. +# Note, if you specify /usr/foo/lib for libdir, +# the library files for your fptools package will be +# installed in /usr/foo/lib/-, i.e., +# /usr/foo/lib/ghc-2.02. If you don't want the package/version +# directory appended, you'll have to modify $(real_libdir) +# below. +# +# * datadir +# path to where the platform-independent files will go. +# As for libdir, the effective path for the platform-indep +# stuff is $(datadir)/-. If you want +# complete control, see $(real_libdir) +# +# * platform +# the platform you're installing for. The configure +# makes an educated guess what it, so you will only +# have to set this if it clashes with your reality. +# +# * infodir +# where to install the Emacs info files +# * htmldir +# where to install the documentation HTML files. +# * dvidir +# where to install the DVI files. +# +# Installing the documentation is not via the `install' rule, but +# via the rules: `install-docs', `install-html', `install-dvi' +# and `install-info'. +# +# For more complete instructions, consult the INSTALL file +# that came with the bundle, and/or consult the installation +# documentation in one of the document directories. +# +bindir = @bindir@ +libdir = @libdir@ +datadir = @datadir@ +platform = @platform@ + +infodir = @infodir@ +htmldir = @htmldir@ +dvidir = @dvidir@ + +# +# Putting the package stuff in package-specific +# directories: +# +real_libdir = $(libdir)/$(package)-$(version) +real_datadir = $(datadir)/$(package)-$(version) + + + + +package = ghc +version = 2.02 +PERL = @PerlCmd@ + +.PHONY: config install install-dirs + +config: + @echo Configuring $(package), version $(version), on $(platform) + @RM `pwd`/bin/$(platform)/$(package)-$(version)/$(package)-$(version) + @RM `pwd`/bin/$(platform)/$(package)-$(version)/$(package) + @echo $(PerlCmd) > `pwd`/bin/$(platform)/$(package) + @echo "$""bindir='"`pwd`"/bin/$(platform)/$(package)-$(version)';" >> `pwd`/bin/$(platform)/$(package)-$(version)/$(package) + @echo "$""libdir='"`pwd`"/lib/$(platform)/$(package)-$(version)';" >> `pwd`/bin/$(platform)/$(package)-$(version)/$(package) + @echo "$""datadir='"`pwd`"/share/$(platform)/$(package)-$(version)';" >> `pwd`/bin/$(platform)/$(package)-$(version)/$(package) + @cat `pwd`/bin/$(platform)/$(package)-$(version)/$(package).prl';" >> `pwd`/bin/$(platform)/$(package)-$(version)/$(package) + @(cd `pwd`/bin/$(platform)/$(package)-$(version); $(LN_S) $(package) $(package)-$(version) ) + @echo Finished..to use, add `pwd`/bin/$(platform)/$(package)-$(version) to your PATH. + +libdirs = . imports include +datadirs = . include + +install-dirs: + $(MKDIRHIER) $(bindir) + @for i in $(libdirs) ; do \ + echo (MKDIRHIER) $(real_libdir)/$$i; \ + (MKDIRHIER) $(real_libdir)/$$i; \ + done; + @for i in $(datadirs) ; do \ + echo (MKDIRHIER) $(real_datadir)/$$i; \ + (MKDIRHIER) $(real_datadir)/$$i; \ + done; + +install : install-dirs + +install : + $(INSTALL_PROGRAM) `pwd`/bin/$(platform)/$(package)-$(version)/* $(bindir) + @for i in $(libdirs); do \ + echo $(INSTALL) `pwd`/lib/$(platform)/$(package)-$(version)/$$i/* $(real_libdir)/$$i; \ + $(INSTALL) `pwd`/lib/$(platform)/$(package)-$(version)/$$i/* $(real_libdir)/$$i; \ + done; + @for i in $(datadirs); do \ + echo $(INSTALL) `pwd`/share/$(package)-$(version)/$$i/* $(real_datadir)/$$i; \ + $(INSTALL) `pwd`/share/$(package)-$(version)/$$i/* $(real_datadir)/$$i; \ + done; + +install-docs : install-info install-html install-dvi + +install-dirs-html: + $(MKDIRHIER) $(htmldir) + +install-dirs-info: + $(MKDIRHIER) $(infodir) + +install-dirs-dvi: + $(MKDIRHIER) $(dvidir) + +install-docs : install-html install-info install-dvi + +install-dvi: install-dirs-dvi + $(INSTALL) `pwd`/dvi/$(package)-$(version)/* $(dvidir) + +install-info: install-dirs-info + $(INSTALL) `pwd`/info/$(package)-$(version)/* $(infodir) + +install-html: install-dirs-html + $(INSTALL) `pwd`/html/$(package)-$(version)/* $(htmldir) + diff --git a/distrib/configure-bin.in b/distrib/configure-bin.in new file mode 100644 index 0000000000..88579d28b7 --- /dev/null +++ b/distrib/configure-bin.in @@ -0,0 +1,133 @@ +dnl +dnl Binary distribution configure script +dnl +#!/bin/sh +# + +AC_INIT(Makefile.in) + +# +# First off, what system are we running under? +# +AC_CANONICAL_SYSTEM + +dnl ** canonicalize platform names +# Canonicali[sz]e the platform name +TargetPlatform=`/bin/sh $srcdir/config.sub $target` || exit 1 + +# +# The following will be more difficult when we *are* cross-compiling. +# Suitable names to slam in *_CPP are in platform.h.in. +# We also record the architecture, vendor, and operating system (OS) +# separately. +case $HostPlatform in +alpha-dec-osf[[1234]]*) + TargetPlatform=alpha-dec-osf1;; +hppa1.1-hp-hpux*) + TargetPlatform=hppa1.1-hp-hpux;; +i[[3456]]86-*-linuxaout*) + TargetPlatform=i386-unknown-linuxaout;; +i[[3456]]86-*-linux*) + TargetPlatform=i386-unknown-linux;; +i[[3456]]86-*-freebsd*) + TargetPlatform=i386-unknown-freebsd;; +i[[3456]]86-*-netbsd*) + TargetPlatform=i386-unknown-netbsd;; +i[[3456]]86-*-solaris2*) + TargetPlatform=i386-unknown-solaris2;; +i[[3456]]86-*-cygwin32*) + TargetPlatform=i386-unknown-cygwin32;; +m68k-next-nextstep2) + TargetPlatform=m68k-next-nextstep2;; +m68k-next-nextstep3) + TargetPlatform=m68k-next-nextstep3;; +i[[3456]]86-next-nextstep3) + TargetPlatform=i386-next-nextstep3 +m68k-sun-sunos4*) + TargetPlatform=m68k-sun-sunos4 #hack +mips-dec-ultrix*) + TargetPlaformP=mips-dec-ultrix;; +mips-sgi-irix*) + TargetPlatform=mips-sgi-irix;; +powerpc-ibm-aix*) + TargetPlatform=powerpc-ibm-aix;; +sparc-sun-sunos4*) + TargetPlatform=sparc-sun-sunos4;; +sparc-sun-solaris2*) + TargetPlatform=sparc-sun-solaris2;; +*) + echo "Unrecognised platform: $TargetPlatform" + exit 1 + ;; +esac +echo "Which we'll canonicalise into: $TargetPlatform" + +platform=$TargetPlatform +AC_SUBST(platform) + +AC_CHECK_PROG(PerlCmd,perl,$ac_dir/$ac_word) +if test -z "$PerlCmd"; then + echo "You must install perl before you can continue" + echo "Perhaps it is already installed, but not in your PATH?" + exit 1 +else + $PerlCmd -v >conftest.out 2>&1 + if egrep "version 4" conftest.out >/dev/null 2>&1; then + if egrep "Patch level: 35" conftest.out >/dev/null 2>&1; then + echo " +************************************************************************ +Uh-oh...looks like you have Perl 4.035. + +Perl version 4.035 has a bug to do with recursion that will bite if +you run the lit2texi script, when making Info files from +literate files of various sorts. Either use the current version +(4.036), an older version (e.g., perl 4.019) or apply the patch in +glafp-utils/perl-4.035-fixes to your 4.035 perl. +************************************************************************ +" + fi + else + if egrep "version 5" conftest.out >/dev/null 2>&1; then + : + else + echo "I'm not sure if your version of perl will work," + echo "but it's worth a shot, eh?" + fi + fi + rm -fr conftest* +fi +# +dnl ** does #!.../perl work? (sometimes it's too long...) +echo "checking if \`#!$PerlCmd' works in shell scripts" +echo "#!$PerlCmd"' +exit $1; +' > conftest +chmod u+x conftest +(SHELL=/bin/sh; export SHELL; ./conftest 69 > /dev/null) +if test $? -ne 69; then + echo "It does!" +else + echo "It doesn't! Perhaps \`#!$PerlCmd' is too long (often 32 characters max)" + exit 1 +fi +rm -f conftest +# +dnl ** check if perl library is properly installed +# (by seeing if a "do 'getopts.pl'" works... +if $PerlCmd -e 'do "getopts.pl" || exit(1); exit(0);' > /dev/null 2>&1 ; then + : +else + echo "I think your perl library is misinstalled." + echo "The following script did not work:" + echo ' do "getopts.pl" || exit(1); exit(0);' + exit 1 +fi + +dnl ** figure out how to do a BSD-ish install +# +AC_PROG_INSTALL +# + + +AC_OUTPUT(Makefile) + diff --git a/docs/Makefile b/docs/Makefile new file mode 100644 index 0000000000..851469d476 --- /dev/null +++ b/docs/Makefile @@ -0,0 +1,8 @@ +TOP = .. +include $(TOP)/mk/boilerplate.mk + +DOC_SRCS = installing.lit release.lit + +SRC_TEXI2HTML_OPTS += -number -monolithic -invisible xbm + +include $(TOP)/mk/target.mk diff --git a/docs/installing.lit b/docs/installing.lit new file mode 100644 index 0000000000..81bdeee2f0 --- /dev/null +++ b/docs/installing.lit @@ -0,0 +1,1730 @@ +% Building and installing the Glasgow Functional Programming Tools Suite +% +% Version 2.02 +% Feb 1997 + + + + +\begin{onlystandalone} +\documentstyle[11pt,literate]{article} +\begin{document} +\title{Building and installing the Glasgow Functional Programming Tools Suite\\ +Version~2.02} +\author{The GHC Team\\ +Department of Computing Science\\ +University of Glasgow\\ +Glasgow, Scotland\\ +G12 8QQ\\ +\\ +Email: glasgow-haskell-\{users,bugs\}\@dcs.gla.ac.uk} +\maketitle +\begin{rawlatex} +\tableofcontents +\end{rawlatex} +\clearpage +\end{onlystandalone} + +This guide is intended for people who want to install or modify +programs from the Glasgow @fptools@ suite (as distinct from those +who merely want to {\em run} them. + +The whole install-and-make system has been completely re-done +between GHC 2.01 and 2.02, so it will be worth your while to re-read this guide +even if you have done so before. + +\section{Getting the Glasgow @fptools@ suite} + +Building the Glasgow tools {\em can} be complicated, mostly because +there are so many permutations of what/why/how, e.g., ``Build Happy +with HBC, everything else with GHC, leave out profiling, and test it +all on the `real' NoFib programs.'' Yeeps! + +Happily, such complications don't apply to most people. A few common +``strategies'' serve most purposes. Pick one and proceed +as suggested: + +\begin{description} +\item[Binary distribution.] If your only purpose is to install +some of the @fptools@ suite then the easiest thing to do is to +get a binary distribution. In the binary distribution everything is +pre-compiled for your particular machine architecture and operating +system, so all you should have to do is install the binaries and libraries +in suitable places. {\em Need pointer to info about doing binary installation.} + +A binary distribution may not work for you for two reasons. +First, we may not have built the suite for the particular +architecture/OS platform you want. That may be due to lack of time and +energy (in which case you can get a source distribution and build from it; +see below). Alternatively, it may be because we havn't yet ported the +suite to your architecture, in which case you are considerably worse off. + +The second reason a binary distribution may not be what you want is +if you want to read or modify the souce code. + +\item[Source distribution.] +You have a supported +platform, but (a)~you like the warm fuzzy feeling of compiling things +yourself; (b)~you want to build something ``extra''---e.g., a set of +libraries with strictness-analysis turned off; or (c)~you want to hack +on GHC yourself. + +A source distribution contains complete sources for the @fptools@ suite. +Not only that, but the more awkward machine-independent steps are done +for you. For example, if you don't have @flex@ you'll it convenient that +the source distribution contains the result of running @flex@ on the +lexical analyser specification. If you don't want to alter the lexical +analyser then this saves you having to find and install @flex@. +You will still need a working version of GHC on your machine in order to +compile (most of) the sources, however. + + +\item[Build GHC from intermediate C \tr{.hc} files:] +You need a working GHC to use a source distribution. What if you don't have a working GHC? +Then you have no choice but to ``bootstrap'' up from the +intermediate C (\tr{.hc}) files that we provide. +Building GHC on an unsupported platform falls into this category. +Please see \sectionref{booting-from-C}. + +NB: For GHC~2.01, bootstrapping from \tr{.hc} files means you will get +an all-2.01 system---possibly unduly slow. Building with GHC~0.29 +will get you a faster compiler... + +Once you have built GHC, you can build the other Glasgow tools with +it. + +In theory, you can build GHC with another Haskell compiler (e.g., +HBC). We havn't tried to do this for ages and it almost certainly +doesn't work any more. + +\item[The CVS repository.] +We make source distributions at the same time as binary distributions; +i.e. infrequently. They should, however, be pretty throughly tested. +If you want more up-to-the minute (but less tested) source code then you +need to get access to our CVS repository. + +All the @fptools@ source code is held in a CVS repository. +CVS is a pretty good source-code control system, and best of all it works over the network. + +The repository holds source code only. It holds no mechanically generated +files at all. So if you check out a source tree from CVS you will need +to install every utility so that you can build all the derived files +from scratch. + +Giving you access to the repository entails some systems administration +at our end; and we are a bit nervous about being submerged in bug reports +about our current working copy (which is, by definition, in flux). So +we are a bit cautious about offering CVS access. Feel free to ask though! +\end{description} + +If you are going to do any building from sources (either from a source +distribution or the CVS repository) then you need to read all of this manual in detail. + + +%************************************************************************ +%* * +\section{Things to check before you start typing} +%* * +%************************************************************************ + +Here's a list of things to check before you get started. +\begin{enumerate} +\item +\index{disk space needed} +Disk space needed: About 30MB (five hamburgers' worth) of disk space +for the most basic binary distribution of GHC; more for some +platforms, e.g., Alphas. An extra ``bundle'' (e.g., concurrent +Haskell libraries) might take you to 8--10 hamburgers. + +You'll need over 100MB (say, 20 hamburgers' worth) if you need to +build the basic stuff from scratch. + +I don't yet know the disk requirements for the non-GHC tools. + +All of the above are {\em estimates} of disk-space needs. + +\item +Use an appropriate machine, compilers, and things. + +SPARC boxes and DEC Alphas running OSF/1 are fully supported. +Linux, MIPS, and HP boxes are in pretty good shape. +\Sectionref{port-info} gives the full run-down on ports or lack +thereof. + +\item +Be sure that the ``pre-supposed'' utilities are installed. +Section~\ref{sect_std-utils} elaborates. + +\item +If you have any problem when building or installing the Glasgow tools, +please check the ``known pitfalls'' (\sectionref{build-pitfalls}). If +you feel there is still some shortcoming in our procedure or +instructions, please report it. + +For GHC, please see the bug-reporting section of the User's guide +(separate document), to maximise the usefulness of your report. + +If in doubt, please send a message to +\tr{glasgow-haskell-bugs@dcs.gla.ac.uk}. +\end{enumerate} + + +%************************************************************************ +%* * +\section[port-info]{What machines the Glasgow tools, version~2.01, run on} +\index{ports, GHC} +\index{GHC ports} +\index{supported platforms} +\index{platforms, supported} +%* * +%************************************************************************ + +The main question is whether or not the Haskell compiler (GHC) runs on +your platform. + +A ``platform'' is a +architecture/manufacturer/operating-system combination, +such as @sparc-sun-solaris2.5.1@. Other common ones are +@alpha-dec-osf2@, @hppa1.1-hp-hpux9@, @i386-unknown-linux@, +@i386-unknown-solaris2@, @i386-unknown-freebsd@, +@m68k-sun-sunos4@, @mips-sgi-irix5@, +@sparc-sun-sunos4@, @sparc-sun-solaris2@. + +Bear in mind that certain ``bundles'', e.g. parallel Haskell, may not +work on all machines for which basic Haskell compiling is supported. + +Some libraries may only work on a limited number of platforms; for +example, a sockets library is of no use unless the operating system +supports the underlying BSDisms. + +%************************************************************************ +%* * +\subsection{What platforms the Haskell compiler (GHC) runs on} +%* * +%************************************************************************ +\index{fully-supported platforms} +\index{native-code generator} +\index{registerised ports} +\index{unregisterised ports} + +The GHC hierarchy of Porting Goodness: (a)~Best is a native-code +generator; (b)~next best is a ``registerised'' +port; (c)~the bare minimum is an ``unregisterised'' port. +``Unregisterised'' is so terrible that we won't say more about it. + +We use Sun4s running SunOS~4.1.3 and Solaris 2.5, and DEC~Alphas +running OSF/1~V2.0, so those are the ``fully-supported'' platforms, +unsurprisingly. Both have native-code generators, for quicker +compilations. The native-code generator for iX86 platforms (e.g., +Linux ELF) is {\em nearly} working; but is not turned on by default. + +Here's everything that's known about GHC ports, as of 2.01. We +identify platforms by their ``canonical GNU-style'' names. + +Note that some ports are fussy about which GCC version you use; or +require GAS; or ... + +\begin{description} +%------------------------------------------------------------------- +\item[\tr{alpha-dec-osf1}:] +\index{alpha-dec-osf1: fully supported} +(We have OSF/1 V2.0.) Fully supported, including native-code generator. +We recommend GCC 2.6.x or later. + +%------------------------------------------------------------------- +\item[\tr{sparc-sun-sunos4}:] +\index{sparc-sun-sunos4: fully supported} +Fully supported, including native-code generator. + +%------------------------------------------------------------------- +\item[\tr{sparc-sun-solaris2}:] +\index{sparc-sun-solaris2: fully supported} +Fully supported, including native-code generator. A couple of quirks, +though: (a)~the profiling libraries are bizarrely huge; (b)~the +default \tr{xargs} program is atrociously bad for building GHC +libraries (see \sectionref{Pre-supposed} for details). + +%------------------------------------------------------------------- +\item[HP-PA box running HP/UX 9.x:] +\index{hppa1.1-hp-hpux: registerised port} +Works registerised. No native-code generator. +For GCC, you're best off with one of the Utah releases of +GCC~2.6.3 (`u3' or later), from \tr{jaguar.cs.utah.edu}. +We think a straight GCC 2.7.x works, too. + +Concurrent/Parallel Haskell probably don't work (yet). +\index{hppa1.1-hp-hpux: concurrent---no} +\index{hppa1.1-hp-hpux: parallel---no} + +%------------------------------------------------------------------- +\item[\tr{i386-*-linux} (PCs running Linux---ELF format):] +\index{i386-*-linux: registerised port} +GHC~2.01 works registerised. +You {\em must} have GCC 2.7.x or later. +The iX86 native-code generator is {\em nearly} there, but it +isn't turned on by default. + +Profiling works, and Concurrent Haskell works. +\index{i386-*-linux: profiling---yes} +\index{i386-*-linux: concurrent---yes} +Parallel Haskell probably works. +\index{i386-*-linux: parallel---maybe} + +On old Linux a.out systems: should be the same. +\index{i386-*-linuxaout: registerised port} + +%------------------------------------------------------------------- +\item[\tr{i386-*-*bsd} (PCs running FreeBSD (and NetBSD?):] +\index{i386-*-freebsd: registerised port} +GHC~2.01 works registerised. Supports same set of bundles +as the above. + +\index{i386-*-freebsd: profiling---yes} +\index{i386-*-freebsd: concurrent---yes} +\index{i386-*-freebsd: parallel---maybe} + +%------------------------------------------------------------------- +\item[\tr{i386-unknown-cygwin32}:] +\index{i386-unknown-cygwin32: fully supported} +Fully supported under Win95/NT, including a native +code generator. Requires the @cygwin32@ compatibility library and +a healthy collection of GNU tools (i.e., gcc, GNU ld, bash etc.) +Profiling works, so does Concurrent Haskell. +\index{i386-*-cygwin32: profiling---yes} +\index{i386-*-cygwin32: concurrent---yes} + +% ToDo: more documentation on this is reqd here. + +%------------------------------------------------------------------- +\item[\tr{mips-sgi-irix5}:] +\index{mips-sgi-irix5: registerised port} +GHC~2.01 works registerised (no native-code generator). +I suspect any GCC~2.6.x (or later) is OK. The GCC that I used +was built with \tr{--with-gnu-as}; turns out that is important! + +Concurrent/Parallel Haskell probably don't work (yet). +Profiling might work, but it is untested. +\index{mips-sgi-irix5: concurrent---no} +\index{mips-sgi-irix5: parallel---no} +\index{mips-sgi-irix5: profiling---maybe} + +%------------------------------------------------------------------- +\item[\tr{m68k-apple-macos7} (Mac, using MPW):] +\index{m68k-apple-macos7: historically ported} +Once upon a time, David Wright in Tasmania has actually +gotten GHC to run on a Macintosh. Ditto James Thomson here at Glasgow. +You may be able to get Thomson's from here. (Not sure that it will +excite you to death, but...) + +No particularly recent GHC is known to work on a Mac. + +%------------------------------------------------------------------- +\item[\tr{m68k-next-nextstep3}:] +\index{m68k-next-nextstep3: historically ported} +Carsten Schultz succeeded with a ``registerised'' port of GHC~0.19. +There's probably a little bit-rot since then, but otherwise it should +still be fine. Had a report that things were basically OK at 0.22. + +Concurrent/Parallel Haskell probably won't work (yet). +\index{m68k-next-nextstep3: concurrent---no} +\index{m68k-next-nextstep3: parallel---no} + +%------------------------------------------------------------------- +\item[\tr{m68k-sun-sunos4} (Sun3):] +\index{m68k-sun-sunos4: registerised port} +GHC~2.01 hasn't been tried on a Sun3. GHC~0.26 worked registerised. +No native-code generator. + +Concurrent/Parallel Haskell probably don't work (yet). +\index{m68k-sun-sunos4: concurrent---no} +\index{m68k-sun-sunos4: parallel---no} +\end{description} + +%************************************************************************ +%* * +\subsection{What machines the other tools run on} +%* * +%************************************************************************ + +Unless you hear otherwise, the other tools work if GHC works. + +Haggis requires Concurrent Haskell to work. +\index{Haggis, Concurrent Haskell} + + +%************************************************************************ +%* * +\section[installing-bin-distrib]{Installing from binary distributions} +\index{binary installations} +\index{installation, of binaries} +%* * +%************************************************************************ + +Installing from binary distributions is easiest, and recommended! +(Why binaries? Because GHC is a Haskell compiler written in Haskell, +so you've got to ``bootstrap'' it, somehow. We provide +machine-generated C-files-from-Haskell for this purpose, but it's +really quite a pain to use them. If you must build GHC from its +sources, using a binary-distributed GHC to do so is a sensible way to +proceed. For the other @fptools@ programs, many are written in Haskell, +so binary distributions allow you to install them without having a Haskell compiler.) + + +\subsection{Bundle structure} + +Binary distributions come in ``bundles,''\index{bundles of binary stuff} +one bundle per file called \tr{-.tar.gz}. +(See Section~\ref{port-info} for what a platform is.) +Suppose that you untar a binary-distribution bundle, thus: +\begin{verbatim} + % cd /your/scratch/space + % gunzip < ghc-2.02-sun-sparc-solaris2.tar.gz | tar xvf - +\end{verbatim} +Then you should find a single directory, @fptools@, with the following +structure: +\begin{description} +\item[@Makefile.in@] the raw material from which the @Makefile@ will be made (\sectionref{sect_install}). +\item[@configure@] the configuration script (\sectionref{sect_install}). +\item[@README@] Contains this file summary. +\item[@INSTALL@] Contains this description of how to install the bundle. +\item[@ANNOUNCE-@] The announcement message for the bundle. +\item[@NEWS-@] release notes for the bundle -- a longer version of @ANNOUNCE@. +\item[@bin//@] contains platform-specific executable files to be invoked +directly by the user. These are the files that must end up in your path. +\item[@lib/@] contains platform-specific support files for the installation. +Typically there is a subdirectory for each @fptools@ project, whose name is +the name of the project with its version number. +For example, for GHC 2.02 there would be a sub-directory @ghc-2.02/@. + +These sub-directories have the following general structure: +\begin{description} +\item[@libHS.a@ etc:] supporting library archives. +\item[@ghc-iface.prl@ etc:] support scripts. +\item[@import/@] Interface files (@.hi@) for the prelude. +\item[@include/@] A few C @#include@ files. +\end{description} + +\item[@share/@] contains platform-independent support files for the installation. +Again, there is a sub-directory for each @fptools@ project. + +\item[@info/@] contains Emacs info documentation files (one sub-directory per project). +\item[@html/@] contains HTML documentation files (one sub-directory per project). +\item[@man/@] contains Unix manual pages. +\end{description} +This structure is designed so that you can unpack multiple bundles (including +ones from different releases or platforms) into a single @fptools@ directory: +\begin{verbatim} + % cd /your/scratch/space + % gunzip < ghc-2.02-sun-sparc-solaris2.tar.gz | tar xvf - + % gunzip < happy-1.09-sun-sparc-sunos4.tar.gz | tar xvf - +\end{verbatim} +When you do multiple unpacks like this, the top level @Makefile@, @README@, +and @INSTALL@ get overwritten each time. That's fine -- they should be the same. +Likewise, the @ANNOUNCE-@ and @NEWS-@ files will be duplicated +across multiple platforms, so they will be harmlessly overwritten when you do +multiple unpacks. +Finally, the @share/@ stuff will get harmlessly overwritten when you do multiple +unpacks for one bundle on different platforms. + +\subsection[sect_install]{Installing} + +OK, so let's assume that you have unpacked your chosen bundles into +a scratch directory @fptools@. What next? Well, you will at least need +to run the @configure@ script by changing your directory to @fptools@. +That should convert @Makefile.in@ to @Makefile@. + +You can now either start using the tools {\em in-situ} without going +through any installation process, just type @make config@ to set the +tools up for this (you have to be in the @fptools@ directory). You'll +also want to add the path which @make@ echoes to your @PATH@ +environment variable. This option is useful if you simply want to try +out the package or you don't have the necessary priviledges (or +inclination) to properly install the tools locally. Note that if you +do decide to install the package `properly' at a later date, you have +to go through the installation steps that +follows. + +To install an @fptools@ package, you'll have to do the following: + +\begin{enumerate} +\item Edit the @Makefile@ and check the settings of the following variables: +\begin{description} +\item[@platform@] the platform you are going to install for. +\item[@bindir@] the directory in which to install user-invokable binaries. +\item[@libdir@] the directory in which to install platform-dependent support files. +\item[@datadir@] the directory in which to install platform-independent support files. +\item[@infodir@] the directory in which to install Emacs info files. +\item[@htmldir@] the directory in which to install HTML documentation. +\item[@dvidir@] the directory in which to install DVI documentation. +\end{description} +The values for these variables can be set through invocation of the +@configure@ script that comes with the distribution, but doing an optical +diff to see if the values match your expectations is always a Good Idea. + +{\em Instead of running @configure@, it is perfectly OK to copy +@Makefile.in@ to @Makefile@ and set all these variables directly +yourself. But do it right!} + +\item Run @make install@. This {\em should} works with ordinary Unix +@make@ -- no need for fancy stuff like GNU @make@. + +\item \tr{rehash} (t?csh users), so your shell will see the new stuff +in your bin directory. + +\item +Once done, test your ``installation'' as suggested in +\sectionref{GHC_test}. Be sure to use a \tr{-v} option, so you +can see exactly what pathnames it's using. + +If things don't work as expected, check the list of know pitfalls +\sectionref{build-pitfalls}. +\end{enumerate} + +When installing the user-invokable binaries, this installation +procedure will install, say, @GHC@ version 2.02 as @ghc-2.02@. It +will also make a link (in the binary installation directory) from +@ghc@ to @ghc-2.02@. If you install multiple versions of GHC then the +last one ``wins'', and ``@ghc@'' will invoke the last one installed. +You can change this manually if you want. But regardless, @ghc-2.02@ +should always invoke @GHC@ version 2.02. + +\subsection{What bundles there are} + +There are plenty of ``non-basic'' GHC bundles. The files for them are +called \tr{ghc-2.01--.tar.gz}, where the +\tr{} is as above, and \tr{} is one of these: +\begin{description} +\item[\tr{prof}:] Profiling with cost-centres. You probably want this. + +\item[\tr{conc}:] Concurrent Haskell features. You may want this. + +\item[\tr{par}:] Parallel Haskell features (sits on top of PVM). +You'll want this if you're into that kind of thing. + +\item[\tr{gran}:] The ``GranSim'' parallel-Haskell simulator +(hmm... mainly for implementors). + +\item[\tr{ticky}:] ``Ticky-ticky'' profiling; very detailed +information about ``what happened when I ran this program''---really +for implementors. + +\item[\tr{prof-conc}:] Cost-centre profiling for Concurrent Haskell. + +\item[\tr{prof-ticky}:] Ticky-ticky profiling for Concurrent Haskell. +\end{description} + +One likely scenario is that you will grab {\em three} binary +bundles---basic, profiling, and concurrent. + + + +%************************************************************************ +%* * +\subsection[GHC_test]{Test that GHC seems to be working} +\index{testing a new GHC} +%* * +%************************************************************************ + +The way to do this is, of course, to compile and run {\em this} program +(in a file \tr{Main.hs}): +\begin{verbatim} +main = putStr "Hello, world!\n" +\end{verbatim} + +First, give yourself a convenient way to execute the driver script +\tr{ghc/driver/ghc}, perhaps something like... +\begin{verbatim} +% ln -s /local/src/ghc-2.01/ghc/driver/ghc ~/bin/alpha/ghc +% rehash +\end{verbatim} + +Compile the program, using the \tr{-v} (verbose) flag to verify that +libraries, etc., are being found properly: +\begin{verbatim} +% ghc -v -o hello Main.hs +\end{verbatim} + +Now run it: +\begin{verbatim} +% ./hello +Hello, world! +\end{verbatim} + +Some simple-but-profitable tests are to compile and run the +notorious \tr{nfib} program, using different numeric types. Start +with \tr{nfib :: Int -> Int}, and then try \tr{Integer}, \tr{Float}, +\tr{Double}, \tr{Rational} and maybe \tr{Complex Float}. Code +for this is distributed in \tr{ghc/misc/examples/nfib/}. + +For more information on how to ``drive'' GHC, +either do \tr{ghc -help} or consult the User's Guide (distributed in +\tr{ghc/docs/users_guide}). + + +%************************************************************************ +%* * +\section[Pre-supposed]{Installing pre-supposed utilities} +\index{pre-supposed utilities} +\index{utilities, pre-supposed} +%* * +%************************************************************************ + +\label{sect_std-utils} + +Here are the gory details about some utility programs you may need; +\tr{perl} and \tr{gcc} are the only important ones. (PVM is important +if you're going for Parallel Haskell.) The \tr{configure} script will +tell you if you are missing something. + +\begin{description} +\item[Perl:] +\index{pre-supposed: Perl} +\index{Perl, pre-supposed} +{\em You have to have Perl to proceed!} Perl is a language quite good +for doing shell-scripty tasks that involve lots of text processing. +It is pretty easy to install. + +(Perl~5 is the current version; GHC might be Perl~4 friendly, we've +run into some trouble with our scripts on \tr{alpha-dec-osf\{1,2\}} +using Perl~4 (patchlevel 36)) + +Perl should be put somewhere so that it can be invoked by the \tr{#!} +script-invoking mechanism. (I believe \tr{/usr/bin/perl} is preferred; +we use \tr{/usr/local/bin/perl} at Glasgow.) The full pathname should +be less than 32 characters long. + +\item[GNU C (\tr{gcc}):] +\index{pre-supposed: GCC (GNU C compiler)} +\index{GCC (GNU C compiler), pre-supposed} +The current version is 2.7.2. It has a bug that it ticked if you +compile the @gmp@ library without the @-O@ flag. So the Makefile in +there has the @-O@ flag switched on! Otherwise, 2.7.2 has no problems that we know of. + +If your GCC dies with ``internal error'' on some GHC source file, +please let us know, so we can report it and get things improved. +(Exception: on \tr{iX86} boxes---you may need to fiddle with GHC's +\tr{-monly-N-regs} option; ask if confused...) + +\item[PVM version 3:] +\index{pre-supposed: PVM3 (Parallel Virtual Machine)} +\index{PVM3 (Parallel Virtual Machine), pre-supposed} +PVM is the Parallel Virtual Machine on which Parallel Haskell programs +run. (You only need this if you plan to run Parallel Haskell. +Concurent Haskell, which runs concurrent threads on a uniprocessor) +doesn't need it.) +Underneath PVM, you can have (for example) a network of +workstations (slow) or a multiprocessor box (faster). + +The current version of PVM is 3.3.11; we use 3.3.7. It is readily available on +the net; I think I got it from \tr{research.att.com}, in \tr{netlib}. + +A PVM installation is slightly quirky, but easy to do. Just follow +the \tr{Readme} instructions. + +\item[\tr{xargs} on Solaris2:] +\index{xargs, presupposed (Solaris only)} +\index{Solaris: alternative xargs} +The GHC libraries are put together with something like: +\begin{verbatim} +find bunch-of-dirs -name '*.o' -print | xargs ar q ... +\end{verbatim} +Unfortunately the Solaris \tr{xargs} (the shell-script equivalent +of \tr{map}) only ``bites off'' the \tr{.o} files a few at a +time---with near-infinite rebuilding of the symbol table in +the \tr{.a} file. + +The best solution is to install a sane \tr{xargs} from the GNU +findutils distribution. You can unpack, build, and install the GNU +version in the time the Solaris \tr{xargs} mangles just one GHC +library. + +\item[\tr{bash} (Parallel Haskell only):] +\index{bash, presupposed (Parallel Haskell only)} +Sadly, the \tr{gr2ps} script, used to convert ``parallelism profiles'' +to PostScript, is written in Bash (GNU's Bourne Again shell). +This bug will be fixed (someday). + +\item[Makeindex:] +\index{pre-supposed: makeindex} +\index{makeindex, pre-supposed} +You won't need this unless you are re-making our documents. Makeindex +normally comes with a \TeX{} distribution, but if not, we can provide +the latest and greatest. + +\item[Tgrind:] +\index{pre-supposed: tgrind} +\index{tgrind, pre-supposed} +This is required only if you remake lots of our documents {\em and} +you use the \tr{-t tgrind} option with \tr{lit2latex} (also literate +programming), to do ``fancy'' typesetting of your code. {\em +Unlikely.} + +\item[Flex:] +\index{pre-supposed: flex} +\index{flex, pre-supposed} +This is a quite-a-bit-better-than-Lex lexer. Used in the +literate-programming stuff. You won't need it unless you're hacking +on some of our more obscure stuff. + +\item[Yacc:] +\index{pre-supposed: non-worthless Yacc} +\index{Yacc, pre-supposed} +If you mess with the Haskell parser, you'll need a Yacc that can cope. +The unbundled \tr{/usr/lang/yacc} is OK; the GNU \tr{bison} is OK; +Berkeley yacc, \tr{byacc}, is not OK. + +\item[@sed@] +\index{pre-supposed: sed} +\index{sed, pre-supposed} +You need a working @sed@ if you are going to build from sources. +The build-configuration stuff needs it. +GNU sed version 2.0.4 is no good! It has a bug in it that is tickled by the +build-configuration. 2.0.5 is ok. Others are probably ok too +(assuming we don't create too elaborate configure scripts..) +\end{description} + +Two @fptools@ projects are worth a quick note at this point, because +they are useful for all the others: +\begin{itemize} +\item @glafp-utils@ contains several small utilities +which aren't particularly Glasgow-ish, but which are sometimes not +available on Unix systems. + +\item @literate@ contains the Glasgow-built tools for generating +documentation. (The unoriginal idea is to be able to generate @latex@, @info@, +and program code from a single source file.) To get anywhere you'll +need at least @lit2pgm@, either from the @literate@ project, or +because it's already installed on your system. +\end{itemize} + + + + +%************************************************************************ +%* * +\section{Building from source} +%* * +%************************************************************************ + +You've been rash enough to want to build some of +the Glasgow Functional Programming tools (GHC, Happy, +nofib, etc) from source. You've slurped the source, +from the CVS repository or from a source distribution, and +now you're sitting looking at a huge mound of bits, wondering +what to do next. + +Gingerly, you type @make all@. Wrong already! + +This rest of this guide is intended for duffers like me, who aren't really +interested in Makefiles and systems configurations, but who need +a mental model of the interlocking pieces so that they can +make them work, extend them consistently when adding new +software, and lay hands on them gently when they don't work. + +\subsection{Your source tree} + +The source code is held in your {\em source tree}. +The root directory of your source tree {\em must} +contain the following directories and files: +\begin{itemize} +\item @Makefile@: the root Makefile. +\item @mk/@: the directory that contains the +main Makefile code, shared by all the +@fptools@ software. +\item @configure.in@: a file that tells the GNU configuration +tools what @fptools@ needs to know about the host platform and +operating system. +\end{itemize} +All the other directories are individual {\em projects} of the +@fptools@ system --- for example, the Glasgow Haskell Compiler (@ghc@), +the Happy parser generator (@happy@), the @nofib@ benchmark stuite, +and so on. +You can have zero or more of these. Needless to say, some of them +are needed to build others. For example, you need @happy@ to build +@ghc@. You can either grab @happy@ too, or else you can use +an version of @happy@ that's already installed on your system, or +grab a binary distribution of @happy@ and install it. + +The important thing to remember is that even if you want only +one project (@happy@, say), you must have a source tree +whose root directory contains @Makefile@, +@mk/@, @configure.in@, and the project(s) you +want (@happy/@ in this case). You cannot get by with +just the @happy/@ directory. + +\subsection{Build trees} + +While you can build a system in the source tree, we don't recommend it. +We often want to build multiple versions of our software +for different architectures, or with different options (e.g. profiling). +It's very desirable to share a single copy of the source code among +all these builds. + +So for every source tree we have zero or more {\em build trees}. +Each build tree is initially an exact copy of the source tree, +except that each file is a symbolic link to the source file, +rather than being a copy of the source file. There are ``standard'' +Unix utilities that make such copies, so standard that they go by +different names: @lndir@, @mkshadowdir@ are two. + +The build +tree does not need to be anywhere near the source tree in the +file system. +Indeed, one advantage of separating the build tree from the source +is that the build tree can be placed in a non-backed-up partition, +saving your systems support people from backing up untold megabytes +of easily-regenerated, and rapidly-changing, gubbins. The golden rule is +that (with a single exception -- Section~\ref{sect_build-config}) +{\em absolutely +everything in the build tree is either a symbolic link to the source +tree, or else is mechanically generated}. It should be perfectly +OK for your build tree to vanish overnight; an hour or two compiling +and you're on the road again. + +You need to be a bit careful, though, that any new files you create +(if you do any development work) are in the source tree, not a build tree! + +Like the source tree, the top level of your build tree must (a linked copy of) +the root directory of the @fptools@ suite. +Inside Makefiles, the root of your build tree is called @$(FPTOOLS_TOP)@. +In the rest of this document path names are relative to @$(FPTOOLS_TOP)@ +unless otherwise stated. For example, the file @ghc/mk/target.mk@ is +actually @$(FPTOOLS_TOP)/ghc/mk/target.mk@. + + +\subsection{Getting the build you want} +\label{sect_build-config} + +When you build @fptools@ you will be compiling code +on a particular {\em host platform}, +to run on a particular {\em target platform} (usually the same +as the host platform)\index{platform}. The difficulty is +that there are minor differences between different platforms; +minor, but enough that the code needs to be a bit different +for each. There are some big differences too: for +a different architecture we need to build GHC with a different +native-code generator. + +There are also knobs you can turn to control how the @fptools@ +software is built. For example, you might want to build GHC +optimised (so that it runs fast) or unoptimised (so that you can +compile it fast after you've modified it. +Or, you might want to compile it with debugging on (so that +extra consistency-checking code gets included) or off. And so on. + +All of this stuff is called the {\em configuration} of your build. +You set the configuration using an exciting two-step process. +\begin{description} +\item[Step 1: system configuration.] This is easy, provided you +have the programs mentioned in Section~\ref{sect_std-utils}. Just +@cd@ to @$(FPTOOLS)@ and say @gmake configure@. This +command does three things: +\begin{itemize} +\item +It runs a GNU program called @autoconf@, which +converts @$(FPTOOLS)/configure.in@ to a shell script +called @$(FPTOOLS)/configure@. + +This step is completely platform-independent; it just means +that the human-written file (@configure.in@) can be short, although +the resulting shell script, @configure@ is long. + +\item It runs a second GNU program called @autoheader@, which converts +@$(FPTOOLS)/configure.in@ to @$(FPTOOLS)/mk/config.h.in@. +Again, this step is platform-independent. + +\item It then runs the newly-created @configure@ script. @configure@'s mission +is to scurry round your computer working out what architecture it has, +what operating system, whether it has the @vfork@ system call, +where @yacc@ is kept, whether @gcc@ is available, where various +obscure @#include@ files are, whether it's a leap year, and +what the systems manager had for lunch. +It communicates these snippets of information in two ways: +\begin{itemize} +\item It translates @mk/config.mk.in@ to @mk/config.mk@, +substituting for things between ``{\tt @@@@}'' brackets. So, +``{\tt @@HaveGcc@@}'' will be replaced by ``@YES@'' or ``@NO@'' +depending on what @configure@ finds. +@mk/config.mk@ is included by every Makefile (directly or indirectly), +so the configuration information is thereby communicated to +all Makefiles. + +\item It translates @mk/config.h.in@ to @mk/config.h@. +The latter is @#include@d by various C programs, which +can thereby make use of configuration information. +\end{itemize} +\end{itemize} + + +\item[Step 2: build configuration.] Next, you say how this build +of @fptools@ is to differ from the standard defaults by creating a new +file @mk/build.mk@ +{\em in the build tree}. This file is the one and only +file you edit in the build tree, precisely because it says how +this build differs from the source. (Just in case your build tree +does die, you might want to keep a private directory of @build.mk@ files, +and use a symbolic link in each build tree to point to the appropriate one.) +So @mk/build.mk@ never +exists in the source tree --- you create one in each build tree +from the template. We'll discuss what to put in it shortly. +\end{description} +And that's it for configuration. Simple, eh? + +What do you put in your build-specific configuration +file @mk/build.mk@? {\em For almost all purposes all you will do is +put make variable definitions that override those in @mk/config.mk.in@}. +The whole point of @mk/config.mk.in@ --- and its derived +counterpart @mk/config.mk@ --- is to define the build configuration. It is heavily +commented, as you will see if you look at it. +So generally, what you do is edit @mk/config.mk.in@ (read-only), and add definitions +in @mk/build.mk@ that override any of the @config.mk@ definitions that you +want to change. (The override occurs because the main boilerplate file, +@mk/boilerplate.mk@, includes @build.mk@ after @config.mk@.) + +For example, @config.mk.in@ contains the definition: +\begin{verbatim} + SUBDIRS = glafp-utils literate ghc +\end{verbatim} +The accompanying comment explains that this is the list of enabled +projects; that is, if (after configuring) you type @gmake all@ +in @FPTOOLS_TOP@ three specified projects will be made. +If you want to add @happy@, you can add this line to @build.mk@: +\begin{verbatim} + SUBDIRS += happy +\end{verbatim} +or, if you prefer, +\begin{verbatim} + SUBDIRS = glafp-utils literate ghc happy +\end{verbatim} +(GNU @make@ allows existing definitions to have new text appended using +the ``@+=@'' operator, which is quite a convenient feature.) + +When reading @config.mk.in@, remember that anything between ``{\tt @@...@@}'' signs +is going to be substituted by @configure@ later. You {\em can} override +the resulting definition if you want, +but you need to be a bit surer what you are doing. +For example, there's a line that says: +\begin{verbatim} + YACC = @Yacc@ +\end{verbatim} +This defines the Make variables @YACC@ to the pathname for a Yacc that +@configure@ finds somewhere. If you have your own pet Yacc you want +to use instead, that's fine. Just add this line to @mk/build.mk@: +\begin{verbatim} + YACC = myyacc +\end{verbatim} +You do not {\em have} to have a @mk/build.mk@ file at all; if you don't, +you'll get all the default settings from @mk/config.mk.in@. + + +\subsection{The story so far} + +Let's summarise the steps you need to carry to get yourself +a fully-configured build tree from scratch. + +\begin{enumerate} +\item Get your source tree from somewhere (CVS repository or +source distribution). Say you call the root directory +@myfptools@ (it does not have to be called @fptools@). + +\item Use @lndir@ or @mkshadowdir@ to create a build tree. +\begin{verbatim} + cd myfptools + mkshadowdir . /scratch/joe-bloggs/myfptools-sun4 +\end{verbatim} +You probably want to give the build tree a name that +suggests its main defining characteristic (in your mind at least), +in case you later add others. + +\item Change directory to the build tree. Everything is going +to happen there now. +\begin{verbatim} + cd /scratch/joe-bloggs/myfptools-sun4 +\end{verbatim} +\item Do system configuration: +\begin{verbatim} + gmake configure +\end{verbatim} +\item Create the file @mk/build.mk@, +adding definitions for your desired configuration options. +\begin{verbatim} + emacs mk/build.mk +\end{verbatim} +\end{enumerate} +You can make subsequent changes to @mk/build.mk@ as often +as you like. You do not have to run any further configuration +programs to make these changes take effect. +In theory you should, however, say @gmake clean@, @gmake all@, +because configuration option changes could affect anything --- but in practice you are likely to know what's affected. + +\subsection{Making things} + +At this point you have made yourself a fully-configured build tree, +so you are ready to start building real things. + +The first thing you need to know is that +{\em you must use GNU @make@, usually called @gmake@, not standard Unix @make@}. +If you use standard Unix @make@ you will get all sorts of error messages +(but no damage) because the @fptools@ @Makefiles@ use GNU @make@'s facilities +extensively. + +\subsection[sect_standard-targets]{Standard targets} + +In any directory you should be able to make the following: +\begin{description} +\item[@boot@:] does the one-off preparation required to get ready +for the real work. Notably, it does @gmake depend@ in all directories +that contain programs. But @boot@ does more. For example, you can't +do @gmake depend@ in a directory of C program until you have converted +the literate @.lh@ header files into standard @.h@ header files. Similarly, you convert a literate file to illiterate +form until you have built the @literate@ tools. @boot@ takes care of these +inter-directory dependencies. + +You should say @gmake boot@ right after configuring your build tree. + +\item[@all@:] makes all the final target(s) for this Makefile. +Depending on which directory you are in a ``final target'' +may be an executable program, a library archive, a shell script, +or a Postscript file. +Typing @gmake@ alone is generally the same as typing @gmake all@. + +\item[@install@:] installs the things built by @all@. Where does it +install them? That is specified by @mk/config.mk.in@; you can +override it in @mk/build.mk@. + +\item[@uninstall@:] reverses the effect of @install@. + +\item[@clean@:] remove all easily-rebuilt files. + +\item[@veryclean@:] remove all files that can be rebuilt at all. +There's a danger here that you may remove a file that needs a more +obscure +utility to rebuild it (especially if you started from a source +distribution). + +\item[@check@:] run the test suite. +\end{description} +All of these standard targets +automatically recurse into sub-directories. +Certain other standard targets do not: +\begin{description} +\item[@configure@:] is only available in the root directory @$(FPTOOLS)@; +it has been discussed in Section~\ref{sect_build-config}. + +\item[@depend@:] make a @.depend@ file in each directory that needs +it. This @.depend@ file contains mechanically-generated dependency +information; for example, suppose a directory contains a Haskell +source module @Foo.lhs@ which imports another module @Baz@. +Then the generated @.depend@ file will contain the dependency: +\begin{verbatim} + Foo.o : Baz.hi +\end{verbatim} +which says that the object file @Foo.o@ depends on the interface +file @Baz.hi@ generated by compiling module @Baz@. +The @.depend@ file is automatically included by every Makefile. + +\item[@binary-dist@:] make a binary distribution. + +\item[@dist@:] make a source distribution. +\end{description} + +\subsection{Other targets} + +Most @Makefiles@ have targets other than these. You can find +this out by looking in the @Makefile@ itself. + + + + +%************************************************************************ +%* * +\section{The @Makefile@ architecture} +%* * +%************************************************************************ + + +@make@ is great if everything works --- you type @gmake install@ and, lo, +the right things get compiled and installed in the right places. +Our goal is to make this happen often, but somehow it often doesn't; +instead +some wierd error message eventually emerges from the bowels of a directory +you didn't know existed. + +The purpose of this section is to give you a road-map to help you figure +out what is going right and what is going wrong. + +\subsection{A small project} + +To get started, let us look at the @Makefile@ for an imaginary small +@fptools@ project, @small@. Each project in @fptools@ has its own +directory in @FPTOOLS_TOP@, so the @small@ project will have its own +directory @FPOOLS_TOP/small/@. Inside the @small/@ directory there +will be a @Makefile@, looking something like this: +\begin{verbatim} + # Makefile for fptools project "small" + + TOP = .. + include $(TOP)/mk/boilerplate.mk + + SRCS = $(wildcard *.lhs) $(wildcard *.c) + HS_PROG = small + + include $(TOP)/target.mk +\end{verbatim} +This @Makefile@ has three sections: +\begin{enumerate} +\item The first section includes\footnote{One of the +most important features of GNU @make@ that we use is the ability +for a @Makefile@ to include another named file, very like @cpp@'s @#include@ directive.} +a file of ``boilerplate'' code from the +level above (which in this case will be @FPTOOLS_TOP/mk/boilerplate.mk@). +As its name suggests, @boilerplate.mk@ consists of a large quantity of standard +@Makefile@ code. We discuss this boilerplate in more detail in Section~\ref{sect_boiler}. + +Before the @include@ statement, you must define the @make@ variable +@TOP@ to be the directory containing the @mk@ directory in which +the @boilerplate.mk@ file is. +It is {\em not} OK to simply say +\begin{verbatim} + include ../mk/boilerplate.mk # NO NO NO +\end{verbatim} +Why? Because the @boilerplate.mk@ file needs to know where it is, +so that it can, in turn, @include@ other files. +(Unfortunately, when an @include@d file does an +@include@, the filename is treated +relative to the directory in which @gmake@ is being run, not +the directory in which the @included@ sits.) +In general, +{\em every file @foo.mk@ +assumes that @$(TOP)/mk/foo.mk@ refers to itself.} +It is up to the @Makefile@ doing the @include@ to ensure this +is the case. + +Files intended for inclusion in other @Makefile@s are written to have +the following property: +{\em after @foo.mk@ is @include@d, it leaves @TOP@ containing the same +value as it had just before the @include@ statement}. +In our example, this invariant guarantees that the @include@ +for @target.mk@ will look in the same directory as that for +@boilerplate.mk@. + +\item The second section +defines the following standard @make@ variables: @SRCS@ (the source files from +which is to be built), and @HS_PROG@ (the +executable binary to be built). +We will discuss in more detail what the ``standard variables'' are, +and how they affect what happens, in Section~\ref{sect_targets}. + +The definition for @SRCS@ uses the useful GNU @make@ +construct @$(wildcard@~$pat$@)@, which expands to a list of all the +files matching the pattern $pat$ in the current directory. +In this example, @SRCS@ is set to the list of all the @.lhs@ and @.c@ files +in the directory. (Let's suppose there is one of each, @Foo.lhs@ +and @Baz.c@.) + +\item The last section includes a second file of standard code, +called @target.mk@. It contains the rules that tell @gmake@ +how to make the standard targets +(Section~\ref{sect_standard-targets}). +Why, you ask, can't this standard code +be part of @boilerplate.mk@? Good question. +We discuss the reason later, in Section~\ref{sect_boiler-arch}. + +You do not {\em have} to @include@ the @target.mk@ file. Instead, +you can write rules of your own for all the standard targets. +Usually, though, you will find quite a big payoff from using +the canned rules in +@target.mk@; the price tag is that you have to understand +what canned rules get enabled, and what they do (Section~\ref{sect_targets}). +\end{enumerate} + +In our example @Makefile@, most of the work is done +by the two @include@d files. When you say @gmake all@, +the following things happen: +\begin{itemize} +\item @gmake@ figures out that the object files are @Foo.o@ and @Baz.o@. +\item It uses a boilerplate pattern rule to compile +@Foo.lhs@ to @Foo.o@ using +a Haskell compiler. (Which one? That is set in the build configuration.) +\item It uses another standard pattern rule to compile @Baz.c@ to @Baz.o@, +using a C compiler. (Ditto.) +\item It links the resulting @.o@ files together to make @small@, +using the Haskell compiler to do the link step. (Why not use @ld@? Because +the Haskell compiler knows what standard librarise to link in. How did @gmake@ +know to use the Haskell compiler to do the link, rather than the C compiler? +Because we set the variable @HS_PROG@ rather than @C_PROG@.) +\end{itemize} +All @Makefile@s should follow the above three-section format. + +\subsection{A larger project} + +Larger projects are usually structured into a nummber of sub-directories, +each of which has its own @Makefile@. (In very large projects, this +sub-structure might be iterated recursively, though that is rare.) +To give you the idea, here's part of the directory structure for +the (rather large) @ghc@ project: +\begin{verbatim} + $(FPTOOLS_TOP)/ghc/ + Makefile + + mk/ + boilerplate.mk + rules.mk + + docs/ + Makefile + ...source files for documentation... + + driver/ + Makefile + ...source files for driver... + + compiler/ + Makefile + parser/...source files for parser... + renamer/...source files for renamer... + ...etc... +\end{verbatim} +The sub-directories @docs@, @driver@, @compiler@, and so on, each contains +a sub-component of @ghc@, and each has its own @Makefile@. +There must also be a @Makefile@ in @$(FPTOOLS_TOP)/ghc@. +It does most of its work by recursively invoking @gmake@ +on the @Makefile@s in the sub-directories. +We say that @ghc/Makefile@ is a {\em non-leaf @Makefile@}, +because it does little except organise its children, while the @Makefile@s +in the sub-directories are all {\em leaf @Makefile@s}. (In principle +the sub-directories might themselves contain a non-leaf @Makefile@ and +several sub-sub-directories, but that does not happen in @ghc@.) + +The @Makefile@ in @ghc/compiler@ is considered a leaf @Makefile@ even +though the @ghc/compiler@ has sub-directories, because these sub-directories +do not themselves have @Makefile@ in them. They are just used to structure +the collection of modules that make up @ghc@, but all are managed by the +single @Makefile@ in @ghc/compiler@. + +You will notice that @ghc/@ also contains a directory @ghc/mk/@. +It contains @ghc@-specific @Makefile@ boilerplate code. +More precisely: +\begin{itemize} +\item @ghc/mk/boilerplate.mk@ is included at the top of @ghc/Makefile@, +and of all the leaf @Makefile@s in the sub-directories. +It in turn @include@s the main boilerplate file @mk/boilerplate.mk@. + +\item @ghc/mk/target.mk@ is @include@d at the bottom of @ghc/Makefile@, +and of all the leaf @Makefiles@ in the sub-directories. +It in turn @include@s the file @mk/target.mk@. +\end{itemize} +So these two files are the place to look for @ghc@-wide customisation +of the standard boilerplate. + + + +\subsection{Boilerplate architecture} +\label{sect_boiler-arch} + +Every @Makefile@ includes a @boilerplate.mk@ file at the top, +and @target.mk@ file at the bottom. In this section we discuss +what is in these files, and why there have to be two of them. +In general: +\begin{itemize} +\item @boilerplate.mk@ consists of: +\begin{itemize} +\item {\em Definitions of millions of @make@ variables} that collectively +specify the build configuration. Examples: @HC_OPTS@, the options to +feed to the Haskell compiler; @NoFibSubDirs@, the sub-directories to +enable within the @nofib@ project; @GhcWithHc@, the name of the +Haskell compiler to use when compiling @GHC@ in the @ghc@ project. +\item {\em Standard pattern rules} that tell @gmake@ how to construct +one file from another. +\end{itemize} +@boilerplate.mk@ needs to be @include@d at the {\em top} of each +@Makefile@, so that the +user can replace the boilerplate definitions or pattern rules by simply +giving a new definition or pattern rule in the @Makefile@. @gmake@ simply +takes the last definition as the definitive one. + +Instead of {\em replacing} boilerplate definitions, it is also quite +common to {\em augment} them. For example, a @Makefile@ might say: +\begin{verbatim} + SRC_HC_OPTS += -O +\end{verbatim} +thereby adding ``@-O@'' to the end of @SRC_HC_OPTS@. + +\item @target.mk@ contains @make@ rules for the standard targets described +in Section~\ref{sect_standard-targets}. +These rules are selectively included, depending on the setting of +certain @make@ variables. These variables are usually set in the middle +section of the @Makefile@ between the two @include@s. + +@target.mk@ must be included at the end (rather than being part of @boilerplate.mk@) +for several tiresome reasons: +\begin{itemize} +\item @gmake@ commits target and dependency lists earlier than it should. +For example, @target.mk@ has a rule that looks like this: +\begin{verbatim} + $(HS_PROG) : $(OBJS) + $(HC) $(LD_OPTS) $< -o $@ +\end{verbatim} +If this rule was in @boilerplate.mk@ then @$(HS_PROG)@ and @$(OBJS)@ +would not have their final values at the moment @gmake@ encountered the +rule. Alas, @gmake@ takes a snapshot of their current values, and +wires that snapshot into the rule. +(In contrast, the commands executed when the rule ``fires'' are +only substituted at the moment of firing.) +So, the rule must follow the definitions given in the @Makefile@ itself. + +\item Unlike pattern rules, ordinary rules cannot be overriden or +replaced by subsequent rules for the same target (at least not without an +error message). Including ordinary rules in @boilerplate.mk@ would +prevent the user from writing rules for specific targets in specific cases. + +\item There are a couple of other reasons I've forgotten, but it doesn't +matter too much. +\end{itemize} +\end{itemize} + +\subsection{The main @mk/boilerplate.mk@ file} +\label{sect_boiler} + +If you look at @$(FPTOOLS_TOP)/mk/boilerplate.mk@ you will find that +it consists of the following sections, each held in a separate file: +\begin{description} +\item[@config.mk@] is the build configuration file we discussed at length +in Section~\ref{sect_build-config}. + +\item[@paths.mk@] defines @make@ variables for pathnames and file +lists. In particular, it gives definitions for: +\begin{description} +\item[@SRCS@:] all source files in the current directory. +\item[@HS_SRCS@:] all Haskell source files in the current directory. +It is derived from @$(SRCS)@, so if you override @SRCS@ with a new value +@HS_SRCS@ will follow suit. +\item[@C_SRCS@:] similarly for C source files. +\item[@HS_OBJS@:] the @.o@ files derived from @$(HS_SRCS)@. +\item[@C_OBJS@:] similarly for @$(C_SRCS)@. +\item[@OBJS@:] the concatenation of @$(HS_OBJS)@ and @$(C_OBJS)@. +\end{description} +Any or all of these definitions can easily be overriden by giving new +definitions in your @Makefile@. For example, +if there are things in the current directory that look like source files +but aren't, then you'll need to set @SRCS@ manually in your @Makefile@. +The other definitions will then work from this new definition. + +What, exactly, does @paths.mk@ consider a ``source file'' to be. +It's based the file's suffix (e.g. @.hs@, @.lhs@, @.c@, @.lc@, etc), +but this is the kind of detail that changes +more rapidly, so rather than enumerate the source suffices here the best thing +to do is to look in @paths.mk@. + +\item[@opts.mk@] defines @make@ variables for option strings to +pass to each program. For example, it defines @HC_OPTS@, the +option strings to pass to the Haskell compiler. See \sectionref{sect_suffix}. + +\item[@suffix.mk@] defines standard pattern rules -- see \sectionref{sect_suffix} +\end{description} +Any of the variables and pattern rules defined by the boilerplate file +can easily be overridden in any particular @Makefile@, because +the boilerplace @include@ comes first. Definitions after this +@include@ directive simply override the default ones in @boilerplate.mk@. + +\subsection[sect_suffix]{Pattern rules and options} + +The file @suffix.mk@ defines standard {\em pattern rules} that say how to build one kind +of file from another, for example, how to build a @.o@ file from a @.c@ file. +(GNU @make@'s {\em pattern rules} are more powerful and easier to use than +Unix @make@'s {\em suffix rules}.) + +Almost all the rules look something like this: +\begin{verbatim} +%.o : %.c + @$(RM) $@ + $(CC) $(CC_OPTS) -c $< -o $@ +\end{verbatim} +Here's how to understand the rule. It says that $something@.o@$ (say @Foo.o@) +can be built from $something@.c@$ (@Foo.c@), by invoking the C compiler +(path name held in @$(CC)@), passing to it the options @$(CC_OPTS)@ and the rule's +dependent +file of the rule @$<@ (@Foo.c@ in this case), and putting the result in +the rule's target @$@@@ (@Foo.o@ in this case). + +Every program is held in a @make@ variable defined in @mk/config.mk@ --- look in @mk/config.mk@ for +the complete list. One important one is the Haskell compiler, which is called @$(HC)@. + +Every programs options are are held in a @make@ variables called @_OPTS@. +the @_OPTS@ variables are defined in @mk/opts.mk@. Almost all of them are defined +like this: +\begin{verbatim} + CC_OPTS = $(SRC_CC_OPTS) $(WAY$(_way)_CC_OPTS) $($*_CC_OPTS) $(EXTRA_CC_OPTS) +\end{verbatim} +The four variables from which @CC_OPTS@ is built have the following meaning: +\begin{description} +\item[@SRC_CC_OPTS@:] options passed to all C compilations. +\item[@WAY__CC_OPTS@:] options passed to C compilations for way @@. For example, +@WAY_mp_CC_OPTS@ gives options to pass to the C compiler when compiling way @mp@. +The variable @WAY_CC_OPTS@ holds options to pass to the C compiler when compiling the standard way. +(Section~\ref{sect_ways} dicusses multi-way compilation.) +\item[@_CC_OPTS@:] options to pass to the C compiler that are specific to module @@. +For example, @SMap_CC_OPTS@ gives the specific options to pass to the C compiler when compiling +@SMap.c@. +\item[@EXTRA_CC_OPTS@:] extra options to pass to all C compilations. This is intended for command +line use, thus; +\begin{verbatim} + gmake libHS.a EXTRA_CC_OPTS="-v" +\end{verbatim} +\end{description} + + +\subsection{The main @mk/target.mk@ file} +\label{sect_targets} + +@target.mk@ contains canned rules for all the standard targets described in +Section~\ref{sect_standard-targets}. It is complicated by the fact +that you don't want all of these rules to be active in every @Makefile@. +Rather than have a plethora of tiny files which you can include selectively, +there is a single file, @target.mk@, which selectively includes rules +based on whether you have defined certain variables in your @Makefile@. +This section explains what rules you get, what variables control them, and +what the rules do. Hopefully, you will also get enough of an idea of what is supposed +to happen that you can read and understand any wierd special cases yourself. + +\begin{description} +\item{@HS_PROG@.} If @HS_PROG@ is defined, you get rules with the +following targets: +\begin{description} +\item[@HS_PROG@] itself. This rule links @$(OBJS)@ with the Haskell +runtime system to get an executable called @$(HS_PROG)@. +\item[@install@] installs @$(HS_PROG)@ in @$(bindir)@ with the execute bit set. +\end{description} + +\item[@C_PROG@] is similar to @HS_PROG@, except that the link step +links @$(C_OBJS)@ with the C runtime system. + +\item[@LIBRARY@] is similar to @HS_PROG@, except +that it links @$(LIB_OBJS)@ to make the library archive @$(LIBRARY)@, +and @install@ installs it in @$(libdir)@, with the execute bit not set. + +\item[@LIB_DATA@] ... +\item[@LIB_EXEC@] ... + +\item[@HS_SRCS@, @C_SRCS@.] If @HS_SRCS@ is defined and non-empty, a rule for +the target @depend@ is included, which generates dependency information for +Haskell programs. Similarly for @C_SRCS@. +\end{description} + +All of these rules are ``double-colon'' rules, thus +\begin{verbatim} + install :: $(HS_PROG) + ...how to install it... +\end{verbatim} +GNU @make@ treats double-colon rules as separate entities. If there +are several double-colon rules for the same target it takes each in turn +and fires it if its dependencies say to do so. This means that you can, +for example, define both @HS_PROG@ and @LIBRARY@, which will generate two +rules for @install@. When you type @gmake install@ both rules will be fired, +and both the program and the library will be installed, just as you wanted. + +\subsection{Recursion} +\label{sect_subdirs} + +In leaf @Makefiles@ the variable @SUBDIRS@ is undefined. In non-leaf +@Makefiles@, @SUBDIRS@ is set to the list of sub-directories that contain subordinate +@Makefile@s. {\em It is up to you to set @SUBDIRS@ in the @Makefile@.} +There is no automation here --- @SUBDIRS@ is too important automate. + +When @SUBDIRS@ is defined, @target.mk@ includes a rather neat rule for +the standard targets (Section~\ref{sect_standard-targets}) that +simply invokes @make@ recursively in each of the sub-directories. + +{\em These recursive invocations are guaranteed to occur in the order in +which the list of directories is specified in @SUBDIRS@.} This guarantee can +be important. For example, when you say @gmake boot@ it can be important +that the recursive invocation of @make boot@ is done in one sub-directory (the include +files, say) before another (the source files). +Generally, put the most independent sub-directory first, and the most dependent +last. + +\subsection{Way management} +\label{sect_ways} + +We sometimes want to build essentially the same system in several different +``ways''. For example, we want to build @ghc@'s @Prelude@ libraries with +and without profiling, with and without concurrency, and so on, so that +there is an appropriately-built library archive to link with when the user compiles +his program. +It would be possible to have a completely separate build tree for each such ``way'', +but it would be horribly bureaucratic, especially since often only parts of the +build tree need to be constructed in multiple ways. + +Instead, the @template.mk@ contains some clever magic to allow you to build +several versions of a system; and to control locally how many versions are built +and how they differ. This section explains the magic. + +The files for a particular way are distinguished by munging the suffix. +The ``normal way'' is always built, and its files have the standard suffices +@.o@, @.hi@, and so on. In addition, you can build one or more extra ways, +each distinguished by a {\em way tag}. The object files and interface files +for one of these extra ways are distinguished by their suffix. For example, +way @mp@ has files @.mp_o@ and @.mp_hi@. Library archives have their way +tag the other side of the dot, for boring reasons; thus, @libHS_mp.a@. + +A @make@ variable called @way@ holds the current way tag. {\em @way@ is only ever +set on the command line of a recursive invocation of @gmake@.} It is +never set inside a @Makefile@. So it is a global constant for any one invocation +of @gmake@. Two other @make@ variables, @way_@ and @_way@ are immediately derived +from @$(way)@ and never altered. If @way@ is not set, then neither are @way_@ +and @_way@, and the invocation of @make@ will build the ``normal way''. +If @way@ is set, then the other two variables are set in sympathy. +For example, if @$(way)@ is ``@mp@'', then @way_@ is set to ``@mp_@'' +and @_way@ is set to ``@_mp@''. These three variables are then used +when constructing file names. + +So how does @make@ ever get recursively invoked with @way@ set? There +are two ways in which this happens: +\begin{itemize} +\item For some (but not all) of the standard targets, when in a leaf sub-directory, +@make@ is recursively invoked for each way tag in @$(WAYS)@. You set @WAYS@ to +the list of way tags you want these targets built for. The mechanism here is +very much like the recursive invocation of @make@ in sub-directories +(Section~\ref{sect_subdirs}). + +It is up to you to set @WAYS@ in your @Makefile@; this is how you control +what ways will get built. +\item For a useful collection of targets (such as @libHS_mp.a@, @Foo.mp_o@) +there is a rule which recursively invokes @make@ to make the specified +target, setting the @way@ variable. So if you say @gmake Foo.mp_o@ +you should see a recursive invocation @gmake Foo.mp_o way=mp@, +and {\em in this recursive invocation the pattern rule for compiling a Haskell +file into a @.o@ file will match}. The key pattern rules (in @suffix.mk@) +look like this: +\begin{verbatim} + %.$(way_)o : %.lhs + $(HC) $(HC_OPTS) $< -o $@ +\end{verbatim} +Neat, eh? +\end{itemize} + + +\subsection{When the canned rule isn't right} + +Sometimes the canned rule just doesn't do the right thing. For example, in +the @nofib@ suite we want the link step to print out timing information. +The thing to do here is {\em not} to define @HS_PROG@ or @C_PROG@, and instead +define a special purpose rule in your own @Makefile@. +By using different variable names you will avoid the canned rules being included, +and conflicting with yours. + + +%************************************************************************ +%* * +\section[booting-from-C]{Booting/porting from C (\tr{.hc}) files} +\index{building GHC from .hc files} +\index{booting GHC from .hc files} +%* * +%************************************************************************ + +This section is for people trying to get GHC going by using the +supplied intermediate C (\tr{.hc}) files. This would probably be +because no binaries have been provided, or because the machine +is not ``fully supported.'' + +THIS SECTION HASN'T BEEN UPDATED YET. Please let us know if you want to use this +route. Unless someone does, this section may never get written, and the +.hc files distribution may not get built! + + +%************************************************************************ +%* * +\section[build-pitfalls]{Known pitfalls in building Glasgow Haskell} +\index{problems, building} +\index{pitfalls, in building} +\index{building pitfalls} +%* * +%************************************************************************ + +WARNINGS about pitfalls and known ``problems'': + +\begin{enumerate} +%------------------------------------------------------------------------ +\item +One difficulty that comes up from time to time is running out of space +in \tr{/tmp}. (It is impossible for the configuration stuff to +compensate for the vagaries of different sysadmin approaches re temp +space.) + +The quickest way around it is \tr{setenv TMPDIR /usr/tmp} or +even \tr{setenv TMPDIR .} (or the equivalent incantation with the +shell of your choice). + +The best way around it is to say +\begin{verbatim} + TMPDIR= +\end{verbatim} +in your @build.mk@ file. +Then GHC and the other @fptools@ programs will use the appropriate directory +in all cases. + +%------------------------------------------------------------------------ +\item +In compiling some support-code bits, e.g., in \tr{ghc/runtime/gmp} and +even in \tr{ghc/lib}, you may get a few C-compiler warnings. We think +these are OK. + +%------------------------------------------------------------------------ +\item +When compiling via C, you'll sometimes get ``warning: +assignment from incompatible pointer type'' out of GCC. Harmless. + +%------------------------------------------------------------------------ +\item +Similarly, \tr{ar}chiving warning messages like the following are not +a problem: +\begin{verbatim} +ar: filename GlaIOMonad__1_2s.o truncated to GlaIOMonad_ +ar: filename GlaIOMonad__2_2s.o truncated to GlaIOMonad_ +... +\end{verbatim} + +%------------------------------------------------------------------------ +\item +Also harmless are some specialisation messages that you may see when +compiling GHC; e.g.: +\begin{verbatim} +SPECIALISATION MESSAGES (Desirable): +*** INSTANCES +{-# SPECIALIZE instance Eq [Class] #-} +{-# SPECIALIZE instance Eq (Class, [Class]) #-} +{-# SPECIALIZE instance Outputable [ClassOp] #-} +{-# SPECIALIZE instance Outputable [Id] #-} +\end{verbatim} + +%------------------------------------------------------------------------ +\item +In compiling the compiler proper (in \tr{compiler/}), you {\em may} get an +``Out of heap space'' error message. These +can vary with the vagaries of different systems, it seems. The +solution is simple: (1)~add a suitable \tr{-H} flag to the @_HC_OPTS@ +@make@ variable in the appropriate @Makefile@; +(2)~try again: \tr{gmake}. +(Section~\ref{sect_suffix}.) + +Alternatively, just cut to the chase scene: +\begin{verbatim} +% cd ghc/compiler +% make EXTRA_HC_OPTS=-H32m # or some nice big number +\end{verbatim} + +%------------------------------------------------------------------------ +\item +Not too long into the build process, you may get a huge complaint +of the form: +\begin{verbatim} +Giant error 'do'ing getopts.pl: at ./lit2pgm.BOOT line 27. +\end{verbatim} +This indicates that your \tr{perl} was mis-installed; the binary is +unable to find the files for its ``built-in'' library. Speak to your +perl installer, then re-try. + +%------------------------------------------------------------------------ +\item +If you try to compile some Haskell, and you get errors from GCC +about lots of things from \tr{/usr/include/math.h}, then your GCC +was mis-installed. \tr{fixincludes} wasn't run when it should've +been. + +As \tr{fixincludes} is now automagically run as part of GCC +installation, this bug also suggests that you have an old GCC. + + +%------------------------------------------------------------------------ +\item +You {\em may} need to re-\tr{ranlib} your libraries (on Sun4s). +\begin{verbatim} +% cd $(libdir)/ghc-2.01/sparc-sun-sunos4 +% foreach i ( `find . -name '*.a' -print` ) # or other-shell equiv... +? ranlib $i +? # or, on some machines: ar s $i +? end +\end{verbatim} +We'd be interested to know if this is still necessary. + +%------------------------------------------------------------------------ +\item +If you end up making documents that involve (La)TeX and/or \tr{tib} +(Simon's favourite), the odds are that something about your/our setup +will reach out and bite you. Yes, please complain; meanwhile, +you can do \tr{make -n whatever.dvi} to see the intended commands, +then try to muddle through, doing them by hand. + +\end{enumerate} + + + +% ==================================================================== +Here follow pitfalls that apply to pre-2.02 releases. They should not +happen any more If they do crop up with 2.02 or later, please let us +know. + +\begin{enumerate} +%------------------------------------------------------------------------ +\item +When configuring the support code (mkworld, glafp-utils, etc.), you +will see mention of \tr{NO_SPECIFIC_PROJECT} and +\tr{NO_SPECIFIC_VERSION}. This is cool. + + +%------------------------------------------------------------------------ +\item +Sooner or later in your ``make-worlding'' life you will do and see +something like: +\begin{verbatim} +% make Makefile + rm -f Makefile.bak; mv Makefile Makefile.bak +../.././mkworld/jmake -P ghc -S std -I../.././mkworld -DTopDir=../../. -DTopDir=... +../.././mkworld/jrestoredeps +==== The new Makefile is for: ==== +make: Fatal error in reader: Makefile, line 850: Unexpected end of line seen +Current working directory /export/users/fp/grasp/ghc-0.26/ghc/runtimes/standard +*** Error code 1 +make: Fatal error: Command failed for target `Makefile' +\end{verbatim} + +Don't panic! It should restore your previous \tr{Makefile}, and +leave the junk one in \tr{Makefile.bad}. Snoop around at your leisure. + +% ------------------------------------------------------------------------ +\item +If you do corrupt a \tr{Makefile} totally, or you need to glue a new +directory into the directory structure (in \tr{newdir}---which must +have a \tr{Jmakefile}, even if empty), here's a neat trick: +\begin{verbatim} +# +# move to the directory just above the one where you want a Makefile... +cd .. +# +# make Makefiles, but lie about the directories below... +make Makefiles SUBDIRS=newdir +\end{verbatim} + +This will create a \tr{Makefile} {\em ex nihilo} in \tr{newdir}, and +it will be properly wired into the general make-world structure. + +% ------------------------------------------------------------------------ +\item +Don't configure/build/install using a variety of machines. A +mistake we've made is to do \tr{make Makefiles} on a Sun4, then try to +build GHC (\tr{make all}) on a Sun3. + +%------------------------------------------------------------------------ +%\item +%If you build an ``unregisterised'' build, you will get bazillions of +%warnings about `ANSI C forbids braced-groups within expressions'. +%Especially in \tr{ghc/lib}. These are OK. + +\end{enumerate} + + +\begin{onlystandalone} +\printindex +\end{document} +\end{onlystandalone} + diff --git a/ghc/CONTRIB/README b/ghc/CONTRIB/README deleted file mode 100644 index 79aca73692..0000000000 --- a/ghc/CONTRIB/README +++ /dev/null @@ -1,19 +0,0 @@ -This directory contains contributed software/bits related to the -Glasgow Haskell compiler. - -fptags Denis Howe - Bourne-shell script. - Create an emacs TAGS file for one or more functional programs. - -haskell-modes/ A collection of all known "Haskell modes" for GNU Emacs. - -haskel.gif Provided by Lennart Augustsson - -haskell_poem Speaks for itself. - -mira2hs Denis Howe - Bourne-shell script. - Convert Miranda code to Haskell, more-or-less. - -pphs Pretty-print Haskell code in LaTeX documents. Written by - Andrew Preece while a student at Glasgow. diff --git a/ghc/CONTRIB/fptags b/ghc/CONTRIB/fptags deleted file mode 100644 index be4b5a5c30..0000000000 --- a/ghc/CONTRIB/fptags +++ /dev/null @@ -1,53 +0,0 @@ -#!/bin/sh - -#fptags - Create an emacs tags file for functional programs - -#Please send me a copy of any modifications you make. -#Denis Howe -#0.00 20-Sep-1991 created -#0.01 09-Apr-1992 don't count ==, <=, >= as definition -#0.02 09-Feb-1994 fix bug in fix 0.01. Add /=. - -# partain: got it from wombat.doc.ic.ac.uk:pub - -#The algorithm for spotting identifiers is crude to the point of -#vulgarity. Any line containing an = is assumed to define an -#identifier. If there are no non-white characters before the = then -#the definition is assumed to start on the previous line. White -#characters are space, tab and > (for literate programs). The =s in -#the relations ==, <=, >= and /= are temporarily transformed while -#searching for =s. - -#The tags file is not in the format produced by ctags but rather, -#that produced by etags and used by GNU-Emacs's find-tag command. - -#Does not tag constructors in sum data types. - -#The tags file, TAGS, is created in the current directory. It -#contains an entry for each argument file. The entry begins with a -#line containing just ^L. The next line contains the filename, a -#comma and the number of following bytes before the next ^L or EOF. -#Subsequent lines should give the location within the argument file of -#identifier definitions. Each line contains a prefix of a line from -#the argument file, a ^?, the line number within the argument file, a -#comma and the position of the start of that line in the argument file -#(first character = 1). - -[ -z "$1" ] && echo usage: $0 files && exit 1 -exec > TAGS -tf=/tmp/fp$$ -for f -do echo " " - sed 's/==//g - s/>=/>/g - s/<=/</g - s|/=|/|g' $f | awk ' - /^[> ]*=/{ print prevline "" NR-1 "," prevpos; } - /[^> ].*=/{ print $0 "" NR "," pos; } - { prevline = $0; prevpos = pos; pos += length($0)+1; } - ' pos=1 | sed 's/[ )]*=.*// - s//=/g' > $tf - echo -n $f,; echo `wc -c < $tf` #lose spaces - cat $tf -done -rm -f $tf diff --git a/ghc/CONTRIB/haskel.gif b/ghc/CONTRIB/haskel.gif deleted file mode 100644 index 89b20abefcd85c191c5588b06b458d5a10227ffe..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 5380 zcmV+f75nN(Nk%v~VH5!)0q_6-|Ns90001li0000K0V4qb0{(=LsmtvTqnxzbi?iOm z`wxcVNS5Y_rs~SJ?hD8AOxN~}=lag~{tpZahs2`sh)gP%%%<}RjY_A~s`ZM^YPa03 z_X`e-$BRHBfKIE;2()TVjw{ymy8VvN>-Ti08=&^Y2FO=vc!-#&I4Fc@@aMp`I7z8U z68Nb1Vc3&4R|y)r_X#OSc(+sfAljD+N@#l0YNHx!3xQcvd&?WCD#^0jJ6r}S$ta6V zyj+Z|Z1T)3ec<^R98HTot*b1&seJ}M@+-bnz8Z4QP)&{EO}a6d+s!EK-1csfFHy=4 z->}aYJ`M9ys5=#p8m3;hVA12Nh={%7?%c03c$q6d+HF1Eu6@MKAo zurdi$d5WC8d#*l3YH0FLt&KJnQltsix*?4iyxDNf% zrA1gCP!?7|-F1PTx6onoePv=$Hqu66kNKVE-2_3x$ib9SqL|`0R#vGQI9qN;Ut@?mO}Z71EA2%LM3>>9djC?F$sDl zenfS`k43W87AJsnxmXh(c_sMeo}He_!#;X;SR9m4##9`C8k*%Ea&|2!=BOg@`Q@i_ zmc!vH9yLXxt8tlUC#!pe$|st)->%T$T>@T+*1n25*(7T3&Bo$e&B=?Y zbVivO?VsR^3-OWU!t2<1N6L$2zmfg=p}EugD3`V(a(Swo{0KNP$C3(*7`M#n$g9g6 zvX}6USs6%b2KHvzXpr7~d}YQf)_k0>8LoDz$Sik-9qqd<*UcuL zA+h`@E-$hjrp$(CV<*12M*jS`5ulYUR^?-q9Q7LyYu<>aE`J^$=u_~)_0Br0ZaO!p z=SljBt?R(bq9@P5`s}I}Dav-TN=8HOmZ#k%<^cDOYVtB}4V~-eurkVs&>uoG)pz|) zI1K;ZFg+#GSMrUa8TZOtDyZNBcK4(BJ*;}hYrimvt-hbKLBmDgt@?e$o?^g|gX|;! z1Wj^@(FDTolRc-AY;k=OS^$y7kc$ZqeUo}05ZD)|LdD>0?)ggRU`N0%U@$KlgdgBW zhdD}lj(?#8*WQ9xl(ulLLlXp(7gYB`++K__k}2RjTRyOLD}Q86k+EG%3CeetQX{S68M*_mT%XvRx1 zYeF%!9|gx|uQqxne@-eE{vxG6*wiYCWYQH5m86=H5wSA);{;*?2}wuhNpgz&k@#NK zm0Ug2hK5`Oks>(>G!{aNo~xuK&4M6KQHzPEJRbI5z{(YRv5Y%{)m1G;*Gx{L?{*5jhCS@(&d8YyqdPR@0C$wb)&xu@0t}4S zVinR0b`pdQ6`aI6s4nK&Z6tUbR7`zfl1!JZPf!^t3=Qb3mme>T2xT_tL5 zx+pV!I3H@p?WN9qNpya8v;$%iqpQ;@Ab%PtT+z{>VQpgdq^3MRo>6v79pMqM8OzjA zwVq6}Q3NNmEiKj6u0%-V)JTQEf0o85)=|q!`9~eJN+^tEbL&5Cda(h;l|o1p=dqMI zH?wXqU;Zo55eW%cV#e%6a6F$!B}){-Cec4BoD|w<=D5~Y43DxMn^*~mqH6+^uVrN@ zOnd(8sXVZ=jH2VMYq@#W*Xa(m{R3@m2?fgOuFheiUEm`_sa>5h?p|BXrp44rIjrg< zA#?Sc8k;#>lU^`g_MGJIoSIp2R#mmH;-JCMR*|UYmyz@JY(N2dU+Y1ax~q(4F86!0 z2=?ZB!R;vXd+9BT6jcC@qnHNY-;uVCIwPV3?ku=S;2T8M+x(hgWbmpp8E zW^`Dy!6<(4ba6{z_{xn+sXgqvv5XDNuf-GzV?z7=kWXZ~IvblPt}|+hU1Z!T#CF zHG{;iS#5vHh0dMcs%(Dxaqv!SSiRA=Xi({iprdH5Hunoa&xG*2Qi?{PMr6YT7IMf+ z6(G=hY3k+WXv-;7-Hu0;rXpx@(`su6_X*ce)idloylU}^I$Xw% z7*vZ*E|95vjrE55 zjx+@>OUdgn9fFJ-Exz)rIeF*PA_>X{Zig6SEMoxUyJ0%)w`F_8?v2gN&o=Z5yqz^u z@E}^V#&qe$SDayuT1AltzZ_@y+c3nbR5@R4mt&Xpa%7%c!;$jp9Hodi{zl)}JLWYd zvNcv!;59nFkW25nwTbhFvg#i&w~&;Z9^cx8yV8;wI?hg5p!Q`q}fwxD? zyy5y(zi8!Lin@;HU2IU}HPx>d&9Ad=<#T-YNuw_P-^X^SzAH$$%1I@6hqvY}cU>yqW=Zw_uV3pQm*w4w9e?@H ze^ZG3`&PPqO!~Kf-O_%|COw0;Jt}8<16Wo;2Yc6%fXd}(2gQKwhcL%ia9KrWLt{Yt zm3DXnJ{p&SxsfQFAzkmJV##C)Ylc(S_CnY8FM32<40lDwBRV07atv2~rqVRebr@D-Y*K@6wXHuv> z9!EmWM`0qEBNhig*!F}>kx0uIhIJQ(eoFB=U!aJQ3IKHhhv2zHj4QeeoDY)Dd>*5 zxJA_XfTua(fwUd)8cA6jV`I zN|-5Ec9;$!shGBTRIinrpSPO_=$3mXi*|l+>7{sX})$k6&q8{(RXpJSjl7Wtbg>o3V+CvXD`ExS925ZZqcG7Gp~zRDF!+!8 zMvyfX2-2CM_IGFzNt8b&T;g$^)cBvumwKlXlR!2cG?;k%7*bkATk092sYsJHnwbWe zmXVp8M95Q@PHR4F~&8g@Ognm*_^i-j~&>K6-uODDtUG~P=v~xh-zx< zF``-HT?h0#fGTl1N~yESEz$Y@YI3-6ditOAlcuStq>y(X7!wQX6s&`n?D!o*l-RPgSbfTk5msSO-aQTsqglyJoXebtt9%^%arigx7jqSN% z|46M}IA`w)mY+zP+SoG{r%zfLsGpi!JQ#zK8jd@vsbI7hg{Y;$_${60Sl5cLTB@s? zM|-g-cC0C-E!eGGDM1KVj@$*O4C{At`mD|hr_L8@faYHe%A_xeb}tw^wlQH?b&#P- zhSB<&yIP(UM^>WPEZ6?iMD=r@niO`63T{pLmMyA|D)Wl{iLUt6VO3N^a~EsdB%UW& zkyq+HXt^2!OM>6oGCcW1pLaD1YH1Yumm-^{*%+U^XhJoWVl?Vqp;s61_j1GMZmW5Z z4LPZ~CyZ^#uU!dxKM0yfTU*7Gl3OdNAG(%^$90l6C+^Z$^toW38kba8@oPyqYDO+;N@hR9*WhQiNt5{M5Yth<+J2xZ71D zs)314+q2mFu>R$WY9~gp_ffIDC2zB|hj2^0c8QXJ){~t|aZ_ib1%tC3IVMZ_qQzU3 z0Qx$TCWA5BI3_u?lDc-P$7G=!qH$U)-->N!xxahyVl0b~0gPs1ioeHou@wrv23%n@ zJA=rXyFOb45cQk&*|+~|!ds`e(1*daS8}TBZG(se1l+Kk+NoA~KPDA~j4Q6cB%F?G zZ*mBxF-5P``n~BBq^yOp4DviOYOo+RpVBv$Qk*+otV&mv1UyQ_#Fq@3k~Kgm#V&io zR3|WG{KKRRu1#wn@EeC(d&1TGs$|Av55vSwTzExHfCpQ_d^^Qz8lT_VzkrOcXkvsT zO2Uh~{;js!$2u&;8j3HIM1^<>r8mio3ihPzn8`dFw_ohR`P*2^7RnO1z%^3J=1L-( zT!zCFd`4D#-!sb5bGq}qki$70C$-efZ zkM#iSU@&47Qjts_S;ZpghfcjJ9C+glt>8`HarTDYnN9V;y#!ojYta ztIN*Xmkf=%6D`U3JfCzX%+eIdTzrx0xPj}t$ndRvg}sVScX@;Ra4w_c2>H1Y(P+Epps0MiHy>2#&J7a#;d8qAR1i+eW-s5 z)7a<2$6M5|M`LE1)shO-V?@B~1J$Yw!kA3ersrxl^^gpCf)I?#Kb^WzU6tKe)7bi7 z)0;{CShOvr*Dov7n@h**iPkL|noFH-Q=QVr*v5&yq}Ges-^HCnin;&n!s5Cym95fI zOwm>5)svTyvC7jT-O_}2U+4FZr;W%ttJKO1kzhR1jLn24H?OsPzBmfkPkh=XYR=b~ zf8WceKK9JMeXLLBq|6(^bX>{FOwSg*8qZzke6M#jU|~SKI!U*v`v} z$3yGS{y-ox^z|EzgQ_8__D!xJ(-Vr6!yD%Q*e#me+B5F6GPrc{RY|SZW_E%JiWc!hSSchu7RID+>iOGMxC_b1zLl?OiwJTe5cy8*W)0Vxzoh8sZ7v9dfd|v z>=u;jZm!+7&Vxnx;|%ESke)o3P1vGT)#qM;%vipq*4#@=#P7aDa(9|ji>yR@$Hf?!1- iFY+T#@+EKbCy(+euktI;@-6T3FAwuEFY`)J0028i;iIzv diff --git a/ghc/CONTRIB/haskell-modes/README b/ghc/CONTRIB/haskell-modes/README deleted file mode 100644 index c931787996..0000000000 --- a/ghc/CONTRIB/haskell-modes/README +++ /dev/null @@ -1,55 +0,0 @@ -I've collected all the Haskell modes for GNU Emacs that I could lay my -hands on -- there are billions. A list is attached, grouped by -"family". - -I don't like "mode junk" myself, so I don't use any of them. I will -include advertising or testimonials from happy users if they send them -along... - -Will Partain -partain@dcs.gla.ac.uk -95/12/05 - -======================================================================= - -* "Chalmers Haskell mode family" -- "Major mode for editing Haskell", - by Lars Bo Nielsen and Lennart Augustsson. - - chalmers/original -- the original -- version 0.1. - - chalmers/thiemann -- Peter Thiemann added "indentation stuff" - and fontification -- version 0.2. - - chalmers/sof -- Sigbjorn Finne's hacked - version of Thiemann's. - -....................................................................... - -* "Glasgow Haskell mode family" -- originally written by Richard McPhee - et al., at Glasgow University, as a student project, for Kevin - Hammond. - - glasgow/original : version 1.0, now maintained by - gem@minster.york.ac.uk - -....................................................................... - -* "Simon Marlow Haskell mode family" -- This is the one that comes - with GHC, versions 0.16 up to at least 0.26. - - simonm/real : the real thing - - simonm/ghc : the one distributed with GHC 0.16-0.26; no particular - reason to prefer this one... - -....................................................................... - -* "Yale Haskell mode family" -- Especially good for chatting to a - Yale-Haskell inferior process :-) - - yale/original : the real thing - - yale/chak : "extended by Manuel M.T. Chakravarty with rudimentary - editing features (including better syntax table) and support - for the font-lock-mode." Via Hans Wolfgang Loidl - diff --git a/ghc/CONTRIB/haskell-modes/chalmers/original/haskell-mode.el b/ghc/CONTRIB/haskell-modes/chalmers/original/haskell-mode.el deleted file mode 100644 index 167956d429..0000000000 --- a/ghc/CONTRIB/haskell-modes/chalmers/original/haskell-mode.el +++ /dev/null @@ -1,543 +0,0 @@ -;; haskell-mode.el. Major mode for editing Haskell. -;; Copyright (C) 1989, Free Software Foundation, Inc., Lars Bo Nielsen -;; and Lennart Augustsson - -;; This file is not officially part of GNU Emacs. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY. No author or distributor -;; accepts responsibility to anyone for the consequences of using it -;; or for whether it serves any particular purpose or works at all, -;; unless he says so in writing. Refer to the GNU Emacs General Public -;; License for full details. - -;; Everyone is granted permission to copy, modify and redistribute -;; GNU Emacs, but only under the conditions described in the -;; GNU Emacs General Public License. A copy of this license is -;; supposed to have been given to you along with GNU Emacs so you -;; can know your rights and responsibilities. It should be in a -;; file named COPYING. Among other things, the copyright notice -;; and this notice must be preserved on all copies. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Haskell Mode. A major mode for editing and running Haskell. (Version 0.0) -;; ================================================================= -;; -;; This is a mode for editing and running Haskell. -;; It is very much based on the sml mode for GNU Emacs. It -;; features: -;; -;; - Inferior shell running Haskell. No need to leave emacs, just -;; keep right on editing while Haskell runs in another window. -;; -;; - Automatic "load file" in inferior shell. Send regions of code -;; to the Haskell program. -;; -;; -;; 1. HOW TO USE THE Haskell-MODE -;; ========================== -;; -;; Here is a short introduction to the mode. -;; -;; 1.1 GETTING STARTED -;; ------------------- -;; -;; If you are an experienced user of Emacs, just skip this section. -;; -;; To use the haskell-mode, insert this in your "~/.emacs" file (Or ask your -;; emacs-administrator to help you.): -;; -;; (setq auto-mode-alist (cons '("\\.hs$" . haskell-mode) (cons '("\\.lhs$" . haskell-mode) -;; auto-mode-alist))) -;; (autoload 'haskell-mode "haskell-mode" "Major mode for editing Haskell." t) -;; -;; Now every time a file with the extension `.hs' or `.lhs' is found, it is -;; automatically started up in haskell-mode. -;; -;; You will also have to specify the path to this file, so you will have -;; to add this as well: -;; -;; (setq load-path (cons "/usr/me/emacs" load-path)) -;; -;; where "/usr/me/emacs" is the directory where this file is. -;; -;; You may also want to compile the this file (M-x byte-compile-file) -;; for speed. -;; -;; You are now ready to start using haskell-mode. If you have tried other -;; language modes (like lisp-mode or C-mode), you should have no -;; problems. There are only a few extra functions in this mode. -;; -;; 1.2. EDITING COMMANDS. -;; ---------------------- -;; -;; The following editing and inferior-shell commands can ONLY be issued -;; from within a buffer in haskell-mode. -;; -;; LFD (reindent-then-newline-and-indent). -;; This is probably the function you will be using the most (press -;; CTRL while you press Return, press C-j or press Newline). It -;; will reindent the line, then make a new line and perform a new -;; indentation. -;; -;; M-; (indent-for-comment). -;; Like in other language modes, this command will give you a comment -;; at the of the current line. The column where the comment starts is -;; determined by the variable comment-column (default: 40). -;; -;; C-c C-v (haskell-mode-version). -;; Get the version of the haskell-mode. -;; -;; -;; 1.3. COMMANDS RELATED TO THE INFERIOR SHELL -;; ------------------------------------------- -;; -;; C-c C-s (haskell-pop-to-shell). -;; This command starts up an inferior shell running haskell. If the shell -;; is running, it will just pop up the shell window. -;; -;; C-c C-u (haskell-save-buffer-use-file). -;; This command will save the current buffer and send a "load file", -;; where file is the file visited by the current buffer, to the -;; inferior shell running haskell. -;; -;; C-c C-f (haskell-run-on-file). -;; Will send a "load file" to the inferior shell running haskell, -;; prompting you for the file name. -;; -;; C-c C-r (haskell-send-region). -;; Will send region, from point to mark, to the inferior shell -;; running haskell. -;; -;; C-c C-b (haskell-send-buffer). -;; Will send whole buffer to inferior shell running haskell. -;; -;; 2. INDENTATION -;; ================ -;; Not yet. -;; -;; 3. INFERIOR SHELL. -;; ================== -;; -;; The mode for Standard ML also contains a mode for an inferior shell -;; running haskell. The mode is the same as the shell-mode, with just one -;; extra command. -;; -;; 3.1. INFERIOR SHELL COMMANDS -;; ---------------------------- -;; -;; C-c C-f (haskell-run-on-file). Send a `load file' to the process running -;; haskell. -;; -;; 3.2. CONSTANTS CONTROLLING THE INFERIOR SHELL MODE -;; -------------------------------------------------- -;; -;; Because haskell is called differently on various machines, and the -;; haskell-systems have their own command for reading in a file, a set of -;; constants controls the behavior of the inferior shell running haskell (to -;; change these constants: See CUSTOMIZING YOUR Haskell-MODE below). -;; -;; haskell-prog-name (default "hbi"). -;; This constant is a string, containing the command to invoke -;; Standard ML on your system. -;; -;; haskell-use-right-delim (default "\"") -;; haskell-use-left-delim (default "\"") -;; The left and right delimiter used by your version of haskell, for -;; `use file-name'. -;; -;; haskell-process-name (default "Haskell"). -;; The name of the process running haskell. (This will be the name -;; appearing on the mode line of the buffer) -;; -;; NOTE: The haskell-mode functions: haskell-send-buffer, haskell-send-function and -;; haskell-send-region, creates temporary files (I could not figure out how -;; to send large amounts of data to a process). These files will be -;; removed when you leave emacs. -;; -;; -;; 4. CUSTOMIZING YOUR Haskell-MODE -;; ============================ -;; -;; If you have to change some of the constants, you will have to add a -;; `hook' to the haskell-mode. Insert this in your "~/.emacs" file. -;; -;; (setq haskell-mode-hook 'my-haskell-constants) -;; -;; Your function "my-haskell-constants" will then be executed every time -;; "haskell-mode" is invoked. Now you only have to write the emacs-lisp -;; function "my-haskell-constants", and put it in your "~/.emacs" file. -;; -;; Say you are running a version of haskell that uses the syntax `load -;; ["file"]', is invoked by the command "OurHaskell" and you don't want the -;; indentation algorithm to indent according to open parenthesis, your -;; function should look like this: -;; -;; (defun my-haskell-constants () -;; (setq haskell-prog-name "OurHaskell") -;; (setq haskell-use-left-delim "[\"") -;; (setq haskell-use-right-delim "\"]") -;; (setq haskell-paren-lookback nil)) -;; -;; The haskell-shell also runs a `hook' (haskell-shell-hook) when it is invoked. -;; -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; -;; ORIGINAL AUTHOR -;; Lars Bo Nielsen -;; Aalborg University -;; Computer Science Dept. -;; 9000 Aalborg -;; Denmark -;; -;; lbn@iesd.dk -;; or: ...!mcvax!diku!iesd!lbn -;; or: mcvax!diku!iesd!lbn@uunet.uu.net -;; -;; MODIFIED FOR Haskell BY -;; Lennart Augustsson -;; -;; -;; Please let me know if you come up with any ideas, bugs, or fixes. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconst haskell-mode-version-string - "HASKELL-MODE, Version 0.1") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; CONSTANTS CONTROLLING THE MODE. -;;; -;;; These are the constants you might want to change -;;; - -;; The command used to start up the haskell-program. -(defconst haskell-prog-name "hbi" "*Name of program to run as haskell.") - -;; The left delimmitter for `load file' -(defconst haskell-use-left-delim "\"" - "*The left delimiter for the filename when using \"load\".") - -;; The right delimmitter for `load file' -(defconst haskell-use-right-delim "\"" - "*The right delimiter for the filename when using \"load\".") - -;; A regular expression matching the prompt pattern in the inferior -;; shell -(defconst haskell-shell-prompt-pattern "^> *" - "*The prompt pattern for the inferion shell running haskell.") - -;; The template used for temporary files, created when a region is -;; send to the inferior process running haskell. -(defconst haskell-tmp-template "/tmp/haskell.tmp." - "*Template for the temporary file, created by haskell-simulate-send-region.") - -;; The name of the process running haskell (This will also be the name of -;; the buffer). -(defconst haskell-process-name "Haskell" "*The name of the Haskell-process") - -;;; -;;; END OF CONSTANTS CONTROLLING THE MODE. -;;; -;;; If you change anything below, you are on your own. -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(defvar haskell-mode-syntax-table nil "The syntax table used in haskell-mode.") - -(defvar haskell-mode-map nil "The mode map used in haskell-mode.") - -(defun haskell-mode () - "Major mode for editing Haskell code. -Tab indents for Haskell code. -Comments are delimited with -- -Paragraphs are separated by blank lines only. -Delete converts tabs to spaces as it moves back. - -Key bindings: -============= - -\\[haskell-pop-to-shell]\t Pop to the haskell window. -\\[haskell-save-buffer-use-file]\t Save the buffer, and send a \"load file\". -\\[haskell-send-region]\t Send region (point and mark) to haskell. -\\[haskell-run-on-file]\t Send a \"load file\" to haskell. -\\[haskell-send-buffer]\t Send whole buffer to haskell. -\\[haskell-mode-version]\t Get the version of haskell-mode. -\\[haskell-evaluate-expression]\t Prompt for an expression and evalute it. - - -Mode map -======== -\\{haskell-mode-map} -Runs haskell-mode-hook if non nil." - (interactive) - (kill-all-local-variables) - (if haskell-mode-map - () - (setq haskell-mode-map (make-sparse-keymap)) - (define-key haskell-mode-map "\C-c\C-v" 'haskell-mode-version) - (define-key haskell-mode-map "\C-c\C-u" 'haskell-save-buffer-use-file) - (define-key haskell-mode-map "\C-c\C-s" 'haskell-pop-to-shell) - (define-key haskell-mode-map "\C-c\C-r" 'haskell-send-region) - (define-key haskell-mode-map "\C-c\C-m" 'haskell-region) - (define-key haskell-mode-map "\C-c\C-f" 'haskell-run-on-file) - (define-key haskell-mode-map "\C-c\C-b" 'haskell-send-buffer) - (define-key haskell-mode-map "\C-ce" 'haskell-evaluate-expression) - (define-key haskell-mode-map "\C-j" 'reindent-then-newline-and-indent) - (define-key haskell-mode-map "\177" 'backward-delete-char-untabify)) - (use-local-map haskell-mode-map) - (setq major-mode 'haskell-mode) - (setq mode-name "Haskell") - (define-abbrev-table 'haskell-mode-abbrev-table ()) - (setq local-abbrev-table haskell-mode-abbrev-table) - (if haskell-mode-syntax-table - () - (setq haskell-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\( "()1" haskell-mode-syntax-table) - (modify-syntax-entry ?\) ")(4" haskell-mode-syntax-table) - (modify-syntax-entry ?\\ "." haskell-mode-syntax-table) - (modify-syntax-entry ?* ". 23" haskell-mode-syntax-table) - ;; Special characters in haskell-mode to be treated as normal - ;; characters: - (modify-syntax-entry ?_ "w" haskell-mode-syntax-table) - (modify-syntax-entry ?\' "w" haskell-mode-syntax-table) - ) - (set-syntax-table haskell-mode-syntax-table) - (make-local-variable 'require-final-newline) ; Always put a new-line - (setq require-final-newline t) ; in the end of file - (make-local-variable 'indent-line-function) - (setq indent-line-function 'haskell-indent-line) - (make-local-variable 'comment-start) - (setq comment-start "-- ") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column 39) ; Start of comment in this column - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "(\\*+[ \t]?") ; This matches a start of comment - (make-local-variable 'comment-indent-hook) - (setq comment-indent-hook 'haskell-comment-indent) - ;; - ;; Adding these will fool the matching of parens. I really don't - ;; know why. It would be nice to have comments treated as - ;; white-space - ;; - ;; (make-local-variable 'parse-sexp-ignore-comments) - ;; (setq parse-sexp-ignore-comments t) - ;; - (run-hooks 'haskell-mode-hook)) ; Run the hook - -(defun haskell-mode-version () - (interactive) - (message haskell-mode-version-string)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; INDENTATION -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun haskell-indent-line () - "Indent current line of Haskell code." - (interactive) - (let ((indent (haskell-calculate-indentation))) - (if (/= (current-indentation) indent) - (let ((beg (progn (beginning-of-line) (point)))) - (skip-chars-forward "\t ") - (delete-region beg (point)) - (indent-to indent)) - ;; If point is before indentation, move point to indentation - (if (< (current-column) (current-indentation)) - (skip-chars-forward "\t "))))) - -(defun haskell-calculate-indentation () - (save-excursion - (previous-line 1) - (beginning-of-line) ; Go to first non whitespace - (skip-chars-forward "\t ") ; on the line. - (current-column))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; INFERIOR SHELL -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar haskell-shell-map nil "The mode map for haskell-shell.") - -(defun haskell-shell () - "Inferior shell invoking Haskell. -It is not possible to have more than one shell running Haskell. -Like the shell mode with the additional command: - -\\[haskell-run-on-file]\t Runs haskell on the file. -\\{haskell-shell-map} -Variables controlling the mode: - -haskell-prog-name (default \"hbi\") - The string used to invoke the haskell program. - -haskell-use-right-delim (default \"\\\"\") -haskell-use-left-delim (default \"\\\"\") - The left and right delimiter used by your version of haskell, for - \"load file-name\". - -haskell-process-name (default \"Haskell\") - The name of the process running haskell. - -haskell-shell-prompt-pattern (default \"^> *\") - The prompt pattern. - -Runs haskell-shell-hook if not nil." - (interactive) - (if (not (process-status haskell-process-name)) - (save-excursion ; Process is not running - (message "Starting Haskell...") ; start up a new process - (require 'shell) - (set-buffer (make-shell haskell-process-name haskell-prog-name)) - (erase-buffer) ; Erase the buffer if a previous - (if haskell-shell-map ; process died in there - () - (setq haskell-shell-map (copy-sequence shell-mode-map)) - (define-key haskell-shell-map "\C-c\C-f" 'haskell-run-on-file)) - (use-local-map haskell-shell-map) - (make-local-variable 'shell-prompt-pattern) - (setq shell-prompt-pattern haskell-shell-prompt-pattern) - (setq major-mode 'haskell-shell) - (setq mode-name "Haskell Shell") - (setq mode-line-format - "-----Emacs: %17b %M %[(%m: %s)%]----%3p--%-") - (set-process-filter (get-process haskell-process-name) 'haskell-process-filter) - (message "Starting Haskell...done.") - (run-hooks 'haskell-shell-hook)))) - -(defun haskell-process-filter (proc str) - (let ((cur (current-buffer)) - (pop-up-windows t)) - (pop-to-buffer (concat "*" haskell-process-name "*")) - (goto-char (point-max)) - (if (string= str "\b\b\b \b\b\b") - (backward-delete-char 4) - (insert str)) - (set-marker (process-mark proc) (point-max)) - (pop-to-buffer cur))) - -(defun haskell-pop-to-shell () - (interactive) - (haskell-shell) - (pop-to-buffer (concat "*" haskell-process-name "*"))) - -(defun haskell-run-on-file (fil) - (interactive "FRun Haskell on : ") - (haskell-shell) - (save-some-buffers) - (send-string haskell-process-name - (concat "load " haskell-use-left-delim (expand-file-name fil) - haskell-use-right-delim ";\n"))) - -(defun haskell-save-buffer-use-file () - "Save the buffer, and send a `use file' to the inferior shell -running Haskell." - (interactive) - (let (file) - (if (setq file (buffer-file-name)) ; Is the buffer associated - (progn ; with file ? - (save-buffer) - (haskell-shell) - (send-string haskell-process-name - (concat "load " haskell-use-left-delim - (expand-file-name file) - haskell-use-right-delim ";\n"))) - (error "Buffer not associated with file.")))) - -(defvar haskell-tmp-files-list nil - "List of all temporary files created by haskell-simulate-send-region. -Each element in the list is a list with the format: - - (\"tmp-filename\" buffer start-line)") - -(defvar haskell-simulate-send-region-called-p nil - "Has haskell-simulate-send-region been called previously.") - -(defun haskell-make-temp-name (pre) - (concat (make-temp-name pre) ".m")) - -(defun haskell-simulate-send-region (point1 point2) - "Simulate send region. As send-region only can handle what ever the -system sets as the default, we have to make a temporary file. -Updates the list of temporary files (haskell-tmp-files-list)." - (let ((file (expand-file-name (haskell-make-temp-name haskell-tmp-template)))) - ;; Remove temporary files when we leave emacs - (if (not haskell-simulate-send-region-called-p) - (progn - (setq haskell-old-kill-emacs-hook kill-emacs-hook) - (setq kill-emacs-hook 'haskell-remove-tmp-files) - (setq haskell-simulate-send-region-called-p t))) - (save-excursion - (goto-char point1) - (setq haskell-tmp-files-list - (cons (list file - (current-buffer) - (save-excursion ; Calculate line no. - (beginning-of-line) - (1+ (count-lines 1 (point))))) - haskell-tmp-files-list))) - (write-region point1 point2 file nil 'dummy) - (haskell-shell) - (message "Using temporary file: %s" file) - (send-string - haskell-process-name - ;; string to send: load file; - (concat "load " haskell-use-left-delim file haskell-use-right-delim ";\n")))) - -(defvar haskell-old-kill-emacs-hook nil - "Old value of kill-emacs-hook") - -(defun haskell-remove-tmp-files () - "Remove the temporary files, created by haskell-simulate-send-region, if -they still exist. Only files recorded in haskell-tmp-files-list are removed." - (message "Removing temporary files created by haskell-mode...") - (while haskell-tmp-files-list - (condition-case () - (delete-file (car (car haskell-tmp-files-list))) - (error ())) - (setq haskell-tmp-files-list (cdr haskell-tmp-files-list))) - (message "Removing temporary files created by haskell-mode...done.") - (run-hooks 'haskell-old-kill-emacs-hook)) - -(defun haskell-send-region () - "Send region." - (interactive) - (let (start end) - (save-excursion - (setq end (point)) - (exchange-point-and-mark) - (setq start (point))) - (haskell-simulate-send-region start end))) - -(defun haskell-send-buffer () - "Send the buffer." - (interactive) - (haskell-simulate-send-region (point-min) (point-max))) - -(defun haskell-evaluate-expression (h-expr) - "Prompt for and evaluate an expression" - (interactive "sExpression: ") - (let ((str (concat h-expr ";\n")) - (buf (current-buffer))) - (haskell-pop-to-shell) - (insert str) - (send-string haskell-process-name str) - (pop-to-buffer buf))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; END OF Haskell-MODE -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/ghc/CONTRIB/haskell-modes/chalmers/sof/haskell-mode.el b/ghc/CONTRIB/haskell-modes/chalmers/sof/haskell-mode.el deleted file mode 100644 index 25a4324ad8..0000000000 --- a/ghc/CONTRIB/haskell-modes/chalmers/sof/haskell-mode.el +++ /dev/null @@ -1,825 +0,0 @@ -;; haskell-mode.el. Major mode for editing Haskell. -;; Copyright (C) 1989, Free Software Foundation, Inc., Lars Bo Nielsen -;; and Lennart Augustsson -;; modified by Peter Thiemann, March 1994 - -;; This file is not officially part of GNU Emacs. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY. No author or distributor -;; accepts responsibility to anyone for the consequences of using it -;; or for whether it serves any particular purpose or works at all, -;; unless he says so in writing. Refer to the GNU Emacs General Public -;; License for full details. - -;; Everyone is granted permission to copy, modify and redistribute -;; GNU Emacs, but only under the conditions described in the -;; GNU Emacs General Public License. A copy of this license is -;; supposed to have been given to you along with GNU Emacs so you -;; can know your rights and responsibilities. It should be in a -;; file named COPYING. Among other things, the copyright notice -;; and this notice must be preserved on all copies. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Haskell Mode. A major mode for editing and running Haskell. (Version 0.0) -;; ================================================================= -;; -;; This is a mode for editing and running Haskell. -;; It is very much based on the sml mode for GNU Emacs. It -;; features: -;; -;; - Inferior shell running Haskell. No need to leave emacs, just -;; keep right on editing while Haskell runs in another window. -;; -;; - Automatic "load file" in inferior shell. Send regions of code -;; to the Haskell program. -;; -;; -;; 1. HOW TO USE THE Haskell-MODE -;; ========================== -;; -;; Here is a short introduction to the mode. -;; -;; 1.1 GETTING STARTED -;; ------------------- -;; -;; If you are an experienced user of Emacs, just skip this section. -;; -;; To use the haskell-mode, insert this in your "~/.emacs" file (Or ask your -;; emacs-administrator to help you.): -;; -;; (setq auto-mode-alist (cons '("\\.hs$" . haskell-mode) (cons '("\\.lhs$" . haskell-mode) -;; auto-mode-alist))) -;; (autoload 'haskell-mode "haskell-mode" "Major mode for editing Haskell." t) -;; -;; Now every time a file with the extension `.hs' or `.lhs' is found, it is -;; automatically started up in haskell-mode. -;; -;; You will also have to specify the path to this file, so you will have -;; to add this as well: -;; -;; (setq load-path (cons "/usr/me/emacs" load-path)) -;; -;; where "/usr/me/emacs" is the directory where this file is. -;; -;; You may also want to compile the this file (M-x byte-compile-file) -;; for speed. -;; -;; You are now ready to start using haskell-mode. If you have tried other -;; language modes (like lisp-mode or C-mode), you should have no -;; problems. There are only a few extra functions in this mode. -;; -;; 1.2. EDITING COMMANDS. -;; ---------------------- -;; -;; The following editing and inferior-shell commands can ONLY be issued -;; from within a buffer in haskell-mode. -;; -;; LFD (haskell-newline-and-indent). -;; This is probably the function you will be using the most (press -;; CTRL while you press Return, press C-j or press Newline). It -;; makes a new line and performs indentation based on the last -;; preceding non-comment line. -;; -;; M-; (indent-for-comment). -;; Like in other language modes, this command will give you a comment -;; at the of the current line. The column where the comment starts is -;; determined by the variable comment-column (default: 40). -;; -;; C-c C-v (haskell-mode-version). -;; Get the version of the haskell-mode. -;; -;; -;; 1.3. COMMANDS RELATED TO THE INFERIOR SHELL -;; ------------------------------------------- -;; -;; C-c C-s (haskell-pop-to-shell). -;; This command starts up an inferior shell running haskell. If the shell -;; is running, it will just pop up the shell window. -;; -;; C-c C-u (haskell-save-buffer-use-file). -;; This command will save the current buffer and send a "load file", -;; where file is the file visited by the current buffer, to the -;; inferior shell running haskell. -;; -;; C-c C-f (haskell-run-on-file). -;; Will send a "load file" to the inferior shell running haskell, -;; prompting you for the file name. -;; -;; C-c C-r (haskell-send-region). -;; Will send region, from point to mark, to the inferior shell -;; running haskell. -;; -;; C-c C-b (haskell-send-buffer). -;; Will send whole buffer to inferior shell running haskell. -;; -;; 2. INDENTATION -;; ================ -;; -;; The first indentation command (using C-j or TAB) on a given line -;; indents like the last preceding non-comment line. The next TAB -;; indents to the indentation of the innermost enclosing scope. Further -;; TABs get you to further enclosing scopes. After indentation has -;; reached the first column, the process restarts using the indentation -;; of the preceding non-comment line, again. -;; -;; 3. INFERIOR SHELL. -;; ================== -;; -;; The mode for Standard ML also contains a mode for an inferior shell -;; running haskell. The mode is the same as the shell-mode, with just one -;; extra command. -;; -;; 3.1. INFERIOR SHELL COMMANDS -;; ---------------------------- -;; -;; C-c C-f (haskell-run-on-file). Send a `load file' to the process running -;; haskell. -;; -;; 3.2. CONSTANTS CONTROLLING THE INFERIOR SHELL MODE -;; -------------------------------------------------- -;; -;; Because haskell is called differently on various machines, and the -;; haskell-systems have their own command for reading in a file, a set of -;; constants controls the behavior of the inferior shell running haskell (to -;; change these constants: See CUSTOMIZING YOUR Haskell-MODE below). -;; -;; haskell-prog-name (default "hbi"). -;; This constant is a string, containing the command to invoke -;; Standard ML on your system. -;; -;; haskell-use-right-delim (default "\"") -;; haskell-use-left-delim (default "\"") -;; The left and right delimiter used by your version of haskell, for -;; `use file-name'. -;; -;; haskell-process-name (default "Haskell"). -;; The name of the process running haskell. (This will be the name -;; appearing on the mode line of the buffer) -;; -;; NOTE: The haskell-mode functions: haskell-send-buffer, haskell-send-function and -;; haskell-send-region, creates temporary files (I could not figure out how -;; to send large amounts of data to a process). These files will be -;; removed when you leave emacs. -;; -;; 4. FONTIFICATION -;; -;; There is support for Jamie Zawinski's font-lock-mode through the -;; variable "haskell-font-lock-keywords". -;; -;; 5. CUSTOMIZING YOUR Haskell-MODE -;; ============================ -;; -;; If you have to change some of the constants, you will have to add a -;; `hook' to the haskell-mode. Insert this in your "~/.emacs" file. -;; -;; (setq haskell-mode-hook 'my-haskell-constants) -;; -;; Your function "my-haskell-constants" will then be executed every time -;; "haskell-mode" is invoked. Now you only have to write the emacs-lisp -;; function "my-haskell-constants", and put it in your "~/.emacs" file. -;; -;; Say you are running a version of haskell that uses the syntax `load -;; ["file"]', is invoked by the command "OurHaskell" and you don't want the -;; indentation algorithm to indent according to open parenthesis, your -;; function should look like this: -;; -;; (defun my-haskell-constants () -;; (setq haskell-prog-name "OurHaskell") -;; (setq haskell-use-left-delim "[\"") -;; (setq haskell-use-right-delim "\"]") -;; (setq haskell-paren-lookback nil)) -;; -;; The haskell-shell also runs a `hook' (haskell-shell-hook) when it is invoked. -;; -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; -;; ORIGINAL AUTHOR -;; Lars Bo Nielsen -;; Aalborg University -;; Computer Science Dept. -;; 9000 Aalborg -;; Denmark -;; -;; lbn@iesd.dk -;; or: ...!mcvax!diku!iesd!lbn -;; or: mcvax!diku!iesd!lbn@uunet.uu.net -;; -;; MODIFIED FOR Haskell BY -;; Lennart Augustsson -;; indentation stuff by Peter Thiemann -;; -;; -;; Please let me know if you come up with any ideas, bugs, or fixes. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconst haskell-mode-version-string - "HASKELL-MODE, Version 0.2, PJT indentation") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; CONSTANTS CONTROLLING THE MODE. -;;; -;;; These are the constants you might want to change -;;; - -;; The command used to start up the haskell-program. -(defconst haskell-prog-name "hbi" "*Name of program to run as haskell.") - -;; The left delimmitter for `load file' -(defconst haskell-use-left-delim "\"" - "*The left delimiter for the filename when using \"load\".") - -;; The right delimmitter for `load file' -(defconst haskell-use-right-delim "\"" - "*The right delimiter for the filename when using \"load\".") - -;; A regular expression matching the prompt pattern in the inferior -;; shell -(defconst haskell-shell-prompt-pattern "^> *" - "*The prompt pattern for the inferion shell running haskell.") - -;; The template used for temporary files, created when a region is -;; send to the inferior process running haskell. -(defconst haskell-tmp-template "/tmp/haskell.tmp." - "*Template for the temporary file, created by haskell-simulate-send-region.") - -;; The name of the process running haskell (This will also be the name of -;; the buffer). -(defconst haskell-process-name "Haskell" "*The name of the Haskell-process") - -;;; -;;; END OF CONSTANTS CONTROLLING THE MODE. -;;; -;;; If you change anything below, you are on your own. -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(defvar haskell-mode-syntax-table nil "The syntax table used in haskell-mode.") - -(defvar haskell-mode-map nil "The mode map used in haskell-mode.") - -(defvar haskell-mode-abbrev-table nil "The abbrev-table used in haskell-mode.") - -(defvar haskell-old-kill-emacs-hook nil "Old value of kill-emacs-hook") - -(defun haskell-mode () - "Major mode for editing Haskell code. -Tab indents for Haskell code. -Comments are delimited with -- -Paragraphs are separated by blank lines only. -Delete converts tabs to spaces as it moves back. - -Key bindings: -============= - -\\[haskell-pop-to-shell]\t Pop to the haskell window. -\\[haskell-save-buffer-use-file]\t Save the buffer, and send a \"load file\". -\\[haskell-send-region]\t Send region (point and mark) to haskell. -\\[haskell-run-on-file]\t Send a \"load file\" to haskell. -\\[haskell-send-buffer]\t Send whole buffer to haskell. -\\[haskell-mode-version]\t Get the version of haskell-mode. -\\[haskell-evaluate-expression]\t Prompt for an expression and evalute it. - - -Mode map -======== -\\{haskell-mode-map} -Runs haskell-mode-hook if non nil." - (interactive) - (kill-all-local-variables) - (if haskell-mode-map - () - (setq haskell-mode-map (make-sparse-keymap)) - (define-key haskell-mode-map "\C-c\C-v" 'haskell-mode-version) - (define-key haskell-mode-map "\C-c\C-u" 'haskell-save-buffer-use-file) - (define-key haskell-mode-map "\C-c\C-s" 'haskell-pop-to-shell) - (define-key haskell-mode-map "\C-c\C-r" 'haskell-send-region) - (define-key haskell-mode-map "\C-c\C-m" 'haskell-region) - (define-key haskell-mode-map "\C-c\C-f" 'haskell-run-on-file) - (define-key haskell-mode-map "\C-c\C-b" 'haskell-send-buffer) - (define-key haskell-mode-map "\C-c\C-l" 'comment-line) - (define-key haskell-mode-map "\C-ce" 'haskell-evaluate-expression) -; (define-key haskell-mode-map "\C-j" 'haskell-newline-and-indent) - (define-key haskell-mode-map [S-tab] 'tab-to-tab-stop) - (define-key haskell-mode-map "\177" 'backward-delete-char-untabify)) - (use-local-map haskell-mode-map) - (setq major-mode 'haskell-mode) - (setq mode-name "Haskell") - (define-abbrev-table 'haskell-mode-abbrev-table ()) - (setq local-abbrev-table haskell-mode-abbrev-table) - (if haskell-mode-syntax-table - () - (setq haskell-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?{ "(}1" haskell-mode-syntax-table) - (modify-syntax-entry ?} "){4" haskell-mode-syntax-table) -; partain: out -; (modify-syntax-entry ?- "_ 2356" haskell-mode-syntax-table) -; (modify-syntax-entry ?\f "> b" haskell-mode-syntax-table) -; (modify-syntax-entry ?\n "> b" haskell-mode-syntax-table) -; partain: end out -; partain: in - (modify-syntax-entry ?- "_ 23" haskell-mode-syntax-table) -; (modify-syntax-entry ?\f "> b" haskell-mode-syntax-table) -; (modify-syntax-entry ?\n "> b" haskell-mode-syntax-table) -; partain: end in - (modify-syntax-entry ?\\ "\\" haskell-mode-syntax-table) - (modify-syntax-entry ?* "_" haskell-mode-syntax-table) - (modify-syntax-entry ?_ "_" haskell-mode-syntax-table) - (modify-syntax-entry ?' "_" haskell-mode-syntax-table) - (modify-syntax-entry ?: "_" haskell-mode-syntax-table) - (modify-syntax-entry ?| "." haskell-mode-syntax-table) - ) - (set-syntax-table haskell-mode-syntax-table) - (make-local-variable 'require-final-newline) ; Always put a new-line - (setq require-final-newline t) ; in the end of file -; (make-local-variable 'change-major-mode-hook) -; (setq change-major-mode-hook nil) -; (make-local-variable 'indent-line-function) -; (setq indent-line-function 'haskell-indent-line) - (make-local-variable 'comment-start) - (setq comment-start "-- ") -; (setq comment-start "{- ") - (make-local-variable 'comment-end) - (setq comment-end "") -; (setq comment-end " -}") - (make-local-variable 'comment-column) - (setq comment-column 60) ; Start of comment in this column - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "{-+ *\\|--+ *") ; This matches a start of comment - (make-local-variable 'comment-multi-line) - (setq comment-multi-line nil) -; (make-local-variable 'comment-indent-function) -; (setq comment-indent-function 'haskell-comment-indent) - ;; - ;; Adding these will fool the matching of parens. I really don't - ;; know why. It would be nice to have comments treated as - ;; white-space - ;; - ;; (make-local-variable 'parse-sexp-ignore-comments) - ;; (setq parse-sexp-ignore-comments t) - ;; - (run-hooks 'haskell-mode-hook)) ; Run the hook - -(defun haskell-mode-version () - (interactive) - (message haskell-mode-version-string)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; INDENTATION -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; some variables for later use - -(defvar haskell-open-comment "{-") -(defvar haskell-close-comment "-}") -(defvar haskell-indentation-counter 0 - "count repeated invocations of indent-for-tab-command") -(defvar haskell-literate-flag nil - "used to guide literate/illiterate behavior, set automagically") - -(defun haskell-newline-and-indent () - (interactive) - (setq haskell-literate-flag - (save-excursion - (beginning-of-line) - (= (following-char) ?>))) - (newline) - (if haskell-literate-flag (insert ">")) - (haskell-indent-line)) - -(defun haskell-indent-line () - "Indent current line of ordinary or literate Haskell code." - (interactive) - (let ((indent (haskell-calculate-indentation-pjt-2))) - (if (/= (current-indentation) indent) - (let ((beg (progn - (beginning-of-line) - (if (= (following-char) ?>) (forward-char 1)) ;LITERATE - (point)))) - (skip-chars-forward "\t ") - (delete-region beg (point)) - (indent-to indent)) - ;; If point is before indentation, move point to indentation - (if (< (current-column) (current-indentation)) - (skip-chars-forward "\t "))))) - -(defun haskell-calculate-indentation () - (save-excursion - (let ((col (current-column))) - (while (and (not (bobp)) ;skip over empty and comment-only lines - (= col (current-column))) - (previous-line 1) - (beginning-of-line) ; Go to first non whitespace - (if (= (following-char) ?>) ;LITERATE - (forward-char 1) - (if haskell-literate-flag ;ignore illiterate lines - (end-of-line))) - (skip-chars-forward "\t ") ; on the line. - (setq col (current-column)) - (search-forward-regexp (concat haskell-open-comment "\\|--\\|\n") nil 0) - (goto-char (match-beginning 0))) - (search-backward-regexp "\\b\\(where\\|let\\|of\\|in\\)\\b\\|\n" nil 0) - (if (looking-at "\n") - () - (setq col (current-column)) - (forward-word 1) - (skip-chars-forward "\t ") - (if (looking-at "\\w") - (setq col (current-column)) - (setq col (+ 2 col)))) - col))) - -(defun haskell-calculate-indentation-pjt-2 () - "Calculate indentation for Haskell program code, versatile version" - (save-excursion - (if (eq last-command 'haskell-indentation) - (setq haskell-indentation-counter (1+ haskell-indentation-counter)) - (setq haskell-indentation-counter -1)) - (setq this-command 'haskell-indentation) - (let* ((simple-indent (haskell-calculate-indentation)) - (count haskell-indentation-counter) - (min-indent simple-indent) ; minimum indentation found in a non-comment line - (last-indent simple-indent) ; indentation of the following non-comment line - (return-indent nil) ; computed indentation - (comment-depth 0)) - (previous-line 1) - (if (< haskell-indentation-counter 0) ; 1st tab gives simple indentation - (setq return-indent simple-indent)) - (while (not return-indent) - (if (search-backward-regexp "\\b\\(where\\|let\\|of\\)\\b\\|\n\\|{-\\|-}" nil t 1) - (cond - ((looking-at haskell-open-comment) - (setq comment-depth (1- comment-depth))) - ((looking-at haskell-close-comment) - (setq comment-depth (1+ comment-depth))) - ((= 0 comment-depth) - (cond - ((looking-at "\n") - (save-excursion - (forward-char 1) - (if (= (following-char) ?>) - (forward-char 1) - (if haskell-literate-flag - (end-of-line))) ;LITERATE: ignore lines w/o > - (skip-chars-forward "\t ") - (if (looking-at (concat haskell-open-comment "\\|--\\|\n")) - () - (setq last-indent (current-column)) - (if (< last-indent min-indent) - (setq min-indent last-indent))))) - (t ; looking at a keyword - (save-excursion - (forward-word 1) - (skip-chars-forward " \t") - (if (and haskell-literate-flag ;LITERATE: ignore lines w/o > - (save-excursion - (beginning-of-line) - (/= (following-char) ?>))) - (end-of-line)) - (if (looking-at (concat haskell-open-comment "\\|--\\|\n")) - () - (setq last-indent (current-column))) - (if (<= last-indent min-indent) - (if (> count 0) - (setq count (1- count)) - (setq return-indent last-indent))) - (if (< last-indent min-indent) - (setq min-indent last-indent))))))) - (setq return-indent simple-indent) - (setq haskell-indentation-counter -1))) - return-indent))) - -(defun haskell-skip-nested-comment () - ;; point looks at opening {-, move over closing -} - ;; todo: specify what happens on failure, bounds check ... - (forward-char 2) - (let ((comment-depth 1)) - (while (> comment-depth 0) - (search-forward-regexp "{-\\|-}") - (goto-char (match-beginning 0)) - (setq comment-depth - (if (= (following-char) 123) ; code for opening brace - (1+ comment-depth) - (1- comment-depth))) - (goto-char (match-end 0))))) - - -;;;seemingly obsolete functions -(defun haskell-inside-of-inline-comment () - (let ((bolp (save-excursion - (beginning-of-line) - (point)))) - (search-backward comment-start bolp t 1))) - -(defun haskell-inside-of-nested-comment () - (save-excursion - (let ((count 0)) - (while - (search-backward-regexp "\\({-\\|-}\\)" 0 t 1) - (if (haskell-inside-of-inline-comment) - () - (if (looking-at haskell-open-comment) - (setq count (1+ count)) - (setq count (1- count))))) - (> count 0)))) - -(defun haskell-inside-of-comment () - (or (haskell-inside-of-inline-comment) - (haskell-inside-of-nested-comment))) - -;;;stolen from sml-mode.el -(defun haskell-comment-indent () - "Compute indentation for Haskell comments" - (if (looking-at "^--") - 0 - (save-excursion - (skip-chars-backward " \t") - (max (1+ (current-column)) - comment-column)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; INFERIOR SHELL -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar haskell-shell-map nil "The mode map for haskell-shell.") - -(defun haskell-shell () - "Inferior shell invoking Haskell. -It is not possible to have more than one shell running Haskell. -Like the shell mode with the additional command: - -\\[haskell-run-on-file]\t Runs haskell on the file. -\\{haskell-shell-map} -Variables controlling the mode: - -haskell-prog-name (default \"hbi\") - The string used to invoke the haskell program. - -haskell-use-right-delim (default \"\\\"\") -haskell-use-left-delim (default \"\\\"\") - The left and right delimiter used by your version of haskell, for - \"load file-name\". - -haskell-process-name (default \"Haskell\") - The name of the process running haskell. - -haskell-shell-prompt-pattern (default \"^> *\") - The prompt pattern. - -Runs haskell-shell-hook if not nil." - (interactive) - (if (not (process-status haskell-process-name)) - (save-excursion ; Process is not running - (message "Starting Haskell...") ; start up a new process - (require 'shell) - (set-buffer (make-comint haskell-process-name haskell-prog-name)) - (erase-buffer) ; Erase the buffer if a previous - (if haskell-shell-map ; process died in there - () - (setq haskell-shell-map (copy-keymap shell-mode-map)) - (define-key haskell-shell-map "\C-c\C-f" 'haskell-run-on-file)) - (use-local-map haskell-shell-map) - (make-local-variable 'shell-prompt-pattern) - (setq shell-prompt-pattern haskell-shell-prompt-pattern) - (setq major-mode 'haskell-shell) - (setq mode-name "Haskell Shell") - (setq mode-line-format - "-----Emacs: %17b %M %[(%m: %s)%]----%3p--%-") - (set-process-filter (get-process haskell-process-name) 'haskell-process-filter) - (message "Starting Haskell...done.") - (run-hooks 'haskell-shell-hook)))) - -(defun haskell-process-filter (proc str) - (let ((cur (current-buffer)) - (pop-up-windows t)) - (pop-to-buffer (concat "*" haskell-process-name "*")) - (goto-char (point-max)) - (if (string= str "\b\b\b \b\b\b") - (backward-delete-char 4) - (insert str)) - (set-marker (process-mark proc) (point-max)) - (pop-to-buffer cur))) - -(defun haskell-pop-to-shell () - (interactive) - (haskell-shell) - (pop-to-buffer (concat "*" haskell-process-name "*"))) - -(defun haskell-run-on-file (fil) - (interactive "FRun Haskell on : ") - (haskell-shell) - (save-some-buffers) - (process-send-string haskell-process-name - (concat "load " haskell-use-left-delim (expand-file-name fil) - haskell-use-right-delim ";\n"))) - -(defun haskell-save-buffer-use-file () - "Save the buffer, and send a `use file' to the inferior shell -running Haskell." - (interactive) - (let (file) - (if (setq file (buffer-file-name)) ; Is the buffer associated - (progn ; with file ? - (save-buffer) - (haskell-shell) - (process-send-string haskell-process-name - (concat "load " haskell-use-left-delim - (expand-file-name file) - haskell-use-right-delim ";\n"))) - (error "Buffer not associated with file.")))) - -(defvar haskell-tmp-files-list nil - "List of all temporary files created by haskell-simulate-send-region. -Each element in the list is a list with the format: - - (\"tmp-filename\" buffer start-line)") - -(defvar haskell-simulate-send-region-called-p nil - "Has haskell-simulate-send-region been called previously.") - -(defun haskell-make-temp-name (pre) - (concat (make-temp-name pre) ".m")) - -(defun haskell-simulate-send-region (point1 point2) - "Simulate send region. As send-region only can handle what ever the -system sets as the default, we have to make a temporary file. -Updates the list of temporary files (haskell-tmp-files-list)." - (let ((file (expand-file-name (haskell-make-temp-name haskell-tmp-template)))) - ;; Remove temporary files when we leave emacs - (if (not haskell-simulate-send-region-called-p) - (progn - (setq haskell-old-kill-emacs-hook kill-emacs-hook) - (setq kill-emacs-hook 'haskell-remove-tmp-files) - (setq haskell-simulate-send-region-called-p t))) - (save-excursion - (goto-char point1) - (setq haskell-tmp-files-list - (cons (list file - (current-buffer) - (save-excursion ; Calculate line no. - (beginning-of-line) - (1+ (count-lines 1 (point))))) - haskell-tmp-files-list))) - (write-region point1 point2 file nil 'dummy) - (haskell-shell) - (message "Using temporary file: %s" file) - (process-send-string - haskell-process-name - ;; string to send: load file; - (concat "load " haskell-use-left-delim file haskell-use-right-delim ";\n")))) - -(defun haskell-remove-tmp-files () - "Remove the temporary files, created by haskell-simulate-send-region, if -they still exist. Only files recorded in haskell-tmp-files-list are removed." - (message "Removing temporary files created by haskell-mode...") - (while haskell-tmp-files-list - (condition-case () - (delete-file (car (car haskell-tmp-files-list))) - (error ())) - (setq haskell-tmp-files-list (cdr haskell-tmp-files-list))) - (message "Removing temporary files created by haskell-mode...done.") - (run-hooks 'haskell-old-kill-emacs-hook)) - -(defun haskell-send-region () - "Send region." - (interactive) - (let (start end) - (save-excursion - (setq end (point)) - (exchange-point-and-mark) - (setq start (point))) - (haskell-simulate-send-region start end))) - -(defun haskell-send-buffer () - "Send the buffer." - (interactive) - (haskell-simulate-send-region (point-min) (point-max))) - -(defun haskell-evaluate-expression (h-expr) - "Prompt for and evaluate an expression" - (interactive "sExpression: ") - (let ((str (concat h-expr ";\n")) - (buf (current-buffer))) - (haskell-pop-to-shell) - (insert str) - (process-send-string haskell-process-name str) - (pop-to-buffer buf))) - - -;; -;; font-lock-mode patterns, based on specs. in an earlier version -;; of haskell-mode.el -;; (these patterns have only been tested with 19.30) - -(defconst haskell-font-lock-keywords nil - "Conservative highlighting of a Haskell buffer -(using font-lock.)") - -(let ((haskell-id "[a-z_][a-zA-Z0-9_'#]+") - (haskell-reserved-ids - (concat "\\b\\(" - (mapconcat - 'identity - '("case" "class" "data" - "default" "deriving" "else" - "hiding" "if" "import" "in" - "instance" "interface" "let" - "module" "of" "renaming" - "then" "to" "type" "where" "infix[rl]?") - "\\|") - "\\)[ \t\n:,]")) - (haskell-basic-types - (concat "\\b\\(" - (mapconcat 'identity - '("Bool" "()" "String" "Char" "Int" - "Integer" "Float" "Double" "Ratio" - "Assoc" "Rational" "Array") - "\\|") - "\\)\\b")) - (haskell-prelude-classes - (concat "\\b\\(" - (mapconcat 'identity - '("Eq" "Ord" "Text" "Num" "Real" "Fractional" - "Integral" "RealFrac" "Floating" "RealFloat" - "Complex" "Ix" "Enum" - ;; ghc-isms - "_CCallable" "_CReturnable") - "\\|") - "\\)\\b")) - (haskell-reserved-ops - (mapconcat 'identity - '("\\.\\." "::" - "=>" "/=" "@" - "<-" "->") - "\\|")) - (glasgow-haskell-ops - (concat "\\b\\(" - (mapconcat - 'identity - '(">>" ">>=" "thenPrimIO" - "seqPrimIO" "returnPrimIO" - "return" "_ccall_" "_casm_" - "thenST" "seqST" "returnST" - "thenStrictlyST" "seqStrictlyST" "returnStrictlyST" - "unsafeInterleavePrimIO" "unsafePerformIO") - "\\|") - "\\)\\b")) - (glasgow-haskell-types - (concat "\\b\\(" - (mapconcat - 'identity - '("IO" "PrimIO" "_?ST" - "_Word" "_Addr" "_?MVar" - "_?IVar" "_RealWorld" - "_?MutableByteArray" - "_?ByteArray") - "\\|") - "\\)\\b"))) - (setq haskell-font-lock-keywords - (list - '("--.*$" . font-lock-comment-face) - (list "[ \t\n]*\\([A-Za-z[(_][]A-Za-z0-9_$', ~@|:[)(#]*[ \t\n]*\\)=" 1 font-lock-function-name-face) - (list (concat "^>?[ \t\n]*\\(" haskell-id "\\)[ \t]*::") 1 'font-lock-function-name-face) - (list haskell-reserved-ids 0 'font-lock-function-name-face) - (list glasgow-haskell-ops 0 'font-lock-function-name-face) - (list glasgow-haskell-types 0 'font-lock-type-face) - (list haskell-basic-types 0 'font-lock-type-face) - (list haskell-prelude-classes 0 'font-lock-type-face) - (list "^[ \t\n]*\\([A-Za-z[(_][]A-Za-z0-9_$', @:[)(#]*[ \t\n]*\\)->" 1 font-lock-variable-name-face) - ))) - -;; -;; To enable font-lock-mode for Haskell buffers, add something -;; like this to your ~/.emacs - -;(cond (window-system -; (require 'font-lock) -; (add-hook 'haskell-mode-hook -; '(lambda () (make-local-variable 'font-lock-defaults) -; (make-local-variable 'font-lock-mode-hook) ; don't affect other buffers -; (setq font-lock-mode-hook nil) -; (add-hook 'font-lock-mode-hook -; '(lambda () -; (setq font-lock-keywords haskell-font-lock-keywords))) -; (font-lock-mode 1)))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; -;;;; END OF Haskell-MODE -;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(provide 'haskell-mode) diff --git a/ghc/CONTRIB/haskell-modes/chalmers/thiemann/haskell-mode.el b/ghc/CONTRIB/haskell-modes/chalmers/thiemann/haskell-mode.el deleted file mode 100644 index e900f01a76..0000000000 --- a/ghc/CONTRIB/haskell-modes/chalmers/thiemann/haskell-mode.el +++ /dev/null @@ -1,764 +0,0 @@ -;; haskell-mode.el. Major mode for editing Haskell. -;; Copyright (C) 1989, Free Software Foundation, Inc., Lars Bo Nielsen -;; and Lennart Augustsson -;; modified by Peter Thiemann, March 1994 - -;; This file is not officially part of GNU Emacs. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY. No author or distributor -;; accepts responsibility to anyone for the consequences of using it -;; or for whether it serves any particular purpose or works at all, -;; unless he says so in writing. Refer to the GNU Emacs General Public -;; License for full details. - -;; Everyone is granted permission to copy, modify and redistribute -;; GNU Emacs, but only under the conditions described in the -;; GNU Emacs General Public License. A copy of this license is -;; supposed to have been given to you along with GNU Emacs so you -;; can know your rights and responsibilities. It should be in a -;; file named COPYING. Among other things, the copyright notice -;; and this notice must be preserved on all copies. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Haskell Mode. A major mode for editing and running Haskell. (Version 0.0) -;; ================================================================= -;; -;; This is a mode for editing and running Haskell. -;; It is very much based on the sml mode for GNU Emacs. It -;; features: -;; -;; - Inferior shell running Haskell. No need to leave emacs, just -;; keep right on editing while Haskell runs in another window. -;; -;; - Automatic "load file" in inferior shell. Send regions of code -;; to the Haskell program. -;; -;; -;; 1. HOW TO USE THE Haskell-MODE -;; ========================== -;; -;; Here is a short introduction to the mode. -;; -;; 1.1 GETTING STARTED -;; ------------------- -;; -;; If you are an experienced user of Emacs, just skip this section. -;; -;; To use the haskell-mode, insert this in your "~/.emacs" file (Or ask your -;; emacs-administrator to help you.): -;; -;; (setq auto-mode-alist (cons '("\\.hs$" . haskell-mode) (cons '("\\.lhs$" . haskell-mode) -;; auto-mode-alist))) -;; (autoload 'haskell-mode "haskell-mode" "Major mode for editing Haskell." t) -;; -;; Now every time a file with the extension `.hs' or `.lhs' is found, it is -;; automatically started up in haskell-mode. -;; -;; You will also have to specify the path to this file, so you will have -;; to add this as well: -;; -;; (setq load-path (cons "/usr/me/emacs" load-path)) -;; -;; where "/usr/me/emacs" is the directory where this file is. -;; -;; You may also want to compile the this file (M-x byte-compile-file) -;; for speed. -;; -;; You are now ready to start using haskell-mode. If you have tried other -;; language modes (like lisp-mode or C-mode), you should have no -;; problems. There are only a few extra functions in this mode. -;; -;; 1.2. EDITING COMMANDS. -;; ---------------------- -;; -;; The following editing and inferior-shell commands can ONLY be issued -;; from within a buffer in haskell-mode. -;; -;; LFD (haskell-newline-and-indent). -;; This is probably the function you will be using the most (press -;; CTRL while you press Return, press C-j or press Newline). It -;; makes a new line and performs indentation based on the last -;; preceding non-comment line. -;; -;; M-; (indent-for-comment). -;; Like in other language modes, this command will give you a comment -;; at the of the current line. The column where the comment starts is -;; determined by the variable comment-column (default: 40). -;; -;; C-c C-v (haskell-mode-version). -;; Get the version of the haskell-mode. -;; -;; -;; 1.3. COMMANDS RELATED TO THE INFERIOR SHELL -;; ------------------------------------------- -;; -;; C-c C-s (haskell-pop-to-shell). -;; This command starts up an inferior shell running haskell. If the shell -;; is running, it will just pop up the shell window. -;; -;; C-c C-u (haskell-save-buffer-use-file). -;; This command will save the current buffer and send a "load file", -;; where file is the file visited by the current buffer, to the -;; inferior shell running haskell. -;; -;; C-c C-f (haskell-run-on-file). -;; Will send a "load file" to the inferior shell running haskell, -;; prompting you for the file name. -;; -;; C-c C-r (haskell-send-region). -;; Will send region, from point to mark, to the inferior shell -;; running haskell. -;; -;; C-c C-b (haskell-send-buffer). -;; Will send whole buffer to inferior shell running haskell. -;; -;; 2. INDENTATION -;; ================ -;; -;; The first indentation command (using C-j or TAB) on a given line -;; indents like the last preceding non-comment line. The next TAB -;; indents to the indentation of the innermost enclosing scope. Further -;; TABs get you to further enclosing scopes. After indentation has -;; reached the first column, the process restarts using the indentation -;; of the preceding non-comment line, again. -;; -;; 3. INFERIOR SHELL. -;; ================== -;; -;; The mode for Standard ML also contains a mode for an inferior shell -;; running haskell. The mode is the same as the shell-mode, with just one -;; extra command. -;; -;; 3.1. INFERIOR SHELL COMMANDS -;; ---------------------------- -;; -;; C-c C-f (haskell-run-on-file). Send a `load file' to the process running -;; haskell. -;; -;; 3.2. CONSTANTS CONTROLLING THE INFERIOR SHELL MODE -;; -------------------------------------------------- -;; -;; Because haskell is called differently on various machines, and the -;; haskell-systems have their own command for reading in a file, a set of -;; constants controls the behavior of the inferior shell running haskell (to -;; change these constants: See CUSTOMIZING YOUR Haskell-MODE below). -;; -;; haskell-prog-name (default "hbi"). -;; This constant is a string, containing the command to invoke -;; Standard ML on your system. -;; -;; haskell-use-right-delim (default "\"") -;; haskell-use-left-delim (default "\"") -;; The left and right delimiter used by your version of haskell, for -;; `use file-name'. -;; -;; haskell-process-name (default "Haskell"). -;; The name of the process running haskell. (This will be the name -;; appearing on the mode line of the buffer) -;; -;; NOTE: The haskell-mode functions: haskell-send-buffer, haskell-send-function and -;; haskell-send-region, creates temporary files (I could not figure out how -;; to send large amounts of data to a process). These files will be -;; removed when you leave emacs. -;; -;; 4. FONTIFICATION -;; -;; There is support for Jamie Zawinski's font-lock-mode through the -;; variable "haskell-font-lock-keywords". -;; -;; 5. CUSTOMIZING YOUR Haskell-MODE -;; ============================ -;; -;; If you have to change some of the constants, you will have to add a -;; `hook' to the haskell-mode. Insert this in your "~/.emacs" file. -;; -;; (setq haskell-mode-hook 'my-haskell-constants) -;; -;; Your function "my-haskell-constants" will then be executed every time -;; "haskell-mode" is invoked. Now you only have to write the emacs-lisp -;; function "my-haskell-constants", and put it in your "~/.emacs" file. -;; -;; Say you are running a version of haskell that uses the syntax `load -;; ["file"]', is invoked by the command "OurHaskell" and you don't want the -;; indentation algorithm to indent according to open parenthesis, your -;; function should look like this: -;; -;; (defun my-haskell-constants () -;; (setq haskell-prog-name "OurHaskell") -;; (setq haskell-use-left-delim "[\"") -;; (setq haskell-use-right-delim "\"]") -;; (setq haskell-paren-lookback nil)) -;; -;; The haskell-shell also runs a `hook' (haskell-shell-hook) when it is invoked. -;; -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; -;; ORIGINAL AUTHOR -;; Lars Bo Nielsen -;; Aalborg University -;; Computer Science Dept. -;; 9000 Aalborg -;; Denmark -;; -;; lbn@iesd.dk -;; or: ...!mcvax!diku!iesd!lbn -;; or: mcvax!diku!iesd!lbn@uunet.uu.net -;; -;; MODIFIED FOR Haskell BY -;; Lennart Augustsson -;; indentation stuff by Peter Thiemann -;; -;; -;; Please let me know if you come up with any ideas, bugs, or fixes. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconst haskell-mode-version-string - "HASKELL-MODE, Version 0.2, PJT indentation") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; CONSTANTS CONTROLLING THE MODE. -;;; -;;; These are the constants you might want to change -;;; - -;; The command used to start up the haskell-program. -(defconst haskell-prog-name "hbi" "*Name of program to run as haskell.") - -;; The left delimmitter for `load file' -(defconst haskell-use-left-delim "\"" - "*The left delimiter for the filename when using \"load\".") - -;; The right delimmitter for `load file' -(defconst haskell-use-right-delim "\"" - "*The right delimiter for the filename when using \"load\".") - -;; A regular expression matching the prompt pattern in the inferior -;; shell -(defconst haskell-shell-prompt-pattern "^> *" - "*The prompt pattern for the inferion shell running haskell.") - -;; The template used for temporary files, created when a region is -;; send to the inferior process running haskell. -(defconst haskell-tmp-template "/tmp/haskell.tmp." - "*Template for the temporary file, created by haskell-simulate-send-region.") - -;; The name of the process running haskell (This will also be the name of -;; the buffer). -(defconst haskell-process-name "Haskell" "*The name of the Haskell-process") - -;;; -;;; END OF CONSTANTS CONTROLLING THE MODE. -;;; -;;; If you change anything below, you are on your own. -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(defvar haskell-mode-syntax-table nil "The syntax table used in haskell-mode.") - -(defvar haskell-mode-map nil "The mode map used in haskell-mode.") - -(defvar haskell-mode-abbrev-table nil "The abbrev-table used in haskell-mode.") - -(defvar haskell-old-kill-emacs-hook nil "Old value of kill-emacs-hook") - -(defun haskell-mode () - "Major mode for editing Haskell code. -Tab indents for Haskell code. -Comments are delimited with -- -Paragraphs are separated by blank lines only. -Delete converts tabs to spaces as it moves back. - -Key bindings: -============= - -\\[haskell-pop-to-shell]\t Pop to the haskell window. -\\[haskell-save-buffer-use-file]\t Save the buffer, and send a \"load file\". -\\[haskell-send-region]\t Send region (point and mark) to haskell. -\\[haskell-run-on-file]\t Send a \"load file\" to haskell. -\\[haskell-send-buffer]\t Send whole buffer to haskell. -\\[haskell-mode-version]\t Get the version of haskell-mode. -\\[haskell-evaluate-expression]\t Prompt for an expression and evalute it. - - -Mode map -======== -\\{haskell-mode-map} -Runs haskell-mode-hook if non nil." - (interactive) - (kill-all-local-variables) - (if haskell-mode-map - () - (setq haskell-mode-map (make-sparse-keymap)) - (define-key haskell-mode-map "\C-c\C-v" 'haskell-mode-version) - (define-key haskell-mode-map "\C-c\C-u" 'haskell-save-buffer-use-file) - (define-key haskell-mode-map "\C-c\C-s" 'haskell-pop-to-shell) - (define-key haskell-mode-map "\C-c\C-r" 'haskell-send-region) - (define-key haskell-mode-map "\C-c\C-m" 'haskell-region) - (define-key haskell-mode-map "\C-c\C-f" 'haskell-run-on-file) - (define-key haskell-mode-map "\C-c\C-b" 'haskell-send-buffer) - (define-key haskell-mode-map "\C-ce" 'haskell-evaluate-expression) - (define-key haskell-mode-map "\C-j" 'haskell-newline-and-indent) - (define-key haskell-mode-map "\177" 'backward-delete-char-untabify)) - (use-local-map haskell-mode-map) - (setq major-mode 'haskell-mode) - (setq mode-name "Haskell") - (define-abbrev-table 'haskell-mode-abbrev-table ()) - (setq local-abbrev-table haskell-mode-abbrev-table) - (if haskell-mode-syntax-table - () - (setq haskell-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?{ "(}1" haskell-mode-syntax-table) - (modify-syntax-entry ?} "){4" haskell-mode-syntax-table) -; partain: out -; (modify-syntax-entry ?- "_ 2356" haskell-mode-syntax-table) -; (modify-syntax-entry ?\f "> b" haskell-mode-syntax-table) -; (modify-syntax-entry ?\n "> b" haskell-mode-syntax-table) -; partain: end out -; partain: in - (modify-syntax-entry ?- "_ 23" haskell-mode-syntax-table) -; (modify-syntax-entry ?\f "> b" haskell-mode-syntax-table) -; (modify-syntax-entry ?\n "> b" haskell-mode-syntax-table) -; partain: end in - (modify-syntax-entry ?\\ "\\" haskell-mode-syntax-table) - (modify-syntax-entry ?* "_" haskell-mode-syntax-table) - (modify-syntax-entry ?_ "_" haskell-mode-syntax-table) - (modify-syntax-entry ?' "_" haskell-mode-syntax-table) - (modify-syntax-entry ?: "_" haskell-mode-syntax-table) - (modify-syntax-entry ?| "." haskell-mode-syntax-table) - ) - (set-syntax-table haskell-mode-syntax-table) - (make-local-variable 'require-final-newline) ; Always put a new-line - (setq require-final-newline t) ; in the end of file - (make-local-variable 'indent-line-function) - (setq indent-line-function 'haskell-indent-line) - (make-local-variable 'comment-start) - (setq comment-start "-- ") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column 60) ; Start of comment in this column - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "--[^a-zA-Z0-9]*") ; This matches a start of comment - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'haskell-comment-indent) - ;; - ;; Adding these will fool the matching of parens. I really don't - ;; know why. It would be nice to have comments treated as - ;; white-space - ;; - ;; (make-local-variable 'parse-sexp-ignore-comments) - ;; (setq parse-sexp-ignore-comments t) - ;; - (run-hooks 'haskell-mode-hook)) ; Run the hook - -(defun haskell-mode-version () - (interactive) - (message haskell-mode-version-string)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; INDENTATION -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; some variables for later use - -(defvar haskell-open-comment "{-") -(defvar haskell-close-comment "-}") -(defvar haskell-indentation-counter 0 - "count repeated invocations of indent-for-tab-command") -(defvar haskell-literate-flag nil - "used to guide literate/illiterate behavior, set automagically") - -(defun haskell-newline-and-indent () - (interactive) - (setq haskell-literate-flag - (save-excursion - (beginning-of-line) - (= (following-char) ?>))) - (newline) - (if haskell-literate-flag (insert ">")) - (haskell-indent-line)) - -(defun haskell-indent-line () - "Indent current line of ordinary or literate Haskell code." - (interactive) - (let ((indent (haskell-calculate-indentation-pjt-2))) - (if (/= (current-indentation) indent) - (let ((beg (progn - (beginning-of-line) - (if (= (following-char) ?>) (forward-char 1)) ;LITERATE - (point)))) - (skip-chars-forward "\t ") - (delete-region beg (point)) - (indent-to indent)) - ;; If point is before indentation, move point to indentation - (if (< (current-column) (current-indentation)) - (skip-chars-forward "\t "))))) - -(defun haskell-calculate-indentation () - (save-excursion - (let ((col (current-column))) - (while (and (not (bobp)) ;skip over empty and comment-only lines - (= col (current-column))) - (previous-line 1) - (beginning-of-line) ; Go to first non whitespace - (if (= (following-char) ?>) ;LITERATE - (forward-char 1) - (if haskell-literate-flag ;ignore illiterate lines - (end-of-line))) - (skip-chars-forward "\t ") ; on the line. - (setq col (current-column)) - (search-forward-regexp (concat haskell-open-comment "\\|--\\|\n") nil 0) - (goto-char (match-beginning 0))) - (search-backward-regexp "\\b\\(where\\|let\\|of\\|in\\)\\b\\|\n" nil 0) - (if (looking-at "\n") - () - (setq col (current-column)) - (forward-word 1) - (skip-chars-forward "\t ") - (if (looking-at "\\w") - (setq col (current-column)) - (setq col (+ 2 col)))) - col))) - -(defun haskell-calculate-indentation-pjt-2 () - "Calculate indentation for Haskell program code, versatile version" - (save-excursion - (if (eq last-command 'haskell-indentation) - (setq haskell-indentation-counter (1+ haskell-indentation-counter)) - (setq haskell-indentation-counter -1)) - (setq this-command 'haskell-indentation) - (let* ((simple-indent (haskell-calculate-indentation)) - (count haskell-indentation-counter) - (min-indent simple-indent) ; minimum indentation found in a non-comment line - (last-indent simple-indent) ; indentation of the following non-comment line - (return-indent nil) ; computed indentation - (comment-depth 0)) - (previous-line 1) - (if (< haskell-indentation-counter 0) ; 1st tab gives simple indentation - (setq return-indent simple-indent)) - (while (not return-indent) - (if (search-backward-regexp "\\b\\(where\\|let\\|of\\)\\b\\|\n\\|{-\\|-}" nil t 1) - (cond - ((looking-at haskell-open-comment) - (setq comment-depth (1- comment-depth))) - ((looking-at haskell-close-comment) - (setq comment-depth (1+ comment-depth))) - ((= 0 comment-depth) - (cond - ((looking-at "\n") - (save-excursion - (forward-char 1) - (if (= (following-char) ?>) - (forward-char 1) - (if haskell-literate-flag - (end-of-line))) ;LITERATE: ignore lines w/o > - (skip-chars-forward "\t ") - (if (looking-at (concat haskell-open-comment "\\|--\\|\n")) - () - (setq last-indent (current-column)) - (if (< last-indent min-indent) - (setq min-indent last-indent))))) - (t ; looking at a keyword - (save-excursion - (forward-word 1) - (skip-chars-forward " \t") - (if (and haskell-literate-flag ;LITERATE: ignore lines w/o > - (save-excursion - (beginning-of-line) - (/= (following-char) ?>))) - (end-of-line)) - (if (looking-at (concat haskell-open-comment "\\|--\\|\n")) - () - (setq last-indent (current-column))) - (if (<= last-indent min-indent) - (if (> count 0) - (setq count (1- count)) - (setq return-indent last-indent))) - (if (< last-indent min-indent) - (setq min-indent last-indent))))))) - (setq return-indent simple-indent) - (setq haskell-indentation-counter -1))) - return-indent))) - -(defun haskell-skip-nested-comment () - ;; point looks at opening {-, move over closing -} - ;; todo: specify what happens on failure, bounds check ... - (forward-char 2) - (let ((comment-depth 1)) - (while (> comment-depth 0) - (search-forward-regexp "{-\\|-}") - (goto-char (match-beginning 0)) - (setq comment-depth - (if (= (following-char) 123) ; code for opening brace - (1+ comment-depth) - (1- comment-depth))) - (goto-char (match-end 0))))) - - -;;;seemingly obsolete functions -(defun haskell-inside-of-inline-comment () - (let ((bolp (save-excursion - (beginning-of-line) - (point)))) - (search-backward comment-start bolp t 1))) - -(defun haskell-inside-of-nested-comment () - (save-excursion - (let ((count 0)) - (while - (search-backward-regexp "\\({-\\|-}\\)" 0 t 1) - (if (haskell-inside-of-inline-comment) - () - (if (looking-at haskell-open-comment) - (setq count (1+ count)) - (setq count (1- count))))) - (> count 0)))) - -(defun haskell-inside-of-comment () - (or (haskell-inside-of-inline-comment) - (haskell-inside-of-nested-comment))) - -;;;stolen from sml-mode.el -(defun haskell-comment-indent () - "Compute indentation for Haskell comments" - (if (looking-at "^--") - 0 - (save-excursion - (skip-chars-backward " \t") - (max (1+ (current-column)) - comment-column)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; INFERIOR SHELL -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar haskell-shell-map nil "The mode map for haskell-shell.") - -(defun haskell-shell () - "Inferior shell invoking Haskell. -It is not possible to have more than one shell running Haskell. -Like the shell mode with the additional command: - -\\[haskell-run-on-file]\t Runs haskell on the file. -\\{haskell-shell-map} -Variables controlling the mode: - -haskell-prog-name (default \"hbi\") - The string used to invoke the haskell program. - -haskell-use-right-delim (default \"\\\"\") -haskell-use-left-delim (default \"\\\"\") - The left and right delimiter used by your version of haskell, for - \"load file-name\". - -haskell-process-name (default \"Haskell\") - The name of the process running haskell. - -haskell-shell-prompt-pattern (default \"^> *\") - The prompt pattern. - -Runs haskell-shell-hook if not nil." - (interactive) - (if (not (process-status haskell-process-name)) - (save-excursion ; Process is not running - (message "Starting Haskell...") ; start up a new process - (require 'shell) - (set-buffer (make-comint haskell-process-name haskell-prog-name)) - (erase-buffer) ; Erase the buffer if a previous - (if haskell-shell-map ; process died in there - () - (setq haskell-shell-map (copy-keymap shell-mode-map)) - (define-key haskell-shell-map "\C-c\C-f" 'haskell-run-on-file)) - (use-local-map haskell-shell-map) - (make-local-variable 'shell-prompt-pattern) - (setq shell-prompt-pattern haskell-shell-prompt-pattern) - (setq major-mode 'haskell-shell) - (setq mode-name "Haskell Shell") - (setq mode-line-format - "-----Emacs: %17b %M %[(%m: %s)%]----%3p--%-") - (set-process-filter (get-process haskell-process-name) 'haskell-process-filter) - (message "Starting Haskell...done.") - (run-hooks 'haskell-shell-hook)))) - -(defun haskell-process-filter (proc str) - (let ((cur (current-buffer)) - (pop-up-windows t)) - (pop-to-buffer (concat "*" haskell-process-name "*")) - (goto-char (point-max)) - (if (string= str "\b\b\b \b\b\b") - (backward-delete-char 4) - (insert str)) - (set-marker (process-mark proc) (point-max)) - (pop-to-buffer cur))) - -(defun haskell-pop-to-shell () - (interactive) - (haskell-shell) - (pop-to-buffer (concat "*" haskell-process-name "*"))) - -(defun haskell-run-on-file (fil) - (interactive "FRun Haskell on : ") - (haskell-shell) - (save-some-buffers) - (process-send-string haskell-process-name - (concat "load " haskell-use-left-delim (expand-file-name fil) - haskell-use-right-delim ";\n"))) - -(defun haskell-save-buffer-use-file () - "Save the buffer, and send a `use file' to the inferior shell -running Haskell." - (interactive) - (let (file) - (if (setq file (buffer-file-name)) ; Is the buffer associated - (progn ; with file ? - (save-buffer) - (haskell-shell) - (process-send-string haskell-process-name - (concat "load " haskell-use-left-delim - (expand-file-name file) - haskell-use-right-delim ";\n"))) - (error "Buffer not associated with file.")))) - -(defvar haskell-tmp-files-list nil - "List of all temporary files created by haskell-simulate-send-region. -Each element in the list is a list with the format: - - (\"tmp-filename\" buffer start-line)") - -(defvar haskell-simulate-send-region-called-p nil - "Has haskell-simulate-send-region been called previously.") - -(defun haskell-make-temp-name (pre) - (concat (make-temp-name pre) ".m")) - -(defun haskell-simulate-send-region (point1 point2) - "Simulate send region. As send-region only can handle what ever the -system sets as the default, we have to make a temporary file. -Updates the list of temporary files (haskell-tmp-files-list)." - (let ((file (expand-file-name (haskell-make-temp-name haskell-tmp-template)))) - ;; Remove temporary files when we leave emacs - (if (not haskell-simulate-send-region-called-p) - (progn - (setq haskell-old-kill-emacs-hook kill-emacs-hook) - (setq kill-emacs-hook 'haskell-remove-tmp-files) - (setq haskell-simulate-send-region-called-p t))) - (save-excursion - (goto-char point1) - (setq haskell-tmp-files-list - (cons (list file - (current-buffer) - (save-excursion ; Calculate line no. - (beginning-of-line) - (1+ (count-lines 1 (point))))) - haskell-tmp-files-list))) - (write-region point1 point2 file nil 'dummy) - (haskell-shell) - (message "Using temporary file: %s" file) - (process-send-string - haskell-process-name - ;; string to send: load file; - (concat "load " haskell-use-left-delim file haskell-use-right-delim ";\n")))) - -(defun haskell-remove-tmp-files () - "Remove the temporary files, created by haskell-simulate-send-region, if -they still exist. Only files recorded in haskell-tmp-files-list are removed." - (message "Removing temporary files created by haskell-mode...") - (while haskell-tmp-files-list - (condition-case () - (delete-file (car (car haskell-tmp-files-list))) - (error ())) - (setq haskell-tmp-files-list (cdr haskell-tmp-files-list))) - (message "Removing temporary files created by haskell-mode...done.") - (run-hooks 'haskell-old-kill-emacs-hook)) - -(defun haskell-send-region () - "Send region." - (interactive) - (let (start end) - (save-excursion - (setq end (point)) - (exchange-point-and-mark) - (setq start (point))) - (haskell-simulate-send-region start end))) - -(defun haskell-send-buffer () - "Send the buffer." - (interactive) - (haskell-simulate-send-region (point-min) (point-max))) - -(defun haskell-evaluate-expression (h-expr) - "Prompt for and evaluate an expression" - (interactive "sExpression: ") - (let ((str (concat h-expr ";\n")) - (buf (current-buffer))) - (haskell-pop-to-shell) - (insert str) - (process-send-string haskell-process-name str) - (pop-to-buffer buf))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; keywords for jwz's font-look-mode (lemacs 19) -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(setq haskell-font-lock-keywords - (list (concat "\\b\\(" - (mapconcat 'identity - '("case" "class" "data" "default" "deriving" "else" "hiding" - "if" "import" "in" "infix" "infixl" "infixr" "instance" - "interface" "let" "module" "of" "renaming" "then" "to" - "type" "where") - "\\|") - "\\)\\b") - (list "^\\(#[ \t]*\\(if\\|ifdef\\|ifndef\\|else\\|endif\\|include\\)\\)") - (list "\\(^>?\\|\\bwhere\\b\\|\\blet\\b\\)[ \t]*\\(\\(\\w\\|\\s_\\)+\\)\\(\\([^=\n]*\\S.\\)?=\\(\\S.\\|$\\)\\|[ \t]*::\\S.\\).*$" - 2 'font-lock-function-name-face) - (list "\\b\\(data\\|type\\)\\b[ \t]+\\(\\(\\w\\|\\s_\\)+\\)" - 2 'font-lock-type-face) - (list (concat "'\\([^\\]\\|\\\\\\([0-9]+\\|" - (mapconcat 'identity - '("a" "b" "f" "n" "r" "t" "v" "\\\\" "\"" "'" "&") - "\\|") - "\\|\\^\\([][_^A-Z@\\\\]\\)" - "\\)\\)'") 1 'font-lock-string-face))) - -;;; font-lock-keywords for literate style files - -(setq haskell-font-lock-keywords-2 - (list (concat "^>.*\\b\\(" - (mapconcat 'identity - '("case" "class" "data" "default" "deriving" "else" "hiding" - "if" "import" "in" "infix" "infixl" "infixr" "instance" - "interface" "let" "module" "of" "renaming" "then" "to" - "type" "where") - "\\|") - "\\)\\b") - (list "^>\\(.*\\(\\bwhere\\b\\|\\blet\\b\\)\\|\\)[ \t]*\\(\\(\\w\\|\\s_\\)+\\)\\(\\([^=\n]*\\S.\\)?=\\(\\S.\\|$\\)\\|[ \t]*::\\S.\\).*$" - 3 'font-lock-function-name-face) - (list "^>.*\\b\\(data\\|type\\)\\b[ \t]+\\(\\(\\w\\|\\s_\\)+\\)" - 2 'font-lock-type-face) - (list (concat "^>.*'\\([^\\]\\|\\\\\\([0-9]+\\|" - (mapconcat 'identity - '("a" "b" "f" "n" "r" "t" "v" "\\\\" "\"" "'" "&") - "\\|") - "\\|\\^\\([][_^A-Z@\\\\]\\)" - "\\)\\)'") 1 'font-lock-string-face))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; END OF Haskell-MODE -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(provide 'haskell-mode) diff --git a/ghc/CONTRIB/haskell-modes/glasgow/original/haskell-mode.el b/ghc/CONTRIB/haskell-modes/glasgow/original/haskell-mode.el deleted file mode 100644 index b9a490ffd1..0000000000 --- a/ghc/CONTRIB/haskell-modes/glasgow/original/haskell-mode.el +++ /dev/null @@ -1,1935 +0,0 @@ -;; Haskell major mode -;; (c) Copyright, Richard McPhee et al. -;; University of Glasgow, February 1993 - - - -;; if .hs is not recognised then put the extension in auto-mode-list - -(if (assoc "\\.hs" auto-mode-alist) - nil - (nconc auto-mode-alist '(("\\.hs". haskell-mode)))) - -(if (assoc "\\.hi" auto-mode-alist) - nil - (nconc auto-mode-alist '(("\\.hi". haskell-mode)))) - -(if (assoc "\\.gs" auto-mode-alist) - nil - (nconc auto-mode-alist '(("\\.gs". haskell-mode)))) - -(defvar haskell-mode-syntax-table nil - "Syntax table for haskell-mode buffers.") - -(defvar haskell-mode-abbrev-table nil - "Abbrev table for haskell-mode buffers.") - -(defvar haskell-mode-map (make-sparse-keymap) - "Keymap for haskell-mode-buffers.") - - - -;;; Here are the keymaps used in haskell-mode - -(define-key haskell-mode-map "\M-;" 'haskell-insert-comment) -(define-key haskell-mode-map "\C-c=" 'haskell-insert-concat) -(define-key haskell-mode-map "\C-c;" 'set-haskell-comment-column) -(define-key haskell-mode-map "\C-c+" 'set-haskell-concat-column) -(define-key haskell-mode-map "\C-cn" 'set-haskell-indent-offset) -(define-key haskell-mode-map "\C-cl" 'set-haskell-list-offset) -(define-key haskell-mode-map "\C-ci" 'set-haskell-if-offset) -(define-key haskell-mode-map "\C-ce" 'set-haskell-let-offset) -(define-key haskell-mode-map "\C-cc" 'set-haskell-case-offset) -(define-key haskell-mode-map "\C-ct" 'set-haskell-then-offset) -(define-key haskell-mode-map "\C-co" 'set-haskell-comp-offset) -(define-key haskell-mode-map "\C-cw" 'set-haskell-where-offset) -(define-key haskell-mode-map "\C-cg" 'goto-line) -(define-key haskell-mode-map "\C-j" 'haskell-reindent-then-newline-and-indent) -(define-key haskell-mode-map "\t" 'haskell-indent-line) -(define-key haskell-mode-map "}" 'electric-haskell-brace) -(define-key haskell-mode-map "]" 'electric-haskell-brace) -(define-key haskell-mode-map ")" 'haskell-insert-round-paren) -(define-key haskell-mode-map "\C-cr" 'haskell-indent-region) -(define-key haskell-mode-map "\C-cf" 'haskell-further-indent) -(define-key haskell-mode-map "\C-cb" 'haskell-lesser-indent) -(define-key haskell-mode-map "\177" 'backward-delete-char-untabify) -(define-key haskell-mode-map "\M-\C-\177" 'delete-horizontal-space) - -(defun haskell-set-local-vars () - "Set the local variables for haskell-mode." - (kill-all-local-variables) - - (setq indent-line-function 'haskell-indent-line) - - (make-local-variable 'haskell-std-list-indent) - ;;Non-nil means indent to the offset, 'haskell-list-offset' in a bracket rather than - ;; moving to the next word afer a function name - (setq haskell-std-list-indent t) - - (make-local-variable 'haskell-nest-ifs) - ;;Non-nil means that 'if' statements are nested ie. lined up with `if' not `else'. - (setq haskell-nest-ifs nil) - - (make-local-variable 'haskell-align-else-with-then) - ;;Non-nil means align an `else' under it's corresponding `then' - (setq haskell-align-else-with-then nil) - - - ;;The local vars for 'where' indentation - - (make-local-variable 'haskell-align-where-with-eq) - ;;Non-nil means align a 'where' under it's corresponding equals sign - (setq haskell-align-where-with-eq t) - - (make-local-variable 'haskell-align-where-after-eq) - ;;Non-nil means align a 'where' after it's corresponding equals sign - (setq haskell-align-where-after-eq nil) - - (make-local-variable 'haskell-std-indent-where) - ;;put the 'where' the standard offset ie. 'haskell-indent-offset' - (setq haskell-std-indent-where nil) - - - (make-local-variable 'haskell-always-fixup-comment-space) - ;;Non-nil means always insert a (single) space after a comment, even - ;; if there is more or less than one. - (setq haskell-always-fixup-comment-space t) - - - (make-local-variable 'haskell-indent-offset) - ;;Extra indentation for a line continued after a keyword. - (setq haskell-indent-offset 4) - - (make-local-variable 'haskell-list-offset) - ;;Extra indentation for continuing a list. - (setq haskell-list-offset 4) - - (make-local-variable 'haskell-comp-offset) - ;;Extra indentation for a list comprehension. - (setq haskell-comp-offset 4) - - (make-local-variable 'haskell-case-offset) - (setq haskell-case-offset 4) - - (make-local-variable 'haskell-where-offset) - (setq haskell-where-offset 4) - - (make-local-variable 'haskell-let-offset) - (setq haskell-let-offset 4) - - (make-local-variable 'haskell-then-offset) - (setq haskell-then-offset 0) - - (make-local-variable 'haskell-if-offset) - (setq haskell-if-offset 4) - - (make-local-variable 'haskell-comment-column) - (setq haskell-comment-column 35) - - (make-local-variable 'haskell-concat-column) - (setq haskell-concat-column 69) - - (make-local-variable 'haskell-where-threshold) - (setq haskell-where-threshold 35) - - (make-local-variable 'line-comment) - (setq line-comment "-- ") - - (make-local-variable 'haskell-indent-style) - (setq haskell-indent-style "none")) - - -(defun haskell-set-syntax-table () - "Set the syntax table for Haskell-mode." - (setq haskell-mode-syntax-table (make-syntax-table)) - (set-syntax-table haskell-mode-syntax-table) - (modify-syntax-entry ?\" "\"") - (modify-syntax-entry ?\\ "\\") - (modify-syntax-entry ?\' "w") - (modify-syntax-entry ?_ "w") - (modify-syntax-entry ?# "_") - (modify-syntax-entry ?$ "_") - (modify-syntax-entry ?% "_") - (modify-syntax-entry ?: "_") - (modify-syntax-entry ?? "_") - (modify-syntax-entry ?@ "_") - (modify-syntax-entry ?! "_") - (modify-syntax-entry ?^ "_") - (modify-syntax-entry ?~ "_") - (modify-syntax-entry ?- "_ 12") - (modify-syntax-entry ?\n ">") - (modify-syntax-entry ?{ "(}") - (modify-syntax-entry ?} "){") - (set-syntax-table haskell-mode-syntax-table)) - - - -(defun haskell-mode () - "Major mode for editing Haskell code. -Linefeed reindents current line, takes newline and indents. -Tab indents current line for Haskell code. -Functions are seperated by blank lines. -Delete converts tabs to spaces as it moves back. -\\{haskell-mode-map} -Variables controlling indentation style: - haskell-indent-offset - Standard extra indentation for continuing Haskell - code under the scope of an expression. The default is 4. - - haskell-list-offset - Extra indentation for indenting in a list. Used if variable - haskell-std-list-indent is non-nil. The default is 4. - - haskell-comp-offset - Extra indentation for continuing a list comprehension. - The default is 4. - - haskell-case-offset - Standard extra indentation for continuing Haskell - code under the scope of an expression. The default is 4. - - haskell-where-offset - Standard extra indentation for continuing Haskell - code under the scope of a `where'. The default is 4. - - haskell-let-offset - Standard extra indentation for continuing Haskell - code under the scope of a `let'. The default is 4. - - haskell-then-offset - Standard extra indentation for a `then' beyond - its corresponding `if'. The default is 0. - - haskell-if-offset - Standard extra indentation for continuing Haskell - code under the scope of an `if'. The default is 4. - - haskell-comment-column - Column to which line comments `--' will be inserted. - The default is 35. - - haskell-concat-column - Column to which concatenation operator `++' will be inserted. - The default is 69. - - haskell-where-threshold - Column beyond which a `where' will be indented to the - start of a line (to avoid spilling over lines). - The default is 35. - - set-haskell-indent-offset (C-c i) - Changes the default value of the local variable, - haskell-indent-offset. May be a number from 0-10. - - set-haskell-list-indent (C-c l) - Change the value of the local variable, - haskell-list-offset. May be a number from 0-100. - - set-haskell-comment-column (C-x ;) - Changes the value of the local variable, - haskell-comment-column. May be any number from 0-100." - - (interactive) - (haskell-set-local-vars) - (haskell-set-syntax-table) - (use-local-map haskell-mode-map) - (setq major-mode 'haskell-mode) - (setq mode-name "Haskell") - (define-abbrev-table 'haskell-mode-abbrev-table ())) - - - - -;;; Returns the indentation column for a comment on this line. -;;; The point is positioned at the last char of any code on the line. - -(defun haskell-comment-indent () - "Returns the indentation for a comment on the given line. -If the line has code on it or the point is not at the beginning of the line, -then indent to indent-column. -Otherwise, don't indent." - (cond ((or (haskell-code-on-linep) - (not (bolp))) - ;;There is code before the haskell-comment-column - ;; or not at the beginning of the line - ;;Return the largest of - ;; the current column +1 and the haskell-comment-column - (max (1+ (current-column)) - haskell-comment-column)) - (t - ;;Otherwise, return 0 - 0))) - - - -;;; Returns whether a comment is on the current line -;;; Search from bol, and beware of "--", {-- etc! -;;; DOES NOT RECOGNISE {- COMMENTS YET or -- within a string - -(defun haskell-comment-on-linep () - "Returns the truth value of whether there is a '--' comment on the current line." - (save-excursion - (beginning-of-line) - (looking-at ".*--"))) - - -;;; This doesn't account for comments '{-'. Test explicitly if you use this function! - -(defun haskell-code-on-linep () - "Returns a truth value as to whether there is code on the current line." - (save-excursion - (beginning-of-line) - (not - ;; Code on line if not looking at a comment directly - ;; and the line is not blank - (or - (looking-at "^[ \t]*--") - (looking-at "^[ \t]*$"))))) - - -;;; Insert a Haskell "--" comment on the current line. -;;; Move to the comment position if there's already a comment here. -;;; Otherwise, the comment is inserted either at the comment column -;;; or one column after the last non-space character, whichever is further -;;; to the right. -;;; This function is executed by M-; - -(defun haskell-insert-comment () - "Inserts a '--' comment on the given line." - (interactive) - (cond ((haskell-comment-on-linep) - ;;There is a comment on the line - ;;Just reindent existing comment - (haskell-reindent-comment)) - (t - (if (haskell-code-on-linep) - ;;There is code on the line - ;; and guarenteed that a comment - ;; does not already exist. - ;;Move to the last nonspace char - ;; (there may be spaces after the last char) - (progn - (end-of-line) - (skip-chars-backward " \t"))) - ;;Indent to required level - ;; and insert the line comment '--' - (indent-to (haskell-comment-indent)) - (insert line-comment)))) - - -;;; Reindents a comment. -;;; The comment is indented according to the normal rules. -;;; Skips over ---- and following spaces or tabs - -(defun haskell-reindent-comment () - "Indents a comment on a line to keep it at haskell-comment-column, -if possible. -It is guaranteed that a comment exists on the current line." - (beginning-of-line) - ;;Go back to beginning of comment - (re-search-forward "--") - (forward-char -2) - ;;Delete all spaces and reindent to - ;; the correct location. - (delete-horizontal-space) - (indent-to (haskell-comment-indent)) - ;;Move past the comment and insert - ;; only one space between it and the text. - ;;Leave point just after comment. - (skip-chars-forward "- \t") - (if haskell-always-fixup-comment-space - (progn - (fixup-whitespace) - (forward-char 1)))) - - - -;;; Inserts a haskell concatenation operator, `++', at the -;;; column dictated by haskell-concat-column - -(defun haskell-insert-concat() - "Inserts a `++' operator on the given line." - (interactive) - (end-of-line) - (skip-chars-backward " \t") - ;;Indent to required level - ;; and insert the concat operator `++' - (indent-to (haskell-concat-indent)) - (insert "++")) - - - -;;; Returns the indentation column for a concatenation operator on this line. -;;; The point is positioned at the last char of any code on the line. - -(defun haskell-concat-indent () - "Returns the indentation for a concat operator on the given line." - (max (1+ (current-column)) - haskell-concat-column)) - - - -;;; Returns the indentation of the current line of haskell code. -;;; A blank line has ZERO indentation - -(defun haskell-current-indentation () - "Returns the indentation for the current haskell line. A blank line has -indentation zero." - (save-excursion - (beginning-of-line) - (if (looking-at "^[ \t]*$") - ;;The line is empty - ;; so the indentation is zero - 0 - ;;Otherwise find the normal value of indentation - (current-indentation)))) - - - -;;; Returns the indentation of the previous line of haskell code. -;;; A blank line has ZERO indentation - -(defun haskell-previous-indentation () - "Returns the previous line's indentation as Haskell indentation." - (save-excursion - (if (not (bobp)) - ;;Not at the start of the buffer - ;; so get the previous lines indentation - (progn - (forward-line -1) - (haskell-current-indentation)) - ;;We are at the start of buffer - ;;There is no previous line; Indent is zero - 0))) - - - -;;; Move back to the last line which is aligned in the left column. -;;; Ignores comments and blank lines. -;;; The point is left at the beginning of the line. - -(defun haskell-back-to-zero-indent () - "Moves point to last line which has zero as indentation." - ;;Not at the beginning of buffer. - ;;Continue to go to the previous line until - ;; we find a line whose indentation is non-zero. - ;;Blank lines and lines containing only comments - ;; are ignored. - (beginning-of-line) - (while (and - (or (not (zerop (haskell-current-indentation))) - (looking-at "^[ \t]*\\($\\|--\\)")) - (not (bobp))) - (haskell-backward-to-noncomment) - (beginning-of-line))) - - - -;;; Find the last symbol, usually an equality. - -;;; Note: we check for "=" as a complete WORD (and ignore -;;; comments) when searching for this. Ie. an `=' may be -;;; surrounded only by a letter, digit, or whitespace . -;;; Strings are not considered. -;;; Don't go beyond the first character in the (possibly narrowed) buffer. -;;; From the beginning of the line, -;;; find the comment position (or end-of-line) -;;; search forward to this position, looking for a "where" -;;; If one's found, then search forward for "\b=\b" -;;; If there's no equality sign then -;;; search forward from the start of the line for an equals -;;; Otherwise we found it. -;;; If there's no where then search forward for an equals, as above. - -(defun haskell-back-to-symbol (exp) - "Goes backward from point until a symbol, EXP, is found. -The point is left at the first symbol matching the context -of the haskell code." - (let* ((found nil) - (symbol (concat "[ \ta-z0-9A-Z]" exp "[ \t\na-z0-9A-Z]")) - eol-limit - bol-limit - (zero-indent (save-excursion - (haskell-back-to-zero-indent) - (point))) - (initial-depth (car (parse-partial-sexp - (point) - zero-indent)))) - - (while (and (not found) - (> (point) zero-indent)) - ;;Not found and point > point min - ;;Record the limit of search for the beginning and - ;; end of the line. - (setq eol-limit (point)) - (beginning-of-line) - (setq bol-limit (point)) - (goto-char eol-limit) - (re-search-backward "\\bwhere\\b" bol-limit 't) - ;;Search back from the end of the line - ;; to find the most recent 'where'. - - (cond ((and (re-search-backward symbol bol-limit 't) - (= initial-depth - (car (parse-partial-sexp - (point) - zero-indent)))) - ;;Found a symbol sign surrounded by - ;; a letter, digit or space only, or at the - ;; beginning of the buffer and they are at - ;; the same depth level - (setq found 't)) - ((and (re-search-backward symbol bol-limit 't) - (zerop - (car (parse-partial-sexp - (point) - zero-indent)))) - ;; Found a symbol and it is not in any parens - (setq found 't)) - ;;Otherwise, go back a line. - (t (haskell-backward-to-noncomment)))) - (if found - (forward-char 1)))) - - -;;; Goes back to the last keyword. The point is left at the -;;; beginning of the keyword. -;;; The words recognised are: -;;; `case',`of',`where',`let',`in',`if',`then',`else' - -(defun haskell-back-to-keyword () - "Goes backward from point until a keyword is found. -The point is left after the first keyword." - (let* ((found nil) - eol-limit - bol-limit - (zero-indent (save-excursion - (haskell-back-to-zero-indent) - (point))) - (initial-depth (car (parse-partial-sexp - (point) - zero-indent)))) - - (while (and (not found) - (>= (point) zero-indent)) - ;;Not found and point > point min - ;;Go back past any comment. - ;;Record the limit of search for the beginning and - ;; end of the line. - (setq eol-limit (point)) - (beginning-of-line) - (setq bol-limit (point)) - (goto-char eol-limit) - (if (and (re-search-backward - "\\b\\(case\\|of\\|where\\|let\\|in\\|if\\|then\\|else\\)\\b" - bol-limit 't) - (= initial-depth - (car (parse-partial-sexp - (point) - zero-indent)))) - ;;Found a keyword and it is at the same level as the initial position - (progn - (setq found 't) - (forward-word 1)) - ;;Otherwise, go back a line. - (haskell-backward-to-noncomment))))) - - - -;;; Returns the end of line (point) of the current line, excluding any -;;; line comments on it. - -(defun haskell-eol () - "Returns the end (point) of the current line, excluding any line comments." - (save-excursion - (end-of-line) - (let ((eol-limit (point))) - (beginning-of-line) - (if (search-forward "--" eol-limit 'move-to-eol) - ;;Found a '--' - ;;So move to the beginning of the comment - ;;If fail then move to end of line - (forward-char -2))) - (point))) - - - -;;; Returns whether or not the current line contains an equality outwith a -;;; comment. The equality may only be surrounded by a letter, digit or -;;; whitespace. - -(defun haskell-looking-at-eqp () - "Returns whether or not the current line contains an equality outwith a -comment." - (save-excursion - (beginning-of-line) - (re-search-forward "[ \ta-z0-9A-Z]=[ \t\na-z0-9A-Z]" (1+ (haskell-eol)) 't))) - - -;;; This function does not require all keywords, just those which -;;; may have a bracket before them. -(defun haskell-looking-at-keywordp () - "Returns whether or not there is a keyword after the point outwith a -comment." - (save-excursion - (re-search-forward - "\\(\\(=>\\|=\\|++\\|->\\|<-\\|::\\)\\|\\b\\(case\\|of\\|if\\|then\\|else\\|let\\|in\\)\\b\\)" - (haskell-eol) 't))) - - -;;; This function returns whether or not there is a keyword contained in -;;; the region START END. START < END. - -(defun haskell-keyword-in-regionp (start end) - "Returns whether or not there is a keyword between START and END." - (save-excursion - (goto-char start) - (let ((found nil) - (eol-limit (haskell-eol))) - (while (and (not found) (< (point) end)) - (if (> eol-limit end) - (setq eol-limit end)) - (if (re-search-forward - "\\b\\(case\\|of\\|if\\|then\\|else\\|let\\|in\\)\\b" - eol-limit 'move) - (setq found t) - ;;Otherwise, have not found a keyword. Now at haskell-eol. - (if (< (point) end) - ;;We still have an area to search - ;; so go forward one line - (progn - (beginning-of-line) - (forward-line 1) - (setq eol-limit (haskell-eol)))))) - ;;found is `t' or point >= end - found))) - - -;;; Goes back to the last line which is not entirely commented out. -;;; The point is left just before the comment. - -(defun haskell-backward-to-noncomment () - "Sets the point to the last char on the line of Haskell code before a comment." - (let ((comment 't) - (limit (point-min))) - (while (and comment (> (point) limit)) - ;; comment is true and point > limit - (beginning-of-line) - (if (< (forward-line -1) 0) - ;;This was the first line in the buffer - (setq comment nil) - ;;Otherwise, this was not the first line - (if (not (looking-at "^[ \t]*\\($\\|--\\)")) - ;;There is not a comment at the beginning of the line - ;; and the line is not blank - (progn - ;;The line is either blank or has code on it. - (setq comment nil) - (goto-char (haskell-eol)))))) - - ;;return point - (point))) - - - -;;; Indents a region (by applying "tab" to each line). -;;; The marker upper-marker is set to the end of the region. -;;; We indent from the beginning of the region to this marker. -;;; Implements C-c r. - -(defun haskell-indent-region () - "Indents the region between the point and mark." - (interactive) - (let ((lower-limit (min (point) (mark))) - (upper-limit (max (point) (mark)))) - (indent-region lower-limit upper-limit 'nil))) - - - -;;; Implements TAB. -;;; This actually indents a line. -;;; Eventually it will handle a line split at any point, - -(defun haskell-indent-line () - "Indent current line as Haskell code. -Keeps the point at the same position on the line unless the -point is less then the current indentation, in which case the -point is moved to the first char." - (interactive) - (save-excursion - (let ((indent (haskell-calculate-indentation))) - (beginning-of-line) - (delete-horizontal-space) - ;;Kill any spaces that may preceed the code - ;; and reindent to the correct level. - (indent-to indent))) - (if (< (current-column) (current-indentation)) - ;;The point is in the indentation - ;; so move to the first char on the line - (move-to-column (current-indentation)))) - - - -;;; This is the haskell version of the Emacs function -;;; reindent-then-newline-and-indent. It was necessary -;;; to write this because the Emacs version has the -;;; terrible property of deleting whitespace BEFORE -;;; reindenting the original line. - -(defun haskell-reindent-then-newline-and-indent () - "Reidents the current line of Haskell code then takes a -newline and indents this new line." - (interactive) - (skip-chars-backward " \t") - (haskell-indent-line) - (newline) - (delete-horizontal-space) - (haskell-indent-line)) - - - -;;; Returns whether the first word of the last line with zero indentation -;;; is the same as the first word of the current line. -;;; This function is based on the (reasonable?) assumption that -;;; a function definition occurs on the left hand margin. -;;; This is not quit reasonable since recusive functions are not -;;; recognised. - -(defun haskell-continued-fn-defp () - "Returns whether the first word on the last line with zero indentation -matches the first word on the current line." - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - ;;Goto the first non space char - (haskell-word-eq (point) - (save-excursion - (forward-line -1) - (haskell-back-to-zero-indent) - (point))))) - - -;;; Returns whether two words are the same. -;;; The beginning of both words are given as their -;;; respective points in the buffer. - -(defun haskell-word-eq (current-pos previous-pos) - (let ((OK 't)) - (goto-char previous-pos) - ;;We shall compare the two words starting - ;; at previous-pos and current-pos. - (while (and OK (looking-at "\\S-")) - ;;OK and looking at a word constituent - (if (eq (char-after current-pos) - (char-after previous-pos)) - ;;The two chars are the same - (progn - ;;Increment the two postions - ;; and update location of point - (setq current-pos (1+ current-pos)) - (setq previous-pos (1+ previous-pos)) - (goto-char previous-pos)) - ;;The two chars are different - ;; so set OK to be false - (setq OK 'nil))) - - ;;Return the value of OK - OK)) - - - - -;;; This function returns the column of the last unbalanced -;;; expression. -;;; It is called when an keyword is found. The point is -;;; initially placed before the corresponding keyword. -;;; The function looks at every word to see if it is a -;;; `let' or `in'. Each word must be outwith a comment. - -(defun haskell-last-unbalanced-key-column (open close) - "Returns the column of the last unbalanced keyword, open." - (save-excursion - (let ((original-pos (point)) - (bol-limit (save-excursion - (beginning-of-line) - (setq bol-limit (point)))) - (depth 1)) - (setq open (concat "\\b" open "\\b")) - (setq close (concat "\\b" close "\\b")) - (while (and - (> depth 0) - (> (point) (point-min))) - (forward-word -1) - (if (< (point) bol-limit) - ;;Moved past the beginning of line limit - ;; so go back to the previous line past - ;; any comments. - (progn - (goto-char original-pos) - (haskell-backward-to-noncomment) - (setq original-pos (point)) - (setq bol-limit (save-excursion - (beginning-of-line) - (point)))) - ;;Otherwise, still on the same line - (if (looking-at open) - ;;This word is an open keyword - (setq depth (1- depth)) - ;;Otherwise, - (if (looking-at close) - ;;This word is a close keyword - (setq depth (1+ depth)))))) - - (if (string= open "\\bif\\b") - ;;The argument is `if' - (if (not (save-excursion (skip-chars-backward " \t") (bolp))) - ;;There is something before the `if' - (if (and (save-excursion - (forward-word -1) - (looking-at "\\belse\\b")) - (not haskell-nest-ifs)) - ;;There is an `else' before the 'if' - (forward-word -1)))) - - - (current-column)))) - - - -;;; Return the indentation for a line given that we expect a `where'. -;;; The point lies on the corresponding symbol -;;; that the `where' scopes over. - -(defun haskell-indent-where () - "Return the indentation for a line, given that we expect a `where' -clause." - (let ((symbol (if (looking-at "=") - "=" - "->"))) - - (cond ((or haskell-std-indent-where - (> (current-column) haskell-where-threshold)) - ;;Set indentation as the sum of the previous - ;; line's layout column and the standard offset - ;; (ie. 'haskell-where-offset) - (save-excursion - (beginning-of-line) - (cond ((looking-at (concat "^[ \t]*" symbol)) - ;;The line starts with the symbol - (setq indent (current-indentation))) - ((looking-at "^[ \t]*where\\b") - ;;The line starts with a 'where' - (forward-word 1) - (skip-chars-forward " \t") - (setq indent (+ (current-column) haskell-where-offset))) - (t - ;;The line begins on the layout column - (setq indent (+ (current-indentation) - haskell-indent-offset)))))) - ((or haskell-align-where-with-eq - haskell-align-where-after-eq) - (if (looking-at (concat symbol "[ \t]*$")) - ;;The symbol is at the end of the line - (setq indent (+ (current-indentation) - haskell-where-offset)) - (save-excursion - ;;Set the indentation as required - (if haskell-align-where-after-eq - (skip-chars-forward (concat symbol " \t"))) - (setq indent (current-column)))))))) - - - -;;; Calculates the indentation for the current line. -;;; When we come here, we are in a line which we want to indent. -;;; We should leave the point at the same relative position it -;;; was in before we called the function, that is, if a line -;;; is already correctly indented, nothing happens! - -;;; The main problems are handling "where" definitions -;;; and the syntax of expressions when these are continued -;;; over multiple lines (e.g. tuples, lists, or just plain -;;; bracketed expressions). Watch out for let ... in, too! - -;;; For example, think about the following tricky cases: - -;;; f x = x + - -;;; f x = [ x + y, - -;;; f x = [ - -;;; f x = [ -- start of a large list -;;; -- which I'm commenting in as I go -;;; - -(defun haskell-calculate-indentation () - "Returns the indentation level for the current line of haskell code." - (save-excursion - (let ((indent 0) - (eol-position (point))) - (beginning-of-line) - (cond ((bobp) - ;;We are at the beginning of the buffer so do nothing at all - (setq indent 0)) - - ((looking-at "^[ \t]*--") - ;;There is a comment on the line by itself - ;;Leave it the way it is - (setq indent (current-indentation))) - - ((looking-at "^[ \t]*\\(data\\|type\\|module\\|import\\|instance\\)\\b") - ;;There is a 'data', 'type', 'module' or 'import' at start of line - (setq indent 0)) - - ((haskell-continued-fn-defp) - ;;This is clearly same function - ;; so set indent to be 0 - (setq indent 0)) - - ((looking-at "^[ \t]*[]}]") - ;;There is a "]" or "}" at the start of the line - (let ((state (parse-partial-sexp (match-end 0) - (save-excursion - (haskell-back-to-zero-indent) - (point))))) - (if (>= (car state) 0) - ;;Since the point is just after a parenthesis - ;; it has a match if the depth is >= 0 - (save-excursion - (goto-char (nth 2 state)) - ;;Move to the match. - (if (not - (save-excursion - (skip-chars-backward " \t") - (bolp))) - ;;There is something before the brace. - (progn - (let ((initial-pos (point))) - (forward-word -1) - (if (not (looking-at - "\\(let\\|where\\)")) - ;;The word is not `where' or `let' - ;; so go back. - (progn - (goto-char initial-pos) - (skip-chars-forward " \t")))))) - (setq indent (current-column))) - (setq indent 0)))) - - ((looking-at "^[ \t]*\\(->\\|=>\\)") - ;; '->' or '=>' at start of line - (save-excursion - (haskell-backward-to-noncomment) - ;;Go back to previous line - (let ((eol-limit (point))) - (beginning-of-line) - (if (re-search-forward "::" eol-limit 't) - ;;There is a '::' on this (previous) line - ;; set indent to be at the start of it - (setq indent (- (current-column) 2)) - ;;Otherwise copy this (previous) line's indentation - (setq indent (current-indentation)))))) - - ((looking-at "^[ \t]*where\\b") - ;;There is a 'where' at the start of the line - ;;Look for the equality (which will not - ;; be on this line). - (haskell-backward-to-noncomment) - (goto-char (max (save-excursion - (haskell-back-to-symbol "=") - (point)) - (save-excursion - (haskell-back-to-symbol "->") - (point)))) - (setq indent (haskell-indent-where))) - - ((looking-at "^[ \t]*then\\b") - ;;The first thing on the line is a `then' - (setq indent (+ (haskell-last-unbalanced-key-column "if" "then") - haskell-then-offset))) - - ((looking-at "^[ \t]*else\\b") - ;;The first thing on the line is a `else' - (if haskell-align-else-with-then - (setq indent (haskell-last-unbalanced-key-column "then" "else")) - (setq indent (haskell-last-unbalanced-key-column "if" "else")))) - - ((looking-at "^[ \t]*|") - ;;There is a `|' at beginning of line - (save-excursion - (let ((state - (parse-partial-sexp (save-excursion - (haskell-back-to-zero-indent) - (point)) - (point)))) - (if (not (or (nth 3 state) (nth 4 state))) - ;;Not in a comment or string - (if (> (car state) 0) - ;;In an unbalanced parenthesis. - (progn - (goto-char (nth 1 state)) - ;;Move to the beginning of the unbalanced parentheses - (if (and (looking-at "\\[") - (search-forward "|" (haskell-eol) 't)) - ;;It is a list comprehension - (setq indent (1- (current-column))) - (setq indent (+ (current-column) - haskell-comp-offset)))) - ;;Otherwise, not in an unbalanced parenthesis - (setq indent (save-excursion - (haskell-back-to-symbol "=") - (cond ((not (looking-at "=")) - ;;Did not find an equals - (+ (haskell-previous-indentation) - haskell-indent-offset)) - ((save-excursion - (beginning-of-line) - (looking-at "^[ \t]*data\\b")) - ;;There is a `data' at beginning - (setq indent (current-column))) - ((save-excursion - (beginning-of-line) - (search-forward - "|" (haskell-eol) 't)) - ;;There is a `|' on this line - ;; so set this to be the indent - (save-excursion - (goto-char (match-beginning 0)) - (current-column))) - (t - ;;Otherwise, set `=' as indent - (current-column)))))))))) - - ((looking-at "^[ \t]*=") - ;;There is an equals at the start of the line - ;;Set the indentation to be the previous line's - ;; indentation plus the standard offset - (setq indent (+ haskell-indent-offset - (haskell-previous-indentation)))) - - ((looking-at "^[ \t]*in\\b") - ;;The line starts with 'in' - (beginning-of-line) - (setq indent (haskell-last-unbalanced-key-column "let" "in"))) - - ((looking-at "^[ \t]*of\\b") - ;;The line starts with `of' - (beginning-of-line) - (setq indent (haskell-last-unbalanced-key-column "case" "of"))) - - ((looking-at "^.*::") - ;;There is a '::' in the line - ;;There are several possibilities for indentation - (if (looking-at "[ \t]*::") - ;;The '::' is the first thing on the line - ;; so set indent to be the previous line's - ;; indentation plus the standard offset - (setq indent (+ (haskell-previous-indentation) - haskell-indent-offset)) - (save-excursion - ;;Otherwise, the '::' is contained in the line somewhere - ;; so use contextual indentation - (setq indent (haskell-context-indent))))) - - (t - ;;Do not recognise the first word on the line. - (setq indent (haskell-context-indent)))) - - indent))) ;return indent as indentation value - - - -;;; Returns the indentation for the current line by looking at the -;;; previous line to give clues to the indentation. - -(defun haskell-context-indent () - "Returns the indentation for the current line by looking at -the previous line to dictate the indentation." - (save-excursion - (let ((original-position (point)) - indent) - (beginning-of-line) - (if (bobp) - ;;At the beginning of the buffer - (setq indent 0) - ;;Otherwise, we are not at the beginning of the buffer - (haskell-backward-to-noncomment) - (let ((eol-limit (point)) - ;;Record the (upper) limit for any search on this line - bol-limit - (paren-indent 'nil)) - ;;`paren-indent' flags whether we are indenting a list or not - (beginning-of-line) - (setq bol-limit (point)) - ;;Record the (lower) limit for any search on this line - (goto-char eol-limit) ;goto the end of the line - (flag) - (if (save-excursion - (goto-char eol-limit) - (and (re-search-backward - "[])][^][()]*" bol-limit 't) - (save-excursion - (goto-char (match-beginning 0)) - (not (haskell-looking-at-keywordp))))) - - ;;There is a close parenthesis at the end of the line - ;; followed by anything except "(", ")", "[", "]" - ;; or a keyword - (progn - ;;Search back for the close parenthesis - ;; and move to just after it. - (re-search-backward "[])]" bol-limit 't) - (forward-char 1) - (let ((state - (parse-partial-sexp (save-excursion - (haskell-back-to-zero-indent) - (point)) - (point)))) - (if (not (or (nth 3 state) (nth 4 state))) - ;;Not in a comment or string - (if (>= (car state) 0) - ;;The parenthesis has a match - (progn - (goto-char (nth 2 state)) - ;;Move to the beginning of the parentheses - ;; as this new line will determine - ;; further indentation - (if (zerop (car state)) - ;;This paren closes all unbalanced parens - ;; so move to - ;; the eol of last line with an equality. - (progn - (setq eol-limit (point)) - (goto-char - (max (save-excursion - (haskell-back-to-symbol "=") - (point)) - (save-excursion - (haskell-back-to-keyword) - (point)))) - (goto-char eol-limit)) - ;;esle just go to the end of the line - (goto-char (haskell-eol))) - (setq paren-indent 't) - ;;Set 'paren-indent' to true to indicate we - ;; are indenting a list. - (setq eol-limit (point)) - (beginning-of-line) - (setq bol-limit (point)) - ;;Reduce the scope of any later - ;; indentation to - ;; exclude the balanced parentheses - ;; by making this point - ;; be the eol-limit. - (goto-char eol-limit))))))) - (flag) - ;;This cond expression is structured, to an - ;; extent, such that the keywords with highest - ;; indentation precedence come first. Order is important. - ;;In each condition, the point of match is noted so - ;; that we can see if this point is in a string. - (let ((indent-point (point))) - (cond ((re-search-backward "\\bof\\b" bol-limit 't) - ;; `of' is contained in previous line - (setq indent-point (point)) - (if (looking-at "of[ \t]*$") - ;;`of' at end of line - (setq indent (+ (haskell-last-unbalanced-key-column - "case" "of") - haskell-case-offset)) - ;;Otherwise, `of' is in line - (forward-word 1) - (skip-chars-forward " \t") - (setq indent (current-column)) - (setq indent (list indent)))) - - ((re-search-backward - "\\bthen[ \t]*$" bol-limit 't) - ;;There is a `then' at the end of the line. - (setq indent-point (point)) - (if haskell-align-else-with-then - ;;We want to align the `else' (to follow) with the `then' - (setq indent (+ (current-column) - haskell-if-offset)) - (setq indent (+ (haskell-last-unbalanced-key-column - "if" "then") - haskell-if-offset)))) - ;; This was here but don't know why (setq indent (list indent)))) - - ((save-excursion - (and (re-search-backward "\\bif\\b" bol-limit 't) - (setq indent-point (point)) - (not (re-search-forward "\\bthen\\b" eol-limit 't)))) - ;;There is an `if' on the (previous) line and the line does - ;; not have a `then' on it. - (setq indent (+ (haskell-last-unbalanced-key-column - "if" "then") - haskell-then-offset))) - - ((save-excursion - (and (re-search-backward "\\bif\\b" bol-limit 't) - (setq indent-point (point)) - (not (re-search-forward "\\belse\\b" eol-limit 't)))) - ;;There is an `if' on the (previous) line (the line may - ;; have a `then' on it) and does not have an else on it. - (if (re-search-backward "\\bthen\\b" bol-limit 't) - ;;There is a then on the line and it is followed by - ;; some code. - (progn - (forward-word 1) - (skip-chars-forward " \t") - (setq indent (current-column))) - (if haskell-align-else-with-then - ;;We want to align the `else' with the `then' - (setq indent (haskell-last-unbalanced-key-column - "then" "else")) - (setq indent (haskell-last-unbalanced-key-column - "if" "else"))))) - - ((re-search-backward "\\b\\(let\\|in\\)\\b" bol-limit 't) - ;; 'let' or 'in' is contained in the (previous) line - (setq indent-point (point)) - (forward-word 1) ;skip past the word - (skip-chars-forward " \t{") - (if (looking-at "\\($\\|--\\)") - ;;looking-at eol or comment - (progn - (forward-word -1) - (setq indent (+ (current-column) - haskell-let-offset))) - (setq indent (current-column)))) - - ((re-search-backward - "\\belse[ \t]*$" bol-limit 't) - ;;There is a `else' at end of line - (setq indent-point (point)) - (save-excursion - (goto-char eol-limit) - (forward-word -1) - (setq indent (+ (current-column) - haskell-if-offset)))) - - ((re-search-backward - "\\belse\\b" bol-limit 't) - ;;There is a `else' on the line with no if or then - (setq indent-point (point)) - (save-excursion - (forward-word 1) - (skip-chars-forward " \t") - (setq indent (current-column)))) - - ((save-excursion - (beginning-of-line) - (looking-at - "^[ \t]*then\\b")) - ;;There is a 'then' at beginning of line - (setq indent-point (point)) - (setq indent (current-indentation))) - - ((save-excursion - (beginning-of-line) - (looking-at "^[ \t]*else[ \t]*if\\b")) - (setq indent-point (point)) - ;;There is an 'else if' at start of (previous) line - (save-excursion - (beginning-of-line) - (if haskell-nest-ifs - (save-excursion - (forward-word 1) - (skip-chars-forward " \t") - (setq indent (current-column))) - (skip-chars-forward " \t") - (setq indent (current-column))))) - - ((re-search-backward "\\bcase\\b" bol-limit 't) - ;;There is a 'case' on the previous line - ;; so copy this line's indentation and add on - ;; the offset unless there is not an of. - (setq indent-point (point)) - (setq indent (+ (current-column) - haskell-case-offset))) - - ((save-excursion - (beginning-of-line) - (looking-at "^\\(instance\\|class\\)\\b")) - ;;This (previous) line has an 'instance' or 'class' at start - ;; so just set indentation to be this line indentation - ;; plus the standard offset - (setq indent-point (point)) - (setq indent (+ (current-indentation) - haskell-indent-offset))) - - ((re-search-backward "where\\b" bol-limit 't) - ;;There is a 'where' on the (previous) line - (setq indent-point (point)) - (if (looking-at "where[ \t]*$") - ;;There is nothing after the 'where' - ;; so set indent to be this column - ;; (ie. the column of the 'w') - ;; plus the standard offset - (if (save-excursion - (skip-chars-backward " \t") - (bolp)) - ;;The 'where' is the only thing on the line. - (setq indent (+ (current-column) - haskell-where-offset)) - ;;Otherwise, the 'where' is at the end - ;; of the line and there is code before it. - ;;Look before the 'where' for the symbol - ;; it scopes over. - (forward-word -1) - (goto-char (max (save-excursion - (haskell-back-to-symbol "=") - (point)) - (save-excursion - (haskell-back-to-symbol "->") - (point)))) - (setq indent (haskell-indent-where))) - - ;;Otherwise, go past the 'where' - ;; and goto the last non space character. - ;;Set this column to be the indentation. - (forward-word 1) - (skip-chars-forward " \t") - (setq indent (current-column)))) - - ((re-search-backward - "[ \ta-z0-9A-Z]=[ \t]*$" bol-limit 't) - ;;There is an equals is at the end of line - ;; so make the indentation be this line's indentation - ;; plus the standard offset - (setq indent-point (point)) - (setq indent (+ (current-indentation) - haskell-indent-offset))) - - ((re-search-backward - "[ \ta-z0-9A-Z]\\+\\+[ \t]*$" bol-limit 't) - ;;There is a concat operator at the end of line - ;; so make the indentation be this line's indentation - (setq indent-point (point)) - (setq indent (current-indentation))) - - ((save-excursion - (beginning-of-line) - (looking-at - "^[ \t]*=[ \ta-z0-9A-Z]")) - ;;There is an equals is at the beginning of line - ;; so make the indentation be the previous line's - ;; indentation unless the previous line's - ;; indentation is zero. - (setq indent-point (point)) - (save-excursion - (haskell-backward-to-noncomment) - (if (zerop (current-indentation)) - (setq indent (+ (current-indentation) - haskell-indent-offset)) - (setq indent (haskell-current-indentation))))) - - ((re-search-backward "|" bol-limit 't) - ;;There is an `|' on this line. - (setq indent-point (point)) - (if (save-excursion - (goto-char original-position) - (looking-at "^[ \t]*\\($\\|--\\||\\)")) - ;;The original line is empty or has a `|' at the - ;; start. So set indent to be first `|' on this line - (save-excursion - (goto-char bol-limit) - (re-search-forward "|" eol-limit 't) - (setq indent (1- (current-column)))) - ;;Otherwise set indent to be this (previous) line's - (setq indent 0))) - - ((re-search-backward "->" bol-limit 't) - ;;There is a `->' in the line. - ;;This may be from a `case' or a - ;; type declaration. - (setq indent-point (point)) - (save-excursion - (if (re-search-backward "::" bol-limit 't) - ;;There is a '::' on this line - (if (looking-at ".*->[ \t]*$") - ;;The '->' is at the end of line. - ;;Move past the '::' and any spaces - ;; and set indent to be this column. - (progn - (skip-chars-forward ": \t") - (setq indent (current-column))) - ;;Otherwise, the '->' is not at end of line - ;; so copy the indentation - (setq indent (haskell-context-indent))) - - ;;Otherwise, there is not a - ;; `::' on this line so copy this - ;; (previous) indentation. - (setq indent (haskell-context-indent))))) - - ((re-search-backward "::" bol-limit 't) - ;;There is an '::' on this line. - ;;We know that the line does not end with '->'. - (setq indent-point (point)) - (if (looking-at "::[ \t]*$") - ;;The '::' is at the end of the line - ;; so set indent to be this line's - ;; indentation plus the offset. - (setq indent (+ (current-indentation) - haskell-indent-offset)) - ;;Otherwise the `::' is in the line - (setq indent (current-indentation)))) - - ((re-search-backward - "\\b\\(import\\|class\\)\\b" - bol-limit 't) - ;;There is an `import' or `class' on the line. - ;;Copy this indentation. - (setq indent-point (point)) - (setq indent (current-indentation))) - - ((or - (haskell-looking-at-eqp) - (save-excursion - (beginning-of-line) - (looking-at "^[ \t]*$"))) - ;;There is an '=' on the line - ;; or it is blank - (setq indent-point (point)) - (cond ((save-excursion - (beginning-of-line) - (looking-at "^[ \t]*data\\b")) - ;;`data' at start of line - ;; so expect a `|' - (haskell-back-to-symbol "=") - (setq indent (current-column))) - ((zerop (current-indentation)) - ;;If the indentation is zero, we expect a `where' - (goto-char eol-limit) - (haskell-back-to-symbol "=") - (setq indent (haskell-indent-where))) - ((looking-at "^[ \t]*=[ \t\na-z0-9A-Z]") - ;;The equality is the first thing on the line - ;; so copy the last lines indentation - (save-excursion - (haskell-backward-to-noncomment) - (setq indent (current-indentation)))) - (t - ;;Otherwise, copy the indentation - (setq indent (current-indentation))))) - - ((save-excursion - (beginning-of-line) - (and (zerop (current-indentation)) - (not (looking-at "^[ \t]*$")))) - ;;The line is not blank and its indentation is zero - ;;It is a function definition. We know that - ;; there is not an equals on the line - (goto-char eol-limit) - ;;We expect a keyword - ;; so set indent to be this line's indentation - ;; plus the offset - (setq indent-point (point)) - (setq indent (+ (current-indentation) - haskell-indent-offset))) - - ((bobp) - ;;At the beginning of buffer - (setq indent 0)) - - (paren-indent - ;;We are indenting a list and none - ;; of the above indentations are applicable - ;; so copy the indentation of this line - (setq indent (current-indentation))) - - (t - (save-excursion - (setq indent (haskell-context-indent))))) - - (if (nth 3 (parse-partial-sexp - (save-excursion - (goto-char indent-point) - (haskell-back-to-zero-indent) - (point)) - (save-excursion - (goto-char indent-point)))) - ;;The point we determined indentation at is in a - ;; string so go to this point and go back one line to - ;; find indentation. - (setq indent (haskell-context-indent)))) - - - ;;HOWEVER, we may have to override any indentation if we are in - ;; an unbalanced parenthesis (on the original line). - (flag) - (save-excursion - (goto-char original-position) - (let* ((eq-point (save-excursion - (haskell-back-to-symbol "=") - (point))) - (state (parse-partial-sexp - eq-point - (point)))) - (if (> (car state) 0) - ;;There is an unbalanced parenthesis between - ;; the function and here. - (if (not (or (nth 3 state) (nth 4 state))) - ;;We are not in a string or comment - ;; so goto the parenthesis - (progn - (goto-char (nth 1 state)) - (if (not (haskell-keyword-in-regionp - (point) - original-position)) - ;;There is not a keyword after the open - ;; bracket so we override the indentation - (progn - (if (not (looking-at "{")) - ;;The parenthesis is not a `{' - (if (or (looking-at "\\[") - (save-excursion - (goto-char (haskell-eol)) - (skip-chars-backward " \t") - (and - (char-equal (preceding-char) ?,) - (= (car state) - (car (parse-partial-sexp - eq-point - (point))))))) - ;;The paren is a square one - ;; or it is a tuple. - ;;Don't ignore what is after it. - (setq indent (haskell-list-align (haskell-eol))) - ;;Otherwise, ignore what comes after it. - (setq indent (haskell-list-align (point)))))))))))) - )) - - indent))) - - -;;; Inserts the close parenthesis and reindents the line. -;;; We want to reindent the line if the parenthesis is -;;; the first character on the line. The parenthesis -;;; recognised by this function are `]', `}'. - -(defun electric-haskell-brace () - "Inserts the character `]' or `}' and reindents the current line." - "Insert character and correct line's indentation." - (interactive) - (if (save-excursion - (skip-chars-backward " \t") - (bolp)) - ;;The parenthesis is at the beginning of the line. - (progn - (insert last-command-char) - (haskell-indent-line)) - ;;Otherwise it is not at the beginning of line. - (insert last-command-char)) - ;; Match its beginning. - (haskell-blink-open)) - - - - -;;; This function returns the indentation for the next line given -;;; that it is contained in a bracket or we are extending a functions -;;; parameters over a line. For the case of being in an unbalanced -;;; parenthesis list, the point lies on the unbalanced parenthesis. -;;; The parameter eol-limit is used to delimit the end of the line. - -(defun haskell-list-align (eol-limit) - "Returns the indentation for the next line given that -the point lies on an unbalanced open parenthesis." - (save-excursion - (let ((indent (1+ (current-column)))) - ;;Set indent to be the next char (at least). - - (cond ((not - (looking-at ".[ \t]*\\($\\|--\\)")) - ;;There is something after the parenthesis - ;;ie. the line is not empty and ignore comments - (cond ((save-excursion - (goto-char eol-limit) - (skip-chars-backward " \t") - (and (char-equal (preceding-char) ?,) - (save-excursion - (beginning-of-line) - (not (search-forward "|" eol-limit 't))))) - ;;This is a normal list since a `,' at end - ;; and there is no a `|' on the line. - (forward-char 1) - (skip-chars-forward " \t") - (setq indent (current-column))) - - ((looking-at "\\[") - ;;It is a list comp we are looking at - ;;Goto the bar. - (forward-char 1) - (search-forward "|" eol-limit 't) - (skip-chars-forward " \t") - (setq indent (current-column))) - - ((looking-at ".[ \t]*(") - ;;We are looking at an open parenthesis - ;; after this character. - ;;It must be balanced so - ;; move to the start of this paren - ;; and set indent to be here - (forward-char 1) - (skip-chars-forward " \t") - (setq indent (current-column))) - - (t - (forward-word 1) - ;;We are not looking at another open - ;; parenthesis, so move forward past the - ;; (assumed) function name. - (if (or - haskell-std-list-indent - (looking-at"[ \t]*\\($\\|--\\)")) - ;;There is nothing after the name - ;; or haskell-std-list-offset is set - ;; so set indent to be its original - ;; value plus the offset minus 1 - ;; since we added one on earlier. - (setq indent - (+ indent - (1- haskell-list-offset))) - - ;;Otherwise there is something after the - ;; name, so skip to the first non space - ;; character. - (skip-chars-forward " \t") - (setq indent (current-column))))))) - - - indent))) - - - -(defun haskell-insert-round-paren () - "Inserts a `(' and blinks to its matching parenthesis." - (interactive) - (insert last-command-char) - (haskell-blink-open)) - - - -;;; This function is called when a close parenthesis -;;; `)', `]', or `}' is typed. -;;; Blinks the cursor on the corresponding open parnethesis. -;;; The point lies just after the close parenthesis. - -(defun haskell-blink-open () - "Blinks the cursor to the matching open parenthesis. -The point lies just after a parenthesis." - (let ((state (parse-partial-sexp (point) - (save-excursion - (haskell-back-to-zero-indent) - (point))))) - (if (and - (>= (car state) 0) - (not (or (nth 3 state) (nth 4 state)))) - ;;The parenthesis just inserted has a match - ;; and is not in a string or a comment - ;; so blink on its match - (save-excursion - (goto-char (nth 2 state)) - (sit-for 1))))) - - - -;;; This function indents the line expecting the line to be a -;;; continued function application. - -;;; foo a = bar a -;;; b {haskell-further-indent applied to this line -;;; indents the line as shown} - -;;; The line would look like this if only tab had been applied: -;;; foo a = bar a -;;; b - -(defun haskell-further-indent () - "Indents the line more than the ordinary indentation in order to -extend function arguments over multiple lines." - (interactive) - (let (indent - (new-point (max (save-excursion - (haskell-back-to-symbol "=") - (point)) - (save-excursion - (haskell-back-to-keyword) - (point))))) - (save-excursion - ;;This may be a continuation of a function - ;; application so go back to the last '=' - ;; and set indent as designated by the style chosen - (goto-char new-point) - (skip-chars-forward "= \t") - (setq indent (haskell-list-align (haskell-eol)))) - ;;The argument to haskell-list-align is not important here. - (save-excursion - (beginning-of-line) - (delete-horizontal-space) - (indent-to indent)) - (if (< (current-column) indent) - (move-to-column indent)))) - - -;;; This function indents the current line to the first previous -;;; indentation value which is less than the current indentation. - -(defun haskell-lesser-indent () - "Indents the current line to the first previous indentation -value which is less than the current indentation." - (interactive) - (let ((original-indent - (current-indentation)) - (indent (haskell-context-indent)) - (done nil)) - (save-excursion - (while (not done) - (while (and (not (bobp)) - (not (zerop (current-indentation))) - (>= indent original-indent)) - (haskell-backward-to-noncomment) - (setq indent (current-indentation))) - ;;bobp or indent < original-indent - (if (>= indent original-indent) - ;;indent is still greater than or equal to original indent - (progn - (setq indent 0) - (setq done t)) - ;;Otherwise, indent is less than orignal indent. - (forward-line 1) - (setq indent (haskell-context-indent)) - (if (< indent original-indent) - ;;The new indent is an improvement - (setq done t) - ;;Otherwise, indent is still >= original - ;; so go back to the line and keep typing. - (forward-line -1))))) - (save-excursion - (beginning-of-line) - (delete-horizontal-space) - (indent-to indent)) - (if (< (current-column) indent) - (move-to-column indent)))) - - - -;;; Here are the functions which change the local variables -;;; to facilitate tailorability. - -(defun default-mode () - "Calls the function haskell-mode." - (interactive) - (haskell-mode) - (message haskell-indent-style)) - -(defun wadler-mode () - "Sets defaults according to Dr. Philip L. Wadler's preferences. - - Aligns `where' clauses with the corresponding equality. - - Aligns `else' keyword with the corresponding `then' - - haskell-list-offset 2 - - haskell-indent-offset 8 - - haskell-if-indent 2 - - haskell-comment-column 0 - - haskell-case-offset 2 - - haskell-let-offset 5." - ;;Preferences: - ;;'haskell-align-where-with-eq non-nil - ;;'haskell-list-offset 2 - (interactive) - (haskell-mode) - (or haskell-align-where-with-eq - (progn - (setq haskell-align-where-with-eq t) - (setq haskell-std-indent-where nil))) - (setq haskell-align-else-with-then t) - (setq haskell-list-offset 2) - (setq haskell-indent-offset 8) - (setq haskell-if-offset 2) - (setq haskell-case-offset 2) - (setq haskell-let-offset 5) - (setq haskell-comment-column 0) - (setq haskell-indent-style "Wadler") - (message haskell-indent-style)) - - -(defun report-mode () - "Sets defaults according to the style of the Haskell Report. - - Aligns `where' clauses after the corresponding equality. - - Aligns `else' with `then'. - - haskell-then-offset = 3 - - haskell-where-offset = 0. - - haskell-case-offset = 5." - ;;Preferences: - ;; haskell-align-where-after-eq non-nil - ;; haskell-then-offset 3 - ;; haskell-where-offset 0 - ;; haskell-case-offset 5 - (interactive) - (haskell-mode) - (haskell-align-where-after-eq) - (or haskell-align-else-with-then - (haskell-align-else-with-then)) - (setq haskell-then-offset 3) - (setq haskell-where-offset 0) - (setq haskell-case-offset 5) - (setq haskell-indent-style "Report") - (message haskell-indent-style)) - - -(defun haskell-align-where-with-eq () - "Sets indentation so that a 'where' clause lines up underneath -its corresponding equals sign." - (interactive) - (or haskell-align-where-with-eq - (progn - (setq haskell-align-where-after-eq nil) - (setq haskell-std-indent-where nil) - (setq haskell-align-where-with-eq t) - haskell-align-where-with-eq))) - - - -(defun haskell-align-where-after-eq () - "Sets indentation so that a 'where' clause lines up underneath -the first nonspace character after its corresponding equals sign." - (interactive) - (or haskell-align-where-after-eq - (progn - (setq haskell-align-where-with-eq nil) - (setq haskell-std-indent-where nil) - (setq haskell-align-where-after-eq t) - haskell-align-where-after-eq))) - - -(defun haskell-std-indent-where () - "Sets indentation so that a `where' clause lines up underneath -its corresponding equals sign." - (interactive) - (or haskell-std-indent-where - (progn - (setq haskell-align-where-after-eq nil) - (setq haskell-align-where-with-eq nil) - (setq haskell-std-indent-where t) - haskell-std-indent-where))) - - -(defun haskell-align-else-with-then () - "Sets indentation so that an `else' lines up underneath -it's corresponding `then'." - (interactive) - (setq haskell-align-else-with-then - (not haskell-align-else-with-then)) - (setq haskell-nest-ifs nil)) - -(defun haskell-nest-ifs () - "Sets indentation so that an `if' is lined up -under an `if' in an `else ." - (interactive) - (setq haskell-nest-ifs - (not haskell-nest-ifs)) - (setq haskell-align-else-with-then nil)) - - -(defun haskell-always-fixup-comment-space () - "Non-nil means always position one space after a line comment `--', -when reindenting or inserting a comment, -whether or not one space exists." - (setq haskell-always-fixup-comment-space - (not haskell-always-fixup-comment-space)) - haskell-always-fixup-comment-space) - -(defun haskell-indent-style () - "Echos the chosen indentation style in the mini-buffer." - (interactive) - (message haskell-indent-style)) - -(defun set-haskell-let-offset (offset) - "Changes the value of haskell-let-offset, the variable which -determines extra indentation after a `let' and `in'." - (interactive "nSet haskell-let-offset to: ") - (if (and (>= offset 0) (<= offset 10)) - (setq haskell-let-offset offset))) - -(defun set-haskell-if-offset (offset) - "Changes the value of haskell-let-offset, the variable which -determines extra indentation after an `if', `then' and `else'." - (interactive "nSet haskell-if-offset to: ") - (if (and (>= offset 0) (<= offset 10)) - (setq haskell-if-offset offset))) - -(defun set-haskell-case-offset (offset) - "Changes the value of haskell-case-offset, the variable which -determines extra indentation after a `case' and `of'." - (interactive "nSet haskell-case-offset to: ") - (if (and (>= offset 0) (<= offset 10)) - (setq haskell-case-offset offset))) - - -(defun set-haskell-where-offset (offset) - "Changes the value of haskell-where-offset, the variable which -determines extra indentation after a line of haskell code." - (interactive "nSet haskell-where-offset to: ") - (if (and (>= offset 0) (<= offset 10)) - (setq haskell-where-offset offset))) - - -(defun set-haskell-indent-offset (offset) - "Changes the value of haskell-indent-offset, the variable which -determines extra indentation after a line of haskell code." - (interactive "nSet haskell-indent-offset to: ") - (if (and (>= offset 1) (<= offset 10)) - (setq haskell-indent-offset offset))) - - -(defun set-haskell-list-offset (offset) - "Changes the value of haskell-list-offset, the variable which -determines extra indentation after a line of haskell code for a list." - (interactive "nSet haskell-list-offset to: ") - (if (and (>= offset 0) (<= offset 10)) - (setq haskell-list-offset offset))) - - -(defun set-haskell-comp-offset (offset) - "Changes the value of haskell-comp-offset, the variable which -determines extra indentation after a list comprehension." - (interactive "nSet haskell-comp-offset to: ") - (if (and (>= offset 0) (<= offset 10)) - (setq haskell-comp-offset offset))) - - -(defun set-haskell-then-offset (offset) - "Changes the value of haskell-then-offset, the variable which -determines extra indentation for a `then' keyword after an `if'." - (interactive "nSet haskell-then-offset to: ") - (if (and (>= offset 0) (<= offset 10)) - (setq haskell-then-offset offset))) - - -(defun set-haskell-comment-column (column) - "Changes the value of haskell-comment-column, the variable which -determines where to postition a line comment `--'." - (interactive "nSet haskell-comment-column to: ") - (if (and (>= column 0) (<= column 100)) - (setq haskell-comment-column column))) - -(defun set-haskell-concat-column (column) - "Changes the value of haskell-concat-column, the variable which -determines where to postition a concatenation operator `++'." - (interactive "nSet haskell-concat-column to: ") - (if (and (>= column 0) (<= column 100)) - (setq haskell-concat-column column))) - -(defun set-haskell-where-threshold (column) - "Changes the value of haskell-where-threshold, the variable which -determines when to override positioning a `where' under or after -its corresponding equality." - (interactive "nSet haskell-where-threshold to: ") - (if (and (>= column 0) (<= column 100)) - (setq haskell-where-threshold column))) - -(defun flag ()) \ No newline at end of file diff --git a/ghc/CONTRIB/haskell-modes/glasgow/original/manual.dvi b/ghc/CONTRIB/haskell-modes/glasgow/original/manual.dvi deleted file mode 100644 index 616b0fcb84725b7cba2f8d1d88e67dbfbe256a5c..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 25452 zcmb__3zQsXo$oN+lRyXvh=_nZ2G>k6+?L6!=J0Cjbybk@)N6n9(?o|A-ihugxIp>_+ zKRDDsFnI3Z(7;)r=OeTEcL4u(ckW$z?e^VoWbV6icjqVN$6N7Z#}B%U?f6$c?%3tK z5B#OkbzMhCK7ZJQ-@JJDVN;J?zWo~hKR?>O`@mVxe{nnhbJZ_?wtZ*Eryl?6{$n2b zm({yFj$M9N$9ybfPPUxcIym(0^|rO8cA)Zz>3WtQOw{K5&wWllSY9%`f>XukhJgDIg?{o@yuZVfP8cN?Pu*jUdHCi603V~shKs)J9c+uc3jb6y0!GS zj=|o5gq^(gl%pQoUY+QBbg4OJxPIBR@tDsiu>2)X862?eLa;7tnReEcX}**{g}c3R zH-=K1RZpwU;`MQPY|pRX)BL2DBQ75t3O;bjCGzcek9uTX*6~Y*otwnJoritrKdy<% zKKZ45K4uBO-re!k=l^MP@&+>hF#K;e|K5{ezGC(M-m$v|KGHF7|Duk07y+#FN`nK> z4OZvvKYL{L=-M6kp0Q@>`X!?yYgX?(?822-?LT_uYgbIf&v#|Z?%+Uu5X))Gk{bDe z!O7}-E-f_cIzAN0TWPPw_a@VPwKQD4tA1zv5t#hJSHtd`4Jp#$+@=ypKP6U*d5Rwv-A6Gdeluf%iI{KmipelnGYKk-zghDruQ+IW#>$;%{RDot{|Rg%ykN`QT77x zD=@skt7OAsVBz;*OZ7l*sZpvJnG)rLI^}aMPN|mKllL9Gf-w_o)?<}Tw|{cinQO0A zBz$nNA4D8@digL#WkdD%Kk0DXTrf%`K7F> zWVi*B5BE-`UcJun1K%o}UT>I%K$py|fp2d012bp&j@w`D+MXwGf*eJmRICQim)DmHn3;2Jh)1Lo$9EVkua*rO~*&xrxCe-7#OR?~By z!OOMO{_9Jo;o39>*@_E6B=0R7ZyTl3MBw?RITmEVCL_R*e#s2Ruvl!^q|h2L9oQ%2 zRfOGegS=a@e31U}khJ#LF5^<%A1B?aZRX(lG9Og$*HA=-fd*FrbjKnwj$E@R#PK+B@Cw4 zDMjOOVvK~?f98w-e*V_jJiwgz{@_5vr1AxIC=khxWkTU|po$H7NdMzI*N_&5-9qwl zXda0^UP~?bZV~F`2=#0*wK9ff48LOxtM-CM*0HhAQc&lRjba@me&e>)6lRE~yc0Bh z{iy?^@reo;o_9(m{=(&0w&%ObG`Nz?^|g%&OCPca5eS7l1;WO ztz_m35QGOtl4gNIP*$73JJuoY`|Dy&ydfGC!!bGl|F5?B8KpD^1TGx zvG)CV+n~aL0@GX)+}TZOvzVlF}zAMXtN+Rg#do0P%#Q* z!NcGCFxigh`XViZwKFi|rZ*zf#8)^C*Mf<1){&-bLdLk8mS=3TavBMuxxjPo`{K~> zvf{gG8XdQmnkX;n4?x?A%owB*>XTS>{4yxz#b1CBpfoIu=Rmc}reQ-y^2w!OV~rON zwz1mN(XbfEHQ{)&u#n^!T%OV(&%vkjsnCuZJ6aP>7Ua-&{2+5PR9e3*_Qr&>iM6+A zPE4h~dIHApt);$tnP*^ZF@wG2dM?b|h~Gm40~Jj-jE2X$UnmckN+CY=%rMf>5W~P) z+rgH=v;jRJ-s5Nr*Pg zZ+Mis)ymLD2P9k$d$LN7YeXNx>cK^Vn7$Kwu%{u+h=n(SE$}F8vKN9pVXhMM2(}I` z8LD0cb1HBHu`?J0Z}s9JRwmFT@t)TkI5zgoSIQ1-$;PqJ8LL2ex&zNAgG;p05UDIs zgbSenm!^63A@SU|TFa~;O|A3QO`^SHK2{87l_5tMByt$}N+|%^ zBy92EOR!rQE58U-2P(gMewG&4&N{AQ0C)*YiBF&vK^ZQGzJifbq~fE%GwHeaX*ueNoyrzS1dZD!zR|I^zDtmF!1mDu9&mFdNuF2SkcK%{8Ez8e; zancez2sNpt|NhZ+Sxi@S=9`o~kZK)5AV1guWMmOsi)mSDZULcJz;QWt4iIwRenF>D z1S1$Te9UX+di5;S${r3GQ zozdNUa}pwX6N3YfzXc)P_G;hem5qW~{tz5AM8)l&0RHVavi+4!lapW8!CvQVBE61| z&IL1qz2}A))~#PRvU+(H^jR^yZsoFzF6vvgX6dq>hn@87lKN1aI1WL`A~9DZSQ4Z` zHaofN#FurHF`Uaq7F4zlS^>KOUI5(*)R}-?af3#`27&Y8t$QjS3^D`@TvcBesVX@O zmWNP&VejPL6Tf(qNKK>1GyToAt_N>tWCo{@Gy9AZG%4tzN(Bpgx;Jj@FM99l4*G*4 zOsaAnIdh>3_I7scxb7u+lw;_ptu{|HkudYoLc4+aXl-Qsv;{51KP`kk{Ho*_IhixL zs-QdhTX)dC%21)Ij#C+_kbHCw*hznP;KzeTgy6t^ko%%0LHA#lCrChkgdc^_pk;Ru zKZu1XXI>u%(lBeC*X|UPR6#TnG}^x&)U~6D*%HXhBIS+bF8a+{%w7q9D6`nGLVFCl=yvAA=2TPe2dMNCEb1szMRjqI#7#0U5y2S}(G~|1 z7A$b5P*R?$Jqq= zMC1#e5{W7r<|RiXKD^0P2}Hwj$noh9{gcki4C%bgDE;QPjt>iDQ*m^JWLkk;!d~(n zEN9HM$_C=72;E2TX$nIhBy~j`3Bl7&1+HXIf(v00 z+w271m;vajat(kJQ2HETBj`*e2Mj4$RMlILe?In8&G9dEjVuP-6qvruvGMWz6ijKO zzrT9qCr2MI)Vq6wjg6jA{k~BB`f>g1|EPD<^KxCts%61V`079>*}!Ue0m%!2XWBtF zCx*wt9-s@g)ZEt~&U7gncarrUX6@^%cLzNXu=DB*p%;6PL<~9i31%21HpS-PNrez( zG8{f3mjmKc#vm`q-|m%^APCuv`jO88*2h|Xm8595xaE#7p@S@n1h148d0qO}p2m{C zY!y^0U|sEAA7NqB_R6vfAg z{3ws0HH1M4v9?bfWPBAaV<5NIb;NFYpQIM2-&^g<*q)>|vetZI9b+4Y17g$&aYHz- zutIwsMYBq}6h;E542eDIj6iT?!l>OY6AgRvT%reFYQp6YvcijisIWS`Fl}|R7I2=E zGdl)>!GHv6@}Q1>6Ehr)#v`O!ylc*cp$x<=1)Ak}fi4zE(U!*%2ZD_m5AYL`fWc`VAz81NuSV(Xl-XaM)BAPU6VP8$ zdjhEI_pZ7J(5<2HmOWnDIYyd%vf{K>eE&h(L?4YFb$SRY@-~_>A0wXjeJxFv6*cm+7=v+`V5LT%lh2bTb)k;JATpjPy{ru8!0O9XkgU{O&A{YHct})23ylH#>KnIA zv1Fr|BdhEdt2z&Rx z^Q2#OUz!Z~P#qn3f=KAbJwCCGC`;h?IY(kGwe-;T9@xOZUWgiC$JZBcQf0E#6Sn1R}sz2ej28%|w8e06O1D*ny~4a%e>} z^s>%aV1`Z}*|yN!DoJ;k!H76O(|H4V!_e}=v-&6Zo>1=9+m;RPP#a{pHf?t$+1=Dr z7wFx6VcV>B2f1_&rHb*^wBffUafCf$TlkI}qwQw(#e*=zQiGXD)yjGaaj{;aDe|ag zv5<#WP9T&7C#J4=Qm^%xcl>EVfA6eTdJy3j2{0st14SE5 z)XliiEpe}juiE)~D>Zq7Ags{YMz6aF= zCKdFBPpGumCd*nP)=4#l^=T*861z{^*SPHK>mS>#_w~&6v)b3elu&O9yCMCxTLf=V zYlFNJ1sHmY*37oBls;!_bYDI>H?RL`RWTPl&-P8g8dv+9kAn?uv+L63=LKiun*3!i2}U z7|+isU*h*^A|rPOY)F*AawqU=*Vt2|s=5qC(Kd$6!oZ8pP6!U2B0ZEg;B6>==Y|1A z@$@~XHnBcf4PuUa3bX($GAGR9IyM4Y2+a|QDN095P)nbeiFT;P0_$lKTKpr1C6+%p ziLuL8B8Muntj@XR>E@neZ_Qnor68vWB#wK!?q~R=F^d3c zqUF-0yrsJdr4wikxVtYK>wwx!#3>rcuWi1Js^(OnD`?#kN+`%AZ;~O9t)fEMiXy~y zdghkMo-z}Iyn$W?_$b*;l$p?>g#IuP?X&XUoTOwkO_5=FPEp$rKz!88At72|7*iqCQMSbbnMSUkV z-h9+|*0iV(VDA0bZyjX7SzY$I4Y5!}%jFjQ$-T$@_eZw#`@G{I`zNJ^U~vE<8^Pkm z!5}4sUgD8H5-2U)4!em(4yu;i_}Bk86Jrq;uL2M zh_{x7*M|f|?)mI#cDeRNV^YpKt?bZ~XTmr9+`n{)_$YDYENt{-eXh;FGga9d$-H`X5^ z_>`Y%vI;Se=WQda2b=g$l3Pj}=G}EDX;bJ##Le6+!gkA*v9P7P9-k>}3FB%omO+g| zBPNYMn)X%u0o4qmfnF_r)j0}?SO*Nz17wMQURvHf;6FBz(8vQ~9bBda zkwqDb$m%Krx9m0$=gO`pz#lY1vgC^SS}L(BTX^o|-jf!kB;;(g8oms-X!I|Wfob6~ zu!h?FwTmQ@%MhU3r>K6{{u5)Wr(V48&rkKP4-P1*bBiqX0VCRd9!nd6fGX7TvjpCU zhTobunz5r$>snX#n50hAKaxGl`Ej<0frnyAL<=bHyth6Nw(A)LzB1J>u%4kER*pO= zb0(-q3a^53sqHW!(2hH$J8$}f+|h6>4gvsINK6pIZ7y zb4jK+K9>Xva^;ce3Js7~k$hc!VK9bXESPZsuL<_yY_S}a;#j^zvp|#?QDD1&s;hXh zFe&xy4SyVyVv=Zz)ceEXC|RJkqrJ7XH_yob3?6` zkyY)8Z+}Zgb-mRihmXSkAp$N_1?(bij+|(^lCl9RgDCU7{hiON%7jMkdUy#|n$Z35 z+y9+%r9NWQfLsz z08{c-lPj7jFn@DSc<(3^_(yMJZ-2asC`BEwAsNP?ejh0d>awC5s(KA2~)iBA`X5che+m?}AtSc#s9Fo!{{3VUO; zEMC^e$$%nkG{pe6$U+SXiqqVTHvE9u5+`$pbW@y&`L>RWtg@xt zyJ*@9X3pd|PSn|(Xyet5P3h+rNZzp`xg5Ts3$?oIwd>4F6(@o1GAPbYzzPQ> z%4rZ)*p3PC26+vFNj5WzaO-v^d`KRnwgJULSw}U55PTGQt_C6z#$Caot~#Qt6a9t& zCG4xl1EuD!nk6FD+3&z0BBzPWG>Sga*$8d|9ux_JTIz4_#k%$RDAfEND<@j4^H!c& zw&3y5zlVx*xENcJURmjbk2_{Xqo6j>d;`5?tUc>3v4~zvl>zKgS483#>cGS*v#=a+ z;>5U{pB;ki_Czxi2<8`i!;D}Ko-q(VUJ$6M=66u=&*t!2ST$O&^=BukRaG5C1ji}&SH1r zT6t^@ooS2yV+2-}&3Ik&hEWi3;ZJc6#6TyUP?F6lI3l81rKtnE_^Y?m`#~{^Q>mZ+ z+T^JUO1%xeK=vB;GsMXfd@8CyB`ld`mb86vT9>Ig2*p6oXs|}g(QPy!>z-geCjyMr zZHE`o_9u+chhy~7f-|b=pFXmR2MLt)$H!8z#M{QQ=v@LJh4%YJ=$!Z>2yhWxVEb$mj(b7q;3YwtMzYrneIkQ8;L+8DDB>cWsBrF?v zaH#(*X_&rPjsrshpg_&G6DYg1o9;TvxI~_>j|v#>e63TvZJ!4p(5N3V1>b<&F3PTD z=myR-xYR$C?nS_hpb|b-bV40)K>}sSOmT}LOxc(7YvI(<3lX1#^h3= zhG#6)kwKYYf{pB_+CK$GmqzwP%ergA#@LhOAOI3JL{Zt3*DWK`E5TNM-I^vAMD?hU zI8y0pm4v+~tbV!8G-!)E*c|$OmHkldbU2zO9t7tY5u}MN;1Nl-s8To-bU;IXVjp~- zU2?6nbbhOPNwvjNcf!QrCR(8QQW zE8?M&3CKXp*e&zJ-riOgQKGSgKSCgC;N(k&Cr=UOc(J7g(G{yL9?W^+g(Yy3fE22e zrzLYF)Nu;Jt zAoEQ*ZD#7jES=UmKX;;ZlgT+66@y2asT{v#H?MRK2cgvf=vW=)a86BPJ$}Q49(mXpWd^ki5)5ryNm6p;6`KIL(;e}Uj zTL*}yJBOegJAlYOXvb7~=4vhjv>UOIQY^HhI7i+}6{|s%z=)|3@DdsLUs(yYMtQ zOq3)kQ5^ti7Nuz(+YpAU+)u1=9za|V#8cY0)wxt0x|y@?W|>9Lh=putdu$^!Sv?|u z3>qQfT-pgtTM-FbMQFoOAB@iG)RotWDAu{}{shIC88xRm@2P@L$g>HVAU6B%2Ux&~ zH$^dI@@f9%VOFXAClMMrMe^Z9$y=(z}Z-jqYita;;#xx0m{+ zTBiU>;$~cw*;F}FD-fs*IgRs3Qr{PS49C4UMJTQZ)De^xWmyK3)Kf0KuI&lu1$JHj zYwA&pQ4wvAQrvL$x&TWdf}o6T09fErQNX+CBr?(nGA&4l?}3L@UK-}NDFT!L*%$m4 zyF%F2K6@$PIGGz11dTU`4|jH4JMVAKh@Af1**X2i%ig@xe}Ajfr|nj4(}*vCmXQ^} z-b+tGGsT`SJ5|tpi=UPl54S6X077_9y3*C5ONFLHA)%9Ghz@Y@W7BI#kueU?O(hh& zcPjn!pKIj>AE}ZUB%!TfQzEwK=#3mgoVok1)cGZ%3^WXI{@zf9mzr;7NC^_0wbXY% zE|MHHl-I}WU5oEu!Ak`o+c`;PIl!)sk8*gu3Mr@H)C?gjc0C?7{RkAupfeP=JSarT zU`Ee~%nFV#T>pO&?IG_0SM}^SM=_-GWfK23RZ6WTsKda42P7g2*pb80Cz+sZIQ(I6 z5?28{5_i8M|Hq?BwbYs4Ahv{SNo0Z&aOx&}6v*LQjXsYF%?qi@^_Kv&-jeVkxVu+;b#EL7nVZJ+&<`5d#tEGC65vvA>? z=mfOEUa|l9st3JG2cQfN07s>_NNOc&``3m?<*jkmi0VI&+SycY6n)eZ#WKoBi0X8E z81poeC$ua5av#~3FlN+pxNWc!IWVN^sew4E)^*#eQ9OtZn|K6|GdH3WQ&CvMTRfs;ZbnY-72$IlqN|{`dib?3 zuSgsj@9ITM76Q3Y_r7~f>~;*!RMcLs|UvF3irbi*EvJ0i_5(#y7*F@nLnIzuq!N*c6mhu%4y1_k2=Rq3 zk?oZb1%!pVLd<9AGdR=z-?|k`Ppz8ib=(;TPKrZJCy9c#@JWtFMJb78TX9yBdQnSn zy1Hq?lF54*%v&CfOe}Ss-WHIogk%a2)da{Bsl1N|kH?3LR-uTB5Hbwne)URqb__e0 zvja>pi5-=kcq_--MpQ^zz?SHW9!l{%5IzI)@FZgO*b9E&3Ud)D#V~gm*JW+}Jmym< zyLYPdKB@U=H;Y7xjbjbQj_l!JF2c+@aiaf2TCMzCqc4g*CbKH;8EM? z4gu9b4i4i`EZE$ubedvM4?(*TumuO`F7ccezK&g3u10_wg}9aqP9svwoy zdHuhV9?gbLxe-ktuZb&P(@He;{;BjQKZX*P>h{qn?F`dJ4 zW<1`Wi3a-0o@PW+eMoFiy~8c)V&Yw@}X%X$(UrDfa1f z334||<$*b)q;&ezFER-*mA>?UNh+JSsqsD>dOx;T$YGwa#Oy+eKg&WjqJU1n+A#`< z(oC)5Jw(ZR9pb-fu*K^@4H*0B^B@8jVvZ+pb94hnWbhJAmpBIlWn%gVQQfk}u*8m0 z40rhKVz_1J&Wzy}@urKFtJgsDH>~D**R5EymZh7~C2LmU{)=_Nnhysp7hrVky7aR8 z2UJ(0!AuuAvOyD7G6iKrs6MJGB^2!PMl zIGB}IbS5ALpW#MQq&A3qOHyD_*Er%hY~=jlxPXt;HBkzD2?PQ}#>6kYu+HgKiRI|* zv)HfL**B9Le^Bt5#em4g5~qKUC9hiQ=l`asmqo5gtoKg z5YktAEx{6yD8VwgGw=uz8TK>I5c~0$hYP4Tfnw7@YM?L!J(cD}GuS!dn&{AFOkvVT zRUcxEtP7`$R*JXNQJ{o&5rCYD8F3jGhE(yqo;F6hWJq1DiqneOjjw4^$Riopad12q zg=I-9An@v0_%+pf^Z+iq!5t+lal_vYPmSBPu6!Pt!}UQ<$ah@bmk2PvwB*$HeIr@Q zN&WD324RRCq4n{#05yCJY=Cb>Et;h~>Ss$t2_E6%IbJVIaG`XQg)|kMVi|zar72vZ zC#6nJ7s^~MHSz{u#%WN!U0i6%_c2J*3Pcef8=G(fiWouH3o5oowahiBG7aWH@Cx80 zO;GV%uxmBkQdh)QB=Dgj(SZaCq>QqNX5{t|xiXBX3)j5q%QaE8{q%m7lP@~J5{!zm zM7d54Bm$qjs9u}sK_J7$0!7Tly)C$eMef*)=YkxtlnOfIfW$^!wndRssLo6V7>Q^Y zfdkYVjPHK^RmJ!R7wJnqHee~d)dPf-D_32d_7Ym~i(m;zcA*(8Wq2H4#5&@C5Dgxi z7bqd1(XXZ7_0Jf91sJFyS_SorD1zXW9H8cK6ji!La#7c<0Mb zS_e0-`M{ca{U11{=(M^Ml?fz5RDJeG7m9^uK*sRZXk@_ZRrC|JUh1w9M8!xhLE|u= zX$3q&-kacDdEQDGKKF2tg zP53Y2Y&Y!DI5Y`mdH#-xbe2;0j|zT?5VGdDlvwa2?F;Fn!g+O_P8`Rhq{a-0-k!d$ zPL(wxYcE!%B`jvTNFng3hIksTOzsC}VeRvYwQ@^@QL3g3>uG|~?zP9~C3$K8v$!~= z(bwPK-}iXoiEidi3)@K#iU3P zlBHNoE&cQ^>X_UctksVf1^w0Mh8f92_2m{L@SLItc%#RrXMmfAAHjuhS~yXu!x?fB zNj(d0jl-RDoCZpdo=TXPxCKpJwseu@jm7z}C@x+stGgF2eP=7()Qc)CnAif<|RZ1YK@hKh$ z(u;=ilt$)SYTvs=aD<Ywo5f_>?I}Dkhl;+H)JU^Biz~u3yX3Bt^r^C`};o|qCTe;QMc(8W(dFvFwdC7azJ1PgT4zA zXRn@JuziStn;*`E+&eq)Jux@?2vzq1a?c%iXb1`;Ed5ciwX_4t>RJK^L2h5Z2Z5(< zsM8uwCx&>JuvlyeR|@kJDS~ouIPZ9gSi2;4r|PZ02rnrWq7}lvV!RsE#gDZn@s(G@ zWBRseyaapysV|M#dP4E=>BZ~gfFF}&kLAkrUdJH>D(@mbJ(=my+ZR%>t^yySiYjyd z?)EioTvhh9is9o8>SU4&n*c-n&5}sIwy%Jd_y1>{R}(}hUIz|V{!2VCAJce{Nsl0e z7j%Ocpy}u0zD4RWkD+&hA z5{ky`RP>>-L_{K&wFh!CRnAYtZmDxTp#1XZV#yNQpc=>GTsI9n94`<>wJo!@}H_+3ZGR$vi+st?XN}I-}ZLQ d_J6{m{U42J|HmlW{@sHA>gdR9>wFRa{y#4urUn22 diff --git a/ghc/CONTRIB/haskell-modes/glasgow/original/report.dvi b/ghc/CONTRIB/haskell-modes/glasgow/original/report.dvi deleted file mode 100644 index 5f7aaebabf28236c528d599ebb792ed274bca4f6..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 82272 zcmeFa37lM2o%h|OsuPxog3BX<3vuZVbjNf82!Vh}2oN9%kVbR}NOf0rcaiFVTc`TqXroO^F|qQ=qp z{d`_u^HI9H>fW>b_wD@8FX!y@+8y^Ec6=BAGXHt#^9Bnqe_o|gpJ>#dH*nl>M=u&! zvS{(ZvVkQ7$6TdH_U7Lc{JUY!&1bxR+YOHmefU*3%(=pTy^&wL?*HPM+xXW!_@Gm7 zc;c9;XT7njYh+}fd+s{xhJCi3wRGF-^k03n?S>~#c-o!Yw(We~g5PZ0(e;|oyl2-_ z?)#^8H*_6z>g`?gS;gGp@u95)OFnjPxwyIYMB~0fwN|W0ldZXz{(EI4I<=ImjaHg` zzGeH310P?=5Zfjf?>g9qIB;YnJ;dEBTHPZfr{!v!u72|ag;FV6n`?IcpOK3z)o5+y z>e|wLVf)VKpZYjMeEfOu8L3p8JiU56H(cBPPCmQkmZNq(&4$&gQY*XX)^?c3ihyzj&R_vYUbDZD!@@9LYleevmC z`|n!XwLc?(wpwXm@k6WDuNz#wZg9hneI_nCbJu}q{OqF1_?hnE@#?_h=^{%=NXJO# z?p2lYwQqi)UMNTP+V&ft^X4!6NuK?z|6cI2cmPKmi$6cGy}97k&sbBw`lfolTDkfa zSLGYS^TZmMq@tyUW4d{nPQhUo~1MWT>4 z^a0Yp{GBV7Zr^_6Q{Q$S12Dz(l10pQ{B2v$8_U&OnVUw6HTU94&3R8;%rkR7{)I)` zx3~6v-SYU4=&!$R|Knk>t$FCfKLYl`9DrZ42;2ep(<)crarhQN-r?)K<`d5-RH~b5 z&Fs#n#(@4S{EZC%hfqH%1@)x{^%Vm6pg^6g)e8~A>#S;Jw3-_qm-s4{J@cGdtW7lM z&cFRH2MtGo6EPWhUXlXO z(FwVvfFnIS^)at!*M2Ksh|sQ%W}5rF`IUd!F#4TvJ2nNkV+?L57Y`^@3*~F?IJ`au zd95kurT=o$WbF;uJf#9+?)J<6{|B!VSK!OQ zNr3<%aC^Jo?*5W9D{)TlYz_2n0C8c3wX^iiHTV{zI9eCvm5_1v%|!@R%!+Fv4| zem{ZzKliOePy+s=Jn611lne9gHIeRm>>vmg&#pLJoG>|k_3EvEMZzDJ5DvJ=Y;WEl zwa6QqwOXN8lb;O#H|HL8$X|i^hk^O$;ei+>K_FqvA&_M1qCz(`#>aEj$>_|=C|a}s zn#Y$cjzt&73lDBUUN^8$mTWtxFo6qRsn&V&l()Wc$&wh&)5mxbc4l$B=;XUGlDzIS z%I4aYqm_+OhWXN4|B8B{-q4Z);W1tenKxFbDSp)4_qG51S780W#V32>Hisml6@hnF z7)!|RB*^6KPDQ1RmCmgd2sq}-?M6-^rpG?mza%jOR;HQGg*fC@V<0)ZRgP1KIor+` z804;jbC(=LDDRI7;>}sGTM+M|f#&|Zj$X5F@Eip2`jgLHHMnN|x*hwhJma!ytmJf* z&V}g+h8=O?!35rj)e(3jhUx-u+jl zoKD8n(A8_dRT!=)I?>8LXi^SNq1N{t!DQ3NA5oXZ!+i^Kd5Q`HH~R?4iE z6&CCKoR~24lnH51w1xcw2W9R=Nq+pb+Sd+WKpyG8{1Eb z;_b9Dzd19^USq3IUfn2{ibNfOMIjo--`m_Sl-pW_+dCT?F60~4T**%!zun4w@a?t6 zFiRPWa<%BJcCI$eJJ89hzNlI#O-8j!Nk3S6*t^@9rrO+mB7btO)F{+6^CU0S8&$2H z0rG{apR8V)%Km&;ZWzyWtXS9_71}&pthPrhxl--;X7}~S4UXZtwu`lPxzZjjRfck< zcCB9Fqh9})o2XjM4PmP;Y!}PzTzjIS^|iyQcH0|JYfqn|u#*Q|EA!nC8To zF5oVdEA?pTI`AFk3&W*cm5+wn1^C2ZIT`Uu)Tr?(z=2R2HP{YlumQih;am;AJnupF z43Q;(j$#l)XaD`|K@n;00Kj6PiU|^C&PAiu0=`R?CGeXC$evW#S{y2tigg%i($6Hq zklo1K3=S|sO2fj)qBE8}o~tXkW(@A)N}lX%i?-jaAawKj2c5d246Y|znd`31A^*n; z7@ts#atSP;rc?rSQ>#OU#HH%F(x!+}ONH_%epXJD%A7`Kj^k>YF&Ax7#G6$W^IDT% zu%8_~tUO?Yqp?=zb6?Db%?qG}1c7D+%E{&XTA8oBV5CwiRoYwn#5{VM_&TW!v7e2z z0x0rutx>A?HF;dXs29fz@L8a?+$Mllz%tnObjiCMD2BYkq~rX`eA;rgFjfF^8p1DC zD}n?XFpDwoxDc8z&d0ShlBrk1Bx41|SZbA#I*8aJGHDMZl#P|!;|PQHc+?n<#@gc| zV|H0AO^Os3A>@UIHRV?K!sqAmc_T)xNXxL-%|Y;B1y=&BL$2IgztFyB_ZuJ78$z~+ zy_0GZIEB)PUnc; z<(N9@56^ENuwt`~`1I_sF(LUeTq!li%e4iIn)@BP4x|f=9wqz|7Am;=oo=ZX>m+xtTcN`CO;J-!Vk)S`T`He8XotVS1Wqhrus1fYwRh7)rmRf%DiSswK> z@>Zs`D!uJ!6i*U?jxaL$#42))dIcHav;fZ{)`sziL`tKTcBP#Mswn&p;n7+(1V7h` zE`cb$lz^_4Iq-+j9cCY=(&nrOE`ZTVxWAC2#SxAB0Lm>chsBF)Nv!)5>mqBWvBld@)3l z#Y9`iieAT+Y8B{fxKed%0bIf}AGPa9UsRv{Rz)~SAesR2%k^~-XE$KHW%xXx(iVSUt0uYbxslh6)XcF)5_fOFC)2OX#l+_8e=y>TBX2@ zdKMWXd%)6gWwczZIsDhOzrrxG3w*aH+Y;NJ2Z3@MZm$F(0YM-55@nc+!wo2LkLYFP zPhXD^M;@RD%5F6ZG-+vW>ww>bA{ULvF?%OML6)<6BpX`UpIpSAEvjD_*0QiMHVfUc zZbZ$Gi*CK(lW`PFI**4Mih42{mg>~kj`t)A{Y>!^q%-|03?H`IAcwV{zNyUQ)5a<$ z$Yq{X`!GdXnelsah=&7#2?`H(N4DMn+ts#CXQjnU>OpHXFidRt0Bsmz@@b$FaRp?s z3X$Wr#&CPguP@ii?0hER9z`N!k(%1iyAVF0K(Z))-*#>;ueTMyH#%;QMTXmoV$0s_ zt4Ii-LXfKpgH{C*qg^JA@yuezTbbHRji*h3#cW|D*oKPh;w_YsRH~#@L*&lRANWdu zfB(1y3v4ZZZsVsrq>WdQp8P!_67pND8S%32R`waNOCD2o$vB48cw2CgNo7n}s};ew z`_h!Z8<8EEs;=jXB?-wwmESP6J!KmOcS0#v&!$IF2UX#|hSrN@0m$IP6mkmK2(f$e zxz)l1+hH3F%x;YYfg-SiF45!FXpD8%i0DJ}?5~E^DVi5JWM=?inO}~mn)|%y~G|4oKnbSJ$UO7mE9PU-0t)dr1ZHI6CmxbrKb5`ob`o|IEVI4q`TzFA6Sj8PTlIm(GX+%^ zwWo3Q*hCv^b{r~f%Ys_eocA{$S&u$%V|3Wi?JWSgf{k7=xlyjQ8xwHb2kr$CwOV_o zP#exogq=?_9##}?h9GP&L^E4u*ggF4iV-bWJL!uMNdC)Wd89HO*y=REuD4~-3A_{4 zqDB5NUhRU>*_A!Y$ds9`^)%Eo6|1mKMB8%ymgv@d+i+#h@t?b`l7PJPK zbEtw2ypiQ>TjVhoOHO!oTw+Sv)Z)ydvD!3H{`CreD@M~uu$e`pwP>0EKpbh%i)&?z z-*5tqRS~O2^^_&FultC!2;v+l3FAYh+;Dr7eJj_|K9WwUW1I%2OH;fNr*to4y|E8_ ze4><#CQ%vZn}ZXyO*w}IMiS5TYSSQSAv8Jn@#nI#*+iyU^pF$J=qnk$aomLkwK9(% zhVTN>LI5@lFT{8SmMO*ShcXw-+nucQY5SoYWt&KlAlbCZ;YOA0dm9BTrUZ!|s+AF9 zEU(fNUS7gVkGgmO5Ho;RHB>Crj4N$m-kGWAh8*z--2EepSxn>cO*+y;xCI*M_w#vx zK~vv572ve8j~|uhFu@}1J&%^C73BONx|mkM5ytNTz%0wdyXV?*JfArJ-^Vs;D^C3{ zfN&)}(EK><+yA3ezx=dUz%cDTj%5nqYLJHP)<3M`{hakmEA#iiln!N@Eyf@YkTr{V z*_!dM2yI~I)D=IQ{}y1;A?%%~iP3JJ6wy1Z3`g4FaokzTeSX%BGyVP33;LRKe)|mA zvNh)`D--O2NkpDvD{KyTo2lwBh0qw-W3-G9>z|X<)>Ggwo<^RaeDd;WI$pEBTxfOg zf3X>g@ci(_5)W0y_3D)gZO~C4D2?rDc}{T37FmN%?V)SNb5KnUNAOzNcljn`rtuu? z^Yg}pxK`$?Z-Y21WqB$oZiwwFOy-AgV!fn}*)|3$78~b>vl^Yfw%#?732#lY$#seD=36Lpi+vPV48ie?e z#1rV)GG;+(_UNZ#@d_3N(6f~GP%ck|69HvB;!RRxz`I1imzdKh?oQn zSO-%IJup&lZ)poO&T6+f5l=9E5DG!&5bFpSJ}vF&G`s)fb8KU(dt#j&pUHOFjK_9m zq^%+FVoU8LhSZiBjFAy%-#~`hA6iOeQLshL{g1z9P{i#wpL#mj1&X;eY6_}?>lz-Q zMDQ`ef*8d0Xk|8j7H%0grbHizCIto?OkhCMVR7kw+inUJ1QQU}7D_-Cr)a`JXXF4` z2O?nL9I9sSC(ClMhYJ&03*zGOAFp9U1j7jk8IxO)?^sTeB4(w?LRK{-Gf`A%g!RV; zj-%h*MNOCzWr?;Mo67#n+qV!bE#=!|xky2Ab7c#8nQa;ap)5tr7nm3XTPtOYj$q8O ziD22)E3*Aqgsi=MyV@xGX@otd0e>Prz@U0dq%l_9X^?2-{oH(mV0?v$FL;%^N2E)0 z*Tm3-<3Xun^7VF(P^N|M^8rmO9Iv-B3%}**(L=zQ$?OZq$-rfNtH4ei!wA$F$Xs6~ z(F>8dmpU;G2^w{D+4_;%aJ4v5XD4(2`CCS3CL1gwf)(aGWUx90a-dD^Mv7BelF6HF zC8Nc1*~GFchs46Q$#IL@R!Y&vUH|KV8-`9yTifGAH}5+Uv7f@9#&2c5^O@S1@aF^* zOO`Q@7M0Th;e<`H5U*;y;6nP3p@jHX33+ z!d1Lcr|3MKaF&VOm5KMh|Tvv_<>rfvG5OwshG zpAPi~Qcc3x3*I$P&t+H$wsqGYj&>xlZB3RB+XqT_n!p+=UA#T3J&ZI4?TCl5sl3a;YLCN!&;#%muaK zpHwAJfQ;qxlpbQScnx5?`G}|-5Vg8lUH}nc9P>FnO$Xg+f$(@|F)?-Mi;lnwn1lM^ z&c4VBIg!6Hwj9D`;;?u>QEFFV$x8E-jtj^<22y|cw$w^f$gCDd$uDa(EpfgKJnv`u z(WT=cuApUK{IWr|?#aw+BoO%F1?Ws0BBgk3u|6JEj)tg^K~&g7wMoq5afvIJ!Q&T# zo&|;6!mbFAYm5sjgfBI#!(#oqA5R{@isZw+Gj^SFc?Wt=iCD!C$AX*l@<`Gtb=7b?f{Sr} zZK0&0Xk(i&5_yT1yy+-Du%wqMM>G?%9feL(K}qA+K496(Q;N`|3kSe#&wW>V@pB&g z*~;A(uTY;4R2bXswwZt@PlqnBpjs7AXWnA5*dnlwV~bjDPGP7mup$g&S$P?TPN!B2 z1U_^c4qWf-z351Xw7WU|L!pTs;M2*iH$M<`*&Y=cgj7ocEqYHDeg~*HU+$Rsv#AW$Ap?4z=Gi+9|aGgq&S(H z#Qw;^e-x>NZF0yznfxU`WH=D{II{wZxMx^Xns(4=EI}lM;Bt6n0RYYQ7$Se!QTBO4P%C4NvfID0IQR@MYq??UU?PW{E&b;;pW!oZe9GdoFJxRz|_LEhLsM@JQRb+@BC!~*HvAF%zoJST7MU&=Z zxwI-|wDW!!SH>t;de+oBqcv@vIctLok-f?mp#&crub^s<0!jreHspA6R z#n#%PbfrBX;ZX=)65@r8L2zhJBHk7wPX+k311(8mJqg<2!Rz5TXQwTeA)MlvjS zAhQP{n6Gk>8W*}emHpcf1upc-lJ+#?wgbVpr=hV)399PdYl3TjF{#~38F?`MDM+MN zASTW;3fHtvOA&6B>zxZYn_1h;{>_J`sU2u#|K{J;VuLL-NjtM@T9tTv4$aT~?V6Ri zRAvK6h({J0HrE&Es4Sra%qKN@;WQ;4fo{msBFCzfedSA&hd1Z7K5(8Y4l%6yrm~;E z+o4Vb(adgte^I4#CMo;cl#R6bhyy1DPf||a0?0!2q=rSp4Kd=609~N*`MdeRBhc*$ zRW|3LL!d*S?{p^cxa2a$4db9dg;Y~KLj}=r1Q@GuI&@Gfj>s|<>olqe129rKz=VK6 zEgq;~AwXJPZy}Yd2u5ti;#V5So7Msrea7cC(Pa@=$h~;3-yp>J|zw}JS-O{F@rRWf-n^si@eUJ*d9xt(rH@4 zA85$`v+|sRYIdC5Rk)vwj8580__DH?%HzrkXT-HK4}I5&-3&Pqx|NSIxDPXSS6}W5 zO_5wyL;#>dC5ovh^RA*ruj`7^jq1(E(m2{Iq$EqDsxwSRGOL)h(RS# zY)-fcYmg?eLA+-h%E;LDN%v96r23QaFz*HiplVT7BgdY|>sq=*0ClPBPN^$I(jf7z zTF&?pZQYfTqCKZyxQ1j&K@w-(DTcu?f#nH<52JX+x>KB&7Ep-9Ag}cA7ZJT?8pW?$ zb3XW-oI(Ju?%d@cg4-9vk1{(~6^138uT0dVUema~(hylhex_EZ?ks!NX9kfPem<*t z`ra-|kiM}zp5j4^N4a2BGkeGfYju(n%2&Igm8S0AJmi8fRY=PYwf4b<@T=T8BlWOj zSH3553I(8BiZz0!E2p(U3|F(k8(8JWY>MYQB2+cB;#S}p>P7D`ApLnD9<-hg3ll>)cXOH@>j)UCZYLF%MF}k5e~zSFW2*P zL9?yw<@d*itEdp=;tR}KetzFmLlLiP!_lO7zDonoq;mZdv#tn0rd_&VAi+M;J!Jnq zv70MG8TaO24r-IHe5pnhPx<}C6ePsB3@?o34e4NNYR6iRnUhKu$nKD+rG!gTJ68>2 zQvrf`!{1sPsy^BF$9)|FKvc;s^WvOKWjcdHdu^JbQk!V291LYC$;qdlG8Nv>lekrg z3_A8<4VRzv0H(AeyW((#-kZz5y%4H;{DBrjMmq+WwYt2$>C<*PbnvxVGOv`MdFv|*_J@Fbujebwhe zEQs9FX2xUB60FHiRl_U|CZcoF~IyFn_x?t?1vU>#b+bO`%& zxBtV$D7Lr-h~Y#ZNKm|M)EhfkqF_NBQL~hVFRlsFp;$A)(8{iSo9S0?paz%V_-6L% zJ6|DDMEpv_ig&Ogo&MBmD=YuEP6Jb2g3HXC4fKh-qPXnb(NV3sUar z6+kDI16Da=L;%;$2w*-zF-q)9SUU03k-u@sq|@3tua6_NM0bhM(%XslW{S}|J#k+1 z@o#sjw-b@tTc2=|+O<$pD|6M?*t|W|lRDETf`xb_q-3+3`zY5McnSylP;hmALWn@h zEC~VzvfzOP|7PLxS}S{UTpNpU*z|t4J_WmdiQc_bA~yHSo}h}hf7sx@cIs=WQ7qN_ z8M$bwC!b$-=Mn_lSnK&|S#2x3PsLOp62wkPWuH0VvZEL{Mpv?@JZw|ZCdns>29-@q zQv{Pv2R`BwTtAI6c_SZ7_5lNb{>E7hT-##b>p^YRi9f)F5)t&MNa4s&yrOs`3(#7x z`neO*)FG2c@N)()qm_B$BPlr&zbIiO!8qq^?md6 zhjW6dSi_+iZ5ER$OHQpwR#s{~##%Bd0#P9;?iv|0{5kBP(NuMUWY$boEGJPkhF|wn zA70JJFdS9L+NjkU1l~lgB9fJ+PfhN@kr0dd^kX8)NBQXCKnk2(~VV zSn?f`Rh$8iBz{)!_kt69*B>!;Fa{rEP5=`fbtQ#YVXtB;Y?4w7mCkb)FXW6cxj$ zrZxghDy=zRe7pJTEJI!ZQ+B3SNJciZ*ZgFK!VOq}E-oALk#l}|p%_quP_0irj%pGi zG_QBTCIn)nYA1eK0IBe{8euA-8w5Q`*y)5gqLC`q%GyDQfvL(}Cu}Xn>K>fYXVEk% zELQiSUw2mf6Y<4f8&#Aiv;4q-UJdCd_8@O%e)Q!UXCoExie}dKZ*6wpbBh}oIN3zd z`|bbhoWeM5Lhm@-;Dj)cDQ<-73<6{F$VaECJI_3}kg3X)?)&K!ux@3JIKnN@C7D;!*usdt5-IH@>CVX13nJtCLk`AI9mGy6d*Am> z$*^@7HE{{+j)a)PajwG1g)H4UI%#2NnhKc?{E~+{+GDc8PvwsIH0Qna95&O+Uh*H5 z7s?{ayQmq~x9p0J)h64tsGAOn#HTnyyd^%&Dg)7~%8;CXN+P#bl4fzm54;=A=>lqL z4h|6TD>p7d#RNY#`|E32Zc39`FjK1}%n>2Usv)#7RHW+V@vmWtvNR|lF9QnxN5MlI zv>MZ~5GRNW$_$HR1#+)6fV!{o-snz*VyQ2XK4dYxZxPL9+pUsgzc*~LHm`fC`fsQ@6>v$8Bi zw4xk{F@sK_gCqbG&p-}sKaqTpVWI)(PBD1L8-ksKbj+kN^`eTLAufNDH&9)Qr^JH? zHSa?wt<05kHJmfKS#wSCVkfwfBX7842twWBReVRypcoM6*$6RZFiE~Abm+OHSTj4S zXkAUlU3=T64g0}+8rT#NkDJ9y7S;?Jz6h{l(j*-kPy`KeO7tHHXqw#WL=Ff? z-Pbl1CtxMEi%8j7P<0=wgo@@Gql4xDT8eSAwbxXzmxR49Ii) zzZix4o2-p}NS>P8_qnZtddthgvSjLXW zqv;1uE6N5|k}ZMT$Swk@C)@S7e zXv_(TCt!-b0qeR$m;9M3`CxA05QpxOQ*mv3R3=H(#<}(yZ-vYHAY3h%W_sJt>r{rd z9YH56M(sG&7vAxw7_x)cEY{Ginc2Mji8;9kPaoCFTUc5K7RvV0CW$xU~*ut?Y6CVqlZyBeAEW zfB4O2h8IF;ZD*Cc)qFoW*j#l11Hb*3_Az_O_gijqL0=o|pMxvW zSifG-H|ftTP~<*sWlMH+FHRme=PjPQLLxtCawlNPEWKOSkiw~uv>7MHp-zAr<)jNm zpbH?EY`>YgXt5N9%QjgmR|e-ri(RV^%KQrDG#oScy~E%L38*E51=XBv5i^D8mrhF~ z@nq6rV{rOJiB`foPC6vAJy{6!t6-)Fr^HG2+e;su5bITnW%UKw_o|ZzA!>_hx?qMT zaAUbr2~(>ge4Vm}aKN*pCmpRrhy)t;D%K6?XLS29v$mDJ@P~nYnIRN7kdqJc);+PqZjYdbI7&u9Fl@cyAcj*mJ6K!2>smCM_HEFU9R zP0~T}?c>%nf7z)66X0S6Ey0$%+_h zAd52!bVT5NG)o_QT$3ziq58l~dDqz{0NNI5YYY1%017QkWxx7>r+h%B*eVDeK5&rm zg(M1b41LU?C_Iw!oF3X!NY)>BfkWiDbG(F*$9#%5c+XGg*T|%lM&z$|@enJMv6Dwe z-|f`8)d)(nx*7lply;3jQ3#wUbElQOn`N<&Xe=D6fRtT?)#NoCGkSqbKesaHO-XgY zo~j5O*I_AQGWwW_0ubS2`9Gg}+n~kZ$P=qIQ~<1T7=Vz~CFYE!k>906l*IlX7-^Xf z=xnSh?#!(H97%%o;e@nbKGps7ox48~_rYq{>^PANE=|Z=cg!TL2v($49sk*hA$>xz z{HAtquI)m`ev$eR@=+;f<{uGbCJJKtop}5k*_~9u0+P(#zgT#lh}%?WAX=|O$@C(b zvWG4f7&$CYWkp;I5`tDL!&~=7&-7{8)L8SS1dh>@+w$&^)=MUsYZkqx&Xfd}0vAp~D2g0wsyNXp zoXY|ZPzmZ9`*luqnqZ=UQ{clmoxxa^&M;YWnu^{*3AI_xIrpzq%2VA#Xa(pFFuAy` zmqF-oFPWq?$s84HV96ub&Lsa>LJXl4({1o#v>GpDvyas}N!*fE;_ICtn{nZ!%Y>vh3~MriC3pe`XwjNz(zdn_!fV`}~=r3b!{IERt(} zdqvk^7w8bRGCvDidHCUwD-NX#+i!gKx|f+7G1FVBRCIudjzm@o~M{psXOKXQ$Gtjlx2zB>SeiUvZSyY$ZngEp`kN z1ysm_q#AH%sM)uTJKlBjLitMGnAyUCaM`D3LRD$4<4-l{RK;HWdwJu}hQ>m(a>UX&E)*UN&kG={mR7P6t1lfb-v>CrD~O%ZWJqvCIx zqV`~|7YIC;i#nDJM|z@4xi_tB*Q+}WOGMuzFIokEDR*d?F#`jn>YP$+CSgcfrvyhp z3Wv<17e5t8QV|ub4=M!BHexWyK)PdF=)lZ0dVtuBasL5J^$Xw-h-2gJHy?IQ!xMTQ zwZx&Mdv39}`zz&sJwFlkI#NGt^+gw*V_h6Mxp&Vk@e0-CQCX8cEh-mzc7d|}4%}jl zmo)sMo*rYQvsU+F4f;rQA?-+mCv2AUg)uXA?437wVrsl07{r7`HO7dPJHB zqE)7W%0y?2VqOMt4`a=gQiBXghIpD6dDmf-i~vPwf{N+fQQ(l8Pd$ zpqa{i@+V48etbL^%}n5SbU*iJwk}YG)#*ZJ2n1(e!6PVrJuO*4rG zdRdVn_W;ggVG;Vq&+nO;CLhPg+!ETNg4*An55S!-?-)~KrDDcG<;Ro7vEn3bpwdW1 zisDLpR@a*I1v(QV8=T!5Su+7)9tE+ge@x7)npH?K=5f6;&G046lOVoW;Wg^+(z(L) z?t{s^TN;U1qgU{1YtCo?g_XFCq*#KC+OD_6zByk|p9r{fB@`bvOmP03VJVr`kOIV@ zmyjVYka8z6ALe`~j^6;lkgy_n4K93!GI`sPuoZDImalM4EiFm!5Zx*EdnuWO8#37k zlP{bjtW(z{13hVIf{uns9p|OCt^M+OrU`thN-dj4XiF%sfts#6*=7O!5Nt>NHBYNC4EbZr;MRI)`VU zd`_x2$!Kf~oBhj~h1a~>`=MChj_$BmB95C7^0)YsB*N1uv^zPS*5wKDHG-KYONoLGtpmpz~_VRB-YK_+`w3g+AS16yuf z-ep~%GplxqToj4+hNIa!&FtOtVPOjqC4B>2fGkk(tamI-U?gBP;T5>h%2;eAaEm1~ zr!qgfa(BK_JVj2XECQ#J%y3|Vi9Mk2^g){F150b^ZIewTE5d}qh?hAE&Jm~-aT7<| z!?s}+AQ#+PF)iH$*2Osq(SFUf*!6}wB#)T`8L%oFP#CLpj)567?)1CZG;w^Bp^6}cIl&qi3 zEN?l1nIEk-7)nOE{H#&9j^kAAw1soeeB4rQoe(c4h7ywTgYD7Wn19>Q?_tcDuGC} zz`Fi#-}y9E11|s8v!<0hoP5Uyn*J2Vp-;nTm8(~eeF+xEc!8rqfYp#kO}abT1&pyC zeOUzVPGm6!Z`_inV#a>&o%UaHM#yS&i@?oce%YaUe|sx(e?`@5fhe=2!H9gkGClZV z1X5F+JIVH3x*j=<{)c{=jDj3Bjl$rv`B839Mc9&-;*|!KF{=CYCWD3&O$4nqD?=xH z1S^=-A{7*b9lvlV54!{43{KY&8r(c)^zDScFEABIEUOHEs*EpRxs-rk88;F?ns(yI z%3VXQGyfiD4r^CByw!d95_V}w!LaYX;(Hh{%#c5kWOIp|KeAc6{Xqzd7{4md7LrjI~|UpZZ##}|YdP^$0v z3PJ+1r|3iL)D;-OR%FqJD3ZK@>OYw~r;yA$z9K-HT|J_kZ_PIK<1;zz^g#vA(-&T7 z?H%pCp^(3QCn(gzM5w&QaurO|Lk44T12er%h7=-R)=Rh_JCde8IDJLRP-n%Ua>_5e9q zLx>s#Af-CCeLD#Qr1pG`2sl0TgAf~V9c#_`bp{4l)tvLIhe+D_8%3~WZanDRL{7!N z!l4ks?(VR1Vx-;`XGy9#p?lW@+5^{}a%*L`eh!%H$T8jYEkv=W{pz^Txm|0@(eA=2 zph6UW+bbC>IIX)QF+;C4NpOo`bGny}Z~aHfE%=5rkj4*uk04L%6|p{r8nbFqDe|9i zr3q%*(-^k5Hi<;TwJC<<5(a{Wt<29))`|q&XtF3(^x$T9>B@9(Zb~wBAlX?{mgaMtW1<=3s|U-$R~WW@t?LFN)}j|M;>LA+upsG>64=%Z zi7V^s2y2e>Sh~^d8;*Uo7$N+I69U`;q6?~ij`bYFTk$6v0}2a{wl6@fBfDp3Hd z+pR|Ca&z`pdJRp8Ot5FAgcWF1KGL6p^@OSOPlw&idhA=LA{9oAl(jqTX6Z=}Eq{#w zAk=~+FX&l6Yv1hPr8mJK;R(25*>NUtCQ})WF(W3w0Cb@hR?7RARs7HlkS-|fcKhPh z{?=2O*Flxbu-;NpYQH+iWQv@T_%eqJm0@b%L)sQFOO zOm4b|o}~ADN_!SSLO=6ZFGMp(PIHF5;{X>JpalzNSANzqbU0Xyq@WKdpE-XZ*vU)C z;@oq~(hH0|!ekS^QZbU+C1g2gkmK} zU&cy!Atn;<|MOJa5(*}*jRhrGOk_&+xbk)5cCjuz0!cC2xix4OEx~>tx?uMsa~|Dwru;&W;T#&nCThrQ7CoUvS<}$ zL7Mxe2flTw|7cA)1cA@*8SClm8S1&fe{;T`zCe#Z`|7FQqxyRCJq!I;y}Z?@uPvRy zXh$ZaMg1p6eC>avauBWTL8sHFk{wwW#Zol0Y+1AW&KsvqqHsXMVF(owaHO(u373sx z*ud$;+2=mz?}QW!AGtE`7=+;516QJnOdAlZPtCc1tAbZ5c0!3?vz@mIA{47c8hl?N zt3Zcx#4BpbK(7-TE09xA27*B?#K5x(PPb>Yb;W4hNSKlI*6`EHtU2ZS|I8;FQ~ zNKR17lzjLf0aPVBimG>NGK~J70{H64r@k zgb<6SCTTmuwz?GrnhR6gV-kGt?T-1(=Eqz{p<^P@Rl=*Pd`Q@;ANyYX+kEh!$$jQJ z+S#?uK^eBPuYEi=GE!#@W!q@oVk6W_wE}!38+=P;85dTSrxvtiQ`BB^-sbn5rqc}Q zkB{XA45$|Amn3bi7~i#Ak{n_RySuYPO9-^!SsqOknDEG`XQT(|dh@{xUlgaZGGF^z z8d>M(F0hsbUWBLu)QpT-Y8GA)s{)v&l{xVTNa;LOW_5lT<~rSH&exEuX`)3C(3~SZ72RoNL?h_()NQ zfPA#wv_rHU{;F+pvD1wY{J@|oP3J!4Yxm9(;jJT}60}NM>9Kv&QcXE9bz78k z`_4m--~ATSIbUvgiifu3o2nZI>+kM6eD)Z>oVNQwAdcoP)8#7Vx0T5vsbod>qSt7_@9oJ^Z;EF z0J@Uh)%SCEScNi&*?R>xBQnb5^}5WA&Qhbq6)?qt)mmn~BQYCdyH*ux_dDScE`7vI ze7#ak(!_XrSQ6+$gK)_X5cis2y+x-&h%AJ1J0d6OIJ0|;qm4>~_=Shxpb+)4=WPsZ z1fef*LNbLTM6~PifZqvl2#DfKOA>Q58l`}UX5|RSc&DYpNZn7M8c7G_S(}|@eEJPC z4E2yMl#0<3d_Y^~lWiGD(=p>X$Fhvt<#*C%*`o46To&~`N$d@ zC|*^7nE0%f`GOixrO3xR7QqHI4`lQ)ANqkET^+Q$0w^#^xV6k(1&A$k$}i)JKzS|@ zod=U|3NIbzn!*cOCedIrD;TUOWnfZYQc;2AnUM<3KdYud(VYmiXo#Qr=!ocO4O{zS zGuE(q>E7tb=qPQ zH%k{`W7(uMIeGl6K<$KwwZ+-{$ejJFP-?HQP5RFS^y#H(pAQNGn%fAd3)8a{WYg-E zc=Xx7f?0gl#CyzsL4JC7sML&0x59A8rPaWh`5aFUyF31L@p{E{2hVc8m$iwR%3Ss# zA6ThM5LkIZ+%m~xS)s|I#7J#I#gi7j;?jXxHU$QRZvK)P!Zu#NZ%*;h5M<@lm-@LK zGi`0|u;nGk&AOFf082EGBH<->H4Sm;=#3<-7I;OjbBK4%?o_h&$?Uhu*h&s^Y>NV8 zI0dGQH`2-syj4;S0VG2&99p{-#` zxY(>cy-Y_Ieo_xm?%uu?&1f>3HU|b$#0<6|@^5Q6n6Q8B2{X$vym*Vdx^JE7KQVT022~)EJ@Z7f*%cUy{N>c_%<_v5Qi-2^?W?Vqs_xNi zd{~FxMVRh1niL$C(iXd~iqBcO1E|aD1u}8M&L85=yy@y#^!I!^N|>Zvn{a;^9o!hEPSYq@*x!=cSRqH%^*9HS|)>oPNA! zkTKCyiy7W|3b6ggTL1|mLqs?cMM@j+8bls;sLcEKI5-{l37)5B^GCcWUsA?6rfv<_ z%3SjiWCTMKSWIp~hM(+Y@GrRY<;|QrwQS0Qb>l2H})DeOprR*p{ zFdO}9&2W|wt<-4gr5l}bsDS99?|o)4&j*5e9t;Kz;rvEtO2yad8TX3`IwT3~O}Vq_ z|7hCjL?$?7;8vSp$x|Ng%`HU9H&_4Nc`GC)HGHD)e6u;N(Alr@I9VnOcV;3&|LX{S z-j)>-Ob~PC#^!E_%?{ZkIqZ>v#om(}XdFJ>JG9%(R%B+J{D)`8_}SC6wb#G*cTcfT1wq?GBz29_o>q1Cyjy?wstg$U zuqwA0;bB^`R#UjpfPU2y%zv0YiF_Crqh~6!-ey7Ew$8ZT;*MDPY)2Z{>iF;B z|E&Nl*;_yvizGeWYQbMhKUbNFAV~7gT?+4{$eHbE@^pG zB*23mXUAIF^<@kt?Cn_$&J;>0V1Ly_2+EQm#PPJ%?=XT;7C~BsDtlY0(xPNlClIBlO9&%~Wj@kl*NKRsalM;)+@e5AHw&_d56*v zQ|;19*qOL5H7miuz_jGNmAULj&Sre+742uXf@9B#5C{|6nW{8L#=!-t@m}k^%DU9nc+g)KS)fHdoowhy}5R2L?KI zgboT1%Ajv`|IKS8*%YyoS>>F%DL$oK6FdR{PVHH)O71X@uQOrQSi!!uBeAIt_gK8a zXl@s_h6-c6npn;g+}i&t3YxR~-{7ym^Cd{nzddde?uIKseOrS~2oR9O6q+^(anGs{6GK zYMr62G?&U@JapCi$xn7=BJpfE7V)Bm4%Y1&amx?uBkYL=)!}U;qTn^V!Y7Lr`hM^V zUZ6C?HSY|G9;ObSI9wi8e#VhwE_`GmXLhKP2m9O`Mds}@tQye7Ji41J&z42csnCTb zB5|O#2gNXE-ecOu`)k(iB;^=1yI=OUH7QA(bn5x%56hRsJgl^>0UweL+fj58Z$+1T z+Xa;#c3@5b^ATk=Dau#y40^9z;hedHQi@uW1Cx~k$!8adec&O97sR~HZq>Rx(< zo6B9vBi{3qL9HZ;1w1duU=BJvSgRwvBVroK{e97jIQ#0Tj>MZ?7{!`Y#1^u!R+|a& zdX$2Qq>J&=MU)qlpWHxrL8lltxc1Gf{ZdmsjA6}I=7;;Ik7pPK%RVP?<8npL%y-p( zjyj-7QHQVKw5FuSG74!4cr^>nN#TURr-wuUC^!9H4tzp09=$W{ct>WdeWR}BFtRa+ zsNI+YjDC0-i&o*S<>6&F7y$ta-mLkUR~TP__EV4P;%5cU$&(NAXkPR1mP-FE*6*?y z*>C=>X&ziQ6CFH}lATh2d|=Bm0&oyA7mvV}Ta9zN{Io896E+7#!u{lI<>805l{D}L zRTE?gA(m@Mp5>qGvI$*#hX3PKgy_l>l;kGj-B;K!nZpxHjxz#QkS586?46idbNr4RDQNkV90$+hBy)1uqWE)v?(w+$$kC(Uen zMWWx7^USa!aMA6CWZ#R)-9+Gf%cQQ>Gp?DxuMNB$JDhL>VVxuXQw+sM!M9SYMlZ2v z;HtJ~E>l_9EyWEDyVtJh&wc2KEI@^5MAZEwT(AO+q$MDNz^+QElrBwqr;Z>~eWTcv z%jGi1{o8%7)`Yf8m!>x7=~>A@0{Rd-$$8`u``D^bu|j=;M0Ie8pr8BL~)t)MnZn$OBAX^B?Tx$wz9xy<4_%a;!{54d7*d9>t+*iUQVqdMbxUzw6PlT^8g$*ty!@BD)10dS3ErPcE%68PeG)pv*7F1}0_Vdq2vgw= zwaG{`p$l_)2`kRxF!MvkT!lPMjJ%EIvRJJ2IWL~o=j@Y91sjEpF(x>Uo-a%>02%=x zQ$@)Ah3z7T)6H(H=qfcVYuXD_=o=vK=T4`GrZTOILlu`{QbiYSwVOan{PP>vz@NgD zYhY~l4*UFwhAN5T$)hh#tPGZU`R#Ve#)ZBhjFSXUN1yP z#u(6OZ6A|wX76~9(>zm|7u@YYLj9N{G8`A(7{b<1e7~S;Ld6~Lqv`@;ZhO_j-ILPF zhJu-a#qKJ~U@H^jAm+-MJ-^kII%s8X`L&PX%+_pB-jA+zr4cF1NhX|wwxD91@9YA# z7US3ij-L13TB8eSJDOgREC%h8cV`J>8U_W*o;i=luBS=|OGD2EqO`vMJ!cK#YbcWVjzD zzWsnNTbbv7%2`K9LqE6+mjt6*aIj30Mc`QloS=Oq_;kXQDjW9&HENv_)3gb}Z>J`x&?l=gdm6Rfx49xJ|D-<=3c6@S$+w=g+^2qXH{OQX!ED=e) zpL1jR+{e)J6zJV`utla7(T*$hG@vt&e$P;PV2J2kTrC@?l@I++NcT9Iqce@itrU%5 zDL~^CCaYw|#Tx@jnm`L09ak_EKYDsdS0Z}s8ns@qBg~b`Dzq{e?7;H%ucl0V3;Jmx zp(}#S1ecMPTNo%h5uh$3mY(nx>)nL%6Fz<9SrUp;e2JWJrbogd#vFdWWMG7tyV2Oe z0;%9#lYA%#^JlACnc@pnbr8oamF%Gk-tn6ui14yE**T(QMSF2sV_pd$}hW`v(oU}|MH zeWF^h8O$irx-@QZ=G}C`E(?hEn+E>(pS8x_NQ%PRGI@^E2MkhfB%(#f;qo*mN_pEI>lha-ttb{Mf8D7vo0??~ThXhCPnT_2Ai zo*LR6{x>ZR^xWp{@4WfB-d&$QPeH5f{!hghkk*(5M+-~fr@6L4ug=C|%+>m_{Zy-#07Pu%~E9oUGGr$NGS?wNQ>RG?e#)Qm~ME0mK z$^tz_bZV%n_hhD=IqFDd*dog+3#nx?q zZ6ekmAr}lI%5!;C*JX1GPd2mF)L?jUXj|b>%mO=~XD%!jJ+jTO8F8XTD>o4MKSb3< zAM77HiWvfjOZ;dZkfOUKJGD1*qEYWqUvqTw=P9k-YungVaH31^(p5;aC*bW(*D)1wI}P>aZ9rSZ_6NLW(k4 z>Ej1+ZkCzwJmHlDk$hApqj0D)=&1L=1==sfWU1hz1*)>@VU(u2=0_)m{OiDyWU@r_ z|GwFZBeB>#aPP$CUF-h@v3b-ivH1r#=#t&%m#0!&y!n~uOa+i88T&yI^LKTpN||`B zEDv|fjjzWKhC|xsaFU42y}RFf<(hODQ0B0O2NQ*7G|X}p7gM|S!xgY=W%qr9+L)Mr zo6WhRCwMo(tWleU9GNL7)QW`Eife9mh2l2h1N;e5EOY6i9gC&FG>eV7e;2&;0zlH{ z#o|U8`XCLpL%%oWs6U9V?AC{@6eKBXkYgsp?zS2ubp)e*n6PTs#=ClZJ>pFusSteC z-OMd53!W9EGCRHz^asoV#XFf68FN>Nvao+RKj&t!1hv}H$hp8Mc<2>Auu6aEocZ9P z)1tZ8t^1^JVhy*OAQbc1q)GY7z+!Pv6BQ9kK?W8N_)qMh8gg@Bv6YLkgWXj^@A8|1 zN(e#);I}d#+JTHO7ZfDQQRoL`oY?OOqJ@sGp~88J*YM`h4Wdi6a-x=VK`06RG5(WZ=zdDf8eH|MRPB)ef>Obtcvg(k)e<_p>m6=yG!gu4 zu-U4YM&}0`P2u0>*`quG5 z?YbNjp8NYKiS>N48Bs)?^Zq;tgW>3XDre%6-odOqWPy>n!dpO?nP;pGwn)A{9 zkwMBR5%&#j2mf^I^6^_+^AX4Bq8<^4{sryZ`r}pgWK5)SV_-?^(LYT~d28 z-LbIfmEpDg%_=psacOB9Kd8`wa%#g%D&u>aD>Yms7+CTPH(~6{H3`eSU=bXAfh^V$CieFM! zO$yyrjOdbM9yUIY+-3+GtB;5-44RkMsm{1oK5Rv-uKoD~-M;CT=xqZhGV&;Mdg~QR z4Q#d$nRT=gOuD`lL!ZA5Xm?LucL4@k@Wf^S6Jc_TtzdBXaz4L6f4)+bTNo`r(HYz?dDth;LGD zX?G|`0~5*c^Q!FQiJ!{G2qXlooX(36g2^AwMO;9TE3sxqN-_iHmg~A=isHBcpx z^Ny~6eEm1m^z5mvdE8|;dQ#r8&weZaF-5b@r62!|C)?z!m~NX3E`M}4()Egcq*Te( z&*B_mp?Zos)hR>6dSC@7`^Ni_nTS4m8|MqB=;26r*6!%KbKbxC1f>mePA*^E>c6^v zzn3IZE;d<@t(d-#@4Zv9w+>+0q&ps2Dg~r^c*}N-c5b1SvEy4?pTeLJKF)=r|g}1 z^6C5j1oPyWPV>YUBysumj0{#DTiSv#lKWk!4%){c)^!ko4b1ML&$MHr;aY^4wvln2P`LUyyxVCSu2kB zG#2Bq2KCX!=23wbf=6x%7?GpfE8DA;Is2Qm+}DHZZqIGrTsM|4&~EYUZ(?&gUq)@@ z2*8@vmB^(yydHbjA>Qs|=rcw0@8kO#j3h;-xV$$%=d|^x2OMn6m=oqwW2HDk zc8)*L=17Y=O!8iTw0P0c3lV<;A&1TT!$}RZZ}?!blwtpgexkx=gqnFH`e7)vurCi< zVUY`Qj(6A}Ke~ADDbQ125cK%P&R8kdU12rN++=D%tDgGwr^mjG=2qs8Z(@kaZdNg` zN#2-h(FyogiU6fhZuFqeDx9*83<*Z6>cf`(#phgqFtxPc#%LogLIcskY@K(QvpkPueJA_OkIma|S~oIB(wmRE3dPkh`O;U&5`5V<)J ziVej(MfnvEo;3udt(j4L>HS$w%QlX7^Ey9_>mziOCrD$$6R8*dRHmP4NNm}6v2xI% z?(&wv)dsGIAJ+ML`qXG0sv$~+<0*slA&e~;yEyB{9UJH^4I9c}bHAFk1x(|IYH)y& zZ5}o_k2_Ap^BZJDka2KS3o~4FQIDC^8pwv=vszE{pc5Z=l)DAv%ZB77yFX}0*VS+Q zPOK?=w@_`)rC`i8gbA=InIdILtMUDpYsvPpi3LBxbmig%mG)Mm%8(pN;odsx!bN|M zo`E;wEKl;i`xV`5AhS*x76{2G1nQAne%rq0*+Z}1J@+OT#BDdm#H1apxXkSz^tVss z6y0%kzih;kh~pGJ%ffSIRAAF%H|$0Ri(SSO@VRVRj4xdFYGrGYZL%)VHW6I{oGvX+ zCH9wgJ7OvP9ku9!5z>8RzOTNUrVj&_Ita?-A_VoWOV@bU0s9tVXd@=$ zunB2K8U7#r4>ws50wxr^G$ML2TGk4Dy`ImxO4dV4U(Yf63fpmz8(j+dW2fcdl z?OD8t*w&Fa)|(1Z?|ASn@wpAdMQ3>0 zQi}2^1;v;fJVZ|^ZjCiUYAvqGhzsqxNFPgcfBMyqV61CQQd2gjHr8ve_30}a36@e? zL42=pq_(2rrIc(RetK5fF}=-|_cQ(8iFb4n9bBYYHLiQK5Y~tX5t#sFn%;5l58$cd zs1?syER&)Z}4x)fE_{A9iOB;+h}Ov z!WZkqfyE1>Bh8=C+|0VjrZ4m?bO#5(8Xpb_aRZAlWF8_5XoxbXHv74^{$hq;sRIDb z12~0od-nvric2mEaqsHmKDq9NcnkWd+5gyC#wu=Xv!Ga3T?HkMgG=kg+wKmiRAZuH-RmYuqhEk#E4$A{rWJh!Y|!;W9N~QRW3~&&{_BepFp?AI z8@U!bJme#GHiXMN_&P(w6wnhkEjeTJNk*-?B9<_?>25%ROQ_m@)>73Q8zl4?jx0s>ogC94u&uefg9f=S(@eNDI)zb!P2%3v^<+1V3oahb!RS4QIK< zhR(rzXXrfiq}>gjqjZpZ)%ta-&OCR+n)T~;>~qGqPn{mvLl*~2yV@}cCDT8#w^^e)Q-ACdKgP^+TGR!$asp|iL2^AO!2by7Ly#US&&X* zU2?4EPH53^fQFfNd6$=!N%u733C*slk6p}}V#1~e*LRw=-g(E$RCnoihHG^n^fd{5 zIdV9Ln$D*Z^-Z{0N*|{Nb$43QI8t?<#Y@>6>q3R-dKuULDp^wY8_%+)(C&H~1|jdH zOizn15YRqa99fqG3RY-N%Ai)e-~}>p7%z;wY8{~E{pV3gm>jFUAg5JpefzqJ9h__KOGo1Hdi!g!p`GuifGlRjY%)DZfpQ0=o!}E*BU&Q zH3mMcg`o@O@zYlNvkDQWm(a0l^n6}DIKXETr z*v)+(y`OmK+#4QWYsYQW!Ijgw34pu1{*N7b_eO^glR0AI@=$k?k-r*8cr?iAC^!d^ zi2AA`7s^WE2vlqVvOm6HO^9NJJ7L&kV?DhQ&-gE0=$+nRfUzc^mm9UR7OexAZs20Q zMo)bK*Xropi7l2oY(okHRIY?gxg4hgm#yyAYb;mBu|PaQTH=ah7B%<#=o{R)Mn1AP zIQ7F(V~S1f5uzuz&9Qwc0b#8W9euir5f41o@`7L$1fKCeU9<{dbE6{7Bc`m1hVy!^ zjz|6|D<@XS{v6%Yz?|AWD+1Tq?;6bt`03(J24X|A>zRX4(Om8{BQOAR;Z^}}rmnys zMPRhLpLeKM%VN1|kM`PZEYyYs8cOkD=)|a1scn7;Fe$pPYF(}>a#v$*J>GAbdu9dJ z%);Nu*xRBi7~dGxw>G33W_X)LSPaaVz&)yKfLJNk}=y|uLgzqxUP7~GbR*4v%G?0^!8FJG%$Z+ufhyCgVVLZAu5Dgra= zZ|9h|GRNg)>k=EbZRj2@qP>z=)X(|*6K!u;g5q!P^8_LW;$e z0ujrjX2U04NYMH6#9CvBdbQB>CPJP&cVp1n(PSrVQlXsB=3LEntBMy zdy$vhE}gz}-=WLi*wr;M(sf&P&d&YM{F2pI&wtfNcRt#`{F8{;?aim$lzVtZEA#Y0 zuH-JM8wcQ%Eav!}@=N(>!|>IgIBpCtF1GNWx_1`-zx`rwE&SPyomn{{t_qRkn$8MO zWsYs6PK?QsB}HtaO0{I1Q~)5I^2WncUcyoM@JJkQ;ZP)6+A=JEvFt<*vjOQ>1cSY$x<-;$SAehic7LgA zH&9hYBJteas%5*-Kh!}~>cpXZ`Nsag- zNca^8%9$qJ&kVg(ll`0Vh)vgcJ2YuX)Y6?X!JcE^0C1qlb$PUQqxH!OvORhTvG@5D z3#&rTrL{n|$xqVB!|d7x4cCy2|H$_ft2gtpc|v_K>q6X4+@@XxuHPANcyRmDKtrf$ z(V()zk*d&R8;jDf%hpiAe?p1PKlfZbiUcCr1CE=ei{o+Zs_PewTSC@1qf<$dx@u9X z!HY!AWRyZaYW+c(jy`m+WA(mZTmBaC7CxzBcf~2$FSz2*S)SAGdY=`_L z-Gyw(%UzZ#LV}P5TU|IBhN=ZCbkGV(p7nEPHy3RZ2Bw9w(O=E_LBvduvUcH?4-6$| zXODSEIPo&D=9;?!au$NMkW^;|SYa;sjmF(K6~ri(U8NYvxl?aBL85y&&>+Wt}+Kk}H1F zPT~b_pMG%A5^U$MM9tW8z&yYY3=6;*kAezan&t@0`RvXan~a`>x>ZfhM3Hky+J7xJ zNdgP6r=3Q2-~BvCS_eX^H=GS@G-vwPky%GZU|} zA-8BNcM|wfNTy>+0e(~w+$_$~bB=jb>x`Nntj*t}PhBa4;+I(##yeV$jb5lSLs) zVY9mM?6C!)1k1+Yze>rlw0Z1dFHmA zkNtMnw&tS;e&gO1*v(y^rwo2u^YOkrcg{I~%j)gT?8^OKF7X~jMCsME zK@UCFH%=(TaF6Wa7@L5N^kLa7-HA+#ofx&@{z)^UuZ7Z>%0(DSgs;QCq%oy#Yx}>Q zoePkiWqHRpIcEt1(xP1CVy&TQU^XGi8gfyQO|m3`O^CZ2FeY?3yV-1x+0BM?b|Fi= zfC?=F!OelsEo%)rOh-h~K^z+^lnK^LwTL&gVo|hXE!uL)I4BDC_kW)EeZTK);xr>O zVUlyc^S$r$ywCmi!sPWjm{nU$!JO=p*Eb^S%}W1!bC{qITef`ze~dEt)+~PYP0B^a zv_;zo!^wr0FiuW2zeFIlxkW&sDjk~ah#;b&WDMz4ugT^{k@!3pb}{bVU9;86>;S+I&r~evda)|K1^8A2=3|IoobsROaPRFg3r9a zs`x@ObO>ba7?evT4C8KhsKtopj@n3!5w)dxQCa!v+l{oqc+~JwNo3{qvyc>&<7?j$ zLnuG@=7@U}M~kx7?!?>eb(E^%B;zFvA`amUG=;VB61c5bb;Vey@j3Cx9OGa9;84eS zky2m1t2@OTJsZ}p?dTS5Y;1I0vTE;)v&N_PFPwj9aZmTaphodR(?5h6Wq2WA-L?%! z6S;-(xg-9nYMt?W6XllYnY(AVG+QBGsPd3j3S1|OGDoApb8WesJS+=ve5ySEhA_l# z+rW^mVEr{10F)xK2V8{8Fq3hh2JS+E-mL!%OT3QtfU9Gc-#g!gFM%7ORx!5LbG&|7 zSk`LF0~Oif5{lx27<&Ig9hhDt%YC_7?kmS&qs!`074JdZ=LCy=GWg~qn*?!&Kdehn zWx6xST#i5rxJ&p%eWtfM#}f=J?nj4)8dA3z4DKwN;+Z&jAykvqXy6 ziZV@Gti(=;ZbD^C}u%|EoA%-bzS{MIfM$EP-9zk=P?@#=?HhHk@N&{ z@)&${bNP8z{^xdfWssO^tn|}$>Jdq(z#PmfA>*Uxtn_y&sOE8@sL>T!hw-dqAf}u) z-GU}lE26|r0j$yuk8_<6o`p>m_RuV?#R^woT7GAvOiQrjQdbSi9uG2uBTOVP-JqD# zVUt!|bOCpIx-@r7DNAASg0dc8sH7nn{Fxj2F zR0f-QrbeE&O9se^q}ry+&zyzR5yI7MlEK2lTyB+0kHB2NUY>R%`x;y9xYQ6MMl1c( z%@PQ}skjk3F&g1!#zp@VVn{F)6Dtur>dz@X^gYoNT3y)Y8?**#uf*0yJ6Y)$->|s! zMCrG>Vmca9+HH*T`DDpv<4k%9l8|F*ueW{1$OOAHv00(@Kjo|pXKFtdJ=VvthP52O ztCA|Qv41ICGV^0U(|2BhETS8*8@ZcAtRAp4B_rp2b1^wk#c6~$z@Pcpzv`I+Elkta zQ4BD%xcwd_?9il%@=S9X$Y5fd-eMUYagolLod$4dwFiaqQl;5%zwa&th2X<1-CEEB)%wo5uDT9=$9O+8}%vW{ewx;sx;xCW>zurBKd zg9EyxQC-)sM(tA3ghH<3d(Jjp@fZl+2d{+ufbcaZ#sdvPYb_D1$!(m@AFk~Mb{AMS zp(d&X0j*SNoWZnHx%5b{OV$Ew`0Z*m;z$+}EwfY%=mw zJfS;tFb}urifEoLnhyFWu_F3lMIIrBgkoX-l)G0vTp0@c5^l0m+ojEN2Pyiwxuy%v zXea)P+rWC3kI_+jT>yGrJGFGD{jE60*j99Th9Clxd@!$d{sBOw!d}V2+doC21p`8nHOea%&*L>{Q;Y5c;ZQwMcIDn@9>cg~rUPm)uhmW|ible_k+}?xIU9SbFkt zf#mYf8Blw2azwB{!@Ww1$C#oho`e$S0UyQ9OGBml$;f~M3=#CpZ54fd_yyH-zU_-{ zcqubIqRu$4Dw!Tn^P>zovM@&3?0-LbwrV4Sbvg<>g%v6Fn6n`jnCjwff*$Nv?=e#k zX2Q;Z_lPIjNAzi4lcC)oEw* zz+?Ab`OBZQ1q=vqtu!CEtH|TFw-z2|bBd+noQOxEJX5LxsI+?WR!=%IZ}o*|{}gX^ z!8C7`07r-DHYbBbid7r_tj6$ z{02%MA%d$pLW;Kr>D<0z^#G;L5+^opg25#9u|ZUxPB&c#8HE*H$x0I=sr-USX&@w_ z=T8GtQx-Lw`Q$cjrYVoA4~kkn3hiWIu%{2VCqWU}+k_6k#b7IJFSk!59AQ%ru^WX? zl|K4}lrI5!1CJlee^y2)-ezJqZLr>t-fl{et2CkfhGzxk!9|Iy-!Z=>xAZVN@{2${ z8;9|&FtX1K#ws5kun>)E?w)%gxZqyKw5v}zu)(+-KI2s2GX+yfYW?ab32;(^B7X7y zmVrKG&R5)#3Kn&^VLj;ydx5HjzAoZj0p^Xg$DkuPv@xucVbo5iR?<7hOs|i%9 zqbSX&=x_i{Nj)K{;7j@I4J$|{;n$7`K=mLQ7S-FSn9~9p7yv`m86ub$Vij7bK*5e^ zclZq^yhKMHgr+hOs#B90kXv89(tGP(Y&uwrnECNyN=gN)Zf0~8^V8OHw1()2SGQIA zVa8$TR?4qB>iUn}U9pQ=selGh1?bYGjJv+Z)d^u1uV`b5=tvya(}gNTfK&tv9p0v{ z6tu6zk>9rzYxc~IzR$3t3PDlXbWi+TnXAbyD643#F!6!wfE4N!Qt^`RzI?fl?LZs& zAZQ{YG85#OGJYB#@&>jrX~GPHU<-9B7D7)$v#jnE(?ChFlm40=2Wt@6+;Rl`U^}XU zERqh9Dr{_10bn-Ip;71L}@{2Pk>B7y~CZD?M>xh&fAjY@<5> zvFR~ju1mlssf}R{;0Ku;_MyJD3F#PDGk+gXARtn|V$4xi z+Jl6_vkp$Ng=2AJF_C$rhswYXHbS1>v(8bwkb|h&Kn?x{ftGJzO<{P%3rfRE9G*DS zrXLy0i{H)u6&`Z#OtFsADSz3qvsN8yEU1spGvGC`B&Xk41Zgjm$E$mg$OGuiK|kaM zGq!(~J=@8Pn3|e;qTq1q$x5qmA!Y7~j65Q=6+4CVd2o3|noDrM9y?T18P@FGkuv~_ z4G>T;duu247wk+Q(I+Qe9q>W(@yu_3RKF~m@18@ArVyC9+V&$s7NO&O1z(KR@&axj zVMv)61fQ7=f9OJ+R3y^?99u|&4M0s{X{jVgY}-`n74yX~l);cO(QqmAVGtkGG=hqJ z`jn&yFaG3JD=i;s57s#xs?gjAkB)Td-0xDKY?22(TvHL`@f0~kd59nu5eRB?aiJ9H zU!;cR0$>!0I^-g*1>s0EDjLD^LO>zFEkz(Y92$Wtf;)YQ=RLBS@7|*~nGdP(iIbs=zVQAVaDJ4Hab$uwzd0|C%3D~Yc-rIdO&NwzBz$?JS9?d#{%x}Cg zm>ITzue?n$e5*)z@KzglMgL|f(ede zBgyQvCkkdebehv4yA&OQ{C}yc4GUu|E3bY^4BOK`G71u;5(l-GVpPRz8%>%NRENZw zL<+ZW-q9v*lVsP6(hQ*jS8*rQf96`p7C~Mdr+k-aQrnVtpe6%~sL}8_vYl8`?QJ>h zGzR?+qQSB17V8SAn|Tpz)Bqu`sG4x%KwyFCwTYG#Fz#wL4B;Sr>nbw~AU> zU#I3at#1p&v0^Uv5GaugnU;(2Q2}18z72zHDTO3LF48)Cs(keKg?Rk6;9IJ|4`IvO z{T?6Az#eaSZ8P(jx$K62NcZy%(tv}K41_ovZs-KS;y$wSBezj|Xv0F?{%2`P$|=4` z{%;r&bo8ZzE5Z`-im%pJ?bB|OW=$iLR3j>aXTJ*LAy)=cMI*l;BPg5e)|Ybn6RzrL zaRzXtJ>2?ISbEkS{{W6HJm>|DkiW2k1`QEHVi_m|XarNr*h_u90b0N>Fl*_+f%HrF zBuyCrMl4j0Qz{|vh0kqSfFA5RwZ5oVFZ;L)N_7JOK` zzU^;wM|R9LBYJ!;qk!Y_oNb)PjS8&MoUI8fRV41L?TR!lC{UG^2Xm=^3iSpjA5jEn z#>@5{8o@bF^#(n?8AS#ijouACN~d>suD_(a(YtrX((%jpFFef6c5b?4r3a{~pU$17 zhnMQZXvI%nWh^2O-MtX%k=(%Ip?v(qMC+NyB!v(RhC(>U%=g|$Lohu?4C|>N2>0sR z?S$v*YECKeqgfom-zi8&%+rGNchrBMu^Lk#Cnh@ZO>37w`BZ_sVSglR&fm#QaHlK8 z_d=zjOasgch}GCP=9zr-aX48M5Kyf|ggoPcnu~_UC~CRfO zf0b;24(!@z#VeU#T9?tu##4wC3#uP+VQ*SrODzBvAC0_Sdh^FQEBxtQl{&=)J5zMi z903U$IWjs<@t&!916CDKFrjQrH2~NXML1dXzNMGtAq*{2ZvXcvCxywv$zX9rZopS0 zkgEkf=;lwQT_hot|6sb1B{!-{;L(9x%-Tz)N+)y$85;^!5Sj)i3S49EZT4{dOg<1X zLF{jntM0xbbKHHC`F@UBp_m%sFm;jWBM%g`L8wUkDa#@`r&!@IDSsOY5n&UJT<{p?*3L15W{U#V3ey-*cwyXVV-?=`pzOuK z8OpfIj?tDh&D;-mh&yZi^v&bf+SnZhH5ogzCR!g|#P+k&^YbjP5E0r$Jqf2p22w@t zbZJUo2y}}6(R^8?{-cYcxCubU!<7gBU#mreyu*v(u%?1@KdlCM;P`$@MOaRcSB3`F zU$l(^OS~$UxbwZM^(mwzGa&_B;$dgy9T&(@Q+*$yL8>|ic6yf9+znYG7~=h49M$e2 zn?xwVGUi7%;}}bF)}nW~RE}rnRxG~C^%q6odflVMy9x z7ZVG>G7Nbl$^}IOOMx4`P^L4hS?tR z6#y&BI2iGp*RAz94I!nsreG8SM@%n_2_KSJTuL+$@+_FvY%jiFNu_U6d4V|cZ6@9( zzEEoK(HUF6Rb%AX9C@)@Tn~gQAhH=8s+yxM)+R zO`vRx6Jv0Bv@Gvmo0t zEY%1`9rgWp2Hz`UU6t&wImSIOEQEMnqh1+Gg|(DemOlvbFdxC_#Yj(8?O6PwO{@Hw z2RkepY0vv>E$k513)i`4r62vgokO{9b3uEc9X#$87N6XH*riqUVBBX*L_j_En!;ne zLWnjMj^>6M(A^Nb#=GDYD-NPnG=oWi$u^=0B*)aAeRHnu2-S+`S+!!1Ju=a{b!#{H zthY0^Z_mEJ`2Mq@%kR7}B%&)9_3HG~%P+=7zq5tesmsR(85eQdJ%8{L$ATIN-49v$ z%FCfQEGS)&s(6l-KIUICYx>5!DLtOuAf_C)S(VC@F89`oDo@_?jED(FpyW-)nvaFI&V;}uu zg@^a)as&Qry0l6ql+rv@`_24S<^|9MRv(-#3)7Y=ns`v2?nw!%#M3LHF#B;lh`gIa zPM-}U(#E*uh@D%rYY<)%n0g`VLMI?=WxMPZ9LT=66y(~xsaYosuJo~ao}Q^Wv!%Rc zTv9)b!Yr)G0$J%jt168`53xQ_BEkUounUTpa8YP|K#A1Jj79w`!AGvn5RvQxxH`W@vC*dP6hbnFPJ>AXe{!o_q{C#esQZbpC+y?4oCgk zy)CzX{tn$3rBAtSaNnsP*lm=)-wtM-Vc@WO8gd$9(2hdZC@G)rEK+#nwYskKp}$#U z*}C9?;o(Y?S?Q^Fu@e3>ug{DzolmgFDql}pw^0xJHj(jw#LdY24J@r?{l3YRseGLU ztb#?^HiR(Qr!jZM_y^y?=*=Wvw}Hu`TkftPh1IY$H4`LwI0{9rW5>Sd?vqdaU=%;? zP4xT9yAo^7C6OV^HxV>T%PN&lkx7wKo3JWhDRV6PiY+8HmB$nXR@ksr)?}p{U(ySL z?V;bY_qyFMHl_0mlejs~$*nqt?+)~``?Qs4+=u~`6p?Qu(8!NjMkK5i87s+Ph$#94 zvJoW@!mN$h02GAs8zNRDNrQV7Z?7+}y^X=4+-p*qBzd7+vrEG53Ij6W#3EJ(dBgoI z3ls1#8}z8ORq<28Pa4H~W1t%MZxl4wX6G0S(@(#H8)7)of?;RUF&?E5A8;(Sa@VV` zztW60H7uO`cd>z3hr%zwQSzwp?p0LYzDe+b1<9#c0lL-utoe~SaXLr;H76#upI47A z1JBd7*c$UmV}dZ7`Dt!OBfncoI$4xrnM98Drn^=iu1SO9JJi^defX(#^J6B65B zz?;q+ZN-I0Z`srwUdSV(z&ftmJXqDDa!(?D5T`rAOPGqgbY15wd&4M`8z+D>?OP@OD6`PLvRHDNkLsG zD!SbkflgN!22^C_6Q+a$j*zlPFFz3AyzLMhpdboDF9ihyFig%o<~hiF(vbz&Hy=2E z|Lm-M>K8G@3d9nV_YyhQj_1_~qVc#7_e1D1MxQIyviJ#Lb*s*TDoRdMof7XaJZ3lJV;!E_x?k`bmpB;n=ya`*l9g zqTDz=4`fBE53Y0YVxmbZXF_{W&4p66ePdPJX92C%RhKClMp~mb3W1@kRcMqlWS1M$irN-mSCRHYA$UwZIMp^`0fW?DWaR3}SQyo=gw?@OHy(v$ zHuKd-L)pjzuDer3ZFv&CEc&ri%}0;#cf=qYqRks| zXJUm39w)VL37x+ou_tlFUmJ`ZBJPg-3ibSH5wCJ6AcE)VLkI?U-`KJ0(hYNnB)I*( zS?T!4!YSImL#dR0rh+5s1{wE)x3Kp@#SUeP6x5l@M5}BzO;?}&#)(qL=FSk)3#%Gw zbJ|(yz4s^UJbx*W+iOFiEAXmbIMD)8=CVk;;R za0!iLFWgX3mKgZ1s=^qmF2WSR>(D!?CA{R8L!?e*bxL!rddT8`n$)kV8U^WPteU0+ z@d4cY_!wrl#uOY&x-wP9eBTWQZPaFQ3AUo3opm(TlKhhvGYM}$R8SleFkFSzU|Y(= zT6-=Nmdh{Rf(Wy)qL!2^2+F`=6nI|fhp`wM+o=S=o0ded!9B{^bKa~OvYN0FDPqO5 zBXFtSEBd3Ci7rXz-x2^qg2>$YCG-Cn_MHUF8n?eFC(zGH_o2-c}(j=H-lrRV= zA|1z`zLxQk3}{pd%jb5RNn|nx9sz1CWxb09!H4fA=YgPBC1onGOUJ~)l8f|PZFdta zfGM_CC5@Qm@!yN-4hf~D#pD25wm6mbPqe=KBZa~ry#gVNvH)^g67@Pcmr)OdHG$CV z$gF(g{hOPzy*kU;hO^Dhf$G^%#hfqq@;-?qc8h`N)tZyAEGy(fgVTwq6g_37Q|=Gq zCPWD|T)BMj+TzQMG%Z7ER*(@r1XwqvZu|M8>4WHqz3Rvuv2)(=r{osjFwGH@-cW=s zD?eFBDD>IT7N!jA-=a9Li>GoaxY0c1xs}5xRPJ&?$OrC|Zft}OSqs$U9n2CLm~fb& zkmhG+h_$Cm|5F=eW&^iTa@3RkFrfx7O3!&oC&n560vTP^EHy&IqwKoA#sDi}nxl}I za<|of?^Z%AlHNyJ@v=470k1s3bSREAZ5z4&(deK{yaHk8O|g4(#HuQ;+O$ z7C&(4;dChRySk(2;?AzFxoa<3*{S6>^mKMN)^@Dh(9yNG<)^!A`xh>1J|R=>4|MFA zn0M_WGskZJhHUq>BSZnYF|T#&)(rqos9e|M=z&!29z+C$FL&02L=%?>o+W{l4=xKDV=~>@c0nCjHC&_ddv9Pyg za^idY7f!qF%)wqxpyjI%z+Zy1P(`$2lG~sT$u#p;M!o6oa zdy||NwzPlKg3F0poq6iFE*jYeUasg`&8!Jxk5i=`Z|$kdm0vHdGd{}SE<#Dy+a}k; z(bb)e%Vcv@n4zKE_O{(nEc~;AV)13&ppOQ)2Gy8Xbgg0xD?ZDG%BFI~w(zYmwcnt@ zx^q@_pWB(W9{1vsMT?g%J$u>Ita~2jXeU})rVG7 zc|pb#6fRY+!3_v`Ta2sNyKG#}>x-?QqWc9)mn>=QZgh+d66&GheaTY7AQr|GIyNl~ z*jNvNR>p?1)^9CXJ+`GngTzsreirb-nAIE`Q+yr}(lxJuleWp_^nw##$G907YMTUi z-sxYd*82FfBW~~_RQyh4&he+Lo)?~AFbnu^yM?x`YNfGuUSrkRH7K;U$>v5?-noso zRX;Br$dO@0lRm50X#kZj1pbviL^vzIx&PuS%^bDSYiK#{pWQ7aj*rzE>#Ey1&o)IQ z?8koI*eSdOrTF3d(wRZ8rg4j+9CVv9WTn9|x>d9CigUK5Sjn=9qfSA3?x5m^xEgak zS^6EDb`r=%z#Q(-CcW%cwfv0*^A@oFr=D{CkAbm6tv-#kodDoQE1Bu)+;Hy76+P#6 zch6nCcrm8)!f$Ovg_CDL=~v9UyGn|M+5(#BCRfI!IaG;afV#-0qa?V=!zSnHw@x0D zOk-Fe>&$s&Q+pte?h&)xYh(w1f6v7=%@{)eF~avsbjpu=^3 -;;; -;;; ... What it buys you: very little actually, but the nice things are -;;; -;;; (i) Pressing line feed indents the next line according to the -;;; previous one, -;;; (ii) Pressing Meta-; gives you a comment on the current line, -;;; (iii) For literate scripts, pressing line feed gives you a bird -;;; track on the next line if there was one on the previous -;;; line, and does the indentation -;;; (iv) For literate scripts, pressing Meta-Tab toggles a bird track -;;; on or off at the beginning of the current line, -;;; (v) There's a function for toggling bird tracks on all lines in a -;;; region. -;;; (vi) Emacs says "Haskell" or "Literate Haskell" in the mode line :-) -;;; -;;; You'll have to make the necessary changes in .emacs to load in the -;;; library automatically (you probably know what to do). ... - -(defvar haskell-mode-map () - "Keymap used in Haskell mode.") - -(defvar haskell-literate-mode-map () - "Keymap used in Haskell literate script mode.") - -(defvar haskell-mode-syntax-table () - "Syntax table for haskell mode.") - -(if haskell-mode-map - () - (setq haskell-mode-map (make-sparse-keymap)) - (define-key haskell-mode-map "\C-j" 'haskell-newline-and-indent)) - -(if haskell-literate-mode-map - () - (setq haskell-literate-mode-map (make-sparse-keymap)) - (define-key haskell-literate-mode-map "\C-j" 'haskell-literate-newline-and-indent) - (define-key haskell-literate-mode-map "\M-\C-i" 'haskell-literate-toggle-bird-track-line)) - -(if haskell-mode-syntax-table - () - (let ((i 0)) - (setq haskell-mode-syntax-table (make-syntax-table)) - (while (< i ?0) - (modify-syntax-entry i "." haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i (1+ ?9)) - (modify-syntax-entry i "_" haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i ?A) - (modify-syntax-entry i "." haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i (1+ ?Z)) - (modify-syntax-entry i "w" haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i ?a) - (modify-syntax-entry i "." haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i (1+ ?z)) - (modify-syntax-entry i "w" haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i 128) - (modify-syntax-entry i "." haskell-mode-syntax-table) - (setq i (1+ i))) - (modify-syntax-entry ? " " haskell-mode-syntax-table) - (modify-syntax-entry ?\t " " haskell-mode-syntax-table) - (modify-syntax-entry ?\n ">" haskell-mode-syntax-table) - (modify-syntax-entry ?\f ">" haskell-mode-syntax-table) - (modify-syntax-entry ?\" "\"" haskell-mode-syntax-table) - (modify-syntax-entry ?\' "w" haskell-mode-syntax-table) - (modify-syntax-entry ?_ "w" haskell-mode-syntax-table) - (modify-syntax-entry ?\\ "." haskell-mode-syntax-table) - (modify-syntax-entry ?\( "()" haskell-mode-syntax-table) - (modify-syntax-entry ?\) ")(" haskell-mode-syntax-table) - (modify-syntax-entry ?\[ "(]" haskell-mode-syntax-table) - (modify-syntax-entry ?\] ")[" haskell-mode-syntax-table) - (modify-syntax-entry ?{ "(}1" haskell-mode-syntax-table) - (modify-syntax-entry ?} "){4" haskell-mode-syntax-table) - (modify-syntax-entry ?- "_ 123" haskell-mode-syntax-table) - )) - -(defun haskell-vars () - (kill-all-local-variables) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "^$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'comment-start) - (setq comment-start "--") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "--[^a-zA-Z0-9]*") - (make-local-variable 'comment-column) - (setq comment-column 40) - (make-local-variable 'comment-indent-hook) - (setq comment-indent-hook 'haskell-comment-indent)) - -(defun haskell-mode () - "Major mode for editing Haskell programs. -Blank lines separate paragraphs, Comments start with '--'. -Use Linefeed to do a newline and indent to the level of the previous line. -Tab simply inserts a TAB character. -Entry to this mode calls the value of haskell-mode-hook if non-nil." - (interactive) - (haskell-vars) - (setq major-mode 'haskell-mode) - (setq mode-name "Haskell") - (use-local-map haskell-mode-map) - (set-syntax-table haskell-mode-syntax-table) - (run-hooks 'haskell-mode-hook)) - -(defun haskell-literate-mode () - "Major mode for editing haskell programs in literate script form. -Linefeed produces a newline, indented maybe with a bird track on it. -M-TAB toggles the state of the bird track on the current-line. -Entry to this mode calls haskell-mode-hook and haskell-literate-mode-hook." - (interactive) - (haskell-vars) - (setq major-mode 'haskell-literate-mode) - (setq mode-name "Literate Haskell") - (use-local-map haskell-literate-mode-map) - (set-syntax-table haskell-mode-syntax-table) - (run-hooks 'haskell-mode-hook) - (run-hooks 'haskell-literate-mode-hook)) - -;; Find the indentation level for a comment.. -(defun haskell-comment-indent () - (skip-chars-backward " \t") - ;; if the line is blank, put the comment at the beginning, - ;; else at comment-column - (if (bolp) 0 (max (1+ (current-column)) comment-column))) - -;; Newline, and indent according to the previous line's indentation. -;; Don't forget to use 'indent-tabs-mode' if you require tabs to be used -;; for indentation. -(defun haskell-newline-and-indent () - (interactive) - (newline) - (let ((c 0)) - (save-excursion - (forward-line -1) - (back-to-indentation) - (setq c (if (eolp) 0 (current-column)))) - (indent-to c))) ;ident new line to this level - -;;; Functions for literate scripts - -;; Newline and maybe add a bird track, indent -(defun haskell-literate-newline-and-indent () - (interactive) - (newline) - (let ((bird-track nil) (indent-column 0)) - (save-excursion - (forward-line -1) - (if (= (following-char) ?>) (setq bird-track t)) - (skip-chars-forward "^ \t") - (skip-chars-forward " \t") - (setq indent-column (if (eolp) 0 (current-column)))) - (if bird-track (insert-char ?> 1)) - (indent-to indent-column))) - -;; Toggle bird-track ][ -(defun haskell-literate-toggle-bird-track-line () - (interactive) - (save-excursion - (beginning-of-line) - (if (= (following-char) ? ) - (progn (delete-char 1) (insert-char ?> 1)) - (if (= (following-char) ?>) - (progn (delete-char 1) (insert-char ? 1)) - (progn (insert-char ?> 1) (insert-char ? 1)))))) - -(defun haskell-literate-toggle-bird-track-region (start end) - (interactive "r") - (save-excursion - (goto-char start) - (while (<= (point) end) - (beginning-of-line) - (haskell-literate-toggle-bird-track-line) - (forward-line 1)))) - diff --git a/ghc/CONTRIB/haskell-modes/simonm/real/haskell.el b/ghc/CONTRIB/haskell-modes/simonm/real/haskell.el deleted file mode 100644 index 6adc7441ed..0000000000 --- a/ghc/CONTRIB/haskell-modes/simonm/real/haskell.el +++ /dev/null @@ -1,202 +0,0 @@ -;;; Haskell mode for emacs (c) Simon Marlow 11/1/92 - -(defvar haskell-mode-map () - "Keymap used in Haskell mode.") - -(defvar haskell-literate-mode-map () - "Keymap used in Haskell literate script mode.") - -(defvar haskell-mode-syntax-table () - "Syntax table for haskell mode.") - -(if haskell-mode-map - () - (setq haskell-mode-map (make-sparse-keymap)) - (define-key haskell-mode-map "\C-j" 'haskell-newline-and-indent)) - -(if haskell-literate-mode-map - () - (setq haskell-literate-mode-map (make-sparse-keymap)) - (define-key haskell-literate-mode-map "\C-j" - 'haskell-literate-newline-and-indent) - (define-key haskell-literate-mode-map "\M-\C-i" - 'haskell-literate-toggle-bird-track-line) - (define-key haskell-literate-mode-map "\M-m" - 'haskell-literate-back-to-indentation)) - - -(if haskell-mode-syntax-table - () - (let ((i 0)) - (setq haskell-mode-syntax-table (make-syntax-table)) -; (while (< i ?0) -; (modify-syntax-entry i "." haskell-mode-syntax-table) -; (setq i (1+ i))) -; (while (< i (1+ ?9)) -; (modify-syntax-entry i "_" haskell-mode-syntax-table) -; (setq i (1+ i))) -; (while (< i ?A) -; (modify-syntax-entry i "." haskell-mode-syntax-table) -; (setq i (1+ i))) -; (while (< i (1+ ?Z)) -; (modify-syntax-entry i "w" haskell-mode-syntax-table) -; (setq i (1+ i))) -; (while (< i ?a) -; (modify-syntax-entry i "." haskell-mode-syntax-table) -; (setq i (1+ i))) -; (while (< i (1+ ?z)) -; (modify-syntax-entry i "w" haskell-mode-syntax-table) -; (setq i (1+ i))) -; (while (< i 128) -; (modify-syntax-entry i "." haskell-mode-syntax-table) -; (setq i (1+ i))) - (modify-syntax-entry ? " " haskell-mode-syntax-table) - (modify-syntax-entry ?\t " " haskell-mode-syntax-table) - (modify-syntax-entry ?\f "> b" haskell-mode-syntax-table) - (modify-syntax-entry ?\n "> b" haskell-mode-syntax-table) - (modify-syntax-entry ?\" "\"" haskell-mode-syntax-table) - (modify-syntax-entry ?\' "w" haskell-mode-syntax-table) - (modify-syntax-entry ?_ "w" haskell-mode-syntax-table) - (modify-syntax-entry ?\\ "." haskell-mode-syntax-table) - (modify-syntax-entry ?\( "()" haskell-mode-syntax-table) - (modify-syntax-entry ?\) ")(" haskell-mode-syntax-table) - (modify-syntax-entry ?\[ "(]" haskell-mode-syntax-table) - (modify-syntax-entry ?\] ")[" haskell-mode-syntax-table) - (modify-syntax-entry ?{ "(}1" haskell-mode-syntax-table) - (modify-syntax-entry ?} "){4" haskell-mode-syntax-table) - (modify-syntax-entry ?- ". 12b" haskell-mode-syntax-table) - )) - -(defun haskell-vars () - (kill-all-local-variables) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "^$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'comment-start) - (setq comment-start "--") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "--[^a-zA-Z0-9]*") - (make-local-variable 'comment-column) - (setq comment-column 40) - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'haskell-comment-indent) - ) - -(defun haskell-mode () - "Major mode for editing Haskell programs. -Blank lines separate paragraphs, Comments start with '--'. -Use Linefeed to do a newline and indent to the level of the previous line. -Tab simply inserts a TAB character. -Entry to this mode calls the value of haskell-mode-hook if non-nil." - (interactive) - (haskell-vars) - (setq major-mode 'haskell-mode) - (setq mode-name "Haskell") - (use-local-map haskell-mode-map) - (set-syntax-table haskell-mode-syntax-table) - (run-hooks 'haskell-mode-hook)) - -(defun haskell-literate-mode () - "Major mode for editing haskell programs in literate script form. -Linefeed produces a newline, indented maybe with a bird track on it. -M-TAB toggles the state of the bird track on the current-line. -Entry to this mode calls haskell-mode-hook and haskell-literate-mode-hook." - (interactive) - (haskell-vars) - (make-local-variable 'font-lock-keywords) - (setq font-lock-keywords haskell-literate-font-lock-keywords) - (setq major-mode 'haskell-literate-mode) - (setq mode-name "Literate Haskell") - (use-local-map haskell-literate-mode-map) - (set-syntax-table haskell-mode-syntax-table) - (run-hooks 'haskell-mode-hook) - (run-hooks 'haskell-literate-mode-hook)) - -;; Find the indentation level for a comment.. -(defun haskell-comment-indent () - (skip-chars-backward " \t") - ;; if the line is blank, put the comment at the beginning, - ;; else at comment-column - (if (bolp) 0 (max (1+ (current-column)) comment-column))) - -;; Newline, and indent according to the previous line's indentation. -;; Don't forget to use 'indent-tabs-mode' if you require tabs to be used -;; for indentation. -(defun haskell-newline-and-indent () - (interactive) - (newline) - (let ((c 0)) - (save-excursion - (forward-line -1) - (back-to-indentation) - (setq c (if (eolp) 0 (current-column)))) - (indent-to c))) ;ident new line to this level - -;;; Functions for literate scripts - -;; Newline and maybe add a bird track, indent -(defun haskell-literate-newline-and-indent () - (interactive) - (newline) - (let ((bird-track nil) (indent-column 0)) - (save-excursion - (forward-line -1) - (if (= (following-char) ?>) (setq bird-track t)) - (skip-chars-forward "^ \t") - (skip-chars-forward " \t") - (setq indent-column (if (eolp) 0 (current-column)))) - (if bird-track (insert-char ?> 1)) - (indent-to indent-column))) - -;; Toggle bird-track ][ -(defun haskell-literate-toggle-bird-track-line () - (interactive) - (save-excursion - (beginning-of-line) - (if (= (following-char) ? ) - (progn (delete-char 1) (insert-char ?> 1)) - (if (= (following-char) ?>) - (progn (delete-char 1) (insert-char ? 1)) - (progn (insert-char ?> 1) (insert-char ? 1)))))) - -(defun haskell-literate-toggle-bird-track-region (start end) - (interactive "r") - (save-excursion - (goto-char start) - (while (<= (point) end) - (beginning-of-line) - (haskell-literate-toggle-bird-track-line) - (forward-line 1)))) - -(defun haskell-literate-back-to-indentation () - (interactive) - (beginning-of-line) - (if (= (following-char) ?>) - (forward-char 1)) - (skip-chars-forward " \t")) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; keywords for jwz's font-look-mode (lemacs 19) -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar haskell-literate-font-lock-keywords () - "Font definitions for Literate Haskell files.") - -(setq haskell-literate-font-lock-keywords - (list - '("^[^>\n].*$" . font-lock-comment-face) - (concat "\\b\\(" - (mapconcat 'identity - '("case" "class" "data" "default" "deriving" "else" - "hiding" "if" "import" "in" "infix" "infixl" - "infixr" "instance" "interface" "let" "module" - "of" "renaming" "then" "to" "type" "where") - "\\|") - "\\)\\b") -; '("(\\|)\\|\\[\\|\\]\\|,\\|[\\\\!$#^%&*@~?=-+<>.:]+" . font-lock-function-name-face) - )) - diff --git a/ghc/CONTRIB/haskell-modes/yale/chak/haskell.el b/ghc/CONTRIB/haskell-modes/yale/chak/haskell.el deleted file mode 100644 index 4470553ce9..0000000000 --- a/ghc/CONTRIB/haskell-modes/yale/chak/haskell.el +++ /dev/null @@ -1,1866 +0,0 @@ -;;; ================================================================== -;;; File: haskell.el ;;; -;;; ;;; -;;; Author: A. Satish Pai ;;; -;;; Maria M. Gutierrez ;;; -;;; Dan Rabin (Jul-1991) ;;; -;;; ================================================================== -;;; Time-stamp: -;;; ================================================================== -;;; -;;; extended by Manuel M.T. Chakravarty with rudimentary editing features -;;; (including better syntax table) and support for the font-lock-mode; -;;; changes are marked with !chak! -;;; -;;; using this mode on a 19.x Emacs running under a window system automagically -;;; applies the font-lock-mode; this feature can be switched off by setting -;;; `haskell-auto-font-lock' to `nil' - -;;; Description: Haskell mode for GNU Emacs. - -;;; Related files: comint.el - -;;; Contents: - -;;; Update Log - -;;; Known bugs / problems -;;; - the haskell editing mode (indentation, etc) is still missing. -;;; - the handling for errors from haskell needs to be rethought. -;;; - general cleanup of code. - - -;;; Errors generated - -;;; ================================================================== -;;; Haskell mode for editing files, and an Inferior Haskell mode to -;;; run a Haskell process. This file contains stuff snarfed and -;;; modified from tea.el, scheme.el, etc. This file may be freely -;;; modified; however, if you have any bug-corrections or useful -;;; improvements, I'd appreciate it if you sent me the mods so that -;;; I can merge them into the version I maintain. -;;; -;;; The inferior Haskell mode requires comint.el. -;;; -;;; You might want to add this to your .emacs to go automagically -;;; into Haskell mode while finding .hs files. -;;; -;;; (setq auto-mode-alist -;;; (cons '("\\.hs$" . haskell-mode) -;;; auto-mode-alist)_) -;;; -;;; To use this file, set up your .emacs to autoload this file for -;;; haskell-mode. For example: -;;; -;;; (autoload 'haskell-mode "$HASKELL/emacs-tools/haskell.elc" -;;; "Load Haskell mode" t) -;;; -;;; (autoload 'run-mode "$HASKELL/emacs-tools/haskell.elc" -;;; "Load Haskell mode" t) -;;; -;;; [Note: The path name given above is Yale specific!! Modify as -;;; required.] -;;; ================================================================ - -;;; Announce your existence to the world at large. - -(provide 'haskell) - - -;;; Load these other files. - -(require 'comint) ; Olin Shivers' comint mode is the substratum - -;;; !chak! -;;; -(if (and window-system (string-match "19." emacs-version)) - (require 'font-lock)) - - - -;;; ================================================================ -;;; Declare a bunch of variables. -;;; ================================================================ - - -;;; User settable (via M-x set-variable and M-x edit-options) - -(defvar haskell-program-name (getenv "HASKELLPROG") - "*Program invoked by the haskell command.") - -(defvar haskell-auto-create-process t - "*If not nil, create a Haskell process automatically when required to evaluate or compile Haskell code.") - -(defvar haskell-auto-switch-input t - "*If not nil, jump to *haskell* buffer automatically on input request.") - -(defvar haskell-ask-before-saving t - "*If not nil, ask before saving random haskell-mode buffers.") - -(defvar haskell-initial-printers '("interactive") - "*Printers to set when starting a new Haskell process.") - - -;;; Pad/buffer Initialization variables - -(defvar *haskell-buffer* "*haskell*" - "Name of the haskell process buffer") - -(defvar haskell-main-pad "\*Main-pad\*" - "Scratch pad associated with module Main") - -(defvar haskell-main-module "Main") - - -(defvar *last-loaded* nil) -(defvar *last-module* haskell-main-module) -(defvar *last-pad* haskell-main-pad) - - -;;; These are used for haskell-tutorial mode. - -(defvar *ht-source-file* "$HASKELL/progs/tutorial/tutorial.lhs") -(defvar *ht-temp-buffer* nil) -(defvar *ht-file-buffer* "Haskell-Tutorial-Master") - -;;; !chak! variables for font-lock-mode support -;;; - -(defvar haskell-auto-font-lock t - "Use font-lock-mode by default.") - -(defvar haskell-font-lock-keywords - (list - "\\bcase\\b" "\\bclass\\b" "\\bdata\\b" "\\bdefault\\b" "\\bderiving\\b" - "\\belse\\b" "\\bhiding\\b" "\\bif\\b" "\\bimport\\b" "\\bin\\b" - "\\binfix\\b" "\\binfixl\\b" "\\binfixr\\b" "\\binstance\\b" - "\\binterface\\b" "\\blet\\b" "\\bmodule\\b" "\\bof\\b" "\\brenaming\\b" - "\\bthen\\b" "\\bto\\b" "\\btype\\b" "\\bwhere\\b" - ;'("\\S_\\(\\.\\.\\|::\\|=>\\|=\\|@\\||\\|~\\|-\\|<-\\|->\\)\\S_" . 1) - '("\\bdata\\b\\s *\\(\\w+\\)\\(\\w\\|\\s \\)*=[^>]" 1 font-lock-type-face) - '("\\bdata\\b\\(\\s \\|(\\|)\\|\\w\\)*=>\\s *\n?\\s *\\(\\w+\\)" 2 - font-lock-type-face) - '("\\btype\\b\\s *\\(\\w+\\)" 1 font-lock-type-face) - '("\\(\\w+\\)\\s *::\\(\\s \\|$\\)" 1 font-lock-function-name-face) - '("(\\(\\s_+\\))\\s *::\\(\\s \\|$\\)" 1 font-lock-function-name-face) -; '("\\($\\|[^\\\\]\\)\\('[^\\\\]'\\)" 2 font-lock-string-face t) - '("\\('\\([^\\\\]\\|\\\\'\\)'\\)" 1 font-lock-string-face t) - ) - "Additional expressions to highlight in Haskell mode.") - - - -;;; ================================================================ -;;; Haskell editing mode stuff -;;; ================================================================ - -;;; Leave this place alone... -;;; The definitions below have been pared down to the bare -;;; minimum; they will be restored later. -;;; -;;; -Satish 2/5. - -;;; Keymap for Haskell mode -(defvar haskell-mode-map (make-sparse-keymap) - "Keymap used for haskell-mode") - -(defun haskell-establish-key-bindings (keymap) - (define-key keymap "\C-ce" 'haskell-eval) - (define-key keymap "\C-cr" 'haskell-run) - (define-key keymap "\C-ct" 'haskell-report-type) - (define-key keymap "\C-cm" 'haskell-run-main) - (define-key keymap "\C-c\C-r" 'haskell-run-file) - (define-key keymap "\C-cp" 'haskell-get-pad) - (define-key keymap "\C-c\C-o" 'haskell-optimizers) - (define-key keymap "\C-c\C-p" 'haskell-printers) - (define-key keymap "\C-cc" 'haskell-compile) - (define-key keymap "\C-cl" 'haskell-load) - (define-key keymap "\C-ch" 'haskell-switch) - (define-key keymap "\C-c\C-k" 'haskell-kill) - (define-key keymap "\C-c:" 'haskell-command) - (define-key keymap "\C-cq" 'haskell-exit) - (define-key keymap "\C-ci" 'haskell-interrupt) - (define-key keymap "\C-cu" 'haskell-edit-unit)) - - -(haskell-establish-key-bindings haskell-mode-map) - - -(defvar haskell-mode-syntax-table nil - "Syntax table used for haskell-mode") - -;; !chak! taken from lisp-mode -;; -(defvar haskell-mode-abbrev-table nil - "Abbrev table used for the haskell-mode") - -;; !chak! took syntax table from haskell mode distributed with GHC and modified -;; it; we treat numbers as parts of words and operators as elements of -;; the syntactic class `_' -;; -(if haskell-mode-syntax-table - () - (let ((i 0)) - (setq haskell-mode-syntax-table (make-syntax-table)) - (while (< i ?0) - (modify-syntax-entry i "." haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i (1+ ?9)) - (modify-syntax-entry i "w" haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i ?A) - (modify-syntax-entry i "." haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i (1+ ?Z)) - (modify-syntax-entry i "w" haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i ?a) - (modify-syntax-entry i "." haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i (1+ ?z)) - (modify-syntax-entry i "w" haskell-mode-syntax-table) - (setq i (1+ i))) - (while (< i 128) - (modify-syntax-entry i "." haskell-mode-syntax-table) - (setq i (1+ i))) - (modify-syntax-entry ? " " haskell-mode-syntax-table) - (modify-syntax-entry ?\t " " haskell-mode-syntax-table) - (modify-syntax-entry ?\n ">" haskell-mode-syntax-table) - (modify-syntax-entry ?\f ">" haskell-mode-syntax-table) - (modify-syntax-entry ?! "_" haskell-mode-syntax-table) - (modify-syntax-entry ?# "_" haskell-mode-syntax-table) - (modify-syntax-entry ?$ "_" haskell-mode-syntax-table) - (modify-syntax-entry ?% "_" haskell-mode-syntax-table) - (modify-syntax-entry ?& "_" haskell-mode-syntax-table) - (modify-syntax-entry ?* "_" haskell-mode-syntax-table) - (modify-syntax-entry ?+ "_" haskell-mode-syntax-table) - (modify-syntax-entry ?. "_" haskell-mode-syntax-table) - (modify-syntax-entry ?/ "_" haskell-mode-syntax-table) - (modify-syntax-entry ?< "_" haskell-mode-syntax-table) - (modify-syntax-entry ?= "_" haskell-mode-syntax-table) - (modify-syntax-entry ?> "_" haskell-mode-syntax-table) - (modify-syntax-entry ?? "_" haskell-mode-syntax-table) - (modify-syntax-entry ?@ "_" haskell-mode-syntax-table) - (modify-syntax-entry ?^ "_" haskell-mode-syntax-table) - (modify-syntax-entry ?| "_" haskell-mode-syntax-table) - (modify-syntax-entry ?~ "_" haskell-mode-syntax-table) - (modify-syntax-entry ?\" "\"" haskell-mode-syntax-table) - (modify-syntax-entry ?\' "w" haskell-mode-syntax-table) - (modify-syntax-entry ?_ "w" haskell-mode-syntax-table) - (modify-syntax-entry ?\\ "_" haskell-mode-syntax-table) - (modify-syntax-entry ?\( "()" haskell-mode-syntax-table) - (modify-syntax-entry ?\) ")(" haskell-mode-syntax-table) - (modify-syntax-entry ?\[ "(]" haskell-mode-syntax-table) - (modify-syntax-entry ?\] ")[" haskell-mode-syntax-table) - (modify-syntax-entry ?{ "(}1" haskell-mode-syntax-table) - (modify-syntax-entry ?} "){4" haskell-mode-syntax-table) - (modify-syntax-entry ?- "_ 123" haskell-mode-syntax-table) - )) - -;; !chak! taken from lisp-mode -;; -(define-abbrev-table 'haskell-mode-abbrev-table ()) - -;; !chak! adapted from lisp-mode -;; -(defun haskell-mode-variables (haskell-syntax) - (cond (haskell-syntax - (set-syntax-table haskell-mode-syntax-table))) - (setq local-abbrev-table haskell-mode-abbrev-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "^$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'haskell-indent-line) -; (make-local-variable 'indent-region-function) -; (setq indent-region-function 'haskell-indent-region) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) -; (make-local-variable 'outline-regexp) -; (setq outline-regexp ";;; \\|(....") - (make-local-variable 'comment-start) - (setq comment-start "--") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "-- *") - (make-local-variable 'comment-column) - (setq comment-column 40) -; (make-local-variable 'comment-indent-function) -; (setq comment-indent-function 'haskell-comment-indent) - (make-local-variable 'font-lock-keywords) - (setq font-lock-keywords haskell-font-lock-keywords) - ) - -;; !chak! -;; -(defun haskell-indent-line () - "Simple indentation function using `indent-relative'." - (interactive) - (save-excursion - (beginning-of-line) - (delete-horizontal-space) - (indent-relative) - ) - ) - -;;; Command for invoking the Haskell mode -(defun haskell-mode nil - "Major mode for editing Haskell code to run in Emacs -The following commands are available: -\\{haskell-mode-map} - -A Haskell process can be fired up with \"M-x haskell\". - -Customization: Entry to this mode runs the hooks that are the value of variable -haskell-mode-hook. - -Windows: - -There are 3 types of windows associated with Haskell mode. They are: - *haskell*: which is the process window. - Pad: which are buffers available for each module. It is here - where you want to test things before preserving them in a - file. Pads are always associated with a module. - When issuing a command: - The pad and its associated module are sent to the Haskell - process prior to the execution of the command. - .hs: These are the files where Haskell programs live. They - have .hs as extension. - When issuing a command: - The file is sent to the Haskell process prior to the - execution of the command. - -Commands: - -Each command behaves differently according to the type of the window in which -the cursor is positioned when the command is issued . - -haskell-eval: \\[haskell-eval] - Always promts user for a Haskell expression to be evaluated. If in a - .hs file buffer, then the cursor tells which module is the current - module and the pad for that module (if any) gets loaded as well. - -haskell-run: \\[haskell-run] - Always queries for a variable of type Dialogue to be evaluated. - -haskell-run-main: \\[haskell-run-main] - Run Dialogue named main in the current module. - -haskell-report-type: \\[haskell-report-type] - Like haskell-eval, but prints the type of the expression without - evaluating it. - -haskell-mode: \\[haskell-mode] - Puts the current buffer in haskell mode. - -haskell-compile: \\[haskell-compile] - Compiles file in current buffer. - -haskell-load: \\[haskell-load] - Loads file in current buffer. - -haskell-run-file: \\[haskell-run-file] - Runs file in the current buffer. - -haskell-pad: \\[haskell-pad] - Creates a scratch pad for the current module. - -haskell-optimizers: \\[haskell-optimizers] - Shows the list of available optimizers. Commands for turning them on/off. - -haskell-printers: \\[haskell-printers] - Shows the list of available printers. Commands for turning them on/off. - -haskell-command: \\[haskell-command] - Prompts for a command to be sent to the command interface. You don't - need to put the : before the command. - -haskell-quit: \\[haskell-quit] - Terminates the haskell process. - -haskell-switch: \\[haskell-switch] - Switches to the inferior Haskell buffer (*haskell*) and positions the - cursor at the end of the buffer. - -haskell-kill: \\[haskell-kill] - Kill the current contents of the *haskell* buffer. - -haskell-interrupt: \\[haskell-interrupt] - Interrupts haskell process and resets it. - -haskell-edit-unit: \\[haskell-edit-unit] - Edit the .hu file for the unit containing this file. -" - (interactive) - (kill-all-local-variables) - (use-local-map haskell-mode-map) - (setq major-mode 'haskell-mode) - (setq mode-name "Haskell") - (make-local-variable 'indent-line-function) - (setq indent-line-function 'indent-relative-maybe) - ;(setq local-abbrev-table haskell-mode-abbrev-table) - (set-syntax-table haskell-mode-syntax-table) - ;(setq tab-stop-list haskell-tab-stop-list) ;; save old list?? - (haskell-mode-variables t) ; !chak! - (cond (haskell-auto-font-lock ; !chak! - (font-lock-mode 1) ; !chak! - )) ; !chak! - (run-hooks 'haskell-mode-hook)) - - - -;;;================================================================ -;;; Inferior Haskell stuff -;;;================================================================ - - -(defvar inferior-haskell-mode-map (copy-keymap comint-mode-map)) - -(haskell-establish-key-bindings inferior-haskell-mode-map) -(define-key inferior-haskell-mode-map "\C-m" 'haskell-send-input) - -(defvar haskell-source-modes '(haskell-mode) - "*Used to determine if a buffer contains Haskell source code. -If it's loaded into a buffer that is in one of these major modes, -it's considered a Haskell source file.") - -(defvar haskell-prompt-pattern "^[A-Z]\\([A-Z]\\|[a-z]\\|[0-9]\\)*>\\s-*" - "Regular expression capturing the Haskell system prompt.") - -(defvar haskell-prompt-ring () - "Keeps track of input to haskell process from the minibuffer") - -(defun inferior-haskell-mode-variables () - nil) - - -;;; INFERIOR-HASKELL-MODE (adapted from comint.el) - -(defun inferior-haskell-mode () - "Major mode for interacting with an inferior Haskell process. - -The following commands are available: -\\{inferior-haskell-mode-map} - -A Haskell process can be fired up with \"M-x haskell\". - -Customization: Entry to this mode runs the hooks on comint-mode-hook and -inferior-haskell-mode-hook (in that order). - -You can send text to the inferior Haskell process from other buffers containing -Haskell source. - - -Windows: - -There are 3 types of windows in the inferior-haskell-mode. They are: - *haskell*: which is the process window. - Pad: which are buffers available for each module. It is here - where you want to test things before preserving them in a - file. Pads are always associated with a module. - When issuing a command: - The pad and its associated module are sent to the Haskell - process prior to the execution of the command. - .hs: These are the files where Haskell programs live. They - have .hs as extension. - When issuing a command: - The file is sent to the Haskell process prior to the - execution of the command. - -Commands: - -Each command behaves differently according to the type of the window in which -the cursor is positioned when the command is issued. - -haskell-eval: \\[haskell-eval] - Always promts user for a Haskell expression to be evaluated. If in a - .hs file, then the cursor tells which module is the current module and - the pad for that module (if any) gets loaded as well. - -haskell-run: \\[haskell-run] - Always queries for a variable of type Dialogue to be evaluated. - -haskell-run-main: \\[haskell-run-main] - Run Dialogue named main. - -haskell-report-type: \\[haskell-report-type] - Like haskell-eval, but prints the type of the expression without - evaluating it. - -haskell-mode: \\[haskell-mode] - Puts the current buffer in haskell mode. - -haskell-compile: \\[haskell-compile] - Compiles file in current buffer. - -haskell-load: \\[haskell-load] - Loads file in current buffer. - -haskell-run-file: \\[haskell-run-file] - Runs file in the current buffer. - -haskell-pad: \\[haskell-pad] - Creates a scratch pad for the current module. - -haskell-optimizers: \\[haskell-optimizers] - Shows the list of available optimizers. Commands for turning them on/off. - -haskell-printers: \\[haskell-printers] - Shows the list of available printers. Commands for turning them on/off. - -haskell-command: \\[haskell-command] - Prompts for a command to be sent to the command interface. You don't - need to put the : before the command. - -haskell-quit: \\[haskell-quit] - Terminates the haskell process. - -haskell-switch: \\[haskell-switch] - Switches to the inferior Haskell buffer (*haskell*) and positions the - cursor at the end of the buffer. - -haskell-kill: \\[haskell-kill] - Kill the current contents of the *haskell* buffer. - -haskell-interrupt: \\[haskell-interrupt] - Interrupts haskell process and resets it. - -haskell-edit-unit: \\[haskell-edit-unit] - Edit the .hu file for the unit containing this file. - -The usual comint functions are also available. In particular, the -following are all available: - -comint-bol: Beginning of line, but skip prompt. Bound to C-a by default. -comint-delchar-or-maybe-eof: Delete char, unless at end of buffer, in - which case send EOF to process. Bound to C-d by default. - -Note however, that the default keymap bindings provided shadow some of -the default comint mode bindings, so that you may want to bind them -to your choice of keys. - -Comint mode's dynamic completion of filenames in the buffer is available. -(Q.v. comint-dynamic-complete, comint-dynamic-list-completions.) - -If you accidentally suspend your process, use \\[comint-continue-subjob] -to continue it." - - (interactive) - (comint-mode) - (setq comint-prompt-regexp haskell-prompt-pattern) - ;; Customise in inferior-haskell-mode-hook - (inferior-haskell-mode-variables) - (setq major-mode 'inferior-haskell-mode) - (setq mode-name "Inferior Haskell") - (setq mode-line-process '(": %s : busy")) - (use-local-map inferior-haskell-mode-map) - (setq comint-input-filter 'haskell-input-filter) - (setq comint-input-sentinel 'ignore) - (setq comint-get-old-input 'haskell-get-old-input) - (run-hooks 'inferior-haskell-mode-hook) - ;Do this after the hook so the user can mung INPUT-RING-SIZE w/his hook. - ;The test is so we don't lose history if we run comint-mode twice in - ;a buffer. - (setq haskell-prompt-ring (make-ring comint-input-ring-size))) - - -(defun haskell-input-filter (str) - "Don't save whitespace." - (not (string-match "\\s *" str))) - - - -;;; ================================================================== -;;; Random utilities -;;; ================================================================== - - -;;; This keeps track of the status of the haskell process. -;;; Values are: -;;; busy -- The process is busy. -;;; ready -- The process is ready for a command. -;;; input -- The process is waiting for input. -;;; debug -- The process is in the debugger. - -(defvar *haskell-status* 'busy - "Status of the haskell process") - -(defun set-haskell-status (value) - (setq *haskell-status* value) - (haskell-update-mode-line)) - -(defun get-haskell-status () - *haskell-status*) - -(defun haskell-update-mode-line () - (save-excursion - (set-buffer *haskell-buffer*) - (cond ((eq *haskell-status* 'ready) - (setq mode-line-process '(": %s: ready"))) - ((eq *haskell-status* 'input) - (setq mode-line-process '(": %s: input"))) - ((eq *haskell-status* 'busy) - (setq mode-line-process '(": %s: busy"))) - ((eq *haskell-status* 'debug) - (setq mode-line-process '(": %s: debug"))) - (t - (haskell-mode-error "Confused about status of haskell process!"))) - ;; Yes, this is the officially sanctioned technique for forcing - ;; a redisplay of the mode line. - (set-buffer-modified-p (buffer-modified-p)))) - - -(defun haskell-send-to-process (string) - (process-send-string "haskell" string) - (process-send-string "haskell" "\n")) - - - -;;; ================================================================== -;;; Handle input in haskell process buffer; history commands. -;;; ================================================================== - -(defun haskell-get-old-input () - "Get old input text from Haskell process buffer." - (save-excursion - (if (re-search-forward haskell-prompt-pattern (point-max) 'move) - (goto-char (match-beginning 0))) - (cond ((re-search-backward haskell-prompt-pattern (point-min) t) - (comint-skip-prompt) - (let ((temp (point))) - (end-of-line) - (buffer-substring temp (point))))))) - - -(defun haskell-send-input () - "Send input to Haskell while in the process buffer" - (interactive) - (if (eq (get-haskell-status) 'debug) - (comint-send-input) - (haskell-send-input-aux))) - -(defun haskell-send-input-aux () - ;; Note that the input string does not include its terminal newline. - (let ((proc (get-buffer-process (current-buffer)))) - (if (not proc) - (haskell-mode-error "Current buffer has no process!") - (let* ((pmark (process-mark proc)) - (pmark-val (marker-position pmark)) - (input (if (>= (point) pmark-val) - (buffer-substring pmark (point)) - (let ((copy (funcall comint-get-old-input))) - (goto-char pmark) - (insert copy) - copy)))) - (insert ?\n) - (if (funcall comint-input-filter input) - (ring-insert input-ring input)) - (funcall comint-input-sentinel input) - (set-marker (process-mark proc) (point)) - (set-marker comint-last-input-end (point)) - (haskell-send-to-process input))))) - - - -;;; ================================================================== -;;; Minibuffer input stuff -;;; ================================================================== - -;;; Haskell input history retrieval commands (taken from comint.el) -;;; M-p -- previous input M-n -- next input - -(defvar haskell-minibuffer-local-map nil - "Local map for minibuffer when in Haskell") - -(if haskell-minibuffer-local-map - nil - (progn - (setq haskell-minibuffer-local-map - (copy-keymap minibuffer-local-map)) - ;; Haskell commands - (define-key haskell-minibuffer-local-map "\ep" 'haskell-previous-input) - (define-key haskell-minibuffer-local-map "\en" 'haskell-next-input) - )) - -(defun haskell-previous-input (arg) - "Cycle backwards through input history." - (interactive "*p") - (let ((len (ring-length haskell-prompt-ring))) - (cond ((<= len 0) - (message "Empty input ring.") - (ding)) - (t - (cond ((eq last-command 'haskell-previous-input) - (delete-region (mark) (point)) - (set-mark (point))) - (t - (setq input-ring-index - (if (> arg 0) -1 - (if (< arg 0) 1 0))) - (push-mark (point)))) - (setq input-ring-index (comint-mod (+ input-ring-index arg) len)) - (insert (ring-ref haskell-prompt-ring input-ring-index)) - (setq this-command 'haskell-previous-input)) - ))) - -(defun haskell-next-input (arg) - "Cycle forwards through input history." - (interactive "*p") - (haskell-previous-input (- arg))) - -(defvar haskell-last-input-match "" - "Last string searched for by Haskell input history search, for defaulting. -Buffer local variable.") - -(defun haskell-previous-input-matching (str) - "Searches backwards through input history for substring match" - (interactive (let ((s (read-from-minibuffer - (format "Command substring (default %s): " - haskell-last-input-match)))) - (list (if (string= s "") haskell-last-input-match s)))) - (setq haskell-last-input-match str) ; update default - (let ((str (regexp-quote str)) - (len (ring-length haskell-prompt-ring)) - (n 0)) - (while (and (<= n len) - (not (string-match str (ring-ref haskell-prompt-ring n)))) - (setq n (+ n 1))) - (cond ((<= n len) (haskell-previous-input (+ n 1))) - (t (haskell-mode-error "Not found."))))) - - -;;; Actually read an expression from the minibuffer using the new keymap. - -(defun haskell-get-expression (prompt) - (let ((exp (read-from-minibuffer prompt nil haskell-minibuffer-local-map))) - (ring-insert haskell-prompt-ring exp) - exp)) - - - -;;; ================================================================== -;;; Handle output from Haskell process -;;; ================================================================== - -;;; The haskell process produces output with embedded control codes. -;;; These control codes are used to keep track of what kind of input -;;; the haskell process is expecting. Ordinary output is just displayed. -;;; -;;; This is kind of complicated because control sequences can be broken -;;; across multiple batches of text received from the haskell process. -;;; If the string ends in the middle of a control sequence, save it up -;;; for the next call. - -(defvar *haskell-saved-output* nil) - -;;; On the Next, there is some kind of race condition that causes stuff -;;; sent to the Haskell subprocess before it has really started to be lost. -;;; The point of this variable is to force the Emacs side to wait until -;;; Haskell has started and printed out its banner before sending it -;;; anything. See start-haskell below. - -(defvar *haskell-process-alive* nil) - -(defun haskell-output-filter (process str) - "Filter for output from Yale Haskell command interface" - ;; *** debug - ;;(let ((buffer (get-buffer-create "haskell-output"))) - ;; (save-excursion - ;; (set-buffer buffer) - ;; (insert str))) - (setq *haskell-process-alive* t) - (let ((next 0) - (start 0) - (data (match-data))) - (unwind-protect - (progn - ;; If there was saved output from last time, glue it in front of the - ;; newly received input. - (if *haskell-saved-output* - (progn - (setq str (concat *haskell-saved-output* str)) - (setq *haskell-saved-output* nil))) - ;; Loop, looking for complete command sequences. - ;; Set next to point to the first one. - ;; start points to first character to be processed. - (while (setq next - (string-match *haskell-message-match-regexp* - str start)) - ;; Display any intervening ordinary text. - (if (not (eq next start)) - (haskell-display-output (substring str start next))) - ;; Now dispatch on the particular command sequence found. - ;; Handler functions are called with the string and start index - ;; as arguments, and should return the index of the "next" - ;; character. - (let ((end (match-end 0))) - (haskell-handle-message str next) - (setq start end))) - ;; Look to see whether the string ends with an incomplete - ;; command sequence. - ;; If so, save the tail of the string for next time. - (if (and (setq next - (string-match *haskell-message-prefix-regexp* str start)) - (eq (match-end 0) (length str))) - (setq *haskell-saved-output* (substring str next)) - (setq next (length str))) - ;; Display any leftover ordinary text. - (if (not (eq next start)) - (haskell-display-output (substring str start next)))) - (store-match-data data)))) - -(defvar *haskell-message-match-regexp* - "EMACS:.*\n") - -(defvar *haskell-message-prefix-regexp* - "E\\(M\\(A\\(C\\(S\\(:.*\\)?\\)?\\)?\\)?\\)?") - -(defvar *haskell-message-dispatch* - '(("EMACS:debug\n" . haskell-got-debug) - ("EMACS:busy\n" . haskell-got-busy) - ("EMACS:input\n" . haskell-got-input) - ("EMACS:ready\n" . haskell-got-ready) - ("EMACS:printers .*\n" . haskell-got-printers) - ("EMACS:optimizers .*\n" . haskell-got-optimizers) - ("EMACS:message .*\n" . haskell-got-message) - ("EMACS:error\n" . haskell-got-error) - )) - -(defun haskell-handle-message (str idx) - (let ((list *haskell-message-dispatch*) - (fn nil)) - (while (and list (null fn)) - (if (eq (string-match (car (car list)) str idx) idx) - (setq fn (cdr (car list))) - (setq list (cdr list)))) - (if (null fn) - (haskell-mode-error "Garbled message from Haskell!") - (let ((end (match-end 0))) - (funcall fn str idx end) - end)))) - - -(defun haskell-message-data (string start end) - (let ((real-start (+ (string-match " " string start) 1)) - (real-end (- end 1))) - (substring string real-start real-end))) - -(defun haskell-got-debug (string start end) - (beep) - (message "In the debugger!") - (set-haskell-status 'debug)) - -(defun haskell-got-busy (string start end) - (set-haskell-status 'busy)) - -(defun haskell-got-input (string start end) - (if haskell-auto-switch-input - (progn - (haskell-switch) - (beep))) - (set-haskell-status 'input) - (message "Waiting for input...")) - -(defun haskell-got-ready (string start end) - (set-haskell-status 'ready)) - -(defun haskell-got-printers (string start end) - (haskell-printers-update (haskell-message-data string start end))) - -(defun haskell-got-optimizers (string start end) - (haskell-optimizers-update (haskell-message-data string start end))) - -(defun haskell-got-message (string start end) - (message "%s" (haskell-message-data string start end))) - -(defun haskell-got-error (string start end) -; [[!chak! I found that annoying]] (beep) - (message "Haskell error.")) - - -;;; Displays output at end of given buffer. -;;; This function only ensures that the output is visible, without -;;; selecting the buffer in which it is displayed. -;;; Note that just using display-buffer instead of all this rigamarole -;;; won't work; you need to temporarily select the window containing -;;; the *haskell-buffer*, or else the display won't be scrolled to show -;;; the new output. -;;; *** This should really position the window in the buffer so that -;;; *** the point is on the last line of the window. - -(defun haskell-display-output (str) - (let ((window (selected-window))) - (unwind-protect - (progn - (pop-to-buffer *haskell-buffer*) - (haskell-display-output-aux str)) - (select-window window)))) - -(defun haskell-display-output-aux (str) - (haskell-move-marker) - (insert str) - (haskell-move-marker)) - - - -;;; ================================================================== -;;; Interactive commands -;;; ================================================================== - - -;;; HASKELL -;;; ------- -;;; -;;; This is the function that fires up the inferior haskell process. - -(defun haskell () - "Run an inferior Haskell process with input and output via buffer *haskell*. -Takes the program name from the variable haskell-program-name. -Runs the hooks from inferior-haskell-mode-hook -(after the comint-mode-hook is run). -\(Type \\[describe-mode] in the process buffer for a list of commands.)" - (interactive) - (if (not (haskell-process-exists-p)) - (start-haskell))) - -(defun start-haskell () - (message "Starting haskell subprocess...") - ;; Kill old haskell process. Normally this routine is only called - ;; after checking haskell-process-exists-p, but things can get - ;; screwed up if you rename the *haskell* buffer while leaving the - ;; old process running. This forces it to get rid of the old process - ;; and start a new one. - (if (get-process "haskell") - (delete-process "haskell")) - (let ((haskell-buffer - (apply 'make-comint - "haskell" - (or haskell-program-name - (haskell-mode-error "Haskell-program-name undefined!")) - nil - nil))) - (save-excursion - (set-buffer haskell-buffer) - (inferior-haskell-mode)) - (haskell-session-init) - ;; Wait for process to get started before sending it anything - ;; to avoid race condition on NeXT. - (setq *haskell-process-alive* nil) - (while (not *haskell-process-alive*) - (sleep-for 1)) - (haskell-send-to-process ":(use-emacs-interface)") - (haskell-printers-set haskell-initial-printers nil) - (display-buffer haskell-buffer)) - (message "Starting haskell subprocess... Done.")) - - -(defun haskell-process-exists-p () - (let ((haskell-buffer (get-buffer *haskell-buffer*))) - (and haskell-buffer (comint-check-proc haskell-buffer)))) - - - -;;; Initialize things on the emacs side, and tell haskell that it's -;;; talking to emacs. - -(defun haskell-session-init () - (set-haskell-status 'busy) - (setq *last-loaded* nil) - (setq *last-module* haskell-main-module) - (setq *last-pad* haskell-main-pad) - (setq *haskell-saved-output* nil) - (haskell-create-main-pad) - (set-process-filter (get-process "haskell") 'haskell-output-filter) - ) - - -(defun haskell-create-main-pad () - (let ((buffer (get-buffer-create haskell-main-pad))) - (save-excursion - (set-buffer buffer) - (haskell-mode)) - (haskell-record-pad-mapping - haskell-main-pad haskell-main-module nil) - buffer)) - - -;;; Called from evaluation and compilation commands to start up a Haskell -;;; process if none is already in progress. - -(defun haskell-maybe-create-process () - (cond ((haskell-process-exists-p) - t) - (haskell-auto-create-process - (start-haskell)) - (t - (haskell-mode-error "No Haskell process!")))) - - - -;;; HASKELL-GET-PAD -;;; ------------------------------------------------------------------ - -;;; This always puts the pad buffer in the "other" window. -;;; Having it wipe out the .hs file window is clearly the wrong -;;; behavior. - -(defun haskell-get-pad () - "Creates a new scratch pad for the current module. -Signals an error if the current buffer is not a .hs file." - (interactive) - (let ((fname (buffer-file-name))) - (if fname - (do-get-pad fname (current-buffer)) - (haskell-mode-error "Not in a .hs buffer!")))) - - -(defun do-get-pad (fname buff) - (let* ((mname (or (haskell-get-modname buff) - (read-no-blanks-input "Scratch pad for module? " nil))) - (pname (haskell-lookup-pad mname fname)) - (pbuff nil)) - ;; Generate the base name of the pad buffer, then create the - ;; buffer. The actual name of the pad buffer may be something - ;; else because of name collisions. - (if (not pname) - (progn - (setq pname (format "*%s-pad*" mname)) - (setq pbuff (generate-new-buffer pname)) - (setq pname (buffer-name pbuff)) - (haskell-record-pad-mapping pname mname fname) - ) - (setq pbuff (get-buffer pname))) - ;; Make sure the pad buffer is in haskell mode. - (pop-to-buffer pbuff) - (haskell-mode))) - - - -;;; HASKELL-SWITCH -;;; ------------------------------------------------------------------ - -(defun haskell-switch () - "Switches to \*haskell\* buffer." - (interactive) - (haskell-maybe-create-process) - (pop-to-buffer *haskell-buffer*) - (push-mark) - (goto-char (point-max))) - - - -;;; HASKELL-KILL -;;; ------------------------------------------------------------------ - -(defun haskell-kill () - "Kill contents of *haskell* buffer. \\[haskell-kill]" - (interactive) - (save-excursion - (set-buffer *haskell-buffer*) - (beginning-of-buffer) - (let ((mark (point))) - (end-of-buffer) - (kill-region mark (point))))) - - - -;;; HASKELL-COMMAND -;;; ------------------------------------------------------------------ - -(defun haskell-command (str) - "Format STRING as a haskell command and send it to haskell process. \\[haskell-command]" - (interactive "sHaskell command: ") - (haskell-send-to-process (format ":%s" str))) - - -;;; HASKELL-EVAL and HASKELL-RUN -;;; ------------------------------------------------------------------ - -(defun haskell-eval () - "Evaluate expression in current module. \\[haskell-eval]" - (interactive) - (haskell-maybe-create-process) - (haskell-eval-aux (haskell-get-expression "Haskell expression: ") - "emacs-eval")) - -(defun haskell-run () - "Run Haskell Dialogue in current module" - (interactive) - (haskell-maybe-create-process) - (haskell-eval-aux (haskell-get-expression "Haskell dialogue: ") - "emacs-run")) - -(defun haskell-run-main () - "Run Dialogue named main in current module" - (interactive) - (haskell-maybe-create-process) - (haskell-eval-aux "main" "emacs-run")) - -(defun haskell-report-type () - "Print the type of the expression." - (interactive) - (haskell-maybe-create-process) - (haskell-eval-aux (haskell-get-expression "Haskell expression: ") - "emacs-report-type")) - -(defun haskell-eval-aux (exp fn) - (cond ((equal *haskell-buffer* (buffer-name)) - ;; In the *haskell* buffer. - (let* ((pname *last-pad*) - (mname *last-module*) - (fname *last-loaded*)) - (haskell-eval-aux-aux exp pname mname fname fn))) - ((buffer-file-name) - ;; In a .hs file. - (let* ((fname (buffer-file-name)) - (mname (haskell-get-modname (current-buffer))) - (pname (haskell-lookup-pad mname fname))) - (haskell-eval-aux-aux exp pname mname fname fn))) - (t - ;; In a pad. - (let* ((pname (buffer-name (current-buffer))) - (mname (haskell-get-module-from-pad pname)) - (fname (haskell-get-file-from-pad pname))) - (haskell-eval-aux-aux exp pname mname fname fn))) - )) - -(defun haskell-eval-aux-aux (exp pname mname fname fn) - (haskell-save-modified-source-files fname) - (haskell-send-to-process (format ":(%s" fn)) - (haskell-send-to-process - (prin1-to-string exp)) - (haskell-send-to-process - (prin1-to-string (or pname fname "interactive"))) - (haskell-send-to-process - (prin1-to-string - (if (and pname (get-buffer pname)) - (save-excursion - (set-buffer pname) - (buffer-string)) - ""))) - (haskell-send-to-process - (format "'|%s|" mname)) - (haskell-send-to-process - (if fname - (prin1-to-string (haskell-maybe-get-unit-file-name fname)) - "'#f")) - (haskell-send-to-process ")") - (setq *last-pad* pname) - (setq *last-module* mname) - (setq *last-loaded* fname)) - - - -;;; HASKELL-RUN-FILE, HASKELL-LOAD, HASKELL-COMPILE -;;; ------------------------------------------------------------------ - -(defun haskell-run-file () - "Runs Dialogue named main in current file." - (interactive) - (haskell-maybe-create-process) - (let ((fname (haskell-get-file-to-operate-on))) - (haskell-save-modified-source-files fname) - (haskell-send-to-process ":(emacs-run-file") - (haskell-send-to-process (prin1-to-string fname)) - (haskell-send-to-process ")"))) - -(defun haskell-load () - "Load current file." - (interactive) - (haskell-maybe-create-process) - (let ((fname (haskell-get-file-to-operate-on))) - (haskell-save-modified-source-files fname) - (haskell-send-to-process ":(emacs-load-file") - (haskell-send-to-process (prin1-to-string fname)) - (haskell-send-to-process ")"))) - -(defun haskell-compile () - "Compile current file." - (interactive) - (haskell-maybe-create-process) - (let ((fname (haskell-get-file-to-operate-on))) - (haskell-save-modified-source-files fname) - (haskell-send-to-process ":(emacs-compile-file") - (haskell-send-to-process (prin1-to-string fname)) - (haskell-send-to-process ")"))) - - -(defun haskell-get-file-to-operate-on () - (cond ((equal *haskell-buffer* (buffer-name)) - ;; When called from the haskell process buffer, prompt for a file. - (call-interactively 'haskell-get-file/prompt)) - ((buffer-file-name) - ;; When called from a .hs file buffer, use the unit file - ;; associated with it, if there is one. - (haskell-maybe-get-unit-file-name (buffer-file-name))) - (t - ;; When called from a pad, use the file that the module the - ;; pad belongs to lives in. - (haskell-maybe-get-unit-file-name - (haskell-get-file-from-pad (buffer-name (current-buffer))))))) - -(defun haskell-get-file/prompt (filename) - (interactive "fHaskell file: ") - filename) - - - -;;; HASKELL-EXIT -;;; ------------------------------------------------------------------ - -(defun haskell-exit () - "Quit the haskell process." - (interactive) - (cond ((not (haskell-process-exists-p)) - (message "No process currently running.")) - ((y-or-n-p "Do you really want to quit Haskell? ") - (haskell-send-to-process ":quit") - ;; If we were running the tutorial, mark the temp buffer as unmodified - ;; so we don't get asked about saving it later. - (if (and *ht-temp-buffer* - (get-buffer *ht-temp-buffer*)) - (save-excursion - (set-buffer *ht-temp-buffer*) - (set-buffer-modified-p nil))) - ;; Try to remove the haskell output buffer from the screen. - (bury-buffer *haskell-buffer*) - (replace-buffer-in-windows *haskell-buffer*)) - (t - nil))) - - -;;; HASKELL-INTERRUPT -;;; ------------------------------------------------------------------ - -(defun haskell-interrupt () - "Interrupt the haskell process." - (interactive) - (if (haskell-process-exists-p) - (haskell-send-to-process "\C-c"))) - - - -;;; HASKELL-EDIT-UNIT -;;; ------------------------------------------------------------------ - -(defun haskell-edit-unit () - "Edit the .hu file." - (interactive) - (let ((fname (buffer-file-name))) - (if fname - (let ((find-file-not-found-hooks (list 'haskell-new-unit)) - (file-not-found nil) - (units-fname (haskell-get-unit-file-name fname))) - (find-file-other-window units-fname) - ;; If creating a new file, initialize it to contain the name - ;; of the haskell source file. - (if file-not-found - (save-excursion - (insert - (if (string= (file-name-directory fname) - (file-name-directory units-fname)) - (file-name-nondirectory fname) - fname) - "\n")))) - (haskell-mode-error "Not in a .hs buffer!")))) - -(defun haskell-new-unit () - (setq file-not-found t)) - - -;;; Look for a comment like "-- unit:" at top of file. -;;; If not found, assume unit file has same name as the buffer but -;;; a .hu extension. - -(defun haskell-get-unit-file-name (fname) - (or (haskell-get-unit-file-name-from-file fname) - (concat (haskell-strip-file-extension fname) ".hu"))) - -(defun haskell-maybe-get-unit-file-name (fname) - (or (haskell-get-unit-file-name-from-file fname) - (haskell-strip-file-extension fname))) - -(defun haskell-get-unit-file-name-from-file (fname) - (let ((buffer (get-file-buffer fname))) - (if buffer - (save-excursion - (beginning-of-buffer) - (if (re-search-forward "-- unit:[ \t]*" (point-max) t) - (let ((beg (match-end 0))) - (end-of-line) - (buffer-substring beg (point))) - nil)) - nil))) - - - - -;;; ================================================================== -;;; Support for printers/optimizers menus -;;; ================================================================== - -;;; This code was adapted from the standard buff-menu.el code. - -(defvar haskell-menu-mode-map nil "") - -(if (not haskell-menu-mode-map) - (progn - (setq haskell-menu-mode-map (make-keymap)) - (suppress-keymap haskell-menu-mode-map t) - (define-key haskell-menu-mode-map "m" 'hm-mark) - (define-key haskell-menu-mode-map "u" 'hm-unmark) - (define-key haskell-menu-mode-map "x" 'hm-exit) - (define-key haskell-menu-mode-map "q" 'hm-exit) - (define-key haskell-menu-mode-map " " 'next-line) - (define-key haskell-menu-mode-map "\177" 'hm-backup-unmark) - (define-key haskell-menu-mode-map "?" 'describe-mode))) - -;; Printers Menu mode is suitable only for specially formatted data. - -(put 'haskell-menu-mode 'mode-class 'special) - -(defun haskell-menu-mode () - "Major mode for editing Haskell flags. -Each line describes a flag. -Letters do not insert themselves; instead, they are commands. -m -- mark flag (turn it on) -u -- unmark flag (turn it off) -x -- exit; tell the Haskell process to update the flags, then leave menu. -q -- exit; same as x. -Precisely,\\{haskell-menu-mode-map}" - (kill-all-local-variables) - (use-local-map haskell-menu-mode-map) - (setq truncate-lines t) - (setq buffer-read-only t) - (setq major-mode 'haskell-menu-mode) - (setq mode-name "Haskell Flags Menu") - ;; These are all initialized elsewhere - (make-local-variable 'hm-current-flags) - (make-local-variable 'hm-request-fn) - (make-local-variable 'hm-update-fn) - (run-hooks 'haskell-menu-mode-hook)) - - -(defun haskell-menu (help-file buffer request-fn update-fn) - (haskell-maybe-create-process) - (if (get-buffer buffer) - (progn - (pop-to-buffer buffer) - (goto-char (point-min))) - (progn - (pop-to-buffer buffer) - (insert-file-contents help-file) - (haskell-menu-mode) - (setq hm-request-fn request-fn) - (setq hm-update-fn update-fn) - )) - (hm-mark-current) - (message "m = mark; u = unmark; x = execute; q = quit; ? = more help.")) - - - -;;; A line that starts with *hm-marked* is a menu item turned on. -;;; A line that starts with *hm-unmarked* is turned off. -;;; A line that starts with anything else is just random text and is -;;; ignored by commands that deal with menu items. - -(defvar *hm-marked* " on") -(defvar *hm-unmarked* " ") -(defvar *hm-marked-regexp* " on \\w") -(defvar *hm-unmarked-regexp* " \\w") - -(defun hm-mark () - "Mark flag to be turned on." - (interactive) - (beginning-of-line) - (cond ((looking-at *hm-marked-regexp*) - (forward-line 1)) - ((looking-at *hm-unmarked-regexp*) - (let ((buffer-read-only nil)) - (delete-char (length *hm-unmarked*)) - (insert *hm-marked*) - (forward-line 1))) - (t - (forward-line 1)))) - -(defun hm-unmark () - "Unmark flag." - (interactive) - (beginning-of-line) - (cond ((looking-at *hm-unmarked-regexp*) - (forward-line 1)) - ((looking-at *hm-marked-regexp*) - (let ((buffer-read-only nil)) - (delete-char (length *hm-marked*)) - (insert *hm-unmarked*) - (forward-line 1))) - (t - (forward-line 1)))) - -(defun hm-backup-unmark () - "Move up and unmark." - (interactive) - (forward-line -1) - (hm-unmark) - (forward-line -1)) - - -;;; Actually make the changes. - -(defun hm-exit () - "Update flags, then leave menu." - (interactive) - (hm-execute) - (hm-quit)) - -(defun hm-execute () - "Tell haskell process to tweak flags." - (interactive) - (save-excursion - (goto-char (point-min)) - (let ((flags-on nil) - (flags-off nil)) - (while (not (eq (point) (point-max))) - (cond ((looking-at *hm-unmarked-regexp*) - (setq flags-off (cons (hm-flag) flags-off))) - ((looking-at *hm-marked-regexp*) - (setq flags-on (cons (hm-flag) flags-on))) - (t - nil)) - (forward-line 1)) - (funcall hm-update-fn flags-on flags-off)))) - - -(defun hm-quit () - (interactive) - "Make the menu go away." - (bury-buffer (current-buffer)) - (replace-buffer-in-windows (current-buffer))) - -(defun hm-flag () - (save-excursion - (beginning-of-line) - (forward-char 6) - (let ((beg (point))) - ;; End of flag name marked by tab or two spaces. - (re-search-forward "\t\\| ") - (buffer-substring beg (match-beginning 0))))) - - -;;; Update the menu to mark only those items currently turned on. - -(defun hm-mark-current () - (funcall hm-request-fn) - (save-excursion - (goto-char (point-min)) - (while (not (eq (point) (point-max))) - (cond ((and (looking-at *hm-unmarked-regexp*) - (hm-item-currently-on-p (hm-flag))) - (hm-mark)) - ((and (looking-at *hm-marked-regexp*) - (not (hm-item-currently-on-p (hm-flag)))) - (hm-unmark)) - (t - (forward-line 1)))))) - - -;;; See if a menu item is turned on. - -(defun hm-item-currently-on-p (item) - (member-string= item hm-current-flags)) - -(defun member-string= (item list) - (cond ((null list) - nil) - ((string= item (car list)) - list) - (t - (member-string= item (cdr list))))) - - - -;;; Make the menu for printers. - -(defvar *haskell-printers-help* - (concat (getenv "HASKELL") "/emacs-tools/printer-help.txt") - "Help file for printers.") - -(defvar *haskell-printers-buffer* "*Haskell printers*") - -(defun haskell-printers () - "Set printers interactively." - (interactive) - (haskell-menu - *haskell-printers-help* - *haskell-printers-buffer* - 'haskell-printers-inquire - 'haskell-printers-set)) - -(defun haskell-printers-inquire () - (setq hm-current-flags t) - (haskell-send-to-process ":(emacs-send-printers)") - (while (eq hm-current-flags t) - (sleep-for 1))) - -(defun haskell-printers-update (data) - (setq hm-current-flags (read data))) - -(defun haskell-printers-set (flags-on flags-off) - (haskell-send-to-process ":(emacs-set-printers '") - (haskell-send-to-process (prin1-to-string flags-on)) - (haskell-send-to-process ")")) - - -;;; Equivalent stuff for the optimizers menu - -(defvar *haskell-optimizers-help* - (concat (getenv "HASKELL") "/emacs-tools/optimizer-help.txt") - "Help file for optimizers.") - -(defvar *haskell-optimizers-buffer* "*Haskell optimizers*") - -(defun haskell-optimizers () - "Set optimizers interactively." - (interactive) - (haskell-menu - *haskell-optimizers-help* - *haskell-optimizers-buffer* - 'haskell-optimizers-inquire - 'haskell-optimizers-set)) - -(defun haskell-optimizers-inquire () - (setq hm-current-flags t) - (haskell-send-to-process ":(emacs-send-optimizers)") - (while (eq hm-current-flags t) - (sleep-for 1))) - -(defun haskell-optimizers-update (data) - (setq hm-current-flags (read data))) - -(defun haskell-optimizers-set (flags-on flags-off) - (haskell-send-to-process ":(emacs-set-optimizers '") - (haskell-send-to-process (prin1-to-string flags-on)) - (haskell-send-to-process ")")) - - - -;;; ================================================================== -;;; Random utilities -;;; ================================================================== - - -;;; Keep track of the association between pads, modules, and files. -;;; The global variable is a list of (pad-buffer-name module-name file-name) -;;; lists. - -(defvar *haskell-pad-mappings* () - "Associates pads with their corresponding module and file.") - -(defun haskell-record-pad-mapping (pname mname fname) - (setq *haskell-pad-mappings* - (cons (list pname mname fname) *haskell-pad-mappings*))) - -(defun haskell-get-module-from-pad (pname) - (car (cdr (assoc pname *haskell-pad-mappings*)))) - -(defun haskell-get-file-from-pad (pname) - (car (cdr (cdr (assoc pname *haskell-pad-mappings*))))) - -(defun haskell-lookup-pad (mname fname) - (let ((pname (haskell-lookup-pad-aux mname fname *haskell-pad-mappings*))) - (if (and pname (get-buffer pname)) - pname - nil))) - -(defun haskell-lookup-pad-aux (mname fname list) - (cond ((null list) - nil) - ((and (equal mname (car (cdr (car list)))) - (equal fname (car (cdr (cdr (car list)))))) - (car (car list))) - (t - (haskell-lookup-pad-aux mname fname (cdr list))))) - - - -;;; Save any modified .hs and .hu files. -;;; Yes, the two set-buffer calls really seem to be necessary. It seems -;;; that y-or-n-p makes emacs forget we had temporarily selected some -;;; other buffer, and if you just do save-buffer directly it will end -;;; up trying to save the current buffer instead. The built-in -;;; save-some-buffers function has this problem.... - -(defun haskell-save-modified-source-files (filename) - (let ((buffers (buffer-list)) - (found-any nil)) - (while buffers - (let ((buffer (car buffers))) - (if (and (buffer-modified-p buffer) - (save-excursion - (set-buffer buffer) - (and buffer-file-name - (haskell-source-file-p buffer-file-name) - (setq found-any t) - (or (null haskell-ask-before-saving) - (and filename (string= buffer-file-name filename)) - (y-or-n-p - (format "Save file %s? " buffer-file-name)))))) - (save-excursion - (set-buffer buffer) - (save-buffer)))) - (setq buffers (cdr buffers))) - (if found-any - (message "") - (message "(No files need saving)")))) - -(defun haskell-source-file-p (filename) - (or (string-match "\\.hs$" filename) - (string-match "\\.lhs$" filename) - (string-match "\\.hi$" filename) - (string-match "\\.hu$" filename))) - - - -;;; Buffer utilities - -(defun haskell-move-marker () - "Moves the marker and point to the end of buffer" - (set-marker comint-last-input-end (point-max)) - (set-marker (process-mark (get-process "haskell")) (point-max)) - (goto-char (point-max))) - - - -;;; Extract the name of the module the point is in, from the given buffer. - -(defvar *haskell-re-module-hs* "^module\\s *") -(defvar *haskell-re-module-lhs* "^>\\s *module\\s *") -(defvar *haskell-re-modname* "[A-Z]\\([a-z]\\|[A-Z]\\|[0-9]\\|'\\|_\\)*") - -(defun haskell-get-modname (buff) - "Get module name in BUFFER that point is in." - (save-excursion - (set-buffer buff) - (let ((regexp (if (haskell-lhs-filename-p (buffer-file-name)) - *haskell-re-module-lhs* - *haskell-re-module-hs*))) - (if (or (looking-at regexp) - (re-search-backward regexp (point-min) t) - (re-search-forward regexp (point-max) t)) - (progn - (goto-char (match-end 0)) - (if (looking-at *haskell-re-modname*) - (buffer-substring (match-beginning 0) (match-end 0)) - (haskell-mode-error "Module name not found!!"))) - "Main")))) - - -;;; Strip file extensions. -;;; Only strip off extensions we know about; e.g. -;;; "foo.hs" -> "foo" but "foo.bar" -> "foo.bar". - -(defvar *haskell-filename-regexp* "\\(.*\\)\\.\\(hs\\|lhs\\)$") - -(defun haskell-strip-file-extension (filename) - "Strip off the extension from a filename." - (if (string-match *haskell-filename-regexp* filename) - (substring filename (match-beginning 1) (match-end 1)) - filename)) - - -;;; Is this a .lhs filename? - -(defun haskell-lhs-filename-p (filename) - (string-match ".*\\.lhs$" filename)) - - -;;; Haskell mode error - -(defun haskell-mode-error (msg) - "Show MSG in message line as an error from the haskell mode." - (error (concat "Haskell mode: " msg))) - - - -;;; ================================================================== -;;; User customization -;;; ================================================================== - -(defvar haskell-load-hook nil - "This hook is run when haskell is loaded in. -This is a good place to put key bindings." - ) - -(run-hooks 'haskell-load-hook) - - - - -;;;====================================================================== -;;; Tutorial mode setup -;;;====================================================================== - -;;; Set up additional key bindings for tutorial mode. - -(defvar ht-mode-map (make-sparse-keymap)) - -(haskell-establish-key-bindings ht-mode-map) -(define-key ht-mode-map "\C-c\C-f" 'ht-next-page) -(define-key ht-mode-map "\C-c\C-b" 'ht-prev-page) -(define-key ht-mode-map "\C-c\C-l" 'ht-restore-page) -(define-key ht-mode-map "\C-c?" 'describe-mode) - -(defun haskell-tutorial-mode () - "Major mode for running the Haskell tutorial. -You can use these commands: -\\{ht-mode-map}" - (interactive) - (kill-all-local-variables) - (use-local-map ht-mode-map) - (setq major-mode 'haskell-tutorial-mode) - (setq mode-name "Haskell Tutorial") - (set-syntax-table haskell-mode-syntax-table) - (run-hooks 'haskell-mode-hook)) - - -(defun haskell-tutorial () - "Run the haskell tutorial." - (interactive) - (ht-load-tutorial) - (ht-make-buffer) - (ht-display-page) - (haskell-maybe-create-process) - (haskell-send-to-process ":(emacs-set-printers '(interactive))") - ) - - -;;; Load the tutorial file into a read-only buffer. Do not display this -;;; buffer. - -(defun ht-load-tutorial () - (let ((buffer (get-buffer *ht-file-buffer*))) - (if buffer - (save-excursion - (set-buffer buffer) - (beginning-of-buffer)) - (save-excursion - (set-buffer (setq buffer (get-buffer-create *ht-file-buffer*))) - (let ((fname (substitute-in-file-name *ht-source-file*))) - (if (file-readable-p fname) - (ht-load-tutorial-aux fname) - (call-interactively 'ht-load-tutorial-aux))))))) - -(defun ht-load-tutorial-aux (filename) - (interactive "fTutorial file: ") - (insert-file filename) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (beginning-of-buffer)) - - -;;; Create a buffer to use for messing about with each page of the tutorial. -;;; Put the buffer into haskell-tutorial-mode. - -(defun ht-make-buffer () - (find-file (concat "/tmp/" (make-temp-name "ht") ".lhs")) - (setq *ht-temp-buffer* (buffer-name)) - (haskell-tutorial-mode)) - - -;;; Commands for loading text into the tutorial pad buffer - -(defun ht-next-page () - "Go to the next tutorial page." - (interactive) - (if (ht-goto-next-page) - (ht-display-page) - (beep))) - -(defun ht-goto-next-page () - (let ((buff (current-buffer))) - (unwind-protect - (progn - (set-buffer *ht-file-buffer*) - (search-forward "\C-l" nil t)) - (set-buffer buff)))) - -(defun ht-prev-page () - "Go to the previous tutorial page." - (interactive) - (if (ht-goto-prev-page) - (ht-display-page) - (beep))) - -(defun ht-goto-prev-page () - (let ((buff (current-buffer))) - (unwind-protect - (progn - (set-buffer *ht-file-buffer*) - (search-backward "\C-l" nil t)) - (set-buffer buff)))) - -(defun ht-goto-page (arg) - "Go to the tutorial page specified as the argument." - (interactive "sGo to page: ") - (if (ht-searchfor-page (format "Page: %s " arg)) - (ht-display-page) - (beep))) - -(defun ht-goto-section (arg) - "Go to the tutorial section specified as the argument." - (interactive "sGo to section: ") - (if (ht-searchfor-page (format "Section: %s " arg)) - (ht-display-page) - (beep))) - -(defun ht-searchfor-page (search-string) - (let ((buff (current-buffer))) - (unwind-protect - (progn - (set-buffer *ht-file-buffer*) - (let ((point (point))) - (beginning-of-buffer) - (if (search-forward search-string nil t) - t - (progn - (goto-char point) - nil)))) - (set-buffer buff)))) - -(defun ht-restore-page () - (interactive) - (let ((old-point (point))) - (ht-display-page) - (goto-char old-point))) - -(defun ht-display-page () - (set-buffer *ht-file-buffer*) - (let* ((beg (progn - (if (search-backward "\C-l" nil t) - (forward-line 1) - (beginning-of-buffer)) - (point))) - (end (progn - (if (search-forward "\C-l" nil t) - (beginning-of-line) - (end-of-buffer)) - (point))) - (text (buffer-substring beg end))) - (set-buffer *ht-temp-buffer*) - (erase-buffer) - (insert text) - (beginning-of-buffer))) - - - -;;;====================================================================== -;;; Menu bar stuff -;;;====================================================================== - -;;; This only works in Emacs version 19, so it's in a separate file for now. - -(if (featurep 'menu-bar) - (load-library "haskell-menu")) - diff --git a/ghc/CONTRIB/haskell-modes/yale/original/README b/ghc/CONTRIB/haskell-modes/yale/original/README deleted file mode 100644 index bb22105391..0000000000 --- a/ghc/CONTRIB/haskell-modes/yale/original/README +++ /dev/null @@ -1,5 +0,0 @@ -This directory contains GNU Emacs support for editing Haskell files. -We don't yet have a fancy editing mode, but haskell.el contains stuff -for running Haskell as an inferior process from Emacs with key bindings -for evaluating code from buffers, etc. Look at the comments in haskell.el -for more information. diff --git a/ghc/CONTRIB/haskell-modes/yale/original/comint.el b/ghc/CONTRIB/haskell-modes/yale/original/comint.el deleted file mode 100644 index e690005aa8..0000000000 --- a/ghc/CONTRIB/haskell-modes/yale/original/comint.el +++ /dev/null @@ -1,1524 +0,0 @@ -;;; -*-Emacs-Lisp-*- General command interpreter in a window stuff -;;; Copyright Olin Shivers (1988). -;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright -;;; notice appearing here to the effect that you may use this code any -;;; way you like, as long as you don't charge money for it, remove this -;;; notice, or hold me liable for its results. - -;;; The changelog is at the end of this file. - -;;; Please send me bug reports, bug fixes, and extensions, so that I can -;;; merge them into the master source. -;;; - Olin Shivers (shivers@cs.cmu.edu) - -;;; This hopefully generalises shell mode, lisp mode, tea mode, soar mode,... -;;; This file defines a general command-interpreter-in-a-buffer package -;;; (comint mode). The idea is that you can build specific process-in-a-buffer -;;; modes on top of comint mode -- e.g., lisp, shell, scheme, T, soar, .... -;;; This way, all these specific packages share a common base functionality, -;;; and a common set of bindings, which makes them easier to use (and -;;; saves code, implementation time, etc., etc.). - -;;; Several packages are already defined using comint mode: -;;; - cmushell.el defines a shell-in-a-buffer mode. -;;; - cmulisp.el defines a simple lisp-in-a-buffer mode. -;;; Cmushell and cmulisp mode are similar to, and intended to replace, -;;; their counterparts in the standard gnu emacs release (in shell.el). -;;; These replacements are more featureful, robust, and uniform than the -;;; released versions. The key bindings in lisp mode are also more compatible -;;; with the bindings of Hemlock and Zwei (the Lisp Machine emacs). -;;; -;;; - The file cmuscheme.el defines a scheme-in-a-buffer mode. -;;; - The file tea.el tunes scheme and inferior-scheme modes for T. -;;; - The file soar.el tunes lisp and inferior-lisp modes for Soar. -;;; - cmutex.el defines tex and latex modes that invoke tex, latex, bibtex, -;;; previewers, and printers from within emacs. -;;; - background.el allows csh-like job control inside emacs. -;;; It is pretty easy to make new derived modes for other processes. - -;;; For documentation on the functionality provided by comint mode, and -;;; the hooks available for customising it, see the comments below. -;;; For further information on the standard derived modes (shell, -;;; inferior-lisp, inferior-scheme, ...), see the relevant source files. - -;;; For hints on converting existing process modes (e.g., tex-mode, -;;; background, dbx, gdb, kermit, prolog, telnet) to use comint-mode -;;; instead of shell-mode, see the notes at the end of this file. - -(provide 'comint) -(defconst comint-version "2.01") - - - - - - - - - - - - - - - - - - - - - -;;; Brief Command Documentation: -;;;============================================================================ -;;; Comint Mode Commands: (common to all derived modes, like cmushell & cmulisp -;;; mode) -;;; -;;; m-p comint-previous-input Cycle backwards in input history -;;; m-n comint-next-input Cycle forwards -;;; m-s comint-previous-similar-input Previous similar input -;;; c-c r comint-previous-input-matching Search backwards in input history -;;; return comint-send-input -;;; c-a comint-bol Beginning of line; skip prompt. -;;; c-d comint-delchar-or-maybe-eof Delete char unless at end of buff. -;;; c-c c-u comint-kill-input ^u -;;; c-c c-w backward-kill-word ^w -;;; c-c c-c comint-interrupt-subjob ^c -;;; c-c c-z comint-stop-subjob ^z -;;; c-c c-\ comint-quit-subjob ^\ -;;; c-c c-o comint-kill-output Delete last batch of process output -;;; c-c c-r comint-show-output Show last batch of process output -;;; -;;; Not bound by default in comint-mode -;;; send-invisible Read a line w/o echo, and send to proc -;;; (These are bound in shell-mode) -;;; comint-dynamic-complete Complete filename at point. -;;; comint-dynamic-list-completions List completions in help buffer. -;;; comint-replace-by-expanded-filename Expand and complete filename at point; -;;; replace with expanded/completed name. -;;; comint-kill-subjob No mercy. -;;; comint-continue-subjob Send CONT signal to buffer's process -;;; group. Useful if you accidentally -;;; suspend your process (with C-c C-z). -;;; -;;; Bound for RMS -- I prefer the input history stuff, but you might like 'em. -;;; m-P comint-msearch-input Search backwards for prompt -;;; m-N comint-psearch-input Search forwards for prompt -;;; C-cR comint-msearch-input-matching Search backwards for prompt & string - -;;; comint-mode-hook is the comint mode hook. Basically for your keybindings. -;;; comint-load-hook is run after loading in this package. - - - - - -;;; Buffer Local Variables: -;;;============================================================================ -;;; Comint mode buffer local variables: -;;; comint-prompt-regexp - string comint-bol uses to match prompt. -;;; comint-last-input-end - marker For comint-kill-output command -;;; input-ring-size - integer For the input history -;;; input-ring - ring mechanism -;;; input-ring-index - marker ... -;;; comint-last-input-match - string ... -;;; comint-get-old-input - function Hooks for specific -;;; comint-input-sentinel - function process-in-a-buffer -;;; comint-input-filter - function modes. -;;; comint-input-send - function -;;; comint-eol-on-send - boolean - -(defvar comint-prompt-regexp "^" - "Regexp to recognise prompts in the inferior process. -Defaults to \"^\", the null string at BOL. - -Good choices: - Canonical Lisp: \"^[^> ]*>+:? *\" (Lucid, franz, kcl, T, cscheme, oaklisp) - Lucid Common Lisp: \"^\\(>\\|\\(->\\)+\\) *\" - franz: \"^\\(->\\|<[0-9]*>:\\) *\" - kcl: \"^>+ *\" - shell: \"^[^#$%>]*[#$%>] *\" - T: \"^>+ *\" - -This is a good thing to set in mode hooks.") - -(defvar input-ring-size 30 - "Size of input history ring.") - -;;; Here are the per-interpreter hooks. -(defvar comint-get-old-input (function comint-get-old-input-default) - "Function that submits old text in comint mode. -This function is called when return is typed while the point is in old text. -It returns the text to be submitted as process input. The default is -comint-get-old-input-default, which grabs the current line, and strips off -leading text matching comint-prompt-regexp") - -(defvar comint-input-sentinel (function ignore) - "Called on each input submitted to comint mode process by comint-send-input. -Thus it can, for instance, track cd/pushd/popd commands issued to the csh.") - -(defvar comint-input-filter - (function (lambda (str) (not (string-match "\\`\\s *\\'" str)))) - "Predicate for filtering additions to input history. -Only inputs answering true to this function are saved on the input -history list. Default is to save anything that isn't all whitespace") - -(defvar comint-input-sender (function comint-simple-send) - "Function to actually send to PROCESS the STRING submitted by user. -Usually this is just 'comint-simple-send, but if your mode needs to -massage the input string, this is your hook. This is called from -the user command comint-send-input. comint-simple-send just sends -the string plus a newline.") - -(defvar comint-eol-on-send 'T - "If non-nil, then jump to the end of the line before sending input to process. -See COMINT-SEND-INPUT") - -(defvar comint-mode-hook '() - "Called upon entry into comint-mode") - -(defvar comint-mode-map nil) - -(defun comint-mode () - "Major mode for interacting with an inferior interpreter. -Interpreter name is same as buffer name, sans the asterisks. -Return at end of buffer sends line as input. -Return not at end copies rest of line to end and sends it. -Setting mode variable comint-eol-on-send means jump to the end of the line -before submitting new input. - -This mode is typically customised to create inferior-lisp-mode, -shell-mode, etc.. This can be done by setting the hooks -comint-input-sentinel, comint-input-filter, comint-input-sender and -comint-get-old-input to appropriate functions, and the variable -comint-prompt-regexp to the appropriate regular expression. - -An input history is maintained of size input-ring-size, and -can be accessed with the commands comint-next-input [\\[comint-next-input]] and -comint-previous-input [\\[comint-previous-input]]. Commands not keybound by -default are send-invisible, comint-dynamic-complete, and -comint-list-dynamic-completions. - -If you accidentally suspend your process, use \\[comint-continue-subjob] -to continue it. - -\\{comint-mode-map} - -Entry to this mode runs the hooks on comint-mode-hook" - (interactive) - (let ((old-ring (and (assq 'input-ring (buffer-local-variables)) - (boundp 'input-ring) - input-ring)) - (old-ptyp comint-ptyp)) ; preserve across local var kill. gross. - (kill-all-local-variables) - (setq major-mode 'comint-mode) - (setq mode-name "Comint") - (setq mode-line-process '(": %s")) - (use-local-map comint-mode-map) - (make-local-variable 'comint-last-input-end) - (setq comint-last-input-end (make-marker)) - (make-local-variable 'comint-last-input-match) - (setq comint-last-input-match "") - (make-local-variable 'comint-prompt-regexp) ; Don't set; default - (make-local-variable 'input-ring-size) ; ...to global val. - (make-local-variable 'input-ring) - (make-local-variable 'input-ring-index) - (setq input-ring-index 0) - (make-local-variable 'comint-get-old-input) - (make-local-variable 'comint-input-sentinel) - (make-local-variable 'comint-input-filter) - (make-local-variable 'comint-input-sender) - (make-local-variable 'comint-eol-on-send) - (make-local-variable 'comint-ptyp) - (setq comint-ptyp old-ptyp) - (run-hooks 'comint-mode-hook) - ;Do this after the hook so the user can mung INPUT-RING-SIZE w/his hook. - ;The test is so we don't lose history if we run comint-mode twice in - ;a buffer. - (setq input-ring (if (ring-p old-ring) old-ring - (make-ring input-ring-size))))) - -;;; The old-ptyp stuff above is because we have to preserve the value of -;;; comint-ptyp across calls to comint-mode, in spite of the -;;; kill-all-local-variables that it does. Blech. Hopefully, this will all -;;; go away when a later release fixes the signalling bug. - -(if comint-mode-map - nil - (setq comint-mode-map (make-sparse-keymap)) - (define-key comint-mode-map "\ep" 'comint-previous-input) - (define-key comint-mode-map "\en" 'comint-next-input) - (define-key comint-mode-map "\es" 'comint-previous-similar-input) - (define-key comint-mode-map "\C-m" 'comint-send-input) - (define-key comint-mode-map "\C-d" 'comint-delchar-or-maybe-eof) - (define-key comint-mode-map "\C-a" 'comint-bol) - (define-key comint-mode-map "\C-c\C-u" 'comint-kill-input) - (define-key comint-mode-map "\C-c\C-w" 'backward-kill-word) - (define-key comint-mode-map "\C-c\C-c" 'comint-interrupt-subjob) - (define-key comint-mode-map "\C-c\C-z" 'comint-stop-subjob) - (define-key comint-mode-map "\C-c\C-\\" 'comint-quit-subjob) - (define-key comint-mode-map "\C-c\C-o" 'comint-kill-output) - (define-key comint-mode-map "\C-cr" 'comint-previous-input-matching) - (define-key comint-mode-map "\C-c\C-r" 'comint-show-output) - ;;; Here's the prompt-search stuff I installed for RMS to try... - (define-key comint-mode-map "\eP" 'comint-msearch-input) - (define-key comint-mode-map "\eN" 'comint-psearch-input) - (define-key comint-mode-map "\C-cR" 'comint-msearch-input-matching)) - - -;;; This function is used to make a full copy of the comint mode map, -;;; so that client modes won't interfere with each other. This function -;;; isn't necessary in emacs 18.5x, but we keep it around for 18.4x versions. -(defun full-copy-sparse-keymap (km) - "Recursively copy the sparse keymap KM" - (cond ((consp km) - (cons (full-copy-sparse-keymap (car km)) - (full-copy-sparse-keymap (cdr km)))) - (t km))) - -(defun comint-check-proc (buffer-name) - "True if there is a process associated w/buffer BUFFER-NAME, and -it is alive (status RUN or STOP)." - (let ((proc (get-buffer-process buffer-name))) - (and proc (memq (process-status proc) '(run stop))))) - -;;; Note that this guy, unlike shell.el's make-shell, barfs if you pass it () -;;; for the second argument (program). -(defun make-comint (name program &optional startfile &rest switches) - (let* ((buffer (get-buffer-create (concat "*" name "*"))) - (proc (get-buffer-process buffer))) - ;; If no process, or nuked process, crank up a new one and put buffer in - ;; comint mode. Otherwise, leave buffer and existing process alone. - (cond ((or (not proc) (not (memq (process-status proc) '(run stop)))) - (save-excursion - (set-buffer buffer) - (comint-mode)) ; Install local vars, mode, keymap, ... - (comint-exec buffer name program startfile switches))) - buffer)) - -(defvar comint-ptyp t - "True if communications via pty; false if by pipe. Buffer local. -This is to work around a bug in emacs process signalling.") - -(defun comint-exec (buffer name command startfile switches) - "Fires up a process in buffer for comint modes. -Blasts any old process running in the buffer. Doesn't set the buffer mode. -You can use this to cheaply run a series of processes in the same comint -buffer." - (save-excursion - (set-buffer buffer) - (let ((proc (get-buffer-process buffer))) ; Blast any old process. - (if proc (delete-process proc))) - ;; Crank up a new process - (let ((proc (comint-exec-1 name buffer command switches))) - (make-local-variable 'comint-ptyp) - (setq comint-ptyp process-connection-type) ; T if pty, NIL if pipe. - ;; Jump to the end, and set the process mark. - (goto-char (point-max)) - (set-marker (process-mark proc) (point))) - ;; Feed it the startfile. - (cond (startfile - ;;This is guaranteed to wait long enough - ;;but has bad results if the comint does not prompt at all - ;; (while (= size (buffer-size)) - ;; (sleep-for 1)) - ;;I hope 1 second is enough! - (sleep-for 1) - (goto-char (point-max)) - (insert-file-contents startfile) - (setq startfile (buffer-substring (point) (point-max))) - (delete-region (point) (point-max)) - (comint-send-string proc startfile))) - buffer)) - -;;; This auxiliary function cranks up the process for comint-exec in -;;; the appropriate environment. It is twice as long as it should be -;;; because emacs has two distinct mechanisms for manipulating the -;;; process environment, selected at compile time with the -;;; MAINTAIN-ENVIRONMENT #define. In one case, process-environment -;;; is bound; in the other it isn't. - -(defun comint-exec-1 (name buffer command switches) - (if (boundp 'process-environment) ; Not a completely reliable test. - (let ((process-environment - (comint-update-env process-environment - (list (format "TERMCAP=emacs:co#%d:tc=unknown" - (screen-width)) - "TERM=emacs" - "EMACS=t")))) - (apply 'start-process name buffer command switches)) - - (let ((tcapv (getenv "TERMCAP")) - (termv (getenv "TERM")) - (emv (getenv "EMACS"))) - (unwind-protect - (progn (setenv "TERMCAP" (format "emacs:co#%d:tc=unknown" - (screen-width))) - (setenv "TERM" "emacs") - (setenv "EMACS" "t") - (apply 'start-process name buffer command switches)) - (setenv "TERMCAP" tcapv) - (setenv "TERM" termv) - (setenv "EMACS" emv))))) - - - -;; This is just (append new old-env) that compresses out shadowed entries. -;; It's also pretty ugly, mostly due to elisp's horrible iteration structures. -(defun comint-update-env (old-env new) - (let ((ans (reverse new)) - (vars (mapcar (function (lambda (vv) - (and (string-match "^[^=]*=" vv) - (substring vv 0 (match-end 0))))) - new))) - (while old-env - (let* ((vv (car old-env)) ; vv is var=value - (var (and (string-match "^[^=]*=" vv) - (substring vv 0 (match-end 0))))) - (setq old-env (cdr old-env)) - (cond ((not (and var (comint-mem var vars))) - (if var (setq var (cons var vars))) - (setq ans (cons vv ans)))))) - (nreverse ans))) - -;;; This should be in emacs, but it isn't. -(defun comint-mem (item list &optional elt=) - "Test to see if ITEM is equal to an item in LIST. -Option comparison function ELT= defaults to equal." - (let ((elt= (or elt= (function equal))) - (done nil)) - (while (and list (not done)) - (if (funcall elt= item (car list)) - (setq done list) - (setq list (cdr list)))) - done)) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -;;; Ring Code -;;;============================================================================ -;;; This code defines a ring data structure. A ring is a -;;; (hd-index tl-index . vector) -;;; list. You can insert to, remove from, and rotate a ring. When the ring -;;; fills up, insertions cause the oldest elts to be quietly dropped. -;;; -;;; HEAD = index of the newest item on the ring. -;;; TAIL = index of the oldest item on the ring. -;;; -;;; These functions are used by the input history mechanism, but they can -;;; be used for other purposes as well. - -(defun ring-p (x) - "T if X is a ring; NIL otherwise." - (and (consp x) (integerp (car x)) - (consp (cdr x)) (integerp (car (cdr x))) - (vectorp (cdr (cdr x))))) - -(defun make-ring (size) - "Make a ring that can contain SIZE elts" - (cons 1 (cons 0 (make-vector (+ size 1) nil)))) - -(defun ring-plus1 (index veclen) - "INDEX+1, with wraparound" - (let ((new-index (+ index 1))) - (if (= new-index veclen) 0 new-index))) - -(defun ring-minus1 (index veclen) - "INDEX-1, with wraparound" - (- (if (= 0 index) veclen index) 1)) - -(defun ring-length (ring) - "Number of elts in the ring." - (let ((hd (car ring)) (tl (car (cdr ring))) (siz (length (cdr (cdr ring))))) - (let ((len (if (<= hd tl) (+ 1 (- tl hd)) (+ 1 tl (- siz hd))))) - (if (= len siz) 0 len)))) - -(defun ring-empty-p (ring) - (= 0 (ring-length ring))) - -(defun ring-insert (ring item) - "Insert a new item onto the ring. If the ring is full, dump the oldest -item to make room." - (let* ((vec (cdr (cdr ring))) (len (length vec)) - (new-hd (ring-minus1 (car ring) len))) - (setcar ring new-hd) - (aset vec new-hd item) - (if (ring-empty-p ring) ;overflow -- dump one off the tail. - (setcar (cdr ring) (ring-minus1 (car (cdr ring)) len))))) - -(defun ring-remove (ring) - "Remove the oldest item retained on the ring." - (if (ring-empty-p ring) (error "Ring empty") - (let ((tl (car (cdr ring))) (vec (cdr (cdr ring)))) - (set-car (cdr ring) (ring-minus1 tl (length vec))) - (aref vec tl)))) - -;;; This isn't actually used in this package. I just threw it in in case -;;; someone else wanted it. If you want rotating-ring behavior on your history -;;; retrieval (analagous to kill ring behavior), this function is what you -;;; need. I should write the yank-input and yank-pop-input-or-kill to go with -;;; this, and not bind it to a key by default, so it would be available to -;;; people who want to bind it to a key. But who would want it? Blech. -(defun ring-rotate (ring n) - (if (not (= n 0)) - (if (ring-empty-p ring) ;Is this the right error check? - (error "ring empty") - (let ((hd (car ring)) (tl (car (cdr ring))) (vec (cdr (cdr ring)))) - (let ((len (length vec))) - (while (> n 0) - (setq tl (ring-plus1 tl len)) - (aset ring tl (aref ring hd)) - (setq hd (ring-plus1 hd len)) - (setq n (- n 1))) - (while (< n 0) - (setq hd (ring-minus1 hd len)) - (aset vec hd (aref vec tl)) - (setq tl (ring-minus1 tl len)) - (setq n (- n 1)))) - (set-car ring hd) - (set-car (cdr ring) tl))))) - -(defun comint-mod (n m) - "Returns N mod M. M is positive. Answer is guaranteed to be non-negative, -and less than m." - (let ((n (% n m))) - (if (>= n 0) n - (+ n - (if (>= m 0) m (- m)))))) ; (abs m) - -(defun ring-ref (ring index) - (let ((numelts (ring-length ring))) - (if (= numelts 0) (error "indexed empty ring") - (let* ((hd (car ring)) (tl (car (cdr ring))) (vec (cdr (cdr ring))) - (index (comint-mod index numelts)) - (vec-index (comint-mod (+ index hd) - (length vec)))) - (aref vec vec-index))))) - - -;;; Input history retrieval commands -;;; M-p -- previous input M-n -- next input -;;; C-c r -- previous input matching -;;; =========================================================================== - -(defun comint-previous-input (arg) - "Cycle backwards through input history." - (interactive "*p") - (let ((len (ring-length input-ring))) - (cond ((<= len 0) - (message "Empty input ring") - (ding)) - ((not (comint-after-pmark-p)) - (message "Not after process mark") - (ding)) - (t - (cond ((eq last-command 'comint-previous-input) - (delete-region (mark) (point))) - ((eq last-command 'comint-previous-similar-input) - (delete-region - (process-mark (get-buffer-process (current-buffer))) - (point))) - (t - (setq input-ring-index - (if (> arg 0) -1 - (if (< arg 0) 1 0))) - (push-mark (point)))) - (setq input-ring-index (comint-mod (+ input-ring-index arg) len)) - (message "%d" (1+ input-ring-index)) - (insert (ring-ref input-ring input-ring-index)) - (setq this-command 'comint-previous-input))))) - -(defun comint-next-input (arg) - "Cycle forwards through input history." - (interactive "*p") - (comint-previous-input (- arg))) - -(defvar comint-last-input-match "" - "Last string searched for by comint input history search, for defaulting. -Buffer local variable.") - -(defun comint-previous-input-matching (str) - "Searches backwards through input history for substring match." - (interactive (let* ((last-command last-command) ; preserve around r-f-m - (s (read-from-minibuffer - (format "Command substring (default %s): " - comint-last-input-match)))) - (list (if (string= s "") comint-last-input-match s)))) -; (interactive "sCommand substring: ") - (setq comint-last-input-match str) ; update default - (if (not (eq last-command 'comint-previous-input)) - (setq input-ring-index -1)) - (let ((str (regexp-quote str)) - (len (ring-length input-ring)) - (n (+ input-ring-index 1))) - (while (and (< n len) (not (string-match str (ring-ref input-ring n)))) - (setq n (+ n 1))) - (cond ((< n len) - (comint-previous-input (- n input-ring-index))) - (t (if (eq last-command 'comint-previous-input) - (setq this-command 'comint-previous-input)) - (message "Not found.") - (ding))))) - - -;;; These next three commands are alternatives to the input history commands -- -;;; comint-next-input, comint-previous-input and -;;; comint-previous-input-matching. They search through the process buffer -;;; text looking for occurrences of the prompt. RMS likes them better; -;;; I don't. Bound to M-P, M-N, and C-c R (uppercase P, N, and R) for -;;; now. Try'em out. Go with what you like... - -;;; comint-msearch-input-matching prompts for a string, not a regexp. -;;; This could be considered to be the wrong thing. I decided to keep it -;;; simple, and not make the user worry about regexps. This, of course, -;;; limits functionality. - -(defun comint-psearch-input () - "Search forwards for next occurrence of prompt and skip to end of line. -\(prompt is anything matching regexp comint-prompt-regexp)" - (interactive) - (if (re-search-forward comint-prompt-regexp (point-max) t) - (end-of-line) - (error "No occurrence of prompt found"))) - -(defun comint-msearch-input () - "Search backwards for previous occurrence of prompt and skip to end of line. -Search starts from beginning of current line." - (interactive) - (let ((p (save-excursion - (beginning-of-line) - (cond ((re-search-backward comint-prompt-regexp (point-min) t) - (end-of-line) - (point)) - (t nil))))) - (if p (goto-char p) - (error "No occurrence of prompt found")))) - -(defun comint-msearch-input-matching (str) - "Search backwards for occurrence of prompt followed by STRING. -STRING is prompted for, and is NOT a regular expression." - (interactive (let ((s (read-from-minibuffer - (format "Command (default %s): " - comint-last-input-match)))) - (list (if (string= s "") comint-last-input-match s)))) -; (interactive "sCommand: ") - (setq comint-last-input-match str) ; update default - (let* ((r (concat comint-prompt-regexp (regexp-quote str))) - (p (save-excursion - (beginning-of-line) - (cond ((re-search-backward r (point-min) t) - (end-of-line) - (point)) - (t nil))))) - (if p (goto-char p) - (error "No match")))) - -;;; -;;; Similar input -- contributed by ccm and highly winning. -;;; -;;; Reenter input, removing back to the last insert point if it exists. -;;; -(defvar comint-last-similar-string "" - "The string last used in a similar string search.") -(defun comint-previous-similar-input (arg) - "Reenters the last input that matches the string typed so far. If repeated -successively older inputs are reentered. If arg is 1, it will go back -in the history, if -1 it will go forward." - (interactive "p") - (if (not (comint-after-pmark-p)) - (error "Not after process mark")) - (if (not (eq last-command 'comint-previous-similar-input)) - (setq input-ring-index -1 - comint-last-similar-string - (buffer-substring - (process-mark (get-buffer-process (current-buffer))) - (point)))) - (let* ((size (length comint-last-similar-string)) - (len (ring-length input-ring)) - (n (+ input-ring-index arg)) - entry) - (while (and (< n len) - (or (< (length (setq entry (ring-ref input-ring n))) size) - (not (equal comint-last-similar-string - (substring entry 0 size))))) - (setq n (+ n arg))) - (cond ((< n len) - (setq input-ring-index n) - (if (eq last-command 'comint-previous-similar-input) - (delete-region (mark) (point)) ; repeat - (push-mark (point))) ; 1st time - (insert (substring entry size))) - (t (message "Not found.") (ding) (sit-for 1))) - (message "%d" (1+ input-ring-index)))) - - - - - - - - - -(defun comint-send-input () - "Send input to process. After the process output mark, sends all text -from the process mark to point as input to the process. Before the -process output mark, calls value of variable comint-get-old-input to retrieve -old input, copies it to the end of the buffer, and sends it. A terminal -newline is also inserted into the buffer and sent to the process. In either -case, value of variable comint-input-sentinel is called on the input before -sending it. The input is entered into the input history ring, if value of -variable comint-input-filter returns non-nil when called on the input. - -If variable comint-eol-on-send is non-nil, then point is moved to the end of -line before sending the input. - -comint-get-old-input, comint-input-sentinel, and comint-input-filter are chosen -according to the command interpreter running in the buffer. E.g., -If the interpreter is the csh, - comint-get-old-input is the default: take the current line, discard any - initial string matching regexp comint-prompt-regexp. - comint-input-sentinel monitors input for \"cd\", \"pushd\", and \"popd\" - commands. When it sees one, it cd's the buffer. - comint-input-filter is the default: returns T if the input isn't all white - space. - -If the comint is Lucid Common Lisp, - comint-get-old-input snarfs the sexp ending at point. - comint-input-sentinel does nothing. - comint-input-filter returns NIL if the input matches input-filter-regexp, - which matches (1) all whitespace (2) :a, :c, etc. - -Similarly for Soar, Scheme, etc.." - (interactive) - ;; Note that the input string does not include its terminal newline. - (let ((proc (get-buffer-process (current-buffer)))) - (if (not proc) (error "Current buffer has no process") - (let* ((pmark (process-mark proc)) - (pmark-val (marker-position pmark)) - (input (if (>= (point) pmark-val) - (progn (if comint-eol-on-send (end-of-line)) - (buffer-substring pmark (point))) - (let ((copy (funcall comint-get-old-input))) - (goto-char pmark) - (insert copy) - copy)))) - (insert ?\n) - (if (funcall comint-input-filter input) (ring-insert input-ring input)) - (funcall comint-input-sentinel input) - (funcall comint-input-sender proc input) - (set-marker (process-mark proc) (point)) - (set-marker comint-last-input-end (point)))))) - -(defun comint-get-old-input-default () - "Default for comint-get-old-input: take the current line, and discard -any initial text matching comint-prompt-regexp." - (save-excursion - (beginning-of-line) - (comint-skip-prompt) - (let ((beg (point))) - (end-of-line) - (buffer-substring beg (point))))) - -(defun comint-skip-prompt () - "Skip past the text matching regexp comint-prompt-regexp. -If this takes us past the end of the current line, don't skip at all." - (let ((eol (save-excursion (end-of-line) (point)))) - (if (and (looking-at comint-prompt-regexp) - (<= (match-end 0) eol)) - (goto-char (match-end 0))))) - - -(defun comint-after-pmark-p () - "Is point after the process output marker?" - ;; Since output could come into the buffer after we looked at the point - ;; but before we looked at the process marker's value, we explicitly - ;; serialise. This is just because I don't know whether or not emacs - ;; services input during execution of lisp commands. - (let ((proc-pos (marker-position - (process-mark (get-buffer-process (current-buffer)))))) - (<= proc-pos (point)))) - -(defun comint-simple-send (proc string) - "Default function for sending to PROC input STRING. -This just sends STRING plus a newline. To override this, -set the hook COMINT-INPUT-SENDER." - (comint-send-string proc string) - (comint-send-string proc "\n")) - -(defun comint-bol (arg) - "Goes to the beginning of line, then skips past the prompt, if any. -If a prefix argument is given (\\[universal-argument]), then no prompt skip --- go straight to column 0. - -The prompt skip is done by skipping text matching the regular expression -comint-prompt-regexp, a buffer local variable. - -If you don't like this command, reset c-a to beginning-of-line -in your hook, comint-mode-hook." - (interactive "P") - (beginning-of-line) - (if (null arg) (comint-skip-prompt))) - -;;; These two functions are for entering text you don't want echoed or -;;; saved -- typically passwords to ftp, telnet, or somesuch. -;;; Just enter m-x send-invisible and type in your line. - -(defun comint-read-noecho (prompt) - "Prompt the user with argument PROMPT. Read a single line of text -without echoing, and return it. Note that the keystrokes comprising -the text can still be recovered (temporarily) with \\[view-lossage]. This -may be a security bug for some applications." - (let ((echo-keystrokes 0) - (answ "") - tem) - (if (and (stringp prompt) (not (string= (message prompt) ""))) - (message prompt)) - (while (not(or (= (setq tem (read-char)) ?\^m) - (= tem ?\n))) - (setq answ (concat answ (char-to-string tem)))) - (message "") - answ)) - -(defun send-invisible (str) - "Read a string without echoing, and send it to the process running -in the current buffer. A new-line is additionally sent. String is not -saved on comint input history list. -Security bug: your string can still be temporarily recovered with -\\[view-lossage]." -; (interactive (list (comint-read-noecho "Enter non-echoed text"))) - (interactive "P") ; Defeat snooping via C-x esc - (let ((proc (get-buffer-process (current-buffer)))) - (if (not proc) (error "Current buffer has no process") - (comint-send-string proc - (if (stringp str) str - (comint-read-noecho "Enter non-echoed text"))) - (comint-send-string proc "\n")))) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -;;; Low-level process communication - -(defvar comint-input-chunk-size 512 - "*Long inputs send to comint processes are broken up into chunks of this size. -If your process is choking on big inputs, try lowering the value.") - -(defun comint-send-string (proc str) - "Send PROCESS the contents of STRING as input. -This is equivalent to process-send-string, except that long input strings -are broken up into chunks of size comint-input-chunk-size. Processes -are given a chance to output between chunks. This can help prevent processes -from hanging when you send them long inputs on some OS's." - (let* ((len (length str)) - (i (min len comint-input-chunk-size))) - (process-send-string proc (substring str 0 i)) - (while (< i len) - (let ((next-i (+ i comint-input-chunk-size))) - (accept-process-output) - (process-send-string proc (substring str i (min len next-i))) - (setq i next-i))))) - -(defun comint-send-region (proc start end) - "Sends to PROC the region delimited by START and END. -This is a replacement for process-send-region that tries to keep -your process from hanging on long inputs. See comint-send-string." - (comint-send-string proc (buffer-substring start end))) - - - - - - - - - - - - - - - - - - -;;; Random input hackage - -(defun comint-kill-output () - "Kill all output from interpreter since last input." - (interactive) - (let ((pmark (process-mark (get-buffer-process (current-buffer))))) - (kill-region comint-last-input-end pmark) - (goto-char pmark) - (insert "*** output flushed ***\n") - (set-marker pmark (point)))) - -(defun comint-show-output () - "Display start of this batch of interpreter output at top of window. -Also put cursor there." - (interactive) - (goto-char comint-last-input-end) - (backward-char) - (beginning-of-line) - (set-window-start (selected-window) (point)) - (end-of-line)) - -(defun comint-interrupt-subjob () - "Interrupt the current subjob." - (interactive) - (interrupt-process nil comint-ptyp)) - -(defun comint-kill-subjob () - "Send kill signal to the current subjob." - (interactive) - (kill-process nil comint-ptyp)) - -(defun comint-quit-subjob () - "Send quit signal to the current subjob." - (interactive) - (quit-process nil comint-ptyp)) - -(defun comint-stop-subjob () - "Stop the current subjob. -WARNING: if there is no current subjob, you can end up suspending -the top-level process running in the buffer. If you accidentally do -this, use \\[comint-continue-subjob] to resume the process. (This -is not a problem with most shells, since they ignore this signal.)" - (interactive) - (stop-process nil comint-ptyp)) - -(defun comint-continue-subjob () - "Send CONT signal to process buffer's process group. -Useful if you accidentally suspend the top-level process." - (interactive) - (continue-process nil comint-ptyp)) - -(defun comint-kill-input () - "Kill all text from last stuff output by interpreter to point." - (interactive) - (let* ((pmark (process-mark (get-buffer-process (current-buffer)))) - (p-pos (marker-position pmark))) - (if (> (point) p-pos) - (kill-region pmark (point))))) - -(defun comint-delchar-or-maybe-eof (arg) - "Delete ARG characters forward, or send an EOF to process if at end of buffer." - (interactive "p") - (if (eobp) - (process-send-eof) - (delete-char arg))) - - - - - - - - - - - - - - - - - - - - - - - -;;; Support for source-file processing commands. -;;;============================================================================ -;;; Many command-interpreters (e.g., Lisp, Scheme, Soar) have -;;; commands that process files of source text (e.g. loading or compiling -;;; files). So the corresponding process-in-a-buffer modes have commands -;;; for doing this (e.g., lisp-load-file). The functions below are useful -;;; for defining these commands. -;;; -;;; Alas, these guys don't do exactly the right thing for Lisp, Scheme -;;; and Soar, in that they don't know anything about file extensions. -;;; So the compile/load interface gets the wrong default occasionally. -;;; The load-file/compile-file default mechanism could be smarter -- it -;;; doesn't know about the relationship between filename extensions and -;;; whether the file is source or executable. If you compile foo.lisp -;;; with compile-file, then the next load-file should use foo.bin for -;;; the default, not foo.lisp. This is tricky to do right, particularly -;;; because the extension for executable files varies so much (.o, .bin, -;;; .lbin, .mo, .vo, .ao, ...). - - -;;; COMINT-SOURCE-DEFAULT -- determines defaults for source-file processing -;;; commands. -;;; -;;; COMINT-CHECK-SOURCE -- if FNAME is in a modified buffer, asks you if you -;;; want to save the buffer before issuing any process requests to the command -;;; interpreter. -;;; -;;; COMINT-GET-SOURCE -- used by the source-file processing commands to prompt -;;; for the file to process. - -;;; (COMINT-SOURCE-DEFAULT previous-dir/file source-modes) -;;;============================================================================ -;;; This function computes the defaults for the load-file and compile-file -;;; commands for tea, soar, cmulisp, and cmuscheme modes. -;;; -;;; - PREVIOUS-DIR/FILE is a pair (directory . filename) from the last -;;; source-file processing command. NIL if there hasn't been one yet. -;;; - SOURCE-MODES is a list used to determine what buffers contain source -;;; files: if the major mode of the buffer is in SOURCE-MODES, it's source. -;;; Typically, (lisp-mode) or (scheme-mode). -;;; -;;; If the command is given while the cursor is inside a string, *and* -;;; the string is an existing filename, *and* the filename is not a directory, -;;; then the string is taken as default. This allows you to just position -;;; your cursor over a string that's a filename and have it taken as default. -;;; -;;; If the command is given in a file buffer whose major mode is in -;;; SOURCE-MODES, then the the filename is the default file, and the -;;; file's directory is the default directory. -;;; -;;; If the buffer isn't a source file buffer (e.g., it's the process buffer), -;;; then the default directory & file are what was used in the last source-file -;;; processing command (i.e., PREVIOUS-DIR/FILE). If this is the first time -;;; the command has been run (PREVIOUS-DIR/FILE is nil), the default directory -;;; is the cwd, with no default file. (\"no default file\" = nil) -;;; -;;; SOURCE-REGEXP is typically going to be something like (tea-mode) -;;; for T programs, (lisp-mode) for Lisp programs, (soar-mode lisp-mode) -;;; for Soar programs, etc. -;;; -;;; The function returns a pair: (default-directory . default-file). - -(defun comint-source-default (previous-dir/file source-modes) - (cond ((and buffer-file-name (memq major-mode source-modes)) - (cons (file-name-directory buffer-file-name) - (file-name-nondirectory buffer-file-name))) - (previous-dir/file) - (t - (cons default-directory nil)))) - - -;;; (COMINT-CHECK-SOURCE fname) -;;;============================================================================ -;;; Prior to loading or compiling (or otherwise processing) a file (in the CMU -;;; process-in-a-buffer modes), this function can be called on the filename. -;;; If the file is loaded into a buffer, and the buffer is modified, the user -;;; is queried to see if he wants to save the buffer before proceeding with -;;; the load or compile. - -(defun comint-check-source (fname) - (let ((buff (get-file-buffer fname))) - (if (and buff - (buffer-modified-p buff) - (y-or-n-p (format "Save buffer %s first? " - (buffer-name buff)))) - ;; save BUFF. - (let ((old-buffer (current-buffer))) - (set-buffer buff) - (save-buffer) - (set-buffer old-buffer))))) - - -;;; (COMINT-GET-SOURCE prompt prev-dir/file source-modes mustmatch-p) -;;;============================================================================ -;;; COMINT-GET-SOURCE is used to prompt for filenames in command-interpreter -;;; commands that process source files (like loading or compiling a file). -;;; It prompts for the filename, provides a default, if there is one, -;;; and returns the result filename. -;;; -;;; See COMINT-SOURCE-DEFAULT for more on determining defaults. -;;; -;;; PROMPT is the prompt string. PREV-DIR/FILE is the (directory . file) pair -;;; from the last source processing command. SOURCE-MODES is a list of major -;;; modes used to determine what file buffers contain source files. (These -;;; two arguments are used for determining defaults). If MUSTMATCH-P is true, -;;; then the filename reader will only accept a file that exists. -;;; -;;; A typical use: -;;; (interactive (comint-get-source "Compile file: " prev-lisp-dir/file -;;; '(lisp-mode) t)) - -;;; This is pretty stupid about strings. It decides we're in a string -;;; if there's a quote on both sides of point on the current line. -(defun comint-extract-string () - "Returns string around point that starts the current line or nil." - (save-excursion - (let* ((point (point)) - (bol (progn (beginning-of-line) (point))) - (eol (progn (end-of-line) (point))) - (start (progn (goto-char point) - (and (search-backward "\"" bol t) - (1+ (point))))) - (end (progn (goto-char point) - (and (search-forward "\"" eol t) - (1- (point)))))) - (and start end - (buffer-substring start end))))) - -(defun comint-get-source (prompt prev-dir/file source-modes mustmatch-p) - (let* ((def (comint-source-default prev-dir/file source-modes)) - (stringfile (comint-extract-string)) - (sfile-p (and stringfile - (file-exists-p stringfile) - (not (file-directory-p stringfile)))) - (defdir (if sfile-p (file-name-directory stringfile) - (car def))) - (deffile (if sfile-p (file-name-nondirectory stringfile) - (cdr def))) - (ans (read-file-name (if deffile (format "%s(default %s) " - prompt deffile) - prompt) - defdir - (concat defdir deffile) - mustmatch-p))) - (list (expand-file-name (substitute-in-file-name ans))))) - -;;; I am somewhat divided on this string-default feature. It seems -;;; to violate the principle-of-least-astonishment, in that it makes -;;; the default harder to predict, so you actually have to look and see -;;; what the default really is before choosing it. This can trip you up. -;;; On the other hand, it can be useful, I guess. I would appreciate feedback -;;; on this. -;;; -Olin - - - - - - - - - - - - - - - - - - - - - - - -;;; Simple process query facility. -;;; =========================================================================== -;;; This function is for commands that want to send a query to the process -;;; and show the response to the user. For example, a command to get the -;;; arglist for a Common Lisp function might send a "(arglist 'foo)" query -;;; to an inferior Common Lisp process. -;;; -;;; This simple facility just sends strings to the inferior process and pops -;;; up a window for the process buffer so you can see what the process -;;; responds with. We don't do anything fancy like try to intercept what the -;;; process responds with and put it in a pop-up window or on the message -;;; line. We just display the buffer. Low tech. Simple. Works good. - -;;; Send to the inferior process PROC the string STR. Pop-up but do not select -;;; a window for the inferior process so that its response can be seen. -(defun comint-proc-query (proc str) - (let* ((proc-buf (process-buffer proc)) - (proc-mark (process-mark proc))) - (display-buffer proc-buf) - (set-buffer proc-buf) ; but it's not the selected *window* - (let ((proc-win (get-buffer-window proc-buf)) - (proc-pt (marker-position proc-mark))) - (comint-send-string proc str) ; send the query - (accept-process-output proc) ; wait for some output - ;; Try to position the proc window so you can see the answer. - ;; This is bogus code. If you delete the (sit-for 0), it breaks. - ;; I don't know why. Wizards invited to improve it. - (if (not (pos-visible-in-window-p proc-pt proc-win)) - (let ((opoint (window-point proc-win))) - (set-window-point proc-win proc-mark) (sit-for 0) - (if (not (pos-visible-in-window-p opoint proc-win)) - (push-mark opoint) - (set-window-point proc-win opoint))))))) - - - - - - - - - - - -;;; Filename completion in a buffer -;;; =========================================================================== -;;; Useful completion functions, courtesy of the Ergo group. -;;; M- will complete the filename at the cursor as much as possible -;;; M-? will display a list of completions in the help buffer. - -;;; Three commands: -;;; comint-dynamic-complete Complete filename at point. -;;; comint-dynamic-list-completions List completions in help buffer. -;;; comint-replace-by-expanded-filename Expand and complete filename at point; -;;; replace with expanded/completed name. - -;;; These are not installed in the comint-mode keymap. But they are -;;; available for people who want them. Shell-mode installs them: -;;; (define-key cmushell-mode-map "\M-\t" 'comint-dynamic-complete) -;;; (define-key cmushell-mode-map "\M-?" 'comint-dynamic-list-completions))) -;;; -;;; Commands like this are fine things to put in load hooks if you -;;; want them present in specific modes. Example: -;;; (setq cmushell-load-hook -;;; '((lambda () (define-key lisp-mode-map "\M-\t" -;;; 'comint-replace-by-expanded-filename)))) -;;; - - -(defun comint-match-partial-pathname () - "Returns the string of an existing filename or causes an error." - (if (save-excursion (backward-char 1) (looking-at "\\s ")) "" - (save-excursion - (re-search-backward "[^~/A-Za-z0-9---_.$#,]+") - (re-search-forward "[~/A-Za-z0-9---_.$#,]+") - (substitute-in-file-name - (buffer-substring (match-beginning 0) (match-end 0)))))) - - -(defun comint-replace-by-expanded-filename () -"Replace the filename at point with an expanded, canonicalised, and -completed replacement. -\"Expanded\" means environment variables (e.g., $HOME) and ~'s are -replaced with the corresponding directories. \"Canonicalised\" means .. -and \. are removed, and the filename is made absolute instead of relative. -See functions expand-file-name and substitute-in-file-name. See also -comint-dynamic-complete." - (interactive) - (let* ((pathname (comint-match-partial-pathname)) - (pathdir (file-name-directory pathname)) - (pathnondir (file-name-nondirectory pathname)) - (completion (file-name-completion pathnondir - (or pathdir default-directory)))) - (cond ((null completion) - (message "No completions of %s." pathname) - (ding)) - ((eql completion t) - (message "Unique completion.")) - (t ; this means a string was returned. - (delete-region (match-beginning 0) (match-end 0)) - (insert (expand-file-name (concat pathdir completion))))))) - - -(defun comint-dynamic-complete () - "Dynamically complete the filename at point. -This function is similar to comint-replace-by-expanded-filename, except -that it won't change parts of the filename already entered in the buffer; -it just adds completion characters to the end of the filename." - (interactive) - (let* ((pathname (comint-match-partial-pathname)) - (pathdir (file-name-directory pathname)) - (pathnondir (file-name-nondirectory pathname)) - (completion (file-name-completion pathnondir - (or pathdir default-directory)))) - (cond ((null completion) - (message "No completions of %s." pathname) - (ding)) - ((eql completion t) - (message "Unique completion.")) - (t ; this means a string was returned. - (goto-char (match-end 0)) - (insert (substring completion (length pathnondir))))))) - -(defun comint-dynamic-list-completions () - "List in help buffer all possible completions of the filename at point." - (interactive) - (let* ((pathname (comint-match-partial-pathname)) - (pathdir (file-name-directory pathname)) - (pathnondir (file-name-nondirectory pathname)) - (completions - (file-name-all-completions pathnondir - (or pathdir default-directory)))) - (cond ((null completions) - (message "No completions of %s." pathname) - (ding)) - (t - (let ((conf (current-window-configuration))) - (with-output-to-temp-buffer "*Help*" - (display-completion-list completions)) - (sit-for 0) - (message "Hit space to flush.") - (let ((ch (read-char))) - (if (= ch ?\ ) - (set-window-configuration conf) - (setq unread-command-char ch)))))))) - -; Ergo bindings -; (global-set-key "\M-\t" 'comint-replace-by-expanded-filename) -; (global-set-key "\M-?" 'comint-dynamic-list-completions) -; (define-key shell-mode-map "\M-\t" 'comint-dynamic-complete) - - - - - - - - - - - - - - - - - - - - - - - - - - -;;; Converting process modes to use comint mode -;;; =========================================================================== -;;; Several gnu packages (tex-mode, background, dbx, gdb, kermit, prolog, -;;; telnet are some) use the shell package as clients. Most of them would -;;; be better off using the comint package, but they predate it. -;;; -;;; Altering these packages to use comint mode should greatly -;;; improve their functionality, and is fairly easy. -;;; -;;; Renaming variables -;;; Most of the work is renaming variables and functions. These are the common -;;; ones: -;;; Local variables: -;;; last-input-end comint-last-input-end -;;; last-input-start -;;; shell-prompt-pattern comint-prompt-regexp -;;; shell-set-directory-error-hook -;;; Miscellaneous: -;;; shell-set-directory -;;; shell-mode-map comint-mode-map -;;; Commands: -;;; shell-send-input comint-send-input -;;; shell-send-eof comint-delchar-or-maybe-eof -;;; kill-shell-input comint-kill-input -;;; interrupt-shell-subjob comint-interrupt-subjob -;;; stop-shell-subjob comint-stop-subjob -;;; quit-shell-subjob comint-quit-subjob -;;; kill-shell-subjob comint-kill-subjob -;;; kill-output-from-shell comint-kill-output -;;; show-output-from-shell comint-show-output -;;; copy-last-shell-input Use comint-previous-input/comint-next-input -;;; -;;; LAST-INPUT-START is no longer necessary because inputs are stored on the -;;; input history ring. SHELL-SET-DIRECTORY is gone, its functionality taken -;;; over by SHELL-DIRECTORY-TRACKER, the shell mode's comint-input-sentinel. -;;; Comint mode does not provide functionality equivalent to -;;; shell-set-directory-error-hook; it is gone. -;;; -;;; If you are implementing some process-in-a-buffer mode, called foo-mode, do -;;; *not* create the comint-mode local variables in your foo-mode function. -;;; This is not modular. Instead, call comint-mode, and let *it* create the -;;; necessary comint-specific local variables. Then create the -;;; foo-mode-specific local variables in foo-mode. Set the buffer's keymap to -;;; be foo-mode-map, and its mode to be foo-mode. Set the comint-mode hooks -;;; (comint-prompt-regexp, comint-input-filter, comint-input-sentinel, -;;; comint-get-old-input) that need to be different from the defaults. Call -;;; foo-mode-hook, and you're done. Don't run the comint-mode hook yourself; -;;; comint-mode will take care of it. The following example, from cmushell.el, -;;; is typical: -;;; -;;; (defun shell-mode () -;;; (interactive) -;;; (comint-mode) -;;; (setq comint-prompt-regexp shell-prompt-pattern) -;;; (setq major-mode 'shell-mode) -;;; (setq mode-name "Shell") -;;; (cond ((not shell-mode-map) -;;; (setq shell-mode-map (full-copy-sparse-keymap comint-mode-map)) -;;; (define-key shell-mode-map "\M-\t" 'comint-dynamic-complete) -;;; (define-key shell-mode-map "\M-?" -;;; 'comint-dynamic-list-completions))) -;;; (use-local-map shell-mode-map) -;;; (make-local-variable 'shell-directory-stack) -;;; (setq shell-directory-stack nil) -;;; (setq comint-input-sentinel 'shell-directory-tracker) -;;; (run-hooks 'shell-mode-hook)) -;;; -;;; -;;; Note that make-comint is different from make-shell in that it -;;; doesn't have a default program argument. If you give make-shell -;;; a program name of NIL, it cleverly chooses one of explicit-shell-name, -;;; $ESHELL, $SHELL, or /bin/sh. If you give make-comint a program argument -;;; of NIL, it barfs. Adjust your code accordingly... -;;; - - - - - - - - - - - - - - -;;; Do the user's customisation... - -(defvar comint-load-hook nil - "This hook is run when comint is loaded in. -This is a good place to put keybindings.") - -(run-hooks 'comint-load-hook) - -;;; Change log: -;;; 9/12/89 -;;; - Souped up the filename expansion procedures. -;;; Doc strings are much clearer and more detailed. -;;; Fixed a bug where doing a filename completion when the point -;;; was in the middle of the filename instead of at the end would lose. -;;; -;;; 2/17/90 -;;; - Souped up the command history stuff so that text inserted -;;; by comint-previous-input-matching is removed by following -;;; command history recalls. comint-next/previous-input-matching -;;; is now much more smoothly integrated w/the command history stuff. -;;; - Added comint-eol-on-send flag and comint-input-sender hook. -;;; Comint-input-sender based on code contributed by Jeff Peck -;;; (peck@sun.com). -;;; -;;; 3/13/90 ccm@cmu.cs.edu -;;; - Added comint-previous-similar-input for looking up similar inputs. -;;; - Added comint-send-and-get-output to allow snarfing input from -;;; buffer. -;;; - Added the ability to pick up a source file by positioning over -;;; a string in comint-get-source. -;;; - Added add-hook to make it a little easier for the user to use -;;; multiple hooks. -;;; -;;; 5/22/90 shivers -;;; - Moved Chris' multiplexed ipc stuff to comint-ipc.el. -;;; - Altered Chris' comint-get-source string feature. The string -;;; is only offered as a default if it names an existing file. -;;; - Changed comint-exec to directly crank up the process, instead -;;; of calling the env program. This made background.el happy. -;;; - Added new buffer-local var comint-ptyp. The problem is that -;;; the signalling functions don't work as advertised. If you are -;;; communicating via pipes, the CURRENT-GROUP arg is supposed to -;;; be ignored, but, unfortunately it seems to be the case that you -;;; must pass a NIL for this arg in the pipe case. COMINT-PTYP -;;; is a flag that tells whether the process is communicating -;;; via pipes or a pty. The comint signalling functions use it -;;; to determine the necessary CURRENT-GROUP arg value. The bug -;;; has been reported to the Gnu folks. -;;; - comint-dynamic-complete flushes the help window if you hit space -;;; after you execute it. -;;; - Added functions comint-send-string, comint-send-region and var -;;; comint-input-chunk-size. comint-send-string tries to prevent processes -;;; from hanging when you send them long strings by breaking them into -;;; chunks and allowing process output between chunks. I got the idea from -;;; Eero Simoncelli's Common Lisp package. Note that using -;;; comint-send-string means that the process buffer's contents can change -;;; during a call! If you depend on process output only happening between -;;; toplevel commands, this could be a problem. In such a case, use -;;; process-send-string instead. If this is a problem for people, I'd like -;;; to hear about it. -;;; - Added comint-proc-query as a simple mechanism for commands that -;;; want to query an inferior process and display its response. For a -;;; typical use, see lisp-show-arglist in cmulisp.el. -;;; - Added constant comint-version, which is now "2.01". -;;; -;;; 6/14/90 shivers -;;; - Had comint-update-env defined twice. Removed extra copy. Also -;;; renamed mem to be comint-mem, for modularity. The duplication -;;; was reported by Michael Meissner. -;;; 6/16/90 shivers -;;; - Emacs has two different mechanisms for maintaining the process -;;; environment, determined at compile time by the MAINTAIN-ENVIRONMENT -;;; #define. One uses the process-environment global variable, and -;;; one uses a getenv/setenv interface. comint-exec assumed the -;;; process-environment interface; it has been generalised (with -;;; comint-exec-1) to handle both cases. Pretty bogus. We could, -;;; of course, skip all this and just use the etc/env program to -;;; handle the environment tweaking, but that obscures process -;;; queries that other modules (like background.el) depend on. etc/env -;;; is also fairly bogus. This bug, and some of the fix code was -;;; reported by Dan Pierson. -;;; -;;; 9/5/90 shivers -;;; - Changed make-variable-buffer-local's to make-local-variable's. -;;; This leaves non-comint-mode buffers alone. Stephane Payrard -;;; reported the sloppy useage. -;;; - You can now go from comint-previous-similar-input to -;;; comint-previous-input with no problem. - - diff --git a/ghc/CONTRIB/haskell-modes/yale/original/haskell-menu.el b/ghc/CONTRIB/haskell-modes/yale/original/haskell-menu.el deleted file mode 100644 index 9f851c683c..0000000000 --- a/ghc/CONTRIB/haskell-modes/yale/original/haskell-menu.el +++ /dev/null @@ -1,43 +0,0 @@ -;;; haskell-menu.el -- support for Haskell menubar functions -;;; -;;; author : Sandra Loosemore -;;; date : 15 Jun 1994 -;;; - - -;;; Add an entry to the main menu bar - -(defvar menu-bar-haskell-menu (make-sparse-keymap "Haskell")) -(define-key haskell-mode-map [menu-bar haskell] - (cons "Haskell" menu-bar-haskell-menu)) -(define-key inferior-haskell-mode-map [menu-bar haskell] - (cons "Haskell" menu-bar-haskell-menu)) -(define-key ht-mode-map [menu-bar haskell] - (cons "Haskell" menu-bar-haskell-menu)) - - -;;; Define the functions. They get listed on the menu in the reverse -;;; order that they're defined. - -(define-key menu-bar-haskell-menu [haskell-tutorial] - '("Tutorial" . haskell-tutorial)) -(define-key menu-bar-haskell-menu [haskell-optimizers] - '("Optimizers..." . haskell-optimizers)) -(define-key menu-bar-haskell-menu [haskell-printers] - '("Printers..." . haskell-printers)) -(define-key menu-bar-haskell-menu [haskell-get-pad] - '("Scratch Pad" . haskell-get-pad)) -(define-key menu-bar-haskell-menu [haskell-compile] - '("Compile File..." . haskell-compile)) -(define-key menu-bar-haskell-menu [haskell-run-file] - '("Run File..." . haskell-run-file)) -(define-key menu-bar-haskell-menu [haskell-load] - '("Load File..." . haskell-load)) -(define-key menu-bar-haskell-menu [haskell-report-type] - '("Type Check Expression..." . haskell-report-type)) -(define-key menu-bar-haskell-menu [haskell-run] - '("Run Dialogue..." . haskell-run)) -(define-key menu-bar-haskell-menu [haskell-eval] - '("Eval Expression..." . haskell-eval)) - -(provide 'haskell-menu) diff --git a/ghc/CONTRIB/haskell-modes/yale/original/haskell.el b/ghc/CONTRIB/haskell-modes/yale/original/haskell.el deleted file mode 100644 index 9b4c95b3ca..0000000000 --- a/ghc/CONTRIB/haskell-modes/yale/original/haskell.el +++ /dev/null @@ -1,1710 +0,0 @@ -;;; ================================================================== -;;; File: haskell.el ;;; -;;; ;;; -;;; Author: A. Satish Pai ;;; -;;; Maria M. Gutierrez ;;; -;;; Dan Rabin (Jul-1991) ;;; -;;; ================================================================== - -;;; Description: Haskell mode for GNU Emacs. - -;;; Related files: comint.el - -;;; Contents: - -;;; Update Log - -;;; Known bugs / problems -;;; - the haskell editing mode (indentation, etc) is still missing. -;;; - the handling for errors from haskell needs to be rethought. -;;; - general cleanup of code. - - -;;; Errors generated - -;;; ================================================================== -;;; Haskell mode for editing files, and an Inferior Haskell mode to -;;; run a Haskell process. This file contains stuff snarfed and -;;; modified from tea.el, scheme.el, etc. This file may be freely -;;; modified; however, if you have any bug-corrections or useful -;;; improvements, I'd appreciate it if you sent me the mods so that -;;; I can merge them into the version I maintain. -;;; -;;; The inferior Haskell mode requires comint.el. -;;; -;;; You might want to add this to your .emacs to go automagically -;;; into Haskell mode while finding .hs files. -;;; -;;; (setq auto-mode-alist -;;; (cons '("\\.hs$" . haskell-mode) -;;; auto-mode-alist)_) -;;; -;;; To use this file, set up your .emacs to autoload this file for -;;; haskell-mode. For example: -;;; -;;; (autoload 'haskell-mode "$HASKELL/emacs-tools/haskell.elc" -;;; "Load Haskell mode" t) -;;; -;;; (autoload 'run-mode "$HASKELL/emacs-tools/haskell.elc" -;;; "Load Haskell mode" t) -;;; -;;; [Note: The path name given above is Yale specific!! Modify as -;;; required.] -;;; ================================================================ - -;;; Announce your existence to the world at large. - -(provide 'haskell) - - -;;; Load these other files. - -(require 'comint) ; Olin Shivers' comint mode is the substratum - - - - -;;; ================================================================ -;;; Declare a bunch of variables. -;;; ================================================================ - - -;;; User settable (via M-x set-variable and M-x edit-options) - -(defvar haskell-program-name (getenv "HASKELLPROG") - "*Program invoked by the haskell command.") - -(defvar haskell-auto-create-process t - "*If not nil, create a Haskell process automatically when required to evaluate or compile Haskell code.") - -(defvar haskell-auto-switch-input t - "*If not nil, jump to *haskell* buffer automatically on input request.") - -(defvar haskell-ask-before-saving t - "*If not nil, ask before saving random haskell-mode buffers.") - -(defvar haskell-initial-printers '("interactive") - "*Printers to set when starting a new Haskell process.") - - -;;; Pad/buffer Initialization variables - -(defvar *haskell-buffer* "*haskell*" - "Name of the haskell process buffer") - -(defvar haskell-main-pad "\*Main-pad\*" - "Scratch pad associated with module Main") - -(defvar haskell-main-module "Main") - - -(defvar *last-loaded* nil) -(defvar *last-module* haskell-main-module) -(defvar *last-pad* haskell-main-pad) - - -;;; These are used for haskell-tutorial mode. - -(defvar *ht-source-file* "$HASKELL/progs/tutorial/tutorial.lhs") -(defvar *ht-temp-buffer* nil) -(defvar *ht-file-buffer* "Haskell-Tutorial-Master") - - - -;;; ================================================================ -;;; Haskell editing mode stuff -;;; ================================================================ - -;;; Leave this place alone... -;;; The definitions below have been pared down to the bare -;;; minimum; they will be restored later. -;;; -;;; -Satish 2/5. - -;;; Keymap for Haskell mode -(defvar haskell-mode-map (make-sparse-keymap) - "Keymap used for haskell-mode") - -(defun haskell-establish-key-bindings (keymap) - (define-key keymap "\C-ce" 'haskell-eval) - (define-key keymap "\C-cr" 'haskell-run) - (define-key keymap "\C-ct" 'haskell-report-type) - (define-key keymap "\C-cm" 'haskell-run-main) - (define-key keymap "\C-c\C-r" 'haskell-run-file) - (define-key keymap "\C-cp" 'haskell-get-pad) - (define-key keymap "\C-c\C-o" 'haskell-optimizers) - (define-key keymap "\C-c\C-p" 'haskell-printers) - (define-key keymap "\C-cc" 'haskell-compile) - (define-key keymap "\C-cl" 'haskell-load) - (define-key keymap "\C-ch" 'haskell-switch) - (define-key keymap "\C-c\C-k" 'haskell-kill) - (define-key keymap "\C-c:" 'haskell-command) - (define-key keymap "\C-cq" 'haskell-exit) - (define-key keymap "\C-ci" 'haskell-interrupt) - (define-key keymap "\C-cu" 'haskell-edit-unit)) - - -(haskell-establish-key-bindings haskell-mode-map) - - -(defvar haskell-mode-syntax-table nil - "Syntax table used for haskell-mode") - -(if haskell-mode-syntax-table - nil - (setq haskell-mode-syntax-table (standard-syntax-table))) - -;;; Command for invoking the Haskell mode -(defun haskell-mode nil - "Major mode for editing Haskell code to run in Emacs -The following commands are available: -\\{haskell-mode-map} - -A Haskell process can be fired up with \"M-x haskell\". - -Customization: Entry to this mode runs the hooks that are the value of variable -haskell-mode-hook. - -Windows: - -There are 3 types of windows associated with Haskell mode. They are: - *haskell*: which is the process window. - Pad: which are buffers available for each module. It is here - where you want to test things before preserving them in a - file. Pads are always associated with a module. - When issuing a command: - The pad and its associated module are sent to the Haskell - process prior to the execution of the command. - .hs: These are the files where Haskell programs live. They - have .hs as extension. - When issuing a command: - The file is sent to the Haskell process prior to the - execution of the command. - -Commands: - -Each command behaves differently according to the type of the window in which -the cursor is positioned when the command is issued . - -haskell-eval: \\[haskell-eval] - Always promts user for a Haskell expression to be evaluated. If in a - .hs file buffer, then the cursor tells which module is the current - module and the pad for that module (if any) gets loaded as well. - -haskell-run: \\[haskell-run] - Always queries for a variable of type Dialogue to be evaluated. - -haskell-run-main: \\[haskell-run-main] - Run Dialogue named main in the current module. - -haskell-report-type: \\[haskell-report-type] - Like haskell-eval, but prints the type of the expression without - evaluating it. - -haskell-mode: \\[haskell-mode] - Puts the current buffer in haskell mode. - -haskell-compile: \\[haskell-compile] - Compiles file in current buffer. - -haskell-load: \\[haskell-load] - Loads file in current buffer. - -haskell-run-file: \\[haskell-run-file] - Runs file in the current buffer. - -haskell-pad: \\[haskell-pad] - Creates a scratch pad for the current module. - -haskell-optimizers: \\[haskell-optimizers] - Shows the list of available optimizers. Commands for turning them on/off. - -haskell-printers: \\[haskell-printers] - Shows the list of available printers. Commands for turning them on/off. - -haskell-command: \\[haskell-command] - Prompts for a command to be sent to the command interface. You don't - need to put the : before the command. - -haskell-quit: \\[haskell-quit] - Terminates the haskell process. - -haskell-switch: \\[haskell-switch] - Switches to the inferior Haskell buffer (*haskell*) and positions the - cursor at the end of the buffer. - -haskell-kill: \\[haskell-kill] - Kill the current contents of the *haskell* buffer. - -haskell-interrupt: \\[haskell-interrupt] - Interrupts haskell process and resets it. - -haskell-edit-unit: \\[haskell-edit-unit] - Edit the .hu file for the unit containing this file. -" - (interactive) - (kill-all-local-variables) - (use-local-map haskell-mode-map) - (setq major-mode 'haskell-mode) - (setq mode-name "Haskell") - (make-local-variable 'indent-line-function) - (setq indent-line-function 'indent-relative-maybe) - ;(setq local-abbrev-table haskell-mode-abbrev-table) - (set-syntax-table haskell-mode-syntax-table) - ;(setq tab-stop-list haskell-tab-stop-list) ;; save old list?? - (run-hooks 'haskell-mode-hook)) - - - -;;;================================================================ -;;; Inferior Haskell stuff -;;;================================================================ - - -(defvar inferior-haskell-mode-map (full-copy-sparse-keymap comint-mode-map)) - -(haskell-establish-key-bindings inferior-haskell-mode-map) -(define-key inferior-haskell-mode-map "\C-m" 'haskell-send-input) - -(defvar haskell-source-modes '(haskell-mode) - "*Used to determine if a buffer contains Haskell source code. -If it's loaded into a buffer that is in one of these major modes, -it's considered a Haskell source file.") - -(defvar haskell-prompt-pattern "^[A-Z]\\([A-Z]\\|[a-z]\\|[0-9]\\)*>\\s-*" - "Regular expression capturing the Haskell system prompt.") - -(defvar haskell-prompt-ring () - "Keeps track of input to haskell process from the minibuffer") - -(defun inferior-haskell-mode-variables () - nil) - - -;;; INFERIOR-HASKELL-MODE (adapted from comint.el) - -(defun inferior-haskell-mode () - "Major mode for interacting with an inferior Haskell process. - -The following commands are available: -\\{inferior-haskell-mode-map} - -A Haskell process can be fired up with \"M-x haskell\". - -Customization: Entry to this mode runs the hooks on comint-mode-hook and -inferior-haskell-mode-hook (in that order). - -You can send text to the inferior Haskell process from other buffers containing -Haskell source. - - -Windows: - -There are 3 types of windows in the inferior-haskell-mode. They are: - *haskell*: which is the process window. - Pad: which are buffers available for each module. It is here - where you want to test things before preserving them in a - file. Pads are always associated with a module. - When issuing a command: - The pad and its associated module are sent to the Haskell - process prior to the execution of the command. - .hs: These are the files where Haskell programs live. They - have .hs as extension. - When issuing a command: - The file is sent to the Haskell process prior to the - execution of the command. - -Commands: - -Each command behaves differently according to the type of the window in which -the cursor is positioned when the command is issued. - -haskell-eval: \\[haskell-eval] - Always promts user for a Haskell expression to be evaluated. If in a - .hs file, then the cursor tells which module is the current module and - the pad for that module (if any) gets loaded as well. - -haskell-run: \\[haskell-run] - Always queries for a variable of type Dialogue to be evaluated. - -haskell-run-main: \\[haskell-run-main] - Run Dialogue named main. - -haskell-report-type: \\[haskell-report-type] - Like haskell-eval, but prints the type of the expression without - evaluating it. - -haskell-mode: \\[haskell-mode] - Puts the current buffer in haskell mode. - -haskell-compile: \\[haskell-compile] - Compiles file in current buffer. - -haskell-load: \\[haskell-load] - Loads file in current buffer. - -haskell-run-file: \\[haskell-run-file] - Runs file in the current buffer. - -haskell-pad: \\[haskell-pad] - Creates a scratch pad for the current module. - -haskell-optimizers: \\[haskell-optimizers] - Shows the list of available optimizers. Commands for turning them on/off. - -haskell-printers: \\[haskell-printers] - Shows the list of available printers. Commands for turning them on/off. - -haskell-command: \\[haskell-command] - Prompts for a command to be sent to the command interface. You don't - need to put the : before the command. - -haskell-quit: \\[haskell-quit] - Terminates the haskell process. - -haskell-switch: \\[haskell-switch] - Switches to the inferior Haskell buffer (*haskell*) and positions the - cursor at the end of the buffer. - -haskell-kill: \\[haskell-kill] - Kill the current contents of the *haskell* buffer. - -haskell-interrupt: \\[haskell-interrupt] - Interrupts haskell process and resets it. - -haskell-edit-unit: \\[haskell-edit-unit] - Edit the .hu file for the unit containing this file. - -The usual comint functions are also available. In particular, the -following are all available: - -comint-bol: Beginning of line, but skip prompt. Bound to C-a by default. -comint-delchar-or-maybe-eof: Delete char, unless at end of buffer, in - which case send EOF to process. Bound to C-d by default. - -Note however, that the default keymap bindings provided shadow some of -the default comint mode bindings, so that you may want to bind them -to your choice of keys. - -Comint mode's dynamic completion of filenames in the buffer is available. -(Q.v. comint-dynamic-complete, comint-dynamic-list-completions.) - -If you accidentally suspend your process, use \\[comint-continue-subjob] -to continue it." - - (interactive) - (comint-mode) - (setq comint-prompt-regexp haskell-prompt-pattern) - ;; Customise in inferior-haskell-mode-hook - (inferior-haskell-mode-variables) - (setq major-mode 'inferior-haskell-mode) - (setq mode-name "Inferior Haskell") - (setq mode-line-process '(": %s : busy")) - (use-local-map inferior-haskell-mode-map) - (setq comint-input-filter 'haskell-input-filter) - (setq comint-input-sentinel 'ignore) - (setq comint-get-old-input 'haskell-get-old-input) - (run-hooks 'inferior-haskell-mode-hook) - ;Do this after the hook so the user can mung INPUT-RING-SIZE w/his hook. - ;The test is so we don't lose history if we run comint-mode twice in - ;a buffer. - (setq haskell-prompt-ring (make-ring input-ring-size))) - - -(defun haskell-input-filter (str) - "Don't save whitespace." - (not (string-match "\\s *" str))) - - - -;;; ================================================================== -;;; Random utilities -;;; ================================================================== - - -;;; This keeps track of the status of the haskell process. -;;; Values are: -;;; busy -- The process is busy. -;;; ready -- The process is ready for a command. -;;; input -- The process is waiting for input. -;;; debug -- The process is in the debugger. - -(defvar *haskell-status* 'busy - "Status of the haskell process") - -(defun set-haskell-status (value) - (setq *haskell-status* value) - (haskell-update-mode-line)) - -(defun get-haskell-status () - *haskell-status*) - -(defun haskell-update-mode-line () - (save-excursion - (set-buffer *haskell-buffer*) - (cond ((eq *haskell-status* 'ready) - (setq mode-line-process '(": %s: ready"))) - ((eq *haskell-status* 'input) - (setq mode-line-process '(": %s: input"))) - ((eq *haskell-status* 'busy) - (setq mode-line-process '(": %s: busy"))) - ((eq *haskell-status* 'debug) - (setq mode-line-process '(": %s: debug"))) - (t - (haskell-mode-error "Confused about status of haskell process!"))) - ;; Yes, this is the officially sanctioned technique for forcing - ;; a redisplay of the mode line. - (set-buffer-modified-p (buffer-modified-p)))) - - -(defun haskell-send-to-process (string) - (process-send-string "haskell" string) - (process-send-string "haskell" "\n")) - - - -;;; ================================================================== -;;; Handle input in haskell process buffer; history commands. -;;; ================================================================== - -(defun haskell-get-old-input () - "Get old input text from Haskell process buffer." - (save-excursion - (if (re-search-forward haskell-prompt-pattern (point-max) 'move) - (goto-char (match-beginning 0))) - (cond ((re-search-backward haskell-prompt-pattern (point-min) t) - (comint-skip-prompt) - (let ((temp (point))) - (end-of-line) - (buffer-substring temp (point))))))) - - -(defun haskell-send-input () - "Send input to Haskell while in the process buffer" - (interactive) - (if (eq (get-haskell-status) 'debug) - (comint-send-input) - (haskell-send-input-aux))) - -(defun haskell-send-input-aux () - ;; Note that the input string does not include its terminal newline. - (let ((proc (get-buffer-process (current-buffer)))) - (if (not proc) - (haskell-mode-error "Current buffer has no process!") - (let* ((pmark (process-mark proc)) - (pmark-val (marker-position pmark)) - (input (if (>= (point) pmark-val) - (buffer-substring pmark (point)) - (let ((copy (funcall comint-get-old-input))) - (goto-char pmark) - (insert copy) - copy)))) - (insert ?\n) - (if (funcall comint-input-filter input) - (ring-insert input-ring input)) - (funcall comint-input-sentinel input) - (set-marker (process-mark proc) (point)) - (set-marker comint-last-input-end (point)) - (haskell-send-to-process input))))) - - - -;;; ================================================================== -;;; Minibuffer input stuff -;;; ================================================================== - -;;; Haskell input history retrieval commands (taken from comint.el) -;;; M-p -- previous input M-n -- next input - -(defvar haskell-minibuffer-local-map nil - "Local map for minibuffer when in Haskell") - -(if haskell-minibuffer-local-map - nil - (progn - (setq haskell-minibuffer-local-map - (full-copy-sparse-keymap minibuffer-local-map)) - ;; Haskell commands - (define-key haskell-minibuffer-local-map "\ep" 'haskell-previous-input) - (define-key haskell-minibuffer-local-map "\en" 'haskell-next-input) - )) - -(defun haskell-previous-input (arg) - "Cycle backwards through input history." - (interactive "*p") - (let ((len (ring-length haskell-prompt-ring))) - (cond ((<= len 0) - (message "Empty input ring.") - (ding)) - (t - (cond ((eq last-command 'haskell-previous-input) - (delete-region (mark) (point)) - (set-mark (point))) - (t - (setq input-ring-index - (if (> arg 0) -1 - (if (< arg 0) 1 0))) - (push-mark (point)))) - (setq input-ring-index (comint-mod (+ input-ring-index arg) len)) - (insert (ring-ref haskell-prompt-ring input-ring-index)) - (setq this-command 'haskell-previous-input)) - ))) - -(defun haskell-next-input (arg) - "Cycle forwards through input history." - (interactive "*p") - (haskell-previous-input (- arg))) - -(defvar haskell-last-input-match "" - "Last string searched for by Haskell input history search, for defaulting. -Buffer local variable.") - -(defun haskell-previous-input-matching (str) - "Searches backwards through input history for substring match" - (interactive (let ((s (read-from-minibuffer - (format "Command substring (default %s): " - haskell-last-input-match)))) - (list (if (string= s "") haskell-last-input-match s)))) - (setq haskell-last-input-match str) ; update default - (let ((str (regexp-quote str)) - (len (ring-length haskell-prompt-ring)) - (n 0)) - (while (and (<= n len) - (not (string-match str (ring-ref haskell-prompt-ring n)))) - (setq n (+ n 1))) - (cond ((<= n len) (haskell-previous-input (+ n 1))) - (t (haskell-mode-error "Not found."))))) - - -;;; Actually read an expression from the minibuffer using the new keymap. - -(defun haskell-get-expression (prompt) - (let ((exp (read-from-minibuffer prompt nil haskell-minibuffer-local-map))) - (ring-insert haskell-prompt-ring exp) - exp)) - - - -;;; ================================================================== -;;; Handle output from Haskell process -;;; ================================================================== - -;;; The haskell process produces output with embedded control codes. -;;; These control codes are used to keep track of what kind of input -;;; the haskell process is expecting. Ordinary output is just displayed. -;;; -;;; This is kind of complicated because control sequences can be broken -;;; across multiple batches of text received from the haskell process. -;;; If the string ends in the middle of a control sequence, save it up -;;; for the next call. - -(defvar *haskell-saved-output* nil) - -;;; On the Next, there is some kind of race condition that causes stuff -;;; sent to the Haskell subprocess before it has really started to be lost. -;;; The point of this variable is to force the Emacs side to wait until -;;; Haskell has started and printed out its banner before sending it -;;; anything. See start-haskell below. - -(defvar *haskell-process-alive* nil) - -(defun haskell-output-filter (process str) - "Filter for output from Yale Haskell command interface" - ;; *** debug - ;;(let ((buffer (get-buffer-create "haskell-output"))) - ;; (save-excursion - ;; (set-buffer buffer) - ;; (insert str))) - (setq *haskell-process-alive* t) - (let ((next 0) - (start 0) - (data (match-data))) - (unwind-protect - (progn - ;; If there was saved output from last time, glue it in front of the - ;; newly received input. - (if *haskell-saved-output* - (progn - (setq str (concat *haskell-saved-output* str)) - (setq *haskell-saved-output* nil))) - ;; Loop, looking for complete command sequences. - ;; Set next to point to the first one. - ;; start points to first character to be processed. - (while (setq next - (string-match *haskell-message-match-regexp* - str start)) - ;; Display any intervening ordinary text. - (if (not (eq next start)) - (haskell-display-output (substring str start next))) - ;; Now dispatch on the particular command sequence found. - ;; Handler functions are called with the string and start index - ;; as arguments, and should return the index of the "next" - ;; character. - (let ((end (match-end 0))) - (haskell-handle-message str next) - (setq start end))) - ;; Look to see whether the string ends with an incomplete - ;; command sequence. - ;; If so, save the tail of the string for next time. - (if (and (setq next - (string-match *haskell-message-prefix-regexp* str start)) - (eq (match-end 0) (length str))) - (setq *haskell-saved-output* (substring str next)) - (setq next (length str))) - ;; Display any leftover ordinary text. - (if (not (eq next start)) - (haskell-display-output (substring str start next)))) - (store-match-data data)))) - -(defvar *haskell-message-match-regexp* - "EMACS:.*\n") - -(defvar *haskell-message-prefix-regexp* - "E\\(M\\(A\\(C\\(S\\(:.*\\)?\\)?\\)?\\)?\\)?") - -(defvar *haskell-message-dispatch* - '(("EMACS:debug\n" . haskell-got-debug) - ("EMACS:busy\n" . haskell-got-busy) - ("EMACS:input\n" . haskell-got-input) - ("EMACS:ready\n" . haskell-got-ready) - ("EMACS:printers .*\n" . haskell-got-printers) - ("EMACS:optimizers .*\n" . haskell-got-optimizers) - ("EMACS:message .*\n" . haskell-got-message) - ("EMACS:error\n" . haskell-got-error) - )) - -(defun haskell-handle-message (str idx) - (let ((list *haskell-message-dispatch*) - (fn nil)) - (while (and list (null fn)) - (if (eq (string-match (car (car list)) str idx) idx) - (setq fn (cdr (car list))) - (setq list (cdr list)))) - (if (null fn) - (haskell-mode-error "Garbled message from Haskell!") - (let ((end (match-end 0))) - (funcall fn str idx end) - end)))) - - -(defun haskell-message-data (string start end) - (let ((real-start (+ (string-match " " string start) 1)) - (real-end (- end 1))) - (substring string real-start real-end))) - -(defun haskell-got-debug (string start end) - (beep) - (message "In the debugger!") - (set-haskell-status 'debug)) - -(defun haskell-got-busy (string start end) - (set-haskell-status 'busy)) - -(defun haskell-got-input (string start end) - (if haskell-auto-switch-input - (progn - (haskell-switch) - (beep))) - (set-haskell-status 'input) - (message "Waiting for input...")) - -(defun haskell-got-ready (string start end) - (set-haskell-status 'ready)) - -(defun haskell-got-printers (string start end) - (haskell-printers-update (haskell-message-data string start end))) - -(defun haskell-got-optimizers (string start end) - (haskell-optimizers-update (haskell-message-data string start end))) - -(defun haskell-got-message (string start end) - (message "%s" (haskell-message-data string start end))) - -(defun haskell-got-error (string start end) - (beep) - (message "Haskell error.")) - - -;;; Displays output at end of given buffer. -;;; This function only ensures that the output is visible, without -;;; selecting the buffer in which it is displayed. -;;; Note that just using display-buffer instead of all this rigamarole -;;; won't work; you need to temporarily select the window containing -;;; the *haskell-buffer*, or else the display won't be scrolled to show -;;; the new output. -;;; *** This should really position the window in the buffer so that -;;; *** the point is on the last line of the window. - -(defun haskell-display-output (str) - (let ((window (selected-window))) - (unwind-protect - (progn - (pop-to-buffer *haskell-buffer*) - (haskell-display-output-aux str)) - (select-window window)))) - -(defun haskell-display-output-aux (str) - (haskell-move-marker) - (insert str) - (haskell-move-marker)) - - - -;;; ================================================================== -;;; Interactive commands -;;; ================================================================== - - -;;; HASKELL -;;; ------- -;;; -;;; This is the function that fires up the inferior haskell process. - -(defun haskell () - "Run an inferior Haskell process with input and output via buffer *haskell*. -Takes the program name from the variable haskell-program-name. -Runs the hooks from inferior-haskell-mode-hook -(after the comint-mode-hook is run). -\(Type \\[describe-mode] in the process buffer for a list of commands.)" - (interactive) - (if (not (haskell-process-exists-p)) - (start-haskell))) - -(defun start-haskell () - (message "Starting haskell subprocess...") - ;; Kill old haskell process. Normally this routine is only called - ;; after checking haskell-process-exists-p, but things can get - ;; screwed up if you rename the *haskell* buffer while leaving the - ;; old process running. This forces it to get rid of the old process - ;; and start a new one. - (if (get-process "haskell") - (delete-process "haskell")) - (let ((haskell-buffer - (apply 'make-comint - "haskell" - (or haskell-program-name - (haskell-mode-error "Haskell-program-name undefined!")) - nil - nil))) - (save-excursion - (set-buffer haskell-buffer) - (inferior-haskell-mode)) - (haskell-session-init) - ;; Wait for process to get started before sending it anything - ;; to avoid race condition on NeXT. - (setq *haskell-process-alive* nil) - (while (not *haskell-process-alive*) - (sleep-for 1)) - (haskell-send-to-process ":(use-emacs-interface)") - (haskell-printers-set haskell-initial-printers nil) - (display-buffer haskell-buffer)) - (message "Starting haskell subprocess... Done.")) - - -(defun haskell-process-exists-p () - (let ((haskell-buffer (get-buffer *haskell-buffer*))) - (and haskell-buffer (comint-check-proc haskell-buffer)))) - - - -;;; Initialize things on the emacs side, and tell haskell that it's -;;; talking to emacs. - -(defun haskell-session-init () - (set-haskell-status 'busy) - (setq *last-loaded* nil) - (setq *last-module* haskell-main-module) - (setq *last-pad* haskell-main-pad) - (setq *haskell-saved-output* nil) - (haskell-create-main-pad) - (set-process-filter (get-process "haskell") 'haskell-output-filter) - ) - - -(defun haskell-create-main-pad () - (let ((buffer (get-buffer-create haskell-main-pad))) - (save-excursion - (set-buffer buffer) - (haskell-mode)) - (haskell-record-pad-mapping - haskell-main-pad haskell-main-module nil) - buffer)) - - -;;; Called from evaluation and compilation commands to start up a Haskell -;;; process if none is already in progress. - -(defun haskell-maybe-create-process () - (cond ((haskell-process-exists-p) - t) - (haskell-auto-create-process - (start-haskell)) - (t - (haskell-mode-error "No Haskell process!")))) - - - -;;; HASKELL-GET-PAD -;;; ------------------------------------------------------------------ - -;;; This always puts the pad buffer in the "other" window. -;;; Having it wipe out the .hs file window is clearly the wrong -;;; behavior. - -(defun haskell-get-pad () - "Creates a new scratch pad for the current module. -Signals an error if the current buffer is not a .hs file." - (interactive) - (let ((fname (buffer-file-name))) - (if fname - (do-get-pad fname (current-buffer)) - (haskell-mode-error "Not in a .hs buffer!")))) - - -(defun do-get-pad (fname buff) - (let* ((mname (or (haskell-get-modname buff) - (read-no-blanks-input "Scratch pad for module? " nil))) - (pname (haskell-lookup-pad mname fname)) - (pbuff nil)) - ;; Generate the base name of the pad buffer, then create the - ;; buffer. The actual name of the pad buffer may be something - ;; else because of name collisions. - (if (not pname) - (progn - (setq pname (format "*%s-pad*" mname)) - (setq pbuff (generate-new-buffer pname)) - (setq pname (buffer-name pbuff)) - (haskell-record-pad-mapping pname mname fname) - ) - (setq pbuff (get-buffer pname))) - ;; Make sure the pad buffer is in haskell mode. - (pop-to-buffer pbuff) - (haskell-mode))) - - - -;;; HASKELL-SWITCH -;;; ------------------------------------------------------------------ - -(defun haskell-switch () - "Switches to \*haskell\* buffer." - (interactive) - (haskell-maybe-create-process) - (pop-to-buffer *haskell-buffer*) - (push-mark) - (goto-char (point-max))) - - - -;;; HASKELL-KILL -;;; ------------------------------------------------------------------ - -(defun haskell-kill () - "Kill contents of *haskell* buffer. \\[haskell-kill]" - (interactive) - (save-excursion - (set-buffer *haskell-buffer*) - (beginning-of-buffer) - (let ((mark (point))) - (end-of-buffer) - (kill-region mark (point))))) - - - -;;; HASKELL-COMMAND -;;; ------------------------------------------------------------------ - -(defun haskell-command (str) - "Format STRING as a haskell command and send it to haskell process. \\[haskell-command]" - (interactive "sHaskell command: ") - (haskell-send-to-process (format ":%s" str))) - - -;;; HASKELL-EVAL and HASKELL-RUN -;;; ------------------------------------------------------------------ - -(defun haskell-eval () - "Evaluate expression in current module. \\[haskell-eval]" - (interactive) - (haskell-maybe-create-process) - (haskell-eval-aux (haskell-get-expression "Haskell expression: ") - "emacs-eval")) - -(defun haskell-run () - "Run Haskell Dialogue in current module" - (interactive) - (haskell-maybe-create-process) - (haskell-eval-aux (haskell-get-expression "Haskell dialogue: ") - "emacs-run")) - -(defun haskell-run-main () - "Run Dialogue named main in current module" - (interactive) - (haskell-maybe-create-process) - (haskell-eval-aux "main" "emacs-run")) - -(defun haskell-report-type () - "Print the type of the expression." - (interactive) - (haskell-maybe-create-process) - (haskell-eval-aux (haskell-get-expression "Haskell expression: ") - "emacs-report-type")) - -(defun haskell-eval-aux (exp fn) - (cond ((equal *haskell-buffer* (buffer-name)) - ;; In the *haskell* buffer. - (let* ((pname *last-pad*) - (mname *last-module*) - (fname *last-loaded*)) - (haskell-eval-aux-aux exp pname mname fname fn))) - ((buffer-file-name) - ;; In a .hs file. - (let* ((fname (buffer-file-name)) - (mname (haskell-get-modname (current-buffer))) - (pname (haskell-lookup-pad mname fname))) - (haskell-eval-aux-aux exp pname mname fname fn))) - (t - ;; In a pad. - (let* ((pname (buffer-name (current-buffer))) - (mname (haskell-get-module-from-pad pname)) - (fname (haskell-get-file-from-pad pname))) - (haskell-eval-aux-aux exp pname mname fname fn))) - )) - -(defun haskell-eval-aux-aux (exp pname mname fname fn) - (haskell-save-modified-source-files fname) - (haskell-send-to-process (format ":(%s" fn)) - (haskell-send-to-process - (prin1-to-string exp)) - (haskell-send-to-process - (prin1-to-string (or pname fname "interactive"))) - (haskell-send-to-process - (prin1-to-string - (if (and pname (get-buffer pname)) - (save-excursion - (set-buffer pname) - (buffer-string)) - ""))) - (haskell-send-to-process - (format "'|%s|" mname)) - (haskell-send-to-process - (if fname - (prin1-to-string (haskell-maybe-get-unit-file-name fname)) - "'#f")) - (haskell-send-to-process ")") - (setq *last-pad* pname) - (setq *last-module* mname) - (setq *last-loaded* fname)) - - - -;;; HASKELL-RUN-FILE, HASKELL-LOAD, HASKELL-COMPILE -;;; ------------------------------------------------------------------ - -(defun haskell-run-file () - "Runs Dialogue named main in current file." - (interactive) - (haskell-maybe-create-process) - (let ((fname (haskell-get-file-to-operate-on))) - (haskell-save-modified-source-files fname) - (haskell-send-to-process ":(emacs-run-file") - (haskell-send-to-process (prin1-to-string fname)) - (haskell-send-to-process ")"))) - -(defun haskell-load () - "Load current file." - (interactive) - (haskell-maybe-create-process) - (let ((fname (haskell-get-file-to-operate-on))) - (haskell-save-modified-source-files fname) - (haskell-send-to-process ":(emacs-load-file") - (haskell-send-to-process (prin1-to-string fname)) - (haskell-send-to-process ")"))) - -(defun haskell-compile () - "Compile current file." - (interactive) - (haskell-maybe-create-process) - (let ((fname (haskell-get-file-to-operate-on))) - (haskell-save-modified-source-files fname) - (haskell-send-to-process ":(emacs-compile-file") - (haskell-send-to-process (prin1-to-string fname)) - (haskell-send-to-process ")"))) - - -(defun haskell-get-file-to-operate-on () - (cond ((equal *haskell-buffer* (buffer-name)) - ;; When called from the haskell process buffer, prompt for a file. - (call-interactively 'haskell-get-file/prompt)) - ((buffer-file-name) - ;; When called from a .hs file buffer, use the unit file - ;; associated with it, if there is one. - (haskell-maybe-get-unit-file-name (buffer-file-name))) - (t - ;; When called from a pad, use the file that the module the - ;; pad belongs to lives in. - (haskell-maybe-get-unit-file-name - (haskell-get-file-from-pad (buffer-name (current-buffer))))))) - -(defun haskell-get-file/prompt (filename) - (interactive "fHaskell file: ") - (haskell-run-file-aux filename)) - - - -;;; HASKELL-EXIT -;;; ------------------------------------------------------------------ - -(defun haskell-exit () - "Quit the haskell process." - (interactive) - (cond ((not (haskell-process-exists-p)) - (message "No process currently running.")) - ((y-or-n-p "Do you really want to quit Haskell? ") - (haskell-send-to-process ":quit") - ;; If we were running the tutorial, mark the temp buffer as unmodified - ;; so we don't get asked about saving it later. - (if (and *ht-temp-buffer* - (get-buffer *ht-temp-buffer*)) - (save-excursion - (set-buffer *ht-temp-buffer*) - (set-buffer-modified-p nil))) - ;; Try to remove the haskell output buffer from the screen. - (bury-buffer *haskell-buffer*) - (replace-buffer-in-windows *haskell-buffer*)) - (t - nil))) - - -;;; HASKELL-INTERRUPT -;;; ------------------------------------------------------------------ - -(defun haskell-interrupt () - "Interrupt the haskell process." - (interactive) - (if (haskell-process-exists-p) - (haskell-send-to-process "\C-c"))) - - - -;;; HASKELL-EDIT-UNIT -;;; ------------------------------------------------------------------ - -(defun haskell-edit-unit () - "Edit the .hu file." - (interactive) - (let ((fname (buffer-file-name))) - (if fname - (let ((find-file-not-found-hooks (list 'haskell-new-unit)) - (file-not-found nil) - (units-fname (haskell-get-unit-file-name fname))) - (find-file-other-window units-fname) - ;; If creating a new file, initialize it to contain the name - ;; of the haskell source file. - (if file-not-found - (save-excursion - (insert - (if (string= (file-name-directory fname) - (file-name-directory units-fname)) - (file-name-nondirectory fname) - fname) - "\n")))) - (haskell-mode-error "Not in a .hs buffer!")))) - -(defun haskell-new-unit () - (setq file-not-found t)) - - -;;; Look for a comment like "-- unit:" at top of file. -;;; If not found, assume unit file has same name as the buffer but -;;; a .hu extension. - -(defun haskell-get-unit-file-name (fname) - (or (haskell-get-unit-file-name-from-file fname) - (concat (haskell-strip-file-extension fname) ".hu"))) - -(defun haskell-maybe-get-unit-file-name (fname) - (or (haskell-get-unit-file-name-from-file fname) - (haskell-strip-file-extension fname))) - -(defun haskell-get-unit-file-name-from-file (fname) - (let ((buffer (get-file-buffer fname))) - (if buffer - (save-excursion - (beginning-of-buffer) - (if (re-search-forward "-- unit:[ \t]*" (point-max) t) - (let ((beg (match-end 0))) - (end-of-line) - (buffer-substring beg (point))) - nil)) - nil))) - - - - -;;; ================================================================== -;;; Support for printers/optimizers menus -;;; ================================================================== - -;;; This code was adapted from the standard buff-menu.el code. - -(defvar haskell-menu-mode-map nil "") - -(if (not haskell-menu-mode-map) - (progn - (setq haskell-menu-mode-map (make-keymap)) - (suppress-keymap haskell-menu-mode-map t) - (define-key haskell-menu-mode-map "m" 'hm-mark) - (define-key haskell-menu-mode-map "u" 'hm-unmark) - (define-key haskell-menu-mode-map "x" 'hm-exit) - (define-key haskell-menu-mode-map "q" 'hm-exit) - (define-key haskell-menu-mode-map " " 'next-line) - (define-key haskell-menu-mode-map "\177" 'hm-backup-unmark) - (define-key haskell-menu-mode-map "?" 'describe-mode))) - -;; Printers Menu mode is suitable only for specially formatted data. - -(put 'haskell-menu-mode 'mode-class 'special) - -(defun haskell-menu-mode () - "Major mode for editing Haskell flags. -Each line describes a flag. -Letters do not insert themselves; instead, they are commands. -m -- mark flag (turn it on) -u -- unmark flag (turn it off) -x -- exit; tell the Haskell process to update the flags, then leave menu. -q -- exit; same as x. -Precisely,\\{haskell-menu-mode-map}" - (kill-all-local-variables) - (use-local-map haskell-menu-mode-map) - (setq truncate-lines t) - (setq buffer-read-only t) - (setq major-mode 'haskell-menu-mode) - (setq mode-name "Haskell Flags Menu") - ;; These are all initialized elsewhere - (make-local-variable 'hm-current-flags) - (make-local-variable 'hm-request-fn) - (make-local-variable 'hm-update-fn) - (run-hooks 'haskell-menu-mode-hook)) - - -(defun haskell-menu (help-file buffer request-fn update-fn) - (haskell-maybe-create-process) - (if (get-buffer buffer) - (progn - (pop-to-buffer buffer) - (goto-char (point-min))) - (progn - (pop-to-buffer buffer) - (insert-file-contents help-file) - (haskell-menu-mode) - (setq hm-request-fn request-fn) - (setq hm-update-fn update-fn) - )) - (hm-mark-current) - (message "m = mark; u = unmark; x = execute; q = quit; ? = more help.")) - - - -;;; A line that starts with *hm-marked* is a menu item turned on. -;;; A line that starts with *hm-unmarked* is turned off. -;;; A line that starts with anything else is just random text and is -;;; ignored by commands that deal with menu items. - -(defvar *hm-marked* " on") -(defvar *hm-unmarked* " ") -(defvar *hm-marked-regexp* " on \\w") -(defvar *hm-unmarked-regexp* " \\w") - -(defun hm-mark () - "Mark flag to be turned on." - (interactive) - (beginning-of-line) - (cond ((looking-at *hm-marked-regexp*) - (forward-line 1)) - ((looking-at *hm-unmarked-regexp*) - (let ((buffer-read-only nil)) - (delete-char (length *hm-unmarked*)) - (insert *hm-marked*) - (forward-line 1))) - (t - (forward-line 1)))) - -(defun hm-unmark () - "Unmark flag." - (interactive) - (beginning-of-line) - (cond ((looking-at *hm-unmarked-regexp*) - (forward-line 1)) - ((looking-at *hm-marked-regexp*) - (let ((buffer-read-only nil)) - (delete-char (length *hm-marked*)) - (insert *hm-unmarked*) - (forward-line 1))) - (t - (forward-line 1)))) - -(defun hm-backup-unmark () - "Move up and unmark." - (interactive) - (forward-line -1) - (hm-unmark) - (forward-line -1)) - - -;;; Actually make the changes. - -(defun hm-exit () - "Update flags, then leave menu." - (interactive) - (hm-execute) - (hm-quit)) - -(defun hm-execute () - "Tell haskell process to tweak flags." - (interactive) - (save-excursion - (goto-char (point-min)) - (let ((flags-on nil) - (flags-off nil)) - (while (not (eq (point) (point-max))) - (cond ((looking-at *hm-unmarked-regexp*) - (setq flags-off (cons (hm-flag) flags-off))) - ((looking-at *hm-marked-regexp*) - (setq flags-on (cons (hm-flag) flags-on))) - (t - nil)) - (forward-line 1)) - (funcall hm-update-fn flags-on flags-off)))) - - -(defun hm-quit () - (interactive) - "Make the menu go away." - (bury-buffer (current-buffer)) - (replace-buffer-in-windows (current-buffer))) - -(defun hm-flag () - (save-excursion - (beginning-of-line) - (forward-char 6) - (let ((beg (point))) - ;; End of flag name marked by tab or two spaces. - (re-search-forward "\t\\| ") - (buffer-substring beg (match-beginning 0))))) - - -;;; Update the menu to mark only those items currently turned on. - -(defun hm-mark-current () - (funcall hm-request-fn) - (save-excursion - (goto-char (point-min)) - (while (not (eq (point) (point-max))) - (cond ((and (looking-at *hm-unmarked-regexp*) - (hm-item-currently-on-p (hm-flag))) - (hm-mark)) - ((and (looking-at *hm-marked-regexp*) - (not (hm-item-currently-on-p (hm-flag)))) - (hm-unmark)) - (t - (forward-line 1)))))) - - -;;; See if a menu item is turned on. - -(defun hm-item-currently-on-p (item) - (member-string= item hm-current-flags)) - -(defun member-string= (item list) - (cond ((null list) - nil) - ((string= item (car list)) - list) - (t - (member-string= item (cdr list))))) - - - -;;; Make the menu for printers. - -(defvar *haskell-printers-help* - (concat (getenv "HASKELL") "/emacs-tools/printer-help.txt") - "Help file for printers.") - -(defvar *haskell-printers-buffer* "*Haskell printers*") - -(defun haskell-printers () - "Set printers interactively." - (interactive) - (haskell-menu - *haskell-printers-help* - *haskell-printers-buffer* - 'haskell-printers-inquire - 'haskell-printers-set)) - -(defun haskell-printers-inquire () - (setq hm-current-flags t) - (haskell-send-to-process ":(emacs-send-printers)") - (while (eq hm-current-flags t) - (sleep-for 1))) - -(defun haskell-printers-update (data) - (setq hm-current-flags (read data))) - -(defun haskell-printers-set (flags-on flags-off) - (haskell-send-to-process ":(emacs-set-printers '") - (haskell-send-to-process (prin1-to-string flags-on)) - (haskell-send-to-process ")")) - - -;;; Equivalent stuff for the optimizers menu - -(defvar *haskell-optimizers-help* - (concat (getenv "HASKELL") "/emacs-tools/optimizer-help.txt") - "Help file for optimizers.") - -(defvar *haskell-optimizers-buffer* "*Haskell optimizers*") - -(defun haskell-optimizers () - "Set optimizers interactively." - (interactive) - (haskell-menu - *haskell-optimizers-help* - *haskell-optimizers-buffer* - 'haskell-optimizers-inquire - 'haskell-optimizers-set)) - -(defun haskell-optimizers-inquire () - (setq hm-current-flags t) - (haskell-send-to-process ":(emacs-send-optimizers)") - (while (eq hm-current-flags t) - (sleep-for 1))) - -(defun haskell-optimizers-update (data) - (setq hm-current-flags (read data))) - -(defun haskell-optimizers-set (flags-on flags-off) - (haskell-send-to-process ":(emacs-set-optimizers '") - (haskell-send-to-process (prin1-to-string flags-on)) - (haskell-send-to-process ")")) - - - -;;; ================================================================== -;;; Random utilities -;;; ================================================================== - - -;;; Keep track of the association between pads, modules, and files. -;;; The global variable is a list of (pad-buffer-name module-name file-name) -;;; lists. - -(defvar *haskell-pad-mappings* () - "Associates pads with their corresponding module and file.") - -(defun haskell-record-pad-mapping (pname mname fname) - (setq *haskell-pad-mappings* - (cons (list pname mname fname) *haskell-pad-mappings*))) - -(defun haskell-get-module-from-pad (pname) - (car (cdr (assoc pname *haskell-pad-mappings*)))) - -(defun haskell-get-file-from-pad (pname) - (car (cdr (cdr (assoc pname *haskell-pad-mappings*))))) - -(defun haskell-lookup-pad (mname fname) - (let ((pname (haskell-lookup-pad-aux mname fname *haskell-pad-mappings*))) - (if (and pname (get-buffer pname)) - pname - nil))) - -(defun haskell-lookup-pad-aux (mname fname list) - (cond ((null list) - nil) - ((and (equal mname (car (cdr (car list)))) - (equal fname (car (cdr (cdr (car list)))))) - (car (car list))) - (t - (haskell-lookup-pad-aux mname fname (cdr list))))) - - - -;;; Save any modified .hs and .hu files. -;;; Yes, the two set-buffer calls really seem to be necessary. It seems -;;; that y-or-n-p makes emacs forget we had temporarily selected some -;;; other buffer, and if you just do save-buffer directly it will end -;;; up trying to save the current buffer instead. The built-in -;;; save-some-buffers function has this problem.... - -(defun haskell-save-modified-source-files (filename) - (let ((buffers (buffer-list)) - (found-any nil)) - (while buffers - (let ((buffer (car buffers))) - (if (and (buffer-modified-p buffer) - (save-excursion - (set-buffer buffer) - (and buffer-file-name - (haskell-source-file-p buffer-file-name) - (setq found-any t) - (or (null haskell-ask-before-saving) - (and filename (string= buffer-file-name filename)) - (y-or-n-p - (format "Save file %s? " buffer-file-name)))))) - (save-excursion - (set-buffer buffer) - (save-buffer)))) - (setq buffers (cdr buffers))) - (if found-any - (message "") - (message "(No files need saving)")))) - -(defun haskell-source-file-p (filename) - (or (string-match "\\.hs$" filename) - (string-match "\\.lhs$" filename) - (string-match "\\.hi$" filename) - (string-match "\\.hu$" filename))) - - - -;;; Buffer utilities - -(defun haskell-move-marker () - "Moves the marker and point to the end of buffer" - (set-marker comint-last-input-end (point-max)) - (set-marker (process-mark (get-process "haskell")) (point-max)) - (goto-char (point-max))) - - - -;;; Extract the name of the module the point is in, from the given buffer. - -(defvar *haskell-re-module-hs* "^module\\s *") -(defvar *haskell-re-module-lhs* "^>\\s *module\\s *") -(defvar *haskell-re-modname* "[A-Z]\\([a-z]\\|[A-Z]\\|[0-9]\\|'\\|_\\)*") - -(defun haskell-get-modname (buff) - "Get module name in BUFFER that point is in." - (save-excursion - (set-buffer buff) - (let ((regexp (if (haskell-lhs-filename-p (buffer-file-name)) - *haskell-re-module-lhs* - *haskell-re-module-hs*))) - (if (or (looking-at regexp) - (re-search-backward regexp (point-min) t) - (re-search-forward regexp (point-max) t)) - (progn - (goto-char (match-end 0)) - (if (looking-at *haskell-re-modname*) - (buffer-substring (match-beginning 0) (match-end 0)) - (haskell-mode-error "Module name not found!!"))) - "Main")))) - - -;;; Strip file extensions. -;;; Only strip off extensions we know about; e.g. -;;; "foo.hs" -> "foo" but "foo.bar" -> "foo.bar". - -(defvar *haskell-filename-regexp* "\\(.*\\)\\.\\(hs\\|lhs\\)$") - -(defun haskell-strip-file-extension (filename) - "Strip off the extension from a filename." - (if (string-match *haskell-filename-regexp* filename) - (substring filename (match-beginning 1) (match-end 1)) - filename)) - - -;;; Is this a .lhs filename? - -(defun haskell-lhs-filename-p (filename) - (string-match ".*\\.lhs$" filename)) - - -;;; Haskell mode error - -(defun haskell-mode-error (msg) - "Show MSG in message line as an error from the haskell mode." - (error (concat "Haskell mode: " msg))) - - - -;;; ================================================================== -;;; User customization -;;; ================================================================== - -(defvar haskell-load-hook nil - "This hook is run when haskell is loaded in. -This is a good place to put key bindings." - ) - -(run-hooks 'haskell-load-hook) - - - - -;;;====================================================================== -;;; Tutorial mode setup -;;;====================================================================== - -;;; Set up additional key bindings for tutorial mode. - -(defvar ht-mode-map (make-sparse-keymap)) - -(haskell-establish-key-bindings ht-mode-map) -(define-key ht-mode-map "\C-c\C-f" 'ht-next-page) -(define-key ht-mode-map "\C-c\C-b" 'ht-prev-page) -(define-key ht-mode-map "\C-c\C-l" 'ht-restore-page) -(define-key ht-mode-map "\C-c?" 'describe-mode) - -(defun haskell-tutorial-mode () - "Major mode for running the Haskell tutorial. -You can use these commands: -\\{ht-mode-map}" - (interactive) - (kill-all-local-variables) - (use-local-map ht-mode-map) - (setq major-mode 'haskell-tutorial-mode) - (setq mode-name "Haskell Tutorial") - (set-syntax-table haskell-mode-syntax-table) - (run-hooks 'haskell-mode-hook)) - - -(defun haskell-tutorial () - "Run the haskell tutorial." - (interactive) - (ht-load-tutorial) - (ht-make-buffer) - (ht-display-page) - (haskell-maybe-create-process) - (haskell-send-to-process ":(emacs-set-printers '(interactive))") - ) - - -;;; Load the tutorial file into a read-only buffer. Do not display this -;;; buffer. - -(defun ht-load-tutorial () - (let ((buffer (get-buffer *ht-file-buffer*))) - (if buffer - (save-excursion - (set-buffer buffer) - (beginning-of-buffer)) - (save-excursion - (set-buffer (setq buffer (get-buffer-create *ht-file-buffer*))) - (let ((fname (substitute-in-file-name *ht-source-file*))) - (if (file-readable-p fname) - (ht-load-tutorial-aux fname) - (call-interactively 'ht-load-tutorial-aux))))))) - -(defun ht-load-tutorial-aux (filename) - (interactive "fTutorial file: ") - (insert-file filename) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (beginning-of-buffer)) - - -;;; Create a buffer to use for messing about with each page of the tutorial. -;;; Put the buffer into haskell-tutorial-mode. - -(defun ht-make-buffer () - (find-file (concat "/tmp/" (make-temp-name "ht") ".lhs")) - (setq *ht-temp-buffer* (buffer-name)) - (haskell-tutorial-mode)) - - -;;; Commands for loading text into the tutorial pad buffer - -(defun ht-next-page () - "Go to the next tutorial page." - (interactive) - (if (ht-goto-next-page) - (ht-display-page) - (beep))) - -(defun ht-goto-next-page () - (let ((buff (current-buffer))) - (unwind-protect - (progn - (set-buffer *ht-file-buffer*) - (search-forward "\C-l" nil t)) - (set-buffer buff)))) - -(defun ht-prev-page () - "Go to the previous tutorial page." - (interactive) - (if (ht-goto-prev-page) - (ht-display-page) - (beep))) - -(defun ht-goto-prev-page () - (let ((buff (current-buffer))) - (unwind-protect - (progn - (set-buffer *ht-file-buffer*) - (search-backward "\C-l" nil t)) - (set-buffer buff)))) - -(defun ht-goto-page (arg) - "Go to the tutorial page specified as the argument." - (interactive "sGo to page: ") - (if (ht-searchfor-page (format "Page: %s " arg)) - (ht-display-page) - (beep))) - -(defun ht-goto-section (arg) - "Go to the tutorial section specified as the argument." - (interactive "sGo to section: ") - (if (ht-searchfor-page (format "Section: %s " arg)) - (ht-display-page) - (beep))) - -(defun ht-searchfor-page (search-string) - (let ((buff (current-buffer))) - (unwind-protect - (progn - (set-buffer *ht-file-buffer*) - (let ((point (point))) - (beginning-of-buffer) - (if (search-forward search-string nil t) - t - (progn - (goto-char point) - nil)))) - (set-buffer buff)))) - -(defun ht-restore-page () - (interactive) - (let ((old-point (point))) - (ht-display-page) - (goto-char old-point))) - -(defun ht-display-page () - (set-buffer *ht-file-buffer*) - (let* ((beg (progn - (if (search-backward "\C-l" nil t) - (forward-line 1) - (beginning-of-buffer)) - (point))) - (end (progn - (if (search-forward "\C-l" nil t) - (beginning-of-line) - (end-of-buffer)) - (point))) - (text (buffer-substring beg end))) - (set-buffer *ht-temp-buffer*) - (erase-buffer) - (insert text) - (beginning-of-buffer))) - - - -;;;====================================================================== -;;; Menu bar stuff -;;;====================================================================== - -;;; This only works in Emacs version 19, so it's in a separate file for now. - -(if (featurep 'menu-bar) - (load-library "haskell-menu")) diff --git a/ghc/CONTRIB/haskell-modes/yale/original/optimizer-help.txt b/ghc/CONTRIB/haskell-modes/yale/original/optimizer-help.txt deleted file mode 100644 index c18ac5db61..0000000000 --- a/ghc/CONTRIB/haskell-modes/yale/original/optimizer-help.txt +++ /dev/null @@ -1,6 +0,0 @@ -Optimizer switches - inline Aggressively inline functions - constant Hoist constant expressions to top-level - foldr Perform foldr/build deforestation - lisp Tell the Lisp compiler to work hard to produce best code - delays Try to make delays out-of-line for more compact code diff --git a/ghc/CONTRIB/haskell-modes/yale/original/printer-help.txt b/ghc/CONTRIB/haskell-modes/yale/original/printer-help.txt deleted file mode 100644 index f8a620056e..0000000000 --- a/ghc/CONTRIB/haskell-modes/yale/original/printer-help.txt +++ /dev/null @@ -1,26 +0,0 @@ -General messages - compiling Printed when the compilation system starts a compilation - loading Printed when a previously compiled unit is loaded - reading Prints the name of the file being parsed - pad Enables printing within scratch pads - interactive Print verbose messages in command loop - prompt Print prompt in command loop -Timings - time Prints the time that it takes to execute a computation - phase-time Prints the time of each phase of compilation -Compiler passes - parse Prints the program recreated from ast - import Lists all symbols imported and exported for each module - scope Print the program after scoping and precedence parsing - depend Prints entire program in nested let's - type Prints signatures during inference - cfn Prints entire program after context free normalization - depend2 Like depend - flic Prints entire program as flic code - optimize Prints entire program as optimized flic code - optimize-extra Prints extra verbose information during optimization - strictness Print strictness of all functions and variables - codegen Prints generated Lisp code - codegen-flic Prints generated Lisp code and associated flic code - dumper Prints the code in the interface - dump-stat Prints statistics for the interface file diff --git a/ghc/CONTRIB/haskell_poem b/ghc/CONTRIB/haskell_poem deleted file mode 100644 index 1f8218648a..0000000000 --- a/ghc/CONTRIB/haskell_poem +++ /dev/null @@ -1,58 +0,0 @@ -From: dsmith@lucy.cs.waikato.ac.nz -Subject: A Haskell Lover's Plea -Date: Thu, 16 Mar 1995 21:06:35 -0500 -To: haskell-dist@dcs.gla.ac.uk - - - A Haskell Lover's Plea - -Why should I renounce for you, dear Haskell, -My much yearned for side-effects? -Why should I face the software dragons -Without my weapon, my manly spear of destruction? -They call you non-strict, oh so elegant and pure Ariel. -Yet side-effect celibacy is surely severe. - - Your flesh is too weak, you brutish beast. - The tarpit demons of software hell await you! - This sinful habit in which you indulge - Does more harm than good. - Restrain yourself! And you too will see - The wondrous and refined joys of referential transparency! - -Alas, I can do without goto, without call/cc. -But sans side-effects, I am lost and forlorn, can't you see? -Oh, lady fairer yet than admirable Miranda (tm), -Scheme's prolix, parenthetical tedium -Is no match for your elegant syntax. What's more, -Your list comprehensions outshine even Prolog for sure... - - Ah, flatter me not, you low-spirited Caliban! - Do you not know what advantages await - Those who renounce destructive update? - Start with an immaculate high-level specification, - Throw in some algebraic code transformation. - Soon you will have a provably correct and maintainable implementation. - -Show mercy on mere mortals like me! -How I dream still of the efficient pleasures of pointer manipulation! -How I too wish to mutate memory with thoughts born of von Neumann earthiness! -Relent! Relent! Let me have my assignment, my printf, my gensym. -Let me fulfill my destructive impulses. -Let me set bang. Let me update. Let me assign. Let me mutate. - - Fear not, lowly beast, I have heard your pleas. - To satisfy your low-level desire - I'll give you monads, linear types, MADTs, - Even single-threaded polymorphic lambda calculi. - My beauty may suffer, still I will aspire - To let you do (within typeful limits) what you please. - -Rejoice! Rejoice! I'm free! I'm free! -The best of both worlds is mine at last. -Oh, infinite progeny of Church, Hope, and ML, -I curry favor not when I say: -Scan me right, fold me left, -Lazy lady of many shapes, you've got class. - - Don Smith (dsmith@cs.waikato.ac.nz) diff --git a/ghc/CONTRIB/mira2hs b/ghc/CONTRIB/mira2hs deleted file mode 100644 index 1ad61040f7..0000000000 --- a/ghc/CONTRIB/mira2hs +++ /dev/null @@ -1,364 +0,0 @@ -#!/bin/sh - -# mira2hs - Convert Miranda to Haskell (or Gofer) - -# usage: mira2hs [infile [outfile]] -# -# Input defaults to stdin, output defaults to .hs or stdout if -# input is stdin - -# Copyright Denis Howe 1992 -# -# Permission is granted to make and distribute verbatim or modified -# copies of this program, provided that every such copy or derived -# work carries the above copyright notice and is distributed under -# terms identical to these. -# -# Miranda is a trademark of Research Software Limited. -# (E-mail: mira-request@ukc.ac.uk). -# -# Denis Howe - -# NOTE: This program needs a sed which understands \ regular -# expressions, eg. Sun or GNU sed (gsed). - -# partain: got it from wombat.doc.ic.ac.uk:pub - -# 1.05 18 Sep 1992 zip -> zipPair -# 1.04 29 Jul 1992 Improve handling of ==, -- and whitespace round guards -# $infix -> `infix` -# 1.03 24 Apr 1992 Incorporate Lennart's miranda.hs functions -# Replace most Miranda fns & operators -# Use \ patterns, ';' -> ',' in list comprehension -# Provide example main functions -# 1.02 30 Mar 1992 Mods to header, fix handling of type,type -# Comment out String definition, Bool ops -# num -> Int, = -> == in guards -# 1.01 10 Dec 1991 Convert type names to initial capital -# 1.00 27 Sep 1991 Initial version advertised to net - -# Does NOT handle: -# continued inequalities (a < x < b) -# boolean '=' operator -> '==' (except in guards) -# main function -# multi-line type definitions -# guards on different line from body -# diagonalised list comprehensions (//) -# repeated variables in patterns (eg. LHS of function) -# filemode -> statusFile, getenv -> getEnv, read -> readFile, system -# include directives -# conflicts with prelude identifiers - -# Miranda's num type (Integral+Floating) is changed to Int so won't -# work for non-intger nums. Miranda has irrefutable ("lazy") tuple -# patterns so you may need to add a ~, like ~(x,y) in Haskell. -# Haskell functions "length" and "not" may need parentheses round -# their arguments. - -# mira2hs copes equally well with literate and illiterate scripts. It -# doesn't care what characters lines begins with - it assumes -# everything is code. It will convert code even inside comments. -# -# For literate programs you will have to turn the standard header into -# literate form and rename the output .lhs. You might want to do this -# to (a copy of) mira2hs itself if you have lots of literate progs. - -# ToDo: = inside brackets -> == - -if [ -n "$1" ] -then in=$1 - out=`basename $in .m`.hs -else in="Standard input" -fi -[ -n "$2" ] && out=$2 -tmp=/tmp/m2h$$ -script=${tmp}s - -# Prepend a standard header and some function definitions. -echo -- $in converted to Haskell by $USER on `date` > $tmp -cat << "++++" >> $tmp -module Main (main) where - --------------------- mira2hs functions -------------------- - -cjustify :: Int -> String -> String -cjustify n s = spaces l ++ s ++ spaces r - where - m = n - length s - l = div m 2 - r = m - l - -e :: (Floating a) => a -e = exp 1 - -hugenum :: (RealFloat a) => a -hugenum = encodeFloat (r^d-1) (n-d) - where r = floatRadix hugenum - d = floatDigits hugenum - (_,n) = floatRange hugenum - -subscripts :: [a] -> [Int] -- Miranda index -subscripts xs = f xs 0 - where f [] n = [] - f (_:xs) n = n : f xs (n+1) - -integer :: (RealFrac a) => a -> Bool -integer x = x == fromIntegral (truncate x) - -lay :: [String] -> String -lay = concat . map (++"\n") - -layn :: [String] -> String -layn = concat . zipWith f [1..] - where - f :: Int -> String -> String - f n x = rjustify 4 (show n) ++ ") " ++ x ++ "\n" - -limit :: (Eq a) => [a] -> a -limit (x:y:ys) | x == y = x - | otherwise = limit (y:ys) -limit _ = error "limit: bad use" - -ljustify :: Int -> String -> String -ljustify n s = s ++ spaces (n - length s) - -member :: (Eq a) => [a] -> a -> Bool -member xs x = elem x xs - -merge :: (Ord a) => [a] -> [a] -> [a] -merge [] ys = ys -merge xs [] = xs -merge xxs@(x:xs) yys@(y:ys) | x <= y = x : merge xs yys - | otherwise = y : merge xxs ys - -numval :: (Num a) => String -> a -numval cs = read cs - -postfix :: [a] -> a -> [a] -postfix xs x = xs ++ [x] - -rep :: Int -> b -> [b] -rep n x = take n (repeat x) - -rjustify :: Int -> String -> String -rjustify n s = spaces (n - length s) ++ s - -seq :: (Eq a) => a -> b -> b -seq x y = if x == x then y else y - -shownum :: (Num a) => a -> String -shownum x = show x - -sort :: (Ord a) => [a] -> [a] -sort x | n <= 1 = x - | otherwise = merge (sort (take n2 x)) (sort (drop n2 x)) - where n = length x - n2 = div n 2 -spaces :: Int -> String -spaces 0 = "" -spaces n = ' ' : spaces (n-1) - -tinynum :: (RealFloat a) => a -tinynum = encodeFloat 1 (n-d) - where r = floatRadix tinynum - d = floatDigits tinynum - (n,_) = floatRange tinynum - -undef :: a -undef = error "undefined" - -zipPair (x,y) = zip x y - --- Following is UNTESTED -data Sys_message = - Stdout String | Stderr String | Tofile String String | - Closefile String | Appendfile String | --- System String | - Exit Int - -doSysMessages :: [Sys_message] -> Dialogue -doSysMessages requests responses = doMsgs requests [] - -doMsgs [] afs = [] -doMsgs ((Appendfile f):rs) afs = doMsgs rs (f:afs) -doMsgs ((Exit n) :rs) afs = [] -doMsgs (r :rs) afs - = doMsg r : doMsgs rs afs - where doMsg (Stdout s) = AppendChan stdout s - doMsg (Stderr s) = AppendChan stderr s - doMsg (Tofile f s) | elem f afs = AppendFile f s - | otherwise = WriteFile f s - doMsg (Closefile f) - = error "doSysMessages{mira2hs}: Closefile sys_message not supported" --- doMsg (Closefile f) = CloseFile f -- optional --- doMsg (System cmd) --- = error "doSysMessages{mira2hs}: System sys_message not supported" - --- Pick a main. (If I was clever main would be an overloaded fn :-). -main :: Dialogue --- main = printString s -- s :: String --- main = interact f -- f :: String -> String --- main = doSysMessages l -- l :: [Sys_message] --- main = print x -- x :: (Text a) => a - -printString :: String -> Dialogue -printString s = appendChan stdout s abort done - --------------------- mira2hs functions end -------------------- - -++++ -# It's amazing what sed can do. -sed ' -# Type synonyms and constructed types: insert "type" or "data". Add a -# dummy :: to flag this line to the type name munging below. Beware -# ====== in comments. -/[^=]==[^=]/s/\(.*=\)=/::type \1/g -/::=/s/\(.*\)::=/::data \1=/g -# Change type variable *s to "a"s -/::/s/\*/a/g -# List length & various other renamed functions (# reused below). -s/ *# */ length /g -s/\/atan/g -s/\/ord/g -s/\/flip/g -s/\/chr/g -s/\/dropWhile/g -s/\/isDigit/g -s/\/floor/g -s/\/head/g -s/\/subscripts/g -s/\/isAlpha/g -s/\/zipWith/g -s/\/maximum/g -s/\/max/g -s/\/minimum/g -s/\/min/g -s/\/nub/g -s/\/negate/g -s/\/scanl/g -s/\/tail/g -# Miranda uncurried zip -> zipPair (above). Do before zip2->zip. -s/\/zipPair/g -# Miranda curried zip2 -> zip -s/\/zip/g -# Haskel div and mod are functions, not operators -s/\/\`div\`/g -s/\/\`mod\`/g -# Locate commas introducing guards by temporarily changing others. -# Replace comma with # when after || or unmatched ( or [ or before -# unmatched ) or ] or in string or char constants. Replace -# matched () not containing commas with _<_ _>_ and matched [] -# with _{_ _}_ and repeat until no substitutions. -: comma -s/\(||.*\),/\1#/g -s/\([[(][^])]*\),/\1#/g -s/,\([^[(]*[])]\)/#\1/g -s/(\([^),]*\))/_<_\1_>_/g -s/\[\([^],]*\)\]/_{_\1_}_/g -s/"\(.*\),\(.*\)"/"\1#\2"/g -'"#change quotes -s/','/'#'/g -"'#change quotes -t comma -# Restore () and [] -s/_<_/(/g -s/_>_/)/g -s/_{_/[/g -s/_}_/]/g -# The only commas left now introduce guards, remove optional "if" -s/,[ ]*if/,/g -s/[ ]*,[ ]*/,/g -# Temporarily change ~=, <=, >=. -s%~=%/_eq_%g -s/<=/<_eq_/g -s/>=/>_eq_/g -# Replace every = in guard with == (do after type synonyms) -: neq -s/\(,.*[^=]\)=\([^=]\)/\1==\2/ -t neq -# Fix other equals -s/_eq_/=/g -# Replace = , with | () = -s/=\(..*\),\(..*\)/| (\2) =\1/g -s/(otherwise)/otherwise/g -# Restore other commas -s/#/,/g -# List difference. Beware ------ in comments. -s/\([^-]\)--\([^-]\)/\1\\\\\2/g -# Comments (do after list diff) -s/||/--/g -s/--|/---/g -# Boolean not, or, and (do after comments) -s/ *~ */ not /g -s% *\\/ *% || %g -s/&/&&/g -# list indexing -s/!/!!/g -# Locate semicolon in list comprehensions by temporarily replacing ones -# in string or char constants with #. Replace matched [] not -# containing semicolon with _{_ _}_ and repeat until no substitutions. -: semico -s/\[\([^];]*\)\]/_{_\1_}_/g -s/"\([^;"]*\);\([^;"]*\)"/"\1#\2"/g -'"#change quotes -s/';'/'#'/g -"'# change quotes -t semico -# Remaining [ ] must contain semicolons which we change to comas. -: lcomp -s/\(\[[^;]*\);/\1,/g -s/;\([^;]*\]\)/,\1/g -t lcomp -# Restore [] and other semicolons -s/_{_/[/g -s/_}_/]/g -s/#/;/g -# Miranda dollar turns a function into an infix operator -s/\$\([_A-Za-z0-9'\'']\{1,\}\)/`\1`/g -' $1 >> $tmp - -# Create a sed script to change the first letter of each type name to -# upper case. -# Dummy definitions for predefined types (num is special). -( - echo ::type char = - echo ::type bool = - echo ::type sys_message = - cat $tmp -) | \ -# Find type definitions & extract type names -sed -n '/::data[ ].*=/{ -h;s/::data[ ]*\([^ =]\).*/\1/p -y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/;p -g;s/::data[ ]*[^ =]\([^ =]*\).*=.*/\1/p -} -/::type[ ].*=/{ -h;s/::type[ ]*\([^ =]\).*/\1/p -y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/;p -g;s/::type[ ]*[^ =]\([^ =]*\).*=.*/\1/p -}' | \ -# Read lower case initial, upper case inital and rest of type name. -# Type is always after "::". -( -echo ": loop" -while read h; read H; read t -do echo "/::/s/\<$h$t\>/$H$t/g" -done -cat << "++++" -# num -> Int -/::/s/\/Int/g -# Loop round to catch type,type,.. -t loop -# Remove the dummy :: flags from type definitions. -s/::type/type/ -s/::data/data/ -# Comment out string type if defined. -s/\(type[ ]*String[ ]*=\)/-- \1/ -++++ -) > $script - -if [ "$out" ] -then exec > $out -fi -sed -f $script $tmp -rm -f ${tmp}* diff --git a/ghc/CONTRIB/pphs/Jmakefile b/ghc/CONTRIB/pphs/Jmakefile deleted file mode 100644 index 24d546c7e7..0000000000 --- a/ghc/CONTRIB/pphs/Jmakefile +++ /dev/null @@ -1,16 +0,0 @@ -SuffixRule_c_o() - -BuildPgmFromOneCFile(pphs) - -InstallBinaryTarget(pphs,$(INSTBINDIR_GHC)) - -/* These .dvi-ish rules are not right, but so what? [WDP 94/09] */ - -docs/UserGuide.dvi: docs/UserGuide.tex - $(RM) $@ - (cd docs && ../$(LTX) UserGuide.tex) - -/* Student project final report */ -docs/Report.dvi: docs/Report.tex - $(RM) $@ - (cd docs && ../$(LTX) Report.tex) diff --git a/ghc/CONTRIB/pphs/README b/ghc/CONTRIB/pphs/README deleted file mode 100644 index a99d81e8f5..0000000000 --- a/ghc/CONTRIB/pphs/README +++ /dev/null @@ -1,18 +0,0 @@ -"pphs" is a Haskell code pretty-printer, written by Andrew Preece as a -senior honours project at Glasgow. - -== original README ======================================== - -* * RELEASE directory * * - -To find out how to use pphs read the User Guide by -typing xdvi User_Guide - -If you put the output of pphs into a file called Haskell.tex -then you can use Wrapper.tex to produce a ``stand alone'' -dvi file of your program. Just run latex on Wrapper.tex -by typing latex Wrapper then view with xdvi Wrapper - -* * MAINTENANCE directory * * - -Code for pphs program, LaTeX file, report, Makefile, etc. diff --git a/ghc/CONTRIB/pphs/docs/Code.tex b/ghc/CONTRIB/pphs/docs/Code.tex deleted file mode 100644 index 5437457350..0000000000 --- a/ghc/CONTRIB/pphs/docs/Code.tex +++ /dev/null @@ -1,53 +0,0 @@ -\chapter{Project code} - -\section{The program code - {\tt pphs.c}} \label{prog-code} - -\newpage % 8 pages of code a2ps (21.4.94) -\setcounter{page}{50} - -\section{The style file - {\tt pphs.sty}} \label{style-code} - -\begin{verbatim} -% ========================================= -% Definitions for use with the pphs program -% ========================================= - -\typeout{For use with the pphs program} - -% Definitions of commands used by pphs - -\newbox\foo -\def\skipover#1{\setbox\foo\hbox{#1}\hskip\wd\foo} -\def\plusplus{\hbox{$+\mkern-7.5mu+$}} -\def\xspa#1{\hskip#1ex} -\def\bareq{\setbox\foo\hbox{$=$}\makebox[\wd\foo]{$|$}} - -% User-redefinable commands - typefaces - -\def\keyword{\bf} -\def\iden{\it} -\def\stri{\rm} -\def\com{\rm} -\def\numb{\rm} - -% User-redefinable commands - quote marks - -\def\forquo{\hbox{\rm '}} -\def\escquo{\hbox{\rm '}} -\end{verbatim} - -\section{The make file - {\tt Makefile}} \label{make-code} - -\begin{verbatim} -# Makefile for A Preece's program... etc. - -default: - @echo "Type make pphs to create the program." - -pphs: pphs.c - cc -o pphs pphs.c - -test: pphs - pphs test - latex test.tex -\end{verbatim} \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Error_Messages.tex b/ghc/CONTRIB/pphs/docs/Error_Messages.tex deleted file mode 100644 index e53c960eb9..0000000000 --- a/ghc/CONTRIB/pphs/docs/Error_Messages.tex +++ /dev/null @@ -1,36 +0,0 @@ -\chapter{Error messages given} - -The {\tt pphs} program generates error messages to {\tt stderr}, -with error codes. Normal operation of the program will be -indicated by error code {\tt 0}. - -\section{\tt Call with one file name} - -Error code {\tt 1} is produced when {\tt pphs} is not called with -exactly one filename. Either no filename was given, or too many -filenames were given. Call {\tt pphs} again with one filename. - -\section{\tt File could not be opened} - -Error code {\tt 2} is produced when the filename given when {\tt pphs} -was called could not be opened. This could be because it did not exist, -or was read-protected. Call {\tt pphs} again with a filename that exists -and is readable. - -\section{\tt Stack is too big} - -Error code {\tt 3} is produced when the program has used up too much of -the computer's memory. It is not possible to run {\tt pphs} on this file -without getting more memory for the computer to use. - -\section{\tt Queue is too big} - -Error code {\tt 4} is produced when the program has used up too much of -the computer's memory. It is not possible to run {\tt pphs} on this file -without getting more memory for the computer to use. - -\section{\tt Stack underflow} - -Error code {\tt 5} is produced when the program attempts to remove an item -from a stack in memory that doesn't exist. This should not happen in the -{\tt pphs} program. diff --git a/ghc/CONTRIB/pphs/docs/External_Specification.tex b/ghc/CONTRIB/pphs/docs/External_Specification.tex deleted file mode 100644 index 4190680670..0000000000 --- a/ghc/CONTRIB/pphs/docs/External_Specification.tex +++ /dev/null @@ -1,117 +0,0 @@ -\section{External specification} - -The program is to be run in UNIX by typing {\tt pphs} followed by the -filename containing the Haskell code requiring to be typeset. This will -produce the \LaTeX\ code to stdout. If there is some error, -a suitable error message is to be printed to stderr. The user may, if -desired, direct the output to another file by typing {\tt pphs infilename > outfilename}. -In this case, any error messages must still go to the screen and not the file. - -The input filename may be given in its entirety or the {\tt .hs} extension may be omitted. -In the case where there are two files with the same name, except that one has the -{\tt .hs} extension, to run the program on the file with the extension to its name -the complete filename will be typed. - -The output will consist of the \LaTeX\ code to produce the typeset Haskell -code. As this is to be made easily insertable into another \LaTeX\ document, the output -will not contain any header information such as declarations or definitions. These, -however, can -be contained in a style file which the user will include in their main document. - -Keywords and identifiers are to be distinguished in the result as typeset. -The default for keywords is to be boldface and for identifiers italics. -Numbers not forming part of an identifier are to be in roman by default -while math is to be used where appropriate. - -Haskell uses ASCII characters and combinations of ASCII characters -to substitute for mathematical characters not present on the -keyboard. Where this happens, the program is to replace the ASCII character(s) -with the corresponding mathematical character using the special \LaTeX\ commands -to generate them. The single characters are: -\begin{quote} -\begin{tabular}[t]{@{}cc@{}} -Haskell & Math\\ -{\tt *} & $\times$ -\end{tabular} -\end{quote} -The double characters are: -\begin{quote} -\begin{tabular}[t]{@{}cc@{}} -Haskell & Math\\ -{\tt ++} & {\hbox{$+\mkern-7.5mu+$}}\\ -{\tt :+} & {:}{+}\\ -{\tt <=} & $\leq$\\ -{\tt >=} & $\geq$\\ -{\tt <-} & $\leftarrow$\\ -{\tt ->} & $\rightarrow$\\ -{\tt =>} & $\Rightarrow$ -\end{tabular} -\end{quote} - -The \LaTeX\ system uses special characters to aid with the typesetting. -They are: -\begin{quote} -\(\#\ \$\ \%\ \&\ \char'176\ \_\ \char'136\ \hbox{$\setminus$}\ \hbox{$\cal \char'146\ \char'147$}\) -\end{quote} -These characters may -appear in the input, so the program must generate the correct \LaTeX\ code to -print them and -avoid having them mess up the typesetting process. - -As the output when typeset must have the same layout as the input, the program -must get the linebreaks and indentation right. As \LaTeX\ is primarily designed for normal -text, it would ignore the linebreaks and indentation in the Haskell file. Therefore -the program must insert them using the correct typesetting commands. In the case of -linebreaks it must recognise where these occur, but for indentation it must also work out -how much space needs to be inserted. - -There are two types of indentation in Haskell programs: left-hand and internal. -For the former, the program must work out what the start of the line is aligned -under in the input file. It then has to calculate how much space is required -to get the line of text to line up with this in the output once typeset. -Take, for instance, the following Haskell example input: -\begin{quote} -\begin{verbatim} -foobar a b = c - where - c = (a, b) -\end{verbatim} -\end{quote} -Notice that the {\tt w} of {\tt where} on the second line lines up -under the {\tt =} on -the first line. Similarly, the {\tt c} on the third line is aligned under the -final letter of {\tt where} on the second line. The result as typeset must -get the indentation correct like this: -\begin{quote} -\begin{tabbing} -foobar a b = c\\ -\newbox\foo -{\setbox\foo\hbox{foobar a b }\hskip\wd\foo}where\\ -{\setbox\foo\hbox{foobar a b wher}\hskip\wd\foo}c = (a, b) -\end{tabbing} -\end{quote} - -For internal indentation, the program must first recognise where it has -occurred. It must then insert the correct amount of space to get alignment -in the output. As \LaTeX\ uses variable-width characters, extra space -may be needed in lines preceding a line within an internal alignment section. -This is necessary if a lower line which -aligns in the input file is longer up to the alignment point, -due to the variable-width characters, than its predecessors -once it has been properly typeset. For example: -\begin{quote} -\begin{verbatim} -lilli :: a -wmwm :: b -\end{verbatim} -\end{quote} -becomes -\begin{quote} -\begin{tabular}[t]{@{}l@{\ }c@{\ }l} -lilli & :: & a\\ -wmwm & :: & b\\ -\end{tabular} -\end{quote} -Notice how {\tt lilli} is longer than {\tt wmwm} in the input file style -using fixed-width font but shorter when using the variable-width font -of the typeset output. diff --git a/ghc/CONTRIB/pphs/docs/Faults.tex b/ghc/CONTRIB/pphs/docs/Faults.tex deleted file mode 100644 index 1c38984bb7..0000000000 --- a/ghc/CONTRIB/pphs/docs/Faults.tex +++ /dev/null @@ -1,66 +0,0 @@ -\chapter{Things that don't work} \label{faults} - -The {\tt pphs} program has some deficiencies that cause it to not always produce the -correct code. These are detailed in this chapter. - -\section{Internal alignment} - -The program can deal only with simple internal alignment. It cannot deal with a -situation where there is more than one column where internal alignment is occurring -on the same line. This can occur when two sections of internal -alignment overlap by having lines in common or where one section is wholly within another. -When this happens, {\tt pphs} will only -line up one occurrence of internal alignment on each line. - -Related is left alignment under a section of internal alignment. Take this earlier example. -\begin{quote} -\input{Haskell_leftindent1} -\end{quote} -This is how this code is typeset by {\tt pphs}: -\begin{quote} -\input{LaTeX_leftindent1} -\end{quote} -Notice how the {\bf where} on the third line doesn't line up under the {\it gcd\/}$'$ on -the second. The reason for this -is the \LaTeX\ {\tt tabular} section does not respect any spaces that occur at the end -of the right hand edge of the left hand column such as those after -{\tt gcd x y} and instead moves the central column left -so it is only one space away from the longest piece of text in the left hand column, -in this case {\iden gcd\/}\xspa1 {\iden x\/}\xspa1 {\iden y\/}. -The left indentation of the lines under the internal alignment section does not take this -movement into account and so if a line is indented beyond the end of the text in the first -column of the last line of the internal alignment section then it may be incorrectly -positioned and therefore will not align with what it was aligned with in the original -program. Should a piece of text in the left hand column be longer once typeset than what was -previously the longest, due to the variable-width characters used by \LaTeX , -then the second and third columns will get moved to the right, and so, similarly, -any code indented under the other columns will be wrongly positioned. - -Where a section of internal alignment coincides with the bottom of the user's page, -it can run off the bottom of the page. This is because the {\tt tabular} environment -used for internal alignment sections does not allow pagebreaks. Therefore the pagebreak -will come after the section has been completed. - -\section{Mathematical symbols} - -Mathematical symbols are always written in math font. This means that where, say, -comments are re-defined to be in typewriter font, as in the following -example, any mathematical symbols in the comments -will appear in math font, rather than typewriter font. -\begin{quote} -\def\com{\tt} -\input{LaTeX_comment} -\end{quote} - -\section{Left indentation} - -Where a line is indented beyond the end of its predecessor and aligns under another -line, but when typeset, the predecessor becomes longer than the indentation level -due to the variable-width characters, the line's indentation will appear to be under the -predecessor line. - -\section{Floating point numbers} - -Currently {\tt pphs} will recognise strings such as {\tt 3.} or {\tt 5.6e} as -valid floating point numbers. This needs rectifying so only valid floating -point numbers are recognised. \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Future_Work.tex b/ghc/CONTRIB/pphs/docs/Future_Work.tex deleted file mode 100644 index 4bf7b89692..0000000000 --- a/ghc/CONTRIB/pphs/docs/Future_Work.tex +++ /dev/null @@ -1,30 +0,0 @@ -\chapter{Things remaining to be implemented} - -Due to pressure of time, not everything that was planned to be included in -{\tt pphs} was implemented. This chapter details these things. - -\section{Faults} - -The faults detailed in Chapter~\ref{faults} remain to be rectified. The fault -regarding multiple columns of internal alignment would, it seems, require a -major rethink on the way internal alignment is handled by {\tt pphs}, perhaps -using the {\tt tabbing} environment with tabs and tabstops, rather than the -{\tt tabular} environment as at present. This could also -be extended to left indentation to solve the problem with indentation under -internal alignment section. Elimination of the {\tt tabular} sections would solve -the problem of pagebreaks during internal alignment sections. - -\section{Parsing} - -Currently, {\tt pphs} only does limited parsing. This could be altered to -give a full parse by restructuring into Lex. This would be better because -it would allow sections of code to be classified more easily once they were -broken down. - -\section{Literate Haskell} - -It has been suggested that {\tt pphs} be extended to accept Literate Haskell -files as input. This is where the program code lines all start with {\tt >} -and plain text is written between sections of code to document the file. -This would be called by an additional option, say {\tt -l}, and would typeset -the sections of Haskell code, whilst leaving the text sections alone. \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Haskell_char.tex b/ghc/CONTRIB/pphs/docs/Haskell_char.tex deleted file mode 100644 index 265b063bce..0000000000 --- a/ghc/CONTRIB/pphs/docs/Haskell_char.tex +++ /dev/null @@ -1,7 +0,0 @@ -\begin{verbatim} --- Character functions - -minChar, maxChar :: Char -minChar = '\0' -maxChar = '\255' -\end{verbatim} \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Haskell_internalalign1.tex b/ghc/CONTRIB/pphs/docs/Haskell_internalalign1.tex deleted file mode 100644 index b4942bb9c2..0000000000 --- a/ghc/CONTRIB/pphs/docs/Haskell_internalalign1.tex +++ /dev/null @@ -1,12 +0,0 @@ -% From Haskell report PreludeComlex.hs -\begin{verbatim} -instance (RealFloat a) => Num (Complex a) where - (x:+y) + (x':+y') = (x+x') :+ (y+y') - (x:+y) - (x':+y') = (x-x') :+ (y-y') - (x:+y) * (x':+y') = (x*x'-y*y') :+ (x*y'+y*x') - negate (x:+y) = negate x :+ negate y - abs z = magnitude z :+ 0 - signum 0 = 0 - signum z@(x:+y) = x/r :+ y/r where r = magnitude z - fromInteger n = fromInteger n :+ 0 -\end{verbatim} \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Haskell_internalalign2.tex b/ghc/CONTRIB/pphs/docs/Haskell_internalalign2.tex deleted file mode 100644 index 80d17b6a16..0000000000 --- a/ghc/CONTRIB/pphs/docs/Haskell_internalalign2.tex +++ /dev/null @@ -1,4 +0,0 @@ -\begin{verbatim} -fst :: (a,b) -> a -fst (x,_) = x -\end{verbatim} diff --git a/ghc/CONTRIB/pphs/docs/Haskell_leftindent1.tex b/ghc/CONTRIB/pphs/docs/Haskell_leftindent1.tex deleted file mode 100644 index aac11d82e8..0000000000 --- a/ghc/CONTRIB/pphs/docs/Haskell_leftindent1.tex +++ /dev/null @@ -1,7 +0,0 @@ -\begin{verbatim} -gcd :: Int -> Int -> Int -gcd x y = gcd' (abs x) (abs y) - where gcd' x 0 = x - gcd' x y = gcd' y (x `rem` y) -\end{verbatim} - diff --git a/ghc/CONTRIB/pphs/docs/Haskell_leftindent2.tex b/ghc/CONTRIB/pphs/docs/Haskell_leftindent2.tex deleted file mode 100644 index 09533c8a08..0000000000 --- a/ghc/CONTRIB/pphs/docs/Haskell_leftindent2.tex +++ /dev/null @@ -1,9 +0,0 @@ -% From cvh/Public/GBC/Source/Gm7.hs -\begin{verbatim} -eval :: GmState -> [GmState] -eval state = state: restStates - where - restStates | gmFinal state = [] - | otherwise = eval nextState - nextState = doAdmin (step state) -\end{verbatim} diff --git a/ghc/CONTRIB/pphs/docs/Haskell_math.tex b/ghc/CONTRIB/pphs/docs/Haskell_math.tex deleted file mode 100644 index 2e67e31e05..0000000000 --- a/ghc/CONTRIB/pphs/docs/Haskell_math.tex +++ /dev/null @@ -1,5 +0,0 @@ -\begin{verbatim} --- list concatenation (right-associative) -(++) :: [a] -> [a] -> [a] -xs ++ ys = foldr (:) ys xs -\end{verbatim} \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Haskell_simple.tex b/ghc/CONTRIB/pphs/docs/Haskell_simple.tex deleted file mode 100644 index 4ca2bb50c7..0000000000 --- a/ghc/CONTRIB/pphs/docs/Haskell_simple.tex +++ /dev/null @@ -1,5 +0,0 @@ -\begin{verbatim} -foobar a b = c - where - c = a + b -\end{verbatim} \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Haskell_string1.tex b/ghc/CONTRIB/pphs/docs/Haskell_string1.tex deleted file mode 100644 index 0284da1e3c..0000000000 --- a/ghc/CONTRIB/pphs/docs/Haskell_string1.tex +++ /dev/null @@ -1,8 +0,0 @@ -\begin{verbatim} --- File and channel names: - -stdin = "stdin" -stdout = "stdout" -stderr = "stderr" -stdecho = "stdecho" -\end{verbatim} \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Haskell_typewriter.tex b/ghc/CONTRIB/pphs/docs/Haskell_typewriter.tex deleted file mode 100644 index a8518c3e76..0000000000 --- a/ghc/CONTRIB/pphs/docs/Haskell_typewriter.tex +++ /dev/null @@ -1,7 +0,0 @@ -\begin{verbatim} -Horrible typewriter font - where - everything is the same - fixed width characters - no highlighting -\end{verbatim} \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/How.tex b/ghc/CONTRIB/pphs/docs/How.tex deleted file mode 100644 index 10120131f8..0000000000 --- a/ghc/CONTRIB/pphs/docs/How.tex +++ /dev/null @@ -1,465 +0,0 @@ -\chapter{How it does it} - -This chapter explains in detail how the program {\tt pphs} was implemented -from a programmer's viewpoint. It was implemented in the C programming -language, as this is a commonly used language often used for writing UNIX tools. -The program code is shown in Appendix~\ref{prog-code} and the makefile in -Appendix~\ref{make-code}. - -\section{General sequence of events} - -When the {\tt pphs} program is run, the program first finds out what, if any, -options it has been called with. If any have been specified, the appropriate -variables are set. The program then checks it has been called with exactly one -further argument. If not, the program terminates with an -explanatory error message. If called correctly, the program then checks that the -supplied argument is the name of a file that exists and is readable. -The program is normally used -on files ending with a {\tt .hs} extension. When called with a filename -with no extension and that file is not found, then it appends the extension and searches -for that file. If no file with that name is found or the file is unreadable, an -error message is produced and the program terminates. If the file is found, the -program starts the typesetting process by writing out the opening -\LaTeX\ command to {\tt stdout}. -This defines the \LaTeX\ environment which the program exploits to do the typesetting. -It then initialises the variables used in the program. - -This done, the first character is read. The program enters a loop and keeps -reading characters until the end of the file is reached. As each character is read -in, its typeface is established and it is stored with its typeface in something -called the {\em line store\/}. If any left indentation is -encountered, the correct characters to be skipped are identified from the {\em left -indentation stack} and copied into the line store. Internal alignment is checked -for and if any is found, appropriate variables are set accordingly. Each stored line is -added to both the left indentation stack and the {\em writing queue}. When the value of the -internal alignment changes, or it has been established that the first line in the writing -queue is not part of any internal alignment section, the lines in the queue are written out. - -Once all the lines are written out, {\tt pphs} then writes the closing \LaTeX\ command -and terminates. - -\section{Basic storage unit for a line of code} \label{line-store} - -The basic storage unit used in {\tt pphs} is the line store unit. -This stores the details of one line of Haskell code. These are -the characters on the line, the typeface associated with each -character, the length of the line, the indentation level and the position of -any internal alignment in the line. - -In the C program, {\tt ElementType} is the structure used for this type. This has -five parts: -\begin{itemize} -\item {\tt chars} which stores the characters used on the line of Haskell -code - -\item {\tt typeface} which stores the typeface values associated with the -characters on that line - -\item {\tt indentation} which stores the level of the line's indentation - -\item {\tt length} which stores the length of the line - -\item {\tt col} which stores the column where any internal alignment occurs or -is set to {\tt 0} if there is none -\end{itemize} -The variable {\tt store} in the main program is of type {\tt ElementType} and -is used as the basic storage unit for the current line. Its C declaration is -\begin{quote} -\begin{verbatim} -typedef struct ElementType_Tag { - char chars[MAXLINELENGTH]; - enum face typeface[MAXLINELENGTH]; - int indentation, length, col; -} ElementType; -\end{verbatim} -\end{quote} - -\section{Stack of lines for left indentation} - -Due to \LaTeX 's variable width characters, {\tt pphs} cannot simply uses spaces -for the left indentation as in the input Haskell file. It has to work out how far -each line is indented by finding out what it is indented under. As each line is -completed, it is added to a stack of lines, each line being stored in a basic -storage unit. If the line at the top of the stack is of a greater or equal -indentation level and of a lesser or equal length, then it is no -longer required for calculating typeset indentation -and can be disposed of. Once all lines of greater indentation level have been removed -from the top of the stack, the current line can then be added. - -When a line's indentation level, in terms of the number of spaces used in the -input, has been determined, {\tt pphs} has to find -out the characters that determine the actual typeset length of the indentation. To get this, -{\tt pphs} looks down the stack until it comes to a line whose indentation is less than -that of the current line and whose length is greater than the indentation level of the -current line. Once a suitable line is found, its characters and typefaces are copied -into the line store of the current line; then the rest of the current line is read in, -overwriting the characters beyond the indentation level. If there is no line preceding -the current one that is as long as the indentation level of the current line, spaces -are placed in the line store instead. - -A special case has been made for left indentation. Most of the time, the left-hand edge -of the characters will be aligned, but where a {\tt |} is aligned under an {\tt =} sign, it is -centered under the sign. This will be the case for any further {\tt |} symbols aligned -under this {\tt =} sign. - -The type {\tt StackType} is used in the program for the stack. This makes a stack of -the basic line storage units of {\tt ElementType}, together with a set of functions available -for use with stacks. These are {\tt CreateStack}, which returns an empty stack; -{\tt IsEmptyStack}, which returns {\tt 1} if the stack which it is called with is empty, -{\tt 0} otherwise; {\tt Push}, which takes a stack and an element and returns the stack -with the element pushed onto the top; {\tt Top}, which takes a stack and returns the top -element of the stack; {\tt Pop}, which takes a stack and returns it with the top element -removed; and {\tt PopSym}, which is the same as {\tt Pop} except that it does not free the -memory used by the top element - this function was found necessary to fix a fault caused by -returning to a stack's previous state, having popped off elements in the interim period. - -\section{Internal alignment identification} - -Internal alignment is deemed to have occurred when a character matches the one -immediately above it, the preceding characters in both lines are spaces, and there is -more than one space preceding the character on at least one of the lines. - -To check for this in {\tt pphs}, the current position on the line, indicated by -the linecounter, must be greater than one because either the current line or -the previous line will be required to have two spaces before the current position. The current -line will be located in the line store and the previous line will be at the rear of the queue -of lines waiting to be written out. - -One special case has been implemented for internal alignment. This is to allow Haskell -type declarations, such as in the example below, to align with their corresponding function -definitions. -\begin{quote} -\input{Haskell_internalalign2} -\end{quote} -The {\tt =} sign can be under either the first or second {\tt :} symbol for the -internal alignment to be recognised. - -\section{Typefaces and mathematical characters} - -Each character has a typeface value associated with it. Normally, this will -indicate the type of token the character is part of, either keyword, identifier, -string, comment, number or maths symbol, but where Haskell uses an ASCII character -simulation of a mathematical character or some other special symbol, the typeface -value will indicate this as well. - -In the program, the typeface values are of the -enumerated type called {\tt face}, which has the values shown in Table~\ref{tf-val}. -They are used in the basic storage unit {\tt ElementType} in the {\tt typeface} part. - -\begin{table} -\begin{center} -\begin{tabular}{|c|l|} \hline -{\em value\/} & {\em indicates\/} \\ \hline -{\tt KW} & keyword \\ -{\tt ID} & identifier \\ -{\tt IE} & exponent identifier \\ -{\tt ST} & string \\ -{\tt SE} & exponent string \\ -{\tt CO} & comment \\ -{\tt CE} & exponent comment \\ -{\tt NU} & number \\ -{\tt NE} & exponent number \\ -{\tt MA} & maths \\ -{\tt SP} & space \\ -{\tt LC} & line comment \\ -{\tt RC} & regional comment begin \\ -{\tt CR} & regional comment end \\ -{\tt BF} & backwards/forwards quote \\ -{\tt FQ} & forwards quote \\ -{\tt EQ} & escape quote \\ -{\tt DQ} & double quote begin \\ -{\tt QD} & double quote end \\ -{\tt EE} & escape double quote \\ -{\tt DC} & second part of double character \\ -{\tt DP} & double plus \\ -{\tt CP} & colon plus \\ -{\tt LE} & less than or equal to \\ -{\tt GE} & greater than or equal to \\ -{\tt LA} & left arrow \\ -{\tt RA} & right arrow \\ -{\tt RR} & double right arrow \\ -{\tt TI} & times \\ -{\tt EX} & double exponent character \\ -{\tt XP} & exponent \\ -{\tt BE} & bar aligned under equals \\ \hline -\end{tabular} -\end{center} -\caption{Typeface values} \label{tf-val} -\end{table} - -\subsection{Current character and retrospective update} - -The {\tt pphs} program has to determine the typeface of a character without knowledge of the -characters to follow. Therefore it allocates the value depending on the status -of various boolean variables. This may subsequently be found to be wrong once the remaining -characters of that token have been read. - -In the case of keywords and double characters, these are only identifiable -as such once all the characters of the token have been read in. Having established -the existence of a keyword or double character, {\tt pphs} then goes back and changes -the typeface values for the appropriate characters. - -The functions {\tt CheckForDoubleChar} and {\tt CheckForKeyword} perform this in the -program. - -\section{Writing lines out} - -Lines are written to {\tt stdout}, but not immediately on being read in. Instead they -are held back while it is established whether or not they form part of a section of -internal alignment. - -Before any typeset Haskell code is written, {\tt pphs} writes an opening \LaTeX\ command -{\tt \char'134 begin\char'173 tabbing\char'175 } to {\tt stdout}. This defines the -\LaTeX\ environment that the typeset code will be written in. At the end, -{\tt \char'134 end\char'173 tabbing\char'175 } is written to terminate this -environment. - -\subsection{The line queue} - -Lines are stored in a queue while they are waiting to be written out. -The elements of the queue are the basic line storage units described in -Section~\ref{line-store}. - -In the program, the queue is of type {\tt QueueType} -and a set of functions related to queues is available. This set consists of -{\tt CreateQueue}, which returns an empty queue; {\tt IsEmptyQueue}, which takes -a queue and returns {\tt 1} if the queue is empty, {\tt 0} otherwise; {\tt LengthOfQueue}, -which takes a queue and returns its length; {\tt FrontOfQueue}, which takes a queue and -returns a pointer to its front element; {\tt RearOfQueue}, which takes a queue and returns -a pointer to its rear element; {\tt AddToQueue}, which takes a queue and an element and -returns the queue with the element added to the rear; {\tt TakeFromQueue}, which takes -a queue and returns the queue with the front element removed. - -The last line in the queue is inspected to search -for internal alignment; if any is found, the internal alignment variable of that -line is altered accordingly. - -\subsection{When lines are written} - -The queue is written out by the function {\tt WriteQueue} when a section of internal -alignment is commenced or terminated -or when it has been established that there is no internal alignment involving the first line -in the queue. If the section being written out has been found to have -no internal alignment, then the last line is retained -in the queue because it may form part of the next section of internal alignment. - -At the end of the input, {\tt WriteRestOfQueue} writes all the lines remaining in the queue. -This is because the last line of Haskell code will not form part of any further section of -internal alignment and can therefore be written out. Facilities -are provided in the function {\tt WriteLine} to avoid writing the last newline -character at the end of the Haskell -file, as this would create an unwanted blank line in the final document. - -\subsection{Writing a line} - -The function {\tt WriteLine} is used in {\tt pphs} to write out one line. This is -called from either {\tt WriteQueue} or {\tt WriteRestOfQueue} and is supplied with -a basic line storage unit containing the line needing to be written out together with a -flag stating whether or not a \LaTeX\ newline character is required. - -If a line has any left indentation, this is written out first by calling the function -{\tt WriteSkipover}. The rest of the line is then written out by {\tt WriteWords} -followed if necessary by the newline character. Both these functions are given -the current line in the line store. - -\subsection{Writing left indentation} - -As \LaTeX\ uses variable width characters, fixed width spaces cannot be used for the -left indentation. Instead, the width of the characters above the current line needs -to be skipped. The {\tt \char'134 skipover} command, defined in the {\tt pphs.sty} -style file (see Section~\ref{style-file}), is used by the function {\tt WriteSkipover} -to get \LaTeX\ to do this. The command is supplied with the typefaces and characters -in the lines above, and, with this, \LaTeX\ creates the correct amount of -indentation in the typeset result. The typefaces and characters are written in -braces as the argument to {\tt \char'134 skipover} by calling {\tt WriteStartFace}, -{\tt WriteChar}, {\tt WriteSpaces} and {\tt WriteFinishFace}. The typeface functions -are called with the typeface value whereas the other two are given the line store, -current position and where the end of the skipover section is. - -Using this specially defined {\tt \char'134 skipover} command avoids having to get -information back from \LaTeX , therefore keeping the information flow unidirectional. - -\subsection{Writing the rest of a line} - -The function {\tt WriteWords} writes out the indented line once any left indentation -has been dealt with. Starting at the indentation level of the line, it uses the functions -{\tt WriteStartFace}, {\tt WriteChar}, {\tt WriteSpaces} and {\tt WriteFinishFace} to -write out each character and its typeface. The typeface functions are called with -the typeface value whereas the other two are given the line store, current position -and where the end of the line is. - -\subsection{Writing \LaTeX\ typeface commands} - -Every character has a typeface associated with it, so at the start and finish of every -line and every time the current typeface changes, typeface commands have to be written -out. This is done by the functions {\tt WriteStartFace} and {\tt WriteFinishFace}. -They write the appropriate \LaTeX\ typeface commands according to the typeface values -given as shown in Table~\ref{tf-comms}. To avoid complications, double characters have -their typefaces written out as part of the character command, therefore they need no -further typeface commands. Similarly, the user-redefinable quote mark characters -have their typeface defined in their definitions, so do not need any more typeface -commands. - -\begin{table} -\begin{center} -\begin{tabular}{|c|l|l|} \hline % ``commands'' to be over two columns -{\em value\/} & \multicolumn{2}{c|}{\em commands\/} \\ \cline{2-3} - & {\em begin\/} & {\em end\/} \\ \hline -{\tt KW} & {\tt \char'173 \char'134 keyword} & {\tt \char'134 /\char'175 }\\ -{\tt ID} & {\tt \char'173 \char'134 iden} & {\tt \char'134 /\char'175 }\\ -{\tt IE} & {\tt \char'173 \char'134 iden} & {\tt \char'134 /\char'175 \$ }\\ -{\tt ST} & {\tt \char'173 \char'134 stri} & {\tt \char'134 /\char'175 }\\ -{\tt SE} & {\tt \char'173 \char'134 stri} & {\tt \char'134 /\char'175 \$ }\\ -{\tt CO} & {\tt \char'173 \char'134 com} & {\tt \char'134 /\char'175 }\\ -{\tt CE} & {\tt \char'173 \char'134 com} & {\tt \char'134 /\char'175 \$ }\\ -{\tt NU} & {\tt \char'173 \char'134 numb} & {\tt \char'134 /\char'175 }\\ -{\tt NE} & {\tt \char'173 \char'134 numb} & {\tt \char'134 /\char'175 \$ }\\ -{\tt MA} & {\tt \$ } & {\tt \$ }\\ -{\tt SP} & & \\ -{\tt LC} & & \\ -{\tt RC} & & \\ -{\tt CR} & & \\ -{\tt BF} & & \\ -{\tt FQ} & & \\ \hline -\end{tabular} \hskip3mm \begin{tabular}{|c|l|l|} \hline -{\em value\/} & \multicolumn{2}{c|}{\em commands\/} \\ \cline{2-3} - & {\em begin\/} & {\em end\/} \\ \hline -{\tt EQ} & & \\ -{\tt DQ} & & \\ -{\tt QD} & & \\ -{\tt EE} & & \\ -{\tt DC} & & \\ -{\tt DP} & & \\ -{\tt CP} & & \\ -{\tt LE} & & \\ -{\tt GE} & & \\ -{\tt LA} & & \\ -{\tt RA} & & \\ -{\tt RR} & & \\ -{\tt TI} & {\tt \$ } & {\tt \$ } \\ -{\tt EX} & {\tt \$ } & \\ -{\tt XP} & {\tt \$ } & \\ -{\tt BE} & & \\ \hline -\end{tabular} -\end{center} -\caption{Typeface values and related \LaTeX\ commands} \label{tf-comms} -\end{table} - -\subsection{Writing characters} - -{\tt WriteChar} is the function which handles writing characters. It takes the line store, -the current position on the line and the end of the current section - either the skipover -section or the writing section - and returns the current position on the line which will -have been incremented if a double character has been written. If the first character of -a double character is the last character of a skipover section, it will not be written -so the indentation for that line will fall instead, below the start of the double -character in a line above. Most characters are written out as they were inputted, -but many require special \LaTeX\ code. - -As \LaTeX\ uses embedded typesetting commands, some characters are reserved for this -purpose. Should any of these characters appear in the input Haskell code, {\tt pphs} -has to produce the appropriate \LaTeX\ code to avoid these characters upsetting the typesetting -process. The characters and the replacement \LaTeX\ code are shown in Table~\ref{rep-chars}. -\begin{table} -\begin{center} -\begin{tabular}{|c|l|} \hline -{\em input\/} & {\em \LaTeX\ code output } \\ \hline -{\tt \#} & {\tt \char'134 \#} \\ -{\tt \$} & {\tt \char'134 \$} \\ -{\tt \%} & {\tt \char'134 \%} \\ -{\tt \&} & {\tt \char'134 \&} \\ -{\tt \char'176 } & {\tt \char'134 char'176 } \\ -{\tt \_} & {\tt \char'134 \_} \\ -{\tt \char'134} & {\tt \char'134 hbox\char'173 \$setminus\$\char'175 } \\ -{\tt \char'173} & {\tt \char'134 hbox\char'173 \$\char'134 cal \char'134 char'146 \$\char'175 } \\ -{\tt \char'175} & {\tt \char'134 hbox\char'173 \$\char'134 cal \char'134 char'147 \$\char'175 } \\ -{\tt *} & {\tt \char'134 times}\\ \hline -\end{tabular} \hskip3mm \begin{tabular}{|c|l|} \hline -{\em input\/} & {\em \LaTeX\ code output } \\ \hline -{\tt ++} & {\tt \char'134 plusplus}\\ -{\tt :+} & {\tt \char'173 :\char'175 \char'173 +\char'175}\\ -{\tt <=} & {\tt \$\char'134 leq\$}\\ -{\tt >=} & {\tt \$\char'134 geq\$}\\ -{\tt <-} & {\tt \$\char'134 leftarrow\$}\\ -{\tt ->} & {\tt \$\char'134 rightarrow\$}\\ -{\tt =>} & {\tt \$\char'134 Rightarrow\$}\\ -{\tt \char'173 -} & {\tt \char'173 \char'134 com \char'134 \char'173 -\char'134 /\char'175 }\\ -{\tt -\char'175 } & {\tt \char'173 \char'134 com -\char'134 \char'175 \char'134 /\char'175 }\\ -{\tt --} & {\tt \char'173 \char'134 rm -\char'175 \char'173 \char'134 rm -\char'175 }\\ \hline -\end{tabular} -\end{center} -\caption{Haskell input and replacement \LaTeX\ code} \label{rep-chars} -\end{table} - -When a mathematical character needs written, {\tt WriteChar} outputs the \LaTeX\ code for -the character rather than the Haskell ASCII character simulation. Some of these -simulations use more than one character, so this could cause problems if some left -indentation is aligned under the second character of such a simulation. It has been -decided that in this case, the output from {\tt pphs} will cause the indented line -to align under the start of the double character rather than the centre or end of it. -The Haskell ASCII simulations and the \LaTeX\ codes that replaces them are shown in -Table~\ref{rep-chars}. The non-standard command {\tt \char'134 plusplus} is defined -in the {\tt pphs.sty} style file (see Section~\ref{style-file}). - -When a {\tt |} symbol is aligned under an {\tt =} sign at the left indentation, -{\tt \char'134 bareq} is output. This command is defined in the {\tt pphs.sty} -style file explained in Section~\ref{style-file} and causes \LaTeX\ to write the bar symbol -centrally in the space it would have taken to write an equals sign, thereby causing -the bar to be positioned centrally under the equals sign it is aligned under and the text -following the bar to align with that after the equals sign. - -For writing spaces, {\tt WriteSpaces}, called with the line store, current position and the -position of the end of the current section, first counts the number of consecutive spaces -to be written before writing out a {\tt \char'134 xspa} command with an argument of -the number of spaces needed. This makes the output code easier to read. The -{\tt \char'134 xspa} command is defined in the {\tt pphs.sty} style file explained -in Section~\ref{style-file}. Any tab characters are treated as spaces by {\tt pphs} -with the number of spaces they represent being calculated from the current position -on the line and the {\tt tablength} variable, which may have been changed from its -default of 8 by the {\tt -t} option at the program call. - -Numbers are written by {\tt WriteChar}, including floating point numbers. - -As \LaTeX\ provides several different quote marks, it was decided that the user -should be able to choose a preferred symbol. An input quote mark {\tt '} can -either be a prime or a quote mark in the output. This requires the program to -determine which it is. In program code this is fine, but in comments or strings -the marks won't necessarily be used in a manner from which it can easily be -determined which symbol is required. In program code, an input {\tt '} is deemed -to be a quote mark if either it is preceded by punctuation or a quote has -already been opened; otherwise it is a prime. Of the quote marks, these can -either be for actual quotes or an escape quote where a quote mark is being quoted. -Special cases has been implemented when the input file contains a quote within a comment -started with a backquote and ended with a forwards quote, and for \LaTeX\ style -quotes in comments started with two backquotes and ended with two forwards quote -marks. All input {\tt '} in strings, other than escape quotes, are treated -as primes. In strings, an input {\tt '} may be an apostrophe, however, there is -little way of telling this.\label{string-apostrophe} One of five different pieces -of \LaTeX\ code can be produced having received {\tt '} as input. -\begin{itemize} -\item {\tt \char'134 forquo} for a forwards quote mark -\item {\tt \char'134 escquo} for an escape (quoted) quote mark -\item {\tt \char'173 \char'134 com '\char'134 /\char'175 } for a forward quote ending a quote -in a comment opened by a backquote -\item {\tt \char'173 \char'134 com ''\char'134 /\char'175 } for two forward quotes ending a quote -in a comment opened by two backquotes -\item {\tt '} for a prime which will be in the math font -\end{itemize} -The first two are commands defined in the {\tt pphs.sty} style file and are -thus user-redefinable as described in Section~\ref{user-adj}. Backquotes, input -as {\tt `}, are either in the comment typeface for backquotes in comments or in -math font elsewhere. - -\subsection{Writing internal alignment} - -To commence a section of internal alignment, either of the functions {\tt WriteQueue} -or {\tt WriteRestOfQueue} write out -{\tt \char'134 begin\char'173 tabular\char'175 \char'173 @\char'173 \char'175 l@\char'173 \char'134 xspa1\char'175 c@\char'173 \char'175 l\char'175 } -before writing the first line of the section. This provides an environment -with three columns. The first column accommodates the Haskell code to the left of the -internal alignment, the second has the symbols that line up vertically, while the third -has the Haskell code to the right. The Haskell code is written complete with its \LaTeX\ -typesetting commands with the addition of {\tt \&} symbols denoting the breaks between -columns. Once the internal alignment section has been completed, the -{\tt \char'134 end\char'173 tabular\char'175 } command is written to terminate the -environment. \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Introduction.tex b/ghc/CONTRIB/pphs/docs/Introduction.tex deleted file mode 100644 index 141fb5940b..0000000000 --- a/ghc/CONTRIB/pphs/docs/Introduction.tex +++ /dev/null @@ -1,137 +0,0 @@ -\chapter{Introduction} - -Documents, such as papers for publication, often include sections -of program code. These have to be specially typeset, as default -typesetting modes are generally intended for plain prose. -It is therefore useful to have a special-purpose system for typesetting -programs for inserting into documents. -Haskell \cite{Haskell-report} is a fairly new functional programming language and does not -yet have a full range of tools available to use with the language, -including one to do typesetting. -The goal of this project, therefore, is to provide a tool to automatically -typeset Haskell programs. - -Many people use the \LaTeX\ system \cite{LaTeX-book} -for typesetting. This uses -embedded typesetting commands in the input to arrange the typesetting. -The typeset result has variable-width characters with a choice of -font styles and sizes available. The page-size, margins and layout -are also controllable by the user. Because \LaTeX\ is so widely used and -so flexible, the tool to be created will be -for use with the \LaTeX\ system. - -Haskell programs are generally written with editors that produce ASCII -text. This has fixed-width characters and one plain font. -Indentation and vertical alignment are simple because -fixed-width characters line up in columns, one below the other. -Haskell avoids having compulsory expression terminators -by using such indentation to delimit expressions. It is thus crucial -that this indentation is retained when the text is typeset. - -The \LaTeX\ system, however, uses variable-width characters, so the indentation -level becomes dependent on the characters under which the text is aligned. -The tabs and spaces that went to make -up the indentation in the original file have to be replaced with a -suitable amount of space to make the text line up with the position -it is aligned with in the original file. - -It is also desirable to have formatting improvements, such as -highlighting keywords and identifiers, as well as to have -proper mathematical characters inserted in place of the -Haskell ASCII approximations. A tool could do this as well. - -Currently the only way of typesetting Haskell program code is to -labouriously insert formatting -commands into the text by hand. The alternative is to print out the programs -verbatim with a plain ASCII-style fixed-width font, but it would be far better -if there were a tool to do the proper typesetting. - -\subsection*{Goals} - -The proposed tool is required to comply to the following requirements: -\begin{itemize} -\item The program must take a file with a Haskell program in it and produce -\LaTeX\ code to stdout. This code must produce the input Haskell program in -typeset style when run through -the \LaTeX\ program. The typeset result must be recognisable as having the same -layout as the input file's Haskell program had. - -\item The typeset result must preserve the parse of the program. - -\item The input file will contain only Haskell code. Any documentation in the file -will be in the form of comments. - -\item The input file will not have any embedded typesetting commands, so -the program must analyse the input and decide for itself what needs to be -done to produce the correct \LaTeX\ code. - -\item The \LaTeX\ code produced must be easy to incorporate into a \LaTeX\ -document such as a paper or book. Thus the produced code must be able -to be incorporated into documents of different page and font sizes. - -\item Keywords and identifiers must be highlightable so as to distinguish -them from the rest of the Haskell program. -The user should be allowed some choice in the typeface used for -highlighting. - -\item Proper mathematical symbols must replace ASCII approximations in the -typeset output. - -\item The program must accept as input -a file of any name and thus not use an inflexible built-in filename. - -\item The program must be in keeping with conventional UNIX style to fit in with -Haskell and \LaTeX , which are also run under UNIX. -\end{itemize} - -\noindent This report describes a program written to satisfy these needs. - -\subsection*{Background} - -Haskell, being a functional programming language, uses functions as its -sole means of programming. This is unlike traditional programming -languages such as C or Pascal, where assignments and procedures are also used. -Haskell also does not normally use expression terminators, such as semi-colons, -but instead relies on the layout of the -program and, in particular, the indentation to determine the context of -lines of code. Lines of code are positioned so they are aligned under particular -points on preceding lines, and this delimits expressions. It is thus -imperative that this indentation be replicated in any attempt to pretty-print -the program code. - -\LaTeX\ is a typesetting program that takes a file with embedded typesetting -commands and produces a file containing typeset text. This is commonly used when -writing documents such as papers and books for publication. Users of \LaTeX\ -can do many things, but anything fancy requires lots of typesetting commands to -be embedded into the input file. Thus typesetting a Haskell program in the -desired way is a considerable task. More simply, a -Haskell program can be displayed in \LaTeX's verbatim mode, but this uses a fixed-width -typewriter font. Verbatim mode does not recognise tab characters, however these can be -replaced with spaces. - -It will be assumed that the user is familiar with Haskell and at least familiar with -preparing basic textual documents with \LaTeX, although it is not required for the -user to understand many of the more involved parts of typesetting with \LaTeX. - -Already in existence is a program called `Phinew' written by Phil Wadler. -This can be found in {\tt \char'176 wadler/bin}. This required the user to supply -typesetting commands embedded in their Haskell programs, meaning that the -user would have to manually pre-process their Haskell code before using -Phinew. Although simpler -than typesetting in \LaTeX, it is still better to have a program -to do all the typesetting automatically, taking an unprepared Haskell -program as input. - -\subsection*{Outline} - -In the remaining sections of this report the functionality of the program written -are discussed; in particular, how all the various layout arrangements are dealt with. The way -in which the program goes about working out what to do is explained, -along with descriptions of the algorithm and data-structures used. Examples -of the input and resulting output are used to illustrate the capabilities -of the program. The various possibilities for the user to decide what happens -are explained, along with details on how to exploit them. The user will -need to know how to incorporate the results into a document so this -is also explained. Finally, the limitations and deficiencies of the -program are detailed complete with an outline of further possible work -which could rectify these problems and make the program more complete. diff --git a/ghc/CONTRIB/pphs/docs/LaTeX-code_simple.tex b/ghc/CONTRIB/pphs/docs/LaTeX-code_simple.tex deleted file mode 100644 index 8110ca4a16..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX-code_simple.tex +++ /dev/null @@ -1,12 +0,0 @@ -\begin{verbatim} -\begin{tabbing} -{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/} - \xspa{1}$=$\xspa{1}{\iden c\/}\\ -\skipover{{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1} - {\iden b\/}\xspa{1}}{\keyword where\/}\\ -\skipover{{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1} - {\iden b\/}\xspa{1}{\keyword wher\/}}{\iden c\/} - \xspa{1}$=$\xspa{1}{\iden a\/}\xspa{1}$+$\xspa{1} - {\iden b\/} -\end{tabbing} -\end{verbatim} \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_blankline.tex b/ghc/CONTRIB/pphs/docs/LaTeX_blankline.tex deleted file mode 100644 index 1c1a67fe91..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX_blankline.tex +++ /dev/null @@ -1,6 +0,0 @@ -\begin{tabbing} -{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/}\xspa{1}$=$\xspa{1}{\iden c\/}\\ -\skipover{{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/}\xspa{1}}{\keyword where\/}\\ -\skipover{{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/}\xspa{1}{\keyword wher\/}}{\iden c\/}\xspa{1}$=$\xspa{1}{\iden a\/}\xspa{1}$+$\xspa{1}{\iden b\/}\\ -\skipover{{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/}\xspa{1}{\keyword wher\/}} -\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_char.tex b/ghc/CONTRIB/pphs/docs/LaTeX_char.tex deleted file mode 100644 index 7b5a7c83c6..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX_char.tex +++ /dev/null @@ -1,9 +0,0 @@ -\begin{tabbing} -{\rm -}{\rm -}\xspa{1}{\com Character\/}\xspa{1}{\com functions\/}\\ -\\ -\begin{tabular}{@{}l@{\xspa1}c@{}l} -{\iden minChar\/}$,$\xspa{1}{\iden maxChar\/}\xspa{8} & $::$ & \xspa{1}{\iden Char\/}\\ -{\iden minChar\/}\xspa{17} & $=$ & \xspa{1}\forquo {\stri \hbox{$\setminus$}\/}{\numb 0\/}\forquo \\ -{\iden maxChar\/}\xspa{17} & $=$ & \xspa{1}\forquo {\stri \hbox{$\setminus$}\/}{\numb 255\/}\forquo -\end{tabular} -\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_comment.tex b/ghc/CONTRIB/pphs/docs/LaTeX_comment.tex deleted file mode 100644 index 324be0b648..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX_comment.tex +++ /dev/null @@ -1,3 +0,0 @@ -\begin{tabbing} -{\rm -}{\rm -}\xspa{1}{\com note\/}\xspa{1}{\com that\/}\xspa{1}{\com x\/}\xspa{1}$+$\xspa{1}{\com y\/}\xspa{1}$=$\xspa{1}{\com z\/} -\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_internalalign1.tex b/ghc/CONTRIB/pphs/docs/LaTeX_internalalign1.tex deleted file mode 100644 index 069691a88d..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX_internalalign1.tex +++ /dev/null @@ -1,13 +0,0 @@ -\begin{tabbing} -\begin{tabular}{@{}l@{\xspa1}c@{}l} -{\keyword instance\/}\xspa{2}$(${\iden RealFloat\/}\xspa{1}{\iden a\/}$)$\xspa{1} & $\Rightarrow$ & \xspa{1}{\iden Num\/}\xspa{1}$(${\iden Complex\/}\xspa{1}{\iden a\/}$)$\xspa{2}{\keyword where\/}\\ -\skipover{{\keyword inst\/}}$(${\iden x\/}{:}{+}{\iden y\/}$)$\xspa{1}$+$\xspa{1}$(${\iden x\/}$'${:}{+}{\iden y\/}$')$\xspa{3} & $=$ & \xspa{2}$(${\iden x\/}$+${\iden x\/}$')$\xspa{1}{:}{+}\xspa{1}$(${\iden y\/}$+${\iden y\/}$')$\\ -\skipover{{\keyword inst\/}}$(${\iden x\/}{:}{+}{\iden y\/}$)$\xspa{1}$-$\xspa{1}$(${\iden x\/}$'${:}{+}{\iden y\/}$')$\xspa{3} & $=$ & \xspa{2}$(${\iden x\/}$-${\iden x\/}$')$\xspa{1}{:}{+}\xspa{1}$(${\iden y\/}$-${\iden y\/}$')$\\ -\skipover{{\keyword inst\/}}$(${\iden x\/}{:}{+}{\iden y\/}$)$\xspa{1}$\times $\xspa{1}$(${\iden x\/}$'${:}{+}{\iden y\/}$')$\xspa{3} & $=$ & \xspa{2}$(${\iden x\/}$\times ${\iden x\/}$'-${\iden y\/}$\times ${\iden y\/}$')$\xspa{1}{:}{+}\xspa{1}$(${\iden x\/}$\times ${\iden y\/}$'+${\iden y\/}$\times ${\iden x\/}$')$\\ -\skipover{{\keyword inst\/}}{\iden negate\/}\xspa{1}$(${\iden x\/}{:}{+}{\iden y\/}$)$\xspa{7} & $=$ & \xspa{2}{\iden negate\/}\xspa{1}{\iden x\/}\xspa{1}{:}{+}\xspa{1}{\iden negate\/}\xspa{1}{\iden y\/}\\ -\skipover{{\keyword inst\/}}{\iden abs\/}\xspa{1}{\iden z\/}\xspa{15} & $=$ & \xspa{2}{\iden magnitude\/}\xspa{1}{\iden z\/}\xspa{1}{:}{+}\xspa{1}{\numb 0\/}\\ -\skipover{{\keyword inst\/}}{\iden signum\/}\xspa{1}{\numb 0\/}\xspa{12} & $=$ & \xspa{2}{\numb 0\/}\\ -\skipover{{\keyword inst\/}}{\iden signum\/}\xspa{1}{\iden z@\/}$(${\iden x\/}{:}{+}{\iden y\/}$)$\xspa{5} & $=$ & \xspa{2}{\iden x\/}$/${\iden r\/}\xspa{1}{:}{+}\xspa{1}{\iden y\/}$/${\iden r\/}\xspa{2}{\keyword where\/}\xspa{1}{\iden r\/}\xspa{1}$=$\xspa{1}{\iden magnitude\/}\xspa{1}{\iden z\/}\\ -\skipover{{\keyword inst\/}}{\iden fromInteger\/}\xspa{1}{\iden n\/}\xspa{7} & $=$ & \xspa{2}{\iden fromInteger\/}\xspa{1}{\iden n\/}\xspa{1}{:}{+}\xspa{1}{\numb 0\/} -\end{tabular} -\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_leftindent1.tex b/ghc/CONTRIB/pphs/docs/LaTeX_leftindent1.tex deleted file mode 100644 index e668990f3d..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX_leftindent1.tex +++ /dev/null @@ -1,8 +0,0 @@ -\begin{tabbing} -\begin{tabular}{@{}l@{\xspa1}c@{}l} -{\iden gcd\/}\xspa{7} & $::$ & \xspa{1}{\iden Int\/}\xspa{1}$\rightarrow$\xspa{1}{\iden Int\/}\xspa{1}$\rightarrow$\xspa{1}{\iden Int\/}\\ -{\iden gcd\/}\xspa{1}{\iden x\/}\xspa{1}{\iden y\/}\xspa{4} & $=$ & \xspa{1}{\iden gcd\/}$'$\xspa{1}$(${\iden abs\/}\xspa{1}{\iden x\/}$)$\xspa{1}$(${\iden abs\/}\xspa{1}{\iden y\/}$)$\\ -\end{tabular}\\ -\skipover{{\iden gcd\/}\xspa{1}{\iden x\/}\xspa{1}{\iden y\/}\xspa{4}$=$\xspa{1}}{\keyword where\/}\xspa{1}{\iden gcd\/}$'$\xspa{1}{\iden x\/}\xspa{1}{\numb 0\/}\xspa{1}$=$\xspa{1}{\iden x\/}\\ -\skipover{{\iden gcd\/}\xspa{1}{\iden x\/}\xspa{1}{\iden y\/}\xspa{4}$=$\xspa{1}{\keyword where\/}\xspa{1}}{\iden gcd\/}$'$\xspa{1}{\iden x\/}\xspa{1}{\iden y\/}\xspa{1}$=$\xspa{1}{\iden gcd\/}$'$\xspa{1}{\iden y\/}\xspa{1}$(${\iden x\/}\xspa{1}$`${\iden rem\/}$`$\xspa{1}{\iden y\/}$)$ -\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_leftindent2.tex b/ghc/CONTRIB/pphs/docs/LaTeX_leftindent2.tex deleted file mode 100644 index d175774169..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX_leftindent2.tex +++ /dev/null @@ -1,8 +0,0 @@ -\begin{tabbing} -{\iden eval\/}\xspa{1}$::$\xspa{1}{\iden GmState\/}\xspa{1}$\rightarrow$\xspa{1}$[${\iden GmState\/}$]$\\ -{\iden eval\/}\xspa{1}{\iden state\/}\xspa{1}$=$\xspa{1}{\iden state\/}$:$\xspa{1}{\iden restStates\/}\\ -\skipover{{\iden eval\/}\xspa{1}{\iden state\/}\xspa{1}$=$\xspa{1}}{\keyword where\/}\\ -\skipover{{\iden eval\/}\xspa{1}{\iden state\/}\xspa{1}$=$\xspa{1}}{\iden restStates\/}\xspa{1}$|$\xspa{1}{\iden gmFinal\/}\xspa{1}{\iden state\/}\xspa{1}$=$\xspa{1}$[]$\\ -\skipover{{\iden eval\/}\xspa{1}{\iden state\/}\xspa{1}$=$\xspa{1}{\iden restStates\/}\xspa{1}}$|$\xspa{1}{\iden otherwise\/}\xspa{1}$=$\xspa{1}{\iden eval\/}\xspa{1}{\iden nextState\/}\\ -\skipover{{\iden eval\/}\xspa{1}{\iden state\/}\xspa{1}$=$\xspa{1}}{\iden nextState\/}\xspa{2}$=$\xspa{1}{\iden doAdmin\/}\xspa{1}$(${\iden step\/}\xspa{1}{\iden state\/}$)$ -\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_math.tex b/ghc/CONTRIB/pphs/docs/LaTeX_math.tex deleted file mode 100644 index 4b4198dde3..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX_math.tex +++ /dev/null @@ -1,7 +0,0 @@ -\begin{tabbing} -{\rm -}{\rm -}\xspa{1}{\com list\/}\xspa{1}{\com concatenation\/}\xspa{1}$(${\com right\/}$-${\com associative\/}$)$\\ -\begin{tabular}{@{}l@{\xspa1}c@{}l} -$($\plusplus$)$\xspa{20} & $::$ & \xspa{1}$[${\iden a\/}$]$\xspa{1}$\rightarrow$\xspa{1}$[${\iden a\/}$]$\xspa{1}$\rightarrow$\xspa{1}$[${\iden a\/}$]$\\ -{\iden xs\/}\xspa{1}\plusplus\xspa{1}{\iden ys\/}\xspa{16} & $=$ & \xspa{2}{\iden foldr\/}\xspa{1}$(:)$\xspa{1}{\iden ys\/}\xspa{1}{\iden xs\/} -\end{tabular} -\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_simple.tex b/ghc/CONTRIB/pphs/docs/LaTeX_simple.tex deleted file mode 100644 index 956fc496c7..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX_simple.tex +++ /dev/null @@ -1,5 +0,0 @@ -\begin{tabbing} -{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/}\xspa{1}$=$\xspa{1}{\iden c\/}\\ -\skipover{{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/}\xspa{1}}{\keyword where\/}\\ -\skipover{{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/}\xspa{1}{\keyword wher\/}}{\iden c\/}\xspa{1}$=$\xspa{1}{\iden a\/}\xspa{1}$+$\xspa{1}{\iden b\/} -\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_string1.tex b/ghc/CONTRIB/pphs/docs/LaTeX_string1.tex deleted file mode 100644 index 6472e1d6c1..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX_string1.tex +++ /dev/null @@ -1,10 +0,0 @@ -\begin{tabbing} -{\rm -}{\rm -}\xspa{1}{\com File\/}\xspa{1}{\com and\/}\xspa{1}{\com channel\/}\xspa{1}{\com names\/}$:$\\ -\\ -\begin{tabular}{@{}l@{\xspa1}c@{}l} -{\iden stdin\/}\xspa{7} & $=$ & \xspa{2}{\rm ``}{\stri stdin\/}{\rm "}\\ -{\iden stdout\/}\xspa{6} & $=$ & \xspa{2}{\rm ``}{\stri stdout\/}{\rm "}\\ -{\iden stderr\/}\xspa{6} & $=$ & \xspa{2}{\rm ``}{\stri stderr\/}{\rm "}\\ -{\iden stdecho\/}\xspa{5} & $=$ & \xspa{2}{\rm ``}{\stri stdecho\/}{\rm "} -\end{tabular} -\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_string2.tex b/ghc/CONTRIB/pphs/docs/LaTeX_string2.tex deleted file mode 100644 index 696a2b6666..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX_string2.tex +++ /dev/null @@ -1,10 +0,0 @@ -\begin{tabbing} -{\iden main\/}\xspa{1}$=$\xspa{1}{\iden appendChan\/}\xspa{1}{\iden stdout\/}\xspa{1}{\rm ``}{\stri please\/}\xspa{1}{\stri type\/}\xspa{1}{\stri a\/}\xspa{1}{\stri filename\hbox{$\setminus$}n\/}{\rm "}\xspa{1}{\iden exit\/}\xspa{1}$($\\ -\skipover{{\iden main\/}\xspa{1}$=$\xspa{1}}{\iden readChan\/}\xspa{1}{\iden stdin\/}\xspa{1}{\iden exit\/}\xspa{1}$(${\iden \hbox{$\setminus$}\/}\xspa{1}{\iden userInput\/}\xspa{1}$\rightarrow$\\ -\skipover{{\iden main\/}\xspa{1}$=$\xspa{1}}{\keyword let\/}\xspa{1}$(${\iden name\/}\xspa{1}$:$\xspa{1}{\iden \_\/}$)$\xspa{1}$=$\xspa{1}{\iden lines\/}\xspa{1}{\iden userInput\/}\xspa{1}{\keyword in\/}\\ -\skipover{{\iden main\/}\xspa{1}$=$\xspa{1}}{\iden appendChan\/}\xspa{1}{\iden stdout\/}\xspa{1}{\iden name\/}\xspa{1}{\iden exit\/}\xspa{1}$($\\ -\skipover{{\iden main\/}\xspa{1}$=$\xspa{1}}{\iden readFile\/}\xspa{1}{\iden name\/}\xspa{1}$(${\iden \hbox{$\setminus$}\/}\xspa{1}{\iden ioerror\/}\xspa{1}$\rightarrow$\xspa{1}{\iden appendChan\/}\xspa{1}{\iden stdout\/}\\ -\skipover{{\iden main\/}\xspa{1}$=$\xspa{1}{\iden readFile\/}\xspa{1}{\iden name\/}\xspa{1}$(${\iden \hbox{$\setminus$}\/}\xspa{1}{\iden ioerror\/}\xspa{1}$\rightarrow$\xspa{1}}{\rm ``}{\stri can\/}$'${\stri t\/}\xspa{1}{\stri open\/}\xspa{1}{\stri file\/}{\rm "}\xspa{1}{\iden exit\/}\xspa{1}{\iden done\/}$)$\\ -\skipover{{\iden main\/}\xspa{1}$=$\xspa{1}{\iden readFile\/}\xspa{1}{\iden name\/}\xspa{1}}$(${\iden \hbox{$\setminus$}\/}\xspa{1}{\iden contents\/}\xspa{1}$\rightarrow$\\ -\skipover{{\iden main\/}\xspa{1}$=$\xspa{1}}{\iden appendChan\/}\xspa{1}{\iden stdout\/}\xspa{1}{\iden contents\/}\xspa{1}{\iden exit\/}\xspa{1}{\iden done\/}$))))$ -\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_wide-colons.tex b/ghc/CONTRIB/pphs/docs/LaTeX_wide-colons.tex deleted file mode 100644 index 668ce57838..0000000000 --- a/ghc/CONTRIB/pphs/docs/LaTeX_wide-colons.tex +++ /dev/null @@ -1,9 +0,0 @@ -\begin{tabbing} -{\rm -}{\rm -}\xspa{1}{\com Character\/}\xspa{1}{\com functions\/}\\ -\\ -\begin{tabular}{@{}l@{\xspa1}c@{}l} -{\iden minChar\/}$,$\xspa{1}{\iden maxChar\/}\xspa{8} & $:\,:$ & \xspa{1}{\iden Char\/}\\ -{\iden minChar\/}\xspa{17} & $=$ & \xspa{1}\forquo {\stri \hbox{$\setminus$}\/}{\numb 0\/}\forquo \\ -{\iden maxChar\/}\xspa{17} & $=$ & \xspa{1}\forquo {\stri \hbox{$\setminus$}\/}{\numb 255\/}\forquo -\end{tabular} -\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/Problem_Definition.tex b/ghc/CONTRIB/pphs/docs/Problem_Definition.tex deleted file mode 100644 index 8659bcc8dd..0000000000 --- a/ghc/CONTRIB/pphs/docs/Problem_Definition.tex +++ /dev/null @@ -1,37 +0,0 @@ -\section{Problem definition} - -The problem is that a system is needed to typeset Haskell programs -to be inserted into documents. This would be useful in, for -instance, preparing papers for publication that are to include -Haskell programs. - -Haskell is a fairly new functional programming language and does not -as yet have a full range of tools available to use with the language. - -Many people use the \LaTeX\ system for typesetting. This uses -embedded typesetting commands in the input to arrange the typesetting. -The result as typeset has variable-width characters with a choice of -font styles and sizes available. The page-size, margins and layout -are also controllable by the user. - -Haskell programs are generally written on editors that produce ASCII -text. This has fixed-width characters and one plain font. - -In Haskell, the language avoids using -line terminators by having indentation to indicate the contextual meaning of -each line. It is thus crucial that this indentation is retained -when the text is put into \LaTeX. However as the \LaTeX\ system uses -variable width characters, the indentation -level is dependent on the characters under which the text is aligned. -The tabs and spaces that went to make -up the indentation in the original file have to be replaced with a -suitable amount of space to make the text line up with the position with which it -is aligned in the original file. - -It is also desirable to have -formatting improvements such as highlighting keywords and identifiers as well as -inserting proper mathematical characters in place of the Haskell-ASCII simulations. - -Currently the only way of doing this is by labouriously inserting formatting -commands into the text by hand. The alternative is to print out the programs -verbatim with plain ASCII-style fixed-width font. diff --git a/ghc/CONTRIB/pphs/docs/Project_Documents.tex b/ghc/CONTRIB/pphs/docs/Project_Documents.tex deleted file mode 100644 index 5833c2a032..0000000000 --- a/ghc/CONTRIB/pphs/docs/Project_Documents.tex +++ /dev/null @@ -1,7 +0,0 @@ -\chapter{Project documents} - -These are the original project documents from 19th January 1994. - -\input{Problem_Definition} -\input{Statement_Of_Requirements} -\input{External_Specification} diff --git a/ghc/CONTRIB/pphs/docs/Report.tex b/ghc/CONTRIB/pphs/docs/Report.tex deleted file mode 100644 index d37dd0d153..0000000000 --- a/ghc/CONTRIB/pphs/docs/Report.tex +++ /dev/null @@ -1,49 +0,0 @@ -\documentstyle[12pt,fleqn,rep,pphs]{report} -\renewcommand{August 1994} -\begin{document} - -\def\sect{\section} -\def\subsect{\subsection} - -% Title page -\title{Literate Haskell} -\author{A. Preece \\\\ University of Glasgow} -\maketitle - -\setcounter{page}{2} -\tableofcontents - -\input{Introduction} -\input{What} -\input{How} -\input{Uses} -\input{Error_Messages} -\input{Faults} -\input{Future_Work} - -\appendix - -\input{Project_Documents} -\input{User_Documents} -\input{Code} - -\begin{thebibliography}{9} -\addcontentsline{toc}{chapter}{Bibliography} - -\bibitem{Haskell-report} -Hudak, P., Peyton Jones, S., Wadler, P., et al., {\em Haskell, Report on the Programming Language\/} -(1992) - -\bibitem{LaTeX-book} -Lamport, L., {\em \LaTeX : A Document Preparation System\/} -(Addison-Wesley, 1986) - -\end{thebibliography} - -\chapter*{Acknowledgements} -\addcontentsline{toc}{chapter}{Acknowledgements} - -I am very grateful for the help and advise of Project Supervisor Tom Melham, -and also for the suggestions of Phil Wadler, Richard McPhee, and Mark Pollock. - -\end{document} diff --git a/ghc/CONTRIB/pphs/docs/Statement_Of_Requirements.tex b/ghc/CONTRIB/pphs/docs/Statement_Of_Requirements.tex deleted file mode 100644 index 00b8fd52e4..0000000000 --- a/ghc/CONTRIB/pphs/docs/Statement_Of_Requirements.tex +++ /dev/null @@ -1,32 +0,0 @@ -\section{Statement of requirements} - -There are various things that are required of the solution to the -problem described previously. -\begin{itemize} -\item The program must take a file with a Haskell program in it and produce -\LaTeX\ code to stdout. This code must produce that Haskell program in -typeset style when run through -the \LaTeX\ program. The result as typeset must be recognisable as having the same -layout as the input file's Haskell program had. - -\item The input file will contain only Haskell code. Any documentation in the file -will be in the form of comments. - -\item The input file will not have any embedded typesetting characters in it so -the program must analyse the input and decide for itself what needs to be -done to produce the correct \LaTeX\ code. - -\item The \LaTeX\ code produced must be easy to incorporate into a \LaTeX\ -document such as a paper or book. Thus the produced code must be able -to be incorporated into documents of different page and font size. - -\item Keywords and identifiers must be highlightable so as to distinguish -them from the rest of the Haskell program. -The user should be allowed some choice in the typeface used for -highlighting. - -\item Generality of use must be retained so as to allow the program to be used in conjunction -with a file of any name and thus not use an inflexible built-in filename. - -\item The program must be in keeping with conventional UNIX style. -\end{itemize} diff --git a/ghc/CONTRIB/pphs/docs/Title.tex b/ghc/CONTRIB/pphs/docs/Title.tex deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/ghc/CONTRIB/pphs/docs/UserGuide.tex b/ghc/CONTRIB/pphs/docs/UserGuide.tex deleted file mode 100644 index 5f46b0861a..0000000000 --- a/ghc/CONTRIB/pphs/docs/UserGuide.tex +++ /dev/null @@ -1,9 +0,0 @@ -\documentstyle[12pt,fleqn,a4,pphs]{report} -\begin{document} - -\def\sect{\section*} -\def\subsect{\subsection*} - -\input{UserGuide_Text} - -\end{document} diff --git a/ghc/CONTRIB/pphs/docs/UserGuide_Text.tex b/ghc/CONTRIB/pphs/docs/UserGuide_Text.tex deleted file mode 100644 index 5dc6999ce4..0000000000 --- a/ghc/CONTRIB/pphs/docs/UserGuide_Text.tex +++ /dev/null @@ -1,231 +0,0 @@ -\sect{User guide to {\tt pphs}} - -The program {\tt pphs} typesets programs in the Haskell programming -language for use with the \LaTeX\ intensional text formatting -and typesetting system. It takes -as input a file containing a Haskell program and produces \LaTeX\ -code to {\tt stdout}. There are various different features of this -process. - -\subsect{Left indentation} - -It is in the nature of Haskell programs that indentation is heavily used. As the -indentation is vital to the parsing of the program, any attempt at typesetting -Haskell code must replicate this indentation. Take, for example, the following piece of code. -\begin{quote} -\input{Haskell_leftindent2} -\end{quote} -Note how the third, fifth and sixth lines start at different levels of indentation. -The {\tt pphs} program produces the correct \LaTeX\ code to align these under the -correct position in the preceding lines once typeset. It also selects the correct -line to line up under. Note how the sixth line does not line up -under its predecessor, but under the fourth line. -The code necessary to typeset this is produced, preserving the parsing -order. Once typeset, it will look like this: -\begin{quote} -\input{LaTeX_leftindent2} -\end{quote} -Note that this -example of possible input had no `extra' typesetting commands. - -A line of Haskell code may be indented beyond the end of its predecessor. -Here, {\tt pphs} aligns it with whichever line it is lined up underneath in the -original file, or, if longer than any preceding line, inserts space to correspond -to that in the input file. - -\subsect{Internal alignment} - -Another form of alignment used in Haskell is {\em internal alignment}. This is where -there is vertical alignment of columns other than at the left-hand edge of the -Haskell code. This is typically characterised with a column of the same character -appearing in the program code, and it is this case, along with a -special case, that {\tt pphs} recognises for internal alignment having occurred. -\begin{quote} -\input{Haskell_internalalign1} -\end{quote} -In this example, see how the {\tt =} signs line up, one below the other. This makes -the program more readable, although it does not affect the parsing of the program. -As the purpose of {\tt pphs} is to make Haskell programs even more readable, it -retains this alignment. This example would be typeset to produce the following: -\begin{quote} -\input{LaTeX_internalalign1} -\end{quote} -The special case for internal alignment is a $=$ aligned under a $::$. -This will cause the same effect as would have happened if they were the same -character. - -\subsect{Token highlighting} - -To increase the readability of Haskell programs, {\tt pphs} allows various tokens -to be highlighted. By using different typefaces for some pieces of code, this -distinguishes them from the rest. The user can specify the details of -the highlighting, but the default settings are {\bf bold} for -keywords, {\it italics} for identifiers and {\rm roman} for everything else. -Strings, comments and numbers are also highlightable. - -Note that in the previous example, the keywords {\bf instance} and {\bf where} -are highlighted in bold, whereas the various identifiers are in italics. - -\subsect{Mathematical symbols} - -Rather than simply replicate the ASCII approximations of mathematical symbols -used in Haskell, {\tt pphs} -substitutes the proper symbols in the output. These are shown below. -\begin{center} -\begin{tabular}[t]{|c|c|} \hline -{\em Haskell\/} & {\em Math\/} \\ \hline -{\tt *} & $\times$ \\ -{\tt ++} & {\hbox{$+\mkern-7.5mu+$}} \\ -{\tt :+} & {:}{+} \\ -{\tt <=} & $\leq$ \\ \hline -\end{tabular} \hskip3mm \begin{tabular}[t]{|c|c|} \hline -{\em Haskell\/} & {\em Math\/} \\ \hline -{\tt >=} & $\geq$ \\ -{\tt <-} & $\leftarrow$ \\ -{\tt ->} & $\rightarrow$ \\ -{\tt =>} & $\Rightarrow$ \\ \hline -\end{tabular} -\end{center} - -\subsect{\LaTeX\ typesetting characters} - -\LaTeX\ uses embedded typesetting commands, so {\tt pphs} has to ensure that if -any of the characters used by \LaTeX\ appear in the input Haskell code, the correct -\LaTeX\ code is outputted to typeset them, rather than have the characters interfere -with the typesetting process. The characters used by \LaTeX\ for typesetting are: -\begin{quote} -\(\#\ \$\ \%\ \&\ \char'176\ \_\ \char'136\ \hbox{$\setminus$}\ \hbox{$\cal \char'146\ \char'147$}\) -\end{quote} -The user of {\tt pphs} need not worry about using any of these characters in Haskell -programs, as this will be dealt with by {\tt pphs} before \LaTeX\ gets to see the code. - -\subsect{How to call it} - -The program is called by typing {\tt pphs} followed by the name of -the file containing the Haskell program to be typeset. If the -filename ends with a {\tt .hs} extension, this may be omitted, -unless another file exists with the same name but no extension. -When no extension is specified, the program will look for a -filename with no extension before looking for a file with the -{\tt .hs} extension. - -For example, if the Haskell program was in a file called {\tt Haskell.hs}, -the program would be called by -\begin{quote} -\tt pphs Haskell.hs -\end{quote} -As the filename ends with a {\tt .hs} extension, the extension may be omitted, provided -there is no file already existing called {\tt Haskell}. If there is no such file -\begin{quote} -\tt pphs Haskell -\end{quote} -would produce the same effect as the original call. - -As the program outputs to {\tt stdout}, the code produced may be -directed to a file by using a {\tt >} symbol after the call, followed by -the name of the file to contain the \LaTeX\ code produced by the -program. Continuing the above example, if the output code is to be in -a file called {\tt Haskell.tex}, the call would now be -\begin{quote} -\tt pphs Haskell.hs > Haskell.tex -\end{quote} -It must be noted that if the file {\tt Haskell.tex} already exists, it must be -renamed or removed before making this call. - -There are three options that can be specified in the program call. -If it is desired that double colon symbols should look like $:\,:$ rather than $::$, -use {\tt -w} in the call. The length of the tab characters in the input file can -be specified with {\tt -t} followed by the length. The default tablength is 8. -If identifiers with subscripts are wanted, eg {\iden ident$_1$\/}, then use {\tt -s}. -These are written in the Haskell file as {\tt ident\_1}. - -If the length of the tabs are 4 and -the wide double colons are required, the example call above would become as follows. -\begin{quote} -\tt pphs -t4w Haskell.hs > Haskell.tex -\end{quote} - -\subsect{What to do with the produced code} - -Before including the \LaTeX\ code in the document, it is necessary -to include definitions of the \LaTeX\ commands used by {\tt pphs}. -This can be done simply by including the style file {\tt pphs.sty} -by adding {\tt pphs} to the option list of the documentstyle -command like thus: -\begin{quote} -\begin{verbatim} -\documentstyle[12pt,a4,pphs]{article} -\end{verbatim} -\end{quote} - -Once this has been done, the file containing the \LaTeX\ code -of the Haskell program code can be included. This is done -using the {\tt \char'134 input} command. If the \LaTeX\ -code is located in a file called {\tt Haskell.tex} then the -command is: -\begin{quote} -\begin{verbatim} -\input{Haskell} -\end{verbatim} -\end{quote} -This can be used in various \LaTeX\ environments such as {\tt quote}, -{\tt figure} or {\tt table} to produce different effects. An example -of possible code is: -\begin{quote} -\begin{verbatim} -\begin{quote} -\input{Haskell} -\end{quote} -\end{verbatim} -\end{quote} -See Lamport, L., {\em \LaTeX : A Document Preparation System\/} -(Addison-Wesley, 1986) for more details. - -\subsect{How to make adjustments to the output} - -The {\tt pphs} program is flexible in that it allows user choice on some aspects -of the appearance of the final result. User choice is allowed in two areas, typefaces -and qoute marks. - -The default settings for typefaces are bold for keywords, italics for identifiers and -roman for everything else that is not in the math typeface. However, keywords, identifiers, -strings, comments and numbers may be in whatever typeface the user chooses. -This is done using the {\tt \char'134 def} command to redefine the typeface commands -used by {\tt pphs}. These are {\tt \char'134 keyword}, {\tt \char'134 iden}, -{\tt \char'134 stri}, {\tt \char'134 com} and {\tt \char'134 numb} respectively. - -For example, to put all comments into typewriter font, use -{\tt \char'134 def\char'134 com\char'173 \char'134 tt\char'175} in -the document. The scope of the declaration will be from the point of introduction to -the end of the document. To cancel a redefinition, use {\tt \char'134 def} to -redefine it back to what it was originally. The different typefaces available in \LaTeX\ are -\begin{center} -\begin{tabular}{|c|l|} \hline -{\em code\/} & {\em meaning\/} \\ \hline -{\tt \char'134 bf} & {\bf Boldface} \\ -{\tt \char'134 em} & {\em Emphatic\/} \\ -{\tt \char'134 it} & {\it Italics\/} \\ -{\tt \char'134 rm} & {\rm Roman} \\ \hline -\end{tabular} \hskip3mm \begin{tabular}{|c|l|} \hline -{\em code\/} & {\em meaning\/} \\ \hline -{\tt \char'134 sc} & {\sc Small Caps} \\ -{\tt \char'134 sf} & {\sf Sans Serif} \\ -{\tt \char'134 sl} & {\sl Slanted\/} \\ -{\tt \char'134 tt} & {\tt Typewriter} \\ \hline -\end{tabular} -\end{center} -It should be noted that the emphatic typeface is just the same as italics, although -nesting emphatic sections will alternate between italics and roman. - -Two types of quote mark are redefinable, forwards quotes and escape quotes. -The default for both of them is ' but if it is wished to redefine one or -both of them, use the {\tt \char'134 def} with either {\tt \char'134 forquo} -or {\tt \char'134 escquo}. For example, to make escape quotes be -printed as {\sf '} use {\tt \char'134 def\char'134 escquo\char'173 \char'134 hbox\char'173 \char'134 sf '\char'175 \char'175} in the document. - -\subsect{Altering the output} - -As {\tt pphs} produces code which is subsequently run through \LaTeX , it is possible -to alter the code before it is run through \LaTeX . This is useful for correcting -mistakes made by {\tt pphs}. However, it is recommended that only those experienced -in \LaTeX\ try this. \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/User_Documents.tex b/ghc/CONTRIB/pphs/docs/User_Documents.tex deleted file mode 100644 index 0680e62daf..0000000000 --- a/ghc/CONTRIB/pphs/docs/User_Documents.tex +++ /dev/null @@ -1,5 +0,0 @@ -\chapter{User documentation} - -This document is intended to be read by users of {\tt pphs}. - -\input{UserGuide_Text} diff --git a/ghc/CONTRIB/pphs/docs/Uses.tex b/ghc/CONTRIB/pphs/docs/Uses.tex deleted file mode 100644 index c488bb4263..0000000000 --- a/ghc/CONTRIB/pphs/docs/Uses.tex +++ /dev/null @@ -1,262 +0,0 @@ -\chapter{Uses for output} - -This chapter describes how the output from {\tt pphs} can be used. First, -examples of the capabilities of {\tt pphs} are shown, then it is explained how -the output is incorporated into \LaTeX\ documents, and how the user can alter -the output using built in methods or by editing the output. - -\section{Examples of output} \label{examples} - -Up until now, only examples of input have been shown. Let us now see what -{\tt pphs} actually does to this input. Take this earlier example. -\begin{quote} -\input{Haskell_leftindent2} -\end{quote} -This is how this code is typeset by {\tt pphs}. -\begin{quote} -\input{LaTeX_leftindent2} -\end{quote} -Probably the most obvious thing about the typeset code is the highlighting -of the identifiers. The reserved identifier or keyword {\keyword where} has been -highlighted in boldface while all the other identifiers are in italics. -The various symbols are in roman or math font as appropriate, these do not -get put in italics. Less obvious is the indentation. Notice how the starts -of the third, fourth and sixth lines all line up under {\iden state\/} on the -second line, just like they do in the input. Similarly, the start of the fifth -line is under the $|$ on the fourth. This demonstrates {\tt pphs}'s ability to -recreate left indentation in \LaTeX. But note how the $=$ on the sixth line does -not align under the $|$ on the fifth as it does in the input. This is because -they are different characters and so {\tt pphs} does not recognise this as internal -alignment. The only special case made in this part of the program was for $::$ and $=$. -Alignment would have occurred by coincidence had the preceding characters on both lines -been of the same width. - -To illustrate internal alignment, recall this earlier example. -\begin{quote} -\input{Haskell_internalalign1} -\end{quote} -This code gets typeset like this. -\begin{quote} -\input{LaTeX_internalalign1} -\end{quote} -Notice here how the $=$ signs are aligned in a column, despite being preceded -be characters that may be of different widths. This demonstrates the ability of -{\tt pphs} to recreate internal alignment. Notice also how the {\tt '} signs -have been interpreted as primes. This is because they are immediately preceded -by identifiers. The {\tt *} signs have been transformed into multiplication signs, -while the {\tt =>} has been replaced with $\Rightarrow$. - -Here is a new example, this time illustrating a comment and strings. -\begin{quote} -\input{Haskell_string1} -\end{quote} -This example gets typeset as follows. -\begin{quote} -\input{LaTeX_string1} -\end{quote} -Note how {\tt pphs} puts the correct inverted commas at each end of the strings -and how the strings themselves and the comment are in roman typeface. -The $=$ signs show internal alignment. - -This next example demonstrates a comment, character quotes and the special case -with internal alignment where {\tt =} are aligned under {\tt ::}. -\begin{quote} -\input{Haskell_char} -\end{quote} -Typeset, this becomes -\begin{quote} -\input{LaTeX_char} -\end{quote} -The comment is typeset in roman, as are the character quotes. This example has -the default double colon. Using the {\tt -w} option, the colons can be positioned -further apart as illustrated below. -\begin{quote} -\input{LaTeX_wide-colons} -\end{quote} -It is a matter of taste which is used. - -\section{Incorporating output into \LaTeX\ documents} - -The motivation behind typesetting Haskell programs was so they could be incorporated -into \LaTeX\ documents. This section describes how to do this with the output -of {\tt pphs}. - -\subsection{The style file} \label{style-file} - -Before using the output generated by {\tt pphs}, it is necessary to incorporate the -{\tt pphs.sty} style file (see Appendix~\ref{style-code}) into the document. -This provides definitions of the non-standard -commands produced by the program. The use of the style file is announced -by adding {\tt pphs} to the option list of the documentstyle -command like thus: -\begin{quote} -\begin{verbatim} -\documentstyle[12pt,a4,pphs]{article} -\end{verbatim} -\end{quote} -Without {\tt pphs} in the option list, errors will occur when \LaTeX\ is run, -unless all the non-standard commands used by {\tt pphs} have been defined elsewhere -in the document. - -\subsection{Including the output file} - -To include the file containing the code output by {\tt pphs}, the \LaTeX\ -{\tt \char'134 input} command is used. If the file containing the output is called -{\tt output.tex} then the following command is used. -\begin{quote} -\begin{verbatim} -\input{output} -\end{verbatim} -\end{quote} -The code will appear at the left margin like this: -\input{LaTeX_simple} -This is useful for code listings. - -By using various different \LaTeX\ environments, the typeset Haskell code -can be arranged differently. -To have the code indented like the examples in Section~\ref{examples}, the -{\tt quote} environment should be used. The code -\begin{quote} -\begin{verbatim} -\begin{quote} -\input{output} -\end{quote} -\end{verbatim} -\end{quote} -would produce -\begin{quote} -\input{LaTeX_simple} -\end{quote} -The {\tt table} environment can be used to put the typeset Haskell code -into a table and also allows the code to be captioned. -The table will appear at the top of the current or next page depending on what -space is available in the document. The \LaTeX\ code used to produce this is -\begin{quote} -\begin{verbatim} -\begin{table} -\begin{center} -\begin{minipage}{5cm} -\input{output} -\end{minipage} -\end{center} -\caption{Typeset code in a table} \label{output-table} -\end{table} -\end{verbatim} -\end{quote} -and this will produce a table, in this case Table~\ref{simple-table}. -The {\tt minipage} environment is required because \LaTeX\ interprets the {\tt tabbing} -environment as occupying the full page width, even if the text doesn't actually -use all that space. The width argument, here {\tt 5cm}, is set to the width of the typeset -Haskell code. If centering is not required, omit the {\tt center} and -{\tt minipage} environments. -The table can be referenced if it is labelled with the {\tt \char'134 label} -command, as above, and can be referred to in the text by using the code -{\tt Table\char'176 \char'134 ref\char'173 output-table\char'175} which will -keep the table number consistent with the numbering of the chapter and other tables. -\begin{table} -\begin{center} -\begin{minipage}{5cm} -\input{LaTeX_simple} -\end{minipage} -\end{center} -\caption{Typeset code in a table} \label{simple-table} -\end{table} -Similarly, the {\tt figure} environment can be used. The code is -\begin{quote} -\begin{verbatim} -\begin{figure} -\begin{center} -\begin{minipage}{5cm} -\input{output} -\end{minipage} -\end{center} -\caption{Typeset code in a figure} \label{output-figure} -\end{figure} -\end{verbatim} -\end{quote} -which produces a figure, in this case Figure~\ref{simple-figure}. -Again, it can be captioned and referenced, as with tables. -\begin{figure} -\begin{center} -\begin{minipage}{5cm} -\input{LaTeX_simple} -\end{minipage} -\end{center} -\caption{Typeset code in a figure} \label{simple-figure} -\end{figure} - -The result, once included in the final document, may have too -much blank space under the typeset code such as is the case in -this next example. -\begin{quote} -\input{LaTeX_blankline} -\end{quote} -This means there were extra blank lines at the end of the input file, caused -by extra return characters. This can be -rectified by removing the extra return characters and running {\tt pphs} again. - -\subsection{Lengthy lines} - -It is always possible that the lines of typeset Haskell code will run off -the right-hand edge of the user's page in the final document. Where this happens, -it is necessary to edit the input file and re-run {\tt pphs}. Be careful not to -change the parse of the program by wrongly indenting the second part of the line. - -\section{User adjustments} \label{user-adj} - -The user is able to have some say on what the output looks like. -This makes the program more flexible and doesn't dictate what a -Haskell program should look like when typeset. There are two areas in which user -choice is allowed, other than the double colon symbol described in Chapter~\ref{wide-colons}. - -\subsection{Typefaces} - -The default settings for typefaces are bold for keywords, italics for identifiers and -roman for everything else that is not in the math typeface. However, keywords, identifiers, -strings, comments and numbers may be in whatever typeface the user chooses. -This is done using the {\tt \char'134 def} command to redefine the typeface commands -used by {\tt pphs}. These are {\tt \char'134 keyword}, {\tt \char'134 iden}, -{\tt \char'134 stri}, {\tt \char'134 com} and {\tt \char'134 numb} respectively. - -For example, to put all comments into typewriter font, use -{\tt \char'134 def\char'134 com\char'173 \char'134 tt\char'175} in -the document. The scope of the declaration will be from the point of introduction to -the end of the document. To cancel a redefinition, use {\tt \char'134 def} to -redefine it back to what it was originally. - -The different typefaces available in \LaTeX\ are shown in Table~\ref{fonts}. -It should be noted that the emphatic typeface is just the same as italics, although -nesting emphatic sections will alternate between italics and roman. -\begin{table} -\begin{center} -\begin{tabular}{|c|l|} \hline -{\em code\/} & {\em meaning\/} \\ \hline -{\tt \char'134 bf} & {\bf Boldface} \\ -{\tt \char'134 em} & {\em Emphatic\/} \\ -{\tt \char'134 it} & {\it Italics\/} \\ -{\tt \char'134 rm} & {\rm Roman} \\ \hline -\end{tabular} \hskip3mm \begin{tabular}{|c|l|} \hline -{\em code\/} & {\em meaning\/} \\ \hline -{\tt \char'134 sc} & {\sc Small Caps} \\ -{\tt \char'134 sf} & {\sf Sans Serif} \\ -{\tt \char'134 sl} & {\sl Slanted\/} \\ -{\tt \char'134 tt} & {\tt Typewriter} \\ \hline -\end{tabular} -\end{center} -\caption{Typefaces available in \LaTeX } \label{fonts} -\end{table} - -\subsection{Quote marks} - -Two types of quote mark are redefinable, forwards quotes and escape quotes. -The default for both of them is ' but if it is wished to redefine one or -both of them, use the {\tt \char'134 def} with either {\tt \char'134 forquo} -or {\tt \char'134 escquo}. For example, to make escape quotes be -printed as {\sf '} use {\tt \char'134 def\char'134 escquo\char'173 \char'134 hbox\char'173 \char'134 sf '\char'175 \char'175} in the document. - -\section{Altering the output} - -As {\tt pphs} produces code which is subsequently run through \LaTeX , it is possible -to alter the code before it is run through \LaTeX . This is useful for correcting -mistakes made by {\tt pphs}. However, it is recommended that only those experienced -in \LaTeX\ try this. \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/What.tex b/ghc/CONTRIB/pphs/docs/What.tex deleted file mode 100644 index 741c822fa2..0000000000 --- a/ghc/CONTRIB/pphs/docs/What.tex +++ /dev/null @@ -1,136 +0,0 @@ -\chapter{What {\tt pphs} does} - -This chapter describes a program called {\tt pphs} which implements the typesetting -requirements described in the previous chapter. The description is from the user's viewpoint, -later chapters going on to describe it from that of the programmer. - -The {\tt pphs} program typesets Haskell programs for use with the \LaTeX\ -typesetting program. It takes as input a file containing a Haskell -program and produces the Haskell code to {\tt stdout}. It is called by -typing {\tt pphs}, followed by the name of the file containing the Haskell -program. For example, if the Haskell program was in a file called {\tt Haskell.hs}, -the program would be called by -\begin{quote} -\tt pphs Haskell.hs -\end{quote} - -If the filename ends with a {\tt .hs} extension, the extension may be omitted, provided -there is no file already existing with the same name but with no extension. If no -extension is given with the filename when called, the program will look for a file of -that name with no extension. If this is not found, the program will add a {\tt .hs} -extension. The above example, therefore, may be simplified to -\begin{quote} -\tt pphs Haskell -\end{quote} -unless the file {\tt Haskell} exists, in which case the original call must be made. - -As the output of {\tt pphs} is to {\tt stdout}, it may be directed to a file by using -the {\tt >} command after the call, followed by the name of the file to contain -the \LaTeX\ code. Continuing the above example, if the output code is to be put into -a file called {\tt Haskell.tex}, the call would now be -\begin{quote} -\tt pphs Haskell.hs > Haskell.tex -\end{quote} -It must be noted that if the file {\tt Haskell.tex} already exists, it should be -renamed or removed before making this call. - -Two options are allowed with the call. In the output, some people prefer \label{wide-colons} -the {\tt ::} symbol to be written $:\,:$ rather than $::$. To obtain the former, use -{\tt -w} for wide colons. A call on {\tt Haskell.hs} requiring wide colons would be -\begin{quote} -\tt pphs -w Haskell.hs -\end{quote} -When the input file's tab characters are not of the standard 8 spaces, this can be -specified with the {\tt -t} command. For example, if the tabs were 4 spaces long, type -\begin{quote} -\tt pphs -t4 Haskell.hs -\end{quote} -Both options can be used at the same time by calling -\begin{quote} -\tt pphs -t4w Haskell.hs -\end{quote} -or -\begin{quote} -\tt pphs -wt4 Haskell.hs -\end{quote} -Any positive integer can be specified for the tablength. - -\section{Left indentation} - -It is in the nature of Haskell programs that indentation is heavily used. As the -indentation is vital to the parsing of the program, any attempt at typesetting -Haskell code must replicate this indentation. Take, for example, the following piece of code. -\begin{quote} -\input{Haskell_leftindent1} -\end{quote} -Note how the third and fourth lines both start at different levels of indentation. -The {\tt pphs} program produces the correct \LaTeX\ code to align these under the -correct position in the preceding lines once typeset. It also selects the correct -line to line up under. Note how, in the following example, the sixth line does not line up -under its predecessor, but under the fourth line. -\begin{quote} -\input{Haskell_leftindent2} -\end{quote} -Again, {\tt pphs} produces the code necessary to typeset this, preserving the parsing -order. A line of Haskell code may be indented beyond the end of its predecessor. -Here, {\tt pphs} aligns it with whichever line it is lined up underneath in the -original file. Note that these -examples of possible input have no `extra' typesetting commands. - -\section{Internal alignment} - -Another form of alignment used in Haskell is {\em internal alignment}. This is where -there is vertical alignment of columns other than at the left-hand edge of the -Haskell code. -\begin{quote} -\input{Haskell_internalalign1} -\end{quote} -In this example, see how the {\tt =} signs line up, one below the other. This makes -the program more readable, although it does not affect the parsing of the program. -As the purpose of {\tt pphs} is to make Haskell programs even more readable, it -retains this alignment. - -\section{Token highlighting} - -To increase the readability of Haskell programs, {\tt pphs} allows various tokens -to be highlighted. By using different typefaces for some pieces of code, this -distinguishes them from the rest. The user can specify the details of the highlighting as -described in Section~\ref{user-adj}, but the default settings are {\bf bold} for -keywords, {\it italics} for identifiers and {\rm roman} for everything else. Strings, -comments and numbers are also highlightable (see Section~\ref{user-adj}). - -\section{Mathematical symbols} - -Rather than simply replicate the ASCII approximations of mathematical symbols -used in Haskell, {\tt pphs} -substitutes the proper symbols in the output. These are shown in Table~\ref{maths-sym}. -\begin{table} -\begin{center} -\begin{tabular}[t]{|c|c|} \hline -{\em Haskell\/} & {\em Math\/} \\ \hline -{\tt *} & $\times$ \\ -{\tt ++} & {\hbox{$+\mkern-7.5mu+$}} \\ -{\tt :+} & {:}{+} \\ -{\tt <=} & $\leq$ \\ \hline -\end{tabular} \hskip3mm \begin{tabular}[t]{|c|c|} \hline -{\em Haskell\/} & {\em Math\/} \\ \hline -{\tt >=} & $\geq$ \\ -{\tt <-} & $\leftarrow$ \\ -{\tt ->} & $\rightarrow$ \\ -{\tt =>} & $\Rightarrow$ \\ \hline -\end{tabular} -\end{center} -\caption{Haskell ASCII approximations to mathematical characters} \label{maths-sym} -\end{table} - -\section{\LaTeX\ typesetting characters} - -\LaTeX\ uses embedded typesetting commands, so {\tt pphs} has to ensure that if -any of the characters used by \LaTeX\ appear in the input Haskell code, the correct -\LaTeX\ code is outputted to typeset them, rather than have the characters interfere -with the typesetting process. The characters used by \LaTeX\ for typesetting are: -\begin{quote} -\(\#\ \$\ \%\ \&\ \char'176\ \_\ \char'136\ \hbox{$\setminus$}\ \hbox{$\cal \char'146\ \char'147$}\) -\end{quote} -The user of {\tt pphs} need not worry about using any of these characters in Haskell -programs, as this will be dealt with by {\tt pphs} before \LaTeX\ gets to see the code. \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Wrapper.tex b/ghc/CONTRIB/pphs/docs/Wrapper.tex deleted file mode 100644 index c780cd8be6..0000000000 --- a/ghc/CONTRIB/pphs/docs/Wrapper.tex +++ /dev/null @@ -1,6 +0,0 @@ -\documentstyle[12pt,fleqn,a4,pphs]{article} -\begin{document} - -\input{Haskell} - -\end{document} diff --git a/ghc/CONTRIB/pphs/docs/char.hs b/ghc/CONTRIB/pphs/docs/char.hs deleted file mode 100644 index 0aa661eab7..0000000000 --- a/ghc/CONTRIB/pphs/docs/char.hs +++ /dev/null @@ -1,5 +0,0 @@ --- Character functions - -minChar, maxChar :: Char -minChar = '\0' -maxChar = '\255' \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/comment.hs b/ghc/CONTRIB/pphs/docs/comment.hs deleted file mode 100644 index 694cc4aa2c..0000000000 --- a/ghc/CONTRIB/pphs/docs/comment.hs +++ /dev/null @@ -1 +0,0 @@ --- note that x + y = z \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/internalalign1.hs b/ghc/CONTRIB/pphs/docs/internalalign1.hs deleted file mode 100644 index dad2f142b0..0000000000 --- a/ghc/CONTRIB/pphs/docs/internalalign1.hs +++ /dev/null @@ -1,9 +0,0 @@ -instance (RealFloat a) => Num (Complex a) where - (x:+y) + (x':+y') = (x+x') :+ (y+y') - (x:+y) - (x':+y') = (x-x') :+ (y-y') - (x:+y) * (x':+y') = (x*x'-y*y') :+ (x*y'+y*x') - negate (x:+y) = negate x :+ negate y - abs z = magnitude z :+ 0 - signum 0 = 0 - signum z@(x:+y) = x/r :+ y/r where r = magnitude z - fromInteger n = fromInteger n :+ 0 diff --git a/ghc/CONTRIB/pphs/docs/leftindent1.hs b/ghc/CONTRIB/pphs/docs/leftindent1.hs deleted file mode 100644 index 43a7cf44ed..0000000000 --- a/ghc/CONTRIB/pphs/docs/leftindent1.hs +++ /dev/null @@ -1,4 +0,0 @@ -gcd :: Int -> Int -> Int -gcd x y = gcd' (abs x) (abs y) - where gcd' x 0 = x - gcd' x y = gcd' y (x `rem` y) diff --git a/ghc/CONTRIB/pphs/docs/leftindent2.hs b/ghc/CONTRIB/pphs/docs/leftindent2.hs deleted file mode 100644 index 9d9fcd07c1..0000000000 --- a/ghc/CONTRIB/pphs/docs/leftindent2.hs +++ /dev/null @@ -1,6 +0,0 @@ -eval :: GmState -> [GmState] -eval state = state: restStates - where - restStates | gmFinal state = [] - | otherwise = eval nextState - nextState = doAdmin (step state) diff --git a/ghc/CONTRIB/pphs/docs/math.hs b/ghc/CONTRIB/pphs/docs/math.hs deleted file mode 100644 index 4906527797..0000000000 --- a/ghc/CONTRIB/pphs/docs/math.hs +++ /dev/null @@ -1,3 +0,0 @@ --- list concatenation (right-associative) -(++) :: [a] -> [a] -> [a] -xs ++ ys = foldr (:) ys xs diff --git a/ghc/CONTRIB/pphs/docs/pphs.sty b/ghc/CONTRIB/pphs/docs/pphs.sty deleted file mode 100644 index 298a58ea78..0000000000 --- a/ghc/CONTRIB/pphs/docs/pphs.sty +++ /dev/null @@ -1,26 +0,0 @@ -% ========================================= -% Definitions for use with the pphs program -% ========================================= - -\typeout{For use with the pphs program} - -% Definitions of commands used by pphs - -\newbox\foo -\def\skipover#1{\setbox\foo\hbox{#1}\hskip\wd\foo} -\def\plusplus{\hbox{$+\mkern-7.5mu+$}} -\def\xspa#1{\hskip#1ex} -\def\bareq{\setbox\foo\hbox{$=$}\makebox[\wd\foo]{$|$}} - -% User-redefinable commands - typefaces - -\def\keyword{\bf} -\def\iden{\it} -\def\stri{\rm} -\def\com{\rm} -\def\numb{\rm} - -% User-redefinable commands - quote marks - -\def\forquo{\hbox{\rm '}} -\def\escquo{\hbox{\rm '}} diff --git a/ghc/CONTRIB/pphs/docs/rep.sty b/ghc/CONTRIB/pphs/docs/rep.sty deleted file mode 100644 index bb4242d7a4..0000000000 --- a/ghc/CONTRIB/pphs/docs/rep.sty +++ /dev/null @@ -1,80 +0,0 @@ -% ===================================================================== -% A4 layout file for documents with big left margins - for folders. -% ===================================================================== - -\typeout{A4 with big left margin document layout} - -% --------------------------------------------------------------------- -% make "@" a letter -% --------------------------------------------------------------------- -\makeatletter - -% --------------------------------------------------------------------- -% PAPER SIZE -% -% TeX expects 1 inch margins all around (1 inch = 25.4 mm). -% a4 is exactly 297mm high by 208mm wide. -% --------------------------------------------------------------------- - -\hsize=157.2truemm -\vsize=246.2truemm - -% --------------------------------------------------------------------- -% PAGE LAYOUT -% -% text size = 144.5mm wide by 231.1mm high -% -% Top Margin: 1in -% Left margin: 1.5in -% Right Margin: 1in -% --------------------------------------------------------------------- - -\textwidth 144.5truemm -\textheight 231.1truemm - -\oddsidemargin=12.7truemm -\evensidemargin=0truemm -\topmargin=0truemm - -% --------------------------------------------------------------------- -% RUNNING HEAD: none -% --------------------------------------------------------------------- -\headheight 0mm -\headsep 0mm - -% --------------------------------------------------------------------- -% FOOT: page number and other information. -% --------------------------------------------------------------------- -\footheight 12pt -\footskip 18truemm -\addtolength{\footskip}{\footheight} - -% --------------------------------------------------------------------- -% INDENTATION -% -% 5mm indentation -% --------------------------------------------------------------------- -\parindent 5truemm - -% --------------------------------------------------------------------- -% math indentation. -% --------------------------------------------------------------------- -\mathindent 10.0truemm - -% --------------------------------------------------------------------- -% FOOTNOTES -% -% Footnotes are in 10 point font. -% -% put 12+1-1 points between text and rule -% put 10pt between at start of footnote -% foot note rule 40mm long -% --------------------------------------------------------------------- -\skip\footins 12pt plus 2pt minus 2pt -\footnotesep 10pt -\def\footnoterule{\kern-3\p@ \hrule width 40mm \kern 2.6\p@} - -% --------------------------------------------------------------------- -% make "@" an other -% --------------------------------------------------------------------- -\makeatother diff --git a/ghc/CONTRIB/pphs/docs/simple.hs b/ghc/CONTRIB/pphs/docs/simple.hs deleted file mode 100644 index b31d0232b6..0000000000 --- a/ghc/CONTRIB/pphs/docs/simple.hs +++ /dev/null @@ -1,3 +0,0 @@ -foobar a b = c - where - c = a + b diff --git a/ghc/CONTRIB/pphs/docs/string1.hs b/ghc/CONTRIB/pphs/docs/string1.hs deleted file mode 100644 index 437573222c..0000000000 --- a/ghc/CONTRIB/pphs/docs/string1.hs +++ /dev/null @@ -1,6 +0,0 @@ --- File and channel names: - -stdin = "stdin" -stdout = "stdout" -stderr = "stderr" -stdecho = "stdecho" diff --git a/ghc/CONTRIB/pphs/docs/string2.hs b/ghc/CONTRIB/pphs/docs/string2.hs deleted file mode 100644 index c3a063756b..0000000000 --- a/ghc/CONTRIB/pphs/docs/string2.hs +++ /dev/null @@ -1,8 +0,0 @@ -main = appendChan stdout "please type a filename\n" exit ( - readChan stdin exit (\ userInput -> - let (name : _) = lines userInput in - appendChan stdout name exit ( - readFile name (\ ioerror -> appendChan stdout - "can't open file" exit done) - (\ contents -> - appendChan stdout contents exit done)))) diff --git a/ghc/CONTRIB/pphs/pphs.c b/ghc/CONTRIB/pphs/pphs.c deleted file mode 100644 index aa31a3e7bd..0000000000 --- a/ghc/CONTRIB/pphs/pphs.c +++ /dev/null @@ -1,1030 +0,0 @@ - /* pphs - a pretty printer for Haskell code */ -#include -#include -#include -#define MAXLINELENGTH 256 - -enum face {KW, ID, IS, SU, ST, CO, NU, MA, SP, LC, RC, CR, BF, FQ, EQ, DQ, QD, EE, DC, DP, CP, LE, GE, LA, RA, RR, TI, BE}; - /* Possible values of typeface */ - -int widecolons = 0; /* User may want space between double colons */ -int subscripts = 0; /* User may want subscripts after '_' in identifiers */ -int tablength = 8; /* User's input file tablength */ - -typedef struct ElementType_Tag { /* Basic storage unit */ - char chars[MAXLINELENGTH]; /* Characters */ - enum face typeface[MAXLINELENGTH]; /* Typefaces */ - int indentation, length, col; /* Indentation level, non-empty length, column level */ -} ElementType; - -typedef struct StackNodeType_Tag *Link; /* Stack-related types */ -typedef struct StackNodeType_Tag { - ElementType Element; /* Stack item */ - Link Next; /* Link to next node */ -} StackNodeType; -typedef StackNodeType *StackNodePtr; -typedef StackNodePtr StackType; - -typedef int QueueSizeType; /* Queue-related types */ -typedef struct QueueNodeType_Tag *Connection; -typedef struct QueueNodeType_Tag { - ElementType Element; /* Queue item */ - Connection Next; /* Link to next node */ -} QueueNodeType; -typedef QueueNodeType *QueueNodePtr; -typedef struct QueueType_Tag { - QueueNodePtr Front, Rear; - QueueSizeType Length; -} QueueType; - -FILE *ifptr; /* input file pointer */ - - /* * * STACK FUNCTIONS * * */ -StackType - CreateStack() /* Returns an empty stack */ -{ - return(NULL); -} - -int - IsEmptyStack(s) /* Returns 1 if s is empty, 0 otherwise */ -StackType s; -{ - return(s == NULL); -} - -StackType - Push(s, x) /* Returns stack with x pushed onto s */ -StackType s; -ElementType x; -{ - StackType p; - - p = (StackNodeType *) malloc(sizeof(StackNodeType)); - if (p == NULL) { - fprintf(stderr, "pphs: Stack is too big\n"); - exit(3); - } - else { - (*p).Element = x; - (*p).Next = s; - return(p); - } -} - -ElementType - Top(s) /* Returns value of top element in s */ -StackType s; -{ - return((*s).Element); -} - -StackType - Pop(s) /* Returns stack with top element of s popped off */ -StackType s; -{ - StackType t; - - t = (*s).Next; - free(s); - return(t); -} - -StackType - PopSym(s) /* Returns stack with top element of s popped off without freeing */ -StackType s; -{ - StackType t; - - t = (*s).Next; -/* free(s); As PopSym is called within a function, free would free space needed later */ - return(t); -} - /* * * QUEUE FUNCTIONS * * */ -QueueType - CreateQueue() /* Returns an empty queue */ -{ - QueueType q; - - q.Front = NULL; - q.Rear = NULL; - q.Length = 0; - return(q); -} - -int - IsEmptyQueue(q) /* Returns 1 if q is empty, 0 otherwise */ -QueueType q; -{ - return(q.Front == NULL); -} - -int - LengthOfQueue(q) /* Returns length of q */ -QueueType q; -{ - return(q.Length); -} - -QueueNodePtr - FrontOfQueue(q) /* Returns pointer to front of q */ -QueueType q; -{ - return(q.Front); -} - -QueueNodePtr - RearOfQueue(q) /* Returns pointer to rear of q */ -QueueType q; -{ - return(q.Rear); -} - -QueueType - AddToQueue(q, x) /* Adds item x to rear of queue q */ -QueueType q; -ElementType x; -{ - QueueNodePtr p; - - p = (QueueNodeType *) malloc(sizeof(QueueNodeType)); - if (p == NULL) { - fprintf(stderr, "pphs: Queue is too big\n"); - exit(4); - } - else { - (*p).Element = x; - (*p).Next = NULL; - if (q.Front == NULL) - q.Front = p; - else - (*(q.Rear)).Next = p; - q.Rear = p; - q.Length++; - return(q); - } -} - -QueueType - TakeFromQueue(q) /* Removes front item from queue */ -QueueType q; -{ - QueueNodePtr p; - - if (q.Front == NULL) { - fprintf(stderr, "pphs: Stack underflow\n"); - exit(5); - } - else { - p = q.Front; - q.Front = (*(q.Front)).Next; - if (q.Front == NULL) - q.Rear = NULL; - q.Length--; - free(p); - return(q); - } -} - /* * * TYPEFACE FUNCTIONS * * */ -int - IsMathsChar(c) /* Returns 1 if c is a character to be in maths */ -char c; -{ - return((c == '[') || (c == ']') || (c == '/') || (c == ',') || (c == '!') - || (c == ':') || (c == ';') || (c == '(') || (c == ')') || (c == '&') - || (c == '#') || (c == '+') || (c == '-') || (c == '<') || (c == '>') - || (c == '{') || (c == '}') || (c == '=') || (c == '|') || (c == '\'') - || (c == '^')); -} - -ElementType - ChangeTypeface(store, length, finish, tf) /* Changes the typeface to tf in store - for length until finish */ -ElementType store; -int length, finish; -enum face tf; -{ - int counter; - - for (counter = (finish - length); counter < finish; counter++) - store.typeface[counter] = tf; - return(store); -} - -ElementType - CheckForDoubleChar(store, position) /* Checks for double character - in store.chars[position - 2..position - 1], - if found alters typeface */ -ElementType store; -int position; -{ - if ((position >= 2) && (store.typeface[position - 2] != DC)) { - if ((store.chars[position - 2] == '-') && (store.chars[position - 1] == '-')) { - store.typeface[position - 2] = LC; /* Haskell "--" line comment */ - store.typeface[position - 1] = LC; - } - else if ((store.chars[position - 2] == '{') && (store.chars[position - 1] == '-')) { - store.typeface[position - 2] = RC; /* Haskell "{-" regional comment begin */ - store.typeface[position - 1] = DC; - } - else if ((store.chars[position - 2] == '-') && (store.chars[position - 1] == '}')) { - store.typeface[position - 2] = CR; /* Haskell "-}" regional comment end */ - store.typeface[position - 1] = DC; - } - else if ((store.chars[position - 2] == '+') && (store.chars[position - 1] == '+')) { - store.typeface[position - 2] = DP; /* Double plus */ - store.typeface[position - 1] = DC; - } - else if ((store.chars[position - 2] == ':') && (store.chars[position - 1] == '+')) { - store.typeface[position - 2] = CP; /* Colon plus */ - store.typeface[position - 1] = DC; - } - else if ((store.chars[position - 2] == '<') && (store.chars[position - 1] == '=')) { - store.typeface[position - 2] = LE; /* Less than or equal to */ - store.typeface[position - 1] = DC; - } - else if ((store.chars[position - 2] == '>') && (store.chars[position - 1] == '=')) { - store.typeface[position - 2] = GE; /* Greater than or equal to */ - store.typeface[position - 1] = DC; - } - else if ((store.chars[position - 2] == '<') && (store.chars[position - 1] == '-')) { - store.typeface[position - 2] = LA; /* Leftarrow */ - store.typeface[position - 1] = DC; - } - else if ((store.chars[position - 2] == '-') && (store.chars[position - 1] == '>')) { - store.typeface[position - 2] = RA; /* Rightarrow */ - store.typeface[position - 1] = DC; - } - else if ((store.chars[position - 2] == '=') && (store.chars[position - 1] == '>')) { - store.typeface[position - 2] = RR; /* Double rightarrow */ - store.typeface[position - 1] = DC; - } - else if (((store.chars[position - 2] == '*') && (store.chars[position - 1] == '*')) - || ((store.chars[position - 2] == '^') && (store.chars[position - 1] == '^'))) { - store.typeface[position - 2] = MA; /* Exponent, ie not Times */ - store.typeface[position - 1] = MA; - } - } - return(store); -} - -int - IsHaskellPunc(c) /* Returns 1 if c is a punctuation mark not part of identifier */ -char c; -{ - return((c == ' ') || (c == ',') || (c == '@') || (c == '#') || (c == '$') - || (c == '%') || (c == '&') || (c == '*') || (c == '(') || (c == ')') - || (c == '-') || (c == '+') || (c == '=') || (c == '\\') || (c == '|') - || (c == '[') || (c == ']') || (c == '{') || (c == '}') || (c == ':') - || (c == ';') || (c == '"') || (c == '~') || (c == '?') || (c == '/') - || (c == '<') || (c == '>') || (c == '^')); -} - -int - IsKeyWord(str) /* Returns 1 if str is a keyword to be in keyword font */ -char str[MAXLINELENGTH]; -{ - return((!(strcmp(str, "case"))) || (!(strcmp(str, "class"))) - || (!(strcmp(str, "data"))) || (!(strcmp(str, "default"))) - || (!(strcmp(str, "deriving"))) || (!(strcmp(str, "else"))) - || (!(strcmp(str, "hiding"))) || (!(strcmp(str, "if"))) - || (!(strcmp(str, "import"))) || (!(strcmp(str, "in"))) - || (!(strcmp(str, "infix"))) || (!(strcmp(str, "infixl"))) - || (!(strcmp(str, "infixr"))) || (!(strcmp(str, "instance"))) - || (!(strcmp(str, "interface"))) || (!(strcmp(str, "let"))) - || (!(strcmp(str, "module"))) || (!(strcmp(str, "of"))) - || (!(strcmp(str, "renaming"))) || (!(strcmp(str, "then"))) - || (!(strcmp(str, "to"))) || (!(strcmp(str, "type"))) - || (!(strcmp(str, "where")))); -} - -int - KeyWord(c, store, position) /* Returns length of keyword if a keyword ends - at store.chars[position - 1] */ -char c; -ElementType store; -int position; -{ - int counter, start, end = position - 1, keywordlen = 0; - char str[MAXLINELENGTH]; - - if ((!isalpha(c)) && (c != '_') && (c != '\'') && (position)) { - for (counter = end; (counter >= 0) && ((isalpha(store.chars[counter])) - || (c == '_') || (c == '\'')) - && (counter >= store.indentation); counter--) { - ; /* Just count letters */ - } - start = ++counter; - for (counter = 0; counter + start <= end; counter++) { - str[counter] = store.chars[counter + start]; /* Copy letters into str */ - } - str[counter] = '\0'; /* Add null character to end */ - if (IsKeyWord(str)) /* Checks word in str is keyword */ - keywordlen = strlen(str); /* and measures it */ - } - return(keywordlen); -} - -ElementType - CheckForKeyword(c, store, position) /* Returns store with any possible keyword - ending at store.chars[position - 1] - identified as such in store.typeface */ -char c; -ElementType store; -int position; -{ - if (KeyWord(c, store, position)) - store = ChangeTypeface(store, KeyWord(c, store, position), position, KW); - return(store); -} - -int - IsNumber(c, store, position, statesok) /* Returns 1 if c forms part of a number */ -char c; -ElementType store; -int position, statesok; -{ - int counter, foundident = 0, foundpunc = 0; - - if (((isdigit(c)) || (c == 'e') || (c == 'E') || (c == '|') || (c == '.')) - && (statesok)) { - counter = position - 1; - while ((isdigit(store.chars[counter])) && (counter >= 0)) - counter--; - if (((store.chars[counter] == '+') || (store.chars[counter] == '-')) - && ((store.chars[counter - 1] == 'e') || (store.chars[counter - 1] == 'E')) - && (counter > 2)) - counter -= 2; - else if (((store.chars[counter] == 'e') || (store.chars[counter] == 'E')) - && (counter > 1)) - counter--; - while ((isdigit(store.chars[counter])) && (counter >= 0)) - counter--; - if ((store.chars[counter] == '.') && (counter > 1)) - counter--; - while ((isdigit(store.chars[counter])) && (counter >= 0)) - counter--; - if ((isalpha(store.chars[counter])) && (counter >= 0)) - foundident = 1; /* ie not number */ - else if ((IsHaskellPunc(store.chars[counter])) || (counter < 0)) - foundpunc = 1; /* ie is number */ - } - return(foundpunc); -} - /* * * LINE SELECTION FUNCTIONS * * */ -ElementType - SelectSkipLine(s, store, linecounter) /* Returns store containing line for skipover */ -StackType s; -ElementType store; -int linecounter; -{ - ElementType temp; - int counter; - - if (!(IsEmptyStack(s))) { - while (((Top(s)).length <= linecounter) || ((Top(s)).indentation >= linecounter)) { - temp = Top(s); - s = PopSym(s); - if (IsEmptyStack(s)) { - counter = temp.length; - while (counter < linecounter) { - temp.chars[counter] = ' '; - temp.typeface[counter++] = SP; - } - temp.chars[counter] = '\0'; /* Add null character to end */ - s = Push(s, temp); - break; - } - } - store = Top(s); - } - else { /* Stack is empty */ - counter = store.length; - while (counter < linecounter) { - store.chars[counter] = ' '; - store.typeface[counter++] = SP; - } - store.chars[counter] = '\0'; /* Add null character to end */ - } - return(store); -} - /* * * STORING FUNCTIONS * * */ -ElementType - CreateStore() /* Returns an empty store */ -{ - ElementType store; - - strcpy(store.chars, ""); - store.length = 0; - store.indentation = 0; - store.col = 0; - return(store); -} - -ElementType - StoreSpace(store, position) /* Stores a space in the store at current position */ -ElementType store; -int position; -{ - store.chars[position] = ' '; - store.typeface[position] = SP; - return(store); -} - /* * * WRITING FUNCTIONS * * */ -void - WriteStartFace(tf) /* Writes LaTeX typeface commands for start of section */ -enum face tf; -{ - if (tf == KW) /* Keywords */ - printf("{\\keyword "); - else if ((tf == ID) || (tf == IS)) /* Identifiers */ - printf("{\\iden "); - else if (tf == ST) /* Strings */ - printf("{\\stri "); - else if (tf == CO) /* Comments */ - printf("{\\com "); - else if (tf == NU) /* Numbers */ - printf("{\\numb "); - else if ((tf == MA) || (tf == TI)) /* Various maths */ - printf("$"); -} - -void - WriteFinishFace(tf) /* Writes LaTeX typeface commands for end of section */ -enum face tf; -{ - if ((tf == KW) || (tf == ID) || (tf == ST) || (tf == CO) - || (tf == NU)) /* Keywords, identifiers, strings, comments or numbers */ - printf("\\/}"); - else if ((tf == MA) || (tf == TI)) /* Various maths */ - printf("$"); - else if (tf == IS) /* Subscripts in identifiers */ - printf("\\/}$"); -} - -int - WriteSpaces(store, counter, finish) /* Writes consecutive spaces, - returning new counter value */ -ElementType store; -int counter, finish; -{ - int spaces = 0; /* The number of spaces found */ - - for (; (store.typeface[counter] == SP) && (counter < finish); counter++) - spaces++; - printf("\\xspa{%d}", spaces); - return(--counter); -} - -int - WriteChar(store, counter, finish) /* Writes charater, returning new counter value */ -ElementType store; -int counter, finish; -{ - if (store.typeface[counter] == SP) /* Space */ - printf("\\xspa1"); /* Redundant */ - else if (store.typeface[counter] == BE) /* Bar under equals sign */ - printf("\\bareq"); - else if (store.typeface[counter] == DP) { /* Double plus */ - if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { - printf("\\plusplus"); - counter++; - } - } - else if (store.typeface[counter] == CP) { /* Colon plus */ - if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { - printf("{:}{+}"); - counter++; - } - } - else if (store.typeface[counter] == LE) { /* Less than or equal to */ - if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { - printf("$\\leq$"); - counter++; - } - } - else if (store.typeface[counter] == GE) { /* Greater than or equal to */ - if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { - printf("$\\geq$"); - counter++; - } - } - else if (store.typeface[counter] == LA) { /* Leftarrow */ - if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { - printf("$\\leftarrow$"); - counter++; - } - } - else if (store.typeface[counter] == RA) { /* Rightarrow */ - if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { - printf("$\\rightarrow$"); - counter++; - } - } - else if (store.typeface[counter] == RR) { /* Double rightarrow */ - if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { - printf("$\\Rightarrow$"); - counter++; - } - } - else if (store.typeface[counter] == RC) { /* Regional comment begin */ - if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { - printf("{\\com \\{-\\/}"); - counter++; - } - else - printf("{\\com \\{\\/}"); - } - else if (store.typeface[counter] == CR) { /* Regional comment end */ - if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { - printf("{\\com -\\}\\/}"); - counter++; - } - else - printf("{\\com -\\/}"); - } - else if ((store.typeface[counter] == LC) && (store.chars[counter] == '-')) - printf("{\\rm -}"); /* Comment - problem: "--" becomes "-" in LaTeX so fix done */ - else if (store.chars[counter] == '\\') - printf("\\hbox{$\\setminus$}"); /* Backslash */ - else if (store.chars[counter] == '*') { - if (store.typeface[counter] == TI) - printf("\\times "); /* Multiplication */ - else - printf("*"); /* Other star symbols, eg Exponent */ - } - else if ((store.chars[counter] == '_') && (store.typeface[counter] == SU)) { - if ((counter < finish - 1) && (store.typeface[counter + 1] == IS)) - printf("$_"); /* Subscript character */ - } - else if (store.chars[counter] == '^') - printf("\\char'136 "); /* Up-arrow */ - else if (store.chars[counter] == '~') - printf("\\char'176 "); /* Tilda */ - else if ((store.chars[counter] == ':') && (store.chars[counter - 1] == ':') - && (widecolons)) - printf("\\,:"); /* Double colon */ - else if (store.chars[counter] == '"') { - if ((counter) && ((store.chars[counter - 1] == '"') - || (store.chars[counter - 1] == '\''))) - printf("\\,"); /* If previous character was a quote, leave a little space */ - if (store.typeface[counter] == DQ) - printf("{\\rm ``}"); /* Open doublequote */ - else if (store.typeface[counter] == QD) - printf("{\\rm \"}"); /* Close doublequote */ - else - printf("{\\rm \\char'175}"); /* Escape doublequote in string */ - } - else if (store.chars[counter] == '\'') { - if ((counter) && ((store.chars[counter - 1] == '"') - || ((store.chars[counter - 1] == '\'') - && ((store.typeface[counter - 1] != MA) - || (store.typeface[counter] != MA))))) - printf("\\,"); /* If previous character was a quote, leave a little space - except when it's a double prime */ - if (store.typeface[counter] == FQ) - printf("\\forquo "); /* Forward single quote */ - else if (store.typeface[counter] == EQ) - printf("\\escquo "); /* Escape single quote */ - else if (store.typeface[counter] == BF) { - if ((counter + 1 < store.length) && (store.typeface[counter + 1] == BF) - && (counter + 1 != store.indentation)) { - printf("{\\com \'\'\\/}"); /* Closing LaTeX style quote */ - counter++; - } - else - printf("{\\com \'\\/}"); /* Single quote following backquote in comment */ - } - else - printf("\'"); /* Prime */ - } - else if (store.chars[counter] == '{') - printf("\\hbox{$\\cal \\char'146$}"); /* Open curly bracket */ - else if (store.chars[counter] == '}') - printf("\\hbox{$\\cal \\char'147$}"); /* Close curly bracket */ - else if ((counter) && (store.chars[counter - 1] == '[') && (store.chars[counter] == ']')) - printf("\\,]"); /* Leave small gap between adjacent square brackets */ - else if ((store.chars[counter] == '$') || (store.chars[counter] == '%') - || (store.chars[counter] == '_') || (store.chars[counter] == '#') - || (store.chars[counter] == '&')) /* Various characters needing '\' for LaTeX */ - printf("\\%c", store.chars[counter]); - else /* Other characters */ - printf("%c", store.chars[counter]); - return(counter); -} - -void - WriteSkipover(store) /* Writes the skipover portion of line in store */ -ElementType store; -{ - int counter = 0; - - printf("\\skipover{"); /* Write opening LaTeX skipover command */ - WriteStartFace(store.typeface[counter]); /* Write opening LaTeX typeface command */ - if (store.typeface[counter] == SP) - counter = WriteSpaces(store, counter, store.indentation); /* Write spaces */ - else - counter = WriteChar(store, counter, store.indentation); /* Write character */ - for (counter++; counter < store.indentation; counter++){ /* until end of skipover */ - if (store.typeface[counter - 1] != store.typeface[counter]) { /* If typeface change */ - WriteFinishFace(store.typeface[counter - 1]); /* write closing typeface command */ - WriteStartFace(store.typeface[counter]); /* write opening LaTeX typeface command */ - } - if (store.typeface[counter] == SP) - counter = WriteSpaces(store, counter, store.indentation); /* Write spaces */ - else - counter = WriteChar(store, counter, store.indentation); /* Write character */ - } - if (store.typeface[counter - 1] == SU) - ; /* If indentation is under subscript don't open math section */ - else - WriteFinishFace(store.typeface[counter - 1]); /* Write closing LaTeX typeface command */ - printf("}"); /* Write closing LaTeX skipover command */ -} - -void - WriteWords(store) /* Writes rest of line, starting at indentation level */ -ElementType store; -{ - int counter = store.indentation; - int intabular = 0; /* Boolean: is in tabular section for internal alignment */ - - WriteStartFace(store.typeface[counter]); /* Write opening LaTeX typeface command */ - if (store.typeface[counter] == SP) - counter = WriteSpaces(store, counter, store.length); /* Write spaces */ - else - counter = WriteChar(store, counter, store.length); /* Write character */ - for (counter++; counter < store.length; counter++){ /* until end of word */ - if ((store.col) && (store.col == counter)) { - printf(" & "); - if (store.chars[counter - 1] == ':') - printf("$:"); - intabular = 1; - } - if (store.typeface[counter - 1] != store.typeface[counter]) /* If typeface change */ - WriteFinishFace(store.typeface[counter - 1]); /* Write closing typeface command */ - if ((store.typeface[counter] == SP) && (intabular)) { - printf(" & "); - intabular = 0; - } - if ((store.typeface[counter - 1] != store.typeface[counter]) /* If typeface change */ - && ((store.chars[counter] != ':') || (store.col != counter + 1))) - WriteStartFace(store.typeface[counter]); /* Write opening LaTeX typeface command */ - if (store.typeface[counter] == SP) - counter = WriteSpaces(store, counter, store.length); /* Write spaces */ - else if ((store.chars[counter] != ':') || (!store.col) || (store.col != counter + 1)) - counter = WriteChar(store, counter, store.length); /* Write character */ - } - WriteFinishFace(store.typeface[counter - 1]); /* Write closing LaTeX typeface command */ -} - -void - WriteLine(store, needed) /* Writes the line in store, - only writing LaTeX newline if needed */ -ElementType store; -int needed; -{ - if (store.indentation) - WriteSkipover(store); - if (store.indentation < store.length) - WriteWords(store); - if (needed) - printf("\\\\"); /* LaTeX newline character */ - printf("\n"); -} - -QueueType - WriteQueue(q) /* Writes lines, removing them from queue, - leaves last line in queue if not in tabular section */ -QueueType q; -{ - int intabular = 0; - - if ((!(IsEmptyQueue(q))) && ((*(FrontOfQueue(q))).Element.col)) { - printf("\\begin{tabular}{@{}l@{\\xspa1}c@{}l}\n"); - intabular = 1; - } - while (LengthOfQueue(q) > !intabular) { - WriteLine((*(FrontOfQueue(q))).Element, 1); /* LaTeX newline character is needed */ - q = TakeFromQueue(q); - } - if (intabular) - printf("\\end{tabular}\\\\\n"); - return(q); -} - -QueueType - WriteRestOfQueue(q) /* Writes all lines, removing them from queue, - doesn't have LaTeX newline after last line */ -QueueType q; -{ - int intabular = 0; - - if ((!(IsEmptyQueue(q))) && ((*(FrontOfQueue(q))).Element.col)) { - printf("\\begin{tabular}{@{}l@{\\xspa1}c@{}l}\n"); - intabular = 1; - } - while (!(IsEmptyQueue(q))) { - WriteLine((*(FrontOfQueue(q))).Element, (LengthOfQueue(q) > 1)); /* Last line doesn't - need LaTeX newline character */ - q = TakeFromQueue(q); - } - if (intabular) { - printf("\\end{tabular}"); - if (!IsEmptyQueue(q)) /* Last line doesn't need LaTeX newline character */ - printf("\\\\"); - printf("\n"); - } - return(q); -} - -int -main (argc, argv) /* * * MAIN PROGRAM * * */ - int argc; - char *argv[]; -{ - int tripped = 1, instring = 0, instringincomment = 0, inlinecomment = 0; - int incharquote = 0, incharquoteincomment = 0, inbackquoteincomment = 0; - int insub = 0; - /* Booleans - just taken new line, in string, in string inside comment, in line comment, - in character quote, in character quote inside comment, in backquote inside comment, - in subscript */ - int linecounter = 0, indentcounter = 0, inregcomment = 0, pos; - /* Counters: current position on line, indentation of current line, - nesting level of regional comments, position marker */ - char c; /* Character */ - StackType s; /* Stack of previous longest lines */ - QueueType q; /* Queue of lines waiting to be printed */ - ElementType store; /* Store of letters, typefaces and non-empty length */ - - if ((argc == 3) && (argv[1][0] == '-')) { /* If options specified with call */ - if (strstr(argv[1], "s")) /* if -s option, subscripts in identifiers wanted */ - subscripts = 1; - if (strstr(argv[1], "t")) { /* if -tX option, tab characters are X spaces */ - for (pos = 1; (argv[1][pos] != 't'); pos++) /* find 't' */ - ; - for (pos++, tablength = 0; isdigit(argv[1][pos]); pos++) /* read number */ - tablength = (tablength * 10) + (argv[1][pos] - '0'); - } - if (strstr(argv[1], "w")) /* if -w option called, wide double colons wanted */ - widecolons = 1; - } - else if (argc == 2) /* If no options */ - ; - else { /* If not called with pphs and a filename */ - fprintf(stderr, "pphs: Call with one file name\n"); - exit(1); - } - - if ((strcspn(argv[argc - 1], ".") == strlen(argv[argc - 1])) /* If filename has no extention */ - && ((ifptr = fopen(argv[argc - 1], "r")) == NULL)) /* and no plain file of that name */ - strcat(argv[argc - 1], ".hs"); /* add a ".hs" extention */ - if ((ifptr = fopen(argv[argc - 1], "r")) == NULL) { /* Open input file */ - fprintf(stderr, "pphs: File could not be opened\n"); /* eg isn't there */ - exit(2); - } - else { - - printf("\\begin{tabbing}\n"); /* Start of Haskell program */ - - store = CreateStore(); /* an empty one */ - s = CreateStack(); /* an empty one */ - q = CreateQueue(); /* an empty one */ - - fscanf(ifptr, "%c", &c); /* Read character */ - while (!feof(ifptr)) { /* While not at end of input file */ - while ((isspace(c)) && (!(feof(ifptr)))) { /* Read blank characters */ - if (c == ' ') { - if (tripped) - linecounter++; /* Count leading spaces */ - else { /* or */ - store = StoreSpace(store, linecounter++); /* Store intermediate - or trailing space */ - if (store.length < linecounter) - store.chars[linecounter] = '\0'; /* Add null character to end */ - } - fscanf(ifptr, "%c", &c); /* Read next character */ - } - else if (c == '\t') { - if (tripped) - linecounter += (tablength - (linecounter % tablength)); - else { - store = StoreSpace(store, linecounter++); - for (; linecounter % tablength; linecounter++) - store = StoreSpace(store, linecounter); - if (store.length < linecounter) - store.chars[linecounter] = '\0'; /* Add null character to end */ - } - fscanf(ifptr, "%c", &c); /* Read next character */ - } - else if (c == '\n') { - tripped = 1; /* Just taken a new line */ - inlinecomment = 0; - if (!(IsEmptyStack(s))) - while (((Top(s)).length <= store.length) - && ((Top(s)).indentation >= store.length)) { - s = Pop(s); - if (IsEmptyStack(s)) - break; - } - if (store.length > 0) { /* Push non-empty line onto indentation stack */ - store.indentation = indentcounter; - s = Push(s, store); - } - if (!(IsEmptyQueue(q))) { - if ((store.col != (*(FrontOfQueue(q))).Element.col) - || (!(*(FrontOfQueue(q))).Element.col)) - q = WriteQueue(q); /* If internal alignment changes or there is none - write out lines */ - } - q = AddToQueue(q, store); /* Add to writing queue */ - linecounter = 0; /* Get ready to count leading spaces */ - store.length = linecounter; - fscanf(ifptr, "%c", &c); /* Read next character */ - } - else break; - } - if (tripped) { - indentcounter = linecounter; - store.indentation = linecounter; - store.col = 0; - } - if ((tripped) && (linecounter)) { /* Skipover necessary for indentation */ - store = SelectSkipLine(s, store, linecounter); - store.indentation = linecounter; - store.col = 0; - } - if (!feof(ifptr)) - tripped = 0; /* No longer just taken new line */ - while ((!(isspace(c))) && (!(feof(ifptr)))) { /* Read word */ - if ((linecounter > 1) && (!IsEmptyQueue(q)) - && ((*(RearOfQueue(q))).Element.length >= linecounter) - && (linecounter > store.indentation) - && (linecounter > (*(RearOfQueue(q))).Element.indentation) - && (store.chars[linecounter - 1] == ' ') - && ((((*(RearOfQueue(q))).Element.chars[linecounter - 1] == ' ') - && ((c == (*(RearOfQueue(q))).Element.chars[linecounter]) - || ((c == '=') - && ((*(RearOfQueue(q))).Element.chars[linecounter] == ':') - && ((*(RearOfQueue(q))).Element.chars[linecounter + 1] == ':')))) - || (((*(RearOfQueue(q))).Element.chars[linecounter - 1] == ':') - && ((*(RearOfQueue(q))).Element.chars[linecounter] == ':') - && (c == '='))) - && ((store.chars[linecounter - 2] == ' ') - || ((*(RearOfQueue(q))).Element.chars[linecounter - 2] == ' ')) - && (((*(RearOfQueue(q))).Element.col == 0) - || ((*(RearOfQueue(q))).Element.col == linecounter))) { - store.col = linecounter; /* Identify any internal alignment */ - (*(RearOfQueue(q))).Element.col = linecounter; - } - if ((c == '"') && (!incharquote) /* String outside comments */ - && (!inregcomment) && (!inlinecomment)) { - if (((linecounter) && (store.chars[linecounter - 1] != '\\')) - || (!linecounter)) - instring = !instring; - } - else if ((c == '"') && (!incharquoteincomment) /* String inside comment */ - && (!inbackquoteincomment) - && ((inregcomment) || (inlinecomment))) { - if (((linecounter) && (store.chars[linecounter - 1] != '\\')) - || (!linecounter)) - instringincomment = !instringincomment; - } - else if ((c == '`') && ((inlinecomment) || (inregcomment))) { - if ((linecounter) && (store.chars[linecounter - 1] == '`')) - inbackquoteincomment = 2; /* Opening LaTeX style quote in comment */ - else - inbackquoteincomment = !inbackquoteincomment; /* Backquote in comment */ - } - else if ((linecounter) && (!inlinecomment) && (!instring)) { - if ((store.chars[linecounter - 1] == '{') && (c == '-')) - inregcomment++; /* Haskell "{-" regional comment begin */ - else if ((store.chars[linecounter - 1] == '-') && (c == '}')) { - inregcomment--; /* Haskell "-}" regional comment end */ - instringincomment = 0; - incharquoteincomment = 0; - inbackquoteincomment = 0; - } - } - if (c == '|') { - if ((!IsEmptyQueue(q)) - && ((((*(RearOfQueue(q))).Element.chars[linecounter] == '=') - && (linecounter == store.indentation)) - || ((*(RearOfQueue(q))).Element.typeface[linecounter] == BE))) - store.typeface[linecounter] = BE; - else - store.typeface[linecounter] = MA; - } - else if ((c == '\'') && (linecounter) && (store.chars[linecounter - 1] == '\\')) - store.typeface[linecounter] = EQ; /* Escape character quote */ - else if ((c == '\'') && (!instring) && (!inregcomment) && (!inlinecomment)) { - if (((linecounter) && (store.chars[linecounter - 1] != '\\') - && ((IsHaskellPunc(store.chars[linecounter - 1])) || (incharquote))) - || (!linecounter)) { - incharquote = !incharquote; - store.typeface[linecounter] = FQ; /* Character quote */ - } - else - store.typeface[linecounter] = MA; /* Prime */ - } - else if ((c == '\'') && (!instringincomment) - && ((inregcomment) || (inlinecomment))) { - if (((linecounter) && (store.chars[linecounter - 1] != '\\') - && ((IsHaskellPunc(store.chars[linecounter - 1])) - || (incharquoteincomment))) - || (!linecounter)) { - incharquoteincomment = !incharquoteincomment; - store.typeface[linecounter] = FQ; /* Character quote in comment */ - } - else if (inbackquoteincomment) { - inbackquoteincomment--; - store.typeface[linecounter] = BF; /* `x' character quote in comment */ - } - else - store.typeface[linecounter] = MA; /* Prime */ - } - else if (c == '"') { - if ((!incharquote) && (!incharquoteincomment) && (!inbackquoteincomment) - && ((instring) || (instringincomment))) { - if (((linecounter) && (store.chars[linecounter - 1] != '\\')) - || (!linecounter)) - store.typeface[linecounter] = DQ; /* Open doublequote */ - else if (store.chars[linecounter - 1] == '\\') - store.typeface[linecounter] = EE; /* Escape doublequote */ - } - else if ((!incharquote) && (!incharquoteincomment) && (!inbackquoteincomment)) { - if (((linecounter) && (store.chars[linecounter - 1] != '\\')) - || (!linecounter)) - store.typeface[linecounter] = QD; /* Close doublequote */ - else if (store.chars[linecounter - 1] == '\\') - store.typeface[linecounter] = EE; /* Escape doublequote */ - } - else - store.typeface[linecounter] = EE; /* Character quote of doublequote */ - } - else if (c == '`') { - if ((inlinecomment) || (inregcomment)) - store.typeface[linecounter] = CO; - else - store.typeface[linecounter] = MA; - } - else if ((linecounter) && (subscripts) && (c == '_') - && (store.typeface[linecounter - 1] == ID)) - store.typeface[linecounter] = SU; /* Subscript in identifier */ - else if (c == '*') - store.typeface[linecounter] = TI; /* Times - may be changed by double char */ - else if (IsMathsChar(c)) - store.typeface[linecounter] = MA; /* Maths characters */ - else if (IsNumber(c, store, linecounter, - ((!inregcomment) && (!instring) && (!inlinecomment)))) - store.typeface[linecounter] = NU; /* Numbers */ - else if ((instring) || (incharquote)) - store.typeface[linecounter] = ST; /* Characters in strings */ - else if ((inlinecomment) || (inregcomment)) - store.typeface[linecounter] = CO; /* Characters in comments */ - else { - if (insub) - store.typeface[linecounter] = IS; /* Subscript identifiers */ - else - store.typeface[linecounter] = ID; /* Others */ - } - if (linecounter) - if ((store.typeface[linecounter - 1] == IS) - && (store.typeface[linecounter] != IS)) - insub = 0; /* End of subscript identifier */ - store.chars[linecounter++] = c; /* Place character in store */ - if (linecounter > store.indentation + 1) - store = CheckForDoubleChar(store, linecounter); - if ((store.typeface[linecounter - 1] == LC) && (!inregcomment) - && (!instring) && (!incharquote)) { - instringincomment = 0; - incharquoteincomment = 0; - inbackquoteincomment = 0; - inlinecomment = 1; - } - else if ((store.typeface[linecounter - 1] == SU) - && (linecounter != store.indentation)) - insub = 1; - fscanf(ifptr, "%c", &c); /* Read next character */ - if (feof(ifptr)) - c = ' '; - if ((!inregcomment) && (!inlinecomment) && (!instring)) - store = CheckForKeyword(c, store, linecounter); /* Keywords not in comments or - strings to be in keyword typeface */ - } - insub = 0; - store.chars[linecounter] = '\0'; /* String terminating null character */ - store.length = linecounter; - } - if ((!tripped) && (!store.col)) /* If last line not in internal alignment */ - q = WriteQueue(q); /* write previous lines which might */ - if (!tripped) /* Put final line in queue if non-empty */ - q = AddToQueue(q, store); - if (feof(ifptr)) /* Write remaining lines */ - q = WriteRestOfQueue(q); - - printf("\\end{tabbing}\n"); /* End of Haskell program */ - - exit(0); - } -} diff --git a/ghc/Makefile b/ghc/Makefile index effd0a9e7a..3876e1b670 100644 --- a/ghc/Makefile +++ b/ghc/Makefile @@ -1,79 +1,71 @@ #----------------------------------------------------------------------------- -# $Id: Makefile,v 1.2 1996/11/21 16:46:26 simonm Exp $ +# $Id: Makefile,v 1.3 1997/03/14 07:53:55 simonpj Exp $ +# -TOP=.. -include $(TOP)/ghc/mk/ghc.mk +TOP=. +include $(TOP)/mk/boilerplate.mk line = @echo "------------------------------------------------------------------------------" -define BuildLibs -$(line) -@echo "Building Libraries" -$(line) -@$(MAKE) -C lib depend all -endef - -define BuildCompiler -$(line) -@echo "Building Compiler" -$(line) -@$(MAKE) -C compiler depend all -endef - -# dependencies: +# +# subdir dependencies: # everything needs utils -# includes needs driver (for mkNativeGen.c) +# includes/ needs driver (to easily c.pile mkNativeGen.c) # make depend except in {utils,driver} needs includes # RTS and compiler need includes +# boot :: $(line) - @echo "Building Utils" + @echo "Booting Utils" $(line) - @$(MAKE) -C utils depend all + @$(MAKE) -C utils boot depend $(line) - @echo "Building Driver" + @echo "Booting Driver" $(line) - @$(MAKE) -C driver all + @$(MAKE) -C driver boot depend $(line) - @echo "Building Includes" + @echo "Booting Includes" $(line) - @$(MAKE) -C includes all + @$(MAKE) -C includes boot depend $(line) - @echo "Building Runtime System" + @echo "Booting Runtime System" $(line) - @$(MAKE) -C runtime depend all + @$(MAKE) -C runtime boot depend $(line) - @echo "Building Docs" + @echo "Booting Docs" $(line) - @$(MAKE) -C docs depend all + @$(MAKE) -C docs boot -ifeq ($(HaskellCompilerType), HC_USE_HC_FILES) - $(BuildLibs) - $(BuildCompiler) -else - $(BuildCompiler) - $(BuildLibs) -endif - -# "CONTRIB" is also a SUBDIR, but there is nothing to build there. -SUBDIRS = utils driver includes runtime docs compiler lib + $(line) + @echo "Booting Compiler" + $(line) + @$(MAKE) -C compiler boot -# Make the required directories for install. + $(line) + @echo "Booting Prelude libraries" + $(line) + @$(MAKE) -C compiler boot -install_dirs :: - $(MKDIRHIER) $(INSTBINDIR_GHC) - $(MKDIRHIER) $(INSTSCRIPTDIR_GHC) - $(MKDIRHIER) $(INSTLIBDIR_GHC) - $(MKDIRHIER) $(INSTLIBDIR_GHC)/includes - $(MKDIRHIER) $(INSTDATADIR_GHC) - $(MKDIRHIER) $(INSTDATADIR_GHC)/includes - $(MKDIRHIER) $(INSTDATADIR_GHC)/imports -install :: install_dirs +# "CONTRIB" is also a SUBDIR, but there is nothing to build there. +# +# leave out docs for the moment -- SOF +# +# Order is important! driver/ has to come before includes/ which +# again has to come before the rest. +# +# If we're booting from .hc files, swap the order +# we descend into compiler/ and lib/ +# +ifeq "$(GhcWithHscBuiltViaC)" "NO" +SUBDIRS = utils driver includes runtime compiler lib +else +SUBDIRS = utils driver includes runtime lib compiler +endif -include $(TOP)/mk/subdir.mk +include $(TOP)/mk/target.mk diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h index c630c8dcfa..2a2b376b0d 100644 --- a/ghc/compiler/HsVersions.h +++ b/ghc/compiler/HsVersions.h @@ -36,6 +36,7 @@ you will screw up the layout where they are used in case expressions! # define _GT GT # define _Addr GHCbase.Addr # define Text Show +# define IMP_FASTSTRING() # define IMP_Ubiq() IMPORT_DELOOPER(Ubiq); import qualified GHCbase # define CHK_Ubiq() IMPORT_DELOOPER(Ubiq); import qualified GHCbase # define minInt (minBound::Int) @@ -45,8 +46,9 @@ you will screw up the layout where they are used in case expressions! # define EXP_MODULE(a) a.. # define IMPORT_DELOOPER(mod) import mod # define IMPORT_1_3(mod) {--} -# define IMP_Ubiq() IMPORT_DELOOPER(Ubiq) -# define CHK_Ubiq() IMPORT_DELOOPER(Ubiq) +# define IMP_FASTSTRING() import FastString +# define IMP_Ubiq() IMPORT_DELOOPER(Ubiq) ; import FastString +# define CHK_Ubiq() IMPORT_DELOOPER(Ubiq) ; import FastString #endif #if __GLASGOW_HASKELL__ >= 26 && __GLASGOW_HASKELL__ < 200 @@ -107,21 +109,21 @@ you will screw up the layout where they are used in case expressions! #if __GLASGOW_HASKELL__ >= 23 # define USE_FAST_STRINGS 1 # if __GLASGOW_HASKELL__ < 200 -# define FAST_STRING _PackedString -# define SLIT(x) (_packCString (A# x#)) +# define FAST_STRING FastString {-_PackedString -} +# define SLIT(x) (mkFastCharString (A# (x#))) {- (_packCString (A# x#)) -} # define _CMP_STRING_ cmpPString /* cmpPString defined in utils/Util.lhs */ -# define _NULL_ _nullPS -# define _NIL_ _nilPS -# define _CONS_ _consPS -# define _HEAD_ _headPS -# define _TAIL_ _tailPS -# define _LENGTH_ _lengthPS -# define _PK_ _packString -# define _UNPK_ _unpackPS -# define _SUBSTR_ _substrPS -# define _APPEND_ `_appendPS` -# define _CONCAT_ _concatPS +# define _NULL_ nullFastString {-_nullPS-} +# define _NIL_ (mkFastString "") {-_nilPS -} +# define _CONS_ consFS {-_consPS-} +# define _HEAD_ headFS {-_headPS-} +# define _TAIL_ tailFS {-_tailPS-} +# define _LENGTH_ lengthFS {-_lengthPS-} +# define _PK_ mkFastString {-_packString-} +# define _UNPK_ unpackFS {-_unpackPS-} + /* # define _SUBSTR_ _substrPS */ +# define _APPEND_ `appendFS` {-`_appendPS`-} +# define _CONCAT_ concatFS {-_concatPS-} # else # define FAST_STRING GHCbase.PackedString # define SLIT(x) (packCString (GHCbase.A# x#)) diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index dcf06812d8..b0b54d0a9b 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,260 +1,345 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.7 1997/01/17 00:32:23 simonpj Exp $ +# $Id: Makefile,v 1.8 1997/03/14 07:55:43 simonpj Exp $ -TOP = ../.. -FlexSuffixRules = YES -YaccSuffixRules = YES -SuffixRule_WantStdOnes = NO -include $(TOP)/ghc/mk/ghc.mk - -# Problem: don't know whether GhcWithHscBuiltViaC until now, so we have -# to re-include rules.mk to get the correct suffix rules. - -FlexSuffixRules = -YaccSuffixRules = -ifeq ($(GhcWithHscBuiltViaC),YES) - HC = $(GHC) - SuffixRule_hc_o = YES -else - HaskellSuffixRules = YES -endif -include $(TOP)/mk/rules.mk +TOP = .. +include $(TOP)/mk/boilerplate.mk #----------------------------------------------------------------------------- -# make libhsp.a - -YFLAGS = -d -v -CFLAGS = -Iparser -I. -IcodeGen -ARCHIVE = libhsp.a -DESTDIR = $(INSTLIBDIR_GHC) -UGN = $(wildcard parser/*.ugn) -UGNC = $(patsubst %.ugn, %.c, $(UGN)) -UGNH = $(patsubst %.ugn, %.h, $(UGN)) -UGNHS = $(patsubst parser/%.ugn, parser/U_%.hs, $(UGN)) -LIBOBJS = \ - $(patsubst %.c, %.o, $(UGNC)) parser/hslexer.o parser/hsparser.tab.o \ - parser/id.o parser/infix.o parser/syntax.o parser/type2context.o \ - parser/util.o - -parser/%.h parser/%.c parser/U_%.hs : parser/%.ugn - @$(RM) $@ parser/$*.hs parser/U_$*.hs parser/$*.h - $(UGEN) $< || $(RM) parser/$*.h parser/$*.hs - @$(MV) -f parser/$*.hs parser/U_$*.hs - @chmod 444 parser/$*.h parser/U_$*.hs - -parser/%.o : parser/%.c $(UGNH) - @$(RM) $@ - $(CC) $(CFLAGS) -c $< -o $@ - -clean :: - $(RM) parser/hslexer.c parser/hsparser.tab.h parser/hsparser.tab.c - -parser/hslexer.o : parser/hslexer.c parser/hsparser.tab.h - -include $(TOP)/mk/lib.mk +# Building hsc different ways (default is just `normal' sequential) +WAYS=$(GhcCompilerWays) #----------------------------------------------------------------------------- +# Set SUBDIRS ifeq ($(IncludeTestDirsInBuild),YES) SUBDIRS = tests endif -ifeq ($(Ghc2_0),YES) - %.hi : %_1_3.lhi - $(RM) $@ - $(GHC_UNLIT) $< $@ || ( $(RM) $@ && exit 1 ) - @chmod 444 $@ -else - %.hi : %.lhi - $(RM) $@ - $(GHC_UNLIT) $< $@ || ( $(RM) $@ && exit 1 ) - @chmod 444 $@ -endif +# ----------------------------------------------------------------------------- +# Set HS_PROG, LIBRARY +# Setting HS_PROG and LIBRARY causes all targets in target.mk +# (included below) to kick in. + +LIBRARY=libhsp.a +HS_PROG=hsc + + +# ----------------------------------------------------------------------------- +# Set SRCS, LOOPS, HCS, OBJS +# +# First figure out DIRS, the source sub-directories +# Then derive SRCS by looking in them +# DIRS = \ utils basicTypes types hsSyn prelude rename typecheck deSugar coreSyn \ specialise simplCore stranal stgSyn simplStg codeGen absCSyn main \ reader profiling parser -# ----------------------------------------------------------------------------- -# optional directories ifeq ($(GhcWithDeforester),YES) DIRS += deforest endif ifeq ($(GhcWithNativeCodeGen),YES) - DIRS += nativeGen -else ifeq ($(GhcWithHscBuiltViaC),YES) # If building via C, we *assume* that it is the distributed C files, # which do not have a native-code generator in them else DIRS += nativeGen endif +else +SRC_HC_OPTS += -DOMIT_NATIVE_CODEGEN endif -# ----------------------------------------------------------------------------- -# wildcard to get the lists of sources/objects -INCLUDEDIRS = $(foreach dir,$(DIRS),-i$(dir)) -SRCS = \ - $(foreach dir,$(DIRS),$(wildcard $(dir)/*.lhs)) \ - $(UGNHS) rename/ParseIface.hs \ - main/LoopHack.hc +HS_SRCS = $(SRCS_UGNHS) \ + $(foreach dir,$(DIRS),$(wildcard $(dir)/*.lhs)) \ + rename/ParseIface.hs rename/ParseType.hs rename/ParseUnfolding.hs \ + main/LoopHack.hc -# LoopHack.lhc is an SLPJ addition to fix a profiling problem. See comments -# inside it. +# 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. -LOOPS = $(patsubst %.lhi, %.hi, $(wildcard */*.lhi)) -HCS = $(patsubst %.hs, %.hc, $(patsubst %.lhs, %.hc, $(SRCS))) -OBJS = \ - $(patsubst %.hc, %.o, $(HCS)) rename/ParseIface.o \ - parser/hsclink.o parser/hschooks.o libhsp.a \ - main/LoopHack.o +LOOPS = $(patsubst %.lhi, %.hi, $(wildcard */*.lhi)) +HCS = $(patsubst %.lhs, %.hc, $(patsubst %.hs, %.hc, $(HS_SRCS))) -main/LoopHack.hc : main/LoopHack.lhc - $(RM) $@ - $(GHC_UNLIT) $< $@ || ( $(RM) $@ && exit 1 ) - @chmod 444 $@ +HS_OBJS = \ + $(patsubst %.hc, %.o, $(HCS)) \ + parser/hsclink.o parser/hschooks.o libhsp.a + + +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) + +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 -main/LoopHack.o : main/LoopHack.hc - $(HC) -v -c $(HC_OPTS) $< +# +# stuff you get for free in a source distribution +# +SRC_DIST_FILES += rename/ParseIface.hs \ + rename/ParseType.hs rename/ParseUnfolding.hs \ + parser/U_tree.c parser/tree.h parser/tree.c \ + parser/hsparser.tab.c parser/hsparser.tab.h \ + parser/hslexer.c # ----------------------------------------------------------------------------- -# options for the Haskell compiler +# Haskell compilations -MAKEFLAGS += --no-builtin-rules +# Compiler to use for building hsc +# +HC=$(WithGhcHc) -HC_OPTS += \ - -cpp $(HcMaxHeapFlag) $(HcMaxStackFlag) -fhaskell-1.3 \ +SRC_HC_OPTS += \ + -cpp -fhaskell-1.3 -syslib ghc \ -fglasgow-exts -DCOMPILING_GHC -Rghc-timing -I. -IcodeGen \ - -InativeGen -Iparser $(INCLUDEDIRS) + -InativeGen -Iparser $(foreach dir,$(DIRS),-i$(dir)) -# expect 12 shift/reduce conflicts and 0 reduce/reduce conflicts +# -syslib ghc just needed for utils/CharSeq.lhs use of PackedString.hPutPS -ifeq ($(GhcWithHscDebug),YES) - HC_OPTS += -DDEBUG - CFLAGS += -DDEBUG -endif -ifneq ($(Ghc2_0),YES) - HC_OPTS += -fomit-derived-read -fomit-reexported-instances -endif +SRC_CC_OPTS += -Iparser -I. -ifeq ($(GhcWithHscOptimised),YES) - HC_OPTS += -O -fshow-import-specs +ifneq ($(Ghc2_0),NO) + SRC_HC_OPTS += -fomit-derived-read -fomit-reexported-instances endif ifeq ($(GhcWithDeforester),NO) - HC_OPTS += -DOMIT_DEFORESTER + SRC_HC_OPTS += -DOMIT_DEFORESTER +endif + +SRC_HC_OPTS += $(GhcHcOpts) + +# Special flags for particular modules +# The standard suffix rule for compiling a Haskell file +# adds these flags to the command line + +absCSyn/AbsCSyn_HC_OPTS = -fno-omit-reexported-instances +basicTypes/IdInfo_HC_OPTS = -K2m +coreSyn/AnnCoreSyn_HC_OPTS = -fno-omit-reexported-instances +hsSyn/HsExpr_HC_OPTS = -K2m +hsSyn/HsSyn_HC_OPTS = -fno-omit-reexported-instances +main/Main_HC_OPTS = -fvia-C +main/CmdLineOpts_HC_OPTS = -fvia-C +nativeGen/PprMach_HC_OPTS = -K2m +parser/UgenAll_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +parser/UgenUtil_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +parser/U_constr_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +parser/U_binding_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +parser/U_pbinding_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +parser/U_entidt_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_maybe_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +parser/U_either_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +parser/U_qid_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +parser/U_tree_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +parser/U_ttype_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +prelude/PrimOp_HC_OPTS = -K3m +reader/Lex_HC_OPTS = -K2m +reader/ReadPrefix_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +rename/ParseIface_HC_OPTS = -Onot -H16m +rename/ParseType_HC_OPTS = -Onot -H16m +rename/ParseUnfolding_HC_OPTS = -Onot -H16m +ifeq "$(TARGETPLATFORM)" "hppa1.1-hp-hpux9" +rename/RnMonad_HC_OPTS = -fvia-C -O2 -O2-for-C +else +rename/RnMonad_HC_OPTS = -fvia-C endif +rename/RnEnv_HC_OPTS = -fvia-C +rename/RnSource_HC_OPTS = -H12m +rename/RnIfaces_HC_OPTS = -H8m -fvia-C +rename/RnNames_HC_OPTS = -H12m +specialise/Specialise_HC_OPTS = -Onot -H12m +stgSyn/StgSyn_HC_OPTS = -fno-omit-reexported-instances +typecheck/TcMonad_HC_OPTS = -fvia-C +typecheck/TcGenDeriv_HC_OPTS = -H10m +typecheck/TcExpr_HC_OPTS = -H10m +utils/Argv_HC_OPTS = -fvia-C +utils/CharSeq_HC_OPTS = -fvia-C +utils/SST_HC_OPTS = -fvia-C +utils/PrimPacked_HC_OPTS = -fvia-C -monly-3-regs +utils/FastString_HC_OPTS = -fvia-C +utils/StringBuffer_HC_OPTS = -fvia-C + + +# ---------------------------------------------------------------------------- +# C compilations + +SRC_C_OPTS += -O -Iparser -I. -IcodeGen + # ---------------------------------------------------------------------------- +# Parsers -all :: hsc libhsp.a +# Main parser uses Yacc/Bison +SRC_YACC_OPTS += -d -v -hsc : $(OBJS) -# $(HC) -no-link-chk "-pgml time /projects/pacsoft/ghc/src/pureatria/purelink-1.2.2-solaris2/purelink gcc" $(HC_OPTS) $(EXTRA_HC_OPTS) -o $@ $^ - $(HC) -no-link-chk "-pgml time gcc -B/projects/unsupported/gnu/sparc-sunos5/bin/g" $(HC_OPTS) $(EXTRA_HC_OPTS) -o $@ $^ -# $(HC) -no-link-chk "-pgml time gcc" $(HC_OPTS) $(EXTRA_HC_OPTS) -o $@ $^ +# +# Want to keep the intermediate (included in src distribs). +# +.PRECIOUS: parser/%.tab.c parser/hslexer.c parser/hschooks.o : parser/hschooks.c @$(RM) $@ $(HC) -c -o $@ $(HCFLAGS) parser/hschooks.c + +# Interface-file parser uses Happy +SRC_HAPPY_OPTS += +RTS -K2m -H10m -RTS + rename/ParseIface.hs : rename/ParseIface.y @$(RM) rename/ParseIface.hs rename/ParseIface.hinfo - happy +RTS -K2m -H10m -RTS -g rename/ParseIface.y + $(HAPPY) $(HAPPY_OPTS) -g rename/ParseIface.y @chmod 444 rename/ParseIface.hs -# ---------------------------------------------------------------------------- -# Special extra dependencies for yukky ugen stuff +rename/ParseType.hs : rename/ParseType.y + @$(RM) rename/ParseType.hs rename/ParseType.hinfo + $(HAPPY) $(HAPPY_OPTS) -g rename/ParseType.y + @chmod 444 rename/ParseType.hs -hspincl.h : $(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 -reader/ReadPrefix.o : parser/hspincl.h +rename/ParseUnfolding.hs : rename/ParseUnfolding.y + @$(RM) rename/ParseUnfolding.hs rename/ParseUnfolding.hinfo + $(HAPPY) $(HAPPY_OPTS) -g rename/ParseUnfolding.y + @chmod 444 rename/ParseUnfolding.hs -# ---------------------------------------------------------------------------- -# Special flags for particular modules - -absCSyn/AbsCSyn_flags = -fno-omit-reexported-instances -hsSyn/HsExpr_flags = -K2m -hsSyn/HsSyn_flags = -fno-omit-reexported-instances -main/Main_flags = -fvia-C -basicTypes/IdInfo_flags = -K2m -main/CmdLineOpts_flags = -fvia-C -coreSyn/AnnCoreSyn_flags = -fno-omit-reexported-instances -nativeGen/PprMach_flags = -K2m -parser/UgenAll_flags = -fvia-C '-\#include"hspincl.h"' -parser/UgenUtil_flags = -fvia-C '-\#include"hspincl.h"' -parser/U_constr_flags = -fvia-C '-\#include"hspincl.h"' -parser/U_binding_flags = -fvia-C '-\#include"hspincl.h"' -parser/U_pbinding_flags = -fvia-C '-\#include"hspincl.h"' -parser/U_entidt_flags = -fvia-C '-\#include"hspincl.h"' -parser/U_list_flags = -fvia-C '-\#include"hspincl.h"' -parser/U_literal_flags = -fvia-C '-\#include"hspincl.h"' -parser/U_maybe_flags = -fvia-C '-\#include"hspincl.h"' -parser/U_either_flags = -fvia-C '-\#include"hspincl.h"' -parser/U_qid_flags = -fvia-C '-\#include"hspincl.h"' -parser/U_tree_flags = -fvia-C '-\#include"hspincl.h"' -parser/U_ttype_flags = -fvia-C '-\#include"hspincl.h"' -prelude/PrimOp_flags = -K3m -reader/ReadPrefix_flags = -fvia-C '-\#include"hspincl.h"' -rename/ParseIface_flags = -Onot -H16m -rename/RnMonad_flags = -fvia-C -rename/RnSource_flags = -H12m -rename/RnIfaces_flags = -H8m -rename/RnNames_flags = -H12m -specialise/Specialise_flags = -Onot -H12m -stgSyn/StgSyn_flags = -fno-omit-reexported-instances -typecheck/TcMonad_flags = -fvia-C -typecheck/TcGenDeriv_flags = -H10m -typecheck/TcExpr_flags = -H10m -utils/Argv_flags = -fvia-C -utils/CharSeq_flags = -fvia-C -utils/SST_flags = -fvia-C +#---------------------------------------------------------------------- +# +# Building the stand-alone parser +# +all :: hsp + +hsp: parser/printtree.o parser/main.o libhsp.a + $(CC) -o $@ $(CC_OPTS) $^ + +#----------------------------------------------------------------------------- +# Interface files + +# LoopHack.lhc is an SLPJ addition to fix a profiling problem. See comments +# inside it. (compilation is handled by the suffix rules). + +# +# Building the loop breakers from .lhi files +# +ifeq ($(Ghc2_0),YES) + %.hi : %_1_3.lhi + $(RM) $@ + $(UNLIT) $< $@ || ( $(RM) $@ && exit 1 ) + @chmod 444 $@ +else + %.hi : %.lhi + $(RM) $@ + $(UNLIT) $< $@ || ( $(RM) $@ && exit 1 ) + @chmod 444 $@ +endif + +#----------------------------------------------------------------------------- +# Linking + +SRC_LD_OPTS += -no-link-chk + +# Build-specific +#SRC_LD_OPTS += "-pgml time gcc -B/projects/unsupported/gnu/sparc-sunos5/bin/g" + + +#----------------------------------------------------------------------------- +# install + +# We don't want hsc treated as an ordinary executable, +# but put it together with the libraries. +# Also don't want any interface files intstalled + +INSTALL_LIBEXECS += hsc hsp #----------------------------------------------------------------------------- -# make depend, clean, tags and install +# depend + +# If we're using a 1.2 compiler to compile the compiler, need the old mkdepend stuff +# +# ToDo: define sep MKDEPENDHS_1.2 variable so that it can be readily overridden +# in a build.mk file. +# +ifeq ($(Ghc2_0),NO) +MKDEPENDHS = $(MKDEPENDHS_1_2) +endif -depend :: $(LOOPS) +# +# Before doing `make depend', need to build all derived Haskell source files +# +depend :: $(LOOPS) $(SRCS_UGNHS) rename/ParseIface.hs rename/ParseUnfolding.hs rename/ParseType.hs -MKDEPENDHSFLAGS = -f .depend -I../includes -x HsVersions.h ifeq ($(GhcWithDeforester),NO) - MKDEPENDHSFLAGS += -DOMIT_DEFORESTER + SRC_MKDEPENDHS_OPTS += -DOMIT_DEFORESTER +endif + +ifeq ($(Ghc2_0),YES) +SRC_MKDEPENDHS_OPTS += $(SRC_HC_OPTS) endif ifeq ($(GhcWithHscBuiltViaC),YES) - MKDEPENDHSFLAGS += -o .hc + SRC_MKDEPENDHS_OPTS += -o .hc else - HS_DEP_SRCS = $(SRCS) # should add $(LOOPS) ? - include $(TOP)/mk/hsdepend.mk + SRCS_MKDEPENDHS = $(SRCS_HC) # should add $(LOOPS) ? endif -clean :: - $(RM) */*.o */*.hi $(UGNC) $(UGNH) $(UGNHS) - $(RM) rename/ParseIface.hs -veryclean :: - $(RM) */*.hc +#----------------------------------------------------------------------------- +# 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 + +# Extra tidy, remove the .hc files (if you've got them). +MAINTAINER_CLEAN_FILES += $(wildcard */*.hc) + + +#----------------------------------------------------------------------------- +# TAGS + +SRC_HSTAGS_OPTS += -fglasgow-exts -cpp + + +#----------------------------------------------------------------------------- +# Include target-rule boilerplate + +include $(TOP)/mk/target.mk + +# +# Special extra dependencies for yukky ugen stuff +# -tags :: - @$(RM) TAGS - @touch TAGS - $(HSTAGS) -I../includes $(HSTAGSFLAGS) $(SRCS) +parser/%.o : parser/%.c $(SRCS_UGNH) +parser/hslexer.o : parser/hslexer.c parser/hsparser.tab.h -install :: - $(INSTALL) $(INSTBINFLAGS) hsc $(INSTLIBDIR_GHC) +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 diff --git a/ghc/compiler/NOTES b/ghc/compiler/NOTES new file mode 100644 index 0000000000..6ad337559d --- /dev/null +++ b/ghc/compiler/NOTES @@ -0,0 +1,129 @@ +* CHECK that the things seek_liftable found are done in Core + +* CHECK that there aren't too many indirections in STG + local = ... + global = local Int + +Interface files +~~~~~~~~~~~~~~~ +* Don't need to pin a kind on the type variable in a interface class decl, + because it'll be correctly re-inferred when we read it in. + +* The double semicolon at the end of an interface-file signature is so that + the lexer can run through the pragmas very fast when -O isn't being used. + +* In export lists, T!(A,B) says that constructors A and B are exported, + but not the type T. Similarly for classes. + +=========================================================================== + + Nofib failures + ~~~~~~~~~~~~~~ + +* spectral/hartel/wave4main, wang, spectral/simple, real/symalg + +Bus error + +* real/anna + +expected stdout not matched by reality +*** big.sum.out Thu Aug 22 14:37:05 1996 +--- /tmp/runtest21900.1 Mon Jan 20 17:57:49 1997 +*************** +*** 1 **** +! 12796 49 +--- 1 ---- +! 63325 97 + + +* /real/compress2 + +expected stderr not matched by reality +Warning: missing newline at end of file /tmp/runtest14691.2 +*** /tmp/no_stderr14691 Thu Jan 23 14:33:29 1997 +--- /tmp/runtest14691.2 Thu Jan 23 14:33:29 1997 +*************** +*** 0 **** +--- 1,2 ---- ++ ++ Fail: Prelude.Enum.Char.toEnum:out of range + + +* real/ebnf2ps + +IOSupplement.hs: 43: value not in scope: getEnv + + ...and... + +HappyParser.hs: 127: Couldn't match the type + [HappyParser.Token'] against PrelBase.Int + Expected: HappyParser.HappyReduction + Inferred: PrelBase.Int -> HappyParser.Token' -> HappyParser.HappyState HappyParser.Token' ([HappyParser.HappyAbsSyn] -> [AbstractSyntax.Production]) -> PrelBase.Int -> PrelBase.Int -> o{-a1yN-} -> o{-a1yO-} -> [HappyParser.Token'] -> a{-a1yP-} + In an equation for function HappyParser.action_1: + HappyParser.action_1 _ = HappyParser.happyFail + + +* GHC_ONLY/bugs/andy_cherry + +DataTypes.lhs: 3: Could not find valid interface file for `GenUtils' + +Need "make depend" + +* GHC_ONLY/bugs/lex + +Pattern match fail in lex; must be producing empty or multi-valued result + +Aggravated by dreadful error messages: ++ ++ Fail: In irrefutable pattern ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matching ++ Fail: In pattern-matchingtoo many nested calls to `error' + + +* GHC_ONLY/bugs/jtod_circint + +Main.hs: 12: No instance for: Signal.Signal (Signal.Stream Bit.Bit) + Main.hs: 12: at a use of an overloaded identifier: `Signal.one' + +instance-decl slurping is WRONG + +* GHC_ONLY/arith005 + +ceiling doesn't work properly + +--- 1,3 ---- ++ [1, 1, 2, 3, 4, 5, 0, -2, -3, -4, 1000013, 124, 101, 103, 1, 0, 17001, 0, 1, 4] ++ [1, 1, 2, 3, 4, 5, 0, -2, -3, -4, 1000013, 124, 101, 103, 1, 0, 17001, 0, 1, 4] + [0, 0, 2, 3, 4, 5, -1, -2, -3, -4, 1000012, 124, 101, 103, 1, 0, 17000, 0, 1, 4] +*************** +*** 2,5 **** + [0, 0, 2, 3, 4, 5, -1, -2, -3, -4, 1000012, 124, 101, 103, 1, 0, 17000, 0, 1, 4] +- [0, 0, 2, 3, 4, 5, -1, -2, -3, -4, 1000012, 124, 101, 103, 1, 0, 17000, 0, 1, 4] +- [0, 0, 2, 3, 4, 5, -1, -2, -3, -4, 1000012, 124, 101, 103, 1, 0, 17000, 0, 1, 4] + [0, 0, 1, 2, 3, 4, -1, -3, -4, -5, 1000012, 123, 100, 102, 0, -1, 17000, -1, 0, 3] +--- 4,5 ---- + + +* GHC_ONLY/bugs/lennart_array + +Wrong array semantics (but who cares?) + +* GHC_ONLY/bugs/life_space_leak + +-n *** sum I got: +0 0 +-n *** sum I expected: +02845 1350 diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 98464fa3eb..7c9444c601 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -363,12 +363,12 @@ pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = uppPStr SLIT("BH_UPD_info") pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset)) = uppBesides [uppPStr SLIT("__sel_info_"), uppStr (show offset), - uppStr (if upd_reqd then "upd" else "noupd"), + uppPStr (if upd_reqd then SLIT("upd") else SLIT("noupd")), uppPStr SLIT("__")] pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset)) = uppBesides [uppPStr SLIT("__sel_entry_"), uppStr (show offset), - uppStr (if upd_reqd then "upd" else "noupd"), + uppPStr (if upd_reqd then SLIT("upd") else SLIT("noupd")), uppPStr SLIT("__")] pprCLabel sty (IdLabel (CLabelId id) flavor) diff --git a/ghc/compiler/absCSyn/Costs.lhs b/ghc/compiler/absCSyn/Costs.lhs index 5c03e36d6d..4c0a636ff9 100644 --- a/ghc/compiler/absCSyn/Costs.lhs +++ b/ghc/compiler/absCSyn/Costs.lhs @@ -367,8 +367,9 @@ stmtMacroCosts macro modes = GRAN_FETCH -> nullCosts {- GrAnSim bookkeeping -} GRAN_RESCHEDULE -> nullCosts {- GrAnSim bookkeeping -} GRAN_FETCH_AND_RESCHEDULE -> nullCosts {- GrAnSim bookkeeping -} + GRAN_YIELD -> nullCosts {- GrAnSim bookkeeping -- added SOF -} THREAD_CONTEXT_SWITCH -> nullCosts {- GrAnSim bookkeeping -} - _ -> trace "Costs.stmtMacroCosts" nullCosts + _ -> trace ("Costs.stmtMacroCosts: "++show macro) nullCosts -- --------------------------------------------------------------------------- diff --git a/ghc/compiler/absCSyn/HeapOffs.lhs b/ghc/compiler/absCSyn/HeapOffs.lhs index 0958307f37..ee58c6f5a1 100644 --- a/ghc/compiler/absCSyn/HeapOffs.lhs +++ b/ghc/compiler/absCSyn/HeapOffs.lhs @@ -305,7 +305,7 @@ pprHeapOffsetPieces sty int_offs fxdhdr_offs varhdr_offs tothdr_offs else if fxdhdr_offs _EQ_ ILIT(1) then Just (uppPStr SLIT("_FHS")) else - Just (uppBesides [uppStr "(_FHS*", uppInt IBOX(fxdhdr_offs), uppChar ')']) + Just (uppBesides [uppChar '(', uppPStr SLIT("_FHS*"), uppInt IBOX(fxdhdr_offs), uppChar ')']) pp_varhdr_offs = pp_hdrs (uppPStr SLIT("_VHS")) varhdr_offs diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index e73bf1576f..b2e60c492a 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -88,7 +88,7 @@ emitMacro :: CostRes -> Unpretty -- ToDo: Check a compile time flag to decide whether a macro should be emitted emitMacro (Cost (i,b,l,s,f)) - = uppBesides [ uppStr "GRAN_EXEC(", + = uppBesides [ uppPStr SLIT("GRAN_EXEC"), uppChar '(', uppInt i, uppComma, uppInt b, uppComma, uppInt l, uppComma, uppInt s, uppComma, uppInt f, pp_paren_semi ] \end{code} @@ -114,21 +114,21 @@ pprAbsC sty (CAssign dest src) _ = pprAssign sty (getAmodeRep dest) dest src pprAbsC sty (CJump target) c = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CJump */"-} ]) - (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ]) + (uppBesides [ uppStr jmp_lit, pprAmode sty target, pp_paren_semi ]) pprAbsC sty (CFallThrough target) c = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CFallThrough */"-} ]) - (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ]) + (uppBesides [ uppStr jmp_lit, pprAmode sty target, pp_paren_semi ]) -- -------------------------------------------------------------------------- -- Spit out GRAN_EXEC macro immediately before the return HWL pprAbsC sty (CReturn am return_info) c = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <---- CReturn */"-} ]) - (uppBesides [uppStr "JMP_(", target, pp_paren_semi ]) + (uppBesides [uppStr jmp_lit, target, pp_paren_semi ]) where target = case return_info of - DirectReturn -> uppBesides [uppStr "DIRECT(", pprAmode sty am, uppRparen] + DirectReturn -> uppBesides [uppPStr SLIT("DIRECT"),uppChar '(', pprAmode sty am, uppRparen] DynamicVectoredReturn am' -> mk_vector (pprAmode sty am') StaticVectoredReturn n -> mk_vector (uppInt n) -- Always positive mk_vector x = uppBesides [uppLparen, pprAmode sty am, uppStr ")[RVREL(", x, uppStr ")]"] @@ -232,7 +232,7 @@ pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _ -- hence we can toss the provided cast... pprAbsC sty (CSimultaneous abs_c) c - = uppBesides [uppStr "{{", pprAbsC sty abs_c c, uppStr "}}"] + = uppBesides [uppPStr SLIT("{{"), pprAbsC sty abs_c c, uppPStr SLIT("}}")] pprAbsC sty stmt@(CMacroStmt macro as) _ = uppBesides [uppStr (show macro), uppLparen, @@ -285,7 +285,7 @@ pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ PprForC -> pp_exts _ -> uppNil, uppBesides [ - uppStr "SET_STATIC_HDR(", + uppPStr SLIT("SET_STATIC_HDR"),uppChar '(', pprCLabel sty closure_lbl, uppComma, pprCLabel sty info_lbl, uppComma, if_profiling sty (pprAmode sty cost_centre), uppComma, @@ -295,7 +295,7 @@ pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ ], uppNest 2 (uppBesides (map (ppr_item sty) amodes)), uppNest 2 (uppBesides (map (ppr_item sty) padding_wds)), - uppStr "};" ] + uppPStr SLIT("};") ] } where info_lbl = infoTableLabelFromCI cl_info @@ -328,7 +328,7 @@ pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liven = uppAboves [ uppBesides [ pp_info_rep, - uppStr "_ITBL(", + uppPStr SLIT("_ITBL"),uppChar '(', pprCLabel sty info_lbl, uppComma, -- CONST_ITBL needs an extra label for @@ -404,16 +404,16 @@ pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liven pp_type = uppBesides [uppChar '"', uppStr (stringToC (closureTypeDescr cl_info)), uppChar '"'] pprAbsC sty (CRetVector lbl maybes deflt) c - = uppAboves [ uppStr "{ // CRetVector (lbl????)", + = uppAboves [ uppPStr SLIT("{ // CRetVector (lbl????)"), uppNest 8 (uppSep (map (ppr_maybe_amode sty) maybes)), uppStr "} /*default=*/ {", pprAbsC sty deflt c, - uppStr "}"] + uppChar '}'] where ppr_maybe_amode sty Nothing = uppPStr SLIT("/*default*/") ppr_maybe_amode sty (Just a) = pprAmode sty a pprAbsC sty stmt@(CRetUnVector label amode) _ - = uppBesides [uppStr "UNVECTBL(", pp_static, uppComma, pprCLabel sty label, uppComma, + = uppBesides [uppPStr SLIT("UNVECTBL"),uppChar '(', pp_static, uppComma, pprCLabel sty label, uppComma, pprAmode sty amode, uppRparen] where pp_static = if externallyVisibleCLabel label then uppNil else uppPStr SLIT("static") @@ -442,15 +442,20 @@ ppLocalness label const = if not (isReadOnly label) then uppNil else uppPStr SLIT("const") ppLocalnessMacro for_fun{-vs data-} clabel - = case (if externallyVisibleCLabel clabel then "E" else "I") of { prefix -> - case (if isReadOnly clabel then "RO_" else "") of { suffix -> - if for_fun - then uppStr (prefix ++ "F_") - else uppStr (prefix ++ "D_" ++ suffix) - } } + = uppBesides [ uppChar (if externallyVisibleCLabel clabel then 'E' else 'I'), + if for_fun then + uppPStr SLIT("F_") + else + uppBeside (uppPStr SLIT("D_")) + (if isReadOnly clabel then + uppPStr SLIT("RO_") + else + uppNil)] \end{code} \begin{code} +jmp_lit = "JMP_(" + grab_non_void_amodes amodes = filter non_void amodes @@ -662,7 +667,7 @@ pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vo (uppBesides [ if null non_void_results then uppNil - else uppPStr SLIT("%r = "), + else uppStr "%r = ", uppLparen, uppPStr op_str, uppLparen, uppIntersperse uppComma ccall_args, uppStr "));" @@ -693,13 +698,14 @@ ppr_casm_arg sty amode a_num -- for array arguments, pass a pointer to the body of the array -- (PTRS_ARR_CTS skips over all the header nonsense) ArrayRep -> (pp_kind, - uppBesides [uppStr "PTRS_ARR_CTS(", pp_amode, uppRparen]) + uppBesides [uppPStr SLIT("PTRS_ARR_CTS"),uppChar '(', pp_amode, uppRparen]) ByteArrayRep -> (pp_kind, - uppBesides [uppStr "BYTE_ARR_CTS(", pp_amode, uppRparen]) + uppBesides [uppPStr SLIT("BYTE_ARR_CTS"),uppChar '(', pp_amode, uppRparen]) -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents. ForeignObjRep -> (uppPStr SLIT("StgForeignObj"), - uppBesides [uppStr "ForeignObj_CLOSURE_DATA(", pp_amode, uppStr")"]) + uppBesides [uppPStr SLIT("ForeignObj_CLOSURE_DATA"),uppChar '(', + pp_amode, uppChar ')']) other -> (pp_kind, pp_amode) declare_local_var @@ -750,7 +756,7 @@ ppr_casm_results sty [r] liveness + ForeignObjRep -> (uppPStr SLIT("StgForeignObj"), - uppBesides [ uppStr "constructForeignObj(", + uppBesides [ uppPStr SLIT("constructForeignObj"),uppChar '(', liveness, uppComma, result_reg, uppComma, local_var, @@ -841,10 +847,10 @@ Special treatment for floats and doubles, to avoid unwanted conversions. \begin{code} pprAssign sty FloatRep dest@(CVal reg_rel _) src - = uppBesides [ uppStr "ASSIGN_FLT(", ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ] + = uppBesides [ uppPStr SLIT("ASSIGN_FLT"),uppChar '(', ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ] pprAssign sty DoubleRep dest@(CVal reg_rel _) src - = uppBesides [ uppStr "ASSIGN_DBL(", ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ] + = uppBesides [ uppPStr SLIT("ASSIGN_DBL"),uppChar '(', ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ] \end{code} Lastly, the question is: will the C compiler think the types of the @@ -924,7 +930,7 @@ no-cast case: \begin{code} pprAmode sty amode | mixedTypeLocn amode - = uppParens (uppBesides [ pprPrimKind sty (getAmodeRep amode), uppStr ")(", + = uppParens (uppBesides [ pprPrimKind sty (getAmodeRep amode), uppPStr SLIT(")("), ppr_amode sty amode ]) | otherwise -- No cast needed = ppr_amode sty amode @@ -950,13 +956,13 @@ ppr_amode sty (CTemp uniq kind) = prettyToUn (pprUnique uniq) ppr_amode sty (CLbl label kind) = pprCLabel sty label ppr_amode sty (CUnVecLbl direct vectored) - = uppBesides [uppStr "(StgRetAddr) UNVEC(", pprCLabel sty direct, uppComma, + = uppBesides [uppChar '(',uppPStr SLIT("StgRetAddr"),uppChar ')', uppPStr SLIT("UNVEC"),uppChar '(', pprCLabel sty direct, uppComma, pprCLabel sty vectored, uppRparen] ppr_amode sty (CCharLike char) - = uppBesides [uppStr "CHARLIKE_CLOSURE(", pprAmode sty char, uppRparen ] + = uppBesides [uppPStr SLIT("CHARLIKE_CLOSURE"),uppChar '(', pprAmode sty char, uppRparen ] ppr_amode sty (CIntLike int) - = uppBesides [uppStr "INTLIKE_CLOSURE(", pprAmode sty int, uppRparen ] + = uppBesides [uppPStr SLIT("INTLIKE_CLOSURE"),uppChar '(', pprAmode sty int, uppRparen ] ppr_amode sty (CString str) = uppBesides [uppChar '"', uppStr (stringToC (_UNPK_ str)), uppChar '"'] -- ToDo: are these *used* for anything? @@ -968,10 +974,10 @@ ppr_amode sty (CLitLit str _) = uppPStr str ppr_amode sty (COffset off) = pprHeapOffset sty off ppr_amode sty (CCode abs_C) - = uppAboves [ uppStr "{ -- CCode", uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ] + = uppAboves [ uppPStr SLIT("{ -- CCode"), uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ] ppr_amode sty (CLabelledCode label abs_C) - = uppAboves [ uppBesides [pprCLabel sty label, uppStr " = { -- CLabelledCode"], + = uppAboves [ uppBesides [pprCLabel sty label, uppPStr SLIT(" = { -- CLabelledCode")], uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ] ppr_amode sty (CJoinPoint _ _) @@ -980,7 +986,7 @@ ppr_amode sty (CJoinPoint _ _) ppr_amode sty (CTableEntry base index kind) = uppBesides [uppStr "((", pprPrimKind sty kind, uppStr " *)(", ppr_amode sty base, uppStr "))[(I_)(", ppr_amode sty index, - uppStr ")]"] + uppPStr SLIT(")]")] ppr_amode sty (CMacroExpr pk macro as) = uppBesides [uppLparen, pprPrimKind sty pk, uppStr ")(", uppStr (show macro), uppLparen, @@ -1353,7 +1359,7 @@ ppr_decls_Amode (CUnVecLbl direct vectored) returnTE (Nothing, if (dlbl_seen || not (needsCDecl direct)) && (vlbl_seen || not (needsCDecl vectored)) then Nothing - else Just (uppBesides [uppStr "UNVEC(", ddcl, uppComma, vdcl, uppRparen])) + else Just (uppBesides [uppPStr SLIT("UNVEC"),uppChar '(', ddcl, uppComma, vdcl, uppRparen])) -} ppr_decls_Amode (CUnVecLbl direct vectored) @@ -1369,7 +1375,7 @@ ppr_decls_Amode (CUnVecLbl direct vectored) returnTE (Nothing, if ({-dlbl_seen ||-} not (needsCDecl direct)) && ({-vlbl_seen ||-} not (needsCDecl vectored)) then Nothing - else Just (uppBesides [uppStr "UNVEC(", ddcl, uppComma, vdcl, uppRparen])) + else Just (uppBesides [uppPStr SLIT("UNVEC"),uppChar '(', ddcl, uppComma, vdcl, uppRparen])) ppr_decls_Amode (CTableEntry base index _) = ppr_decls_Amode base `thenTE` \ p1 -> diff --git a/ghc/compiler/basicTypes/Id.hi-boot b/ghc/compiler/basicTypes/Id.hi-boot new file mode 100644 index 0000000000..69169c0efa --- /dev/null +++ b/ghc/compiler/basicTypes/Id.hi-boot @@ -0,0 +1,8 @@ +_interface_ Id 1 +_exports_ + +_declarations_ + +1 type Id = Id.GenId Type.Type ; +1 data GenId ty ; + diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 2a7e85bd88..8419e0deeb 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -797,12 +797,8 @@ mkMethodSelId op_name rec_c op ty = addStandardIdInfo $ Id (uniqueOf op_name) op_name ty (MethodSelId rec_c op) NoPragmaInfo noIdInfo -mkDefaultMethodId op_name uniq rec_c op gen ty - = Id uniq dm_name ty details NoPragmaInfo noIdInfo - where - dm_name = mkCompoundName name_fn uniq op_name - details = DefaultMethodId rec_c op gen - name_fn op_str = SLIT("dm_") _APPEND_ op_str +mkDefaultMethodId dm_name rec_c op gen ty + = Id (uniqueOf dm_name) dm_name ty (DefaultMethodId rec_c op gen) NoPragmaInfo noIdInfo mkDictFunId dfun_name full_ty clas ity = Id (nameUnique dfun_name) dfun_name full_ty details NoPragmaInfo noIdInfo @@ -822,7 +818,7 @@ mkWorkerId u unwrkr ty info where name = mkCompoundName name_fn u (getName unwrkr) details = WorkerId unwrkr - name_fn wkr_str = wkr_str _APPEND_ SLIT("_wrk") + name_fn wkr_str = SLIT("$w") _APPEND_ wkr_str mkInstId u ty name = Id u (changeUnique name u) ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo @@ -866,9 +862,11 @@ mkImported n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info mkPrimitiveId n ty primop = addStandardIdInfo $ Id (nameUnique n) n ty (PrimitiveId primop) NoPragmaInfo noIdInfo + \end{code} \begin{code} + type MyTy a b = GenType (GenTyVar a) b type MyId a b = GenId (MyTy a b) diff --git a/ghc/compiler/basicTypes/IdLoop.lhi b/ghc/compiler/basicTypes/IdLoop.lhi index 86680a8caa..eb21149694 100644 --- a/ghc/compiler/basicTypes/IdLoop.lhi +++ b/ghc/compiler/basicTypes/IdLoop.lhi @@ -3,7 +3,8 @@ Breaks the IdInfo/ loops. \begin{code} interface IdLoop where -import PreludePS ( _PackedString ) +--import PreludePS ( _PackedString ) +import FastString ( FastString ) import PreludeStdIO ( Maybe ) import BinderInfo ( BinderInfo ) @@ -16,7 +17,13 @@ import Id ( externallyVisibleId, isDataCon, isWorkerId, isWrapperId, nullIdEnv, lookupIdEnv, IdEnv(..), Id(..), GenId ) -import CostCentre ( CostCentre ) +import CostCentre ( CostCentre, + noCostCentre, subsumedCosts, cafifyCC, + useCurrentCostCentre, dontCareCostCentre, + overheadCostCentre, preludeCafsCostCentre, + preludeDictsCostCentre, mkAllCafsCC, + mkAllDictsCC, mkUserCC + ) import IdInfo ( IdInfo ) import SpecEnv ( SpecEnv, nullSpecEnv, isNullSpecEnv ) import Literal ( Literal ) @@ -93,8 +100,16 @@ data UnfoldingGuidance | UnfoldIfGoodArgs Int Int [Bool] Int data CostCentre -\end{code} - - - +noCostCentre :: CostCentre +subsumedCosts :: CostCentre +useCurrentCostCentre :: CostCentre +dontCareCostCentre :: CostCentre +overheadCostCentre :: CostCentre +preludeCafsCostCentre :: CostCentre +preludeDictsCostCentre :: Bool -> CostCentre +mkAllCafsCC :: FastString -> FastString -> CostCentre +mkAllDictsCC :: FastString -> FastString -> Bool -> CostCentre +mkUserCC :: FastString -> FastString -> FastString -> CostCentre +cafifyCC :: CostCentre -> CostCentre +\end{code} diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index b94f150229..b561cc3c55 100644 --- a/ghc/compiler/basicTypes/Literal.lhs +++ b/ghc/compiler/basicTypes/Literal.lhs @@ -19,7 +19,7 @@ IMP_Ubiq(){-uitous-} IMPORT_1_3(Ratio) -- friends: -import PrimRep ( PrimRep(..) ) -- non-abstract +import PrimRep ( PrimRep(..), ppPrimRep ) -- non-abstract import TysPrim ( getPrimRepInfo, addrPrimTy, intPrimTy, floatPrimTy, doublePrimTy, charPrimTy, wordPrimTy ) @@ -190,11 +190,11 @@ instance Outputable Literal where ppr sty (MachStr s) | codeStyle sty = ppBesides [ppChar '"', ppStr (stringToC (_UNPK_ s)), ppChar '"'] - | otherwise = ppStr (show (_UNPK_ s)) + | otherwise = ppBesides [ppChar '"', ppPStr s, ppChar '"'] ppr sty lit@(NoRepStr s) | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit) - | otherwise = ppBesides [ppStr "_string_", ppStr (show (_UNPK_ s))] + | otherwise = ppBesides [ppPStr SLIT("_string_"), ppChar '"', ppPStr s,ppChar '"'] ppr sty (MachInt i signed) | codeStyle sty && out_of_range @@ -210,25 +210,25 @@ instance Outputable Literal where ppr sty (MachFloat f) | codeStyle sty = ppBesides [ppCast sty SLIT("(StgFloat)"), ppRational f] - | otherwise = ppBesides [ppStr "_float_", ppRational f] + | otherwise = ppBesides [ppPStr SLIT("_float_"), ppRational f] ppr sty (MachDouble d) = ppRational d ppr sty (MachAddr p) | codeStyle sty = ppBesides [ppCast sty SLIT("(void*)"), ppInteger p] - | otherwise = ppBesides [ppStr "_addr_", ppInteger p] + | otherwise = ppBesides [ppPStr SLIT("_addr_"), ppInteger p] ppr sty lit@(NoRepInteger i _) | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit) - | otherwise = ppCat [ppStr "_integer_", ppInteger i] + | otherwise = ppCat [ppPStr SLIT("_integer_"), ppInteger i] ppr sty lit@(NoRepRational r _) | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit) - | otherwise = ppCat [ppStr "_rational_", ppInteger (numerator r), ppInteger (denominator r)] + | otherwise = ppCat [ppPStr SLIT("_rational_"), ppInteger (numerator r), ppInteger (denominator r)] ppr sty (MachLitLit s k) | codeStyle sty = ppPStr s - | otherwise = ppBesides [ppStr "_litlit_", ppStr (show (_UNPK_ s))] + | otherwise = ppBesides [ppPStr SLIT("_litlit_ "), ppPrimRep k, ppStr " \"", ppPStr s, ppChar '"'] showLiteral :: PprStyle -> Literal -> String showLiteral sty lit = ppShow 80 (ppr sty lit) diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 593d61bb53..ee1dfa658b 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -13,7 +13,8 @@ module Name ( -- The OccName type OccName(..), - pprOccName, pprSymOcc, pprNonSymOcc, occNameString, occNameFlavour, isTvOcc, + pprOccName, pprSymOcc, pprNonSymOcc, occNameString, occNameFlavour, + isTvOcc, isTCOcc, isVarOcc, prefixOccName, quoteInText, parenInCode, -- The Name type @@ -38,7 +39,7 @@ module Name ( -- Sets of Names NameSet(..), emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets, - minusNameSet, elemNameSet, nameSetToList, addListToNameSet, + minusNameSet, elemNameSet, nameSetToList, addListToNameSet, isEmptyNameSet, -- Misc DefnInfo(..), @@ -65,7 +66,7 @@ import Pretty import Lex ( isLexSym, isLexConId ) import SrcLoc ( noSrcLoc, SrcLoc ) import Unique ( pprUnique, showUnique, Unique ) -import UniqSet ( UniqSet(..), emptyUniqSet, unitUniqSet, unionUniqSets, uniqSetToList, +import UniqSet ( UniqSet(..), emptyUniqSet, unitUniqSet, unionUniqSets, uniqSetToList, isEmptyUniqSet, unionManyUniqSets, minusUniqSet, mkUniqSet, elementOfUniqSet, addListToUniqSet ) import UniqFM ( UniqFM ) import Util ( cmpPString, panic, assertPanic {-, pprTrace ToDo:rm-} ) @@ -102,6 +103,11 @@ occNameString (VarOcc s) = s occNameString (TvOcc s) = s occNameString (TCOcc s) = s +prefixOccName :: FAST_STRING -> OccName -> OccName +prefixOccName prefix (VarOcc s) = VarOcc (prefix _APPEND_ s) +prefixOccName prefix (TvOcc s) = TvOcc (prefix _APPEND_ s) +prefixOccName prefix (TCOcc s) = TCOcc (prefix _APPEND_ s) + -- occNameFlavour is used only to generate good error messages, so it doesn't matter -- that the VarOcc case isn't mega-efficient. We could have different Occ constructors for -- data constructors and values, but that makes everything else a bit more complicated. @@ -111,10 +117,17 @@ occNameFlavour (VarOcc s) | isLexConId s = "data constructor" occNameFlavour (TvOcc s) = "type variable" occNameFlavour (TCOcc s) = "type constructor or class" -isTvOcc :: OccName -> Bool +isVarOcc, isTCOcc, isTvOcc :: OccName -> Bool +isVarOcc (VarOcc s) = True +isVarOcc other = False + isTvOcc (TvOcc s) = True isTvOcc other = False +isTCOcc (TCOcc s) = True +isTCOcc other = False + + instance Eq OccName where a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } @@ -287,7 +300,8 @@ setNameVisibility mod (Local uniq occ loc) setNameVisibility mod name = name all_toplev_ids_visible = not opt_OmitInterfacePragmas || -- Pragmas can make them visible - opt_EnsureSplittableC -- Splitting requires visiblilty + opt_EnsureSplittableC -- Splitting requires visiblilty + \end{code} %************************************************************************ @@ -408,13 +422,15 @@ instance Outputable Name where ppr sty name@(Global u m n _ _) = ppBesides [pp_name, pp_debug sty name] where pp_name | codeStyle sty = identToC qual_name - | otherwise = ppPStr qual_name - qual_name = m _APPEND_ SLIT(".") _APPEND_ occNameString n + | otherwise = ppBesides[ ppPStr m, ppChar '.', ppPStr pk_n] + pk_n = occNameString n + qual_name = m _APPEND_ SLIT(".") _APPEND_ pk_n -pp_debug PprDebug (Global uniq m n _ prov) = ppBesides [ppStr "{-", pprUnique uniq, ppStr ",", +pp_debug PprDebug (Global uniq m n _ prov) = ppBesides [ppStr "{-", pprUnique uniq, ppChar ',', pp_prov prov, ppStr "-}"] where - pp_prov (LocalDef _ _) = ppChar 'l' + pp_prov (LocalDef Exported _) = ppChar 'x' + pp_prov (LocalDef NotExported _) = ppChar 'l' pp_prov (Imported _ _) = ppChar 'i' pp_prov Implicit = ppChar 'p' pp_debug other name = ppNil @@ -426,9 +442,9 @@ pprNameProvenance sty (Global _ _ _ _ prov) = pprProvenance sty prov pprProvenance :: PprStyle -> Provenance -> Pretty pprProvenance sty (Imported mod loc) - = ppSep [ppStr "Imported from", pprModule sty mod, ppStr "at", ppr sty loc] + = ppSep [ppPStr SLIT("Imported from"), pprModule sty mod, ppPStr SLIT("at"), ppr sty loc] pprProvenance sty (LocalDef _ loc) - = ppSep [ppStr "Defined at", ppr sty loc] + = ppSep [ppPStr SLIT("Defined at"), ppr sty loc] pprProvenance sty Implicit = panic "pprNameProvenance: Implicit" \end{code} @@ -451,7 +467,9 @@ unionManyNameSets :: [NameSet] -> NameSet minusNameSet :: NameSet -> NameSet -> NameSet elemNameSet :: Name -> NameSet -> Bool nameSetToList :: NameSet -> [Name] +isEmptyNameSet :: NameSet -> Bool +isEmptyNameSet = isEmptyUniqSet emptyNameSet = emptyUniqSet unitNameSet = unitUniqSet mkNameSet = mkUniqSet diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs index f4a3b2b388..e7453786b3 100644 --- a/ghc/compiler/basicTypes/SrcLoc.lhs +++ b/ghc/compiler/basicTypes/SrcLoc.lhs @@ -81,13 +81,18 @@ isNoSrcLoc other = False \begin{code} instance Outputable SrcLoc where ppr PprForUser (SrcLoc src_file src_line) - = ppBesides [ ppPStr src_file, ppStr ": ", ppStr (show IBOX(src_line)) ] + = ppBesides [ ppPStr src_file, ppChar ':', ppStr (show IBOX(src_line)) ] ppr sty (SrcLoc src_file src_line) - = ppBesides [ppPStr SLIT("{-# LINE "), ppStr (show IBOX(src_line)), ppSP, - ppChar '"', ppPStr src_file, ppPStr SLIT("\" #-}")] - + = ppBesides [ppStr "{-# LINE ", ppStr (show IBOX(src_line)), ppSP, + ppChar '\"', ppPStr src_file, ppStr " #-}"] ppr sty (UnhelpfulSrcLoc s) = ppPStr s ppr sty NoSrcLoc = ppStr "" \end{code} + +{- + = ppBesides [ppPStr SLIT("{-# LINE "), ppStr (show IBOX(src_line)), ppSP, + ppChar '"', ppPStr src_file, ppPStr SLIT(" #-}")] + --ppPStr SLIT("\" #-}")] +-} diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs index 76e5ab3e80..c60a989edd 100644 --- a/ghc/compiler/basicTypes/UniqSupply.lhs +++ b/ghc/compiler/basicTypes/UniqSupply.lhs @@ -80,14 +80,14 @@ mkSplitUniqSupply (C# c#) -- here comes THE MAGIC: mk_supply# - = unsafeInterleavePrimIO {-unsafe_interleave-} ( + = unsafe_interleave ( mk_unique `thenPrimIO` \ uniq -> mk_supply# `thenPrimIO` \ s1 -> mk_supply# `thenPrimIO` \ s2 -> returnPrimIO (MkSplitUniqSupply uniq s1 s2) ) where -{- +-- -- inlined copy of unsafeInterleavePrimIO; -- this is the single-most-hammered bit of code -- in the compiler.... @@ -97,7 +97,7 @@ mkSplitUniqSupply (C# c#) (r, new_s) = m s in (r, s) --} +-- mk_unique = _ccall_ genSymZh `thenPrimIO` \ (WHASH u#) -> returnPrimIO (I# (w2i (mask# `or#` u#))) diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index a482b689d7..5f14e9fed8 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -114,6 +114,7 @@ module Unique ( listTyConKey, ltDataConKey, mainKey, mainPrimIoKey, + minusClassOpKey, monadClassKey, monadPlusClassKey, monadZeroClassKey, @@ -127,6 +128,7 @@ module Unique ( numClassKey, ordClassKey, orderingTyConKey, + otherwiseIdKey, packCStringIdKey, parErrorIdKey, parIdKey, @@ -148,6 +150,7 @@ module Unique ( return2GMPsTyConKey, returnIntAndGMPDataConKey, returnIntAndGMPTyConKey, + returnMClassOpKey, runSTIdKey, seqIdKey, showClassKey, @@ -658,6 +661,7 @@ to conjure them up during type checking. \begin{code} fromIntClassOpKey = mkPreludeMiscIdUnique 53 fromIntegerClassOpKey = mkPreludeMiscIdUnique 54 +minusClassOpKey = mkPreludeMiscIdUnique 69 fromRationalClassOpKey = mkPreludeMiscIdUnique 55 enumFromClassOpKey = mkPreludeMiscIdUnique 56 enumFromThenClassOpKey = mkPreludeMiscIdUnique 57 @@ -673,4 +677,7 @@ fromEnumClassOpKey = mkPreludeMiscIdUnique 65 mainKey = mkPreludeMiscIdUnique 66 mainPrimIoKey = mkPreludeMiscIdUnique 67 +returnMClassOpKey = mkPreludeMiscIdUnique 68 +-- Used for minusClassOp 69 +otherwiseIdKey = mkPreludeMiscIdUnique 70 \end{code} diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index dff94d2185..872827fba6 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -65,11 +65,10 @@ import PprType ( GenType{-instance Outputable-}, TyCon{-ditto-} ) import Pretty ( prettyToUn, ppBesides, ppChar, ppPStr, ppCat, ppStr ) import PrimRep ( isFollowableRep, PrimRep(..) ) import TyCon ( isPrimTyCon, tyConDataCons ) +import Type ( showTypeCategory ) import Unpretty ( uppShow ) import Util ( isIn, panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} ) -myWrapperMaybe = panic "CgClosure.myWrapperMaybe (ToDo)" -showTypeCategory = panic "CgClosure.showTypeCategory (ToDo)" getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)" \end{code} @@ -563,7 +562,7 @@ closureCodeBody binder_info closure_info cc all_args body wrapper_maybe = get_ultimate_wrapper Nothing id where get_ultimate_wrapper deflt x -- walk all the way up a "wrapper chain" - = case (myWrapperMaybe x) of + = case myWrapperMaybe x of Nothing -> deflt Just xx -> get_ultimate_wrapper (Just xx) xx diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index 2b23b93290..18902fc84b 100644 --- a/ghc/compiler/codeGen/CgMonad.lhs +++ b/ghc/compiler/codeGen/CgMonad.lhs @@ -67,7 +67,7 @@ import Id ( idType, import Maybes ( maybeToBool ) import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instance Outputable-} ) -import Pretty ( ppAboves, ppCat, ppStr ) +import Pretty ( ppAboves, ppCat, ppPStr ) import PrimRep ( getPrimRepSize, PrimRep(..) ) import StgSyn ( SYN_IE(StgLiveVars) ) import Type ( typePrimRep ) @@ -689,11 +689,11 @@ lookupBindC name info_down@(MkCgInfoDown _ static_binds _) Nothing -> pprPanic "lookupBindC:no info!\n" (ppAboves [ - ppCat [ppStr "for:", ppr PprShowAll name], - ppStr "(probably: data dependencies broken by an optimisation pass)", - ppStr "static binds for:", + ppCat [ppPStr SLIT("for:"), ppr PprShowAll name], + ppPStr SLIT("(probably: data dependencies broken by an optimisation pass)"), + ppPStr SLIT("static binds for:"), ppAboves [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ], - ppStr "local binds for:", + ppPStr SLIT("local binds for:"), ppAboves [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ] ]) \end{code} diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index a786145a4a..4f2e58556c 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -57,11 +57,8 @@ codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg = let doing_profiling = opt_SccProfilingOn compiling_prelude = opt_CompilingGhcInternals - maybe_split = if opt_EnsureSplittableC - then CSplitMarker - else AbsCNop - - cinfo = MkCompInfo mod_name + maybe_split = if opt_EnsureSplittableC then CSplitMarker else AbsCNop + cinfo = MkCompInfo mod_name in if not doing_profiling then mkAbstractCs [ diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 99afabcf14..cff93925e2 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -94,9 +94,9 @@ lintCoreBindings sty whoDunnit spec_done binds pprPanic "" (ppAboves [ ppStr ("*** Core Lint Errors: in " ++ whoDunnit ++ " ***"), msg sty, - ppStr "*** Offending Program ***", + ppPStr SLIT("*** Offending Program ***"), ppAboves (map (pprCoreBinding sty) binds), - ppStr "*** End of Offense ***" + ppPStr SLIT("*** End of Offense ***") ]) where lint_binds [] = returnL () @@ -126,9 +126,9 @@ lintUnfolding locn expr Just msg -> pprTrace "WARNING: Discarded bad unfolding from interface:\n" (ppAboves [msg PprForUser, - ppStr "*** Bad unfolding ***", + ppPStr SLIT("*** Bad unfolding ***"), ppr PprDebug expr, - ppStr "*** End unfolding ***"]) + ppPStr SLIT("*** End unfolding ***")]) Nothing \end{code} @@ -276,8 +276,6 @@ lintCoreArg e ty (VarArg v) lintCoreArg e ty a@(TyArg arg_ty) = -- ToDo: Check that ty is well-kinded and has no unbound tyvars - checkIfSpecDoneL (not (isPrimType arg_ty)) (mkSpecTyAppMsg a) - `seqL` case (getForAllTyExpandingDicts_maybe ty) of Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing @@ -415,18 +413,18 @@ data LintLocInfo instance Outputable LintLocInfo where ppr sty (RhsOf v) - = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"] + = ppBesides [ppr sty (getSrcLoc v), ppPStr SLIT(": [RHS of "), pp_binders sty [v], ppChar ']'] ppr sty (LambdaBodyOf b) = ppBesides [ppr sty (getSrcLoc b), - ppStr ": [in body of lambda with binder ", pp_binder sty b, ppStr "]"] + ppPStr SLIT(": [in body of lambda with binder "), pp_binder sty b, ppChar ']'] ppr sty (BodyOfLetRec bs) = ppBesides [ppr sty (getSrcLoc (head bs)), - ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"] + ppPStr SLIT(": [in body of letrec with binders "), pp_binders sty bs, ppChar ']'] ppr sty (ImportedUnfolding locn) - = ppBeside (ppr sty locn) (ppStr ": [in an imported unfolding]") + = ppBeside (ppr sty locn) (ppPStr SLIT(": [in an imported unfolding]")) pp_binders :: PprStyle -> [Id] -> Pretty pp_binders sty bs = ppInterleave ppComma (map (pp_binder sty) bs) @@ -543,7 +541,7 @@ checkInScope id spec loc scope errs id_name = getName id in if isLocallyDefined id_name && not (id `elementOfIdSet` scope) then - ((),addErr errs (\sty -> ppCat [ppr sty id, ppStr "is out of scope"]) loc) + ((),addErr errs (\sty -> ppCat [ppr sty id, ppPStr SLIT("is out of scope")]) loc) else ((),errs) @@ -555,54 +553,54 @@ checkTys ty1 ty2 msg spec loc scope errs \begin{code} mkCaseAltMsg :: CoreCaseAlts -> ErrMsg mkCaseAltMsg alts sty - = ppAbove (ppStr "Type of case alternatives not the same:") + = ppAbove (ppPStr SLIT("Type of case alternatives not the same:")) (ppr sty alts) mkCaseDataConMsg :: CoreExpr -> ErrMsg mkCaseDataConMsg expr sty - = ppAbove (ppStr "A case scrutinee not of data constructor type:") + = ppAbove (ppPStr SLIT("A case scrutinee not of data constructor type:")) (pp_expr sty expr) mkCaseNotPrimMsg :: TyCon -> ErrMsg mkCaseNotPrimMsg tycon sty - = ppAbove (ppStr "A primitive case on a non-primitive type:") + = ppAbove (ppPStr SLIT("A primitive case on a non-primitive type:")) (ppr sty tycon) mkCasePrimMsg :: TyCon -> ErrMsg mkCasePrimMsg tycon sty - = ppAbove (ppStr "An algebraic case on a primitive type:") + = ppAbove (ppPStr SLIT("An algebraic case on a primitive type:")) (ppr sty tycon) mkCaseAbstractMsg :: TyCon -> ErrMsg mkCaseAbstractMsg tycon sty - = ppAbove (ppStr "An algebraic case on some weird type:") + = ppAbove (ppPStr SLIT("An algebraic case on some weird type:")) (ppr sty tycon) mkDefltMsg :: CoreCaseDefault -> ErrMsg mkDefltMsg deflt sty - = ppAbove (ppStr "Binder in case default doesn't match type of scrutinee:") + = ppAbove (ppPStr SLIT("Binder in case default doesn't match type of scrutinee:")) (ppr sty deflt) mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg mkAppMsg fun arg expr sty - = ppAboves [ppStr "Argument value doesn't match argument type:", - ppHang (ppStr "Fun type:") 4 (ppr sty fun), - ppHang (ppStr "Arg type:") 4 (ppr sty arg), - ppHang (ppStr "Expression:") 4 (pp_expr sty expr)] + = ppAboves [ppPStr SLIT("Argument value doesn't match argument type:"), + ppHang (ppPStr SLIT("Fun type:")) 4 (ppr sty fun), + ppHang (ppPStr SLIT("Arg type:")) 4 (ppr sty arg), + ppHang (ppPStr SLIT("Expression:")) 4 (pp_expr sty expr)] mkTyAppMsg :: FAST_STRING -> Type -> Type -> CoreExpr -> ErrMsg mkTyAppMsg msg ty arg expr sty - = ppAboves [ppCat [ppPStr msg, ppStr "type application:"], - ppHang (ppStr "Exp type:") 4 (ppr sty ty), - ppHang (ppStr "Arg type:") 4 (ppr sty arg), - ppHang (ppStr "Expression:") 4 (pp_expr sty expr)] + = ppAboves [ppCat [ppPStr msg, ppPStr SLIT("type application:")], + ppHang (ppPStr SLIT("Exp type:")) 4 (ppr sty ty), + ppHang (ppPStr SLIT("Arg type:")) 4 (ppr sty arg), + ppHang (ppPStr SLIT("Expression:")) 4 (pp_expr sty expr)] mkUsageAppMsg :: Type -> Usage -> CoreExpr -> ErrMsg mkUsageAppMsg ty u expr sty - = ppAboves [ppStr "Illegal usage application:", - ppHang (ppStr "Exp type:") 4 (ppr sty ty), - ppHang (ppStr "Usage exp:") 4 (ppr sty u), - ppHang (ppStr "Expression:") 4 (pp_expr sty expr)] + = ppAboves [ppPStr SLIT("Illegal usage application:"), + ppHang (ppPStr SLIT("Exp type:")) 4 (ppr sty ty), + ppHang (ppPStr SLIT("Usage exp:")) 4 (ppr sty u), + ppHang (ppPStr SLIT("Expression:")) 4 (pp_expr sty expr)] mkAlgAltMsg1 :: Type -> ErrMsg mkAlgAltMsg1 ty sty @@ -643,22 +641,22 @@ mkPrimAltMsg alt sty mkRhsMsg :: Id -> Type -> ErrMsg mkRhsMsg binder ty sty = ppAboves - [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:", + [ppCat [ppPStr SLIT("The type of this binder doesn't match the type of its RHS:"), ppr sty binder], - ppCat [ppStr "Binder's type:", ppr sty (idType binder)], - ppCat [ppStr "Rhs type:", ppr sty ty]] + ppCat [ppPStr SLIT("Binder's type:"), ppr sty (idType binder)], + ppCat [ppPStr SLIT("Rhs type:"), ppr sty ty]] mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg mkRhsPrimMsg binder rhs sty - = ppAboves [ppCat [ppStr "The type of this binder is primitive:", + = ppAboves [ppCat [ppPStr SLIT("The type of this binder is primitive:"), ppr sty binder], - ppCat [ppStr "Binder's type:", ppr sty (idType binder)] + ppCat [ppPStr SLIT("Binder's type:"), ppr sty (idType binder)] ] mkSpecTyAppMsg :: CoreArg -> ErrMsg mkSpecTyAppMsg arg sty = ppAbove - (ppStr "Unboxed types in a type application (after specialisation):") + (ppPStr SLIT("Unboxed types in a type application (after specialisation):")) (ppr sty arg) pp_expr :: PprStyle -> CoreExpr -> Pretty diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 4b25be3d90..e16b6d9061 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -381,14 +381,16 @@ collectBinders :: ([uvar], [tyvar], [val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar) collectBinders expr - = (usages, tyvars, vals, body) + = case collectValBinders body1 of { (vals,body) -> (usages, tyvars, vals, body) } where (usages, tyvars, body1) = collectUsageAndTyBinders expr - (vals, body) = collectValBinders body1 +-- (vals, body) = collectValBinders body1 collectUsageAndTyBinders expr - = usages expr [] + = case usages expr [] of + ([],tyvars,body) -> ([],tyvars,body) + v -> v where usages (Lam (UsageBinder u) body) uacc = usages body (u:uacc) usages other uacc @@ -411,7 +413,9 @@ collectUsageAndTyBinders expr collectValBinders :: GenCoreExpr val_bdr val_occ tyvar uvar -> ([val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar) collectValBinders expr - = go [] expr + = case go [] expr of + ([],body) -> ([],body) + v -> v where go acc (Lam (ValBinder v) b) = go (v:acc) b go acc body = (reverse acc, body) diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 215f25b30e..f2077ba738 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -96,10 +96,15 @@ data SimpleUnfolding noUnfolding = NoUnfolding mkUnfolding inline_me expr - = CoreUnfolding (SimpleUnfolding - (mkFormSummary expr) - (calcUnfoldingGuidance inline_me opt_UnfoldingCreationThreshold expr) - (occurAnalyseGlobalExpr expr)) + = let + -- strictness mangling (depends on there being no CSE) + ufg = calcUnfoldingGuidance inline_me opt_UnfoldingCreationThreshold expr + occ = occurAnalyseGlobalExpr expr + cuf = CoreUnfolding (SimpleUnfolding (mkFormSummary expr) ufg occ) + + cont = case occ of { Var _ -> cuf; _ -> cuf } + in + case ufg of { UnfoldAlways -> cont; _ -> cont } mkMagicUnfolding :: Unique -> Unfolding mkMagicUnfolding tag = MagicUnfolding tag (mkMagicUnfoldingFun tag) @@ -128,10 +133,10 @@ data UnfoldingGuidance \begin{code} instance Outputable UnfoldingGuidance where - ppr sty UnfoldAlways = ppStr "_ALWAYS_" --- ppr sty EssentialUnfolding = ppStr "_ESSENTIAL_" -- shouldn't appear in an iface + ppr sty UnfoldAlways = ppPStr SLIT("_ALWAYS_") +-- ppr sty EssentialUnfolding = ppPStr SLIT("_ESSENTIAL_") -- shouldn't appear in an iface ppr sty (UnfoldIfGoodArgs t v cs size) - = ppCat [ppStr "_IF_ARGS_", ppInt t, ppInt v, + = ppCat [ppPStr SLIT("_IF_ARGS_"), ppInt t, ppInt v, if null cs -- always print *something* then ppChar 'X' else ppBesides (map (ppStr . show) cs), @@ -154,10 +159,10 @@ data FormSummary | OtherForm -- Anything else instance Outputable FormSummary where - ppr sty VarForm = ppStr "Var" - ppr sty ValueForm = ppStr "Value" - ppr sty BottomForm = ppStr "Bot" - ppr sty OtherForm = ppStr "Other" + ppr sty VarForm = ppPStr SLIT("Var") + ppr sty ValueForm = ppPStr SLIT("Value") + ppr sty BottomForm = ppPStr SLIT("Bot") + ppr sty OtherForm = ppPStr SLIT("Other") mkFormSummary ::GenCoreExpr bndr Id tyvar uvar -> FormSummary @@ -238,9 +243,7 @@ calcUnfoldingGuidance calcUnfoldingGuidance True bOMB_OUT_SIZE expr = UnfoldAlways -- Always inline if the INLINE pragma says so calcUnfoldingGuidance False bOMB_OUT_SIZE expr - = let - (use_binders, ty_binders, val_binders, body) = collectBinders expr - in + = case collectBinders expr of { (use_binders, ty_binders, val_binders, body) -> case (sizeExpr bOMB_OUT_SIZE val_binders body) of Nothing -> UnfoldNever @@ -250,7 +253,7 @@ calcUnfoldingGuidance False bOMB_OUT_SIZE expr (length ty_binders) (length val_binders) (map discount_for val_binders) - size + size where discount_for b | is_data && b `is_elem` cased_args = tyConFamilySize tycon @@ -261,7 +264,7 @@ calcUnfoldingGuidance False bOMB_OUT_SIZE expr Nothing -> (False, panic "discount") Just (tc,_,_) -> (True, tc) - is_elem = isIn "calcUnfoldingGuidance" + is_elem = isIn "calcUnfoldingGuidance" } \end{code} \begin{code} @@ -350,27 +353,27 @@ sizeExpr bOMB_OUT_SIZE args expr ------------ size_up_alts scrut_ty (AlgAlts alts deflt) - = foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts `addSizeN` 1 - -- "1" for the case itself + = foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts + `addSizeN` + alt_cost + where + size_alg_alt (con,args,rhs) = size_up rhs + -- Don't charge for args, so that wrappers look cheap - -- `addSizeN` (if is_data then tyConFamilySize tycon else 1) - -- - -- OLD COMMENT: looks unfair to me! So I've nuked this extra charge - -- SLPJ Jan 97 -- NB: we charge N for an alg. "case", where N is -- the number of constructors in the thing being eval'd. -- (You'll eventually get a "discount" of N if you -- think the "case" is likely to go away.) + -- It's important to charge for alternatives. If you don't then you + -- get size 1 for things like: + -- case x of { A -> 1#; B -> 2#; ... lots } - where - size_alg_alt (con,args,rhs) = size_up rhs - -- Don't charge for args, so that wrappers look cheap - - (is_data,tycon) + alt_cost :: Int + alt_cost = --trace "CoreUnfold.getAppDataTyConExpandingDicts:2" $ case (maybeAppDataTyConExpandingDicts scrut_ty) of - Nothing -> (False, panic "size_up_alts") - Just (tc,_,_) -> (True, tc) + Nothing -> 1 + Just (tc,_,_) -> tyConFamilySize tc size_up_alts _ (PrimAlts alts deflt) = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index d7dd124077..9ee12f3202 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -95,11 +95,20 @@ init_ppr_env sty tvbndr pbdr1 pbdr2 pocc (Just (pprParendGenType sty)) -- types (Just (ppr sty)) -- usages where + + ppr_con con = ppr sty con + +{- [We now use Con {a,b,c} for Con expressions. SLPJ March 97.] + [We can't treat them as ordinary applications because the Con doesn't have + dictionaries in it, whereas the constructor Id does.] + + OLD VERSION: -- ppr_con is used when printing Con expressions; we add a "!" -- to distinguish them from ordinary applications. But not when -- printing for interfaces, where they are treated as ordinary applications ppr_con con | ifaceStyle sty = ppr sty con | otherwise = ppr sty con `ppBeside` ppChar '!' +-} -- We add a "!" to distinguish Primitive applications from ordinary applications. -- But not when printing for interfaces, where they are treated @@ -113,9 +122,9 @@ pprCoreBinding sty (NonRec binder expr) 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr) pprCoreBinding sty (Rec binds) - = ppAboves [ifPprDebug sty (ppStr "{- plain Rec -}"), + = ppAboves [ifPprDebug sty (ppPStr SLIT("{- plain Rec -}")), ppAboves (map ppr_bind binds), - ifPprDebug sty (ppStr "{- end plain Rec -}")] + ifPprDebug sty (ppPStr SLIT("{- end plain Rec -}"))] where ppr_bind (binder, expr) = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals]) @@ -163,7 +172,7 @@ pprIfaceUnfolding = ppr_expr env where env = init_ppr_env PprInterface (pprTyVarBndr PprInterface) (pprTypedCoreBinder PprInterface) - (pprTypedCoreBinder PprInterface) + (ppr PprInterface) (ppr PprInterface) ppr_core_arg sty pocc arg @@ -252,11 +261,10 @@ ppr_parend_expr pe expr \begin{code} ppr_expr pe (Var name) = pOcc pe name ppr_expr pe (Lit lit) = pLit pe lit -ppr_expr pe (Con con []) = pCon pe con ppr_expr pe (Con con args) = ppHang (pCon pe con) - 4 (ppSep (map (ppr_arg pe) args)) + 4 (ppCurlies $ ppSep (map (ppr_arg pe) args)) ppr_expr pe (Prim prim args) = ppHang (pPrim pe prim) @@ -268,12 +276,12 @@ ppr_expr pe expr@(Lam _ _) in ppHang (ppCat [pp_vars SLIT("/u\\") (pUVar pe) uvars, pp_vars SLIT("_/\\_") (pTyVarB pe) tyvars, - pp_vars SLIT("\\") (pMinBndr pe) vars]) + pp_vars SLIT("\\") (pMajBndr pe) vars]) 4 (ppr_expr pe body) where pp_vars lam pp [] = ppNil pp_vars lam pp vs - = ppCat [ppPStr lam, ppInterleave ppSP (map pp vs), ppStr "->"] + = ppCat [ppPStr lam, ppInterleave ppSP (map pp vs), ppPStr SLIT("->")] ppr_expr pe expr@(App fun arg) = let @@ -288,18 +296,22 @@ ppr_expr pe (Case expr alts) -- johan thinks that single case patterns should be on same line as case, -- and no indent; all sane persons agree with him. = let - ppr_alt (AlgAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->") - ppr_alt (PrimAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->") - ppr_alt (PrimAlts ((l, _):[]) NoDefault)= ppBeside (pLit pe l) (ppStr " ->") + + ppr_alt (AlgAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) ppr_arrow + ppr_alt (PrimAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) ppr_arrow + ppr_alt (PrimAlts ((l, _):[]) NoDefault)= ppBeside (pLit pe l) ppr_arrow ppr_alt (AlgAlts ((con, params, _):[]) NoDefault) = ppCat [pCon pe con, ppInterleave ppSP (map (pMinBndr pe) params), - ppStr "->"] + ppr_arrow] ppr_rhs (AlgAlts [] (BindDefault _ expr)) = ppr_expr pe expr ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr ppr_rhs (PrimAlts [] (BindDefault _ expr)) = ppr_expr pe expr ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr + + + ppr_arrow = ppPStr SLIT(" ->") in ppSep [ppSep [pp_keyword, ppNest 4 (ppr_expr pe expr), ppStr "of {", ppr_alt alts], @@ -307,7 +319,7 @@ ppr_expr pe (Case expr alts) | otherwise -- default "case" printing = ppSep - [ppSep [pp_keyword, ppNest 4 (ppr_expr pe expr), ppStr "of {"], + [ppSep [pp_keyword, ppNest 4 (ppr_expr pe expr), ppPStr SLIT("of {")], ppNest 2 (ppr_alts pe alts), ppStr "}"] where @@ -320,27 +332,27 @@ ppr_expr pe (Case expr alts) ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) = ppAboves [ - ppCat [ppStr "let {", pMajBndr pe val_bdr, ppEquals], + ppCat [ppPStr SLIT("let {"), pMajBndr pe val_bdr, ppEquals], ppNest 2 (ppr_expr pe rhs), - ppStr "} in", + ppPStr SLIT("} in"), ppr_expr pe body ] ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) = ppAbove - (ppHang (ppStr "let {") + (ppHang (ppPStr SLIT("let {")) 2 (ppCat [ppHang (ppCat [pMajBndr pe val_bdr, ppEquals]) 4 (ppr_expr pe rhs), - ppStr "} in"])) + ppPStr SLIT("} in")])) (ppr_expr pe expr) -- general case (recursive case, too) ppr_expr pe (Let bind expr) - = ppSep [ppHang (ppStr keyword) 2 (ppr_bind pe bind), - ppHang (ppStr "} in ") 2 (ppr_expr pe expr)] + = ppSep [ppHang (ppPStr keyword) 2 (ppr_bind pe bind), + ppHang (ppPStr SLIT("} in ")) 2 (ppr_expr pe expr)] where keyword = case bind of - Rec _ -> "letrec {" - NonRec _ _ -> "let {" + Rec _ -> SLIT("letrec {") + NonRec _ _ -> SLIT("let {") ppr_expr pe (SCC cc expr) = ppSep [ppCat [ppPStr SLIT("_scc_"), pSCC pe cc], @@ -349,8 +361,8 @@ ppr_expr pe (SCC cc expr) ppr_expr pe (Coerce c ty expr) = ppSep [pp_coerce c, pTy pe ty, ppr_expr pe expr] where - pp_coerce (CoerceIn v) = ppBeside (ppStr "_coerce_in_ ") (ppr (pStyle pe) v) - pp_coerce (CoerceOut v) = ppBeside (ppStr "_coerce_out_ ") (ppr (pStyle pe) v) + pp_coerce (CoerceIn v) = ppBeside (ppPStr SLIT("_coerce_in_ ")) (ppr (pStyle pe) v) + pp_coerce (CoerceOut v) = ppBeside (ppPStr SLIT("_coerce_out_ ")) (ppr (pStyle pe) v) only_one_alt (AlgAlts [] (BindDefault _ _)) = True only_one_alt (AlgAlts (_:[]) NoDefault) = True @@ -363,14 +375,16 @@ only_one_alt _ = False ppr_alts pe (AlgAlts alts deflt) = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ] where + ppr_arrow = ppPStr SLIT("->") + ppr_alt (con, params, expr) = ppHang (if isTupleCon con then ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)), - ppStr "->"] + ppr_arrow] else ppCat [pCon pe con, ppInterleave ppSP (map (pMinBndr pe) params), - ppStr "->"] + ppr_arrow] ) 4 (ppr_expr pe expr `ppBeside` ppSemi) @@ -378,7 +392,7 @@ ppr_alts pe (PrimAlts alts deflt) = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ] where ppr_alt (lit, expr) - = ppHang (ppCat [pLit pe lit, ppStr "->"]) + = ppHang (ppCat [pLit pe lit, ppPStr SLIT("->")]) 4 (ppr_expr pe expr `ppBeside` ppSemi) \end{code} @@ -386,14 +400,14 @@ ppr_alts pe (PrimAlts alts deflt) ppr_default pe NoDefault = ppNil ppr_default pe (BindDefault val_bdr expr) - = ppHang (ppCat [pMinBndr pe val_bdr, ppStr "->"]) + = ppHang (ppCat [pMinBndr pe val_bdr, ppPStr SLIT("->")]) 4 (ppr_expr pe expr `ppBeside` ppSemi) \end{code} \begin{code} ppr_arg pe (LitArg lit) = pLit pe lit ppr_arg pe (VarArg v) = pOcc pe v -ppr_arg pe (TyArg ty) = ppStr "_@_ " `ppBeside` pTy pe ty +ppr_arg pe (TyArg ty) = ppPStr SLIT("_@_ ") `ppBeside` pTy pe ty ppr_arg pe (UsageArg use) = pUse pe use \end{code} @@ -417,7 +431,7 @@ pprBabyCoreBinder sty binder pp_strictness = case (getIdStrictness binder) of NoStrictnessInfo -> ppNil - BottomGuaranteed -> ppStr "{- _!_ -}" + BottomGuaranteed -> ppPStr SLIT("{- _!_ -}") StrictnessInfo xx _ -> panic "PprCore:pp_strictness:StrictnessInfo:ToDo" -- ppStr ("{- " ++ (showList xx "") ++ " -}") @@ -425,7 +439,7 @@ pprBabyCoreBinder sty binder pprTypedCoreBinder sty binder = ppBesides [ppr sty binder, ppDcolon, pprParendGenType sty (idType binder)] -ppDcolon = ppStr " :: " +ppDcolon = ppPStr SLIT(" :: ") -- The space before the :: is important; it helps the lexer -- when reading inferfaces. Otherwise it would lex "a::b" as one thing. \end{code} diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 697c32dd2f..40e3bcc1fc 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -6,23 +6,28 @@ \begin{code} #include "HsVersions.h" -module Desugar ( deSugar, DsMatchContext, pprDsWarnings ) where +module Desugar ( deSugar, DsMatchContext, pprDsWarnings, + DsWarnFlavour -- removed when compiling with 1.4 + ) where IMP_Ubiq(){-uitous-} import HsSyn ( HsBinds, HsExpr ) import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) ) import CoreSyn - +import Name ( isExported ) import DsMonad import DsBinds ( dsBinds, dsInstBinds ) import DsUtils import Bag ( unionBags ) -import CmdLineOpts ( opt_DoCoreLinting, opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs ) +import CmdLineOpts ( opt_DoCoreLinting, opt_AutoSccsOnAllToplevs, + opt_AutoSccsOnExportedToplevs, opt_SccGroup + ) +import CostCentre ( IsCafCC(..), mkAutoCC ) import CoreLift ( liftCoreBindings ) import CoreLint ( lintCoreBindings ) -import Id ( nullIdEnv, mkIdEnv ) +import Id ( nullIdEnv, mkIdEnv, idType, SYN_IE(DictVar), GenId ) import PprStyle ( PprStyle(..) ) import UniqSupply ( splitUniqSupply ) \end{code} @@ -42,7 +47,7 @@ deSugar :: UniqSupply -- name supply -- ToDo: handling of const_inst thingies is certainly WRONG *************************** -> ([CoreBinding], -- output - Bag DsMatchContext) -- Shadowing complaints + DsWarnings) -- Shadowing complaints deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst_pairs) = let @@ -52,9 +57,11 @@ deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst (us3, us3a) = splitUniqSupply us2a (us4, us5) = splitUniqSupply us3a - auto_meth = opt_AutoSccsOnAllToplevs - auto_top = opt_AutoSccsOnAllToplevs - || opt_AutoSccsOnExportedToplevs + + module_and_group = (mod_name, grp_name) + grp_name = case opt_SccGroup of + Just xx -> _PK_ xx + Nothing -> mod_name -- default: module name ((core_const_prs, consts_pairs), shadows1) = initDs us0 nullIdEnv mod_name (dsInstBinds [] const_inst_pairs) @@ -62,19 +69,19 @@ deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst consts_env = mkIdEnv consts_pairs (core_clas_binds, shadows2) - = initDs us1 consts_env mod_name (dsBinds False clas_binds) + = initDs us1 consts_env mod_name (dsBinds clas_binds) core_clas_prs = pairsFromCoreBinds core_clas_binds (core_inst_binds, shadows3) - = initDs us2 consts_env mod_name (dsBinds auto_meth inst_binds) + = initDs us2 consts_env mod_name (dsBinds inst_binds) core_inst_prs = pairsFromCoreBinds core_inst_binds (core_val_binds, shadows4) - = initDs us3 consts_env mod_name (dsBinds auto_top val_binds) - core_val_pairs = pairsFromCoreBinds core_val_binds + = initDs us3 consts_env mod_name (dsBinds val_binds) + core_val_pairs = map (addAutoScc module_and_group) (pairsFromCoreBinds core_val_binds) (core_recsel_binds, shadows5) - = initDs us4 consts_env mod_name (dsBinds ({-trace "Desugar:core_recsel_binds"-} False) recsel_binds) + = initDs us4 consts_env mod_name (dsBinds recsel_binds) core_recsel_prs = pairsFromCoreBinds core_recsel_binds final_binds @@ -98,3 +105,29 @@ deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst in (really_final_binds, shadows) \end{code} + + +%************************************************************************ +%* * +\subsection[addAutoScc]{Adding automatic sccs} +%* * +%************************************************************************ + +\begin{code} +addAutoScc :: (FAST_STRING, FAST_STRING) -- Module and group + -> (Id, CoreExpr) + -> (Id,CoreExpr) + +addAutoScc (mod, grp) pair@(bndr, core_expr) + | worthSCC core_expr && + (opt_AutoSccsOnAllToplevs || + (isExported bndr && opt_AutoSccsOnExportedToplevs)) + = (bndr, SCC (mkAutoCC bndr mod grp IsNotCafCC) core_expr) + + | otherwise + = pair + +worthSCC (SCC _ _) = False +worthSCC (Con _ _) = False +worthSCC core_expr = True +\end{code} diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index 657e2652f1..af09307aba 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -29,7 +29,8 @@ import DsGRHSs ( dsGuarded ) import DsUtils import Match ( matchWrapper ) -import CmdLineOpts ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs, opt_CompilingGhcInternals ) +import CmdLineOpts ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs, + opt_AutoSccsOnExportedToplevs, opt_CompilingGhcInternals ) import CostCentre ( mkAutoCC, IsCafCC(..), mkAllDictsCC, preludeDictsCostCentre ) import Id ( idType, SYN_IE(DictVar), GenId ) import ListSetOps ( minusList, intersectLists ) @@ -59,7 +60,7 @@ that some of the binders are of unboxed type. This is sorted out when the caller wraps the bindings round an expression. \begin{code} -dsBinds :: Bool -> TypecheckedHsBinds -> DsM [CoreBinding] +dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding] \end{code} All ``real'' bindings are expressed in terms of the @@ -95,12 +96,12 @@ But there are lots of special cases. %============================================== \begin{code} -dsBinds auto_scc (BindWith _ _) = panic "dsBinds:BindWith" -dsBinds auto_scc EmptyBinds = returnDs [] -dsBinds auto_scc (SingleBind bind) = dsBind auto_scc [] [] id [] bind +dsBinds (BindWith _ _) = panic "dsBinds:BindWith" +dsBinds EmptyBinds = returnDs [] +dsBinds (SingleBind bind) = dsBind [] [] id [] bind -dsBinds auto_scc (ThenBinds binds_1 binds_2) - = andDs (++) (dsBinds auto_scc binds_1) (dsBinds auto_scc binds_2) +dsBinds (ThenBinds binds_1 binds_2) + = andDs (++) (dsBinds binds_1) (dsBinds binds_2) \end{code} @@ -129,7 +130,7 @@ definitions, which don't mention the type variables at all, so making them polymorphic is really overkill. @dsInstBinds@ deals with this case. \begin{code} -dsBinds auto_scc (AbsBinds tyvars [] local_global_prs inst_binds val_binds) +dsBinds (AbsBinds tyvars [] local_global_prs inst_binds val_binds) = mapDs mk_poly_private_binder private_binders `thenDs` \ poly_private_binders -> let @@ -148,7 +149,7 @@ dsBinds auto_scc (AbsBinds tyvars [] local_global_prs inst_binds val_binds) dsInstBinds tyvars inst_binds `thenDs` \ (inst_bind_pairs, inst_env) -> extendEnvDs inst_env ( - dsBind auto_scc tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds + dsBind tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds )) where -- "private_binders" is the list of binders in val_binds @@ -194,7 +195,7 @@ the defn of f' can get floated out, notably if f gets specialised to a particular type for a. \begin{code} -dsBinds auto_scc (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds) +dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds) = -- If there is any non-overloaded polymorphism, make new locals with -- appropriate polymorphism (if null non_overloaded_tyvars @@ -230,7 +231,7 @@ dsBinds auto_scc (AbsBinds all_tyvars dicts local_global_prs dict_binds val_bind extendEnvDs inst_env ( - dsBind auto_scc non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds + dsBind non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds )) `thenDs` \ core_binds -> let @@ -240,7 +241,7 @@ dsBinds auto_scc (AbsBinds all_tyvars dicts local_global_prs dict_binds val_bind in mkTupleBind all_tyvars dicts local_global_prs tuple_rhs `thenDs` \ core_bind_prs -> - returnDs [ NonRec binder rhs | (binder,rhs) <- core_bind_prs ] + returnDs (mk_result_bind core_bind_prs) where locals = [local | (local,global) <- local_global_prs] non_ov_tyvar_tys = mkTyVarTys non_overloaded_tyvars @@ -250,6 +251,14 @@ dsBinds auto_scc (AbsBinds all_tyvars dicts local_global_prs dict_binds val_bind binders = collectTypedBinders val_binds mk_binder id = newSysLocalDs (mkForAllTys non_overloaded_tyvars (idType id)) + + is_rec_bind = case val_binds of + RecBind _ -> True + NonRecBind _ -> False + + -- Recursion can still be needed if there are type signatures + mk_result_bind prs | is_rec_bind = [Rec prs] + | otherwise = [NonRec binder rhs | (binder,rhs) <- prs] \end{code} @mkSatTyApp id tys@ constructs an expression whose value is (id tys). @@ -385,22 +394,21 @@ some of the binders are of unboxed type. For an explanation of the first three args, see @dsMonoBinds@. \begin{code} -dsBind :: Bool -- Add auto sccs to binds - -> [TyVar] -> [DictVar] -- Abstract wrt these +dsBind :: [TyVar] -> [DictVar] -- Abstract wrt these -> (Id -> Id) -- Binder substitution -> [(Id,CoreExpr)] -- Inst bindings already dealt with -> TypecheckedBind -> DsM [CoreBinding] -dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs EmptyBind +dsBind tyvars dicts binder_subst inst_bind_pairs EmptyBind = returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs] -dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds) - = dsMonoBinds auto_scc False tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs -> +dsBind tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds) + = dsMonoBinds False tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs -> returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs] -dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds) - = dsMonoBinds auto_scc True tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs -> +dsBind tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds) + = dsMonoBinds True tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs -> returnDs [Rec (inst_bind_pairs ++ val_bind_pairs)] \end{code} @@ -424,8 +432,7 @@ of these binders into applications of the new binder to suitable type variables and dictionaries. \begin{code} -dsMonoBinds :: Bool -- True <=> add auto sccs - -> Bool -- True <=> recursive binding group +dsMonoBinds :: Bool -- True <=> recursive binding group -> [TyVar] -> [DictVar] -- Abstract wrt these -> (Id -> Id) -- Binder substitution -> TypecheckedMonoBinds @@ -439,11 +446,11 @@ dsMonoBinds :: Bool -- True <=> add auto sccs %============================================== \begin{code} -dsMonoBinds auto_scc is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs [] +dsMonoBinds is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs [] -dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 binds_2) - = andDs (++) (dsMonoBinds auto_scc is_rec tyvars dicts binder_subst binds_1) - (dsMonoBinds auto_scc is_rec tyvars dicts binder_subst binds_2) +dsMonoBinds is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 binds_2) + = andDs (++) (dsMonoBinds is_rec tyvars dicts binder_subst binds_1) + (dsMonoBinds is_rec tyvars dicts binder_subst binds_2) \end{code} @@ -452,31 +459,27 @@ dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 bin %============================================== \begin{code} -dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (CoreMonoBind var core_expr) - = doSccAuto auto_scc [var] core_expr `thenDs` \ sccd_core_expr -> - returnDs [(binder_subst var, mkLam tyvars dicts sccd_core_expr)] +dsMonoBinds is_rec tyvars dicts binder_subst (CoreMonoBind var core_expr) + = returnDs [(binder_subst var, mkLam tyvars dicts core_expr)] -dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (VarMonoBind var expr) +dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr) = dsExpr expr `thenDs` \ core_expr -> - doSccAuto auto_scc [var] core_expr `thenDs` \ sccd_core_expr -> - returnDs [(binder_subst var, mkLam tyvars dicts sccd_core_expr)] + returnDs [(binder_subst var, mkLam tyvars dicts core_expr)] -dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn) +dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn) = putSrcLocDs locn $ let new_fun = binder_subst fun error_string = "function " ++ showForErr fun in matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) -> - doSccAuto auto_scc [fun] body `thenDs` \ sccd_body -> returnDs [(new_fun, - mkLam tyvars (dicts ++ args) sccd_body)] + mkLam tyvars (dicts ++ args) body)] -dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn) +dsMonoBinds is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn) = putSrcLocDs locn $ dsGuarded grhss_and_binds `thenDs` \ body_expr -> - doSccAuto auto_scc [v] body_expr `thenDs` \ sccd_body_expr -> - returnDs [(binder_subst v, mkLam tyvars dicts sccd_body_expr)] + returnDs [(binder_subst v, mkLam tyvars dicts body_expr)] \end{code} %============================================== @@ -490,7 +493,7 @@ be empty. (Simple pattern bindings were handled above.) First, the paranoia check. \begin{code} -dsMonoBinds auto_scc is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn) +dsMonoBinds is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn) = panic "Non-empty dict list in for pattern binding" \end{code} @@ -518,11 +521,10 @@ Then we transform to: \end{description} \begin{code} -dsMonoBinds auto_scc is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn) +dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn) = putSrcLocDs locn $ dsGuarded grhss_and_binds `thenDs` \ body_expr -> - doSccAuto auto_scc pat_binders body_expr `thenDs` \ sccd_body_expr -> {- KILLED by Sansom. 95/05 -- make *sure* there are no primitive types in the pattern @@ -535,11 +537,11 @@ dsMonoBinds auto_scc is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_bi -- we can just use the rhs directly else -} --- pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug sccd_body_expr) $ +-- pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug body_expr) $ mkSelectorBinds tyvars pat [(binder, binder_subst binder) | binder <- pat_binders] - sccd_body_expr + body_expr where pat_binders = collectTypedPatBinders pat -- NB For a simple tuple pattern, these binders @@ -552,40 +554,3 @@ extra work to benefit only rather unusual constructs like let (_,a,b) = ... in ... \end{verbatim} Better to extend the whole thing for any irrefutable constructor, at least. - -%************************************************************************ -%* * -\subsection[doSccAuto]{Adding automatic sccs} -%* * -%************************************************************************ - -\begin{code} -doSccAuto :: Bool -> [Id] -> CoreExpr -> DsM CoreExpr - -doSccAuto False binders core_expr - = returnDs core_expr - -doSccAuto True [] core_expr -- no binders - = returnDs core_expr - -doSccAuto True _ core_expr@(SCC _ _) -- already sccd - = returnDs core_expr - -doSccAuto True _ core_expr@(Con _ _) -- dont bother for simple Con - = returnDs core_expr - -doSccAuto True binders core_expr - = let - scc_all = opt_AutoSccsOnAllToplevs - scc_export = not (null export_binders) - - export_binders = filter isExported binders - - scc_binder = head (if scc_all then binders else export_binders) - in - if scc_all || scc_export then - getModuleAndGroupDs `thenDs` \ (mod,grp) -> - returnDs (SCC (mkAutoCC scc_binder mod grp IsNotCafCC) core_expr) - else - returnDs core_expr -\end{code} diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 2efca382c9..96e870e4e8 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -13,7 +13,7 @@ IMPORT_DELOOPER(DsLoop) -- partly to get dsBinds, partly to chk dsExpr import HsSyn ( failureFreePat, HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..), - Stmt(..), Match(..), Qualifier, HsBinds, HsType, Fixity, + Stmt(..), DoOrListComp(..), Match(..), HsBinds, HsType, Fixity, GRHSsAndBinds ) import TcHsSyn ( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds), @@ -47,16 +47,17 @@ import PprType ( GenType ) import PrelVals ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, voidId ) import Pretty ( ppShow, ppBesides, ppPStr, ppStr ) import TyCon ( isDataTyCon, isNewTyCon ) -import Type ( splitSigmaTy, splitFunTy, typePrimRep, - getAppDataTyConExpandingDicts, getAppTyCon, applyTy, - maybeBoxedPrimType +import Type ( splitSigmaTy, splitFunTy, typePrimRep, + getAppDataTyConExpandingDicts, maybeAppTyCon, getAppTyCon, applyTy, + maybeBoxedPrimType, splitAppTy ) import TysPrim ( voidTy ) -import TysWiredIn ( mkTupleTy, tupleCon, nilDataCon, consDataCon, +import TysWiredIn ( mkTupleTy, tupleCon, nilDataCon, consDataCon, listTyCon, charDataCon, charTy ) import TyVar ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar{-instance Eq-} ) import Usage ( SYN_IE(UVar) ) +import Maybes ( maybeToBool ) import Util ( zipEqual, pprError, panic, assertPanic ) mk_nil_con ty = mkCon nilDataCon [] [ty] [] -- micro utility... @@ -75,7 +76,7 @@ around; if we get hits, we use the value accordingly. \begin{code} dsExpr :: TypecheckedHsExpr -> DsM CoreExpr -dsExpr e@(HsVar var) = dsApp e [] +dsExpr e@(HsVar var) = dsId var \end{code} %************************************************************************ @@ -261,18 +262,25 @@ dsExpr expr@(HsCase discrim matches src_loc) matchWrapper CaseMatch matches "case" `thenDs` \ ([discrim_var], matching_code) -> returnDs ( mkCoLetAny (NonRec discrim_var core_discrim) matching_code ) -dsExpr (ListComp expr quals) - = dsExpr expr `thenDs` \ core_expr -> - dsListComp core_expr quals - dsExpr (HsLet binds expr) - = dsBinds False binds `thenDs` \ core_binds -> + = dsBinds binds `thenDs` \ core_binds -> dsExpr expr `thenDs` \ core_expr -> returnDs ( mkCoLetsAny core_binds core_expr ) -dsExpr (HsDoOut stmts then_id zero_id src_loc) +dsExpr (HsDoOut do_or_lc stmts return_id then_id zero_id result_ty src_loc) + | maybeToBool maybe_list_comp -- Special case for list comprehensions + = putSrcLocDs src_loc $ + dsListComp stmts elt_ty + + | otherwise = putSrcLocDs src_loc $ - dsDo then_id zero_id stmts + dsDo do_or_lc stmts return_id then_id zero_id result_ty + where + maybe_list_comp = case maybeAppTyCon result_ty of + Just (tycon, [elt_ty]) | tycon == listTyCon + -> Just elt_ty + other -> Nothing + Just elt_ty = maybe_list_comp dsExpr (HsIf guard_expr then_expr else_expr src_loc) = putSrcLocDs src_loc $ @@ -519,7 +527,7 @@ dsExpr (ClassDictLam dicts methods expr) #ifdef DEBUG -- HsSyn constructs that just shouldn't be here: -dsExpr (HsDo _ _) = panic "dsExpr:HsDo" +dsExpr (HsDo _ _ _) = panic "dsExpr:HsDo" dsExpr (ExplicitList _) = panic "dsExpr:ExplicitList" dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig" dsExpr (ArithSeqIn _) = panic "dsExpr:ArithSeqIn" @@ -565,13 +573,13 @@ dsApp (TyApp expr tys) args -- we might should look out for SectionLs, etc., here, but we don't -dsApp (HsVar v) args - = lookupEnvDs v `thenDs` \ maybe_expr -> - mkAppDs (case maybe_expr of { Nothing -> Var v; Just expr -> expr }) args - dsApp anything_else args = dsExpr anything_else `thenDs` \ core_expr -> mkAppDs core_expr args + +dsId v + = lookupEnvDs v `thenDs` \ maybe_expr -> + returnDs (case maybe_expr of { Nothing -> Var v; Just expr -> expr }) \end{code} \begin{code} @@ -611,47 +619,73 @@ dsRbinds ((sel_id, rhs, pun_flag) : rbinds) continue_with Basically does the translation given in the Haskell~1.3 report: \begin{code} -dsDo :: Id -- id for: (>>=) m - -> Id -- id for: zero m +dsDo :: DoOrListComp -> [TypecheckedStmt] + -> Id -- id for: return m + -> Id -- id for: (>>=) m + -> Id -- id for: zero m + -> Type -- Element type; the whole expression has type (m t) -> DsM CoreExpr -dsDo then_id zero_id (stmt:stmts) - = case stmt of - ExprStmt expr locn -> ASSERT( null stmts ) do_expr expr locn - - ExprStmtOut expr locn a b -> - do_expr expr locn `thenDs` \ expr2 -> - ds_rest `thenDs` \ rest -> - newSysLocalDs a `thenDs` \ ignored_result_id -> - dsApp (HsVar then_id) [TyArg a, TyArg b, VarArg expr2, - VarArg (mkValLam [ignored_result_id] rest)] - - LetStmt binds -> - dsBinds False binds `thenDs` \ binds2 -> - ds_rest `thenDs` \ rest -> - returnDs (mkCoLetsAny binds2 rest) - - BindStmtOut pat expr locn a b -> - do_expr expr locn `thenDs` \ expr2 -> - let - zero_expr = TyApp (HsVar zero_id) [b] - main_match - = PatMatch pat (SimpleMatch (HsDoOut stmts then_id zero_id locn)) - the_matches - = if failureFreePat pat - then [main_match] - else [main_match, PatMatch (WildPat a) (SimpleMatch zero_expr)] - in - matchWrapper DoBindMatch the_matches "`do' statement" - `thenDs` \ (binders, matching_code) -> - dsApp (HsVar then_id) [TyArg a, TyArg b, - VarArg expr2, VarArg (mkValLam binders matching_code)] +dsDo do_or_lc stmts return_id then_id zero_id result_ty + = dsId return_id `thenDs` \ return_ds -> + dsId then_id `thenDs` \ then_ds -> + dsId zero_id `thenDs` \ zero_ds -> + let + (_, b_ty) = splitAppTy result_ty -- result_ty must be of the form (m b) + + go [ReturnStmt expr] + = dsExpr expr `thenDs` \ expr2 -> + mkAppDs return_ds [TyArg b_ty, VarArg expr2] + + go (GuardStmt expr locn : stmts) + = do_expr expr locn `thenDs` \ expr2 -> + go stmts `thenDs` \ rest -> + mkAppDs zero_ds [TyArg b_ty] `thenDs` \ zero_expr -> + returnDs (mkCoreIfThenElse expr2 rest zero_expr) + + go (ExprStmt expr locn : stmts) + = do_expr expr locn `thenDs` \ expr2 -> + let + (_, a_ty) = splitAppTy (coreExprType expr2) -- Must be of form (m a) + in + if null stmts then + returnDs expr2 + else + go stmts `thenDs` \ rest -> + newSysLocalDs a_ty `thenDs` \ ignored_result_id -> + mkAppDs then_ds [TyArg a_ty, TyArg b_ty, VarArg expr2, + VarArg (mkValLam [ignored_result_id] rest)] + + go (LetStmt binds : stmts ) + = dsBinds binds `thenDs` \ binds2 -> + go stmts `thenDs` \ rest -> + returnDs (mkCoLetsAny binds2 rest) + + go (BindStmt pat expr locn : stmts) + = putSrcLocDs locn $ + dsExpr expr `thenDs` \ expr2 -> + let + (_, a_ty) = splitAppTy (coreExprType expr2) -- Must be of form (m a) + zero_expr = TyApp (HsVar zero_id) [b_ty] + main_match = PatMatch pat (SimpleMatch ( + HsDoOut do_or_lc stmts return_id then_id zero_id result_ty locn)) + the_matches + = if failureFreePat pat + then [main_match] + else [main_match, PatMatch (WildPat a_ty) (SimpleMatch zero_expr)] + in + matchWrapper DoBindMatch the_matches match_msg + `thenDs` \ (binders, matching_code) -> + mkAppDs then_ds [TyArg a_ty, TyArg b_ty, + VarArg expr2, VarArg (mkValLam binders matching_code)] + in + go stmts + where - ds_rest = dsDo then_id zero_id stmts do_expr expr locn = putSrcLocDs locn (dsExpr expr) -#ifdef DEBUG -dsDo then_expr zero_expr [] = panic "dsDo:[]" -#endif + match_msg = case do_or_lc of + DoStmt -> "`do' statement" + ListComp -> "comprehension" \end{code} diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index 6b95110a28..c36e0bd58b 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -12,7 +12,8 @@ IMP_Ubiq() IMPORT_DELOOPER(DsLoop) -- break dsExpr/dsBinds-ish loop import HsSyn ( GRHSsAndBinds(..), GRHS(..), - HsExpr, HsBinds ) + HsExpr, HsBinds + ) import TcHsSyn ( SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS), SYN_IE(TypecheckedPat), SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) ) @@ -45,7 +46,7 @@ dsGuarded :: TypecheckedGRHSsAndBinds -> DsM CoreExpr dsGuarded (GRHSsAndBindsOut grhss binds err_ty) - = dsBinds False binds `thenDs` \ core_binds -> + = dsBinds binds `thenDs` \ core_binds -> dsGRHSs err_ty PatBindMatch [] grhss `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn _) -> case can_it_fail of CantFail -> returnDs (mkCoLetsAny core_binds (core_grhss_fn (panic "It can't fail"))) @@ -96,3 +97,4 @@ dsGRHS ty kind pats (GRHS guard expr locn) \end{code} + diff --git a/ghc/compiler/deSugar/DsHsSyn.lhs b/ghc/compiler/deSugar/DsHsSyn.lhs index d7e54ef40a..010d741291 100644 --- a/ghc/compiler/deSugar/DsHsSyn.lhs +++ b/ghc/compiler/deSugar/DsHsSyn.lhs @@ -36,6 +36,7 @@ outPatType (TuplePat pats) = mkTupleTy (length pats) (map outPatType pats) outPatType (RecPat _ ty _) = ty outPatType (LitPat lit ty) = ty outPatType (NPat lit ty _) = ty +outPatType (NPlusKPat _ _ ty _ _) = ty outPatType (DictPat ds ms) = case (length ds_ms) of 0 -> unitTy 1 -> idType (head ds_ms) diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 2a396ea7eb..bec2c8ac24 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -11,8 +11,8 @@ module DsListComp ( dsListComp ) where IMP_Ubiq() IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop -import HsSyn ( Qualifier(..), HsExpr, HsBinds ) -import TcHsSyn ( SYN_IE(TypecheckedQual), SYN_IE(TypecheckedHsExpr) , SYN_IE(TypecheckedHsBinds) ) +import HsSyn ( Stmt(..), HsExpr, HsBinds ) +import TcHsSyn ( SYN_IE(TypecheckedStmt), SYN_IE(TypecheckedHsExpr) , SYN_IE(TypecheckedHsBinds) ) import DsHsSyn ( outPatType ) import CoreSyn @@ -37,42 +37,36 @@ turned on'' (if you read Gill {\em et al.}'s paper on the subject). There will be at least one ``qualifier'' in the input. \begin{code} -dsListComp :: CoreExpr -> [TypecheckedQual] -> DsM CoreExpr +dsListComp :: [TypecheckedStmt] + -> Type -- Type of list elements + -> DsM CoreExpr + +dsListComp quals elt_ty + | not opt_FoldrBuildOn -- Be boring + = deListComp quals nil_expr -dsListComp expr quals - = let - expr_ty = coreExprType expr + | otherwise -- foldr/build lives! + = newTyVarsDs [alphaTyVar] `thenDs` \ [n_tyvar] -> + let + alpha_to_alpha = alphaTy `mkFunTy` alphaTy + + n_ty = mkTyVarTy n_tyvar + c_ty = mkFunTys [elt_ty, n_ty] n_ty + g_ty = mkForAllTy alphaTyVar ( + (elt_ty `mkFunTy` alpha_to_alpha) + `mkFunTy` + alpha_to_alpha + ) in - if not opt_FoldrBuildOn then -- be boring - deListComp expr quals (nIL_EXPR expr_ty) - - else -- foldr/build lives! - new_alpha_tyvar `thenDs` \ (n_tyvar, n_ty) -> - let - alpha_to_alpha = alphaTy `mkFunTy` alphaTy - - c_ty = mkFunTys [expr_ty, n_ty] n_ty - g_ty = mkForAllTy alphaTyVar ( - (expr_ty `mkFunTy` alpha_to_alpha) - `mkFunTy` - alpha_to_alpha - ) - in - newSysLocalsDs [c_ty,n_ty,g_ty] `thenDs` \ [c, n, g] -> - - dfListComp expr expr_ty - c_ty c - n_ty n - quals `thenDs` \ result -> - - returnDs (mkBuild expr_ty n_tyvar c n g result) - where - nIL_EXPR ty = mkCon nilDataCon [] [ty] [] + newSysLocalsDs [c_ty,n_ty,g_ty] `thenDs` \ [c, n, g] -> - new_alpha_tyvar :: DsM (TyVar, Type) - new_alpha_tyvar - = newTyVarsDs [alphaTyVar] `thenDs` \ [new_ty] -> - returnDs (new_ty, mkTyVarTy new_ty) + dfListComp c_ty c + n_ty n + quals `thenDs` \ result -> + + returnDs (mkBuild elt_ty n_tyvar c n g result) + where + nil_expr = mkCon nilDataCon [] [elt_ty] [] \end{code} %************************************************************************ @@ -119,23 +113,24 @@ is the TE translation scheme. Note that we carry around the @L@ list already desugared. @dsListComp@ does the top TE rule mentioned above. \begin{code} -deListComp :: CoreExpr -> [TypecheckedQual] -> CoreExpr -> DsM CoreExpr +deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr -deListComp expr [] list -- Figure 7.4, SLPJ, p 135, rule C above - = mkConDs consDataCon [TyArg (coreExprType expr), VarArg expr, VarArg list] +deListComp [ReturnStmt expr] list -- Figure 7.4, SLPJ, p 135, rule C above + = dsExpr expr `thenDs` \ core_expr -> + mkConDs consDataCon [TyArg (coreExprType core_expr), VarArg core_expr, VarArg list] -deListComp expr (FilterQual filt : quals) list -- rule B above - = dsExpr filt `thenDs` \ core_filt -> - deListComp expr quals list `thenDs` \ core_rest -> - returnDs ( mkCoreIfThenElse core_filt core_rest list ) +deListComp (GuardStmt guard locn : quals) list -- rule B above + = dsExpr guard `thenDs` \ core_guard -> + deListComp quals list `thenDs` \ core_rest -> + returnDs (mkCoreIfThenElse core_guard core_rest list) -- [e | let B, qs] = let B in [e | qs] -deListComp expr (LetQual binds : quals) list - = dsBinds False binds `thenDs` \ core_binds -> - deListComp expr quals list `thenDs` \ core_rest -> +deListComp (LetStmt binds : quals) list + = dsBinds binds `thenDs` \ core_binds -> + deListComp quals list `thenDs` \ core_rest -> returnDs (mkCoLetsAny core_binds core_rest) -deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above +deListComp (BindStmt pat list1 locn : quals) core_list2 -- rule A' above = dsExpr list1 `thenDs` \ core_list1 -> let u3_ty@u1_ty = coreExprType core_list1 -- two names, same thing @@ -146,27 +141,14 @@ deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above res_ty = coreExprType core_list2 h_ty = u1_ty `mkFunTy` res_ty in - newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] - `thenDs` \ [h', u1, u2, u3] -> - {- - Make the function h unfoldable by the deforester. - Since it only occurs once in the body, we can't get - an increase in code size by unfolding it. - -} - let - h = if False -- LATER: sw_chkr DoDeforest??? - then panic "deListComp:deforest" - -- replaceIdInfo h' (addInfo (getIdInfo h') DoDeforest) - else h' - in - -- the "fail" value ... - mkAppDs (Var h) [VarArg (Var u3)] `thenDs` \ core_fail -> - - deListComp expr quals core_fail `thenDs` \ rest_expr -> + newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] `thenDs` \ [h, u1, u2, u3] -> - matchSimply (Var u2) pat res_ty rest_expr core_fail `thenDs` \ core_match -> - - mkAppDs (Var h) [VarArg core_list1] `thenDs` \ letrec_body -> + -- the "fail" value ... + mkAppDs (Var h) [VarArg (Var u3)] `thenDs` \ core_fail -> + deListComp quals core_fail `thenDs` \ rest_expr -> + matchSimply (Var u2) pat res_ty + rest_expr core_fail `thenDs` \ core_match -> + mkAppDs (Var h) [VarArg core_list1] `thenDs` \ letrec_body -> returnDs ( mkCoLetrecAny [ @@ -174,8 +156,8 @@ deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above (Lam (ValBinder u1) (Case (Var u1) (AlgAlts - [(nilDataCon, [], core_list2), - (consDataCon, [u2, u3], core_match)] + [(nilDataCon, [], core_list2), + (consDataCon, [u2, u3], core_match)] NoDefault))) )] letrec_body ) @@ -196,29 +178,27 @@ TE << [ e | p <- l , q ] c n = foldr _ b -> b) n l \end{verbatim} \begin{code} -dfListComp :: CoreExpr -- the inside of the comp - -> Type -- the type of the inside - -> Type -> Id -- 'c'; its type and id +dfListComp :: Type -> Id -- 'c'; its type and id -> Type -> Id -- 'n'; its type and id - -> [TypecheckedQual] -- the rest of the qual's + -> [TypecheckedStmt] -- the rest of the qual's -> DsM CoreExpr -dfListComp expr expr_ty c_ty c_id n_ty n_id [] - = mkAppDs (Var c_id) [VarArg expr, VarArg (Var n_id)] +dfListComp c_ty c_id n_ty n_id [ReturnStmt expr] + = dsExpr expr `thenDs` \ core_expr -> + mkAppDs (Var c_id) [VarArg core_expr, VarArg (Var n_id)] -dfListComp expr expr_ty c_ty c_id n_ty n_id (FilterQual filt : quals) - = dsExpr filt `thenDs` \ core_filt -> - dfListComp expr expr_ty c_ty c_id n_ty n_id quals - `thenDs` \ core_rest -> - returnDs (mkCoreIfThenElse core_filt core_rest (Var n_id)) +dfListComp c_ty c_id n_ty n_id (GuardStmt guard locn : quals) + = dsExpr guard `thenDs` \ core_guard -> + dfListComp c_ty c_id n_ty n_id quals `thenDs` \ core_rest -> + returnDs (mkCoreIfThenElse core_guard core_rest (Var n_id)) -dfListComp expr expr_ty c_ty c_id n_ty n_id (LetQual binds : quals) +dfListComp c_ty c_id n_ty n_id (LetStmt binds : quals) -- new in 1.3, local bindings - = dsBinds False binds `thenDs` \ core_binds -> - dfListComp expr expr_ty c_ty c_id n_ty n_id quals `thenDs` \ core_rest -> - returnDs ( mkCoLetsAny core_binds core_rest ) + = dsBinds binds `thenDs` \ core_binds -> + dfListComp c_ty c_id n_ty n_id quals `thenDs` \ core_rest -> + returnDs (mkCoLetsAny core_binds core_rest) -dfListComp expr expr_ty c_ty c_id n_ty n_id (GeneratorQual pat list1 : quals) +dfListComp c_ty c_id n_ty n_id (BindStmt pat list1 locn : quals) -- evaluate the two lists = dsExpr list1 `thenDs` \ core_list1 -> @@ -236,7 +216,7 @@ dfListComp expr expr_ty c_ty c_id n_ty n_id (GeneratorQual pat list1 : quals) -- build rest of the comprehesion - dfListComp expr expr_ty c_ty c_id b_ty b quals `thenDs` \ core_rest -> + dfListComp c_ty c_id b_ty b quals `thenDs` \ core_rest -> -- build the pattern match matchSimply (Var p) pat b_ty core_rest (Var b) `thenDs` \ core_expr -> diff --git a/ghc/compiler/deSugar/DsLoop.lhi b/ghc/compiler/deSugar/DsLoop.lhi index fd329c0c69..26a0c4b313 100644 --- a/ghc/compiler/deSugar/DsLoop.lhi +++ b/ghc/compiler/deSugar/DsLoop.lhi @@ -26,6 +26,6 @@ matchSimply :: CoreExpr -- Scrutinee -> CoreExpr -- Return this if it does -> DsM CoreExpr -dsBinds :: Bool -> TypecheckedHsBinds -> DsM [CoreBinding] +dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding] dsExpr :: TypecheckedHsExpr -> DsM CoreExpr \end{code} diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index bf3f5f0878..38e567a7ea 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -20,8 +20,11 @@ module DsMonad ( SYN_IE(DsIdEnv), lookupId, - dsShadowError, - DsMatchContext(..), DsMatchKind(..), pprDsWarnings + dsShadowWarn, dsIncompleteWarn, + DsWarnings(..), + DsMatchContext(..), DsMatchKind(..), pprDsWarnings, + DsWarnFlavour -- Nuke with 1.4 + ) where IMP_Ubiq() @@ -60,8 +63,9 @@ type DsM result = -> DsWarnings -> (result, DsWarnings) -type DsWarnings = Bag DsMatchContext -- The desugarer reports matches which are - -- completely shadowed +type DsWarnings = Bag (DsWarnFlavour, DsMatchContext) + -- The desugarer reports matches which are + -- completely shadowed or incomplete patterns {-# INLINE andDs #-} {-# INLINE thenDs #-} {-# INLINE returnDs #-} @@ -181,9 +185,13 @@ putSrcLocDs :: SrcLoc -> DsM a -> DsM a putSrcLocDs new_loc expr us old_loc mod_and_grp env warns = expr us new_loc mod_and_grp env warns -dsShadowError :: DsMatchContext -> DsM () -dsShadowError cxt us loc mod_and_grp env warns - = ((), warns `snocBag` cxt) +dsShadowWarn :: DsMatchContext -> DsM () +dsShadowWarn cxt us loc mod_and_grp env warns + = ((), warns `snocBag` (Shadowed, cxt)) + +dsIncompleteWarn :: DsMatchContext -> DsM () +dsIncompleteWarn cxt us loc mod_and_grp env warns + = ((), warns `snocBag` (Incomplete, cxt)) \end{code} \begin{code} @@ -237,9 +245,12 @@ lookupId env id %************************************************************************ \begin{code} +data DsWarnFlavour = Shadowed | Incomplete deriving () + data DsMatchContext = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc | NoMatchContext + deriving () data DsMatchKind = FunMatch Id @@ -247,23 +258,31 @@ data DsMatchKind | LambdaMatch | PatBindMatch | DoBindMatch + deriving () -pprDsWarnings :: PprStyle -> Bag DsMatchContext -> Pretty +pprDsWarnings :: PprStyle -> DsWarnings -> Pretty pprDsWarnings sty warns - = ppAboves (map pp_cxt (bagToList warns)) + = ppAboves (map pp_warn (bagToList warns)) where - pp_cxt NoMatchContext = ppPStr SLIT("Some match is shadowed; I don't know what") - pp_cxt (DsMatchContext kind pats loc) - = ppHang (ppBesides [ppr PprForUser loc, ppPStr SLIT(": ")]) - 4 (ppHang (ppPStr SLIT("Pattern match(es) completely overlapped:")) + pp_warn (flavour, NoMatchContext) = ppSep [ppPStr SLIT("Warning: Some match is"), + case flavour of + Shadowed -> ppPStr SLIT("shadowed") + Incomplete -> ppPStr SLIT("possibly incomplete")] + + pp_warn (flavour, DsMatchContext kind pats loc) + = ppHang (ppBesides [ppr PprForUser loc, ppPStr SLIT(": ")]) + 4 (ppHang msg 4 (pp_match kind pats)) + where + msg = case flavour of + Shadowed -> ppPStr SLIT("Warning: Pattern match(es) completely overlapped") + Incomplete -> ppPStr SLIT("Warning: Possibly incomplete patterns") pp_match (FunMatch fun) pats - = ppHang (ppr sty fun) - 4 (ppSep [ppSep (map (ppr sty) pats), ppPStr SLIT("= ...")]) + = ppCat [ppPStr SLIT("in the definition of function"), ppQuote (ppr sty fun)] pp_match CaseMatch pats - = ppHang (ppPStr SLIT("in a case alternative:")) + = ppHang (ppPStr SLIT("in a group of case alternative beginning:")) 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot]) pp_match PatBindMatch pats diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index ff2ec5fe45..3fdc1d3c9a 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -31,7 +31,7 @@ IMP_Ubiq() IMPORT_DELOOPER(DsLoop) ( match, matchSimply ) import HsSyn ( HsExpr(..), OutPat(..), HsLit(..), Fixity, - Match, HsBinds, Stmt, Qualifier, HsType, ArithSeqInfo ) + Match, HsBinds, Stmt, DoOrListComp, HsType, ArithSeqInfo ) import TcHsSyn ( SYN_IE(TypecheckedPat) ) import DsHsSyn ( outPatType ) import CoreSyn @@ -46,21 +46,20 @@ import Id ( idType, dataConArgTys, -- pprId{-ToDo:rm-}, SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId ) import Literal ( Literal(..) ) +import PprType ( GenType, GenTyVar ) import TyCon ( isNewTyCon, tyConDataCons ) import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTy, - mkTheta, isUnboxedType, applyTyCon, getAppTyCon + mkTheta, isUnboxedType, applyTyCon, getAppTyCon, + GenType {- instances -} ) +import TyVar ( GenTyVar {- instances -} ) import TysPrim ( voidTy ) import TysWiredIn ( tupleTyCon, unitDataCon, tupleCon ) import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, SYN_IE(UniqSet) ) import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} ) +import Unique ( Unique ) import Usage ( SYN_IE(UVar) ) import SrcLoc ( SrcLoc {- instance Outputable -} ) ---import PprCore{-ToDo:rm-} ---import PprType--ToDo:rm ---import Pretty--ToDo:rm ---import TyVar--ToDo:rm ---import Unique--ToDo:rm \end{code} %************************************************************************ @@ -316,7 +315,7 @@ mkErrorAppDs :: Id -- The error function mkErrorAppDs err_id ty msg = getSrcLocDs `thenDs` \ src_loc -> let - full_msg = ppShow 80 (ppBesides [ppr PprForUser src_loc, ppStr ": ", ppStr msg]) + full_msg = ppShow 80 (ppBesides [ppr PprForUser src_loc, ppStr "|", ppStr msg]) msg_lit = NoRepStr (_PK_ full_msg) in returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit]) @@ -356,7 +355,7 @@ mkSelectorBinds tyvars pat locals_and_globals val_expr = if is_simple_tuple_pat pat then mkTupleBind tyvars [] locals_and_globals val_expr else - mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty "" `thenDs` \ error_msg -> + mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty pat_string `thenDs` \ error_msg -> matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr -> mkTupleBind tyvars [] locals_and_globals tuple_expr where @@ -369,6 +368,8 @@ mkSelectorBinds tyvars pat locals_and_globals val_expr is_var_pat (VarPat v) = True is_var_pat other = False -- Even wild-card patterns aren't acceptable + + pat_string = ppShow 80 (ppr PprForUser pat) \end{code} We're about to match against some patterns. We want to make some diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index c822765110..7fb28b1c05 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -153,31 +153,27 @@ And gluing the ``success expressions'' together isn't quite so pretty. \begin{code} match [] eqns_info shadows - = pin_eqns eqns_info `thenDs` \ match_result@(MatchResult _ _ _ cxt) -> + = complete_matches eqns_info (any eqn_cant_fail shadows) + where + complete_matches [eqn] is_shadowed + = complete_match eqn is_shadowed + + complete_matches (eqn:eqns) is_shadowed + = complete_match eqn is_shadowed `thenDs` \ match_result1 -> + complete_matches eqns (is_shadowed || eqn_cant_fail eqn) `thenDs` \ match_result2 -> + combineMatchResults match_result1 match_result2 -- If at this stage we find that at least one of the shadowing -- equations is guaranteed not to fail, then warn of an overlapping pattern - if not (all shadow_can_fail shadows) then - dsShadowError cxt `thenDs` \ _ -> - returnDs match_result - else - returnDs match_result - - where - pin_eqns [EqnInfo [] match_result] = returnDs match_result - -- Last eqn... can't have pats ... - - pin_eqns (EqnInfo [] match_result1 : more_eqns) - = pin_eqns more_eqns `thenDs` \ match_result2 -> - combineMatchResults match_result1 match_result2 + complete_match (EqnInfo [] match_result@(MatchResult _ _ _ cxt)) is_shadowed + | is_shadowed = dsShadowWarn cxt `thenDs` \ _ -> + returnDs match_result - pin_eqns other_pat = panic "match: pin_eqns" + | otherwise = returnDs match_result - shadow_can_fail :: EquationInfo -> Bool - - shadow_can_fail (EqnInfo [] (MatchResult CanFail _ _ _)) = True - shadow_can_fail (EqnInfo [] (MatchResult CantFail _ _ _)) = False - shadow_can_fail other = panic "match:shadow_can_fail" + eqn_cant_fail :: EquationInfo -> Bool + eqn_cant_fail (EqnInfo [] (MatchResult CanFail _ _ _)) = False + eqn_cant_fail (EqnInfo [] (MatchResult CantFail _ _ _)) = True \end{code} %************************************************************************ @@ -253,6 +249,8 @@ Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@. Removing lazy (irrefutable) patterns (you don't want to know...). \item Converting explicit tuple- and list-pats into ordinary @ConPats@. +\item +Convert the literal pat "" to []. \end{itemize} The result of this tidying is that the column of patterns will include @@ -395,6 +393,7 @@ tidy1 v pat@(LitPat lit lit_ty) match_result -- NPats: we *might* be able to replace these w/ a simpler form + tidy1 v pat@(NPat lit lit_ty _) match_result = returnDs (better_pat, match_result) where @@ -405,6 +404,10 @@ tidy1 v pat@(NPat lit lit_ty _) match_result | lit_ty `eqTy` addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy] | lit_ty `eqTy` floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy] | lit_ty `eqTy` doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy] + + -- Convert the literal pattern "" to the constructor pattern []. + | null_str_lit lit = ConPat nilDataCon lit_ty [] + | otherwise = pat mk_int (HsInt i) = HsIntPrim i @@ -425,6 +428,9 @@ tidy1 v pat@(NPat lit lit_ty _) match_result mk_double (HsFrac f) = HsDoublePrim f mk_double l@(HsLitLit s) = l + null_str_lit (HsString s) = _NULL_ s + null_str_lit other_lit = False + -- and everything else goes through unchanged... tidy1 v non_interesting_pat match_result @@ -608,7 +614,7 @@ matchWrapper kind [(PatMatch (WildPat ty) match)] error_string matchWrapper kind [(GRHSMatch (GRHSsAndBindsOut [OtherwiseGRHS expr _] binds _))] error_string - = dsBinds False binds `thenDs` \ core_binds -> + = dsBinds binds `thenDs` \ core_binds -> dsExpr expr `thenDs` \ core_expr -> returnDs ([], mkCoLetsAny core_binds core_expr) @@ -622,8 +628,14 @@ matchWrapper kind matches error_string match new_vars eqns_info [] `thenDs` \ match_result -> mkErrorAppDs pAT_ERROR_ID result_ty error_string `thenDs` \ fail_expr -> - extractMatchResult match_result fail_expr `thenDs` \ result_expr -> + -- Check for incomplete pattern match + (case match_result of + MatchResult CanFail result_ty match_fn cxt -> dsIncompleteWarn cxt + other -> returnDs () + ) `thenDs` \ _ -> + + extractMatchResult match_result fail_expr `thenDs` \ result_expr -> returnDs (new_vars, result_expr) \end{code} @@ -664,8 +676,8 @@ matchSimply scrut_expr pat result_ty result_expr msg extractMatchResult (MatchResult CantFail _ match_fn _) fail_expr = returnDs (match_fn (error "It can't fail!")) -extractMatchResult (MatchResult CanFail result_ty match_fn _) fail_expr - = mkFailurePair result_ty `thenDs` \ (fail_bind_fn, if_it_fails) -> +extractMatchResult (MatchResult CanFail result_ty match_fn cxt) fail_expr + = mkFailurePair result_ty `thenDs` \ (fail_bind_fn, if_it_fails) -> returnDs (Let (fail_bind_fn fail_expr) (match_fn if_it_fails)) \end{code} @@ -699,7 +711,7 @@ flattenMatches kind (match : matches) = flatten_match (pat:pats_so_far) match flatten_match pats_so_far (GRHSMatch (GRHSsAndBindsOut grhss binds ty)) - = dsBinds False binds `thenDs` \ core_binds -> + = dsBinds binds `thenDs` \ core_binds -> dsGRHSs ty kind pats grhss `thenDs` \ match_result -> returnDs (EqnInfo pats (mkCoLetsMatchResult core_binds match_result)) where @@ -707,12 +719,14 @@ flattenMatches kind (match : matches) flatten_match pats_so_far (SimpleMatch expr) = dsExpr expr `thenDs` \ core_expr -> + getSrcLocDs `thenDs` \ locn -> returnDs (EqnInfo pats (MatchResult CantFail (coreExprType core_expr) (\ ignore -> core_expr) - NoMatchContext)) - -- The NoMatchContext is just a place holder. In a simple match, - -- the matching can't fail, so we won't generate an error message. - where - pats = reverse pats_so_far -- They've accumulated in reverse order + (DsMatchContext kind pats locn))) + + -- the matching can't fail, so we won't generate an error message. + where + pats = reverse pats_so_far -- They've accumulated in reverse order + \end{code} diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index a4ed52d685..c7e4bc1d9c 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -12,11 +12,12 @@ IMP_Ubiq() IMPORT_DELOOPER(DsLoop) -- break match-ish and dsExpr-ish loops import HsSyn ( HsLit(..), OutPat(..), HsExpr(..), Fixity, - Match, HsBinds, Stmt, Qualifier, HsType, ArithSeqInfo ) + Match, HsBinds, Stmt(..), DoOrListComp, HsType, ArithSeqInfo ) import TcHsSyn ( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedPat) ) -import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(CoreBinding) ) +import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(CoreBinding), GenCoreExpr(..), GenCoreBinding(..) ) +import Id ( GenId {- instance Eq -} ) import DsMonad import DsUtils @@ -54,9 +55,9 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo (LitPat literal lit_ty : ps match_prims_used vars eqns_info@(EqnInfo ((LitPat literal lit_ty):ps1) _ : eqns) shadows = let (shifted_eqns_for_this_lit, eqns_not_for_this_lit) - = partitionEqnsByLit literal eqns_info + = partitionEqnsByLit Nothing literal eqns_info (shifted_shadows_for_this_lit, shadows_not_for_this_lit) - = partitionEqnsByLit literal shadows + = partitionEqnsByLit Nothing literal shadows in -- recursive call to make other alts... match_prims_used vars eqns_not_for_this_lit shadows_not_for_this_lit `thenDs` \ rest_of_alts -> @@ -85,9 +86,9 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo (LitPat literal lit_ty : ps matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo ((NPat literal lit_ty eq_chk):ps1) _ : eqns) shadows = let (shifted_eqns_for_this_lit, eqns_not_for_this_lit) - = partitionEqnsByLit literal eqns_info + = partitionEqnsByLit Nothing literal eqns_info (shifted_shadows_for_this_lit, shadows_not_for_this_lit) - = partitionEqnsByLit literal shadows + = partitionEqnsByLit Nothing literal shadows in dsExpr (HsApp eq_chk (HsVar var)) `thenDs` \ pred_expr -> match vars shifted_eqns_for_this_lit shifted_shadows_for_this_lit `thenDs` \ inner_match_result -> @@ -111,12 +112,42 @@ We generate: \end{verbatim} + +\begin{code} +matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo ((NPlusKPat master_n k ty ge sub):ps1) _ : eqns) shadows + = let + (shifted_eqns_for_this_lit, eqns_not_for_this_lit) + = partitionEqnsByLit (Just master_n) k eqns_info + (shifted_shadows_for_this_lit, shadows_not_for_this_lit) + = partitionEqnsByLit (Just master_n) k shadows + in + match vars shifted_eqns_for_this_lit shifted_shadows_for_this_lit `thenDs` \ inner_match_result -> + + dsExpr (HsApp ge (HsVar var)) `thenDs` \ ge_expr -> + dsExpr (HsApp sub (HsVar var)) `thenDs` \ nminusk_expr -> + + mkGuardedMatchResult + ge_expr + (mkCoLetsMatchResult [NonRec master_n nminusk_expr] inner_match_result) + `thenDs` \ match_result1 -> + + if (null eqns_not_for_this_lit) + then + returnDs match_result1 + else + matchLiterals all_vars eqns_not_for_this_lit shadows_not_for_this_lit `thenDs` \ match_result2 -> + combineMatchResults match_result1 match_result2 +\end{code} + Given a blob of LitPats/NPats, we want to split them into those that are ``same''/different as one we are looking at. We need to know whether we're looking at a LitPat/NPat, and what literal we're after. \begin{code} -partitionEqnsByLit :: HsLit +partitionEqnsByLit :: Maybe Id -- (Just v) for N-plus-K patterns, where v + -- is the "master" variable; + -- Nothing for NPats and LitPats + -> HsLit -> [EquationInfo] -> ([EquationInfo], -- These ones are for this lit, AND -- they've been "shifted" by stripping @@ -125,27 +156,34 @@ partitionEqnsByLit :: HsLit -- are exactly as fed in. ) -partitionEqnsByLit lit eqns +partitionEqnsByLit nPlusK lit eqns = ( \ (xs,ys) -> (catMaybes xs, catMaybes ys)) - (unzip (map (partition_eqn lit) eqns)) + (unzip (map (partition_eqn nPlusK lit) eqns)) where - partition_eqn :: HsLit -> EquationInfo -> + partition_eqn :: Maybe Id -> HsLit -> EquationInfo -> (Maybe EquationInfo, Maybe EquationInfo) - partition_eqn lit (EqnInfo (LitPat k _ : remaining_pats) match_result) + partition_eqn Nothing lit (EqnInfo (LitPat k _ : remaining_pats) match_result) | lit `eq_lit` k = (Just (EqnInfo remaining_pats match_result), Nothing) - -- NB the pattern is stripped off thhe EquationInfo + -- NB the pattern is stripped off the EquationInfo - partition_eqn lit (EqnInfo (NPat k _ _ : remaining_pats) match_result) + partition_eqn Nothing lit (EqnInfo (NPat k _ _ : remaining_pats) match_result) | lit `eq_lit` k = (Just (EqnInfo remaining_pats match_result), Nothing) - -- NB the pattern is stripped off thhe EquationInfo + -- NB the pattern is stripped off the EquationInfo + + partition_eqn (Just master_n) lit (EqnInfo (NPlusKPat n k _ _ _ : remaining_pats) match_result) + | lit `eq_lit` k = (Just (EqnInfo remaining_pats new_match_result), Nothing) + -- NB the pattern is stripped off the EquationInfo + where + new_match_result | master_n == n = match_result + | otherwise = mkCoLetsMatchResult [NonRec n (Var master_n)] match_result -- Wild-card patterns, which will only show up in the shadows, go into both groups - partition_eqn lit eqn@(EqnInfo (WildPat _ : remaining_pats) match_result) + partition_eqn nPlusK lit eqn@(EqnInfo (WildPat _ : remaining_pats) match_result) = (Just (EqnInfo remaining_pats match_result), Just eqn) -- Default case; not for this pattern - partition_eqn lit eqn = (Nothing, Just eqn) + partition_eqn nPlusK lit eqn = (Nothing, Just eqn) -- ToDo: meditate about this equality business... diff --git a/ghc/compiler/hsSyn/HsBasic.lhs b/ghc/compiler/hsSyn/HsBasic.lhs index 114721a707..b6bf85e340 100644 --- a/ghc/compiler/hsSyn/HsBasic.lhs +++ b/ghc/compiler/hsSyn/HsBasic.lhs @@ -92,9 +92,9 @@ instance Outputable Fixity where ppr sty (Fixity prec dir) = ppBesides [ppr sty dir, ppSP, ppInt prec] instance Outputable FixityDirection where - ppr sty InfixL = ppStr "infixl" - ppr sty InfixR = ppStr "infixr" - ppr sty InfixN = ppStr "infix" + ppr sty InfixL = ppPStr SLIT("infixl") + ppr sty InfixR = ppPStr SLIT("infixr") + ppr sty InfixN = ppPStr SLIT("infix") instance Eq Fixity where -- Used to determine if two fixities conflict (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2 diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index fd1f1f3ec0..8a0232721b 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -68,7 +68,7 @@ data HsBinds tyvar uvar id pat -- binders and bindees | AbsBinds -- Binds abstraction; TRANSLATION [tyvar] [id] -- Dicts - [(id, id)] -- (old, new) pairs + [(id, id)] -- (momonmorphic, polymorphic) pairs [(id, HsExpr tyvar uvar id pat)] -- local dictionaries (Bind tyvar uvar id pat) -- "the business end" @@ -80,6 +80,31 @@ data HsBinds tyvar uvar id pat -- binders and bindees -- of this last construct.) \end{code} +What AbsBinds means +~~~~~~~~~~~~~~~~~~~ + AbsBinds [a,b] + [d1,d2] + [(fm,fp), (gm,gp)] + [d3 = d1, + d4 = df d2] + BIND +means + + fp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND + in fm + + gp = ...same again, with gm instead of fm + +This is a pretty bad translation, because it duplicates all the bindings. +So the desugarer tries to do a better job: + + fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of + (fm,gm) -> fm + ..ditto for gp.. + + p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND + in (fm,gm) + \begin{code} nullBinds :: HsBinds tyvar uvar id pat -> Bool @@ -129,9 +154,9 @@ data Sig name (HsType name) SrcLoc - | ClassOpSig name -- class-op sigs have different pragmas + | ClassOpSig name -- Selector name + name -- Default-method name (HsType name) - (ClassOpPragmas name) -- only interface ones have pragmas SrcLoc | SpecSig name -- specialise a function or datatype ... @@ -157,27 +182,28 @@ instance (NamedThing name, Outputable name) => Outputable (Sig name) where = ppHang (ppCat [ppr sty var, ppPStr SLIT("::")]) 4 (ppr sty ty) - ppr sty (ClassOpSig var ty pragmas _) + ppr sty (ClassOpSig var _ ty _) = ppHang (ppCat [ppr sty (getOccName var), ppPStr SLIT("::")]) - 4 (ppHang (ppr sty ty) - 4 (ifnotPprForUser sty (ppr sty pragmas))) + 4 (ppr sty ty) ppr sty (DeforestSig var _) = ppHang (ppCat [ppStr "{-# DEFOREST", pprNonSym sty var]) - 4 (ppStr "#-}") + 4 (ppStr "#-") ppr sty (SpecSig var ty using _) - = ppHang (ppCat [ppPStr SLIT("{-# SPECIALIZE"), pprNonSym sty var, ppPStr SLIT("::")]) - 4 (ppCat [ppr sty ty, pp_using using, ppPStr SLIT("#-}")]) + = ppHang (ppCat [ppStr "{-# SPECIALIZE", pprNonSym sty var, ppPStr SLIT("::")]) + 4 (ppCat [ppr sty ty, pp_using using, ppStr "#-}"]) + where pp_using Nothing = ppNil pp_using (Just me) = ppCat [ppChar '=', ppr sty me] ppr sty (InlineSig var _) - = ppCat [ppPStr SLIT("{-# INLINE"), pprNonSym sty var, ppPStr SLIT("#-}")] + + = ppCat [ppStr "{-# INLINE", pprNonSym sty var, ppStr "#-}"] ppr sty (MagicUnfoldingSig var str _) - = ppCat [ppPStr SLIT("{-# MAGIC_UNFOLDING"), pprNonSym sty var, ppPStr str, ppPStr SLIT("#-}")] + = ppCat [ppStr "{-# MAGIC_UNFOLDING", pprNonSym sty var, ppPStr str, ppStr "#-}"] \end{code} %************************************************************************ @@ -215,10 +241,10 @@ instance (NamedThing id, Outputable id, Outputable pat, Outputable (Bind tyvar uvar id pat) where ppr sty EmptyBind = ppNil ppr sty (NonRecBind binds) - = ppAbove (ifnotPprForUser sty (ppStr "{- nonrec -}")) + = ppAbove (ifnotPprForUser sty (ppPStr SLIT("{- nonrec -}"))) (ppr sty binds) ppr sty (RecBind binds) - = ppAbove (ifnotPprForUser sty (ppStr "{- rec -}")) + = ppAbove (ifnotPprForUser sty (ppPStr SLIT("{- rec -}"))) (ppr sty binds) \end{code} diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 3a240733fc..8e60262755 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -66,15 +66,14 @@ data UfPrimOp name data UfCoercion name = UfIn name | UfOut name data UfAlts name - = UfAlgAlts [(name, [UfBinder name], UfExpr name)] + = UfAlgAlts [(name, [name], UfExpr name)] (UfDefault name) | UfPrimAlts [(Literal, UfExpr name)] (UfDefault name) data UfDefault name = UfNoDefault - | UfBindDefault (UfBinder name) - (UfExpr name) + | UfBindDefault name (UfExpr name) data UfBinding name = UfNonRec (UfBinder name) @@ -105,15 +104,15 @@ instance Outputable name => Outputable (UfExpr name) where ppr sty (UfLit l) = ppr sty l ppr sty (UfCon c as) - = ppCat [ppStr "(UfCon", ppr sty c, ppr sty as, ppStr ")"] + = ppCat [ppStr "UfCon", ppr sty c, ppr sty as, ppChar ')'] ppr sty (UfPrim o as) - = ppCat [ppStr "(UfPrim", ppr sty o, ppr sty as, ppStr ")"] + = ppCat [ppStr "UfPrim", ppr sty o, ppr sty as, ppChar ')'] ppr sty (UfLam b body) - = ppCat [ppChar '\\', ppr sty b, ppStr "->", ppr sty body] + = ppCat [ppChar '\\', ppr sty b, ppPStr SLIT("->"), ppr sty body] ppr sty (UfApp fun (UfTyArg ty)) - = ppCat [ppr sty fun, ppStr "@", pprParendHsType sty ty] + = ppCat [ppr sty fun, ppChar '@', pprParendHsType sty ty] ppr sty (UfApp fun (UfLitArg lit)) = ppCat [ppr sty fun, ppr sty lit] @@ -122,34 +121,36 @@ instance Outputable name => Outputable (UfExpr name) where = ppCat [ppr sty fun, ppr sty var] ppr sty (UfCase scrut alts) - = ppCat [ppStr "case", ppr sty scrut, ppStr "of {", pp_alts alts, ppStr "}"] + = ppCat [ppPStr SLIT("case"), ppr sty scrut, ppPStr SLIT("of {"), pp_alts alts, ppChar '}'] where pp_alts (UfAlgAlts alts deflt) = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt] where - pp_alt (c,bs,rhs) = ppCat [ppr sty c, ppr sty bs, ppStr "->", ppr sty rhs] + pp_alt (c,bs,rhs) = ppCat [ppr sty c, ppr sty bs, ppr_arrow, ppr sty rhs] pp_alts (UfPrimAlts alts deflt) = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt] where - pp_alt (l,rhs) = ppCat [ppr sty l, ppStr "->", ppr sty rhs] + pp_alt (l,rhs) = ppCat [ppr sty l, ppr_arrow, ppr sty rhs] pp_deflt UfNoDefault = ppNil - pp_deflt (UfBindDefault b rhs) = ppCat [ppr sty b, ppStr "->", ppr sty rhs] + pp_deflt (UfBindDefault b rhs) = ppCat [ppr sty b, ppr_arrow, ppr sty rhs] + + ppr_arrow = ppPStr SLIT("->") ppr sty (UfLet (UfNonRec b rhs) body) - = ppCat [ppStr "let", ppr sty b, ppEquals, ppr sty rhs, ppStr "in", ppr sty body] + = ppCat [ppPStr SLIT("let"), ppr sty b, ppEquals, ppr sty rhs, ppPStr SLIT("in"), ppr sty body] ppr sty (UfLet (UfRec pairs) body) - = ppCat [ppStr "letrec {", ppInterleave ppSemi (map pp_pair pairs), ppStr "} in", ppr sty body] + = ppCat [ppPStr SLIT("letrec {"), ppInterleave ppSemi (map pp_pair pairs), ppPStr SLIT("} in"), ppr sty body] where pp_pair (b,rhs) = ppCat [ppr sty b, ppEquals, ppr sty rhs] ppr sty (UfSCC uf_cc body) - = ppCat [ppStr "_scc_ ", ppr sty body] + = ppCat [ppPStr SLIT("_scc_ "), ppr sty body] instance Outputable name => Outputable (UfPrimOp name) where ppr sty (UfCCallOp str is_casm can_gc arg_tys result_ty) = let - before = ppStr (if is_casm then "_casm_ ``" else "_ccall_ ") + before = ppPStr (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ ")) after = if is_casm then ppStr "'' " else ppSP in ppBesides [before, ppPStr str, after, @@ -165,8 +166,8 @@ instance Outputable name => Outputable (UfArg name) where ppr sty (UfUsageArg name) = ppr sty name instance Outputable name => Outputable (UfBinder name) where - ppr sty (UfValBinder name ty) = ppCat [ppr sty name, ppStr "::", ppr sty ty] - ppr sty (UfTyBinder name kind) = ppCat [ppr sty name, ppStr "::", ppr sty kind] + ppr sty (UfValBinder name ty) = ppCat [ppr sty name, ppPStr SLIT("::"), ppr sty ty] + ppr sty (UfTyBinder name kind) = ppCat [ppr sty name, ppPStr SLIT("::"), ppr sty kind] ppr sty (UfUsageBinder name) = ppr sty name \end{code} diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 9f9073560e..d4f6628b68 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -31,7 +31,7 @@ import Outputable ( interppSP, interpp'SP, ) import Pretty import SrcLoc ( SrcLoc ) -import PprStyle ( PprStyle(..) ) +import PprStyle ( PprStyle(..), ifaceStyle ) \end{code} @@ -71,6 +71,10 @@ instance (NamedThing name, Outputable name, Outputable pat, ppr sty (ValD binds) = ppr sty binds ppr sty (DefD def) = ppr sty def ppr sty (InstD inst) = ppr sty inst + +-- In interfaces, top-level binders are printed without their "Module." prefix +ppr_top_binder sty bndr | ifaceStyle sty = ppr sty (getOccName bndr) + | otherwise = ppr sty bndr \end{code} @@ -143,12 +147,12 @@ instance (NamedThing name, Outputable name) derivings pp_decl_head sty str pp_context tycon tyvars - = ppCat [ppPStr str, pp_context, ppr sty (getOccName tycon), + = ppCat [ppPStr str, pp_context, ppr_top_binder sty tycon, interppSP sty tyvars, ppPStr SLIT("=")] pp_condecls sty [] = ppNil -- Curious! pp_condecls sty (c:cs) - = ppSep (ppr sty c : map (\ c -> ppBeside (ppStr "| ") (ppr sty c)) cs) + = ppSep (ppr sty c : map (\ c -> ppBeside (ppPStr SLIT("| ")) (ppr sty c)) cs) pp_tydecl sty pp_head pp_decl_rhs derivings = ppHang pp_head 4 (ppSep [ @@ -215,25 +219,26 @@ data BangType name instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where ppr sty (ConDecl con tys _) - = ppCat [ppr sty (getOccName con), ppInterleave ppNil (map (ppr_bang sty) tys)] + = ppCat [ppr_top_binder sty con, ppInterleave ppNil (map (ppr_bang sty) tys)] -- We print ConOpDecls in prefix form in interface files - ppr PprInterface (ConOpDecl ty1 op ty2 _) - = ppCat [ppr PprInterface (getOccName op), ppr_bang PprInterface ty1, ppr_bang PprInterface ty2] ppr sty (ConOpDecl ty1 op ty2 _) - = ppCat [ppr_bang sty ty1, ppr sty (getOccName op), ppr_bang sty ty2] + | ifaceStyle sty + = ppCat [ppr_top_binder sty op, ppr_bang sty ty1, ppr_bang sty ty2] + | otherwise + = ppCat [ppr_bang sty ty1, ppr_top_binder sty op, ppr_bang sty ty2] ppr sty (NewConDecl con ty _) - = ppCat [ppr sty (getOccName con), pprParendHsType sty ty] + = ppCat [ppr_top_binder sty con, pprParendHsType sty ty] ppr sty (RecConDecl con fields _) - = ppCat [ppr sty (getOccName con), + = ppCat [ppr_top_binder sty con, ppCurlies (ppInterleave pp'SP (map pp_field fields)) ] where - pp_field (ns, ty) = ppCat [ppCat (map (ppr sty . getOccName) ns), + pp_field (ns, ty) = ppCat [ppCat (map (ppr_top_binder sty) ns), ppPStr SLIT("::"), ppr_bang sty ty] -ppr_bang sty (Banged ty) = ppBeside (ppStr "! ") (pprParendHsType sty ty) +ppr_bang sty (Banged ty) = ppBeside (ppPStr SLIT("! ")) (pprParendHsType sty ty) -- The extra space helps the lexical analyser that lexes -- interface files; it doesn't make the rigid operator/identifier -- distinction, so "!a" is a valid identifier so far as it is concerned @@ -267,16 +272,16 @@ instance (NamedThing name, Outputable name, Outputable pat, = top_matter | iface_style -- All on one line (for now at least) - = ppCat [top_matter, ppStr "where", + = ppCat [top_matter, ppPStr SLIT("where"), ppCurlies (ppInterleave (ppPStr SLIT("; ")) pp_sigs)] | otherwise -- Laid out - = ppSep [ppCat [top_matter, ppStr "where {"], + = ppSep [ppCat [top_matter, ppPStr SLIT("where {")], ppNest 4 ((ppIntersperse ppSemi pp_sigs `ppAbove` pp_methods) - `ppBeside` ppStr "}")] + `ppBeside` ppChar '}')] where - top_matter = ppCat [ppStr "class", pp_context_and_arrow sty context, - ppr sty (getOccName clas), ppr sty tyvar] + top_matter = ppCat [ppPStr SLIT("class"), pp_context_and_arrow sty context, + ppr_top_binder sty clas, ppr sty tyvar] pp_sigs = map (ppr sty) sigs pp_methods = ppr sty methods iface_style = case sty of {PprInterface -> True; other -> False} @@ -311,10 +316,10 @@ instance (NamedThing name, Outputable name, Outputable pat, ppr sty (InstDecl inst_ty binds uprags dfun_name src_loc) | case sty of { PprInterface -> True; other -> False} || nullMonoBinds binds && null uprags - = ppCat [ppStr "instance", ppr sty inst_ty] + = ppCat [ppPStr SLIT("instance"), ppr sty inst_ty] | otherwise - = ppAboves [ppCat [ppStr "instance", ppr sty inst_ty, ppStr "where"], + = ppAboves [ppCat [ppPStr SLIT("instance"), ppr sty inst_ty, ppPStr SLIT("where")], ppNest 4 (ppr sty uprags), ppNest 4 (ppr sty binds) ] \end{code} @@ -372,7 +377,7 @@ data IfaceSig name instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where ppr sty (IfaceSig var ty _ _) - = ppHang (ppCat [ppr sty (getOccName var), ppPStr SLIT("::")]) + = ppHang (ppCat [ppr_top_binder sty var, ppPStr SLIT("::")]) 4 (ppr sty ty) data HsIdInfo name diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index b08debd8a1..936c61225a 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -82,17 +82,18 @@ data HsExpr tyvar uvar id pat | HsLet (HsBinds tyvar uvar id pat) -- let(rec) (HsExpr tyvar uvar id pat) - | HsDo [Stmt tyvar uvar id pat] -- "do":one or more stmts + | HsDo DoOrListComp + [Stmt tyvar uvar id pat] -- "do":one or more stmts SrcLoc - | HsDoOut [Stmt tyvar uvar id pat] -- "do":one or more stmts - id -- id for >>=, types applied - id -- id for zero, typed applied + | HsDoOut DoOrListComp + [Stmt tyvar uvar id pat] -- "do":one or more stmts + id -- id for return + id -- id for >>= + id -- id for zero + (GenType tyvar uvar) -- Type of the whole expression SrcLoc - | ListComp (HsExpr tyvar uvar id pat) -- list comprehension - [Qualifier tyvar uvar id pat] -- at least one Qualifier - | ExplicitList -- syntactic list [HsExpr tyvar uvar id pat] | ExplicitListOut -- TRANSLATION @@ -200,7 +201,7 @@ pprExpr sty (HsLit lit) = ppr sty lit pprExpr sty (HsLitOut lit _) = ppr sty lit pprExpr sty (HsLam match) - = ppCat [ppStr "\\", ppNest 2 (pprMatch sty True match)] + = ppCat [ppChar '\\', ppNest 2 (pprMatch sty True match)] pprExpr sty expr@(HsApp e1 e2) = let (fun, args) = collect_args expr [] in @@ -236,8 +237,8 @@ pprExpr sty (SectionL expr op) where pp_expr = pprParendExpr sty expr - pp_prefixly = ppHang (ppCat [ppStr "( \\ x_ ->", ppr sty op]) - 4 (ppCat [pp_expr, ppStr "x_ )"]) + pp_prefixly = ppHang (ppCat [ppStr " \\ x_ ->", ppr sty op]) + 4 (ppCat [pp_expr, ppPStr SLIT("x_ )")]) pp_infixly v = ppSep [ ppBeside ppLparen pp_expr, ppBeside (ppr sty v) ppRparen ] @@ -274,14 +275,8 @@ pprExpr sty (HsLet binds expr) = ppSep [ppHang (ppPStr SLIT("let")) 2 (ppr sty binds), ppHang (ppPStr SLIT("in")) 2 (ppr sty expr)] -pprExpr sty (HsDo stmts _) - = ppHang (ppPStr SLIT("do")) 2 (ppAboves (map (ppr sty) stmts)) -pprExpr sty (HsDoOut stmts _ _ _) - = ppHang (ppPStr SLIT("do")) 2 (ppAboves (map (ppr sty) stmts)) - -pprExpr sty (ListComp expr quals) - = ppHang (ppCat [ppLbrack, pprExpr sty expr, ppChar '|']) - 4 (ppSep [interpp'SP sty quals, ppRbrack]) +pprExpr sty (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp sty stmts +pprExpr sty (HsDoOut do_or_list_comp stmts _ _ _ _ _) = pprDo do_or_list_comp sty stmts pprExpr sty (ExplicitList exprs) = ppBracket (ppInterleave ppComma (map (pprExpr sty) exprs)) @@ -311,11 +306,11 @@ pprExpr sty (ArithSeqOut expr info) PprForUser -> ppBracket (ppr sty info) _ -> - ppBesides [ppLbrack, ppParens (ppr sty expr), ppr sty info, ppRbrack] + ppBesides [ppLbrack, ppParens (ppr sty expr), ppSP, ppr sty info, ppRbrack] pprExpr sty (CCall fun args _ is_asm result_ty) = ppHang (if is_asm - then ppBesides [ppStr "_casm_ ``", ppPStr fun, ppStr "''"] + then ppBesides [ppPStr SLIT("_casm_ ``"), ppPStr fun, ppPStr SLIT("''")] else ppBeside (ppPStr SLIT("_ccall_ ")) (ppPStr fun)) 4 (ppSep (map (pprParendExpr sty) args)) @@ -324,7 +319,7 @@ pprExpr sty (HsSCC label expr) pprParendExpr sty expr ] pprExpr sty (TyLam tyvars expr) - = ppHang (ppCat [ppStr "/\\", interppSP sty tyvars, ppStr "->"]) + = ppHang (ppCat [ppPStr SLIT("/\\"), interppSP sty tyvars, ppPStr SLIT("->")]) 4 (pprExpr sty expr) pprExpr sty (TyApp expr [ty]) @@ -335,7 +330,7 @@ pprExpr sty (TyApp expr tys) 4 (ppBracket (interpp'SP sty tys)) pprExpr sty (DictLam dictvars expr) - = ppHang (ppCat [ppStr "\\{-dict-}", interppSP sty dictvars, ppStr "->"]) + = ppHang (ppCat [ppPStr SLIT("\\{-dict-}"), interppSP sty dictvars, ppPStr SLIT("->")]) 4 (pprExpr sty expr) pprExpr sty (DictApp expr [dname]) @@ -346,10 +341,10 @@ pprExpr sty (DictApp expr dnames) 4 (ppBracket (interpp'SP sty dnames)) pprExpr sty (ClassDictLam dicts methods expr) - = ppHang (ppCat [ppStr "\\{-classdict-}", + = ppHang (ppCat [ppPStr SLIT("\\{-classdict-}"), ppBracket (interppSP sty dicts), ppBracket (interppSP sty methods), - ppStr "->"]) + ppPStr SLIT("->")]) 4 (pprExpr sty expr) pprExpr sty (Dictionary dicts methods) @@ -402,27 +397,43 @@ pp_rbinds sty thing rbinds 4 (ppCurlies (ppIntersperse pp'SP (map (pp_rbind sty) rbinds))) where pp_rbind PprForUser (v, _, True) = ppr PprForUser v - pp_rbind sty (v, e, _) = ppCat [ppr sty v, ppStr "=", ppr sty e] + pp_rbind sty (v, e, _) = ppCat [ppr sty v, ppChar '=', ppr sty e] \end{code} %************************************************************************ %* * -\subsection{Do stmts} +\subsection{Do stmts and list comprehensions} %* * %************************************************************************ +\begin{code} +data DoOrListComp = DoStmt | ListComp + +pprDo DoStmt sty stmts + = ppHang (ppPStr SLIT("do")) 2 (ppAboves (map (ppr sty) stmts)) +pprDo ListComp sty stmts + = ppHang (ppCat [ppLbrack, pprExpr sty expr, ppChar '|']) + 4 (ppSep [interpp'SP sty quals, ppRbrack]) + where + ReturnStmt expr = last stmts -- Last stmt should be a ReturnStmt for list comps + quals = init stmts +\end{code} + \begin{code} data Stmt tyvar uvar id pat = BindStmt pat (HsExpr tyvar uvar id pat) SrcLoc - | ExprStmt (HsExpr tyvar uvar id pat) - SrcLoc + | LetStmt (HsBinds tyvar uvar id pat) - - -- Translations; the types are the "a" and "b" types of the monad. - | BindStmtOut pat (HsExpr tyvar uvar id pat) SrcLoc (GenType tyvar uvar) (GenType tyvar uvar) - | ExprStmtOut (HsExpr tyvar uvar id pat) SrcLoc (GenType tyvar uvar) (GenType tyvar uvar) + + | GuardStmt (HsExpr tyvar uvar id pat) -- List comps only + SrcLoc + + | ExprStmt (HsExpr tyvar uvar id pat) -- Do stmts only + SrcLoc + + | ReturnStmt (HsExpr tyvar uvar id pat) -- List comps only, at the end \end{code} \begin{code} @@ -430,15 +441,15 @@ instance (NamedThing id, Outputable id, Outputable pat, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => Outputable (Stmt tyvar uvar id pat) where ppr sty (BindStmt pat expr _) - = ppCat [ppr sty pat, ppStr "<-", ppr sty expr] + = ppCat [ppr sty pat, ppPStr SLIT("<-"), ppr sty expr] ppr sty (LetStmt binds) = ppCat [ppPStr SLIT("let"), ppr sty binds] ppr sty (ExprStmt expr _) = ppr sty expr - ppr sty (BindStmtOut pat expr _ _ _) - = ppCat [ppr sty pat, ppStr "<-", ppr sty expr] - ppr sty (ExprStmtOut expr _ _ _) + ppr sty (GuardStmt expr _) = ppr sty expr + ppr sty (ReturnStmt expr) + = ppCat [ppPStr SLIT("return"), ppr sty expr] \end{code} %************************************************************************ @@ -471,24 +482,3 @@ instance (NamedThing id, Outputable id, Outputable pat, pp_dotdot = ppPStr SLIT(" .. ") \end{code} - -``Qualifiers'' in list comprehensions: -\begin{code} -data Qualifier tyvar uvar id pat - = GeneratorQual pat - (HsExpr tyvar uvar id pat) - | LetQual (HsBinds tyvar uvar id pat) - | FilterQual (HsExpr tyvar uvar id pat) -\end{code} - -\begin{code} -instance (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - Outputable (Qualifier tyvar uvar id pat) where - ppr sty (GeneratorQual pat expr) - = ppCat [ppr sty pat, ppStr "<-", ppr sty expr] - ppr sty (LetQual binds) - = ppCat [ppPStr SLIT("let"), ppr sty binds] - ppr sty (FilterQual expr) - = ppr sty expr -\end{code} diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index da42d1ce89..aff67627c1 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -50,6 +50,9 @@ data InPat name Fixity -- c.f. OpApp in HsExpr (InPat name) + | NPlusKPatIn name -- n+k pattern + HsLit + -- We preserve prefix negation and parenthesis for the precedence parser. | NegPatIn (InPat name) -- negated pattern @@ -104,6 +107,15 @@ data OutPat tyvar uvar id (HsExpr tyvar uvar id (OutPat tyvar uvar id)) -- of type t -> Bool; detects match + | NPlusKPat id + HsLit -- Same reason as for LitPat + -- (This could be an Integer, but then + -- it's harder to partitionEqnsByLit + -- in the desugarer.) + (GenType tyvar uvar) -- Type of pattern, t + (HsExpr tyvar uvar id (OutPat tyvar uvar id)) -- Of type t -> Bool; detects match + (HsExpr tyvar uvar id (OutPat tyvar uvar id)) -- Of type t -> t; subtracts k + | DictPat -- Used when destructing Dictionaries with an explicit case [id] -- superclass dicts [id] -- methods @@ -115,7 +127,7 @@ instance (Outputable name, NamedThing name) => Outputable (InPat name) where pprInPat :: (Outputable name, NamedThing name) => PprStyle -> InPat name -> Pretty -pprInPat sty (WildPatIn) = ppStr "_" +pprInPat sty (WildPatIn) = ppChar '_' pprInPat sty (VarPatIn var) = ppr sty var pprInPat sty (LitPatIn s) = ppr sty s pprInPat sty (LazyPatIn pat) = ppBeside (ppChar '~') (ppr sty pat) @@ -151,12 +163,14 @@ pprInPat sty (ListPatIn pats) = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack] pprInPat sty (TuplePatIn pats) = ppParens (interpp'SP sty pats) +pprInPat sty (NPlusKPatIn n k) + = ppBesides [ppLparen, ppr sty n, ppChar '+', ppr sty k, ppRparen] pprInPat sty (RecPatIn con rpats) = ppCat [ppr sty con, ppCurlies (ppIntersperse pp'SP (map (pp_rpat sty) rpats))] where pp_rpat PprForUser (v, _, True) = ppr PprForUser v - pp_rpat sty (v, p, _) = ppCat [ppr sty v, ppStr "=", ppr sty p] + pp_rpat sty (v, p, _) = ppCat [ppr sty v, ppChar '=', ppr sty p] \end{code} \begin{code} @@ -193,10 +207,12 @@ pprOutPat sty (RecPat con ty rpats) = ppBesides [ppr sty con, ppCurlies (ppIntersperse pp'SP (map (pp_rpat sty) rpats))] where pp_rpat PprForUser (v, _, True) = ppr PprForUser v - pp_rpat sty (v, p, _) = ppCat [ppr sty v, ppStr "=", ppr sty p] + pp_rpat sty (v, p, _) = ppCat [ppr sty v, ppChar '=', ppr sty p] pprOutPat sty (LitPat l ty) = ppr sty l -- ToDo: print more pprOutPat sty (NPat l ty e) = ppr sty l -- ToDo: print more +pprOutPat sty (NPlusKPat n k ty e1 e2) -- ToDo: print more + = ppBesides [ppLparen, ppr sty n, ppChar '+', ppr sty k, ppRparen] pprOutPat sty (DictPat dicts methods) = ppSep [ppBesides [ppLparen, ppPStr SLIT("{-dict-}")], @@ -279,10 +295,11 @@ isConPat other = False patsAreAllLits :: [OutPat a b c] -> Bool patsAreAllLits pat_list = all isLitPat pat_list -isLitPat (AsPat _ pat) = isLitPat pat -isLitPat (LitPat _ _) = True -isLitPat (NPat _ _ _) = True -isLitPat other = False +isLitPat (AsPat _ pat) = isLitPat pat +isLitPat (LitPat _ _) = True +isLitPat (NPat _ _ _) = True +isLitPat (NPlusKPat _ _ _ _ _) = True +isLitPat other = False \end{code} This function @collectPatBinders@ works with the ``collectBinders'' @@ -296,6 +313,7 @@ collectPatBinders (VarPatIn var) = [var] collectPatBinders (LitPatIn _) = [] collectPatBinders (LazyPatIn pat) = collectPatBinders pat collectPatBinders (AsPatIn a pat) = a : collectPatBinders pat +collectPatBinders (NPlusKPatIn n _) = [n] collectPatBinders (ConPatIn c pats) = concat (map collectPatBinders pats) collectPatBinders (ConOpPatIn p1 c f p2) = collectPatBinders p1 ++ collectPatBinders p2 collectPatBinders (NegPatIn pat) = collectPatBinders pat diff --git a/ghc/compiler/hsSyn/HsPragmas.lhs b/ghc/compiler/hsSyn/HsPragmas.lhs index 1337b4d83d..c8a7112a61 100644 --- a/ghc/compiler/hsSyn/HsPragmas.lhs +++ b/ghc/compiler/hsSyn/HsPragmas.lhs @@ -173,34 +173,34 @@ Some instances for printing (just for debugging, really) instance Outputable name => Outputable (ClassPragmas name) where ppr sty NoClassPragmas = ppNil ppr sty (SuperDictPragmas sdsel_prags) - = ppAbove (ppStr "{-superdict pragmas-}") + = ppAbove (ppPStr SLIT("{-superdict pragmas-}")) (ppr sty sdsel_prags) instance Outputable name => Outputable (ClassOpPragmas name) where ppr sty NoClassOpPragmas = ppNil ppr sty (ClassOpPragmas op_prags defm_prags) - = ppAbove (ppCat [ppStr "{-meth-}", ppr sty op_prags]) - (ppCat [ppStr "{-defm-}", ppr sty defm_prags]) + = ppAbove (ppCat [ppPStr SLIT("{-meth-}"), ppr sty op_prags]) + (ppCat [ppPStr SLIT("{-defm-}"), ppr sty defm_prags]) instance Outputable name => Outputable (InstancePragmas name) where ppr sty NoInstancePragmas = ppNil ppr sty (SimpleInstancePragma dfun_pragmas) - = ppCat [ppStr "{-dfun-}", ppr sty dfun_pragmas] + = ppCat [ppPStr SLIT("{-dfun-}"), ppr sty dfun_pragmas] ppr sty (ConstantInstancePragma dfun_pragmas name_pragma_pairs) - = ppAbove (ppCat [ppStr "{-constm-}", ppr sty dfun_pragmas]) + = ppAbove (ppCat [ppPStr SLIT("{-constm-}"), ppr sty dfun_pragmas]) (ppAboves (map pp_pair name_pragma_pairs)) where pp_pair (n, prags) = ppCat [ppr sty n, ppEquals, ppr sty prags] ppr sty (SpecialisedInstancePragma dfun_pragmas spec_pragma_info) - = ppAbove (ppCat [ppStr "{-spec'd-}", ppr sty dfun_pragmas]) + = ppAbove (ppCat [ppPStr SLIT("{-spec'd-}"), ppr sty dfun_pragmas]) (ppAboves (map pp_info spec_pragma_info)) where pp_info (ty_maybes, num_dicts, prags) = ppBesides [ppLbrack, ppInterleave ppSP (map pp_ty ty_maybes), ppRbrack, ppLparen, ppInt num_dicts, ppRparen, ppEquals, ppr sty prags] - pp_ty Nothing = ppStr "_N_" + pp_ty Nothing = ppPStr SLIT("_N_") pp_ty (Just t)= ppr sty t instance Outputable name => Outputable (GenPragmas name) where @@ -211,29 +211,29 @@ instance Outputable name => Outputable (GenPragmas name) where pp_specs specs] where pp_arity Nothing = ppNil - pp_arity (Just i) = ppBeside (ppStr "ARITY=") (ppInt i) + pp_arity (Just i) = ppBeside (ppPStr SLIT("ARITY=")) (ppInt i) pp_upd Nothing = ppNil pp_upd (Just u) = ppUpdateInfo sty u pp_str NoImpStrictness = ppNil pp_str (ImpStrictness is_bot demands wrkr_prags) - = ppBesides [ppStr "IS_BOT=", ppr sty is_bot, - ppStr "STRICTNESS=", ppStr (showList demands ""), - ppStr " {", ppr sty wrkr_prags, ppStr "}"] + = ppBesides [ppPStr SLIT("IS_BOT="), ppr sty is_bot, + ppPStr SLIT("STRICTNESS="), ppStr (showList demands ""), + ppPStr SLIT(" {"), ppr sty wrkr_prags, ppChar '}'] - pp_unf NoImpUnfolding = ppStr "NO_UNFOLDING" - pp_unf (ImpMagicUnfolding m) = ppBeside (ppStr "MAGIC=") (ppPStr m) - pp_unf (ImpUnfolding g core) = ppBeside (ppStr "UNFOLD=") (ppr sty core) + pp_unf NoImpUnfolding = ppPStr SLIT("NO_UNFOLDING") + pp_unf (ImpMagicUnfolding m) = ppBeside (ppPStr SLIT("MAGIC=")) (ppPStr m) + pp_unf (ImpUnfolding g core) = ppBeside (ppPStr SLIT("UNFOLD=")) (ppr sty core) pp_specs [] = ppNil pp_specs specs - = ppBesides [ppStr "SPECS=[", ppInterleave ppSP (map pp_spec specs), ppStr "]"] + = ppBesides [ppPStr SLIT("SPECS=["), ppInterleave ppSP (map pp_spec specs), ppChar ']'] where pp_spec (ty_maybes, num_dicts, gprags) = ppCat [ppLbrack, ppInterleave ppSP (map pp_MaB ty_maybes), ppRbrack, ppInt num_dicts, ppr sty gprags] - pp_MaB Nothing = ppStr "_N_" + pp_MaB Nothing = ppPStr SLIT("_N_") pp_MaB (Just x) = ppr sty x \end{code} diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 425ee72ab2..195809dc34 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -104,7 +104,7 @@ instance (Outputable name) => Outputable (HsType name) where instance (Outputable name) => Outputable (HsTyVar name) where ppr sty (UserTyVar name) = ppr_hs_tyname sty name - ppr sty (IfaceTyVar name kind) = ppCat [ppr_hs_tyname sty name, ppStr "::", ppr sty kind] + ppr sty (IfaceTyVar name kind) = ppCat [ppr_hs_tyname sty name, ppPStr SLIT("::"), ppr sty kind] -- Here comes a rather gross hack. @@ -118,8 +118,8 @@ ppr_hs_tyname other_sty tv_name = ppr other_sty tv_name ppr_forall sty ctxt_prec [] [] ty = ppr_mono_ty sty ctxt_prec ty ppr_forall sty ctxt_prec tvs ctxt ty - = ppSep [ppStr "_forall_", ppBracket (interppSP sty tvs), - pprContext sty ctxt, ppStr "=>", + = ppSep [ppPStr SLIT("_forall_"), ppBracket (interppSP sty tvs), + pprContext sty ctxt, ppPStr SLIT("=>"), pprHsType sty ty] pprContext :: (Outputable name) => PprStyle -> (Context name) -> Pretty @@ -156,7 +156,7 @@ ppr_mono_ty sty ctxt_prec (MonoFunTy ty1 ty2) p2 = ppr_mono_ty sty pREC_TOP ty2 in maybeParen (ctxt_prec >= pREC_FUN) - (ppSep [p1, ppBeside (ppStr "-> ") p2]) + (ppSep [p1, ppBeside (ppPStr SLIT("-> ")) p2]) ppr_mono_ty sty ctxt_prec (MonoTupleTy _ tys) = ppParens (ppInterleave ppComma (map (ppr sty) tys)) diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index b695f4caf0..19e3d26d4c 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -46,6 +46,7 @@ module CmdLineOpts ( opt_D_verbose_core2core, opt_D_verbose_stg2stg, opt_DoCoreLinting, + opt_DoStgLinting, opt_DoSemiTagging, opt_DoEtaReduction, opt_DoTickyProfiling, @@ -58,6 +59,7 @@ module CmdLineOpts ( opt_Haskell_1_3, opt_HiMap, opt_HiSuffix, + opt_HiSuffixPrelude, opt_IgnoreIfacePragmas, opt_IgnoreStrictnessPragmas, opt_IrrefutableEverything, @@ -95,7 +97,9 @@ module CmdLineOpts ( opt_UnfoldingUseThreshold, opt_Verbose, - opt_WarnNameShadowing + opt_WarnNameShadowing, + opt_NoWarnIncompletePatterns + ) where IMPORT_1_3(Array(array, (//))) @@ -281,6 +285,7 @@ opt_D_source_stats = lookUp SLIT("-dsource-stats") opt_D_verbose_core2core = lookUp SLIT("-dverbose-simpl") opt_D_verbose_stg2stg = lookUp SLIT("-dverbose-stg") opt_DoCoreLinting = lookUp SLIT("-dcore-lint") +opt_DoStgLinting = lookUp SLIT("-dstg-lint") opt_DoSemiTagging = lookUp SLIT("-fsemi-tagging") opt_DoTickyProfiling = lookUp SLIT("-fticky-ticky") opt_DoEtaReduction = lookUp SLIT("-fdo-eta-reduction") @@ -293,6 +298,7 @@ opt_GlasgowExts = lookUp SLIT("-fglasgow-exts") opt_Haskell_1_3 = lookUp SLIT("-fhaskell-1.3") opt_HiMap = lookup_str "-himap=" -- file saying where to look for .hi files opt_HiSuffix = lookup_str "-hisuf=" +opt_HiSuffixPrelude = lookup_str "-hisuf-prelude=" opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas") opt_IgnoreStrictnessPragmas = lookUp SLIT("-fignore-strictness-pragmas") opt_IrrefutableEverything = lookUp SLIT("-firrefutable-everything") @@ -331,6 +337,7 @@ opt_UnfoldingConDiscount = lookup_def_int "-funfolding-con-discount" uNFOLDIN opt_LiberateCaseThreshold = lookup_def_int "-fliberate-case-threshold" lIBERATE_CASE_THRESHOLD opt_WarnNameShadowing = lookUp SLIT("-fwarn-name-shadowing") +opt_NoWarnIncompletePatterns = lookUp SLIT("-fno-warn-incomplete-patterns") -- opt_UnfoldingUseThreshold = lookup_int "-funfolding-use-threshold" -- opt_UnfoldingOverrideThreshold = lookup_int "-funfolding-override-threshold" diff --git a/ghc/compiler/main/LoopHack.lhc b/ghc/compiler/main/LoopHack.lhc index 7f46936977..91d361bdb0 100644 --- a/ghc/compiler/main/LoopHack.lhc +++ b/ghc/compiler/main/LoopHack.lhc @@ -8,6 +8,57 @@ What we do here is simply to satisfy the unresolved references \begin{code} +#ifdef PROFILING +START_REGISTER_PRELUDE(_regUbiq); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regAbsCLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regNcgLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regDsLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regIdLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regPrelLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regSmplLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regTyLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regHsLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regSpecLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regTcMLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regTcLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regRnLoop); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regCgLoop1); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regCgLoop2); +END_REGISTER_CCS() + +START_REGISTER_PRELUDE(_regHandleHack); +END_REGISTER_CCS() +#endif + +/* STGFUN(_regUbiq){} STGFUN(_regAbsCLoop){} STGFUN(_regNcgLoop){} @@ -23,5 +74,5 @@ STGFUN(_regTcLoop){} STGFUN(_regRnLoop){} STGFUN(_regCgLoop1){} STGFUN(_regCgLoop2){} - +*/ \end{code} diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index 27bbe1e52d..9db06ac126 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -20,7 +20,7 @@ import RnMonad ( ExportEnv ) import MkIface -- several functions import TcModule ( typecheckModule ) -import Desugar ( deSugar, DsMatchContext, pprDsWarnings ) +import Desugar ( deSugar, DsMatchContext, pprDsWarnings, DsWarnFlavour {-TEMP!-} ) import SimplCore ( core2core ) import CoreToStg ( topCoreBindsToStg ) import StgSyn ( collectFinalStgBinders ) @@ -56,12 +56,13 @@ import Unique ( Unique ) -- instances \end{code} \begin{code} -main - = hGetContents stdin >>= \ input_pgm -> - let - cmd_line_info = classifyOpts - in - doIt cmd_line_info input_pgm +main = + _scc_ "main" + hGetContents stdin >>= \ input_pgm -> + let + cmd_line_info = classifyOpts + in + doIt cmd_line_info input_pgm \end{code} \begin{code} @@ -82,13 +83,21 @@ doIt (core_cmds, stg_cmds) input_pgm (pp_show (ppSourceStats rdr_module)) >> -- UniqueSupplies for later use (these are the only lower case uniques) + _scc_ "spl-rn" mkSplitUniqSupply 'r' >>= \ rn_uniqs -> -- renamer + _scc_ "spl-tc" mkSplitUniqSupply 'a' >>= \ tc_uniqs -> -- typechecker + _scc_ "spl-ds" mkSplitUniqSupply 'd' >>= \ ds_uniqs -> -- desugarer + _scc_ "spl-sm" mkSplitUniqSupply 's' >>= \ sm_uniqs -> -- core-to-core simplifier + _scc_ "spl-c2s" mkSplitUniqSupply 'c' >>= \ c2s_uniqs -> -- core-to-stg + _scc_ "spl-st" mkSplitUniqSupply 'g' >>= \ st_uniqs -> -- stg-to-stg passes + _scc_ "spl-absc" mkSplitUniqSupply 'f' >>= \ fl_uniqs -> -- absC flattener + _scc_ "spl-ncg" mkSplitUniqSupply 'n' >>= \ ncg_uniqs -> -- native-code generator -- ******* RENAMER @@ -207,6 +216,7 @@ doIt (core_cmds, stg_cmds) input_pgm let final_ids = collectFinalStgBinders stg_binds2 in + _scc_ "Interface" ifaceDecls if_handle rn_mod inst_info final_ids simplified >> endIface if_handle >> -- We are definitely done w/ interface-file stuff at this point: diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 5bc488d7b6..15bb569644 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -19,6 +19,7 @@ import HsSyn import RdrHsSyn ( RdrName(..) ) import RnHsSyn ( SYN_IE(RenamedHsModule) ) import RnMonad +import RnEnv ( availName ) import TcInstUtil ( InstInfo(..) ) @@ -41,7 +42,7 @@ import Name ( isLocallyDefined, isWiredInName, modAndOcc, getName, pprOccName, OccName, occNameString, nameOccName, nameString, isExported, pprNonSym, Name {-instance NamedThing-}, Provenance ) -import TyCon ( TyCon(..){-instance NamedThing-}, NewOrData(..) ) +import TyCon ( TyCon{-instance NamedThing-} ) import Class ( GenClass(..){-instance NamedThing-}, GenClassOp, classOpLocalType ) import FieldLabel ( FieldLabel{-instance NamedThing-} ) import Type ( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy ) @@ -160,10 +161,11 @@ ifaceExports if_hdl avails -- Sort them into groups by module export_fm :: FiniteMap Module [AvailInfo] export_fm = foldr insert emptyFM avails - insert avail@(Avail name _) efm = addToFM_C (++) efm mod [avail] - where - (mod,_) = modAndOcc name + insert NotAvailable efm = efm + insert avail efm = addToFM_C (++) efm mod [avail] + where + (mod,_) = modAndOcc (availName avail) -- Print one module's worth of stuff do_one_module (mod_name, avails) @@ -251,16 +253,18 @@ ifaceId get_idinfo needed_ids is_rec id rhs = Nothing -- Well, that was easy! ifaceId get_idinfo needed_ids is_rec id rhs - = Just (ppCat [sig_pretty, prag_pretty, ppStr ";;"], new_needed_ids) + = Just (ppCat [sig_pretty, pp_double_semi, prag_pretty], new_needed_ids) where - idinfo = get_idinfo id - inline_pragma = idWantsToBeINLINEd id + pp_double_semi = ppPStr SLIT(";;") + idinfo = get_idinfo id + inline_pragma = idWantsToBeINLINEd id ty_pretty = pprType PprInterface (initNmbr (nmbrType (idType id))) - sig_pretty = ppBesides [ppr PprInterface (getOccName id), ppPStr SLIT(" :: "), ty_pretty] + sig_pretty = ppBesides [ppr PprInterface (getOccName id), ppPStr SLIT(" _:_ "), ty_pretty] - prag_pretty | opt_OmitInterfacePragmas = ppNil - | otherwise = ppCat [arity_pretty, strict_pretty, unfold_pretty] + prag_pretty + | opt_OmitInterfacePragmas = ppNil + | otherwise = ppCat [arity_pretty, strict_pretty, unfold_pretty, pp_double_semi] ------------ Arity -------------- arity_pretty = ppArityInfo PprInterface (arityInfo idinfo) @@ -271,7 +275,7 @@ ifaceId get_idinfo needed_ids is_rec id rhs strict_pretty = ppStrictnessInfo PprInterface strict_info ------------ Unfolding -------------- - unfold_pretty | show_unfold = ppCat [ppStr "_U_", pprIfaceUnfolding rhs] + unfold_pretty | show_unfold = ppCat [ppPStr SLIT("_U_"), pprIfaceUnfolding rhs] | otherwise = ppNil show_unfold = not implicit_unfolding && -- Unnecessary @@ -373,22 +377,33 @@ ifaceBinds hdl needed_ids final_ids binds \subsection{Random small things} %* * %************************************************************************ - + +When printing export lists, we print like this: + Avail f f + AvailTC C [C, x, y] C(x,y) + AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C + \begin{code} -upp_avail NotAvailable = uppNil -upp_avail (Avail name ns) = uppBesides [upp_occname (getOccName name), upp_export ns] +upp_avail NotAvailable = uppNil +upp_avail (Avail name) = upp_occname (getOccName name) +upp_avail (AvailTC name []) = uppNil +upp_avail (AvailTC name ns) = uppBesides [upp_occname (getOccName name), bang, upp_export ns'] + where + bang | name `elem` ns = uppNil + | otherwise = uppChar '!' + ns' = filter (/= name) ns upp_export [] = uppNil -upp_export names = uppBesides [uppStr "(", +upp_export names = uppBesides [uppChar '(', uppIntersperse uppSP (map (upp_occname . getOccName) names), - uppStr ")"] + uppChar ')'] upp_fixity (occ, (Fixity prec dir, prov)) = uppBesides [upp_dir dir, uppSP, uppInt prec, uppSP, upp_occname occ, uppSemi] -upp_dir InfixR = uppStr "infixr" -upp_dir InfixL = uppStr "infixl" -upp_dir InfixN = uppStr "infix" +upp_dir InfixR = uppPStr SLIT("infixr") +upp_dir InfixL = uppPStr SLIT("infixl") +upp_dir InfixN = uppPStr SLIT("infix") ppr_unqual_name :: NamedThing a => a -> Unpretty -- Just its occurrence name ppr_unqual_name name = upp_occname (getOccName name) @@ -428,9 +443,7 @@ by unique \begin{code} lt_avail :: AvailInfo -> AvailInfo -> Bool -NotAvailable `lt_avail` (Avail _ _) = True -(Avail n1 _) `lt_avail` (Avail n2 _) = n1 `lt_name` n2 -any `lt_avail` NotAvailable = False +a1 `lt_avail` a2 = availName a1 `lt_name` availName a2 lt_name :: Name -> Name -> Bool n1 `lt_name` n2 = modAndOcc n1 < modAndOcc n2 diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index d88986893c..3a87fecb4f 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -77,7 +77,7 @@ So, here we go: writeRealAsm :: Handle -> AbstractC -> UniqSupply -> IO () writeRealAsm handle absC us - = uppPutStr handle 80 (runNCG absC us) + = _scc_ "writeRealAsm" (uppPutStr handle 80 (runNCG absC us)) dumpRealAsm :: AbstractC -> UniqSupply -> String diff --git a/ghc/compiler/nativeGen/NCG.h b/ghc/compiler/nativeGen/NCG.h index 873ebebf87..d02415f0fd 100644 --- a/ghc/compiler/nativeGen/NCG.h +++ b/ghc/compiler/nativeGen/NCG.h @@ -14,7 +14,7 @@ you will screw up the layout where they are used in case expressions! #define FAST_REG_NO FAST_INT -#include "../../includes/platform.h" +#include "../../includes/config.h" #if 0 {-testing only-} diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs index 3d1665b598..d958af78d7 100644 --- a/ghc/compiler/nativeGen/PprMach.lhs +++ b/ghc/compiler/nativeGen/PprMach.lhs @@ -33,7 +33,7 @@ a_HASH x = GHCbase.A# x pACK_STR x = packCString x #else a_HASH x = A# x -pACK_STR x = _packCString x +pACK_STR x = mkFastCharString x --_packCString x #endif \end{code} @@ -428,15 +428,15 @@ pprInstr (LABEL clab) ] pprInstr (ASCII False{-no backslash conversion-} str) - = uppBesides [ uppStr "\t.asciz \"", uppStr str, uppChar '"' ] + = uppBesides [ uppPStr SLIT("\t.asciz \""), uppStr str, uppChar '"' ] pprInstr (ASCII True str) - = uppBeside (uppStr "\t.ascii \"") (asciify str 60) + = uppBeside (uppPStr SLIT("\t.ascii \"")) (asciify str 60) where asciify :: String -> Int -> Unpretty - asciify [] _ = uppStr ("\\0\"") - asciify s n | n <= 0 = uppBeside (uppStr "\"\n\t.ascii \"") (asciify s 60) + asciify [] _ = uppPStr SLIT("\\0\"") + asciify s n | n <= 0 = uppBeside (uppPStr SLIT("\"\n\t.ascii \"")) (asciify s 60) asciify ('\\':cs) n = uppBeside (uppStr "\\\\") (asciify cs (n-1)) asciify ('\"':cs) n = uppBeside (uppStr "\\\"") (asciify cs (n-1)) asciify (c:cs) n | isPrint c = uppBeside (uppChar c) (asciify cs (n-1)) diff --git a/ghc/compiler/parser/UgenUtil.lhs b/ghc/compiler/parser/UgenUtil.lhs index 4b4523f211..944b217612 100644 --- a/ghc/compiler/parser/UgenUtil.lhs +++ b/ghc/compiler/parser/UgenUtil.lhs @@ -22,8 +22,8 @@ import PreludeGlaST # define PACK_BYTES packCBytes #else # define ADDR _Addr -# define PACK_STR _packCString -# define PACK_BYTES _packCBytes +# define PACK_STR mkFastCharString +# define PACK_BYTES mkFastCharString2 #endif import RdrHsSyn ( RdrName(..) ) @@ -85,7 +85,7 @@ 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 (PACK_BYTES len bytes) + returnUgn (PACK_BYTES bytes len) \end{code} \begin{code} diff --git a/ghc/compiler/parser/hslexer.flex b/ghc/compiler/parser/hslexer.flex index efac20b4a8..f7da732a6a 100644 --- a/ghc/compiler/parser/hslexer.flex +++ b/ghc/compiler/parser/hslexer.flex @@ -307,8 +307,18 @@ NL [\n\r] nested_comments =1; PUSH_STATE(Comment); } +"{-#"{WS}*"OPTIONS" { + /* these are by the driver! */ + nested_comments =1; + PUSH_STATE(Comment); + } +"{-#"{WS}*"SOURCE" { + /* these are used by `make depend' (temp) */ + nested_comments =1; + PUSH_STATE(Comment); + } "{-#"{WS}*[A-Z_]+ { - fprintf(stderr, "\"%s\", line %d: Warning: Unrecognised pragma '", + fprintf(stderr, "%s:%d: Warning: Unrecognised pragma '", input_filename, hsplineno); format_string(stderr, (unsigned char *) yytext, yyleng); fputs("'\n", stderr); @@ -381,6 +391,7 @@ NL [\n\r] "<-" { RETURN(LARROW); } "->" { RETURN(RARROW); } "-" { RETURN(MINUS); } +"+" { RETURN(PLUS); } "=>" { RETURN(DARROW); } "@" { RETURN(AT); } @@ -558,7 +569,7 @@ NL [\n\r] } if (length > 1) { - fprintf(stderr, "\"%s\", line %d, column %d: Unboxed character literal '", + 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); @@ -577,7 +588,7 @@ NL [\n\r] text = fetchtext(&length); if (length > 1) { - fprintf(stderr, "\"%s\", line %d, column %d: Character literal '", + fprintf(stderr, "%s:%d:%d: Character literal '", input_filename, hsplineno, hspcolno + 1); format_string(stderr, (unsigned char *) text, length); fputs("' too long\n", stderr); @@ -799,21 +810,21 @@ NL [\n\r] %} (.|\n) { - fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `", + fprintf(stderr, "%s:%d:%d: Illegal character: `", input_filename, hsplineno, hspcolno + 1); format_string(stderr, (unsigned char *) yytext, 1); fputs("'\n", stderr); hsperror(""); } (.|\n) { - fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `", + 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(""); } (.|\n) { - fprintf(stderr, "\"%s\", line %d, column %d: Illegal character escape: `\\", + fprintf(stderr, "%s:%d:%d: Illegal character escape: `\\", input_filename, hsplineno, hspcolno + 1); format_string(stderr, (unsigned char *) yytext, 1); fputs("'\n", stderr); @@ -822,7 +833,7 @@ NL [\n\r] (.|\n) { if (nonstandardFlag) { addtext(yytext, yyleng); } else { - fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `", + 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); @@ -831,13 +842,13 @@ NL [\n\r] } (.|\n) { if (noGap) { - fprintf(stderr, "\"%s\", line %d, column %d: Illegal string escape: `\\", + 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\", line %d, column %d: Illegal character: `", + 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); diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y index 5212226d0a..77351a0740 100644 --- a/ghc/compiler/parser/hsparser.y +++ b/ghc/compiler/parser/hsparser.y @@ -47,6 +47,7 @@ static char *the_module_name; static maybe module_exports; extern list Lnil; +extern list reverse_list(); extern tree root; /* For FN, PREVPATT and SAMEFN macros */ @@ -170,7 +171,7 @@ BOOLEAN inpat; * * **********************************************************************/ -%token MINUS BANG +%token MINUS BANG PLUS %token AS HIDING QUALIFIED @@ -200,7 +201,7 @@ BOOLEAN inpat; SCC CASM CCALL CASM_GC CCALL_GC %left VARSYM CONSYM QVARSYM QCONSYM - MINUS BQUOTE BANG DARROW + MINUS BQUOTE BANG DARROW PLUS %left DCOLON @@ -223,7 +224,7 @@ BOOLEAN inpat; %type caserest alts alt quals dorest stmts stmt - rbinds rpats list_exps + rbinds rbinds1 rpats rpats1 list_exps list_rest qvarsk qvars_list constrs constr1 fields types atypes batypes @@ -244,11 +245,11 @@ BOOLEAN inpat; %type exp oexp dexp kexp fexp aexp rbind texps expL oexpL kexpL expLno oexpLno dexpLno kexpLno vallhs funlhs qual gd leftexp - pat bpat apat apatc conpat rpat - patk bpatk apatck conpatk + pat cpat bpat apat apatc conpat rpat + patk bpatk apatck conpatk -%type MINUS DARROW AS LAZY +%type MINUS PLUS DARROW AS LAZY VARID CONID VARSYM CONSYM var con varop conop op vark varid varsym varsym_nominus @@ -270,10 +271,8 @@ BOOLEAN inpat; %type simple ctype type atype btype gtyconvars - bbtype batype + bbtype batype bxtype bang_atype class tyvar -/* gtyconapp0 gtyconapp1 ntyconapp0 ntyconapp1 btyconapp */ -/* restrict_inst general_inst */ %type constr field @@ -734,24 +733,13 @@ constrs : constr { $$ = lsing($1); } | constrs VBAR constr { $$ = lapp($1,$3); } ; -constr : -/* This stuff looks really baroque. I've replaced it with simpler stuff. - SLPJ Jan 97 - - btyconapp { qid tyc; list tys; +constr : btype { qid tyc; list tys; splittyconapp($1, &tyc, &tys); $$ = mkconstrpre(tyc,tys,hsplineno); } - | btyconapp qconop bbtype { checknobangs($1); - $$ = mkconstrinf($1,$2,$3,hsplineno); } - | ntyconapp0 qconop bbtype { $$ = mkconstrinf($1,$2,$3,hsplineno); } - - | BANG atype qconop bbtype { $$ = mkconstrinf(mktbang($2),$3,$4,hsplineno); } - | OPAREN qconsym CPAREN { $$ = mkconstrpre($2,Lnil,hsplineno); } -*/ - - btype { qid tyc; list tys; + | bxtype { qid tyc; list tys; splittyconapp($1, &tyc, &tys); $$ = mkconstrpre(tyc,tys,hsplineno); } + /* We have to parse the constructor application as a *type*, else we get into terrible ambiguity problems. Consider the difference between @@ -764,24 +752,30 @@ constr : second. */ + | btype qconop bbtype { $$ = mkconstrinf($1,$2,$3,hsplineno); } + | bang_atype qconop bbtype { $$ = mkconstrinf( $1, $2, $3, hsplineno ); } + + | OPAREN qconsym CPAREN batypes { $$ = mkconstrpre($2,$4,hsplineno); } - | bbtype qconop bbtype { $$ = mkconstrinf($1,$2,$3,hsplineno); } | gtycon OCURLY fields CCURLY { $$ = mkconstrrec($1,$3,hsplineno); } /* 1 S/R conflict on OCURLY -> shift */ ; -/* -btyconapp: gtycon { $$ = mktname($1); } - | btyconapp batype { $$ = mktapp($1,$2); } +/* S !Int Bool */ +bxtype : btype bang_atype { $$ = mktapp($1, $2); } + | bxtype bbtype { $$ = mktapp($1, $2); } ; -*/ + bbtype : btype { $$ = $1; } - | BANG atype { $$ = mktbang($2); } + | bang_atype { $$ = $1; } ; batype : atype { $$ = $1; } - | BANG atype { $$ = mktbang($2); } + | bang_atype { $$ = $1; } + ; + +bang_atype : BANG atype { $$ = mktbang( $2 ) } ; batypes : { $$ = Lnil; } @@ -913,6 +907,8 @@ gdrhs : gd EQUAL exp { $$ = lsing(mkpgdexp($1,$3)); } maybe_where: WHERE ocurly decls ccurly { $$ = $3; } | WHERE vocurly decls vccurly { $$ = $3; } + /* A where containing no decls is OK */ + | WHERE SEMI { $$ = mknullbind(); } | /* empty */ { $$ = mknullbind(); } ; @@ -1036,7 +1032,6 @@ aexp : qvar { $$ = mkident($1); } | gcon { $$ = mkident($1); } | lit_constant { $$ = mklit($1); } | OPAREN exp CPAREN { $$ = mkpar($2); } /* mkpar: stop infix parsing at ()'s */ - | qcon OCURLY CCURLY { $$ = mkrecord($1,Lnil); } | 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 { if (ttree($4) == tuple) @@ -1045,7 +1040,7 @@ aexp : qvar { $$ = mkident($1); } $$ = mktuple(ldub($2, $4)); } /* only in expressions ... */ - | aexp OCURLY rbinds CCURLY { $$ = mkrupdate($1,$3); } + | 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()); } @@ -1073,8 +1068,12 @@ dorest : ocurly stmts ccurly { checkdostmts($2); $$ = $2; } | vocurly stmts vccurly { checkdostmts($2); $$ = $2; } ; -rbinds : rbind { $$ = lsing($1); } - | rbinds COMMA rbind { $$ = lapp($1,$3); } +rbinds : /* empty */ { $$ = Lnil; } + | rbinds1 + ; + +rbinds1 : rbind { $$ = lsing($1); } + | rbinds1 COMMA rbind { $$ = lapp($1,$3); } ; rbind : qvar { $$ = mkrbind($1,mknothing()); } @@ -1093,10 +1092,22 @@ texps : exp { $$ = mkpar($1); } /* mkpar: so we don't flatten last element in t /* 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 @@ -1108,7 +1119,6 @@ list_exps : (In fact, if you change the grammar and throw yacc/bison at it, it *will* do the wrong thing [WDP 94/06]) */ - ; letdecls: LET ocurly decls ccurly { $$ = $3 } | LET vocurly decls vccurly { $$ = $3 } @@ -1177,13 +1187,17 @@ leftexp : LARROW exp { $$ = $2; } * * **********************************************************************/ -pat : pat qconop bpat { $$ = mkinfixap($2,$1,$3); } +pat : 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); } + | qcon OCURLY rpats CCURLY { $$ = mkrecord($1,$3); } | MINUS INTEGER { $$ = mknegate(mklit(mkinteger($2))); } | MINUS FLOAT { $$ = mknegate(mklit(mkfloatr($2))); } ; @@ -1230,8 +1244,12 @@ pats : pat COMMA pats { $$ = mklcons($1, $3); } /* right recursion? (WDP) */ ; -rpats : rpat { $$ = lsing($1); } - | rpats COMMA rpat { $$ = lapp($1,$3); } +rpats : /* empty */ { $$ = Lnil; } + | rpats1 + ; + +rpats1 : rpat { $$ = lsing($1); } + | rpats1 COMMA rpat { $$ = lapp($1,$3); } ; rpat : qvar { $$ = mkrbind($1,mknothing()); } @@ -1450,6 +1468,12 @@ varsym : varsym_nominus | MINUS { $$ = install_literal("-"); } ; +/* PLUS, BANG are valid varsyms */ +varsym_nominus : VARSYM + | PLUS { $$ = install_literal("+"); } + | BANG { $$ = install_literal("!"); } + ; + /* AS HIDING QUALIFIED are valid varids */ varid : VARID | AS { $$ = install_literal("as"); } @@ -1457,10 +1481,6 @@ varid : VARID | QUALIFIED { $$ = install_literal("qualified"); } ; -/* BANG are valid varsyms */ -varsym_nominus : VARSYM - | BANG { $$ = install_literal("!"); } - ; ccallid : VARID | CONID @@ -1577,7 +1597,7 @@ yyerror(s) /*NOTHING*/; } else { - fprintf(stderr, "\"%s\", line %d, column %d: %s on input: ", + fprintf(stderr, "%s:%d:%d: %s on input: ", input_filename, hsplineno, hspcolno + 1, s); if (yyleng == 1 && *yytext == '\0') diff --git a/ghc/compiler/parser/id.c b/ghc/compiler/parser/id.c index 457dbd812a..173f38db98 100644 --- a/ghc/compiler/parser/id.c +++ b/ghc/compiler/parser/id.c @@ -54,7 +54,7 @@ installHstring(length, s) str->len = length; if (length == 0) { - str->bytes = NULL; + str->bytes = ""; } else { p = xmalloc(length); diff --git a/ghc/compiler/parser/main.c b/ghc/compiler/parser/main.c index 325c553940..eb1c58ecb4 100644 --- a/ghc/compiler/parser/main.c +++ b/ghc/compiler/parser/main.c @@ -24,6 +24,7 @@ main(int argc, char **argv) { Lnil = mklnil(); /* The null list -- used in lsing, etc. */ + argv++; argc--; process_args(argc,argv); hash_init(); diff --git a/ghc/compiler/parser/syntax.c b/ghc/compiler/parser/syntax.c index 509145360a..a48b1198cb 100644 --- a/ghc/compiler/parser/syntax.c +++ b/ghc/compiler/parser/syntax.c @@ -13,6 +13,7 @@ #include "constants.h" #include "utils.h" #include "tree.h" +#include "list.h" #include "hsparser.tab.h" @@ -108,6 +109,9 @@ expORpat(int wanted, tree e) expORpat(wanted, glazyp(e)); break; + case plusp: + break; + case lit: switch (tliteral(glit(e))) { case integer: @@ -556,7 +560,7 @@ splittyconapp(app, tyc, tys) break; default: - hsperror("panic: splittyconap: bad tycon application (no tycon)"); + hsperror("bad left argument to constructor op"); } } @@ -701,3 +705,20 @@ checkprec(exp,qfn,right) #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 ); +} diff --git a/ghc/compiler/parser/tree.ugn b/ghc/compiler/parser/tree.ugn index 86c5174c78..98d67c2f4d 100644 --- a/ghc/compiler/parser/tree.ugn +++ b/ghc/compiler/parser/tree.ugn @@ -72,8 +72,9 @@ type tree; as : < gasid : qid; gase : tree; >; lazyp : < glazyp : tree; >; + plusp : < gplusp : qid; + gplusi : literal; >; wildp : < >; - restr : < grestre : tree; grestrt : ttype; >; diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 7001a7bd01..98364f2573 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -292,6 +292,8 @@ knownKeyNames -- ClassOps , (fromInt_RDR, fromIntClassOpKey) , (fromInteger_RDR, fromIntegerClassOpKey) + , (ge_RDR, geClassOpKey) + , (minus_RDR, minusClassOpKey) , (enumFrom_RDR, enumFromClassOpKey) , (enumFromThen_RDR, enumFromThenClassOpKey) , (enumFromTo_RDR, enumFromToClassOpKey) @@ -299,8 +301,12 @@ knownKeyNames , (fromEnum_RDR, fromEnumClassOpKey) , (eq_RDR, eqClassOpKey) , (thenM_RDR, thenMClassOpKey) + , (returnM_RDR, returnMClassOpKey) , (zeroM_RDR, zeroClassOpKey) , (fromRational_RDR, fromRationalClassOpKey) + + -- Others + , (otherwiseId_RDR, otherwiseIdKey) ] \end{code} @@ -354,6 +360,7 @@ creturnableClass_RDR = tcQual (fOREIGN, SLIT("CReturnable")) fromInt_RDR = varQual (pREL_BASE, SLIT("fromInt")) fromInteger_RDR = varQual (pREL_BASE, SLIT("fromInteger")) +minus_RDR = varQual (pREL_BASE, SLIT("-")) fromEnum_RDR = varQual (pREL_BASE, SLIT("fromEnum")) enumFrom_RDR = varQual (pREL_BASE, SLIT("enumFrom")) enumFromTo_RDR = varQual (pREL_BASE, SLIT("enumFromTo")) @@ -361,6 +368,7 @@ enumFromThen_RDR = varQual (pREL_BASE, SLIT("enumFromThen")) enumFromThenTo_RDR = varQual (pREL_BASE, SLIT("enumFromThenTo")) thenM_RDR = varQual (pREL_BASE, SLIT(">>=")) +returnM_RDR = varQual (pREL_BASE, SLIT("return")) zeroM_RDR = varQual (pREL_BASE, SLIT("zero")) fromRational_RDR = varQual (pREL_NUM, SLIT("fromRational")) @@ -428,6 +436,8 @@ minusH_RDR = prelude_primop IntSubOp main_RDR = varQual (mAIN, SLIT("main")) mainPrimIO_RDR = varQual (gHC_MAIN, SLIT("mainPrimIO")) + +otherwiseId_RDR = varQual (pREL_BASE, SLIT("otherwise")) \end{code} %************************************************************************ @@ -464,7 +474,7 @@ deriving_occ_info showParen_RDR, showSpace_RDR, showList___RDR]) , (readClassKey, [intTyCon_RDR, numClass_RDR, ordClass_RDR, append_RDR, lex_RDR, readParen_RDR, readList___RDR]) - , (ixClassKey, [intTyCon_RDR, numClass_RDR, and_RDR, map_RDR]) + , (ixClassKey, [intTyCon_RDR, numClass_RDR, and_RDR, map_RDR, enumFromTo_RDR]) ] -- intTyCon: Practically any deriving needs Int, either for index calculations, -- or for taggery. diff --git a/ghc/compiler/prelude/PrelLoop.lhi b/ghc/compiler/prelude/PrelLoop.lhi index ba1320a13e..9d5d407aba 100644 --- a/ghc/compiler/prelude/PrelLoop.lhi +++ b/ghc/compiler/prelude/PrelLoop.lhi @@ -3,7 +3,8 @@ Breaks the PrelVal loop and the PrelInfo loop caused by primOpNameInfo. \begin{code} interface PrelLoop where -import PreludePS ( _PackedString ) +--import PreludePS ( _PackedString ) +import FastString ( FastSring ) import Class ( GenClass ) import CoreUnfold ( mkMagicUnfolding, Unfolding ) diff --git a/ghc/compiler/prelude/PrelMods.lhs b/ghc/compiler/prelude/PrelMods.lhs index 8d9a5ad6e6..321b83c4da 100644 --- a/ghc/compiler/prelude/PrelMods.lhs +++ b/ghc/compiler/prelude/PrelMods.lhs @@ -4,15 +4,53 @@ \section[PrelMods]{Definitions of prelude modules} The strings identify built-in prelude modules. They are -defined here so as to avod +defined here so as to avod + +[oh dear, look like the recursive module monster caught up and + gobbled whoever was writing the above :-) -- SOF ] + \begin{code} #include "HsVersions.h" -module PrelMods where +module PrelMods + ( + isPreludeModule, -- :: Module -> Bool + + gHC__, pRELUDE, pREL_BASE, + pREL_READ , pREL_NUM, pREL_LIST, + pREL_TUP , pACKED_STRING, cONC_BASE, + iO_BASE , mONAD, rATIO, iX, + sT_BASE , aRR_BASE, fOREIGN, mAIN, + gHC_MAIN , gHC_ERR + ) where CHK_Ubiq() -- debugging consistency check +import UniqSet ( UniqSet(..), mkUniqSet, elementOfUniqSet ) + \end{code} +Predicate used by RnIface to decide whether or not to +append a special suffix for prelude modules: + +\begin{code} +isPreludeModule :: Module -> Bool +isPreludeModule mod = mod `elementOfUniqSet` preludeNames + +preludeNames :: UniqSet FAST_STRING +preludeNames = + mkUniqSet + [ gHC__ + , pRELUDE , pREL_BASE + , pREL_READ , pREL_NUM + , pREL_LIST , pREL_TUP + , pACKED_STRING , cONC_BASE + , iO_BASE , mONAD + , rATIO , iX + , sT_BASE , aRR_BASE + , fOREIGN , mAIN + , gHC_MAIN , gHC_ERR + ] +\end{code} \begin{code} gHC__ = SLIT("GHC") -- Primitive types and values @@ -36,4 +74,7 @@ fOREIGN = SLIT("Foreign") mAIN = SLIT("Main") gHC_MAIN = SLIT("GHCmain") gHC_ERR = SLIT("GHCerr") + + + \end{code} diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index 741911b592..046e6fa79d 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -571,7 +571,7 @@ realWorldPrimId \end{code} \begin{code} -voidId = pc_bottoming_Id voidIdKey gHC__ SLIT("void") voidTy +voidId = pc_bottoming_Id voidIdKey pREL_BASE SLIT("void") voidTy \end{code} %************************************************************************ diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 7af6822120..bd24ebe37d 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -1400,9 +1400,13 @@ primOpHeapReq DoubleDecodeOp = FixedHeapRequired (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE)) (intOff mIN_MP_INT_SIZE))) --- ccall may allocate heap if it is explicitly allowed to (_ccall_gc_) --- or if it returns a ForeignObj. +{- + ccall may allocate heap if it is explicitly allowed to (_ccall_gc_) + or if it returns a ForeignObj. + Hmm..the allocation for makeForeignObj# is known (and fixed), so + why dod we need to be so indeterminate about it? --SOF +-} primOpHeapReq (CCallOp _ _ mayGC@True _ _) = VariableHeapRequired primOpHeapReq (CCallOp _ _ mayGC@False _ _) = NoHeapRequired diff --git a/ghc/compiler/prelude/PrimRep.lhs b/ghc/compiler/prelude/PrimRep.lhs index 94ab0c50f2..387f70d8a9 100644 --- a/ghc/compiler/prelude/PrimRep.lhs +++ b/ghc/compiler/prelude/PrimRep.lhs @@ -15,8 +15,8 @@ module PrimRep ( separateByPtrFollowness, isFollowableRep, isFloatingRep, getPrimRepSize, retPrimRepSize, - showPrimRep, - guessPrimRep + showPrimRep, ppPrimRep, + guessPrimRep, decodePrimRep ) where IMP_Ubiq() @@ -85,8 +85,12 @@ isFollowableRep :: PrimRep -> Bool isFollowableRep PtrRep = True isFollowableRep ArrayRep = True isFollowableRep ByteArrayRep = True --- why is a MallocPtr followable? 4/96 SOF --- isFollowableRep ForeignObjRep = True +-- why is a ForeignObj followable? 4/96 SOF +-- +-- A: they're followable because these objects +-- should be lugged around by the storage manager +-- (==> we need to generate code that identify them as such) -- 3/97 SOF +isFollowableRep ForeignObjRep = True isFollowableRep StablePtrRep = False -- StablePtrs aren't followable because they are just indices into a @@ -145,7 +149,32 @@ instance Outputable PrimRep where ppr sty kind = ppStr (showPrimRep kind) showPrimRep :: PrimRep -> String +-- dumping PrimRep tag for unfoldings +ppPrimRep :: PrimRep -> Pretty + guessPrimRep :: String -> PrimRep -- a horrible "inverse" function +decodePrimRep :: Char -> PrimRep -- of equal nature + +ppPrimRep k = + ppChar + (case k of + PtrRep -> 'P' + CodePtrRep -> 'p' + DataPtrRep -> 'd' + CostCentreRep -> 'c' -- Pointer to a cost centre + RetRep -> 'R' + CharRep -> 'C' + IntRep -> 'I' + WordRep -> 'W' + AddrRep -> 'A' + FloatRep -> 'F' + DoubleRep -> 'D' + ArrayRep -> 'a' + ByteArrayRep -> 'b' + StablePtrRep -> 'S' + ForeignObjRep -> 'f' + VoidRep -> 'V' + _ -> panic "ppPrimRep") showPrimRep PtrRep = "P_" -- short for StgPtr @@ -169,6 +198,26 @@ showPrimRep StablePtrRep = "StgStablePtr" showPrimRep ForeignObjRep = "StgPtr" -- see comment below showPrimRep VoidRep = "!!VOID_KIND!!" +decodePrimRep ch = + case ch of + 'P' -> PtrRep + 'p' -> CodePtrRep + 'd' -> DataPtrRep + 'c' -> CostCentreRep + 'R' -> RetRep + 'C' -> CharRep + 'I' -> IntRep + 'W' -> WordRep + 'A' -> AddrRep + 'F' -> FloatRep + 'D' -> DoubleRep + 'a' -> ArrayRep + 'b' -> ByteArrayRep + 'S' -> StablePtrRep + 'f' -> ForeignObjRep + 'V' -> VoidRep + _ -> panic "decodePrimRep" + guessPrimRep "D_" = DataPtrRep guessPrimRep "StgRetAddr" = RetRep guessPrimRep "StgChar" = CharRep diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs index bb2ede0448..2f0b008372 100644 --- a/ghc/compiler/profiling/CostCentre.lhs +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -30,7 +30,7 @@ module CostCentre ( IMP_Ubiq(){-uitous-} -import Id ( externallyVisibleId, GenId, SYN_IE(Id) ) +import Id ( externallyVisibleId, GenId, showId, SYN_IE(Id) ) import CStrings ( identToC, stringToC ) import Name ( OccName, getOccString, moduleString ) import Pretty ( ppShow, prettyToUn ) @@ -39,7 +39,6 @@ import UniqSet import Unpretty import Util -showId = panic "Whoops" pprIdInUnfolding = panic "Whoops" \end{code} @@ -371,7 +370,6 @@ uppCostCentre sty print_as_string cc friendly_sty = friendly_style sty ---------------- - do_cc OverheadCC = "OVERHEAD" do_cc DontCareCC = "DONT_CARE" do_cc (AllCafsCC m _) = if print_as_string then "CAFs_in_..." @@ -432,14 +430,19 @@ even if we won't ultimately do a \tr{SET_CCC} from it. upp_cc_uf (PreludeDictsCC d) = uppCat [uppPStr SLIT("_PRELUDE_DICTS_CC_"), upp_dupd d] upp_cc_uf (AllDictsCC m g d) - = uppCat [uppPStr SLIT("_ALL_DICTS_CC_"), uppStr (show (_UNPK_ m)), uppStr (show (_UNPK_ g)), upp_dupd d] + = uppCat [uppPStr SLIT("_ALL_DICTS_CC_"), + uppChar '"',uppPStr m,uppChar '"', + uppChar '"',uppPStr g,uppChar '"', + upp_dupd d] upp_cc_uf cc@(NormalCC cc_kind m g is_dupd is_caf) = ASSERT(sccAbleCostCentre cc) - uppCat [pp_kind cc_kind, uppStr (show (_UNPK_ m)), uppStr (show (_UNPK_ g)), + uppCat [pp_kind cc_kind, + uppChar '"', uppPStr m, uppChar '"', + uppChar '"', uppPStr g, uppChar '"', upp_dupd is_dupd, pp_caf is_caf] where - pp_kind (UserCC name) = uppBeside (uppPStr SLIT("_USER_CC_ ")) (uppStr (show (_UNPK_ name))) + pp_kind (UserCC name) = uppBesides [uppPStr SLIT("_USER_CC_ "), uppChar '"', uppPStr name, uppChar '"'] pp_kind (AutoCC id) = uppBeside (uppPStr SLIT("_AUTO_CC_ ")) (show_id id) pp_kind (DictCC id) = uppBeside (uppPStr SLIT("_DICT_CC_ ")) (show_id id) @@ -455,7 +458,7 @@ upp_cc_uf other = panic ("upp_cc_uf:"++(showCostCentre PprDebug True other)) #endif upp_dupd AnOriginalCC = uppPStr SLIT("_N_") -upp_dupd ADupdCC = uppPStr SLIT("_DUPD_CC_") +upp_dupd ADupdCC = uppPStr SLIT("_D_") \end{code} \begin{code} @@ -467,7 +470,7 @@ uppCostCentreDecl sty is_local cc #endif = if is_local then uppBesides [ - uppStr "CC_DECLARE(", + uppPStr SLIT("CC_DECLARE"),uppChar '(', upp_ident, uppComma, uppCostCentre sty True {-as String!-} cc, uppComma, pp_str mod_name, uppComma, @@ -476,12 +479,12 @@ uppCostCentreDecl sty is_local cc if externally_visible then uppNil else uppPStr SLIT("static"), uppStr ");"] else - uppBesides [ uppStr "CC_EXTERN(", upp_ident, uppStr ");" ] + uppBesides [ uppPStr SLIT("CC_EXTERN"),uppChar '(', upp_ident, uppStr ");" ] where upp_ident = uppCostCentre sty False{-as identifier!-} cc - pp_str s = uppBeside (uppPStr (_CONS_ '"' s)) (uppChar '"') - pp_char c = uppBeside (uppPStr (_CONS_ '\'' c)) (uppChar '\'') + pp_str s = uppBesides [uppChar '"',uppPStr s, uppChar '"' ] + pp_char c = uppBesides [uppChar '\'', uppPStr c, uppChar '\''] (mod_name, grp_name, is_subsumed, externally_visible) = case cc of diff --git a/ghc/compiler/reader/Lex.lhs b/ghc/compiler/reader/Lex.lhs index ec761e4659..32f20e9e1f 100644 --- a/ghc/compiler/reader/Lex.lhs +++ b/ghc/compiler/reader/Lex.lhs @@ -10,27 +10,39 @@ module Lex ( isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym, isLexVarId, isLexVarSym, - mkTupNameStr, + mkTupNameStr, ifaceParseErr, -- Monad for parser - IfaceToken(..), lexIface, SYN_IE(IfM), thenIf, returnIf, happyError + IfaceToken(..), lexIface, SYN_IE(IfM), thenIf, returnIf, happyError, + StringBuffer ) where IMPORT_1_3(Char(isDigit, isAlpha, isAlphanum, isUpper)) +IMPORT_DELOOPER(Ubiq) +IMPORT_DELOOPER(IdLoop) -- get the CostCentre type&constructors from here import CmdLineOpts ( opt_IgnoreIfacePragmas ) -import Demand ( Demand {- instance Read -} ) -import FiniteMap ( FiniteMap, listToFM, lookupFM ) +import Demand ( Demand(..) {- instance Read -} ) +import UniqFM ( UniqFM, listToUFM, lookupUFM) +--import FiniteMap ( FiniteMap, listToFM, lookupFM ) import Maybes ( Maybe(..), MaybeErr(..) ) import Pretty import CharSeq ( CSeq ) + + + import ErrUtils ( Error(..) ) import Outputable ( Outputable(..) ) import PprStyle ( PprStyle(..) ) import Util ( nOfThem, panic ) +import FastString +import StringBuffer + +import PreludeGlaST + \end{code} %************************************************************************ @@ -86,8 +98,10 @@ isLexVarSym cs ------------- isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf]) -isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c -isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c +isUpperISO (C# c#) = c# `geChar#` '\xc0'# && c# `leChar#` '\xde'# && c# `neChar#` '\xd7'# +--0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c +isLowerISO (C# c#) = c# `geChar#` '\xdf'# && c# `leChar#` '\xff'# && c# `neChar#` '\xf7'# +--0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c \end{code} @@ -114,6 +128,28 @@ mkTupNameStr n = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")") %* * %************************************************************************ +The token data type, fairly un-interesting except from two constructors, +@ITidinfo@ and @ITtype@, which are used to lazily lex id info (arity, +strictness, unfolding etc) and types for id decls. + +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 at 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 = ITinterface -- keywords @@ -144,8 +180,6 @@ data IfaceToken | ITdotdot | ITequal | ITocurly - | ITdccurly - | ITdocurly | ITobrack | IToparen | ITrarrow @@ -162,17 +196,25 @@ data IfaceToken | ITqvarsym (FAST_STRING,FAST_STRING) | ITqconsym (FAST_STRING,FAST_STRING) + | ITidinfo [IfaceToken] -- lazily return the stream of tokens for + -- the info attached to an id. + | ITtysig [IfaceToken] -- lazily return the stream of tokens for + -- the info attached to an id. -- Stuff for reading unfoldings | ITarity | ITstrict | ITunfold | ITdemand [Demand] | ITbottom | ITlam | ITbiglam | ITcase | ITprim_case | ITlet | ITletrec | ITin | ITof | ITcoerce_in | ITcoerce_out | ITatsign | ITccall (Bool,Bool) -- (is_casm, may_gc) - + | ITscc CostCentre | ITchar Char | ITstring FAST_STRING | ITinteger Integer | ITdouble Double | ITinteger_lit | ITfloat_lit | ITrational_lit | ITaddr_lit | ITlit_lit | ITstring_lit + | ITunknown String -- Used when the lexer can't make sense of it deriving Text -- debugging + +instance Text CostCentre -- cheat! + \end{code} %************************************************************************ @@ -182,144 +224,487 @@ data IfaceToken %************************************************************************ \begin{code} -lexIface :: String -> [IfaceToken] - -lexIface input - = _scc_ "Lexer" - case input of - [] -> [] - - -- whitespace and comments - ' ' : cs -> lexIface cs - '\t' : cs -> lexIface cs - '\n' : cs -> lexIface cs - '-' : '-' : cs -> lex_comment cs +lexIface :: StringBuffer -> [IfaceToken] +lexIface buf = + _scc_ "Lexer" +-- if bufferExhausted buf then +-- [] +-- else +-- _trace ("Lexer: "++[C# (currentChar# buf)]) $ + case currentChar# buf of + -- whitespace and comments, ignore. + ' '# -> lexIface (stepOn buf) + '\t'# -> lexIface (stepOn buf) + '\n'# -> lexIface (stepOn buf) + +-- Numbers and comments + '-'# -> + case lookAhead# buf 1# of + '-'# -> lex_comment (stepOnBy# buf 2#) + c -> + if isDigit (C# c) + then lex_num (negate) (ord# c -# ord# '0'#) (incLexeme (incLexeme buf)) + else lex_id buf -- Leave out nested comments for now; danger of finding { and - juxtaposed by mistake? -- '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs - '(' : '.' : '.' : ')' : cs -> ITdotdot : lexIface cs - '{' : cs -> ITocurly : lexIface cs - '}' : cs -> ITccurly : lexIface cs - '(' : ',' : cs -> lex_tuple Nothing cs - '(' : ')' : cs -> ITconid SLIT("()") : lexIface cs - '(' : cs -> IToparen : lexIface cs - ')' : cs -> ITcparen : lexIface cs - '[' : ']' : cs -> ITconid SLIT("[]") : lexIface cs - '[' : cs -> ITobrack : lexIface cs - ']' : cs -> ITcbrack : lexIface cs - ',' : cs -> ITcomma : lexIface cs - ':' : ':' : cs -> ITdcolon : lexIface cs - ';' : cs -> ITsemi : lexIface cs - '\"' : cs -> case reads input of - [(str, rest)] -> ITstring (_PK_ (str::String)) : lexIface rest - '\'' : cs -> case reads input of - [(ch, rest)] -> ITchar ch : lexIface rest + '('# -> + case prefixMatch (stepOn buf) "..)" of + Just buf' -> ITdotdot : lexIface (stepOverLexeme buf') + Nothing -> + case lookAhead# buf 1# of + ','# -> lex_tuple Nothing (stepOnBy# buf 2#) + ')'# -> ITconid SLIT("()") : lexIface (stepOnBy# buf 2#) + _ -> IToparen : lexIface (stepOn buf) + + '{'# -> ITocurly : lexIface (stepOn buf) + '}'# -> ITccurly : lexIface (stepOn buf) + ')'# -> ITcparen : lexIface (stepOn buf) + '['# -> + case lookAhead# buf 1# of + ']'# -> ITconid SLIT("[]") : lexIface (stepOnBy# buf 2#) + _ -> ITobrack : lexIface (stepOn buf) + ']'# -> ITcbrack : lexIface (stepOn buf) + ','# -> ITcomma : lexIface (stepOn buf) + ':'# -> case lookAhead# buf 1# of + ':'# -> ITdcolon : lexIface (stepOnBy# buf 2#) + _ -> lex_id (incLexeme buf) + ';'# -> ITsemi : lexIface (stepOn buf) + '\"'# -> case untilEndOfString# (stepOn buf) of + buf' -> + -- the string literal does *not* include the dquotes + case lexemeToFastString buf' of + v -> ITstring v : lexIface (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)] -> ITchar ch : lexIface (stepOverLexeme (incLexeme buf')) -- ``thingy'' form for casm - '`' : '`' : cs -> lex_cstring "" cs - + '`'# -> + case lookAhead# buf 1# of + '`'# -> lex_cstring (stepOnBy# buf 2#) -- remove the `` and go. + _ -> lex_id (incLexeme buf) -- add ` to lexeme and assume + -- scanning an id of some sort. -- Keywords - '_' : 'S' : '_' : cs -> ITstrict : lex_demand cs - '_' : cs -> lex_keyword cs - --- Numbers - '-' : c : cs | isDigit c -> lex_num "-" (c:cs) - c : cs | isDigit c -> lex_num "" (c:cs) - - other -> lex_id input - where - lex_comment str - = case (span ((/=) '\n') str) of { (junk, rest) -> - lexIface rest } - - ------------------ - lex_demand (c:cs) | isSpace c = lex_demand cs - | otherwise = case readList (c:cs) of - ((demand,rest) : _) -> ITdemand demand : lexIface rest - - ----------- - lex_num minus str - = case (span isDigit str) of { (num, rest) -> - case rest of - '.' : str2 -> case (span isDigit str2) of { (num2,rest2) -> - ITdouble (read (minus ++ num ++ ('.':num2))) : lexIface rest2 - } - - other -> ITinteger (read (minus ++ num)) : lexIface rest - } - - ------------ - lex_keyword str - = case (span is_kwd_mod_char str) of { (kw, rest) -> - case (lookupFM ifaceKeywordsFM kw) of - Nothing -> panic ("lex_keyword:"++str) - - Just xx | startDiscard xx && - opt_IgnoreIfacePragmas -> lexIface (doDiscard rest) - | otherwise -> xx : lexIface rest - } - - is_kwd_mod_char c = isAlphanum c || c `elem` "_@/\\" - - ----------- - lex_cstring so_far ('\'' : '\'' : cs) = ITstring (_PK_ (reverse (so_far::String))) : lexIface cs - lex_cstring so_far (c : cs) = lex_cstring (c:so_far) cs + '_'# -> + case lookAhead# buf 1# of + 'S'# -> case lookAhead# buf 2# of + '_'# -> ITstrict : + lex_demand (stepOnUntil (not . isSpace) + (stepOnBy# buf 3#)) -- past _S_ + 's'# -> case prefixMatch (stepOnBy# buf 2#) "cc_" of + Just buf' -> lex_scc (stepOnUntil (not . isSpace) + (stepOverLexeme buf')) + Nothing -> lex_keyword (stepOnBy# buf 1#) -- drop the '_' and assume + -- it is a keyword. + _ -> lex_keyword (stepOn buf) + + '\NUL'# -> + if bufferExhausted (stepOn buf) then + [] + else + lex_id buf + c -> + if isDigit (C# c) then + lex_num (id) (ord# c -# ord# '0'#) (incLexeme buf) + else + lex_id buf +-- where +lex_comment buf = +-- _trace ("comment: "++[C# (currentChar# buf)]) $ + case untilChar# buf '\n'# of {buf' -> lexIface (stepOverLexeme buf')} + +------------------ +lex_demand buf = +-- _trace ("demand: "++[C# (currentChar# buf)]) $ + case read_em [] buf of { (ls,buf') -> ITdemand ls : lexIface (stepOverLexeme buf')} + where + -- code snatched from Demand.lhs + read_em acc buf = +-- _trace ("read_em: "++[C# (currentChar# 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 True acc (stepOnBy# buf 2#) + 'u'# -> do_unpack False acc (stepOnBy# buf 2#) + _ -> (reverse acc, buf) + + do_unpack wrapper_unpacks acc buf + = case read_em [] buf of + (stuff, rest) -> read_em (WwUnpack wrapper_unpacks stuff : acc) rest + +------------------ +lex_scc buf = +-- _trace ("scc: "++[C# (currentChar# buf)]) $ + case currentChar# buf of + '"'# -> + -- YUCK^2 + case prefixMatch (stepOn buf) "NO_CC\"" of + Just buf' -> ITscc noCostCentre : lexIface (stepOverLexeme buf') + Nothing -> + case prefixMatch (stepOn buf) "CURRENT_CC\"" of + Just buf' -> ITscc useCurrentCostCentre : lexIface (stepOverLexeme buf') + Nothing -> + case prefixMatch (stepOn buf) "OVERHEAD\"" of + Just buf' -> ITscc overheadCostCentre : lexIface (stepOverLexeme buf') + Nothing -> + case prefixMatch (stepOn buf) "DONT_CARE\"" of + Just buf' -> ITscc dontCareCostCentre : lexIface (stepOverLexeme buf') + Nothing -> + case prefixMatch (stepOn buf) "SUBSUMED\"" of + Just buf' -> ITscc subsumedCosts : lexIface (stepOverLexeme buf') + Nothing -> + case prefixMatch (stepOn buf) "CAFs_in_...\"" of + Just buf' -> ITscc preludeCafsCostCentre : lexIface (stepOverLexeme buf') + Nothing -> + case prefixMatch (stepOn buf) "CC_CAFs_in_..." of + Just buf' -> + case untilChar# (stepOverLexeme buf') '\"'# of + buf'' -> ITscc (mkAllCafsCC ({-module-}lexemeToFastString buf'') _NIL_): + lexIface (stepOverLexeme buf'') + Nothing -> + case prefixMatch (stepOn buf) "DICTs_in_...\"" of + Just buf' -> ITscc (preludeDictsCostCentre True) : lexIface (stepOverLexeme buf') + Nothing -> + case prefixMatch (stepOn buf) "CC_DICTs_in_..." of + Just buf' -> + case untilChar# (stepOverLexeme buf') '\"'# of + buf'' -> ITscc (mkAllDictsCC (lexemeToFastString buf'') _NIL_ True): + lexIface (stepOverLexeme buf'') + Nothing -> + case prefixMatch (stepOn buf) "CAF:" of + Just buf' -> + case untilChar# (stepOverLexeme buf') '\"'# of + buf'' -> ITscc (cafifyCC (mkUserCC (lexemeToFastString buf'') _NIL_ _NIL_)): + lexIface (stepOverLexeme buf'') + Nothing -> + case untilChar# (stepOn buf) '\"'# of + buf' -> ITscc (mkUserCC (lexemeToFastString buf') _NIL_ _NIL_): + lexIface (stepOverLexeme buf') + c -> ITunknown [C# c] : lexIface (stepOn buf) + + +----------- +lex_num :: (Int -> Int) -> Int# -> StringBuffer -> [IfaceToken] +lex_num 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 (isDigit) (incLexeme buf') of + buf'' -> -- points to first non digit char + case reads (lexemeToString buf'') of + [(v,_)] -> ITdouble v : lexIface (stepOverLexeme buf'') + _ -> ITinteger (fromInt (minus acc')) : lexIface (stepOverLexeme buf') + +-- case reads (lexemeToString buf') of +-- [(i,_)] -> ITinteger i : lexIface (stepOverLexeme buf') + +------------ +lex_keyword buf = +-- _trace ("lex_keyword: "++[C# (currentChar# buf)]) $ + case currentChar# buf of + ':'# -> case lookAhead# buf 1# of + '_'# -> -- a binding, type (and other id-info) follows, + -- to make the parser ever so slightly, we push + -- + lex_decl (stepOnBy# buf 2#) + v# -> ITunknown (['_',':',C# v#]) : lexIface (stepOnBy# buf 2#) + _ -> + case expandWhile (is_kwd_char) buf of + buf' -> + let kw = lexemeToFastString buf' in +-- _trace ("kw: "++lexemeToString buf') $ + case lookupUFM ifaceKeywordsFM kw of + Nothing -> ITunknown (_UNPK_ kw) : -- (minor) sigh + lexIface (stepOverLexeme buf') + Just xx -> xx : lexIface (stepOverLexeme buf') + +lex_decl buf = + case expandUntilMatch buf ";;" of + buf' -> +-- _trace (show (lexemeToString buf')) $ + case currentChar# buf' of + '\n'# -> -- newline, no id info. + ITtysig (lexIface (lexemeToBuffer (decLexeme buf'))) : + lexIface (stepOverLexeme buf') + '\r'# -> -- just to be sure for those Win* boxes.. + ITtysig (lexIface (lexemeToBuffer (decLexeme buf'))) : + lexIface (stepOverLexeme buf') + '\NUL'# -> + ITtysig (lexIface (lexemeToBuffer (decLexeme buf'))) : + lexIface (stepOverLexeme buf') + c -> -- run all over the id info + case expandUntilMatch (stepOverLexeme buf') ";;" of + buf'' -> + --_trace ((C# c):show (lexemeToString (decLexeme buf'))) $ + --_trace (show (lexemeToString (decLexeme buf''))) $ + ITtysig (lexIface (lexemeToBuffer (decLexeme buf'))): + let ls = lexIface (stepOverLexeme buf'') in + if opt_IgnoreIfacePragmas then + ls + else + let is = lexIface (lexemeToBuffer (decLexeme buf'')) in + --_trace (show is) $ + ITidinfo is : ls + +-- ToDo: hammer! +is_kwd_char c@(C# c#) = + isAlphanum c || -- OLD: c `elem` "_@/\\" + (case c# of + '_'# -> True + '@'# -> True + '/'# -> True + '\\'# -> True + _ -> False) + + + +----------- +lex_cstring buf = +-- _trace ("lex_cstring: "++[C# (currentChar# buf)]) $ + case expandUntilMatch buf "\'\'" of + buf' -> ITstring (lexemeToFastString (setCurrentPos# buf' (negateInt# 2#))) : + lexIface (stepOverLexeme buf') - - ----------- - lex_tuple module_dot orig_cs = go 2 orig_cs - where - go n (',':cs) = go (n+1) cs - go n (')':cs) = end_lex_id module_dot (ITconid (mkTupNameStr n)) cs - go n other = panic ("lex_tuple" ++ orig_cs) - - -- Similarly ' itself is ok inside an identifier, but not at the start - is_id_char c = isAlphanum c || c `elem` ":_'!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic - - lex_id cs = go [] cs - where - go xs (f :cs) | is_kwd_mod_char f = go (f : xs) cs - go xs ('.':cs) | not (null xs) = lex_id2 (Just (_PK_ (reverse xs))) [] cs - go xs cs = lex_id2 Nothing xs cs - - -- Dealt with the Module.part - lex_id2 module_dot [] ('[': ']': cs) = end_lex_id module_dot (ITconid SLIT("[]")) cs - lex_id2 module_dot [] ('(': ')': cs) = end_lex_id module_dot (ITconid SLIT("()")) cs - lex_id2 module_dot [] ('(': ',': cs) = lex_tuple module_dot cs - lex_id2 module_dot [] (':' : cs) = lex_id3 module_dot [':'] cs - lex_id2 module_dot xs cs = lex_id3 module_dot xs cs - - -- Dealt with [], (), : special cases - lex_id3 module_dot xs (f:cs) | is_id_char f = lex_id3 module_dot (f : xs) cs - - lex_id3 Nothing xs rest = case lookupFM haskellKeywordsFM rxs of - Just kwd_token -> kwd_token : lexIface rest - other -> (mk_var_token rxs) : lexIface rest - where - rxs = reverse xs - - lex_id3 (Just m) xs rest = end_lex_id (Just m) (mk_var_token (reverse xs)) rest - +----------- +lex_tuple module_dot buf = +-- _trace ("lex_tuple: "++[C# (currentChar# buf)]) $ + go 2 buf + where + go n buf = + case currentChar# buf of + ','# -> go (n+1) (stepOn buf) + ')'# -> end_lex_id module_dot (ITconid (mkTupNameStr n)) (stepOn buf) + _ -> ITunknown ("tuple " ++ show n) : lexIface buf + +-- Similarly ' itself is ok inside an identifier, but not at the start + +id_arr :: _ByteArray Int +id_arr = + unsafePerformPrimIO ( + newCharArray (0,255) `thenPrimIO` \ barr -> + let + loop 256# = returnPrimIO () + loop i# = + if isAlphanum (C# (chr# i#)) || is_sym (chr# i#) then + writeCharArray barr (I# i#) '\1' `seqPrimIO` + loop (i# +# 1#) + else + writeCharArray barr (I# i#) '\0' `seqPrimIO` + loop (i# +# 1#) + in + loop 0# `seqPrimIO` + unsafeFreezeByteArray barr) + +is_id_char (C# c#) = + let + _ByteArray _ arr# = id_arr + in + case ord# (indexCharArray# arr# (ord# c#)) of + 0# -> False + 1# -> True + +--is_id_char c@(C# c#) = isAlphanum c || is_sym c# + +is_sym c#= + case c# of { + ':'# -> True; '_'# -> True; '\''# -> True; '!'# -> True; + '#'# -> True; '$'# -> True; ':'# -> True; '%'# -> True; + '&'# -> True; '*'# -> True; '+'# -> True; '.'# -> True; + '/'# -> True; '<'# -> True; '='# -> True; '>'# -> True; + '?'# -> True; '\\'# -> True; '^'# -> True; '|'# -> True; + '-'# -> True; '~'# -> True; _ -> False } + +--isAlphanum c || c `elem` ":_'!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic + + +mod_arr :: _ByteArray Int +mod_arr = + unsafePerformPrimIO ( + newCharArray (0,255) `thenPrimIO` \ barr -> + let + loop 256# = returnPrimIO () + loop i# = + if isAlphanum (C# (chr# i#)) || i# ==# (ord# '_'#) || i# ==# (ord# '\''#) then + writeCharArray barr (I# i#) '\1' `seqPrimIO` + loop (i# +# 1#) + else + writeCharArray barr (I# i#) '\0' `seqPrimIO` + loop (i# +# 1#) + in + loop 0# `seqPrimIO` + unsafeFreezeByteArray barr) + + +is_mod_char (C# c#) = + let + _ByteArray _ arr# = mod_arr + in + case ord# (indexCharArray# arr# (ord# c#)) of + 0# -> False + 1# -> True + +--isAlphanum c || c == '_' || c== '\'' --`elem` "_'" + +{- +lex_id cs = + case _scc_ "lex_id.span" my_span' (is_mod_char) cs of + (xs, len, cs') -> + case cs' of + [] -> case xs of + [] -> lex_id2 Nothing cs + _ -> lex_id3 Nothing len xs cs + + '.':cs'' -> + case xs of + [] -> lex_id2 Nothing cs + _ -> + let + pk_str = _PK_ (xs::String) + len = lengthPS pk_str + in + if len==len+1 then + error "Well, I never!" + else + lex_id2 (Just pk_str) cs'' + _ -> case xs of + [] -> lex_id2 Nothing cs + _ -> lex_id3 Nothing len xs cs' + +-} + +lex_id buf = +-- _trace ("lex_id: "++[C# (currentChar# buf)]) $ + case expandWhile (is_mod_char) buf of + buf' -> + case currentChar# buf' of + '.'# -> + if not (emptyLexeme buf') then +-- _trace ("lex_id: "++(C# (currentChar# (stepOverLexeme buf'))):show (lexemeToFastString buf')) $ + case lexemeToFastString buf' of + l@(FastString u# l# ba#) -> lex_id2 (Just (FastString u# l# ba#)) + (stepOn (stepOverLexeme buf')) + else + lex_id2 Nothing buf' + _ -> lex_id2 Nothing buf' + +-- Dealt with the Module.part +lex_id2 module_dot buf = +-- _trace ("lex_id2: "++[C# (currentChar# buf)]) $ + case currentChar# buf of + '['# -> + case lookAhead# buf 1# of + ']'# -> end_lex_id module_dot (ITconid SLIT("[]")) (stepOnBy# buf 2#) + _ -> lex_id3 module_dot buf + '('# -> + case lookAhead# buf 1# of + ')'# -> end_lex_id module_dot (ITconid SLIT("()")) (stepOnBy# buf 2#) + ','# -> lex_tuple module_dot (stepOnBy# buf 2#) + _ -> lex_id3 module_dot buf + ':'# -> lex_id3 module_dot (incLexeme buf) + _ -> lex_id3 module_dot buf + + + +-- Dealt with [], (), : special cases + +lex_id3 module_dot buf = +-- _trace ("lex_id3: "++[C# (currentChar# buf)]) $ + case expandWhile (is_id_char) buf of + buf' -> + case module_dot of + Just _ -> + end_lex_id module_dot (mk_var_token lexeme) (stepOverLexeme buf') + Nothing -> + case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of + Just kwd_token -> kwd_token : lexIface new_buf + Nothing -> mk_var_token lexeme : lexIface new_buf + where + lexeme = lexemeToFastString buf' + new_buf = stepOverLexeme buf' + + +{- OLD: +lex_id2 module_dot [] ('[': ']': cs) = end_lex_id module_dot (ITconid SLIT("[]")) cs +lex_id2 module_dot [] ('(': ')': cs) = end_lex_id module_dot (ITconid SLIT("()")) cs +lex_id2 module_dot [] ('(': ',': cs) = lex_tuple module_dot cs +lex_id2 module_dot [] (':' : cs) = lex_id3 module_dot [':'] cs +lex_id2 module_dot xs cs = lex_id3 module_dot xs cs +-} + + +-- Dealt with [], (), : special cases + +{- +lex_id3 module_dot len_xs xs cs = + case my_span' (is_id_char) cs of + (xs1,len_xs1,rest) -> + case module_dot of + Just m -> end_lex_id (Just m) (mk_var_token rxs) rest --OLD:_PK_ (reverse xs))) rest + Nothing -> + case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM rxs of + Just kwd_token -> kwd_token : lexIface rest + other -> token : lexIface cs end_lex_id Nothing (mk_var_token rxs) rest + where + rxs = packNChars (len_xs+len_xs1) (xs++xs1) -- OLD: _PK_ (reverse xs) +-} +mk_var_token pk_str = + let + f = _HEAD_ pk_str + in + -- + -- These tests assume a non- ISO-8859-1 impl of isUpper&isLower, + -- remove the second half of disjunction when using a 1.3 prelude. + -- + if isUpper f then ITconid pk_str + else if isLower f then ITvarid pk_str + else if f == ':' then ITconsym pk_str + else if isLowerISO f then ITvarid pk_str + else if isUpperISO f then ITconid pk_str + else ITvarsym pk_str + +{- mk_var_token xs@(f:_) | isUpper f || isUpperISO f = ITconid n | f == ':' = ITconsym n | isAlpha f = ITvarid n | otherwise = ITvarsym n where n = _PK_ xs +-} - end_lex_id (Just m) (ITconid n) cs = ITqconid (m,n) : lexIface cs - end_lex_id (Just m) (ITvarid n) cs = ITqvarid (m,n) : lexIface cs - end_lex_id (Just m) (ITconsym n) cs = ITqconsym (m,n): lexIface cs - end_lex_id (Just m) (ITvarsym n) cs = ITqvarsym (m,n): lexIface cs - end_lex_id (Just m) ITbang cs = ITqvarsym (m,SLIT("!")) : lexIface cs - end_lex_id (Just m) token cs = panic ("end_lex_id:" ++ show token) - end_lex_id Nothing token cs = token : lexIface cs - - ------------ - ifaceKeywordsFM :: FiniteMap String IfaceToken - ifaceKeywordsFM = listToFM [ - ("/\\_", ITbiglam) +end_lex_id Nothing token buf = token : lexIface buf +end_lex_id (Just m) token buf = + case token of + ITconid n -> ITqconid (m,n) : lexIface buf + ITvarid n -> ITqvarid (m,n) : lexIface buf + ITconsym n -> ITqconsym (m,n) : lexIface buf + ITvarsym n -> ITqvarsym (m,n) : lexIface buf + ITbang -> ITqvarsym (m,SLIT("!")) : lexIface buf + _ -> ITunknown (show token) : lexIface buf + +------------ +ifaceKeywordsFM :: UniqFM IfaceToken +ifaceKeywordsFM = listToUFM $ + map (\ (x,y) -> (_PK_ x,y)) + [("/\\_", ITbiglam) ,("@_", ITatsign) ,("interface_", ITinterface) ,("usages_", ITusages) @@ -348,8 +733,9 @@ lexIface input ,("casm_GC_", ITccall (True, True)) ] - haskellKeywordsFM = listToFM [ - ("data", ITdata) +haskellKeywordsFM = listToUFM $ + map (\ (x,y) -> (_PK_ x,y)) + [ ("data", ITdata) ,("type", ITtype) ,("newtype", ITnewtype) ,("class", ITclass) @@ -374,18 +760,33 @@ lexIface input ,("=", ITequal) ] -startDiscard ITarity = True -startDiscard ITunfold = True -startDiscard ITstrict = True -startDiscard other = False -- doDiscard rips along really fast looking for a double semicolon, -- indicating the end of the pragma we're skipping -doDiscard rest@(';' : ';' : _) = rest -doDiscard ( _ : rest) = doDiscard rest -doDiscard [] = [] +doDiscard buf = + case currentChar# buf of + ';'# -> + case lookAhead# buf 1# of + ';'# -> stepOnBy# buf 2# + _ -> doDiscard (stepOn buf) + _ -> doDiscard (stepOn buf) + \end{code} +begin{code} +my_span :: (a -> Bool) -> [a] -> ([a],[a]) +my_span p xs = go [] xs + where + go so_far (x:xs') | p x = go (x:so_far) xs' + go so_far xs = (reverse so_far, xs) + +my_span' :: (a -> Bool) -> [a] -> ([a],Int,[a]) +my_span' p xs = go [] 0 xs + where + go so_far n (x:xs') | p x = go (x:so_far) (n+1) xs' + go so_far n xs = (reverse so_far,n, xs) +end{code} + %************************************************************************ %* * @@ -410,5 +811,5 @@ happyError ln toks = Failed (ifaceParseErr ln toks) ----------------------------------------------------------------- ifaceParseErr ln toks sty - = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppStr "toks=", ppStr (show (take 10 toks))] + = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppPStr SLIT("toks="), ppStr (show (take 10 toks))] \end{code} diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs index 9b72fa5f2a..1892af89cc 100644 --- a/ghc/compiler/reader/PrefixToHs.lhs +++ b/ghc/compiler/reader/PrefixToHs.lhs @@ -45,7 +45,7 @@ cvValSig (RdrTySig vars poly_ty src_loc) = [ Sig v poly_ty src_loc | v <- vars ] cvClassOpSig (RdrTySig vars poly_ty src_loc) - = [ ClassOpSig v poly_ty noClassOpPragmas src_loc | v <- vars ] + = [ ClassOpSig v v poly_ty src_loc | v <- vars ] cvInstDeclSig (RdrSpecValSig sigs) = sigs cvInstDeclSig (RdrInlineValSig sig) = [ sig ] diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs index ab07b885e6..d7bbd7f981 100644 --- a/ghc/compiler/reader/RdrHsSyn.lhs +++ b/ghc/compiler/reader/RdrHsSyn.lhs @@ -33,7 +33,6 @@ module RdrHsSyn ( SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNamePat), SYN_IE(RdrNameHsType), - SYN_IE(RdrNameQual), SYN_IE(RdrNameSig), SYN_IE(RdrNameSpecInstSig), SYN_IE(RdrNameStmt), @@ -51,8 +50,8 @@ module RdrHsSyn ( qual, varQual, tcQual, varUnqual, dummyRdrVarName, dummyRdrTcName, isUnqual, isQual, - showRdr, rdrNameOcc, - cmpRdr, + showRdr, rdrNameOcc, ieOcc, + cmpRdr, prefixRdrName, mkOpApp ) where @@ -63,7 +62,7 @@ import HsSyn import Lex import PrelMods ( pRELUDE ) import Name ( ExportFlag(..), Module(..), pprModule, - OccName(..), pprOccName ) + OccName(..), pprOccName, prefixOccName ) import Pretty import PprStyle ( PprStyle(..) ) import Util ( cmpPString, panic, thenCmp ) @@ -93,7 +92,6 @@ type RdrNameMatch = Match Fake Fake RdrName RdrNamePat type RdrNameMonoBinds = MonoBinds Fake Fake RdrName RdrNamePat type RdrNamePat = InPat RdrName type RdrNameHsType = HsType RdrName -type RdrNameQual = Qualifier Fake Fake RdrName RdrNamePat type RdrNameSig = Sig RdrName type RdrNameSpecInstSig = SpecInstSig RdrName type RdrNameStmt = Stmt Fake Fake RdrName RdrNamePat @@ -173,6 +171,11 @@ isUnqual (Qual _ _) = False isQual (Unqual _) = False isQual (Qual _ _) = True + -- Used for adding a prefix to a RdrName +prefixRdrName :: FAST_STRING -> RdrName -> RdrName +prefixRdrName prefix (Qual m n) = Qual m (prefixOccName prefix n) +prefixRdrName prefix (Unqual n) = Unqual (prefixOccName prefix n) + cmpRdr (Unqual n1) (Unqual n2) = n1 `cmp` n2 cmpRdr (Unqual n1) (Qual m2 n2) = LT_ cmpRdr (Qual m1 n1) (Unqual n2) = GT_ @@ -183,6 +186,9 @@ rdrNameOcc :: RdrName -> OccName rdrNameOcc (Unqual occ) = occ rdrNameOcc (Qual _ occ) = occ +ieOcc :: RdrNameIE -> OccName +ieOcc ie = rdrNameOcc (ieName ie) + instance Text RdrName where -- debugging showsPrec _ rn = showString (ppShow 80 (ppr PprDebug rn)) @@ -201,7 +207,7 @@ instance Ord3 RdrName where instance Outputable RdrName where ppr sty (Unqual n) = pprOccName sty n - ppr sty (Qual m n) = ppBesides [pprModule sty m, ppStr ".", pprOccName sty n] + ppr sty (Qual m n) = ppBesides [pprModule sty m, ppChar '.', pprOccName sty n] instance NamedThing RdrName where -- Just so that pretty-printing of expressions works getOccName = rdrNameOcc diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs index 2098692e77..d72394f920 100644 --- a/ghc/compiler/reader/ReadPrefix.lhs +++ b/ghc/compiler/reader/ReadPrefix.lhs @@ -95,7 +95,7 @@ cvFlag 1 = True # define PACK_STR packCString # define CCALL_THEN `stThen` #else -# define PACK_STR _packCString +# define PACK_STR mkFastCharString # define CCALL_THEN `thenPrimIO` #endif @@ -222,7 +222,7 @@ wlkExpr expr U_doe gdo srcline -> -- do expression mkSrcLocUgn srcline $ \ src_loc -> wlkList rd_stmt gdo `thenUgn` \ stmts -> - returnUgn (HsDo stmts src_loc) + returnUgn (HsDo DoStmt stmts src_loc) where rd_stmt pt = rdU_tree pt `thenUgn` \ bind -> @@ -249,7 +249,8 @@ wlkExpr expr U_comprh cexp cquals -> -- list comprehension wlkExpr cexp `thenUgn` \ expr -> wlkList rd_qual cquals `thenUgn` \ quals -> - returnUgn (ListComp expr quals) + getSrcLocUgn `thenUgn` \ loc -> + returnUgn (HsDo ListComp (quals ++ [ReturnStmt expr]) loc) where rd_qual pt = rdU_tree pt `thenUgn` \ qual -> @@ -259,12 +260,14 @@ wlkExpr expr = case qual of U_guard exp -> wlkExpr exp `thenUgn` \ expr -> - returnUgn (FilterQual expr) + getSrcLocUgn `thenUgn` \ loc -> + returnUgn (GuardStmt expr loc) U_qual qpat qexp -> wlkPat qpat `thenUgn` \ pat -> wlkExpr qexp `thenUgn` \ expr -> - returnUgn (GeneratorQual pat expr) + getSrcLocUgn `thenUgn` \ loc -> + returnUgn (BindStmt pat expr loc) U_seqlet seqlet -> wlkBinding seqlet `thenUgn` \ bs -> @@ -272,7 +275,7 @@ wlkExpr expr let binds = cvBinds sf cvValSig bs in - returnUgn (LetQual binds) + returnUgn (LetStmt binds) U_eenum efrom estep eto -> -- arithmetic sequence wlkExpr efrom `thenUgn` \ e1 -> @@ -386,6 +389,11 @@ wlkPat pat wlkPat lazyp `thenUgn` \ pat -> returnUgn (LazyPatIn pat) + U_plusp avar lit -> + wlkVarId avar `thenUgn` \ var -> + wlkLiteral lit `thenUgn` \ lit -> + returnUgn (NPlusKPatIn var lit) + U_wildp -> returnUgn WildPatIn -- wildcard pattern U_lit lit -> -- literal pattern diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 0faa549453..5107c5bc0f 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -1,6 +1,5 @@ { #include "HsVersions.h" - module ParseIface ( parseIface ) where IMP_Ubiq(){-uitous-} @@ -25,14 +24,16 @@ import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..), ) import Bag ( emptyBag, unitBag, snocBag ) import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap ) -import Name ( OccName(..), Provenance ) +import Name ( OccName(..), isTCOcc, Provenance ) import SrcLoc ( mkIfaceSrcLoc ) import Util ( panic{-, pprPanic ToDo:rm-} ) - +import ParseType ( parseType ) +import ParseUnfolding ( parseUnfolding ) +import Maybes ----------------------------------------------------------------- -parseIface = parseIToks . lexIface +parseIface ls = parseIToks (lexIface ls) ----------------------------------------------------------------- } @@ -51,33 +52,33 @@ parseIface = parseIToks . lexIface FIXITIES_PART { ITfixities } DECLARATIONS_PART { ITdeclarations } PRAGMAS_PART { ITpragmas } - BANG { ITbang } - CBRACK { ITcbrack } - CCURLY { ITccurly } + DATA { ITdata } + TYPE { ITtype } + NEWTYPE { ITnewtype } + DERIVING { ITderiving } CLASS { ITclass } + WHERE { ITwhere } + INSTANCE { ITinstance } + INFIXL { ITinfixl } + INFIXR { ITinfixr } + INFIX { ITinfix } + FORALL { ITforall } + BANG { ITbang } + VBAR { ITvbar } + DCOLON { ITdcolon } COMMA { ITcomma } - CPAREN { ITcparen } DARROW { ITdarrow } - DATA { ITdata } - DCOLON { ITdcolon } - DERIVING { ITderiving } DOTDOT { ITdotdot } EQUAL { ITequal } - FORALL { ITforall } - INFIX { ITinfix } - INFIXL { ITinfixl } - INFIXR { ITinfixr } - INSTANCE { ITinstance } - NEWTYPE { ITnewtype } - OBRACK { ITobrack } OCURLY { ITocurly } + OBRACK { ITobrack } OPAREN { IToparen } RARROW { ITrarrow } + CCURLY { ITccurly } + CBRACK { ITcbrack } + CPAREN { ITcparen } SEMI { ITsemi } - TYPE { ITtype } - VBAR { ITvbar } - WHERE { ITwhere } - INTEGER { ITinteger $$ } + VARID { ITvarid $$ } CONID { ITconid $$ } VARSYM { ITvarsym $$ } @@ -87,6 +88,8 @@ parseIface = parseIToks . lexIface QVARSYM { ITqvarsym $$ } QCONSYM { ITqconsym $$ } + IDINFO_PART { ITidinfo $$ } + TYPE_PART { ITtysig $$ } ARITY_PART { ITarity } STRICT_PART { ITstrict } UNFOLD_PART { ITunfold } @@ -96,23 +99,29 @@ parseIface = parseIToks . lexIface BIGLAM { ITbiglam } CASE { ITcase } PRIM_CASE { ITprim_case } - OF { ITof } LET { ITlet } LETREC { ITletrec } IN { ITin } - ATSIGN { ITatsign } + OF { ITof } COERCE_IN { ITcoerce_in } COERCE_OUT { ITcoerce_out } + ATSIGN { ITatsign } + CCALL { ITccall $$ } + SCC { ITscc $$ } + CHAR { ITchar $$ } STRING { ITstring $$ } + INTEGER { ITinteger $$ } DOUBLE { ITdouble $$ } + INTEGER_LIT { ITinteger_lit } - STRING_LIT { ITstring_lit } FLOAT_LIT { ITfloat_lit } RATIONAL_LIT { ITrational_lit } ADDR_LIT { ITaddr_lit } LIT_LIT { ITlit_lit } - CCALL { ITccall $$ } + STRING_LIT { ITstring_lit } + + UNKNOWN { ITunknown $$ } %% iface :: { ParsedIface } @@ -172,11 +181,14 @@ entities : { [] } | entity entities { $1 : $2 } entity :: { (OccName, [OccName]) } -entity : entity_occ maybe_inside { ($1, $2) } - -maybe_inside :: { [OccName] } -maybe_inside : { [] } - | OPAREN val_occs CPAREN { $2 +entity : entity_occ { ($1, if isTCOcc $1 + then [$1] {- AvailTC -} + else []) {- Avail -} } + | entity_occ stuff_inside { ($1, ($1 : $2)) {- TyCls exported too -} } + | entity_occ BANG stuff_inside { ($1, $3) {- TyCls not exported -} } + +stuff_inside :: { [OccName] } +stuff_inside : OPAREN val_occs1 CPAREN { $2 -------------------------------------------------------------------------- } @@ -219,23 +231,28 @@ version : INTEGER { fromInteger $1 } topdecl :: { RdrNameHsDecl } topdecl : TYPE tc_name tv_bndrs EQUAL type SEMI { TyD (TySynonym $2 $3 $5 mkIfaceSrcLoc) } - | DATA decl_context tc_name tv_bndrs EQUAL constrs deriving SEMI - { TyD (TyData $2 $3 $4 $6 $7 noDataPragmas mkIfaceSrcLoc) } + | DATA decl_context tc_name tv_bndrs constrs deriving SEMI + { TyD (TyData $2 $3 $4 $5 $6 noDataPragmas mkIfaceSrcLoc) } | NEWTYPE decl_context tc_name tv_bndrs EQUAL constr1 deriving SEMI { TyD (TyNew $2 $3 $4 $6 $7 noDataPragmas mkIfaceSrcLoc) } | CLASS decl_context tc_name tv_bndr csigs SEMI { ClD (ClassDecl $2 $3 $4 $5 EmptyMonoBinds noClassPragmas mkIfaceSrcLoc) } - | var_name DCOLON type id_info SEMI SEMI - { {- Double semicolon allows easy pragma discard in lexer -} - let - id_info = if opt_IgnoreIfacePragmas then [] else $4 - in - SigD (IfaceSig $1 $3 id_info mkIfaceSrcLoc) } + | var_name TYPE_PART id_info + { + let + (Succeeded tp) = parseType $2 + in + SigD (IfaceSig $1 tp $3 mkIfaceSrcLoc) } + +id_info :: { [HsIdInfo RdrName] } +id_info : { [] } + | IDINFO_PART { let { (Succeeded id_info) = parseUnfolding $1 } in id_info} decl_context :: { RdrNameContext } decl_context : { [] } | OCURLY context_list1 CCURLY DARROW { $2 } + csigs :: { [RdrNameSig] } csigs : { [] } | WHERE OCURLY csigs1 CCURLY { $3 } @@ -245,13 +262,17 @@ csigs1 : csig { [$1] } | csig SEMI csigs1 { $1 : $3 } csig :: { RdrNameSig } -csig : var_name DCOLON type { ClassOpSig $1 $3 noClassOpPragmas mkIfaceSrcLoc +csig : var_name DCOLON type { ClassOpSig $1 $1 $3 mkIfaceSrcLoc ---------------------------------------------------------------- } constrs :: { [RdrNameConDecl] } -constrs : constr { [$1] } - | constr VBAR constrs { $1 : $3 } + : { [] } + | EQUAL constrs1 { $2 } + +constrs1 :: { [RdrNameConDecl] } +constrs1 : constr { [$1] } + | constr VBAR constrs1 { $1 : $3 } constr :: { RdrNameConDecl } constr : data_name batypes { ConDecl $1 $2 mkIfaceSrcLoc } @@ -349,9 +370,9 @@ val_occ : var_occ { $1 } | CONID { VarOcc $1 } | CONSYM { VarOcc $1 } -val_occs :: { [OccName] } - : { [] } - | val_occ val_occs { $1 : $2 } +val_occs1 :: { [OccName] } + : val_occ { [$1] } + | val_occ val_occs1 { $1 : $2 } qvar_name :: { RdrName } @@ -431,123 +452,3 @@ instd : INSTANCE type EQUAL var_name SEMI mkIfaceSrcLoc -------------------------------------------------------------------------- } - -id_info :: { [HsIdInfo RdrName] } -id_info : { [] } - | id_info_item id_info { $1 : $2 } - -id_info_item :: { HsIdInfo RdrName } -id_info_item : ARITY_PART arity_info { HsArity $2 } - | STRICT_PART strict_info { HsStrictness $2 } - | BOTTOM { HsStrictness mkBottomStrictnessInfo } - | UNFOLD_PART core_expr { HsUnfold $2 } - -arity_info :: { ArityInfo } -arity_info : INTEGER { exactArity (fromInteger $1) } - -strict_info :: { StrictnessInfo RdrName } -strict_info : DEMAND any_var_name { mkStrictnessInfo $1 (Just $2) } - | DEMAND { mkStrictnessInfo $1 Nothing } - -core_expr :: { UfExpr RdrName } -core_expr : any_var_name { UfVar $1 } - | qdata_name { UfVar $1 } - | core_lit { UfLit $1 } - | OPAREN core_expr CPAREN { $2 } - - | core_expr ATSIGN atype { UfApp $1 (UfTyArg $3) } - | core_expr core_arg { UfApp $1 $2 } - | LAM core_val_bndrs RARROW core_expr { foldr UfLam $4 $2 } - | BIGLAM core_tv_bndrs RARROW core_expr { foldr UfLam $4 $2 } - - | CASE core_expr OF - OCURLY alg_alts core_default CCURLY { UfCase $2 (UfAlgAlts $5 $6) } - | PRIM_CASE core_expr OF - OCURLY prim_alts core_default CCURLY { UfCase $2 (UfPrimAlts $5 $6) } - - - | LET OCURLY core_val_bndr EQUAL core_expr CCURLY - IN core_expr { UfLet (UfNonRec $3 $5) $8 } - | LETREC OCURLY rec_binds CCURLY - IN core_expr { UfLet (UfRec $3) $6 } - - | coerce atype core_expr { UfCoerce $1 $2 $3 } - - | CCALL ccall_string - OBRACK atype atypes CBRACK core_args { let - (is_casm, may_gc) = $1 - in - UfPrim (UfCCallOp $2 is_casm may_gc $5 $4) - $7 - } - -rec_binds :: { [(UfBinder RdrName, UfExpr RdrName)] } - : { [] } - | core_val_bndr EQUAL core_expr SEMI rec_binds { ($1,$3) : $5 } - -coerce :: { UfCoercion RdrName } -coerce : COERCE_IN qdata_name { UfIn $2 } - | COERCE_OUT qdata_name { UfOut $2 } - -prim_alts :: { [(Literal,UfExpr RdrName)] } - : { [] } - | core_lit RARROW core_expr SEMI prim_alts { ($1,$3) : $5 } - -alg_alts :: { [(RdrName, [UfBinder RdrName], UfExpr RdrName)] } - : { [] } - | qdata_name core_val_bndrs RARROW - core_expr SEMI alg_alts { ($1,$2,$4) : $6 } - -core_default :: { UfDefault RdrName } - : { UfNoDefault } - | core_val_bndr RARROW core_expr SEMI { UfBindDefault $1 $3 } - -core_arg :: { UfArg RdrName } - : var_name { UfVarArg $1 } - | qvar_name { UfVarArg $1 } - | qdata_name { UfVarArg $1 } - | core_lit { UfLitArg $1 } - -core_args :: { [UfArg RdrName] } - : { [] } - | core_arg core_args { $1 : $2 } - -core_lit :: { Literal } -core_lit : INTEGER { MachInt $1 True } - | CHAR { MachChar $1 } - | STRING { MachStr $1 } - | STRING_LIT STRING { NoRepStr $2 } - | DOUBLE { MachDouble (toRational $1) } - | FLOAT_LIT DOUBLE { MachFloat (toRational $2) } - - | INTEGER_LIT INTEGER { NoRepInteger $2 (panic "NoRepInteger type") - -- The type checker will add the types - } - - | RATIONAL_LIT INTEGER INTEGER { NoRepRational ($2 % $3) - (panic "NoRepRational type") - -- The type checker will add the type - } - - | ADDR_LIT INTEGER { MachAddr $2 } - | LIT_LIT STRING { MachLitLit $2 (panic "ParseIface.y: ToDo: need PrimRep on LitLits in ifaces") } - -core_val_bndr :: { UfBinder RdrName } -core_val_bndr : var_name DCOLON atype { UfValBinder $1 $3 } - -core_val_bndrs :: { [UfBinder RdrName] } -core_val_bndrs : { [] } - | core_val_bndr core_val_bndrs { $1 : $2 } - -core_tv_bndr :: { UfBinder RdrName } -core_tv_bndr : tv_name DCOLON akind { UfTyBinder $1 $3 } - | tv_name { UfTyBinder $1 mkTypeKind } - -core_tv_bndrs :: { [UfBinder RdrName] } -core_tv_bndrs : { [] } - | core_tv_bndr core_tv_bndrs { $1 : $2 } - -ccall_string :: { FAST_STRING } - : STRING { $1 } - | VARID { $1 } - | CONID { $1 } diff --git a/ghc/compiler/rename/ParseType.y b/ghc/compiler/rename/ParseType.y new file mode 100644 index 0000000000..d39c56b53a --- /dev/null +++ b/ghc/compiler/rename/ParseType.y @@ -0,0 +1,140 @@ +{ +#include "HsVersions.h" +module ParseType ( parseType ) where + +IMP_Ubiq(){-uitous-} + +import HsSyn -- quite a bit of stuff +import RdrHsSyn -- oodles of synonyms +import HsDecls ( HsIdInfo(..) ) +import HsTypes ( mkHsForAllTy ) +import HsCore +import Literal +import HsPragmas ( noGenPragmas, noDataPragmas, noClassPragmas, noClassOpPragmas, noInstancePragmas ) +import IdInfo ( exactArity, mkStrictnessInfo, mkBottomStrictnessInfo, + ArgUsageInfo, FBTypeInfo + ) +import Kind ( Kind, mkArrowKind, mkTypeKind ) +import Lex + +import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..), + SYN_IE(RdrNamePragma), SYN_IE(ExportItem) + ) +import Bag ( emptyBag, unitBag, snocBag ) +import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap ) +import Name ( OccName(..), isTCOcc, Provenance ) +import SrcLoc ( mkIfaceSrcLoc ) +import Util ( panic{-, pprPanic ToDo:rm-} ) +import Pretty ( ppShow ) +import PprStyle -- PprDebug for panic +import Maybes ( MaybeErr(..) ) + +------------------------------------------------------------------ + +parseType :: [IfaceToken] -> MaybeErr RdrNameHsType (PprStyle -> Int -> Bool -> PrettyRep) +parseType ls = + let + res = + case parseT ls of + v@(Succeeded _) -> v + Failed err -> panic (ppShow 80 (err PprDebug)) + in + res + +} + +%name parseT +%tokentype { IfaceToken } +%monad { IfM }{ thenIf }{ returnIf } + +%token + FORALL { ITforall } + DCOLON { ITdcolon } + COMMA { ITcomma } + DARROW { ITdarrow } + OCURLY { ITocurly } + OBRACK { ITobrack } + OPAREN { IToparen } + RARROW { ITrarrow } + CCURLY { ITccurly } + CBRACK { ITcbrack } + CPAREN { ITcparen } + + VARID { ITvarid $$ } + CONID { ITconid $$ } + VARSYM { ITvarsym $$ } + CONSYM { ITconsym $$ } + QCONID { ITqconid $$ } + + UNKNOWN { ITunknown $$ } +%% + +type :: { RdrNameHsType } +type : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 } + | tautype { $1 } + +forall : OBRACK tv_bndrs CBRACK { $2 } + +context :: { RdrNameContext } +context : { [] } + | OCURLY context_list1 CCURLY { $2 } + +context_list1 :: { RdrNameContext } +context_list1 : class { [$1] } + | class COMMA context_list1 { $1 : $3 } + +class :: { (RdrName, RdrNameHsType) } +class : qtc_name atype { ($1, $2) } + + +tautype :: { RdrNameHsType } +tautype : btype { $1 } + | btype RARROW tautype { MonoFunTy $1 $3 } + +types2 :: { [RdrNameHsType] {- Two or more -} } +types2 : type COMMA type { [$1,$3] } + | type COMMA types2 { $1 : $3 } + +btype :: { RdrNameHsType } +btype : atype { $1 } + | btype atype { MonoTyApp $1 $2 } + +atype :: { RdrNameHsType } +atype : qtc_name { MonoTyVar $1 } + | tv_name { MonoTyVar $1 } + | OPAREN types2 CPAREN { MonoTupleTy dummyRdrTcName $2 } + | OBRACK type CBRACK { MonoListTy dummyRdrTcName $2 } + | OCURLY qtc_name atype CCURLY { MonoDictTy $2 $3 } + | OPAREN type CPAREN { $2 } + +atypes :: { [RdrNameHsType] {- Zero or more -} } +atypes : { [] } + | atype atypes { $1 : $2 +--------------------------------------------------------------------- + } + +tv_bndr :: { HsTyVar RdrName } +tv_bndr : tv_name DCOLON akind { IfaceTyVar $1 $3 } + | tv_name { UserTyVar $1 } + +tv_bndrs :: { [HsTyVar RdrName] } + : { [] } + | tv_bndr tv_bndrs { $1 : $2 } + +kind :: { Kind } + : akind { $1 } + | akind RARROW kind { mkArrowKind $1 $3 } + +akind :: { Kind } + : VARSYM { mkTypeKind {- ToDo: check that it's "*" -} } + | OPAREN kind CPAREN { $2 } + +tv_name :: { RdrName } +tv_name : VARID { Unqual (TvOcc $1) } + +tv_names :: { [RdrName] } + : { [] } + | tv_name tv_names { $1 : $2 } +qtc_name :: { RdrName } +qtc_name : QCONID { tcQual $1 } + diff --git a/ghc/compiler/rename/ParseUnfolding.y b/ghc/compiler/rename/ParseUnfolding.y new file mode 100644 index 0000000000..1336fb9f51 --- /dev/null +++ b/ghc/compiler/rename/ParseUnfolding.y @@ -0,0 +1,344 @@ +{ +#include "HsVersions.h" +module ParseUnfolding ( parseUnfolding ) where + +IMP_Ubiq(){-uitous-} + +import HsSyn -- quite a bit of stuff +import RdrHsSyn -- oodles of synonyms +import HsDecls ( HsIdInfo(..) ) +import HsTypes ( mkHsForAllTy ) +import HsCore +import Literal +import PrimRep ( decodePrimRep ) +import HsPragmas ( noGenPragmas, noDataPragmas, noClassPragmas, noClassOpPragmas, noInstancePragmas ) +import IdInfo ( exactArity, mkStrictnessInfo, mkBottomStrictnessInfo, + ArgUsageInfo, FBTypeInfo + ) +import Kind ( Kind, mkArrowKind, mkTypeKind ) +import Lex + +import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..), + SYN_IE(RdrNamePragma), SYN_IE(ExportItem) + ) +import Bag ( emptyBag, unitBag, snocBag ) +import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap ) +import Name ( OccName(..), isTCOcc, Provenance ) +import SrcLoc ( mkIfaceSrcLoc ) +import Util ( panic{-, pprPanic ToDo:rm-} ) +import Pretty ( ppShow ) +import PprStyle -- PprDebug for panic +import Maybes ( MaybeErr(..) ) + +------------------------------------------------------------------ + +parseUnfolding ls = + let + res = + case parseUnfold ls of + v@(Succeeded _) -> v + -- ill-formed unfolding, crash and burn. + Failed err -> panic (ppShow 80 (err PprDebug)) + in + res +} + +%name parseUnfold +%tokentype { IfaceToken } +%monad { IfM }{ thenIf }{ returnIf } + +%token + PRAGMAS_PART { ITpragmas } + DATA { ITdata } + TYPE { ITtype } + NEWTYPE { ITnewtype } + DERIVING { ITderiving } + CLASS { ITclass } + WHERE { ITwhere } + INSTANCE { ITinstance } + FORALL { ITforall } + BANG { ITbang } + VBAR { ITvbar } + DCOLON { ITdcolon } + COMMA { ITcomma } + DARROW { ITdarrow } + DOTDOT { ITdotdot } + EQUAL { ITequal } + OCURLY { ITocurly } + OBRACK { ITobrack } + OPAREN { IToparen } + RARROW { ITrarrow } + CCURLY { ITccurly } + CBRACK { ITcbrack } + CPAREN { ITcparen } + SEMI { ITsemi } + + VARID { ITvarid $$ } + CONID { ITconid $$ } + VARSYM { ITvarsym $$ } + CONSYM { ITconsym $$ } + QVARID { ITqvarid $$ } + QCONID { ITqconid $$ } + QVARSYM { ITqvarsym $$ } + QCONSYM { ITqconsym $$ } + + ARITY_PART { ITarity } + STRICT_PART { ITstrict } + UNFOLD_PART { ITunfold } + DEMAND { ITdemand $$ } + BOTTOM { ITbottom } + LAM { ITlam } + BIGLAM { ITbiglam } + CASE { ITcase } + PRIM_CASE { ITprim_case } + LET { ITlet } + LETREC { ITletrec } + IN { ITin } + OF { ITof } + COERCE_IN { ITcoerce_in } + COERCE_OUT { ITcoerce_out } + ATSIGN { ITatsign } + CCALL { ITccall $$ } + SCC { ITscc $$ } + + CHAR { ITchar $$ } + STRING { ITstring $$ } + INTEGER { ITinteger $$ } + DOUBLE { ITdouble $$ } + + INTEGER_LIT { ITinteger_lit } + FLOAT_LIT { ITfloat_lit } + RATIONAL_LIT { ITrational_lit } + ADDR_LIT { ITaddr_lit } + LIT_LIT { ITlit_lit } + STRING_LIT { ITstring_lit } + + UNKNOWN { ITunknown $$ } +%% + +id_info :: { [HsIdInfo RdrName] } +id_info : { [] } + | id_info_item id_info { $1 : $2 } + +id_info_item :: { HsIdInfo RdrName } +id_info_item : ARITY_PART arity_info { HsArity $2 } + | STRICT_PART strict_info { HsStrictness $2 } + | BOTTOM { HsStrictness mkBottomStrictnessInfo } + | UNFOLD_PART core_expr { HsUnfold $2 } + +arity_info :: { ArityInfo } +arity_info : INTEGER { exactArity (fromInteger $1) } + +strict_info :: { StrictnessInfo RdrName } +strict_info : DEMAND any_var_name { mkStrictnessInfo $1 (Just $2) } + | DEMAND { mkStrictnessInfo $1 Nothing } + +core_expr :: { UfExpr RdrName } +core_expr : any_var_name { UfVar $1 } + | qdata_name { UfVar $1 } + | core_lit { UfLit $1 } + | OPAREN core_expr CPAREN { $2 } + | qdata_name OCURLY data_args CCURLY { UfCon $1 $3 } + + | core_expr ATSIGN atype { UfApp $1 (UfTyArg $3) } + | core_expr core_arg { UfApp $1 $2 } + | LAM core_val_bndrs RARROW core_expr { foldr UfLam $4 $2 } + | BIGLAM core_tv_bndrs RARROW core_expr { foldr UfLam $4 $2 } + + | CASE core_expr OF + OCURLY alg_alts core_default CCURLY { UfCase $2 (UfAlgAlts $5 $6) } + | PRIM_CASE core_expr OF + OCURLY prim_alts core_default CCURLY { UfCase $2 (UfPrimAlts $5 $6) } + + + | LET OCURLY core_val_bndr EQUAL core_expr CCURLY + IN core_expr { UfLet (UfNonRec $3 $5) $8 } + | LETREC OCURLY rec_binds CCURLY + IN core_expr { UfLet (UfRec $3) $6 } + + | coerce atype core_expr { UfCoerce $1 $2 $3 } + + | CCALL ccall_string + OBRACK atype atypes CBRACK core_args { let + (is_casm, may_gc) = $1 + in + UfPrim (UfCCallOp $2 is_casm may_gc $5 $4) + $7 + } + | SCC OPAREN core_expr CPAREN { UfSCC $1 $3 } + +rec_binds :: { [(UfBinder RdrName, UfExpr RdrName)] } + : { [] } + | core_val_bndr EQUAL core_expr SEMI rec_binds { ($1,$3) : $5 } + +coerce :: { UfCoercion RdrName } +coerce : COERCE_IN qdata_name { UfIn $2 } + | COERCE_OUT qdata_name { UfOut $2 } + +prim_alts :: { [(Literal,UfExpr RdrName)] } + : { [] } + | core_lit RARROW core_expr SEMI prim_alts { ($1,$3) : $5 } + +alg_alts :: { [(RdrName, [RdrName], UfExpr RdrName)] } + : { [] } + | qdata_name var_names RARROW + core_expr SEMI alg_alts { ($1,$2,$4) : $6 } + +core_default :: { UfDefault RdrName } + : { UfNoDefault } + | var_name RARROW core_expr SEMI { UfBindDefault $1 $3 } + +core_arg :: { UfArg RdrName } + : var_name { UfVarArg $1 } + | qvar_name { UfVarArg $1 } + | qdata_name { UfVarArg $1 } + | core_lit { UfLitArg $1 } + +core_args :: { [UfArg RdrName] } + : { [] } + | core_arg core_args { $1 : $2 } + +data_args :: { [UfArg RdrName] } + : { [] } + | ATSIGN atype data_args { UfTyArg $2 : $3 } + | core_arg data_args { $1 : $2 } + +core_lit :: { Literal } +core_lit : INTEGER { MachInt $1 True } + | CHAR { MachChar $1 } + | STRING { MachStr $1 } + | STRING_LIT STRING { NoRepStr $2 } + | DOUBLE { MachDouble (toRational $1) } + | FLOAT_LIT DOUBLE { MachFloat (toRational $2) } + + | INTEGER_LIT INTEGER { NoRepInteger $2 (panic "NoRepInteger type") + -- The type checker will add the types + } + + | RATIONAL_LIT INTEGER INTEGER { NoRepRational ($2 % $3) + (panic "NoRepRational type") + -- The type checker will add the type + } + + | ADDR_LIT INTEGER { MachAddr $2 } + | LIT_LIT prim_rep STRING { MachLitLit $3 (decodePrimRep $2) } + +core_val_bndr :: { UfBinder RdrName } +core_val_bndr : var_name DCOLON atype { UfValBinder $1 $3 } + +core_val_bndrs :: { [UfBinder RdrName] } +core_val_bndrs : { [] } + | core_val_bndr core_val_bndrs { $1 : $2 } + +core_tv_bndr :: { UfBinder RdrName } +core_tv_bndr : tv_name DCOLON akind { UfTyBinder $1 $3 } + | tv_name { UfTyBinder $1 mkTypeKind } + +core_tv_bndrs :: { [UfBinder RdrName] } +core_tv_bndrs : { [] } + | core_tv_bndr core_tv_bndrs { $1 : $2 } + +ccall_string :: { FAST_STRING } + : STRING { $1 } + | VARID { $1 } + | CONID { $1 } + +prim_rep :: { Char } + : VARID { head (_UNPK_ $1) } + | CONID { head (_UNPK_ $1) + +---variable names----------------------------------------------------- + } +var_occ :: { OccName } +var_occ : VARID { VarOcc $1 } + | VARSYM { VarOcc $1 } + | BANG { VarOcc SLIT("!") {-sigh, double-sigh-} } + +qdata_name :: { RdrName } +qdata_name : QCONID { varQual $1 } + | QCONSYM { varQual $1 } + +qvar_name :: { RdrName } + : QVARID { varQual $1 } + | QVARSYM { varQual $1 } + +var_name :: { RdrName } +var_name : var_occ { Unqual $1 } + +any_var_name :: {RdrName} +any_var_name : var_name { $1 } + | qvar_name { $1 } + +var_names :: { [RdrName] } +var_names : { [] } + | var_name var_names { $1 : $2 + +--productions-for-types-------------------------------- + } +forall : OBRACK tv_bndrs CBRACK { $2 } + +context :: { RdrNameContext } +context : { [] } + | OCURLY context_list1 CCURLY { $2 } + +context_list1 :: { RdrNameContext } +context_list1 : class { [$1] } + | class COMMA context_list1 { $1 : $3 } + +class :: { (RdrName, RdrNameHsType) } +class : qtc_name atype { ($1, $2) } + +type :: { RdrNameHsType } +type : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 } + | tautype { $1 } + +tautype :: { RdrNameHsType } +tautype : btype { $1 } + | btype RARROW tautype { MonoFunTy $1 $3 } + +types2 :: { [RdrNameHsType] {- Two or more -} } +types2 : type COMMA type { [$1,$3] } + | type COMMA types2 { $1 : $3 } + +btype :: { RdrNameHsType } +btype : atype { $1 } + | btype atype { MonoTyApp $1 $2 } + +atype :: { RdrNameHsType } +atype : qtc_name { MonoTyVar $1 } + | tv_name { MonoTyVar $1 } + | OPAREN types2 CPAREN { MonoTupleTy dummyRdrTcName $2 } + | OBRACK type CBRACK { MonoListTy dummyRdrTcName $2 } + | OCURLY qtc_name atype CCURLY { MonoDictTy $2 $3 } + | OPAREN type CPAREN { $2 } + +atypes :: { [RdrNameHsType] {- Zero or more -} } +atypes : { [] } + | atype atypes { $1 : $2 +--------------------------------------------------------------------- + } + +tv_bndr :: { HsTyVar RdrName } +tv_bndr : tv_name DCOLON akind { IfaceTyVar $1 $3 } + | tv_name { UserTyVar $1 } + +tv_bndrs :: { [HsTyVar RdrName] } + : { [] } + | tv_bndr tv_bndrs { $1 : $2 } + +kind :: { Kind } + : akind { $1 } + | akind RARROW kind { mkArrowKind $1 $3 } + +akind :: { Kind } + : VARSYM { mkTypeKind {- ToDo: check that it's "*" -} } + | OPAREN kind CPAREN { $2 } + +tv_name :: { RdrName } +tv_name : VARID { Unqual (TvOcc $1) } + +tv_names :: { [RdrName] } + : { [] } + | tv_name tv_names { $1 : $2 } +qtc_name :: { RdrName } +qtc_name : QCONID { tcQual $1 } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index d66596bc3f..81059c201e 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -21,8 +21,8 @@ import CmdLineOpts ( opt_HiMap ) import RnMonad import RnNames ( getGlobalNames ) import RnSource ( rnDecl ) -import RnIfaces ( getImportedInstDecls, getDecl, getImportVersions, getSpecialInstModules, - mkSearchPath, getWiredInDecl +import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, getSpecialInstModules, + mkSearchPath ) import RnEnv ( availsToNameSet, addAvailToNameSet, addImplicitOccsRn, lookupImplicitOccRn ) @@ -81,34 +81,11 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_ ) `thenRn` \ rn_local_decls -> -- SLURP IN ALL THE NEEDED DECLARATIONS - -- Notice that the rnEnv starts empty - closeDecls rn_local_decls (availsToNameSet local_avails) [] - `thenRn` \ (rn_all_decls1, all_names1, imp_avails1) -> - - -- SLURP IN ALL NEEDED INSTANCE DECLARATIONS - -- We extract instance decls that only mention things (type constructors, classes) that are - -- already imported. Those that don't can't possibly be useful to us. - -- - -- We do another closeDecls, so that we can slurp info for the dictionary functions - -- for the instance declaration. These are *not* optional because the version number on - -- the dfun acts as the version number for the instance declaration itself; if the - -- instance decl changes, so will its dfun version number. - getImportedInstDecls `thenRn` \ imported_insts -> - let - all_big_names = mkNameSet [name | Avail name _ <- local_avails] `unionNameSets` - mkNameSet [name | Avail name _ <- imp_avails1] - - rn_needed_insts = [ initRnMS emptyRnEnv mod_name InterfaceMode (rnDecl (InstD inst_decl)) - | (inst_names, mod_name, inst_decl) <- imported_insts, - all (`elemNameSet` all_big_names) inst_names - ] - in - sequenceRn rn_needed_insts `thenRn` \ inst_decls -> - closeDecls rn_all_decls1 all_names1 imp_avails1 `thenRn` \ (rn_all_decls2, all_names2, imp_avails2) -> + closeDecls rn_local_decls `thenRn` \ rn_all_decls -> -- GENERATE THE VERSION/USAGE INFO - getImportVersions imp_avails2 `thenRn` \ import_versions -> + getImportVersions mod_name exports `thenRn` \ import_versions -> getNameSupplyRn `thenRn` \ name_supply -> @@ -133,7 +110,7 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_ renamed_module = HsModule mod_name vers trashed_exports trashed_imports trashed_fixities - (inst_decls ++ rn_all_decls2) + rn_all_decls loc in returnRn (Just (renamed_module, @@ -169,62 +146,56 @@ addImplicits mod_name \begin{code} closeDecls :: [RenamedHsDecl] -- Declarations got so far - -> NameSet -- Names bound by those declarations - -> [AvailInfo] -- Available stuff generated by closeDecls so far - -> RnMG ([RenamedHsDecl], -- input + extra decls slurped - NameSet, -- input + names bound by extra decls - [AvailInfo]) -- input + extra avails from extra decls + -> RnMG [RenamedHsDecl] -- input + extra decls slurped -- The monad includes a list of possibly-unresolved Names -- This list is empty when closeDecls returns -closeDecls decls decl_names import_avails +closeDecls decls = popOccurrenceName `thenRn` \ maybe_unresolved -> - case maybe_unresolved of - -- No more unresolved names; we're done - Nothing -> returnRn (decls, decl_names, import_avails) - - -- An "unresolved" name that we've already dealt with - Just (name,_) | name `elemNameSet` decl_names - -> closeDecls decls decl_names import_avails + -- No more unresolved names + Nothing -> -- Slurp instance declarations + getImportedInstDecls `thenRn` \ inst_decls -> + traceRn (ppSep [ppPStr SLIT("Slurped"), ppInt (length inst_decls), ppPStr SLIT("instance decls")]) + `thenRn_` + + -- None? then at last we are done + if null inst_decls then + returnRn decls + else + mapRn rn_inst_decl inst_decls `thenRn` \ new_inst_decls -> + + -- We *must* loop again here. Why? Two reasons: + -- (a) an instance decl will give rise to an unresolved dfun, whose + -- decl we must slurp to get its version number; that's the version + -- number for the whole instance decl. + -- (b) an instance decl might give rise to a new unresolved class, + -- whose decl we must slurp, which might let in some new instance decls, + -- and so on. Example: instance Foo a => Baz [a] where ... - -- An unresolved name that's wired in. In this case there's no - -- declaration to get, but we still want to record it as now available, - -- so that we remember to look for instance declarations involving it. - Just (name,_) | isWiredInName name - -> getWiredInDecl name `thenRn` \ decl_avail -> - closeDecls decls - (addAvailToNameSet decl_names decl_avail) - (decl_avail : import_avails) - - -- Genuinely unresolved name - Just (name,necessity) | otherwise - -> getDecl name `thenRn` \ (decl_avail,new_decl) -> - case decl_avail of - - -- Can't find the declaration; check that it was optional - NotAvailable -> case necessity of { - Optional -> addWarnRn (getDeclWarn name); - other -> addErrRn (getDeclErr name) - } `thenRn_` - closeDecls decls decl_names import_avails - - -- Found it - other -> initRnMS emptyRnEnv mod_name InterfaceMode ( - rnDecl new_decl - ) `thenRn` \ rn_decl -> - closeDecls (rn_decl : decls) - (addAvailToNameSet decl_names decl_avail) - (decl_avail : import_avails) + closeDecls (new_inst_decls ++ decls) + + -- An unresolved name + Just (name,necessity) + -> -- Slurp its declaration, if any +-- traceRn (ppSep [ppPStr SLIT("Considering"), ppr PprDebug name]) `thenRn_` + importDecl name necessity `thenRn` \ maybe_decl -> + case maybe_decl of + + -- No declaration... (wired in thing or optional) + Nothing -> closeDecls decls + + -- Found a declaration... rename it + Just decl -> rn_iface_decl mod_name decl `thenRn` \ new_decl -> + closeDecls (new_decl : decls) where (mod_name,_) = modAndOcc name + where + -- Notice that the rnEnv starts empty + rn_iface_decl mod_name decl = initRnMS emptyRnEnv mod_name InterfaceMode (rnDecl decl) + rn_inst_decl (mod_name,decl) = rn_iface_decl mod_name (InstD decl) -getDeclErr name sty - = ppSep [ppStr "Failed to find interface decl for", ppr sty name] - -getDeclWarn name sty - = ppSep [ppStr "Warning: failed to find (optional) interface decl for", ppr sty name] \end{code} diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index d4df584c22..d5183aed30 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -26,7 +26,7 @@ import RdrHsSyn import RnHsSyn import RnMonad import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch ) -import RnEnv ( bindLocatedLocalsRn, lookupRn, lookupOccRn, isUnboundName ) +import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, isUnboundName ) import CmdLineOpts ( opt_SigsRequired ) import Digraph ( stronglyConnComp ) @@ -174,7 +174,7 @@ rnTopMonoBinds EmptyMonoBinds sigs = returnRn EmptyBinds rnTopMonoBinds mbinds sigs - = mapRn lookupRn binder_rdr_names `thenRn` \ binder_names -> + = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names -> let binder_set = mkNameSet binder_names in @@ -312,7 +312,7 @@ flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn) flattenMonoBinds uniq sigs (FunMonoBind name inf matches locn) = pushSrcLocRn locn $ mapRn (checkPrecMatch inf name) matches `thenRn_` - lookupRn name `thenRn` \ name' -> + lookupBndrRn name `thenRn` \ name' -> mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) -> let fvs = unionManyNameSets fv_lists @@ -346,13 +346,13 @@ rnMethodBinds (AndMonoBinds mb1 mb2) rnMethodBinds (FunMonoBind occname inf matches locn) = pushSrcLocRn locn $ mapRn (checkPrecMatch inf occname) matches `thenRn_` - lookupRn occname `thenRn` \ op_name -> + lookupBndrRn occname `thenRn` \ op_name -> mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) -> returnRn (FunMonoBind op_name inf new_matches locn) rnMethodBinds (PatMonoBind (VarPatIn occname) grhss_and_binds locn) = pushSrcLocRn locn $ - lookupRn occname `thenRn` \ op_name -> + lookupBndrRn occname `thenRn` \ op_name -> rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', _) -> returnRn (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn) @@ -503,13 +503,13 @@ rnBindSigs is_toplev binders sigs renameSig (Sig v ty src_loc) = pushSrcLocRn src_loc $ - lookupRn v `thenRn` \ new_v -> + lookupBndrRn v `thenRn` \ new_v -> rnHsType ty `thenRn` \ new_ty -> returnRn (Sig new_v new_ty src_loc) renameSig (SpecSig v ty using src_loc) = pushSrcLocRn src_loc $ - lookupRn v `thenRn` \ new_v -> + lookupBndrRn v `thenRn` \ new_v -> rnHsType ty `thenRn` \ new_ty -> rn_using using `thenRn` \ new_using -> returnRn (SpecSig new_v new_ty new_using src_loc) @@ -520,17 +520,17 @@ renameSig (SpecSig v ty using src_loc) renameSig (InlineSig v src_loc) = pushSrcLocRn src_loc $ - lookupRn v `thenRn` \ new_v -> + lookupBndrRn v `thenRn` \ new_v -> returnRn (InlineSig new_v src_loc) renameSig (DeforestSig v src_loc) = pushSrcLocRn src_loc $ - lookupRn v `thenRn` \ new_v -> + lookupBndrRn v `thenRn` \ new_v -> returnRn (DeforestSig new_v src_loc) renameSig (MagicUnfoldingSig v str src_loc) = pushSrcLocRn src_loc $ - lookupRn v `thenRn` \ new_v -> + lookupBndrRn v `thenRn` \ new_v -> returnRn (MagicUnfoldingSig new_v str src_loc) \end{code} @@ -573,29 +573,29 @@ sig_name (MagicUnfoldingSig n _ _) = n \begin{code} dupSigDeclErr (sig:sigs) = pushSrcLocRn loc $ - addErrRn (\sty -> ppSep [ppStr "more than one", - ppStr what_it_is, ppStr "given for", - ppQuote (ppr sty (sig_name sig))]) + addErrRn (\sty -> ppSep [ppPStr SLIT("more than one"), + ppPStr what_it_is, ppPStr SLIT("given for"), + ppQuote (ppr sty (sig_name sig))]) where (what_it_is, loc) = sig_doc sig unknownSigErr sig = pushSrcLocRn loc $ - addErrRn (\sty -> ppSep [ppStr flavour, ppStr "but no definition for", + addErrRn (\sty -> ppSep [ppPStr flavour, ppPStr SLIT("but no definition for"), ppQuote (ppr sty (sig_name sig))]) where (flavour, loc) = sig_doc sig -sig_doc (Sig _ _ loc) = ("type signature",loc) -sig_doc (ClassOpSig _ _ _ loc) = ("class-method type signature", loc) -sig_doc (SpecSig _ _ _ loc) = ("SPECIALIZE pragma",loc) -sig_doc (InlineSig _ loc) = ("INLINE pragma",loc) -sig_doc (MagicUnfoldingSig _ _ loc) = ("MAGIC_UNFOLDING pragma",loc) +sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc) +sig_doc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc) +sig_doc (SpecSig _ _ _ loc) = (SLIT("SPECIALIZE pragma"),loc) +sig_doc (InlineSig _ loc) = (SLIT("INLINE pragma"),loc) +sig_doc (MagicUnfoldingSig _ _ loc) = (SLIT("MAGIC_UNFOLDING pragma"),loc) missingSigErr var sty - = ppSep [ppStr "a definition but no type signature for", ppQuote (ppr sty var)] + = ppSep [ppPStr SLIT("a definition but no type signature for"), ppQuote (ppr sty var)] methodBindErr mbind sty - = ppHang (ppStr "Can't handle multiple methods defined by one pattern binding") + = ppHang (ppPStr SLIT("Can't handle multiple methods defined by one pattern binding")) 4 (ppr sty mbind) \end{code} diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index da4fed92c0..1b348bccc1 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -10,18 +10,18 @@ module RnEnv where -- Export everything IMP_Ubiq() -import CmdLineOpts ( opt_WarnNameShadowing, opt_IgnoreIfacePragmas ) +import CmdLineOpts ( opt_WarnNameShadowing ) import HsSyn import RdrHsSyn ( RdrName(..), SYN_IE(RdrNameIE), - rdrNameOcc, isQual, qual + rdrNameOcc, ieOcc, isQual, qual ) import HsTypes ( getTyVarName, replaceTyVarName ) import RnMonad import Name ( Name, OccName(..), Provenance(..), DefnInfo(..), ExportFlag(..), occNameString, occNameFlavour, SYN_IE(NameSet), emptyNameSet, addListToNameSet, - mkLocalName, mkGlobalName, modAndOcc, - isLocalName, isWiredInName, nameOccName, setNameProvenance, + mkLocalName, mkGlobalName, modAndOcc, isLocallyDefinedName, + isWiredInName, nameOccName, setNameProvenance, isVarOcc, pprProvenance, pprOccName, pprModule, pprNonSymOcc, pprNameProvenance ) import TyCon ( TyCon ) @@ -49,7 +49,8 @@ newGlobalName :: Module -> OccName -> RnM s d Name newGlobalName mod occ = -- First check the cache getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> - case lookupFM cache (mod,occ) of + let key = (mod,occ) in + case lookupFM cache key of -- A hit in the cache! Return it, but change the src loc -- of the thing we've found if this is a second definition site @@ -63,7 +64,7 @@ newGlobalName mod occ (us', us1) = splitUniqSupply us uniq = getUnique us1 name = mkGlobalName uniq mod occ VanillaDefn Implicit - cache' = addToFM cache (mod,occ) name + cache' = addToFM cache key name in setNameSupplyRn (us', inst_ns, cache') `thenRn_` returnRn name @@ -86,28 +87,50 @@ newLocallyDefinedGlobalName mod occ rec_exp_fn loc provenance = LocalDef (rec_exp_fn new_name) loc (us', us1) = splitUniqSupply us uniq = getUnique us1 - new_name = case lookupFM cache (mod,occ) of - Just name -> setNameProvenance name provenance - Nothing -> mkGlobalName uniq mod occ VanillaDefn provenance - cache' = addToFM cache (mod,occ) new_name + key = (mod,occ) + new_name = case lookupFM cache key of + Just name -> setNameProvenance name provenance + Nothing -> mkGlobalName uniq mod occ VanillaDefn provenance + new_cache = addToFM cache key new_name in - setNameSupplyRn (us', inst_ns, cache') `thenRn_` + setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` returnRn new_name --- newDfunName is used to allocate a name for the dictionary function for --- a local instance declaration. No need to put it in the cache (I think!). -newDfunName :: SrcLoc -> RnMS s Name -newDfunName src_loc - = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> - getModuleRn `thenRn` \ mod_name -> +-- newSysName is used to create the names for +-- a) default methods +-- These are never mentioned explicitly in source code (hence no point in looking +-- them up in the NameEnv), but when reading an interface file +-- we may want to slurp in their pragma info. In the source file itself we +-- need to create these names too so that we export them into the inferface file for this module. + +newSysName :: OccName -> ExportFlag -> SrcLoc -> RnMS s Name +newSysName occ export_flag loc + = getModeRn `thenRn` \ mode -> + getModuleRn `thenRn` \ mod_name -> + case mode of + SourceMode -> newLocallyDefinedGlobalName + mod_name occ + (\_ -> export_flag) + loc + InterfaceMode -> newGlobalName mod_name occ + +-- newDfunName is a variant, specially for dfuns. +-- When renaming derived definitions we are in *interface* mode (because we can trip +-- over original names), but we still want to make the Dfun locally-defined. +-- So we can't use whether or not we're in source mode to decide the locally-defined question. +newDfunName :: Maybe RdrName -> SrcLoc -> RnMS s Name +newDfunName Nothing src_loc -- Local instance decls have a "Nothing" + = getModuleRn `thenRn` \ mod_name -> + newInstUniq `thenRn` \ inst_uniq -> let - (us', us1) = splitUniqSupply us - uniq = getUnique us1 - dfun_name = mkGlobalName uniq mod_name (VarOcc (_PK_ ("df" ++ show inst_ns))) - VanillaDefn (LocalDef Exported src_loc) - in - setNameSupplyRn (us', inst_ns+1, cache) `thenRn_` - returnRn dfun_name + dfun_occ = VarOcc (_PK_ ("$d" ++ show inst_uniq)) + in + newLocallyDefinedGlobalName mod_name dfun_occ + (\_ -> Exported) src_loc + +newDfunName (Just n) src_loc -- Imported ones have "Just n" + = getModuleRn `thenRn` \ mod_name -> + newGlobalName mod_name (rdrNameOcc n) newLocalNames :: [(RdrName,SrcLoc)] -> RnM s d [Name] @@ -189,10 +212,9 @@ bindTyVarsRn doc_str tyvar_names enclosed_scope Looking up a name in the RnEnv. \begin{code} -lookupRn :: RdrName -> RnMS s Name -lookupRn rdr_name - = getNameEnv `thenRn` \ name_env -> - case lookupFM name_env rdr_name of +lookupRn :: NameEnv -> RdrName -> RnMS s Name +lookupRn name_env rdr_name + = case lookupFM name_env rdr_name of -- Found it! Just name -> returnRn name @@ -218,31 +240,37 @@ lookupRn rdr_name newGlobalName mod_name occ +lookupBndrRn rdr_name + = getNameEnv `thenRn` \ name_env -> + lookupRn name_env rdr_name + -- Just like lookupRn except that we record the occurrence too -- Perhaps surprisingly, even wired-in names are recorded. -- Why? So that we know which wired-in names are referred to when -- deciding which instance declarations to import. lookupOccRn :: RdrName -> RnMS s Name lookupOccRn rdr_name - = lookupRn rdr_name `thenRn` \ name -> - if isLocalName name then - returnRn name - else - addOccurrenceName Compulsory name `thenRn_` - returnRn name + = getNameEnv `thenRn` \ name_env -> + lookupRn name_env rdr_name `thenRn` \ name -> + addOccurrenceName Compulsory name + +-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global +-- environment. It's used for record field names only. +lookupGlobalOccRn :: RdrName -> RnMS s Name +lookupGlobalOccRn rdr_name + = getGlobalNameEnv `thenRn` \ name_env -> + lookupRn name_env rdr_name `thenRn` \ name -> + addOccurrenceName Compulsory name -- lookupOptionalOccRn is similar, but it's used in places where -- we don't *have* to find a definition for the thing. lookupOptionalOccRn :: RdrName -> RnMS s Name lookupOptionalOccRn rdr_name - = lookupRn rdr_name `thenRn` \ name -> - if opt_IgnoreIfacePragmas || isLocalName name then - -- Never look for optional things if we're - -- ignoring optional input interface information - returnRn name - else - addOccurrenceName Optional name `thenRn_` - returnRn name + = getNameEnv `thenRn` \ name_env -> + lookupRn name_env rdr_name `thenRn` \ name -> + addOccurrenceName Optional name + + -- lookupImplicitOccRn takes an RdrName representing an *original* name, and -- adds it to the occurrence pool so that it'll be loaded later. This is @@ -253,7 +281,7 @@ lookupOptionalOccRn rdr_name -- This doesn't apply in interface mode, where everything is explicit, but -- we don't check for this case: it does no harm to record an "extra" occurrence -- and lookupImplicitOccRn isn't used much in interface mode (it's only the --- Nothing clause of rnDerivs that calls it at all I think. +-- Nothing clause of rnDerivs that calls it at all I think). -- -- For List and Tuple types it's important to get the correct -- isLocallyDefined flag, which is used in turn when deciding @@ -263,10 +291,9 @@ lookupOptionalOccRn rdr_name lookupImplicitOccRn :: RdrName -> RnMS s Name lookupImplicitOccRn (Qual mod occ) = newGlobalName mod occ `thenRn` \ name -> - addOccurrenceName Compulsory name `thenRn_` - returnRn name + addOccurrenceName Compulsory name -addImplicitOccRn :: Name -> RnM s d () +addImplicitOccRn :: Name -> RnM s d Name addImplicitOccRn name = addOccurrenceName Compulsory name addImplicitOccsRn :: [Name] -> RnM s d () @@ -357,42 +384,112 @@ lookupModuleAvails = lookupFM =============== AvailInfo ================ \begin{code} -plusAvail (Avail n1 ns1) (Avail n2 ns2) = Avail n1 (nub (ns1 ++ ns2)) +plusAvail (Avail n1) (Avail n2) = Avail n1 +plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2)) plusAvail a NotAvailable = a plusAvail NotAvailable a = a addAvailToNameSet :: NameSet -> AvailInfo -> NameSet -addAvailToNameSet names NotAvailable = names -addAvailToNameSet names (Avail n ns) = addListToNameSet names (n:ns) +addAvailToNameSet names avail = addListToNameSet names (availNames avail) availsToNameSet :: [AvailInfo] -> NameSet availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails +availName :: AvailInfo -> Name +availName (Avail n) = n +availName (AvailTC n _) = n + availNames :: AvailInfo -> [Name] -availNames NotAvailable = [] -availNames (Avail n ns) = n:ns - -filterAvail :: RdrNameIE -> AvailInfo -> AvailInfo -filterAvail (IEThingWith _ wanted) NotAvailable = NotAvailable -filterAvail (IEThingWith _ wanted) (Avail n ns) - | sub_names_ok = Avail n (filter is_wanted ns) - | otherwise = NotAvailable +availNames NotAvailable = [] +availNames (Avail n) = [n] +availNames (AvailTC n ns) = ns + +-- availEntityNames is used to extract the names that can appear on their own in +-- an export or import list. For class decls, class methods can appear on their +-- own, thus import A( op ) +-- but constructors cannot; thus +-- import B( T ) +-- means import type T from B, not constructor T. + +availEntityNames :: AvailInfo -> [Name] +availEntityNames NotAvailable = [] +availEntityNames (Avail n) = [n] +availEntityNames (AvailTC n ns) = n : filter (isVarOcc . nameOccName) ns + +filterAvail :: RdrNameIE -- Wanted + -> AvailInfo -- Available + -> AvailInfo -- Resulting available; + -- NotAvailable if wanted stuff isn't there + +filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns) + | sub_names_ok = AvailTC n (filter is_wanted ns) + | otherwise = pprTrace "filterAvail" (ppCat [ppr PprDebug ie, pprAvail PprDebug avail]) $ + NotAvailable where is_wanted name = nameOccName name `elem` wanted_occs sub_names_ok = all (`elem` avail_occs) wanted_occs - wanted_occs = map rdrNameOcc wanted avail_occs = map nameOccName ns + wanted_occs = map rdrNameOcc (want:wants) + +filterAvail (IEThingAbs _) (AvailTC n ns) + | n `elem` ns = AvailTC n [n] + +filterAvail (IEThingAbs _) avail@(Avail n) = avail -- Type synonyms + +filterAvail (IEVar _) avail@(Avail n) = avail +filterAvail (IEVar v) avail@(AvailTC n ns) = AvailTC n (filter wanted ns) + where + wanted n = nameOccName n == occ + occ = rdrNameOcc v + -- The second equation happens if we import a class op, thus + -- import A( op ) + -- where op is a class operation + +filterAvail (IEThingAll _) avail@(AvailTC _ _) = avail + +filterAvail ie avail = NotAvailable + + +hideAvail :: RdrNameIE -- Hide this + -> AvailInfo -- Available + -> AvailInfo -- Resulting available; +-- Don't complain about hiding non-existent things; that's done elsewhere + +hideAvail ie NotAvailable + = NotAvailable + +hideAvail ie (Avail n) + | not (ieOcc ie == nameOccName n) = Avail n -- No match + | otherwise = NotAvailable -- Names match + +hideAvail ie (AvailTC n ns) + | not (ieOcc ie == nameOccName n) -- No match + = case ie of -- But in case we are faced with ...hiding( (+) ) + -- we filter the "ns" anyhow + IEVar op -> AvailTC n (filter keep ns) + where + op_occ = rdrNameOcc op + keep n = nameOccName n /= op_occ + + other -> AvailTC n ns + | otherwise -- Names match + = case ie of + IEThingAbs _ -> AvailTC n (filter (/= n) ns) + IEThingAll _ -> NotAvailable + IEThingWith hide hides -> AvailTC n (filter keep ns) + where + keep n = nameOccName n `notElem` hide_occs + hide_occs = map rdrNameOcc (hide : hides) -filterAvail (IEThingAll _) avail = avail -filterAvail ie (Avail n ns) = Avail n [] -- IEThingAbs and IEVar -- pprAvail gets given the OccName of the "host" thing -pprAvail sty NotAvailable = ppStr "NotAvailable" -pprAvail sty (Avail n ns) = ppCat [pprOccName sty (nameOccName n), - ppStr "(", - ppInterleave ppComma (map (pprOccName sty.nameOccName) ns), - ppStr ")"] +pprAvail sty NotAvailable = ppPStr SLIT("NotAvailable") +pprAvail sty (AvailTC n ns) = ppCat [pprOccName sty (nameOccName n), + ppChar '(', + ppInterleave ppComma (map (pprOccName sty.nameOccName) ns), + ppChar ')'] +pprAvail sty (Avail n) = pprOccName sty (nameOccName n) \end{code} @@ -436,33 +533,35 @@ conflictFM bad fm key elt \begin{code} nameClashErr (rdr_name, (name1,name2)) sty - = ppHang (ppCat [ppStr "Conflicting definitions for: ", ppr sty rdr_name]) + = ppHang (ppCat [ppPStr SLIT("Conflicting definitions for: "), ppr sty rdr_name]) 4 (ppAboves [pprNameProvenance sty name1, pprNameProvenance sty name2]) fixityClashErr (rdr_name, (fp1,fp2)) sty - = ppHang (ppCat [ppStr "Conflicting fixities for: ", ppr sty rdr_name]) + = ppHang (ppCat [ppPStr SLIT("Conflicting fixities for: "), ppr sty rdr_name]) 4 (ppAboves [pprFixityProvenance sty fp1, pprFixityProvenance sty fp2]) shadowedNameWarn shadow sty - = ppBesides [ppStr "More than one value with the same name (shadowing): ", ppr sty shadow] + = ppBesides [ppPStr SLIT("This binding for"), + ppQuote (ppr sty shadow), + ppPStr SLIT("shadows an existing binding")] unknownNameErr name sty - = ppSep [ppStr flavour, ppStr "not in scope:", ppr sty name] + = ppSep [ppStr flavour, ppPStr SLIT("not in scope:"), ppr sty name] where flavour = occNameFlavour (rdrNameOcc name) qualNameErr descriptor (name,loc) = pushSrcLocRn loc $ - addErrRn (\sty -> ppBesides [ppStr "invalid use of qualified ", - ppStr descriptor, ppStr ": ", + addErrRn (\sty -> ppBesides [ppPStr SLIT("invalid use of qualified "), + ppStr descriptor, ppPStr SLIT(": "), pprNonSymOcc sty (rdrNameOcc name) ]) dupNamesErr descriptor ((name,loc) : dup_things) = pushSrcLocRn loc $ - addErrRn (\sty -> ppBesides [ppStr "duplicate bindings of `", - ppr sty name, ppStr "' in ", + addErrRn (\sty -> ppBesides [ppPStr SLIT("duplicate bindings of `"), + ppr sty name, ppPStr SLIT("' in "), ppStr descriptor]) \end{code} diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 73b1c44692..e1e6fe23db 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -26,16 +26,18 @@ import RnHsSyn import RnMonad import RnEnv import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR, - creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR, + creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR, ordClass_RDR, negate_RDR ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) import TyCon ( TyCon ) +import Id ( GenId ) import ErrUtils ( addErrLoc, addShortErrLocLine ) import Name import Pretty +import Unique ( Unique, otherwiseIdKey ) import UniqFM ( lookupUFM{-, ufmToList ToDo:rm-} ) import UniqSet ( emptyUniqSet, unitUniqSet, unionUniqSets, unionManyUniqSets, @@ -58,7 +60,7 @@ rnPat :: RdrNamePat -> RnMS s RenamedPat rnPat WildPatIn = returnRn WildPatIn rnPat (VarPatIn name) - = lookupRn name `thenRn` \ vname -> + = lookupBndrRn name `thenRn` \ vname -> returnRn (VarPatIn vname) rnPat (LitPatIn lit) @@ -72,17 +74,17 @@ rnPat (LazyPatIn pat) rnPat (AsPatIn name pat) = rnPat pat `thenRn` \ pat' -> - lookupRn name `thenRn` \ vname -> + lookupBndrRn name `thenRn` \ vname -> returnRn (AsPatIn vname pat') rnPat (ConPatIn con pats) - = lookupRn con `thenRn` \ con' -> + = lookupOccRn con `thenRn` \ con' -> mapRn rnPat pats `thenRn` \ patslist -> returnRn (ConPatIn con' patslist) rnPat (ConOpPatIn pat1 con _ pat2) = rnPat pat1 `thenRn` \ pat1' -> - lookupRn con `thenRn` \ con' -> + lookupOccRn con `thenRn` \ con' -> lookupFixity con `thenRn` \ fixity -> rnPat pat2 `thenRn` \ pat2' -> mkConOpPatRn pat1' con' fixity pat2' @@ -105,6 +107,12 @@ rnPat (ParPatIn pat) = rnPat pat `thenRn` \ pat' -> returnRn (ParPatIn pat') +rnPat (NPlusKPatIn name lit) + = litOccurrence lit `thenRn_` + lookupImplicitOccRn ordClass_RDR `thenRn_` + lookupBndrRn name `thenRn` \ name' -> + returnRn (NPlusKPatIn name' lit) + rnPat (ListPatIn pats) = addImplicitOccRn listType_name `thenRn_` mapRn rnPat pats `thenRn` \ patslist -> @@ -116,7 +124,7 @@ rnPat (TuplePatIn pats) returnRn (TuplePatIn patslist) rnPat (RecPatIn con rpats) - = lookupRn con `thenRn` \ con' -> + = lookupOccRn con `thenRn` \ con' -> rnRpats rpats `thenRn` \ rpats' -> returnRn (RecPatIn con' rpats') \end{code} @@ -168,7 +176,15 @@ rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds) = pushSrcLocRn locn $ rnExpr guard `thenRn` \ (guard', fvsg) -> rnExpr expr `thenRn` \ (expr', fvse) -> - returnRn (GRHS guard' expr' locn, fvsg `unionNameSets` fvse) + + -- Turn an "otherwise" guard into an OtherwiseGRHS. + -- This is the first moment that we can be sure we havn't got a shadowed binding + -- of "otherwise". + let grhs' = case guard' of + HsVar v | uniqueOf v == otherwiseIdKey -> OtherwiseGRHS expr' locn + other -> GRHS guard' expr' locn + in + returnRn (grhs', fvsg `unionNameSets` fvse) rnGRHS (OtherwiseGRHS expr locn) = pushSrcLocRn locn $ @@ -184,13 +200,15 @@ rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds) \begin{code} rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars) - -rnExprs [] = returnRn ([], emptyNameSet) - -rnExprs (expr:exprs) - = rnExpr expr `thenRn` \ (expr', fvExpr) -> - rnExprs exprs `thenRn` \ (exprs', fvExprs) -> - returnRn (expr':exprs', fvExpr `unionNameSets` fvExprs) +rnExprs ls = + rnExprs' ls [] `thenRn` \ (exprs, fvExprs) -> + returnRn (exprs, unionManyNameSets fvExprs) + +rnExprs' [] acc = returnRn ([], acc) +rnExprs' (expr:exprs) acc + = rnExpr expr `thenRn` \ (expr', fvExpr) -> + rnExprs' exprs (fvExpr:acc) `thenRn` \ (exprs', fvExprs) -> + returnRn (expr':exprs', fvExprs) \end{code} Variables. We look up the variable and return the resulting name. The @@ -280,16 +298,11 @@ rnExpr (HsLet binds expr) rnExpr expr `thenRn` \ (expr',fvExpr) -> returnRn (HsLet binds' expr', fvExpr) -rnExpr (HsDo stmts src_loc) +rnExpr (HsDo do_or_lc stmts src_loc) = pushSrcLocRn src_loc $ lookupImplicitOccRn monadZeroClass_RDR `thenRn_` -- Forces Monad to come too rnStmts stmts `thenRn` \ (stmts', fvStmts) -> - returnRn (HsDo stmts' src_loc, fvStmts) - -rnExpr (ListComp expr quals) - = addImplicitOccRn listType_name `thenRn_` - rnQuals expr quals `thenRn` \ ((expr', quals'), fvs) -> - returnRn (ListComp expr' quals', fvs) + returnRn (HsDo do_or_lc stmts' src_loc, fvStmts) rnExpr (ExplicitList exps) = addImplicitOccRn listType_name `thenRn_` @@ -367,7 +380,7 @@ rnRbinds str rbinds field_dup_err dups = addErrRn (dupFieldErr str dups) rn_rbind (field, expr, pun) - = lookupOccRn field `thenRn` \ fieldname -> + = lookupGlobalOccRn field `thenRn` \ fieldname -> rnExpr expr `thenRn` \ (expr', fvExpr) -> returnRn ((fieldname, expr', pun), fvExpr) @@ -380,14 +393,14 @@ rnRpats rpats field_dup_err dups = addErrRn (dupFieldErr "pattern" dups) rn_rpat (field, pat, pun) - = lookupOccRn field `thenRn` \ fieldname -> + = lookupGlobalOccRn field `thenRn` \ fieldname -> rnPat pat `thenRn` \ pat' -> returnRn (fieldname, pat', pun) \end{code} %************************************************************************ %* * -\subsubsection{@Qualifier@s: in list comprehensions} +\subsubsection{@Stmt@s: in @do@ expressions} %* * %************************************************************************ @@ -399,60 +412,10 @@ be @{r}@, and the free var set for the entire Quals will be @{r}@. This @r@ will be removed only when we finally return from examining all the Quals. -\begin{code} -rnQuals :: RdrNameHsExpr -> [RdrNameQual] - -> RnMS s ((RenamedHsExpr, [RenamedQual]), FreeVars) - -rnQuals expr [qual] -- must be at least one qual - = rnQual qual $ \ new_qual -> - rnExpr expr `thenRn` \ (expr', fvs) -> - returnRn ((expr', [new_qual]), fvs) - -rnQuals expr (qual: quals) - = rnQual qual $ \ qual' -> - rnQuals expr quals `thenRn` \ ((expr', quals'), fv_quals) -> - returnRn ((expr', qual' : quals'), fv_quals) - - --- rnQual :: RdrNameQual --- -> (RenamedQual -> RnMS s (a,FreeVars)) --- -> RnMS s (a,FreeVars) --- Because of mutual recursion the actual type is a bit less general than this [Haskell 1.2] - -rnQual (GeneratorQual pat expr) thing_inside - = rnExpr expr `thenRn` \ (expr', fv_expr) -> - bindLocalsRn "pattern in list comprehension" binders $ \ new_binders -> - rnPat pat `thenRn` \ pat' -> - - thing_inside (GeneratorQual pat' expr') `thenRn` \ (result, fvs) -> - returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders)) - where - binders = collectPatBinders pat - -rnQual (FilterQual expr) thing_inside - = rnExpr expr `thenRn` \ (expr', fv_expr) -> - thing_inside (FilterQual expr') `thenRn` \ (result, fvs) -> - returnRn (result, fv_expr `unionNameSets` fvs) - -rnQual (LetQual binds) thing_inside - = rnBinds binds $ \ binds' -> - thing_inside (LetQual binds') -\end{code} - - -%************************************************************************ -%* * -\subsubsection{@Stmt@s: in @do@ expressions} -%* * -%************************************************************************ - \begin{code} rnStmts :: [RdrNameStmt] -> RnMS s ([RenamedStmt], FreeVars) -rnStmts [stmt@(ExprStmt expr src_loc)] -- last stmt must be ExprStmt - = pushSrcLocRn src_loc $ - rnExpr expr `thenRn` \ (expr', fv_expr) -> - returnRn ([ExprStmt expr' src_loc], fv_expr) +rnStmts [] = returnRn ([], emptyNameSet) rnStmts (stmt:stmts) = rnStmt stmt $ \ stmt' -> @@ -480,6 +443,17 @@ rnStmt (ExprStmt expr src_loc) thing_inside thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) -> returnRn (result, fv_expr `unionNameSets` fvs) +rnStmt (GuardStmt expr src_loc) thing_inside + = pushSrcLocRn src_loc $ + rnExpr expr `thenRn` \ (expr', fv_expr) -> + thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) -> + returnRn (result, fv_expr `unionNameSets` fvs) + +rnStmt (ReturnStmt expr) thing_inside + = rnExpr expr `thenRn` \ (expr', fv_expr) -> + thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) -> + returnRn (result, fv_expr `unionNameSets` fvs) + rnStmt (LetStmt binds) thing_inside = rnBinds binds $ \ binds' -> thing_inside (LetStmt binds') @@ -663,12 +637,10 @@ litOccurrence (HsStringPrim _) = addImplicitOccRn (getName addrPrimTyCon) litOccurrence (HsInt _) - = lookupImplicitOccRn numClass_RDR `thenRn_` -- Int and Integer are forced in by Num - returnRn () + = lookupImplicitOccRn numClass_RDR -- Int and Integer are forced in by Num litOccurrence (HsFrac _) - = lookupImplicitOccRn fractionalClass_RDR `thenRn_` -- ... similarly Rational - returnRn () + = lookupImplicitOccRn fractionalClass_RDR -- ... similarly Rational litOccurrence (HsIntPrim _) = addImplicitOccRn (getName intPrimTyCon) @@ -680,8 +652,7 @@ litOccurrence (HsDoublePrim _) = addImplicitOccRn (getName doublePrimTyCon) litOccurrence (HsLitLit _) - = lookupImplicitOccRn ccallableClass_RDR `thenRn_` - returnRn () + = lookupImplicitOccRn ccallableClass_RDR \end{code} @@ -693,19 +664,23 @@ litOccurrence (HsLitLit _) \begin{code} dupFieldErr str (dup:rest) sty - = ppBesides [ppStr "duplicate field name `", ppr sty dup, ppStr "' in record ", ppStr str] + = ppBesides [ppPStr SLIT("duplicate field name `"), + ppr sty dup, + ppPStr SLIT("' in record "), ppStr str] negPatErr pat sty - = ppSep [ppStr "prefix `-' not applied to literal in pattern", ppr sty pat] + = ppSep [ppPStr SLIT("prefix `-' not applied to literal in pattern"), ppr sty pat] precParseNegPatErr op sty - = ppHang (ppStr "precedence parsing error") - 4 (ppBesides [ppStr "prefix `-' has lower precedence than ", pp_op sty op, ppStr " in pattern"]) + = ppHang (ppPStr SLIT("precedence parsing error")) + 4 (ppBesides [ppPStr SLIT("prefix `-' has lower precedence than "), + pp_op sty op, + ppPStr SLIT(" in pattern")]) precParseErr op1 op2 sty - = ppHang (ppStr "precedence parsing error") - 4 (ppBesides [ppStr "cannot mix ", pp_op sty op1, ppStr " and ", pp_op sty op2, - ppStr " in the same infix expression"]) + = ppHang (ppPStr SLIT("precedence parsing error")) + 4 (ppBesides [ppPStr SLIT("cannot mix "), pp_op sty op1, ppPStr SLIT(" and "), pp_op sty op2, + ppPStr SLIT(" in the same infix expression")]) pp_op sty (op, fix) = ppBesides [pprSym sty op, ppLparen, ppr sty fix, ppRparen] \end{code} diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index fab6dd1119..953d8add83 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -48,7 +48,6 @@ type RenamedMonoBinds = MonoBinds Fake Fake Name RenamedPat type RenamedPat = InPat Name type RenamedHsType = HsType Name type RenamedRecordBinds = HsRecordBinds Fake Fake Name RenamedPat -type RenamedQual = Qualifier Fake Fake Name RenamedPat type RenamedSig = Sig Name type RenamedSpecInstSig = SpecInstSig Name type RenamedStmt = Stmt Fake Fake Name RenamedPat diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 8b804f279b..3024b8e6b3 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -10,8 +10,8 @@ module RnIfaces ( getInterfaceExports, getImportedInstDecls, getSpecialInstModules, - getDecl, getWiredInDecl, - getImportVersions, + importDecl, recordSlurp, + getImportVersions, checkUpToDate, @@ -22,26 +22,27 @@ module RnIfaces ( IMP_Ubiq() --- import CmdLineOpts ( opt_HiSuffix ) -import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..), HsTyVar, Bind, HsExpr, Sig(..), - HsBinds(..), MonoBinds, DefaultDecl, ConDecl(..), HsType, BangType, IfaceSig(..), - FixityDecl(..), Fixity, Fake, InPat, InstDecl(..), SYN_IE(Version), HsIdInfo +import CmdLineOpts ( opt_HiSuffix, opt_HiSuffixPrelude ) +import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..), HsTyVar, Bind, HsExpr, Sig(..), HsType(..), + HsBinds(..), MonoBinds, DefaultDecl, ConDecl(..), BangType, IfaceSig(..), + FixityDecl(..), Fixity, Fake, InPat, InstDecl(..), SYN_IE(Version), HsIdInfo, + IE(..) ) import HsPragmas ( noGenPragmas ) import RdrHsSyn ( SYN_IE(RdrNameHsDecl), SYN_IE(RdrNameInstDecl), RdrName, rdrNameOcc ) -import RnEnv ( newGlobalName, lookupRn, addImplicitOccsRn, availNames ) +import RnEnv ( newGlobalName, lookupRn, addImplicitOccsRn, availName, availNames, addAvailToNameSet ) import