From 887fa59389cbe81f92fba3f0501c9aa9788f852c Mon Sep 17 00:00:00 2001 From: Don Stewart Date: Sun, 24 Apr 2005 08:51:33 +0000 Subject: [PATCH] Import hs-plugins cvs --- AUTHORS | 5 + BUILDING.CVS | 25 + LICENSE | 504 +++++ Makefile | 104 + README | 97 + TODO | 30 + VERSION | 1 + autogen.sh | 6 + config.guess | 1354 ++++++++++++ config.h.in | 21 + config.mk.in | 57 + config.sub | 1460 +++++++++++++ configure.ac | 198 ++ docs/Makefile | 31 + docs/haskell.sty | 452 +++++ docs/hs-plugins.1 | 36 + docs/hs-plugins.hdir | 1 + docs/hs-plugins.tex | 1808 +++++++++++++++++ docs/munge.sed | 17 + docs/tex2page.sty | 9 + docs/tex2page.tex | 1381 +++++++++++++ examples/README | 17 + examples/TIMINGS | 45 + examples/build.mk | 41 + examples/check.mk | 24 + examples/conf/simple/Mailrc.conf | 11 + examples/conf/simple/Mailrc.stub | 28 + examples/conf/simple/Makefile | 4 + examples/conf/simple/api/API.hs | 27 + examples/conf/simple/prog/Main.hs | 22 + examples/conf/simple/prog/expected | 1 + examples/dynload/io/Makefile | 6 + examples/dynload/io/TestIO.hs | 86 + examples/dynload/io/api/API.hs | 19 + examples/dynload/io/prog/Main.hs | 12 + examples/dynload/io/prog/expected | 1 + examples/dynload/poly/Makefile | 4 + examples/dynload/poly/Plugin.hs | 12 + examples/dynload/poly/api/API.hs | 24 + examples/dynload/poly/prog/Main.hs | 17 + examples/dynload/poly/prog/expected | 2 + examples/dynload/should_fail/Makefile | 4 + examples/dynload/should_fail/Plugin.hs | 12 + examples/dynload/should_fail/api/API.hs | 20 + examples/dynload/should_fail/prog/Main.hs | 14 + examples/dynload/should_fail/prog/expected | 4 + examples/dynload/should_fail_1/Makefile | 4 + examples/dynload/should_fail_1/Plugin.hs | 15 + examples/dynload/should_fail_1/api/API.hs | 20 + examples/dynload/should_fail_1/prog/Main.hs | 11 + examples/dynload/should_fail_1/prog/expected | 4 + examples/dynload/should_fail_2/Makefile | 4 + examples/dynload/should_fail_2/Plugin.in | 19 + examples/dynload/should_fail_2/Plugin.stub | 12 + examples/dynload/should_fail_2/api/API.hs | 22 + examples/dynload/should_fail_2/prog/Main.hs | 19 + examples/dynload/should_fail_2/prog/expected | 8 + .../dynload/should_fail_2/prog/expected.604 | 7 + examples/dynload/should_fail_3/Makefile | 4 + examples/dynload/should_fail_3/Plugin.in | 19 + examples/dynload/should_fail_3/Plugin.stub | 12 + examples/dynload/should_fail_3/api/API.hs | 22 + examples/dynload/should_fail_3/prog/Main.hs | 18 + examples/dynload/should_fail_3/prog/expected | 9 + .../dynload/should_fail_3/prog/expected.604 | 8 + examples/dynload/simple/Makefile | 4 + examples/dynload/simple/Plugin.hs | 11 + examples/dynload/simple/api/API.hs | 20 + examples/dynload/simple/prog/Main.hs | 15 + examples/dynload/simple/prog/expected | 1 + examples/eval.mk | 27 + examples/eval/eval1/Main.hs | 5 + examples/eval/eval1/Makefile | 2 + examples/eval/eval1/expected | 1 + examples/eval/eval2/Main.hs | 6 + examples/eval/eval2/Makefile | 2 + examples/eval/eval2/expected | 1 + examples/eval/eval3/Main.hs | 42 + examples/eval/eval3/Makefile | 2 + examples/eval/eval3/expected | 1 + examples/eval/eval_/Main.hs | 9 + examples/eval/eval_/Makefile | 2 + examples/eval/eval_/expected | 1 + examples/eval/eval_fn/Main.hs | 10 + examples/eval/eval_fn/Makefile | 2 + examples/eval/eval_fn/expected | 1 + examples/eval/eval_fn1/Main.hs | 15 + examples/eval/eval_fn1/Makefile | 2 + examples/eval/eval_fn1/Poly.hs | 16 + examples/eval/eval_fn1/expected | 2 + examples/eval/foreign_eval/Makefile | 2 + examples/eval/foreign_eval/README | 1 + examples/eval/foreign_eval/expected | 1 + examples/eval/foreign_eval/main.c | 16 + examples/eval/foreign_eval1/Makefile | 2 + examples/eval/foreign_eval1/expected | 1 + examples/eval/foreign_eval1/main.c | 16 + examples/eval/foreign_should_fail/Makefile | 2 + examples/eval/foreign_should_fail/expected | 2 + .../eval/foreign_should_fail/expected.604 | 1 + examples/eval/foreign_should_fail/main.c | 16 + .../foreign_should_fail_illtyped/Makefile | 2 + .../foreign_should_fail_illtyped/expected | 4 + .../foreign_should_fail_illtyped/expected.604 | 1 + .../eval/foreign_should_fail_illtyped/main.c | 16 + examples/eval/unsafeidir/Main.hs | 16 + examples/eval/unsafeidir/Makefile | 2 + examples/eval/unsafeidir/a/Extra.hs | 3 + examples/eval/unsafeidir/expected | 1 + examples/foreign.mk | 23 + examples/hier/hier1/Makefile | 8 + examples/hier/hier1/Modules/Flags.hs | 15 + examples/hier/hier1/Modules/Makefile | 6 + examples/hier/hier1/Plugin.hs | 14 + examples/hier/hier1/api/API.hs | 16 + examples/hier/hier1/prog/Main.hs | 21 + examples/hier/hier1/prog/expected | 1 + examples/hier/hier2/A/B/C/Module.hs | 8 + examples/hier/hier2/A/Makefile | 7 + examples/hier/hier2/Makefile | 7 + examples/hier/hier2/api/API.hs | 4 + examples/hier/hier2/prog/Main.hs | 15 + examples/hier/hier2/prog/expected | 1 + examples/hier/hier3/Main.hs | 25 + examples/hier/hier3/Makefile | 7 + examples/hier/hier3/One.hs | 7 + examples/hier/hier3/Two.hs | 4 + examples/hier/hier3/expected | 5 + examples/hier/hier4/A.hs | 11 + examples/hier/hier4/B.hs | 4 + examples/hier/hier4/C.hs | 12 + examples/hier/hier4/D.hs | 6 + examples/hier/hier4/Main.hs | 12 + examples/hier/hier4/Makefile | 4 + examples/hier/hier4/expected | 1 + examples/hmake/lib-plugs/Main.hs | 69 + examples/hmake/lib-plugs/Makefile | 29 + examples/hmake/lib-plugs/expected | 9 + examples/hmake/lib-plugs/test.in | 2 + examples/hmake/one-shot/Main.hs | 39 + examples/hmake/one-shot/Makefile | 30 + examples/hmake/one-shot/expected | 1 + examples/hmake/one-shot/test.in | 1 + examples/iface/null/A.hs | 1 + examples/iface/null/B.hs | 1 + examples/iface/null/Main.hs | 9 + examples/iface/null/Makefile | 2 + examples/iface/null/expected | 5 + examples/iface/null/expected.604 | 5 + examples/load/io/Makefile | 6 + examples/load/io/TestIO.hs | 84 + examples/load/io/api/API.hs | 16 + examples/load/io/prog/Main.hs | 15 + examples/load/io/prog/expected | 1 + examples/load/load_0/Makefile | 6 + examples/load/load_0/Test.hs | 6 + examples/load/load_0/api/API.hs | 8 + examples/load/load_0/prog/Main.hs | 11 + examples/load/load_0/prog/expected | 1 + examples/load/loadpkg/Main.hs | 4 + examples/load/loadpkg/Makefile | 4 + examples/load/loadpkg/expected | 0 examples/load/null/Makefile | 4 + examples/load/null/Null.hs | 11 + examples/load/null/api/API.hs | 12 + examples/load/null/prog/Main.hs | 17 + examples/load/null/prog/expected | 1 + examples/load/rawload/Main.hs | 8 + examples/load/rawload/Makefile | 6 + examples/load/rawload/t.c | 1 + examples/load/thiemann0/Makefile | 6 + examples/load/thiemann0/Test.hs | 11 + examples/load/thiemann0/api/API.hs | 8 + examples/load/thiemann0/prog/Main.hs | 16 + examples/load/thiemann0/prog/expected | 1 + examples/load/thiemann2/C.hs | 6 + examples/load/thiemann2/Makefile | 6 + examples/load/thiemann2/api/API.hs | 8 + examples/load/thiemann2/prog/A.hs | 8 + examples/load/thiemann2/prog/B.hs | 3 + examples/load/thiemann2/prog/Main.hs | 20 + examples/load/thiemann2/prog/expected | 1 + examples/load/unloadpkg/Main.hs | 6 + examples/load/unloadpkg/Makefile | 4 + examples/load/unloadpkg/expected | 0 examples/make/makeall001/A.hs | 3 + examples/make/makeall001/B.hs | 3 + examples/make/makeall001/C.hs | 3 + examples/make/makeall001/Makefile | 3 + examples/make/makeall001/Tiny.hs | 13 + examples/make/makeall001/api/API.hs | 13 + examples/make/makeall001/prog/Main.hs | 18 + examples/make/makeall001/prog/expected | 1 + examples/make/null/Makefile | 4 + examples/make/null/Null.hs | 11 + examples/make/null/api/API.hs | 12 + examples/make/null/prog/Main.hs | 13 + examples/make/null/prog/expected | 1 + examples/make/o/Makefile | 3 + examples/make/o/Plugin.hs | 7 + examples/make/o/api/API.hs | 8 + examples/make/o/prog/Main.hs | 23 + examples/make/o/prog/expected | 1 + examples/make/odir/Makefile | 3 + examples/make/odir/Plugin.hs | 7 + examples/make/odir/api/API.hs | 8 + examples/make/odir/prog/Main.hs | 16 + examples/make/odir/prog/expected | 1 + examples/make/remake001/Bar.hs | 3 + examples/make/remake001/Foo.hs | 3 + examples/make/remake001/Main.hs | 36 + examples/make/remake001/Makefile | 4 + examples/make/remake001/expected | 4 + examples/make/remake001_should_fail/Bar.hs | 3 + examples/make/remake001_should_fail/Foo.hs | 3 + examples/make/remake001_should_fail/Main.hs | 31 + examples/make/remake001_should_fail/Makefile | 4 + examples/make/remake001_should_fail/expected | 4 + examples/make/simple/Makefile | 3 + examples/make/simple/Tiny.hs | 14 + examples/make/simple/api/API.hs | 13 + examples/make/simple/prog/Main.hs | 19 + examples/make/simple/prog/expected | 1 + examples/makewith/global_pragma/Makefile | 5 + examples/makewith/global_pragma/Plugin.hs | 17 + examples/makewith/global_pragma/api/API.hs | 8 + examples/makewith/global_pragma/prog/Main.hs | 19 + examples/makewith/global_pragma/prog/expected | 1 + examples/makewith/io/Makefile | 4 + examples/makewith/io/README | 2 + examples/makewith/io/TestIO.conf | 76 + examples/makewith/io/TestIO.stub | 10 + examples/makewith/io/api/API.hs | 16 + examples/makewith/io/prog/Main.hs | 21 + examples/makewith/io/prog/expected | 1 + examples/makewith/merge00/Bar.hs | 3 + examples/makewith/merge00/Foo.hs | 4 + examples/makewith/merge00/Main.hs | 38 + examples/makewith/merge00/Makefile | 4 + examples/makewith/merge00/expected | 2 + examples/makewith/mergeto0/Bar.hs | 3 + examples/makewith/mergeto0/Foo.hs | 4 + examples/makewith/mergeto0/Main.hs | 37 + examples/makewith/mergeto0/Makefile | 4 + examples/makewith/mergeto0/expected | 3 + examples/makewith/module_name/Bar.hs | 3 + examples/makewith/module_name/Foo.hs | 4 + examples/makewith/module_name/Main.hs | 33 + examples/makewith/module_name/Makefile | 4 + examples/makewith/module_name/expected | 5 + examples/makewith/multi_make/Bar.hs | 4 + examples/makewith/multi_make/Foo.hs | 4 + examples/makewith/multi_make/Main.hs | 37 + examples/makewith/multi_make/Makefile | 4 + examples/makewith/multi_make/Stub.hs | 4 + examples/makewith/multi_make/expected | 6 + examples/makewith/should_fail_0/Makefile | 4 + examples/makewith/should_fail_0/Plugin.in | 3 + examples/makewith/should_fail_0/Plugin.stub | 6 + examples/makewith/should_fail_0/api/API.hs | 10 + examples/makewith/should_fail_0/prog/Main.hs | 19 + examples/makewith/should_fail_0/prog/expected | 1 + examples/makewith/tiny/Makefile | 5 + examples/makewith/tiny/Tiny.conf | 8 + examples/makewith/tiny/Tiny.stub | 31 + examples/makewith/tiny/api/API.hs | 13 + examples/makewith/tiny/prog/Main.hs | 21 + examples/makewith/tiny/prog/expected | 1 + examples/makewith/unsafeio/Makefile | 5 + examples/makewith/unsafeio/README | 3 + examples/makewith/unsafeio/Unsafe.conf | 17 + examples/makewith/unsafeio/Unsafe.stub | 13 + examples/makewith/unsafeio/api/API.hs | 13 + examples/makewith/unsafeio/prog/Main.hs | 20 + examples/makewith/unsafeio/prog/README | 8 + examples/makewith/unsafeio/prog/expected | 1 + examples/misc/mkstemps/Main.hs | 69 + examples/misc/mkstemps/Makefile | 2 + examples/misc/mkstemps/expected | 5 + examples/multi/3plugins/Makefile | 6 + examples/multi/3plugins/Plugin1.hs | 8 + examples/multi/3plugins/Plugin2.hs | 9 + examples/multi/3plugins/Plugin3.hs | 7 + examples/multi/3plugins/api/API.hs | 9 + examples/multi/3plugins/prog/Main.hs | 13 + examples/multi/3plugins/prog/expected | 3 + .../ArithmeticExpressionParser.hs | 30 + .../English.lproj/Credits.rtf | 29 + .../English.lproj/InfoPlist.strings | Bin 0 -> 568 bytes .../English.lproj/MainMenu.nib/classes.nib | 4 + .../English.lproj/MainMenu.nib/info.nib | 21 + .../English.lproj/MainMenu.nib/objects.nib | Bin 0 -> 5248 bytes .../English.lproj/MyDocument.nib/classes.nib | 13 + .../English.lproj/MyDocument.nib/info.nib | 16 + .../MyDocument.nib/keyedobjects.nib | Bin 0 -> 7470 bytes .../English.lproj/MyDocument.nib/objects.nib | Bin 0 -> 2952 bytes examples/objc/expression_parser/Info.plist | 47 + .../objc/expression_parser/KeyValueParser.hs | 33 + examples/objc/expression_parser/Makefile | 67 + examples/objc/expression_parser/MyDocument.h | 16 + examples/objc/expression_parser/MyDocument.m | 52 + .../objc/expression_parser/PluginEvalAux.hs | 43 + .../project.pbxproj | 602 ++++++ .../PluginExpressionParser_Prefix.pch | 7 + examples/objc/expression_parser/README | 6 + examples/objc/expression_parser/RunHaskell.h | 4 + examples/objc/expression_parser/dont_test | 0 examples/objc/expression_parser/main.m | 26 + examples/objc/expression_parser/version.plist | 16 + examples/pdynload/badint/Makefile | 5 + examples/pdynload/badint/Plugin.hs | 4 + examples/pdynload/badint/api/API.hs | 9 + examples/pdynload/badint/prog/Main.hs | 18 + examples/pdynload/badint/prog/expected | 1 + examples/pdynload/null/Makefile | 4 + examples/pdynload/null/Plugin.hs | 5 + examples/pdynload/null/api/API.hs | 5 + examples/pdynload/null/prog/Main.hs | 19 + examples/pdynload/null/prog/expected | 1 + examples/pdynload/numclass/Makefile | 4 + examples/pdynload/numclass/Plugin.hs | 5 + examples/pdynload/numclass/api/API.hs | 5 + examples/pdynload/numclass/prog/Main.hs | 19 + examples/pdynload/numclass/prog/expected | 1 + examples/pdynload/poly/Makefile | 5 + examples/pdynload/poly/Plugin.hs | 9 + examples/pdynload/poly/api/API.hs | 12 + examples/pdynload/poly/prog/Main.hs | 17 + examples/pdynload/poly/prog/expected | 1 + examples/pdynload/poly1/Makefile | 4 + examples/pdynload/poly1/Plugin.hs | 5 + examples/pdynload/poly1/api/API.hs | 9 + examples/pdynload/poly1/prog/Main.hs | 18 + examples/pdynload/poly1/prog/expected | 1 + examples/pdynload/should_fail0/Makefile | 4 + examples/pdynload/should_fail0/Plugin.hs | 9 + examples/pdynload/should_fail0/api/API.hs | 13 + examples/pdynload/should_fail0/prog/Main.hs | 18 + examples/pdynload/should_fail0/prog/expected | 1 + examples/pdynload/should_fail1/Makefile | 5 + examples/pdynload/should_fail1/Plugin.hs | 5 + examples/pdynload/should_fail1/api/API.hs | 8 + examples/pdynload/should_fail1/prog/Main.hs | 17 + examples/pdynload/should_fail1/prog/expected | 1 + examples/pdynload/small/Makefile | 4 + examples/pdynload/small/Plugin.hs | 5 + examples/pdynload/small/api/API.hs | 9 + examples/pdynload/small/prog/Main.hs | 18 + examples/pdynload/small/prog/expected | 1 + examples/pdynload/spj1/Makefile | 5 + examples/pdynload/spj1/Plugin.hs | 17 + examples/pdynload/spj1/api/API.hs | 9 + examples/pdynload/spj1/dont_test | 0 examples/pdynload/spj1/prog/Main.hs | 17 + examples/pdynload/spj1/prog/expected | 0 examples/pdynload/spj2/Makefile | 5 + examples/pdynload/spj2/Plugin.hs | 13 + examples/pdynload/spj2/api/API.hs | 6 + examples/pdynload/spj2/prog/Main.hs | 17 + examples/pdynload/spj2/prog/expected | 1 + examples/pdynload/spj3/Makefile | 3 + examples/pdynload/spj3/Plugin.hs | 5 + examples/pdynload/spj3/api/API.hs | 9 + examples/pdynload/spj3/prog/Main.hs | 18 + examples/pdynload/spj3/prog/expected | 8 + examples/pdynload/spj3/prog/expected.604 | 9 + examples/pdynload/spj4/Makefile | 5 + examples/pdynload/spj4/Plugin.hs | 16 + examples/pdynload/spj4/api/API.hs | 5 + examples/pdynload/spj4/prog/Main.hs | 17 + examples/pdynload/spj4/prog/expected | 1 + examples/pdynload/typealias/Makefile | 5 + examples/pdynload/typealias/Plugin.hs | 3 + examples/pdynload/typealias/api/API.hs | 8 + examples/pdynload/typealias/prog/Main.hs | 19 + examples/pdynload/typealias/prog/expected | 1 + examples/pdynload/univquant/Makefile | 4 + examples/pdynload/univquant/Plugin.hs | 8 + examples/pdynload/univquant/api/API.hs | 9 + examples/pdynload/univquant/prog/Main.hs | 17 + examples/pdynload/univquant/prog/expected | 1 + examples/pkgconf/null/Makefile | 16 + examples/pkgconf/null/Null.hs | 6 + examples/pkgconf/null/api/API.hs | 10 + examples/pkgconf/null/api/package.conf.in | 18 + examples/pkgconf/null/dont_test | 0 examples/pkgconf/null/prog/Main.hs | 12 + examples/popen/test1/Main.hs | 10 + examples/popen/test1/Makefile | 2 + examples/popen/test1/expected | 0 examples/printf/000/Main.hs | 37 + examples/printf/000/Makefile | 2 + examples/printf/000/expected | 30 + examples/printf/000/printf.sh | 36 + examples/printf/001/Main.hs | 13 + examples/printf/001/Makefile | 2 + examples/printf/001/expected | 9 + examples/printf/002/Main.hs | 12 + examples/printf/002/Makefile | 2 + examples/printf/002/expected | 7 + examples/printf/should_fail_000/Main.hs | 3 + examples/printf/should_fail_000/Makefile | 2 + examples/printf/should_fail_000/expected | 3 + examples/printf/should_fail_000/expected.604 | 2 + examples/printf/should_fail_001/Main.hs | 13 + examples/printf/should_fail_001/Makefile | 2 + examples/printf/should_fail_001/expected | 10 + examples/printf/should_fail_001/expected.604 | 9 + examples/reload/null/Makefile | 4 + examples/reload/null/Null.hs | 11 + examples/reload/null/api/API.hs | 12 + examples/reload/null/prog/Main.hs | 19 + examples/reload/null/prog/expected | 2 + examples/shell/shell/API.hs | 8 + examples/shell/shell/Main.hs | 85 + examples/shell/shell/Makefile | 2 + examples/shell/shell/Plugin.hs | 5 + examples/shell/shell/Plugin.stub | 19 + examples/shell/shell/README | 23 + examples/shell/shell/dont_test | 0 examples/shell/simple/Main.hs | 41 + examples/shell/simple/Makefile | 6 + examples/shell/simple/Plugin.hs | 5 + examples/shell/simple/Plugin.stub | 19 + examples/shell/simple/README | 23 + examples/shell/simple/StringProcessorAPI.hs | 8 + examples/shell/simple/dont_test | 0 examples/typecase/000/Main.hs | 14 + examples/typecase/000/Makefile | 2 + examples/typecase/000/expected | 1 + examples/unload/null/Makefile | 4 + examples/unload/null/Null.hs | 11 + examples/unload/null/api/API.hs | 12 + examples/unload/null/prog/Main.hs | 11 + examples/unload/null/prog/expected | 1 + examples/unload/sjwtrap/Makefile | 4 + examples/unload/sjwtrap/Null.hs | 6 + examples/unload/sjwtrap/api/API.hs | 9 + examples/unload/sjwtrap/prog/Main.hs | 15 + examples/unload/sjwtrap/prog/expected | 1 + install-sh | 251 +++ scripts/openbsd-port/Makefile | 21 + scripts/openbsd-port/distinfo | 3 + scripts/openbsd-port/pkg/DESCR | 6 + scripts/openbsd-port/pkg/PLIST | 28 + src/Makefile | 38 + src/README | 23 + src/altdata/AltData.hs | 24 + src/altdata/AltData/Dynamic.hs | 174 ++ src/altdata/AltData/Typeable.hs | 958 +++++++++ src/altdata/Makefile | 7 + src/altdata/altdata.conf.in.cpp | 53 + src/build.mk | 91 + src/eval/Eval.hs | 27 + src/eval/Eval/Haskell.hs | 250 +++ src/eval/Eval/Meta.hs | 96 + src/eval/Eval/Utils.hs | 121 ++ src/eval/Makefile | 12 + src/eval/eval.conf.in.cpp | 60 + src/hi/Hi.hs | 25 + src/hi/Hi/Binary.hs | 566 ++++++ src/hi/Hi/FastMutInt.hs | 81 + src/hi/Hi/FastString.hs | 508 +++++ src/hi/Hi/Parser.hs | 722 +++++++ src/hi/Hi/PrimPacked.hs | 194 ++ src/hi/Hi/Syntax.hs | 360 ++++ src/hi/Hi/hschooks.c | 38 + src/hi/Hi/hschooks.h | 13 + src/hi/Makefile | 12 + src/hi/hi.conf.in.cpp | 57 + src/plugins/Makefile | 22 + src/plugins/Plugins.hs | 37 + src/plugins/Plugins/Consts.hs | 62 + src/plugins/Plugins/Env.hs | 358 ++++ src/plugins/Plugins/Load.hs | 632 ++++++ src/plugins/Plugins/Make.hs | 297 +++ src/plugins/Plugins/MkTemp.hs | 281 +++ src/plugins/Plugins/Package.hs | 67 + src/plugins/Plugins/PackageAPI.hs | 92 + src/plugins/Plugins/ParsePkgConfCabal.hs | 776 +++++++ src/plugins/Plugins/ParsePkgConfCabal.y | 218 ++ src/plugins/Plugins/ParsePkgConfLite.hs | 624 ++++++ src/plugins/Plugins/ParsePkgConfLite.y | 159 ++ src/plugins/Plugins/Parser.hs | 229 +++ src/plugins/Plugins/Utils.hs | 454 +++++ src/plugins/plugins.conf.in.cpp | 63 + src/printf/Makefile | 16 + src/printf/Printf.hs | 25 + src/printf/Printf/Compile.hs | 390 ++++ src/printf/Printf/Lexer.hs | 407 ++++ src/printf/Printf/Lexer.x | 86 + src/printf/Printf/Parser.hs | 719 +++++++ src/printf/Printf/Parser.y | 174 ++ src/printf/printf.conf.in.cpp | 54 + 494 files changed, 23721 insertions(+) create mode 100644 AUTHORS create mode 100644 BUILDING.CVS create mode 100644 LICENSE create mode 100644 Makefile create mode 100644 README create mode 100644 TODO create mode 100644 VERSION create mode 100644 autogen.sh create mode 100644 config.guess create mode 100644 config.h.in create mode 100644 config.mk.in create mode 100644 config.sub create mode 100644 configure.ac create mode 100644 docs/Makefile create mode 100644 docs/haskell.sty create mode 100644 docs/hs-plugins.1 create mode 100644 docs/hs-plugins.hdir create mode 100644 docs/hs-plugins.tex create mode 100644 docs/munge.sed create mode 100644 docs/tex2page.sty create mode 100644 docs/tex2page.tex create mode 100644 examples/README create mode 100644 examples/TIMINGS create mode 100644 examples/build.mk create mode 100644 examples/check.mk create mode 100644 examples/conf/simple/Mailrc.conf create mode 100644 examples/conf/simple/Mailrc.stub create mode 100644 examples/conf/simple/Makefile create mode 100644 examples/conf/simple/api/API.hs create mode 100644 examples/conf/simple/prog/Main.hs create mode 100644 examples/conf/simple/prog/expected create mode 100644 examples/dynload/io/Makefile create mode 100644 examples/dynload/io/TestIO.hs create mode 100644 examples/dynload/io/api/API.hs create mode 100644 examples/dynload/io/prog/Main.hs create mode 100644 examples/dynload/io/prog/expected create mode 100644 examples/dynload/poly/Makefile create mode 100644 examples/dynload/poly/Plugin.hs create mode 100644 examples/dynload/poly/api/API.hs create mode 100644 examples/dynload/poly/prog/Main.hs create mode 100644 examples/dynload/poly/prog/expected create mode 100644 examples/dynload/should_fail/Makefile create mode 100644 examples/dynload/should_fail/Plugin.hs create mode 100644 examples/dynload/should_fail/api/API.hs create mode 100644 examples/dynload/should_fail/prog/Main.hs create mode 100644 examples/dynload/should_fail/prog/expected create mode 100644 examples/dynload/should_fail_1/Makefile create mode 100644 examples/dynload/should_fail_1/Plugin.hs create mode 100644 examples/dynload/should_fail_1/api/API.hs create mode 100644 examples/dynload/should_fail_1/prog/Main.hs create mode 100644 examples/dynload/should_fail_1/prog/expected create mode 100644 examples/dynload/should_fail_2/Makefile create mode 100644 examples/dynload/should_fail_2/Plugin.in create mode 100644 examples/dynload/should_fail_2/Plugin.stub create mode 100644 examples/dynload/should_fail_2/api/API.hs create mode 100644 examples/dynload/should_fail_2/prog/Main.hs create mode 100644 examples/dynload/should_fail_2/prog/expected create mode 100644 examples/dynload/should_fail_2/prog/expected.604 create mode 100644 examples/dynload/should_fail_3/Makefile create mode 100644 examples/dynload/should_fail_3/Plugin.in create mode 100644 examples/dynload/should_fail_3/Plugin.stub create mode 100644 examples/dynload/should_fail_3/api/API.hs create mode 100644 examples/dynload/should_fail_3/prog/Main.hs create mode 100644 examples/dynload/should_fail_3/prog/expected create mode 100644 examples/dynload/should_fail_3/prog/expected.604 create mode 100644 examples/dynload/simple/Makefile create mode 100644 examples/dynload/simple/Plugin.hs create mode 100644 examples/dynload/simple/api/API.hs create mode 100644 examples/dynload/simple/prog/Main.hs create mode 100644 examples/dynload/simple/prog/expected create mode 100644 examples/eval.mk create mode 100644 examples/eval/eval1/Main.hs create mode 100644 examples/eval/eval1/Makefile create mode 100644 examples/eval/eval1/expected create mode 100644 examples/eval/eval2/Main.hs create mode 100644 examples/eval/eval2/Makefile create mode 100644 examples/eval/eval2/expected create mode 100644 examples/eval/eval3/Main.hs create mode 100644 examples/eval/eval3/Makefile create mode 100644 examples/eval/eval3/expected create mode 100644 examples/eval/eval_/Main.hs create mode 100644 examples/eval/eval_/Makefile create mode 100644 examples/eval/eval_/expected create mode 100644 examples/eval/eval_fn/Main.hs create mode 100644 examples/eval/eval_fn/Makefile create mode 100644 examples/eval/eval_fn/expected create mode 100644 examples/eval/eval_fn1/Main.hs create mode 100644 examples/eval/eval_fn1/Makefile create mode 100644 examples/eval/eval_fn1/Poly.hs create mode 100644 examples/eval/eval_fn1/expected create mode 100644 examples/eval/foreign_eval/Makefile create mode 100644 examples/eval/foreign_eval/README create mode 100644 examples/eval/foreign_eval/expected create mode 100644 examples/eval/foreign_eval/main.c create mode 100644 examples/eval/foreign_eval1/Makefile create mode 100644 examples/eval/foreign_eval1/expected create mode 100644 examples/eval/foreign_eval1/main.c create mode 100644 examples/eval/foreign_should_fail/Makefile create mode 100644 examples/eval/foreign_should_fail/expected create mode 100644 examples/eval/foreign_should_fail/expected.604 create mode 100644 examples/eval/foreign_should_fail/main.c create mode 100644 examples/eval/foreign_should_fail_illtyped/Makefile create mode 100644 examples/eval/foreign_should_fail_illtyped/expected create mode 100644 examples/eval/foreign_should_fail_illtyped/expected.604 create mode 100644 examples/eval/foreign_should_fail_illtyped/main.c create mode 100644 examples/eval/unsafeidir/Main.hs create mode 100644 examples/eval/unsafeidir/Makefile create mode 100644 examples/eval/unsafeidir/a/Extra.hs create mode 100644 examples/eval/unsafeidir/expected create mode 100644 examples/foreign.mk create mode 100644 examples/hier/hier1/Makefile create mode 100644 examples/hier/hier1/Modules/Flags.hs create mode 100644 examples/hier/hier1/Modules/Makefile create mode 100644 examples/hier/hier1/Plugin.hs create mode 100644 examples/hier/hier1/api/API.hs create mode 100644 examples/hier/hier1/prog/Main.hs create mode 100644 examples/hier/hier1/prog/expected create mode 100644 examples/hier/hier2/A/B/C/Module.hs create mode 100644 examples/hier/hier2/A/Makefile create mode 100644 examples/hier/hier2/Makefile create mode 100644 examples/hier/hier2/api/API.hs create mode 100644 examples/hier/hier2/prog/Main.hs create mode 100644 examples/hier/hier2/prog/expected create mode 100644 examples/hier/hier3/Main.hs create mode 100644 examples/hier/hier3/Makefile create mode 100644 examples/hier/hier3/One.hs create mode 100644 examples/hier/hier3/Two.hs create mode 100644 examples/hier/hier3/expected create mode 100644 examples/hier/hier4/A.hs create mode 100644 examples/hier/hier4/B.hs create mode 100644 examples/hier/hier4/C.hs create mode 100644 examples/hier/hier4/D.hs create mode 100644 examples/hier/hier4/Main.hs create mode 100644 examples/hier/hier4/Makefile create mode 100644 examples/hier/hier4/expected create mode 100644 examples/hmake/lib-plugs/Main.hs create mode 100644 examples/hmake/lib-plugs/Makefile create mode 100644 examples/hmake/lib-plugs/expected create mode 100644 examples/hmake/lib-plugs/test.in create mode 100644 examples/hmake/one-shot/Main.hs create mode 100644 examples/hmake/one-shot/Makefile create mode 100644 examples/hmake/one-shot/expected create mode 100644 examples/hmake/one-shot/test.in create mode 100644 examples/iface/null/A.hs create mode 100644 examples/iface/null/B.hs create mode 100644 examples/iface/null/Main.hs create mode 100644 examples/iface/null/Makefile create mode 100644 examples/iface/null/expected create mode 100644 examples/iface/null/expected.604 create mode 100644 examples/load/io/Makefile create mode 100644 examples/load/io/TestIO.hs create mode 100644 examples/load/io/api/API.hs create mode 100644 examples/load/io/prog/Main.hs create mode 100644 examples/load/io/prog/expected create mode 100644 examples/load/load_0/Makefile create mode 100644 examples/load/load_0/Test.hs create mode 100644 examples/load/load_0/api/API.hs create mode 100644 examples/load/load_0/prog/Main.hs create mode 100644 examples/load/load_0/prog/expected create mode 100644 examples/load/loadpkg/Main.hs create mode 100644 examples/load/loadpkg/Makefile create mode 100644 examples/load/loadpkg/expected create mode 100644 examples/load/null/Makefile create mode 100644 examples/load/null/Null.hs create mode 100644 examples/load/null/api/API.hs create mode 100644 examples/load/null/prog/Main.hs create mode 100644 examples/load/null/prog/expected create mode 100644 examples/load/rawload/Main.hs create mode 100644 examples/load/rawload/Makefile create mode 100644 examples/load/rawload/t.c create mode 100644 examples/load/thiemann0/Makefile create mode 100644 examples/load/thiemann0/Test.hs create mode 100644 examples/load/thiemann0/api/API.hs create mode 100644 examples/load/thiemann0/prog/Main.hs create mode 100644 examples/load/thiemann0/prog/expected create mode 100644 examples/load/thiemann2/C.hs create mode 100644 examples/load/thiemann2/Makefile create mode 100644 examples/load/thiemann2/api/API.hs create mode 100644 examples/load/thiemann2/prog/A.hs create mode 100644 examples/load/thiemann2/prog/B.hs create mode 100644 examples/load/thiemann2/prog/Main.hs create mode 100644 examples/load/thiemann2/prog/expected create mode 100644 examples/load/unloadpkg/Main.hs create mode 100644 examples/load/unloadpkg/Makefile create mode 100644 examples/load/unloadpkg/expected create mode 100644 examples/make/makeall001/A.hs create mode 100644 examples/make/makeall001/B.hs create mode 100644 examples/make/makeall001/C.hs create mode 100644 examples/make/makeall001/Makefile create mode 100644 examples/make/makeall001/Tiny.hs create mode 100644 examples/make/makeall001/api/API.hs create mode 100644 examples/make/makeall001/prog/Main.hs create mode 100644 examples/make/makeall001/prog/expected create mode 100644 examples/make/null/Makefile create mode 100644 examples/make/null/Null.hs create mode 100644 examples/make/null/api/API.hs create mode 100644 examples/make/null/prog/Main.hs create mode 100644 examples/make/null/prog/expected create mode 100644 examples/make/o/Makefile create mode 100644 examples/make/o/Plugin.hs create mode 100644 examples/make/o/api/API.hs create mode 100644 examples/make/o/prog/Main.hs create mode 100644 examples/make/o/prog/expected create mode 100644 examples/make/odir/Makefile create mode 100644 examples/make/odir/Plugin.hs create mode 100644 examples/make/odir/api/API.hs create mode 100644 examples/make/odir/prog/Main.hs create mode 100644 examples/make/odir/prog/expected create mode 100644 examples/make/remake001/Bar.hs create mode 100644 examples/make/remake001/Foo.hs create mode 100644 examples/make/remake001/Main.hs create mode 100644 examples/make/remake001/Makefile create mode 100644 examples/make/remake001/expected create mode 100644 examples/make/remake001_should_fail/Bar.hs create mode 100644 examples/make/remake001_should_fail/Foo.hs create mode 100644 examples/make/remake001_should_fail/Main.hs create mode 100644 examples/make/remake001_should_fail/Makefile create mode 100644 examples/make/remake001_should_fail/expected create mode 100644 examples/make/simple/Makefile create mode 100644 examples/make/simple/Tiny.hs create mode 100644 examples/make/simple/api/API.hs create mode 100644 examples/make/simple/prog/Main.hs create mode 100644 examples/make/simple/prog/expected create mode 100644 examples/makewith/global_pragma/Makefile create mode 100644 examples/makewith/global_pragma/Plugin.hs create mode 100644 examples/makewith/global_pragma/api/API.hs create mode 100644 examples/makewith/global_pragma/prog/Main.hs create mode 100644 examples/makewith/global_pragma/prog/expected create mode 100644 examples/makewith/io/Makefile create mode 100644 examples/makewith/io/README create mode 100644 examples/makewith/io/TestIO.conf create mode 100644 examples/makewith/io/TestIO.stub create mode 100644 examples/makewith/io/api/API.hs create mode 100644 examples/makewith/io/prog/Main.hs create mode 100644 examples/makewith/io/prog/expected create mode 100644 examples/makewith/merge00/Bar.hs create mode 100644 examples/makewith/merge00/Foo.hs create mode 100644 examples/makewith/merge00/Main.hs create mode 100644 examples/makewith/merge00/Makefile create mode 100644 examples/makewith/merge00/expected create mode 100644 examples/makewith/mergeto0/Bar.hs create mode 100644 examples/makewith/mergeto0/Foo.hs create mode 100644 examples/makewith/mergeto0/Main.hs create mode 100644 examples/makewith/mergeto0/Makefile create mode 100644 examples/makewith/mergeto0/expected create mode 100644 examples/makewith/module_name/Bar.hs create mode 100644 examples/makewith/module_name/Foo.hs create mode 100644 examples/makewith/module_name/Main.hs create mode 100644 examples/makewith/module_name/Makefile create mode 100644 examples/makewith/module_name/expected create mode 100644 examples/makewith/multi_make/Bar.hs create mode 100644 examples/makewith/multi_make/Foo.hs create mode 100644 examples/makewith/multi_make/Main.hs create mode 100644 examples/makewith/multi_make/Makefile create mode 100644 examples/makewith/multi_make/Stub.hs create mode 100644 examples/makewith/multi_make/expected create mode 100644 examples/makewith/should_fail_0/Makefile create mode 100644 examples/makewith/should_fail_0/Plugin.in create mode 100644 examples/makewith/should_fail_0/Plugin.stub create mode 100644 examples/makewith/should_fail_0/api/API.hs create mode 100644 examples/makewith/should_fail_0/prog/Main.hs create mode 100644 examples/makewith/should_fail_0/prog/expected create mode 100644 examples/makewith/tiny/Makefile create mode 100644 examples/makewith/tiny/Tiny.conf create mode 100644 examples/makewith/tiny/Tiny.stub create mode 100644 examples/makewith/tiny/api/API.hs create mode 100644 examples/makewith/tiny/prog/Main.hs create mode 100644 examples/makewith/tiny/prog/expected create mode 100644 examples/makewith/unsafeio/Makefile create mode 100644 examples/makewith/unsafeio/README create mode 100644 examples/makewith/unsafeio/Unsafe.conf create mode 100644 examples/makewith/unsafeio/Unsafe.stub create mode 100644 examples/makewith/unsafeio/api/API.hs create mode 100644 examples/makewith/unsafeio/prog/Main.hs create mode 100644 examples/makewith/unsafeio/prog/README create mode 100644 examples/makewith/unsafeio/prog/expected create mode 100644 examples/misc/mkstemps/Main.hs create mode 100644 examples/misc/mkstemps/Makefile create mode 100644 examples/misc/mkstemps/expected create mode 100644 examples/multi/3plugins/Makefile create mode 100644 examples/multi/3plugins/Plugin1.hs create mode 100644 examples/multi/3plugins/Plugin2.hs create mode 100644 examples/multi/3plugins/Plugin3.hs create mode 100644 examples/multi/3plugins/api/API.hs create mode 100644 examples/multi/3plugins/prog/Main.hs create mode 100644 examples/multi/3plugins/prog/expected create mode 100644 examples/objc/expression_parser/ArithmeticExpressionParser.hs create mode 100644 examples/objc/expression_parser/English.lproj/Credits.rtf create mode 100644 examples/objc/expression_parser/English.lproj/InfoPlist.strings create mode 100644 examples/objc/expression_parser/English.lproj/MainMenu.nib/classes.nib create mode 100644 examples/objc/expression_parser/English.lproj/MainMenu.nib/info.nib create mode 100644 examples/objc/expression_parser/English.lproj/MainMenu.nib/objects.nib create mode 100644 examples/objc/expression_parser/English.lproj/MyDocument.nib/classes.nib create mode 100644 examples/objc/expression_parser/English.lproj/MyDocument.nib/info.nib create mode 100644 examples/objc/expression_parser/English.lproj/MyDocument.nib/keyedobjects.nib create mode 100644 examples/objc/expression_parser/English.lproj/MyDocument.nib/objects.nib create mode 100644 examples/objc/expression_parser/Info.plist create mode 100644 examples/objc/expression_parser/KeyValueParser.hs create mode 100644 examples/objc/expression_parser/Makefile create mode 100644 examples/objc/expression_parser/MyDocument.h create mode 100644 examples/objc/expression_parser/MyDocument.m create mode 100644 examples/objc/expression_parser/PluginEvalAux.hs create mode 100644 examples/objc/expression_parser/PluginExpressionParser.xcode/project.pbxproj create mode 100644 examples/objc/expression_parser/PluginExpressionParser_Prefix.pch create mode 100644 examples/objc/expression_parser/README create mode 100644 examples/objc/expression_parser/RunHaskell.h create mode 100644 examples/objc/expression_parser/dont_test create mode 100644 examples/objc/expression_parser/main.m create mode 100644 examples/objc/expression_parser/version.plist create mode 100644 examples/pdynload/badint/Makefile create mode 100644 examples/pdynload/badint/Plugin.hs create mode 100644 examples/pdynload/badint/api/API.hs create mode 100644 examples/pdynload/badint/prog/Main.hs create mode 100644 examples/pdynload/badint/prog/expected create mode 100644 examples/pdynload/null/Makefile create mode 100644 examples/pdynload/null/Plugin.hs create mode 100644 examples/pdynload/null/api/API.hs create mode 100644 examples/pdynload/null/prog/Main.hs create mode 100644 examples/pdynload/null/prog/expected create mode 100644 examples/pdynload/numclass/Makefile create mode 100644 examples/pdynload/numclass/Plugin.hs create mode 100644 examples/pdynload/numclass/api/API.hs create mode 100644 examples/pdynload/numclass/prog/Main.hs create mode 100644 examples/pdynload/numclass/prog/expected create mode 100644 examples/pdynload/poly/Makefile create mode 100644 examples/pdynload/poly/Plugin.hs create mode 100644 examples/pdynload/poly/api/API.hs create mode 100644 examples/pdynload/poly/prog/Main.hs create mode 100644 examples/pdynload/poly/prog/expected create mode 100644 examples/pdynload/poly1/Makefile create mode 100644 examples/pdynload/poly1/Plugin.hs create mode 100644 examples/pdynload/poly1/api/API.hs create mode 100644 examples/pdynload/poly1/prog/Main.hs create mode 100644 examples/pdynload/poly1/prog/expected create mode 100644 examples/pdynload/should_fail0/Makefile create mode 100644 examples/pdynload/should_fail0/Plugin.hs create mode 100644 examples/pdynload/should_fail0/api/API.hs create mode 100644 examples/pdynload/should_fail0/prog/Main.hs create mode 100644 examples/pdynload/should_fail0/prog/expected create mode 100644 examples/pdynload/should_fail1/Makefile create mode 100644 examples/pdynload/should_fail1/Plugin.hs create mode 100644 examples/pdynload/should_fail1/api/API.hs create mode 100644 examples/pdynload/should_fail1/prog/Main.hs create mode 100644 examples/pdynload/should_fail1/prog/expected create mode 100644 examples/pdynload/small/Makefile create mode 100644 examples/pdynload/small/Plugin.hs create mode 100644 examples/pdynload/small/api/API.hs create mode 100644 examples/pdynload/small/prog/Main.hs create mode 100644 examples/pdynload/small/prog/expected create mode 100644 examples/pdynload/spj1/Makefile create mode 100644 examples/pdynload/spj1/Plugin.hs create mode 100644 examples/pdynload/spj1/api/API.hs create mode 100644 examples/pdynload/spj1/dont_test create mode 100644 examples/pdynload/spj1/prog/Main.hs create mode 100644 examples/pdynload/spj1/prog/expected create mode 100644 examples/pdynload/spj2/Makefile create mode 100644 examples/pdynload/spj2/Plugin.hs create mode 100644 examples/pdynload/spj2/api/API.hs create mode 100644 examples/pdynload/spj2/prog/Main.hs create mode 100644 examples/pdynload/spj2/prog/expected create mode 100644 examples/pdynload/spj3/Makefile create mode 100644 examples/pdynload/spj3/Plugin.hs create mode 100644 examples/pdynload/spj3/api/API.hs create mode 100644 examples/pdynload/spj3/prog/Main.hs create mode 100644 examples/pdynload/spj3/prog/expected create mode 100644 examples/pdynload/spj3/prog/expected.604 create mode 100644 examples/pdynload/spj4/Makefile create mode 100644 examples/pdynload/spj4/Plugin.hs create mode 100644 examples/pdynload/spj4/api/API.hs create mode 100644 examples/pdynload/spj4/prog/Main.hs create mode 100644 examples/pdynload/spj4/prog/expected create mode 100644 examples/pdynload/typealias/Makefile create mode 100644 examples/pdynload/typealias/Plugin.hs create mode 100644 examples/pdynload/typealias/api/API.hs create mode 100644 examples/pdynload/typealias/prog/Main.hs create mode 100644 examples/pdynload/typealias/prog/expected create mode 100644 examples/pdynload/univquant/Makefile create mode 100644 examples/pdynload/univquant/Plugin.hs create mode 100644 examples/pdynload/univquant/api/API.hs create mode 100644 examples/pdynload/univquant/prog/Main.hs create mode 100644 examples/pdynload/univquant/prog/expected create mode 100644 examples/pkgconf/null/Makefile create mode 100644 examples/pkgconf/null/Null.hs create mode 100644 examples/pkgconf/null/api/API.hs create mode 100644 examples/pkgconf/null/api/package.conf.in create mode 100644 examples/pkgconf/null/dont_test create mode 100644 examples/pkgconf/null/prog/Main.hs create mode 100644 examples/popen/test1/Main.hs create mode 100644 examples/popen/test1/Makefile create mode 100644 examples/popen/test1/expected create mode 100644 examples/printf/000/Main.hs create mode 100644 examples/printf/000/Makefile create mode 100644 examples/printf/000/expected create mode 100644 examples/printf/000/printf.sh create mode 100644 examples/printf/001/Main.hs create mode 100644 examples/printf/001/Makefile create mode 100644 examples/printf/001/expected create mode 100644 examples/printf/002/Main.hs create mode 100644 examples/printf/002/Makefile create mode 100644 examples/printf/002/expected create mode 100644 examples/printf/should_fail_000/Main.hs create mode 100644 examples/printf/should_fail_000/Makefile create mode 100644 examples/printf/should_fail_000/expected create mode 100644 examples/printf/should_fail_000/expected.604 create mode 100644 examples/printf/should_fail_001/Main.hs create mode 100644 examples/printf/should_fail_001/Makefile create mode 100644 examples/printf/should_fail_001/expected create mode 100644 examples/printf/should_fail_001/expected.604 create mode 100644 examples/reload/null/Makefile create mode 100644 examples/reload/null/Null.hs create mode 100644 examples/reload/null/api/API.hs create mode 100644 examples/reload/null/prog/Main.hs create mode 100644 examples/reload/null/prog/expected create mode 100644 examples/shell/shell/API.hs create mode 100644 examples/shell/shell/Main.hs create mode 100644 examples/shell/shell/Makefile create mode 100644 examples/shell/shell/Plugin.hs create mode 100644 examples/shell/shell/Plugin.stub create mode 100644 examples/shell/shell/README create mode 100644 examples/shell/shell/dont_test create mode 100644 examples/shell/simple/Main.hs create mode 100644 examples/shell/simple/Makefile create mode 100644 examples/shell/simple/Plugin.hs create mode 100644 examples/shell/simple/Plugin.stub create mode 100644 examples/shell/simple/README create mode 100644 examples/shell/simple/StringProcessorAPI.hs create mode 100644 examples/shell/simple/dont_test create mode 100644 examples/typecase/000/Main.hs create mode 100644 examples/typecase/000/Makefile create mode 100644 examples/typecase/000/expected create mode 100644 examples/unload/null/Makefile create mode 100644 examples/unload/null/Null.hs create mode 100644 examples/unload/null/api/API.hs create mode 100644 examples/unload/null/prog/Main.hs create mode 100644 examples/unload/null/prog/expected create mode 100644 examples/unload/sjwtrap/Makefile create mode 100644 examples/unload/sjwtrap/Null.hs create mode 100644 examples/unload/sjwtrap/api/API.hs create mode 100644 examples/unload/sjwtrap/prog/Main.hs create mode 100644 examples/unload/sjwtrap/prog/expected create mode 100644 install-sh create mode 100644 scripts/openbsd-port/Makefile create mode 100644 scripts/openbsd-port/distinfo create mode 100644 scripts/openbsd-port/pkg/DESCR create mode 100644 scripts/openbsd-port/pkg/PLIST create mode 100644 src/Makefile create mode 100644 src/README create mode 100644 src/altdata/AltData.hs create mode 100644 src/altdata/AltData/Dynamic.hs create mode 100644 src/altdata/AltData/Typeable.hs create mode 100644 src/altdata/Makefile create mode 100644 src/altdata/altdata.conf.in.cpp create mode 100644 src/build.mk create mode 100644 src/eval/Eval.hs create mode 100644 src/eval/Eval/Haskell.hs create mode 100644 src/eval/Eval/Meta.hs create mode 100644 src/eval/Eval/Utils.hs create mode 100644 src/eval/Makefile create mode 100644 src/eval/eval.conf.in.cpp create mode 100644 src/hi/Hi.hs create mode 100644 src/hi/Hi/Binary.hs create mode 100644 src/hi/Hi/FastMutInt.hs create mode 100644 src/hi/Hi/FastString.hs create mode 100644 src/hi/Hi/Parser.hs create mode 100644 src/hi/Hi/PrimPacked.hs create mode 100644 src/hi/Hi/Syntax.hs create mode 100644 src/hi/Hi/hschooks.c create mode 100644 src/hi/Hi/hschooks.h create mode 100644 src/hi/Makefile create mode 100644 src/hi/hi.conf.in.cpp create mode 100644 src/plugins/Makefile create mode 100644 src/plugins/Plugins.hs create mode 100644 src/plugins/Plugins/Consts.hs create mode 100644 src/plugins/Plugins/Env.hs create mode 100644 src/plugins/Plugins/Load.hs create mode 100644 src/plugins/Plugins/Make.hs create mode 100644 src/plugins/Plugins/MkTemp.hs create mode 100644 src/plugins/Plugins/Package.hs create mode 100644 src/plugins/Plugins/PackageAPI.hs create mode 100644 src/plugins/Plugins/ParsePkgConfCabal.hs create mode 100644 src/plugins/Plugins/ParsePkgConfCabal.y create mode 100644 src/plugins/Plugins/ParsePkgConfLite.hs create mode 100644 src/plugins/Plugins/ParsePkgConfLite.y create mode 100644 src/plugins/Plugins/Parser.hs create mode 100644 src/plugins/Plugins/Utils.hs create mode 100644 src/plugins/plugins.conf.in.cpp create mode 100644 src/printf/Makefile create mode 100644 src/printf/Printf.hs create mode 100644 src/printf/Printf/Compile.hs create mode 100644 src/printf/Printf/Lexer.hs create mode 100644 src/printf/Printf/Lexer.x create mode 100644 src/printf/Printf/Parser.hs create mode 100644 src/printf/Printf/Parser.y create mode 100644 src/printf/printf.conf.in.cpp diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 0000000..f3dabc0 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,5 @@ + +Don Stewart +Sean Seefried +Andre Pang + diff --git a/BUILDING.CVS b/BUILDING.CVS new file mode 100644 index 0000000..8eea44f --- /dev/null +++ b/BUILDING.CVS @@ -0,0 +1,25 @@ +CVS BUILDING INSTRUCTIONS +========================= + +These are build instructions if you've checked out hs-plugins +from CVS (instead of downloading a source distribution tarball). + +1. Execute autogen.sh to generate the GNU ./configure script: + + ./autogen.sh + +2. Build hs-plugins as usual with ./configure && make + + +cvsps +===== + +For people who are used to more modern revision control systems +(such as Darcs, Subversion and Arch) and miss working with +'patchsets' instead of the disjoint per-file patches that CVS +uses, take a look at cvsps , +a patchset manager for CVS. While it doesn't, by any means, give +you the many advantages that more modern source control systems +offer you, it certainly makes using CVS and managing patches far +easier! + diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..b1e3f5a --- /dev/null +++ b/LICENSE @@ -0,0 +1,504 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! + + diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..8517098 --- /dev/null +++ b/Makefile @@ -0,0 +1,104 @@ +# Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +# LGPL version 2.1 or later (see http://www.gnu.org/copyleft/lesser.html) + +# cut down reimplementation of $fptools/mk directory + +.PHONY: build all + +all: headers runplugs plugs + +build: + cd src && $(MAKE) + +plugs: build + ( cd examples/hmake/lib-plugs ; $(MAKE) build ) + cp examples/hmake/lib-plugs/plugs ./ + +runplugs: build + ( cd examples/hmake/one-shot ; $(MAKE) build ) + cp examples/hmake/one-shot/runplugs ./ + +headers: build + cp src/eval/Eval/Haskell_stub.h EvalHaskell.h + +# +# installing +# + +# TODO put these in subdirs +install: + $(INSTALL_DATA_DIR) $(LIBDIR)/include + $(INSTALL_DATA) EvalHaskell.h $(LIBDIR)/include + @(cd src && $(MAKE) install) + $(INSTALL_DATA_DIR) $(PREFIX)/bin + $(INSTALL_PROGRAM) plugs $(PREFIX)/bin/ + $(INSTALL_PROGRAM) runplugs $(PREFIX)/bin/ + +# +# and register the library with ghc package system +# Use this target if installing by hand. May need to be performed as root +# +register: + env LIBDIR=${LIBDIR} $(GHC_PKG) -u < src/altdata/altdata.conf.in + env LIBDIR=${LIBDIR} $(GHC_PKG) -u < src/hi/hi.conf.in + env LIBDIR=${LIBDIR} $(GHC_PKG) -u < src/plugins/plugins.conf.in + env LIBDIR=${LIBDIR} $(GHC_PKG) -u < src/eval/eval.conf.in + env LIBDIR=${LIBDIR} $(GHC_PKG) -u < src/printf/printf.conf.in + +# and unregister the packages +unregister: + $(GHC_PKG) -r printf + $(GHC_PKG) -r eval + $(GHC_PKG) -r plugins + $(GHC_PKG) -r hi + $(GHC_PKG) -r altdata + +# +# regress check. TODO check expected output +# +check: + @if [ ! -f EvalHaskell.h ] ; then \ + echo "run 'make' first" ; \ + exit 1 ;\ + fi + @( d=/tmp/plugins.tmp.$$$$ ; mkdir $$d ; export TMPDIR=$$d ;\ + for i in `find examples ! -name CVS -type d -maxdepth 2 -mindepth 2` ; do \ + printf "=== testing %-50s ... " "$$i" ; \ + ( cd $$i ; if [ -f dont_test ] ; then \ + echo "ignored." ;\ + else ${MAKE} -sk && ${MAKE} -ksi check |\ + sed '/^Compil/d;/^Load/d;/Read/d;/Expan/d;/Savi/d;/Writ/d' ;\ + ${MAKE} -sk clean ;\ + fi ) 2> /dev/null ;\ + done ; rm -rf $$d ) + + +# +# making clean +# + +CLEAN_FILES += *.conf.*.old *~ +EXTRA_CLEANS+=*.conf.inplace* *.conf.in *.h autom4te.cache \ + config.h config.mk config.log config.status configure + +clean: + cd docs && $(MAKE) clean + cd src && $(MAKE) clean + rm -rf $(CLEAN_FILES) + find examples -name '*.a' -exec rm {} \; + find examples -name '*~' -exec rm {} \; + find examples -name 'a.out' -exec rm {} \; + find examples -name '*.hi' -exec rm {} \; + find examples -name '*.o' -exec rm {} \; + find examples -name '*.core' -exec rm {} \; + find examples -name 'package.conf' -exec rm {} \; + rm -rf plugs + rm -rf runplugs + rm -rf examples/hmake/lib-plugs/plugs + rm -rf examples/hmake/one-shot/runplugs + rm -f EvalHaskell.h + +distclean: clean + rm -rf $(EXTRA_CLEANS) + +include config.mk diff --git a/README b/README new file mode 100644 index 0000000..2b33b07 --- /dev/null +++ b/README @@ -0,0 +1,97 @@ + +------------------------------------------------------------------------ + hs-plugins +------------------------------------------------------------------------ + +Compiler and tool support for compiling and loading, and evaluating +Haskell at runtime. + +The library provides a convenient interface to GHC's runtime loader +and linker, letting you load compiled Haskell code. + +It also provides a `make' system for compiling plugin source +automagically and for combining the user's .hs file with a stub of +standard declarations and syntax, saving the user from having to write +standard code themselves. + +It provides an eval() function, for generating new, well-typed, +compiled code from a Haskell source string. + +It also provides a new variation of printf for Haskell-- a runtime +generated, dynamically-typed printf. + +Read the documentation in doc/ for more. + +------------------------------------------------------------------------ +DEPENDENCIES: + +* Requires GNU make or BSD make to build +* Requires GHC > 6.2 (for Typeable.h) +* 'plugs' requires a working readline library. + +* If you wish to use TH in plugins, or to run load()-programs in GHCi, + you require a patch to GHC's linker, that was committed into ghc + 6.3, and ghc 6.2 -stable branch, and is available from 6.2.2 onwards. + +* If you need to regenerate ./configure you need >= autoconf-2.53 + +------------------------------------------------------------------------ +BUILDING: + $ ./configure --prefix=/usr/local + $ make + $ make install + +If you wish to register the libraries as official ghc pkg (probably as +root): + $ make register + +And to unregister (maybe as root). Note that the unistall order +matters: + + $ ghc-pkg -r printf + $ ghc-pkg -r eval + $ ghc-pkg -r plugins + $ ghc-pkg -r hi + $ ghc-pkg -r altdata + +Once it is registered, you can link against the library by just adding +-package plugins or, e.g. -package eval, to your command line. + +The documentation relies on latex, dvips, tex2page: + + $ cd doc && make + +EXAMPLES: + +Have a look in the examples/ directory for many examples of how to +arrange your code. + +LICENSE: + +This library is distributed under the terms of the LGPL. The runtime +loader code is based on code written by André Pang, and others, and is +distributed under the BSD-style Glasgow University license. + +PORTABILITY: + +Requires GHC 6.2 or greater, though most testing has be done on 6.3. +They dynamic loader requires a functional GHCi implementation. + +---------------------+-------------------------------------------------- + Platform | Works Should work* Unknown Won't work +---------------------+-------------------------------------------------- +i386-*-linux | X +i386-*-freebsd | X +i386-*-openbsd | X +powerpc-apple-darwin | X +sparc-*-solaris2 | X +ia64-*-linux | # +i386-*-solaris2 | X +sparc-*-linux | X +sparc-*-openbsd | X +i386-*-netbsd | X +amd64-*-openbsd | X +mips64-sgi-irix | X +---------------------+-------------------------------------------------- + +# .hi file parsing is currently broken diff --git a/TODO b/TODO new file mode 100644 index 0000000..0c1997f --- /dev/null +++ b/TODO @@ -0,0 +1,30 @@ +For 0.1 +---------- + ++ have eval, printf return errors as arguments, not to stdout + ++ nice functions for cleaning up /tmp files, given a module name + ++ PORTABILITY -- pretty much all of this is in main/SysTools.lhs in GHC + -- where to /tmp files go? Use SysTools code from GHC + -- need to dosify file names on in and out + -- try to confirm the implementation of forkProcess + ++ write a script to strip down the release code. + ++ .hi file parser is broken on Itanium, again. + ++ Implement hs_eval by marshalling Dynamics across to the C side for + checking. + ++ Make data structures used by the library Storable, for C programs + ++ insert iface info into the state, building up a dependency graph like + hram's. use this to allow cascading unloading. Does anyone want this? + ++ enable more .hi interface code to provide full GHC-like :t options + to plugs. + ++ replace the String interface to eval with an ExpQ interface. + ++ build way=p and way='' diff --git a/VERSION b/VERSION new file mode 100644 index 0000000..bb2adc1 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +hs-plugins 0.9.8 diff --git a/autogen.sh b/autogen.sh new file mode 100644 index 0000000..45b6ee7 --- /dev/null +++ b/autogen.sh @@ -0,0 +1,6 @@ +#!/bin/sh -x + +# this is the world's most complicated autogen.sh script :) + +exec autoconf + diff --git a/config.guess b/config.guess new file mode 100644 index 0000000..fd30ab0 --- /dev/null +++ b/config.guess @@ -0,0 +1,1354 @@ +#! /bin/sh +# Attempt to guess a canonical system name. +# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, +# 2000, 2001, 2002 Free Software Foundation, Inc. + +timestamp='2002-07-23' + +# This file is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that program. + +# Originally written by Per Bothner . +# Please send patches to . Submit a context +# diff and a properly formatted ChangeLog entry. +# +# This script attempts to guess a canonical system name similar to +# config.sub. If it succeeds, it prints the system name on stdout, and +# exits with 0. Otherwise, it exits with 1. +# +# The plan is that this can be called by configure scripts if you +# don't specify an explicit build system type. + +me=`echo "$0" | sed -e 's,.*/,,'` + +usage="\ +Usage: $0 [OPTION] + +Output the configuration name of the system \`$me' is run on. + +Operation modes: + -h, --help print this help, then exit + -t, --time-stamp print date of last modification, then exit + -v, --version print version number, then exit + +Report bugs and patches to ." + +version="\ +GNU config.guess ($timestamp) + +Originally written by Per Bothner. +Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 +Free Software Foundation, Inc. + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." + +help=" +Try \`$me --help' for more information." + +# Parse command line +while test $# -gt 0 ; do + case $1 in + --time-stamp | --time* | -t ) + echo "$timestamp" ; exit 0 ;; + --version | -v ) + echo "$version" ; exit 0 ;; + --help | --h* | -h ) + echo "$usage"; exit 0 ;; + -- ) # Stop option processing + shift; break ;; + - ) # Use stdin as input. + break ;; + -* ) + echo "$me: invalid option $1$help" >&2 + exit 1 ;; + * ) + break ;; + esac +done + +if test $# != 0; then + echo "$me: too many arguments$help" >&2 + exit 1 +fi + +trap 'exit 1' 1 2 15 + +# CC_FOR_BUILD -- compiler used by this script. Note that the use of a +# compiler to aid in system detection is discouraged as it requires +# temporary files to be created and, as you can see below, it is a +# headache to deal with in a portable fashion. + +# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still +# use `HOST_CC' if defined, but it is deprecated. + +# This shell variable is my proudest work .. or something. --bje + +set_cc_for_build='tmpdir=${TMPDIR-/tmp}/config-guess-$$ ; +(old=`umask` && umask 077 && mkdir $tmpdir && umask $old && unset old) + || (echo "$me: cannot create $tmpdir" >&2 && exit 1) ; +dummy=$tmpdir/dummy ; +files="$dummy.c $dummy.o $dummy.rel $dummy" ; +trap '"'"'rm -f $files; rmdir $tmpdir; exit 1'"'"' 1 2 15 ; +case $CC_FOR_BUILD,$HOST_CC,$CC in + ,,) echo "int x;" > $dummy.c ; + for c in cc gcc c89 c99 ; do + if ($c $dummy.c -c -o $dummy.o) >/dev/null 2>&1 ; then + CC_FOR_BUILD="$c"; break ; + fi ; + done ; + rm -f $files ; + if test x"$CC_FOR_BUILD" = x ; then + CC_FOR_BUILD=no_compiler_found ; + fi + ;; + ,,*) CC_FOR_BUILD=$CC ;; + ,*,*) CC_FOR_BUILD=$HOST_CC ;; +esac ; +unset files' + +# This is needed to find uname on a Pyramid OSx when run in the BSD universe. +# (ghazi@noc.rutgers.edu 1994-08-24) +if (test -f /.attbin/uname) >/dev/null 2>&1 ; then + PATH=$PATH:/.attbin ; export PATH +fi + +UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown +UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown +UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown +UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown + +# Note: order is significant - the case branches are not exclusive. + +case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in + *:NetBSD:*:*) + # NetBSD (nbsd) targets should (where applicable) match one or + # more of the tupples: *-*-netbsdelf*, *-*-netbsdaout*, + # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently + # switched to ELF, *-*-netbsd* would select the old + # object file format. This provides both forward + # compatibility and a consistent mechanism for selecting the + # object file format. + # + # Note: NetBSD doesn't particularly care about the vendor + # portion of the name. We always set it to "unknown". + sysctl="sysctl -n hw.machine_arch" + UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ + /usr/sbin/$sysctl 2>/dev/null || echo unknown)` + case "${UNAME_MACHINE_ARCH}" in + armeb) machine=armeb-unknown ;; + arm*) machine=arm-unknown ;; + sh3el) machine=shl-unknown ;; + sh3eb) machine=sh-unknown ;; + *) machine=${UNAME_MACHINE_ARCH}-unknown ;; + esac + # The Operating System including object format, if it has switched + # to ELF recently, or will in the future. + case "${UNAME_MACHINE_ARCH}" in + arm*|i386|m68k|ns32k|sh3*|sparc|vax) + eval $set_cc_for_build + if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep __ELF__ >/dev/null + then + # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). + # Return netbsd for either. FIX? + os=netbsd + else + os=netbsdelf + fi + ;; + *) + os=netbsd + ;; + esac + # The OS release + release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` + # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: + # contains redundant information, the shorter form: + # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. + echo "${machine}-${os}${release}" + exit 0 ;; + amiga:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + arc:OpenBSD:*:*) + echo mipsel-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + hp300:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + mac68k:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + macppc:OpenBSD:*:*) + echo powerpc-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + mvme68k:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + mvme88k:OpenBSD:*:*) + echo m88k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + mvmeppc:OpenBSD:*:*) + echo powerpc-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + pmax:OpenBSD:*:*) + echo mipsel-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + sgi:OpenBSD:*:*) + echo mipseb-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + sun3:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + wgrisc:OpenBSD:*:*) + echo mipsel-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + *:OpenBSD:*:*) + echo ${UNAME_MACHINE}-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + alpha:OSF1:*:*) + if test $UNAME_RELEASE = "V4.0"; then + UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` + fi + # A Vn.n version is a released version. + # A Tn.n version is a released field test version. + # A Xn.n version is an unreleased experimental baselevel. + # 1.2 uses "1.2" for uname -r. + eval $set_cc_for_build + cat <$dummy.s + .data +\$Lformat: + .byte 37,100,45,37,120,10,0 # "%d-%x\n" + + .text + .globl main + .align 4 + .ent main +main: + .frame \$30,16,\$26,0 + ldgp \$29,0(\$27) + .prologue 1 + .long 0x47e03d80 # implver \$0 + lda \$2,-1 + .long 0x47e20c21 # amask \$2,\$1 + lda \$16,\$Lformat + mov \$0,\$17 + not \$1,\$18 + jsr \$26,printf + ldgp \$29,0(\$26) + mov 0,\$16 + jsr \$26,exit + .end main +EOF + $CC_FOR_BUILD $dummy.s -o $dummy 2>/dev/null + if test "$?" = 0 ; then + case `$dummy` in + 0-0) + UNAME_MACHINE="alpha" + ;; + 1-0) + UNAME_MACHINE="alphaev5" + ;; + 1-1) + UNAME_MACHINE="alphaev56" + ;; + 1-101) + UNAME_MACHINE="alphapca56" + ;; + 2-303) + UNAME_MACHINE="alphaev6" + ;; + 2-307) + UNAME_MACHINE="alphaev67" + ;; + 2-1307) + UNAME_MACHINE="alphaev68" + ;; + 3-1307) + UNAME_MACHINE="alphaev7" + ;; + esac + fi + rm -f $dummy.s $dummy && rmdir $tmpdir + echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[VTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` + exit 0 ;; + Alpha\ *:Windows_NT*:*) + # How do we know it's Interix rather than the generic POSIX subsystem? + # Should we change UNAME_MACHINE based on the output of uname instead + # of the specific Alpha model? + echo alpha-pc-interix + exit 0 ;; + 21064:Windows_NT:50:3) + echo alpha-dec-winnt3.5 + exit 0 ;; + Amiga*:UNIX_System_V:4.0:*) + echo m68k-unknown-sysv4 + exit 0;; + *:[Aa]miga[Oo][Ss]:*:*) + echo ${UNAME_MACHINE}-unknown-amigaos + exit 0 ;; + *:[Mm]orph[Oo][Ss]:*:*) + echo ${UNAME_MACHINE}-unknown-morphos + exit 0 ;; + *:OS/390:*:*) + echo i370-ibm-openedition + exit 0 ;; + arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) + echo arm-acorn-riscix${UNAME_RELEASE} + exit 0;; + SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) + echo hppa1.1-hitachi-hiuxmpp + exit 0;; + Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) + # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. + if test "`(/bin/universe) 2>/dev/null`" = att ; then + echo pyramid-pyramid-sysv3 + else + echo pyramid-pyramid-bsd + fi + exit 0 ;; + NILE*:*:*:dcosx) + echo pyramid-pyramid-svr4 + exit 0 ;; + DRS?6000:UNIX_SV:4.2*:7*) + case `/usr/bin/uname -p` in + sparc) echo sparc-icl-nx7 && exit 0 ;; + esac ;; + sun4H:SunOS:5.*:*) + echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit 0 ;; + sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) + echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit 0 ;; + i86pc:SunOS:5.*:*) + echo i386-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit 0 ;; + sun4*:SunOS:6*:*) + # According to config.sub, this is the proper way to canonicalize + # SunOS6. Hard to guess exactly what SunOS6 will be like, but + # it's likely to be more like Solaris than SunOS4. + echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit 0 ;; + sun4*:SunOS:*:*) + case "`/usr/bin/arch -k`" in + Series*|S4*) + UNAME_RELEASE=`uname -v` + ;; + esac + # Japanese Language versions have a version number like `4.1.3-JL'. + echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` + exit 0 ;; + sun3*:SunOS:*:*) + echo m68k-sun-sunos${UNAME_RELEASE} + exit 0 ;; + sun*:*:4.2BSD:*) + UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` + test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 + case "`/bin/arch`" in + sun3) + echo m68k-sun-sunos${UNAME_RELEASE} + ;; + sun4) + echo sparc-sun-sunos${UNAME_RELEASE} + ;; + esac + exit 0 ;; + aushp:SunOS:*:*) + echo sparc-auspex-sunos${UNAME_RELEASE} + exit 0 ;; + # The situation for MiNT is a little confusing. The machine name + # can be virtually everything (everything which is not + # "atarist" or "atariste" at least should have a processor + # > m68000). The system name ranges from "MiNT" over "FreeMiNT" + # to the lowercase version "mint" (or "freemint"). Finally + # the system name "TOS" denotes a system which is actually not + # MiNT. But MiNT is downward compatible to TOS, so this should + # be no problem. + atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit 0 ;; + atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit 0 ;; + *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit 0 ;; + milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) + echo m68k-milan-mint${UNAME_RELEASE} + exit 0 ;; + hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) + echo m68k-hades-mint${UNAME_RELEASE} + exit 0 ;; + *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) + echo m68k-unknown-mint${UNAME_RELEASE} + exit 0 ;; + powerpc:machten:*:*) + echo powerpc-apple-machten${UNAME_RELEASE} + exit 0 ;; + RISC*:Mach:*:*) + echo mips-dec-mach_bsd4.3 + exit 0 ;; + RISC*:ULTRIX:*:*) + echo mips-dec-ultrix${UNAME_RELEASE} + exit 0 ;; + VAX*:ULTRIX*:*:*) + echo vax-dec-ultrix${UNAME_RELEASE} + exit 0 ;; + 2020:CLIX:*:* | 2430:CLIX:*:*) + echo clipper-intergraph-clix${UNAME_RELEASE} + exit 0 ;; + mips:*:*:UMIPS | mips:*:*:RISCos) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c +#ifdef __cplusplus +#include /* for printf() prototype */ + int main (int argc, char *argv[]) { +#else + int main (argc, argv) int argc; char *argv[]; { +#endif + #if defined (host_mips) && defined (MIPSEB) + #if defined (SYSTYPE_SYSV) + printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_SVR4) + printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) + printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); + #endif + #endif + exit (-1); + } +EOF + $CC_FOR_BUILD $dummy.c -o $dummy \ + && $dummy `echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` \ + && rm -f $dummy.c $dummy && rmdir $tmpdir && exit 0 + rm -f $dummy.c $dummy && rmdir $tmpdir + echo mips-mips-riscos${UNAME_RELEASE} + exit 0 ;; + Motorola:PowerMAX_OS:*:*) + echo powerpc-motorola-powermax + exit 0 ;; + Night_Hawk:*:*:PowerMAX_OS) + echo powerpc-harris-powermax + exit 0 ;; + Night_Hawk:Power_UNIX:*:*) + echo powerpc-harris-powerunix + exit 0 ;; + m88k:CX/UX:7*:*) + echo m88k-harris-cxux7 + exit 0 ;; + m88k:*:4*:R4*) + echo m88k-motorola-sysv4 + exit 0 ;; + m88k:*:3*:R3*) + echo m88k-motorola-sysv3 + exit 0 ;; + AViiON:dgux:*:*) + # DG/UX returns AViiON for all architectures + UNAME_PROCESSOR=`/usr/bin/uname -p` + if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] + then + if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ + [ ${TARGET_BINARY_INTERFACE}x = x ] + then + echo m88k-dg-dgux${UNAME_RELEASE} + else + echo m88k-dg-dguxbcs${UNAME_RELEASE} + fi + else + echo i586-dg-dgux${UNAME_RELEASE} + fi + exit 0 ;; + M88*:DolphinOS:*:*) # DolphinOS (SVR3) + echo m88k-dolphin-sysv3 + exit 0 ;; + M88*:*:R3*:*) + # Delta 88k system running SVR3 + echo m88k-motorola-sysv3 + exit 0 ;; + XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) + echo m88k-tektronix-sysv3 + exit 0 ;; + Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) + echo m68k-tektronix-bsd + exit 0 ;; + *:IRIX*:*:*) + echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` + exit 0 ;; + ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. + echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id + exit 0 ;; # Note that: echo "'`uname -s`'" gives 'AIX ' + i*86:AIX:*:*) + echo i386-ibm-aix + exit 0 ;; + ia64:AIX:*:*) + if [ -x /usr/bin/oslevel ] ; then + IBM_REV=`/usr/bin/oslevel` + else + IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} + fi + echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} + exit 0 ;; + *:AIX:2:3) + if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + + main() + { + if (!__power_pc()) + exit(1); + puts("powerpc-ibm-aix3.2.5"); + exit(0); + } +EOF + $CC_FOR_BUILD $dummy.c -o $dummy && $dummy && rm -f $dummy.c $dummy && rmdir $tmpdir && exit 0 + rm -f $dummy.c $dummy && rmdir $tmpdir + echo rs6000-ibm-aix3.2.5 + elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then + echo rs6000-ibm-aix3.2.4 + else + echo rs6000-ibm-aix3.2 + fi + exit 0 ;; + *:AIX:*:[45]) + IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` + if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then + IBM_ARCH=rs6000 + else + IBM_ARCH=powerpc + fi + if [ -x /usr/bin/oslevel ] ; then + IBM_REV=`/usr/bin/oslevel` + else + IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} + fi + echo ${IBM_ARCH}-ibm-aix${IBM_REV} + exit 0 ;; + *:AIX:*:*) + echo rs6000-ibm-aix + exit 0 ;; + ibmrt:4.4BSD:*|romp-ibm:BSD:*) + echo romp-ibm-bsd4.4 + exit 0 ;; + ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and + echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to + exit 0 ;; # report: romp-ibm BSD 4.3 + *:BOSX:*:*) + echo rs6000-bull-bosx + exit 0 ;; + DPX/2?00:B.O.S.:*:*) + echo m68k-bull-sysv3 + exit 0 ;; + 9000/[34]??:4.3bsd:1.*:*) + echo m68k-hp-bsd + exit 0 ;; + hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) + echo m68k-hp-bsd4.4 + exit 0 ;; + 9000/[34678]??:HP-UX:*:*) + HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` + case "${UNAME_MACHINE}" in + 9000/31? ) HP_ARCH=m68000 ;; + 9000/[34]?? ) HP_ARCH=m68k ;; + 9000/[678][0-9][0-9]) + if [ -x /usr/bin/getconf ]; then + sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` + sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` + case "${sc_cpu_version}" in + 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 + 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 + 532) # CPU_PA_RISC2_0 + case "${sc_kernel_bits}" in + 32) HP_ARCH="hppa2.0n" ;; + 64) HP_ARCH="hppa2.0w" ;; + '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 + esac ;; + esac + fi + if [ "${HP_ARCH}" = "" ]; then + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + + #define _HPUX_SOURCE + #include + #include + + int main () + { + #if defined(_SC_KERNEL_BITS) + long bits = sysconf(_SC_KERNEL_BITS); + #endif + long cpu = sysconf (_SC_CPU_VERSION); + + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1"); break; + case CPU_PA_RISC2_0: + #if defined(_SC_KERNEL_BITS) + switch (bits) + { + case 64: puts ("hppa2.0w"); break; + case 32: puts ("hppa2.0n"); break; + default: puts ("hppa2.0"); break; + } break; + #else /* !defined(_SC_KERNEL_BITS) */ + puts ("hppa2.0"); break; + #endif + default: puts ("hppa1.0"); break; + } + exit (0); + } +EOF + (CCOPTS= $CC_FOR_BUILD $dummy.c -o $dummy 2>/dev/null) && HP_ARCH=`$dummy` + if test -z "$HP_ARCH"; then HP_ARCH=hppa; fi + rm -f $dummy.c $dummy && rmdir $tmpdir + fi ;; + esac + echo ${HP_ARCH}-hp-hpux${HPUX_REV} + exit 0 ;; + ia64:HP-UX:*:*) + HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` + echo ia64-hp-hpux${HPUX_REV} + exit 0 ;; + 3050*:HI-UX:*:*) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + int + main () + { + long cpu = sysconf (_SC_CPU_VERSION); + /* The order matters, because CPU_IS_HP_MC68K erroneously returns + true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct + results, however. */ + if (CPU_IS_PA_RISC (cpu)) + { + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; + case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; + default: puts ("hppa-hitachi-hiuxwe2"); break; + } + } + else if (CPU_IS_HP_MC68K (cpu)) + puts ("m68k-hitachi-hiuxwe2"); + else puts ("unknown-hitachi-hiuxwe2"); + exit (0); + } +EOF + $CC_FOR_BUILD $dummy.c -o $dummy && $dummy && rm -f $dummy.c $dummy && rmdir $tmpdir && exit 0 + rm -f $dummy.c $dummy && rmdir $tmpdir + echo unknown-hitachi-hiuxwe2 + exit 0 ;; + 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) + echo hppa1.1-hp-bsd + exit 0 ;; + 9000/8??:4.3bsd:*:*) + echo hppa1.0-hp-bsd + exit 0 ;; + *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) + echo hppa1.0-hp-mpeix + exit 0 ;; + hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) + echo hppa1.1-hp-osf + exit 0 ;; + hp8??:OSF1:*:*) + echo hppa1.0-hp-osf + exit 0 ;; + i*86:OSF1:*:*) + if [ -x /usr/sbin/sysversion ] ; then + echo ${UNAME_MACHINE}-unknown-osf1mk + else + echo ${UNAME_MACHINE}-unknown-osf1 + fi + exit 0 ;; + parisc*:Lites*:*:*) + echo hppa1.1-hp-lites + exit 0 ;; + C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) + echo c1-convex-bsd + exit 0 ;; + C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) + if getsysinfo -f scalar_acc + then echo c32-convex-bsd + else echo c2-convex-bsd + fi + exit 0 ;; + C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) + echo c34-convex-bsd + exit 0 ;; + C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) + echo c38-convex-bsd + exit 0 ;; + C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) + echo c4-convex-bsd + exit 0 ;; + CRAY*Y-MP:*:*:*) + echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit 0 ;; + CRAY*[A-Z]90:*:*:*) + echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ + | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ + -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ + -e 's/\.[^.]*$/.X/' + exit 0 ;; + CRAY*TS:*:*:*) + echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit 0 ;; + CRAY*T3D:*:*:*) + echo alpha-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit 0 ;; + CRAY*T3E:*:*:*) + echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit 0 ;; + CRAY*SV1:*:*:*) + echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit 0 ;; + F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) + FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` + FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` + FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` + echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" + exit 0 ;; + i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) + echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} + exit 0 ;; + sparc*:BSD/OS:*:*) + echo sparc-unknown-bsdi${UNAME_RELEASE} + exit 0 ;; + *:BSD/OS:*:*) + echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} + exit 0 ;; + *:FreeBSD:*:*) + # Determine whether the default compiler uses glibc. + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + #if __GLIBC__ >= 2 + LIBC=gnu + #else + LIBC= + #endif +EOF + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^LIBC=` + rm -f $dummy.c && rmdir $tmpdir + echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`${LIBC:+-$LIBC} + exit 0 ;; + i*:CYGWIN*:*) + echo ${UNAME_MACHINE}-pc-cygwin + exit 0 ;; + i*:MINGW*:*) + echo ${UNAME_MACHINE}-pc-mingw32 + exit 0 ;; + i*:PW*:*) + echo ${UNAME_MACHINE}-pc-pw32 + exit 0 ;; + x86:Interix*:3*) + echo i386-pc-interix3 + exit 0 ;; + i*:Windows_NT*:* | Pentium*:Windows_NT*:*) + # How do we know it's Interix rather than the generic POSIX subsystem? + # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we + # UNAME_MACHINE based on the output of uname instead of i386? + echo i386-pc-interix + exit 0 ;; + i*:UWIN*:*) + echo ${UNAME_MACHINE}-pc-uwin + exit 0 ;; + p*:CYGWIN*:*) + echo powerpcle-unknown-cygwin + exit 0 ;; + prep*:SunOS:5.*:*) + echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit 0 ;; + *:GNU:*:*) + echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` + exit 0 ;; + i*86:Minix:*:*) + echo ${UNAME_MACHINE}-pc-minix + exit 0 ;; + arm*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit 0 ;; + ia64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit 0 ;; + m68*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit 0 ;; + mips:Linux:*:*) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #undef CPU + #undef mips + #undef mipsel + #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) + CPU=mipsel + #else + #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) + CPU=mips + #else + CPU= + #endif + #endif +EOF + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^CPU=` + rm -f $dummy.c && rmdir $tmpdir + test x"${CPU}" != x && echo "${CPU}-pc-linux-gnu" && exit 0 + ;; + ppc:Linux:*:*) + echo powerpc-unknown-linux-gnu + exit 0 ;; + ppc64:Linux:*:*) + echo powerpc64-unknown-linux-gnu + exit 0 ;; + alpha:Linux:*:*) + case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in + EV5) UNAME_MACHINE=alphaev5 ;; + EV56) UNAME_MACHINE=alphaev56 ;; + PCA56) UNAME_MACHINE=alphapca56 ;; + PCA57) UNAME_MACHINE=alphapca56 ;; + EV6) UNAME_MACHINE=alphaev6 ;; + EV67) UNAME_MACHINE=alphaev67 ;; + EV68*) UNAME_MACHINE=alphaev68 ;; + esac + objdump --private-headers /bin/sh | grep ld.so.1 >/dev/null + if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi + echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC} + exit 0 ;; + parisc:Linux:*:* | hppa:Linux:*:*) + # Look for CPU level + case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in + PA7*) echo hppa1.1-unknown-linux-gnu ;; + PA8*) echo hppa2.0-unknown-linux-gnu ;; + *) echo hppa-unknown-linux-gnu ;; + esac + exit 0 ;; + parisc64:Linux:*:* | hppa64:Linux:*:*) + echo hppa64-unknown-linux-gnu + exit 0 ;; + s390:Linux:*:* | s390x:Linux:*:*) + echo ${UNAME_MACHINE}-ibm-linux + exit 0 ;; + sh*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit 0 ;; + sparc:Linux:*:* | sparc64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit 0 ;; + x86_64:Linux:*:*) + echo x86_64-unknown-linux-gnu + exit 0 ;; + i*86:Linux:*:*) + # The BFD linker knows what the default object file format is, so + # first see if it will tell us. cd to the root directory to prevent + # problems with other programs or directories called `ld' in the path. + # Set LC_ALL=C to ensure ld outputs messages in English. + ld_supported_targets=`cd /; LC_ALL=C ld --help 2>&1 \ + | sed -ne '/supported targets:/!d + s/[ ][ ]*/ /g + s/.*supported targets: *// + s/ .*// + p'` + case "$ld_supported_targets" in + elf32-i386) + TENTATIVE="${UNAME_MACHINE}-pc-linux-gnu" + ;; + a.out-i386-linux) + echo "${UNAME_MACHINE}-pc-linux-gnuaout" + exit 0 ;; + coff-i386) + echo "${UNAME_MACHINE}-pc-linux-gnucoff" + exit 0 ;; + "") + # Either a pre-BFD a.out linker (linux-gnuoldld) or + # one that does not give us useful --help. + echo "${UNAME_MACHINE}-pc-linux-gnuoldld" + exit 0 ;; + esac + # Determine whether the default compiler is a.out or elf + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + #ifdef __ELF__ + # ifdef __GLIBC__ + # if __GLIBC__ >= 2 + LIBC=gnu + # else + LIBC=gnulibc1 + # endif + # else + LIBC=gnulibc1 + # endif + #else + #ifdef __INTEL_COMPILER + LIBC=gnu + #else + LIBC=gnuaout + #endif + #endif +EOF + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^LIBC=` + rm -f $dummy.c && rmdir $tmpdir + test x"${LIBC}" != x && echo "${UNAME_MACHINE}-pc-linux-${LIBC}" && exit 0 + test x"${TENTATIVE}" != x && echo "${TENTATIVE}" && exit 0 + ;; + i*86:DYNIX/ptx:4*:*) + # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. + # earlier versions are messed up and put the nodename in both + # sysname and nodename. + echo i386-sequent-sysv4 + exit 0 ;; + i*86:UNIX_SV:4.2MP:2.*) + # Unixware is an offshoot of SVR4, but it has its own version + # number series starting with 2... + # I am not positive that other SVR4 systems won't match this, + # I just have to hope. -- rms. + # Use sysv4.2uw... so that sysv4* matches it. + echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} + exit 0 ;; + i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) + UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` + if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then + echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} + else + echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} + fi + exit 0 ;; + i*86:*:5:[78]*) + case `/bin/uname -X | grep "^Machine"` in + *486*) UNAME_MACHINE=i486 ;; + *Pentium) UNAME_MACHINE=i586 ;; + *Pent*|*Celeron) UNAME_MACHINE=i686 ;; + esac + echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} + exit 0 ;; + i*86:*:3.2:*) + if test -f /usr/options/cb.name; then + UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then + UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` + (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 + (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ + && UNAME_MACHINE=i586 + (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ + && UNAME_MACHINE=i686 + (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ + && UNAME_MACHINE=i686 + echo ${UNAME_MACHINE}-pc-sco$UNAME_REL + else + echo ${UNAME_MACHINE}-pc-sysv32 + fi + exit 0 ;; + i*86:*DOS:*:*) + echo ${UNAME_MACHINE}-pc-msdosdjgpp + exit 0 ;; + pc:*:*:*) + # Left here for compatibility: + # uname -m prints for DJGPP always 'pc', but it prints nothing about + # the processor, so we play safe by assuming i386. + echo i386-pc-msdosdjgpp + exit 0 ;; + Intel:Mach:3*:*) + echo i386-pc-mach3 + exit 0 ;; + paragon:*:*:*) + echo i860-intel-osf1 + exit 0 ;; + i860:*:4.*:*) # i860-SVR4 + if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then + echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 + else # Add other i860-SVR4 vendors below as they are discovered. + echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 + fi + exit 0 ;; + mini*:CTIX:SYS*5:*) + # "miniframe" + echo m68010-convergent-sysv + exit 0 ;; + M68*:*:R3V[567]*:*) + test -r /sysV68 && echo 'm68k-motorola-sysv' && exit 0 ;; + 3[34]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0) + OS_REL='' + test -r /etc/.relid \ + && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && echo i486-ncr-sysv4.3${OS_REL} && exit 0 + /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ + && echo i586-ncr-sysv4.3${OS_REL} && exit 0 ;; + 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && echo i486-ncr-sysv4 && exit 0 ;; + m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) + echo m68k-unknown-lynxos${UNAME_RELEASE} + exit 0 ;; + mc68030:UNIX_System_V:4.*:*) + echo m68k-atari-sysv4 + exit 0 ;; + i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.0*:*) + echo i386-unknown-lynxos${UNAME_RELEASE} + exit 0 ;; + TSUNAMI:LynxOS:2.*:*) + echo sparc-unknown-lynxos${UNAME_RELEASE} + exit 0 ;; + rs6000:LynxOS:2.*:*) + echo rs6000-unknown-lynxos${UNAME_RELEASE} + exit 0 ;; + PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.0*:*) + echo powerpc-unknown-lynxos${UNAME_RELEASE} + exit 0 ;; + SM[BE]S:UNIX_SV:*:*) + echo mips-dde-sysv${UNAME_RELEASE} + exit 0 ;; + RM*:ReliantUNIX-*:*:*) + echo mips-sni-sysv4 + exit 0 ;; + RM*:SINIX-*:*:*) + echo mips-sni-sysv4 + exit 0 ;; + *:SINIX-*:*:*) + if uname -p 2>/dev/null >/dev/null ; then + UNAME_MACHINE=`(uname -p) 2>/dev/null` + echo ${UNAME_MACHINE}-sni-sysv4 + else + echo ns32k-sni-sysv + fi + exit 0 ;; + PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort + # says + echo i586-unisys-sysv4 + exit 0 ;; + *:UNIX_System_V:4*:FTX*) + # From Gerald Hewes . + # How about differentiating between stratus architectures? -djm + echo hppa1.1-stratus-sysv4 + exit 0 ;; + *:*:*:FTX*) + # From seanf@swdc.stratus.com. + echo i860-stratus-sysv4 + exit 0 ;; + *:VOS:*:*) + # From Paul.Green@stratus.com. + echo hppa1.1-stratus-vos + exit 0 ;; + mc68*:A/UX:*:*) + echo m68k-apple-aux${UNAME_RELEASE} + exit 0 ;; + news*:NEWS-OS:6*:*) + echo mips-sony-newsos6 + exit 0 ;; + R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) + if [ -d /usr/nec ]; then + echo mips-nec-sysv${UNAME_RELEASE} + else + echo mips-unknown-sysv${UNAME_RELEASE} + fi + exit 0 ;; + BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. + echo powerpc-be-beos + exit 0 ;; + BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. + echo powerpc-apple-beos + exit 0 ;; + BePC:BeOS:*:*) # BeOS running on Intel PC compatible. + echo i586-pc-beos + exit 0 ;; + SX-4:SUPER-UX:*:*) + echo sx4-nec-superux${UNAME_RELEASE} + exit 0 ;; + SX-5:SUPER-UX:*:*) + echo sx5-nec-superux${UNAME_RELEASE} + exit 0 ;; + Power*:Rhapsody:*:*) + echo powerpc-apple-rhapsody${UNAME_RELEASE} + exit 0 ;; + *:Rhapsody:*:*) + echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} + exit 0 ;; + *:Darwin:*:*) + echo `uname -p`-apple-darwin${UNAME_RELEASE} + exit 0 ;; + *:procnto*:*:* | *:QNX:[0123456789]*:*) + UNAME_PROCESSOR=`uname -p` + if test "$UNAME_PROCESSOR" = "x86"; then + UNAME_PROCESSOR=i386 + UNAME_MACHINE=pc + fi + echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} + exit 0 ;; + *:QNX:*:4*) + echo i386-pc-qnx + exit 0 ;; + NSR-[GKLNPTVW]:NONSTOP_KERNEL:*:*) + echo nsr-tandem-nsk${UNAME_RELEASE} + exit 0 ;; + *:NonStop-UX:*:*) + echo mips-compaq-nonstopux + exit 0 ;; + BS2000:POSIX*:*:*) + echo bs2000-siemens-sysv + exit 0 ;; + DS/*:UNIX_System_V:*:*) + echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} + exit 0 ;; + *:Plan9:*:*) + # "uname -m" is not consistent, so use $cputype instead. 386 + # is converted to i386 for consistency with other x86 + # operating systems. + if test "$cputype" = "386"; then + UNAME_MACHINE=i386 + else + UNAME_MACHINE="$cputype" + fi + echo ${UNAME_MACHINE}-unknown-plan9 + exit 0 ;; + i*86:OS/2:*:*) + # If we were able to find `uname', then EMX Unix compatibility + # is probably installed. + echo ${UNAME_MACHINE}-pc-os2-emx + exit 0 ;; + *:TOPS-10:*:*) + echo pdp10-unknown-tops10 + exit 0 ;; + *:TENEX:*:*) + echo pdp10-unknown-tenex + exit 0 ;; + KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) + echo pdp10-dec-tops20 + exit 0 ;; + XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) + echo pdp10-xkl-tops20 + exit 0 ;; + *:TOPS-20:*:*) + echo pdp10-unknown-tops20 + exit 0 ;; + *:ITS:*:*) + echo pdp10-unknown-its + exit 0 ;; + i*86:XTS-300:*:STOP) + echo ${UNAME_MACHINE}-unknown-stop + exit 0 ;; + i*86:atheos:*:*) + echo ${UNAME_MACHINE}-unknown-atheos + exit 0 ;; +esac + +#echo '(No uname command or uname output not recognized.)' 1>&2 +#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2 + +eval $set_cc_for_build +cat >$dummy.c < +# include +#endif +main () +{ +#if defined (sony) +#if defined (MIPSEB) + /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, + I don't know.... */ + printf ("mips-sony-bsd\n"); exit (0); +#else +#include + printf ("m68k-sony-newsos%s\n", +#ifdef NEWSOS4 + "4" +#else + "" +#endif + ); exit (0); +#endif +#endif + +#if defined (__arm) && defined (__acorn) && defined (__unix) + printf ("arm-acorn-riscix"); exit (0); +#endif + +#if defined (hp300) && !defined (hpux) + printf ("m68k-hp-bsd\n"); exit (0); +#endif + +#if defined (NeXT) +#if !defined (__ARCHITECTURE__) +#define __ARCHITECTURE__ "m68k" +#endif + int version; + version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; + if (version < 4) + printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); + else + printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); + exit (0); +#endif + +#if defined (MULTIMAX) || defined (n16) +#if defined (UMAXV) + printf ("ns32k-encore-sysv\n"); exit (0); +#else +#if defined (CMU) + printf ("ns32k-encore-mach\n"); exit (0); +#else + printf ("ns32k-encore-bsd\n"); exit (0); +#endif +#endif +#endif + +#if defined (__386BSD__) + printf ("i386-pc-bsd\n"); exit (0); +#endif + +#if defined (sequent) +#if defined (i386) + printf ("i386-sequent-dynix\n"); exit (0); +#endif +#if defined (ns32000) + printf ("ns32k-sequent-dynix\n"); exit (0); +#endif +#endif + +#if defined (_SEQUENT_) + struct utsname un; + + uname(&un); + + if (strncmp(un.version, "V2", 2) == 0) { + printf ("i386-sequent-ptx2\n"); exit (0); + } + if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ + printf ("i386-sequent-ptx1\n"); exit (0); + } + printf ("i386-sequent-ptx\n"); exit (0); + +#endif + +#if defined (vax) +# if !defined (ultrix) +# include +# if defined (BSD) +# if BSD == 43 + printf ("vax-dec-bsd4.3\n"); exit (0); +# else +# if BSD == 199006 + printf ("vax-dec-bsd4.3reno\n"); exit (0); +# else + printf ("vax-dec-bsd\n"); exit (0); +# endif +# endif +# else + printf ("vax-dec-bsd\n"); exit (0); +# endif +# else + printf ("vax-dec-ultrix\n"); exit (0); +# endif +#endif + +#if defined (alliant) && defined (i860) + printf ("i860-alliant-bsd\n"); exit (0); +#endif + + exit (1); +} +EOF + +$CC_FOR_BUILD $dummy.c -o $dummy 2>/dev/null && $dummy && rm -f $dummy.c $dummy && rmdir $tmpdir && exit 0 +rm -f $dummy.c $dummy && rmdir $tmpdir + +# Apollos put the system type in the environment. + +test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit 0; } + +# Convex versions that predate uname can use getsysinfo(1) + +if [ -x /usr/convex/getsysinfo ] +then + case `getsysinfo -f cpu_type` in + c1*) + echo c1-convex-bsd + exit 0 ;; + c2*) + if getsysinfo -f scalar_acc + then echo c32-convex-bsd + else echo c2-convex-bsd + fi + exit 0 ;; + c34*) + echo c34-convex-bsd + exit 0 ;; + c38*) + echo c38-convex-bsd + exit 0 ;; + c4*) + echo c4-convex-bsd + exit 0 ;; + esac +fi + +cat >&2 < in order to provide the needed +information to handle your system. + +config.guess timestamp = $timestamp + +uname -m = `(uname -m) 2>/dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null` + +hostinfo = `(hostinfo) 2>/dev/null` +/bin/universe = `(/bin/universe) 2>/dev/null` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` +/bin/arch = `(/bin/arch) 2>/dev/null` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` + +UNAME_MACHINE = ${UNAME_MACHINE} +UNAME_RELEASE = ${UNAME_RELEASE} +UNAME_SYSTEM = ${UNAME_SYSTEM} +UNAME_VERSION = ${UNAME_VERSION} +EOF + +exit 1 + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "timestamp='" +# time-stamp-format: "%:y-%02m-%02d" +# time-stamp-end: "'" +# End: diff --git a/config.h.in b/config.h.in new file mode 100644 index 0000000..73db90a --- /dev/null +++ b/config.h.in @@ -0,0 +1,21 @@ +/* + * Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons + * LGPL version 2.1 or later (see http://www.gnu.org/copyleft/lesser.html) + */ + +/* symbols that must be assigned to variables in Haskell code */ + +/* NOTE: this is not the same as symbols needed for cpp of .hs code */ + +/* path to ghc */ +#define GHC "@GHC@" + +/* path to GHC libraries */ +#define GHC_LIB_PATH "@GHC_LIB_PATH@" + +#define TOP "@TOP@" + +#define LEADING_UNDERSCORE @LEADING_UNDERSCORE@ + +#define CABAL @CABAL@ + diff --git a/config.mk.in b/config.mk.in new file mode 100644 index 0000000..0f0e613 --- /dev/null +++ b/config.mk.in @@ -0,0 +1,57 @@ +# +# Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +# LGPL version 2.1 or later (see http://www.gnu.org/copyleft/lesser.html) +# + +# +# config.mk.in : +# variables that need to be visible in Makefiles +# + +# all is the default rule for everyone +default: all + +PACKAGE = plugins +UPACKAGE = Plugins + +TOP = @TOP@ + +PREFIX = @PREFIX@ +LIBDIR = $(PREFIX)/lib/hs-$(PACKAGE) +BINDIR = $(PREFIX)/bin + +WHOLE_ARCHIVE_FLAG = @WHOLE_ARCHIVE_FLAG@ + +# Are we using the new Cabal packages? +CABAL = @CABAL@ + + +GHC = @GHC@ +GHC_LIB_PATH = @GHC_LIB_PATH@ +GHC_VERSION = @GHC_VERSION@ +GLASGOW_HASKELL = @GLASGOW_HASKELL@ +GHC_EXTRA_OPTS = @SYMS@ @DEBUG_OPTS@ +GHC_LD_OPTS = + +GHC_PKG = @GHCPKG@-@GHC_VERSION@ + +LD = @LD@ +LD_X = -x + +HAPPY = @HAPPY@ +HAPPY_OPTS = -a -g -c +ALEX = @ALEX@ +ALEX_OPTS = --ghc +HADDOCK = @HADDOCK@ + +AR = @AR@ +RANLIB = @RANLIB@ + +RM = @RM@ + +INSTALL = @INSTALL@ + +# A few aliases +INSTALL_PROGRAM = ${INSTALL} -s -m 755 +INSTALL_DATA = ${INSTALL} -m 644 +INSTALL_DATA_DIR= ${INSTALL} -d -m 755 diff --git a/config.sub b/config.sub new file mode 100644 index 0000000..9ff085e --- /dev/null +++ b/config.sub @@ -0,0 +1,1460 @@ +#! /bin/sh +# Configuration validation subroutine script. +# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, +# 2000, 2001, 2002 Free Software Foundation, Inc. + +timestamp='2002-07-03' + +# This file is (in principle) common to ALL GNU software. +# The presence of a machine in this file suggests that SOME GNU software +# can handle that machine. It does not imply ALL GNU software can. +# +# This file is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. + +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that program. + +# Please send patches to . Submit a context +# diff and a properly formatted ChangeLog entry. +# +# Configuration subroutine to validate and canonicalize a configuration type. +# Supply the specified configuration type as an argument. +# If it is invalid, we print an error message on stderr and exit with code 1. +# Otherwise, we print the canonical config type on stdout and succeed. + +# This file is supposed to be the same for all GNU packages +# and recognize all the CPU types, system types and aliases +# that are meaningful with *any* GNU software. +# Each package is responsible for reporting which valid configurations +# it does not support. The user should be able to distinguish +# a failure to support a valid configuration from a meaningless +# configuration. + +# The goal of this file is to map all the various variations of a given +# machine specification into a single specification in the form: +# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM +# or in some cases, the newer four-part form: +# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM +# It is wrong to echo any other type of specification. + +me=`echo "$0" | sed -e 's,.*/,,'` + +usage="\ +Usage: $0 [OPTION] CPU-MFR-OPSYS + $0 [OPTION] ALIAS + +Canonicalize a configuration name. + +Operation modes: + -h, --help print this help, then exit + -t, --time-stamp print date of last modification, then exit + -v, --version print version number, then exit + +Report bugs and patches to ." + +version="\ +GNU config.sub ($timestamp) + +Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 +Free Software Foundation, Inc. + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." + +help=" +Try \`$me --help' for more information." + +# Parse command line +while test $# -gt 0 ; do + case $1 in + --time-stamp | --time* | -t ) + echo "$timestamp" ; exit 0 ;; + --version | -v ) + echo "$version" ; exit 0 ;; + --help | --h* | -h ) + echo "$usage"; exit 0 ;; + -- ) # Stop option processing + shift; break ;; + - ) # Use stdin as input. + break ;; + -* ) + echo "$me: invalid option $1$help" + exit 1 ;; + + *local*) + # First pass through any local machine types. + echo $1 + exit 0;; + + * ) + break ;; + esac +done + +case $# in + 0) echo "$me: missing argument$help" >&2 + exit 1;; + 1) ;; + *) echo "$me: too many arguments$help" >&2 + exit 1;; +esac + +# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). +# Here we must recognize all the valid KERNEL-OS combinations. +maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` +case $maybe_os in + nto-qnx* | linux-gnu* | freebsd*-gnu* | storm-chaos* | os2-emx* | windows32-* | rtmk-nova*) + os=-$maybe_os + basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` + ;; + *) + basic_machine=`echo $1 | sed 's/-[^-]*$//'` + if [ $basic_machine != $1 ] + then os=`echo $1 | sed 's/.*-/-/'` + else os=; fi + ;; +esac + +### Let's recognize common machines as not being operating systems so +### that things like config.sub decstation-3100 work. We also +### recognize some manufacturers as not being operating systems, so we +### can provide default operating systems below. +case $os in + -sun*os*) + # Prevent following clause from handling this invalid input. + ;; + -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ + -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ + -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ + -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ + -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ + -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ + -apple | -axis) + os= + basic_machine=$1 + ;; + -sim | -cisco | -oki | -wec | -winbond) + os= + basic_machine=$1 + ;; + -scout) + ;; + -wrs) + os=-vxworks + basic_machine=$1 + ;; + -chorusos*) + os=-chorusos + basic_machine=$1 + ;; + -chorusrdb) + os=-chorusrdb + basic_machine=$1 + ;; + -hiux*) + os=-hiuxwe2 + ;; + -sco5) + os=-sco3.2v5 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco4) + os=-sco3.2v4 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco3.2.[4-9]*) + os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco3.2v[4-9]*) + # Don't forget version if it is 3.2v4 or newer. + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco*) + os=-sco3.2v2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -udk*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -isc) + os=-isc2.2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -clix*) + basic_machine=clipper-intergraph + ;; + -isc*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -lynx*) + os=-lynxos + ;; + -ptx*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` + ;; + -windowsnt*) + os=`echo $os | sed -e 's/windowsnt/winnt/'` + ;; + -psos*) + os=-psos + ;; + -mint | -mint[0-9]*) + basic_machine=m68k-atari + os=-mint + ;; +esac + +# Decode aliases for certain CPU-COMPANY combinations. +case $basic_machine in + # Recognize the basic CPU types without company name. + # Some are omitted here because they have special meanings below. + 1750a | 580 \ + | a29k \ + | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ + | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ + | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr \ + | c4x | clipper \ + | d10v | d30v | dlx | dsp16xx \ + | fr30 | frv \ + | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ + | i370 | i860 | i960 | ia64 \ + | ip2k \ + | m32r | m68000 | m68k | m88k | mcore \ + | mips | mipsbe | mipseb | mipsel | mipsle \ + | mips16 \ + | mips64 | mips64el \ + | mips64orion | mips64orionel \ + | mips64vr4100 | mips64vr4100el \ + | mips64vr4300 | mips64vr4300el \ + | mips64vr5000 | mips64vr5000el \ + | mipsisa32 | mipsisa32el \ + | mipsisa64 | mipsisa64el \ + | mipsisa64sb1 | mipsisa64sb1el \ + | mipstx39 | mipstx39el \ + | mn10200 | mn10300 \ + | ns16k | ns32k \ + | openrisc | or32 \ + | pdp10 | pdp11 | pj | pjl \ + | powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \ + | pyramid \ + | sh | sh[1234] | sh3e | sh[34]eb | shbe | shle | sh[1234]le | sh3ele \ + | sh64 | sh64le \ + | sparc | sparc64 | sparc86x | sparclet | sparclite | sparcv9 | sparcv9b \ + | strongarm \ + | tahoe | thumb | tic80 | tron \ + | v850 | v850e \ + | we32k \ + | x86 | xscale | xstormy16 | xtensa \ + | z8k) + basic_machine=$basic_machine-unknown + ;; + m6811 | m68hc11 | m6812 | m68hc12) + # Motorola 68HC11/12. + basic_machine=$basic_machine-unknown + os=-none + ;; + m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) + ;; + + # We use `pc' rather than `unknown' + # because (1) that's what they normally are, and + # (2) the word "unknown" tends to confuse beginning users. + i*86 | x86_64) + basic_machine=$basic_machine-pc + ;; + # Object if more than one company name word. + *-*-*) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; + # Recognize the basic CPU types with company name. + 580-* \ + | a29k-* \ + | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ + | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ + | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \ + | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ + | avr-* \ + | bs2000-* \ + | c[123]* | c30-* | [cjt]90-* | c54x-* \ + | clipper-* | cydra-* \ + | d10v-* | d30v-* | dlx-* \ + | elxsi-* \ + | f30[01]-* | f700-* | fr30-* | frv-* | fx80-* \ + | h8300-* | h8500-* \ + | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ + | i*86-* | i860-* | i960-* | ia64-* \ + | ip2k-* \ + | m32r-* \ + | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ + | m88110-* | m88k-* | mcore-* \ + | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ + | mips16-* \ + | mips64-* | mips64el-* \ + | mips64orion-* | mips64orionel-* \ + | mips64vr4100-* | mips64vr4100el-* \ + | mips64vr4300-* | mips64vr4300el-* \ + | mips64vr5000-* | mips64vr5000el-* \ + | mipsisa32-* | mipsisa32el-* \ + | mipsisa64-* | mipsisa64el-* \ + | mipsisa64sb1-* | mipsisa64sb1el-* \ + | mipstx39 | mipstx39el \ + | none-* | np1-* | ns16k-* | ns32k-* \ + | orion-* \ + | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ + | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* | ppcbe-* \ + | pyramid-* \ + | romp-* | rs6000-* \ + | sh-* | sh[1234]-* | sh3e-* | sh[34]eb-* | shbe-* \ + | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ + | sparc-* | sparc64-* | sparc86x-* | sparclet-* | sparclite-* \ + | sparcv9-* | sparcv9b-* | strongarm-* | sv1-* | sx?-* \ + | tahoe-* | thumb-* | tic30-* | tic54x-* | tic80-* | tron-* \ + | v850-* | v850e-* | vax-* \ + | we32k-* \ + | x86-* | x86_64-* | xps100-* | xscale-* | xstormy16-* \ + | xtensa-* \ + | ymp-* \ + | z8k-*) + ;; + # Recognize the various machine names and aliases which stand + # for a CPU type and a company and sometimes even an OS. + 386bsd) + basic_machine=i386-unknown + os=-bsd + ;; + 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) + basic_machine=m68000-att + ;; + 3b*) + basic_machine=we32k-att + ;; + a29khif) + basic_machine=a29k-amd + os=-udi + ;; + adobe68k) + basic_machine=m68010-adobe + os=-scout + ;; + alliant | fx80) + basic_machine=fx80-alliant + ;; + altos | altos3068) + basic_machine=m68k-altos + ;; + am29k) + basic_machine=a29k-none + os=-bsd + ;; + amdahl) + basic_machine=580-amdahl + os=-sysv + ;; + amiga | amiga-*) + basic_machine=m68k-unknown + ;; + amigaos | amigados) + basic_machine=m68k-unknown + os=-amigaos + ;; + amigaunix | amix) + basic_machine=m68k-unknown + os=-sysv4 + ;; + apollo68) + basic_machine=m68k-apollo + os=-sysv + ;; + apollo68bsd) + basic_machine=m68k-apollo + os=-bsd + ;; + aux) + basic_machine=m68k-apple + os=-aux + ;; + balance) + basic_machine=ns32k-sequent + os=-dynix + ;; + c90) + basic_machine=c90-cray + os=-unicos + ;; + convex-c1) + basic_machine=c1-convex + os=-bsd + ;; + convex-c2) + basic_machine=c2-convex + os=-bsd + ;; + convex-c32) + basic_machine=c32-convex + os=-bsd + ;; + convex-c34) + basic_machine=c34-convex + os=-bsd + ;; + convex-c38) + basic_machine=c38-convex + os=-bsd + ;; + cray | j90) + basic_machine=j90-cray + os=-unicos + ;; + crds | unos) + basic_machine=m68k-crds + ;; + cris | cris-* | etrax*) + basic_machine=cris-axis + ;; + da30 | da30-*) + basic_machine=m68k-da30 + ;; + decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) + basic_machine=mips-dec + ;; + decsystem10* | dec10*) + basic_machine=pdp10-dec + os=-tops10 + ;; + decsystem20* | dec20*) + basic_machine=pdp10-dec + os=-tops20 + ;; + delta | 3300 | motorola-3300 | motorola-delta \ + | 3300-motorola | delta-motorola) + basic_machine=m68k-motorola + ;; + delta88) + basic_machine=m88k-motorola + os=-sysv3 + ;; + dpx20 | dpx20-*) + basic_machine=rs6000-bull + os=-bosx + ;; + dpx2* | dpx2*-bull) + basic_machine=m68k-bull + os=-sysv3 + ;; + ebmon29k) + basic_machine=a29k-amd + os=-ebmon + ;; + elxsi) + basic_machine=elxsi-elxsi + os=-bsd + ;; + encore | umax | mmax) + basic_machine=ns32k-encore + ;; + es1800 | OSE68k | ose68k | ose | OSE) + basic_machine=m68k-ericsson + os=-ose + ;; + fx2800) + basic_machine=i860-alliant + ;; + genix) + basic_machine=ns32k-ns + ;; + gmicro) + basic_machine=tron-gmicro + os=-sysv + ;; + go32) + basic_machine=i386-pc + os=-go32 + ;; + h3050r* | hiux*) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + h8300hms) + basic_machine=h8300-hitachi + os=-hms + ;; + h8300xray) + basic_machine=h8300-hitachi + os=-xray + ;; + h8500hms) + basic_machine=h8500-hitachi + os=-hms + ;; + harris) + basic_machine=m88k-harris + os=-sysv3 + ;; + hp300-*) + basic_machine=m68k-hp + ;; + hp300bsd) + basic_machine=m68k-hp + os=-bsd + ;; + hp300hpux) + basic_machine=m68k-hp + os=-hpux + ;; + hp3k9[0-9][0-9] | hp9[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hp9k2[0-9][0-9] | hp9k31[0-9]) + basic_machine=m68000-hp + ;; + hp9k3[2-9][0-9]) + basic_machine=m68k-hp + ;; + hp9k6[0-9][0-9] | hp6[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hp9k7[0-79][0-9] | hp7[0-79][0-9]) + basic_machine=hppa1.1-hp + ;; + hp9k78[0-9] | hp78[0-9]) + # FIXME: really hppa2.0-hp + basic_machine=hppa1.1-hp + ;; + hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) + # FIXME: really hppa2.0-hp + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][13679] | hp8[0-9][13679]) + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][0-9] | hp8[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hppa-next) + os=-nextstep3 + ;; + hppaosf) + basic_machine=hppa1.1-hp + os=-osf + ;; + hppro) + basic_machine=hppa1.1-hp + os=-proelf + ;; + i370-ibm* | ibm*) + basic_machine=i370-ibm + ;; +# I'm not sure what "Sysv32" means. Should this be sysv3.2? + i*86v32) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv32 + ;; + i*86v4*) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv4 + ;; + i*86v) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv + ;; + i*86sol2) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-solaris2 + ;; + i386mach) + basic_machine=i386-mach + os=-mach + ;; + i386-vsta | vsta) + basic_machine=i386-unknown + os=-vsta + ;; + iris | iris4d) + basic_machine=mips-sgi + case $os in + -irix*) + ;; + *) + os=-irix4 + ;; + esac + ;; + isi68 | isi) + basic_machine=m68k-isi + os=-sysv + ;; + m88k-omron*) + basic_machine=m88k-omron + ;; + magnum | m3230) + basic_machine=mips-mips + os=-sysv + ;; + merlin) + basic_machine=ns32k-utek + os=-sysv + ;; + mingw32) + basic_machine=i386-pc + os=-mingw32 + ;; + miniframe) + basic_machine=m68000-convergent + ;; + *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) + basic_machine=m68k-atari + os=-mint + ;; + mips3*-*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` + ;; + mips3*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown + ;; + mmix*) + basic_machine=mmix-knuth + os=-mmixware + ;; + monitor) + basic_machine=m68k-rom68k + os=-coff + ;; + morphos) + basic_machine=powerpc-unknown + os=-morphos + ;; + msdos) + basic_machine=i386-pc + os=-msdos + ;; + mvs) + basic_machine=i370-ibm + os=-mvs + ;; + ncr3000) + basic_machine=i486-ncr + os=-sysv4 + ;; + netbsd386) + basic_machine=i386-unknown + os=-netbsd + ;; + netwinder) + basic_machine=armv4l-rebel + os=-linux + ;; + news | news700 | news800 | news900) + basic_machine=m68k-sony + os=-newsos + ;; + news1000) + basic_machine=m68030-sony + os=-newsos + ;; + news-3600 | risc-news) + basic_machine=mips-sony + os=-newsos + ;; + necv70) + basic_machine=v70-nec + os=-sysv + ;; + next | m*-next ) + basic_machine=m68k-next + case $os in + -nextstep* ) + ;; + -ns2*) + os=-nextstep2 + ;; + *) + os=-nextstep3 + ;; + esac + ;; + nh3000) + basic_machine=m68k-harris + os=-cxux + ;; + nh[45]000) + basic_machine=m88k-harris + os=-cxux + ;; + nindy960) + basic_machine=i960-intel + os=-nindy + ;; + mon960) + basic_machine=i960-intel + os=-mon960 + ;; + nonstopux) + basic_machine=mips-compaq + os=-nonstopux + ;; + np1) + basic_machine=np1-gould + ;; + nsr-tandem) + basic_machine=nsr-tandem + ;; + op50n-* | op60c-*) + basic_machine=hppa1.1-oki + os=-proelf + ;; + or32 | or32-*) + basic_machine=or32-unknown + os=-coff + ;; + OSE68000 | ose68000) + basic_machine=m68000-ericsson + os=-ose + ;; + os68k) + basic_machine=m68k-none + os=-os68k + ;; + pa-hitachi) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + paragon) + basic_machine=i860-intel + os=-osf + ;; + pbd) + basic_machine=sparc-tti + ;; + pbb) + basic_machine=m68k-tti + ;; + pc532 | pc532-*) + basic_machine=ns32k-pc532 + ;; + pentium | p5 | k5 | k6 | nexgen | viac3) + basic_machine=i586-pc + ;; + pentiumpro | p6 | 6x86 | athlon) + basic_machine=i686-pc + ;; + pentiumii | pentium2) + basic_machine=i686-pc + ;; + pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) + basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentiumpro-* | p6-* | 6x86-* | athlon-*) + basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentiumii-* | pentium2-*) + basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pn) + basic_machine=pn-gould + ;; + power) basic_machine=power-ibm + ;; + ppc) basic_machine=powerpc-unknown + ;; + ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppcle | powerpclittle | ppc-le | powerpc-little) + basic_machine=powerpcle-unknown + ;; + ppcle-* | powerpclittle-*) + basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppc64) basic_machine=powerpc64-unknown + ;; + ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppc64le | powerpc64little | ppc64-le | powerpc64-little) + basic_machine=powerpc64le-unknown + ;; + ppc64le-* | powerpc64little-*) + basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ps2) + basic_machine=i386-ibm + ;; + pw32) + basic_machine=i586-unknown + os=-pw32 + ;; + rom68k) + basic_machine=m68k-rom68k + os=-coff + ;; + rm[46]00) + basic_machine=mips-siemens + ;; + rtpc | rtpc-*) + basic_machine=romp-ibm + ;; + s390 | s390-*) + basic_machine=s390-ibm + ;; + s390x | s390x-*) + basic_machine=s390x-ibm + ;; + sa29200) + basic_machine=a29k-amd + os=-udi + ;; + sequent) + basic_machine=i386-sequent + ;; + sh) + basic_machine=sh-hitachi + os=-hms + ;; + sparclite-wrs | simso-wrs) + basic_machine=sparclite-wrs + os=-vxworks + ;; + sps7) + basic_machine=m68k-bull + os=-sysv2 + ;; + spur) + basic_machine=spur-unknown + ;; + st2000) + basic_machine=m68k-tandem + ;; + stratus) + basic_machine=i860-stratus + os=-sysv4 + ;; + sun2) + basic_machine=m68000-sun + ;; + sun2os3) + basic_machine=m68000-sun + os=-sunos3 + ;; + sun2os4) + basic_machine=m68000-sun + os=-sunos4 + ;; + sun3os3) + basic_machine=m68k-sun + os=-sunos3 + ;; + sun3os4) + basic_machine=m68k-sun + os=-sunos4 + ;; + sun4os3) + basic_machine=sparc-sun + os=-sunos3 + ;; + sun4os4) + basic_machine=sparc-sun + os=-sunos4 + ;; + sun4sol2) + basic_machine=sparc-sun + os=-solaris2 + ;; + sun3 | sun3-*) + basic_machine=m68k-sun + ;; + sun4) + basic_machine=sparc-sun + ;; + sun386 | sun386i | roadrunner) + basic_machine=i386-sun + ;; + sv1) + basic_machine=sv1-cray + os=-unicos + ;; + symmetry) + basic_machine=i386-sequent + os=-dynix + ;; + t3d) + basic_machine=alpha-cray + os=-unicos + ;; + t3e) + basic_machine=alphaev5-cray + os=-unicos + ;; + t90) + basic_machine=t90-cray + os=-unicos + ;; + tic54x | c54x*) + basic_machine=tic54x-unknown + os=-coff + ;; + tx39) + basic_machine=mipstx39-unknown + ;; + tx39el) + basic_machine=mipstx39el-unknown + ;; + toad1) + basic_machine=pdp10-xkl + os=-tops20 + ;; + tower | tower-32) + basic_machine=m68k-ncr + ;; + udi29k) + basic_machine=a29k-amd + os=-udi + ;; + ultra3) + basic_machine=a29k-nyu + os=-sym1 + ;; + v810 | necv810) + basic_machine=v810-nec + os=-none + ;; + vaxv) + basic_machine=vax-dec + os=-sysv + ;; + vms) + basic_machine=vax-dec + os=-vms + ;; + vpp*|vx|vx-*) + basic_machine=f301-fujitsu + ;; + vxworks960) + basic_machine=i960-wrs + os=-vxworks + ;; + vxworks68) + basic_machine=m68k-wrs + os=-vxworks + ;; + vxworks29k) + basic_machine=a29k-wrs + os=-vxworks + ;; + w65*) + basic_machine=w65-wdc + os=-none + ;; + w89k-*) + basic_machine=hppa1.1-winbond + os=-proelf + ;; + windows32) + basic_machine=i386-pc + os=-windows32-msvcrt + ;; + xps | xps100) + basic_machine=xps100-honeywell + ;; + ymp) + basic_machine=ymp-cray + os=-unicos + ;; + z8k-*-coff) + basic_machine=z8k-unknown + os=-sim + ;; + none) + basic_machine=none-none + os=-none + ;; + +# Here we handle the default manufacturer of certain CPU types. It is in +# some cases the only manufacturer, in others, it is the most popular. + w89k) + basic_machine=hppa1.1-winbond + ;; + op50n) + basic_machine=hppa1.1-oki + ;; + op60c) + basic_machine=hppa1.1-oki + ;; + romp) + basic_machine=romp-ibm + ;; + rs6000) + basic_machine=rs6000-ibm + ;; + vax) + basic_machine=vax-dec + ;; + pdp10) + # there are many clones, so DEC is not a safe bet + basic_machine=pdp10-unknown + ;; + pdp11) + basic_machine=pdp11-dec + ;; + we32k) + basic_machine=we32k-att + ;; + sh3 | sh4 | sh3eb | sh4eb | sh[1234]le | sh3ele) + basic_machine=sh-unknown + ;; + sh64) + basic_machine=sh64-unknown + ;; + sparc | sparcv9 | sparcv9b) + basic_machine=sparc-sun + ;; + cydra) + basic_machine=cydra-cydrome + ;; + orion) + basic_machine=orion-highlevel + ;; + orion105) + basic_machine=clipper-highlevel + ;; + mac | mpw | mac-mpw) + basic_machine=m68k-apple + ;; + pmac | pmac-mpw) + basic_machine=powerpc-apple + ;; + c4x*) + basic_machine=c4x-none + os=-coff + ;; + *-unknown) + # Make sure to match an already-canonicalized machine name. + ;; + *) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; +esac + +# Here we canonicalize certain aliases for manufacturers. +case $basic_machine in + *-digital*) + basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` + ;; + *-commodore*) + basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` + ;; + *) + ;; +esac + +# Decode manufacturer-specific aliases for certain operating systems. + +if [ x"$os" != x"" ] +then +case $os in + # First match some system type aliases + # that might get confused with valid system types. + # -solaris* is a basic system type, with this one exception. + -solaris1 | -solaris1.*) + os=`echo $os | sed -e 's|solaris1|sunos4|'` + ;; + -solaris) + os=-solaris2 + ;; + -svr4*) + os=-sysv4 + ;; + -unixware*) + os=-sysv4.2uw + ;; + -gnu/linux*) + os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` + ;; + # First accept the basic system types. + # The portable systems comes first. + # Each alternative MUST END IN A *, to match a version number. + # -sysv* is not here because it comes later, after sysvr4. + -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ + | -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\ + | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \ + | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ + | -aos* \ + | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ + | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ + | -hiux* | -386bsd* | -netbsd* | -openbsd* | -freebsd* | -riscix* \ + | -lynxos* | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ + | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ + | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ + | -chorusos* | -chorusrdb* \ + | -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ + | -mingw32* | -linux-gnu* | -uxpv* | -beos* | -mpeix* | -udk* \ + | -interix* | -uwin* | -rhapsody* | -darwin* | -opened* \ + | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ + | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ + | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ + | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* | -powermax*) + # Remember, each alternative MUST END IN *, to match a version number. + ;; + -qnx*) + case $basic_machine in + x86-* | i*86-*) + ;; + *) + os=-nto$os + ;; + esac + ;; + -nto*) + os=-nto-qnx + ;; + -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ + | -windows* | -osx | -abug | -netware* | -os9* | -beos* \ + | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) + ;; + -mac*) + os=`echo $os | sed -e 's|mac|macos|'` + ;; + -linux*) + os=`echo $os | sed -e 's|linux|linux-gnu|'` + ;; + -sunos5*) + os=`echo $os | sed -e 's|sunos5|solaris2|'` + ;; + -sunos6*) + os=`echo $os | sed -e 's|sunos6|solaris3|'` + ;; + -opened*) + os=-openedition + ;; + -wince*) + os=-wince + ;; + -osfrose*) + os=-osfrose + ;; + -osf*) + os=-osf + ;; + -utek*) + os=-bsd + ;; + -dynix*) + os=-bsd + ;; + -acis*) + os=-aos + ;; + -atheos*) + os=-atheos + ;; + -386bsd) + os=-bsd + ;; + -ctix* | -uts*) + os=-sysv + ;; + -nova*) + os=-rtmk-nova + ;; + -ns2 ) + os=-nextstep2 + ;; + -nsk*) + os=-nsk + ;; + # Preserve the version number of sinix5. + -sinix5.*) + os=`echo $os | sed -e 's|sinix|sysv|'` + ;; + -sinix*) + os=-sysv4 + ;; + -triton*) + os=-sysv3 + ;; + -oss*) + os=-sysv3 + ;; + -svr4) + os=-sysv4 + ;; + -svr3) + os=-sysv3 + ;; + -sysvr4) + os=-sysv4 + ;; + # This must come after -sysvr4. + -sysv*) + ;; + -ose*) + os=-ose + ;; + -es1800*) + os=-ose + ;; + -xenix) + os=-xenix + ;; + -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) + os=-mint + ;; + -none) + ;; + *) + # Get rid of the `-' at the beginning of $os. + os=`echo $os | sed 's/[^-]*-//'` + echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 + exit 1 + ;; +esac +else + +# Here we handle the default operating systems that come with various machines. +# The value should be what the vendor currently ships out the door with their +# machine or put another way, the most popular os provided with the machine. + +# Note that if you're going to try to match "-MANUFACTURER" here (say, +# "-sun"), then you have to tell the case statement up towards the top +# that MANUFACTURER isn't an operating system. Otherwise, code above +# will signal an error saying that MANUFACTURER isn't an operating +# system, and we'll never get to this point. + +case $basic_machine in + *-acorn) + os=-riscix1.2 + ;; + arm*-rebel) + os=-linux + ;; + arm*-semi) + os=-aout + ;; + # This must come before the *-dec entry. + pdp10-*) + os=-tops20 + ;; + pdp11-*) + os=-none + ;; + *-dec | vax-*) + os=-ultrix4.2 + ;; + m68*-apollo) + os=-domain + ;; + i386-sun) + os=-sunos4.0.2 + ;; + m68000-sun) + os=-sunos3 + # This also exists in the configure program, but was not the + # default. + # os=-sunos4 + ;; + m68*-cisco) + os=-aout + ;; + mips*-cisco) + os=-elf + ;; + mips*-*) + os=-elf + ;; + or32-*) + os=-coff + ;; + *-tti) # must be before sparc entry or we get the wrong os. + os=-sysv3 + ;; + sparc-* | *-sun) + os=-sunos4.1.1 + ;; + *-be) + os=-beos + ;; + *-ibm) + os=-aix + ;; + *-wec) + os=-proelf + ;; + *-winbond) + os=-proelf + ;; + *-oki) + os=-proelf + ;; + *-hp) + os=-hpux + ;; + *-hitachi) + os=-hiux + ;; + i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) + os=-sysv + ;; + *-cbm) + os=-amigaos + ;; + *-dg) + os=-dgux + ;; + *-dolphin) + os=-sysv3 + ;; + m68k-ccur) + os=-rtu + ;; + m88k-omron*) + os=-luna + ;; + *-next ) + os=-nextstep + ;; + *-sequent) + os=-ptx + ;; + *-crds) + os=-unos + ;; + *-ns) + os=-genix + ;; + i370-*) + os=-mvs + ;; + *-next) + os=-nextstep3 + ;; + *-gould) + os=-sysv + ;; + *-highlevel) + os=-bsd + ;; + *-encore) + os=-bsd + ;; + *-sgi) + os=-irix + ;; + *-siemens) + os=-sysv4 + ;; + *-masscomp) + os=-rtu + ;; + f30[01]-fujitsu | f700-fujitsu) + os=-uxpv + ;; + *-rom68k) + os=-coff + ;; + *-*bug) + os=-coff + ;; + *-apple) + os=-macos + ;; + *-atari*) + os=-mint + ;; + *) + os=-none + ;; +esac +fi + +# Here we handle the case where we know the os, and the CPU type, but not the +# manufacturer. We pick the logical manufacturer. +vendor=unknown +case $basic_machine in + *-unknown) + case $os in + -riscix*) + vendor=acorn + ;; + -sunos*) + vendor=sun + ;; + -aix*) + vendor=ibm + ;; + -beos*) + vendor=be + ;; + -hpux*) + vendor=hp + ;; + -mpeix*) + vendor=hp + ;; + -hiux*) + vendor=hitachi + ;; + -unos*) + vendor=crds + ;; + -dgux*) + vendor=dg + ;; + -luna*) + vendor=omron + ;; + -genix*) + vendor=ns + ;; + -mvs* | -opened*) + vendor=ibm + ;; + -ptx*) + vendor=sequent + ;; + -vxsim* | -vxworks* | -windiss*) + vendor=wrs + ;; + -aux*) + vendor=apple + ;; + -hms*) + vendor=hitachi + ;; + -mpw* | -macos*) + vendor=apple + ;; + -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) + vendor=atari + ;; + -vos*) + vendor=stratus + ;; + esac + basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` + ;; +esac + +echo $basic_machine$os +exit 0 + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "timestamp='" +# time-stamp-format: "%:y-%02m-%02d" +# time-stamp-end: "'" +# End: diff --git a/configure.ac b/configure.ac new file mode 100644 index 0000000..fd987be --- /dev/null +++ b/configure.ac @@ -0,0 +1,198 @@ +# +# Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +# LGPL version 2.1 or later (see http://www.gnu.org/copyleft/lesser.html) +# + +# sanity test +AC_INIT(src/plugins/Plugins.hs) + +# untested on earlier than 2.52, but it won't work anyway +AC_PREREQ(2.53) + +# Find out what type of system we're running on +AC_CANONICAL_BUILD + +PREFIX="$prefix" +if test "$prefix" = "NONE" +then + PREFIX="$ac_default_prefix" +fi +AC_SUBST(PREFIX) + +Platform="$build_cpu-$build_vendor-$build_os" + +case $Platform in +powerpc-apple-darwin*) + MACOSX=yes + ;; +*) + MACOSX=no + ;; +esac +if test "$MACOSX" = "yes" +then + WHOLE_ARCHIVE_FLAG=-all_load + LEADING_UNDERSCORE=1 +else + WHOLE_ARCHIVE_FLAG=--whole-archive + LEADING_UNDERSCORE=0 +fi + +AC_SUBST(WHOLE_ARCHIVE_FLAG) +AC_SUBST(LEADING_UNDERSCORE) + + +TOP=`pwd` +AC_SUBST(TOP) + +# necessary tools + +# allow user supplied haskell compiler +AC_ARG_WITH(ghc, + AC_HELP_STRING([--with-ghc=],[use a specific Haskell compiler]), + [ GHC="$withval" + if test ! -f "$GHC" ; then + AC_MSG_ERROR([$GHC not found. You need GHC to build this project]) + fi + ], + [ AC_CHECK_PROG(GHC,ghc,ghc) + if test -z "$GHC" ; then + AC_MSG_ERROR([You need GHC to build this project]) + fi + ] + ) +AC_SUBST(GHC) + +# find path to GHC libs, for runtime_loader +if test -n "$GHC" ; then + AC_MSG_CHECKING([for ghc library directory]) + GHC_LIB_PATH=`$GHC --print-libdir` + AC_MSG_RESULT([$GHC_LIB_PATH]) +fi +AC_SUBST(GHC_LIB_PATH) + +# check ghc version here +if test -n "$GHC" ; then + AC_MSG_CHECKING([for ghc version]) + GHC_VERSION=`$GHC --numeric-version` + AC_MSG_RESULT([$GHC_VERSION]) +fi +AC_SUBST(GHC_VERSION) + +# Work out value of __GLASGOW_HASKELL__ +if test -n "$GHC" ; then + AC_MSG_CHECKING([for value of __GLASGOW_HASKELL__]) + echo "main = print __GLASGOW_HASKELL__" > t.hs + GLASGOW_HASKELL=`echo 'main' | "$GHC" --interactive -v0 -cpp t.hs` + rm t.hs + AC_MSG_RESULT([$GLASGOW_HASKELL]) +fi +AC_SUBST(GLASGOW_HASKELL) + +dnl ** quote char breaks sed +changequote(, )dnl +MAJOR=`echo "$GHC_VERSION" | sed 's/^\([^\.]*\)\.\([^\.]*\).*/\1/'` +MINOR=`echo "$GHC_VERSION" | sed 's/^\([^\.]*\)\.\([^\.]*\).*/\2/'` +changequote([, ])dnl + +if test "$MAJOR" -lt "6"; then + AC_MSG_ERROR(Found major $MAJOR. You need a ghc version >= 6.2) ; +fi +if test "$MINOR" -lt "2"; then + AC_MSG_ERROR(You need a ghc version >= 6.2) ; +fi + +#Allow plugins to be built with Cabal libraries +AC_ARG_ENABLE(cabal, + [ --enable-cabal Enable use of Cabal packages in pluggable-1-branch + of GHC], + [ CABAL=1 ], + [ CABAL=0 ]) + +# used by the Makefile`s to alter dependencies. +if test "$MAJOR" -ge "6" -a "$MINOR" -ge "4"; then + CABAL=1 +fi + +AC_SUBST(CABAL) + +# Allow a debugging version of hs-plugins to be built +AC_ARG_ENABLE(debug, + [ --enable-debug Enable a debug version of hs-plugins to be built], + [ DEBUG_OPTS=-DDEBUG ], + [ DEBUG_OPTS= ]) + +AC_SUBST(DEBUG_OPTS) + +# allow user supplied haskell package manager +AC_ARG_WITH(ghc-pkg, + AC_HELP_STRING([--with-ghc-pkg=],[use a specific ghc-pkg]), + [ GHCPKG="$withval" + if test ! -f "$GHCPKG" ; then + AC_MSG_ERROR([$GHCPKG not found. You need ghc-pkg]) + fi + ], + [ AC_CHECK_PROG(GHCPKG,ghc-pkg,ghc-pkg) + if test -z "$GHCPKG" ; then + AC_MSG_ERROR([You need ghc-pkg]) + fi + ] + ) + +AC_SUBST(GHCPKG) + +AC_CHECK_PROG(HADDOCK,haddock,haddock) +if test -z "$HADDOCK" ; then + AC_MSG_WARN(You need Haddock if you want developer documentation) +fi + +AC_CHECK_PROG(HAPPY,happy,happy) +if test -z "$HAPPY" ; then + AC_MSG_WARN(If you change or remove the parser you'll need Happy) +fi + +AC_CHECK_PROG(ALEX,alex,alex) +if test -z "$ALEX" ; then + AC_MSG_WARN(If you change or remove the lexer files you'll need alex) +fi + +AC_CHECK_PROG(LD,ld,ld) +if test -z "$LD" ; then + AC_MSG_WARN(You need ld -export-dynamic) +fi + +AC_CHECK_PROG(AR,ar,ar) +if test -z "$AR" ; then + AC_MSG_WARN(You need ar to build the library) +fi + +AC_CHECK_PROG(RANLIB,ranlib,ranlib) +if test -z "$RANLIB" ; then + AC_MSG_WARN(You need randlib to build the library) +fi + +AC_CHECK_PROG(RM,rm,rm) +if test -z "$RM" ; then + AC_MSG_WARN(You need rm!) +fi + +AC_CHECK_PROG(TEX,tex,tex) +if test -z "$TEX" ; then + AC_MSG_WARN(You'll need tex if you wish to build the documentation) +fi +AC_CHECK_PROG(TEX2PAGE,tex2page,tex2page) +if test -z "$TEX2PAGE" ; then + AC_MSG_WARN(You'll need tex2page if you wish to build the + documentation: http://www.ccs.neu.edu/home/dorai/tex2page/tex2page-doc.html) +fi + +AC_CHECK_FUNC(arc4random, [SYMS="$SYMS -DHAVE_ARC4RANDOM"]) + +AC_SUBST(SYMS) + +AC_PROG_INSTALL + +AC_CONFIG_FILES(config.mk config.h) + +AC_OUTPUT + diff --git a/docs/Makefile b/docs/Makefile new file mode 100644 index 0000000..bfa3b46 --- /dev/null +++ b/docs/Makefile @@ -0,0 +1,31 @@ +# Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +# LGPL version 2.1 or later (see http://www.gnu.org/copyleft/lesser.html) + +.PHONY: build clean html + +SRC = hs-plugins + +build: $(SRC).ps html + +$(SRC).ps: $(SRC).dvi + dvips -f $(SRC).dvi > $@ + +html: $(SRC).tex + tex2page $(SRC) + tex2page $(SRC) + ./munge.sed < $(SRC)/$(SRC).html > tmp.out + mv tmp.out $(SRC)/$(SRC).html + cp $(SRC)/$(SRC).html $(SRC)/index.html + tar czf $(SRC).html.tar.gz $(SRC) + mv $(SRC).html.tar.gz $(SRC)/ + +$(SRC).dvi: $(SRC).tex + latex $(SRC).tex && latex $(SRC).tex + +CLEANS= *.{ps,dvi,aux,log} *~ hs-plugins *-Z-* *.toc + +clean: + rm -rf $(CLEANS) + +all: doc + diff --git a/docs/haskell.sty b/docs/haskell.sty new file mode 100644 index 0000000..5fd028b --- /dev/null +++ b/docs/haskell.sty @@ -0,0 +1,452 @@ +%%% This is a LaTeX2e style file. +%%% +%%% It supports setting functional languages like Haskell. +%%% +%%% Manuel M. T. Chakravarty [1998..2000] +%%% +%%% $Id: haskell.sty,v 1.2 2004/05/16 08:20:09 dons Exp $ +%%% +%%% This file is free software; you can redistribute it and/or modify +%%% it under the terms of the GNU General Public License as published by +%%% the Free Software Foundation; either version 2 of the License, or +%%% (at your option) any later version. +%%% +%%% This file is distributed in the hope that it will be useful, +%%% but WITHOUT ANY WARRANTY; without even the implied warranty of +%%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +%%% GNU General Public License for more details. +%%% +%%% Acknowledegments ========================================================== +%%% +%%% Thanks to Gabriele Keller for beta testing and +%%% code contributions. Thanks to the LaTeX3 project for improving the LaTeX +%%% sources (which helped me writing this code). Furthermore, I am grateful +%%% to Martin Erwig for feedback and +%%% suggestions, and to Conal Elliott for pointing out +%%% a tricky bug. +%%% +%%% TODO ====================================================================== +%%% +%%% B ~ bug; F ~ feature +%%% +%%% * F: Along the lines of the discussion with Martin Erwig add support for +%%% keywords etc (see the emails) +%%% +%%% * B: If we have as input +%%% +%%% \ +%%% +%%% there won't be a `\hsap' inserted!! (Can this be solved by using +%%% \obeylines in \<...\>?) +%%% +%%% * B: A \relax is needed after a & if it immediately followed by a \hsbody{} +%%% (See TeXbook, S.240) +%%% +%%% * F: Implement a \hstext{...} as \(\text{...}\). +%%% +%%% * We would like hswhere* etc that are like haskell* (\hsalign already +%%% supports this, ie, there is a \hsalign*). +%%% +%%% * Star-Versions of if, let etc that use a single line layout (maybe not +%%% with star, because of the above). +%%% +%%% * Support for enforcing and prohibiting breaks in `haskell' displays. +%%% +%%% * Comments in a let-in should be aligned in the same way for the bindings +%%% and the body. +%%% +%%% * It would be nice to have different styles (indentation after in of +%%% let-in or not) etc; either to be set with a package option or in the +%%% preamble (the latter probably makes more sense). +%%% +%%% * Literate programming facility: Variant of the `haskell' env (maybe +%%% `hschunk', which is named and can be used in other chunks). But maybe +%%% it is not necessary to provide a chunk-based reordering mechanism, +%%% because most of the Haskell stuff can be in any order anyway... +%%% Important is to provide a way to define visually pleasing layout +%%% together with the raw Haskell form for program output. (Maybe `haskell*' +%%% as Haskell env that outputs its contents?) +%%% + +%% Initialization +%% ============== + +\NeedsTeXFormat{LaTeX2e} +\ProvidesPackage{haskell}[2000/10/05 v1.0e Chilli's Haskell Style] + + +%% Parameters +%% ========== + +\newskip\hsmargin +\hsmargin\leftmargini + + +%% Main macros and environments +%% ============================ + +% applications +% +\newcommand{\hsap}{% % application by juxtaposition + \unskip\mskip 4mu plus 1mu} % only the last \hsap counts + +% commands to start and stop setting spaces as \hsap +% +{\obeyspaces\gdef\@hsSpaceToApp{\obeyspaces\let =\hsap}} % spaces matter!!! +{\obeyspaces\gdef\@hsNormalSpace{\let =\space}} + +% commands to start and stop treating numbers specially, ie, we don't want +% them to be affected by font changing commands in Haskell contexts as this +% would give italic numerals; the trick is to redefine their math code such +% that they go into math class 0 and thus don't change families (cf. `The +% TeXbook', Chapter 17, pp152) +% +\newcommand{\@hsRmNumbers}{% + \mathcode`0="0030 + \mathcode`1="0031 + \mathcode`2="0032 + \mathcode`3="0033 + \mathcode`4="0034 + \mathcode`5="0035 + \mathcode`6="0036 + \mathcode`7="0037 + \mathcode`8="0038 + \mathcode`9="0039 + } +\newcommand{\@hsNormalNumbers}{% + \mathcode`0="7030 + \mathcode`1="7031 + \mathcode`2="7032 + \mathcode`3="7033 + \mathcode`4="7034 + \mathcode`5="7035 + \mathcode`6="7036 + \mathcode`7="7037 + \mathcode`8="7038 + \mathcode`9="7039 + } + +% Save the bindings of the standard math commands +% +% This is somewhat subtle as we want to able to enter the original math mode +% within Haskell mode and we have to ensure that the different opening +% commands are matched by the correct versions of the closing commands. +% +\let\@hsmathorg=\( +\let\@hsmathendorg=\) +\let\hs@crorg=\\ +\newcommand{\@hsmath}{% + \relax\hbox\bgroup + \@hsNormalSpace + \@hsNormalNumbers + \let\(=\@hsmathorgx + \let\)=\@hsmathend + \def\\{\hs@crorg}% + \@hsmathorg + } +\newcommand{\@hsmathend}{% + \@hsmathendorg + \egroup + } +\newcommand{\@hsmathorgx}{% + \relax\@hsmathorg + \let\)=\@hsmathendorg + } + +%% Typesetting of Haskell +%% ====================== + +% Inline Haskell phrases are delimited by `\<' and `\>'. +% +% Note: `\>' is only locally redefined. +% +\newcommand{\<}{% + \@hsmathorg + \mathit\bgroup + \@hsSpaceToApp + \@hsRmNumbers + \let\>=\@endhs + \let\(=\@hsmath + \def\\{\cr} % for Haskell alignments + } +\newcommand{\@endhs}{% + \egroup + \@hsmathendorg + } + +% Displayed Haskell (environment `haskell' and `haskell*') +% +% There are two kind of preambles for \halign: \hs@preambleNorm is for +% `amsmath' style alignments and \hs@preambleStar for `equation' style +% alignments (but with an unbound number of columns to its right) +% +% We need #### to get a ## in the \edef building the \halign command. +% +% first the preambles (also used in \hs@align below): +% +\def\hs@preambleNorm{% + \noexpand\<####\unskip\noexpand\>\hfil&&\noexpand% + \<{}####\unskip\noexpand\>\hfil} +\def\hs@preambleStar{% + \noexpand\<####\unskip\noexpand\>\hfil&\hfil\noexpand% + \<{}####\unskip{}\noexpand\>\hfil&&\noexpand\<{}####\noexpand\>\hfil} +% +% the environments: +% +\newenvironment{haskell}{% + \@haskell\hs@preambleNorm}{% + \@endhaskell + } +\newenvironment{haskell*}{% + \@haskell\hs@preambleStar}{% + \@endhaskell + } +% +% auxiliary definition getting the preamble as its first argument and starting +% the environment: +% +\def\@haskell#1{% + \bgroup + \vspace\abovedisplayskip + \let\(=\@hsmath % Important when `\(' occurs after `&'! + \edef\@preamble{% + \halign\bgroup\hskip\hsmargin#1\cr} + \@preamble + } +% +% Auxiliary definition ending environment: +% +\def\@endhaskell{% + \crcr\egroup + \vspace\belowdisplayskip + \egroup\noindent\ignorespaces\global\@ignoretrue% + } + +% single line comment and keyword style +% +\newcommand{\hscom}[1]{% + \relax\(\quad\textnormal{--- #1}\)} +\newcommand{\hskwd}[1]{% + \mathbf{#1}} + +% informal description +% +\newcommand{\hsinf}[1]{% + \(\langle\textnormal{#1}\rangle\)} + +% literals and some special symbols +% +\newcommand{\hschar}[1]{\textrm'\mathrm{#1}\textrm'} % character literals +\newcommand{\hsstr}[1]{"\mathrm{#1}"} % strings literals +\newcommand{\hsfrom}{\leftarrow} % <- + +% aligned subphrases +% +% check for an optional star and combine prefix (in #1) with one of the two +% preambles (with star means to center the material between the first and +% second &) +% +\def\hs@align#1{% + \@ifstar + {\hs@align@pre{#1\hs@preambleStar}}% + {\hs@align@pre{#1\hs@preambleNorm}}% + } +% +% test for optional argument; #1: preamble +% +\def\hs@align@pre#1{% + \@testopt{\hs@align@prealign#1}t} +% +% got all arguments, now for the real code; #1: preamble; #2: alignment; +% #3: body (the material set by the \halign) +% +\def\hs@align@prealign#1[#2]#3{% + \relax\( + \edef\@preamble{% + \halign\bgroup#1\cr} + \if #2t\vtop \else \if#2b\vbox \else \vcenter \fi\fi + \bgroup% + \@preamble + #3% + \crcr\egroup% + \egroup\) + } +% +% user-level command: alignment without a prefix +% +\newcommand{\hsalign}{% + \relax + \hs@align\relax% + } + +% subphrase breaking the surrounding alignment being flushed left +% +\newcommand{\hsnoalign}[1]{% + \noalign{% + \hs@align{\hskip\hsmargin}{#1}% + }% + } + +% body expression breaking the surrounding alignment +% +% * setting \hsmargin to 0pt within the preamble (and _after_ it is used in +% the preamble) is crucial, as we want \hsmargin only to be applied in +% _outermost_ alignments +% +\newcommand{\hsbody}[1]{% + {}\\ + \noalign{% + \hs@align{\hskip\hsmargin\quad\hsmargin0pt}{#1}% + }% + } + + +%% Defining commands for use in the Haskell mode +%% ============================================= +%% +%% We use some of the low-level machinery defined in LaTeX's source file +%% `ltdefns.dtx'. +%% +%% \hscommand is similar to \newcommand, but there is no *-version. +%% +%% We use our own definitions here to insert a strategic `\relax' (see below) +%% and to obey spaces within the bodies of Haskell definitions. + +\newcommand{\hscommand}[1]{\@testopt{\hs@newcommand#1}0} +\def\hs@newcommand#1[#2]{% + \obeyspaces % spaces count in Haskell macros + \@ifnextchar [{\hs@xargdef#1[#2]}% + {\hs@argdef#1[#2]}} + +% All this trouble only to be able to add the `\relax' into the expansion +% process. If we don't that, commands without optional arguments when +% invoked after an alignment character & don't work properly (actually, the +% \obeyspaces doesn't work). I am sure that has to do with the scanning for +% \omit etc in \halign (TeXbook, p240), but I don't understand yet why it +% is problematic in this case. +% +% Furthermore, we switch off \obeyspaces in the end. +% +\long\def\hs@argdef#1[#2]#3{% + \@ifdefinable#1{% + \expandafter\def\expandafter#1\expandafter{% + \relax % in order to stop token expansion after & + \csname\string#1\expandafter\endcsname}% + \expandafter\@yargdef + \csname\string#1\endcsname + \@ne + {#2}% + {#3}}% + \catcode`\ =10% % stop obeying spaces now + } + +% Switch off \obeyspaces in the end. +% +\long\def\hs@xargdef#1[#2][#3]#4{% + \@ifdefinable#1{% + \expandafter\def\expandafter#1\expandafter{% + \expandafter + \@protected@testopt + \expandafter + #1% + \csname\string#1\expandafter\endcsname + {#3}}% + \expandafter\@yargdef + \csname\string#1\endcsname + \tw@ + {#2}% + {#4}}% + \catcode`\ =10% % stop obeying spaces now + } + + +%% Abbreviations +%% ============= + +% infix operators +% +\newcommand{\hsapp}{\mathbin{+\mkern-7mu+}} +\newcommand{\hsifix}[1]{\mathbin{\string`#1\string`}} + +% let expression +% +\hscommand{\hslet}[3][t]{% + \hsalign[#1]{% + \hskwd{let}\\ + \quad\hsalign{#2}\\ + \hskwd{in}\\ + #3 + }% + } + +% if expression +% +\hscommand{\hsif}[4][t]{% + \hsalign[#1]{% + \hskwd{if} #2 \hskwd{then}\\ + \quad\hsalign{#3}\\ + \hskwd{else}\\ + \quad\hsalign{#4}% + }% + } + +% case expression +% +\hscommand{\hscase}[3][t]{% + \hsalign[#1]{% + \hskwd{case} #2 \hskwd{of}\\ + \quad\hsalign{#3}% + }% + } + +% where clause +% +% * it is important to take the \quad into the preamble, so that nested +% \noaligns can break it +% +\hscommand{\hswhere}[1]{% + \hsbody{% + \hskwd{where}\\ + \hs@align{\quad}{#1}% + }% + } + +% do expression +% +\hscommand{\hsdo}[2][t]{% + \hsalign[#1]{% + \hskwd{do}\\ + \quad\hsalign{#2}\\ + }% + } + + +%% Extensions for Distributed Haskell (Goffin) +%% =========================================== +%% +%% These definitions may change in the future. + +\hscommand{\hsunif}{\mathbin{:=:}} +\hscommand{\hsalias}{\mathrel{\sim}} +\hscommand{\hsoutof}{\twoheadleftarrow} +\hscommand{\hsinto}{\twoheadrightarrow} +\hscommand{\hsparc}{\binampersand} +\hscommand{\hsseq}{\Longrightarrow} +\hscommand{\hsex}[2]{{\hskwd{ex} #1 \hskwd{in} #2}} + +\hscommand{\hsexin}[3][t]{% + \hsalign[#1]{% + \hskwd{ex} #2 \hskwd{in}\\ + \quad\hsalign{#3}\\ + }% + } + +\hscommand{\hschoice}[2][t]{% + \hsalign[#1]{% + \hskwd{choice}\\ + \quad\hsalign{#2}\\ + }% + } + + diff --git a/docs/hs-plugins.1 b/docs/hs-plugins.1 new file mode 100644 index 0000000..64cfa9c --- /dev/null +++ b/docs/hs-plugins.1 @@ -0,0 +1,36 @@ +.TH HS-PLUGINS 1 2005-03-26 "hs-plugins version 0.9.8" "User Manual" + +.SH NAME +hs-plugins \- dynamic linker library for Haskell + +.SH DESCRIPTION +.ds c \fIhs-plugins\fP +\*c is a library for loading plugins written in Haskell into an +application at runtime. It also provides a mechanism for (re)compiling +Haskell source at runtime. Thirdly, a combination of runtime compilation +and dynamic loading provides a suite of eval functions. Values exported +by plugins are transparently available to Haskell host applications, and +bindings exist to use Haskell plugins from at least C and Objective C +programs. hs-plugins requires ghc-6.2.2 or greater. + +.SH DOCUMENTATION +The hs-plugins user manual is distributed in html format, and may be +found at + +.SH BUGS +Bug reports, and any other feedback, should be sent to +Don Stewart +.SH COPYRIGHT +Copyright \(co 2004-2005 Don Stewart +.PP +The hs-plugins library modules are distributed under the terms of the +LGPL. +.SH "SEE ALSO" +.BR dlopen (3) + +.SH AUTHOR + +This manual page was written by Don Stewart, based on the man page for +cpphs (written by Ian Lynagh). + + diff --git a/docs/hs-plugins.hdir b/docs/hs-plugins.hdir new file mode 100644 index 0000000..7637edc --- /dev/null +++ b/docs/hs-plugins.hdir @@ -0,0 +1 @@ +hs-plugins diff --git a/docs/hs-plugins.tex b/docs/hs-plugins.tex new file mode 100644 index 0000000..77a8e02 --- /dev/null +++ b/docs/hs-plugins.tex @@ -0,0 +1,1808 @@ +\documentclass{article} + +\usepackage{url} +\usepackage{tex2page} + +% typeset math as ascii +\htmlmathstyle{no-in-text-image no-display-image} + +% something other than | +\verbescapechar\& + +\cssblock +h1 {font-size: 16pt} +h2 {font-size: 15pt} +\endcssblock + +% color of verbatim elements +\cssblock +.verbatim {color: grey20} + +.scheme .variable {color: grey20} +.scheme .keyword {color: navy} +.scheme .builtin {color: maroon} +\endcssblock + +% add some extra keywords +\scmkeyword{as case class data default deriving do else hiding if} +\scmkeyword{import in infix infixl infixr instance let module newtype} +\scmkeyword{of qualified then type where forall \\ } +\scmbuiltin{: :: = -> <- @ ~ => - >>= >> } + +\newcommand{\code}[1]{{\texttt{#1}}} +\newcommand{\hsplugins}{{\texttt{hs-plugins}}} + +\title{hs-plugins\\ + Dynamically Loaded Haskell Modules} + +\author{\urlh{http://www.cse.unsw.edu.au/~dons}{Don Stewart}} + +\begin{document} + +\maketitle + +\medskip +% +{\htmlonly \textbf{Download \endhtmlonly +\urlh{ftp://ftp.cse.unsw.edu.au/pub/users/dons/hs-plugins/hs-plugins-0.9.8.tar.gz} + {version 0.9.8}} +% +\medskip + +\hsplugins{} is a library for loading plugins written in Haskell into an +application at runtime. It also provides a mechanism for (re)compiling +Haskell source at runtime. Thirdly, a combination of runtime compilation +and dynamic loading provides a suite of \code{eval} functions. Values +exported by plugins are transparently available to Haskell host +applications, and bindings exist to use Haskell plugins from at least C +and Objective C programs. \hsplugins{} currently requires ghc-6.2.2. + +\medskip + +% grr. double spaced. + +\tableofcontents + +\newpage + +\section{Download} + +\begin{itemize} + +\item +Download the latest stable release:\\ +\url{ftp://ftp.cse.unsw.edu.au/pub/users/dons/hs-plugins/hs-plugins-0.9.8.tar.gz} + + +\item +Nightly cvs src snapshots are available at:\\ +\url{ftp://ftp.cse.unsw.edu.au/pub/users/dons/hs-plugins/snapshots/} + + +\item +A tarball of the document you are reading:\\ +\url{http://www.cse.unsw.edu.au/~dons/hs-plugins/hs-plugins.html.tar.gz} + + +\item +A postscript version of the document you are reading:\\ +\url{http://www.cse.unsw.edu.au/~dons/hs-plugins/hs-plugins.ps.gz} + + +\item +A paper on interesting uses of \hsplugins{} to enable Haskell to be used +as an application extension language:\\ +\url{http://www.cse.unsw.edu.au/~dons/hs-plugins/paper} + +\end{itemize} + +It is known to run on \code{i386-\{linux,freebsd,openbsd\}}, +\code{ia64-linux}, \code{sparc-solaris2} and \code{powerpc}'s running +Mac OSX. It should run on any machine with a working GHCi +implementation. + +\section{History} + +\begin{itemize} + \item v0.9.8 + \begin{itemize} + \item Fix bug in .hi parsing. + \item Add reloading of packages. + \item Fix bug in canonical module names + (fixing problems with "Foo.o" and "./Foo.o" + \item Fix for hierarchical names, don't guess them, + read them from the .hi file. + \item Add new varients of load. + \item Fix bug in makeAll, such that dependent module + changes were not noticed. + \item Add varient of eval:\code{ unsafeEval\_}, returing + Either. + \item Better, bigger testsuite. + \item Better api. + \end{itemize} + + \item Septemeber 2004. + \begin{itemize} + \item makeAll + \item Better return type for make. + \end{itemize} + + \item Mid August 2004, v0.9.6 release. + \begin{itemize} + \item More portable, thanks to debugging by Niklas Broberg. + \item Other small fixes to the interfaces. + \item Provides a runtime-generated printf. + \end{itemize} + + \item Mid July 2004, added new pdynload strategy. + + \item Mid-June 2004, v0.9.5 release. + \begin{itemize} + \item dynamic typing is working + + \item static typing of interfaces is working + + \item Adds \code{eval}, and \code{hs\_eval} + + \item bugs fixed. + \end{itemize} + + \item Early-June 2004, v0.9.4 release. + \begin{itemize} + + \item Adds a .hi file parser. We use this to work out + plugin dependencies directly, meaning no more + \code{.dep} files or \code{ghcp}. + + \item It also adds a package.conf parser, meaning we + can properly handle packages that either aren't stored + in the normal location, don't have a canonical name, + or are found using a -package-conf argument. Thanks to + Sean for this work. + + \item the interface to load() has changed to allow a + list of package.conf files to search for packages. + + \item the interace to make() has changed, so that you + can get back any stderr output produced during plugin + compilation. + + \item It solves a bug whereby a package that is + required by another package would not be loaded unless + the plugin itself depended on this indirect package. + + \item more stable, more examples. + \end{itemize} + + \item May 2004, v0.9.3 released, adding support for dependency + conflict resolution between multiple plugins. Several plugins with + shared dependencies can now be safely loaded at once. --prefix is now + respected in ./configure. Thanks to Sean for this patch. + + \item v0.9.2 change licence to LGPL + + \item v0.9.1 expand on the documentation + + \item v0.9 released, initial source release + +\end{itemize} + +\section{Acknowledgements} + +\begin{itemize} + +\item Andr\'e Pang's \code{runtime\_loader} was the inspiration and basis +of the dynamic loader (\url{http://www.algorithm.com.au}). +\hsplugins{} has benefited from many discussions with him, +particularly to do with dependency checking and dynamic typing, and +bug reports. Andr\'e wrote an objective C binding to hs-plugins, and +helped with the design of eval(). He also fixed GHC so we could load +the dynamic loader dynamically. + +\item Sean Seefried (\url{http://www.cse.unsw.edu.au/~sseefried}) was +the first user of \hsplugins{} and his code and feedback have helped +make the library much more useful and powerful. + +\item Manuel Chakravarty's \code{take} system provided the basis for +\code{make}, and helped with several issues to do with safety of +plugins, apis and the applications that use them. +Manuel also helped with the design of eval(), and on how to +successfully evaluate polymorphic functions using rank-N types. + +\item Simon Marlow helped with several issues to do with linking and +loading static and dynamic code, and provided many useful suggestions. + +\item Hampus Ram's dynamic loader +(\url{http://www.dtek.chalmers.se/~d00ram/dynamic/}) provided the +design of the state maintained by the loader, and for thread safety +issues relating to this. + +\item Shae Erisson provided several insights into more powerful uses +of the library. Thanks to everyone on \#haskell who provided +discussion about the library. + +\item Malcolm Wallace's \code{hmake} provided some useful insights in +how to compile Haskell source in a way that makes it appear like an +interpreter, used in the interactive environment: \code{plugs}. + +\item Niklas Broberg helped a lot by testing, and providing feedback for +the new make and load API. Thanks Niklas. + +\item Finally, thanks to everyone who has worked on GHC and its +libraries: for GHCi, the .hi interface parser, the package system, and +all the other code the \hsplugins{} depends on. + +\end{itemize} + +\newpage + +\section{Overview} + +\hsplugins{} is a library for compiling and loading Haskell code into a +program at runtime. It allows you to write a Haskell program (which may +be spread over multiple modules) and have an application (implemented in +any language with a Haskell FFI binding, including Haskell) load your +code at runtime, and use the values found within. + +\hsplugins{} provides 3 major features: +% +\begin{itemize} + \item a dynamic loader, + \item a compilation manager, and + \item a Haskell evaluator +\end{itemize} + +The \emph{dynamic loader} loads objects into the address space of an +application, along with any dependencies the plugin may have. The +loader is a binding to the GHC loader, which does single object +loading. GHC also performs the necessary linking of new objects into +the running process. On top of the GHC loader is our Haskell layer +that arranges for module and package dependencies to be found prior to +loading individual modules. + +The \emph{compilation manager} is a \code{make}-like system for +compiling Haskell source code into a form suitable for loading +dynamically. While plugins are normally thought of as strictly object +code, there are a variety of scenarios where it is desirable to be +able to inspect the source code of a plugin, or to be able to +recompile a plugin at runtime. The compilation manager fills this +role. It is particularly useful in the implementation of \code{eval}, +and \code{printf}. + +The \emph{evaluator}, \code{eval}, is a client of the loader and +compilation manager. When passed a string of Haskell code, it compiles +the string to object code, loads the result, and returns a Haskell +value representing the compiled string to the caller. It can be +considered a Haskell interpreter, implemented as a library. + +\section{Dynamic Loader} + +The interface to the \hsplugins{} library can be divided into a number +of sections representing the functional units of the library. +Additionally, depending on the level of trust the application places +in the plugins, a variety of additional checks can be made on the +plugin as it is loaded. The levels of type safety possible are +summarised at the end of Section \ref{sec:compilation-manger} section. +The dynamic loader is available by using \code{-package plugins}. + +\subsection*{Interface} +% +\begin{quote} +\scm{ +load :: FilePath + -> [FilePath] + -> [PackageConf] + -> Symbol + -> IO (LoadStatus a) +} + +\scm{ +load_ :: FilePath + -> [FilePath] + -> Symbol + -> IO (LoadStatus a) +} + +\scm{ +data LoadStatus a + = LoadSuccess Module a + | LoadFailure Errors +} +\end{quote} +% +Example: +% +\begin{quote} +\scm{ +do mv <- load "Plugin.o" ["api"] [] "resource" + case mv of + LoadFailure msg -> print msg + LoadSuccess _ v -> return v +} +\end{quote} +% +This is the basic interface to the dynamic loader. Load the object file +specified by the first argument into the address space (the library will +preload any module or package dependencies). The second argument is an +include path to any additional objects to load (possibly the API of the +plugin). The third argument is a list of paths to any user-defined +\code{package.conf} files, specifying packages unknown to the GHC +package system. \code{Symbol} is a string specifying the symbol name you +wish to lookup. \code{load} returns a \code{LoadStatus} value representing +failure, or an abstract representation of the module (for calls to +\code{unload} or \code{reload}) with the symbol as a Haskell value. The +value returned must be given an explicit type signature, or provided +with appropriate type constraints such that GHC can determine the +expected type returned by \code{load}, as the return type is notionally +polymorphic. + +\code{load\_} is provided for the common situation where no user-defined +package.conf files are required. + +\begin{quote} +\scm{ +dynload :: Typeable a + => FilePath + -> [FilePath] + -> [PackageConf] + -> Symbol + -> IO (LoadStatus a) +} +\end{quote} +% +Example: +% +\begin{quote} +\scm{ +do mv <- dynload "Plugin.o" ["api"] ["plugins.conf.inplace"] "resource" + case mv of + LoadFailure msg -> print msg + LoadSuccess _ v -> putStrLn v +} +\end{quote} +% +\code{dynload} is a safer form of \code{load}. It uses dynamic types +to perform a check on the value returned by \code{load} at runtime, to +ensure that it has the type the application expects it to have. +\code{pdynload} is on average 7\% slower than an unchecked load. + +In order to use \code{dynload}, the symbol the plugin exports must be +of type \code{AltData.Dynamic:Dynamic}. (See the \code{AltData} library +distributed with \hsplugins{}, and the \hsplugins{} +\code{examples/dynload} directory. References to \code{Typeable} and +\code{Dynamic} refer to the \hsplugins{} reimplementation of these +libraries. \code{AltData.Dynamic} is used at the moment, as there is a +limitation in the existing Data.Dynamic library in the presence of +dynamic loading. This will be fixed soon). + +The value wrapped up in the \code{Dynamic} must be an instance of +\code{AltData.Typeable}. If the value exported by the plugin \emph{is} +of type \code{Dynamic}, and the value wrapped by the \code{Dynamic} +does not match the type expected of it by the application, +\code{dynload} will return \code{Nothing}, indicating that the plugin +is not typesafe with respect to the application. If the value passes +the typecheck, \code{dynload} will return \code{LoadSuccess}. If the value +exported by the plugin is \emph{not} of type \code{Dynamic}, +\code{dynload} will crash---this is a limitation of the existing +\code{Dynamic} library, it can only type-check \code{Dynamic} values. +Additionally, Data.Dynamic is limited to monomorphic types, or must be +wrapped inside a rank-N type to hide the polymorphism from the +typechecker. This is a bit cumbersome. An alternative typesafe +\code{load} is available via the \code{pdynload} interface, which is +able to enforce the type of the plugin using GHC's type inference +mechanism, and is not restricted in its expressiveness (at the cost of greater load +times): + +\begin{quote} +\scm{ +pdynload :: FilePath + -> [FilePath] + -> [PackageConf] + -> Type + -> Symbol + -> IO (LoadStatus a) +} +\end{quote} +% +Example: +% +\begin{quote} +\scm{ +do v <- pdynload "Plugin.o" ["api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ a -> putStrLn "yay!" + _ -> putStrLn "type error" +} +\end{quote} +% +\code{pdynload} is a replacement for \code{dynload}, which provides a +solution to the various problems caused by the existing dynamics +library in Haskell. Rather than use normal dynamics, which constrain +us to monomorphic types only (or rank-N types), it instead uses GHC's +type inference to unify the plugin's export value with that provided +by the api (via its .hi file). It is a form of \emph{staged type inference} +for module interfaces, allowing plugins to use any type definable in Haskell. +\code{pdynload} is like \code{dynload}, but requires a new \code{Type} +argument. This can be considered a type annotation on the value the plugin +should be constrained to. + +The type of the plugin's resource field must be equivalent to the +\code{Type}. Prior to loading the object, \code{pdynload} generates a +tiny Haskell source file containing, for example: +% +\begin{quote} +\scm{ +module APITypeConstraint where +import qualified API +import qualified Plugin + +_ = Plugin.resource :: API.Interface +} +\end{quote} +% +It then calls GHC's type checker on this file, which runs the full +Haskell type inference machinery. If the file typecheckes, then the +plugin type is correct, and the plugin is safe to load, otherwise it +is an error. + +Because we use the full Haskell type checker, we can have a form of +dynamic typechecking, on any type expressable in Haskell. A plugin's +value may, for example, have class constraints -- something not +checkable using the standard Dyanmic type. The cost is that +\code{pdynload} is roughly 46\% slower than an unchecked load. + +\begin{quote} +\scm{ +unload :: Module -> IO () +} +\end{quote} + +Unload an object, \emph{but not its dependencies} from the address +space. + +\begin{quote} +\scm{ +reload :: Module -> Symbol -> IO (LoadStatus a) +} +\end{quote} + +Unload, and then reload a module that must have been previously +loaded. Doesn't reload the dependencies. \code{reload} is useful in +conjunction with \code{make}---a call to \code{reload} can be +performed if \code{make} has recompiled the plugin source. + +Additionally, some support is provided to manipulation of +libraries of Haskell modules (usually known as packages): + +\begin{quote} +\scm{ +loadPackage :: String -> IO () + +unloadPackage :: String -> IO () + +loadPackageWith :: String -> [PackageConf] -> IO () +} +\end{quote} + +\code{loadPackage} explcitly pulls in a library (which must be visible +in the current package namespace. \code{unloadPackage} unloads it. +\code{loadPackageWith} behaves like \code{loadPackage}, but you are able +to supply extra package.confs to augment the library search path. + +Examples: +\begin{quote} +\scm{ +do loadPackageWith "yi" ["yi.conf"] + unloadPackage "yi" +} +\end{quote} + +\newpage + +\section{Compilation Manager} + +The compilation manager is the system by which Haskell source code is +compiled to object code suitable for loading. + +\subsection*{Interface} + +\begin{quote} +\scm{ +make :: FilePath + -> [Arg] + -> IO MakeStatus + +makeAll :: FilePath + -> [Arg] + -> IO MakeStatus + +data MakeStatus + = MakeSuccess MakeCode FilePath + | MakeFailure Errors + +data MakeCode = ReComp | NotReq +} +\end{quote} + +Compile a Haskell source file to an object file, with any arguments +specified in the argument list passed through to GHC. Returns the +build status. + +\code{make} generates a GHC \code{.hi} file containing a list of +package and objects that the source depends on. Subsequent calls to +\code{load} will use this interface file to load module and library +dependencies prior to loading the object itself. \code{makeAll} also +recursively compiles any dependencies it can find using GHC's +\code{--make} flag. + +\begin{quote} +\scm{ +merge :: FilePath -> FilePath -> IO MergeStatus + +mergeTo :: FilePath -> FilePath -> FilePath -> IO MergeStatus + +data MergeStatus + = MergeSuccess MergeCode Args FilePath + | MergeFailure Errors + +type MergeCode = MakeCode +} +\end{quote} + +The merging operation is extremely useful for providing extra default +syntax. An EDSL user then need not worry about declaring module names, +or having required imports. In this way, the stub file can also be +used to provide syntax declarations that would be inconvenient to +require of the plugin author. \code{merge} will include any import and +export declarations written in the stub, as well as any module name, +so that plugin author's need not worry about this compulsory syntax. +Additionally, if a plugin requires some non-standard library, which +must be provided as a \code{-package} flag to GHC, they may specify +this using the non-standard \code{GLOBALOPTIONS} pragma. Options +specified in the source this way will be added to the command line. +This is useful for users who wish to use GHC flags that cannot be +specified using the conventional \code{OPTIONS} pragma. + +\begin{quote} +\scm{ +makeWith :: FilePath + -> FilePath + -> [Arg] + -> IO MakeStatus +} +\end{quote} + +This is a variety of \code{make} that first calls \code{merge} to +combine the plugin source with a syntax stub. The result is then +compiled. This is the preferred interface to EDSL authors who wish to +add extra syntax to a user's source. It is important to note that the +module and types from the second file argument are used to override +any of those that appear in the first argument. For example, consider +the following source files: + +\begin{quote} +\scm{ +module A where + +a :: Integer +a = 1 +} +\end{quote} + +\begin{quote} +\scm{ +module B where + +a :: Int +} +\end{quote} + +Calling \code{makeWith "A" "B" []} will merge the module name and types +from module B into module A, generating a third file: + +\begin{quote} +\scm{ +{-# LINE 1 "A.hs" #-} +module MxYz123 where + +{-# LINE 3 "B.hs" #-} +a :: Int +{-# LINE 4 "A.hs" #-} +a = 1 +} +\end{quote} + +Leading to the desired result that we can ignore user-supplied module +names and types. Knowing the module name, in particular, is important +for dynamic loading, which requires the module name be known when +searching for symbols. + +\subsection*{Levels of Safety} + +The normal dynamic loader, using \code{load} on object files only, +places full trust in the author of the plugin to provide a type-safe +object file, containing valid code. This can be mitigated somewhat via +the use of \code{make} to ensure that the plugin is at least Haskell +code that is well-typed internally (if we trust GHC to compile it +correctly). + +If we trust the user to provide an interface of \code{Dynamic} type, we +can check the plugin type at runtime, but the plugin's value must be +\code{Typeable}, which restricts it to be a monomorphic type (or to +using rank-N tricks). + +The greatest safety can be obtained by using \code{pdynload}, at the +cost of increased load times. \code{pdynload} essentially performs full +type inference on the plugin interface at runtime. The type safety of +the plugin, using \code{pdynload}, is then as safe as if the plugin was +statically compiled into the application. It does not provide any +\emph{further} safety than exists in static compilation. For example, it +does not preclude the use of (evil) \code{unsafeCoerce\#} to defeat +type-checking, either statically or at runtime. An extensive discussion +of type safe plugin loading is available in the \hsplugins{} paper +\urlh{http://www.cse.unsw.edu.au/~dons/hs-plugins/paper}{here}. + +\newpage + +\section{Eval.Haskell} + +\code{eval}, and its siblings, provide a mechanism to compile and run +Haskell code at runtime, in the form of a String. It is provided as a +separate package to the plugins package, and needs to be linked +against using \code{-package eval}. The general framework is that the +string is used to create a plugin source file, which is compiled and +loaded, and type checked against its use. The resulting value is +returned to the caller. It resembles the \code{eval} primitives of +scripting languages. + +\subsection*{Interface} + +\begin{quote} +\scm{ +eval :: Typeable a => String -> [Import] -> IO (Maybe a) +} +\end{quote} + +\code{eval} takes a string, and a list of import module names, and +returns a \code{Maybe} value. \code{Nothing} means the code did not +compile. \code{Just v} gives you \code{v}, the result of evaluating +your code. It is interesting to note that \code{eval} has the type of +an interpreter. The \code{Typeable} constraint is used to type check +the evaluated code when it is loaded, using \code{dynload}. The +existing \code{Data.Dynamic} library requires that only monomorphic +values are \code{Typeable}, so in order to evaluate polymorphic +functions you need to wrap them up using rank-N types. Some +examples: +% +\begin{quote} +\scm{ +import Eval.Haskell + +main = do i <- eval "1 + 6 :: Int" [] :: IO (Maybe Int) + if isJust i then putStrLn (show (fromJust i)) else return () +} +\end{quote} + +When executed this program calls \code{eval} to compile and load the +simple arithmetic expression, returning the result, which is +displayed. If the value loaded is not of type \code{Int}, +\code{dynload} will throw an exception. + +The following example, due to Manuel Chakravarty, shows how to +evaluate a polymorphic function. Polymorphic values are not easily +made dynamically typeable, but this example shows how to do it. The +module \code{Poly} is imported as the second argument, providing the +type of the polymorphic function: +% +\begin{quote} +\scm{ +import Poly +import Eval.Haskell + +main = do m_f <- eval "Fn (\\x y -> x == y)" ["Poly"] + when (isJust m_f) $ do + let (Fn f) = fromJust m_f + putStrLn $ show (f True True) + putStrLn $ show (f 1 2) +} +\end{quote} +% +And the type of \code{Fn}: +% +\begin{quote} +\scm{ +{-# OPTIONS -fglasgow-exts #-} +module Poly where + +import AltData.Typeable + +data Fn = Fn {fn :: forall t. Eq t => t -> t -> Bool} + +instance Typeable Fn where + typeOf _ = mkAppTy (mkTyCon "Poly.Fn") [] +} +\end{quote} +% +When executed, this program produces: +% +\begin{quote} +\begin{verbatim} +$ ./a.out +True +False +\end{verbatim} +\end{quote} + +We thus get dynamically typeable polymorphic functions. + +\begin{quote} +\scm{ +unsafeEval :: String -> [Import] -> IO (Maybe a) + +unsafeEval_ :: String + -> [Import] + -> [String] + -> [FilePath] + -> IO (Either [String] a) +} +\end{quote} + +Wrapping up polymorphic values can be annoying, so we provide a +\code{unsafeEval} function for people who like to live on the edge, +which dispenses with dynamic typing, relying instead on the +application to provide the correct type annotation on the call to +\code{eval}. If the type loaded by \code{eval} is wrong, +\code{unsafeEval} will crash. However, its lets us remove some +restrictions on what types can be evaluated, which can be useful. + +{unsafeEval\_} lets the application have full control over the import +environment and load flags to the eval call, which is useful for +applications that wish to script themselves, and require specific +modules and packages to be in scope in the eval-generated module. + +This example maps a \code{toUpper} over a list: +% +\begin{quote} +\scm{ +import Eval.Haskell + +main = do s <- unsafeEval "map toUpper \"haskell\"" ["Data.Char"] + when (isJust s) $ putStrLn (fromJust s) +} +\end{quote} + +And here we evaluate a lambda abstraction, applying the result to +construct a tuple. Note the type information that must be supplied in +order for Haskell to type the usage of \code{fn}: +% +\begin{quote} +\scm{ +import Eval.Haskell + +main = do fn <- unsafeEval "(\\(x::Int) -> (x,x))" [] :: IO (Maybe (Int -> (Int,Int))) + when (isJust fn) $ putStrLn $ show $ (fromJust fn) 7 +} +\end{quote} + +\subsection{Foreign Eval} + +A preliminary binding to \code{eval} has been implemented to allow C +(and Objective C) programs access to the evaluator. Foreign bindings +to the compilation manager and dynamic loader are yet to be +implemented, but shouldn't be too hard. An foreign binding to a +Haskell module that wraps up calls to \code{make} and \code{load} +would be fairly trivial. + +At the moment we have an ad-hoc binding to \code{eval}, so that C +programmers who know the type of value that will be returned by +Haskell can call the appropriate hook into the evaluator. If they get +the type wrong, a nullPtr will be returned (so calling Haskell is +still typesafe). The foreign bindings to \code{eval} all return +\code{NULL} if an error occurred, otherwise a pointer to the value is +returned. + +\begin{quote} +\scm{ +foreign export ccall hs_eval_b :: CString -> IO (Ptr CInt) + +foreign export ccall hs_eval_c :: CString -> IO (Ptr CChar) + +foreign export ccall hs_eval_i :: CString -> IO (Ptr CInt) + +foreign export ccall hs_eval_s :: CString -> IO CString +} +\end{quote} + +An example C program for compiling and evaluating Haskell code at +runtime follows. This program calculates a fibonacci number, returning +it as a \code{CString} to the C program: +% +\begin{quote} +\begin{verbatim} +#include "EvalHaskell.h" +#include + +int main(int argc, char *argv[]) +{ + char *p; + hs_init(&argc, &argv); + p = hs_eval_s("show $ let fibs = 1:1:zipWith (+) fibs (tail fibs) in fibs !! 20"); + if (p != NULL) + printf("%s\n",p); + else + printf("error in code\n"); + hs_exit(); + return 0; +} +\end{verbatim} +\end{quote} + +\subsection{Eval.Printf} + +It has been noted that \code{printf} format strings are the concrete syntax +of a string formatting interpreter (over 1000 lines long in libc!). By +combining runtime generation of new Haskell code, with dynamic typing, +it becomes possible to implement a typesafe \code{printf} for Haskell. + +This has already been achieved in at least 3 different ways. A standard +solution (Hinze, Danvey) begins by supplying printf with the abstract +syntax of the formatting string, resolving the issue of the lack of +typing in the raw fmt string. An alternative solution (see Ian Lynagh's +Printf library) uses Template Haskell to transform a printf format +string into a new Haskell function at compile time, however this +requires that the format string is known at compile time. By using +runtime compilation we can take a similar approach, but instead generate +the print function at runtime! To make this safe, we then need to use +dynamic typing to check the newly-generated print function against its +arguments. + +\subsection*{Printf Interface} + +The \code{Printf} library implements a reasonable amount of the C +printf's functionality. + +\begin{quote} +\scm{ +printf :: String -> [Dynamic] -> IO () +} +\end{quote} + +\begin{quote} +\scm{ +sprintf :: String -> [Dynamic] -> IO String +} +\end{quote} + +Because the arguments to printf are of differing types, and the number +of arguments is not known at compile time, we simulate variadic +functions by using a heterogenous list of arguments. A special list +constructor, \code{!}, is provided for this. An example, noting the +syntax for constructing a heterogenous argument list: + +\begin{quote} +\scm{ +import Eval.Printf + +main = do printf "%d\n" $ (42::Int) ! [] + printf "0x%X\n" $ (42::Int) ! [] + printf "%f\n" $ (42.1234 :: Double) ! [] + printf "%c:%c:%c\n" $ 'a' ! 'b' ! 'c' ! [] + printf "%s\n" $ "haskell" ! [] + printf "%010.4f\n" $ (42.1234 :: Double) ! [] + printf "%10.4s\n" $ "haskell" ! [] + printf "%-10.4s\n" $ "haskell" ! [] +} +\end{quote} + +Compiling this program against \code{-package eval}, and running it +produces the following output: +% +\begin{quote} +\begin{verbatim} +42 +0x2A +42.123400 +a:b:c +haskell +00042.1234 + hask +hask +\end{verbatim} +\end{quote} + +If you mismatch the types specified in the format string, and the +types you apply printf to, printf will generate an exception, like so: + +\begin{quote} +\scm{ +import Eval.Printf + +main = printf "%d\n" ("badstring" ! []) +} +\end{quote} + +The above code will generate this error, indicating that you attempted +to apply a string to a function that expected an Int: +% +\begin{quote} +\begin{verbatim} +paprika$ ./a.out +Fail: Type error in dynamic application. +Can't apply function [Char]> to argument <[Char]> +\end{verbatim} +\end{quote} + +Note that this isn't the fastest printf implementation in the world. A +call to printf invokes GHC to transform the printf format string into +a Haskell code fragment, which is compiled and dynamically linked back +into the application, and then applied to its arguments. If you need +to use the same printf function against multiple times, you can save +recompilation, in which case printf runs as fast as other native code. + +Additionally, it only implements the most common modifiers to the +basic conversion specifiers, and they have not all been fully tested. + +\section{RTS Binding} + +The low level interface is the binding to GHC's Linker.c. Therefore, +\hsplugins{} only works on platforms with a working GHCi. This library +is based on code from André Pang's runtime loader. The low level +interface is as follows: + +\begin{itemize} + \item \code{initLinker} \em start the linker up + \item \code{loadObject} \em load a vanilla .o + \item \code{loadPackage} \em load a GHC library and its cbits + \item \code{loadShared } \em load a .so object file + \item \code{resolveObjs} \em and resolve symbols +\end{itemize} + +Additionally, \code{Hi.Parser} provides an interface to a GHC +\code{.hi} file parser. Currently we only parse just the dependency +information, import and export information from \code{.hi} files, but +all the code is there for an application to extract other information +from \code{.hi} files. + +\newpage + +\section{Dynamic Loader Implementation} + +The dynamic loader is the system by which modules, and their +dependencies can be loaded, unloaded or reloaded at runtime, and +through which we access the functions we need. + +At its lowest level, the \hsplugins{} loader is a binding to the GHC +runtime loader and linker. This layer is a direct reimplementation of +Andre Pang's \code{runtime\_loader} (barely any code changed). The +code at this level can only load single modules, or packages/archives +(which are just objects too). Any dependency resolution must be +performed by hand. + +On top of Andre's interface is a more convenient interface through +which user's should interact with the dynamic loader. The most +significant extension to Andre's work is the automatic calculation and +loading of a plugin's package or module dependencies via .hi file +information. It also handles initialisation of the loader, and +retrieval of values from the plugin in a more convenient way. Some +state is also stored in the loader to keep track of which modules and +packages have been loaded, to prevent unnecessary (actually, fatal) +loading of object files and packages already loaded. Thus you can +safely load several plugins at once, that share common dependencies, +without worrying about the dependencies being loaded multiple times. +We also store package.conf information in the state, so we can work +out where a package lives and what it depends on. + +The ability to remember which packages and objects have been loaded is +based on ideas in Hampus Ram's dynamic loader, which has a more +advanced dependency tracking system, with the ability to unload the +dependencies of a plugin. \hsplugins{} doesn't provide ``cascading +unloading''. The advantage \hsplugins{} has over Hampus' loader seems +to be the automatic dependency resolution via vanilla .hi files and +the dynamic recompilation stuff. + +Using \code{load}, any library packages, or any \code{.o} files, that a +plugin depends upon will be automatically loaded prior to loading the +module itself. \code{load} then looks up a symbol from the object file, +and returns the value associated with the symbol as a conventional +Haskell value. It should also be possible to load a GHCi-style \code{.o} +archive of object files this way, although there is currently no way +to extract multple plugin interfaces from a archive of objects. + +The application writer is not required to recalculate dependencies if +the plugin changes, and the plugin author does not need to specify +what dependencies exist, as is required in the lower level interface. +This is achieved by using the dependency information calculated by GHC +itself, stored in .hi files, to work out which modules and packages to +load, and in what order. A plugin in \hsplugins{} is really a pair of +an object file (or archive) and a \code{.hi} file, containing package +and module dependency information. + +The \code{.hi} file is created by GHC when the plugin is compiled, +either by hand or via \code{make}. \code{load} uses a binary parser to +extract the relevant information from the \code{.hi} data. Because the +dependency information is stored in a separate file to the application +that loads the plugin, such information can be recalculated without +having to modify the application. Becaues of this, it was easy to +extend the load to support recompilation of module source, even if +dependencies change, because dependencies are no longer hard-coded +into the application source itself, but are specified by the plugin. + +Assuming we have a plugin exporting some data, ``resource'', with a +record name \code{field :: String}, here is an example call to \code{load}: +% +\begin{quote} +\scm{ +do m_v <- load "Test.o" ["."] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ field v +} +\end{quote} + +This loads the object file \code{Test.o}, and any packages or objects +\code{Test.o} depends on. It resolves undefined symbols, and returns +from the object file the Haskell value named ``resource'', as the +value ``v''. This must be a value exported by the plugin. We then +retrieve the \code{field} component of \code{v}, and print it out. + +This simple usage assumes that the plugin to load is in the same +directory as the application, and that the api defining the interface +between plugin and application is also in the current directory (hence +the ``.'' in the 2nd argument to \code{load}). + +\subsection*{Dynamically Loading the Dynamic Loader} + +It is also possible to load the \code{plugins} or \code{eval} +libraries in GHC. A couple of recent patches to the linker have made +this possible (available in ghc-6.2.2 or in the head branch). Here, +for example, we load the \code{plugs} interactive environment in GHCi, +and evaluated some code. The source to \code{plugs} is in Appendix +\ref{sec:plugs}. +% +\begin{quote} +\begin{verbatim} +paprika$ ghci -package-conf ../../../plugins.conf.inplace -package eval + ___ ___ _ + / _ \ /\ /\/ __(_) + / /_\// /_/ / / | | GHC Interactive, version 6.3, for Haskell 98. +/ /_\\/ __ / /___| | http://www.haskell.org/ghc/ +\____/\/ /_/\____/|_| Type :? for help. + +Loading package base ... linking ... done. +Loading package altdata ... linking ... done. +Loading package unix ... linking ... done. +Loading package mtl ... linking ... done. +Loading package lang ... linking ... done. +Loading package posix ... linking ... done. +Loading package haskell98 ... linking ... done. +Loading package haskell-src ... linking ... done. +Loading package plugins ... linking ... done. +Loading package eval ... linking ... done. +Prelude> :l Main +Skipping Main ( Main.hs, Main.o ) +Ok, modules loaded: Main. +Prelude Main> main +Loading package readline ... linking ... done. + __ + ____ / /_ ______ ______ + / __ \/ / / / / __ `/ ___/ PLugin User's GHCi System, for Haskell 98 + / /_/ / / /_/ / /_/ (__ ) http://www.cse.unsw.edu.au/~dons/hs-plugins + / .___/_/\__,_/\__, /____/ Type :? for help +/_/ /____/ + +Loading package base ... linking ... done +plugs> map (\x -> x + 1) [0..10] +[1,2,3,4,5,6,7,8,9,10,11] +plugs> :t "haskell" +"haskell" :: [Char] +plugs> :q +*** Exception: exit: ExitSuccess +Prelude Main> :q +Leaving GHCi. +\end{verbatim} +\end{quote} + +\subsection*{Dynamic Typing} + +Support is also provided to unwrap and check the type of dynamically +typed plugin values (those wrapper in a \code{toDyn}) via +\code{dynload}. This is the same as \code{load}, except that instead +of a returning the value it finds, it unwraps a dynamically typed +value, checks the type, and returns the unwrapped value. This is to +provide further trust that the symbol you are retrieving from the +plugin is of the type you think it is, beyond that trust you have by +knowing that the plugin was compiled against a shared API. By using +\code{dynload} it is not enough for an object file to just have the +same symbol name as the function you require, it must also carry the +\code{Data.Dynamic} representation of the type, too. \code{pdynload} +rectifies most of \code{dynload}'s limitations, but at the cost of +additional running time. + +\section{Compilation Manager Implementation} + +Along side the dynamic loader is the compilation manager. This is a +\code{make}-like system for compiling Haskell source, prior to loading +it. \code{make} checks if a source file is newer than its associated +object file. If so, the source is recompiled to an object file, and a +new dependency file is created, in case the dependencies have changed +in the source. This module can then be loaded. The idea is to allow +EDSL authors to write plugins without having to touch a compiler: it +is all transparent. It also allows us to enforce type safety in the +plugin by injecting type constraints into the plugin source, as has +been discussed eariler. + +The effect is much like \emph{hi} (Hmake Interactive), funnily enough. +An application using both \code{make} and \code{load} behaves like a +Haskell interpreter, using \code{eval}. You modify your plugin, and +the application notices the change, recompiles it (possibly issuing +type errors) and then reloads the object file, providing the +application with the latest version of the code. + +An example: +% +\begin{quote} +\scm{ +do status <- make "Plugin.hs" [] + obj <- case status of + MakeSuccess _ o -> return o + MakeFailure e -> mapM_ putStrLn e >> error "failed" + + m_v <- load obj ["api"] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ field v +} +\end{quote} + +\code{make} accepts a source file as an argument, and a (usually empty) +list of GHC flags needed to compile the object file. It then checks to +see if compilation is required, and if so, it calls GHC to compile the +code, with and arguments supplied. If any errors were generated by +GHC, they are returned as the third component of the triple. + +Usually it will be necessary to ensure that GHC can find the plugin +API to compile against. This can be done by either making sure the API +is in the same directory as the plugin, or by adding a \code{-i} flag to +\code{make}'s arguments. If the API is created as a ``package'' with a +package.conf file, \code{make} can be given \code{-package-conf} arguments +to the same effect. + +Normally, \code{make} generates the \code{.o} and \code{.hi} files in +the same directory as the source file. This is not always desirable, +particularly for interpreter-like applications. To solve this, you can +pass \code{[''-odir'', path]} as elements of the arg list to +\code{make}, and it will respect these arguments, generating the +object and interface file in the directory specified. GHC's argument +\code{''-o''} is also respected in a similar manner, so you could also +say \code{[''-o'', obj]} for the same effect. + +\code{make} is entirely optional. All user's have to do to use the +loader on its own is make sure they only load object files that also +have a \code{.hi} file. This will usually be the case if the plugin is +compiled with GHC. + +\subsection*{makeWith} + +\code{makeWith} merges two source files together, using the function +and value declarations from one file, with any syntax in the second, +creating a new third source file. It then compiles this source file +via \code{make}. + +This function exists as a benefit to EDSL authors and is related to +the original motivation for \hsplugins{}, as a .conf file language +library. Configuration files need to be clean and simple, and you +can't rely, or trust, the user to get all the compulsory details +correct. So the solution is to factor out any compulsory syntax, such +as module names, imports, and also to provide a default instance of +the API, and store this code in a separate file provided by the +application writer, not the user. \code{makeWith} then merges +whatever the user has written, with the syntax stub, generating a +complete Haskell plugin source, with the correct module names and +import declarations. We also ensure the plugin only exports a single +interface value while we are here. + +\code{makeWith} thus requires a Haskell parser to parse two source files +and merge the results. We are merging abstract syntax here. This is +implemented using the Language.Haskell parser library. Unfortunately, +this library doesn't implement all of GHC's extensions, so if you wish +to use \code{makeWith} you can only write Haskell source that can be +parsed by this library, which is just H98 and a few extensions. This +is another short coming in the current design that will be overcome +with \code{-package ghc}. Remember, however, for normal uses of +\code{make} and \code{load} you are unrestricted in what Haskell you use. +This is the same restriction present in happy, the Haskell parser, +placed on the code you can provide in the \code{.y} source. + +\code{makeWith} also makes use of line pragmas. If the merged file +fails to compile, the judicious use of line number pragmas ensure that +the user receives errors messages reported with reference to their +source file, and not line number in the merged file. This is a +property of the Language.Haskell parser that we can make use of. + +An example of \code{makeWith}: +% +\begin{quote} +\scm{ +do status <- makeWith "Plugin.in" "Plugin.stub" [] + obj <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess _ o -> return o + m_v <- load obj [apipath] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ field v +} +\end{quote} + +We combine the user's file (\code{Plugin.in}) with a stub of syntax +generating a new, third Haskell file in the default tmpdir. This is +compiled as per usual, producing object and interface files. The +object is then loaded, and we extract the value exported. + +Using \code{makeWith} it is possible to write very simple, clear +Haskell plugins, that appear not to be Haskell at all. It is an easy +way to get EDSL user's writing plugins that are actually Haskell +programs, for .e.g, configuration files. See the examples that come +with the src. + +\newpage + +\section{An Example} + +This is an introductory example. + +\subsection*{API} + +First we need an interface between the application and the plugin. +This module needs to be visible to both the app and the plugin, in the +interest of clear and well-defined interfaces: +% +\begin{quote} +\scm{ +module StringProcAPI (Interface(..), plugin) where + +data Interface = Interface { + stringProcessor :: String -> String +} + +plugin :: Interface +plugin = Interface { stringProcessor = id } +} +\end{quote} + +Here we define \code{Interface} as the inteface signature for the +object passed between plugin and application. We'll use the record +syntax as it looks intuitive in the plugin. We provide a default +instance, the \code{plugin} value, that can be overwritten in the +actual plugin, ensuring sensible behaviour in the absence of any +plugins. The API should theoretically be compiled with \code{-Onot} to +avoid interface details leaking out into the \code{.hi} file. + +\subsection*{The Plugin} + +This is our plugin. Note that the plugin will be compiled entirely +seperately from the application. It must only rely on the API, and +nothing in the application source. +% +\begin{quote} +\scm{ +module StringProcPlugin (resource) where + +import StringProcAPI (plugin) + +resource = plugin { + stringProcessor = reverse +} +} +\end{quote} + +Using the record syntax we overwrite the \code{function} field with our +own value, \code{reverse}. The value \code{resource} is the magic symbol +that must be defined, and which the application will use to find the +data the plugin exports. + +Now, we can make this even easier on the plugin writer by the use of a +``stub'' file. \code{makeWith} lets you merge a plugin source with +another Haskell file, and compiles the result into the actual plugin +object. So the application can provide a stub file containing module +declarations and imports, and a default plugin value. Here is an +application-provided stub, factoring out compulsory syntax and type +declarations from the plugin: +% +\begin{quote} +\scm{ +module StringProcPlugin ( resource ) where + +import StringProcAPI + +resource :: Interface +resource = plugin +} +\end{quote} + +By factoring out compulsory syntax, the plugin author only has to +provide an overriding instance of the \code{resource} field. So all +the plugin actually consists of, is: +% +\begin{quote} +\scm{ +resource = plugin { + stringProcessor = reverse +} +} +\end{quote} + +That is all the code we need! This file may be called anything at all. + +More complex APIs may have more fields, of course. The nice thing +about this arrangement is that the user will write some simple syntax, +which will nonetheless by typechecked safely against the API. Errors +are also reported using line numbers from the source file, not the +stub, which makes things less confusing. + +\subsection*{The Application} + +Now we need to write an application that can use values of the kind +defined in the API, and which can compile and load plugins. The basic +mechanism to compile and load a plugin is as follows: +% +\begin{quote} +\scm{ +do status <- make "StringProcPlugin.hs" [] + obj <- case status of + MakeSuccess _ o -> return o + MakeFailure e -> mapM_ putStrLn e >> error "failed" + + m_v <- load obj ["."] [] "resource" + val <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" +} +\end{quote} +% +This code calls \code{make} to compile the plugin source, yielding +wrapper around a handle to an object file. The object can then be loaded +using \code{load}, and the code associated with the symbol +\code{resource} is retrieved. + +We embed this code in a simple shell-like loop, applying the function +exported by the plugin: +% +\begin{quote} +\scm{ +import Plugins +import StringProcessorAPI +import System.Console.Readline +import System.Exit + +source = "Plugin.hs" +stub = "Plugin.stub" +symbol = "resource" + +main = do s <- makeWith source stub [] + o <- case s of + MakeSuccess _ obj -> do + ls <- load obj ["."] [] symbol + case ls of LoadSuccess m v -> return (m,v) + LoadFailure err -> error "load failed" + MakeFailure e -> mapM_ putStrLn e >> error "compile failed" + shell o + +shell o@(m,plugin) = do + s <- readline "> " + cmd <- case s of + Nothing -> exitWith ExitSuccess + Just (':':'q':_) -> exitWith ExitSuccess + Just s -> addHistory s >> return s + + s <- makeWith source stub [] -- maybe recompile the source + o' <- case s of + MakeSuccess ReComp o -> do + ls <- reload m symbol + case ls of LoadSuccess m' v' -> return (m',v') + LoadFailure err -> error "reload failed" + MakeSuccess NotReq _ -> return o + MakeFailure e -> mapM_ putStrLn e >> shell o + eval cmd o' + shell o' + +eval ":?" _ = putStrLn ":?\n:q\n" + +eval s (_,plugin) = let fn = (stringProcessor plugin) in putStrLn (fn s) +} +\end{quote} + +We have to import the hs-plugins library, and the API. The main loop +proceeds by compiling and loading the plugin for the first time, and +then calls \code{shell}, the interpeter loop. This loop lets us apply +the function in the plugin to strings we supply. We have to pass +around the \code{(Module, a)} pair we get back from \code{reload}, so +that we can pass it to \code{eval} to do the real work. The first +\code{eval} case is where we use the record syntax to select the +\code{function} field out of \code{v}, the plugin interface object, +and we apply it to s. Try it out: +% +\begin{quote} +\begin{verbatim} +paprika$ ./a.out +Loading package base ... linking ... done +Loading objects API Plugin ... done +> :? +":?" +":q" +"" +> abcdefg +gfedcba +\end{verbatim} +\end{quote} + +Now, if we edit the plugin while the shell is running, the next time +we type something at the prompt the plugin will be unloaded, +recompiled and reloaded. Because the plugin is really an EDSL, we can +use any Haskell we want, so we'll change the plugin to: +% +\begin{quote} +\scm{ +import Data.Char + +resource = plugin { + stringProcessor = my_fn +} + +my_fn s = map toUpper (reverse s) +} +\end{quote} + +Back to the shell: +% +\begin{quote} +\begin{verbatim} +> abcdefg +Compiling plugin ... done +Reloading Plugin ... done +GFEDCBA +\end{verbatim} +\end{quote} + +And that's it: dynamically recompiled and reload Haskell code! + +\section{Multiple Plugins} + +It is quite easy to load multiple plugins, that all implement the +common plugin API, and that all export the same value (though +implemented differently). This make \hsplugins{} suitable for +applications that wish to allow an arbitrary number of plugins. The +main problem with multiple plugins is that they may share +dependencies, and if \code{load} na\"ively loaded all dependencies +found in the set of \code{.hi} files associated with all the plugins, +the GHC rts would crash. To solve this the \hsplugins{} dynamic loader +maintains state storing a list of what modules and packages have been +loaded already. If \code{load} is called on a module that is already +loaded, or dependencies are attempted to load, that have already been +loaded, the dynamic loader ignores these extra dependencies. This +makes it quite easy to write an application that will allows an +arbitrary number of plugins to be loaded. An example follows. + +\subsection*{Definition} + +First we need to define the API that a plugin must type check against, +in order to be valid. +% +\begin{quote} +\scm{ +module API where + +data Interface = Interface { + valueOf :: String -> String +} + +plugin :: Interface +plugin = Interface { valueOf = id } +} +\end{quote} + +We can then implement a number of plugins that provide values of type +"Interface". We show three plugins that export string manipulation functions: +% +\begin{quote} +\scm{ +module Plugin1 where + +import API +import Data.Char + +resource = plugin { + valueOf = \s -> map toUpper s +} +} +\end{quote} + +\begin{quote} +\scm{ +module Plugin2 where + +import API +import Data.Char + +resource = plugin { + valueOf = \s -> map toLower s +} +} +\end{quote} + +\begin{quote} +\scm{ +module Plugin3 where + +import API + +resource = plugin { + valueOf = reverse +} +} +\end{quote} + +And finally we need to write an application that would use these +plugins. Remember that the application is written without knowledge of +the plugins, and the plugins are written without knowledge of the +application. They are each implemented only in terms of the API, a +shared module and \code{.hi} file. An application needs to make the +API interface available to plugin authors, by distributing the API +object file and \code{.hi} file with the application. +% +\begin{quote} +\scm{ +import Plugins +import API + +main = do + let plist = ["Plugin1.o", "Plugin2.o", "Plugin3.o"] + plugins <- mapM (\p -> load p ["."] [] "resource") plist + let functions = map (valueOf . fromLoadSuc) plugins + mapM_ (\f -> putStrLn $ f "haskell is for hackers") functions + +fromLoadSuc (LoadFailure _) = error "load failed" +fromLoadSuc (LoadSuccess _ v) = v + +} +\end{quote} + +This application simply loads all the plugins and retrieves the +functions they export. It then applies each of these functions to a +string, printing the result. We assume for this example that the +plugins are compiled once only, and are not compiled dynamically via +\code{make}. This implies that you have to use \code{GHC} to generate +the \code{.hi} file for each plugin. A sample Makefile to compile the +plugins, and the api: +% +\begin{quote} +\begin{verbatim} +all: + ghc -Onot -c API.hs + ghc -O -c Plugin1.hs + ghc -O -c Plugin2.hs + ghc -O -c Plugin3.hs +\end{verbatim} +\end{quote} + +Ghc creates \code{.hi} files for each plugin, which can be inspected +using the \code{Plugins.BinIface.readBinIface} function. It parses the +\code{.hi} file, generating, roughly, the following: +% +\begin{quote} +\begin{verbatim} +interface "Main" Main +module dependencies: A, B +package dependencies: base, haskell98, lang, unix +\end{verbatim} +\end{quote} + +which says that the plugin depends upon a variety of system packages, +and the modules A and B. All these dependencies must be loaded before +the plugin itself. + +You then need to compile the application against the API, and against +the \hsplugins{} library: +% +\begin{quote} +\begin{verbatim} +ghc -O --make -package plugins Main.hs +\end{verbatim} +\end{quote} + +Running the application produces the following result. Note that the +verbose output can be switched off by compiling \hsplugins{} without +the \code{-DDEBUG} flag. If you look at the \code{.hi} file, using +\code{ghc --show-iface}, you'll see that they all depend on the base +package, and on the API, but the state stored in the dynamic loader +ensures that these shared modules are only loaded once: +% +\begin{quote} +\begin{verbatim} +Loading package base ... linking ... done +Loading object API Plugin1 ... done +Loading object Plugin2 ... done +Loading object Plugin3 ... done + +HASKELL IS FOR HACKERS +haskell is for hackers +srekcah rof si lleksah +\end{verbatim} +\end{quote} + +Archives of plugins can be loaded in one go if they have been linked +into a .o GHCi package, see \code{loadPackage}. + +\newpage + +\appendix + +\section{License} + +This library is distributed under the terms of the LGPL: + +\begin{quote} + +Copyright 2004, Don Stewart - \url{http://www.cse.unsw.edu.au/~dons} + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 2.1 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Lesser General Public License for more details. + +You should have received a copy of the GNU Lesser General Public +License along with this library; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +USA + +\end{quote} + +\section{Portability} + +The library tries to be portable. There are two major points that +limit easy portabilty. The first is the dependence on the GHC dynamic +linker. \hsplugins{} is thus limited to platforms to which GHC's dyn +linker has been ported (this is essentially the same as the platforms +that can run GHCi). + +Other than this, there are 3 platform specific items that need to be +defined for new platforms: +\begin{itemize} + \item Where tmp files should be created. Define the + \code{tmpDir} variable in \code{Plugins/Consts.hs} + + \item Process creation, such that we can read stdin and stderr + from the process (this is the POpen library for Posix + systems). For Windows, \hsplugins{} carries Simon + Marlow's \code{forkProcess} library. + + \item Dealing with backslashes in Dos-style path names +\end{itemize} + +I plan to solve the above 3 problems (and thus have a Windows port) once +GHC 6.4 is out. + +\newpage + +\section{A Haskell Interpreter using Plugins} +% \label{sec:plugs} + +Here is a full length example of a Haskell interpreter/compiler in the +style of Malcolm Wallace's \code{hi}. Rather than compiling the +user's code to an executable, we use \hsplugins{} to instead load an +object file and execute that instead, using the \code{eval} interface. +This cuts out the linking phase from the process, making turnaround at +the prompt around twice as fast as \code{hi}. + +\subsection*{Source of Plugs} + +\begin{quote} +\scm{ +import Eval.Haskell +import Plugins.Load + +import System.Exit ( ExitCode(..), exitWith ) +import System.IO +import System.Console.Readline ( readline, addHistory ) + +symbol = "resource" + +main = do + putStrLn banner + putStr "Loading package base" >> hFlush stdout + loadPackage "base" + putStr " ... linking ... " >> hFlush stdout + resolveObjs + putStrLn "done" + + shell [] + +shell :: [String] -> IO () +shell imps = do + s <- readline "plugs> " + cmd <- case s of + Nothing -> exitWith ExitSuccess + Just (':':'q':_) -> exitWith ExitSuccess + Just s -> addHistory s >> return s + imps' <- run cmd imps + shell imps' + +run :: String -> [String] -> IO [String] +run "" is = return is +run ":?" is = putStrLn help >> return is + +run ":l" _ = return [] +run (':':'l':' ':m) is = return (m:is) + +run (':':'t':' ':s) is = do + ty <- typeOf s is + when (not $ null ty) (putStrLn $ s ++ " :: " ++ ty) + return is + +run (':':_) is = putStrLn help >> return is + +run s is = do + s <- unsafeEval ("show $ "++s) is + when (isJust s) (putStrLn (fromJust s)) + return is + +banner = "\ +\ __ \n\ +\ ____ / /_ ______ ______ \n\ +\ / __ \\/ / / / / __ `/ ___/ PLugin User's GHCi System, for Haskell 98\n\ +\ / /_/ / / /_/ / /_/ (__ ) http://www.cse.unsw.edu.au/~dons/hs-plugins\n\ +\ / .___/_/\\__,_/\\__, /____/ Type :? for help \n\ +\/_/ /____/ \n" + +help = "\ +\Commands :\n\ +\ evaluate expression\n\ +\ :t show type of expression (monomorphic only)\n\ +\ :l module bring module in to scope\n\ +\ :l clear module list\n\ +\ :quit quit\n\ +\ :? display this list of commands" +} +\end{quote} + +\subsection*{A Transcript} + +And a transcript: +% +\begin{quote} +\begin{verbatim} +$ ./plugs + __ + ____ / /_ ______ ______ + / __ \/ / / / / __ `/ ___/ PLugin User's GHCi System, for Haskell 98 + / /_/ / / /_/ / /_/ (__ ) http://www.cse.unsw.edu.au/~dons/hs-plugins + / .___/_/\__,_/\__, /____/ Type :? for help +/_/ /____/ + +Loading package base ... linking ... done +plugs> 1 +1 +plugs> let x = 1 + 2 in x +3 +plugs> :l Data.List +plugs> case [1,3,2] of x -> sort x +[1,2,3] +plugs> reverse [1,3,2] +[2,3,1] +plugs> map (\x -> (x,2^x)) [1,2,3,4,5,6,7,8,9,10] +[(1,2),(2,4),(3,8),(4,16),(5,32),(6,64),(7,128),(8,256),(9,512),(10,1024)] +plugs> :t "haskell" +"haskell" :: [Char] +plugs> :quit +\end{verbatim} +\end{quote} + +\end{document} diff --git a/docs/munge.sed b/docs/munge.sed new file mode 100644 index 0000000..e9f5db2 --- /dev/null +++ b/docs/munge.sed @@ -0,0 +1,17 @@ +#!/usr/bin/sed -f + +# de-boldify and

-ify the Contents. + +/Contents/ { + :loop + /Go to/ { + b end + } + s,

,, + s,,, + s,,, + s,

,, + n + b loop +} +:end diff --git a/docs/tex2page.sty b/docs/tex2page.sty new file mode 100644 index 0000000..28bd5bb --- /dev/null +++ b/docs/tex2page.sty @@ -0,0 +1,9 @@ +% tex2page.sty +% Dorai Sitaram + +% Loading this file in a LaTeX document +% gives it all the macros of tex2page.tex, +% but via a more LaTeX-convenient filename. + +\input{tex2page} + diff --git a/docs/tex2page.tex b/docs/tex2page.tex new file mode 100644 index 0000000..e0bda16 --- /dev/null +++ b/docs/tex2page.tex @@ -0,0 +1,1381 @@ +% tex2page.tex +% Dorai Sitaram + +% TeX files using these macros +% can be converted by the program +% tex2page into HTML + +\message{version 2003-10-26} % last change + +\let\texonly\relax +\let\endtexonly\relax + +\texonly + +\newcount\evalQauxfilecount +\evalQauxfilecount=0 + +\def\eval{\begingroup + \ifx\evalfortexQport\UNDEFINED + \expandafter\csname newwrite\endcsname + \evalfortexQport + \immediate\openout\evalfortexQport + \jobname.eval4tex + \immediate\write\evalfortexQport + {\string\ifx\string\shipout\string\UNDEFINED + \string\eval{(eval-for-tex-only)}% + \string\else\string\endinput\string\fi}% + \fi + \global\advance\evalQauxfilecount by 1 + \edef\evalQauxfile{\jobname-Z-E-\the\evalQauxfilecount}% + {\immediate\openin0=\evalQauxfile.tex + \ifeof0 \immediate\closein0 + \else \input \evalQauxfile.tex \fi}% + \def\do##1{\catcode`##1=12 }\dospecials + \catcode`\{=1 \catcode`\}=2 + \catcode`\^^M=12 + \newlinechar=`\^^M% + \evalQii} + +\def\evalQii#1{% + \immediate\write\evalfortexQport{\string\eval{#1}}% + \endgroup} + +%\def\verbwritefile#1 {\relax} +%\let\verbwrite\gobbleencl + +\def\verbwritefile{% + \ifx\verbwritefileQport\UNDEFINED + \expandafter\csname newwrite\endcsname\verbwritefileQport + \else\immediate\closeout\verbwritefileQport + \fi + \futurelet\verbwritefileQnext\verbwritefileQcheckchar} + +\def\verbwritefileQcheckchar{% + \ifx\verbwritefileQnext\bgroup + \let\verbwritefileQnext\verbwritefileQbracedfile + \else + \let\verbwritefileQnext\verbwritefileQspacedfile + \fi\verbwritefileQnext} + +\def\verbwritefileQspacedfile#1 {% + \immediate\openout\verbwritefileQport #1 +} + +\def\verbwritefileQbracedfile#1{% + \verbwritefileQspacedfile #1 +} + +\def\verbwrite{% + \ifx\verbwritefileQport\UNDEFINED + \verbwritefile \jobname.txt \fi + \begingroup + \def\do##1{\catcode`##1=12 }\dospecials + \catcode`\{=1 \catcode`\}=2 + \catcode`\^^M=12 \newlinechar=`\^^M% + \futurelet\verbwriteQopeningchar\verbwriteQii} + +\def\verbwriteQii{\ifx\verbwriteQopeningchar\bgroup + \let\verbwriteQiii\verbwriteQbrace\else + \let\verbwriteQiii\verbwriteQnonbrace\fi + \verbwriteQiii} + +\def\verbwriteQbrace#1{\immediate + \write\verbwritefileQport{#1}\endgroup} + +\def\verbwriteQnonbrace#1{% + \catcode`\{12 \catcode`\}12 + \def\verbwriteQnonbraceQii##1#1{% + \immediate\write\verbwritefileQport{##1}\endgroup}% + \verbwriteQnonbraceQii} + +\ifx\loadonlyQevalfortex1% + \let\maybeloadfollowing\endinput +\else + \let\maybeloadfollowing\relax +\fi\maybeloadfollowing + +\ifx\slatexignorecurrentfile\UNDEFINED\relax\fi + +\edef\atcatcodebeforetiip{\the\catcode`\@ } +\catcode`\@11 + +% margins + +\def\sidemargin{\afterassignment\sidemarginQadjustoffset + \hoffset} + +\def\sidemarginQadjustoffset{% + \advance\hoffset -1true in + \advance\hsize -2\hoffset} + +\def\vertmargin{\afterassignment\vertmarginQadjustoffset + \voffset} + +\def\vertmarginQadjustoffset{% + \advance\voffset -1true in + \advance\vsize -2\voffset} + +% + +\def\defcsactive#1{\defnumactive{`#1}} + +\def\defnumactive#1{\catcode#1\active + \begingroup\lccode`\~#1% + \lowercase{\endgroup\def~}} + +% gobblegobblegobble + +\def\gobblegroup{\bgroup + \def\do##1{\catcode`##1=9 }\dospecials + \catcode`\{1 \catcode`\}2 \catcode`\^^M=9 + \gobblegroupI} + +\def\gobblegroupI#1{\egroup} + +\def\gobbleencl{\bgroup + \def\do##1{\catcode`##1=12 }\dospecials + \catcode`\{1 \catcode`\}2 \catcode`\^^M=9 + \futurelet\gobbleenclnext\gobbleenclI} + +\def\gobbleenclI{\ifx\gobbleenclnext\bgroup + \let\gobbleenclnext\gobblegroupI + \else\let\gobbleenclnext\gobbleenclII\fi + \gobbleenclnext} + +\def\gobbleenclII#1{% + \def\gobbleenclIII##1#1{\egroup}% + \gobbleenclIII} + +% \verb +% Usage: \verb{...lines...} or \verb|...lines...| +% In the former case, | can be used as escape char within +% the verbatim text + +\let\verbhook\relax + +\def\verbfont{\tt} +%\hyphenchar\tentt-1 + +\def\verbsetup{\frenchspacing + \def\do##1{\catcode`##1=12 }\dospecials + \catcode`\|=12 % needed? + \verbfont + \edef\verbQoldhyphenchar{\the\hyphenchar\font}% + \hyphenchar\font-1 + \def\verbQendgroup{\hyphenchar\font\verbQoldhyphenchar\endgroup}% +} + +% The current font is cmtt iff fontdimen3 = 0 _and_ +% fontdimen7 != 0 + +\def\checkifusingcmtt{\let\usingcmtt n% + \ifdim\the\fontdimen3\the\font=0.0pt + \ifdim\the\fontdimen7\the\font=0.0pt + \else\let\usingcmtt y\fi\fi} + +% In a nonmonospaced font, - followed by a letter +% is a regular hyphen. Followed by anything else, it is a +% typewriter hyphen. + +\def\variablelengthhyphen{\futurelet\variablelengthhyphenI + \variablelengthhyphenII} + +\def\variablelengthhyphenII{\ifcat\noexpand\variablelengthhyphenI + a-\else{\tt\char`\-}\fi} + +\def\verbavoidligs{% avoid ligatures + \defcsactive\`{\relax\lq}% + \defcsactive\ {\leavevmode\ }% + \defcsactive\^^I{\leavevmode\ \ \ \ \ \ \ \ }% + \defcsactive\^^M{\leavevmode\endgraf}% + \checkifusingcmtt + \ifx\usingcmtt n% + \defcsactive\<{\relax\char`\<}% + \defcsactive\>{\relax\char`\>}% + \defcsactive\-{\variablelengthhyphen}% + \fi} + +\def\verbinsertskip{% + \let\firstpar y% + \defcsactive\^^M{\ifx\firstpar y% + \let\firstpar n% + \verbdisplayskip + \parskip 0pt + \aftergroup\verbdisplayskip + \else\leavevmode\fi\endgraf}% + \verbhook} + +\ifx\verb\UnDeFiNeD\else +% Save LaTeX's \verb away, because +% we'll be defining our own \verb +\let\LaTeXverb\verb +\fi + +%\def\verb{\begingroup +% \verbsetup\verbI} + +\def\verb{\begingroup + \verbsetup\verbavoidligs\verbQcheckstar} + +\def\verbQcheckstar{% + \futurelet\verbQcheckstarQnext\verbQcheckstarQii} + +\def\verbQcheckstarQii{% + \if\verbQcheckstarQnext*% + \let\verbQcheckstarQnext\verbQcheckstarQiii + \else + \let\verbQcheckstarQnext\verbI + \fi + \verbQcheckstarQnext} + +\def\verbQcheckstarQiii#1{% + \defcsactive\ {\relax\char`\ }% + \verbI} + +\def\verbc{\begingroup + \verbsetup\afterassignment\verbcI + \let\verbcII=} + +\def\verbcI{{\verbfont\verbcII}\endgroup} + +\let\E\verbc + +\newcount\verbbracebalancecount + +\def\verblbrace{\char`\{} +\def\verbrbrace{\char`\}} + +\def\verbescapechar#1{% + \def\escapifyverbescapechar{\catcode`#1=0 }} + +\verbescapechar\| + +{\catcode`\[1 \catcode`\]2 +\catcode`\{12 \catcode`\}12 +\gdef\verbI#1[%\verbavoidligs + \verbinsertskip\verbhook + %\edef\verbQoldhyphenchar{\the\hyphenchar\tentt}% + %\hyphenchar\tentt=-1 + %\def\verbQendgroup{\hyphenchar\tentt\verbQoldhyphenchar\endgroup}% + %\let\verbQendgroup\endgroup% + \if#1{\escapifyverbescapechar + \def\{[\char`\{]% + \def\}[\char`\}]% + \def\|[\char`\|]% + \verbbracebalancecount0 + \defcsactive\{[\advance\verbbracebalancecount by 1 + \verblbrace]% + \defcsactive\}[\ifnum\verbbracebalancecount=0 + \let\verbrbracenext\verbQendgroup\else + \advance\verbbracebalancecount by -1 + \let\verbrbracenext\verbrbrace\fi + \verbrbracenext]\else + \defcsactive#1[\verbQendgroup]\fi + \verbII +]] + +\def\verbII{\futurelet\verbIInext\verbIII} + +{\catcode`\^^M\active% +\gdef\verbIII{\ifx\verbIInext^^M\else% + \defcsactive\^^M{\leavevmode\ }\fi}} + +\let\verbdisplayskip\medbreak + +% \verbatiminput FILENAME +% displays contents of file FILENAME verbatim. + +%\def\verbatiminput#1 {{\verbsetup\verbavoidligs\verbhook +% \input #1 }} + +% ^ original \verbatiminput + +\ifx\verbatiminput\UNDEFINED +% LaTeX's (optional) verbatim package defines a \verbatiminput -- +% don't clobber it +\def\verbatiminput{% + \futurelet\verbatiminputQnext\verbatiminputQcheckchar}% +\fi + +\def\verbatiminputQcheckchar{% + \ifx\verbatiminputQnext\bgroup + \let\verbatiminputQnext\verbatiminputQbracedfile + \else + \let\verbatiminputQnext\verbatiminputQspacedfile + \fi\verbatiminputQnext} + +\def\verbatiminputQbracedfile#1{\verbatiminputQdoit{#1}} + +\def\verbatiminputQspacedfile#1 {\verbatiminputQdoit{#1}} + +\def\verbatiminputQdoit#1{{\verbsetup + \verbavoidligs\verbhook + \input #1 }} + + +% \url{URL} becomes +% URL in HTML, and +% URL in DVI. + +% A-VERY-VERY-LONG-URL in a .bib file +% could be split by BibTeX +% across a linebreak, with % before the newline. +% To accommodate this, %-followed-by-newline will +% be ignored in the URL argument of \url and related +% macros. + +\ifx\url\UnDeFiNeD +\def\url{\bgroup\urlsetup\let\dummy=}% +\fi + +\def\urlsetup{\verbsetup\urlfont\verbavoidligs + \catcode`\{1 \catcode`\}2 + \defcsactive\%{\urlpacifybibtex}% + \defcsactive\ {\relax}% + \defcsactive\^^M{\relax}% + \defcsactive\.{\discretionary{}{\char`\.}{\char`\.}}% + \defcsactive\/{\discretionary{\char`\/}{}{\char`\/}}% + \defcsactive\`{\relax\lq}} + +\let\urlfont\relax + +\def\urlpacifybibtex{\futurelet\urlpacifybibtexnext\urlpacifybibtexI} + +\def\urlpacifybibtexI{\ifx\urlpacifybibtexnext^^M% + \else\%\fi} + +% \mailto{ADDRESS} becomes +% ADDRESS in HTML, and +% ADDRESS in DVI. + +\let\mailto\url + +% \urlh{URL}{TEXT} becomes +% TEXT in HTML, and +% TEXT in DVI. + +% If TEXT contains \\, the part after \\ appears in +% the DVI only. If, further, this part contains \1, +% the latter is replaced by a fixed-width representation +% of URL. + +\def\urlh{\bgroup\urlsetup + \afterassignment\urlhI + \gdef\urlhQurlarg} + +\def\urlhI{\egroup + \bgroup + \let\\\relax + \def\1{{\urlsetup\urlhQurlarg}}% + \let\dummy=} + +\def\urlp#1{{#1} \bgroup\urlsetup + \afterassignment\urlpQwrapparens + \gdef\urlpQurlarg} + +\def\urlpQwrapparens{\egroup + {\rm(}{\urlsetup\urlpQurlarg}{\rm)}} + +% \urlhd{URL}{HTML-TEXT}{DVI-TEXT} becomes +% HTML-TEXT in HTML, and +% DVI-TEXT in DVI + +\def\urlhd{\bgroup + \def\do##1{\catcode`##1=12 }\dospecials + \catcode`\{1 \catcode`\}2 + \urlhdQeaturlhtmlargs} + +\def\urlhdQeaturlhtmlargs#1#2{\egroup} + +\ifx\hyperref\UnDeFiNeD +\let\href\urlh +\let\hypertarget\gobblegroup +\let\hyperlink\gobblegroup +\def\hyperref#1#2#3#4{#2\ref{#4}#3} +\fi + +% + +\let\ignorenextinputtimestamp\relax + +% don't let caps disable end-of-sentence spacing + +\def\nocapdot{% +\count255=`\A +\loop +\sfcode\the\count255=1000 +\ifnum\count255<`\Z +\advance\count255 by 1 +\repeat +} + +% + +%\ifx\newenvironment\UnDeFiNeD +\let\htmlonly\iffalse +\let\endhtmlonly\fi +%\else +%\usepackage{comment} +%\excludecomment{htmlonly} +%\fi + +\def\rawhtml{\errmessage{Can't occur outside + \string\htmlonly}} +\def\endrawhtml{\errmessage{Can't occur outside + \string\htmlonly}} + +\let\htmlheadonly\iffalse +\let\endhtmlheadonly\fi + +\let\cssblock\iffalse +\let\endcssblock\fi + +\def\inputcss#1 {\relax} +\let\htmlstylesheet\inputcss +\let\htmladdimg\gobblegroup + +\def\htmlref{\bgroup\aftergroup\gobblegroup\let\dummy=} + +% + +\let\htmlcolophon\gobblegroup +\let\htmlmathstyle\gobblegroup +\let\htmladvancedentities\relax + +% Scheme + +\let\scm\verb +\let\scminput\verbatiminput + +\let\scmwritefile\verbwritefile +\let\scmwrite\verbwrite +\let\scmdribble\scm + +\ifx\slatexversion\UNDEFINED +% SLaTeX compat +\let\scmkeyword\gobblegroup +\let\scmbuiltin\gobblegroup +\let\scmconstant\scmbuiltin +\let\scmvariable\scmbuiltin +\let\setbuiltin\scmbuiltin +\let\setconstant\scmbuiltin +\let\setkeyword\scmkeyword +\let\setvariable\scmvariable +\def\schemedisplay{\begingroup + \verbsetup\verbavoidligs + \verbinsertskip + \schemedisplayI}% +\def\schemeresponse{\begingroup + \verbsetup\verbavoidligs + \verbinsertskip + \schemeresponseI}% +{\catcode`\|0 |catcode`|\12 + |long|gdef|schemedisplayI#1\endschemedisplay{% + #1|endgroup}% + |long|gdef|schemeresponseI#1\endschemeresponse{% + #1|endgroup}}% +\fi + +\let\slatexlikecomments\relax +\let\noslatexlikecomments\relax + +% definitions (useful in reference manuals) + +\ifx\@@line\UnDeFiNeD +\let\@@line\line +\fi + +\def\defun#1{\def\defuntype{#1}% +\medbreak +\@@line\bgroup + \hbox\bgroup + \aftergroup\enddefun + \vrule width .5ex \thinspace + \vrule \enspace + \vbox\bgroup\setbox0=\hbox{\defuntype}% + \advance\hsize-\wd0 + \advance\hsize-1em + \obeylines + \parindent=0pt + \aftergroup\egroup + \strut + \let\dummy=} + +\def\enddefun{\hfil\defuntype\egroup\smallskip} + + +% Images + +\let\imgdef\def + +%\def\imgpreamble{\let\magnificationoutsideimgpreamble\magnification +% \def\magnification{\count255=}} +% +%\def\endimgpreamble{\let\magnification\magnificationoutsideimgpreamble} + + +\let\imgpreamble\iffalse +\let\endimgpreamble\fi + +\let\makehtmlimage\relax + + +% Tally control sequences are cheap count +% registers: they doesn't use up TeX's limited number of +% real count registers. + +% A tally is a macro that expands to the +% number kept track of. Thus \edef\kount{0} defines a +% tally \kount that currently contains 0. + +% \advancetally\kount n increments \kount by n. +% \globaladvancetally increments the global \kount. +% If \kount is not defined, the \[global]advancetally +% macros define it to be 0 before proceeding with the +% incrementation. + +\def\newtally#1{\edef#1{0}} + +\def\advancetallyhelper#1#2#3{% + \ifx#2\UNDEFINED + #1\edef#2{0}\fi + \edef\setcountCCLV{\count255=#2 }% + \setcountCCLV + \advance\count255 by #3 + #1\edef#2{\the\count255 }} + +\def\advancetally{\advancetallyhelper\relax} +\def\globaladvancetally{\advancetallyhelper\global} + +% plain's \beginsection splits pages too easily + +%\def\beginsection#1\par{\sectionhelp{1}{}{#1}} + +\def\beginsection{\vskip-\lastskip + \bigbreak\noindent + \bgroup\bf + \let\par\sectionafterskip} + +\def\beginsectionstar*{\beginsection} + +% plain's \{left,center,right}line can't handle catcode change +% within their argument + +\def\leftline{\@@line\bgroup\bgroup + \aftergroup\leftlinefinish + \let\dummy=} + +\def\leftlinefinish{\hss\egroup} + +\def\centerline{\@@line\bgroup\bgroup + \aftergroup\leftlinefinish + \hss\let\dummy=} + +\def\rightline{\@@line\bgroup\hss\let\dummy=} + +% + +\let\strike\fiverm % can be much better! + +% + +\let\htmlpagebreak\relax + +\let\htmlpagelabel\gobblegroup + +\def\htmlpageref{\errmessage{Can't occur except inside + \string\htmlonly}} + +% Miscellaneous stuff + +%\def\hr{$$\hbox{---}$$} +\def\hr{\medbreak\centerline{---}\medbreak} +%\def\hr{\par\centerline{$*$}\par} +%\def\hr{\smallskip\@@line{\leaders\hbox{~.~}\hfill}\smallskip} + +%Commonplace math that doesn't require image files. (Avoiding $ +%here because $ triggers image-file generation.) + +\let\nohtmlmathimg\relax +\let\nohtmlmathintextimg\relax +\let\nohtmlmathdisplayimg\relax + +\let\htmlimageformat\gobblegroup +\let\htmlimgmagnification\gobblegroup + +\let\externaltitle\gobblegroup + +\def\mathg{$\bgroup\aftergroup\closemathg\let\dummy=} +\def\closemathg{$} + +\let\mathp\mathg + +\def\mathdg{$$\bgroup\aftergroup\closemathdg\let\dummy=} +\def\closemathdg{$$} + +% + + +\let\evalh\gobblegroup +\let\evalq\gobblegroup + +% Backward compatible stuff + +\let\endgifpreamble\endimgpreamble +\let\endhtmlgif\relax +\let\endhtmlimg\relax +\let\gifdef\imgdef +\let\gifpreamble\imgpreamble +%\let\href\urlh +\let\htmlgif\relax +\let\htmlimg\relax +\let\htmlimgformat\htmlimageformat +\let\n\noindent +\let\p\verb +\let\q\scm +\let\schemeeval\eval +\let\scmfile\scmdribble +\let\scmfileonly\scmwrite +\let\scmp\scm +%\let\scmverbatim\scm +\let\scmverbatimfile\scminput +\let\setverbatimescapechar\verbescapechar +%\let\verbatim\verb +\let\verbatimfile\verbatiminput +\let\verbinput\verbatiminput +\let\verbfilename\verbwritefile +\let\scmfilename\scmwritefile + +% uppercase version of \romannumeral + +\def\Romannumeral{\afterassignment\RomannumeralI\count255=} + +\def\RomannumeralI{\uppercase\expandafter{\romannumeral\the\count255 }} + +\def\f{\footnote} + +\ifx\label\UnDeFiNeD +\else +\def\tag#1#2{\@bsphack + \protected@write\@auxout{}% + {\string\newlabel{#1}{{#2}{\thepage}}}% +\@esphack}% +\let\tagref\ref +\fi + +\def\inputexternallabels#1 {\relax} +\def\includeexternallabels#1 {\relax} + +% The rest of the file isn't needed for LaTeX + +\ifx\section\UnDeFiNeD +\let\maybeloadfollowing\relax +\else +\catcode`\@\atcatcodebeforetiip +\let\maybeloadfollowing\endinput +\fi\maybeloadfollowing + +% LaTeX stops loading here! + +% Title + +\newwrite\sectionscratchfileport + +\def\subject{% + \immediate\openout\sectionscratchfileport Z-sec-temp + \begingroup + \def\do##1{\catcode`##1=11 }\dospecials + \catcode`\{=1 \catcode`\}=2 + \subjectI} + +\def\subjectI#1{\endgroup + \immediate\write\sectionscratchfileport {#1}% + \immediate\closeout\sectionscratchfileport + $$\vbox{\bf \def\\{\cr}% + \halign{\hfil##\hfil\cr + \input Z-sec-temp + \cr}}$$% + \medskip} + +\let\title\subject + +% Sections + +\def\tracksectionchangeatlevel#1{% + \expandafter\let\expandafter\thiscount\csname + sectionnumber#1\endcsname + \ifx\thiscount\relax + \expandafter\edef\csname sectionnumber#1\endcsname{0}% + \fi + \expandafter\advancetally + \csname sectionnumber#1\endcsname 1% + \ifx\doingappendix0% + \edef\recentlabel{\csname sectionnumber1\endcsname}% + \else + %\count255=\expandafter\csname sectionnumber1\endcsname + \edef\recentlabel{\char\csname sectionnumber1\endcsname}% + \fi + \count255=0 + \loop + \advance\count255 by 1 + \ifnum\count255=1 + \else\edef\recentlabel{\recentlabel.\csname + sectionnumber\the\count255\endcsname}\fi + \ifnum\count255<#1% + \repeat + \loop + \advance\count255 by 1 + \expandafter\let\expandafter\nextcount\csname + sectionnumber\the\count255\endcsname + \ifx\nextcount\relax + \let\continue0% + \else + \expandafter\edef\csname + sectionnumber\the\count255\endcsname{0}% + \let\continue1\fi + \ifx\continue1% + \repeat} + +% Vanilla section-header look -- change this macro for new look + +\newcount\secnumdepth + +\secnumdepth=10 + +\def\sectiond#1{\count255=#1% + \ifx\usingchapters1\advance\count255 by 1 \fi + \edef\sectiondlvl{\the\count255 }% + \futurelet\sectionnextchar\sectiondispatch} + +\def\sectiondispatch{\ifx\sectionnextchar*% + \def\sectioncontinue{\sectionstar{\sectiondlvl}}\else + \ifnum\sectiondlvl>\secnumdepth + \def\sectioncontinue{\sectionhelp{\sectiondlvl}{}}\else + \tracksectionchangeatlevel{\sectiondlvl} + \def\sectioncontinue{\sectionhelp{\sectiondlvl}% + {\recentlabel\enspace}}\fi\fi + \sectioncontinue} + +\def\sectionstar#1*{\sectionhelp{#1}{}} + + +\def\sectionhelp#1#2{% + \edef\sectiondepth{#1}% + \def\sectionnr{#2}% + \immediate\openout\sectionscratchfileport Z-sec-temp + \begingroup + \def\do##1{\catcode`##1=11 }\dospecials + \catcode`\{=1 \catcode`\}= 2 + \sectionheader} + +\def\sectionheader#1{\endgroup + \immediate\write\sectionscratchfileport {#1}% + \immediate\closeout\sectionscratchfileport + \vskip -\lastskip + \ifnum\sectiondepth>\tocdepth\else + \tocactivate + {\let\folio0% + \edef\temp{\write\tocout + {\string\tocentry{\sectiondepth}{\sectionnr}{#1}{\folio}}}% + \temp}\fi + \vskip1.5\bigskipamount +\goodbreak %??? + \noindent + \hbox{\vtop{\pretolerance 10000 + \raggedright + \noindent\bf\sectionnr + \input Z-sec-temp }}% + \bgroup\let\par\sectionafterskip} + +% \edef\temp{\write\tocout{\string\hskip#1\space em\string\relax\space #2% +% \string\vtop{\string\hsize=.7\string\hsize +% \string\noindent\string\raggedright\space #3}\string\par}}\temp + +\def\sectionafterskip{\egroup\nobreak\par\noindent} + +\def\section{\sectiond1} +\def\subsection{\sectiond2} +\def\subsubsection{\sectiond3} +\def\paragraph{\sectiond4} +\def\subparagraph{\sectiond5} + +\let\usingchapters0 + +\def\chapter{\global\let\usingchapters1% +\futurelet\chapternextchar\chapterdispatch} + +\def\chapterdispatch{\ifx\chapternextchar*% + \let\chaptercontinue\chapterstar\else + \tracksectionchangeatlevel{1}% + \def\chaptercontinue{\chapterhelp{\recentlabel\enspace}}\fi + \chaptercontinue} + +\def\chapterstar*{\chapterhelp{}} + +\def\chapterhelp#1{% + % #1=number #2=heading-text + \def\chapternr{#1}% + \immediate\openout\sectionscratchfileport Z-sec-temp + \begingroup + \def\do##1{\catcode`##1=11 }\dospecials + \catcode`\{=1 \catcode`\}=2 + \chapterheader} + +\def\chapterheader#1{\endgroup + \immediate\write\sectionscratchfileport {#1}% + \immediate\closeout\sectionscratchfileport + \tocactivate + {\let\folio0% + \edef\temp{\write\tocout{\string\tocentry{1}{\chapternr}{#1}{\folio}}}% + \temp}% + \vfill\eject + \null\vskip3em + \noindent + \ifx\chapternr\empty\hbox{~}\else + \ifx\doingappendix0% + \hbox{\bf Chapter \chapternr}\else + \hbox{\bf Appendix \chapternr}\fi\fi + \vskip 1em + \noindent + \hbox{\bf\vtop{%\hsize=.7\hsize + \pretolerance 10000 + \noindent\raggedright\input Z-sec-temp }}% + \bgroup\let\par\chapterafterskip} + +\def\chapterafterskip{\egroup\nobreak\vskip3em \noindent} + +\let\doingappendix=0 + +\def\appendix{\let\doingappendix=1% + \count255=`\A% + \advance\count255 by -1 + \expandafter\edef\csname + sectionnumber1\endcsname{\the\count255 }} + + +% toc + +\let\tocactive0 + +\newcount\tocdepth + +\tocdepth=10 + +\def\tocoutensure{\ifx\tocout\UNDEFINED + \csname newwrite\endcsname\tocout\fi} + +\def\tocactivate{\ifx\tocactive0% + \tocoutensure + \tocsave + \openout\tocout \jobname.toc + \global\let\tocactive1\fi} + +\def\tocspecials{\def\do##1{\catcode`##1=12 }\dospecials} + +\def\tocsave{\openin0=\jobname.toc + \ifeof0 \closein0 \else + \openout\tocout Z-T-\jobname.tex + \let\tocsaved 0% + \loop + \ifeof0 \closeout\tocout + \let\tocsaved1% + \else{\tocspecials + \read0 to \tocsaveline + \edef\temp{\write\tocout{\tocsaveline}}\temp}% + \fi + \ifx\tocsaved0% + \repeat + \fi + \closein0 } + +\def\tocentry#1#2{% + %#1=depth #2=secnum + \ifnum#1=1 + \ifnum\tocdepth>2 + \medbreak\begingroup\bf + \else\begingroup\fi + \else\begingroup\fi + \vtop\bgroup\raggedright + \noindent\hskip #1 em + #2% + \bgroup + \aftergroup\tocentryI + %read section title + \let\dummy=} + +\def\tocentryI#1{% + %#1=page nr + , #1\strut\egroup + \endgroup\par +} + +\def\tableofcontents{% + \ifx\tocactive0% + \openin0 \jobname.toc + \ifeof0 \closein0 \else + \closein0 \input \jobname.toc + \fi + \tocoutensure + \openout\tocout \jobname.toc + \global\let\tocactive1% + \else + \input Z-T-\jobname.tex + \fi} + +% allow {thebibliography} to be used directly +% in (plain-TeX) source document without +% generating it via BibTeX + +\ifx\thebibliography\UnDeFiNeD +\def\thebibliography#1{\vskip-\lastskip + \begingroup + \def\endthebibliography{\endgroup\endgroup}% + \def\input##1 ##2{\relax}% + \setbox0=\hbox{\biblabelcontents{#1}}% + \biblabelwidth=\wd0 + \@readbblfile}% +\fi + +% Cross-references + +% \openxrefout loads all the TAG-VALUE associations in +% \jobname.xrf and then opens \jobname.xrf as an +% output channel that \tag can use + +\def\openxrefout{% + \openin0=\jobname.xrf + \ifeof0 \closein0 + \else \closein0 {\catcode`\\0 \input \jobname.xrf }% + \fi + \expandafter\csname newwrite\endcsname\xrefout + \openout\xrefout=\jobname.xrf +} + +% I'd like to call \openxrefout lazily, but +% unfortunately it produces a bug in MiKTeX. +% So let's call it up front. + +\openxrefout + +% \tag{TAG}{VALUE} associates TAG with VALUE. +% Hereafter, \ref{TAG} will output VALUE. +% \tag stores its associations in \xrefout. +% \tag calls \openxrefout if \jobname.xrf hasn't +% already been opened + +\def\tag#1#2{\ifx\xrefout\UNDEFINED\openxrefout\fi + {\let\folio0% + \edef\temp{% + \write\xrefout{\string\expandafter\string\gdef + \string\csname\space XREF#1\string\endcsname + {#2}\string\relax}}% + \temp}} + +% \tagref{TAG} outputs VALUE, assuming \tag put such +% an association into \xrefout. \tagref calls +% \openxrefout if \jobname.xrf hasn't already +% been opened + +% Later, we will \let \ref = \tagref after making +% sure we aren't in eplain, which uses the ctlseq +% \ref differently + +\def\tagref#1{\ifx\xrefout\UNDEFINED\openxrefout\fi + \expandafter\ifx\csname XREF#1\endcsname\relax + %\message or \write16 ? + \message{\the\inputlineno: Unresolved label `#1'.}?\else + \csname XREF#1\endcsname\fi} + +% \label, as in LaTeX + +\let\recentlabel\relax + +% The sectioning commands +% define \recentlabel so a subsequent call to \label will pick up the +% right label. + +\def\label#1{\tag{#1}{\recentlabel}% + \tag{PAGE#1}{\folio}} + +% \pageref, as in LaTeX + +\def\pageref#1{\ref{PAGE#1}} + +% eplain users see the \ref they are used to. Others +% have \ref = \tagref + +\ifx\eplain\UnDeFiNeD +\let\ref\tagref +\fi + +% + +\ifx\IfFileExists\UnDeFiNeD +\def\IfFileExists#1#2#3{% + \openin0 #1 % + \ifeof0 % + #3% + \else + #2\fi + \closein0 }% +\fi + +\ifx\InputIfFileExists\UnDeFiNeD +\def\InputIfFileExists#1#2#3{% + \IfFileExists{#1}{#2\input #1 }{#3}}% +\fi + +\let\iffileexists\IfFileExists + +% + +% dummy def to let load dvipsnam.def + +\ifx\ProvidesFile\UnDeFiNeD +\def\ProvidesFile#1[#2]{}% +\fi + +% + +% Index generation +% +% Your TeX source contains \index{NAME} to +% signal that NAME should be included in the index. +% Check the makeindex documentation to see the various +% ways NAME can be specified, eg, for subitems, for +% explicitly specifying the alphabetization for a name +% involving TeX control sequences, etc. +% +% The first run of TeX will create \jobname.idx. +% makeindex on \jobname[.idx] will create the sorted +% index \jobname.ind. +% +% Use \inputindex (without arguments) to include this +% sorted index, typically somewhere to the end of your +% document. This will produce the items and subitems. +% It won't produce a section heading however -- you +% will have to typeset one yourself. +% +% Use \printindex instead of \inputindex if you want +% the section heading ``Index'' automatically generated. + +\def\sanitizeidxletters{\def\do##1{\catcode`##1=11 }% + \do\\\do\$\do\&\do\#\do\^\do\_\do\%\do\~% + \do\@\do\"\do\!\do\|\do\-\do\ \do\'} + +\def\index{%\unskip + \ifx\indexout\UNDEFINED + \csname newwrite\endcsname\indexout + \openout\indexout \jobname.idx\fi + \begingroup + \sanitizeidxletters + \indexI} + +\def\indexI#1{\endgroup + \write\indexout{\string\indexentry{#1}{\folio}}% + \ignorespaces} + +% The following index style indents subitems on a +% separate lines + +\def\theindex{\begingroup + \parskip0pt \parindent0pt + \def\indexitem##1{\par\hangindent30pt \hangafter1 + \hskip ##1 }% + \def\item{\indexitem{0em}}% + \def\subitem{\indexitem{2em}}% + \def\subsubitem{\indexitem{4em}}% + \def\see{{\it see} \bgroup\aftergroup\gobblegroup\let\dummy=}% + \let\indexspace\medskip} + +\def\endtheindex{\endgroup} + +% \packindex declares that subitems be bundled into one +% semicolon-separated paragraph + +\def\packindex{% + \def\theindex{\begingroup + \parskip0pt \parindent0pt + \def\item{\par\hangindent20pt \hangafter1 }% + \def\subitem{\unskip; }% + \def\subsubitem{\unskip; }% + \def\see{\bgroup\it see \aftergroup\gobblegroup\let\dummy=}% + \let\indexspace\medskip}} + +\def\inputindex{% + \openin0 \jobname.ind + \ifeof0 \closein0 + \message{\jobname.ind missing.}% + \else\closein0 + \begingroup + \def\begin##1{\csname##1\endcsname}% + \def\end##1{\csname end##1\endcsname}% + \input\jobname.ind + \endgroup\fi} + +\def\printindex{\csname beginsection\endcsname Index\par + \inputindex} + +% + +\def\italiccorrection{\futurelet\italiccorrectionI + \italiccorrectionII} + +\def\italiccorrectionII{% + \if\noexpand\italiccorrectionI,\else + \if\noexpand\italiccorrectionI.\else + \/\fi\fi} + +\def\em{\it\ifmmode\else\aftergroup\italiccorrection\fi} + +%\def\emph{\bgroup\it +% \ifmmode\else\aftergroup\italiccorrection\fi +% \let\dummy=} + +\def\quote{\bgroup\narrower\smallbreak} +\def\endquote{\smallbreak\egroup} + +\def\begin#1{\begingroup + \def\end##1{\csname end#1\endcsname\endgroup}% + \csname #1\endcsname} + +\def\raggedleft{% + \leftskip 0pt plus 1fil + \parfillskip 0pt +} + +\def\r#1{{\accent23 #1}} + + +\ifx\strip@pt\UNDEFINED +\begingroup + \catcode`P 12 \catcode`T 12 + \lowercase{\endgroup + \gdef\strip@pt#1PT{#1}}% +\fi + +% color + +\ifx\color\UnDeFiNeD +% +\ifx\pdfoutput\UnDeFiNeD % PostScript +% +\def\colorCurrentColor{color cmyk 0 0 0 1}% +% +\def\colorRestoreCurrentColor{% +\special{\colorCurrentColor}\egroup\egroup}% +% +\def\colorWithModelrgb#1{\bgroup +\def\colorCurrentColor{color rgb #1}% +\special{\colorCurrentColor}% +\aftergroup\colorRestoreCurrentColor}% +% +\def\colorWithModelRGBaux#1 #2 #3\end{\bgroup +\dimen0=#1pt \divide\dimen0 by 255 +\edef\red{\expandafter\strip@pt\the\dimen0 }% +\dimen0=#2pt \divide\dimen0 by 255 +\edef\green{\expandafter\strip@pt\the\dimen0 }% +\dimen0=#3pt \divide\dimen0 by 255 +\edef\blue{\expandafter\strip@pt\the\dimen0 }% +\def\colorCurrentColor{color rgb \red\space \green\space \blue}% +\special{\colorCurrentColor}% +\aftergroup\colorRestoreCurrentColor +\ignorespaces} +% +\def\colorWithModelcmyk#1{\bgroup +\def\colorCurrentColor{color cmyk #1}% +\special{\colorCurrentColor}% +\aftergroup\colorRestoreCurrentColor}% +% +\def\colorWithModelgray#1{\bgroup +\def\colorCurrentColor{color gray #1}% +\special{\colorCurrentColor}% +\aftergroup\colorRestoreCurrentColor}% +% +\def\colorWithModelnamed#1{\bgroup +\edef\colorCurrentColor{\csname +ColorNamed#1\endcsname}% +\special{\colorCurrentColor}% +\aftergroup\colorRestoreCurrentColor}% +% +\def\definecolorWithModelrgb#1#2{\egroup +\expandafter\def\csname ColorNamed#1\endcsname +{color rgb #2}}% +% +\def\definecolorWithModelcmyk#1#2{\egroup +\expandafter\def\csname ColorNamed#1\endcsname +{color cmyk #2}}% +% +\def\definecolorWithModelgray#1#2{\egroup +\expandafter\def\csname ColorNamed#1\endcsname +{color gray #2}}% +% +\else % PDF +% +\def\colorCurrentColor{0 0 0 1 k}% +% +\def\colorRestoreCurrentColor{% +\pdfliteral{\colorCurrentColor}\egroup\egroup}% +% +\def\colorWithModelrgb#1{\bgroup +\def\colorCurrentColor{#1 rg}% +\pdfliteral{\colorCurrentColor}% +\aftergroup\colorRestoreCurrentColor +\ignorespaces}% +% +\def\colorWithModelRGBaux#1 #2 #3\end{\bgroup +\dimen0=#1pt \divide\dimen0 by 255 +\edef\red{\expandafter\strip@pt\the\dimen0 }% +\dimen0=#2pt \divide\dimen0 by 255 +\edef\green{\expandafter\strip@pt\the\dimen0 }% +\dimen0=#3pt \divide\dimen0 by 255 +\edef\blue{\expandafter\strip@pt\the\dimen0 }% +\def\colorCurrentColor{\red\space \green\space \blue\space rg}% +\pdfliteral{\colorCurrentColor}% +\aftergroup\colorRestoreCurrentColor +\ignorespaces} +% +\def\colorWithModelcmyk#1{\bgroup +\def\colorCurrentColor{#1 k}% +\pdfliteral{\colorCurrentColor}% +\aftergroup\colorRestoreCurrentColor +\ignorespaces}% +% +\def\colorWithModelgray#1{\bgroup +\def\colorCurrentColor{#1 g}% +\pdfliteral{\colorCurrentColor}% +\aftergroup\colorRestoreCurrentColor +\ignorespaces}% +% +\def\colorWithModelnamed#1{\bgroup +\edef\colorCurrentColor{\csname +ColorNamed#1\endcsname}% +\pdfliteral{\colorCurrentColor}% +\aftergroup\colorRestoreCurrentColor +\ignorespaces}% +% +\def\definecolorWithModelrgb#1#2{\egroup +\expandafter\def\csname ColorNamed#1\endcsname +{#2 rg}}% +% +\def\definecolorWithModelcmyk#1#2{\egroup +\expandafter\def\csname ColorNamed#1\endcsname +{#2 k}}% +% +\def\definecolorWithModelgray#1#2{\egroup +\expandafter\def\csname ColorNamed#1\endcsname +{#2 g}}% +% +\fi +% +\def\color{\futurelet\colorQpeekchar\colorQpossiblynamed}% +% +\def\colorQpossiblynamed{\bgroup +\defcsactive\,{ }% +\if\colorQpeekchar[% +\let\colorQproceed\colorQexplicitmodel\else +\let\colorQproceed\colorWithModelnamed\fi +\colorQproceed}% +% +\def\colorQexplicitmodel[#1]{% +\csname colorWithModel#1\endcsname}% +% +\def\colorWithModelRGB#1{% +\colorWithModelRGBaux#1\end}% +% +\def\definecolor#1#2{\bgroup +\defcsactive\,{ }% +\csname definecolorWithModel#2\endcsname{#1}}% +% +% foll lets load texmf/tex/latex/graphics/dvipsnam.def +\def\DefineNamedColor#1{\definecolor}% +% +% these colors are standard in latex +\definecolor{red}{rgb}{1 0 0}% +\definecolor{green}{rgb}{0 1 0}% +\definecolor{blue}{rgb}{0 1 1}% +\definecolor{cyan}{cmyk}{1 0 0 0}% +\definecolor{magenta}{cmyk}{0 1 0 0}% +\definecolor{yellow}{cmyk}{0 0 1 0}% +\definecolor{black}{cmyk}{0 0 0 1}% +\definecolor{white}{rgb}{1 1 1}% +% +\fi + +%the rest of the file isn't needed for eplain? + +\def\itemize{\par\begingroup + \advance\leftskip\parindent + \smallbreak + \def\item{\smallbreak\noindent + \llap{$\bullet$\enspace}\ignorespaces}} + +\def\enditemize{\smallbreak\smallbreak\endgroup\par} + +\newtally\enumeratelevel + +\def\enumerate{\par\begingroup + \advancetally\enumeratelevel1% + \newtally\enumeratenumber + \advance\leftskip\parindent + \smallbreak + \def\item{\smallbreak\noindent + \advancetally\enumeratenumber1% + \ifnum\enumeratelevel=1 + \edef\enumeratemark{\enumeratenumber}\else + \ifnum\enumeratelevel=2 + \count255=\enumeratenumber + \advance\count255 by -1 \advance\count255 by `a + \edef\enumeratemark{\noexpand\char\the\count255 }\else + \ifnum\enumeratelevel=3 + \edef\enumeratemark{\romannumeral\enumeratenumber}\else + \ifnum\enumeratelevel=4 + \count255=\enumeratenumber + \advance\count255 by -1 \advance\count255 by `A + \edef\enumeratemark{\noexpand\char\the\count255 }\else + \edef\enumeratemark{\enumeratenumber}\fi\fi\fi\fi + \edef\recentlabel{\enumeratemark}% needed? + \llap{\enumeratemark.\enspace}\ignorespaces}} + +\def\endenumerate{\smallbreak\smallbreak\endgroup\par} + +% Numbered footnotes + +\ifx\plainfootnote\UNDEFINED + \let\plainfootnote\footnote +\fi + +\newtally\footnotenumber + +\def\numfootnote{\globaladvancetally\footnotenumber 1% + \bgroup\csname footnotehook\endcsname + \plainfootnote{$^{\footnotenumber}$}\bgroup + \edef\recentlabel{\footnotenumber}% + \aftergroup\egroup + \let\dummy=} + +\let\f\numfootnote + +\ifx\frac\UnDeFiNeD +\def\frac#1/#2{{#1\over#2}}% +\fi + +% \path is like \verb except that its argument +% can break across lines at `.' and `/'. + +\ifx\path\UnDeFiNeD +\def\path{\begingroup\verbsetup + \pathfont + \defcsactive\.{\discretionary{\char`\.}{}{\char`\.}}% + \defcsactive\/{\discretionary{\char`\/}{}{\char`\/}}% + \verbI}% +\fi + +\let\pathfont\relax + +\catcode`\@\atcatcodebeforetiip + +\endtexonly + +% end of file diff --git a/examples/README b/examples/README new file mode 100644 index 0000000..9cc6548 --- /dev/null +++ b/examples/README @@ -0,0 +1,17 @@ +These examples illustrate the various uses of hs-plugins. + +conf a configuration file edsl using plugins +dynload dynamically typed load +eval runtime evaluation of haskell strings, from Haskell and C +hmake the 'plugs' haskell interpreter +iface test the interface file parser +load load a plugin +make build a Haskell file +makewith merge and build a Haskell file +multi load multiple plugins at once +objc load Haskell plugins into object C programs +pkgconf test package.conf parsing +popen test popen +reload reload a plugin when it changes +shell a simple string filter +unload test unloading of plugins diff --git a/examples/TIMINGS b/examples/TIMINGS new file mode 100644 index 0000000..531a2b5 --- /dev/null +++ b/examples/TIMINGS @@ -0,0 +1,45 @@ +Method: + * "pdynload" + comes from pdynload/small + * "load + ghc" + comes from pdynload/null, with lines 13-14 + uncommented from prog/Main.hs + * "dynload" + from dynload/simple + * "load, no check" + from pdynload/null, with lines 13-14 of prog/Main.hs + commented out + +For example, to run the "pdynload" test: + $ cd pdynload/small + $ make + $ make check # to prime caches, etc. + $ time make check + $ time make check + $ time make check # run 'time make check' until value converges + +The converged value is entered into the "Raw" timings, and then the +scaled timing is calculated for each machine. These scaled values were +then averaged over the number of machines, yielding the final +"Average" scores -- the average over a number of machines and os. + +Raw timing: +pdynload load+ghc dynload load, no check + +0.33 0.25 0.22 0.21 -- P4 2.6 , OpenBSD +0.38 0.31 0.29 0.27 -- P4 2.66, Linux +0.84 0.77 0.64 0.55 -- Quad P4 2.4, Linux +0.76 0.60 0.52 0.50 -- AMD 1.1G, Linux +0.95 0.83 0.75 0.72 -- G5 2.0G, Mac OS X + -- Quad Itanium 1,Linux + +Scaled: +1.57 1.19 1.05 1 +1.40 1.15 1.07 +1.52 1.4 1.16 +1.52 1.2 1.04 +1.32 1.15 1.04 + +Average: +=1.46 = 1.218 = 1.07 + diff --git a/examples/build.mk b/examples/build.mk new file mode 100644 index 0000000..d503cd0 --- /dev/null +++ b/examples/build.mk @@ -0,0 +1,41 @@ +# how to build the default projects + +include $(TOP)/config.mk +include $(TOP)/examples/check.mk + +BIN= prog/a.out +OBJ= prog/Main.o +SRC= prog/Main.hs + +BINDIR= prog +REALBIN= ./a.out + +API_OBJ= api/API.o + +INCLUDES= -i$(TOP)/examples/$(TEST)/api +PKGFLAGS= -package-conf $(TOP)/plugins.conf.inplace -package plugins +GHCFLAGS= -Onot -cpp -fglasgow-exts + +.SUFFIXES : .o .hs .hi .lhs .hc .s + +all: $(BIN) + +$(BIN) : $(PRIOR_OBJS) $(API_OBJ) $(SRC) $(EXTRA_OBJS) + @rm -f $@ + @$(GHC) --make -o $@ $(INCLUDES) $(PKGFLAGS) $(GHCFLAGS) $(EXTRAFLAGS) $(API) $(SRC) + +# Standard suffix rules +.o.hi: + @: +.hs.o: + @$(GHC) $(INCLUDES) $(PKGFLAGS) $(GHCFLAGS) $(EXTRAFLAGS) -c $< + +clean: + find . -name '*~' -exec rm {} \; + rm -rf *.{o,hi,dep} + rm -rf */*.{hi,o,old} */a.out + rm -rf */*core + rm -rf */*.a + rm -rf */package.conf + rm -rf *.a + diff --git a/examples/check.mk b/examples/check.mk new file mode 100644 index 0000000..b07d859 --- /dev/null +++ b/examples/check.mk @@ -0,0 +1,24 @@ +include $(TOP)/config.mk + +check: $(BIN) + @(cd $(BINDIR) ;\ + expected="expected" ;\ + if [ -f "expected" -o -f "expected.$(GLASGOW_HASKELL)" ] ;\ + then \ + actual_out="/tmp/hs-plugins-actual.out.$$$$" ;\ + diff_out="/tmp/hs-plugins.diff.$$$$" ;\ + $(REALBIN) > $$actual_out 2>&1 || true ;\ + if [ -f "expected.$(GLASGOW_HASKELL)" ] ; then \ + expected="expected.$(GLASGOW_HASKELL)" ;\ + fi ;\ + diff -u $$expected $$actual_out > $$diff_out || true ;\ + if [ -s "$$diff_out" ] ; then \ + echo "failed with:" ;\ + cat "$$diff_out" | sed '1,3d' ;\ + else \ + echo "ok." ;\ + fi ;\ + rm $$actual_out $$diff_out ;\ + else \ + $(REALBIN) 2>&1 || true ;\ + fi) diff --git a/examples/conf/simple/Mailrc.conf b/examples/conf/simple/Mailrc.conf new file mode 100644 index 0000000..449cfab --- /dev/null +++ b/examples/conf/simple/Mailrc.conf @@ -0,0 +1,11 @@ +import System.Directory + +resource = mail { +-- editor = do b <- doesFileExist "/usr/bin/emacs" +-- return $ if b then "emacs" else "vi" , + editor = do b <- doesFileExist "/bin/sh" + return "sh", + + attribution = \name -> "Today, "++name++" wrote :" +} + diff --git a/examples/conf/simple/Mailrc.stub b/examples/conf/simple/Mailrc.stub new file mode 100644 index 0000000..21a2128 --- /dev/null +++ b/examples/conf/simple/Mailrc.stub @@ -0,0 +1,28 @@ +module Mailrc ( resource ) where + +import API + +resource :: Interface +resource = mail + + + + + + + + + + + + + + + + + + + + + + diff --git a/examples/conf/simple/Makefile b/examples/conf/simple/Makefile new file mode 100644 index 0000000..c7f9b01 --- /dev/null +++ b/examples/conf/simple/Makefile @@ -0,0 +1,4 @@ +TEST= conf/simple + +TOP=../../.. +include ../../build.mk diff --git a/examples/conf/simple/api/API.hs b/examples/conf/simple/api/API.hs new file mode 100644 index 0000000..345bf2a --- /dev/null +++ b/examples/conf/simple/api/API.hs @@ -0,0 +1,27 @@ +-- +-- the configuration file interface. +-- + +module API where + +data Color = Black | Grey | Green | Cyan | Yellow | Magenta | Red + +data Interface = Interface { + editor :: IO String, + attribution :: String -> String, + header_color :: Color, + colorize :: [String], + include :: Bool + } + +-- Default settings +mail :: Interface +mail = Interface { + editor = return "vi", + + attribution = (\user -> user ++ " wrote:"), + header_color = Grey, + colorize = [], + include = True + } + diff --git a/examples/conf/simple/prog/Main.hs b/examples/conf/simple/prog/Main.hs new file mode 100644 index 0000000..7c4fca0 --- /dev/null +++ b/examples/conf/simple/prog/Main.hs @@ -0,0 +1,22 @@ + +import Plugins +import API + +conf = "../Mailrc.conf" +stub = "../Mailrc.stub" +apipath = "../api" + +main = do + status <- makeWith conf stub ["-i"++apipath] + o <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess _ o -> return o + status <- load o [apipath] [] "resource" + v <- case status of + LoadFailure err -> mapM_ putStrLn err >> error "no" + LoadSuccess _ v -> return v + + user_editor <- editor v + putStrLn user_editor + makeCleaner o + diff --git a/examples/conf/simple/prog/expected b/examples/conf/simple/prog/expected new file mode 100644 index 0000000..b001cf7 --- /dev/null +++ b/examples/conf/simple/prog/expected @@ -0,0 +1 @@ +sh diff --git a/examples/dynload/io/Makefile b/examples/dynload/io/Makefile new file mode 100644 index 0000000..3cf85e7 --- /dev/null +++ b/examples/dynload/io/Makefile @@ -0,0 +1,6 @@ +TEST=dynload/io + +EXTRA_OBJS=TestIO.o + +TOP=../../.. +include ../../build.mk diff --git a/examples/dynload/io/TestIO.hs b/examples/dynload/io/TestIO.hs new file mode 100644 index 0000000..979e2d2 --- /dev/null +++ b/examples/dynload/io/TestIO.hs @@ -0,0 +1,86 @@ +{-# OPTIONS -fglasgow-exts -cpp #-} +-- +-- Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- LGPL version 2.1 or later (see http://www.gnu.org/copyleft/lesser.html) +-- + +module TestIO ( resource_dyn ) where + +import API +import AltData + +import System.IO +import System.Posix.Types ( ProcessID, Fd ) +import System.Posix.Process ( forkProcess, executeFile, getProcessID ) +import System.Posix.IO ( createPipe, stdInput, + stdOutput, fdToHandle, closeFd, dupTo ) + +resource_dyn :: Dynamic +resource_dyn = toDyn resource + +resource :: TestIO +resource = testio { field = date } + + +-- +-- call a shell command , returning it's output +-- +date :: IO String +date = do (hdl,_,_) <- catch (popen "/bin/date") (\_->error "popen failed") + hGetLine hdl + +------------------------------------------------------------------------ +-- +-- my implementation of $val = `cmd`; (if this was perl) +-- +-- provide similar functionality to popen(3), +-- along with bidirectional ipc via pipes +-- return's the pid of the child process +-- +-- there are two different forkProcess functions. the pre-620 was a +-- unix-fork style function, and the modern function has semantics more +-- like the Awkward-Squad paper. We provide implementations of popen +-- using both versions, depending on which GHC the user wants to try. +-- + +popen :: FilePath -> IO (Handle, Handle, ProcessID) +popen cmd = do + (pr, pw) <- createPipe + (cr, cw) <- createPipe + + -- parent -- + let parent = do closeFd cw + closeFd pr + -- child -- + let child = do closeFd pw + closeFd cr + exec cmd (pr,cw) + error "exec cmd failed!" -- typing only + +-- if the parser front end understood cpp, this would work +-- #if __GLASGOW_HASKELL__ >= 601 + pid <- forkProcess child -- fork child + parent -- and run parent code +-- #else +-- p <- forkProcess +-- pid <- case p of +-- Just pid -> parent >> return pid +-- Nothing -> child +-- #endif + + hcr <- fdToHandle cr + hpw <- fdToHandle pw + + return (hcr,hpw,pid) + +-- +-- execve cmd in the child process, dup'ing the file descriptors passed +-- as arguments to become the child's stdin and stdout. +-- +exec :: FilePath -> (Fd,Fd) -> IO () +exec cmd (pr,cw) = do + dupTo pr stdInput + dupTo cw stdOutput + executeFile cmd False [] Nothing + +------------------------------------------------------------------------ diff --git a/examples/dynload/io/api/API.hs b/examples/dynload/io/api/API.hs new file mode 100644 index 0000000..6e9bdbd --- /dev/null +++ b/examples/dynload/io/api/API.hs @@ -0,0 +1,19 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import AltData + +data TestIO = TestIO { + field :: IO String + } + +instance Typeable TestIO where +#if __GLASGOW_HASKELL__ >= 603 + typeOf i = mkTyConApp (mkTyCon "API.TestIO") [] +#else + typeOf i = mkAppTy (mkTyCon "API.TestIO") [] +#endif + +testio :: TestIO +testio = TestIO { field = return "default value" } diff --git a/examples/dynload/io/prog/Main.hs b/examples/dynload/io/prog/Main.hs new file mode 100644 index 0000000..7c8a70c --- /dev/null +++ b/examples/dynload/io/prog/Main.hs @@ -0,0 +1,12 @@ + +import Plugins +import API + +main = do + m_v <- dynload "../TestIO.o" ["../api"] + ["../../../../plugins.conf.inplace"] "resource_dyn" + case m_v of + LoadFailure _ -> error "couldn't compile" + LoadSuccess _ v -> do + s <- field v + if s /= [] then print True else print False diff --git a/examples/dynload/io/prog/expected b/examples/dynload/io/prog/expected new file mode 100644 index 0000000..0ca9514 --- /dev/null +++ b/examples/dynload/io/prog/expected @@ -0,0 +1 @@ +True diff --git a/examples/dynload/poly/Makefile b/examples/dynload/poly/Makefile new file mode 100644 index 0000000..e06d6e6 --- /dev/null +++ b/examples/dynload/poly/Makefile @@ -0,0 +1,4 @@ +TEST=dynload/poly +EXTRA_OBJS=Plugin.o +TOP=../../.. +include ../../build.mk diff --git a/examples/dynload/poly/Plugin.hs b/examples/dynload/poly/Plugin.hs new file mode 100644 index 0000000..bf99cde --- /dev/null +++ b/examples/dynload/poly/Plugin.hs @@ -0,0 +1,12 @@ +module Plugin where + +import API +import AltData + +my_fun = plugin { + equals = \x y -> (x /= y) -- a strange equals function :) + } + +resource_dyn :: Dynamic +resource_dyn = toDyn my_fun + diff --git a/examples/dynload/poly/api/API.hs b/examples/dynload/poly/api/API.hs new file mode 100644 index 0000000..0181ef3 --- /dev/null +++ b/examples/dynload/poly/api/API.hs @@ -0,0 +1,24 @@ +{-# OPTIONS -cpp #-} + +module API where + +import AltData + +data Interface = Interface { + equals :: forall t. Eq t => t -> t -> Bool + } + +-- +-- see how it hides the internal type.. but to compile GHC still checks +-- the type. +-- +instance Typeable Interface where +#if __GLASGOW_HASKELL__ >= 603 + typeOf i = mkTyConApp (mkTyCon "API.Interface") [] +#else + typeOf i = mkAppTy (mkTyCon "API.Interface") [] +#endif + +plugin :: Interface +plugin = Interface { equals = (==) } + diff --git a/examples/dynload/poly/prog/Main.hs b/examples/dynload/poly/prog/Main.hs new file mode 100644 index 0000000..ff91b2e --- /dev/null +++ b/examples/dynload/poly/prog/Main.hs @@ -0,0 +1,17 @@ +{-# OPTIONS -cpp #-} + +#include "../../../../config.h" + +import Plugins +import API + +main = do + m_v <- dynload "../Plugin.o" ["../api"] + ["../../../../plugins.conf.inplace"] + "resource_dyn" + case m_v of + LoadFailure _ -> error "didn't compile" + LoadSuccess _ (Interface eq) -> do + putStrLn $ show $ 1 `eq` 2 + putStrLn $ show $ 'a' `eq` 'b' + diff --git a/examples/dynload/poly/prog/expected b/examples/dynload/poly/prog/expected new file mode 100644 index 0000000..dbde422 --- /dev/null +++ b/examples/dynload/poly/prog/expected @@ -0,0 +1,2 @@ +True +True diff --git a/examples/dynload/should_fail/Makefile b/examples/dynload/should_fail/Makefile new file mode 100644 index 0000000..c1bff86 --- /dev/null +++ b/examples/dynload/should_fail/Makefile @@ -0,0 +1,4 @@ +TEST= dynload/should_fail +EXTRA_OBJS=Plugin.o +TOP=../../.. +include ../../build.mk diff --git a/examples/dynload/should_fail/Plugin.hs b/examples/dynload/should_fail/Plugin.hs new file mode 100644 index 0000000..adad70e --- /dev/null +++ b/examples/dynload/should_fail/Plugin.hs @@ -0,0 +1,12 @@ +{-# OPTIONS -fglasgow-exts #-} +module Plugin where + +import API +import AltData + +v :: Int +v = 0xdeadbeef + +resource_dyn :: Dynamic +resource_dyn = toDyn v + diff --git a/examples/dynload/should_fail/api/API.hs b/examples/dynload/should_fail/api/API.hs new file mode 100644 index 0000000..ee11e76 --- /dev/null +++ b/examples/dynload/should_fail/api/API.hs @@ -0,0 +1,20 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import AltData + +data Interface = Interface { + function :: String + } + +instance Typeable Interface where +#if __GLASGOW_HASKELL__ >= 603 + typeOf i = mkTyConApp (mkTyCon "API.Interface") [] +#else + typeOf i = mkAppTy (mkTyCon "API.Interface") [] +#endif + +plugin :: Interface +plugin = Interface { function = "goodbye" } + diff --git a/examples/dynload/should_fail/prog/Main.hs b/examples/dynload/should_fail/prog/Main.hs new file mode 100644 index 0000000..3759159 --- /dev/null +++ b/examples/dynload/should_fail/prog/Main.hs @@ -0,0 +1,14 @@ + +import Plugins +import API + +main = do + m_v <- dynload "../Plugin.o" + ["../api"] + ["../../../../plugins.conf.inplace"] + "resource_dyn" + + case m_v of + LoadFailure _ -> putStrLn "didn't compile" + LoadSuccess _ v -> putStrLn $ function v + diff --git a/examples/dynload/should_fail/prog/expected b/examples/dynload/should_fail/prog/expected new file mode 100644 index 0000000..5e0f819 --- /dev/null +++ b/examples/dynload/should_fail/prog/expected @@ -0,0 +1,4 @@ +Couldn't match `API.Interface' against `Int' + Expected type: API.Interface + Inferred type: Int +didn't compile diff --git a/examples/dynload/should_fail_1/Makefile b/examples/dynload/should_fail_1/Makefile new file mode 100644 index 0000000..896ff0e --- /dev/null +++ b/examples/dynload/should_fail_1/Makefile @@ -0,0 +1,4 @@ +TEST= dynload/should_fail_1 +EXTRA_OBJS=Plugin.o +TOP=../../.. +include ../../build.mk diff --git a/examples/dynload/should_fail_1/Plugin.hs b/examples/dynload/should_fail_1/Plugin.hs new file mode 100644 index 0000000..5e57fad --- /dev/null +++ b/examples/dynload/should_fail_1/Plugin.hs @@ -0,0 +1,15 @@ +-- +-- trying to be really mean. +-- + +module Plugin where + +import API +import AltData + +v :: Int -> Int +v = \x -> 0xdeadbeef + +resource_dyn :: Dynamic +resource_dyn = toDyn v + diff --git a/examples/dynload/should_fail_1/api/API.hs b/examples/dynload/should_fail_1/api/API.hs new file mode 100644 index 0000000..ee11e76 --- /dev/null +++ b/examples/dynload/should_fail_1/api/API.hs @@ -0,0 +1,20 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import AltData + +data Interface = Interface { + function :: String + } + +instance Typeable Interface where +#if __GLASGOW_HASKELL__ >= 603 + typeOf i = mkTyConApp (mkTyCon "API.Interface") [] +#else + typeOf i = mkAppTy (mkTyCon "API.Interface") [] +#endif + +plugin :: Interface +plugin = Interface { function = "goodbye" } + diff --git a/examples/dynload/should_fail_1/prog/Main.hs b/examples/dynload/should_fail_1/prog/Main.hs new file mode 100644 index 0000000..cf8f647 --- /dev/null +++ b/examples/dynload/should_fail_1/prog/Main.hs @@ -0,0 +1,11 @@ + +import Plugins +import API + +main = do + m_v <- dynload "../Plugin.o" ["../api"] + ["../../../../plugins.conf.inplace"] "resource_dyn" + case m_v of + LoadFailure _ -> putStrLn "didn't compile" + LoadSuccess _ v -> putStrLn $ (function v) + diff --git a/examples/dynload/should_fail_1/prog/expected b/examples/dynload/should_fail_1/prog/expected new file mode 100644 index 0000000..821bc22 --- /dev/null +++ b/examples/dynload/should_fail_1/prog/expected @@ -0,0 +1,4 @@ +Couldn't match `API.Interface' against `Int -> Int' + Expected type: API.Interface + Inferred type: Int -> Int +didn't compile diff --git a/examples/dynload/should_fail_2/Makefile b/examples/dynload/should_fail_2/Makefile new file mode 100644 index 0000000..eaf3c29 --- /dev/null +++ b/examples/dynload/should_fail_2/Makefile @@ -0,0 +1,4 @@ +TEST= dynload/should_fail_2 + +TOP=../../.. +include ../../build.mk diff --git a/examples/dynload/should_fail_2/Plugin.in b/examples/dynload/should_fail_2/Plugin.in new file mode 100644 index 0000000..8de0ab7 --- /dev/null +++ b/examples/dynload/should_fail_2/Plugin.in @@ -0,0 +1,19 @@ +-- +-- the plugin doesn't even make the resource_dyn a Dynamic. +-- +-- let's hope that makeWith strips out the invalid declarations +-- + +{-# OPTIONS -fglasgow-exts #-} + +module Plugin where + +import API +import AltData +import GHC.Base + +v :: Int +v = 0xdeadbeef + +resource_dyn = (typeOf v, unsafeCoerce v) + diff --git a/examples/dynload/should_fail_2/Plugin.stub b/examples/dynload/should_fail_2/Plugin.stub new file mode 100644 index 0000000..efc2f53 --- /dev/null +++ b/examples/dynload/should_fail_2/Plugin.stub @@ -0,0 +1,12 @@ +{-# OPTIONS -fglasgow-exts #-} + +module Plugin ( resource_dyn ) where + +import API +import AltData + +resource = plugin + +resource_dyn :: Dynamic +resource_dyn = toDyn resource + diff --git a/examples/dynload/should_fail_2/api/API.hs b/examples/dynload/should_fail_2/api/API.hs new file mode 100644 index 0000000..85ece49 --- /dev/null +++ b/examples/dynload/should_fail_2/api/API.hs @@ -0,0 +1,22 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import AltData +import GHC.Base + +data Interface = Interface { + function :: String + } + +instance Typeable Interface where +#if __GLASGOW_HASKELL__ >= 603 + typeOf i = mkTyConApp (mkTyCon "API.Interface") [] +#else + typeOf i = mkAppTy (mkTyCon "API.Interface") [] +#endif + +plugin :: Interface +plugin = Interface { function = "goodbye" } + +unsafeCoerce = unsafeCoerce# diff --git a/examples/dynload/should_fail_2/prog/Main.hs b/examples/dynload/should_fail_2/prog/Main.hs new file mode 100644 index 0000000..ea9b05c --- /dev/null +++ b/examples/dynload/should_fail_2/prog/Main.hs @@ -0,0 +1,19 @@ + +import Plugins +import API + +conf = "../Plugin.in" +stub = "../Plugin.stub" + +main = do + status <- makeWith conf stub ["-i../api", "-i../../../../src/altdata/"] + case status of + MakeFailure e -> mapM_ putStrLn e >> putStrLn "failed" + MakeSuccess _ o -> do { + ; m_v <- dynload o ["../api"] [] "resource_dyn" + ; makeCleaner o + ; case m_v of + LoadFailure _ -> putStrLn "didn't load" + LoadSuccess _ v -> putStrLn $ (function v) + } + diff --git a/examples/dynload/should_fail_2/prog/expected b/examples/dynload/should_fail_2/prog/expected new file mode 100644 index 0000000..16dbd87 --- /dev/null +++ b/examples/dynload/should_fail_2/prog/expected @@ -0,0 +1,8 @@ + +../Plugin.in:18: + Couldn't match `Dynamic' against `(t, t1)' + Expected type: Dynamic + Inferred type: (t, t1) + In the definition of `resource_dyn': + resource_dyn = (typeOf v, unsafeCoerce v) +failed diff --git a/examples/dynload/should_fail_2/prog/expected.604 b/examples/dynload/should_fail_2/prog/expected.604 new file mode 100644 index 0000000..91d4886 --- /dev/null +++ b/examples/dynload/should_fail_2/prog/expected.604 @@ -0,0 +1,7 @@ + +../Plugin.in:18:15: + Couldn't match `Dynamic' against `(a, b)' + Expected type: Dynamic + Inferred type: (a, b) + In the definition of `resource_dyn': resource_dyn = (typeOf v, unsafeCoerce v) +failed diff --git a/examples/dynload/should_fail_3/Makefile b/examples/dynload/should_fail_3/Makefile new file mode 100644 index 0000000..b0441c4 --- /dev/null +++ b/examples/dynload/should_fail_3/Makefile @@ -0,0 +1,4 @@ +TEST= dynload/should_fail_3 + +TOP=../../.. +include ../../build.mk diff --git a/examples/dynload/should_fail_3/Plugin.in b/examples/dynload/should_fail_3/Plugin.in new file mode 100644 index 0000000..0a4449d --- /dev/null +++ b/examples/dynload/should_fail_3/Plugin.in @@ -0,0 +1,19 @@ +-- +-- the plugin doesn't even make the resource_dyn a Dynamic. +-- let's hope that makeWith strips out the invalid declarations +-- + +{-# OPTIONS -fglasgow-exts #-} + +module Plugin where + +import API + +import AltData +import GHC.Base + +v :: Int +v = 0xdeadbeef + +resource_dyn = (typeOf plugin, unsafeCoerce v) + diff --git a/examples/dynload/should_fail_3/Plugin.stub b/examples/dynload/should_fail_3/Plugin.stub new file mode 100644 index 0000000..0106f56 --- /dev/null +++ b/examples/dynload/should_fail_3/Plugin.stub @@ -0,0 +1,12 @@ +{-# OPTIONS -fglasgow-exts #-} + +module Plugin ( resource_dyn ) where + +import API +import AltData.Dynamic + +resource = plugin + +resource_dyn :: Dynamic +resource_dyn = toDyn resource + diff --git a/examples/dynload/should_fail_3/api/API.hs b/examples/dynload/should_fail_3/api/API.hs new file mode 100644 index 0000000..7989891 --- /dev/null +++ b/examples/dynload/should_fail_3/api/API.hs @@ -0,0 +1,22 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} + +module API where + +import AltData +import GHC.Base + +data Interface = Interface { + function :: String + } + +instance Typeable Interface where +#if __GLASGOW_HASKELL__ >= 603 + typeOf _ = mkTyConApp (mkTyCon "API.Interface") [] +#else + typeOf _ = mkAppTy (mkTyCon "API.Interface") [] +#endif + +plugin :: Interface +plugin = Interface { function = "goodbye" } + +unsafeCoerce = unsafeCoerce# diff --git a/examples/dynload/should_fail_3/prog/Main.hs b/examples/dynload/should_fail_3/prog/Main.hs new file mode 100644 index 0000000..d67d64c --- /dev/null +++ b/examples/dynload/should_fail_3/prog/Main.hs @@ -0,0 +1,18 @@ + +import Plugins +import API + +conf = "../Plugin.in" +stub = "../Plugin.stub" + +main = do + status <- makeWith conf stub ["-i../api", "-i../../../../src/altdata"] + o <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess _ o -> return o + m_v <- dynload o ["../api"] [] "resource_dyn" + case m_v of + LoadFailure _ -> error "didn't compile" + LoadSuccess _ v -> do putStrLn $ (function v) + makeCleaner o + diff --git a/examples/dynload/should_fail_3/prog/expected b/examples/dynload/should_fail_3/prog/expected new file mode 100644 index 0000000..45f7ea2 --- /dev/null +++ b/examples/dynload/should_fail_3/prog/expected @@ -0,0 +1,9 @@ + +../Plugin.in:18: + Couldn't match `Dynamic' against `(t, t1)' + Expected type: Dynamic + Inferred type: (t, t1) + In the definition of `resource_dyn': + resource_dyn = (typeOf plugin, unsafeCoerce v) + +Fail: failed diff --git a/examples/dynload/should_fail_3/prog/expected.604 b/examples/dynload/should_fail_3/prog/expected.604 new file mode 100644 index 0000000..47d4d61 --- /dev/null +++ b/examples/dynload/should_fail_3/prog/expected.604 @@ -0,0 +1,8 @@ + +../Plugin.in:18:15: + Couldn't match `Dynamic' against `(a, b)' + Expected type: Dynamic + Inferred type: (a, b) + In the definition of `resource_dyn': + resource_dyn = (typeOf plugin, unsafeCoerce v) +a.out: failed diff --git a/examples/dynload/simple/Makefile b/examples/dynload/simple/Makefile new file mode 100644 index 0000000..84cfc6d --- /dev/null +++ b/examples/dynload/simple/Makefile @@ -0,0 +1,4 @@ +TEST=dynload/simple +EXTRA_OBJS=Plugin.o +TOP=../../.. +include ../../build.mk diff --git a/examples/dynload/simple/Plugin.hs b/examples/dynload/simple/Plugin.hs new file mode 100644 index 0000000..3850eb7 --- /dev/null +++ b/examples/dynload/simple/Plugin.hs @@ -0,0 +1,11 @@ +{-# OPTIONS -fglasgow-exts #-} +module Plugin where + +import API +import AltData + +my_fun = plugin { function = "plugin says \"hello\"" } + +resource_dyn :: Dynamic +resource_dyn = toDyn my_fun + diff --git a/examples/dynload/simple/api/API.hs b/examples/dynload/simple/api/API.hs new file mode 100644 index 0000000..93035aa --- /dev/null +++ b/examples/dynload/simple/api/API.hs @@ -0,0 +1,20 @@ +{-# OPTIONS -cpp #-} + +module API where + +import AltData + +data Interface = Interface { + function :: String + } + +instance Typeable Interface where +#if __GLASGOW_HASKELL__ >= 603 + typeOf i = mkTyConApp (mkTyCon "API.Interface") [] +#else + typeOf i = mkAppTy (mkTyCon "API.Interface") [] +#endif + +plugin :: Interface +plugin = Interface { function = "goodbye" } + diff --git a/examples/dynload/simple/prog/Main.hs b/examples/dynload/simple/prog/Main.hs new file mode 100644 index 0000000..eabd02c --- /dev/null +++ b/examples/dynload/simple/prog/Main.hs @@ -0,0 +1,15 @@ +{-# OPTIONS -cpp #-} + +#include "../../../../config.h" + +import Plugins +import API + +main = do + m_v <- dynload "../Plugin.o" ["../api"] + ["../../../../plugins.conf.inplace"] + "resource_dyn" + case m_v of + LoadFailure _ -> error "didn't compile" + LoadSuccess _ v -> putStrLn $ (function v) + diff --git a/examples/dynload/simple/prog/expected b/examples/dynload/simple/prog/expected new file mode 100644 index 0000000..0391e1b --- /dev/null +++ b/examples/dynload/simple/prog/expected @@ -0,0 +1 @@ +plugin says "hello" diff --git a/examples/eval.mk b/examples/eval.mk new file mode 100644 index 0000000..879c8f6 --- /dev/null +++ b/examples/eval.mk @@ -0,0 +1,27 @@ +include $(TOP)/config.mk +include $(TOP)/examples/check.mk + +PKGFLAGS= -package-conf $(TOP)/plugins.conf.inplace -package eval -package plugins -package printf + +BIN=a.out +SRC=Main.hs + +BINDIR= "." +REALBIN= ./$(BIN) + +.SUFFIXES : .o .hs .hi .lhs .hc .s + +all: $(BIN) + +$(BIN): $(SRC) $(OBJS) + @rm -f $@ + @$(GHC) --make -fglasgow-exts $(GHCFLAGS) $(PKGFLAGS) $(EXTRAFLAGS) $(SRC) + +# Standard suffix rules +.o.hi: + @: +.hs.o: + @$(GHC) $(INCLUDES) $(PKGFLAGS) $(GHCFLAGS) $(EXTRAFLAGS) -c $< + +clean: + rm -rf *.hi *.o *~ $(BIN) diff --git a/examples/eval/eval1/Main.hs b/examples/eval/eval1/Main.hs new file mode 100644 index 0000000..d7fb14c --- /dev/null +++ b/examples/eval/eval1/Main.hs @@ -0,0 +1,5 @@ + +import Eval.Haskell + +main = do i <- eval "1 + 6 :: Int" [] :: IO (Maybe Int) + if isJust i then putStrLn $ show (fromJust i) else return () diff --git a/examples/eval/eval1/Makefile b/examples/eval/eval1/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/eval/eval1/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/eval/eval1/expected b/examples/eval/eval1/expected new file mode 100644 index 0000000..7f8f011 --- /dev/null +++ b/examples/eval/eval1/expected @@ -0,0 +1 @@ +7 diff --git a/examples/eval/eval2/Main.hs b/examples/eval/eval2/Main.hs new file mode 100644 index 0000000..ff75eac --- /dev/null +++ b/examples/eval/eval2/Main.hs @@ -0,0 +1,6 @@ +import Eval.Haskell + +main = do m_s <- eval "map toUpper \"haskell\"" ["Data.Char"] + case m_s of + Nothing -> putStrLn "typechecking failed" + Just s -> putStrLn s diff --git a/examples/eval/eval2/Makefile b/examples/eval/eval2/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/eval/eval2/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/eval/eval2/expected b/examples/eval/eval2/expected new file mode 100644 index 0000000..532f1d9 --- /dev/null +++ b/examples/eval/eval2/expected @@ -0,0 +1 @@ +HASKELL diff --git a/examples/eval/eval3/Main.hs b/examples/eval/eval3/Main.hs new file mode 100644 index 0000000..69b0903 --- /dev/null +++ b/examples/eval/eval3/Main.hs @@ -0,0 +1,42 @@ +{-# OPTIONS -cpp #-} +-- +-- Should evaluate to '3', unless something goes wrong. +-- +-- Not so bad to use AltData, as it is already derived for all the basic +-- types. Then, just replace deriving Typeable, with hand-derived +-- instance of Typeable (see hs-plugins/examples/eval/eval_fn1/Poly.hs +-- +-- + +#include "../../../config.h" + +import Eval.Haskell +import AltData.Dynamic + +-- import Data.Dynamic + +pkgconf = TOP ++ "/plugins.conf.inplace" + +main = do + a <- return $ toDyn (3::Int) + + m_b <- unsafeEval_ "\\dyn -> fromMaybe (7 :: Int) (fromDyn dyn)" + ["AltData.Dynamic","Data.Maybe"] -- imports + + [ "-package-conf "++pkgconf , "-package altdata" ] + + [ pkgconf ] + [] + + +{- +-- should work, but doesn't. type check fails +-- (due to static vs dynamic typing issue) + + m_b <- unsafeEval_ "\\dyn -> fromMaybe (7 :: Int) (fromDynamic dyn)" + ["Data.Dynamic","Data.Maybe"] [] [] +-} + + case m_b of + Left s -> mapM_ putStrLn s + Right b -> putStrLn $ show (b a :: Int) diff --git a/examples/eval/eval3/Makefile b/examples/eval/eval3/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/eval/eval3/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/eval/eval3/expected b/examples/eval/eval3/expected new file mode 100644 index 0000000..00750ed --- /dev/null +++ b/examples/eval/eval3/expected @@ -0,0 +1 @@ +3 diff --git a/examples/eval/eval_/Main.hs b/examples/eval/eval_/Main.hs new file mode 100644 index 0000000..6bea135 --- /dev/null +++ b/examples/eval/eval_/Main.hs @@ -0,0 +1,9 @@ + +import Eval.Haskell + +main = do i <- eval_ "Just (7 :: Int)" + ["Maybe"] + ["-fglasgow-exts"] + [] + [] :: IO (Either [String] (Maybe (Maybe Int))) + print i diff --git a/examples/eval/eval_/Makefile b/examples/eval/eval_/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/eval/eval_/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/eval/eval_/expected b/examples/eval/eval_/expected new file mode 100644 index 0000000..2432889 --- /dev/null +++ b/examples/eval/eval_/expected @@ -0,0 +1 @@ +Right (Just (Just 7)) diff --git a/examples/eval/eval_fn/Main.hs b/examples/eval/eval_fn/Main.hs new file mode 100644 index 0000000..27b8b8b --- /dev/null +++ b/examples/eval/eval_fn/Main.hs @@ -0,0 +1,10 @@ +-- +-- lambda abstraction! +-- +-- +-- needs unsafeEval because eval has a broken Dynamic check +-- +import Eval.Haskell + +main = do fn <- unsafeEval "(\\(x::Int) -> (x,x))" [] :: IO (Maybe (Int -> (Int,Int))) + when (isJust fn) $ putStrLn $ show $ (fromJust fn) 7 diff --git a/examples/eval/eval_fn/Makefile b/examples/eval/eval_fn/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/eval/eval_fn/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/eval/eval_fn/expected b/examples/eval/eval_fn/expected new file mode 100644 index 0000000..10769d1 --- /dev/null +++ b/examples/eval/eval_fn/expected @@ -0,0 +1 @@ +(7,7) diff --git a/examples/eval/eval_fn1/Main.hs b/examples/eval/eval_fn1/Main.hs new file mode 100644 index 0000000..f106fe2 --- /dev/null +++ b/examples/eval/eval_fn1/Main.hs @@ -0,0 +1,15 @@ +{-# OPTIONS -fglasgow-exts #-} +-- +-- polymorphic eval! +-- + +module Main where + +import Poly +import Eval.Haskell + +main = do m_f <- eval "Fn (\\x y -> x == y)" ["Poly"] + when (isJust m_f) $ do + let (Fn f) = fromJust m_f + putStrLn $ show (f True True) + putStrLn $ show (f 1 2) diff --git a/examples/eval/eval_fn1/Makefile b/examples/eval/eval_fn1/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/eval/eval_fn1/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/eval/eval_fn1/Poly.hs b/examples/eval/eval_fn1/Poly.hs new file mode 100644 index 0000000..62fa38f --- /dev/null +++ b/examples/eval/eval_fn1/Poly.hs @@ -0,0 +1,16 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +module Poly where + +import AltData.Typeable + +data Fn = Fn {fn :: forall t. Eq t => t -> t -> Bool} + +-- +-- ignore type inside the Fn... is this correct? +-- +instance Typeable Fn where +#if __GLASGOW_HASKELL__ >= 603 + typeOf _ = mkTyConApp (mkTyCon "Poly.Fn") [] +#else + typeOf _ = mkAppTy (mkTyCon "Poly.Fn") [] +#endif diff --git a/examples/eval/eval_fn1/expected b/examples/eval/eval_fn1/expected new file mode 100644 index 0000000..1cc8b5e --- /dev/null +++ b/examples/eval/eval_fn1/expected @@ -0,0 +1,2 @@ +True +False diff --git a/examples/eval/foreign_eval/Makefile b/examples/eval/foreign_eval/Makefile new file mode 100644 index 0000000..bbb7d31 --- /dev/null +++ b/examples/eval/foreign_eval/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../foreign.mk diff --git a/examples/eval/foreign_eval/README b/examples/eval/foreign_eval/README new file mode 100644 index 0000000..2d2b839 --- /dev/null +++ b/examples/eval/foreign_eval/README @@ -0,0 +1 @@ +run a string of Haskell code from a C program. diff --git a/examples/eval/foreign_eval/expected b/examples/eval/foreign_eval/expected new file mode 100644 index 0000000..06a735b --- /dev/null +++ b/examples/eval/foreign_eval/expected @@ -0,0 +1 @@ +10946 diff --git a/examples/eval/foreign_eval/main.c b/examples/eval/foreign_eval/main.c new file mode 100644 index 0000000..cd1e575 --- /dev/null +++ b/examples/eval/foreign_eval/main.c @@ -0,0 +1,16 @@ +#include + +#include "EvalHaskell.h" + +int main(int argc, char *argv[]) +{ + int *p; + hs_init(&argc, &argv); + p = hs_eval_i("let fibs = 1:1:zipWith (+) fibs (tail fibs) in fibs !! 20 :: Int"); + if (p == NULL) + printf("failed!\n"); + else + printf("%d\n",*p); + hs_exit(); + return 0; +} diff --git a/examples/eval/foreign_eval1/Makefile b/examples/eval/foreign_eval1/Makefile new file mode 100644 index 0000000..bbb7d31 --- /dev/null +++ b/examples/eval/foreign_eval1/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../foreign.mk diff --git a/examples/eval/foreign_eval1/expected b/examples/eval/foreign_eval1/expected new file mode 100644 index 0000000..06a735b --- /dev/null +++ b/examples/eval/foreign_eval1/expected @@ -0,0 +1 @@ +10946 diff --git a/examples/eval/foreign_eval1/main.c b/examples/eval/foreign_eval1/main.c new file mode 100644 index 0000000..f5f6e34 --- /dev/null +++ b/examples/eval/foreign_eval1/main.c @@ -0,0 +1,16 @@ +#include + +#include "EvalHaskell.h" + +int main(int argc, char *argv[]) +{ + char *p; + hs_init(&argc, &argv); + p = hs_eval_s("show $ let fibs = 1:1:zipWith (+) fibs (tail fibs) in fibs !! 20"); + if (p == NULL) + printf("failed!\n"); + else + printf("%s\n",p); + hs_exit(); + return 0; +} diff --git a/examples/eval/foreign_should_fail/Makefile b/examples/eval/foreign_should_fail/Makefile new file mode 100644 index 0000000..bbb7d31 --- /dev/null +++ b/examples/eval/foreign_should_fail/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../foreign.mk diff --git a/examples/eval/foreign_should_fail/expected b/examples/eval/foreign_should_fail/expected new file mode 100644 index 0000000..d733d74 --- /dev/null +++ b/examples/eval/foreign_should_fail/expected @@ -0,0 +1,2 @@ +:1: parse error on input `in' +failed! diff --git a/examples/eval/foreign_should_fail/expected.604 b/examples/eval/foreign_should_fail/expected.604 new file mode 100644 index 0000000..c7c5b75 --- /dev/null +++ b/examples/eval/foreign_should_fail/expected.604 @@ -0,0 +1 @@ +failed! diff --git a/examples/eval/foreign_should_fail/main.c b/examples/eval/foreign_should_fail/main.c new file mode 100644 index 0000000..d9da5d5 --- /dev/null +++ b/examples/eval/foreign_should_fail/main.c @@ -0,0 +1,16 @@ +#include + +#include "EvalHaskell.h" + +int main(int argc, char *argv[]) +{ + int *p; + hs_init(&argc, &argv); + p = hs_eval_i("show $ case 1 + 2 in{-wrong-} x -> x"); + if (p == NULL) + printf("failed!\n"); + else + printf("%d\n",*p); + hs_exit(); + return 0; +} diff --git a/examples/eval/foreign_should_fail_illtyped/Makefile b/examples/eval/foreign_should_fail_illtyped/Makefile new file mode 100644 index 0000000..bbb7d31 --- /dev/null +++ b/examples/eval/foreign_should_fail_illtyped/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../foreign.mk diff --git a/examples/eval/foreign_should_fail_illtyped/expected b/examples/eval/foreign_should_fail_illtyped/expected new file mode 100644 index 0000000..5cd8828 --- /dev/null +++ b/examples/eval/foreign_should_fail_illtyped/expected @@ -0,0 +1,4 @@ +Couldn't match `Int' against `[Char]' + Expected type: Int + Inferred type: [Char] +failed! diff --git a/examples/eval/foreign_should_fail_illtyped/expected.604 b/examples/eval/foreign_should_fail_illtyped/expected.604 new file mode 100644 index 0000000..c7c5b75 --- /dev/null +++ b/examples/eval/foreign_should_fail_illtyped/expected.604 @@ -0,0 +1 @@ +failed! diff --git a/examples/eval/foreign_should_fail_illtyped/main.c b/examples/eval/foreign_should_fail_illtyped/main.c new file mode 100644 index 0000000..ead2118 --- /dev/null +++ b/examples/eval/foreign_should_fail_illtyped/main.c @@ -0,0 +1,16 @@ +#include + +#include "EvalHaskell.h" + +int main(int argc, char *argv[]) +{ + int *p; + hs_init(&argc, &argv); + p = hs_eval_i("\"an ill-typed string\""); + if (p == NULL) + printf("failed!\n"); + else + printf("%d\n",*p); + hs_exit(); + return 0; +} diff --git a/examples/eval/unsafeidir/Main.hs b/examples/eval/unsafeidir/Main.hs new file mode 100644 index 0000000..72d47d0 --- /dev/null +++ b/examples/eval/unsafeidir/Main.hs @@ -0,0 +1,16 @@ + +import Plugins.Make +import Eval.Haskell + +main = do make "a/Extra.hs" [] + + i <- unsafeEval_ "show (Just (1 + 6 :: Int)) ++ extra" + ["Data.Maybe", "Extra"] + ["-ia"] -- no make flags + [] -- no package.confs + ["a"] -- include paths to load from + :: IO (Either [String] String) + + case i of + Right i -> putStrLn $ show i + Left es -> mapM_ putStrLn es diff --git a/examples/eval/unsafeidir/Makefile b/examples/eval/unsafeidir/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/eval/unsafeidir/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/eval/unsafeidir/a/Extra.hs b/examples/eval/unsafeidir/a/Extra.hs new file mode 100644 index 0000000..0210d78 --- /dev/null +++ b/examples/eval/unsafeidir/a/Extra.hs @@ -0,0 +1,3 @@ +module Extra where + +extra = "an extra value" diff --git a/examples/eval/unsafeidir/expected b/examples/eval/unsafeidir/expected new file mode 100644 index 0000000..e01bba5 --- /dev/null +++ b/examples/eval/unsafeidir/expected @@ -0,0 +1 @@ +"Just 7an extra value" diff --git a/examples/foreign.mk b/examples/foreign.mk new file mode 100644 index 0000000..6958ac9 --- /dev/null +++ b/examples/foreign.mk @@ -0,0 +1,23 @@ +include $(TOP)/config.mk +include $(TOP)/examples/check.mk + + +INCLUDES= -I$(TOP) +PKGFLAGS= -package-conf $(TOP)/plugins.conf.inplace -package eval + +# compile with GHC to save us setting all the necessary include and +# lib flags. use ghc -v to find out what these are if you wish to go +# via gcc. +BIN=./a.out +SRC=main.c + +BINDIR= "." +REALBIN= $(BIN) + +all: $(BIN) + +$(BIN): $(SRC) + @$(GHC) $(INCLUDES) $(PKGFLAGS) $(SRC) + +clean: + rm -rf *.hi *.o *~ $(BIN) diff --git a/examples/hier/hier1/Makefile b/examples/hier/hier1/Makefile new file mode 100644 index 0000000..89ca51a --- /dev/null +++ b/examples/hier/hier1/Makefile @@ -0,0 +1,8 @@ +TEST= hier/hier1 + +EXTRA_OBJS=Plugin.o +PRIOR_OBJS=Modules/Flags.o +EXTRAFLAGS= + +TOP=../../.. +include ../../build.mk diff --git a/examples/hier/hier1/Modules/Flags.hs b/examples/hier/hier1/Modules/Flags.hs new file mode 100644 index 0000000..eb5e10e --- /dev/null +++ b/examples/hier/hier1/Modules/Flags.hs @@ -0,0 +1,15 @@ +-- +-- A simple module +-- + +module Modules.Flags where + + +data FlagRec = FlagRec { + f1 :: Int, + f2 :: Int +} + + +foo :: FlagRec -> Int +foo x = f1 x diff --git a/examples/hier/hier1/Modules/Makefile b/examples/hier/hier1/Modules/Makefile new file mode 100644 index 0000000..58c4ee9 --- /dev/null +++ b/examples/hier/hier1/Modules/Makefile @@ -0,0 +1,6 @@ + +all: + ghc -O -c Flags.hs + +clean: + rm -f *.hi *.o diff --git a/examples/hier/hier1/Plugin.hs b/examples/hier/hier1/Plugin.hs new file mode 100644 index 0000000..0d9b68d --- /dev/null +++ b/examples/hier/hier1/Plugin.hs @@ -0,0 +1,14 @@ +-- +-- Plugin +-- + +module Plugin where + +import API +import Modules.Flags as Flags + + +resource = plugin { + dbFunc = (\x -> Flags.f1 x) +} + diff --git a/examples/hier/hier1/api/API.hs b/examples/hier/hier1/api/API.hs new file mode 100644 index 0000000..deae88e --- /dev/null +++ b/examples/hier/hier1/api/API.hs @@ -0,0 +1,16 @@ +-- +-- API for plugin test +-- + +module API where + +import Modules.Flags as Flags + +data Interface = Interface { + dbFunc :: Flags.FlagRec -> Int +} + + +plugin :: Interface +plugin = Interface { dbFunc = (\x -> 1) } + diff --git a/examples/hier/hier1/prog/Main.hs b/examples/hier/hier1/prog/Main.hs new file mode 100644 index 0000000..ded0247 --- /dev/null +++ b/examples/hier/hier1/prog/Main.hs @@ -0,0 +1,21 @@ +-- +-- Test multiple plugins +-- + + +module Main where + +import Plugins +import API +import Modules.Flags as Flags + + +rec = Flags.FlagRec { Flags.f1 = 4, Flags.f2 = 10 } + + +main = do + status <- load "../Plugin.o" ["../api",".."] [] "resource" + case status of + LoadFailure _ -> error "load failed" + LoadSuccess _ v -> do let func = dbFunc v + print (func rec) diff --git a/examples/hier/hier1/prog/expected b/examples/hier/hier1/prog/expected new file mode 100644 index 0000000..b8626c4 --- /dev/null +++ b/examples/hier/hier1/prog/expected @@ -0,0 +1 @@ +4 diff --git a/examples/hier/hier2/A/B/C/Module.hs b/examples/hier/hier2/A/B/C/Module.hs new file mode 100644 index 0000000..9c5daa5 --- /dev/null +++ b/examples/hier/hier2/A/B/C/Module.hs @@ -0,0 +1,8 @@ +-- +-- A simple module +-- + +module A.B.C.Module where + +symbol = "You found me" + diff --git a/examples/hier/hier2/A/Makefile b/examples/hier/hier2/A/Makefile new file mode 100644 index 0000000..bb9a3be --- /dev/null +++ b/examples/hier/hier2/A/Makefile @@ -0,0 +1,7 @@ + +all: + ghc -c B/C/Module.hs + + +clean: + rm -f B/C/*.hi B/C/*.o diff --git a/examples/hier/hier2/Makefile b/examples/hier/hier2/Makefile new file mode 100644 index 0000000..89631b6 --- /dev/null +++ b/examples/hier/hier2/Makefile @@ -0,0 +1,7 @@ +TEST= hier/hier2 + +PRIOR_OBJS=A/B/C/Module.o +EXTRAFLAGS= + +TOP=../../.. +include ../../build.mk diff --git a/examples/hier/hier2/api/API.hs b/examples/hier/hier2/api/API.hs new file mode 100644 index 0000000..872fd34 --- /dev/null +++ b/examples/hier/hier2/api/API.hs @@ -0,0 +1,4 @@ +module API where + +-- just a dummy for the build system + diff --git a/examples/hier/hier2/prog/Main.hs b/examples/hier/hier2/prog/Main.hs new file mode 100644 index 0000000..afeb097 --- /dev/null +++ b/examples/hier/hier2/prog/Main.hs @@ -0,0 +1,15 @@ +-- +-- Test if we can load a module with a hierarchical name from some weird +-- path. Tests our the module name handling in the .hi file parser. +-- + + +module Main where + +import Plugins + +main = do + status <- load "../A/B/C/Module.o" [".."] [] "symbol" + case status of + LoadFailure ers -> mapM_ putStrLn ers + LoadSuccess _ v -> print (v :: String) diff --git a/examples/hier/hier2/prog/expected b/examples/hier/hier2/prog/expected new file mode 100644 index 0000000..c4a4db5 --- /dev/null +++ b/examples/hier/hier2/prog/expected @@ -0,0 +1 @@ +"You found me" diff --git a/examples/hier/hier3/Main.hs b/examples/hier/hier3/Main.hs new file mode 100644 index 0000000..ae4a152 --- /dev/null +++ b/examples/hier/hier3/Main.hs @@ -0,0 +1,25 @@ +module Main where + +import Plugins + +main = do + + makeAll "One.hs" [] + + load2 "Two.o" + + load2 "./Two.o" -- shouldn't load + load2 "../hier3/Two.o" -- shouldn't load + load2 "././././Two.o" -- shouldn't load + + -- and this one pulls in "../hier3/Two.o" as a dep + y <- load "One.o" ["../hier3"] [] "resource" + case y of + LoadSuccess _ s -> putStrLn $ "One plugin: " ++ s + LoadFailure _ -> putStrLn "Failure: y" + +load2 f = do + x <- load f [".", "../hier3", ""] [] "resource" -- depend on One.o + case x of + LoadSuccess _ s -> putStrLn $ "Two plugin: " ++ s + LoadFailure _ -> putStrLn "Failure: x" diff --git a/examples/hier/hier3/Makefile b/examples/hier/hier3/Makefile new file mode 100644 index 0000000..f15119b --- /dev/null +++ b/examples/hier/hier3/Makefile @@ -0,0 +1,7 @@ +TEST= hier/hier3 + +EXTRA_OBJS=One.o Two.o +EXTRAFLAGS= + +TOP=../../.. +include ../../eval.mk diff --git a/examples/hier/hier3/One.hs b/examples/hier/hier3/One.hs new file mode 100644 index 0000000..da3a764 --- /dev/null +++ b/examples/hier/hier3/One.hs @@ -0,0 +1,7 @@ + +module One where + +import qualified Two + +resource = "This is the sub-plugin of (" ++ Two.resource ++ ")" + diff --git a/examples/hier/hier3/Two.hs b/examples/hier/hier3/Two.hs new file mode 100644 index 0000000..8b0124b --- /dev/null +++ b/examples/hier/hier3/Two.hs @@ -0,0 +1,4 @@ +module Two where + +resource = "This is the top plugin" + diff --git a/examples/hier/hier3/expected b/examples/hier/hier3/expected new file mode 100644 index 0000000..c7dc9d0 --- /dev/null +++ b/examples/hier/hier3/expected @@ -0,0 +1,5 @@ +Two plugin: This is the top plugin +Two plugin: This is the top plugin +Two plugin: This is the top plugin +Two plugin: This is the top plugin +One plugin: This is the sub-plugin of (This is the top plugin) diff --git a/examples/hier/hier4/A.hs b/examples/hier/hier4/A.hs new file mode 100644 index 0000000..10c6c61 --- /dev/null +++ b/examples/hier/hier4/A.hs @@ -0,0 +1,11 @@ + +-- now, the question is: is it possible to not depend on a module or +-- package, but nonetheless have an orphan to it? this could cause +-- problems.... + +module A where + +import B + +u :: Int +u = undefined diff --git a/examples/hier/hier4/B.hs b/examples/hier/hier4/B.hs new file mode 100644 index 0000000..d5bf5db --- /dev/null +++ b/examples/hier/hier4/B.hs @@ -0,0 +1,4 @@ +module B where + +import C () -- instances, to make available to those who use B + diff --git a/examples/hier/hier4/C.hs b/examples/hier/hier4/C.hs new file mode 100644 index 0000000..ba8915a --- /dev/null +++ b/examples/hier/hier4/C.hs @@ -0,0 +1,12 @@ + +-- try to construct an orphan module == an instance decl-only module, +-- that uses classes and types not defined in this module + +module C (C) where + +import D + +instance C a => D (T a) where + +class C a where + diff --git a/examples/hier/hier4/D.hs b/examples/hier/hier4/D.hs new file mode 100644 index 0000000..df13442 --- /dev/null +++ b/examples/hier/hier4/D.hs @@ -0,0 +1,6 @@ + +module D where + +class D a where + +data T a = T diff --git a/examples/hier/hier4/Main.hs b/examples/hier/hier4/Main.hs new file mode 100644 index 0000000..9a3d660 --- /dev/null +++ b/examples/hier/hier4/Main.hs @@ -0,0 +1,12 @@ +module Main where + +import Plugins + +main = do + + makeAll "A.hs" [] + + y <- load "A.o" ["."] [] "u" + case y of + LoadSuccess _ _ -> putStrLn $ "YES" + LoadFailure e -> mapM_ putStrLn e diff --git a/examples/hier/hier4/Makefile b/examples/hier/hier4/Makefile new file mode 100644 index 0000000..c327707 --- /dev/null +++ b/examples/hier/hier4/Makefile @@ -0,0 +1,4 @@ +TEST= hier/hier4 + +TOP=../../.. +include ../../eval.mk diff --git a/examples/hier/hier4/expected b/examples/hier/hier4/expected new file mode 100644 index 0000000..f033a50 --- /dev/null +++ b/examples/hier/hier4/expected @@ -0,0 +1 @@ +YES diff --git a/examples/hmake/lib-plugs/Main.hs b/examples/hmake/lib-plugs/Main.hs new file mode 100644 index 0000000..2d977ad --- /dev/null +++ b/examples/hmake/lib-plugs/Main.hs @@ -0,0 +1,69 @@ +-- +-- Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) +-- + +import Eval.Haskell +import Plugins.Load + +import System.Exit ( ExitCode(..), exitWith ) +import System.IO +import System.Console.Readline ( readline, addHistory ) + +symbol = "resource" + +main = do + putStrLn banner + putStr "Loading package base" >> hFlush stdout + loadPackage "base" + putStr " ... linking ... " >> hFlush stdout + resolveObjs + putStrLn "done" + + shell [] + +shell :: [String] -> IO () +shell imps = do + s <- readline "plugs> " + cmd <- case s of + Nothing -> exitWith ExitSuccess + Just (':':'q':_) -> exitWith ExitSuccess + Just s -> addHistory s >> return s + imps' <- run cmd imps + shell imps' + +run :: String -> [String] -> IO [String] +run "" is = return is +run ":?" is = putStrLn help >> return is + +run ":l" _ = return [] +run (':':'l':' ':m) is = return (m:is) + +run (':':'t':' ':s) is = do + ty <- typeOf s is + when (not $ null ty) (putStrLn $ s ++ " :: " ++ ty) + return is + +run (':':_) is = putStrLn help >> return is + +run s is = do + s <- unsafeEval ("show $ "++s) is + when (isJust s) (putStrLn (fromJust s)) + return is + +banner = "\ +\ __ \n\ +\ ____ / /_ ______ ______ \n\ +\ / __ \\/ / / / / __ `/ ___/ PLugin User's GHCi System, for Haskell 98\n\ +\ / /_/ / / /_/ / /_/ (__ ) http://www.cse.unsw.edu.au/~dons/hs-plugins\n\ +\ / .___/_/\\__,_/\\__, /____/ Type :? for help \n\ +\/_/ /____/ \n" + +help = "\ +\Commands :\n\ +\ evaluate expression\n\ +\ :t show type of expression (monomorphic only)\n\ +\ :l module bring module in to scope\n\ +\ :l clear module list\n\ +\ :quit quit\n\ +\ :? display this list of commands" diff --git a/examples/hmake/lib-plugs/Makefile b/examples/hmake/lib-plugs/Makefile new file mode 100644 index 0000000..aa21db8 --- /dev/null +++ b/examples/hmake/lib-plugs/Makefile @@ -0,0 +1,29 @@ +GHCFLAGS= -O +PKGFLAGS= -package-conf $(TOP)/plugins.conf.inplace +PKGFLAGS+= -package eval -package readline + +all: build + +build: + @$(GHC) $(GHCFLAGS) $(PKGFLAGS) $(EXTRAFLAGS) Main.hs -o plugs +check: build + @(if [ -f "expected" ] ;\ + then \ + actual_out="/tmp/hs-plugins-actual.out.$$$$" ;\ + diff_out="/tmp/hs-plugins.diff.$$$$" ;\ + cat test.in | ./plugs > $$actual_out 2>&1 || true ;\ + diff -u expected $$actual_out > $$diff_out || true ;\ + if [ -s "$$diff_out" ] ; then \ + echo "failed with:" ;\ + cat "$$diff_out" | sed '1,3d' ;\ + else \ + echo "ok." ;\ + fi ;\ + rm $$actual_out ;\ + else \ + cat test.in | ./plugs 2>&1 || true ;\ + fi) +clean: + rm -rf *.hi *.o *~ *.dep ./plugs + +include ../../../config.mk diff --git a/examples/hmake/lib-plugs/expected b/examples/hmake/lib-plugs/expected new file mode 100644 index 0000000..b55bda0 --- /dev/null +++ b/examples/hmake/lib-plugs/expected @@ -0,0 +1,9 @@ + __ + ____ / /_ ______ ______ + / __ \/ / / / / __ `/ ___/ PLugin User's GHCi System, for Haskell 98 + / /_/ / / /_/ / /_/ (__ ) http://www.cse.unsw.edu.au/~dons/hs-plugins + / .___/_/\__,_/\__, /____/ Type :? for help +/_/ /____/ + +Loading package base ... linking ... plugs> plugs> done +453973694165307953197296969697410619233826 diff --git a/examples/hmake/lib-plugs/test.in b/examples/hmake/lib-plugs/test.in new file mode 100644 index 0000000..e38735d --- /dev/null +++ b/examples/hmake/lib-plugs/test.in @@ -0,0 +1,2 @@ +let fibs = 1 : 1 : zipWith (+) fibs (tail fibs) in fibs !! 200 +:quit diff --git a/examples/hmake/one-shot/Main.hs b/examples/hmake/one-shot/Main.hs new file mode 100644 index 0000000..bf59e7d --- /dev/null +++ b/examples/hmake/one-shot/Main.hs @@ -0,0 +1,39 @@ +-- +-- Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) +-- + +import Eval.Haskell (unsafeEval) + +import Data.Maybe (isJust, fromJust) +import Control.Monad (when) + +import System.Exit (exitWith, ExitCode(ExitSuccess)) +import System.IO (getContents, putStrLn) +import System.Posix.Resource (setResourceLimit, + Resource(ResourceCPUTime), + ResourceLimits(ResourceLimits), + ResourceLimit(ResourceLimit)) + +rlimit = ResourceLimit 3 + +context = prehier ++ datas ++ controls + +prehier = ["Char", "List", "Maybe", "Numeric", "Random" ] + +datas = map ("Data." ++) [ + "Bits", "Bool", "Char", "Dynamic", "Either", + "FiniteMap", "Graph", "Int", "Ix", "List", + "Maybe", "Ratio", "Set", "Tree", "Tuple", "Typeable", "Word" + ] + +controls = map ("Control." ++) ["Monad", "Arrow"] + +main = do + setResourceLimit ResourceCPUTime (ResourceLimits rlimit rlimit) + s <- getContents + when (not . null $ s) $ do + s <- unsafeEval ("(take 2048 (show ("++s++")))") context + when (isJust s) (putStrLn (fromJust s)) + exitWith ExitSuccess + diff --git a/examples/hmake/one-shot/Makefile b/examples/hmake/one-shot/Makefile new file mode 100644 index 0000000..8ea2f06 --- /dev/null +++ b/examples/hmake/one-shot/Makefile @@ -0,0 +1,30 @@ +GHCFLAGS= -O +PKGFLAGS= -package-conf $(TOP)/plugins.conf.inplace +PKGFLAGS+= -package eval -package unix + +all: build + +build: + @$(GHC) $(GHCFLAGS) $(PKGFLAGS) $(EXTRAFLAGS) Main.hs -o runplugs +include ../../../config.mk +check: build + @(if [ -f "expected" ] ;\ + then \ + actual_out="/tmp/hs-plugins-actual.out.$$$$" ;\ + diff_out="/tmp/hs-plugins.diff.$$$$" ;\ + cat test.in | ./runplugs > $$actual_out 2>&1 || true ;\ + diff -u expected $$actual_out > $$diff_out || true ;\ + if [ -s "$$diff_out" ] ; then \ + echo "failed with:" ;\ + cat "$$diff_out" | sed '1,3d' ;\ + else \ + echo "ok." ;\ + fi ;\ + rm $$actual_out ;\ + else \ + cat test.in | ./runplugs 2>&1 || true ;\ + fi) +clean: + rm -rf *.hi *.o *~ *.dep ./runplugs + +include ../../../config.mk diff --git a/examples/hmake/one-shot/expected b/examples/hmake/one-shot/expected new file mode 100644 index 0000000..e4b6306 --- /dev/null +++ b/examples/hmake/one-shot/expected @@ -0,0 +1 @@ +453973694165307953197296969697410619233826 diff --git a/examples/hmake/one-shot/test.in b/examples/hmake/one-shot/test.in new file mode 100644 index 0000000..d75281e --- /dev/null +++ b/examples/hmake/one-shot/test.in @@ -0,0 +1 @@ +let fibs = 1 : 1 : zipWith (+) fibs (tail fibs) in fibs !! 200 diff --git a/examples/iface/null/A.hs b/examples/iface/null/A.hs new file mode 100644 index 0000000..d843c00 --- /dev/null +++ b/examples/iface/null/A.hs @@ -0,0 +1 @@ +module A where diff --git a/examples/iface/null/B.hs b/examples/iface/null/B.hs new file mode 100644 index 0000000..c759bc2 --- /dev/null +++ b/examples/iface/null/B.hs @@ -0,0 +1 @@ +module B where diff --git a/examples/iface/null/Main.hs b/examples/iface/null/Main.hs new file mode 100644 index 0000000..f3cee4c --- /dev/null +++ b/examples/iface/null/Main.hs @@ -0,0 +1,9 @@ +module Main ( main ) where + +import Hi.Parser + +import A +import B + +main = do iface <- readIface "Main.hi" + putStrLn (showIface iface) diff --git a/examples/iface/null/Makefile b/examples/iface/null/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/iface/null/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/iface/null/expected b/examples/iface/null/expected new file mode 100644 index 0000000..bce07ed --- /dev/null +++ b/examples/iface/null/expected @@ -0,0 +1,5 @@ +interface "Main" Main +module dependencies: A, B +package dependencies: base, haskell98, hi +import A +import B diff --git a/examples/iface/null/expected.604 b/examples/iface/null/expected.604 new file mode 100644 index 0000000..3e106e3 --- /dev/null +++ b/examples/iface/null/expected.604 @@ -0,0 +1,5 @@ +interface "unknown" Main +module dependencies: A, B +package dependencies: base-1.0, haskell98-1.0, hi-1.0 +import B +import A diff --git a/examples/load/io/Makefile b/examples/load/io/Makefile new file mode 100644 index 0000000..9531bed --- /dev/null +++ b/examples/load/io/Makefile @@ -0,0 +1,6 @@ +TEST= load/io + +EXTRA_OBJS=TestIO.o + +TOP=../../.. +include ../../build.mk diff --git a/examples/load/io/TestIO.hs b/examples/load/io/TestIO.hs new file mode 100644 index 0000000..58303e1 --- /dev/null +++ b/examples/load/io/TestIO.hs @@ -0,0 +1,84 @@ +{-# OPTIONS -cpp #-} +-- +-- Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- LGPL version 2.1 or later (see http://www.gnu.org/copyleft/lesser.html) +-- + +module TestIO ( resource, resource_dyn ) where + +import API +import Data.Dynamic + +import System.IO +import System.Posix.Types ( ProcessID, Fd ) +import System.Posix.Process ( forkProcess, executeFile, getProcessID ) +import System.Posix.IO ( createPipe, stdInput, + stdOutput, fdToHandle, closeFd, dupTo ) + +resource = testio { field = date } + +resource_dyn :: Dynamic +resource_dyn = toDyn resource + +-- +-- call a shell command , returning it's output +-- +date :: IO String +date = do (hdl,_,_) <- catch (popen "/bin/date") (\_->error "popen failed") + hGetLine hdl + +------------------------------------------------------------------------ +-- +-- my implementation of $val = `cmd`; (if this was perl) +-- +-- provide similar functionality to popen(3), +-- along with bidirectional ipc via pipes +-- return's the pid of the child process +-- +-- there are two different forkProcess functions. the pre-620 was a +-- unix-fork style function, and the modern function has semantics more +-- like the Awkward-Squad paper. We provide implementations of popen +-- using both versions, depending on which GHC the user wants to try. +-- + +popen :: FilePath -> IO (Handle, Handle, ProcessID) +popen cmd = do + (pr, pw) <- createPipe + (cr, cw) <- createPipe + + -- parent -- + let parent = do closeFd cw + closeFd pr + -- child -- + let child = do closeFd pw + closeFd cr + exec cmd (pr,cw) + error "exec cmd failed!" -- typing only + +-- if the parser front end understood cpp, this would work +-- #if __GLASGOW_HASKELL__ >= 601 + pid <- forkProcess child -- fork child + parent -- and run parent code +-- #else +-- p <- forkProcess +-- pid <- case p of +-- Just pid -> parent >> return pid +-- Nothing -> child +-- #endif + + hcr <- fdToHandle cr + hpw <- fdToHandle pw + + return (hcr,hpw,pid) + +-- +-- execve cmd in the child process, dup'ing the file descriptors passed +-- as arguments to become the child's stdin and stdout. +-- +exec :: FilePath -> (Fd,Fd) -> IO () +exec cmd (pr,cw) = do + dupTo pr stdInput + dupTo cw stdOutput + executeFile cmd False [] Nothing + +------------------------------------------------------------------------ diff --git a/examples/load/io/api/API.hs b/examples/load/io/api/API.hs new file mode 100644 index 0000000..4b8be53 --- /dev/null +++ b/examples/load/io/api/API.hs @@ -0,0 +1,16 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import Data.Dynamic + +data TestIO = TestIO { + field :: IO String + } + deriving (Typeable, Show) + +instance Show (IO String) where + show _ = "<>" + +testio :: TestIO +testio = TestIO { field = return "default value" } diff --git a/examples/load/io/prog/Main.hs b/examples/load/io/prog/Main.hs new file mode 100644 index 0000000..76d6f1e --- /dev/null +++ b/examples/load/io/prog/Main.hs @@ -0,0 +1,15 @@ +{-# OPTIONS -cpp #-} + +#include "../../../../config.h" + +import Plugins +import API + +main :: IO () +main = do + m_v <- load "../TestIO.o" ["../api"] [] "resource" + v <- case m_v of + LoadFailure _ -> error "load failed" + LoadSuccess _ v -> return v + s <- field v + if null s then print False else print True diff --git a/examples/load/io/prog/expected b/examples/load/io/prog/expected new file mode 100644 index 0000000..0ca9514 --- /dev/null +++ b/examples/load/io/prog/expected @@ -0,0 +1 @@ +True diff --git a/examples/load/load_0/Makefile b/examples/load/load_0/Makefile new file mode 100644 index 0000000..9bc144a --- /dev/null +++ b/examples/load/load_0/Makefile @@ -0,0 +1,6 @@ +TEST= load/load_0 + +EXTRA_OBJS=Test.o + +TOP=../../.. +include ../../build.mk diff --git a/examples/load/load_0/Test.hs b/examples/load/load_0/Test.hs new file mode 100644 index 0000000..6c15820 --- /dev/null +++ b/examples/load/load_0/Test.hs @@ -0,0 +1,6 @@ + +module Test where + +import API + +resource = test { field = "success" } diff --git a/examples/load/load_0/api/API.hs b/examples/load/load_0/api/API.hs new file mode 100644 index 0000000..ab9ce90 --- /dev/null +++ b/examples/load/load_0/api/API.hs @@ -0,0 +1,8 @@ +module API where + +data Test = Test { + field :: String + } + +test :: Test +test = Test { field = "default value" } diff --git a/examples/load/load_0/prog/Main.hs b/examples/load/load_0/prog/Main.hs new file mode 100644 index 0000000..cb8aa5f --- /dev/null +++ b/examples/load/load_0/prog/Main.hs @@ -0,0 +1,11 @@ + +import Plugins +import API + +main = do + m_v <- load_ "../Test.o" ["../api"] "resource" + v <- case m_v of + LoadFailure _ -> error "load failed" + LoadSuccess _ v -> return v + let s = field v + print s diff --git a/examples/load/load_0/prog/expected b/examples/load/load_0/prog/expected new file mode 100644 index 0000000..e1baeaa --- /dev/null +++ b/examples/load/load_0/prog/expected @@ -0,0 +1 @@ +"success" diff --git a/examples/load/loadpkg/Main.hs b/examples/load/loadpkg/Main.hs new file mode 100644 index 0000000..1956cfc --- /dev/null +++ b/examples/load/loadpkg/Main.hs @@ -0,0 +1,4 @@ + +import Plugins + +main = loadPackageWith "posix" [] diff --git a/examples/load/loadpkg/Makefile b/examples/load/loadpkg/Makefile new file mode 100644 index 0000000..2d96691 --- /dev/null +++ b/examples/load/loadpkg/Makefile @@ -0,0 +1,4 @@ +TEST= load/loadpkg + +TOP=../../.. +include ../../eval.mk diff --git a/examples/load/loadpkg/expected b/examples/load/loadpkg/expected new file mode 100644 index 0000000..e69de29 diff --git a/examples/load/null/Makefile b/examples/load/null/Makefile new file mode 100644 index 0000000..b6d39b1 --- /dev/null +++ b/examples/load/null/Makefile @@ -0,0 +1,4 @@ +TEST= load/null +EXTRA_OBJS=Null.o +TOP=../../.. +include ../../build.mk diff --git a/examples/load/null/Null.hs b/examples/load/null/Null.hs new file mode 100644 index 0000000..0b06f81 --- /dev/null +++ b/examples/load/null/Null.hs @@ -0,0 +1,11 @@ +module Null ( resource, resource_dyn ) where + +import API +import Data.Dynamic +import Prelude hiding (null) + +resource = null + +-- ! this has to be special: it can't be overridden by the user. +resource_dyn :: Dynamic +resource_dyn = toDyn resource diff --git a/examples/load/null/api/API.hs b/examples/load/null/api/API.hs new file mode 100644 index 0000000..a77126c --- /dev/null +++ b/examples/load/null/api/API.hs @@ -0,0 +1,12 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import Data.Dynamic + +data Null = Null { a, b :: Int } + deriving (Typeable, Show) + +null :: Null +null = Null { a = 42 , b = 1 } + diff --git a/examples/load/null/prog/Main.hs b/examples/load/null/prog/Main.hs new file mode 100644 index 0000000..53faefd --- /dev/null +++ b/examples/load/null/prog/Main.hs @@ -0,0 +1,17 @@ +{-# OPTIONS -cpp #-} + +#include "../../../../config.h" + +import Plugins +import API + +-- an example where we just want to load an object and run it + +main = do + let includes = [TOP ++ "/examples/load/null/api"] + m_v <- load "../Null.o" includes [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + + putStrLn ( show (a v) ) diff --git a/examples/load/null/prog/expected b/examples/load/null/prog/expected new file mode 100644 index 0000000..d81cc07 --- /dev/null +++ b/examples/load/null/prog/expected @@ -0,0 +1 @@ +42 diff --git a/examples/load/rawload/Main.hs b/examples/load/rawload/Main.hs new file mode 100644 index 0000000..28bdb8d --- /dev/null +++ b/examples/load/rawload/Main.hs @@ -0,0 +1,8 @@ + +import Plugins + +main = do + m <- loadRawObject "t.o" + print (path m) + resolveObjs +-- loadFunction m "sym" diff --git a/examples/load/rawload/Makefile b/examples/load/rawload/Makefile new file mode 100644 index 0000000..fb830d4 --- /dev/null +++ b/examples/load/rawload/Makefile @@ -0,0 +1,6 @@ +TEST= load/rawload + +EXTRA_OBJS=c.o + +TOP=../../.. +include ../../eval.mk diff --git a/examples/load/rawload/t.c b/examples/load/rawload/t.c new file mode 100644 index 0000000..d889433 --- /dev/null +++ b/examples/load/rawload/t.c @@ -0,0 +1 @@ +int sym(void) { return 1; } diff --git a/examples/load/thiemann0/Makefile b/examples/load/thiemann0/Makefile new file mode 100644 index 0000000..a78b224 --- /dev/null +++ b/examples/load/thiemann0/Makefile @@ -0,0 +1,6 @@ +TEST= load/thiemann0 + +#EXTRA_OBJS=Test.o + +TOP=../../.. +include ../../build.mk diff --git a/examples/load/thiemann0/Test.hs b/examples/load/thiemann0/Test.hs new file mode 100644 index 0000000..551f196 --- /dev/null +++ b/examples/load/thiemann0/Test.hs @@ -0,0 +1,11 @@ + +-- P.Thiemann reports that 'import Char' leads to undefined symbol for +-- __stginit_Char_. + +module Test where + +import API +import Char + +resource = test { field = map toUpper "success" } + diff --git a/examples/load/thiemann0/api/API.hs b/examples/load/thiemann0/api/API.hs new file mode 100644 index 0000000..ab9ce90 --- /dev/null +++ b/examples/load/thiemann0/api/API.hs @@ -0,0 +1,8 @@ +module API where + +data Test = Test { + field :: String + } + +test :: Test +test = Test { field = "default value" } diff --git a/examples/load/thiemann0/prog/Main.hs b/examples/load/thiemann0/prog/Main.hs new file mode 100644 index 0000000..d49fbe2 --- /dev/null +++ b/examples/load/thiemann0/prog/Main.hs @@ -0,0 +1,16 @@ + +import Plugins +import API + +main = do + status <- make "../Test.hs" ["-i../api"] + obj <- case status of + MakeSuccess _ o -> return o + MakeFailure e -> mapM_ putStrLn e >> error "failed" + + m_v <- load_ obj ["../api"] "resource" + v <- case m_v of + LoadFailure _ -> error "load failed" + LoadSuccess _ v -> return v + let s = field v + print s diff --git a/examples/load/thiemann0/prog/expected b/examples/load/thiemann0/prog/expected new file mode 100644 index 0000000..5450ed7 --- /dev/null +++ b/examples/load/thiemann0/prog/expected @@ -0,0 +1 @@ +"SUCCESS" diff --git a/examples/load/thiemann2/C.hs b/examples/load/thiemann2/C.hs new file mode 100644 index 0000000..5d937c0 --- /dev/null +++ b/examples/load/thiemann2/C.hs @@ -0,0 +1,6 @@ +module C where + +import API +import qualified A + +resource = let Test s = A.resource in Test { field = s } diff --git a/examples/load/thiemann2/Makefile b/examples/load/thiemann2/Makefile new file mode 100644 index 0000000..28ff4c4 --- /dev/null +++ b/examples/load/thiemann2/Makefile @@ -0,0 +1,6 @@ +TEST= load/thiemann2 +EXTRAFLAGS+=-iprog + +TOP=../../.. +include ../../build.mk + diff --git a/examples/load/thiemann2/api/API.hs b/examples/load/thiemann2/api/API.hs new file mode 100644 index 0000000..ab9ce90 --- /dev/null +++ b/examples/load/thiemann2/api/API.hs @@ -0,0 +1,8 @@ +module API where + +data Test = Test { + field :: String + } + +test :: Test +test = Test { field = "default value" } diff --git a/examples/load/thiemann2/prog/A.hs b/examples/load/thiemann2/prog/A.hs new file mode 100644 index 0000000..9ca72b2 --- /dev/null +++ b/examples/load/thiemann2/prog/A.hs @@ -0,0 +1,8 @@ +module A where + +import API + +import qualified B + +resource = Test { field = B.resource } + diff --git a/examples/load/thiemann2/prog/B.hs b/examples/load/thiemann2/prog/B.hs new file mode 100644 index 0000000..4f566ce --- /dev/null +++ b/examples/load/thiemann2/prog/B.hs @@ -0,0 +1,3 @@ +module B where + +resource = "i'm in b" diff --git a/examples/load/thiemann2/prog/Main.hs b/examples/load/thiemann2/prog/Main.hs new file mode 100644 index 0000000..422f7fa --- /dev/null +++ b/examples/load/thiemann2/prog/Main.hs @@ -0,0 +1,20 @@ + +import Plugins +import API + +import A + +main = do + -- compile C (A and B are already compiled) + status <- makeAll "../C.hs" ["-i../api"] + obj <- case status of + MakeSuccess _ o -> return o + MakeFailure e -> mapM_ putStrLn e >> error "failed" + + -- should load C + m_v <- load_ obj ["../api","."] "resource" + v <- case m_v of + LoadFailure _ -> error "load failed" + LoadSuccess _ v -> return v + let s = field v + print s diff --git a/examples/load/thiemann2/prog/expected b/examples/load/thiemann2/prog/expected new file mode 100644 index 0000000..f72f54e --- /dev/null +++ b/examples/load/thiemann2/prog/expected @@ -0,0 +1 @@ +"i'm in b" diff --git a/examples/load/unloadpkg/Main.hs b/examples/load/unloadpkg/Main.hs new file mode 100644 index 0000000..c5fcae4 --- /dev/null +++ b/examples/load/unloadpkg/Main.hs @@ -0,0 +1,6 @@ + +import Plugins + +main = do loadPackage "posix" + unloadPackage "posix" + loadPackage "posix" diff --git a/examples/load/unloadpkg/Makefile b/examples/load/unloadpkg/Makefile new file mode 100644 index 0000000..78fe8ba --- /dev/null +++ b/examples/load/unloadpkg/Makefile @@ -0,0 +1,4 @@ +TEST= load/unloadpkg + +TOP=../../.. +include ../../eval.mk diff --git a/examples/load/unloadpkg/expected b/examples/load/unloadpkg/expected new file mode 100644 index 0000000..e69de29 diff --git a/examples/make/makeall001/A.hs b/examples/make/makeall001/A.hs new file mode 100644 index 0000000..39df3ef --- /dev/null +++ b/examples/make/makeall001/A.hs @@ -0,0 +1,3 @@ +module A where + +a = "a" diff --git a/examples/make/makeall001/B.hs b/examples/make/makeall001/B.hs new file mode 100644 index 0000000..af38545 --- /dev/null +++ b/examples/make/makeall001/B.hs @@ -0,0 +1,3 @@ +module B where + +b = "b" diff --git a/examples/make/makeall001/C.hs b/examples/make/makeall001/C.hs new file mode 100644 index 0000000..d2f9b2a --- /dev/null +++ b/examples/make/makeall001/C.hs @@ -0,0 +1,3 @@ +module C where + +c = "c" diff --git a/examples/make/makeall001/Makefile b/examples/make/makeall001/Makefile new file mode 100644 index 0000000..2fd41ca --- /dev/null +++ b/examples/make/makeall001/Makefile @@ -0,0 +1,3 @@ +TEST= make/makeall001 +TOP=../../.. +include ../../build.mk diff --git a/examples/make/makeall001/Tiny.hs b/examples/make/makeall001/Tiny.hs new file mode 100644 index 0000000..237aa50 --- /dev/null +++ b/examples/make/makeall001/Tiny.hs @@ -0,0 +1,13 @@ +module Tiny ( resource ) where + +import API + +import A +import B +import C + +resource = tiny { + + field = a ++ b ++ c + +} diff --git a/examples/make/makeall001/api/API.hs b/examples/make/makeall001/api/API.hs new file mode 100644 index 0000000..b8c66f5 --- /dev/null +++ b/examples/make/makeall001/api/API.hs @@ -0,0 +1,13 @@ +{-# OPTIONS -fglasgow-exts #-} +-- ^ needed to derive Typeable + +module API where + +import Data.Dynamic + +data Tiny = Tiny { field :: String } + deriving (Typeable, Show) + +tiny :: Tiny +tiny = Tiny { field = "default value" } + diff --git a/examples/make/makeall001/prog/Main.hs b/examples/make/makeall001/prog/Main.hs new file mode 100644 index 0000000..3130f48 --- /dev/null +++ b/examples/make/makeall001/prog/Main.hs @@ -0,0 +1,18 @@ + +-- little more complex. use the path to the obj file we get back from +-- 'make'. load() uses this to find the .hi file + +import Plugins +import API + +main = do + status <- makeAll "../Tiny.hs" ["-i../api"] + o <- case status of + MakeSuccess _ o -> return o + MakeFailure e -> mapM_ putStrLn e >> error "failed" + m_v <- load o [".."] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ field v + diff --git a/examples/make/makeall001/prog/expected b/examples/make/makeall001/prog/expected new file mode 100644 index 0000000..8baef1b --- /dev/null +++ b/examples/make/makeall001/prog/expected @@ -0,0 +1 @@ +abc diff --git a/examples/make/null/Makefile b/examples/make/null/Makefile new file mode 100644 index 0000000..5c7f194 --- /dev/null +++ b/examples/make/null/Makefile @@ -0,0 +1,4 @@ +TEST= make/null + +TOP=../../.. +include ../../build.mk diff --git a/examples/make/null/Null.hs b/examples/make/null/Null.hs new file mode 100644 index 0000000..0b06f81 --- /dev/null +++ b/examples/make/null/Null.hs @@ -0,0 +1,11 @@ +module Null ( resource, resource_dyn ) where + +import API +import Data.Dynamic +import Prelude hiding (null) + +resource = null + +-- ! this has to be special: it can't be overridden by the user. +resource_dyn :: Dynamic +resource_dyn = toDyn resource diff --git a/examples/make/null/api/API.hs b/examples/make/null/api/API.hs new file mode 100644 index 0000000..a77126c --- /dev/null +++ b/examples/make/null/api/API.hs @@ -0,0 +1,12 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import Data.Dynamic + +data Null = Null { a, b :: Int } + deriving (Typeable, Show) + +null :: Null +null = Null { a = 42 , b = 1 } + diff --git a/examples/make/null/prog/Main.hs b/examples/make/null/prog/Main.hs new file mode 100644 index 0000000..d33ec27 --- /dev/null +++ b/examples/make/null/prog/Main.hs @@ -0,0 +1,13 @@ + +-- an example where we want to compile and load a file + +import Plugins +import API + +main = do + make "../Null.hs" ["-i../api"] + m_v <- load "../Null.o" ["../api"] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn ( show (a v) ) diff --git a/examples/make/null/prog/expected b/examples/make/null/prog/expected new file mode 100644 index 0000000..d81cc07 --- /dev/null +++ b/examples/make/null/prog/expected @@ -0,0 +1 @@ +42 diff --git a/examples/make/o/Makefile b/examples/make/o/Makefile new file mode 100644 index 0000000..09e51ce --- /dev/null +++ b/examples/make/o/Makefile @@ -0,0 +1,3 @@ +TEST=make/o +TOP =../../.. +include ../../build.mk diff --git a/examples/make/o/Plugin.hs b/examples/make/o/Plugin.hs new file mode 100644 index 0000000..44f2c23 --- /dev/null +++ b/examples/make/o/Plugin.hs @@ -0,0 +1,7 @@ +module Plugin ( resource ) where + +import API + +resource = plugin { + field = "hello out there" +} diff --git a/examples/make/o/api/API.hs b/examples/make/o/api/API.hs new file mode 100644 index 0000000..44e6a7b --- /dev/null +++ b/examples/make/o/api/API.hs @@ -0,0 +1,8 @@ +module API where + +data Interface = Interface { + field :: String +} + +plugin :: Interface +plugin = Interface { field = undefined } diff --git a/examples/make/o/prog/Main.hs b/examples/make/o/prog/Main.hs new file mode 100644 index 0000000..53a6a4b --- /dev/null +++ b/examples/make/o/prog/Main.hs @@ -0,0 +1,23 @@ +import Plugins +import API + +import System.Directory + +-- note: the name of the original *source* module is used to find +-- symbols in the *object* file. load works out what the source file +-- name was by looking at the object file name, i.e. it assumes they +-- have the same name. so, if you are going to store objects in a +-- tmpdir, you should make a tmp directory, and store them inside that, +-- rather than mkstemp'ing the name of the object file yourself. +-- +-- this should go away once we can read .hi files. + +main = do + make "../Plugin.hs" [ "-i../api", "-o", "/tmp/Plugin.o" ] + m_v <- load "/tmp/Plugin.o" ["../api"] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ field v + + mapM_ removeFile [ "/tmp/Plugin.o" , "/tmp/Plugin.hi" ] diff --git a/examples/make/o/prog/expected b/examples/make/o/prog/expected new file mode 100644 index 0000000..bd724e5 --- /dev/null +++ b/examples/make/o/prog/expected @@ -0,0 +1 @@ +hello out there diff --git a/examples/make/odir/Makefile b/examples/make/odir/Makefile new file mode 100644 index 0000000..159219a --- /dev/null +++ b/examples/make/odir/Makefile @@ -0,0 +1,3 @@ +TEST= make/odir +TOP=../../.. +include ../../build.mk diff --git a/examples/make/odir/Plugin.hs b/examples/make/odir/Plugin.hs new file mode 100644 index 0000000..44f2c23 --- /dev/null +++ b/examples/make/odir/Plugin.hs @@ -0,0 +1,7 @@ +module Plugin ( resource ) where + +import API + +resource = plugin { + field = "hello out there" +} diff --git a/examples/make/odir/api/API.hs b/examples/make/odir/api/API.hs new file mode 100644 index 0000000..44e6a7b --- /dev/null +++ b/examples/make/odir/api/API.hs @@ -0,0 +1,8 @@ +module API where + +data Interface = Interface { + field :: String +} + +plugin :: Interface +plugin = Interface { field = undefined } diff --git a/examples/make/odir/prog/Main.hs b/examples/make/odir/prog/Main.hs new file mode 100644 index 0000000..6d95f44 --- /dev/null +++ b/examples/make/odir/prog/Main.hs @@ -0,0 +1,16 @@ +import Plugins +import API +import System.Directory + +main = do + status <- make "../Plugin.hs" [ "-i../api", "-odir", "/tmp" ] + o <- case status of + MakeSuccess _ o -> return o + MakeFailure e -> mapM_ putStrLn e >> error "didn't compile" + m_v <- load o ["../api"] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ field v + mapM_ removeFile ["/tmp/Plugin.hi", "/tmp/Plugin.o" ] + diff --git a/examples/make/odir/prog/expected b/examples/make/odir/prog/expected new file mode 100644 index 0000000..bd724e5 --- /dev/null +++ b/examples/make/odir/prog/expected @@ -0,0 +1 @@ +hello out there diff --git a/examples/make/remake001/Bar.hs b/examples/make/remake001/Bar.hs new file mode 100644 index 0000000..4eac815 --- /dev/null +++ b/examples/make/remake001/Bar.hs @@ -0,0 +1,3 @@ +module Bar where + +bar = undefined diff --git a/examples/make/remake001/Foo.hs b/examples/make/remake001/Foo.hs new file mode 100644 index 0000000..13993fd --- /dev/null +++ b/examples/make/remake001/Foo.hs @@ -0,0 +1,3 @@ +module Foo where + +foo = undefined diff --git a/examples/make/remake001/Main.hs b/examples/make/remake001/Main.hs new file mode 100644 index 0000000..29e42fe --- /dev/null +++ b/examples/make/remake001/Main.hs @@ -0,0 +1,36 @@ +-- +-- expected output: +-- $ ./a.out +-- True +-- False +-- True +-- False +-- + +import Plugins +import System.Directory + +main = do + status <- make "Foo.hs" [] -- should make + print status + + status <- make "Foo.hs" [] -- shouldn't make + print status + + status <- merge "Foo.hs" "Bar.hs" + case status of + MergeFailure e -> error $ show e + MergeSuccess _ _ fp -> do { + + ;status <- make fp [] -- should make + ;() <- case status of + MakeSuccess c _ -> print c + MakeFailure e -> error $ show e + + ;status <- make fp [] -- shouldn't make + ;case status of + MakeSuccess c _ -> print c + MakeFailure e -> error $ show e + ;removeFile "Foo.o" + } + diff --git a/examples/make/remake001/Makefile b/examples/make/remake001/Makefile new file mode 100644 index 0000000..a240d27 --- /dev/null +++ b/examples/make/remake001/Makefile @@ -0,0 +1,4 @@ +TEST= merge/remake001 + +TOP=../../.. +include ../../eval.mk diff --git a/examples/make/remake001/expected b/examples/make/remake001/expected new file mode 100644 index 0000000..c35c9dc --- /dev/null +++ b/examples/make/remake001/expected @@ -0,0 +1,4 @@ +MakeSuccess ReComp "Foo.o" +MakeSuccess NotReq "Foo.o" +ReComp +NotReq diff --git a/examples/make/remake001_should_fail/Bar.hs b/examples/make/remake001_should_fail/Bar.hs new file mode 100644 index 0000000..eb59d44 --- /dev/null +++ b/examples/make/remake001_should_fail/Bar.hs @@ -0,0 +1,3 @@ +module Bar where + +bar = undef {- error -} diff --git a/examples/make/remake001_should_fail/Foo.hs b/examples/make/remake001_should_fail/Foo.hs new file mode 100644 index 0000000..13993fd --- /dev/null +++ b/examples/make/remake001_should_fail/Foo.hs @@ -0,0 +1,3 @@ +module Foo where + +foo = undefined diff --git a/examples/make/remake001_should_fail/Main.hs b/examples/make/remake001_should_fail/Main.hs new file mode 100644 index 0000000..d3dcbc7 --- /dev/null +++ b/examples/make/remake001_should_fail/Main.hs @@ -0,0 +1,31 @@ + +import Plugins + +import System.Directory + +main = do + status <- make "Foo.hs" [] -- should make + print status + + status <- make "Foo.hs" [] -- shouldn't make + print status + + status <- merge "Foo.hs" "Bar.hs" + case status of + MergeFailure e -> error $ show e + MergeSuccess _ _ fp -> do { + + ;status <- make fp [] -- should make + ;() <- case status of + MakeSuccess c _ -> print c + MakeFailure _ -> print "make failure" + + ;status <- make fp [] -- shouldn't make + ;case status of + MakeSuccess c _ -> print c + MakeFailure _ -> print "make failure" + + ;removeFile "Foo.o" -- make test deterministic + } + + diff --git a/examples/make/remake001_should_fail/Makefile b/examples/make/remake001_should_fail/Makefile new file mode 100644 index 0000000..c8e3a00 --- /dev/null +++ b/examples/make/remake001_should_fail/Makefile @@ -0,0 +1,4 @@ +TEST= make/remake001_should_fail + +TOP=../../.. +include ../../eval.mk diff --git a/examples/make/remake001_should_fail/expected b/examples/make/remake001_should_fail/expected new file mode 100644 index 0000000..475163e --- /dev/null +++ b/examples/make/remake001_should_fail/expected @@ -0,0 +1,4 @@ +MakeSuccess ReComp "Foo.o" +MakeSuccess NotReq "Foo.o" +"make failure" +"make failure" diff --git a/examples/make/simple/Makefile b/examples/make/simple/Makefile new file mode 100644 index 0000000..0b211ed --- /dev/null +++ b/examples/make/simple/Makefile @@ -0,0 +1,3 @@ +TEST= make/simple +TOP=../../.. +include ../../build.mk diff --git a/examples/make/simple/Tiny.hs b/examples/make/simple/Tiny.hs new file mode 100644 index 0000000..0159f67 --- /dev/null +++ b/examples/make/simple/Tiny.hs @@ -0,0 +1,14 @@ +module Tiny ( resource, resource_dyn ) where + +import API +import Data.Dynamic + +resource = tiny { + + field = "hello strange world" + +} + +resource_dyn :: Dynamic +resource_dyn = toDyn resource + diff --git a/examples/make/simple/api/API.hs b/examples/make/simple/api/API.hs new file mode 100644 index 0000000..b8c66f5 --- /dev/null +++ b/examples/make/simple/api/API.hs @@ -0,0 +1,13 @@ +{-# OPTIONS -fglasgow-exts #-} +-- ^ needed to derive Typeable + +module API where + +import Data.Dynamic + +data Tiny = Tiny { field :: String } + deriving (Typeable, Show) + +tiny :: Tiny +tiny = Tiny { field = "default value" } + diff --git a/examples/make/simple/prog/Main.hs b/examples/make/simple/prog/Main.hs new file mode 100644 index 0000000..032c744 --- /dev/null +++ b/examples/make/simple/prog/Main.hs @@ -0,0 +1,19 @@ + +-- little more complex. use the path to the obj file we get back from +-- 'make'. load() uses this to find the .hi file + +import Plugins +import API + +main = do + status <- make "../Tiny.hs" ["-i../api"] + o <- case status of + MakeSuccess _ o -> return o + MakeFailure e -> mapM_ putStrLn e >> error "failed" + + m_v <- load o ["../api"] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ field v + diff --git a/examples/make/simple/prog/expected b/examples/make/simple/prog/expected new file mode 100644 index 0000000..e681b97 --- /dev/null +++ b/examples/make/simple/prog/expected @@ -0,0 +1 @@ +hello strange world diff --git a/examples/makewith/global_pragma/Makefile b/examples/makewith/global_pragma/Makefile new file mode 100644 index 0000000..5dcd9b0 --- /dev/null +++ b/examples/makewith/global_pragma/Makefile @@ -0,0 +1,5 @@ + +TEST=makewith/global_pragma + +TOP=../../.. +include ../../build.mk diff --git a/examples/makewith/global_pragma/Plugin.hs b/examples/makewith/global_pragma/Plugin.hs new file mode 100644 index 0000000..2c80e71 --- /dev/null +++ b/examples/makewith/global_pragma/Plugin.hs @@ -0,0 +1,17 @@ +{-# GLOBALOPTIONS -package posix #-} + +module M ( resource ) where + +import System.IO.Unsafe +import API +import System.Process +import System.IO + +resource = tiny { field = date } + +date :: String +date = unsafePerformIO $ do + (_,outh,_,proc) <- runInteractiveProcess "echo" ["hello"] Nothing Nothing + waitForProcess proc + s <- hGetContents outh + return s diff --git a/examples/makewith/global_pragma/api/API.hs b/examples/makewith/global_pragma/api/API.hs new file mode 100644 index 0000000..34ec480 --- /dev/null +++ b/examples/makewith/global_pragma/api/API.hs @@ -0,0 +1,8 @@ + +module API where + +data Tiny = Tiny { field :: String } + +tiny :: Tiny +tiny = Tiny { field = "default value" } + diff --git a/examples/makewith/global_pragma/prog/Main.hs b/examples/makewith/global_pragma/prog/Main.hs new file mode 100644 index 0000000..e31a6ed --- /dev/null +++ b/examples/makewith/global_pragma/prog/Main.hs @@ -0,0 +1,19 @@ + +import Plugins +import API + +conf = "../Plugin.hs" +apipath = "../api" + +main = do + status <- makeWith conf conf ["-i"++apipath] + o <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "compile failed" + MakeSuccess _ o -> return o + m_v <- load o [apipath] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + LoadFailure ers -> mapM_ putStrLn ers >> error "load failed" + putStr $ field v + makeCleaner o + diff --git a/examples/makewith/global_pragma/prog/expected b/examples/makewith/global_pragma/prog/expected new file mode 100644 index 0000000..ce01362 --- /dev/null +++ b/examples/makewith/global_pragma/prog/expected @@ -0,0 +1 @@ +hello diff --git a/examples/makewith/io/Makefile b/examples/makewith/io/Makefile new file mode 100644 index 0000000..f1e3069 --- /dev/null +++ b/examples/makewith/io/Makefile @@ -0,0 +1,4 @@ +TEST=makewith/io + +TOP=../../.. +include ../../build.mk diff --git a/examples/makewith/io/README b/examples/makewith/io/README new file mode 100644 index 0000000..1cad0c3 --- /dev/null +++ b/examples/makewith/io/README @@ -0,0 +1,2 @@ +An example using IO monad fields in the .conf file. + diff --git a/examples/makewith/io/TestIO.conf b/examples/makewith/io/TestIO.conf new file mode 100644 index 0000000..03c5b35 --- /dev/null +++ b/examples/makewith/io/TestIO.conf @@ -0,0 +1,76 @@ +{-# OPTIONS -cpp #-} +-- +-- Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- LGPL version 2.1 or later (see http://www.gnu.org/copyleft/lesser.html) +-- + +import System.IO +import System.Posix.Types ( ProcessID, Fd ) +import System.Posix.Process ( forkProcess, executeFile, getProcessID ) +import System.Posix.IO ( createPipe, stdInput, + stdOutput, fdToHandle, closeFd, dupTo ) + +resource = testio { field = date } + +-- +-- call a shell command , returning it's output +-- +date :: IO String +date = do (hdl,_,_) <- catch (popen "/bin/date") (\_->error "popen failed") + hGetLine hdl + +------------------------------------------------------------------------ +-- +-- my implementation of $val = `cmd`; (if this was perl) +-- +-- provide similar functionality to popen(3), +-- along with bidirectional ipc via pipes +-- return's the pid of the child process +-- +-- there are two different forkProcess functions. the pre-620 was a +-- unix-fork style function, and the modern function has semantics more +-- like the Awkward-Squad paper. We provide implementations of popen +-- using both versions, depending on which GHC the user wants to try. +-- + +popen :: FilePath -> IO (Handle, Handle, ProcessID) +popen cmd = do + (pr, pw) <- createPipe + (cr, cw) <- createPipe + + -- parent -- + let parent = do closeFd cw + closeFd pr + -- child -- + let child = do closeFd pw + closeFd cr + exec cmd (pr,cw) + error "exec cmd failed!" -- typing only + +-- if the parser front end understood cpp, this would work +-- #if __GLASGOW_HASKELL__ >= 601 + pid <- forkProcess child -- fork child + parent -- and run parent code +-- #else +-- p <- forkProcess +-- pid <- case p of +-- Just pid -> parent >> return pid +-- Nothing -> child +-- #endif + + hcr <- fdToHandle cr + hpw <- fdToHandle pw + + return (hcr,hpw,pid) + +-- +-- execve cmd in the child process, dup'ing the file descriptors passed +-- as arguments to become the child's stdin and stdout. +-- +exec :: FilePath -> (Fd,Fd) -> IO () +exec cmd (pr,cw) = do + dupTo pr stdInput + dupTo cw stdOutput + executeFile cmd False [] Nothing + +------------------------------------------------------------------------ diff --git a/examples/makewith/io/TestIO.stub b/examples/makewith/io/TestIO.stub new file mode 100644 index 0000000..5caee4c --- /dev/null +++ b/examples/makewith/io/TestIO.stub @@ -0,0 +1,10 @@ + +module TestIO ( resource, resource_dyn ) where + +import API +import Data.Dynamic + +resource = testio + +resource_dyn :: Dynamic +resource_dyn = toDyn resource diff --git a/examples/makewith/io/api/API.hs b/examples/makewith/io/api/API.hs new file mode 100644 index 0000000..4b8be53 --- /dev/null +++ b/examples/makewith/io/api/API.hs @@ -0,0 +1,16 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import Data.Dynamic + +data TestIO = TestIO { + field :: IO String + } + deriving (Typeable, Show) + +instance Show (IO String) where + show _ = "<>" + +testio :: TestIO +testio = TestIO { field = return "default value" } diff --git a/examples/makewith/io/prog/Main.hs b/examples/makewith/io/prog/Main.hs new file mode 100644 index 0000000..36d3dc3 --- /dev/null +++ b/examples/makewith/io/prog/Main.hs @@ -0,0 +1,21 @@ + +import Plugins +import API + +conf = "../TestIO.conf" +stub = "../TestIO.stub" +apipath = "../api" + +main = do + status <- makeWith conf stub ["-i"++apipath] + o <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess _ o -> return o + m_v <- load o [apipath] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + s <- field v + + makeCleaner o + if null s then print False else print True diff --git a/examples/makewith/io/prog/expected b/examples/makewith/io/prog/expected new file mode 100644 index 0000000..0ca9514 --- /dev/null +++ b/examples/makewith/io/prog/expected @@ -0,0 +1 @@ +True diff --git a/examples/makewith/merge00/Bar.hs b/examples/makewith/merge00/Bar.hs new file mode 100644 index 0000000..611493c --- /dev/null +++ b/examples/makewith/merge00/Bar.hs @@ -0,0 +1,3 @@ +module Bar where + +resource :: Int diff --git a/examples/makewith/merge00/Foo.hs b/examples/makewith/merge00/Foo.hs new file mode 100644 index 0000000..73859db --- /dev/null +++ b/examples/makewith/merge00/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +resource :: Integer +resource = 0xBAD diff --git a/examples/makewith/merge00/Main.hs b/examples/makewith/merge00/Main.hs new file mode 100644 index 0000000..7e88c1e --- /dev/null +++ b/examples/makewith/merge00/Main.hs @@ -0,0 +1,38 @@ + +import Plugins + +import System.Directory + +a = "Foo.hs" -- uesr code +b = "Bar.hs" -- trusted code. Result is "Bar.o" + +main = do + status <- merge a b + f <- case status of + MergeFailure e -> error "merge failure" + MergeSuccess _ _ f -> return f + + status <- merge a b + f' <- case status of + MergeFailure e -> error "merge failure" + MergeSuccess ReComp _ f -> error "unnec. merge" + MergeSuccess NotReq _ f -> return f + + print ( f == f' ) + + status <- make f' [] + o <- case status of + MakeFailure e -> error "make failed" + MakeSuccess _ o -> return o + + m_v <- load o [] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ show $ (v :: Int) + + removeFile o + return () + + makeCleaner f + diff --git a/examples/makewith/merge00/Makefile b/examples/makewith/merge00/Makefile new file mode 100644 index 0000000..da2b197 --- /dev/null +++ b/examples/makewith/merge00/Makefile @@ -0,0 +1,4 @@ +TEST=makewith/merge00 + +TOP=../../.. +include ../../eval.mk diff --git a/examples/makewith/merge00/expected b/examples/makewith/merge00/expected new file mode 100644 index 0000000..38cd603 --- /dev/null +++ b/examples/makewith/merge00/expected @@ -0,0 +1,2 @@ +True +2989 diff --git a/examples/makewith/mergeto0/Bar.hs b/examples/makewith/mergeto0/Bar.hs new file mode 100644 index 0000000..611493c --- /dev/null +++ b/examples/makewith/mergeto0/Bar.hs @@ -0,0 +1,3 @@ +module Bar where + +resource :: Int diff --git a/examples/makewith/mergeto0/Foo.hs b/examples/makewith/mergeto0/Foo.hs new file mode 100644 index 0000000..73859db --- /dev/null +++ b/examples/makewith/mergeto0/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +resource :: Integer +resource = 0xBAD diff --git a/examples/makewith/mergeto0/Main.hs b/examples/makewith/mergeto0/Main.hs new file mode 100644 index 0000000..a6beb82 --- /dev/null +++ b/examples/makewith/mergeto0/Main.hs @@ -0,0 +1,37 @@ + +import Plugins + +import System.Directory + +a = "Foo.hs" -- uesr code +b = "Bar.hs" -- trusted code. Result is "Bar.o" +c = "Out.hs" + +main = do + status <- mergeTo a b c + f <- case status of + MergeFailure e -> error "mergeto failure" + MergeSuccess _ _ f -> return f + print $ f == c + + status <- mergeTo a b c + f' <- case status of + MergeFailure e -> error "mergeto failure" + MergeSuccess ReComp _ f -> error "unnec. mergeto" + MergeSuccess NotReq _ f -> return f -- good, not req + + print $ f == f' && f == c + + status <- make f' [] + o <- case status of + MakeFailure e -> error "make failed" + MakeSuccess _ o -> return o + + m_v <- load o [] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ show $ (v :: Int) + + makeCleaner c + diff --git a/examples/makewith/mergeto0/Makefile b/examples/makewith/mergeto0/Makefile new file mode 100644 index 0000000..c2d2d89 --- /dev/null +++ b/examples/makewith/mergeto0/Makefile @@ -0,0 +1,4 @@ +TEST=makewith/mergeto0 + +TOP=../../.. +include ../../eval.mk diff --git a/examples/makewith/mergeto0/expected b/examples/makewith/mergeto0/expected new file mode 100644 index 0000000..06afacf --- /dev/null +++ b/examples/makewith/mergeto0/expected @@ -0,0 +1,3 @@ +True +True +2989 diff --git a/examples/makewith/module_name/Bar.hs b/examples/makewith/module_name/Bar.hs new file mode 100644 index 0000000..611493c --- /dev/null +++ b/examples/makewith/module_name/Bar.hs @@ -0,0 +1,3 @@ +module Bar where + +resource :: Int diff --git a/examples/makewith/module_name/Foo.hs b/examples/makewith/module_name/Foo.hs new file mode 100644 index 0000000..b2cf693 --- /dev/null +++ b/examples/makewith/module_name/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +resource :: Integer +resource = 1 diff --git a/examples/makewith/module_name/Main.hs b/examples/makewith/module_name/Main.hs new file mode 100644 index 0000000..10d4a73 --- /dev/null +++ b/examples/makewith/module_name/Main.hs @@ -0,0 +1,33 @@ + +import Plugins + +import System.Directory + +a = "Foo.hs" -- uesr code +b = "Bar.hs" -- trusted code. Result is "Bar.o" + +main = do + status <- makeWith a b [] + s <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess n s -> print n >> return s + + status <- makeWith a b [] + s' <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess n s -> print n >> return s + + status <- makeWith a b [] + s'' <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess n s -> print n >> return s + + print $ (s == s') && (s' == s'') + + m_v <- load s [] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ show $ (v :: Int) + + makeCleaner s'' diff --git a/examples/makewith/module_name/Makefile b/examples/makewith/module_name/Makefile new file mode 100644 index 0000000..fdab0c9 --- /dev/null +++ b/examples/makewith/module_name/Makefile @@ -0,0 +1,4 @@ +TEST=makewith/module_name + +TOP=../../.. +include ../../eval.mk diff --git a/examples/makewith/module_name/expected b/examples/makewith/module_name/expected new file mode 100644 index 0000000..55e8cc5 --- /dev/null +++ b/examples/makewith/module_name/expected @@ -0,0 +1,5 @@ +ReComp +NotReq +NotReq +True +1 diff --git a/examples/makewith/multi_make/Bar.hs b/examples/makewith/multi_make/Bar.hs new file mode 100644 index 0000000..d09e32d --- /dev/null +++ b/examples/makewith/multi_make/Bar.hs @@ -0,0 +1,4 @@ +module Bar where + +resource :: Int +resource = 2 diff --git a/examples/makewith/multi_make/Foo.hs b/examples/makewith/multi_make/Foo.hs new file mode 100644 index 0000000..b2cf693 --- /dev/null +++ b/examples/makewith/multi_make/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +resource :: Integer +resource = 1 diff --git a/examples/makewith/multi_make/Main.hs b/examples/makewith/multi_make/Main.hs new file mode 100644 index 0000000..1720d88 --- /dev/null +++ b/examples/makewith/multi_make/Main.hs @@ -0,0 +1,37 @@ + +import Plugins + +import System.Directory + +a = "Foo.hs" -- user code +b = "Bar.hs" -- more user code +z = "Stub.hs" -- and a stub + +main = do + status <- makeWith a z [] + s <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess n s -> print n >> return s + + status <- makeWith b z [] + s' <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess n s -> print n >> return s + + -- shouldn't need to remerge (a,z) + status <- makeWith a z [] + t <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess n s -> print n >> return s + + -- shouldn't need to remerge (b,z) + status <- makeWith b z [] + t' <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess n s -> print n >> return s + + print $ s /= s' -- test we got unique modules + print $ t /= t' -- test we got unique modules + + mapM_ makeCleaner [s,s'] + diff --git a/examples/makewith/multi_make/Makefile b/examples/makewith/multi_make/Makefile new file mode 100644 index 0000000..04ffdc9 --- /dev/null +++ b/examples/makewith/multi_make/Makefile @@ -0,0 +1,4 @@ +TEST=makewith/multi_make + +TOP=../../.. +include ../../eval.mk diff --git a/examples/makewith/multi_make/Stub.hs b/examples/makewith/multi_make/Stub.hs new file mode 100644 index 0000000..1be6e6a --- /dev/null +++ b/examples/makewith/multi_make/Stub.hs @@ -0,0 +1,4 @@ +module Stub where + +resource :: Int + diff --git a/examples/makewith/multi_make/expected b/examples/makewith/multi_make/expected new file mode 100644 index 0000000..72713cd --- /dev/null +++ b/examples/makewith/multi_make/expected @@ -0,0 +1,6 @@ +ReComp +ReComp +NotReq +NotReq +True +True diff --git a/examples/makewith/should_fail_0/Makefile b/examples/makewith/should_fail_0/Makefile new file mode 100644 index 0000000..4aa0ebd --- /dev/null +++ b/examples/makewith/should_fail_0/Makefile @@ -0,0 +1,4 @@ +TEST=makewith/should_fail_0 + +TOP=../../.. +include ../../build.mk diff --git a/examples/makewith/should_fail_0/Plugin.in b/examples/makewith/should_fail_0/Plugin.in new file mode 100644 index 0000000..479a79d --- /dev/null +++ b/examples/makewith/should_fail_0/Plugin.in @@ -0,0 +1,3 @@ +module Plugin where + +resource = 0xBAD :: Int diff --git a/examples/makewith/should_fail_0/Plugin.stub b/examples/makewith/should_fail_0/Plugin.stub new file mode 100644 index 0000000..2f8c176 --- /dev/null +++ b/examples/makewith/should_fail_0/Plugin.stub @@ -0,0 +1,6 @@ +module Plugin ( resource ) where + +import API + +resource :: Interface +resource = plugin diff --git a/examples/makewith/should_fail_0/api/API.hs b/examples/makewith/should_fail_0/api/API.hs new file mode 100644 index 0000000..df6c757 --- /dev/null +++ b/examples/makewith/should_fail_0/api/API.hs @@ -0,0 +1,10 @@ + +module API where + +data Interface = Interface { + function :: String + } + +plugin :: Interface +plugin = Interface { function = "goodbye" } + diff --git a/examples/makewith/should_fail_0/prog/Main.hs b/examples/makewith/should_fail_0/prog/Main.hs new file mode 100644 index 0000000..94b4f06 --- /dev/null +++ b/examples/makewith/should_fail_0/prog/Main.hs @@ -0,0 +1,19 @@ + +import Plugins +import API + +conf = "../Plugin.in" +stub = "../Plugin.stub" + +main = do + status <- makeWith conf stub ["-i../api"] + case status of + MakeFailure e -> putStrLn "make failed" + MakeSuccess _ o -> do + m_v <- load o ["../api"] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ (function v) + makeCleaner o + diff --git a/examples/makewith/should_fail_0/prog/expected b/examples/makewith/should_fail_0/prog/expected new file mode 100644 index 0000000..8f81285 --- /dev/null +++ b/examples/makewith/should_fail_0/prog/expected @@ -0,0 +1 @@ +make failed diff --git a/examples/makewith/tiny/Makefile b/examples/makewith/tiny/Makefile new file mode 100644 index 0000000..bcb0aad --- /dev/null +++ b/examples/makewith/tiny/Makefile @@ -0,0 +1,5 @@ + +TEST=makewith/tiny + +TOP=../../.. +include ../../build.mk diff --git a/examples/makewith/tiny/Tiny.conf b/examples/makewith/tiny/Tiny.conf new file mode 100644 index 0000000..f868e95 --- /dev/null +++ b/examples/makewith/tiny/Tiny.conf @@ -0,0 +1,8 @@ +resource = tiny { + + field = "hello strange world" + +} + + + diff --git a/examples/makewith/tiny/Tiny.stub b/examples/makewith/tiny/Tiny.stub new file mode 100644 index 0000000..2778ddd --- /dev/null +++ b/examples/makewith/tiny/Tiny.stub @@ -0,0 +1,31 @@ +module Tiny ( resource, resource_dyn ) where + +import API +import Data.Dynamic + +resource = tiny + +resource_dyn :: Dynamic +resource_dyn = toDyn resource + + + + + + + + + + + + + + + + + + + + + + diff --git a/examples/makewith/tiny/api/API.hs b/examples/makewith/tiny/api/API.hs new file mode 100644 index 0000000..b8c66f5 --- /dev/null +++ b/examples/makewith/tiny/api/API.hs @@ -0,0 +1,13 @@ +{-# OPTIONS -fglasgow-exts #-} +-- ^ needed to derive Typeable + +module API where + +import Data.Dynamic + +data Tiny = Tiny { field :: String } + deriving (Typeable, Show) + +tiny :: Tiny +tiny = Tiny { field = "default value" } + diff --git a/examples/makewith/tiny/prog/Main.hs b/examples/makewith/tiny/prog/Main.hs new file mode 100644 index 0000000..a95d0ea --- /dev/null +++ b/examples/makewith/tiny/prog/Main.hs @@ -0,0 +1,21 @@ + +import Plugins +import API +import Data.Either + +conf = "../Tiny.conf" +stub = "../Tiny.stub" +apipath = "../api" + +main = do + status <- makeWith conf stub ["-i"++apipath] + o <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess _ o -> return o + m_v <- load o [apipath] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn $ field v + makeCleaner o + diff --git a/examples/makewith/tiny/prog/expected b/examples/makewith/tiny/prog/expected new file mode 100644 index 0000000..e681b97 --- /dev/null +++ b/examples/makewith/tiny/prog/expected @@ -0,0 +1 @@ +hello strange world diff --git a/examples/makewith/unsafeio/Makefile b/examples/makewith/unsafeio/Makefile new file mode 100644 index 0000000..f975577 --- /dev/null +++ b/examples/makewith/unsafeio/Makefile @@ -0,0 +1,5 @@ + +TEST=makewith/unsafeio + +TOP=../../.. +include ../../build.mk diff --git a/examples/makewith/unsafeio/README b/examples/makewith/unsafeio/README new file mode 100644 index 0000000..d2d987d --- /dev/null +++ b/examples/makewith/unsafeio/README @@ -0,0 +1,3 @@ +hmm. on 6.3 we need to add 'mtl' to a package dependency, other +HSlang complains of a missing symbol. Is this a bug in the +package.conf for HSlang? diff --git a/examples/makewith/unsafeio/Unsafe.conf b/examples/makewith/unsafeio/Unsafe.conf new file mode 100644 index 0000000..69e9761 --- /dev/null +++ b/examples/makewith/unsafeio/Unsafe.conf @@ -0,0 +1,17 @@ +{-# GLOBALOPTIONS -package posix #-} +-- illustrates the use of static options in pragmas + +import System.IO.Unsafe +import System.IO +import System.Process + +resource = unsafe { field = date } + +-- illustrates the use of the devil's work +date :: String +date = unsafePerformIO $ do + (_,outh,_,proc) <- runInteractiveProcess "date" [] Nothing Nothing + waitForProcess proc + s <- hGetContents outh + return s + diff --git a/examples/makewith/unsafeio/Unsafe.stub b/examples/makewith/unsafeio/Unsafe.stub new file mode 100644 index 0000000..296a5c6 --- /dev/null +++ b/examples/makewith/unsafeio/Unsafe.stub @@ -0,0 +1,13 @@ + +module Unsafe ( resource, resource_dyn ) where + +import API +import Data.Dynamic + +resource = unsafe + +-- +-- special +-- +resource_dyn :: Dynamic +resource_dyn = toDyn resource diff --git a/examples/makewith/unsafeio/api/API.hs b/examples/makewith/unsafeio/api/API.hs new file mode 100644 index 0000000..7b6564a --- /dev/null +++ b/examples/makewith/unsafeio/api/API.hs @@ -0,0 +1,13 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import Data.Dynamic + +data Unsafe = Unsafe { + field :: String + } + deriving (Typeable, Show) + +unsafe :: Unsafe +unsafe = Unsafe { field = "default value" } diff --git a/examples/makewith/unsafeio/prog/Main.hs b/examples/makewith/unsafeio/prog/Main.hs new file mode 100644 index 0000000..b9920b7 --- /dev/null +++ b/examples/makewith/unsafeio/prog/Main.hs @@ -0,0 +1,20 @@ +import Plugins +import API +import Data.Either + +conf = "../Unsafe.conf" +stub = "../Unsafe.stub" +apipath = "../api" + +main = do + status <- makeWith conf stub ["-i"++apipath] + o <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed" + MakeSuccess _ o -> return o + m_v <- load o [apipath] [] "resource" + v <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + let s = field v + makeCleaner o + if null s then print False else print True diff --git a/examples/makewith/unsafeio/prog/README b/examples/makewith/unsafeio/prog/README new file mode 100644 index 0000000..d322aed --- /dev/null +++ b/examples/makewith/unsafeio/prog/README @@ -0,0 +1,8 @@ +this is an example of an application that uses the HSConf library to +dynamically load compiled conf files. + +We use the .conf file in the parent directory, and communicate with +the plugin via the API in the api_package/ directory. + +The plugin is a .o file +The api is a GHC package archive diff --git a/examples/makewith/unsafeio/prog/expected b/examples/makewith/unsafeio/prog/expected new file mode 100644 index 0000000..0ca9514 --- /dev/null +++ b/examples/makewith/unsafeio/prog/expected @@ -0,0 +1 @@ +True diff --git a/examples/misc/mkstemps/Main.hs b/examples/misc/mkstemps/Main.hs new file mode 100644 index 0000000..a471bae --- /dev/null +++ b/examples/misc/mkstemps/Main.hs @@ -0,0 +1,69 @@ + +import Plugins.MkTemp + +import Data.Maybe + +import System.IO +import System.Directory + +main = do + createDirectory "t" + + ------------------------------------------------------------------------ + -- Try mkstemp with simple template + -- + ts <- mapM (\_ -> mkstemp "t/t.X" ) [0..(26+26)] -- 1+26+26 files + () <- if (not $ all isJust ts) + then putStrLn $ "mkstemp couldn't create all expected files" + else putStrLn $ "created "++(show $ length $ catMaybes ts)++" files" + closeAll ts + + -- next one shouldn't be possible + t <- mkstemp "t/t.X" + () <- if (not $ isNothing t) + then putStrLn $ "shouldn't have been able to create this file" + else putStrLn $ "correctly ran out of permutations" + closeAll [t] + + rmAll (t:ts) + + ------------------------------------------------------------------------ + -- Try again with large tmp + -- + ts <- mapM (\_->do v <- mkstemp "t/t.XXXXXXXXXX" + case v of Just (t,h) -> hClose h >> return v + _ -> return v ) [1..10000] + + () <- if (not $ all isJust ts) + then putStrLn $ "mkstemp couldn't create all expected files" + else putStrLn $ "mkstemp: created "++(show $ length $ catMaybes ts)++" files" + rmAll ts + + ------------------------------------------------------------------------ + -- test mkstemps + -- + ts <- mapM (\_->do v <- mkstemps "t/t.XXXXXXXXXX.hs" 3 + case v of Just (t,h) -> hClose h >> return v + _ -> return v ) [1..2000] + () <- if (not $ all isJust ts) + then putStrLn $ "mkstemps couldn't create all expected files" + else putStrLn $ "mkstemps: created "++(show $ length $ catMaybes ts)++" files" + rmAll ts + + ------------------------------------------------------------------------ + -- mkdtemp + -- + ts <- mapM (\_ -> mkdtemp "t/XXXXXXXXXX") [1..2000] + () <- if (not $ all isJust ts) + then putStrLn $ "mkdtemp: couldn't create all expected directories" + else putStrLn $ "mkdtemp: created "++(show $ length $ catMaybes ts)++" directories" + rmAllDirs ts + + ------------------------------------------------------------------------ + + removeDirectory "t" + + where + closeAll ts = mapM_ hClose $ map snd $ catMaybes ts + rmAll ts = mapM_ removeFile $ map fst $ catMaybes ts + rmAllDirs ts = mapM_ removeDirectory $ catMaybes ts diff --git a/examples/misc/mkstemps/Makefile b/examples/misc/mkstemps/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/misc/mkstemps/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/misc/mkstemps/expected b/examples/misc/mkstemps/expected new file mode 100644 index 0000000..e05d35f --- /dev/null +++ b/examples/misc/mkstemps/expected @@ -0,0 +1,5 @@ +created 53 files +correctly ran out of permutations +mkstemp: created 10000 files +mkstemps: created 2000 files +mkdtemp: created 2000 directories diff --git a/examples/multi/3plugins/Makefile b/examples/multi/3plugins/Makefile new file mode 100644 index 0000000..cea7c9d --- /dev/null +++ b/examples/multi/3plugins/Makefile @@ -0,0 +1,6 @@ +TEST= multi/3plugins + +EXTRA_OBJS=Plugin1.o Plugin2.o Plugin3.o + +TOP=../../.. +include ../../build.mk diff --git a/examples/multi/3plugins/Plugin1.hs b/examples/multi/3plugins/Plugin1.hs new file mode 100644 index 0000000..b2c6e8b --- /dev/null +++ b/examples/multi/3plugins/Plugin1.hs @@ -0,0 +1,8 @@ +module Plugin1 where + +import API +import Data.Char + +resource = plugin { + valueOf = map toUpper +} diff --git a/examples/multi/3plugins/Plugin2.hs b/examples/multi/3plugins/Plugin2.hs new file mode 100644 index 0000000..9a58ca6 --- /dev/null +++ b/examples/multi/3plugins/Plugin2.hs @@ -0,0 +1,9 @@ +module Plugin2 where + +import API +import Data.Char + +resource = plugin { + valueOf = \s -> show $ map ord s +} + diff --git a/examples/multi/3plugins/Plugin3.hs b/examples/multi/3plugins/Plugin3.hs new file mode 100644 index 0000000..e99af2b --- /dev/null +++ b/examples/multi/3plugins/Plugin3.hs @@ -0,0 +1,7 @@ +module Plugin3 where + +import API + +resource = plugin { + valueOf = reverse +} diff --git a/examples/multi/3plugins/api/API.hs b/examples/multi/3plugins/api/API.hs new file mode 100644 index 0000000..25df753 --- /dev/null +++ b/examples/multi/3plugins/api/API.hs @@ -0,0 +1,9 @@ +module API where + +data Interface = Interface { + valueOf :: String -> String +} + +plugin :: Interface +plugin = Interface { valueOf = id } + diff --git a/examples/multi/3plugins/prog/Main.hs b/examples/multi/3plugins/prog/Main.hs new file mode 100644 index 0000000..9ef6175 --- /dev/null +++ b/examples/multi/3plugins/prog/Main.hs @@ -0,0 +1,13 @@ +import Plugins +import API + +main = do + let plist = ["../Plugin1.o", "../Plugin2.o", "../Plugin3.o"] + plugins <- mapM (\p -> load p ["../api"] [] "resource") plist + let functions = map (valueOf . fromLoadSuc) plugins + + -- apply the function from each plugin in turn + mapM_ (\f -> putStrLn $ f "haskell is for hackers") functions + +fromLoadSuc (LoadFailure _) = error "load failed" +fromLoadSuc (LoadSuccess _ v) = v diff --git a/examples/multi/3plugins/prog/expected b/examples/multi/3plugins/prog/expected new file mode 100644 index 0000000..d0ae0cf --- /dev/null +++ b/examples/multi/3plugins/prog/expected @@ -0,0 +1,3 @@ +HASKELL IS FOR HACKERS +[104,97,115,107,101,108,108,32,105,115,32,102,111,114,32,104,97,99,107,101,114,115] +srekcah rof si lleksah diff --git a/examples/objc/expression_parser/ArithmeticExpressionParser.hs b/examples/objc/expression_parser/ArithmeticExpressionParser.hs new file mode 100644 index 0000000..74fbdc7 --- /dev/null +++ b/examples/objc/expression_parser/ArithmeticExpressionParser.hs @@ -0,0 +1,30 @@ +module ArithmeticExpressionParser where + +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Expr + +resource :: String -> IO String +resource text = do + parsedText <- mapM parseString (lines text) + return (unlines parsedText) + +parseString s = do + case (parse expr "" s) of + Left err -> return ("Error " ++ show err) + Right num -> return (show num) + +expr :: Parser Integer +expr = buildExpressionParser table factor "expression" + +table = [ [op "*" (*) AssocLeft, op "/" div AssocLeft] + , [op "+" (+) AssocLeft, op "-" (-) AssocLeft] ] + where + op s f assoc = Infix (do { string s; return f }) assoc + +factor = do { char '('; x <- expr; char ')'; return x } + <|> number + "simple expression" + +number :: Parser Integer +number = do { ds <- many1 digit; return (read ds) } "number" + diff --git a/examples/objc/expression_parser/English.lproj/Credits.rtf b/examples/objc/expression_parser/English.lproj/Credits.rtf new file mode 100644 index 0000000..46576ef --- /dev/null +++ b/examples/objc/expression_parser/English.lproj/Credits.rtf @@ -0,0 +1,29 @@ +{\rtf0\ansi{\fonttbl\f0\fswiss Helvetica;} +{\colortbl;\red255\green255\blue255;} +\paperw9840\paperh8400 +\pard\tx560\tx1120\tx1680\tx2240\tx2800\tx3360\tx3920\tx4480\tx5040\tx5600\tx6160\tx6720\ql\qnatural + +\f0\b\fs24 \cf0 Engineering: +\b0 \ + Some people\ +\ + +\b Human Interface Design: +\b0 \ + Some other people\ +\ + +\b Testing: +\b0 \ + Hopefully not nobody\ +\ + +\b Documentation: +\b0 \ + Whoever\ +\ + +\b With special thanks to: +\b0 \ + Mom\ +} diff --git a/examples/objc/expression_parser/English.lproj/InfoPlist.strings b/examples/objc/expression_parser/English.lproj/InfoPlist.strings new file mode 100644 index 0000000000000000000000000000000000000000..f21c27024b919bf094fe9b237e6530c20288ce78 GIT binary patch literal 568 zcmbV|OAo<76ot>)uV^eqykaLd#4ABW6I-cQ2}N22KOWxQE#st}L~p4wTw)bYC~C*#h?y-BXbyr43tF{{VapaO6n$z0;x%ry6U dL0_)gq!(Ds5dR)2dz#p!lT@CWCr$p)e*kAeV-^4a literal 0 HcmV?d00001 diff --git a/examples/objc/expression_parser/English.lproj/MainMenu.nib/classes.nib b/examples/objc/expression_parser/English.lproj/MainMenu.nib/classes.nib new file mode 100644 index 0000000..b9b4b09 --- /dev/null +++ b/examples/objc/expression_parser/English.lproj/MainMenu.nib/classes.nib @@ -0,0 +1,4 @@ +{ + IBClasses = ({CLASS = FirstResponder; LANGUAGE = ObjC; SUPERCLASS = NSObject; }); + IBVersion = 1; +} \ No newline at end of file diff --git a/examples/objc/expression_parser/English.lproj/MainMenu.nib/info.nib b/examples/objc/expression_parser/English.lproj/MainMenu.nib/info.nib new file mode 100644 index 0000000..138ebce --- /dev/null +++ b/examples/objc/expression_parser/English.lproj/MainMenu.nib/info.nib @@ -0,0 +1,21 @@ + + + + + IBDocumentLocation + 116 123 356 240 0 0 1600 1178 + IBEditorPositions + + 29 + 117 405 318 44 0 0 1600 1178 + + IBFramework Version + 328.0 + IBOpenObjects + + 29 + + IBSystem Version + 7B8 + + diff --git a/examples/objc/expression_parser/English.lproj/MainMenu.nib/objects.nib b/examples/objc/expression_parser/English.lproj/MainMenu.nib/objects.nib new file mode 100644 index 0000000000000000000000000000000000000000..f265b7f1d0863305470b34b61dd0d0ac10247664 GIT binary patch literal 5248 zcma)AeQXrR6`$kI#$PPB5U`3shfuLx2MOZR#uODBQ-afSc6>>rMwQy-JeY;M-Rs_- z4Jb`AbZ-^4RX;3ygq@>t-Ig$=rKKOZr3KRBmRt$6p!^XeBpUueCm|srBqWd!eQ$Qp zz7Ni4`;Xmy@Ap3E&CGijsJ9NrX@9~psTyPctnKTtZCeS2ySMf1-bW+WcGXfD`JZjq zgu*U`q=sEcS2AH4F_+jfVlU`G(Z!+guB4^zj?%DYYWjdrN_y`jwy$+jDBKy3N41D* zX@>5k9NVXTiGySvNK!r7ZP6H8@a_m2sdh<>d^lnUw2qDrVjmd`?9lXn$92Io)oGgQ zL1NnrLAQJz8Lt|)-x*HZi$JQo8$~-dYal*0wh+Z{y>-lici$f8Fj+##;WwW=c|ua4 zb4e)dhSf(CM$(MXmJyCZkdT-(#ZapYVLQOlzoi92OJPa&Mxf$?GIb3 zMS4I$6LJ%$-{69-|_67hwe_&6+xbhGirWGo)Ej9C@Z@V*jBCi4L(1)= zM{$v=Uxg@*A;+E=4-B8i=%=LGnq8W%#k4~*lfGCvZLYxK_X)w25$9a~GGUTDtFwwf zwGFE+*cpwY(>qKxq20-qdnB5dW0r&yWrWmmSO&?Yr@nV)Ie`Z0w-spgwmLWLBs^tVlk{mPS#xv zxnJgQdFf8ApBCo|6#Mqh9T^r^y_D^-_EOW`TPV{sb0(A|8f9w2dyOHiwUS5+6F%QX zS^82^D_Lvw|J&vK$Fwy-+OX7UUe4Sigd;LaOMEL>1s9U5xvZ=?KUACC<$5`@Sf4I- zVNaauxdJjOpy%iv_UlJVRU_ExrE(+fwel@o}U6M!2;rr9gSFZXMuCvm}o2P7m{ii%w6z$a!WBb1!;%B%yM3ZsqgMgWGBqn|Bv4Ef?9%S4}uhqfxkjOI)2@ z=+D9e`_bc8xxn=~kz74(p37xdMv*;NFefR~_{GX%pDq*&s)^v&jb!j;Xnafj&7I#^ z#D#^N>u8>yjVWjN0{T-AC(lf0;Pn(cX*6D9Xf`p}(n?6~tZSDET3UGZ2VDrP?bdP; zqrcPqdWJVE{OlCJmf`Iec=k3YS-wW$)1!RTG{2SMO$xu0<(D)3{1mUv@{?)4p_Qkb z`TcwR;xxaJ;U8V&TiUrl%NrGbCBxS$e5Jx4W_gRk?`HYU3_q3T%M?DfiBG2agZn&l zkvB~9sw{t$7&pUig zA@p+&zu*~51IL>>9DW5p{2QMGAF7eP$>AFc1wqvvC|-iL-gni4!^yXF9UeKeTbw9NO^f~ zbNK2)3dFKyE58NAz()9Ucyl2iG_NnDeBR+}fs$`%gTo)A8=!s?SOqR;xAL=FxgXdI zHUjQsp)!!DMM+Rvg-=LOOOf(6IC*Rv&3S_+wP5zE!XDBhFk*HS08EUpLDVy$a7f$T z1=E0OMB$;sIAoZN{6`MCF3Y7gj@bT=j*c@au(~u(O&FMBIIO5v(u8?sGhS-@kDo{O zVikr=eSmiBa?bEr)yPuJq>h*CSJi{izI&W4$f-?0&xo7YBR)XlGZAcPidq#9a0}PA z&Z1^a(_xnMsF#qs$}sz>DUHLNsrRd9zZ@5ORh>pX;Ehp8+w#587|Y%^Zzf52i0g=` zLWD=SDMgYxlAyVLibxYW9f-_Cwi>^y<9MlgI+h`&%7hEqBdkS2T|y3`pwy!_N>~yu zd5^GC5+ZPydW7{zSd2+~AxRU7{LnTaONrnBp1TV?p|%u+wAwNT2BH)fUDJ~=GE0!W z1mKGDkdF|#$XjRG=6Q@e$Y{{%P_A|K=y#=n0bOhnMbVZUq*Jkn_-HF&|`2Jh65aaOw1fsf7Inh!PvEpOoErZY{F0R&RVZA9n z20na_GxAS(j4<*KcuX*o5&J$PPB8MGc-SK@Z5CB8ia|!cFJ5Ql2q2Czas?g^BYzM# z82O1f1R;nOjHJbCMox(P-w~u&=*@un9wUDeR~h+{xYH-HFNskf5P!|cRdMzk0_?s6 zpJ_(^B^ns{xtIiB#5zV!0`-TCoP!5v(d=8q*pm literal 0 HcmV?d00001 diff --git a/examples/objc/expression_parser/English.lproj/MyDocument.nib/classes.nib b/examples/objc/expression_parser/English.lproj/MyDocument.nib/classes.nib new file mode 100644 index 0000000..17cfa47 --- /dev/null +++ b/examples/objc/expression_parser/English.lproj/MyDocument.nib/classes.nib @@ -0,0 +1,13 @@ +{ + IBClasses = ( + {CLASS = FirstResponder; LANGUAGE = ObjC; SUPERCLASS = NSObject; }, + { + ACTIONS = {chooseParser = id; evaluateExpression = id; }; + CLASS = MyDocument; + LANGUAGE = ObjC; + OUTLETS = {evaluation = id; expressionEntry = id; parser = id; }; + SUPERCLASS = NSDocument; + } + ); + IBVersion = 1; +} \ No newline at end of file diff --git a/examples/objc/expression_parser/English.lproj/MyDocument.nib/info.nib b/examples/objc/expression_parser/English.lproj/MyDocument.nib/info.nib new file mode 100644 index 0000000..285ee38 --- /dev/null +++ b/examples/objc/expression_parser/English.lproj/MyDocument.nib/info.nib @@ -0,0 +1,16 @@ + + + + + IBDocumentLocation + 79 43 356 240 0 0 1280 832 + IBFramework Version + 349.0 + IBOpenObjects + + 21 + + IBSystem Version + 7F44 + + diff --git a/examples/objc/expression_parser/English.lproj/MyDocument.nib/keyedobjects.nib b/examples/objc/expression_parser/English.lproj/MyDocument.nib/keyedobjects.nib new file mode 100644 index 0000000000000000000000000000000000000000..291235bb565c8cdcc057f5fa3edb9d63d0cbfd51 GIT binary patch literal 7470 zcma)A34Bvk)<5TFPm|_l4`r)mmr|Q9v_%ElvK44SQd$bdnzo^hO_P$OKrPjaBBFyU z&r%9HaizKvym*5jbd5sJi7O?9G1)S z*=SbCD%cE|$!4;P*evFQRjiWDW>u`3&0#fcE}O?{*?e{}t7DhU9vp5Dg-%KqFheR> zKmse+zzz;@f(zW>fj*E1eW4%phXF7U(%~G)fI%=AhQLr52E$B<0K%Qd{4uj4mz;LM5xxsI>l5A#R)4*qxk$RTn=CX9kC+Mv8n?3k;$YHoSQ zgh)esYakpy1YXF2T*#ZFC<(;oDi>jz+YNb;e=#j?kHsUcirsUP8#n|7B)<@fXunyp zcr+MpqWzYYltvmN{vLmFt)k(4xL_?@02e~Oyp8hqxSyQjlb4Z5<>C;GBa!2wgglYR z#MlE+%=P?+H(>%ygh?15NhBem<2wlgxOF9)i4KYU~Zjct?(&M z_r*IxfpULL39j<2#NW_D7L)De!LToQS%5;Jj8q2Wq24>$Zxjt>Y!=0xZhQ^VKp-q` z#Crb{vA$aR3i+D^w!{NjjFc)d{wHqaDcr!XP$Dm6_g|Q;?gPo>!RN)m10;nL@S)LZS4DOWLA=m>{+Enf_>uNG@rZ5{x=1 zsubFefFJ6if!xzb*bl%0@~5x8ei02RC=&Rb6^OM(!i|Awbprl8m9OO2Dluq=g_|G< zmqH7KpcTRpfi`a8X?!@(R>JBzY2)4h44#g2<;!?`(KU2nls=z`1P3gEB|u7s;d z_;R=!R=_o|60U{o=<_GCZ53P(H^7Z>6Wk29)Je7q-^@TX7-hBuQ)_E zVShYO)=D{AC)q1}J&!1pmK>b)rIHWipC0`E9z}m46m5g;ye}Wd`_)OV z&d$Od%8Vj8GrZnB!c0L|*Kv3>0g^O=#}0zWV+4(z1lq?56i>jDq@ArNh{Xe~wG9fIN zJTNUgYqauL1d>W|=mB`9o2u z|3}1563HYY#z)RiLOqrqkBs@fns;P1@A6SROIG70%FNBlmMJqYKQn!_x2x;*9$1$@Lt>5)e3VorGr`Od#jQCKA{JCC5I>K5dz0)F_>_|Dvy9?w%BF0Ipg3@NIFcUd zrQtT2hSOt#5EX+!w|{Fhr?CJq+@OTzO&$(13^xRj5V{q@h++2h^b+4QRv^G|{!05=ImvqDH~6gtaMD zSREppZn1+3^A5m4wWI0Fain=7Bg032R>?v)J#v)NZmXG7p zBsIU7&$k+Y`xT`FVBrJkdIQr%WyEtZ1E%3194xCFfCDOXiimd|Me4QDi#fFCT-s|MofGnj&Z>ir@n#Y(q=;?GtT5f*5ou3$v_f5} zQc+5qC@B9x@{i+8ya;EZ4=ZWc zvtb8TVKp2i+vi{neY@)<2bJLj1@ssb6MdCv0p&KNEKKd1I5Wu5s*~IzrVIS-p*Urb zzbWc(YnIzodGhpNxTRN)yvK5Xw1v*B$?eDZbnD0uc_pt&kUh?m$=*wc%yBrM?7SHL z*hnU1wa_`E8|&~AK7(J>jrG{T%XtO&omo+KH6 zs_U7H2>Bbnw`D|WA88KTlrXfQ0 zVO%TI|WE621y|IrcSMr1m3{N?1HWur4ms_ zD7IaJ*&8S^I4)D#m3fH@Cvt&$BO#5d1oh>_(sF?j`BX#&<}fbDtI4Pplt|YQ+NVU~ zzP5s9;q~kAdPTA5Izz!Wq4&5<95>=k z368p1=BQhUr&i;i@m9P|%x#a#=RabLN`JH|5T^^J5z83IDN7sVMv~LJ5gy=l2z7LJ zjuM2g6dfv(Vh^=-jgcgwj#2z^7v8-d?@rc!Qj{D&ai&qIqMhH1y@uU~M)Je0ct5To zUr-y|K+MdWGR8$+rMy`_*^KgLlYa3n{8&ge+gm73Hq_bW2*Zl<6#vo@fC^N?U+Zu^ z{Z~9hjh14J@KFz+pH*Zw%0*@qZpH`YBC`cIp_zwxE5C*>=gSmY*ec4xCftG#_J}#F zENp`|Xv6JP7PiY};bBo0c$h~xS42E2m}UF_BKgNi`X=0okK+?PB>yCD<5%!S{Bpi9 zNz3_X(eic_uW#~s^h|<%EoL0+#^X3%NWua(z=62?INs>3Gh$N+T=4Rz(=M?4yM&=e$sqDQ;K=2)W zw;SIT>_T-c@p>T8+7_ZptSEdRKUj+&;D<87C0}X;;zU%w07Xay=3`j65kJ9C@iY7! zzrZi?D}EDS&2Qzm^Sk&x{Jtaj4Sq}W{skHM9sV1NshCa(#Nt6Zv{Jnw3ZL$;4}>Vk zeUWy`Eq*hX)jJYmAdlQurS!PHBN~4G0g9-ZIIhrrK#-Eh})T2w&mWr32o$;-cc8mZOC!$F|^h%I;#(_R%@98bbU5#atIo?H2ukvce-)i1!)dUmJZg=o6t&F;puv z(!`7~NeRiXNm_+W3ZRhQqRi+=GgyB%fDL5n>>QTC2C>0x2ph_VvEh6@-@rHWO?)$d zkZ<7+@vZzXd>h|R{HYw6y@`%WK6!cn>n_Jj(G;~w9?S9OR4Kru6}=RhBeMg`hN9X@ z!BAjWEPcjeY7uGW8FS7OV~#aFSIR{Jb8M3w0>0#eOKFP{{EA!>h9G`P4rsy8 zpp^jb!cU+Ww<~Lk=r8{xpAvKg*xvyZCPYJm16r%J=dY_&)wOzTb*YE4ri~t=P|seXKaZiaP0g zEB3ddM*7K$4l8P@$+u#f6(x!0_Eo~`XZ78zUT*)&N|YCwqO+#A{(b1pa3;M39YZe^ zFQV6njj#ZJC4`sI3+cHm#4cki*=_7zwvj!>_OoN`6#IgGr_!kmsuY!3Wl>pGc9m1* zQKhN+sRpRhRT-+ms-dd$ROhQMRE<+jRryr4swP!P)u~#px?Xj=>Os{*s>f8%s1B-L zQ@ySFRP}}GE7dpZLFxi^ncAoJt0U^A>TA`j)oaubs&}fNP(P)9M*W<6w|b9yuX>+) zzxpNh%j#FvpK0_Ot0qk|P?N1WUsJA`t*O@3Xy$1eHSL-YKLlzv@^6d+D2_uyG(nd_5tly?Jn&B?LqA;+C$nS z+GE<2+EdzhwI69e(SE7@L1)lOI=3!eH$*o~H$pd3SEwu2P12R?Ds-2H`QvFK(t@^e4 z_4453D>6GaU(~oAA*=cs0`t{2n>);%=9|p-nKzlAHa~0LWq#g#(EN(|kogVsd*;tm z4XFcChozpInwvT%wJi0b)VZm3sm-aasW+sqPu-fjJM~2B=N4vBTXYtKCB@>g^tBAP zWLxqr1(qVqSj%`ziDiPN#xl>+VY$I_lVzP{tK|{PF3SPStCqu-qm~nvH!c6Pd}8_D z@~fnl%#uwSA&r*COJ!1(R4)akE2LG@ZPHq4y|hus>@5$he+ZtFVhX6qK~KI=*AN7k>cr)?u`qipBdytZ6hzHO{+ zqAhBR+ZNfD*p}Ir+a9((YJ1G~xa~>X)3z6ECv0!pzP5d9`_9hnYP;F)viGr%v0q>x zYoBJHX`f}UwEOJ~?9KL8d&Iub-f6$t{)l~teW(4T{gnM(`_B%Wqpu^wF~%{`QSWGR zv^lPFta7Y&tZ{5`Y;!#4*zMTk*z4Hm*zb7JalrAG<5S1Cj$a(7o!~S$ZO%T~^>_+#}tE z?#b>dcb)qZchDVm-|ODse${>0eboJ$`*rsl?zh}0-KX5|y5Dzy=>FLKsrz&Hm+r6K z-@3nZfA9X${fqlI4|>!doyX`gdn_KC$LVo<(mee=>7GHJp`PKMk)AwH5xpU%KgJTj L4a#rw+cV`q`bV3S literal 0 HcmV?d00001 diff --git a/examples/objc/expression_parser/English.lproj/MyDocument.nib/objects.nib b/examples/objc/expression_parser/English.lproj/MyDocument.nib/objects.nib new file mode 100644 index 0000000000000000000000000000000000000000..b4b3512203f1eba0b6d737189d5be54781006a05 GIT binary patch literal 2952 zcma)8U1%It6uvjR*=~}J$)-smtv`VlVikl`@FAexcH3ydZlqfbwFKGDPU@J=PMDoF z%~N}~cLsbNHbcgSr9`Z>+m@0PrGeBS(RLzKQTim-B?L4=d=vkm_1t@B|B?!wWoBpY zJ^$Z1=N^BHJ~=KYGrA@x#)$7%iX)WLr(*FV2M15RFH8ENgq|R%L}@S<7c0oH1W7cT z(bX}rxHnH5B8(Nt;<~1!PvbnrFE$^YJfuq5F*&W9hDos!vVo>07C$bZ(FYVcmF%Xp zDHe~aXWNb+`GBS+ zCK09EVsY`BcY@4Pu;^e`*VQz-U=q2V5@U>WR3{fZ<-5C#D>ROX1v zsnmY{eL&I`HO;=m+(!0x0DM-IoF6|#xgbJ_`k8HXdOCRcgG4Hu&}9>ZfkOk}U02@O zLmN-N{E9Rj0NR~!KYWDVL|G&u1tn1ey^b_^rr})%S$L$CVhI&-5f%NWVSuWBh`eFV z(xyyCQJAU-L3g`x&dfy~fmXz{wZ-CII6M^Cx^dYsO^be1asL>>y;>L{EnIegR(KBV z6=ax;uU)$2`4>UxQ&7@!_{_K_g8^!~-@I%XSGi5ssZWYTSm+@5Q8lFkV8sCSiEsqs zlNnteGl4xM37|QRN#~0`+AuP5e*X(sir8e|fw`MN*6xupTdJh<2xv@z3ilgz?hIxh z-E1uRJQFRtL0J<2?j1yq6SW?Vm3;=UO z4=KFz651rnI}MCJ4Aq&CMo(*MHk}mN!I(tm?8?X~=vs1;iQG)~83>)8E~hAbl)1vS zTteh6$h2GYU~vvj+vn!B-padW0E*&=JVY6)-fhwE90<~5)imjqdOg3ygPTt}&7ZDieAX@)CDAuQnyzU8_`=V&7P+n-ga@ zkI`;x6-2Y&*2KBTLjS)R@_juf_v_K!`K0JVBQ2vg#4Q@KN?^?zyBF^LD1dpu-Pr;J zBdo-+w20B|O5B%;@Gld^*(o+qi1aBAC=Ek3gBN0@;k;sg~vDC9g zH#=OQRD@I$+MS>GlY)V%p9uxO8WHhDiWrc-PY{7hYM4KN_UxnI`NN#DmkajFvVFZ^ z7dGt0f)lcrKqky4VtD8??G^a0ZC3UoEVR~~n0-JrD-01#rhR=A$vz-)U=1cL)}iY({z%$=o7F^XP4Fpr*RA@j+$-SAL!HG1qdV3AX>I^Cg$u)eSZb2;8sO#g+ z1E!qvs37Zbb~nQ01}`wS9l_QHkX&@Ou_n_Qi^r5xgIPT#!(p6GLwi-B-F(aYJ?vE0 z!uh$4DNq(nLJvO8#vc&ko15aUO>n%u6&AR_xHz!5EnQp(NMci9MIb2g&&@KC9kMr3 zRe@)sTIQD6Zb;%spmzcar93ts7Yr+&Vg_NGTp3{wgT6^VQ#hS4zbefHce$+u?{EtZ z?sbCxc1r|5?Jg7C?LzfD>rP>JiQsMSEJ1&|Z3I8#E)v}6E)evO8zi{XbqEf)0fIZ+ q6@quV4FtEl8(r=i!MkAVIR{w)WBZYVQB_hC16pECo=~+>)BF#R*0Ib0 literal 0 HcmV?d00001 diff --git a/examples/objc/expression_parser/Info.plist b/examples/objc/expression_parser/Info.plist new file mode 100644 index 0000000..f746309 --- /dev/null +++ b/examples/objc/expression_parser/Info.plist @@ -0,0 +1,47 @@ + + + + + CFBundleDevelopmentRegion + English + CFBundleDocumentTypes + + + CFBundleTypeExtensions + + ???? + + CFBundleTypeIconFile + + CFBundleTypeName + DocumentType + CFBundleTypeOSTypes + + ???? + + CFBundleTypeRole + Editor + NSDocumentClass + MyDocument + + + CFBundleExecutable + PluginExpressionParser + CFBundleIconFile + + CFBundleIdentifier + com.apple.yourCocoaDocApp + CFBundleInfoDictionaryVersion + 6.0 + CFBundlePackageType + APPL + CFBundleSignature + ???? + CFBundleVersion + 0.1 + NSMainNibFile + MainMenu + NSPrincipalClass + NSApplication + + diff --git a/examples/objc/expression_parser/KeyValueParser.hs b/examples/objc/expression_parser/KeyValueParser.hs new file mode 100644 index 0000000..dada1a1 --- /dev/null +++ b/examples/objc/expression_parser/KeyValueParser.hs @@ -0,0 +1,33 @@ +module KeyValueParser where + +import Text.ParserCombinators.Parsec + +parseKeyValue = do + key <- parseKey + char '=' + value <- parseValue + return (key, value) + +parseKey = many1 letter + +parseValue = + do + openQuote <- char '"' <|> char '\'' + value <- many1 letter + char openQuote + return value + <|> + do + value <- many1 letter + return value + +parseString s = do + case (parse parseKeyValue "" s) of + Left err -> return ("Error " ++ show err) + Right (key, value) -> return ("Key: " ++ key ++ ", Value: " ++ value) + +resource :: String -> IO String +resource text = do + parsedText <- mapM parseString (lines text) + return (unlines parsedText) + diff --git a/examples/objc/expression_parser/Makefile b/examples/objc/expression_parser/Makefile new file mode 100644 index 0000000..5b368d7 --- /dev/null +++ b/examples/objc/expression_parser/Makefile @@ -0,0 +1,67 @@ +APP_DIR = build/PluginExpressionParser.app +APP_CONTENTS_DIR = $(APP_DIR)/Contents +APP_ARCH_EXEC_DIR = $(APP_CONTENTS_DIR)/MacOS +APP_RESOURCES_DIR = $(APP_CONTENTS_DIR)/Resources +EXECUTABLE = $(APP_ARCH_EXEC_DIR)/PluginExpressionParser + +OBJECT_FILES = main.o MyDocument.o PluginEvalAux.o +BUILD_OBJECT_FILES = $(addprefix build/,$(OBJECT_FILES)) \ + build/PluginEvalAux_stub.o + +HOST = $(shell uname) + +ifeq ($(HOST),Darwin) +default: app +else +default: no_app +endif + +app: $(APP_CONTENTS_DIR) $(APP_RESOURCES_DIR) $(EXECUTABLE) + +# + +$(EXECUTABLE): $(APP_ARCH_EXEC_DIR) $(BUILD_OBJECT_FILES) + ghc \ + -o "$(EXECUTABLE)" \ + -framework Cocoa \ + -package-conf ../../../plugins.conf.inplace \ + -package plugins \ + -no-hs-main \ + $(BUILD_OBJECT_FILES) + +build/MyDocument.o: MyDocument.m MyDocument.h + gcc -c -o "$@" -Wall -I`ghc --print-libdir`/include "$<" + +build/main.o: main.m + gcc -c -o "$@" -Wall -I`ghc --print-libdir`/include "$<" + +build/PluginEvalAux.o: PluginEvalAux.hs + ghc --make \ + -package-conf ../../../plugins.conf.inplace \ + -package plugins \ + -odir build/ \ + -hidir build/ \ + "$<" + +# + +$(APP_DIR): + mkdir -p "$@" + +$(APP_ARCH_EXEC_DIR): $(APP_DIR) + mkdir -p "$@" + +$(APP_CONTENTS_DIR): $(APP_DIR) Info.plist + mkdir -p "$(APP_CONTENTS_DIR)" + cp Info.plist "$@" + echo -n 'APPL????' > "$@"/PkgInfo + +$(APP_RESOURCES_DIR): $(APP_DIR) English.lproj + mkdir -p "$(APP_RESOURCES_DIR)" + cp -R English.lproj "$@" + +# + +clean: + -rm -rf build *_stub.? + diff --git a/examples/objc/expression_parser/MyDocument.h b/examples/objc/expression_parser/MyDocument.h new file mode 100644 index 0000000..6d0585f --- /dev/null +++ b/examples/objc/expression_parser/MyDocument.h @@ -0,0 +1,16 @@ +/* MyDocument */ + +#import + +#include "RunHaskell.h" + +@interface MyDocument : NSDocument +{ + IBOutlet id evaluation; + IBOutlet id expressionEntry; + IBOutlet id parser; +} +- (IBAction)chooseParser:(id)sender; +- (IBAction)evaluateExpression:(id)sender; + +@end diff --git a/examples/objc/expression_parser/MyDocument.m b/examples/objc/expression_parser/MyDocument.m new file mode 100644 index 0000000..b79b767 --- /dev/null +++ b/examples/objc/expression_parser/MyDocument.m @@ -0,0 +1,52 @@ +#import "MyDocument.h" + +@implementation MyDocument + +- (NSString *)windowNibName { + return @"MyDocument"; +} + +- (NSData *)dataRepresentationOfType:(NSString *)type { + return nil; +} + +- (BOOL)loadDataRepresentation:(NSData *)data ofType:(NSString *)type { + return NO; +} + + +- (IBAction)chooseParser:(id)sender +{ + int result; + NSArray *fileTypes = [NSArray arrayWithObject:@"hs"]; + NSOpenPanel *oPanel = [NSOpenPanel openPanel]; + + result = [oPanel runModalForDirectory:nil file:nil types:fileTypes]; + if (result == NSOKButton) + { + NSArray *filesToOpen = [oPanel filenames]; + [parser setStringValue:[filesToOpen objectAtIndex:0]]; + } +} + +- (IBAction)evaluateExpression:(id)sender +{ + NSLog(@"evaluateExpression"); + NSString *filePathNSS = [parser stringValue]; + char *filePath = [filePathNSS cString]; + + NSString *expressionNSS = [[expressionEntry textStorage] string]; + char *expression = [expressionNSS cString]; + + NSLog (@"filePath:%s expression:%s", filePath, expression); + + char *result = evalhaskell_CString(filePath, expression); + NSString *resultNSS = [NSString stringWithCString:result]; + NSAttributedString *resultNSAS = [[NSAttributedString alloc] + initWithString:resultNSS + attributes:nil]; + [[evaluation textStorage] setAttributedString:resultNSAS]; + +} + +@end diff --git a/examples/objc/expression_parser/PluginEvalAux.hs b/examples/objc/expression_parser/PluginEvalAux.hs new file mode 100644 index 0000000..3ffbefb --- /dev/null +++ b/examples/objc/expression_parser/PluginEvalAux.hs @@ -0,0 +1,43 @@ +{-# OPTIONS -fglasgow-exts -fffi #-} + +module PluginEvalAux where + +import Plugins.Make +import Plugins.Load +import Plugins.Utils + +import Foreign.C +import Control.Exception ( evaluate ) +import System.IO +import System.Directory ( renameFile, removeFile ) + +symbol = "resource" + +evalWithStringResult :: FilePath -> String -> IO String +evalWithStringResult srcFile s = do + status <- make srcFile ["-Onot"] + case status of + MakeFailure err -> putStrLn "error occured" >> return (show err) + MakeSuccess _ obj -> load' obj + where + load' obj = do + loadResult <- load obj [] [] symbol + case loadResult of + LoadFailure errs -> putStrLn "load error" >> return (show errs) + LoadSuccess m (rsrc :: String -> IO String) -> do + v' <- rsrc s + unload m + mapM_ removeFile [ obj, replaceSuffix obj ".hi" ] + return v' + +foreign export ccall evalhaskell_CString :: CString -> CString -> IO CString + +evalhaskell_CString :: CString -> CString -> IO CString +evalhaskell_CString filePathCS sCS = do + s <- peekCString sCS + filePath <- peekCString filePathCS + retval <- evalWithStringResult filePath s + newCString retval + +-- vi:sw=2 sts=2 + diff --git a/examples/objc/expression_parser/PluginExpressionParser.xcode/project.pbxproj b/examples/objc/expression_parser/PluginExpressionParser.xcode/project.pbxproj new file mode 100644 index 0000000..ede92e6 --- /dev/null +++ b/examples/objc/expression_parser/PluginExpressionParser.xcode/project.pbxproj @@ -0,0 +1,602 @@ +// !$*UTF8*$! +{ + archiveVersion = 1; + classes = { + }; + objectVersion = 39; + objects = { + 089C165FFE840EACC02AAC07 = { + children = ( + 089C1660FE840EACC02AAC07, + ); + isa = PBXVariantGroup; + name = InfoPlist.strings; + refType = 4; + sourceTree = ""; + }; + 089C1660FE840EACC02AAC07 = { + fileEncoding = 10; + isa = PBXFileReference; + lastKnownFileType = text.plist.strings; + name = English; + path = English.lproj/InfoPlist.strings; + refType = 4; + sourceTree = ""; + }; +//080 +//081 +//082 +//083 +//084 +//100 +//101 +//102 +//103 +//104 + 1058C7A6FEA54F5311CA2CBB = { + children = ( + 1058C7A7FEA54F5311CA2CBB, + ); + isa = PBXGroup; + name = "Linked Frameworks"; + refType = 4; + sourceTree = ""; + }; + 1058C7A7FEA54F5311CA2CBB = { + fallbackIsa = PBXFileReference; + isa = PBXFrameworkReference; + lastKnownFileType = wrapper.framework; + name = Cocoa.framework; + path = /System/Library/Frameworks/Cocoa.framework; + refType = 0; + sourceTree = ""; + }; + 1058C7A8FEA54F5311CA2CBB = { + children = ( + 2A37F4C5FDCFA73011CA2CEA, + 2A37F4C4FDCFA73011CA2CEA, + ); + isa = PBXGroup; + name = "Other Frameworks"; + refType = 4; + sourceTree = ""; + }; +//100 +//101 +//102 +//103 +//104 +//190 +//191 +//192 +//193 +//194 + 19C28FB0FE9D524F11CA2CBB = { + children = ( + 8D15AC370486D014006FF6A4, + ); + isa = PBXGroup; + name = Products; + refType = 4; + sourceTree = ""; + }; +//190 +//191 +//192 +//193 +//194 +//2A0 +//2A1 +//2A2 +//2A3 +//2A4 + 2A37F4A9FDCFA73011CA2CEA = { + buildSettings = { + }; + buildStyles = ( + 4A9504D0FFE6A4CB11CA0CBA, + 4A9504D1FFE6A4CB11CA0CBA, + ); + hasScannedForEncodings = 1; + isa = PBXProject; + mainGroup = 2A37F4AAFDCFA73011CA2CEA; + projectDirPath = ""; + targets = ( + 8D15AC270486D014006FF6A4, + 7B5F81A4067389B000AC9FA4, + ); + }; + 2A37F4AAFDCFA73011CA2CEA = { + children = ( + 7B5F81A1067383A700AC9FA4, + 7B5F81980673839D00AC9FA4, + 2A37F4ABFDCFA73011CA2CEA, + 2A37F4AFFDCFA73011CA2CEA, + 2A37F4B8FDCFA73011CA2CEA, + 2A37F4C3FDCFA73011CA2CEA, + 19C28FB0FE9D524F11CA2CBB, + ); + isa = PBXGroup; + name = PluginExpressionParser; + path = ""; + refType = 4; + sourceTree = ""; + }; + 2A37F4ABFDCFA73011CA2CEA = { + children = ( + 2A37F4AEFDCFA73011CA2CEA, + 2A37F4ACFDCFA73011CA2CEA, + ); + isa = PBXGroup; + name = Classes; + path = ""; + refType = 4; + sourceTree = ""; + }; + 2A37F4ACFDCFA73011CA2CEA = { + fileEncoding = 30; + isa = PBXFileReference; + lastKnownFileType = sourcecode.c.objc; + path = MyDocument.m; + refType = 4; + sourceTree = ""; + }; + 2A37F4AEFDCFA73011CA2CEA = { + fileEncoding = 30; + isa = PBXFileReference; + lastKnownFileType = sourcecode.c.h; + path = MyDocument.h; + refType = 4; + sourceTree = ""; + }; + 2A37F4AFFDCFA73011CA2CEA = { + children = ( + 7B5F81990673839D00AC9FA4, + 32DBCF750370BD2300C91783, + 7B5F819506737AAC00AC9FA4, + 2A37F4B0FDCFA73011CA2CEA, + ); + isa = PBXGroup; + name = "Other Sources"; + path = ""; + refType = 4; + sourceTree = ""; + }; + 2A37F4B0FDCFA73011CA2CEA = { + fileEncoding = 30; + isa = PBXFileReference; + lastKnownFileType = sourcecode.c.objc; + path = main.m; + refType = 4; + sourceTree = ""; + }; + 2A37F4B4FDCFA73011CA2CEA = { + children = ( + 2A37F4B5FDCFA73011CA2CEA, + ); + isa = PBXVariantGroup; + name = MyDocument.nib; + path = ""; + refType = 4; + sourceTree = ""; + }; + 2A37F4B5FDCFA73011CA2CEA = { + isa = PBXFileReference; + lastKnownFileType = wrapper.nib; + name = English; + path = English.lproj/MyDocument.nib; + refType = 4; + sourceTree = ""; + }; + 2A37F4B6FDCFA73011CA2CEA = { + children = ( + 2A37F4B7FDCFA73011CA2CEA, + ); + isa = PBXVariantGroup; + name = MainMenu.nib; + path = ""; + refType = 4; + sourceTree = ""; + }; + 2A37F4B7FDCFA73011CA2CEA = { + isa = PBXFileReference; + lastKnownFileType = wrapper.nib; + name = English; + path = English.lproj/MainMenu.nib; + refType = 4; + sourceTree = ""; + }; + 2A37F4B8FDCFA73011CA2CEA = { + children = ( + 2A37F4B9FDCFA73011CA2CEA, + 2A37F4B6FDCFA73011CA2CEA, + 2A37F4B4FDCFA73011CA2CEA, + 8D15AC360486D014006FF6A4, + 089C165FFE840EACC02AAC07, + ); + isa = PBXGroup; + name = Resources; + path = ""; + refType = 4; + sourceTree = ""; + }; + 2A37F4B9FDCFA73011CA2CEA = { + children = ( + 2A37F4BAFDCFA73011CA2CEA, + ); + isa = PBXVariantGroup; + name = Credits.rtf; + path = ""; + refType = 4; + sourceTree = ""; + }; + 2A37F4BAFDCFA73011CA2CEA = { + isa = PBXFileReference; + lastKnownFileType = text.rtf; + name = English; + path = English.lproj/Credits.rtf; + refType = 4; + sourceTree = ""; + }; + 2A37F4C3FDCFA73011CA2CEA = { + children = ( + 1058C7A6FEA54F5311CA2CBB, + 1058C7A8FEA54F5311CA2CBB, + ); + isa = PBXGroup; + name = Frameworks; + path = ""; + refType = 4; + sourceTree = ""; + }; + 2A37F4C4FDCFA73011CA2CEA = { + fallbackIsa = PBXFileReference; + isa = PBXFrameworkReference; + lastKnownFileType = wrapper.framework; + name = AppKit.framework; + path = /System/Library/Frameworks/AppKit.framework; + refType = 0; + sourceTree = ""; + }; + 2A37F4C5FDCFA73011CA2CEA = { + fallbackIsa = PBXFileReference; + isa = PBXFrameworkReference; + lastKnownFileType = wrapper.framework; + name = Foundation.framework; + path = /System/Library/Frameworks/Foundation.framework; + refType = 0; + sourceTree = ""; + }; +//2A0 +//2A1 +//2A2 +//2A3 +//2A4 +//320 +//321 +//322 +//323 +//324 + 32DBCF750370BD2300C91783 = { + fileEncoding = 4; + isa = PBXFileReference; + lastKnownFileType = sourcecode.c.h; + path = PluginExpressionParser_Prefix.pch; + refType = 4; + sourceTree = ""; + }; +//320 +//321 +//322 +//323 +//324 +//4A0 +//4A1 +//4A2 +//4A3 +//4A4 + 4A9504D0FFE6A4CB11CA0CBA = { + buildRules = ( + ); + buildSettings = { + COPY_PHASE_STRIP = NO; + DEBUGGING_SYMBOLS = YES; + GCC_DYNAMIC_NO_PIC = NO; + GCC_ENABLE_FIX_AND_CONTINUE = YES; + GCC_GENERATE_DEBUGGING_SYMBOLS = YES; + GCC_OPTIMIZATION_LEVEL = 0; + OPTIMIZATION_CFLAGS = "-O0"; + ZERO_LINK = YES; + }; + isa = PBXBuildStyle; + name = Development; + }; + 4A9504D1FFE6A4CB11CA0CBA = { + buildRules = ( + ); + buildSettings = { + COPY_PHASE_STRIP = YES; + GCC_ENABLE_FIX_AND_CONTINUE = NO; + ZERO_LINK = NO; + }; + isa = PBXBuildStyle; + name = Deployment; + }; +//4A0 +//4A1 +//4A2 +//4A3 +//4A4 +//7B0 +//7B1 +//7B2 +//7B3 +//7B4 + 7B5F819506737AAC00AC9FA4 = { + fileEncoding = 30; + isa = PBXFileReference; + lastKnownFileType = sourcecode.c.h; + path = RunHaskell.h; + refType = 4; + sourceTree = ""; + }; + 7B5F819606737AAC00AC9FA4 = { + fileRef = 7B5F819506737AAC00AC9FA4; + isa = PBXBuildFile; + settings = { + }; + }; + 7B5F81970673839D00AC9FA4 = { + fileEncoding = 30; + isa = PBXFileReference; + lastKnownFileType = sourcecode.haskell; + path = KeyValueParser.hs; + refType = 4; + sourceTree = ""; + }; + 7B5F81980673839D00AC9FA4 = { + fileEncoding = 30; + isa = PBXFileReference; + lastKnownFileType = sourcecode.make; + path = Makefile; + refType = 4; + sourceTree = ""; + }; + 7B5F81990673839D00AC9FA4 = { + fileEncoding = 30; + isa = PBXFileReference; + lastKnownFileType = sourcecode.haskell; + path = PluginEvalAux.hs; + refType = 4; + sourceTree = ""; + }; + 7B5F819A0673839D00AC9FA4 = { + fileRef = 7B5F81970673839D00AC9FA4; + isa = PBXBuildFile; + settings = { + }; + }; + 7B5F819B0673839D00AC9FA4 = { + fileRef = 7B5F81980673839D00AC9FA4; + isa = PBXBuildFile; + settings = { + }; + }; + 7B5F819C0673839D00AC9FA4 = { + fileRef = 7B5F81990673839D00AC9FA4; + isa = PBXBuildFile; + settings = { + }; + }; + 7B5F819D067383A400AC9FA4 = { + fileEncoding = 30; + isa = PBXFileReference; + lastKnownFileType = sourcecode.haskell; + path = ArithmeticExpressionParser.hs; + refType = 4; + sourceTree = ""; + }; + 7B5F819E067383A400AC9FA4 = { + fileRef = 7B5F819D067383A400AC9FA4; + isa = PBXBuildFile; + settings = { + }; + }; + 7B5F81A1067383A700AC9FA4 = { + children = ( + 7B5F819D067383A400AC9FA4, + 7B5F81970673839D00AC9FA4, + ); + isa = PBXGroup; + name = Parsers; + refType = 4; + sourceTree = ""; + }; + 7B5F81A4067389B000AC9FA4 = { + buildArgumentsString = "$(ACTION)"; + buildPhases = ( + ); + buildSettings = { + OPTIMIZATION_CFLAGS = ""; + OTHER_CFLAGS = ""; + OTHER_LDFLAGS = ""; + OTHER_REZFLAGS = ""; + PRODUCT_NAME = "PluginExpressionParser (GNU make)"; + SECTORDER_FLAGS = ""; + WARNING_CFLAGS = "-Wmost -Wno-four-char-constants -Wno-unknown-pragmas"; + }; + buildToolPath = /usr/bin/make; + dependencies = ( + ); + isa = PBXLegacyTarget; + name = "PluginExpressionParser (GNU make)"; + passBuildSettingsInEnvironment = 1; + productName = "PluginExpressionParser (GNU make)"; + }; +//7B0 +//7B1 +//7B2 +//7B3 +//7B4 +//8D0 +//8D1 +//8D2 +//8D3 +//8D4 + 8D15AC270486D014006FF6A4 = { + buildPhases = ( + 8D15AC280486D014006FF6A4, + 8D15AC2B0486D014006FF6A4, + 8D15AC300486D014006FF6A4, + 8D15AC330486D014006FF6A4, + ); + buildRules = ( + ); + buildSettings = { + FRAMEWORK_SEARCH_PATHS = ""; + GCC_ENABLE_TRIGRAPHS = NO; + GCC_GENERATE_DEBUGGING_SYMBOLS = NO; + GCC_PRECOMPILE_PREFIX_HEADER = YES; + GCC_PREFIX_HEADER = PluginExpressionParser_Prefix.pch; + GCC_WARN_ABOUT_MISSING_PROTOTYPES = NO; + GCC_WARN_FOUR_CHARACTER_CONSTANTS = NO; + GCC_WARN_UNKNOWN_PRAGMAS = NO; + HEADER_SEARCH_PATHS = ""; + INFOPLIST_FILE = Info.plist; + INSTALL_PATH = "$(HOME)/Applications"; + LIBRARY_SEARCH_PATHS = ""; + OTHER_CFLAGS = ""; + OTHER_LDFLAGS = ""; + PRODUCT_NAME = PluginExpressionParser; + SECTORDER_FLAGS = ""; + WARNING_CFLAGS = "-Wmost -Wno-four-char-constants -Wno-unknown-pragmas"; + WRAPPER_EXTENSION = app; + }; + dependencies = ( + ); + isa = PBXNativeTarget; + name = PluginExpressionParser; + productInstallPath = "$(HOME)/Applications"; + productName = PluginExpressionParser; + productReference = 8D15AC370486D014006FF6A4; + productType = "com.apple.product-type.application"; + }; + 8D15AC280486D014006FF6A4 = { + buildActionMask = 2147483647; + files = ( + 8D15AC290486D014006FF6A4, + 8D15AC2A0486D014006FF6A4, + 7B5F819606737AAC00AC9FA4, + ); + isa = PBXHeadersBuildPhase; + runOnlyForDeploymentPostprocessing = 0; + }; + 8D15AC290486D014006FF6A4 = { + fileRef = 32DBCF750370BD2300C91783; + isa = PBXBuildFile; + settings = { + }; + }; + 8D15AC2A0486D014006FF6A4 = { + fileRef = 2A37F4AEFDCFA73011CA2CEA; + isa = PBXBuildFile; + settings = { + }; + }; + 8D15AC2B0486D014006FF6A4 = { + buildActionMask = 2147483647; + files = ( + 8D15AC2C0486D014006FF6A4, + 8D15AC2D0486D014006FF6A4, + 8D15AC2E0486D014006FF6A4, + 8D15AC2F0486D014006FF6A4, + 7B5F819A0673839D00AC9FA4, + 7B5F819B0673839D00AC9FA4, + 7B5F819C0673839D00AC9FA4, + 7B5F819E067383A400AC9FA4, + ); + isa = PBXResourcesBuildPhase; + runOnlyForDeploymentPostprocessing = 0; + }; + 8D15AC2C0486D014006FF6A4 = { + fileRef = 2A37F4B9FDCFA73011CA2CEA; + isa = PBXBuildFile; + settings = { + }; + }; + 8D15AC2D0486D014006FF6A4 = { + fileRef = 2A37F4B6FDCFA73011CA2CEA; + isa = PBXBuildFile; + settings = { + }; + }; + 8D15AC2E0486D014006FF6A4 = { + fileRef = 2A37F4B4FDCFA73011CA2CEA; + isa = PBXBuildFile; + settings = { + }; + }; + 8D15AC2F0486D014006FF6A4 = { + fileRef = 089C165FFE840EACC02AAC07; + isa = PBXBuildFile; + settings = { + }; + }; + 8D15AC300486D014006FF6A4 = { + buildActionMask = 2147483647; + files = ( + 8D15AC310486D014006FF6A4, + 8D15AC320486D014006FF6A4, + ); + isa = PBXSourcesBuildPhase; + runOnlyForDeploymentPostprocessing = 0; + }; + 8D15AC310486D014006FF6A4 = { + fileRef = 2A37F4ACFDCFA73011CA2CEA; + isa = PBXBuildFile; + settings = { + ATTRIBUTES = ( + ); + }; + }; + 8D15AC320486D014006FF6A4 = { + fileRef = 2A37F4B0FDCFA73011CA2CEA; + isa = PBXBuildFile; + settings = { + ATTRIBUTES = ( + ); + }; + }; + 8D15AC330486D014006FF6A4 = { + buildActionMask = 2147483647; + files = ( + 8D15AC340486D014006FF6A4, + ); + isa = PBXFrameworksBuildPhase; + runOnlyForDeploymentPostprocessing = 0; + }; + 8D15AC340486D014006FF6A4 = { + fileRef = 1058C7A7FEA54F5311CA2CBB; + isa = PBXBuildFile; + settings = { + }; + }; + 8D15AC360486D014006FF6A4 = { + fileEncoding = 4; + isa = PBXFileReference; + lastKnownFileType = text.plist; + path = Info.plist; + refType = 4; + sourceTree = ""; + }; + 8D15AC370486D014006FF6A4 = { + explicitFileType = wrapper.application; + includeInIndex = 0; + isa = PBXFileReference; + path = PluginExpressionParser.app; + refType = 3; + sourceTree = BUILT_PRODUCTS_DIR; + }; + }; + rootObject = 2A37F4A9FDCFA73011CA2CEA; +} diff --git a/examples/objc/expression_parser/PluginExpressionParser_Prefix.pch b/examples/objc/expression_parser/PluginExpressionParser_Prefix.pch new file mode 100644 index 0000000..4d1db1d --- /dev/null +++ b/examples/objc/expression_parser/PluginExpressionParser_Prefix.pch @@ -0,0 +1,7 @@ +// +// Prefix header for all source files of the 'PluginExpressionParser' target in the 'PluginExpressionParser' project +// + +#ifdef __OBJC__ + #import +#endif diff --git a/examples/objc/expression_parser/README b/examples/objc/expression_parser/README new file mode 100644 index 0000000..eb902c3 --- /dev/null +++ b/examples/objc/expression_parser/README @@ -0,0 +1,6 @@ +This little application is an example of using hs-plugins to embed a Haskell +'interpreter' inside an Objective-C, Cocoa-based program. You will need Mac OS +X for this to be of any use! + +To build it, type 'make', which will build a .app bundle in the build/ directory. Or, 'open *.xcode', and hit the build button in there. + diff --git a/examples/objc/expression_parser/RunHaskell.h b/examples/objc/expression_parser/RunHaskell.h new file mode 100644 index 0000000..40c781d --- /dev/null +++ b/examples/objc/expression_parser/RunHaskell.h @@ -0,0 +1,4 @@ +#include "HsFFI.h" + +extern HsPtr evalhaskell_CString(HsPtr a1, HsPtr a2); + diff --git a/examples/objc/expression_parser/dont_test b/examples/objc/expression_parser/dont_test new file mode 100644 index 0000000..e69de29 diff --git a/examples/objc/expression_parser/main.m b/examples/objc/expression_parser/main.m new file mode 100644 index 0000000..26b35dd --- /dev/null +++ b/examples/objc/expression_parser/main.m @@ -0,0 +1,26 @@ +// +// main.m +// PluginExpressionParser +// +// Created by AndrŽ Pang on Mon Jun 07 2004. +// Copyright (c) 2004 __MyCompanyName__. All rights reserved. +// + +#import + +#include "HsFFI.h" + +extern void __stginit_PluginEvalAux (void); + +int main(int argc, char *argv[]) +{ + hs_init(&argc, &argv); + hs_add_root(__stginit_PluginEvalAux); + const char *c_argv = (const char *) argv; + int retval = NSApplicationMain(argc, &c_argv); + hs_exit(); + return retval; +} + +/* vi:sw=4 */ + diff --git a/examples/objc/expression_parser/version.plist b/examples/objc/expression_parser/version.plist new file mode 100644 index 0000000..a293201 --- /dev/null +++ b/examples/objc/expression_parser/version.plist @@ -0,0 +1,16 @@ + + + + + BuildVersion + 17 + CFBundleShortVersionString + 0.1 + CFBundleVersion + 0.1 + ProjectName + NibPBTemplates + SourceVersion + 1150000 + + diff --git a/examples/pdynload/badint/Makefile b/examples/pdynload/badint/Makefile new file mode 100644 index 0000000..3b2a729 --- /dev/null +++ b/examples/pdynload/badint/Makefile @@ -0,0 +1,5 @@ + +TEST=pdynload/badint + +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/badint/Plugin.hs b/examples/pdynload/badint/Plugin.hs new file mode 100644 index 0000000..8cfe36d --- /dev/null +++ b/examples/pdynload/badint/Plugin.hs @@ -0,0 +1,4 @@ +module Plugin where + +resource :: Num t => t +resource = 0xBAD diff --git a/examples/pdynload/badint/api/API.hs b/examples/pdynload/badint/api/API.hs new file mode 100644 index 0000000..7198219 --- /dev/null +++ b/examples/pdynload/badint/api/API.hs @@ -0,0 +1,9 @@ +module API where + +data Interface = Interface { + transform :: String -> String + } + +rsrc :: Interface +rsrc = Interface { transform = id } + diff --git a/examples/pdynload/badint/prog/Main.hs b/examples/pdynload/badint/prog/Main.hs new file mode 100644 index 0000000..e60e2bf --- /dev/null +++ b/examples/pdynload/badint/prog/Main.hs @@ -0,0 +1,18 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e-> mapM_ putStrLn e + + where f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ a -> putStrLn $ (transform a) "foo" + _ -> putStrLn "wrong types" + diff --git a/examples/pdynload/badint/prog/expected b/examples/pdynload/badint/prog/expected new file mode 100644 index 0000000..7a0bcf2 --- /dev/null +++ b/examples/pdynload/badint/prog/expected @@ -0,0 +1 @@ +wrong types diff --git a/examples/pdynload/null/Makefile b/examples/pdynload/null/Makefile new file mode 100644 index 0000000..3589848 --- /dev/null +++ b/examples/pdynload/null/Makefile @@ -0,0 +1,4 @@ + +TEST= pdynload/null +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/null/Plugin.hs b/examples/pdynload/null/Plugin.hs new file mode 100644 index 0000000..465d956 --- /dev/null +++ b/examples/pdynload/null/Plugin.hs @@ -0,0 +1,5 @@ +module Plugin where + +import API + +resource = D 1 diff --git a/examples/pdynload/null/api/API.hs b/examples/pdynload/null/api/API.hs new file mode 100644 index 0000000..a3b8d8e --- /dev/null +++ b/examples/pdynload/null/api/API.hs @@ -0,0 +1,5 @@ + +module API where + +data Num t => Interface t = D t + diff --git a/examples/pdynload/null/prog/Main.hs b/examples/pdynload/null/prog/Main.hs new file mode 100644 index 0000000..3c3f831 --- /dev/null +++ b/examples/pdynload/null/prog/Main.hs @@ -0,0 +1,19 @@ + +import Plugins +import Plugins.Utils +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e-> mapM_ putStrLn e + + where f = do v <- load "../Plugin.o" ["../api"] [] "resource" + -- (i,_) <- exec "ghc" ["--numeric-version"] + -- mapM_ putStrLn i + putStrLn "done." + diff --git a/examples/pdynload/null/prog/expected b/examples/pdynload/null/prog/expected new file mode 100644 index 0000000..70ff8e5 --- /dev/null +++ b/examples/pdynload/null/prog/expected @@ -0,0 +1 @@ +done. diff --git a/examples/pdynload/numclass/Makefile b/examples/pdynload/numclass/Makefile new file mode 100644 index 0000000..6681e6a --- /dev/null +++ b/examples/pdynload/numclass/Makefile @@ -0,0 +1,4 @@ + +TEST= pdynload/numclass +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/numclass/Plugin.hs b/examples/pdynload/numclass/Plugin.hs new file mode 100644 index 0000000..fcbd7b8 --- /dev/null +++ b/examples/pdynload/numclass/Plugin.hs @@ -0,0 +1,5 @@ +module Plugin where + +-- import API + +resource = "error" diff --git a/examples/pdynload/numclass/api/API.hs b/examples/pdynload/numclass/api/API.hs new file mode 100644 index 0000000..a3b8d8e --- /dev/null +++ b/examples/pdynload/numclass/api/API.hs @@ -0,0 +1,5 @@ + +module API where + +data Num t => Interface t = D t + diff --git a/examples/pdynload/numclass/prog/Main.hs b/examples/pdynload/numclass/prog/Main.hs new file mode 100644 index 0000000..0f4f515 --- /dev/null +++ b/examples/pdynload/numclass/prog/Main.hs @@ -0,0 +1,19 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeFailure _ -> putStrLn "make failed" + MakeSuccess _ _ -> do { + + ;v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface Integer" "resource" + ;case v of + LoadSuccess _ a -> let D i = snd a in putStrLn $ show i + _ -> putStrLn "wrong types" + + } diff --git a/examples/pdynload/numclass/prog/expected b/examples/pdynload/numclass/prog/expected new file mode 100644 index 0000000..7a0bcf2 --- /dev/null +++ b/examples/pdynload/numclass/prog/expected @@ -0,0 +1 @@ +wrong types diff --git a/examples/pdynload/poly/Makefile b/examples/pdynload/poly/Makefile new file mode 100644 index 0000000..ebdb53b --- /dev/null +++ b/examples/pdynload/poly/Makefile @@ -0,0 +1,5 @@ + +TEST=pdynload/poly + +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/poly/Plugin.hs b/examples/pdynload/poly/Plugin.hs new file mode 100644 index 0000000..c65d495 --- /dev/null +++ b/examples/pdynload/poly/Plugin.hs @@ -0,0 +1,9 @@ +module Plugin where + +import Data.Generics.Schemes + +import API + +resource = rsrc { + field = id listify +} diff --git a/examples/pdynload/poly/api/API.hs b/examples/pdynload/poly/api/API.hs new file mode 100644 index 0000000..1cabdab --- /dev/null +++ b/examples/pdynload/poly/api/API.hs @@ -0,0 +1,12 @@ +{-# OPTIONS -fglasgow-exts #-} +-- a really nasty type: + +module API where + +import Data.Generics + +data Interface = Interface { field :: Typeable r => (r -> Bool) -> GenericQ [r] } + +rsrc :: Interface +rsrc = Interface { field = listify } + diff --git a/examples/pdynload/poly/prog/Main.hs b/examples/pdynload/poly/prog/Main.hs new file mode 100644 index 0000000..00c61a1 --- /dev/null +++ b/examples/pdynload/poly/prog/Main.hs @@ -0,0 +1,17 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e -> mapM_ putStrLn e + + where f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ a -> putStrLn "loaded .. yay!" + _ -> putStrLn "wrong types" diff --git a/examples/pdynload/poly/prog/expected b/examples/pdynload/poly/prog/expected new file mode 100644 index 0000000..9fed8f0 --- /dev/null +++ b/examples/pdynload/poly/prog/expected @@ -0,0 +1 @@ +loaded .. yay! diff --git a/examples/pdynload/poly1/Makefile b/examples/pdynload/poly1/Makefile new file mode 100644 index 0000000..6d6440e --- /dev/null +++ b/examples/pdynload/poly1/Makefile @@ -0,0 +1,4 @@ +TEST= pdynload/poly1 +EXTRA_OBJS=Plugin.o +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/poly1/Plugin.hs b/examples/pdynload/poly1/Plugin.hs new file mode 100644 index 0000000..af7585e --- /dev/null +++ b/examples/pdynload/poly1/Plugin.hs @@ -0,0 +1,5 @@ +module Plugin where + +import API + +resource = plugin { function = (+) } diff --git a/examples/pdynload/poly1/api/API.hs b/examples/pdynload/poly1/api/API.hs new file mode 100644 index 0000000..c551700 --- /dev/null +++ b/examples/pdynload/poly1/api/API.hs @@ -0,0 +1,9 @@ +module API where + +data Interface = Interface { + function :: (Num a) => a -> a -> a +} + +plugin :: Interface +plugin = Interface { function = error "no function defined" } + diff --git a/examples/pdynload/poly1/prog/Main.hs b/examples/pdynload/poly1/prog/Main.hs new file mode 100644 index 0000000..98c72e7 --- /dev/null +++ b/examples/pdynload/poly1/prog/Main.hs @@ -0,0 +1,18 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e -> mapM_ putStrLn e + + where f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ a -> let fn = function a in putStrLn $ show $ 1 `fn` 2 + _ -> putStrLn "wrong types" + diff --git a/examples/pdynload/poly1/prog/expected b/examples/pdynload/poly1/prog/expected new file mode 100644 index 0000000..00750ed --- /dev/null +++ b/examples/pdynload/poly1/prog/expected @@ -0,0 +1 @@ +3 diff --git a/examples/pdynload/should_fail0/Makefile b/examples/pdynload/should_fail0/Makefile new file mode 100644 index 0000000..30ef2c1 --- /dev/null +++ b/examples/pdynload/should_fail0/Makefile @@ -0,0 +1,4 @@ +TEST= pdynload/should_fail0 +EXTRA_OBJS=Plugin.o +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/should_fail0/Plugin.hs b/examples/pdynload/should_fail0/Plugin.hs new file mode 100644 index 0000000..f7998f9 --- /dev/null +++ b/examples/pdynload/should_fail0/Plugin.hs @@ -0,0 +1,9 @@ +module Plugin where + +import API + +resource = 0xBAD :: Int + +-- resource = tiny { +-- field = "hello strange world" +-- } diff --git a/examples/pdynload/should_fail0/api/API.hs b/examples/pdynload/should_fail0/api/API.hs new file mode 100644 index 0000000..ad0a0a3 --- /dev/null +++ b/examples/pdynload/should_fail0/api/API.hs @@ -0,0 +1,13 @@ +{-# OPTIONS -fglasgow-exts #-} +-- ^ needed to derive Typeable + +module API where + +import Data.Dynamic + +data Interface = Interface { field :: String } + deriving (Show) + +rsrc :: Interface +rsrc = Interface { field = "default value" } + diff --git a/examples/pdynload/should_fail0/prog/Main.hs b/examples/pdynload/should_fail0/prog/Main.hs new file mode 100644 index 0000000..ed9bb2c --- /dev/null +++ b/examples/pdynload/should_fail0/prog/Main.hs @@ -0,0 +1,18 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e -> mapM_ putStrLn e + where + f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ a -> putStrLn "loaded .. yay!" + _ -> putStrLn "wrong types" + diff --git a/examples/pdynload/should_fail0/prog/expected b/examples/pdynload/should_fail0/prog/expected new file mode 100644 index 0000000..7a0bcf2 --- /dev/null +++ b/examples/pdynload/should_fail0/prog/expected @@ -0,0 +1 @@ +wrong types diff --git a/examples/pdynload/should_fail1/Makefile b/examples/pdynload/should_fail1/Makefile new file mode 100644 index 0000000..207da6e --- /dev/null +++ b/examples/pdynload/should_fail1/Makefile @@ -0,0 +1,5 @@ +# Missing class constraint... can't do that in Clean + +TEST= pdynload/should_fail1 +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/should_fail1/Plugin.hs b/examples/pdynload/should_fail1/Plugin.hs new file mode 100644 index 0000000..c73d571 --- /dev/null +++ b/examples/pdynload/should_fail1/Plugin.hs @@ -0,0 +1,5 @@ +module Plugin where + +data I = I Int + +resource = I 1 diff --git a/examples/pdynload/should_fail1/api/API.hs b/examples/pdynload/should_fail1/api/API.hs new file mode 100644 index 0000000..50380ee --- /dev/null +++ b/examples/pdynload/should_fail1/api/API.hs @@ -0,0 +1,8 @@ + +module API where + +newtype Interface = I Int + +rsrc :: Interface +rsrc = I 1 + diff --git a/examples/pdynload/should_fail1/prog/Main.hs b/examples/pdynload/should_fail1/prog/Main.hs new file mode 100644 index 0000000..5b02b81 --- /dev/null +++ b/examples/pdynload/should_fail1/prog/Main.hs @@ -0,0 +1,17 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e -> mapM_ putStrLn e + + where f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ a -> putStrLn "loaded .. yay!" + _ -> putStrLn "wrong types" diff --git a/examples/pdynload/should_fail1/prog/expected b/examples/pdynload/should_fail1/prog/expected new file mode 100644 index 0000000..7a0bcf2 --- /dev/null +++ b/examples/pdynload/should_fail1/prog/expected @@ -0,0 +1 @@ +wrong types diff --git a/examples/pdynload/small/Makefile b/examples/pdynload/small/Makefile new file mode 100644 index 0000000..c142a87 --- /dev/null +++ b/examples/pdynload/small/Makefile @@ -0,0 +1,4 @@ +TEST= pdynload/small +EXTRA_OBJS=Plugin.o +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/small/Plugin.hs b/examples/pdynload/small/Plugin.hs new file mode 100644 index 0000000..a30c85d --- /dev/null +++ b/examples/pdynload/small/Plugin.hs @@ -0,0 +1,5 @@ +module Plugin where + +import API + +resource = plugin { function = "good" } diff --git a/examples/pdynload/small/api/API.hs b/examples/pdynload/small/api/API.hs new file mode 100644 index 0000000..101d6d9 --- /dev/null +++ b/examples/pdynload/small/api/API.hs @@ -0,0 +1,9 @@ +module API where + +data Interface = Interface { + function :: String +} + +plugin :: Interface +plugin = Interface { function = "goodbye" } + diff --git a/examples/pdynload/small/prog/Main.hs b/examples/pdynload/small/prog/Main.hs new file mode 100644 index 0000000..001c5da --- /dev/null +++ b/examples/pdynload/small/prog/Main.hs @@ -0,0 +1,18 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e -> mapM_ putStrLn e + + where f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ a -> putStrLn "loaded .. yay!" + _ -> putStrLn "wrong types" + diff --git a/examples/pdynload/small/prog/expected b/examples/pdynload/small/prog/expected new file mode 100644 index 0000000..9fed8f0 --- /dev/null +++ b/examples/pdynload/small/prog/expected @@ -0,0 +1 @@ +loaded .. yay! diff --git a/examples/pdynload/spj1/Makefile b/examples/pdynload/spj1/Makefile new file mode 100644 index 0000000..b0cfd89 --- /dev/null +++ b/examples/pdynload/spj1/Makefile @@ -0,0 +1,5 @@ + +TEST=pdynload/spj1 + +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/spj1/Plugin.hs b/examples/pdynload/spj1/Plugin.hs new file mode 100644 index 0000000..d753ed9 --- /dev/null +++ b/examples/pdynload/spj1/Plugin.hs @@ -0,0 +1,17 @@ +module Plugin where + +-- user doesn't import the API +-- and provides a polymorphic value + +-- import API +-- resource :: Interface + +-- +-- should pass type check, and dump core +-- +-- resource :: Num a => a + +-- import API + +resource :: Num a => a +resource = 7 diff --git a/examples/pdynload/spj1/api/API.hs b/examples/pdynload/spj1/api/API.hs new file mode 100644 index 0000000..111fc82 --- /dev/null +++ b/examples/pdynload/spj1/api/API.hs @@ -0,0 +1,9 @@ + +module API where + +-- data Interface = Interface { field :: Int } + +-- newtype Interface = Interface Int + +type Interface = Int + diff --git a/examples/pdynload/spj1/dont_test b/examples/pdynload/spj1/dont_test new file mode 100644 index 0000000..e69de29 diff --git a/examples/pdynload/spj1/prog/Main.hs b/examples/pdynload/spj1/prog/Main.hs new file mode 100644 index 0000000..7cea83c --- /dev/null +++ b/examples/pdynload/spj1/prog/Main.hs @@ -0,0 +1,17 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e -> mapM_ putStrLn e + + where f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ (a :: Interface) -> print $ a -- will crash + LoadFailure es -> putStrLn $ show es diff --git a/examples/pdynload/spj1/prog/expected b/examples/pdynload/spj1/prog/expected new file mode 100644 index 0000000..e69de29 diff --git a/examples/pdynload/spj2/Makefile b/examples/pdynload/spj2/Makefile new file mode 100644 index 0000000..b0cfd89 --- /dev/null +++ b/examples/pdynload/spj2/Makefile @@ -0,0 +1,5 @@ + +TEST=pdynload/spj1 + +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/spj2/Plugin.hs b/examples/pdynload/spj2/Plugin.hs new file mode 100644 index 0000000..eca2a0d --- /dev/null +++ b/examples/pdynload/spj2/Plugin.hs @@ -0,0 +1,13 @@ +module Plugin where + +-- user doesn't import the API +-- and provides a polymorphic value + +import API +resource :: Interface + +-- +-- should pass type check, and dump core +-- +-- resource :: Num a => a +resource = 7 diff --git a/examples/pdynload/spj2/api/API.hs b/examples/pdynload/spj2/api/API.hs new file mode 100644 index 0000000..cd017bf --- /dev/null +++ b/examples/pdynload/spj2/api/API.hs @@ -0,0 +1,6 @@ + +module API where + +-- simple type +type Interface = Int + diff --git a/examples/pdynload/spj2/prog/Main.hs b/examples/pdynload/spj2/prog/Main.hs new file mode 100644 index 0000000..3eb236e --- /dev/null +++ b/examples/pdynload/spj2/prog/Main.hs @@ -0,0 +1,17 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e -> mapM_ putStrLn e + + where f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ (a :: Interface) -> putStrLn $ show a -- will crash + LoadFailure es -> putStrLn $ show es diff --git a/examples/pdynload/spj2/prog/expected b/examples/pdynload/spj2/prog/expected new file mode 100644 index 0000000..7f8f011 --- /dev/null +++ b/examples/pdynload/spj2/prog/expected @@ -0,0 +1 @@ +7 diff --git a/examples/pdynload/spj3/Makefile b/examples/pdynload/spj3/Makefile new file mode 100644 index 0000000..79e5015 --- /dev/null +++ b/examples/pdynload/spj3/Makefile @@ -0,0 +1,3 @@ +TEST= pdynload/spj3 +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/spj3/Plugin.hs b/examples/pdynload/spj3/Plugin.hs new file mode 100644 index 0000000..b1f6297 --- /dev/null +++ b/examples/pdynload/spj3/Plugin.hs @@ -0,0 +1,5 @@ +module Plugin where + +import API + +resource = plugin { function = (+) :: Int -> Int -> Int } diff --git a/examples/pdynload/spj3/api/API.hs b/examples/pdynload/spj3/api/API.hs new file mode 100644 index 0000000..c551700 --- /dev/null +++ b/examples/pdynload/spj3/api/API.hs @@ -0,0 +1,9 @@ +module API where + +data Interface = Interface { + function :: (Num a) => a -> a -> a +} + +plugin :: Interface +plugin = Interface { function = error "no function defined" } + diff --git a/examples/pdynload/spj3/prog/Main.hs b/examples/pdynload/spj3/prog/Main.hs new file mode 100644 index 0000000..98c72e7 --- /dev/null +++ b/examples/pdynload/spj3/prog/Main.hs @@ -0,0 +1,18 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e -> mapM_ putStrLn e + + where f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ a -> let fn = function a in putStrLn $ show $ 1 `fn` 2 + _ -> putStrLn "wrong types" + diff --git a/examples/pdynload/spj3/prog/expected b/examples/pdynload/spj3/prog/expected new file mode 100644 index 0000000..72db92b --- /dev/null +++ b/examples/pdynload/spj3/prog/expected @@ -0,0 +1,8 @@ + +../Plugin.hs:5: + Cannot unify the type-signature variable `a' with the type `Int' + Expected type: a -> a -> a + Inferred type: Int -> Int -> Int + When checking the type signature of the expression: + (+) :: Int -> Int -> Int + In the `function' field of a record diff --git a/examples/pdynload/spj3/prog/expected.604 b/examples/pdynload/spj3/prog/expected.604 new file mode 100644 index 0000000..6e0b917 --- /dev/null +++ b/examples/pdynload/spj3/prog/expected.604 @@ -0,0 +1,9 @@ + +../Plugin.hs:5:31: + Couldn't match the rigid variable `a' against `Int' + `a' is bound by the polymorphic type `forall a. (Num a) => a -> a -> a' + at ../Plugin.hs:5:11-56 + Expected type: a -> a -> a + Inferred type: Int -> Int -> Int + In the expression: (+) :: Int -> Int -> Int + In the `function' field of a record diff --git a/examples/pdynload/spj4/Makefile b/examples/pdynload/spj4/Makefile new file mode 100644 index 0000000..95fe9fe --- /dev/null +++ b/examples/pdynload/spj4/Makefile @@ -0,0 +1,5 @@ + +TEST=pdynload/spj4 + +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/spj4/Plugin.hs b/examples/pdynload/spj4/Plugin.hs new file mode 100644 index 0000000..e81f688 --- /dev/null +++ b/examples/pdynload/spj4/Plugin.hs @@ -0,0 +1,16 @@ +module Plugin where + +-- user doesn't import the API +-- and provides a polymorphic value + +-- import API +-- resource :: Interface + +-- +-- should pass type check, and dump core +-- +-- resource :: Num a => a + +import API + +resource = Interface { field = 7 :: Num a => a } diff --git a/examples/pdynload/spj4/api/API.hs b/examples/pdynload/spj4/api/API.hs new file mode 100644 index 0000000..ae5a35a --- /dev/null +++ b/examples/pdynload/spj4/api/API.hs @@ -0,0 +1,5 @@ + +module API where + +newtype Interface = Interface { field :: Int } + diff --git a/examples/pdynload/spj4/prog/Main.hs b/examples/pdynload/spj4/prog/Main.hs new file mode 100644 index 0000000..7a138e1 --- /dev/null +++ b/examples/pdynload/spj4/prog/Main.hs @@ -0,0 +1,17 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e -> error "there was a type error" + + where f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ (a :: Interface) -> print $ field a -- will crash + LoadFailure es -> mapM_ putStrLn es diff --git a/examples/pdynload/spj4/prog/expected b/examples/pdynload/spj4/prog/expected new file mode 100644 index 0000000..7f8f011 --- /dev/null +++ b/examples/pdynload/spj4/prog/expected @@ -0,0 +1 @@ +7 diff --git a/examples/pdynload/typealias/Makefile b/examples/pdynload/typealias/Makefile new file mode 100644 index 0000000..dfd644b --- /dev/null +++ b/examples/pdynload/typealias/Makefile @@ -0,0 +1,5 @@ +# Missing class constraint... can't do that in Clean + +TEST= pdynload/typealias +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/typealias/Plugin.hs b/examples/pdynload/typealias/Plugin.hs new file mode 100644 index 0000000..de60ef2 --- /dev/null +++ b/examples/pdynload/typealias/Plugin.hs @@ -0,0 +1,3 @@ +module Plugin where + +resource = 1 :: Int diff --git a/examples/pdynload/typealias/api/API.hs b/examples/pdynload/typealias/api/API.hs new file mode 100644 index 0000000..8502215 --- /dev/null +++ b/examples/pdynload/typealias/api/API.hs @@ -0,0 +1,8 @@ + +module API where + +type Interface = Int + +rsrc :: Interface +rsrc = 1 + diff --git a/examples/pdynload/typealias/prog/Main.hs b/examples/pdynload/typealias/prog/Main.hs new file mode 100644 index 0000000..9f30df5 --- /dev/null +++ b/examples/pdynload/typealias/prog/Main.hs @@ -0,0 +1,19 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e -> mapM_ putStrLn e + + where f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ a -> putStrLn "loaded .. yay!" + _ -> putStrLn "wrong types" + + diff --git a/examples/pdynload/typealias/prog/expected b/examples/pdynload/typealias/prog/expected new file mode 100644 index 0000000..9fed8f0 --- /dev/null +++ b/examples/pdynload/typealias/prog/expected @@ -0,0 +1 @@ +loaded .. yay! diff --git a/examples/pdynload/univquant/Makefile b/examples/pdynload/univquant/Makefile new file mode 100644 index 0000000..e96b597 --- /dev/null +++ b/examples/pdynload/univquant/Makefile @@ -0,0 +1,4 @@ +TEST= pdynload/univquant +EXTRA_OBJS=Plugin.o +TOP=../../.. +include ../../build.mk diff --git a/examples/pdynload/univquant/Plugin.hs b/examples/pdynload/univquant/Plugin.hs new file mode 100644 index 0000000..8e88cea --- /dev/null +++ b/examples/pdynload/univquant/Plugin.hs @@ -0,0 +1,8 @@ +module Plugin where + +import API + +resource = plugin { function = my_id } + +my_id :: forall a. a -> a +my_id x = x diff --git a/examples/pdynload/univquant/api/API.hs b/examples/pdynload/univquant/api/API.hs new file mode 100644 index 0000000..31bdac8 --- /dev/null +++ b/examples/pdynload/univquant/api/API.hs @@ -0,0 +1,9 @@ +module API where + +data Interface = Interface { + function :: forall a. a -> a +} + +plugin :: Interface +plugin = Interface { function = id } + diff --git a/examples/pdynload/univquant/prog/Main.hs b/examples/pdynload/univquant/prog/Main.hs new file mode 100644 index 0000000..7aca2d4 --- /dev/null +++ b/examples/pdynload/univquant/prog/Main.hs @@ -0,0 +1,17 @@ + +import Plugins +import API + +src = "../Plugin.hs" +wrap = "../Wrapper.hs" +apipath = "../api" + +main = do status <- make src ["-i"++apipath] + case status of + MakeSuccess _ _ -> f + MakeFailure e -> mapM_ putStrLn e + + where f = do v <- pdynload "../Plugin.o" ["../api"] [] "API.Interface" "resource" + case v of + LoadSuccess _ a -> putStrLn "loaded .. yay!" + _ -> putStrLn "wrong types" diff --git a/examples/pdynload/univquant/prog/expected b/examples/pdynload/univquant/prog/expected new file mode 100644 index 0000000..9fed8f0 --- /dev/null +++ b/examples/pdynload/univquant/prog/expected @@ -0,0 +1 @@ +loaded .. yay! diff --git a/examples/pkgconf/null/Makefile b/examples/pkgconf/null/Makefile new file mode 100644 index 0000000..810d1e6 --- /dev/null +++ b/examples/pkgconf/null/Makefile @@ -0,0 +1,16 @@ +all: + @echo "test disabled" + +#true_api:: +# ( cd api ;\ +# $(GHC) -Onot $(EXTRAFLAGS) -c $(API).hs ;\ +# $(RM) -f libHSapi.a ;\ +# $(AR) cq libHSapi.a API.o ;\ +# $(RANLIB) libHSapi.a ;\ +# $(LD) -r $(LD_X) $(WHOLE_ARCHIVE_FLAG) -o HSapi.o libHSapi.a ;\ +# rm API.o ;\ +# echo [] > package.conf ;\ +# env PREFIX=`pwd` $(GHC_PKG) -f package.conf -u < package.conf.in ) +# $(GHC) -package-conf ${TOP}/plugins.conf.inplace -package plugins \ +# -package-conf api/package.conf -package api \ +# -O $(EXTRAFLAGS) -c Null.hs diff --git a/examples/pkgconf/null/Null.hs b/examples/pkgconf/null/Null.hs new file mode 100644 index 0000000..7f9b962 --- /dev/null +++ b/examples/pkgconf/null/Null.hs @@ -0,0 +1,6 @@ +module Null ( resource ) where + +import API + +resource = plugin { a = 7 } + diff --git a/examples/pkgconf/null/api/API.hs b/examples/pkgconf/null/api/API.hs new file mode 100644 index 0000000..0b1624a --- /dev/null +++ b/examples/pkgconf/null/api/API.hs @@ -0,0 +1,10 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +data Null = Null { a, b :: Int } + deriving Show + +plugin :: Null +plugin = Null { a = 42 , b = 1 } + diff --git a/examples/pkgconf/null/api/package.conf.in b/examples/pkgconf/null/api/package.conf.in new file mode 100644 index 0000000..f037800 --- /dev/null +++ b/examples/pkgconf/null/api/package.conf.in @@ -0,0 +1,18 @@ +Package { + name = "api", + auto = False, + + import_dirs = [ "${PREFIX}" ], + library_dirs = [ "${PREFIX}" ], + hs_libraries = [ "HSapi" ], + + include_dirs = [], + c_includes = [], + source_dirs = [], + extra_libraries = [], + package_deps = [], + extra_ghc_opts = [], + extra_cc_opts = [], + extra_ld_opts = [] +} + diff --git a/examples/pkgconf/null/dont_test b/examples/pkgconf/null/dont_test new file mode 100644 index 0000000..e69de29 diff --git a/examples/pkgconf/null/prog/Main.hs b/examples/pkgconf/null/prog/Main.hs new file mode 100644 index 0000000..cbe81ac --- /dev/null +++ b/examples/pkgconf/null/prog/Main.hs @@ -0,0 +1,12 @@ +{-# OPTIONS -cpp #-} + +#include "../../../../config.h" + +import Plugins +import API + +main = do + let includes = TOP ++ "/examples/load/null/api" + (_,v) <- load "../Null.o" ["."] ["../api/package.conf"] "resource" + putStrLn ( show (a v) ) + diff --git a/examples/popen/test1/Main.hs b/examples/popen/test1/Main.hs new file mode 100644 index 0000000..befda24 --- /dev/null +++ b/examples/popen/test1/Main.hs @@ -0,0 +1,10 @@ +-- +-- test the popen function +-- + +import Plugins.Utils +import System.IO + +main = do + (sout,serr) <- exec "date" [] + mapM_ putStrLn serr diff --git a/examples/popen/test1/Makefile b/examples/popen/test1/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/popen/test1/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/popen/test1/expected b/examples/popen/test1/expected new file mode 100644 index 0000000..e69de29 diff --git a/examples/printf/000/Main.hs b/examples/printf/000/Main.hs new file mode 100644 index 0000000..67788aa --- /dev/null +++ b/examples/printf/000/Main.hs @@ -0,0 +1,37 @@ +import Printf + +main = do printf "%d\n" $> (42::Int) ! [] + printf "%u\n" $> (42::Int) ! [] + printf "0%o\n" $> (42::Int) ! [] + printf "0x%x\n" $> (42::Int) ! [] + printf "0x%X\n" $> (42::Int) ! [] + + printf "%e\n" $> (42.1234 :: Double) ! [] + printf "%E\n" $> (42.1234 :: Double) ! [] + printf "%g\n" $> (42.1234 :: Double) ! [] + printf "%G\n" $> (42.1234 :: Double) ! [] + printf "%f\n" $> (42.1234 :: Double) ! [] + + printf "%c:%c:%c\n" $> 'a' ! 'b' ! 'c' ! [] + printf "%s\n" $> "printf" ! [] + + printf "%+d\n" $> (42::Int) ! [] + printf "%+0d\n" $> (42::Int) ! [] + printf "%0+d\n" $> (42::Int) ! [] + printf "%10d\n" $> (42::Int) ! [] + printf "%-010d\n" $> (42::Int) ! [] + printf "%-010.2d\n" $> (42::Int) ! [] + + printf "%+f\n" $> (42.1234 :: Double) ! [] + printf "%+0f\n" $> (42.1234 :: Double) ! [] + printf "%0+f\n" $> (42.1234 :: Double) ! [] + printf "%10f\n" $> (42.1234 :: Double) ! [] + printf "%-010f\n" $> (42.1234 :: Double) ! [] + printf "%-010.2f\n" $> (42.1234 :: Double) ! [] + + printf "%10s\n" $> "printf" ! [] + printf "%-10s\n" $> "printf" ! [] + printf "%10.2s\n" $> "printf" ! [] + printf "%2.10s\n" $> "printf" ! [] + printf "%-2.10s\n" $> "printf" ! [] + printf "%-10.2s\n" $> "printf" ! [] diff --git a/examples/printf/000/Makefile b/examples/printf/000/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/printf/000/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/printf/000/expected b/examples/printf/000/expected new file mode 100644 index 0000000..6268409 --- /dev/null +++ b/examples/printf/000/expected @@ -0,0 +1,30 @@ +42 +42 +052 +0x2a +0x2A +4.212340e1 +4.212340E1 +42.123400 +42.123400 +42.123400 +a:b:c +printf ++42 ++42 ++42 + 42 +42 +42 ++42.123400 ++42.123400 ++42.123400 + 42.123400 +42.123400 +42.12 + printf +printf + pr +printf +printf +pr diff --git a/examples/printf/000/printf.sh b/examples/printf/000/printf.sh new file mode 100644 index 0000000..0f8e459 --- /dev/null +++ b/examples/printf/000/printf.sh @@ -0,0 +1,36 @@ +#!/bin/sh +printf "%d\n" 42 +printf "%u\n" 42 +printf "0%o\n" 42 +printf "0x%x\n" 42 +printf "0x%X\n" 42 + +printf "%e\n" 42.1234 +printf "%E\n" 42.1234 +printf "%g\n" 42.1234 +printf "%G\n" 42.1234 +printf "%f\n" 42.1234 + +printf "%c:%c:%c\n" 'a' 'b' 'c' +printf "%s\n" "printf" + +printf "%+d\n" 42 +printf "%+0d\n" 42 +printf "%0+d\n" 42 +printf "%10d\n" 42 +printf "%-010d\n" 42 +printf "%-010.2d\n" 42 + +printf "%+f\n" 42.1234 +printf "%+0f\n" 42.1234 +printf "%0+f\n" 42.1234 +printf "%10f\n" 42.1234 +printf "%-010f\n" 42.1234 +printf "%-010.2f\n" 42.1234 + +printf "%10s\n" "printf" +printf "%-10s\n" "printf" +printf "%10.2s\n" "printf" +printf "%2.10s\n" "printf" +printf "%-2.10s\n" "printf" +printf "%-10.2s\n" "printf" diff --git a/examples/printf/001/Main.hs b/examples/printf/001/Main.hs new file mode 100644 index 0000000..dfaed56 --- /dev/null +++ b/examples/printf/001/Main.hs @@ -0,0 +1,13 @@ +import Printf + +main = do + printf "%d\n" $> (42 :: Int) ! [] + printf "0x%X\n" $> (42 :: Int) ! [] + printf "%f\n" $> (42.1234 :: Double) ! [] + printf "%c:%c:%c\n" $> 'a' ! 'b' ! 'c' ! [] + printf "%s\n" $> "haskell" ! [] + printf "%-010.4d\n" $> (42 :: Int) ! [] + printf "%010.4f\n" $> (42.1234 :: Double) ! [] + printf "%10.4s\n" $> (show (7 :: Int)) ! [] + printf "%-10.4s\n" $> "haskell" ! [] + diff --git a/examples/printf/001/Makefile b/examples/printf/001/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/printf/001/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/printf/001/expected b/examples/printf/001/expected new file mode 100644 index 0000000..e48936f --- /dev/null +++ b/examples/printf/001/expected @@ -0,0 +1,9 @@ +42 +0x2A +42.123400 +a:b:c +haskell +42 +00042.1234 + 7 +hask diff --git a/examples/printf/002/Main.hs b/examples/printf/002/Main.hs new file mode 100644 index 0000000..0871a76 --- /dev/null +++ b/examples/printf/002/Main.hs @@ -0,0 +1,12 @@ +import Printf +import Control.Exception ( evaluate ) + +main = do + fn <- evaluate $! printf "%10.4f\n" + fn $> (10.0 :: Double) ! [] + fn $> (-10.0 :: Double) ! [] + fn $> (10.1010 :: Double) ! [] + fn $> (0.0 :: Double) ! [] + fn $> (0.987654321 :: Double) ! [] + fn $> (987654321 :: Double) ! [] + fn $> (-987654321 :: Double) ! [] diff --git a/examples/printf/002/Makefile b/examples/printf/002/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/printf/002/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/printf/002/expected b/examples/printf/002/expected new file mode 100644 index 0000000..bd20026 --- /dev/null +++ b/examples/printf/002/expected @@ -0,0 +1,7 @@ + 10.0000 + -10.0000 + 10.1010 + 0.0000 + 0.9877 +987654321.0000 +-987654321.0000 diff --git a/examples/printf/should_fail_000/Main.hs b/examples/printf/should_fail_000/Main.hs new file mode 100644 index 0000000..7859483 --- /dev/null +++ b/examples/printf/should_fail_000/Main.hs @@ -0,0 +1,3 @@ +import Printf + +main = printf "%x\n" $> "badstring" ! [] diff --git a/examples/printf/should_fail_000/Makefile b/examples/printf/should_fail_000/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/printf/should_fail_000/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/printf/should_fail_000/expected b/examples/printf/should_fail_000/expected new file mode 100644 index 0000000..b380af1 --- /dev/null +++ b/examples/printf/should_fail_000/expected @@ -0,0 +1,3 @@ + +Fail: Type error in dynamic application. +Can't apply function [Char]> to argument <[Char]> diff --git a/examples/printf/should_fail_000/expected.604 b/examples/printf/should_fail_000/expected.604 new file mode 100644 index 0000000..0b47c40 --- /dev/null +++ b/examples/printf/should_fail_000/expected.604 @@ -0,0 +1,2 @@ +a.out: Type error in dynamic application. +Can't apply function [Char]> to argument <[Char]> diff --git a/examples/printf/should_fail_001/Main.hs b/examples/printf/should_fail_001/Main.hs new file mode 100644 index 0000000..b00156a --- /dev/null +++ b/examples/printf/should_fail_001/Main.hs @@ -0,0 +1,13 @@ +import Printf + +main = do + printf "%d\n" $> (42 :: Int) ! [] + printf "0x%X\n" $> (42 :: Int) ! [] + printf "%f\n" $> (42.1234 :: Double) ! [] + printf "%c:%c:%c\n" $> 'a' ! 'b' ! 'c' ! [] + printf "%s\n" $> "haskell" ! [] + printf "%-010.4d\n" $> (42 :: Int) ! [] + printf "%010.4f\n" $> (42.1234 :: Double) ! [] + printf "%10.4s\n" $> (7 :: Int)! [] + printf "%-10.4s\n" $> "haskell" ! [] + diff --git a/examples/printf/should_fail_001/Makefile b/examples/printf/should_fail_001/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/printf/should_fail_001/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/printf/should_fail_001/expected b/examples/printf/should_fail_001/expected new file mode 100644 index 0000000..9c7691f --- /dev/null +++ b/examples/printf/should_fail_001/expected @@ -0,0 +1,10 @@ +42 +0x2A +42.123400 +a:b:c +haskell +42 +00042.1234 + +Fail: Type error in dynamic application. +Can't apply function <[Char] -> [Char]> to argument diff --git a/examples/printf/should_fail_001/expected.604 b/examples/printf/should_fail_001/expected.604 new file mode 100644 index 0000000..77d79da --- /dev/null +++ b/examples/printf/should_fail_001/expected.604 @@ -0,0 +1,9 @@ +42 +0x2A +42.123400 +a:b:c +haskell +42 +00042.1234 +a.out: Type error in dynamic application. +Can't apply function <[Char] -> [Char]> to argument diff --git a/examples/reload/null/Makefile b/examples/reload/null/Makefile new file mode 100644 index 0000000..4a71f74 --- /dev/null +++ b/examples/reload/null/Makefile @@ -0,0 +1,4 @@ +TEST= reload/null +EXTRA_OBJS=Null.o +TOP=../../.. +include ../../build.mk diff --git a/examples/reload/null/Null.hs b/examples/reload/null/Null.hs new file mode 100644 index 0000000..0b06f81 --- /dev/null +++ b/examples/reload/null/Null.hs @@ -0,0 +1,11 @@ +module Null ( resource, resource_dyn ) where + +import API +import Data.Dynamic +import Prelude hiding (null) + +resource = null + +-- ! this has to be special: it can't be overridden by the user. +resource_dyn :: Dynamic +resource_dyn = toDyn resource diff --git a/examples/reload/null/api/API.hs b/examples/reload/null/api/API.hs new file mode 100644 index 0000000..a77126c --- /dev/null +++ b/examples/reload/null/api/API.hs @@ -0,0 +1,12 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import Data.Dynamic + +data Null = Null { a, b :: Int } + deriving (Typeable, Show) + +null :: Null +null = Null { a = 42 , b = 1 } + diff --git a/examples/reload/null/prog/Main.hs b/examples/reload/null/prog/Main.hs new file mode 100644 index 0000000..c30251f --- /dev/null +++ b/examples/reload/null/prog/Main.hs @@ -0,0 +1,19 @@ + +import Plugins +import API + +-- an example where we just want to load an object and run it + +main = do + m_v <- load "../Null.o" ["../api"] [] "resource" + (m,v) <- case m_v of + LoadSuccess m v -> return (m,v) + _ -> error "load failed" + putStrLn ( show (a v) ) + + m_v <- reload m "resource" -- get a new version + v' <- case m_v of + LoadSuccess _ v -> return v + _ -> error "load failed" + putStrLn ( show (a v') ) + diff --git a/examples/reload/null/prog/expected b/examples/reload/null/prog/expected new file mode 100644 index 0000000..daaac9e --- /dev/null +++ b/examples/reload/null/prog/expected @@ -0,0 +1,2 @@ +42 +42 diff --git a/examples/shell/shell/API.hs b/examples/shell/shell/API.hs new file mode 100644 index 0000000..da26a69 --- /dev/null +++ b/examples/shell/shell/API.hs @@ -0,0 +1,8 @@ +module API where + +-- the interface between the app and the plugin +data Interface = Interface { function :: String -> String } + +-- default values for the interface +plugin :: Interface +plugin = Interface { function = id } diff --git a/examples/shell/shell/Main.hs b/examples/shell/shell/Main.hs new file mode 100644 index 0000000..67f4767 --- /dev/null +++ b/examples/shell/shell/Main.hs @@ -0,0 +1,85 @@ +-- +-- a simple shell for loading plugins and evaluating their functions +-- + +import Plugins +import API + +import Data.Either +import Data.Char +import Control.Monad ( when ) +import System.Console.Readline ( readline ) +import System.Exit ( ExitCode(..), exitWith ) + + +source = "Plugin.hs" +stub = "Plugin.stub" + +sym = "resource" + +main = do + status <- makeWith source stub [] + p <- case status of + MakeFailure e -> mapM_ putStrLn e >> error "failed to compile" + MakeSuccess _ obj -> do + m_v <- load obj ["."] [] sym + case m_v of + LoadSuccess m v -> return (m,v) + LoadFailure e -> do mapM_ putStrLn e + error "failed to load" + shell p + + where + shell p@(m,v) = do + + s <- readline "> " + cmd <- case s of + Nothing -> exitWith ExitSuccess + Just ":q" -> exitWith ExitSuccess + Just s -> return (chomp s) + + status <- makeWith source stub [] + case status of + MakeFailure e -> do + mapM_ putStrLn e + shell p -- print error and back to prompt + + MakeSuccess NotReq o -> do + p' <- eval cmd p + shell p' -- eval str again + + MakeSuccess ReComp o -> do + m_v' <- reload m sym + case m_v' of + LoadFailure e -> mapM_ putStrLn e >> error "failed to load" + LoadSuccess _ v' -> do + let p' = (m,v') + p'' <- eval cmd p' + shell p'' + +-- +-- shell commands +-- +eval "" p = return p + +eval ":clear" p = do + let loop i = when (i < 40) (do putStr "\n" ; loop $! i+1) + loop 0 + return p + +eval ":?" p = do + putStrLn$"\":?\"\n" ++ + "\":quit\"\n" ++ + "\":clear\"\n" ++ + "\"foo\"" + return p + +eval s (m,v) = putStrLn ((function v) s) >> return (m,v) + +-- +-- strip trailing whitespace +-- +chomp :: String -> String +chomp [] = [] +chomp s | isSpace (last s) = chomp $! init s + | otherwise = s diff --git a/examples/shell/shell/Makefile b/examples/shell/shell/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/shell/shell/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/shell/shell/Plugin.hs b/examples/shell/shell/Plugin.hs new file mode 100644 index 0000000..e904f35 --- /dev/null +++ b/examples/shell/shell/Plugin.hs @@ -0,0 +1,5 @@ + +resource = plugin { + function = map toUpper +} + diff --git a/examples/shell/shell/Plugin.stub b/examples/shell/shell/Plugin.stub new file mode 100644 index 0000000..a701306 --- /dev/null +++ b/examples/shell/shell/Plugin.stub @@ -0,0 +1,19 @@ +-- +-- this is a "stub" file, containing default syntax we don't +-- want the user to have to write +-- +-- for example, it constrains the module name and force the API to be +-- imported + +module Plugin ( resource ) where + +import API +import Data.Char +import Data.List + +-- this is a default definition of 'resource'. it will be overridden +-- by anything the user writes. useful for default values + +resource :: Interface +resource = plugin + diff --git a/examples/shell/shell/README b/examples/shell/shell/README new file mode 100644 index 0000000..5edd023 --- /dev/null +++ b/examples/shell/shell/README @@ -0,0 +1,23 @@ +$ make +$ ./a.out +Compiling plugin ... done +Loading package base ... linking ... done +Loading objects API Plugin ... done +> ? +"?" +"quit" +"clear" +"filter foo" +> filter adf adsf +fsda fda +> filter asd faSDFADSF +FSDAFDSaf dsa + +-- at this point I edit the plugin and save the source + +> filter asfdaSDFASD +Compiling plugin ... done +Reloading Plugin ... done +DSAFDSADFSA + +-- it compiled and reloaded it for me. nice. diff --git a/examples/shell/shell/dont_test b/examples/shell/shell/dont_test new file mode 100644 index 0000000..e69de29 diff --git a/examples/shell/simple/Main.hs b/examples/shell/simple/Main.hs new file mode 100644 index 0000000..b3f26b1 --- /dev/null +++ b/examples/shell/simple/Main.hs @@ -0,0 +1,41 @@ +import Plugins +import StringProcessorAPI +import System.Console.Readline +import System.Exit + +source = "Plugin.hs" +stub = "Plugin.stub" +symbol = "resource" + +main = do s <- makeWith source stub [] + o <- case s of + MakeSuccess _ obj -> do + ls <- load obj ["."] [] symbol + case ls of LoadSuccess m v -> return (m,v) + LoadFailure err -> error "load failed" + MakeFailure e -> mapM_ putStrLn e >> error "compile failed" + shell o + +shell o@(m,plugin) = do + s <- readline "> " + cmd <- case s of + Nothing -> exitWith ExitSuccess + Just (':':'q':_) -> exitWith ExitSuccess + Just s -> addHistory s >> return s + + s <- makeWith source stub [] -- maybe recompile the source + o' <- case s of + MakeSuccess ReComp o -> do + ls <- reload m symbol + case ls of LoadSuccess m' v' -> return (m',v') + LoadFailure err -> error "reload failed" + MakeSuccess NotReq _ -> return o + MakeFailure e -> mapM_ putStrLn e >> shell o + eval cmd o' + shell o' + +eval ":?" _ = putStrLn ":?\n:q\n" + +eval s (_,plugin) = let fn = (stringProcessor plugin) in putStrLn (fn s) + + diff --git a/examples/shell/simple/Makefile b/examples/shell/simple/Makefile new file mode 100644 index 0000000..cbe6c6d --- /dev/null +++ b/examples/shell/simple/Makefile @@ -0,0 +1,6 @@ +OBJS=StringProcessorAPI.o +TOP=../../.. +include ../../eval.mk + +#all: +# @echo test disabled diff --git a/examples/shell/simple/Plugin.hs b/examples/shell/simple/Plugin.hs new file mode 100644 index 0000000..eff5e28 --- /dev/null +++ b/examples/shell/simple/Plugin.hs @@ -0,0 +1,5 @@ +import Char + +resource = plugin { + stringProcessor = map toUpper +} diff --git a/examples/shell/simple/Plugin.stub b/examples/shell/simple/Plugin.stub new file mode 100644 index 0000000..d53ed15 --- /dev/null +++ b/examples/shell/simple/Plugin.stub @@ -0,0 +1,19 @@ +-- +-- this is a "stub" file, containing default syntax we don't +-- want the user to have to write +-- +-- for example, it constrains the module name and force the API to be +-- imported + +module Plugin ( resource ) where + +import StringProcessorAPI +import Data.Char +import Data.List + +-- this is a default definition of 'resource'. it will be overridden +-- by anything the user writes. useful for default values + +resource :: Interface +resource = plugin + diff --git a/examples/shell/simple/README b/examples/shell/simple/README new file mode 100644 index 0000000..5edd023 --- /dev/null +++ b/examples/shell/simple/README @@ -0,0 +1,23 @@ +$ make +$ ./a.out +Compiling plugin ... done +Loading package base ... linking ... done +Loading objects API Plugin ... done +> ? +"?" +"quit" +"clear" +"filter foo" +> filter adf adsf +fsda fda +> filter asd faSDFADSF +FSDAFDSaf dsa + +-- at this point I edit the plugin and save the source + +> filter asfdaSDFASD +Compiling plugin ... done +Reloading Plugin ... done +DSAFDSADFSA + +-- it compiled and reloaded it for me. nice. diff --git a/examples/shell/simple/StringProcessorAPI.hs b/examples/shell/simple/StringProcessorAPI.hs new file mode 100644 index 0000000..a3ac21d --- /dev/null +++ b/examples/shell/simple/StringProcessorAPI.hs @@ -0,0 +1,8 @@ +module StringProcessorAPI where + +data Interface = Interface { + stringProcessor :: String -> String +} + +plugin :: Interface +plugin = Interface { stringProcessor = id } diff --git a/examples/shell/simple/dont_test b/examples/shell/simple/dont_test new file mode 100644 index 0000000..e69de29 diff --git a/examples/typecase/000/Main.hs b/examples/typecase/000/Main.hs new file mode 100644 index 0000000..f1a6b87 --- /dev/null +++ b/examples/typecase/000/Main.hs @@ -0,0 +1,14 @@ +import AltData +import Data.Char + +main = putStrLn f + +f = let v = toDyn (7 :: Int) + in typecase (v) [ + _Bool --> \(b::Bool) -> show (not b)++" :: Bool", + _Char --> \(c::Char) -> show (toUpper c)++" :: Char", + _Int --> \(i::Int) -> show (-i)++" :: Int", + _String --> \(s::String) -> show (reverse s)++" :: [Char]", + _IntToInt --> \(f::Int->Int) -> show (f 7) ++":: Int -> Int" + ] ("couldn't find a typing") + diff --git a/examples/typecase/000/Makefile b/examples/typecase/000/Makefile new file mode 100644 index 0000000..f775e10 --- /dev/null +++ b/examples/typecase/000/Makefile @@ -0,0 +1,2 @@ +TOP=../../.. +include ../../eval.mk diff --git a/examples/typecase/000/expected b/examples/typecase/000/expected new file mode 100644 index 0000000..8e91335 --- /dev/null +++ b/examples/typecase/000/expected @@ -0,0 +1 @@ +-7 :: Int diff --git a/examples/unload/null/Makefile b/examples/unload/null/Makefile new file mode 100644 index 0000000..b53007a --- /dev/null +++ b/examples/unload/null/Makefile @@ -0,0 +1,4 @@ +TEST= unload/null +EXTRA_OBJS=Null.o +TOP=../../.. +include ../../build.mk diff --git a/examples/unload/null/Null.hs b/examples/unload/null/Null.hs new file mode 100644 index 0000000..0b06f81 --- /dev/null +++ b/examples/unload/null/Null.hs @@ -0,0 +1,11 @@ +module Null ( resource, resource_dyn ) where + +import API +import Data.Dynamic +import Prelude hiding (null) + +resource = null + +-- ! this has to be special: it can't be overridden by the user. +resource_dyn :: Dynamic +resource_dyn = toDyn resource diff --git a/examples/unload/null/api/API.hs b/examples/unload/null/api/API.hs new file mode 100644 index 0000000..a77126c --- /dev/null +++ b/examples/unload/null/api/API.hs @@ -0,0 +1,12 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +import Data.Dynamic + +data Null = Null { a, b :: Int } + deriving (Typeable, Show) + +null :: Null +null = Null { a = 42 , b = 1 } + diff --git a/examples/unload/null/prog/Main.hs b/examples/unload/null/prog/Main.hs new file mode 100644 index 0000000..fb52951 --- /dev/null +++ b/examples/unload/null/prog/Main.hs @@ -0,0 +1,11 @@ + +import Plugins +import API + +-- an example where we just want to load an object and run it + +main = do + m_v <- load "../Null.o" ["../api"] [] "resource" + case m_v of + LoadFailure _ -> error "load failed" + LoadSuccess m v -> do putStrLn ( show (a v) ) ; unload m diff --git a/examples/unload/null/prog/expected b/examples/unload/null/prog/expected new file mode 100644 index 0000000..d81cc07 --- /dev/null +++ b/examples/unload/null/prog/expected @@ -0,0 +1 @@ +42 diff --git a/examples/unload/sjwtrap/Makefile b/examples/unload/sjwtrap/Makefile new file mode 100644 index 0000000..ab35d4b --- /dev/null +++ b/examples/unload/sjwtrap/Makefile @@ -0,0 +1,4 @@ +TEST= unload/sjwtrap +EXTRA_OBJS=Null.o +TOP=../../.. +include ../../build.mk diff --git a/examples/unload/sjwtrap/Null.hs b/examples/unload/sjwtrap/Null.hs new file mode 100644 index 0000000..81964eb --- /dev/null +++ b/examples/unload/sjwtrap/Null.hs @@ -0,0 +1,6 @@ +module Null where + +import qualified Prelude +import API + +resource = null diff --git a/examples/unload/sjwtrap/api/API.hs b/examples/unload/sjwtrap/api/API.hs new file mode 100644 index 0000000..bf1796d --- /dev/null +++ b/examples/unload/sjwtrap/api/API.hs @@ -0,0 +1,9 @@ +{-# OPTIONS -fglasgow-exts #-} + +module API where + +data Null = Null { a, b :: Int } + +null :: Null +null = Null { a = 42 , b = 1 } + diff --git a/examples/unload/sjwtrap/prog/Main.hs b/examples/unload/sjwtrap/prog/Main.hs new file mode 100644 index 0000000..00bdc21 --- /dev/null +++ b/examples/unload/sjwtrap/prog/Main.hs @@ -0,0 +1,15 @@ + +import Plugins +import API + +-- +-- what happens if we try to use code that has been unloaded? +-- + +main = do + m_v <- load "../Null.o" ["../api"] [] "resource" + (m,v) <- case m_v of + LoadSuccess m v -> return (m,v) + _ -> error "load failed" + putStrLn ( show (a v) ) + unload m diff --git a/examples/unload/sjwtrap/prog/expected b/examples/unload/sjwtrap/prog/expected new file mode 100644 index 0000000..d81cc07 --- /dev/null +++ b/examples/unload/sjwtrap/prog/expected @@ -0,0 +1 @@ +42 diff --git a/install-sh b/install-sh new file mode 100644 index 0000000..e9de238 --- /dev/null +++ b/install-sh @@ -0,0 +1,251 @@ +#!/bin/sh +# +# install - install a program, script, or datafile +# This comes from X11R5 (mit/util/scripts/install.sh). +# +# Copyright 1991 by the Massachusetts Institute of Technology +# +# Permission to use, copy, modify, distribute, and sell this software and its +# documentation for any purpose is hereby granted without fee, provided that +# the above copyright notice appear in all copies and that both that +# copyright notice and this permission notice appear in supporting +# documentation, and that the name of M.I.T. not be used in advertising or +# publicity pertaining to distribution of the software without specific, +# written prior permission. M.I.T. makes no representations about the +# suitability of this software for any purpose. It is provided "as is" +# without express or implied warranty. +# +# Calling this script install-sh is preferred over install.sh, to prevent +# `make' implicit rules from creating a file called install from it +# when there is no Makefile. +# +# This script is compatible with the BSD install script, but was written +# from scratch. It can only install one file at a time, a restriction +# shared with many OS's install programs. + + +# set DOITPROG to echo to test this script + +# Don't use :- since 4.3BSD and earlier shells don't like it. +doit="${DOITPROG-}" + + +# put in absolute paths if you don't have them in your path; or use env. vars. + +mvprog="${MVPROG-mv}" +cpprog="${CPPROG-cp}" +chmodprog="${CHMODPROG-chmod}" +chownprog="${CHOWNPROG-chown}" +chgrpprog="${CHGRPPROG-chgrp}" +stripprog="${STRIPPROG-strip}" +rmprog="${RMPROG-rm}" +mkdirprog="${MKDIRPROG-mkdir}" + +transformbasename="" +transform_arg="" +instcmd="$mvprog" +chmodcmd="$chmodprog 0755" +chowncmd="" +chgrpcmd="" +stripcmd="" +rmcmd="$rmprog -f" +mvcmd="$mvprog" +src="" +dst="" +dir_arg="" + +while [ x"$1" != x ]; do + case $1 in + -c) instcmd="$cpprog" + shift + continue;; + + -d) dir_arg=true + shift + continue;; + + -m) chmodcmd="$chmodprog $2" + shift + shift + continue;; + + -o) chowncmd="$chownprog $2" + shift + shift + continue;; + + -g) chgrpcmd="$chgrpprog $2" + shift + shift + continue;; + + -s) stripcmd="$stripprog" + shift + continue;; + + -t=*) transformarg=`echo $1 | sed 's/-t=//'` + shift + continue;; + + -b=*) transformbasename=`echo $1 | sed 's/-b=//'` + shift + continue;; + + *) if [ x"$src" = x ] + then + src=$1 + else + # this colon is to work around a 386BSD /bin/sh bug + : + dst=$1 + fi + shift + continue;; + esac +done + +if [ x"$src" = x ] +then + echo "install: no input file specified" + exit 1 +else + true +fi + +if [ x"$dir_arg" != x ]; then + dst=$src + src="" + + if [ -d $dst ]; then + instcmd=: + chmodcmd="" + else + instcmd=mkdir + fi +else + +# Waiting for this to be detected by the "$instcmd $src $dsttmp" command +# might cause directories to be created, which would be especially bad +# if $src (and thus $dsttmp) contains '*'. + + if [ -f $src -o -d $src ] + then + true + else + echo "install: $src does not exist" + exit 1 + fi + + if [ x"$dst" = x ] + then + echo "install: no destination specified" + exit 1 + else + true + fi + +# If destination is a directory, append the input filename; if your system +# does not like double slashes in filenames, you may need to add some logic + + if [ -d $dst ] + then + dst="$dst"/`basename $src` + else + true + fi +fi + +## this sed command emulates the dirname command +dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` + +# Make sure that the destination directory exists. +# this part is taken from Noah Friedman's mkinstalldirs script + +# Skip lots of stat calls in the usual case. +if [ ! -d "$dstdir" ]; then +defaultIFS=' +' +IFS="${IFS-${defaultIFS}}" + +oIFS="${IFS}" +# Some sh's can't handle IFS=/ for some reason. +IFS='%' +set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'` +IFS="${oIFS}" + +pathcomp='' + +while [ $# -ne 0 ] ; do + pathcomp="${pathcomp}${1}" + shift + + if [ ! -d "${pathcomp}" ] ; + then + $mkdirprog "${pathcomp}" + else + true + fi + + pathcomp="${pathcomp}/" +done +fi + +if [ x"$dir_arg" != x ] +then + $doit $instcmd $dst && + + if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi && + if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi && + if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi && + if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi +else + +# If we're going to rename the final executable, determine the name now. + + if [ x"$transformarg" = x ] + then + dstfile=`basename $dst` + else + dstfile=`basename $dst $transformbasename | + sed $transformarg`$transformbasename + fi + +# don't allow the sed command to completely eliminate the filename + + if [ x"$dstfile" = x ] + then + dstfile=`basename $dst` + else + true + fi + +# Make a temp file name in the proper directory. + + dsttmp=$dstdir/#inst.$$# + +# Move or copy the file name to the temp name + + $doit $instcmd $src $dsttmp && + + trap "rm -f ${dsttmp}" 0 && + +# and set any options; do chmod last to preserve setuid bits + +# If any of these fail, we abort the whole thing. If we want to +# ignore errors from any of these, just make sure not to ignore +# errors from the above "$doit $instcmd $src $dsttmp" command. + + if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi && + if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi && + if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi && + if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi && + +# Now rename the file to the real destination. + + $doit $rmcmd -f $dstdir/$dstfile && + $doit $mvcmd $dsttmp $dstdir/$dstfile + +fi && + + +exit 0 diff --git a/scripts/openbsd-port/Makefile b/scripts/openbsd-port/Makefile new file mode 100644 index 0000000..909dacf --- /dev/null +++ b/scripts/openbsd-port/Makefile @@ -0,0 +1,21 @@ +# $OpenBSD$ + +COMMENT= "dynamic link library for Haskell" + +V= 0.9.8 +DISTNAME= hs-plugins-${V} +CATEGORIES= devel +MAINTAINER= Don Stewart +HOMEPAGE= http://www.cse.unsw.edu.au/~dons/hs-plugins-0.9.8/ +MASTER_SITES= ${HOMEPAGE} + +MODULES= ghc +CONFIGURE_STYLE= gnu dest + +# LGPL +PERMIT_PACKAGE_CDROM= Yes +PERMIT_PACKAGE_FTP= Yes +PERMIT_DISTFILES_CDROM= Yes +PERMIT_DISTFILES_FTP= Yes + +.include diff --git a/scripts/openbsd-port/distinfo b/scripts/openbsd-port/distinfo new file mode 100644 index 0000000..1623c2c --- /dev/null +++ b/scripts/openbsd-port/distinfo @@ -0,0 +1,3 @@ +MD5 (hs-plugins-0.9.4.tar.gz) = 120f38ca532b187ee52798f5c36cc920 +RMD160 (hs-plugins-0.9.4.tar.gz) = 219eaf70e4bc0f1abc8a782d1bbd64ad2c5f8e86 +SHA1 (hs-plugins-0.9.4.tar.gz) = ad38b9f4e5b90c1361c6c96bd94e2a9270ad3d78 diff --git a/scripts/openbsd-port/pkg/DESCR b/scripts/openbsd-port/pkg/DESCR new file mode 100644 index 0000000..dbbdd57 --- /dev/null +++ b/scripts/openbsd-port/pkg/DESCR @@ -0,0 +1,6 @@ +hs-plugins is a library for dynamic loading and compilation of Haskell +code. It provides typesafe "plugins" for Haskell. The interface is +general enough that it can be used to create conventional plugins, +hmake-like Haskell interpreters embedded in applications, or to script +an application with Haskell (or a Haskell EDSL) as the extension +language. diff --git a/scripts/openbsd-port/pkg/PLIST b/scripts/openbsd-port/pkg/PLIST new file mode 100644 index 0000000..7618ba4 --- /dev/null +++ b/scripts/openbsd-port/pkg/PLIST @@ -0,0 +1,28 @@ +@comment $OpenBSD$ +lib/hs-plugins/imports/Plugins.hi +lib/hs-plugins/imports/Plugins/BinIface.hi +lib/hs-plugins/imports/Plugins/Binary.hi +lib/hs-plugins/imports/Plugins/Consts.hi +lib/hs-plugins/imports/Plugins/Env.hi +lib/hs-plugins/imports/Plugins/FastMutInt.hi +lib/hs-plugins/imports/Plugins/FastString.hi +lib/hs-plugins/imports/Plugins/Iface.hi +lib/hs-plugins/imports/Plugins/Load.hi +lib/hs-plugins/imports/Plugins/Make.hi +lib/hs-plugins/imports/Plugins/Package.hi +lib/hs-plugins/imports/Plugins/ParsePkgConfLite.hi +lib/hs-plugins/imports/Plugins/Parser.hi +lib/hs-plugins/imports/Plugins/PrimPacked.hi +lib/hs-plugins/imports/Plugins/Utils.hi +lib/hs-plugins/include/hschooks.h +lib/hs-plugins/libHSplugins.a +lib/hs-plugins/libHSplugins_cbits.a +lib/hs-plugins/plugins.conf.in +@dirrm lib/hs-plugins/include +@dirrm lib/hs-plugins/imports/Plugins +@dirrm lib/hs-plugins/imports +@dirrm lib/hs-plugins +@exec /bin/cat %D/lib/hs-plugins/plugins.conf.in | /usr/bin/env PREFIX=%D %D/bin/ghc-pkg -u +@exec /bin/rm -f %D/lib/ghc-6.2.1/package.conf.old +@unexec %D/bin/ghc-pkg -r plugins +@unexec /bin/rm -f %D/lib/ghc-6.2.1/package.conf.old diff --git a/src/Makefile b/src/Makefile new file mode 100644 index 0000000..56df945 --- /dev/null +++ b/src/Makefile @@ -0,0 +1,38 @@ + +# Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +# GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) + +.PHONY: all build altdata hi plugins eval printf +.PHONY: install i_altdata i_hi i_plugins i_eval i_printf + +build: altdata hi plugins eval printf + +altdata: + @cd altdata && $(MAKE) +hi: + @cd hi && $(MAKE) +plugins: + @cd plugins && $(MAKE) +eval: + @cd eval && $(MAKE) +printf: + @cd printf && $(MAKE) + +install: i_altdata i_hi i_plugins i_eval i_printf + @true + +i_altdata: + @cd altdata && $(MAKE) install +i_hi: + @cd hi && $(MAKE) install +i_plugins: + @cd plugins && $(MAKE) install +i_eval: + @cd eval && $(MAKE) install +i_printf: + @cd printf && $(MAKE) install + +all: build + +TOP=.. +include build.mk diff --git a/src/README b/src/README new file mode 100644 index 0000000..8de08d0 --- /dev/null +++ b/src/README @@ -0,0 +1,23 @@ +Don's Haskell Libraries +----------------------- + +* altdata +An alternative implementation of Typeable and Dynamic that +works in the presence of (completely) separate compilation + +* hi +A parser for .hi files + +* plugins +A dynamic loader for GHC-produce object files. Also provides type +checking of object interfaces via dynamic typing. + +* eval +A system for reflecting strings of Haskell source into native code at +runtime, via runtime compilation and dynamic linking. +Also implements a staged computation doo-hickey. + +* printf +An implementation of printf(3) that uses eval to generate new Haskell +functions from format strings, at runtime, and dynamic typing to +retain type safety. diff --git a/src/altdata/AltData.hs b/src/altdata/AltData.hs new file mode 100644 index 0000000..fcefa19 --- /dev/null +++ b/src/altdata/AltData.hs @@ -0,0 +1,24 @@ +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +module AltData ( module AltData.Dynamic, + module AltData.Typeable + ) where +import AltData.Dynamic {-all-} +import AltData.Typeable {-all-} diff --git a/src/altdata/AltData/Dynamic.hs b/src/altdata/AltData/Dynamic.hs new file mode 100644 index 0000000..3ed9a6d --- /dev/null +++ b/src/altdata/AltData/Dynamic.hs @@ -0,0 +1,174 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +-- +-- reimplement the Data.Dynamic library to use equality over the +-- canonical name of a type, rather than on integer keys. The later is +-- how the Haskell library works, and is broken for our situation: +-- static versus dynamic instances of the same type seem to generate +-- different keys, meaning equal types are not detected as such. +-- + +module AltData.Dynamic ( + + Dynamic, -- must be abstract + toDyn, -- :: Typeable a => a -> Dynamic + fromDyn, -- :: Typeable a => Dynamic -> Maybe a + fromDynamic, + dynApp, + dynApply, + dynAppHList, + + typecase, + (-->), + + _Int, + _Char, + _Bool, + _String, + _IntToInt, + + ) where + +import AltData.Typeable +import Data.Maybe +import System.IO.Unsafe ( unsafePerformIO ) +import GHC.Base ( unsafeCoerce# ) +import Data.List + +data Dynamic = Dynamic TypeRep Obj + +type Obj = forall a . a + +instance Show Dynamic where + -- the instance just prints the type representation. + showsPrec _ (Dynamic t _) = + showString "<" . + showsPrec 0 t . + showString ">" + +instance Typeable Dynamic where +#if __GLASGOW_HASKELL__ >= 603 + typeOf _ = mkTyConApp (mkTyCon "AltData.Dynamic") [] +#else + typeOf _ = mkAppTy (mkTyCon "AltData.Dyanmic") [] +#endif + +-- +-- must be monomophic, see Data.Dynamic +-- +toDyn :: Typeable a => a -> Dynamic +toDyn v = Dynamic (typeOf v) (unsafeCoerce# v) + +-- +-- Converts a 'Dynamic' object back into an ordinary Haskell value of +-- the correct type. (this is the same as fromDynamic) +-- +-- Uses string comparison of the name of the type, rather than the +-- hashed key of the type, which doesn't work for plugins, which mix +-- static and dynamic loaded code. +-- +-- TypeRep is abstract, unfortunately. +-- +fromDyn :: Typeable a => Dynamic -> Maybe a + +fromDyn (Dynamic t v) = + case unsafeCoerce# v of + r | t == typeOf r -> Just r + | otherwise -> unsafePerformIO (putStrLn $ + "Couldn't match `" ++show(typeOf r) ++ + "' against `" ++show t ++"'"++ + "\n\tExpected type: " ++show(typeOf r) ++ + "\n\tInferred type: " ++show t + ) `seq` Nothing + +fromDynamic d = case fromDyn d of + Just v -> v + Nothing -> error ("\nType error in dynamic unwrapping.\n" ++ + "In value `" ++ show d ++ "'") + +dynApp :: Dynamic -> Dynamic -> Dynamic +dynApp f x = case dynApply f x of + Just r -> r + Nothing -> error ("Type error in dynamic application.\n" ++ + "Can't apply function " ++ show f ++ + " to argument " ++ show x) + +-- +-- (f::(a->b)) `dynApply` (x::a) = (f a)::b +-- +dynApply :: Dynamic -> Dynamic -> Maybe Dynamic +dynApply (Dynamic t1 f) (Dynamic t2 x) = +#if __GLASGOW_HASKELL__ >= 603 + case funResultTy t1 t2 of +#else + case applyTy t1 t2 of +#endif + Just t3 -> Just (Dynamic t3 ((unsafeCoerce# f) x)) + Nothing -> Nothing + + +-- +-- hmm +-- +dynAppHList :: Dynamic -> [Dynamic] -> Dynamic +dynAppHList fn [] = fn -- partial applicaiton +dynAppHList fn (x:xs) = (fn `dynApp` x) `dynAppHList` xs + +-- --------------------------------------------------------------------- +-- +-- Implementation of typecase, without patterns, based on "Dynamic +-- typing in a statically typed language". Mart\'in Abadi, Luca +-- Cardelli, Benjamin Pierce and Gordon Plotkin. ACM Trans. Prog. Lang. +-- and Syst. 13(2):237-268, 1991. +-- +-- Doesn't provide the behaviour that if the value is not a Dynamic, +-- then typecase returns a error. Need low-level ops for that. +-- + +-- typecase :: Typeable u => Dynamic -> [(TypeRep, Dynamic)] -> u -> u + +typecase :: Typeable u + => Dynamic -- selector + -> [(Dynamic, Dynamic)] -- branches + -> u -- else arm + -> u -- return type + +typecase dv@(Dynamic ty _) alts dflt = + case find (hasType ty) alts of + Nothing -> dflt + Just v -> fromDynamic $ snd v `dynApp` dv + + where hasType t ((Dynamic u _),_) = t == u + +infixl 6 --> +(-->) :: Typeable b => a -> b -> (a,Dynamic) +a --> b = (a,toDyn b) + +-- +-- need a way to generate a Dynamic prelude +-- +_Int = toDyn ( undefined :: Int ) +_Char = toDyn ( undefined :: Char ) +_Bool = toDyn ( undefined :: Bool ) +_String = toDyn ( undefined :: [Char] ) +_IntToInt = toDyn ( undefined :: Int -> Int ) + +------------------------------------------------------------------------ diff --git a/src/altdata/AltData/Typeable.hs b/src/altdata/AltData/Typeable.hs new file mode 100644 index 0000000..ef3957d --- /dev/null +++ b/src/altdata/AltData/Typeable.hs @@ -0,0 +1,958 @@ +{-# OPTIONS -cpp -fglasgow-exts -fno-implicit-prelude #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +-- Based on: +-- +-- | +-- Module : Data.Typeable +-- Copyright : (c) The University of Glasgow, CWI 2001--2004 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- The Typeable class reifies types to some extent by associating type +-- representations to types. These type representations can be compared, +-- and one can in turn define a type-safe cast operation. To this end, +-- an unsafe cast is guarded by a test for type (representation) +-- equivalence. The module Data.Dynamic uses Typeable for an +-- implementation of dynamics. The module Data.Generics uses Typeable +-- and type-safe cast (but not dynamics) to support the \"Scrap your +-- boilerplate\" style of generic programming. +-- + +module AltData.Typeable + +#if __GLASGOW_HASKELL__ >= 603 + ( + + -- * The Typeable class + Typeable( typeOf ), -- :: a -> TypeRep + + -- * Type-safe cast + cast, -- :: (Typeable a, Typeable b) => a -> Maybe b + gcast, -- a generalisation of cast + + -- * Type representations + TypeRep, -- abstract, instance of: Eq, Show, Typeable + TyCon, -- abstract, instance of: Eq, Show, Typeable + + -- * Construction of type representations + mkTyCon, -- :: String -> TyCon + mkTyConApp, -- :: TyCon -> [TypeRep] -> TypeRep + mkAppTy, -- :: TypeRep -> TypeRep -> TypeRep + mkFunTy, -- :: TypeRep -> TypeRep -> TypeRep + + -- * Observation of type representations + splitTyConApp, -- :: TypeRep -> (TyCon, [TypeRep]) + funResultTy, -- :: TypeRep -> TypeRep -> Maybe TypeRep + typeRepTyCon, -- :: TypeRep -> TyCon + typeRepArgs, -- :: TypeRep -> [TypeRep] + tyConString, -- :: TyCon -> String + + -- * The other Typeable classes + -- | /Note:/ The general instances are provided for GHC only. + Typeable1( typeOf1 ), -- :: t a -> TypeRep + Typeable2( typeOf2 ), -- :: t a b -> TypeRep + Typeable3( typeOf3 ), -- :: t a b c -> TypeRep + Typeable4( typeOf4 ), -- :: t a b c d -> TypeRep + Typeable5( typeOf5 ), -- :: t a b c d e -> TypeRep + Typeable6( typeOf6 ), -- :: t a b c d e f -> TypeRep + Typeable7( typeOf7 ), -- :: t a b c d e f g -> TypeRep + gcast1, -- :: ... => c (t a) -> Maybe (c (t' a)) + gcast2, -- :: ... => c (t a b) -> Maybe (c (t' a b)) + + -- * Default instances + -- | /Note:/ These are not needed by GHC, for which these instances + -- are generated by general instance declarations. + typeOfDefault, -- :: (Typeable1 t, Typeable a) => t a -> TypeRep + typeOf1Default, -- :: (Typeable2 t, Typeable a) => t a b -> TypeRep + typeOf2Default, -- :: (Typeable3 t, Typeable a) => t a b c -> TypeRep + typeOf3Default, -- :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep + typeOf4Default, -- :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep + typeOf5Default, -- :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep + typeOf6Default -- :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep + + ) where + +import qualified Data.HashTable as HT +import Data.Maybe +import Data.Either +import Data.Int +import Data.Word +import Data.List( foldl ) + +import GHC.Base +import GHC.Show +import GHC.Err +import GHC.Num +import GHC.Float +import GHC.Real( rem, Ratio ) +import GHC.IOBase +import GHC.Ptr -- So we can give Typeable instance for Ptr +import GHC.Stable -- So we can give Typeable instance for StablePtr + +unsafeCoerce :: a -> b +unsafeCoerce = unsafeCoerce# + +#include "Typeable.h" + +------------------------------------------------------------- +-- +-- Type representations +-- +------------------------------------------------------------- + +-- | A concrete representation of a (monomorphic) type. 'TypeRep' +-- supports reasonably efficient equality. +-- +-- equality of keys doesn't work for dynamically loaded code, so we +-- revert back to canonical type names. +-- +data TypeRep = TypeRep !Key TyCon [TypeRep] + +-- Compare keys for equality +instance Eq TypeRep where + (TypeRep _ t1 a1) == (TypeRep _ t2 a2) = t1 == t2 && a1 == a2 + +-- | An abstract representation of a type constructor. 'TyCon' objects can +-- be built using 'mkTyCon'. +data TyCon = TyCon !Key String + +instance Eq TyCon where + (TyCon _ s1) == (TyCon _ s2) = s1 == s2 + + -- + -- let fTy = mkTyCon "Foo" in show (mkTyConApp (mkTyCon ",,") + -- [fTy,fTy,fTy]) + -- + -- returns "(Foo,Foo,Foo)" + -- + -- The TypeRep Show instance promises to print tuple types + -- correctly. Tuple type constructors are specified by a + -- sequence of commas, e.g., (mkTyCon ",,,,") returns + -- the 5-tuple tycon. + +----------------- Construction -------------------- + +-- | Applies a type constructor to a sequence of types +mkTyConApp :: TyCon -> [TypeRep] -> TypeRep +mkTyConApp tc@(TyCon tc_k _) args + = TypeRep (appKeys tc_k arg_ks) tc args + where + arg_ks = [k | TypeRep k _ _ <- args] + +-- | A special case of 'mkTyConApp', which applies the function +-- type constructor to a pair of types. +mkFunTy :: TypeRep -> TypeRep -> TypeRep +mkFunTy f a = mkTyConApp funTc [f,a] + +-- | Splits a type constructor application +splitTyConApp :: TypeRep -> (TyCon,[TypeRep]) +splitTyConApp (TypeRep _ tc trs) = (tc,trs) + +-- | Applies a type to a function type. Returns: @'Just' u@ if the +-- first argument represents a function of type @t -> u@ and the +-- second argument represents a function of type @t@. Otherwise, +-- returns 'Nothing'. +funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep +funResultTy trFun trArg + = case splitTyConApp trFun of + (tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2 + _ -> Nothing + +-- | Adds a TypeRep argument to a TypeRep. +mkAppTy :: TypeRep -> TypeRep -> TypeRep +mkAppTy (TypeRep tr_k tc trs) arg_tr + = let (TypeRep arg_k _ _) = arg_tr + in TypeRep (appKey tr_k arg_k) tc (trs++[arg_tr]) + +-- If we enforce the restriction that there is only one +-- @TyCon@ for a type & it is shared among all its uses, +-- we can map them onto Ints very simply. The benefit is, +-- of course, that @TyCon@s can then be compared efficiently. + +-- Provided the implementor of other @Typeable@ instances +-- takes care of making all the @TyCon@s CAFs (toplevel constants), +-- this will work. + +-- If this constraint does turn out to be a sore thumb, changing +-- the Eq instance for TyCons is trivial. + +-- | Builds a 'TyCon' object representing a type constructor. An +-- implementation of "Data.Typeable" should ensure that the following holds: +-- +-- > mkTyCon "a" == mkTyCon "a" +-- + +mkTyCon :: String -- ^ the name of the type constructor (should be unique + -- in the program, so it might be wise to use the + -- fully qualified name). + -> TyCon -- ^ A unique 'TyCon' object +mkTyCon str = TyCon (mkTyConKey str) str + +----------------- Observation --------------------- + +-- | Observe the type constructor of a type representation +typeRepTyCon :: TypeRep -> TyCon +typeRepTyCon (TypeRep _ tc _) = tc + +-- | Observe the argument types of a type representation +typeRepArgs :: TypeRep -> [TypeRep] +typeRepArgs (TypeRep _ _ args) = args + +-- | Observe string encoding of a type representation +tyConString :: TyCon -> String +tyConString (TyCon _ str) = str + +----------------- Showing TypeReps -------------------- + +instance Show TypeRep where + showsPrec p (TypeRep _ tycon tys) = + case tys of + [] -> showsPrec p tycon + [x] | tycon == listTc -> showChar '[' . shows x . showChar ']' + [a,r] | tycon == funTc -> showParen (p > 8) $ + showsPrec 9 a . + showString " -> " . + showsPrec 8 r + xs | isTupleTyCon tycon -> showTuple tycon xs + | otherwise -> + showParen (p > 9) $ + showsPrec p tycon . + showChar ' ' . + showArgs tys + +instance Show TyCon where + showsPrec _ (TyCon _ s) = showString s + +isTupleTyCon :: TyCon -> Bool +isTupleTyCon (TyCon _ (',':_)) = True +isTupleTyCon _ = False + +-- Some (Show.TypeRep) helpers: + +showArgs :: Show a => [a] -> ShowS +showArgs [] = id +showArgs [a] = showsPrec 10 a +showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as + +showTuple :: TyCon -> [TypeRep] -> ShowS +showTuple (TyCon _ str) args = showChar '(' . go str args + where + go [] [a] = showsPrec 10 a . showChar ')' + go _ [] = showChar ')' -- a failure condition, really. + go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as + go _ _ = showChar ')' + +------------------------------------------------------------- +-- +-- The Typeable class and friends +-- +------------------------------------------------------------- + +-- | The class 'Typeable' allows a concrete representation of a type to +-- be calculated. +class Typeable a where + typeOf :: a -> TypeRep + -- ^ Takes a value of type @a@ and returns a concrete representation + -- of that type. The /value/ of the argument should be ignored by + -- any instance of 'Typeable', so that it is safe to pass 'undefined' as + -- the argument. + +-- | Variant for unary type constructors +class Typeable1 t where + typeOf1 :: t a -> TypeRep + +-- | For defining a 'Typeable' instance from any 'Typeable1' instance. +typeOfDefault :: (Typeable1 t, Typeable a) => t a -> TypeRep +typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x) + where + argType :: t a -> a + argType = undefined + +-- | Variant for binary type constructors +class Typeable2 t where + typeOf2 :: t a b -> TypeRep + +-- | For defining a 'Typeable1' instance from any 'Typeable2' instance. +typeOf1Default :: (Typeable2 t, Typeable a) => t a b -> TypeRep +typeOf1Default x = typeOf2 x `mkAppTy` typeOf (argType x) + where + argType :: t a b -> a + argType = undefined + +-- | Variant for 3-ary type constructors +class Typeable3 t where + typeOf3 :: t a b c -> TypeRep + +-- | For defining a 'Typeable2' instance from any 'Typeable3' instance. +typeOf2Default :: (Typeable3 t, Typeable a) => t a b c -> TypeRep +typeOf2Default x = typeOf3 x `mkAppTy` typeOf (argType x) + where + argType :: t a b c -> a + argType = undefined + +-- | Variant for 4-ary type constructors +class Typeable4 t where + typeOf4 :: t a b c d -> TypeRep + +-- | For defining a 'Typeable3' instance from any 'Typeable4' instance. +typeOf3Default :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep +typeOf3Default x = typeOf4 x `mkAppTy` typeOf (argType x) + where + argType :: t a b c d -> a + argType = undefined + +-- | Variant for 5-ary type constructors +class Typeable5 t where + typeOf5 :: t a b c d e -> TypeRep + +-- | For defining a 'Typeable4' instance from any 'Typeable5' instance. +typeOf4Default :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep +typeOf4Default x = typeOf5 x `mkAppTy` typeOf (argType x) + where + argType :: t a b c d e -> a + argType = undefined + +-- | Variant for 6-ary type constructors +class Typeable6 t where + typeOf6 :: t a b c d e f -> TypeRep + +-- | For defining a 'Typeable5' instance from any 'Typeable6' instance. +typeOf5Default :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep +typeOf5Default x = typeOf6 x `mkAppTy` typeOf (argType x) + where + argType :: t a b c d e f -> a + argType = undefined + +-- | Variant for 7-ary type constructors +class Typeable7 t where + typeOf7 :: t a b c d e f g -> TypeRep + +-- | For defining a 'Typeable6' instance from any 'Typeable7' instance. +typeOf6Default :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep +typeOf6Default x = typeOf7 x `mkAppTy` typeOf (argType x) + where + argType :: t a b c d e f g -> a + argType = undefined + +-- Given a @Typeable@/n/ instance for an /n/-ary type constructor, +-- define the instances for partial applications. +-- Programmers using non-GHC implementations must do this manually +-- for each type constructor. +-- (The INSTANCE_TYPEABLE/n/ macros in Typeable.h include this.) + +-- | One Typeable instance for all Typeable1 instances +instance (Typeable1 s, Typeable a) + => Typeable (s a) where + typeOf = typeOfDefault + +-- | One Typeable1 instance for all Typeable2 instances +instance (Typeable2 s, Typeable a) + => Typeable1 (s a) where + typeOf1 = typeOf1Default + +-- | One Typeable2 instance for all Typeable3 instances +instance (Typeable3 s, Typeable a) + => Typeable2 (s a) where + typeOf2 = typeOf2Default + +-- | One Typeable3 instance for all Typeable4 instances +instance (Typeable4 s, Typeable a) + => Typeable3 (s a) where + typeOf3 = typeOf3Default + +-- | One Typeable4 instance for all Typeable5 instances +instance (Typeable5 s, Typeable a) + => Typeable4 (s a) where + typeOf4 = typeOf4Default + +-- | One Typeable5 instance for all Typeable6 instances +instance (Typeable6 s, Typeable a) + => Typeable5 (s a) where + typeOf5 = typeOf5Default + +-- | One Typeable6 instance for all Typeable7 instances +instance (Typeable7 s, Typeable a) + => Typeable6 (s a) where + typeOf6 = typeOf6Default + +------------------------------------------------------------- +-- +-- Type-safe cast +-- +------------------------------------------------------------- + +-- | The type-safe cast operation +cast :: (Typeable a, Typeable b) => a -> Maybe b +cast x = r + where + r = if typeOf x == typeOf (fromJust r) + then Just $ unsafeCoerce x + else Nothing + +-- | A flexible variation parameterised in a type constructor +gcast :: (Typeable a, Typeable b) => c a -> Maybe (c b) +gcast x = r + where + r = if typeOf (getArg x) == typeOf (getArg (fromJust r)) + then Just $ unsafeCoerce x + else Nothing + getArg :: c x -> x + getArg = undefined + +-- | Cast for * -> * +gcast1 :: (Typeable1 t, Typeable1 t') => c (t a) -> Maybe (c (t' a)) +gcast1 x = r + where + r = if typeOf1 (getArg x) == typeOf1 (getArg (fromJust r)) + then Just $ unsafeCoerce x + else Nothing + getArg :: c x -> x + getArg = undefined + +-- | Cast for * -> * -> * +gcast2 :: (Typeable2 t, Typeable2 t') => c (t a b) -> Maybe (c (t' a b)) +gcast2 x = r + where + r = if typeOf2 (getArg x) == typeOf2 (getArg (fromJust r)) + then Just $ unsafeCoerce x + else Nothing + getArg :: c x -> x + getArg = undefined + +------------------------------------------------------------- +-- +-- Instances of the Typeable classes for Prelude types +-- +------------------------------------------------------------- + +INSTANCE_TYPEABLE1([],listTc,"[]") +INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe") +INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio") +INSTANCE_TYPEABLE2(Either,eitherTc,"Either") +INSTANCE_TYPEABLE2((->),funTc,"->") +INSTANCE_TYPEABLE1(IO,ioTc,"IO") +INSTANCE_TYPEABLE0((),unitTc,"()") + +INSTANCE_TYPEABLE2((,),pairTc,",") +INSTANCE_TYPEABLE3((,,),tup3Tc,",,") + +tup4Tc :: TyCon +tup4Tc = mkTyCon ",,," + +instance Typeable4 (,,,) where + typeOf4 _ = mkTyConApp tup4Tc [] + +tup5Tc :: TyCon +tup5Tc = mkTyCon ",,,," + +instance Typeable5 (,,,,) where + typeOf5 _ = mkTyConApp tup5Tc [] + +tup6Tc :: TyCon +tup6Tc = mkTyCon ",,,,," + +instance Typeable6 (,,,,,) where + typeOf6 _ = mkTyConApp tup6Tc [] + +tup7Tc :: TyCon +tup7Tc = mkTyCon ",,,,," + +instance Typeable7 (,,,,,,) where + typeOf7 _ = mkTyConApp tup7Tc [] + +INSTANCE_TYPEABLE1(Ptr,ptrTc,"Foreign.Ptr.Ptr") +INSTANCE_TYPEABLE1(StablePtr,stableptrTc,"Foreign.StablePtr.StablePtr") +INSTANCE_TYPEABLE1(IORef,iorefTc,"Data.IORef.IORef") + +------------------------------------------------------- +-- +-- Generate Typeable instances for standard datatypes +-- +------------------------------------------------------- + +INSTANCE_TYPEABLE0(Bool,boolTc,"Bool") +INSTANCE_TYPEABLE0(Char,charTc,"Char") +INSTANCE_TYPEABLE0(Float,floatTc,"Float") +INSTANCE_TYPEABLE0(Double,doubleTc,"Double") +INSTANCE_TYPEABLE0(Int,intTc,"Int") +INSTANCE_TYPEABLE0(Integer,integerTc,"Integer") +INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering") +INSTANCE_TYPEABLE0(Handle,handleTc,"Handle") + +INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8") +INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16") +INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32") +INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64") + +INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" ) +INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16") +INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32") +INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64") + +INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon") +INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep") + +INSTANCE_TYPEABLE0(Word,wordTc,"Word" ) + +#else /* GHC < 6.3 */ + + ( + -- * The Typeable class + Typeable( typeOf ), -- :: a -> TypeRep + + -- * Type-safe cast + cast, -- :: (Typeable a, Typeable b) => a -> Maybe b + castss, -- a cast for kind "* -> *" + castarr, -- another convenient variation + + -- * Type representations + TypeRep, -- abstract, instance of: Eq, Show, Typeable + TyCon, -- abstract, instance of: Eq, Show, Typeable + + -- * Construction of type representations + mkTyCon, -- :: String -> TyCon + mkAppTy, -- :: TyCon -> [TypeRep] -> TypeRep + mkFunTy, -- :: TypeRep -> TypeRep -> TypeRep + applyTy, -- :: TypeRep -> TypeRep -> Maybe TypeRep + + -- * Observation of type representations + typerepTyCon, -- :: TypeRep -> TyCon + typerepArgs, -- :: TypeRep -> [TypeRep] + tyconString -- :: TyCon -> String + + + ) where + +import qualified Data.HashTable as HT +import Data.Maybe +import Data.Either +import Data.Int +import Data.Word +import Data.List( foldl ) + +import GHC.Base +import GHC.Show +import GHC.Err +import GHC.Num +import GHC.Float +import GHC.Real( rem, Ratio ) +import GHC.IOBase +import GHC.Ptr -- So we can give Typeable instance for Ptr +import GHC.Stable -- So we can give Typeable instance for StablePtr + +unsafeCoerce :: a -> b +unsafeCoerce = unsafeCoerce# + +#include "Typeable.h" + + +------------------------------------------------------------- +-- +-- Type representations +-- +------------------------------------------------------------- + + +-- | A concrete representation of a (monomorphic) type. 'TypeRep' +-- supports reasonably efficient equality. +data TypeRep = TypeRep !Key TyCon [TypeRep] + +-- Compare keys for equality +instance Eq TypeRep where + (TypeRep _ t1 a1) == (TypeRep _ t2 a2) = t1 == t2 && a1 == a2 + +-- | An abstract representation of a type constructor. 'TyCon' objects can +-- be built using 'mkTyCon'. +data TyCon = TyCon !Key String + +instance Eq TyCon where + (TyCon _ s1) == (TyCon _ s2) = s1 == s2 + + -- + -- let fTy = mkTyCon "Foo" in show (mkAppTy (mkTyCon ",,") + -- [fTy,fTy,fTy]) + -- + -- returns "(Foo,Foo,Foo)" + -- + -- The TypeRep Show instance promises to print tuple types + -- correctly. Tuple type constructors are specified by a + -- sequence of commas, e.g., (mkTyCon ",,,,") returns + -- the 5-tuple tycon. + +----------------- Construction -------------------- + +-- | Applies a type constructor to a sequence of types +mkAppTy :: TyCon -> [TypeRep] -> TypeRep +mkAppTy tc@(TyCon tc_k _) args + = TypeRep (appKeys tc_k arg_ks) tc args + where + arg_ks = [k | TypeRep k _ _ <- args] + +funTc :: TyCon +funTc = mkTyCon "->" + +-- | A special case of 'mkAppTy', which applies the function +-- type constructor to a pair of types. +mkFunTy :: TypeRep -> TypeRep -> TypeRep +mkFunTy f a = mkAppTy funTc [f,a] + +-- | Applies a type to a function type. Returns: @'Just' u@ if the +-- first argument represents a function of type @t -> u@ and the +-- second argument represents a function of type @t@. Otherwise, +-- returns 'Nothing'. +applyTy :: TypeRep -> TypeRep -> Maybe TypeRep +applyTy (TypeRep _ tc [t1,t2]) t3 + | tc == funTc && t1 == t3 = Just t2 +applyTy _ _ = Nothing + +-- If we enforce the restriction that there is only one +-- @TyCon@ for a type & it is shared among all its uses, +-- we can map them onto Ints very simply. The benefit is, +-- of course, that @TyCon@s can then be compared efficiently. + +-- Provided the implementor of other @Typeable@ instances +-- takes care of making all the @TyCon@s CAFs (toplevel constants), +-- this will work. + +-- If this constraint does turn out to be a sore thumb, changing +-- the Eq instance for TyCons is trivial. + +-- | Builds a 'TyCon' object representing a type constructor. An +-- implementation of "Data.Typeable" should ensure that the following holds: +-- +-- > mkTyCon "a" == mkTyCon "a" +-- + +mkTyCon :: String -- ^ the name of the type constructor (should be unique + -- in the program, so it might be wise to use the + -- fully qualified name). + -> TyCon -- ^ A unique 'TyCon' object +mkTyCon str = TyCon (mkTyConKey str) str + + + +----------------- Observation --------------------- + + +-- | Observe the type constructor of a type representation +typerepTyCon :: TypeRep -> TyCon +typerepTyCon (TypeRep _ tc _) = tc + + +-- | Observe the argument types of a type representation +typerepArgs :: TypeRep -> [TypeRep] +typerepArgs (TypeRep _ _ args) = args + + +-- | Observe string encoding of a type representation +tyconString :: TyCon -> String +tyconString (TyCon _ str) = str + + +----------------- Showing TypeReps -------------------- + +instance Show TypeRep where + showsPrec p (TypeRep _ tycon tys) = + case tys of + [] -> showsPrec p tycon + [x] | tycon == listTc -> showChar '[' . shows x . showChar ']' + [a,r] | tycon == funTc -> showParen (p > 8) $ + showsPrec 9 a . showString " -> " . showsPrec 8 r + xs | isTupleTyCon tycon -> showTuple tycon xs + | otherwise -> + showParen (p > 9) $ + showsPrec p tycon . + showChar ' ' . + showArgs tys + +instance Show TyCon where + showsPrec _ (TyCon _ s) = showString s + +isTupleTyCon :: TyCon -> Bool +isTupleTyCon (TyCon _ (',':_)) = True +isTupleTyCon _ = False + +-- Some (Show.TypeRep) helpers: + +showArgs :: Show a => [a] -> ShowS +showArgs [] = id +showArgs [a] = showsPrec 10 a +showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as + +showTuple :: TyCon -> [TypeRep] -> ShowS +showTuple (TyCon _ str) args = showChar '(' . go str args + where + go [] [a] = showsPrec 10 a . showChar ')' + go _ [] = showChar ')' -- a failure condition, really. + go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as + go _ _ = showChar ')' + + +------------------------------------------------------------- +-- +-- The Typeable class +-- +------------------------------------------------------------- + +-- | The class 'Typeable' allows a concrete representation of a type to +-- be calculated. +class Typeable a where + typeOf :: a -> TypeRep + -- ^ Takes a value of type @a@ and returns a concrete representation + -- of that type. The /value/ of the argument should be ignored by + -- any instance of 'Typeable', so that it is safe to pass 'undefined' as + -- the argument. + + +------------------------------------------------------------- +-- +-- Type-safe cast +-- +------------------------------------------------------------- + +-- | The type-safe cast operation +cast :: (Typeable a, Typeable b) => a -> Maybe b +cast x = r + where + r = if typeOf x == typeOf (fromJust r) + then Just $ unsafeCoerce x + else Nothing + + +-- | A convenient variation for kind "* -> *" +castss :: (Typeable a, Typeable b) => t a -> Maybe (t b) +castss x = r + where + r = if typeOf (get x) == typeOf (get (fromJust r)) + then Just $ unsafeCoerce x + else Nothing + get :: t c -> c + get = undefined + + +-- | Another variation +castarr :: (Typeable a, Typeable b, Typeable c, Typeable d) + => (a -> t b) -> Maybe (c -> t d) +castarr x = r + where + r = if typeOf (get x) == typeOf (get (fromJust r)) + then Just $ unsafeCoerce x + else Nothing + get :: (e -> t f) -> (e, f) + get = undefined + +{- + +The variations castss and castarr are arguably not really needed. +Let's discuss castss in some detail. To get rid of castss, we can +require "Typeable (t a)" and "Typeable (t b)" rather than just +"Typeable a" and "Typeable b". In that case, the ordinary cast would +work. Eventually, all kinds of library instances should become +Typeable. (There is another potential use of variations as those given +above. It allows quantification on type constructors. + +-} + + +------------------------------------------------------------- +-- +-- Instances of the Typeable class for Prelude types +-- +------------------------------------------------------------- + +listTc :: TyCon +listTc = mkTyCon "[]" + +instance Typeable a => Typeable [a] where + typeOf ls = mkAppTy listTc [typeOf ((undefined :: [a] -> a) ls)] + -- In GHC we can say + -- typeOf (undefined :: a) + -- using scoped type variables, but we use the + -- more verbose form here, for compatibility with Hugs + +unitTc :: TyCon +unitTc = mkTyCon "()" + +instance Typeable () where + typeOf _ = mkAppTy unitTc [] + +tup2Tc :: TyCon +tup2Tc = mkTyCon "," + +instance (Typeable a, Typeable b) => Typeable (a,b) where + typeOf tu = mkAppTy tup2Tc [typeOf ((undefined :: (a,b) -> a) tu), + typeOf ((undefined :: (a,b) -> b) tu)] + +tup3Tc :: TyCon +tup3Tc = mkTyCon ",," + +instance ( Typeable a , Typeable b , Typeable c) => Typeable (a,b,c) where + typeOf tu = mkAppTy tup3Tc [typeOf ((undefined :: (a,b,c) -> a) tu), + typeOf ((undefined :: (a,b,c) -> b) tu), + typeOf ((undefined :: (a,b,c) -> c) tu)] + +tup4Tc :: TyCon +tup4Tc = mkTyCon ",,," + +instance ( Typeable a + , Typeable b + , Typeable c + , Typeable d) => Typeable (a,b,c,d) where + typeOf tu = mkAppTy tup4Tc [typeOf ((undefined :: (a,b,c,d) -> a) tu), + typeOf ((undefined :: (a,b,c,d) -> b) tu), + typeOf ((undefined :: (a,b,c,d) -> c) tu), + typeOf ((undefined :: (a,b,c,d) -> d) tu)] +tup5Tc :: TyCon +tup5Tc = mkTyCon ",,,," + +instance ( Typeable a + , Typeable b + , Typeable c + , Typeable d + , Typeable e) => Typeable (a,b,c,d,e) where + typeOf tu = mkAppTy tup5Tc [typeOf ((undefined :: (a,b,c,d,e) -> a) tu), + typeOf ((undefined :: (a,b,c,d,e) -> b) tu), + typeOf ((undefined :: (a,b,c,d,e) -> c) tu), + typeOf ((undefined :: (a,b,c,d,e) -> d) tu), + typeOf ((undefined :: (a,b,c,d,e) -> e) tu)] + +instance (Typeable a, Typeable b) => Typeable (a -> b) where + typeOf f = mkFunTy (typeOf ((undefined :: (a -> b) -> a) f)) + (typeOf ((undefined :: (a -> b) -> b) f)) + + + +------------------------------------------------------- +-- +-- Generate Typeable instances for standard datatypes +-- +------------------------------------------------------- + +INSTANCE_TYPEABLE0(Bool,boolTc,"Bool") +INSTANCE_TYPEABLE0(Char,charTc,"Char") +INSTANCE_TYPEABLE0(Float,floatTc,"Float") +INSTANCE_TYPEABLE0(Double,doubleTc,"Double") +INSTANCE_TYPEABLE0(Int,intTc,"Int") +INSTANCE_TYPEABLE0(Integer,integerTc,"Integer") +INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio") +INSTANCE_TYPEABLE2(Either,eitherTc,"Either") +INSTANCE_TYPEABLE1(IO,ioTc,"IO") +INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe") +INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering") +INSTANCE_TYPEABLE0(Handle,handleTc,"Handle") +INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr") +INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr") + +INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8") +INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16") +INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32") +INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64") + +INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" ) +INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16") +INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32") +INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64") + +INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon") +INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep") + +INSTANCE_TYPEABLE1(IORef,ioRefTc,"IORef") + +#endif /* GHC < 6.3 */ + + +--------------------------------------------- +-- +-- Internals +-- +--------------------------------------------- + +newtype Key = Key Int deriving( Eq ) + +data KeyPr = KeyPr !Key !Key deriving( Eq ) + +hashKP :: KeyPr -> Int32 +hashKP (KeyPr (Key k1) (Key k2)) = (HT.hashInt k1 + HT.hashInt k2) `rem` HT.prime + +data Cache = Cache { next_key :: !(IORef Key), + tc_tbl :: !(HT.HashTable String Key), + ap_tbl :: !(HT.HashTable KeyPr Key) } + +{-# NOINLINE cache #-} +cache :: Cache +cache = unsafePerformIO $ do + empty_tc_tbl <- HT.new (==) HT.hashString + empty_ap_tbl <- HT.new (==) hashKP + key_loc <- newIORef (Key 1) + return (Cache { next_key = key_loc, + tc_tbl = empty_tc_tbl, + ap_tbl = empty_ap_tbl }) + +newKey :: IORef Key -> IO Key +newKey _ = do i <- genSym; return (Key i) + + +-- In GHC we use the RTS's genSym function to get a new unique, +-- because in GHCi we might have two copies of the Data.Typeable +-- library running (one in the compiler and one in the running +-- program), and we need to make sure they don't share any keys. +-- +-- This is really a hack. A better solution would be to centralise the +-- whole mutable state used by this module, i.e. both hashtables. But +-- the current solution solves the immediate problem, which is that +-- dynamics generated in one world with one type were erroneously +-- being recognised by the other world as having a different type. +-- +-- dons: SimonM says we need to unify the hashes by storing them in a +-- variable in the rts. +-- +foreign import ccall unsafe "genSymZh" + genSym :: IO Int + +mkTyConKey :: String -> Key +mkTyConKey str + = unsafePerformIO $ do + let Cache {next_key = kloc, tc_tbl = tbl} = cache + mb_k <- HT.lookup tbl str + case mb_k of + Just k -> return k + Nothing -> do { k <- newKey kloc ; + HT.insert tbl str k ; + return k } + +appKey :: Key -> Key -> Key +appKey k1 k2 + = unsafePerformIO $ do + let Cache {next_key = kloc, ap_tbl = tbl} = cache + mb_k <- HT.lookup tbl kpr + case mb_k of + Just k -> return k + Nothing -> do { k <- newKey kloc ; + HT.insert tbl kpr k ; + return k } + where + kpr = KeyPr k1 k2 + +appKeys :: Key -> [Key] -> Key +appKeys k ks = foldl appKey k ks diff --git a/src/altdata/Makefile b/src/altdata/Makefile new file mode 100644 index 0000000..e2a79dd --- /dev/null +++ b/src/altdata/Makefile @@ -0,0 +1,7 @@ +PKG = altdata +UPKG = AltData + +TOP=../.. +include ../build.mk + +install: install-me diff --git a/src/altdata/altdata.conf.in.cpp b/src/altdata/altdata.conf.in.cpp new file mode 100644 index 0000000..252ec8f --- /dev/null +++ b/src/altdata/altdata.conf.in.cpp @@ -0,0 +1,53 @@ +#if CABAL == 0 && GLASGOW_HASKELL < 604 +Package { + name = "altdata", + auto = False, + hs_libraries = [ "HSaltdata" ], +#ifdef INSTALLING + import_dirs = [ "${LIBDIR}/imports" ], + library_dirs = [ "${LIBDIR}" ], +#else + import_dirs = [ "${TOP}/src/altdata" ], + library_dirs = [ "${TOP}/src/altdata" ], +#endif + include_dirs = [], + c_includes = [], + source_dirs = [], + extra_libraries = [], + package_deps = [ "base" ], + extra_ghc_opts = [], + extra_cc_opts = [], + extra_ld_opts = [] +} +#else +name: altdata +version: 0.9.8 +license: LGPL +maintainer: dons@cse.unsw.edu.au +exposed: True +exposed-modules: + AltData.Dynamic, + AltData.Typeable, + AltData + +hidden-modules: +#ifdef INSTALLING +import-dirs: LIBDIR/imports +library-dirs: LIBDIR +#else +import-dirs: TOP/src/altdata +library-dirs: TOP/src/altdata +#endif +hs-libraries: HSaltdata +extra-libraries: +include-dirs: +includes: +depends: base +hugs-options: +cc-options: +ld-options: +framework-dirs: +frameworks: +haddock-interfaces: +haddock-html: +#endif diff --git a/src/build.mk b/src/build.mk new file mode 100644 index 0000000..310e688 --- /dev/null +++ b/src/build.mk @@ -0,0 +1,91 @@ +# +# Copyright (c) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons +# LGPL version 2.1 or later (see http://www.gnu.org/copyleft/lesser.html) +# + +include $(TOP)/config.mk + +MAIN = $(UPKG).hs +LIBRARY = libHS$(PKG).a +GHCI_LIBRARY = HS$(PKG).o +OBJS = $(UPKG).o $(UPKG)/*.o + +HC_OPTS = -package-name $(PKG) +HC_OPTS += -O -Wall -Werror -fno-warn-missing-signatures $(GHC_EXTRA_OPTS) + +CLEANS += $(LIBRARY) $(GHCI_LIBRARY) +CLEAN_FILES += *.conf.inplace* *.conf.*.old *.conf.in *.h *.in + +.PHONY: clean all alt_objs inplace-pkg-conf happy banner + +all : $(LIBRARY) inplace-pkg-conf $(PKG).conf.in + +# libraries +$(LIBRARY): banner $(COBJ) $(XOBJ) $(YOBJ) objs + @$(RM) -f $@ + @$(AR) cq $@ $(OBJS) + @$(RANLIB) $@ + +banner: + @echo "=========== building $(PKG) =============" + +# happy files +$(YOBJ): $(YSRC) + $(HAPPY) $(HAPPY_OPTS) -o $@ $(YSRC) + +# alex files +$(XOBJ): $(XSRC) + $(ALEX) $(ALEX_OPTS) -o $@ $(XSRC) + +# objects +objs:: + $(GHC) $(HC_OPTS) --make -no-hs-main -no-link $(MAIN) + +$(COBJ): $(CSRC) + $(GHC) -c $(CSRC) -o $@ + +# package.confs and friends +# ghc-6.2.2 needs TOP as env var. +inplace-pkg-conf: $(LIBRARY) + @rm -f $(GHCI_LIBRARY) + @cpp -DTOP=$(TOP) -DGLASGOW_HASKELL=$(GLASGOW_HASKELL) -DCABAL=$(CABAL) -undef < $(PKG).conf.in.cpp | sed -e 's/""//g' -e 's/\[ *,/[ /g' -e '/^#/d' > $(PKG).conf.inplace.in + @(cd $(TOP) ;\ + if [ ! -f plugins.conf.inplace ]; then echo [] > plugins.conf.inplace; fi;\ + env TOP=$(TOP) $(GHC_PKG) -g -f plugins.conf.inplace -u < src/$(PKG)/$(PKG).conf.inplace.in) + +# installation pkg.confs +$(PKG).conf.in : $(PKG).conf.in.cpp + @cpp -DLIBDIR=$(LIBDIR) -DGLASGOW_HASKELL=$(GLASGOW_HASKELL) -DCABAL=$(CABAL) -DINSTALLING -Uunix < $(PKG).conf.in.cpp | sed -e 's/""//g' -e 's/\[ *,/[ /g' -e '/^#/d' > $@ + +# +# todo. need to re-ranlib the library +# +.PHONY: install install-me +install-me: + $(INSTALL_DATA_DIR) $(LIBDIR)/imports/$(UPKG) + @for i in $(TOP)/src/$(PKG)/*.hi ; do \ + echo $(INSTALL_DATA) $$i $(LIBDIR)/imports/ ; \ + $(INSTALL_DATA) $$i $(LIBDIR)/imports/ ; \ + done + @for i in $(TOP)/src/$(PKG)/$(UPKG)/*.hi ; do \ + echo $(INSTALL_DATA) $$i $(LIBDIR)/imports/$(UPKG)/ ; \ + $(INSTALL_DATA) $$i $(LIBDIR)/imports/$(UPKG)/ ; \ + done + $(INSTALL_DATA) $(TOP)/src/$(PKG)/libHS$(PKG).a $(LIBDIR) + $(RANLIB) $(LIBDIR)/libHS$(PKG).a + $(INSTALL_DATA) $(TOP)/src/$(PKG)/HS$(PKG).o $(LIBDIR) + $(INSTALL_DATA) $(TOP)/src/$(PKG)/$(PKG).conf.in $(LIBDIR) + +clean: + rm -f $(CLEAN_FILES) + find . -name '*.a' -exec rm {} \; + find . -name '*.in' -exec rm {} \; + find . -name '*~' -exec rm {} \; + find . -name 'a.out' -exec rm {} \; + find . -name '*.hi' -exec rm {} \; + find . -name '*.o' -exec rm {} \; + find . -name '*.old' -exec rm {} \; + find . -name '*.core' -exec rm {} \; + find . -name '*_stub.c' -exec rm {} \; + find . -name '*_stub.h' -exec rm {} \; + diff --git a/src/eval/Eval.hs b/src/eval/Eval.hs new file mode 100644 index 0000000..9a6e9e7 --- /dev/null +++ b/src/eval/Eval.hs @@ -0,0 +1,27 @@ +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +module Eval ( + module Eval.Haskell, + module Eval.Meta, + ) where + +import Eval.Haskell {-all-} +import Eval.Meta {-all-} + diff --git a/src/eval/Eval/Haskell.hs b/src/eval/Eval/Haskell.hs new file mode 100644 index 0000000..f147543 --- /dev/null +++ b/src/eval/Eval/Haskell.hs @@ -0,0 +1,250 @@ +{-# OPTIONS -fglasgow-exts -fffi #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +-- +-- compile and run haskell strings at runtime. +-- + +module Eval.Haskell ( + eval, + eval_, + unsafeEval, + unsafeEval_, + typeOf, + + hs_eval_b, -- return a Bool + hs_eval_c, -- return a CChar + hs_eval_i, -- return a CInt + hs_eval_s, -- return a CString + + module Eval.Utils, + + ) where + +import Eval.Utils + +import Plugins.Make +import Plugins.Load + +import AltData.Dynamic +import AltData.Typeable ( Typeable ) + +import Data.Either + +import System.IO +import System.Directory + +import Foreign.C +import Foreign + +-- +-- ok. the idea is: the have either installed the library, in which case +-- is is registered, and the path to altdata is known to ghc, so just +-- saying "-package altdata" will work. if not, we search in the build +-- dir just in case. this should work for inplace work. +-- +-- TODO could have a few extra package.conf search paths in here, +-- including PREFIX. +-- + +-- --------------------------------------------------------------------- +-- return a compiled value, and type check it first +-- +-- TODO make this faster. +-- +eval :: Typeable a => String -> [Import] -> IO (Maybe a) +eval src mods = do + pwd <- getCurrentDirectory + (cmdline,loadpath) <- getPaths + tmpf <- mkUniqueWith dynwrap src mods + status <- make tmpf cmdline + m_rsrc <- case status of + MakeSuccess _ obj -> do + m_v <- dynload obj [pwd] loadpath symbol + case m_v of LoadFailure _ -> return Nothing + LoadSuccess _ rsrc -> return $ Just rsrc + MakeFailure err -> mapM_ putStrLn err >> return Nothing + makeCleaner tmpf + return m_rsrc + +-- --------------------------------------------------------------------- +-- Version of eval with all the buttons available. +eval_ :: Typeable a => + String -- ^ code to compile + -> [Import] -- ^ any imports + -> [String] -- ^ extra make flags + -> [FilePath] -- ^ (package.confs) for load + -> [FilePath] -- ^ include paths load is to search in + -> IO (Either [String] (Maybe a)) -- ^ either errors, or maybe a well typed value + +eval_ src mods args ldflags incs = do + pwd <- getCurrentDirectory + (cmdline,loadpath) <- getPaths -- find path to altdata + tmpf <- mkUniqueWith dynwrap src mods + status <- make tmpf $ ["-Onot"] ++ cmdline ++ args + m_rsrc <- case status of + MakeSuccess _ obj -> do + m_v <- dynload obj (pwd:incs) (loadpath++ldflags) symbol + return $ case m_v of LoadFailure e -> Left e + LoadSuccess _ rsrc -> Right (Just rsrc) + MakeFailure err -> return $ Left err + makeCleaner tmpf + return m_rsrc + +-- --------------------------------------------------------------------- +-- unsafe because it doesn't use Dynamic types +-- useful for not having to provide type constraints to values, or when +-- you want to easily deal with polymorphic values. +-- +unsafeEval :: String -> [Import] -> IO (Maybe a) +unsafeEval src mods = do + pwd <- getCurrentDirectory + tmpf <- mkUniqueWith wrap src mods + status <- make tmpf ["-Onot"] + m_rsrc <- case status of + MakeSuccess _ obj -> do + m_v <- load obj [pwd] [] symbol + case m_v of LoadFailure _ -> return Nothing + LoadSuccess _ rsrc -> return $ Just rsrc + MakeFailure err -> mapM_ putStrLn err >> return Nothing +-- makeCleaner tmpf + return m_rsrc + +-- +-- like unsafeEval, except you can supply extra args to make and load, +-- and the error messages are returned too. +-- +-- Need to be able to specify a search path to look in. +-- +unsafeEval_ :: String -- ^ code to compile + -> [Import] -- ^ any imports + -> [String] -- ^ make flags + -> [FilePath] -- ^ (package.confs) for load + -> [FilePath] -- ^ include paths load is to search in + -> IO (Either [String] a) + +unsafeEval_ src mods args ldflags incs = do + pwd <- getCurrentDirectory + tmpf <- mkUniqueWith wrap src mods + status <- make tmpf $ ["-Onot"] ++ args + e_rsrc <- case status of + MakeSuccess _ obj -> do + m_v <- load obj (pwd:incs) ldflags symbol + case m_v of LoadFailure e -> return $ Left e + LoadSuccess _ rsrc -> return $ Right rsrc + MakeFailure err -> return $ Left err + makeCleaner tmpf + return e_rsrc + +------------------------------------------------------------------------ +-- +-- return a compiled value's type, by using Dynamic to get a +-- representation of the inferred type. +-- +typeOf :: String -> [Import] -> IO String +typeOf src mods = do + pwd <- getCurrentDirectory + (cmdline,loadpath) <- getPaths + tmpf <- mkUniqueWith dynwrap src mods + status <- make tmpf cmdline + ty <- case status of + MakeSuccess _ obj -> do + m_v <- load obj [pwd] loadpath symbol + case m_v of + LoadFailure _ -> return "" + LoadSuccess _ (v::Dynamic) -> return $ (init . tail) $ show v + + MakeFailure err -> mapM_ putStrLn err >> return [] + makeCleaner tmpf + return ty + +-- +-- note that the wrapper uses our altdata library for dynamic typing. +-- hence it needs to see the path to the altdata package. grr. is it +-- installed or not? what path does it have? +-- +dynwrap :: String -> String -> [Import] -> String +dynwrap expr nm mods = + "module "++nm++ "( resource ) where\n" ++ + concatMap (\m-> "import "++m++"\n") mods ++ + "import AltData.Dynamic\n" ++ + "resource = let { v = \n" ++ + "{-# LINE 1 \"\" #-}\n" ++ expr ++ ";} in toDyn v" + +-- --------------------------------------------------------------------- +-- unsafe wrapper +-- +wrap :: String -> String -> [Import] -> String +wrap expr nm mods = + "module "++nm++ "( resource ) where\n" ++ + concatMap (\m-> "import "++m++"\n") mods ++ + "resource = let { v = \n" ++ + "{-# LINE 1 \"\" #-}\n" ++ expr ++ ";} in v" + +------------------------------------------------------------------------ +-- +-- And for our friends in foreign parts +-- +-- TODO needs to accept char** to import list +-- + +-- +-- return NULL pointer if an error occured. +-- + +foreign export ccall hs_eval_b :: CString -> IO (Ptr CInt) +foreign export ccall hs_eval_c :: CString -> IO (Ptr CChar) +foreign export ccall hs_eval_i :: CString -> IO (Ptr CInt) +foreign export ccall hs_eval_s :: CString -> IO CString + +------------------------------------------------------------------------ +-- +-- TODO implement a marshalling for Dynamics, so that we can pass that +-- over to the C side for checking. +-- + +hs_eval_b :: CString -> IO (Ptr CInt) +hs_eval_b s = do m_v <- eval_cstring s + case m_v of Nothing -> return nullPtr + Just v -> new (fromBool v) + +hs_eval_c :: CString -> IO (Ptr CChar) +hs_eval_c s = do m_v <- eval_cstring s + case m_v of Nothing -> return nullPtr + Just v -> new (castCharToCChar v) + +-- should be Integral +hs_eval_i :: CString -> IO (Ptr CInt) +hs_eval_i s = do m_v <- eval_cstring s :: IO (Maybe Int) + case m_v of Nothing -> return nullPtr + Just v -> new (fromIntegral v :: CInt) + +hs_eval_s :: CString -> IO CString +hs_eval_s s = do m_v <- eval_cstring s + case m_v of Nothing -> return nullPtr + Just v -> newCString v + +-- +-- convenience +-- +eval_cstring :: Typeable a => CString -> IO (Maybe a) +eval_cstring cs = do s <- peekCString cs + eval s [] -- TODO use eval() + diff --git a/src/eval/Eval/Meta.hs b/src/eval/Eval/Meta.hs new file mode 100644 index 0000000..8f24510 --- /dev/null +++ b/src/eval/Eval/Meta.hs @@ -0,0 +1,96 @@ +{-# OPTIONS -cpp -fth #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +-- +-- an implementation of the staged compilation primitives from +-- "Dynamic Typing as Staged Type Inference" +-- Shields, Sheard and Jones, 1998 +-- http://doi.acm.org/10.1145/268946.268970 +-- + +module Eval.Meta ( + + run, + defer, + splice, + + ) where + +import Eval.Haskell ( eval ) +import AltData.Typeable ( Typeable ) + +#if __GLASGOW_HASKELL__ > 602 +import Language.Haskell.TH ( ExpQ, pprint, runQ ) +#else +import Language.Haskell.THSyntax ( ExpQ, pprExp, runQ ) +import Text.PrettyPrint ( render ) +#endif + +import System.IO.Unsafe ( unsafePerformIO ) + +type ExpR = String -- hack for splicing + +-- +-- defer the evaluation of an expression by one stage. +-- uses [| |] just for the nice syntax. +-- +-- defer [| 1 + 1 |] --> (1 + 1) +-- +defer :: ExpQ -> ExpR +#if __GLASGOW_HASKELL__ > 602 +defer e = pprint (unsafePerformIO (runQ e)) +#else +defer e = render $ pprExp (unsafePerformIO (runQ e)) +#endif + +-- +-- evaluate 'e' to a deferred expression, and evaluate the result. +-- +-- run( defer [|1+1|] ) --> 2 +-- +run :: (Show t, Typeable t) => ExpR -> t +run e = case unsafePerformIO (eval e imports) of + Nothing -> error "source failed to compile" + Just a -> a + +-- +-- evaluate 'e' to a deferred expression. then splice the result back in +-- to the surrounding deferred expression. splice() is only legal within +-- deferred expressions. +-- +-- let code = defer [| 1 + 1 |] in defer [| splice(code) + 2 |] +-- --> +-- defer [| 1 + 1 + 2 |] +-- +-- defer( "\x -> " ++ splice (v) ) +-- +splice :: Show t => t -> ExpR +splice e = show e + +-- +-- libraries needed +-- +imports = + [ + "GHC.Base", + "GHC.Num", + "GHC.List" + ] + diff --git a/src/eval/Eval/Utils.hs b/src/eval/Eval/Utils.hs new file mode 100644 index 0000000..828e4c8 --- /dev/null +++ b/src/eval/Eval/Utils.hs @@ -0,0 +1,121 @@ +{-# OPTIONS -fglasgow-exts -fffi -cpp #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +-- +-- compile and run haskell strings at runtime. +-- + +module Eval.Utils ( + + Import, + symbol, + escape, + getPaths, + find_altdata_pkgconf, + + mkUniqueWith, + cleanup, + + module Data.Maybe, + module Control.Monad, + + ) where + +import Plugins.Load ( Symbol ) +import Plugins.Utils +import Plugins.Consts ( top {- :{ -} ) + +import System.IO +import System.Directory + +import Data.Char + +-- +-- we export these so that eval() users have a nice time +-- +import Data.Maybe +import Control.Monad + +-- +-- imports Foo's +-- +type Import = String + +-- +-- distinguished symbol name +-- +symbol :: Symbol +symbol = "resource" + +-- +-- turn a Haskell string into a printable version of the same string +-- +escape s = concatMap (\c -> showLitChar c $ "") s + +-- +-- For Dynamic eval's, work out the compile and load command lines +-- +getPaths :: IO ([String],[String]) +getPaths = do + m_pkg <- find_altdata_pkgconf + let load_path = if isJust m_pkg then fromJust m_pkg else [] + let make_line = + let compulsory = ["-Onot","-fglasgow-exts","-package","altdata"] + in if not $ null load_path + then "-package-conf":load_path:compulsory + else compulsory + let load_path' = if null load_path then [] else [load_path] + return (make_line,load_path') + +-- --------------------------------------------------------------------- +-- if we are in-tree eval() needs to use the inplace package.conf to +-- find altdata, otherwise we need it to be in the ghc package system. +-- +-- fixing Typeable/Dynamic in ghc obsoletes this code. as would adding +-- an extra param to eval, which I don't want to do. +-- +find_altdata_pkgconf :: IO (Maybe String) +find_altdata_pkgconf = do + let f = top "plugins.conf.inplace" + b <- doesFileExist f + return $ if b + then Just f + else Nothing + +-- --------------------------------------------------------------------- +-- create the tmp file, and write source into it, using wrapper to +-- create extra .hs src. +-- +mkUniqueWith :: (String -> String -> [Import] -> String) + -> String + -> [Import] -> IO FilePath + +mkUniqueWith wrapper src mods = do + (tmpf,hdl) <- hMkUnique + let nm = mkModid (basename tmpf) -- used as a module name + src' = wrapper src nm mods + hPutStr hdl src' >> hFlush hdl >> hClose hdl >> return tmpf + +-- +-- remove all the tmp files +-- +cleanup :: String -> String -> IO () +cleanup a b = mapM_ removeFile [a, b, replaceSuffix b ".hi"] + diff --git a/src/eval/Makefile b/src/eval/Makefile new file mode 100644 index 0000000..875aa09 --- /dev/null +++ b/src/eval/Makefile @@ -0,0 +1,12 @@ +PKG = eval +UPKG = Eval + +TOP=../.. +include ../build.mk + +HC_OPTS += -package-conf $(TOP)/plugins.conf.inplace +HC_OPTS += -package plugins + +GHC6_3_HC_OPTS += -package template-haskell + +install: install-me diff --git a/src/eval/eval.conf.in.cpp b/src/eval/eval.conf.in.cpp new file mode 100644 index 0000000..eeb639e --- /dev/null +++ b/src/eval/eval.conf.in.cpp @@ -0,0 +1,60 @@ +#if CABAL == 0 && GLASGOW_HASKELL < 604 +Package { + name = "eval", + auto = False, + hs_libraries = [ "HSeval" ], +#ifdef INSTALLING + import_dirs = [ "${LIBDIR}/imports" ], + library_dirs = [ "${LIBDIR}/" ], +#else + import_dirs = [ "${TOP}/src/eval" ], + library_dirs = [ "${TOP}/src/eval" ], +#endif + include_dirs = [], + c_includes = [], + source_dirs = [], + extra_libraries = [], + package_deps = [ "plugins" +#if GLASGOW_HASKELL >= 603 + , "template-haskell" +#endif + ], + extra_ghc_opts = [], + extra_cc_opts = [], + extra_ld_opts = [] +} +#else + +name: eval +version: 0.9.8 +license: LGPL +maintainer: dons@cse.unsw.edu.au +exposed: True +exposed-modules: + Eval.Haskell, + Eval.Meta, + Eval.Utils, + Eval + +hidden-modules: +#ifdef INSTALLING +import-dirs: LIBDIR/imports +library-dirs: LIBDIR +#else +import-dirs: TOP/src/eval +library-dirs: TOP/src/eval +#endif +hs-libraries: HSeval +extra-libraries: +include-dirs: +includes: +depends: plugins, template-haskell +hugs-options: +cc-options: +ld-options: +framework-dirs: +frameworks: +haddock-interfaces: +haddock-html: + +#endif diff --git a/src/hi/Hi.hs b/src/hi/Hi.hs new file mode 100644 index 0000000..9fe3069 --- /dev/null +++ b/src/hi/Hi.hs @@ -0,0 +1,25 @@ +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +module Hi ( + module Hi.Parser + ) where + +import Hi.Parser {-all-} + diff --git a/src/hi/Hi/Binary.hs b/src/hi/Hi/Binary.hs new file mode 100644 index 0000000..a265d7b --- /dev/null +++ b/src/hi/Hi/Binary.hs @@ -0,0 +1,566 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +{-# OPTIONS -fno-warn-unused-imports -fno-warn-name-shadowing #-} +{-# OPTIONS -fno-warn-unused-matches -fno-warn-unused-binds #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA + +-- Based on $fptools/ghc/compiler/utils/Binary.hs: +-- (c) The University of Glasgow 2002 +-- +-- Binary I/O library, with special tweaks for GHC +-- +-- Based on the nhc98 Binary library, which is copyright +-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998. +-- Under the terms of the license for that software, we must tell you +-- where you can obtain the original version of the Binary library, namely +-- http://www.cs.york.ac.uk/fp/nhc98/ +-- +-- We never have to write stuff, so I've scrubbed all the put* code. +-- + +module Hi.Binary ( + {-type-} Bin, + {-class-} Binary(..), + {-type-} BinHandle, + + openBinIO, openBinIO_, + openBinMem, +-- closeBin, + + seekBin, + tellBin, + castBin, + + readBinMem, + + isEOFBin, + + -- for writing instances: + getByte, + + -- lazy Bin I/O + lazyGet, + + -- GHC only: + ByteArray(..), + getByteArray, + + getBinFileWithDict, -- :: Binary a => FilePath -> IO a + + ) where + +-- The *host* architecture version: +#include "MachDeps.h" + +-- import Hi.Utils -- ? + +import Hi.FastMutInt +import Hi.FastString + +#if __GLASGOW_HASKELL__ < 604 +import Data.FiniteMap +#else +import qualified Data.Map as M +#endif + +import Data.Unique + +import Data.Array.IO +import Data.Array +import Data.Bits +import Data.Int +import Data.Word +import Data.IORef +import Data.Char ( ord, chr ) +import Data.Array.Base ( unsafeRead, unsafeWrite ) +import Control.Monad ( when ) +import System.IO +import System.IO.Unsafe ( unsafeInterleaveIO ) +import System.IO.Error ( mkIOError, eofErrorType ) +import GHC.Real ( Ratio(..) ) +import GHC.Exts +import GHC.IOBase ( IO(..) ) +import GHC.Word ( Word8(..) ) +#if __GLASGOW_HASKELL__ < 601 +import GHC.Handle ( openFileEx, IOModeEx(..) ) +#endif + +#if __GLASGOW_HASKELL__ < 601 +openBinaryFile f mode = openFileEx f (BinaryMode mode) +#endif + +type BinArray = IOUArray Int Word8 + +--------------------------------------------------------------- +-- BinHandle +--------------------------------------------------------------- + +data BinHandle + = BinMem { -- binary data stored in an unboxed array + bh_usr :: UserData, -- sigh, need parameterized modules :-) + off_r :: !FastMutInt, -- the current offset + sz_r :: !FastMutInt, -- size of the array (cached) + arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1)) + } + -- XXX: should really store a "high water mark" for dumping out + -- the binary data to a file. + + | BinIO { -- binary data stored in a file + bh_usr :: UserData, + off_r :: !FastMutInt, -- the current offset (cached) + hdl :: !Handle -- the file handle (must be seekable) + } + -- cache the file ptr in BinIO; using hTell is too expensive + -- to call repeatedly. If anyone else is modifying this Handle + -- at the same time, we'll be screwed. + +getUserData :: BinHandle -> UserData +getUserData bh = bh_usr bh + +setUserData :: BinHandle -> UserData -> BinHandle +setUserData bh us = bh { bh_usr = us } + + +--------------------------------------------------------------- +-- Bin +--------------------------------------------------------------- + +newtype Bin a = BinPtr Int + deriving (Eq, Ord, Show, Bounded) + +castBin :: Bin a -> Bin b +castBin (BinPtr i) = BinPtr i + +--------------------------------------------------------------- +-- class Binary +--------------------------------------------------------------- + +class Binary a where + get :: BinHandle -> IO a + +getAt :: Binary a => BinHandle -> Bin a -> IO a +getAt bh p = do seekBin bh p; get bh + +openBinIO_ :: Handle -> IO BinHandle +openBinIO_ h = openBinIO h + +openBinIO :: Handle -> IO BinHandle +openBinIO h = do + r <- newFastMutInt + writeFastMutInt r 0 + return (BinIO noUserData r h) + +openBinMem :: Int -> IO BinHandle +openBinMem size + | size <= 0 = error "Hi.Binary.openBinMem: size must be >= 0" + | otherwise = do + arr <- newArray_ (0,size-1) + arr_r <- newIORef arr + ix_r <- newFastMutInt + writeFastMutInt ix_r 0 + sz_r <- newFastMutInt + writeFastMutInt sz_r size + return (BinMem noUserData ix_r sz_r arr_r) + +tellBin :: BinHandle -> IO (Bin a) +tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix) +tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) + +seekBin :: BinHandle -> Bin a -> IO () +seekBin (BinIO _ ix_r h) (BinPtr p) = do + writeFastMutInt ix_r p + hSeek h AbsoluteSeek (fromIntegral p) +seekBin h@(BinMem _ ix_r sz_r a) (BinPtr p) = do + sz <- readFastMutInt sz_r + if (p >= sz) + then do expandBin h p; writeFastMutInt ix_r p + else writeFastMutInt ix_r p + +isEOFBin :: BinHandle -> IO Bool +isEOFBin (BinMem _ ix_r sz_r a) = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + return (ix >= sz) +isEOFBin (BinIO _ ix_r h) = hIsEOF h + +readBinMem :: FilePath -> IO BinHandle +-- Return a BinHandle with a totally undefined State +readBinMem filename = do + h <- openBinaryFile filename ReadMode + filesize' <- hFileSize h + let filesize = fromIntegral filesize' + arr <- newArray_ (0,filesize-1) + count <- hGetArray h arr filesize + when (count /= filesize) + (error ("Hi.Binary.readBinMem: only read " ++ show count ++ " bytes")) + hClose h + arr_r <- newIORef arr + ix_r <- newFastMutInt + writeFastMutInt ix_r 0 + sz_r <- newFastMutInt + writeFastMutInt sz_r filesize + return (BinMem noUserData ix_r sz_r arr_r) + +-- expand the size of the array to include a specified offset +expandBin :: BinHandle -> Int -> IO () +expandBin (BinMem _ ix_r sz_r arr_r) off = do + sz <- readFastMutInt sz_r + let sz' = head (dropWhile (<= off) (iterate (* 2) sz)) + arr <- readIORef arr_r + arr' <- newArray_ (0,sz'-1) + sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i + | i <- [ 0 .. sz-1 ] ] + writeFastMutInt sz_r sz' + writeIORef arr_r arr' +#ifdef DEBUG + hPutStrLn stderr ("Binary: expanding to size: " ++ show sz') +#endif + return () +expandBin (BinIO _ _ _) _ = return () + -- no need to expand a file, we'll assume they expand by themselves. + +-- ----------------------------------------------------------------------------- +-- Low-level reading/writing of bytes + +getWord8 :: BinHandle -> IO Word8 +getWord8 (BinMem _ ix_r sz_r arr_r) = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + when (ix >= sz) $ +#if __GLASGOW_HASKELL__ <= 408 + throw (mkIOError eofErrorType "Hi.Binary.getWord8" Nothing Nothing) +#else + ioError (mkIOError eofErrorType "Hi.Binary.getWord8" Nothing Nothing) +#endif + arr <- readIORef arr_r + w <- unsafeRead arr ix + writeFastMutInt ix_r (ix+1) + return w +getWord8 (BinIO _ ix_r h) = do + ix <- readFastMutInt ix_r + c <- hGetChar h + writeFastMutInt ix_r (ix+1) + return $! (fromIntegral (ord c)) -- XXX not really correct + +getByte :: BinHandle -> IO Word8 +getByte = getWord8 + +-- ----------------------------------------------------------------------------- +-- Primitve Word writes + +instance Binary Word8 where + get = getWord8 + +instance Binary Word16 where + get h = do + w1 <- getWord8 h + w2 <- getWord8 h + return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2) + +instance Binary Word32 where + get h = do + w1 <- getWord8 h + w2 <- getWord8 h + w3 <- getWord8 h + w4 <- getWord8 h + return $! ((fromIntegral w1 `shiftL` 24) .|. + (fromIntegral w2 `shiftL` 16) .|. + (fromIntegral w3 `shiftL` 8) .|. + (fromIntegral w4)) + +instance Binary Word64 where + get h = do + w1 <- getWord8 h + w2 <- getWord8 h + w3 <- getWord8 h + w4 <- getWord8 h + w5 <- getWord8 h + w6 <- getWord8 h + w7 <- getWord8 h + w8 <- getWord8 h + return $! ((fromIntegral w1 `shiftL` 56) .|. + (fromIntegral w2 `shiftL` 48) .|. + (fromIntegral w3 `shiftL` 40) .|. + (fromIntegral w4 `shiftL` 32) .|. + (fromIntegral w5 `shiftL` 24) .|. + (fromIntegral w6 `shiftL` 16) .|. + (fromIntegral w7 `shiftL` 8) .|. + (fromIntegral w8)) + +-- ----------------------------------------------------------------------------- +-- Primitve Int writes + +instance Binary Int8 where + get h = do w <- get h; return $! (fromIntegral (w::Word8)) + +instance Binary Int16 where + get h = do w <- get h; return $! (fromIntegral (w::Word16)) + +instance Binary Int32 where + get h = do w <- get h; return $! (fromIntegral (w::Word32)) + +instance Binary Int64 where + get h = do w <- get h; return $! (fromIntegral (w::Word64)) + +-- ----------------------------------------------------------------------------- +-- Instances for standard types + +instance Binary () where + get _ = return () + +instance Binary Bool where + get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) + +instance Binary Char where + get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) + +instance Binary Int where +#if SIZEOF_HSINT == 4 + get bh = do + x <- get bh + return $! (fromIntegral (x :: Int32)) +#elif SIZEOF_HSINT == 8 + get bh = do + x <- get bh + return $! (fromIntegral (x :: Int64)) +#else +#error "unsupported sizeof(HsInt)" +#endif + +instance Binary a => Binary [a] where + get bh = do h <- getWord8 bh + case h of + 0 -> return [] + _ -> do x <- get bh + xs <- get bh + return (x:xs) + +instance (Binary a, Binary b) => Binary (a,b) where + get bh = do a <- get bh + b <- get bh + return (a,b) + +instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where + get bh = do a <- get bh + b <- get bh + c <- get bh + return (a,b,c) + +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (a,b,c,d) + +instance Binary a => Binary (Maybe a) where + get bh = do h <- getWord8 bh + case h of + 0 -> return Nothing + _ -> do x <- get bh; return (Just x) + +instance (Binary a, Binary b) => Binary (Either a b) where + get bh = do h <- getWord8 bh + case h of + 0 -> do a <- get bh ; return (Left a) + _ -> do b <- get bh ; return (Right b) + +#ifdef __GLASGOW_HASKELL__ +instance Binary Integer where + get bh = do + b <- getByte bh + case b of + 0 -> do (I# i#) <- get bh + return (S# i#) + _ -> do (I# s#) <- get bh + sz <- get bh + (BA a#) <- getByteArray bh sz + return (J# s# a#) + +getByteArray :: BinHandle -> Int -> IO ByteArray +getByteArray bh (I# sz) = do + (MBA arr) <- newByteArray sz + let loop n + | n ==# sz = return () + | otherwise = do + w <- getByte bh + writeByteArray arr n w + loop (n +# 1#) + loop 0# + freezeByteArray arr + + +data ByteArray = BA ByteArray# +data MBA = MBA (MutableByteArray# RealWorld) + +newByteArray :: Int# -> IO MBA +newByteArray sz = IO $ \s -> + case newByteArray# sz s of { (# s, arr #) -> + (# s, MBA arr #) } + +freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray +freezeByteArray arr = IO $ \s -> + case unsafeFreezeByteArray# arr s of { (# s, arr #) -> + (# s, BA arr #) } + +#if __GLASGOW_HASKELL__ < 503 +writeByteArray arr i w8 = IO $ \s -> + case word8ToWord w8 of { W# w# -> + case writeCharArray# arr i (chr# (word2Int# w#)) s of { s -> + (# s , () #) }} +#else +writeByteArray arr i (W8# w) = IO $ \s -> + case writeWord8Array# arr i w s of { s -> + (# s, () #) } +#endif + +#if __GLASGOW_HASKELL__ < 503 +indexByteArray a# n# = fromIntegral (I# (ord# (indexCharArray# a# n#))) +#else +indexByteArray a# n# = W8# (indexWord8Array# a# n#) +#endif + +instance (Integral a, Binary a) => Binary (Ratio a) where + get bh = do a <- get bh; b <- get bh; return (a :% b) +#endif + +instance Binary (Bin a) where + get bh = do i <- get bh; return (BinPtr i) + +-- ----------------------------------------------------------------------------- +-- Lazy reading/writing + +lazyGet :: Binary a => BinHandle -> IO a +lazyGet bh = do + p <- get bh -- a BinPtr + p_a <- tellBin bh + a <- unsafeInterleaveIO (getAt bh p_a) + seekBin bh p -- skip over the object for now + return a + +-- -------------------------------------------------------------- +-- Main wrappers: getBinFileWithDict, putBinFileWithDict +-- +-- This layer is built on top of the stuff above, +-- and should not know anything about BinHandles +-- -------------------------------------------------------------- + +initBinMemSize = (1024*1024) :: Int +binaryInterfaceMagic = 0x1face :: Word32 + +getBinFileWithDict :: Binary a => FilePath -> IO a +getBinFileWithDict file_path = do + bh <- Hi.Binary.readBinMem file_path + + -- Read the magic number to check that this really is a GHC .hi file + -- (This magic number does not change when we change + -- GHC interface file format) + magic <- get bh + + when (magic /= binaryInterfaceMagic) $ + error "magic number mismatch: old/corrupt interface file?" + + -- Read the dictionary + -- The next word in the file is a pointer to where the dictionary is + -- (probably at the end of the file) + dict_p <- Hi.Binary.get bh -- Get the dictionary ptr + data_p <- tellBin bh -- Remember where we are now + seekBin bh dict_p + dict <- getDictionary bh + + seekBin bh data_p -- Back to where we were before + + -- Initialise the user-data field of bh + let bh' = setUserData bh (initReadState dict) + + -- At last, get the thing + get bh' + +-- ----------------------------------------------------------------------------- +-- UserData +-- ----------------------------------------------------------------------------- + +data UserData = + UserData { -- This field is used only when reading + ud_dict :: Dictionary, + + -- The next two fields are only used when writing + ud_next :: IORef Int, -- The next index to use +#if __GLASGOW_HASKELL__ < 604 + ud_map :: IORef (FiniteMap Unique (Int,FastString)) +#else + ud_map :: IORef (M.Map Unique (Int,FastString)) +#endif + } + +noUserData = error "Hi.Binary.UserData: no user data" + +initReadState :: Dictionary -> UserData +initReadState dict = UserData{ ud_dict = dict, + ud_next = undef "next", + ud_map = undef "map" } + +newWriteState :: IO UserData +newWriteState = do + j_r <- newIORef 0 +#if __GLASGOW_HASKELL__ < 604 + out_r <- newIORef emptyFM +#else + out_r <- newIORef M.empty +#endif + return (UserData { ud_dict = error "dict", + ud_next = j_r, + ud_map = out_r }) + + +undef s = error ("Hi.Binary.UserData: no " ++ s) + +--------------------------------------------------------- +-- The Dictionary +--------------------------------------------------------- + +type Dictionary = Array Int FastString -- The dictionary + -- Should be 0-indexed + +getDictionary :: BinHandle -> IO Dictionary +getDictionary bh = do + sz <- get bh + elems <- sequence (take sz (repeat (getFS bh))) + return (listArray (0,sz-1) elems) + +#if __GLASGOW_HASKELL__ < 604 +constructDictionary :: Int -> FiniteMap Unique (Int,FastString) -> Dictionary +constructDictionary j fm = array (0,j-1) (eltsFM fm) +#else +constructDictionary :: Int -> M.Map Unique (Int,FastString) -> Dictionary +constructDictionary j fm = array (0,j-1) (M.elems fm) +#endif + +--------------------------------------------------------- +-- Reading and writing FastStrings +--------------------------------------------------------- + +getFS bh = do + (I# l) <- get bh + (BA ba) <- getByteArray bh (I# l) + return $! (mkFastSubStringBA# ba 0# l) + +instance Binary FastString where + get bh = do j <- get bh -- Int + return $! (ud_dict (getUserData bh) ! j) + diff --git a/src/hi/Hi/FastMutInt.hs b/src/hi/Hi/FastMutInt.hs new file mode 100644 index 0000000..4c3292e --- /dev/null +++ b/src/hi/Hi/FastMutInt.hs @@ -0,0 +1,81 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +{-# OPTIONS -fno-warn-name-shadowing #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- +-- Based on code from $fptools/ghc/compiler/utils/FastMutInt.lhs +-- +-- (c) Copyright 2002, The University Court of the University of Glasgow. + +-- +-- Unboxed mutable Ints +-- + +module Hi.FastMutInt ( + FastMutInt, + newFastMutInt, + readFastMutInt, + writeFastMutInt, + incFastMutInt, + incFastMutIntBy + ) where + +#include "MachDeps.h" + +#if __GLASGOW_HASKELL__ < 503 +import GlaExts +import PrelIOBase +#else +import GHC.Base +import GHC.IOBase +#endif + +#if __GLASGOW_HASKELL__ < 411 +newByteArray# = newCharArray# +#endif + +data FastMutInt = FastMutInt (MutableByteArray# RealWorld) + +newFastMutInt :: IO FastMutInt +newFastMutInt = IO $ \s -> + case newByteArray# size s of { (# s, arr #) -> + (# s, FastMutInt arr #) } + where I# size = SIZEOF_HSINT + +readFastMutInt :: FastMutInt -> IO Int +readFastMutInt (FastMutInt arr) = IO $ \s -> + case readIntArray# arr 0# s of { (# s, i #) -> + (# s, I# i #) } + +writeFastMutInt :: FastMutInt -> Int -> IO () +writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s -> + case writeIntArray# arr 0# i s of { s -> + (# s, () #) } + +incFastMutInt :: FastMutInt -> IO Int -- Returns original value +incFastMutInt (FastMutInt arr) = IO $ \s -> + case readIntArray# arr 0# s of { (# s, i #) -> + case writeIntArray# arr 0# (i +# 1#) s of { s -> + (# s, I# i #) } } + +incFastMutIntBy :: FastMutInt -> Int -> IO Int -- Returns original value +incFastMutIntBy (FastMutInt arr) (I# n) = IO $ \s -> + case readIntArray# arr 0# s of { (# s, i #) -> + case writeIntArray# arr 0# (i +# n) s of { s -> + (# s, I# i #) } } + diff --git a/src/hi/Hi/FastString.hs b/src/hi/Hi/FastString.hs new file mode 100644 index 0000000..2eff02e --- /dev/null +++ b/src/hi/Hi/FastString.hs @@ -0,0 +1,508 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +{-# OPTIONS -fno-warn-name-shadowing -fno-warn-unused-matches #-} + +{-# OPTIONS -#include "hschooks.h" #-} + +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- +-- Based on $fptools/ghc/compiler/utils/FastString.lhs +-- +-- (c) The GRASP/AQUA Project, Glasgow University, 1997-1998 +-- +-- Fast strings +-- +-- Compact representations of character strings with +-- unique identifiers (hash-cons'ish). +-- + +module Hi.FastString + ( + FastString(..), -- not abstract, for now. + + mkFastString, -- :: String -> FastString + mkFastStringNarrow, -- :: String -> FastString + mkFastSubString, -- :: Addr -> Int -> Int -> FastString + + mkFastString#, -- :: Addr# -> FastString + mkFastSubStringBA#, -- :: ByteArray# -> Int# -> Int# -> FastString + + mkFastStringInt, -- :: [Int] -> FastString + + uniqueOfFS, -- :: FastString -> Int# + lengthFS, -- :: FastString -> Int + nullFastString, -- :: FastString -> Bool + + unpackFS, -- :: FastString -> String + unpackIntFS, -- :: FastString -> [Int] + appendFS, -- :: FastString -> FastString -> FastString + headFS, -- :: FastString -> Char + headIntFS, -- :: FastString -> Int + tailFS, -- :: FastString -> FastString + concatFS, -- :: [FastString] -> FastString + consFS, -- :: Char -> FastString -> FastString + indexFS, -- :: FastString -> Int -> Char + nilFS, -- :: FastString + + hPutFS, -- :: Handle -> FastString -> IO () + + LitString, + mkLitString# -- :: Addr# -> LitString + ) where + +import Hi.PrimPacked + +import IO +import Char ( chr, ord ) + +import GHC.Exts +import GHC.IOBase +import GHC.Arr ( STArray(..), newSTArray ) +import GHC.Handle + +import Foreign.C + +-- import System.IO.Unsafe ( unsafePerformIO ) +-- import Control.Monad.ST ( stToIO ) +-- import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) + + +#define hASH_TBL_SIZE 993 + +{- +@FastString@s are packed representations of strings +with a unique id for fast comparisons. The unique id +is assigned when creating the @FastString@, using +a hash table to map from the character string representation +to the unique ID. +-} + +data FastString + = FastString -- packed repr. on the heap. + Int# -- unique id + -- 0 => string literal, comparison + -- will + Int# -- length + ByteArray# -- stuff + + | UnicodeStr -- if contains characters outside '\1'..'\xFF' + Int# -- unique id + [Int] -- character numbers + +instance Eq FastString where + -- shortcut for real FastStrings + (FastString u1 _ _) == (FastString u2 _ _) = u1 ==# u2 + a == b = case cmpFS a b of { LT -> False; EQ -> True; GT -> False } + + (FastString u1 _ _) /= (FastString u2 _ _) = u1 /=# u2 + a /= b = case cmpFS a b of { LT -> True; EQ -> False; GT -> True } + +instance Ord FastString where + -- Compares lexicographically, not by unique + a <= b = case cmpFS a b of { LT -> True; EQ -> True; GT -> False } + a < b = case cmpFS a b of { LT -> True; EQ -> False; GT -> False } + a >= b = case cmpFS a b of { LT -> False; EQ -> True; GT -> True } + a > b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True } + max x y | x >= y = x + | otherwise = y + min x y | x <= y = x + | otherwise = y + compare a b = cmpFS a b + +lengthFS :: FastString -> Int +lengthFS (FastString _ l# _) = I# l# +lengthFS (UnicodeStr _ s) = length s + +nullFastString :: FastString -> Bool +nullFastString (FastString _ l# _) = l# ==# 0# +nullFastString (UnicodeStr _ []) = True +nullFastString (UnicodeStr _ (_:_)) = False + +unpackFS :: FastString -> String +unpackFS (FastString _ l# ba#) = unpackNBytesBA (BA ba#) (I# l#) +unpackFS (UnicodeStr _ s) = map chr s + +unpackIntFS :: FastString -> [Int] +unpackIntFS (UnicodeStr _ s) = s +unpackIntFS fs = map ord (unpackFS fs) + +appendFS :: FastString -> FastString -> FastString +appendFS fs1 fs2 = mkFastStringInt (unpackIntFS fs1 ++ unpackIntFS fs2) + +concatFS :: [FastString] -> FastString +concatFS ls = mkFastStringInt (concat (map unpackIntFS ls)) -- ToDo: do better + +headFS :: FastString -> Char +headFS (FastString _ l# ba#) = + if l# ># 0# then C# (indexCharArray# ba# 0#) else error ("headFS: empty FS") +headFS (UnicodeStr _ (c:_)) = chr c +headFS (UnicodeStr _ []) = error ("headFS: empty FS") + +headIntFS :: FastString -> Int +headIntFS (UnicodeStr _ (c:_)) = c +headIntFS fs = ord (headFS fs) + +indexFS :: FastString -> Int -> Char +indexFS f i@(I# i#) = + case f of + FastString _ l# ba# + | l# ># 0# && l# ># i# -> C# (indexCharArray# ba# i#) + | otherwise -> error (msg (I# l#)) + UnicodeStr _ s -> chr (s!!i) + where + msg l = "indexFS: out of range: " ++ show (l,i) + +tailFS :: FastString -> FastString +tailFS (FastString _ l# ba#) = mkFastSubStringBA# ba# 1# (l# -# 1#) +tailFS fs = mkFastStringInt (tail (unpackIntFS fs)) + +consFS :: Char -> FastString -> FastString +consFS c fs = mkFastStringInt (ord c : unpackIntFS fs) + +uniqueOfFS :: FastString -> Int# +uniqueOfFS (FastString u# _ _) = u# +uniqueOfFS (UnicodeStr u# _) = u# + +nilFS = mkFastString "" + +{- +GHC-related stuff: + +Internally, the compiler will maintain a fast string symbol +table, providing sharing and fast comparison. Creation of +new @FastString@s then covertly does a lookup, re-using the +@FastString@ if there was a hit. + +Caution: mkFastStringUnicode assumes that if the string is in the +table, it sits under the UnicodeStr constructor. Other mkFastString +variants analogously assume the FastString constructor. +-} + +data FastStringTable = + FastStringTable + Int# + (MutableArray# RealWorld [FastString]) + +type FastStringTableVar = IORef FastStringTable + +string_table :: FastStringTableVar +string_table = + unsafePerformIO ( + stToIO (newSTArray (0::Int,hASH_TBL_SIZE) []) + >>= \ (STArray _ _ arr#) -> + newIORef (FastStringTable 0# arr#)) + +lookupTbl :: FastStringTable -> Int# -> IO [FastString] +lookupTbl (FastStringTable _ arr#) i# = + IO ( \ s# -> + readArray# arr# i# s#) + +updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> IO () +updTbl fs_table_var (FastStringTable uid# arr#) i# ls = + IO (\ s# -> case writeArray# arr# i# ls s# of { s2# -> + (# s2#, () #) }) >> + writeIORef fs_table_var (FastStringTable (uid# +# 1#) arr#) + +mkFastString# :: Addr# -> FastString +mkFastString# a# = + case strLength (Ptr a#) of { (I# len#) -> mkFastStringLen# a# len# } + +mkFastStringLen# :: Addr# -> Int# -> FastString +mkFastStringLen# a# len# = + unsafePerformIO ( + readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) -> + let + h = hashStr a# len# + in +-- _trace ("hashed: "++show (I# h)) $ + lookupTbl ft h >>= \ lookup_result -> + case lookup_result of + [] -> + -- no match, add it to table by copying out the + -- the string into a ByteArray + -- _trace "empty bucket" $ + case copyPrefixStr a# (I# len#) of + BA barr# -> + let f_str = FastString uid# len# barr# in + updTbl string_table ft h [f_str] >> + ({- _trace ("new: " ++ show f_str) $ -} return f_str) + ls -> + -- non-empty `bucket', scan the list looking + -- entry with same length and compare byte by byte. + -- _trace ("non-empty bucket"++show ls) $ + case bucket_match ls len# a# of + Nothing -> + case copyPrefixStr a# (I# len#) of + BA barr# -> + let f_str = FastString uid# len# barr# in + updTbl string_table ft h (f_str:ls) >> + ( {- _trace ("new: " ++ show f_str) $ -} return f_str) + Just v -> {- _trace ("re-use: "++show v) $ -} return v) + where + bucket_match [] _ _ = Nothing + bucket_match (v@(FastString _ l# ba#):ls) len# a# = + if len# ==# l# && eqStrPrefix a# ba# l# then + Just v + else + bucket_match ls len# a# + bucket_match (UnicodeStr _ _ : ls) len# a# = + bucket_match ls len# a# + +mkFastSubStringBA# :: ByteArray# -> Int# -> Int# -> FastString +mkFastSubStringBA# barr# start# len# = + unsafePerformIO ( + readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) -> + let + h = hashSubStrBA barr# start# len# + in +-- _trace ("hashed(b): "++show (I# h)) $ + lookupTbl ft h >>= \ lookup_result -> + case lookup_result of + [] -> + -- no match, add it to table by copying out the + -- the string into a ByteArray + -- _trace "empty bucket(b)" $ + case copySubStrBA (BA barr#) (I# start#) (I# len#) of + BA ba# -> + let f_str = FastString uid# len# ba# in + updTbl string_table ft h [f_str] >> + -- _trace ("new(b): " ++ show f_str) $ + return f_str + ls -> + -- non-empty `bucket', scan the list looking + -- entry with same length and compare byte by byte. + -- _trace ("non-empty bucket(b)"++show ls) $ + case bucket_match ls start# len# barr# of + Nothing -> + case copySubStrBA (BA barr#) (I# start#) (I# len#) of + BA ba# -> + let f_str = FastString uid# len# ba# in + updTbl string_table ft h (f_str:ls) >> + -- _trace ("new(b): " ++ show f_str) $ + return f_str + Just v -> + -- _trace ("re-use(b): "++show v) $ + return v + ) + where + bucket_match [] _ _ _ = Nothing + bucket_match (v:ls) start# len# ba# = + case v of + FastString _ l# barr# -> + if len# ==# l# && eqStrPrefixBA barr# ba# start# len# then + Just v + else + bucket_match ls start# len# ba# + UnicodeStr _ _ -> bucket_match ls start# len# ba# + +mkFastStringUnicode :: [Int] -> FastString +mkFastStringUnicode s = + unsafePerformIO ( + readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) -> + let + h = hashUnicode s + in +-- _trace ("hashed(b): "++show (I# h)) $ + lookupTbl ft h >>= \ lookup_result -> + case lookup_result of + [] -> + -- no match, add it to table by copying out the + -- the string into a [Int] + let f_str = UnicodeStr uid# s in + updTbl string_table ft h [f_str] >> + -- _trace ("new(b): " ++ show f_str) $ + return f_str + ls -> + -- non-empty `bucket', scan the list looking + -- entry with same length and compare byte by byte. + -- _trace ("non-empty bucket(b)"++show ls) $ + case bucket_match ls of + Nothing -> + let f_str = UnicodeStr uid# s in + updTbl string_table ft h (f_str:ls) >> + -- _trace ("new(b): " ++ show f_str) $ + return f_str + Just v -> + -- _trace ("re-use(b): "++show v) $ + return v + ) + where + bucket_match [] = Nothing + bucket_match (v@(UnicodeStr _ s'):ls) = + if s' == s then Just v else bucket_match ls + bucket_match (FastString _ _ _ : ls) = bucket_match ls + +mkFastStringNarrow :: String -> FastString +mkFastStringNarrow str = + case packString str of { (I# len#, BA frozen#) -> + mkFastSubStringBA# frozen# 0# len# + } + {- 0-indexed array, len# == index to one beyond end of string, + i.e., (0,1) => empty string. -} + +mkFastString :: String -> FastString +mkFastString str = if all good str + then mkFastStringNarrow str + else mkFastStringUnicode (map ord str) + where + good c = c >= '\1' && c <= '\xFF' + +mkFastStringInt :: [Int] -> FastString +mkFastStringInt str = if all good str + then mkFastStringNarrow (map chr str) + else mkFastStringUnicode str + where + good c = c >= 1 && c <= 0xFF + +mkFastSubString :: Addr# -> Int -> Int -> FastString +mkFastSubString a# (I# start#) (I# len#) = + mkFastStringLen# (a# `plusAddr#` start#) len# + +hashStr :: Addr# -> Int# -> Int# + -- use the Addr to produce a hash value between 0 & m (inclusive) +hashStr a# len# = + case len# of + 0# -> 0# + 1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE# + 2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE# + _ -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE# + where + c0 = indexCharOffAddr# a# 0# + c1 = indexCharOffAddr# a# (len# `quotInt#` 2# -# 1#) + c2 = indexCharOffAddr# a# (len# -# 1#) +{- + c1 = indexCharOffAddr# a# 1# + c2 = indexCharOffAddr# a# 2# +-} + +hashSubStrBA :: ByteArray# -> Int# -> Int# -> Int# + -- use the byte array to produce a hash value between 0 & m (inclusive) +hashSubStrBA ba# start# len# = + case len# of + 0# -> 0# + 1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE# + 2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE# + _ -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE# + where + c0 = indexCharArray# ba# (start# +# 0#) + c1 = indexCharArray# ba# (start# +# (len# `quotInt#` 2# -# 1#)) + c2 = indexCharArray# ba# (start# +# (len# -# 1#)) + +-- c1 = indexCharArray# ba# 1# +-- c2 = indexCharArray# ba# 2# + +hashUnicode :: [Int] -> Int# + -- use the Addr to produce a hash value between 0 & m (inclusive) +hashUnicode [] = 0# +hashUnicode [I# c0] = ((c0 *# 631#) +# 1#) `remInt#` hASH_TBL_SIZE# +hashUnicode [I# c0, I# c1] = ((c0 *# 631#) +# (c1 *# 217#) +# 2#) `remInt#` hASH_TBL_SIZE# +hashUnicode s = ((c0 *# 631#) +# (c1 *# 217#) +# (c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE# + where + I# len# = length s + I# c0 = s !! 0 + I# c1 = s !! (I# (len# `quotInt#` 2# -# 1#)) + I# c2 = s !! (I# (len# -# 1#)) + +cmpFS :: FastString -> FastString -> Ordering +cmpFS (UnicodeStr u1# s1) (UnicodeStr u2# s2) = if u1# ==# u2# then EQ + else compare s1 s2 +cmpFS (UnicodeStr _ s1) s2 = compare s1 (unpackIntFS s2) +cmpFS s1 (UnicodeStr _ s2) = compare (unpackIntFS s1) s2 +cmpFS (FastString u1# l1# b1#) (FastString u2# l2# b2#) = + if u1# ==# u2# then EQ else + let l# = if l1# <=# l2# then l1# else l2# in + unsafePerformIO ( + memcmp b1# b2# l# >>= \ (I# res) -> + return ( + if res <# 0# then LT + else if res ==# 0# then + if l1# ==# l2# then EQ + else if l1# <# l2# then LT else GT + else GT + )) + +foreign import ccall unsafe "memcmp" + memcmp :: ByteArray# -> ByteArray# -> Int# -> IO Int + +-- ----------------------------------------------------------------------------- +-- Outputting 'FastString's + +#if __GLASGOW_HASKELL__ >= 504 + +-- this is our own version of hPutBuf for FastStrings, because in +-- 5.04+ we don't have mutable byte arrays and therefore hPutBufBA. +-- The closest is hPutArray in Data.Array.IO, but that does some extra +-- range checks that we want to avoid here. + +foreign import ccall unsafe "__hscore_memcpy_dst_off" + memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ()) + +hPutFS handle (FastString _ l# ba#) + | l# ==# 0# = return () + | otherwise + = do wantWritableHandle "hPutFS" handle $ + \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=stream } -> do + + old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size } + <- readIORef ref + + let count = I# l# + raw = unsafeCoerce# ba# :: MutableByteArray# RealWorld + + -- enough room in handle buffer? + if (size - w > count) + -- There's enough room in the buffer: + -- just copy the data in and update bufWPtr. + then do memcpy_baoff_ba old_raw w raw (fromIntegral count) + writeIORef ref old_buf{ bufWPtr = w + count } + return () + + -- else, we have to flush + else do flushed_buf <- flushWriteBuffer fd stream old_buf + writeIORef ref flushed_buf + let this_buf = + Buffer{ bufBuf=raw, bufState=WriteBuffer, + bufRPtr=0, bufWPtr=count, bufSize=count } + flushWriteBuffer fd stream this_buf + return () + +#else + +hPutFS :: Handle -> FastString -> IO () +hPutFS handle (FastString _ l# ba#) + | l# ==# 0# = return () + | otherwise = do mba <- stToIO $ unsafeThawByteArray (ByteArray (bot::Int) bot ba#) + hPutBufBAFull handle mba (I# l#) + where + bot = error "hPutFS.ba" + +#endif + +-- ONLY here for debugging the NCG (so -ddump-stix works for string +-- literals); no idea if this is really necessary. JRS, 010131 +hPutFS handle (UnicodeStr _ is) + = hPutStr handle ("(UnicodeStr " ++ show is ++ ")") + +-- ----------------------------------------------------------------------------- +-- LitStrings, here for convenience only. + +type LitString = Ptr () +-- ToDo: make it a Ptr when we don't have to support 4.08 any more + +mkLitString# :: Addr# -> LitString +mkLitString# a# = Ptr a# diff --git a/src/hi/Hi/Parser.hs b/src/hi/Hi/Parser.hs new file mode 100644 index 0000000..6b1bb55 --- /dev/null +++ b/src/hi/Hi/Parser.hs @@ -0,0 +1,722 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +{-# OPTIONS -fno-warn-unused-matches -fno-warn-unused-binds -fno-warn-name-shadowing #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +-- +-- Based on $fptools/ghc/compiler/iface/BinIface.hs +-- +-- (c) The University of Glasgow 2002 +-- +-- Binary interface file support. +-- + +-- +-- This provides the "Binary" instances for the Iface type such that we +-- can parse binary representations of that type. i.e. from .hi files +-- +-- The main problem we have is that all the stuff we don't care about, +-- we just want to read in to a string. So this has to be hand-hacked +-- somewhat. +-- +-- The "Binary" class for hs-plugins only includes a get method. We +-- don't do any writing. Saves us having to properly reconstruct the +-- abstract syntax, which would pull in *way* too much of GHC. +-- + + + +module Hi.Parser ( readIface, module Hi.Syntax ) where + +import Hi.Syntax +import Hi.Binary +import Hi.FastString + +import GHC.Word + +#include "../../../config.h" + +-- --------------------------------------------------------------------------- +-- how to get there from here + +readIface :: FilePath -> IO Iface +readIface hi_path = getBinFileWithDict hi_path + +-- --------------------------------------------------------------------- +-- All the Binary instances +-- +-- Reading a binary interface into ParsedIface +-- +-- We pull the trick of only reading up to the point we need +-- + +instance Binary Iface where + get bh = do + version <- get bh :: IO String + build_tag <- get bh :: IO Word8 -- 'way' flag + +#if __GLASGOW_HASKELL__ >= 604 + mod_name <- get bh :: IO FastString + _is_boot <- get bh :: IO Bool + let pkg_name = mkFastString "unknown" -- >=604 has no package field +#elif CABAL == 1 && __GLASGOW_HASKELL__ == 603 + mod_name <- get bh :: IO FastString + let pkg_name = mkFastString "unknown" +#else /* <= 622 */ + mod_name <- get bh :: IO FastString + pkg_name <- get bh :: IO FastString +#endif + mod_vers <- get bh :: IO Version + orphan <- get bh :: IO Bool + deps <- get bh :: IO Dependencies + + get bh :: IO (Bin Int) -- fake a lazyGet for [Usage] + usages <- get bh :: IO [Usage] + + exports <- get bh :: IO [IfaceExport] + +-- (exp_vers :: Version) <- get bh +-- (fixities :: [(OccName,Fixity)]) <- get bh +-- (deprecs :: [IfaceDeprec]) <- get bh + +-- (decls :: [(Version,IfaceDecl)])<- get bh + +-- (insts :: [IfaceInst]) <- get bh +-- (rules :: [IfaceRule]) <- get bh +-- (rule_vers :: Version) <- get bh + + return $ Iface { + mi_package = unpackFS pkg_name, + mi_module = unpackFS mod_name, + mi_deps = deps , + mi_usages = usages, + mi_exports = exports {-,-} + +-- mi_mod_vers = mod_vers, +-- mi_boot = False, -- .hi files are never .hi-boot files! +-- mi_orphan = orphan, +-- mi_usages = usages, +-- mi_exports = exports, +-- mi_exp_vers = exp_vers, +-- mi_fixities = fixities, +-- mi_deprecs = deprecs, +-- mi_decls = decls, +-- mi_insts = insts, +-- mi_rules = rules, +-- mi_rule_vers = rule_vers + } + +------------------------------------------------------------------------ +-- +-- Types from: Iface.hs, HscTypes +-- + +-- fake a lazyGet +instance Binary Dependencies where + get bh = do get bh :: IO (Bin Int) -- really a BinPtr Int + ms <- get bh :: IO [(FastString,Bool)] + ps <- get bh :: IO [FastString] + _ <- get bh :: IO [FastString] -- !!orphans + return Deps { dep_mods = map unpackFS $! map fst ms, + dep_pkgs = map unpackFS ps {-,-} + } + +------------------------------------------------------------------------ +-- Usages +------------------------------------------------------------------------ + +instance Binary OccName where + get bh = do aa <- get bh :: IO NameSpace + ab <- get bh :: IO FastString + return $ OccName aa (unpackFS ab) + +instance Binary NameSpace where + get bh = do h <- getByte bh + case h of + 0 -> return VarName + 1 -> return DataName + 2 -> return TvName + _ -> return TcClsName + +instance Binary Usage where + get bh = do (nm :: FastString) <- get bh + (mod :: Version) <- get bh + (exps :: Maybe Version) <- get bh + (ents :: [(OccName,Version)]) <- get bh + (rules :: Version) <- get bh + return $ Usage {usg_name = (unpackFS nm), + usg_mod = mod, + usg_exports = exps, + usg_entities = ents, + usg_rules = rules } + +------------------------------------------------------------------------ +-- Exports + +instance (Binary name) => Binary (GenAvailInfo name) where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: name) <- get bh + return $ Avail aa + _ -> do (ab :: name) <- get bh + (ac :: [name]) <- get bh + return $ AvailTC ab ac + +{- +instance Binary a => Binary (Deprecs a) where + get bh = do + h <- getByte bh + case h of + 0 -> return Deprecs + 1 -> do (aa :: FastString) <- get bh + return Deprecs + _ -> do (ab :: a) <- get bh + return Deprecs +-} + +------------------------------------------------------------------------- +-- Types from: BasicTypes +------------------------------------------------------------------------- + +{- +instance Binary Activation where + get bh = do + h <- getByte bh + case h of + 0 -> return Activation + 1 -> return Activation + 2 -> do (aa :: Int) <- get bh ; return Activation + _ -> do (ab :: Int) <- get bh ; return Activation + +instance Binary StrictnessMark where + get bh = do + h <- getByte bh + case h of + 0 -> return StrictnessMark + 1 -> return StrictnessMark + _ -> return StrictnessMark + +instance Binary Boxity where + get bh = do + h <- getByte bh + case h of + 0 -> return Boxity + _ -> return Boxity + +instance Binary TupCon where + get bh = do + (ab :: Boxity) <- get bh + (ac :: Arity) <- get bh + return TupCon + +instance Binary RecFlag where + get bh = do + h <- getByte bh + case h of + 0 -> return RecFlag + _ -> return RecFlag + +instance Binary DefMeth where + get bh = do + h <- getByte bh + case h of + 0 -> return DefMeth + 1 -> return DefMeth + _ -> return DefMeth + +instance Binary FixityDirection where + get bh = do + h <- getByte bh + case h of + 0 -> return FixityDirection + 1 -> return FixityDirection + _ -> return FixityDirection + +instance Binary Fixity where + get bh = do + (aa :: Int) <- get bh + (ab :: FixityDirection) <- get bh + return Fixity + +instance (Binary name) => Binary (IPName name) where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: name) <- get bh ; return IPName + _ -> do (ab :: name) <- get bh ; return IPName + +------------------------------------------------------------------------- +-- Types from: basicTypes/NewDemand +------------------------------------------------------------------------- + +instance Binary DmdType where + -- Ignore DmdEnv when spitting out the DmdType + get bh = do (ds :: [Demand]) <- get bh + (dr :: DmdResult) <- get bh + return DmdType + +instance Binary Demand where + get bh = do + h <- getByte bh + case h of + 0 -> return Demand + 1 -> return Demand + 2 -> do (aa :: Demand) <- get bh ; return Demand + 3 -> do (ab :: Demands) <- get bh ; return Demand + 4 -> do (ac :: Demands) <- get bh ; return Demand + 5 -> do (ad :: Demand) <- get bh ; return Demand + _ -> return Demand + +instance Binary Demands where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: Demand) <- get bh + return Demands + _ -> do (ab :: [Demand]) <- get bh + return Demands + +instance Binary DmdResult where + get bh = do + h <- getByte bh + case h of + 0 -> return DmdResult + 1 -> return DmdResult + _ -> return DmdResult + +instance Binary StrictSig where + get bh = do (aa :: DmdType) <- get bh ; return StrictSig +-} + +------------------------------------------------------------------------- +-- Types from: CostCentre, from profiling/CostCentre.lhs +------------------------------------------------------------------------- + +{- +instance Binary IsCafCC where + get bh = do + h <- getByte bh + case h of + 0 -> return IsCafCC + _ -> return IsCafCC + +instance Binary IsDupdCC where + get bh = do + h <- getByte bh + case h of + 0 -> return IsDupdCC + _ -> return IsDupdCC + +instance Binary CostCentre where + get bh = do + h <- getByte bh + case h of + 0 -> do return CostCentre + 1 -> do (aa :: CcName) <- get bh + (ab :: ModuleName) <- get bh + (ac :: IsDupdCC) <- get bh + (ad :: IsCafCC) <- get bh + return CostCentre + _ -> do (ae :: ModuleName) <- get bh + return CostCentre +-} + +------------------------------------------------------------------------- +-- IfaceTypes and friends, from IfaceType.lhs +------------------------------------------------------------------------- + +{- +instance Binary IfaceExtName where + get bh = do + h <- getByte bh + case h of + 0 -> do (mod :: ModuleName) <- get bh + (occ :: OccName) <- get bh + return IfaceExtName + 1 -> do (mod :: ModuleName) <- get bh + (occ :: OccName) <- get bh + (vers :: Version) <- get bh + return IfaceExtName + _ -> do (occ :: OccName) <- get bh + return IfaceExtName + +instance Binary IfaceBndr where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: IfaceIdBndr) <- get bh ; return IfaceBndr + _ -> do (ab :: IfaceTvBndr) <- get bh ; return IfaceBndr + +instance Binary Kind where + get bh = do + h <- getByte bh + case h of + 0 -> return Kind + 1 -> return Kind + 2 -> return Kind + 3 -> return Kind + 4 -> return Kind + _ -> do (k1 :: Kind) <- get bh + (k2 :: Kind) <- get bh + return Kind + +instance Binary IfaceType where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: IfaceTvBndr) <- get bh + (ab :: IfaceType) <- get bh + return IfaceType + 1 -> do (ad :: OccName) <- get bh + return IfaceType + 2 -> do (ae :: IfaceType) <- get bh + (af :: IfaceType) <- get bh + return IfaceType + 3 -> do (ag :: IfaceType) <- get bh + (ah :: IfaceType) <- get bh + return IfaceType + 5 -> do (ap :: IfacePredType) <- get bh + return IfaceType + + -- Now the special cases for TyConApp + 6 -> return IfaceType + 7 -> return IfaceType + 8 -> return IfaceType + 9 -> do (ty :: IfaceType) <- get bh + return IfaceType + 10 -> return IfaceType + 11 -> do (t1 :: IfaceType) <- get bh + (t2 :: IfaceType) <- get bh + return IfaceType + 12 -> do (tc :: IfaceExtName) <- get bh + (tys :: [IfaceType]) <- get bh + return IfaceType + _ -> do (tc :: IfaceTyCon) <- get bh + (tys :: [IfaceType]) <- get bh + return IfaceType + +instance Binary IfaceTyCon where + get bh = do + h <- getByte bh + case h of + 1 -> return IfaceTyCon + 2 -> return IfaceTyCon + _ -> do (bx :: Boxity) <- get bh + (ar :: Arity) <- get bh + return IfaceTyCon + +instance Binary IfacePredType where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: IfaceExtName) <- get bh + (ab :: [IfaceType]) <- get bh + return IfacePredType + _ -> do (ac :: (IPName OccName)) <- get bh + (ad :: IfaceType) <- get bh + return IfacePredType + +instance Binary IfaceExpr where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: OccName) <- get bh + return IfaceExpr + 1 -> do (ab :: IfaceType) <- get bh + return IfaceExpr + 2 -> do (ac :: Boxity) <- get bh + (ad :: [IfaceExpr]) <- get bh + return IfaceExpr + 3 -> do (ae :: IfaceBndr) <- get bh + (af :: IfaceExpr) <- get bh + return IfaceExpr + 4 -> do (ag :: IfaceExpr) <- get bh + (ah :: IfaceExpr) <- get bh + return IfaceExpr + 5 -> do (ai :: IfaceExpr) <- get bh + (aj :: OccName) <- get bh + (ak :: [IfaceAlt]) <- get bh + return IfaceExpr + 6 -> do (al :: IfaceBinding) <- get bh + (am :: IfaceExpr) <- get bh + return IfaceExpr + 7 -> do (an :: IfaceNote) <- get bh + (ao :: IfaceExpr) <- get bh + return IfaceExpr + 8 -> do (ap :: Literal) <- get bh + return IfaceExpr + 9 -> do (as :: ForeignCall) <- get bh + (at :: IfaceType) <- get bh + return IfaceExpr + _ -> do (aa :: IfaceExtName) <- get bh + return IfaceExpr + +instance Binary IfaceConAlt where + get bh = do + h <- getByte bh + case h of + 0 -> return IfaceConAlt + 1 -> do (aa :: OccName) <- get bh + return IfaceConAlt + 2 -> do (ab :: Boxity) <- get bh + return IfaceConAlt + _ -> do (ac :: Literal) <- get bh + return IfaceConAlt + +instance Binary IfaceBinding where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: IfaceIdBndr) <- get bh + (ab :: IfaceExpr) <- get bh + return IfaceBinding + _ -> do (ac :: [(IfaceIdBndr,IfaceExpr)]) <- get bh + return IfaceBinding + +instance Binary IfaceIdInfo where + get bh = do + h <- getByte bh + case h of + 0 -> return IfaceIdInfo + _ -> do (info :: [IfaceInfoItem]) <- lazyGet bh + return IfaceIdInfo + +instance Binary IfaceInfoItem where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: Arity) <- get bh + return IfaceInfoItem + 1 -> do (ab :: StrictSig) <- get bh + return IfaceInfoItem + 2 -> do (ac :: Activation) <- get bh + (ad :: IfaceExpr) <- get bh + return IfaceInfoItem + 3 -> return IfaceInfoItem + _ -> do (ae :: IfaceExtName) <- get bh + (af :: Arity) <- get bh + return IfaceInfoItem + +instance Binary IfaceNote where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: CostCentre) <- get bh + return IfaceNote + 1 -> do (ab :: IfaceType ) <- get bh + return IfaceNote + 2 -> return IfaceNote + 3 -> return IfaceNote + _ -> do (ac :: String) <- get bh + return IfaceNote + +instance Binary IfaceDecl where + get bh = do + h <- getByte bh + case h of + 0 -> do + (name :: OccName) <- get bh + (ty :: IfaceType) <- get bh + (idinfo :: IfaceIdInfo) <- get bh + return IfaceDecl + 1 -> error "Binary.get(TyClDecl): ForeignType" + 2 -> do + (a1 :: IfaceContext) <- get bh + (a2 :: OccName) <- get bh + (a3 :: [IfaceTvBndr]) <- get bh + (a4 :: IfaceConDecls) <- get bh + (a5 :: RecFlag) <- get bh + (a6 :: ArgVrcs) <- get bh + (a7 :: Bool) <- get bh + return IfaceDecl + 3 -> do + (aq :: OccName) <- get bh + (ar :: [IfaceTvBndr]) <- get bh + (as :: ArgVrcs) <- get bh + (at :: IfaceType) <- get bh + return IfaceDecl + _ -> do + (a1 :: IfaceContext) <- get bh + (a2 :: OccName) <- get bh + (a3 :: [IfaceTvBndr]) <- get bh + (a4 :: [FunDep OccName])<- get bh + (a5 :: [IfaceClassOp]) <- get bh + (a6 :: RecFlag) <- get bh + (a7 :: ArgVrcs) <- get bh + return IfaceDecl + +instance Binary IfaceInst where + get bh = do + (ty :: IfaceType) <- get bh + (dfun :: OccName) <- get bh + return IfaceInst + +instance Binary IfaceConDecls where + get bh = do + h <- getByte bh + case h of + 0 -> return IfaceConDecls + 1 -> do (aa :: [IfaceConDecl]) <- get bh + return IfaceConDecls + _ -> do (aa :: IfaceConDecl) <- get bh + return IfaceConDecls + +instance Binary IfaceConDecl where + get bh = do + (a1 :: OccName) <- get bh + (a2 :: [IfaceTvBndr]) <- get bh + (a3 :: IfaceContext) <- get bh + (a4 :: [IfaceType]) <- get bh + (a5 :: [StrictnessMark])<- get bh + (a6 :: [OccName]) <- get bh + return IfaceConDecl + +instance Binary IfaceClassOp where + get bh = do + (n :: OccName) <- get bh + (def :: DefMeth) <- get bh + (ty :: IfaceType) <- get bh + return IfaceClassOp + +instance Binary IfaceRule where + get bh = do + (a1 :: RuleName) <- get bh + (a2 :: Activation) <- get bh + (a3 :: [IfaceBndr]) <- get bh + (a4 :: IfaceExtName) <- get bh + (a5 :: [IfaceExpr]) <- get bh + (a6 :: IfaceExpr) <- get bh + return IfaceRule + +-} + +------------------------------------------------------------------------ +-- from Literal +------------------------------------------------------------------------ + +{- +instance Binary Literal where + get bh = do + h <- getByte bh + case h of + 0 -> do + (aa :: Char) <- get bh + return Literal + 1 -> do + (ab :: FastString) <- get bh + return Literal + 2 -> do return Literal + 3 -> do + (ad :: Integer) <- get bh + return Literal + 4 -> do + (ae :: Integer) <- get bh + return Literal + 5 -> do + (af :: Integer) <- get bh + return Literal + 6 -> do + (ag :: Integer) <- get bh + return Literal + 7 -> do + (ah :: Rational) <- get bh + return Literal + 8 -> do + (ai :: Rational) <- get bh + return Literal + 9 -> do + (aj :: FastString) <- get bh + (mb :: Maybe Int) <- get bh + return Literal + _ -> return Literal -- ? + +-} + +------------------------------------------------------------------------ +-- prelude/ForeignCall.lhs +------------------------------------------------------------------------ + +{- +instance Binary ForeignCall where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: CCallSpec) <- get bh + return ForeignCall + _ -> do (ab :: DNCallSpec) <- get bh + return ForeignCall + +instance Binary Safety where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: Bool) <- get bh + return Safety + _ -> return Safety + +instance Binary CExportSpec where + get bh = do + (aa :: CLabelString) <- get bh + (ab :: CCallConv) <- get bh + return CExportSpec + +instance Binary CCallSpec where + get bh = do + (aa :: CCallTarget) <- get bh + (ab :: CCallConv) <- get bh + (ac :: Safety) <- get bh + return CCallSpec + +instance Binary CCallTarget where + get bh = do + h <- getByte bh + case h of + 0 -> do (aa :: CLabelString) <- get bh + return CCallTarget + _ -> return CCallTarget + +instance Binary CCallConv where + get bh = do + h <- getByte bh + case h of + 0 -> return CCallConv + _ -> return CCallConv + +instance Binary DNCallSpec where + get bh = do + (isStatic :: Bool) <- get bh + (kind :: DNKind) <- get bh + (ass :: String) <- get bh + (nm :: String) <- get bh + return DNCallSpec + +instance Binary DNKind where + get bh = do + h <- getByte bh + case h of + _ -> return DNKind + +instance Binary DNType where + get bh = do + h <- getByte bh + case h of + _ -> return DNType + +-} diff --git a/src/hi/Hi/PrimPacked.hs b/src/hi/Hi/PrimPacked.hs new file mode 100644 index 0000000..ad8b87d --- /dev/null +++ b/src/hi/Hi/PrimPacked.hs @@ -0,0 +1,194 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +{-# OPTIONS -fno-warn-name-shadowing -fno-warn-unused-matches #-} + +{-# OPTIONS -#include "hschooks.h" #-} + +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- +-- Based on $fptools/ghc/compiler/utils/PrimPacked.lhs +-- +-- (c) The GRASP/AQUA Project, Glasgow University, 1997-1998 +-- +-- +-- Basic ops on packed representations +-- +-- Some basic operations for working on packed representations of series +-- of bytes (character strings). Used by the interface lexer input +-- subsystem, mostly. + +{-# OPTIONS -optc-DNON_POSIX_SOURCE #-} + +module Hi.PrimPacked ( + Ptr(..), nullPtr, plusAddr#, + BA(..), + packString, -- :: String -> (Int, BA) + unpackNBytesBA, -- :: BA -> Int -> [Char] + strLength, -- :: Ptr CChar -> Int + copyPrefixStr, -- :: Addr# -> Int -> BA + copySubStrBA, -- :: BA -> Int -> Int -> BA + eqStrPrefix, -- :: Addr# -> ByteArray# -> Int# -> Bool + eqStrPrefixBA, -- :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool + ) where + +import Foreign +import GHC.Exts +import GHC.ST + +-- Wrapper types for bytearrays + +data BA = BA ByteArray# +data MBA s = MBA (MutableByteArray# s) + +packString :: String -> (Int, BA) +packString str = (l, arr) + where + l@(I# length#) = length str + + arr = runST (do + ch_array <- new_ps_array length# + -- fill in packed string from "str" + fill_in ch_array 0# str + -- freeze the puppy: + freeze_ps_array ch_array length# + ) + + fill_in :: MBA s -> Int# -> [Char] -> ST s () + fill_in arr_in# idx [] = + return () + fill_in arr_in# idx (C# c : cs) = + write_ps_array arr_in# idx c >> + fill_in arr_in# (idx +# 1#) cs + +-- Unpacking a string + +unpackNBytesBA :: BA -> Int -> [Char] +unpackNBytesBA (BA bytes) (I# len) + = unpack 0# + where + unpack nh + | nh >=# len = [] + | otherwise = C# ch : unpack (nh +# 1#) + where + ch = indexCharArray# bytes nh + +-- Copying a char string prefix into a byte array. + +copyPrefixStr :: Addr# -> Int -> BA +copyPrefixStr a# len@(I# length#) = copy' length# + where + copy' length# = runST (do + {- allocate an array that will hold the string + -} + ch_array <- new_ps_array length# + {- Revert back to Haskell-only solution for the moment. + _ccall_ memcpy ch_array (A# a) len >>= \ () -> + write_ps_array ch_array length# (chr# 0#) >> + -} + -- fill in packed string from "addr" + fill_in ch_array 0# + -- freeze the puppy: + freeze_ps_array ch_array length# + ) + + fill_in :: MBA s -> Int# -> ST s () + fill_in arr_in# idx + | idx ==# length# + = return () + | otherwise + = case (indexCharOffAddr# a# idx) of { ch -> + write_ps_array arr_in# idx ch >> + fill_in arr_in# (idx +# 1#) } + +-- Copying out a substring, assume a 0-indexed string: +-- (and positive lengths, thank you). + +copySubStrBA :: BA -> Int -> Int -> BA +copySubStrBA (BA barr#) (I# start#) len@(I# length#) = ba + where + ba = runST (do + -- allocate an array that will hold the string + ch_array <- new_ps_array length# + -- fill in packed string from "addr" + fill_in ch_array 0# + -- freeze the puppy: + freeze_ps_array ch_array length# + ) + + fill_in :: MBA s -> Int# -> ST s () + fill_in arr_in# idx + | idx ==# length# + = return () + | otherwise + = case (indexCharArray# barr# (start# +# idx)) of { ch -> + write_ps_array arr_in# idx ch >> + fill_in arr_in# (idx +# 1#) } + +-- (Very :-) ``Specialised'' versions of some CharArray things... +-- [Copied from PackBase; no real reason -- UGH] + +new_ps_array :: Int# -> ST s (MBA s) +write_ps_array :: MBA s -> Int# -> Char# -> ST s () +freeze_ps_array :: MBA s -> Int# -> ST s BA + +#if __GLASGOW_HASKELL__ < 411 +#define NEW_BYTE_ARRAY newCharArray# +#else +#define NEW_BYTE_ARRAY newByteArray# +#endif + +new_ps_array size = ST $ \ s -> + case (NEW_BYTE_ARRAY size s) of { (# s2#, barr# #) -> + (# s2#, MBA barr# #) } + +write_ps_array (MBA barr#) n ch = ST $ \ s# -> + case writeCharArray# barr# n ch s# of { s2# -> + (# s2#, () #) } + +-- same as unsafeFreezeByteArray +freeze_ps_array (MBA arr#) len# = ST $ \ s# -> + case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) -> + (# s2#, BA frozen# #) } + +-- Compare two equal-length strings for equality: + +eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool +eqStrPrefix a# barr# len# = + unsafePerformIO $ do + x <- memcmp_ba a# barr# (I# len#) + return (x == 0) + +eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool +eqStrPrefixBA b1# b2# start# len# = + unsafePerformIO $ do + x <- memcmp_baoff_ba b2# (I# start#) b1# (I# len#) + return (x == 0) + +------------------------------------------------------------------------ +-- in hschooks +-- + +foreign import ccall unsafe "plugin_strlen" + strLength :: Ptr () -> Int + +foreign import ccall unsafe "plugin_memcmp" + memcmp_ba :: Addr# -> ByteArray# -> Int -> IO Int + +foreign import ccall unsafe "plugin_memcmp_off" + memcmp_baoff_ba :: ByteArray# -> Int -> ByteArray# -> Int -> IO Int + diff --git a/src/hi/Hi/Syntax.hs b/src/hi/Hi/Syntax.hs new file mode 100644 index 0000000..e37f644 --- /dev/null +++ b/src/hi/Hi/Syntax.hs @@ -0,0 +1,360 @@ +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- +-- Based on code from $fptools/ghc/compiler/main/HscTypes.lhs +-- (c) The University of Glasgow 2002 +-- + +module Hi.Syntax where + +import Hi.FastString + +import Data.List ( intersperse ) + +-- --------------------------------------------------------------------- +-- An Iface, the representation of an .hi file. +-- +-- The abstract syntax that we don't need is blanked with a default +-- type, however we must be careful in BinIface to still parse the +-- correct number of bytes for each data type. This involves leaving the +-- code alone, other than to add the types of the sub-constructors of +-- the types we have blanked out (because they can't be inferred +-- anymore). +-- + +data Iface = Iface { + mi_package :: String, -- what package is this? + mi_module :: String, -- what module is this? + mi_deps :: Dependencies, + mi_usages :: [Usage], + mi_exports :: [IfaceExport] {-,-} + +-- mi_decls :: [(Version,IfaceDecl)] {-,-} + +-- mi_mod_vers :: !Version, +-- mi_orphan :: !Bool, +-- mi_boot :: !Bool, +-- mi_exp_vers :: !Version, +-- mi_fixities :: [(OccName,Fixity)], +-- mi_deprecs :: [IfaceDeprec], +-- mi_insts :: [IfaceInst], +-- mi_rules :: [IfaceRule], +-- mi_rule_vers :: !Version, + } + +emptyIface = Iface { + mi_package = undefined, + mi_module = undefined, + mi_deps = noDependencies, + mi_usages = undefined, + mi_exports = undefined + } + +-- --------------------------------------------------------------------- +-- pretty-print an interface +-- +showIface :: Iface -> String +showIface (Iface { mi_package = p, mi_module = m, + mi_deps = deps, mi_usages = us }) = + "interface \"" ++ p ++ "\" " ++ m ++ + "\n" ++ pprDeps deps ++ + "\n" ++ (concat $ intersperse "\n" (map pprUsage us)) + -- "\n" ++ (concat $ intersperse "\n" (map pprExport es)) + +pprDeps :: Dependencies -> String +pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs }) + = "module dependencies: " ++ (concat $ intersperse ", " mods) ++ + "\npackage dependencies: " ++ (concat $ intersperse ", " pkgs) + +pprUsage :: Usage -> String +pprUsage usage = hsep ["import", usg_name usage] + +pprExport :: IfaceExport -> String +pprExport (fsmod, items) + = hsep [ "export", unpackFS fsmod, hsep (map pp_avail items) ] + where + pp_avail :: GenAvailInfo OccName -> String + pp_avail (Avail nm) = ppr_occ nm + pp_avail (AvailTC _ []) = empty + pp_avail (AvailTC n (n':ns)) + | n==n' = (ppr_occ n) ++ pp_export ns + | otherwise = (ppr_occ n) ++ "|" ++ pp_export (n':ns) + + pp_export [] = empty + pp_export names = "{" ++ (hsep (map ppr_occ names)) ++ "}" + + ppr_occ (OccName _ s) = s + +-- +-- TODO bring in the Pretty library +-- +hsep = \ss -> concat (intersperse " " ss) +empty = "" + +-- --------------------------------------------------------------------- +-- +-- Dependency info about modules and packages below this one +-- in the import hierarchy. See TcRnTypes.ImportAvails for details. +-- +-- Invariant: the dependencies of a module M never includes M +-- Invariant: the lists are unordered, with no duplicates +-- +-- The fields are: +-- Home-package module dependencies +-- External package dependencies +-- Orphan modules (whether home or external pkg) + +data Dependencies = Deps { + dep_mods :: [ModuleName], + dep_pkgs :: [PackageName] {-,-} + } deriving (Show) + +noDependencies :: Dependencies +noDependencies = Deps [] [] + +-- +-- Type aliases need to have a real type so the parser can work out how +-- to parse them. You have to find what these are by reading GHC. +-- +type ModuleName = String {- was FastString -} -- Module +type PackageName = String {- was FastString -} -- Packages +type Version = Int -- BasicTypes +type EncodedFS = FastString -- FastString +type IfaceExport = (EncodedFS, [GenAvailInfo OccName]) -- HscTypes + +data GenAvailInfo name + = Avail name -- An ordinary identifier + | AvailTC name -- The name of the type or class + [name] -- The available pieces of type/class. + -- NB: If the type or class is itself + -- to be in scope, it must be in this list. + -- Thus, typically: AvailTC Eq [Eq, ==, /=] + deriving Show + +data OccName = OccName NameSpace String {- was EncodedFS -} + deriving Show + +instance Eq OccName where + (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2 + +data NameSpace = VarName -- variables, and "source" data constructors + | DataName -- "real" data constructors + | TvName -- tyvars + | TcClsName -- type constructors and classes + deriving (Eq, Show) + +data Usage + = Usage { usg_name :: ModuleName, -- Name of the module + usg_mod :: Version, -- Module version + usg_exports :: Maybe Version, -- Export-list version, if we depend on it + usg_entities :: [(OccName,Version)],-- Sorted by occurrence name + usg_rules :: Version -- Orphan-rules version (for non-orphan + -- modules this will always be initialVersion) + } deriving Show + +------------------------------------------------------------------------ +-- TODO parsing type and decl information out of the .hi file +-- complex data structure... +-- + +{- +data IfaceExtName + = ExtPkg ModuleName OccName -- From an external package; no version # + -- Also used for wired-in things regardless + -- of whether they are home-pkg or not + + | HomePkg ModuleName OccName Version -- From another module in home package; + -- has version # + + | LocalTop OccName -- Top-level from the same module as + -- the enclosing IfaceDecl + + | LocalTopSub -- Same as LocalTop, but for a class method or constr + OccName -- Class-meth/constr name + OccName -- Parent class/datatype name + -- LocalTopSub is written into iface files as LocalTop; the parent + -- info is only used when computing version information in MkIface + +data IfaceTyCon -- Abbreviations for common tycons with known names + = IfaceTc IfaceExtName -- The common case + | IfaceIntTc | IfaceBoolTc | IfaceCharTc + | IfaceListTc | IfacePArrTc + | IfaceTupTc Boxity Arity + +type Arity = Int -- BasicTypes + +data Boxity + = Boxed + | Unboxed + +type IfaceContext = [IfacePredType] + +data IfacePredType -- NewTypes are handled as ordinary TyConApps + = IfaceClassP IfaceExtName [IfaceType] + | IfaceIParam (IPName OccName) IfaceType + +data IPName name + = Dupable name -- ?x: you can freely duplicate this implicit parameter + | Linear name -- %x: you must use the splitting function to duplicate it + deriving( Eq, Ord ) -- Ord is used in the IP name cache finite map + -- (used in HscTypes.OrigIParamCache) + +data IfaceType + = IfaceTyVar OccName -- Type variable only, not tycon + | IfaceAppTy IfaceType IfaceType + | IfaceForAllTy IfaceTvBndr IfaceType + | IfacePredTy IfacePredType + | IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated + -- Includes newtypes, synonyms, tuples + | IfaceFunTy IfaceType IfaceType + +data IfaceBndr -- Local (non-top-level) binders + = IfaceIdBndr IfaceIdBndr + | IfaceTvBndr IfaceTvBndr + +type IfaceIdBndr = (OccName, IfaceType) -- OccName, because always local +type IfaceTvBndr = (OccName, IfaceKind) +type IfaceKind = Kind -- Re-use the Kind type, but no KindVars in it + +data IfaceIdInfo + = NoInfo -- When writing interface file without -O + | HasInfo [IfaceInfoItem] -- Has info, and here it is + +data IfaceInfoItem + = HsArity Arity + | HsStrictness StrictSig + | HsUnfold Activation IfaceExpr + | HsNoCafRefs + | HsWorker IfaceExtName Arity -- Worker, if any see IdInfo.WorkerInfo + -- for why we want arity here. + -- NB: we need IfaceExtName (not just OccName) because the worker + -- can simplify to a function in another module. +-- NB: Specialisations and rules come in separately and are +-- only later attached to the Id. Partial reason: some are orphans. + +newtype StrictSig = StrictSig DmdType + +data IfaceDecl + = IfaceId { ifName :: OccName, + ifType :: IfaceType, + ifIdInfo :: IfaceIdInfo } + + | IfaceData { ifCtxt :: IfaceContext, -- Context + ifName :: OccName, -- Type constructor + ifTyVars :: [IfaceTvBndr], -- Type variables + ifCons :: IfaceConDecls, -- Includes new/data info + ifRec :: RecFlag, -- Recursive or not? + ifVrcs :: ArgVrcs, + ifGeneric :: Bool -- True <=> generic converter functions available + } -- We need this for imported data decls, since the + -- imported modules may have been compiled with + -- different flags to the current compilation unit + + | IfaceSyn { ifName :: OccName, -- Type constructor + ifTyVars :: [IfaceTvBndr], -- Type variables + ifVrcs :: ArgVrcs, + ifSynRhs :: IfaceType -- synonym expansion + } + + | IfaceClass { ifCtxt :: IfaceContext, -- Context... + ifName :: OccName, -- Name of the class + ifTyVars :: [IfaceTvBndr], -- Type variables + ifFDs :: [FunDep OccName], -- Functional dependencies + ifSigs :: [IfaceClassOp], -- Method signatures + ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive? + ifVrcs :: ArgVrcs -- ... and what are its argument variances ... + } + + | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET + ifExtName :: Maybe FastString } +-} + +------------------------------------------------------------------------ +-- +-- all this stuff may be enabled if we ever want other information out +-- + +{- +type ArgVrcs = [(Bool,Bool)] -- TyCon +type CLabelString = FastString -- CStrings +type CcName = EncodedFS -- CostCentre +type DeprecTxt = FastString -- BasicTypes +type FunDep a = ([a],[a]) -- Class +type IfaceAlt = (IfaceConAlt,[OccName],IfaceExpr) -- IfaceSyn +type IfaceContext = [IfacePredType] -- IfaceType +type IfaceDeprec = Deprecs [(OccName,DeprecTxt)] -- HscTypes +type IfaceIdBndr = (OccName, IfaceType) -- IfaceType +type IfaceKind = Kind -- IfaceType +type IfaceTvBndr = (OccName, IfaceKind) -- IfaceType +type RuleName = FastString -- CoreSyn + +-- +-- Empty definitions for the various types we need, but whose results we +-- don't care about. +-- +-- 'data' types that have a parsing method associated with them +-- This list corresponds to each instance in BinIface +-- +-- Try to keep this list ordered by the order they appear in BinIface +-- +data Deprecs a = Deprecs +data Activation = Activation +data StrictnessMark = StrictnessMark +data Boxity = Boxity +data TupCon = TupCon +data RecFlag = RecFlag +data DefMeth = DefMeth +data FixityDirection = FixityDirection +data Fixity = Fixity +data DmdType = DmdType +data Demand = Demand +data Demands = Demands +data DmdResult = DmdResult +data StrictSig = StrictSig +data IsCafCC = IsCafCC +data IsDupdCC = IsDupdCC +data CostCentre = CostCentre +data IfaceExtName = IfaceExtName +data IfaceBndr = IfaceBndr +data Kind = Kind +data IfaceTyCon = IfaceTyCon +data IfacePredType = IfacePredType +data IfaceExpr = IfaceExpr +data IfaceConAlt = IfaceConAlt +data IfaceBinding = IfaceBinding +data IfaceIdInfo = IfaceIdInfo +data IfaceNoteItem = IfaceNoteItem +data IfaceInfoItem = IfaceInfoItem +data IfaceNote = IfaceNote +data IfaceInst = IfaceInst +data IfaceConDecls = IfaceConDecls +data IfaceConDecl = IfaceConDecl +data IfaceClassOp = IfaceClassOp +data IfaceRule = IfaceRule +data Literal = Literal +data ForeignCall = ForeignCall +data Safety = Safety +data CExportSpec = CExportSpec +data CCallSpec = CCallSpec +data CCallTarget = CCallTarget +data CCallConv = CCallConv +data DNCallSpec = DNCallSpec +data DNKind = DNKind +data DNType = DNType + +-} diff --git a/src/hi/Hi/hschooks.c b/src/hi/Hi/hschooks.c new file mode 100644 index 0000000..d2e4823 --- /dev/null +++ b/src/hi/Hi/hschooks.c @@ -0,0 +1,38 @@ +/* +These routines customise the error messages +for various bits of the RTS. They are linked +in instead of the defaults. +*/ + +#include + +/* For GHC 4.08, we are relying on the fact that RtsFlags has + * compatibile layout with the current version, because we're + * #including the current version of RtsFlags.h below. 4.08 didn't + * ship with its own RtsFlags.h, unfortunately. For later GHC + * versions, we #include the correct RtsFlags.h. + */ + +#include "Rts.h" +#include "RtsFlags.h" + +#include "HsFFI.h" + +HsInt +plugin_strlen( HsAddr a ) +{ + return (strlen((char *)a)); +} + +HsInt +plugin_memcmp( HsAddr a1, HsAddr a2, HsInt len ) +{ + return (memcmp((char *)a1, a2, len)); +} + +HsInt +plugin_memcmp_off( HsAddr a1, HsInt i, HsAddr a2, HsInt len ) +{ + return (memcmp((char *)a1 + i, a2, len)); +} + diff --git a/src/hi/Hi/hschooks.h b/src/hi/Hi/hschooks.h new file mode 100644 index 0000000..a1b47bb --- /dev/null +++ b/src/hi/Hi/hschooks.h @@ -0,0 +1,13 @@ +/* ----------------------------------------------------------------------------- + * $ Id: hschooks.h,v 1.1.1.1 2004/05/24 09:35:39 dons Exp $ + * + * Hooks into the RTS from the compiler. + * + * -------------------------------------------------------------------------- */ + +#include "HsFFI.h" + +// Out-of-line string functions, see PrimPacked.lhs +HsInt plugin_strlen( HsAddr a ); +HsInt plugin_memcmp( HsAddr a1, HsAddr a2, HsInt len ); +HsInt plugin_memcmp_off( HsAddr a1, HsInt i, HsAddr a2, HsInt len ); diff --git a/src/hi/Makefile b/src/hi/Makefile new file mode 100644 index 0000000..5d3b87d --- /dev/null +++ b/src/hi/Makefile @@ -0,0 +1,12 @@ +PKG = hi +UPKG = Hi + +CSRC = $(UPKG)/hschooks.c +COBJ = $(UPKG)/hschooks.o + +TOP=../.. +include ../build.mk + +HC_OPTS += -I$(UPKG) + +install: install-me diff --git a/src/hi/hi.conf.in.cpp b/src/hi/hi.conf.in.cpp new file mode 100644 index 0000000..bdea4b8 --- /dev/null +++ b/src/hi/hi.conf.in.cpp @@ -0,0 +1,57 @@ +#if CABAL == 0 && GLASGOW_HASKELL < 604 +Package { + name = "hi", + auto = False, + hs_libraries = [ "HShi" ], +#ifdef INSTALLING + import_dirs = [ "${LIBDIR}/imports" ], + library_dirs = [ "${LIBDIR}/" ], +#else + import_dirs = [ "${TOP}/src/hi" ], + library_dirs = [ "${TOP}/src/hi" ], +#endif + include_dirs = [], + c_includes = [], + source_dirs = [], + extra_libraries = [], + package_deps = [ "base", "haskell98" ], + extra_ghc_opts = [], + extra_cc_opts = [], + extra_ld_opts = [] +} +#else +name: hi +version: 1.0 +license: BSD3 +maintainer: libraries@haskell.org +exposed: True +exposed-modules: + Hi.Binary, + Hi.FastMutInt, + Hi.FastString, + Hi.Parser, + Hi.PrimPacked, + Hi.Syntax, + Hi + +hidden-modules: +#ifdef INSTALLING +import-dirs: LIBDIR/imports +library-dirs: LIBDIR +#else +import-dirs: TOP/src/hi +library-dirs: TOP/src/hi +#endif +hs-libraries: HShi +extra-libraries: +include-dirs: +includes: +depends: base, haskell98 +hugs-options: +cc-options: +ld-options: +framework-dirs: +frameworks: +haddock-interfaces: +haddock-html: +#endif diff --git a/src/plugins/Makefile b/src/plugins/Makefile new file mode 100644 index 0000000..c9f8061 --- /dev/null +++ b/src/plugins/Makefile @@ -0,0 +1,22 @@ +PKG = plugins +UPKG = Plugins + +TOP=../.. +include $(TOP)/config.mk + +ifeq ($(CABAL),1) +YOBJ = $(UPKG)/ParsePkgConfCabal.hs +YSRC = $(UPKG)/ParsePkgConfCabal.y +else +YOBJ = $(UPKG)/ParsePkgConfLite.hs +YSRC = $(UPKG)/ParsePkgConfLite.y +endif + +include ../build.mk + +HC_OPTS += -package-conf $(TOP)/plugins.conf.inplace +HC_OPTS += -package altdata -package hi -package posix +HC_OPTS += -O -funbox-strict-fields +HC_OPTS += -Wall -fno-warn-missing-signatures + +install: install-me diff --git a/src/plugins/Plugins.hs b/src/plugins/Plugins.hs new file mode 100644 index 0000000..08d0617 --- /dev/null +++ b/src/plugins/Plugins.hs @@ -0,0 +1,37 @@ +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +module Plugins ( + + -- $Description + + module Plugins.Make, + module Plugins.Load, + + ) where + +import Plugins.Make {-all-} +import Plugins.Load {-all-} + +-- +-- $Description +-- +-- [@NAME@] hs-plugins library : compile and load Haskell code at runtime +-- + diff --git a/src/plugins/Plugins/Consts.hs b/src/plugins/Plugins/Consts.hs new file mode 100644 index 0000000..cd3a292 --- /dev/null +++ b/src/plugins/Plugins/Consts.hs @@ -0,0 +1,62 @@ +{-# OPTIONS -cpp #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +module Plugins.Consts where + +#include "../../../config.h" + +-- | path to *build* dir, used by eval() for testing the examples +top = TOP + +-- | what is ghc called? +ghc = GHC + +-- | path to standard ghc libraries +ghcLibraryPath = GHC_LIB_PATH + +-- | name of the system package.conf file +sysPkgConf = "package.conf" + +-- | This code is from runtime_loader: +-- The extension used by system modules. +sysPkgSuffix = ".o" +objSuf = sysPkgSuffix +hiSuf = ".hi" +hsSuf = ".hs" + +-- | The prefix used by system modules. This, in conjunction with +-- 'systemModuleExtension', will result in a module filename that looks +-- like \"HSconcurrent.o\" +sysPkgPrefix = "HS" + +-- | '_' on a.out, and Darwin +#if LEADING_UNDERSCORE == 1 +prefixUnderscore = "_" +#else +prefixUnderscore = "" +#endif + +-- | Define tmpDir to where tmp files should be created on your platform +#if !defined(__MINGW32__) +tmpDir = "/tmp" +#else +tmpDir = error "tmpDir not defined for this platform. Try setting the TMPDIR env var" +#endif + diff --git a/src/plugins/Plugins/Env.hs b/src/plugins/Plugins/Env.hs new file mode 100644 index 0000000..5d1fd0c --- /dev/null +++ b/src/plugins/Plugins/Env.hs @@ -0,0 +1,358 @@ +{-# OPTIONS -cpp #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +module Plugins.Env ( + withModEnv, + withPkgEnvs, + withMerged, + modifyModEnv, + modifyPkgEnv, + modifyMerged, + addModule, + rmModule, + addModules, + isLoaded, + loaded, + isMerged, + lookupMerged, + addMerge, + addPkgConf, + union, + grabDefaultPkgConf, + readPackageConf, + lookupPkg + + ) where + +#include "../../../config.h" + +import Plugins.PackageAPI {- everything -} +#if CABAL == 1 || __GLASGOW_HASKELL__ >= 604 +import Plugins.ParsePkgConfCabal( parsePkgConf ) +#else +import Plugins.ParsePkgConfLite ( parsePkgConf ) +#endif +import Plugins.Consts ( ghcLibraryPath, sysPkgConf, sysPkgSuffix ) + +import Data.IORef ( writeIORef, readIORef, newIORef, IORef() ) +import Data.Maybe ( isJust ) +import Data.List ( isPrefixOf, nub ) + +import System.IO.Unsafe ( unsafePerformIO ) +import System.Directory ( doesFileExist ) + +import Control.Concurrent.MVar ( MVar(), newMVar, withMVar ) + +#if __GLASGOW_HASKELL__ < 604 +import Data.FiniteMap + +#else +import qualified Data.Map as M + +-- +-- and map Data.Map terms to FiniteMap terms +-- +type FiniteMap k e = M.Map k e + +emptyFM :: FiniteMap key elt +emptyFM = M.empty + +addToFM :: (Ord key) => FiniteMap key elt -> key -> elt -> FiniteMap key elt +addToFM = \m k e -> M.insert k e m + +delFromFM :: (Ord key) => FiniteMap key elt -> key -> FiniteMap key elt +delFromFM = flip M.delete + +lookupFM :: (Ord key) => FiniteMap key elt -> key -> Maybe elt +lookupFM = flip M.lookup + +#endif + +-- +-- We need to record what modules and packages we have loaded, so if we +-- read a .hi file that wants to load something already loaded, we can +-- safely ignore that request. We're in the IO monad anyway, so we can +-- add some extra state of our own. +-- +-- The state is a FiniteMap String Bool (a hash of package/object names +-- to whether they have been loaded or not). +-- +-- It also contains the package.conf information, so that if there is a +-- package dependency we can find it correctly, even if it has a +-- non-standard path or name, and if it isn't an official package (but +-- rather one provided via -package-conf). This is stored as a +-- FiniteMap PackageName PackageConfig. The problem then is whether a +-- user's package.conf, that uses the same package name as an existing +-- GHC package, should be allowed, or should shadow a library package? +-- I don't know, but I'm inclined to have the GHC package shadow the +-- user's package. +-- +-- This idea is based on *Hampus Ram's dynamic loader* dependency +-- tracking system. He uses state to record dependency trees to allow +-- clean unloading and other fun. This is quite cool. We're just using +-- state to make sure we don't load the same package twice. Implementing +-- the full dependency tree idea would be nice, though not fully +-- necessary as we have the dependency information store in .hi files, +-- unlike in hram's loader. +-- + +type ModEnv = FiniteMap String Bool + +-- represents a package.conf file +type PkgEnv = FiniteMap PackageName PackageConfig + +-- record dependencies between (src,stub) -> merged modid +type MergeEnv = FiniteMap (FilePath,FilePath) FilePath + +-- multiple package.conf's kept in separate namespaces +type PkgEnvs = [PkgEnv] + +type Env = (MVar (), + IORef ModEnv, + IORef PkgEnvs, + IORef MergeEnv) + +-- +-- our environment, contains a set of loaded objects, and a map of known +-- packages and their informations. Initially all we know is the default +-- package.conf information. +-- +env = unsafePerformIO $ do + mvar <- newMVar () + ref1 <- newIORef emptyFM -- loaded objects + p <- grabDefaultPkgConf + ref2 <- newIORef p -- package.conf info + ref3 <- newIORef emptyFM -- merged files + return (mvar, ref1, ref2, ref3) +{-# NOINLINE env #-} + +-- ----------------------------------------------------------- +-- +-- apply 'f' to the loaded objects Env +-- apply 'f' to the package.conf FM +-- *locks up the MVar* so you can't recursively call a function inside a +-- with*Env function. Nice and threadsafe +-- +withModEnv :: Env -> (ModEnv -> IO a) -> IO a +withPkgEnvs :: Env -> (PkgEnvs -> IO a) -> IO a +withMerged :: Env -> (MergeEnv -> IO a) -> IO a + +withModEnv (mvar,ref,_,_) f = withMVar mvar (\_ -> readIORef ref >>= f) +withPkgEnvs (mvar,_,ref,_) f = withMVar mvar (\_ -> readIORef ref >>= f) +withMerged (mvar,_,_,ref) f = withMVar mvar (\_ -> readIORef ref >>= f) + +-- ----------------------------------------------------------- +-- +-- write an object name +-- write a new PackageConfig +-- +modifyModEnv :: Env -> (ModEnv -> IO ModEnv) -> IO () +modifyPkgEnv :: Env -> (PkgEnvs -> IO PkgEnvs) -> IO () +modifyMerged :: Env -> (MergeEnv -> IO MergeEnv)-> IO () + +modifyModEnv (mvar,ref,_,_) f = lockAndWrite mvar ref f +modifyPkgEnv (mvar,_,ref,_) f = lockAndWrite mvar ref f +modifyMerged (mvar,_,_,ref) f = lockAndWrite mvar ref f + +-- private +lockAndWrite mvar ref f = withMVar mvar (\_->readIORef ref>>=f>>=writeIORef ref) + +-- ----------------------------------------------------------- +-- +-- insert a loaded module name into the environment +-- +addModule :: String -> IO () +addModule s = modifyModEnv env $ \fm -> return $ addToFM fm s True + +-- +-- remove a module name from the environment +-- +rmModule :: String -> IO () +rmModule s = modifyModEnv env $ \fm -> return $ delFromFM fm s + +-- +-- insert a list of module names all in one go +-- +addModules :: [String] -> IO () +addModules ns = modifyModEnv env $ \fm -> return $ unionL fm ns + where + unionL :: ModEnv -> [String] -> ModEnv + unionL fm ss = foldr (\s fm' -> addToFM fm' s True) fm ss + +-- +-- is a module/package already loaded? +-- +isLoaded :: String -> IO Bool +isLoaded s = withModEnv env $ \fm -> return $ isJust (lookupFM fm s) + +-- +-- confusing! only for filter. +-- +loaded :: String -> IO Bool +loaded m = do t <- isLoaded m ; return (not t) + +-- ----------------------------------------------------------- +-- Package management stuff +-- +-- insert a single package.conf (containing multiple configs) +-- means: create a new FM. insert packages into FM. add FM to end of +-- list of FM stored in the environment. +-- +addPkgConf :: FilePath -> IO () +addPkgConf f = do + ps <- readPackageConf f + modifyPkgEnv env $ \ls -> return $ union ls ps + +-- +-- add a new FM for the package.conf to the list of existing ones +-- +union :: PkgEnvs -> [PackageConfig] -> PkgEnvs +union ls ps' = + let fm = emptyFM -- new FM for this package.conf + in ls ++ [foldr (\p fm' -> addToFM fm' (packageName p) p) fm ps'] + +-- +-- generate a PkgEnv from the system package.conf +-- * the path to the default package.conf was determined by ./configure * +-- This imposes a constraint that you must build your plugins with the +-- same ghc you use to build hs-plugins. This is reasonable, we feel. +-- + +grabDefaultPkgConf :: IO PkgEnvs +grabDefaultPkgConf = do + pkgs <- readPackageConf $ ghcLibraryPath sysPkgConf + return $ union [] pkgs + +-- +-- parse a source file, expanding any $libdir we see. +-- +readPackageConf :: FilePath -> IO [PackageConfig] +readPackageConf f = do + s <- readFile f + let p = parsePkgConf s + return $! map expand_libdir p + + where + expand_libdir :: PackageConfig -> PackageConfig + expand_libdir pk = + let pk' = updImportDirs (\idirs -> map expand idirs) pk + pk'' = updLibraryDirs (\ldirs -> map expand ldirs) pk' + in pk'' + + expand :: FilePath -> FilePath + expand s | "$libdir" `isPrefixOf` s = ghcLibraryPath ++ drop 7 s + expand s = s + + +-- +-- Package path, given a package name, look it up in the environment and +-- return the path to all the libraries needed to load this package. +-- +-- What do we need to load? With the library_dirs as prefix paths: +-- * anything in the hs_libraries fields, $libdir expanded +-- * anything in the extra_libraries fields (i.e. cbits), expanded, +-- which includes system .so files. Ignore these for now +-- * also load any dependencies now, because of that weird mtl +-- library that lang depends upon, but which doesn't show up in the +-- interfaces for some reason. +-- +-- ToDo At present this does not handle extra_libraries correctly. It +-- only find those extra libraries that live in the directory specfied +-- by the library_dirs field of the package.conf entry. But +-- extra_libraries can contain any libraries supported by the system's +-- linker. For this library they must be, of course, be dynamic. The +-- extensions for such libraries are different on various platforms. +-- This would need to be checked for by configure.ac. (Scary - dons) +-- +-- We return all the package paths that possibly exist, and the leave it +-- up to loadObject not to load the same ones twice... +-- +lookupPkg :: PackageName -> IO [FilePath] +lookupPkg p = do + t <- lookupPkg' p + case t of ([],f) -> return f + (ps,f) -> do gss <- mapM lookupPkg ps + return $ nub $ (concat gss) ++ f + +-- +-- return any stuff to load for this package, plus the list of packages +-- this package depends on. which includes stuff we have to then load +-- too. +-- +lookupPkg' :: PackageName -> IO ([PackageName],[FilePath]) +lookupPkg' p = withPkgEnvs env $ \fms -> go fms p + where + go [] _ = return ([],[]) + go (fm:fms) q = case lookupFM fm q of + Nothing -> go fms q -- look in other pkgs + + Just package -> do + let libdirs = libraryDirs package + hslibs = hsLibraries package + extras = extraLibraries package + deppkgs = packageDeps package + libs <- mapM (findHSlib libdirs) (hslibs ++ extras) + + -- don't care if there are 'Nothings', that usually + -- means that they refer to system libraries. Can't do + -- anything about that. + return (deppkgs, filterJust libs ) + + -- a list elimination form for the Maybe type + filterJust :: [Maybe a] -> [a] + filterJust [] = [] + filterJust (Just x:xs) = x:filterJust xs + filterJust (Nothing:xs) = filterJust xs + + -- + -- Check that a path to a library actually reaches a library + -- Problem: sysPkgSuffix is ".o", but extra libraries could be + -- ".so" -- what to do? + -- + findHSlib :: [FilePath] -> String -> IO (Maybe FilePath) + findHSlib [] _ = return Nothing + findHSlib (dir:dirs) lib = do + let l = dir lib ++ sysPkgSuffix + b <- doesFileExist l + if b then return $ Just l -- found it! + else findHSlib dirs lib + +------------------------------------------------------------------------ +-- do we have a Module name for this merge? +-- +isMerged :: FilePath -> FilePath -> IO Bool +isMerged a b = withMerged env $ \fm -> return $ isJust (lookupFM fm (a,b)) + +lookupMerged :: FilePath -> FilePath -> IO (Maybe FilePath) +lookupMerged a b = withMerged env $ \fm -> return $ lookupFM fm (a,b) + +-- +-- insert a new merge pair into env +-- +addMerge :: FilePath -> FilePath -> FilePath -> IO () +addMerge a b z = modifyMerged env $ \fm -> return $ addToFM fm (a,b) z + +------------------------------------------------------------------------ +-- break a module cycle +-- private: +-- +() :: FilePath -> FilePath -> FilePath +[] b = b +a b = a ++ "/" ++ b diff --git a/src/plugins/Plugins/Load.hs b/src/plugins/Plugins/Load.hs new file mode 100644 index 0000000..03ffcde --- /dev/null +++ b/src/plugins/Plugins/Load.hs @@ -0,0 +1,632 @@ +{-# OPTIONS -#include "Linker.h" #-} +{-# OPTIONS -fglasgow-exts -cpp #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +module Plugins.Load ( + +-- high level interface + load , load_ + , dynload + , pdynload , pdynload_ + , unload + , reload + , Module(..) + + , LoadStatus(..) + +-- low level interface + , initLinker -- start it up + , loadModule -- load a vanilla .o + , loadFunction -- retrieve a function from an object + , loadPackage -- load a ghc library and its cbits + , unloadPackage -- unload a ghc library and its cbits + , loadPackageWith -- load a pkg using the package.conf provided + , loadShared -- load a .so object file + , resolveObjs -- and resolve symbols + + , loadRawObject -- load a bare .o. no dep chasing, no .hi file reading + + , Symbol + + ) where + +import Plugins.Make ( build ) +import Plugins.Env +import Plugins.Utils +import Plugins.Consts ( sysPkgSuffix, hiSuf, prefixUnderscore ) + +import Hi.Parser + +import AltData.Dynamic ( fromDyn, Dynamic ) +import AltData.Typeable ( Typeable ) + +import Data.List ( isSuffixOf, nub, nubBy ) +import Control.Monad ( when, filterM, liftM ) +import System.Directory ( doesFileExist, removeFile ) +import Foreign.C.String ( CString, withCString, peekCString ) + +import GHC.Ptr ( Ptr(..), nullPtr ) +import GHC.Exts ( addrToHValue# ) +import GHC.Prim ( unsafeCoerce# ) + +#if DEBUG +import System.IO ( hFlush, stdout ) +#endif + +-- TODO need a loadPackage p package.conf :: IO () primitive + +-- --------------------------------------------------------------------- + +type Symbol = String +type Type = String +type Errors = [String] +type PackageConf = FilePath + +data Module = Module { path :: !FilePath + , mname :: !String + , kind :: !ObjType + , iface :: Iface -- cache the iface + , key :: Key + } + +data ObjType = Vanilla | Shared deriving Eq + +-- --------------------------------------------------------------------- +-- return status of all *load functions: +-- +data LoadStatus a + = LoadSuccess Module a + | LoadFailure Errors + +-- --------------------------------------------------------------------- +-- | load an object file into the address space, returning the closure +-- associated with the symbol requested, after removing its dynamism. +-- +-- Recursively loads the specified modules, and all the modules they +-- depend on. +-- +load :: FilePath -- ^ object file + -> [FilePath] -- ^ any include paths + -> [PackageConf] -- ^ list of package.conf paths + -> Symbol -- ^ symbol to find + -> IO (LoadStatus a) + +load obj incpaths pkgconfs sym = do + initLinker + + -- load extra package information + mapM_ addPkgConf pkgconfs + hif <- loadDepends obj incpaths + + -- why is this the package name? +#if DEBUG + putStr (' ':(decode $ mi_module hif)) >> hFlush stdout +#endif + + m' <- loadObject obj (Object (mi_module hif)) + let m = m' { iface = hif } + resolveObjs + +#if DEBUG + putStrLn " ... done" >> hFlush stdout +#endif + + v <- loadFunction m sym + return $ case v of + Nothing -> LoadFailure ["load: couldn't find symbol <<"++sym++">>"] + Just a -> LoadSuccess m a + +-- +-- | Like load, but doesn't want a package.conf arg (they are rarely used) +-- +load_ :: FilePath -> [FilePath] -> Symbol -> IO (LoadStatus a) +load_ o i s = load o i [] s + +-- +-- A work-around for Dynamics. The keys used to compare two TypeReps are +-- somehow not equal for the same type in hs-plugin's loaded objects. +-- Solution: implement our own dynamics... +-- +-- The problem with dynload is that it requires the plugin to export +-- a value that is a Dynamic (in our case a (TypeRep,a) pair). If this +-- is not the case, we core dump. Use pdynload if you don't trust the +-- user to supply you with a Dynamic +-- +dynload :: Typeable a + => FilePath + -> [FilePath] + -> [PackageConf] + -> Symbol + -> IO (LoadStatus a) + +dynload obj incpaths pkgconfs sym = do + s <- load obj incpaths pkgconfs sym + case s of e@(LoadFailure _) -> return e + LoadSuccess m dyn_v -> return $ + case fromDyn (unsafeCoerce# dyn_v :: Dynamic) of + Just v' -> LoadSuccess m v' + Nothing -> LoadFailure ["Mismatched types in interface"] + +------------------------------------------------------------------------ +-- +-- The super-replacement for dynload +-- +-- Use GHC at runtime so we get staged type inference, providing full +-- power dynamics, *on module interfaces only*. This is quite suitable +-- for plugins, of coures :) +-- +-- TODO where does the .hc file go in the call to build() ? +-- + +pdynload :: FilePath -- ^ object to load + -> [FilePath] -- ^ include paths + -> [PackageConf] -- ^ package confs + -> Type -- ^ API type + -> Symbol -- ^ symbol + -> IO (LoadStatus a) + +pdynload object incpaths pkgconfs ty sym = do +#if DEBUG + putStr "Checking types ... " >> hFlush stdout +#endif + errors <- unify object incpaths [] ty sym +#if DEBUG + putStrLn "done" +#endif + if null errors + then load object incpaths pkgconfs sym + else return $ LoadFailure errors + +-- +-- | Like pdynload, but you can specify extra arguments to the +-- typechecker. +-- +pdynload_ :: FilePath -- ^ object to load + -> [FilePath] -- ^ include paths for loading + -> [PackageConf] -- ^ any extra package.conf files + -> [Arg] -- ^ extra arguments to ghc, when typechecking + -> Type -- ^ expected type + -> Symbol -- ^ symbol to load + -> IO (LoadStatus a) + +pdynload_ object incpaths pkgconfs args ty sym = do +#if DEBUG + putStr "Checking types ... " >> hFlush stdout +#endif + errors <- unify object incpaths args ty sym +#if DEBUG + putStrLn "done" +#endif + if null errors + then load object incpaths pkgconfs sym + else return $ LoadFailure errors + +------------------------------------------------------------------------ +-- run the typechecker over the constraint file +-- +-- .hc into /dev/null, .hi into /dev/null +-- +-- NON_PORTABLE == /dev/null +-- +-- Problem: if the user depends on a non-auto package to build the +-- module, then that package will not be in scope when we try to build +-- the module, when performing `unify'. Normally make() will handle this +-- (as it takes extra ghc args). pdynload ignores these, atm -- but it +-- shouldn't. Consider a pdynload() that accepts extra -package flags? +-- +-- Also, pdynload() should accept extra in-scope modules. +-- Maybe other stuff we want to hack in here. +-- +unify obj incs args ty sym = do + (tmpf,hdl) <- mkTemp + + let nm = mkModid (basename tmpf) + src = mkTest nm (mkModid obj) (fst $ break (=='.') ty) ty sym + is = map (\s -> "-i"++s) incs -- api + i = "-i" ++ dirname obj -- plugin + + hWrite hdl src + e <- build tmpf "/dev/null" (i:is++args++["-fno-code","-ohi/dev/null"]) + removeFile tmpf + return e + +mkTest modnm plugin api ty sym = + "module "++ modnm ++" where" ++ + "\nimport qualified " ++ plugin ++ + "\nimport qualified " ++ api ++ + "{-# LINE 1 \"\" #-}" ++ + "\n_ = "++ plugin ++"."++ sym ++" :: "++ty + +------------------------------------------------------------------------ +{- +-- +-- old version that tried to rip stuff from .hi files +-- +pdynload obj incpaths pkgconfs sym ty = do + (m, v) <- load obj incpaths pkgconfs sym + ty' <- mungeIface sym obj + if ty == ty' + then return $ Just (m, v) + else return Nothing -- mismatched types + + where + -- grab the iface output from GHC. find the line relevant to our + -- symbol. grab the string rep of the type. + mungeIface sym o = do + let hi = replaceSuffix o hiSuf + (out,_) <- exec ghc ["--show-iface", hi] + case find (\s -> (sym ++ " :: ") `isPrefixOf` s) out of + Nothing -> return undefined + Just v -> do let v' = drop 3 $ dropWhile (/= ':') v + return v' + +-} + +{- +-- +-- a version of load the also unwraps and types a Dynamic object +-- +dynload2 :: Typeable a => + FilePath -> + FilePath -> + Maybe [PackageConf] -> + Symbol -> + IO (Module, a) + +dynload2 obj incpath pkgconfs sym = do + (m, v) <- load obj incpath pkgconfs sym + case fromDynamic v of + Nothing -> panic $ "load: couldn't type "++(show v) + Just a -> return (m,a) +-} + +------------------------------------------------------------------------ +-- +-- | unload a module (not it's dependencies) +-- we have the dependencies, so cascaded unloading is possible +-- +-- once you unload it, you can't 'load' it again, you have to 'reload' +-- it. Cause we don't unload all the dependencies +-- +unload :: Module -> IO () +unload = unloadObj + +-- +-- | this will be nice for panTHeon, needs thinking about the interface +-- reload a single object file. don't care about depends, assume they +-- are loaded. (should use state to store all this) +-- +-- assumes you've already done a 'load' +-- +-- should factor the code +-- +reload :: Module -> Symbol -> IO (LoadStatus a) +reload m@(Module{path = p, iface = hi}) sym = do + unloadObj m -- unload module (and delete) +#if DEBUG + putStr ("Reloading "++(mname m)++" ... ") >> hFlush stdout +#endif + m_ <- loadObject p (Object $ mi_module hi) -- load object at path p + let m' = m_ { iface = hi } + + resolveObjs +#if DEBUG + putStrLn "done" >> hFlush stdout +#endif + v <- loadFunction m' sym + return $ case v of + Nothing -> LoadFailure ["load: couldn't find symbol <<"++sym++">>"] + Just a -> LoadSuccess m' a + +-- --------------------------------------------------------------------- +-- This is a stripped-down version of André Pang's runtime_loader, +-- which in turn is based on GHC's ghci/ObjLinker.lhs binding +-- +-- Load and unload\/Haskell modules at runtime. This is not really +-- \'dynamic loading\', as such -- that implies that you\'re working +-- with proper shared libraries, whereas this is far more simple and +-- only loads object files. But it achieves the same goal: you can +-- load a Haskell module at runtime, load a function from it, and run +-- the function. I have no idea if this works for types, but that +-- doesn\'t mean that you can\'t try it :). +-- +-- read $fptools/ghc/compiler/ghci/ObjLinker.lhs for how to use this stuff +-- +------------------------------------------------------------------------ + +-- | Call the initLinker function first, before calling any of the other +-- functions in this module - otherwise you\'ll get unresolved symbols. + +-- initLinker :: IO () +-- our initLinker transparently calls the one in GHC + +-- +-- | Load a function from a module (which must be loaded and resolved first). +-- +loadFunction :: Module -- ^ The module the value is in + -> String -- ^ Symbol name of value + -> IO (Maybe a) -- ^ The value you want + +loadFunction (Module { iface = i }) valsym + = do let m = mi_module i + symbol = symbolise m +#if DEBUG + putStrLn $ "Looking for <<"++symbol++">>" +#endif + ptr@(~(Ptr addr)) <- withCString symbol c_lookupSymbol + if (ptr == nullPtr) + then return Nothing + else case addrToHValue# addr of + (# hval #) -> return ( Just hval ) + where + symbolise m = prefixUnderscore++m++"_"++(encode valsym)++"_closure" + + + +-- +-- | Load a GHC-compiled Haskell vanilla object file. +-- The first arg is the path to the object file +-- +-- We make it idempotent to stop the nasty problem of loading the same +-- .o twice. Also the rts is a very special package that is already +-- loaded, even if we ask it to be loaded. N.B. we should insert it in +-- the list of known packages. +-- +-- NB the environment stores the *full path* to an object. So if you +-- want to know if a module is already loaded, you need to supply the +-- *path* to that object, not the name. +-- +-- NB -- let's try just the module name. +-- +-- loadObject loads normal .o objs, and packages too. .o objs come with +-- a nice canonical Z-encoded modid. packages just have a simple name. +-- Do we want to ensure they won't clash? Probably. +-- + +-- +-- the second argument to loadObject is a string to use as the unique +-- identifier for this object. For normal .o objects, it should be the +-- Z-encoded modid from the .hi file. For archives/packages, we can +-- probably get away with the package name +-- +data Key = Object String | Package String + +loadObject :: FilePath -> Key -> IO Module +loadObject p ky@(Object k) = loadObject' p ky k +loadObject p ky@(Package k) = loadObject' p ky k + +loadObject' :: FilePath -> Key -> String -> IO Module +loadObject' p ky k + | ("HSrts"++sysPkgSuffix) `isSuffixOf` p = return (emptyMod p) + + | otherwise + = do alreadyLoaded <- isLoaded k + when (not alreadyLoaded) $ do + r <- withCString p c_loadObj + when (not r) (panic $ "Could not load module `"++p++"'") + addModule k -- needs to Z-encode module name + return (emptyMod p) + + where emptyMod q = Module q (mkModid q) Vanilla emptyIface ky + +-- +-- load a single object. no dependencies. You should know what you're +-- doing. +-- +loadModule :: FilePath -> IO Module +loadModule obj = do + let hifile = replaceSuffix obj hiSuf + exists <- doesFileExist hifile + if (not exists) + then error $ "No .hi file found for "++show obj + else do hiface <- readIface hifile + loadObject obj (Object (mi_module hiface)) + +-- +-- | Load a generic .o file, good for loading C objects. +-- You should know what you're doing.. +-- Returns a fairly meaningless iface value. +-- +loadRawObject :: FilePath -> IO Module +loadRawObject obj = loadObject obj (Object k) + where + k = encode (mkModid obj) -- Z-encoded module name + +-- +-- | Resolve (link) the modules loaded by the 'loadObject' function. +-- +resolveObjs :: IO () +resolveObjs = do + r <- c_resolveObjs + when (not r) $ + panic $ "resolveObjs failed with <<" ++ show r ++ ">>" + + +-- | Unload a module +unloadObj :: Module -> IO () +unloadObj (Module { path = p, kind = k, key = ky }) = case k of + Vanilla -> withCString p $ \c_p -> do + r <- c_unloadObj c_p + when (not r) (panic "unloadObj: failed") + rmModule $ case ky of Object s -> s ; Package pk -> pk + + Shared -> return () -- can't unload .so? + +-- +-- | from ghci/ObjLinker.c +-- +-- Load a .so type object file. +-- +loadShared :: FilePath -> IO Module +loadShared str = do + maybe_errmsg <- withCString str $ \dll -> c_addDLL dll + if maybe_errmsg == nullPtr + then return (Module str (mkModid str) Shared emptyIface (Package (mkModid str))) + else do e <- peekCString maybe_errmsg + panic $ "loadShared: couldn't load `"++str++"\' because "++e + +-- +-- Load a -package that we might need, implicitly loading the cbits too +-- The argument is the name of package (e.g. \"concurrent\") +-- +-- How to find a package is determined by the package.conf info we store +-- in the environment. It is just a matter of looking it up. +-- +-- Not printing names of dependent pkgs +-- +loadPackage :: String -> IO () +loadPackage p = do +#if DEBUG + putStr (' ':p) >> hFlush stdout +#endif + libs <- lookupPkg p + mapM_ (\l -> loadObject l (Package (mkModid l))) libs + +-- +-- Unload a -package, that has already been loaded. Unload the cbits +-- too. The argument is the name of the package. +-- +-- May need to check if it exists. +-- +-- Note that we currently need to unload everything. grumble grumble. +-- +-- We need to add the version number to the package name with 6.4 and +-- over. "yi-0.1" for example. This is a bug really. +-- +unloadPackage :: String -> IO () +unloadPackage pkg = do + let pkg' = takeWhile (/= '-') pkg -- in case of *-0.1 + libs <- liftM (filter (isSublistOf pkg')) (lookupPkg pkg) + flip mapM_ libs $ \p -> withCString p $ \c_p -> do + r <- c_unloadObj c_p + when (not r) (panic "unloadObj: failed") + rmModule (mkModid p) -- unrecord this module + +-- +-- load a package using the given package.conf to help +-- TODO should report if it doesn't actually load the package, instead +-- of mapM_ doing nothing like above. +-- +loadPackageWith :: String -> [PackageConf] -> IO () +loadPackageWith p pkgconfs = do +#if DEBUG + putStr "Loading package" >> hFlush stdout +#endif + mapM_ addPkgConf pkgconfs + loadPackage p +#if DEBUG + putStrLn " done" +#endif + + +-- --------------------------------------------------------------------- +-- module dependency loading +-- +-- given an Foo.o vanilla object file, supposed to be a plugin compiled +-- by our library, find the associated .hi file. If this is found, load +-- the dependencies, packages first, then the modules. If it doesn't +-- exist, assume the user knows what they are doing and continue. The +-- linker will crash on them anyway. Second argument is any include +-- paths to search in +-- +-- ToDo problem with absolute and relative paths, and different forms of +-- relative paths. A user may cause a dependency to be loaded, which +-- will search the incpaths, and perhaps find "./Foo.o". The user may +-- then explicitly load "Foo.o". These are the same, and the loader +-- should ignore the second load request. However, isLoaded will say +-- that "Foo.o" is not loaded, as the full string is used as a key to +-- the modenv fm. We need a canonical form for the keys -- is basename +-- good enough? +-- +loadDepends :: FilePath -> [FilePath] -> IO Iface +loadDepends obj incpaths = do + let hifile = replaceSuffix obj hiSuf + exists <- doesFileExist hifile + if (not exists) + then do +#if DEBUG + putStrLn "No .hi file found." >> hFlush stdout +#endif + return emptyIface -- could be considered fatal + + else do hiface <- readIface hifile + let ds = mi_deps hiface + + -- remove ones that we've already loaded + ds' <- filterM loaded (dep_mods ds) + + -- now, try to generate a path to the actual .o file + -- fix up hierachical names + let mods_ = map (\s -> (s, map (\c -> + if c == '.' then '/' else c) $ decode s)) ds' + + -- construct a list of possible dependent modules to load + let mods = concatMap (\p -> + map (\(hi,m) -> (hi,p m++".o")) mods_) incpaths + + -- remove modules that don't exist + mods' <- filterM (\(_,y) -> doesFileExist y) $ + nubBy (\v u -> snd v == snd u) mods + + -- now remove duplicate valid paths to the same object + let mods'' = nubBy (\v u -> fst v == fst u) mods' + + -- and find some packages to load, as well. + let ps = dep_pkgs ds + ps' <- filterM loaded (nub ps) + +#if DEBUG + when (not (null ps')) $ + putStr "Loading package" >> hFlush stdout +#endif + mapM_ loadPackage ps' +#if DEBUG + when (not (null ps')) $ + putStr " ... linking ... " >> hFlush stdout +#endif + resolveObjs +#if DEBUG + when (not (null ps')) $ putStrLn "done" + putStr "Loading object" + mapM_ (\(m,_) -> putStr (" "++(decode m)) >> hFlush stdout) mods'' +#endif + mapM_ (\(hi,m) -> loadObject m (Object hi)) mods'' + return hiface + +-- --------------------------------------------------------------------- +-- C interface +-- +foreign import ccall unsafe "lookupSymbol" + c_lookupSymbol :: CString -> IO (Ptr a) + +foreign import ccall unsafe "loadObj" + c_loadObj :: CString -> IO Bool + +foreign import ccall unsafe "unloadObj" + c_unloadObj :: CString -> IO Bool + +foreign import ccall unsafe "resolveObjs" + c_resolveObjs :: IO Bool + +foreign import ccall unsafe "addDLL" + c_addDLL :: CString -> IO CString + +foreign import ccall unsafe "initLinker" + initLinker :: IO () diff --git a/src/plugins/Plugins/Make.hs b/src/plugins/Plugins/Make.hs new file mode 100644 index 0000000..981e8d5 --- /dev/null +++ b/src/plugins/Plugins/Make.hs @@ -0,0 +1,297 @@ +{-# OPTIONS -cpp #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +module Plugins.Make ( + + make, + makeAll, + makeWith, + MakeStatus(..), + MakeCode(..), + + merge, + mergeTo, + mergeToDir, + MergeStatus(..), + MergeCode, + + makeClean, + makeCleaner, + + build, {- internal -} + + ) where + +import Plugins.Utils +import Plugins.Parser +import Plugins.Consts ( ghc, hiSuf, objSuf, hsSuf ) +import Plugins.Env ( lookupMerged, addMerge ) + +import System.IO +import System.Directory ( doesFileExist, removeFile ) + +import Control.Exception ( handleJust ) +import GHC.IOBase ( Exception(IOException) ) + +#if __GLASGOW_HASKELL__ >= 604 +import System.IO.Error ( isDoesNotExistError ) +#endif + +------------------------------------------------------------------------ +-- +-- A better compiler status. +-- +data MakeStatus + = MakeSuccess MakeCode FilePath + | MakeFailure Errors + deriving (Eq,Show) + +data MakeCode = ReComp | NotReq + deriving (Eq,Show) + +------------------------------------------------------------------------ +-- +-- An equivalent status for the preprocessor (merge) +-- +data MergeStatus + = MergeSuccess MergeCode Args FilePath + | MergeFailure Errors + deriving (Eq,Show) + +type MergeCode = MakeCode + +type Args = [Arg] +type Errors = [String] + +-- --------------------------------------------------------------------- +-- | Standard make. Compile a single module, unconditionally. +-- Behaves like ghc -c +-- +make :: FilePath -> [Arg] -> IO MakeStatus +make src args = rawMake src ("-c":args) True + +-- | Recursive make. Compile a module, and its dependencies if we can +-- find them. Takes the top-level file as the first argument. +-- Behaves like ghc --make +-- +makeAll :: FilePath -> [Arg] -> IO MakeStatus +makeAll src args = + rawMake src ( "--make":"-no-hs-main":"-no-link":"-v0":args ) False + +-- | merge two files; then make them. will leave a .o and .hi file in tmpDir. +-- +makeWith :: FilePath -- ^ a src file + -> FilePath -- ^ a syntax stub file + -> [Arg] -- ^ any required args + -> IO MakeStatus -- ^ path to an object file + +makeWith src stub args = do + status <- merge src stub + case status of + MergeFailure errs -> return $ MakeFailure ("merge failed:\n":errs) + MergeSuccess _ args' tmpf -> do + status' <- rawMake tmpf ("-c": args' ++ args) True + return status' + +-- --------------------------------------------------------------------- +-- rawMake : really do the compilation +-- Conditional on file modification times, compile a .hs file +-- When using 'make', the name of the src file must be the name of the +-- .o file you are expecting back +-- +-- Problem: we use GHC producing stdout to indicate compilation failure. +-- We should instead check the error conditions. I.e. --make will +-- produce output, but of course compiles correctly. TODO +-- So, e.g. --make requires -v0 to stop spurious output confusing +-- rawMake +-- +-- Problem :: makeAll incorrectly refuses to recompile if the top level +-- src isn't new. +-- + +rawMake :: FilePath -- ^ src + -> [Arg] -- ^ any compiler args + -> Bool -- ^ do our own recompilation checking + -> IO MakeStatus + +rawMake src args docheck = do + src_exists <- doesFileExist src + if not src_exists + then return $ MakeFailure ["Source file does not exist: "++src] + else do { + ; let (obj,_) = outFilePath src args + ; src_changed <- if docheck then src `newer` obj else return True + ; if not src_changed + then return $ MakeSuccess NotReq obj + else do +#if DEBUG + putStr "Compiling object ... " >> hFlush stdout +#endif + err <- build src obj args +#if DEBUG + putStrLn "done" +#endif + return $ if null err + then MakeSuccess ReComp obj + else MakeFailure err + } + +-- +-- compile a .hs file to a .o file +-- +-- If the plugin needs to import an api (which should be almost +-- everyone) then the ghc flags to find the api need to be provided as +-- arguments +-- +build :: FilePath -- path to .hs source + -> FilePath -- path to object file + -> [String] -- any extra cmd line flags + -> IO [String] + +build src obj extra_opts = do + + let odir = dirname obj -- *always* put the .hi file next to the .o file + + let ghc_opts = [ "-Onot" ] + output = [ "-o", obj, "-odir", odir, + "-hidir", odir, "-i" ++ odir ] + + let flags = ghc_opts ++ output ++ extra_opts ++ [src] + +#if DEBUG + -- env. + putStr $ show $ ghc : flags +#endif + (_,err) <- exec ghc flags -- this is a fork() + + obj_exists <- doesFileExist obj -- sanity + return $ if not obj_exists && null err -- no errors, but no object? + then ["Compiled, but didn't create object file `"++obj++"'!"] + else err + +-- --------------------------------------------------------------------- +-- | Merge to source files into a temporary file. If we've tried to +-- merge these two stub files before, then reuse the module name (helps +-- recompilation checking) +-- +merge :: FilePath -> FilePath -> IO MergeStatus +merge src stb = do + m_mod <- lookupMerged src stb + (out,domerge) <- case m_mod of + Nothing -> do out <- mkUnique + addMerge src stb (dropSuffix out) + return (out, True) -- definitely out of date + Just nm -> return $ (nm <> hsSuf, False) + rawMerge src stb out domerge + +-- | Merge to source files and store them in the specified output file, +-- instead of a temp file as merge does. +-- +mergeTo :: FilePath -> FilePath -> FilePath -> IO MergeStatus +mergeTo src stb out = rawMerge src stb out False + +mergeToDir :: FilePath -> FilePath -> FilePath -> IO MergeStatus +mergeToDir src stb dir = do + out <- mkUniqueIn dir + rawMerge src stb out True + +-- --------------------------------------------------------------------- +-- Conditional on file modification times, merge a src file with a +-- syntax stub file into a result file. +-- +-- Merge should only occur if the srcs has changed since last time. +-- Parser errors result in MergeFailure, and are reported to the client +-- +-- Also returns a list of cmdline flags found in pragmas in the src of +-- the files. This last feature exists as OPTION pragmas aren't handled +-- (for obvious reasons, relating to the implementation of OPTIONS +-- parsing in GHC) by the library parser, and, also, we want a way for +-- the user to introduce *dynamic* cmd line flags in the .conf file. +-- This is achieved via the GLOBALOPTIONS pragma : an extension to ghc +-- pragma syntax +-- +rawMerge :: FilePath -> FilePath -> FilePath -> Bool -> IO MergeStatus +rawMerge src stb out always_merge = do + src_exists <- doesFileExist src + stb_exists <- doesFileExist stb + case () of {_ + | not src_exists -> return $ + MergeFailure ["Source file does not exist : "++src] + | not stb_exists -> return $ + MergeFailure ["Source file does not exist : "++stb] + | otherwise -> do { + + ;do_merge <- do src_changed <- src `newer` out + stb_changed <- stb `newer` out + return $ src_changed || stb_changed + + ;if not do_merge && not always_merge + then return $ MergeSuccess NotReq [] out + else do + src_str <- readFile src + stb_str <- readFile stb + + let (a,a') = parsePragmas src_str + (b,b') = parsePragmas stb_str + opts = a ++ a' ++ b ++ b' + + let e_src_syn = parse src src_str + e_stb_syn = parse stb stb_str + + -- check if there were parser errors + case (e_src_syn,e_stb_syn) of + (Left e, _) -> return $ MergeFailure [e] + (_ , Left e) -> return $ MergeFailure [e] + (Right src_syn, Right stb_syn) -> do { + + ;let mrg_syn = mergeModules src_syn stb_syn + mrg_syn'= replaceModName mrg_syn (mkModid $ basename out) + mrg_str = pretty mrg_syn' + + ;hdl <- openFile out WriteMode -- overwrite! + ;hPutStr hdl mrg_str ; hClose hdl + ;return $ MergeSuccess ReComp opts out -- must have recreated file + }}} + +-- --------------------------------------------------------------------- +-- | makeClean : assuming we some element of [f.hs,f.hi,f.o], remove the +-- .hi and .o components. Silently ignore any missing components. *Does +-- not remove .hs files*. To do that use makeCleaner. This would be +-- useful for merged files, for example. +-- +makeClean :: FilePath -> IO () +makeClean f = let f_hi = dropSuffix f <> hiSuf + f_o = dropSuffix f <> objSuf + in mapM_ rm_f [f_hi, f_o] + +makeCleaner :: FilePath -> IO () +makeCleaner f = makeClean f >> rm_f (dropSuffix f <> hsSuf) + +-- internal: +-- try to remove a file, ignoring if it didn't exist in the first place +-- Doesn't seem to be able to remove all files in all circumstances, why? +-- +rm_f f = handleJust doesntExist (\_->return ()) (removeFile f) + where + doesntExist (IOException ioe) + | isDoesNotExistError ioe = Just () + | otherwise = Nothing + doesntExist _ = Nothing + diff --git a/src/plugins/Plugins/MkTemp.hs b/src/plugins/Plugins/MkTemp.hs new file mode 100644 index 0000000..a994774 --- /dev/null +++ b/src/plugins/Plugins/MkTemp.hs @@ -0,0 +1,281 @@ +{-# OPTIONS -cpp -fffi -fglasgow-exts #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +-- +-- A Haskell reimplementation of the C mktemp/mkstemp/mkstemps library +-- based on the algorithms in: +-- "$ OpenBSD: mktemp.c,v 1.17 2003/06/02 20:18:37 millert Exp $" +-- which are available under the BSD license. +-- + +module Plugins.MkTemp ( + + mktemp, -- :: FilePath -> FilePath + mkstemp, -- :: FilePath -> (FilePath, Handle) + mkstemps, -- :: FilePath -> Int -> (FilePath,Handle) + mkdtemp, -- :: FilePath -> FilePath + + ) where + +import Data.List +import Data.Char + +import Control.Monad ( liftM ) +import Control.Exception ( handleJust ) + +#if __GLASGOW_HASKELL__ < 604 +import System.IO ( isAlreadyExistsError, Handle ) +#else +import System.IO ( Handle ) +import System.IO.Error ( isAlreadyExistsError ) +#endif + +import System.Directory ( doesDirectoryExist, doesFileExist ) + +import GHC.IOBase ( Exception(IOException) ) + +-- Fix this. +#ifndef __MINGW32__ +import System.Posix.IO +import System.Posix.Files +import qualified System.Posix.Directory ( createDirectory ) +import qualified System.Posix.Internals ( c_getpid ) +#endif + +#ifndef HAVE_ARC4RANDOM +import System.Random ( getStdRandom, Random(randomR) ) +#else +import GHC.Base +import GHC.Int +#endif + +-- --------------------------------------------------------------------- + +mkstemps :: FilePath -> Int -> IO (Maybe (FilePath,Handle)) +mkstemp :: FilePath -> IO (Maybe (FilePath,Handle)) +mktemp :: FilePath -> IO (Maybe FilePath) +mkdtemp :: FilePath -> IO (Maybe FilePath) + +mkstemps path slen = gettemp path True False slen + +mkstemp path = gettemp path True False 0 + +mktemp path = do v <- gettemp path False False 0 + return $ case v of Just (path',_) -> Just path'; _ -> Nothing + +mkdtemp path = do v <- gettemp path False True 0 + return $ case v of Just (path',_) -> Just path'; _ -> Nothing + +-- --------------------------------------------------------------------- + +gettemp :: FilePath -> Bool -> Bool -> Int -> IO (Maybe (FilePath, Handle)) + +gettemp [] _ _ _ = return Nothing +gettemp _ True True _ = return Nothing + +gettemp path doopen domkdir slen = do + -- + -- firstly, break up the path and extract the template + -- + let (pref,tmpl,suff) = let (r,s) = splitAt (length path - slen) path + (p,t) = break (== 'X') r + in (p,t,s) + -- + -- an error if there is only a suffix, it seems + -- + if null pref && null tmpl then return Nothing else do { + -- + -- replace end of template with process id, and rest with randomness + -- + ;pid <- liftM show $ getProcessID + ;let (rest, xs) = merge tmpl pid + ;as <- randomise rest + ;let tmpl' = as ++ xs + path' = pref ++ tmpl' ++ suff + -- + -- just check if we can get at the directory we might need + -- + ;dir_ok <- if doopen || domkdir + then let d = reverse $ dropWhile (/= '/') $ reverse path' + in doesDirectoryExist d + else return True + + ;if not dir_ok then return Nothing else do { + -- + -- We need a function for looking for appropriate temp files + -- + ;let fn p + | doopen = handleJust isInUse (\_ -> return Nothing) $ + do h <- open0600 p ; return $ Just h + | domkdir = handleJust alreadyExists (\_ -> return Nothing) $ + do mkdir0700 p ; return $ Just undefined + | otherwise = do b <- doesFileExist p + return $ if b then Nothing else Just undefined + + -- + -- now, try to create the tmp file, permute if we can't + -- once we've tried all permutations, give up + -- + ;let tryIt p t i = + do v <- fn p + case v of Just h -> return $ Just (p,h) -- it worked + Nothing -> let (i',t') = tweak i t + in if null t' + then return Nothing -- no more + else tryIt (pref++t'++suff) t' i' + ;tryIt path' tmpl' 0 + + }} + +-- +-- Replace X's with pid digits. Complete rewrite +-- +merge :: String -> String -> (String,String) +merge t [] = (t ,[]) +merge [] _ = ([] ,[]) +merge (_:ts) (p:ps) = (ts',p:ps') + where (ts',ps') = merge ts ps + +-- +-- And replace remaining X's with random chars +-- randomR is pretty slow, oh well. +-- +randomise :: String -> IO String +randomise [] = return [] +randomise ('X':xs) = do p <- getRandom () + let c = chr $! if p < 26 + then p + (ord 'A') + else (p - 26) + (ord 'a') + xs' <- randomise xs + return (c : xs') +randomise s = return s + +-- +-- "tricky little algorithm for backward compatibility" +-- could do with a Haskellish rewrite +-- +tweak :: Int -> String -> (Int,String) +tweak i s + | i > length s - 1 = (i,[]) -- no more + | s !! i == 'Z' = if i == length s - 1 + then (i,[]) -- no more + else let s' = splice (i+1) 'a' + in tweak (i+1) s' -- loop + | otherwise = let c = s !! i in case () of {_ + | isDigit c -> (i, splice i 'a' ) + | c == 'z' -> (i, splice i 'A' ) + | otherwise -> let c' = chr $ (ord c) + 1 in (i,splice i c') + } + where + splice j c = let (a,b) = splitAt j s in a ++ [c] ++ tail b + +-- --------------------------------------------------------------------- + +alreadyExists e@(IOException ioe) + | isAlreadyExistsError ioe = Just e + | otherwise = Nothing +alreadyExists _ = Nothing + +#ifndef __MINGW32__ +isInUse (IOException ioe) + | isAlreadyExistsError ioe = Just () + | otherwise = Nothing +isInUse _ = Nothing +#else +isInUse (IOException ioe) + | isAlreadyInUseError ioe = Just () + | isPermissionError ioe = Just () + | isAlreadyExistsError ioe = Just () -- we throw this + | otherwise = Nothing +isInUse _ = Nothing +#endif + +-- --------------------------------------------------------------------- +-- Create a file mode 0600 if possible +-- +open0600 :: FilePath -> IO Handle + +#ifndef __MINGW32__ + +-- open(path, O_CREAT|O_EXCL|O_RDWR, 0600) + +open0600 f = do + openFd f ReadWrite (Just o600) excl >>= fdToHandle + where + o600 = ownerReadMode `unionFileModes` ownerWriteMode + excl = defaultFileFlags { exclusive = True } +#else + +-- N.B. race condition between testing existence and opening + +open0600 f = do + b <- doesFileExist f + if b then ioException err -- race + else openFile f ReadWriteMode + where + err = IOError Nothing AlreadyExists "open0600" "already exists" Nothing +#endif + +-- +-- create a directory mode 0700 if possible +-- +mkdir0700 :: FilePath -> IO () +mkdir0700 dir = +#ifndef __MINGW32__ + System.Posix.Directory.createDirectory dir ownerModes +#else + createDirectory dir +#endif + +-- --------------------------------------------------------------------- +-- | getProcessId, stolen from GHC + +#ifdef __MINGW32__ +foreign import ccall unsafe "_getpid" getProcessID :: IO Int +#elif __GLASGOW_HASKELL__ > 504 +getProcessID :: IO Int +getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral +#else +getProcessID :: IO Int +getProcessID = Posix.getProcessID +#endif + +-- --------------------------------------------------------------------- +-- | Use a variety of random functions, if you like. +-- +getRandom :: () -> IO Int + +#ifndef HAVE_ARC4RANDOM +getRandom _ = getStdRandom (randomR (0,51)) +#else +-- +-- +-- OpenBSD: "The arc4random() function provides a high quality 32-bit +-- pseudo-random number very quickly. arc4random() seeds itself on a +-- regular basis from the kernel strong random number subsystem +-- described in random(4)." Also, it is a bit faster than getStdRandom +-- +getRandom _ = do + (I32# i) <- c_arc4random + return (I# (word2Int# + ((int2Word# i `and#` int2Word# 0xffff#) `remWord#` int2Word# 52#))) + +foreign import ccall unsafe "arc4random" c_arc4random :: IO Int32 +#endif diff --git a/src/plugins/Plugins/Package.hs b/src/plugins/Plugins/Package.hs new file mode 100644 index 0000000..93647ac --- /dev/null +++ b/src/plugins/Plugins/Package.hs @@ -0,0 +1,67 @@ +-- +-- Copyright (C) 2004 Sean Seefried - http://www.cse.unsw.edu.au/~sseefried +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA + +-- +-- Read information from a package.conf +-- + +module Plugins.Package {-everything-} where + +type PackageName = String + +-- +-- Take directly from ghc/utils/ghc-pkg/Package.hs +-- + +data PackageConfig = Package { + name :: PackageName, + auto :: Bool, + import_dirs :: [FilePath], + source_dirs :: [FilePath], + library_dirs :: [FilePath], + hs_libraries :: [String], + extra_libraries :: [String], + include_dirs :: [FilePath], + c_includes :: [String], + package_deps :: [String], + extra_ghc_opts :: [String], + extra_cc_opts :: [String], + extra_ld_opts :: [String], + framework_dirs :: [FilePath], -- ignored everywhere but on Darwin/MacOS X + extra_frameworks:: [String] -- ignored everywhere but on Darwin/MacOS X + } deriving Show + + +defaultPackageConfig = Package { + name = error "defaultPackage", + auto = False, + import_dirs = [], + source_dirs = [], + library_dirs = [], + hs_libraries = [], + extra_libraries = [], + include_dirs = [], + c_includes = [], + package_deps = [], + extra_ghc_opts = [], + extra_cc_opts = [], + extra_ld_opts = [], + framework_dirs = [], + extra_frameworks= [] + } + diff --git a/src/plugins/Plugins/PackageAPI.hs b/src/plugins/Plugins/PackageAPI.hs new file mode 100644 index 0000000..aa821c7 --- /dev/null +++ b/src/plugins/Plugins/PackageAPI.hs @@ -0,0 +1,92 @@ +{-# OPTIONS -cpp #-} +-- +-- Copyright (C) 2005 Sean Seefried - http://www.cse.unsw.edu.au/~sseefried +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA + +-- +-- We export an abstract interface to package conf`s because we have +-- to handle either traditional or Cabal style package conf`s. +-- + +module Plugins.PackageAPI ( + PackageName + , PackageConfig + , packageName + , packageName_ + , importDirs + , hsLibraries + , libraryDirs + , extraLibraries + , packageDeps + , updImportDirs + , updLibraryDirs + ) where + +#include "../../../config.h" + +#if CABAL == 1 || __GLASGOW_HASKELL__ >= 604 +import Distribution.InstalledPackageInfo +import Distribution.Package +#else +import Plugins.Package +#endif + +packageName :: PackageConfig -> PackageName +packageDeps :: PackageConfig -> [PackageName] +updImportDirs :: ([FilePath] -> [FilePath]) -> PackageConfig -> PackageConfig +updLibraryDirs :: ([FilePath] -> [FilePath]) -> PackageConfig -> PackageConfig + +-- We use different package.conf parsers when running on 6.2.x or 6.4 +#if CABAL == 1 || __GLASGOW_HASKELL__ >= 604 + +type PackageName = String + +type PackageConfig = InstalledPackageInfo + +packageName = showPackageId . package +packageName_ = pkgName . package +packageDeps = (map showPackageId) . depends + +updImportDirs f pk@(InstalledPackageInfo { importDirs = idirs }) = + pk { importDirs = f idirs } +updLibraryDirs f pk@(InstalledPackageInfo { libraryDirs = ldirs }) = + pk { libraryDirs = f ldirs } +#else + +packageName = name +packageName_ = name +packageDeps = package_deps + +updImportDirs f pk@(Package {import_dirs = idirs}) + = pk {import_dirs = f idirs} + +updLibraryDirs f pk@(Package {library_dirs = ldirs}) + = pk {library_dirs = f ldirs} + +importDirs :: PackageConfig -> [FilePath] +importDirs = import_dirs + +hsLibraries :: PackageConfig -> [String] +hsLibraries = hs_libraries + +libraryDirs :: PackageConfig -> [FilePath] +libraryDirs = library_dirs + +extraLibraries :: PackageConfig -> [String] +extraLibraries = extra_libraries + +#endif diff --git a/src/plugins/Plugins/ParsePkgConfCabal.hs b/src/plugins/Plugins/ParsePkgConfCabal.hs new file mode 100644 index 0000000..f9a7329 --- /dev/null +++ b/src/plugins/Plugins/ParsePkgConfCabal.hs @@ -0,0 +1,776 @@ +{-# OPTIONS -fglasgow-exts -cpp -w #-} +-- parser produced by Happy Version 1.14 + + + +module Plugins.ParsePkgConfCabal ( + parsePkgConf, parseOnePkgConf + ) where + +import Distribution.InstalledPackageInfo +import Distribution.Package +import Distribution.Version + +import Char ( isSpace, isAlpha, isAlphaNum, isUpper, isDigit ) +import List ( break ) +import Array +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif + +newtype HappyAbsSyn = HappyAbsSyn (() -> ()) +happyIn5 :: ([ PackageConfig ]) -> (HappyAbsSyn ) +happyIn5 x = unsafeCoerce# x +{-# INLINE happyIn5 #-} +happyOut5 :: (HappyAbsSyn ) -> ([ PackageConfig ]) +happyOut5 x = unsafeCoerce# x +{-# INLINE happyOut5 #-} +happyIn6 :: ([ PackageConfig ]) -> (HappyAbsSyn ) +happyIn6 x = unsafeCoerce# x +{-# INLINE happyIn6 #-} +happyOut6 :: (HappyAbsSyn ) -> ([ PackageConfig ]) +happyOut6 x = unsafeCoerce# x +{-# INLINE happyOut6 #-} +happyIn7 :: (PackageConfig) -> (HappyAbsSyn ) +happyIn7 x = unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn ) -> (PackageConfig) +happyOut7 x = unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: (PackageConfig -> PackageConfig) -> (HappyAbsSyn ) +happyIn8 x = unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn ) -> (PackageConfig -> PackageConfig) +happyOut8 x = unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyIn9 :: (PackageConfig -> PackageConfig) -> (HappyAbsSyn ) +happyIn9 x = unsafeCoerce# x +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn ) -> (PackageConfig -> PackageConfig) +happyOut9 x = unsafeCoerce# x +{-# INLINE happyOut9 #-} +happyIn10 :: (PackageIdentifier) -> (HappyAbsSyn ) +happyIn10 x = unsafeCoerce# x +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn ) -> (PackageIdentifier) +happyOut10 x = unsafeCoerce# x +{-# INLINE happyOut10 #-} +happyIn11 :: (Version) -> (HappyAbsSyn ) +happyIn11 x = unsafeCoerce# x +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn ) -> (Version) +happyOut11 x = unsafeCoerce# x +{-# INLINE happyOut11 #-} +happyIn12 :: ([PackageIdentifier]) -> (HappyAbsSyn ) +happyIn12 x = unsafeCoerce# x +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn ) -> ([PackageIdentifier]) +happyOut12 x = unsafeCoerce# x +{-# INLINE happyOut12 #-} +happyIn13 :: ([PackageIdentifier]) -> (HappyAbsSyn ) +happyIn13 x = unsafeCoerce# x +{-# INLINE happyIn13 #-} +happyOut13 :: (HappyAbsSyn ) -> ([PackageIdentifier]) +happyOut13 x = unsafeCoerce# x +{-# INLINE happyOut13 #-} +happyIn14 :: ([Int]) -> (HappyAbsSyn ) +happyIn14 x = unsafeCoerce# x +{-# INLINE happyIn14 #-} +happyOut14 :: (HappyAbsSyn ) -> ([Int]) +happyOut14 x = unsafeCoerce# x +{-# INLINE happyOut14 #-} +happyIn15 :: ([Int]) -> (HappyAbsSyn ) +happyIn15 x = unsafeCoerce# x +{-# INLINE happyIn15 #-} +happyOut15 :: (HappyAbsSyn ) -> ([Int]) +happyOut15 x = unsafeCoerce# x +{-# INLINE happyOut15 #-} +happyIn16 :: ([String]) -> (HappyAbsSyn ) +happyIn16 x = unsafeCoerce# x +{-# INLINE happyIn16 #-} +happyOut16 :: (HappyAbsSyn ) -> ([String]) +happyOut16 x = unsafeCoerce# x +{-# INLINE happyOut16 #-} +happyIn17 :: ([String]) -> (HappyAbsSyn ) +happyIn17 x = unsafeCoerce# x +{-# INLINE happyIn17 #-} +happyOut17 :: (HappyAbsSyn ) -> ([String]) +happyOut17 x = unsafeCoerce# x +{-# INLINE happyOut17 #-} +happyInTok :: Token -> (HappyAbsSyn ) +happyInTok x = unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> Token +happyOutTok x = unsafeCoerce# x +{-# INLINE happyOutTok #-} + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x50\x00\x4a\x00\x4c\x00\x49\x00\x46\x00\x4b\x00\x45\x00\x0a\x00\x1e\x00\x00\x00\x00\x00\x44\x00\x16\x00\x00\x00\x43\x00\x00\x00\x42\x00\x00\x00\x03\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x01\x00\x00\x00\x40\x00\x00\x00\x3e\x00\x3d\x00\x1c\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x3a\x00\x39\x00\x35\x00\x00\x00\x00\x00\x38\x00\x31\x00\x34\x00\x33\x00\x37\x00\x36\x00\x28\x00\x00\x00\x30\x00\x32\x00\x2f\x00\x09\x00\x2d\x00\x00\x00\x2e\x00\x26\x00\x2c\x00\x22\x00\x00\x00\x00\x00\x2b\x00\x29\x00\x0d\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x2a\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\xfe\xff\x00\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x04\x00\x00\x00\xfb\xff\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\xff\xfd\xff\x00\x00\x00\x00\xf8\xff\x00\x00\xfc\xff\x00\x00\xfa\xff\x00\x00\xf9\xff\x00\x00\xf7\xff\xf6\xff\xf1\xff\xf2\xff\x00\x00\xf4\xff\xf5\xff\x00\x00\xf3\xff\xed\xff\x00\x00\x00\x00\xe7\xff\x00\x00\xe5\xff\xe6\xff\x00\x00\xee\xff\x00\x00\x00\x00\x00\x00\xec\xff\xe4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\xff\xe9\xff\x00\x00\x00\x00\x00\x00\xea\xff\xe8\xff\x00\x00\x00\x00\x00\x00\xef\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x05\x00\x01\x00\x05\x00\x08\x00\x07\x00\x03\x00\x0c\x00\x0c\x00\x0b\x00\x09\x00\x08\x00\x09\x00\x04\x00\x04\x00\x0b\x00\x04\x00\x04\x00\x08\x00\x0a\x00\x08\x00\x09\x00\x09\x00\x05\x00\x02\x00\x0a\x00\x08\x00\x05\x00\x03\x00\x04\x00\x01\x00\x02\x00\x04\x00\x05\x00\x04\x00\x05\x00\x0a\x00\x04\x00\x06\x00\x02\x00\x09\x00\x02\x00\x00\x00\x02\x00\x0a\x00\x07\x00\x03\x00\x07\x00\xff\xff\x04\x00\x06\x00\x05\x00\x05\x00\x03\x00\x06\x00\x01\x00\x07\x00\x02\x00\x06\x00\x08\x00\xff\xff\x05\x00\x09\x00\x06\x00\x01\x00\x04\x00\x08\x00\x05\x00\x09\x00\xff\xff\xff\xff\x07\x00\x07\x00\x06\x00\x08\x00\x07\x00\x01\x00\x04\x00\xff\xff\x03\x00\x0b\x00\x0b\x00\x08\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x1e\x00\x1d\x00\x16\x00\x1f\x00\x17\x00\x1a\x00\x20\x00\x20\x00\x18\x00\x1e\x00\x1b\x00\x1c\x00\x3a\x00\x0b\x00\x41\x00\x22\x00\x22\x00\x06\x00\x3b\x00\x23\x00\x24\x00\x24\x00\x1e\x00\x14\x00\x3f\x00\x2a\x00\x15\x00\x0c\x00\x0d\x00\x08\x00\x09\x00\x25\x00\x26\x00\x10\x00\x11\x00\x38\x00\x15\x00\x30\x00\x11\x00\x36\x00\x04\x00\x06\x00\x44\x00\x3b\x00\x3d\x00\x43\x00\x35\x00\x00\x00\x3f\x00\x41\x00\x3e\x00\x3c\x00\x38\x00\x36\x00\x33\x00\x2f\x00\x34\x00\x30\x00\x32\x00\x00\x00\x2e\x00\x2d\x00\x2a\x00\x1d\x00\x27\x00\x23\x00\x28\x00\x2c\x00\x00\x00\x00\x00\x29\x00\x0f\x00\x13\x00\x06\x00\x0f\x00\x0c\x00\x0b\x00\x00\x00\x04\x00\xff\xff\xff\xff\x06\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = array (2, 27) [ + (2 , happyReduce_2), + (3 , happyReduce_3), + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11), + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25), + (26 , happyReduce_26), + (27 , happyReduce_27) + ] + +happy_n_terms = 12 :: Int +happy_n_nonterms = 13 :: Int + +happyReduce_2 = happySpecReduce_2 0# happyReduction_2 +happyReduction_2 happy_x_2 + happy_x_1 + = happyIn5 + ([] + ) + +happyReduce_3 = happySpecReduce_3 0# happyReduction_3 +happyReduction_3 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut6 happy_x_2 of { happy_var_2 -> + happyIn5 + (reverse happy_var_2 + )} + +happyReduce_4 = happySpecReduce_1 1# happyReduction_4 +happyReduction_4 happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn6 + ([ happy_var_1 ] + )} + +happyReduce_5 = happySpecReduce_3 1# happyReduction_5 +happyReduction_5 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + case happyOut7 happy_x_3 of { happy_var_3 -> + happyIn6 + (happy_var_3 : happy_var_1 + )}} + +happyReduce_6 = happyReduce 4# 2# happyReduction_6 +happyReduction_6 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn7 + (happy_var_3 defaultPackageConfig + ) `HappyStk` happyRest} + +happyReduce_7 = happySpecReduce_1 3# happyReduction_7 +happyReduction_7 happy_x_1 + = case happyOut9 happy_x_1 of { happy_var_1 -> + happyIn8 + (\p -> happy_var_1 p + )} + +happyReduce_8 = happySpecReduce_3 3# happyReduction_8 +happyReduction_8 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut9 happy_x_3 of { happy_var_3 -> + happyIn8 + (\p -> happy_var_1 (happy_var_3 p) + )}} + +happyReduce_9 = happySpecReduce_3 4# happyReduction_9 +happyReduction_9 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (ITvarid happy_var_1) -> + case happyOut10 happy_x_3 of { happy_var_3 -> + happyIn9 + (\p -> case happy_var_1 of + "package" -> p {package = happy_var_3} + _ -> error "unknown key in config file" + )}} + +happyReduce_10 = happySpecReduce_3 4# happyReduction_10 +happyReduction_10 happy_x_3 + happy_x_2 + happy_x_1 + = happyIn9 + (id + ) + +happyReduce_11 = happySpecReduce_3 4# happyReduction_11 +happyReduction_11 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (ITvarid happy_var_1) -> + case happyOutTok happy_x_3 of { (ITconid happy_var_3) -> + happyIn9 + (case happy_var_1 of { + "exposed" -> + case happy_var_3 of { + "True" -> (\p -> p {exposed=True}); + "False" -> (\p -> p {exposed=False}); + _ -> error "exposed must be either True or False" }; + "license" -> id; -- not interested + _ -> error "unknown constructor" } + )}} + +happyReduce_12 = happyReduce 4# 4# happyReduction_12 +happyReduction_12 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = happyIn9 + (id + ) `HappyStk` happyRest + +happyReduce_13 = happySpecReduce_3 4# happyReduction_13 +happyReduction_13 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (ITvarid happy_var_1) -> + case happyOut16 happy_x_3 of { happy_var_3 -> + happyIn9 + (\p -> case happy_var_1 of + "exposedModules" -> p{exposedModules = happy_var_3} + "hiddenModules" -> p{hiddenModules = happy_var_3} + "importDirs" -> p{importDirs = happy_var_3} + "libraryDirs" -> p{libraryDirs = happy_var_3} + "hsLibraries" -> p{hsLibraries = happy_var_3} + "extraLibraries" -> p{extraLibraries = happy_var_3} + "includeDirs" -> p{includeDirs = happy_var_3} + "includes" -> p{includes = happy_var_3} + "hugsOptions" -> p{hugsOptions = happy_var_3} + "ccOptions" -> p{ccOptions = happy_var_3} + "ldOptions" -> p{ldOptions = happy_var_3} + "frameworkDirs" -> p{frameworkDirs = happy_var_3} + "frameworks" -> p{frameworks = happy_var_3} + "haddockInterfaces" -> p{haddockInterfaces = happy_var_3} + "haddockHTMLs" -> p{haddockHTMLs = happy_var_3} + "depends" -> p{depends = []} + -- empty list only, non-empty handled below + other -> p + )}} + +happyReduce_14 = happySpecReduce_3 4# happyReduction_14 +happyReduction_14 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (ITvarid happy_var_1) -> + case happyOut12 happy_x_3 of { happy_var_3 -> + happyIn9 + (case happy_var_1 of + "depends" -> (\p -> p{depends = happy_var_3}) + _other -> error "unknown key in config file" + )}} + +happyReduce_15 = happyReduce 10# 5# happyReduction_15 +happyReduction_15 (happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_5 of { (ITstring happy_var_5) -> + case happyOut11 happy_x_9 of { happy_var_9 -> + happyIn10 + (PackageIdentifier{ pkgName = happy_var_5, + pkgVersion = happy_var_9 } + ) `HappyStk` happyRest}} + +happyReduce_16 = happyReduce 10# 6# happyReduction_16 +happyReduction_16 (happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut14 happy_x_5 of { happy_var_5 -> + case happyOut16 happy_x_9 of { happy_var_9 -> + happyIn11 + (Version{ versionBranch=happy_var_5, versionTags=happy_var_9 } + ) `HappyStk` happyRest}} + +happyReduce_17 = happySpecReduce_3 7# happyReduction_17 +happyReduction_17 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut13 happy_x_2 of { happy_var_2 -> + happyIn12 + (happy_var_2 + )} + +happyReduce_18 = happySpecReduce_1 8# happyReduction_18 +happyReduction_18 happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn13 + ([ happy_var_1 ] + )} + +happyReduce_19 = happySpecReduce_3 8# happyReduction_19 +happyReduction_19 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + case happyOut13 happy_x_3 of { happy_var_3 -> + happyIn13 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_20 = happySpecReduce_2 9# happyReduction_20 +happyReduction_20 happy_x_2 + happy_x_1 + = happyIn14 + ([] + ) + +happyReduce_21 = happySpecReduce_3 9# happyReduction_21 +happyReduction_21 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut15 happy_x_2 of { happy_var_2 -> + happyIn14 + (happy_var_2 + )} + +happyReduce_22 = happySpecReduce_1 10# happyReduction_22 +happyReduction_22 happy_x_1 + = case happyOutTok happy_x_1 of { (ITinteger happy_var_1) -> + happyIn15 + ([ fromIntegral happy_var_1 ] + )} + +happyReduce_23 = happySpecReduce_3 10# happyReduction_23 +happyReduction_23 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (ITinteger happy_var_1) -> + case happyOut15 happy_x_3 of { happy_var_3 -> + happyIn15 + (fromIntegral happy_var_1 : happy_var_3 + )}} + +happyReduce_24 = happySpecReduce_2 11# happyReduction_24 +happyReduction_24 happy_x_2 + happy_x_1 + = happyIn16 + ([] + ) + +happyReduce_25 = happySpecReduce_3 11# happyReduction_25 +happyReduction_25 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut17 happy_x_2 of { happy_var_2 -> + happyIn16 + (reverse happy_var_2 + )} + +happyReduce_26 = happySpecReduce_1 12# happyReduction_26 +happyReduction_26 happy_x_1 + = case happyOutTok happy_x_1 of { (ITstring happy_var_1) -> + happyIn17 + ([ happy_var_1 ] + )} + +happyReduce_27 = happySpecReduce_3 12# happyReduction_27 +happyReduction_27 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut17 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_3 of { (ITstring happy_var_3) -> + happyIn17 + (happy_var_3 : happy_var_1 + )}} + +happyNewToken action sts stk [] = + happyDoAction 11# (error "reading EOF!") action sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = happyDoAction i tk action sts stk tks in + case tk of { + ITocurly -> cont 1#; + ITccurly -> cont 2#; + ITobrack -> cont 3#; + ITcbrack -> cont 4#; + ITcomma -> cont 5#; + ITequal -> cont 6#; + ITvarid happy_dollar_dollar -> cont 7#; + ITconid happy_dollar_dollar -> cont 8#; + ITstring happy_dollar_dollar -> cont 9#; + ITinteger happy_dollar_dollar -> cont 10#; + _ -> happyError tks + } + +happyThen = \m k -> k m +happyReturn = \a -> a +happyThen1 = happyThen +happyReturn1 = \a tks -> a + +parse tks = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut5 x)) + +parseOne tks = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut7 x)) + +happySeq = happyDontSeq + +type PackageConfig = InstalledPackageInfo + +defaultPackageConfig = emptyInstalledPackageInfo + +data Token + = ITocurly + | ITccurly + | ITobrack + | ITcbrack + | ITcomma + | ITequal + | ITvarid String + | ITconid String + | ITstring String + | ITinteger Int + +lexer :: String -> [Token] + +lexer [] = [] +lexer ('{':cs) = ITocurly : lexer cs +lexer ('}':cs) = ITccurly : lexer cs +lexer ('[':cs) = ITobrack : lexer cs +lexer (']':cs) = ITcbrack : lexer cs +lexer (',':cs) = ITcomma : lexer cs +lexer ('=':cs) = ITequal : lexer cs +lexer ('"':cs) = lexString cs "" +lexer (c:cs) + | isSpace c = lexer cs + | isAlpha c = lexID (c:cs) + | isDigit c = lexInt (c:cs) +lexer _ = error ( "Unexpected token") + +lexID cs = (if isUpper (head cs) then ITconid else ITvarid) id : lexer rest + where + (id,rest) = break (\c -> c /= '_' && not (isAlphaNum c)) cs + +lexInt cs = let (intStr, rest) = span isDigit cs + in ITinteger (read intStr) : lexer rest + + +lexString ('"':cs) s = ITstring (reverse s) : lexer cs +lexString ('\\':c:cs) s = lexString cs (c:s) +lexString (c:cs) s = lexString cs (c:s) + +happyError _ = error "Couldn't parse package configuration." + +parsePkgConf :: String -> [PackageConfig] +parsePkgConf = parse . lexer + +parseOnePkgConf :: String -> PackageConfig +parseOnePkgConf = parseOne . lexer +{-# LINE 1 "GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "GenericTemplate.hs" #-} +-- $Id: ParsePkgConfCabal.hs,v 1.1 2005/04/22 08:58:28 dons Exp $ + + +{-# LINE 28 "GenericTemplate.hs" #-} + + +data Happy_IntList = HappyCons Int# Happy_IntList + + + + + + +{-# LINE 49 "GenericTemplate.hs" #-} + + +{-# LINE 59 "GenericTemplate.hs" #-} + + + + + + + + + + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +happyAccept j tk st sts (HappyStk ans _) = (happyTcHack j (happyTcHack st)) + + (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | (n <# (0# :: Int#)) -> {- nothing -} + + (happyReduceArr ! rule) i tk st + where rule = (I# ((negateInt# ((n +# (1# :: Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where new_state = (n -# (1# :: Int#)) + where off = indexShortOffAddr happyActOffsets st + off_i = (off +# i) + check = if (off_i >=# (0# :: Int#)) + then (indexShortOffAddr happyCheck off_i ==# i) + else False + action | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + + + + + + + + + + + +indexShortOffAddr (HappyA# arr) off = +#if __GLASGOW_HASKELL__ > 500 + narrow16Int# i +#elif __GLASGOW_HASKELL__ == 500 + intToInt16# i +#else + (i `iShiftL#` 16#) `iShiftRA#` 16# +#endif + where +#if __GLASGOW_HASKELL__ >= 503 + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) +#else + i = word2Int# ((high `shiftL#` 8#) `or#` low) +#endif + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# + + + + + +data HappyAddr = HappyA# Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 166 "GenericTemplate.hs" #-} + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k -# (1# :: Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + happyThen1 (fn stk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where off = indexShortOffAddr happyGotoOffsets st + off_i = (off +# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# tk old_st _ stk = +-- trace "failing" $ + happyError + + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/src/plugins/Plugins/ParsePkgConfCabal.y b/src/plugins/Plugins/ParsePkgConfCabal.y new file mode 100644 index 0000000..2c11a77 --- /dev/null +++ b/src/plugins/Plugins/ParsePkgConfCabal.y @@ -0,0 +1,218 @@ +-- +-- Copyright (C) 2005 Sean Seefried - http://www.cse.unsw.edu.au/~sseefried +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +-- +-- Taken (apart from the most minor of alterations) from +-- ghc/utils/ghc-pkg/ParsePkgConfLite.hs from GHC 6.2.2 source tree +-- and then modified to mimic the behaviour of the parser within +-- ghc/compiler/main/ParsePkgConf.y in GHC 6.4, without importing +-- heavy-weight infrastructure from the GHC source tree such as module +-- FastString, Lexer, etc. +-- +-- (c) Copyright 2002, The University Court of the University of Glasgow. +-- + +{ +{-# OPTIONS -w #-} + +module Plugins.ParsePkgConfCabal ( + parsePkgConf, parseOnePkgConf + ) where + +import Distribution.InstalledPackageInfo +import Distribution.Package +import Distribution.Version + +import Char ( isSpace, isAlpha, isAlphaNum, isUpper, isDigit ) +import List ( break ) + +} + +%token + '{' { ITocurly } + '}' { ITccurly } + '[' { ITobrack } + ']' { ITcbrack } + ',' { ITcomma } + '=' { ITequal } + VARID { ITvarid $$ } + CONID { ITconid $$ } + STRING { ITstring $$ } + INT { ITinteger $$ } + +%name parse pkgconf +%name parseOne pkg +%tokentype { Token } +%% + +pkgconf :: { [ PackageConfig ] } + : '[' ']' { [] } + | '[' pkgs ']' { reverse $2 } + +pkgs :: { [ PackageConfig ] } + : pkg { [ $1 ] } + | pkgs ',' pkg { $3 : $1 } + +pkg :: { PackageConfig } + : CONID '{' fields '}' { $3 defaultPackageConfig } + +fields :: { PackageConfig -> PackageConfig } + : field { \p -> $1 p } + | fields ',' field { \p -> $1 ($3 p) } + +field :: { PackageConfig -> PackageConfig } + : VARID '=' pkgid + {\p -> case $1 of + "package" -> p {package = $3} + _ -> error "unknown key in config file" } + + | VARID '=' STRING { id } + -- we aren't interested in the string fields, they're all + -- boring (copyright, maintainer etc.) + + | VARID '=' CONID + { case $1 of { + "exposed" -> + case $3 of { + "True" -> (\p -> p {exposed=True}); + "False" -> (\p -> p {exposed=False}); + _ -> error "exposed must be either True or False" }; + "license" -> id; -- not interested + _ -> error "unknown constructor" } + } + + | VARID '=' CONID STRING { id } + -- another case of license + + | VARID '=' strlist + {\p -> case $1 of + "exposedModules" -> p{exposedModules = $3} + "hiddenModules" -> p{hiddenModules = $3} + "importDirs" -> p{importDirs = $3} + "libraryDirs" -> p{libraryDirs = $3} + "hsLibraries" -> p{hsLibraries = $3} + "extraLibraries" -> p{extraLibraries = $3} + "includeDirs" -> p{includeDirs = $3} + "includes" -> p{includes = $3} + "hugsOptions" -> p{hugsOptions = $3} + "ccOptions" -> p{ccOptions = $3} + "ldOptions" -> p{ldOptions = $3} + "frameworkDirs" -> p{frameworkDirs = $3} + "frameworks" -> p{frameworks = $3} + "haddockInterfaces" -> p{haddockInterfaces = $3} + "haddockHTMLs" -> p{haddockHTMLs = $3} + "depends" -> p{depends = []} + -- empty list only, non-empty handled below + other -> p + } + | VARID '=' pkgidlist + { case $1 of + "depends" -> (\p -> p{depends = $3}) + _other -> error "unknown key in config file" + } + + +pkgid :: { PackageIdentifier } + : CONID '{' VARID '=' STRING ',' VARID '=' version '}' + { PackageIdentifier{ pkgName = $5, + pkgVersion = $9 } } + +version :: { Version } + : CONID '{' VARID '=' intlist ',' VARID '=' strlist '}' + { Version{ versionBranch=$5, versionTags=$9 } } + +pkgidlist :: { [PackageIdentifier] } + : '[' pkgids ']' { $2 } + -- empty list case is covered by strlist, to avoid conflicts + +pkgids :: { [PackageIdentifier] } + : pkgid { [ $1 ] } + | pkgid ',' pkgids { $1 : $3 } + +intlist :: { [Int] } + : '[' ']' { [] } + | '[' ints ']' { $2 } + +ints :: { [Int] } + : INT { [ fromIntegral $1 ] } + | INT ',' ints { fromIntegral $1 : $3 } + +strlist :: { [String] } + : '[' ']' { [] } + | '[' strs ']' { reverse $2 } + +strs :: { [String] } + : STRING { [ $1 ] } + | strs ',' STRING { $3 : $1 } + +{ + +type PackageConfig = InstalledPackageInfo + +defaultPackageConfig = emptyInstalledPackageInfo + +data Token + = ITocurly + | ITccurly + | ITobrack + | ITcbrack + | ITcomma + | ITequal + | ITvarid String + | ITconid String + | ITstring String + | ITinteger Int + +lexer :: String -> [Token] + +lexer [] = [] +lexer ('{':cs) = ITocurly : lexer cs +lexer ('}':cs) = ITccurly : lexer cs +lexer ('[':cs) = ITobrack : lexer cs +lexer (']':cs) = ITcbrack : lexer cs +lexer (',':cs) = ITcomma : lexer cs +lexer ('=':cs) = ITequal : lexer cs +lexer ('"':cs) = lexString cs "" +lexer (c:cs) + | isSpace c = lexer cs + | isAlpha c = lexID (c:cs) + | isDigit c = lexInt (c:cs) +lexer _ = error ( "Unexpected token") + +lexID cs = (if isUpper (head cs) then ITconid else ITvarid) id : lexer rest + where + (id,rest) = break (\c -> c /= '_' && not (isAlphaNum c)) cs + +lexInt cs = let (intStr, rest) = span isDigit cs + in ITinteger (read intStr) : lexer rest + + +lexString ('"':cs) s = ITstring (reverse s) : lexer cs +lexString ('\\':c:cs) s = lexString cs (c:s) +lexString (c:cs) s = lexString cs (c:s) + +happyError _ = error "Couldn't parse package configuration." + +parsePkgConf :: String -> [PackageConfig] +parsePkgConf = parse . lexer + +parseOnePkgConf :: String -> PackageConfig +parseOnePkgConf = parseOne . lexer + +} diff --git a/src/plugins/Plugins/ParsePkgConfLite.hs b/src/plugins/Plugins/ParsePkgConfLite.hs new file mode 100644 index 0000000..6f75df7 --- /dev/null +++ b/src/plugins/Plugins/ParsePkgConfLite.hs @@ -0,0 +1,624 @@ +{-# OPTIONS -fglasgow-exts -cpp -w #-} +-- parser produced by Happy Version 1.14 + + + +module Plugins.ParsePkgConfLite ( + parsePkgConf, parseOnePkgConf + ) where + +import Plugins.Package ( PackageConfig(..), defaultPackageConfig ) + +import Char ( isSpace, isAlpha, isAlphaNum, isUpper ) +import List ( break ) +import Array +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif + +newtype HappyAbsSyn = HappyAbsSyn (() -> ()) +happyIn5 :: ([ PackageConfig ]) -> (HappyAbsSyn ) +happyIn5 x = unsafeCoerce# x +{-# INLINE happyIn5 #-} +happyOut5 :: (HappyAbsSyn ) -> ([ PackageConfig ]) +happyOut5 x = unsafeCoerce# x +{-# INLINE happyOut5 #-} +happyIn6 :: ([ PackageConfig ]) -> (HappyAbsSyn ) +happyIn6 x = unsafeCoerce# x +{-# INLINE happyIn6 #-} +happyOut6 :: (HappyAbsSyn ) -> ([ PackageConfig ]) +happyOut6 x = unsafeCoerce# x +{-# INLINE happyOut6 #-} +happyIn7 :: (PackageConfig) -> (HappyAbsSyn ) +happyIn7 x = unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn ) -> (PackageConfig) +happyOut7 x = unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: (PackageConfig -> PackageConfig) -> (HappyAbsSyn ) +happyIn8 x = unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn ) -> (PackageConfig -> PackageConfig) +happyOut8 x = unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyIn9 :: (PackageConfig -> PackageConfig) -> (HappyAbsSyn ) +happyIn9 x = unsafeCoerce# x +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn ) -> (PackageConfig -> PackageConfig) +happyOut9 x = unsafeCoerce# x +{-# INLINE happyOut9 #-} +happyIn10 :: ([String]) -> (HappyAbsSyn ) +happyIn10 x = unsafeCoerce# x +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn ) -> ([String]) +happyOut10 x = unsafeCoerce# x +{-# INLINE happyOut10 #-} +happyIn11 :: ([String]) -> (HappyAbsSyn ) +happyIn11 x = unsafeCoerce# x +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn ) -> ([String]) +happyOut11 x = unsafeCoerce# x +{-# INLINE happyOut11 #-} +happyIn12 :: (Bool) -> (HappyAbsSyn ) +happyIn12 x = unsafeCoerce# x +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn ) -> (Bool) +happyOut12 x = unsafeCoerce# x +{-# INLINE happyOut12 #-} +happyInTok :: Token -> (HappyAbsSyn ) +happyInTok x = unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> Token +happyOutTok x = unsafeCoerce# x +{-# INLINE happyOutTok #-} + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x1f\x00\x1e\x00\x1d\x00\x1b\x00\x1a\x00\x1c\x00\x19\x00\x01\x00\x0e\x00\x00\x00\x00\x00\x17\x00\x08\x00\x00\x00\x16\x00\x00\x00\x13\x00\x00\x00\xfe\xff\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x18\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\xfd\xff\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\xff\xfd\xff\x00\x00\x00\x00\xf8\xff\x00\x00\xfc\xff\x00\x00\xfa\xff\x00\x00\xf9\xff\x00\x00\xf7\xff\xf4\xff\xf5\xff\x00\x00\xef\xff\xf6\xff\x00\x00\xf3\xff\xf1\xff\xf2\xff\x00\x00\xf0\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x03\x00\x05\x00\x04\x00\x07\x00\x04\x00\x08\x00\x09\x00\x09\x00\x08\x00\x02\x00\x01\x00\x02\x00\x05\x00\x03\x00\x04\x00\x04\x00\x05\x00\x04\x00\x05\x00\x04\x00\x06\x00\x02\x00\x02\x00\x00\x00\x07\x00\x09\x00\x08\x00\x06\x00\x01\x00\x07\x00\x04\x00\x03\x00\xff\xff\x03\x00\x0a\x00\x0a\x00\xff\xff\x08\x00\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x19\x00\x16\x00\x1d\x00\x17\x00\x0b\x00\x1a\x00\x1b\x00\x1e\x00\x06\x00\x14\x00\x08\x00\x09\x00\x15\x00\x0c\x00\x0d\x00\x1f\x00\x20\x00\x10\x00\x11\x00\x15\x00\x1b\x00\x11\x00\x04\x00\x06\x00\x0f\x00\x21\x00\x06\x00\x13\x00\x0c\x00\x0f\x00\x0b\x00\x04\x00\x00\x00\x08\x00\xff\xff\xff\xff\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = array (2, 16) [ + (2 , happyReduce_2), + (3 , happyReduce_3), + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11), + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16) + ] + +happy_n_terms = 11 :: Int +happy_n_nonterms = 8 :: Int + +happyReduce_2 = happySpecReduce_2 0# happyReduction_2 +happyReduction_2 happy_x_2 + happy_x_1 + = happyIn5 + ([] + ) + +happyReduce_3 = happySpecReduce_3 0# happyReduction_3 +happyReduction_3 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut6 happy_x_2 of { happy_var_2 -> + happyIn5 + (reverse happy_var_2 + )} + +happyReduce_4 = happySpecReduce_1 1# happyReduction_4 +happyReduction_4 happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn6 + ([ happy_var_1 ] + )} + +happyReduce_5 = happySpecReduce_3 1# happyReduction_5 +happyReduction_5 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + case happyOut7 happy_x_3 of { happy_var_3 -> + happyIn6 + (happy_var_3 : happy_var_1 + )}} + +happyReduce_6 = happyReduce 4# 2# happyReduction_6 +happyReduction_6 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn7 + (happy_var_3 defaultPackageConfig + ) `HappyStk` happyRest} + +happyReduce_7 = happySpecReduce_1 3# happyReduction_7 +happyReduction_7 happy_x_1 + = case happyOut9 happy_x_1 of { happy_var_1 -> + happyIn8 + (\p -> happy_var_1 p + )} + +happyReduce_8 = happySpecReduce_3 3# happyReduction_8 +happyReduction_8 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut9 happy_x_3 of { happy_var_3 -> + happyIn8 + (\p -> happy_var_1 (happy_var_3 p) + )}} + +happyReduce_9 = happySpecReduce_3 4# happyReduction_9 +happyReduction_9 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (ITvarid happy_var_1) -> + case happyOutTok happy_x_3 of { (ITstring happy_var_3) -> + happyIn9 + (\p -> case happy_var_1 of + "name" -> p{name = happy_var_3} + _ -> error "unknown key in config file" + )}} + +happyReduce_10 = happySpecReduce_3 4# happyReduction_10 +happyReduction_10 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (ITvarid happy_var_1) -> + case happyOut12 happy_x_3 of { happy_var_3 -> + happyIn9 + (\p -> case happy_var_1 of { + "auto" -> p{auto = happy_var_3}; + _ -> p } + )}} + +happyReduce_11 = happySpecReduce_3 4# happyReduction_11 +happyReduction_11 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (ITvarid happy_var_1) -> + case happyOut10 happy_x_3 of { happy_var_3 -> + happyIn9 + (\p -> case happy_var_1 of + "import_dirs" -> p{import_dirs = happy_var_3} + "library_dirs" -> p{library_dirs = happy_var_3} + "hs_libraries" -> p{hs_libraries = happy_var_3} + "extra_libraries" -> p{extra_libraries = happy_var_3} + "include_dirs" -> p{include_dirs = happy_var_3} + "c_includes" -> p{c_includes = happy_var_3} + "package_deps" -> p{package_deps = happy_var_3} + "extra_ghc_opts" -> p{extra_ghc_opts = happy_var_3} + "extra_cc_opts" -> p{extra_cc_opts = happy_var_3} + "extra_ld_opts" -> p{extra_ld_opts = happy_var_3} + "framework_dirs" -> p{framework_dirs = happy_var_3} + "extra_frameworks"-> p{extra_frameworks= happy_var_3} + _other -> p + )}} + +happyReduce_12 = happySpecReduce_2 5# happyReduction_12 +happyReduction_12 happy_x_2 + happy_x_1 + = happyIn10 + ([] + ) + +happyReduce_13 = happySpecReduce_3 5# happyReduction_13 +happyReduction_13 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut11 happy_x_2 of { happy_var_2 -> + happyIn10 + (reverse happy_var_2 + )} + +happyReduce_14 = happySpecReduce_1 6# happyReduction_14 +happyReduction_14 happy_x_1 + = case happyOutTok happy_x_1 of { (ITstring happy_var_1) -> + happyIn11 + ([ happy_var_1 ] + )} + +happyReduce_15 = happySpecReduce_3 6# happyReduction_15 +happyReduction_15 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut11 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_3 of { (ITstring happy_var_3) -> + happyIn11 + (happy_var_3 : happy_var_1 + )}} + +happyReduce_16 = happyMonadReduce 1# 7# happyReduction_16 +happyReduction_16 (happy_x_1 `HappyStk` + happyRest) + = happyThen (case happyOutTok happy_x_1 of { (ITconid happy_var_1) -> + case happy_var_1 of { + "True" -> True; + "False" -> False; + _ -> error ("unknown constructor in config file: " ++ happy_var_1) }} + ) (\r -> happyReturn (happyIn12 r)) + +happyNewToken action sts stk [] = + happyDoAction 10# (error "reading EOF!") action sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = happyDoAction i tk action sts stk tks in + case tk of { + ITocurly -> cont 1#; + ITccurly -> cont 2#; + ITobrack -> cont 3#; + ITcbrack -> cont 4#; + ITcomma -> cont 5#; + ITequal -> cont 6#; + ITvarid happy_dollar_dollar -> cont 7#; + ITconid happy_dollar_dollar -> cont 8#; + ITstring happy_dollar_dollar -> cont 9#; + _ -> happyError tks + } + +happyThen = \m k -> k m +happyReturn = \a -> a +happyThen1 = happyThen +happyReturn1 = \a tks -> a + +parse tks = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut5 x)) + +parseOne tks = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut7 x)) + +happySeq = happyDontSeq + +data Token + = ITocurly + | ITccurly + | ITobrack + | ITcbrack + | ITcomma + | ITequal + | ITvarid String + | ITconid String + | ITstring String + +lexer :: String -> [Token] + +lexer [] = [] +lexer ('{':cs) = ITocurly : lexer cs +lexer ('}':cs) = ITccurly : lexer cs +lexer ('[':cs) = ITobrack : lexer cs +lexer (']':cs) = ITcbrack : lexer cs +lexer (',':cs) = ITcomma : lexer cs +lexer ('=':cs) = ITequal : lexer cs +lexer ('"':cs) = lexString cs "" +lexer (c:cs) + | isSpace c = lexer cs + | isAlpha c = lexID (c:cs) where +lexer _ = error "Unexpected token" + +lexID cs = (if isUpper (head cs) then ITconid else ITvarid) id : lexer rest + where + (id,rest) = break (\c -> c /= '_' && not (isAlphaNum c)) cs + +lexString ('"':cs) s = ITstring (reverse s) : lexer cs +lexString ('\\':c:cs) s = lexString cs (c:s) +lexString (c:cs) s = lexString cs (c:s) + +happyError _ = error "Couldn't parse package configuration." + +parsePkgConf :: String -> [PackageConfig] +parsePkgConf = parse . lexer + +parseOnePkgConf :: String -> PackageConfig +parseOnePkgConf = parseOne . lexer +{-# LINE 1 "GenericTemplate.hs" #-} +-- $Id: ParsePkgConfLite.hs,v 1.3 2004/06/19 01:28:56 dons Exp $ + + + + + + + + + + + + + +{-# LINE 27 "GenericTemplate.hs" #-} + + + +data Happy_IntList = HappyCons Int# Happy_IntList + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +happyAccept j tk st sts (HappyStk ans _) = (happyTcHack j + (happyTcHack st)) + (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | (n <# (0# :: Int#)) -> {- nothing -} + + (happyReduceArr ! rule) i tk st + where rule = (I# ((negateInt# ((n +# (1# :: Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where new_state = (n -# (1# :: Int#)) + where off = indexShortOffAddr happyActOffsets st + off_i = (off +# i) + check = if (off_i >=# (0# :: Int#)) + then (indexShortOffAddr happyCheck off_i ==# i) + else False + action | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + + + + + + + + + + + +indexShortOffAddr (HappyA# arr) off = +#if __GLASGOW_HASKELL__ > 500 + narrow16Int# i +#elif __GLASGOW_HASKELL__ == 500 + intToInt16# i +#else + (i `iShiftL#` 16#) `iShiftRA#` 16# +#endif + where +#if __GLASGOW_HASKELL__ >= 503 + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) +#else + i = word2Int# ((high `shiftL#` 8#) `or#` low) +#endif + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# + + + + + +data HappyAddr = HappyA# Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 165 "GenericTemplate.hs" #-} + + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k -# (1# :: Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + happyThen1 (fn stk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where off = indexShortOffAddr happyGotoOffsets st + off_i = (off +# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# tk old_st _ stk = +-- trace "failing" $ + happyError + + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/src/plugins/Plugins/ParsePkgConfLite.y b/src/plugins/Plugins/ParsePkgConfLite.y new file mode 100644 index 0000000..08b2e24 --- /dev/null +++ b/src/plugins/Plugins/ParsePkgConfLite.y @@ -0,0 +1,159 @@ +-- +-- Copyright (C) 2004 Sean Seefried - http://www.cse.unsw.edu.au/~sseefried +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +-- +-- Taken (apart from the most minor of alterations) from +-- ghc/utils/ghc-pkg/ParsePkgConfLite.hs: +-- +-- (c) Copyright 2002, The University Court of the University of Glasgow. +-- + +{ + +{-# OPTIONS -w #-} + +module Plugins.ParsePkgConfLite ( + parsePkgConf, parseOnePkgConf + ) where + +import Plugins.Package ( PackageConfig(..), defaultPackageConfig ) + +import Char ( isSpace, isAlpha, isAlphaNum, isUpper ) +import List ( break ) + +} + +%token + '{' { ITocurly } + '}' { ITccurly } + '[' { ITobrack } + ']' { ITcbrack } + ',' { ITcomma } + '=' { ITequal } + VARID { ITvarid $$ } + CONID { ITconid $$ } + STRING { ITstring $$ } + +%name parse pkgconf +%name parseOne pkg +%tokentype { Token } +%% + +pkgconf :: { [ PackageConfig ] } + : '[' ']' { [] } + | '[' pkgs ']' { reverse $2 } + +pkgs :: { [ PackageConfig ] } + : pkg { [ $1 ] } + | pkgs ',' pkg { $3 : $1 } + +pkg :: { PackageConfig } + : CONID '{' fields '}' { $3 defaultPackageConfig } + +fields :: { PackageConfig -> PackageConfig } + : field { \p -> $1 p } + | fields ',' field { \p -> $1 ($3 p) } + +field :: { PackageConfig -> PackageConfig } + : VARID '=' STRING + {\p -> case $1 of + "name" -> p{name = $3} + _ -> error "unknown key in config file" } + + | VARID '=' bool + {\p -> case $1 of { + "auto" -> p{auto = $3}; + _ -> p } } + + | VARID '=' strlist + {\p -> case $1 of + "import_dirs" -> p{import_dirs = $3} + "library_dirs" -> p{library_dirs = $3} + "hs_libraries" -> p{hs_libraries = $3} + "extra_libraries" -> p{extra_libraries = $3} + "include_dirs" -> p{include_dirs = $3} + "c_includes" -> p{c_includes = $3} + "package_deps" -> p{package_deps = $3} + "extra_ghc_opts" -> p{extra_ghc_opts = $3} + "extra_cc_opts" -> p{extra_cc_opts = $3} + "extra_ld_opts" -> p{extra_ld_opts = $3} + "framework_dirs" -> p{framework_dirs = $3} + "extra_frameworks"-> p{extra_frameworks= $3} + _other -> p + } + +strlist :: { [String] } + : '[' ']' { [] } + | '[' strs ']' { reverse $2 } + +strs :: { [String] } + : STRING { [ $1 ] } + | strs ',' STRING { $3 : $1 } + +bool :: { Bool } + : CONID {% case $1 of { + "True" -> True; + "False" -> False; + _ -> error ("unknown constructor in config file: " ++ $1) } } + +{ + +data Token + = ITocurly + | ITccurly + | ITobrack + | ITcbrack + | ITcomma + | ITequal + | ITvarid String + | ITconid String + | ITstring String + +lexer :: String -> [Token] + +lexer [] = [] +lexer ('{':cs) = ITocurly : lexer cs +lexer ('}':cs) = ITccurly : lexer cs +lexer ('[':cs) = ITobrack : lexer cs +lexer (']':cs) = ITcbrack : lexer cs +lexer (',':cs) = ITcomma : lexer cs +lexer ('=':cs) = ITequal : lexer cs +lexer ('"':cs) = lexString cs "" +lexer (c:cs) + | isSpace c = lexer cs + | isAlpha c = lexID (c:cs) where +lexer _ = error "Unexpected token" + +lexID cs = (if isUpper (head cs) then ITconid else ITvarid) id : lexer rest + where + (id,rest) = break (\c -> c /= '_' && not (isAlphaNum c)) cs + +lexString ('"':cs) s = ITstring (reverse s) : lexer cs +lexString ('\\':c:cs) s = lexString cs (c:s) +lexString (c:cs) s = lexString cs (c:s) + +happyError _ = error "Couldn't parse package configuration." + +parsePkgConf :: String -> [PackageConfig] +parsePkgConf = parse . lexer + +parseOnePkgConf :: String -> PackageConfig +parseOnePkgConf = parseOne . lexer + +} diff --git a/src/plugins/Plugins/Parser.hs b/src/plugins/Plugins/Parser.hs new file mode 100644 index 0000000..9638e99 --- /dev/null +++ b/src/plugins/Plugins/Parser.hs @@ -0,0 +1,229 @@ +{-# OPTIONS -fglasgow-exts #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation; either version 2 of +-- the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- + +module Plugins.Parser ( + parse, mergeModules, pretty, parsePragmas, + HsModule(..) , + replaceModName + ) where + +import Data.List +import Data.Char +import Data.Either + +import Language.Haskell.Parser +import Language.Haskell.Syntax +import Language.Haskell.Pretty + +-- +-- | parse a file (as a string) as Haskell src +-- +parse :: FilePath -- ^ module name + -> String -- ^ haskell src + -> Either String HsModule -- ^ abstract syntax + +parse f fsrc = + case parseModuleWithMode (ParseMode f) fsrc of + ParseOk src -> Right src + ParseFailed loc _ -> Left $ srcmsg loc + where + srcmsg loc = "parse error in " ++ f ++ "\n" ++ + "line: " ++ (show $ srcLine loc) ++ + ", col: " ++ (show $ srcColumn loc)++ "\n" + +-- +-- | pretty print haskell src +-- +-- doesn't handle operators with '#' at the end. i.e. unsafeCoerce# +-- +pretty :: HsModule -> String +pretty code = prettyPrintWithMode (defaultMode { linePragmas = True }) code + + +-- | +-- mergeModules : generate a full Haskell src file, give a .hs config +-- file, and a stub to take default syntax and decls from. Mostly we +-- just ensure they don't do anything bad, and that the names are +-- correct for the module. +-- +-- Transformations: +-- +-- * Take src location pragmas from the conf file (1st file) +-- * Use the template's (2nd argument) module name +-- * Only use export list from template (2nd arg) +-- * Merge top-level decls +-- * need to force the type of the plugin to match the stub, +-- overwriting any type they supply. +-- +mergeModules :: HsModule -> -- ^ Configure module + HsModule -> -- ^ Template module + HsModule -- ^ A merge of the two + +mergeModules (HsModule l _ _ is ds ) + (HsModule _ m' es' is' ds') + = (HsModule l m' es' + (mImps m' is is') + (mDecl ds ds') ) + +-- +-- replace Module name with String. +-- +replaceModName :: HsModule -> String -> HsModule +replaceModName (HsModule l _ es is ds) nm = (HsModule l (Module nm) es is ds) + +-- +-- | merge import declarations: +-- +-- * ensure that the config file doesn't import the stub name +-- * merge import lists uniquely, and when they match, merge their decls +-- +-- TODO : we don't merge imports of the same module from both files. +-- We should, and then merge the decls in their import list +-- ** rename args, too confusing. +-- +-- quick fix: strip all type signatures from the source. +-- +mImps :: Module -> -- ^ plugin module name + [HsImportDecl] -> -- ^ conf file imports + [HsImportDecl] -> -- ^ stub file imports + [HsImportDecl] + +mImps plug_mod cimps timps = + case filter (!~ self) cimps of cimps' -> unionBy (=~) cimps' timps + where + self = ( HsImportDecl undefined plug_mod undefined undefined undefined ) + +-- +-- | merge top-level declarations +-- +-- Remove decls found in template, using those from the config file. +-- Need to sort decls by types, then decls first, in both. +-- +-- * could we write a pass to handle "editor, foo :: String" ? +-- +-- we must keep the type from the template. +-- +mDecl ds es = let ds' = filter (\t->not $ typeDecl t) ds -- rm type sigs from plugin + in sortBy decls $! unionBy (=~) ds' es + where + decls a b = compare (encoding a) (encoding b) + + typeDecl :: HsDecl -> Bool + typeDecl (HsTypeSig _ _ _) = True + typeDecl _ = False + + encoding :: HsDecl -> Int + encoding d = case d of + HsFunBind _ -> 1 + HsPatBind _ _ _ _ -> 1 + _ -> 0 + +-- +-- syntactic equality over the useful Haskell abstract syntax +-- this may be extended if we try to merge the files more thoroughly +-- +class SynEq a where + (=~) :: a -> a -> Bool + (!~) :: a -> a -> Bool + n !~ m = not (n =~ m) + +instance SynEq HsDecl where + (HsPatBind _ (HsPVar n) _ _) =~ (HsPatBind _ (HsPVar m) _ _) = n == m + (HsTypeSig _ (n:_) _) =~ (HsTypeSig _ (m:_) _) = n == m + _ =~ _ = False + +instance SynEq HsImportDecl where + (HsImportDecl _ m _ _ _) =~ (HsImportDecl _ n _ _ _) = n == m + + +-- +-- | Parsing option pragmas. +-- +-- This is not a type checker. If the user supplies bogus options, +-- they'll get slightly mystical error messages. Also, we *want* to +-- handle -package options, and other *static* flags. This is more than +-- GHC. +-- +-- GHC user's guide : +-- "OPTIONS pragmas are only looked for at the top of your source +-- files, upto the first (non-literate,non-empty) line not +-- containing OPTIONS. Multiple OPTIONS pragmas are recognised." +-- +-- based on getOptionsFromSource(), in main/DriverUtil.hs +-- +parsePragmas :: String -- ^ input src + -> ([String],[String]) -- ^ normal options, global options + +parsePragmas s = look $ lines s + where + look [] = ([],[]) + look (l':ls) = + let l = remove_spaces l' + in case () of + () | null l -> look ls + | prefixMatch "#" l -> look ls + | prefixMatch "{-# LINE" l -> look ls + | Just (Option o) <- matchPragma l + -> let (as,bs) = look ls in (words o ++ as,bs) + | Just (Global g) <- matchPragma l + -> let (as,bs) = look ls in (as,words g ++ bs) + | otherwise -> ([],[]) + +-- +-- based on main/DriverUtil.hs +-- +-- extended to handle dynamic options too +-- + +data Pragma = Option !String | Global !String + +matchPragma :: String -> Maybe Pragma +matchPragma s + | Just s1 <- maybePrefixMatch "{-#" s, -- -} + Just s2 <- maybePrefixMatch "OPTIONS" (remove_spaces s1), + Just s3 <- maybePrefixMatch "}-#" (reverse s2) + = Just (Option (reverse s3)) + + | Just s1 <- maybePrefixMatch "{-#" s, -- -} + Just s2 <- maybePrefixMatch "GLOBALOPTIONS" (remove_spaces s1), + Just s3 <- maybePrefixMatch "}-#" (reverse s2) + = Just (Global (reverse s3)) + + | otherwise + = Nothing + +remove_spaces :: String -> String +remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +-- +-- verbatim from utils/Utils.lhs +-- +prefixMatch :: Eq a => [a] -> [a] -> Bool +prefixMatch [] _str = True +prefixMatch _pat [] = False +prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss + | otherwise = False + +maybePrefixMatch :: String -> String -> Maybe String +maybePrefixMatch [] rest = Just rest +maybePrefixMatch (_:_) [] = Nothing +maybePrefixMatch (p:pat) (r:rest) + | p == r = maybePrefixMatch pat rest + | otherwise = Nothing diff --git a/src/plugins/Plugins/Utils.hs b/src/plugins/Plugins/Utils.hs new file mode 100644 index 0000000..5d6d276 --- /dev/null +++ b/src/plugins/Plugins/Utils.hs @@ -0,0 +1,454 @@ +{-# OPTIONS -cpp #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +#include "../../../config.h" + +module Plugins.Utils ( + Arg, + + hWrite, + + mkUnique, + hMkUnique, + mkUniqueIn, + hMkUniqueIn, + + mkTemp, mkTempIn, {- internal -} + + replaceSuffix, + outFilePath, + dropSuffix, + mkModid, + + isSublistOf, -- :: Eq a => [a] -> [a] -> Bool + + dirname, + basename, + + (), (<.>), (<+>), (<>), + + newer, + + encode, + decode, + EncodedString, + + exec, + panic + + ) where + +import Plugins.Env ( isLoaded ) +import Plugins.Consts ( objSuf, hiSuf, tmpDir ) +import qualified Plugins.MkTemp ( mkstemps ) + +import Data.Char +import Data.List + +import System.IO +import System.Environment ( getEnv ) +import System.Directory + +-- +-- The fork library +-- +#if CABAL == 0 && __GLASGOW_HASKELL__ < 604 +import POpen ( popen ) +import System.Posix.Process ( getProcessStatus ) +#else +import System.Process +#endif + +-- --------------------------------------------------------------------- +-- some misc types we use + +type Arg = String + +-- --------------------------------------------------------------------- +-- | useful +-- +panic s = ioError ( userError s ) + +-- --------------------------------------------------------------------- +-- | writeFile for Handles +-- +hWrite :: Handle -> String -> IO () +hWrite hdl src = hPutStr hdl src >> hClose hdl >> return () + + +-- --------------------------------------------------------------------- +-- | mkstemps. +-- +-- We use the Haskell version now... it is faster than calling into +-- mkstemps(3). +-- + +mkstemps :: String -> Int -> IO (String,Handle) +mkstemps path slen = do + m_v <- Plugins.MkTemp.mkstemps path slen + case m_v of Nothing -> error "mkstemps : couldn't create temp file" + Just v' -> return v' + +{- + +mkstemps path slen = do + withCString path $ \ ptr -> do + let c_slen = fromIntegral $ slen+1 + fd <- throwErrnoIfMinus1 "mkstemps" $ c_mkstemps ptr c_slen + name <- peekCString ptr + hdl <- fdToHandle fd + return (name, hdl) + +foreign import ccall unsafe "mkstemps" c_mkstemps :: CString -> CInt -> IO Fd + +-} + +-- --------------------------------------------------------------------- +-- | create a new temp file, returning name and handle. +-- bit like the mktemp shell utility +-- +mkTemp :: IO (String,Handle) +mkTemp = do tmpd <- catch (getEnv "TMPDIR") (\_ -> return tmpDir) + mkTempIn tmpd + +mkTempIn :: String -> IO (String, Handle) +mkTempIn tmpd = do + (tmpf,hdl) <- mkstemps (tmpd++"/MXXXXXXXXX.hs") 3 + let modname = mkModid $ dropSuffix tmpf + if and $ map (\c -> isAlphaNum c && c /= '_') modname + then return (tmpf,hdl) + else panic $ "Illegal characters in temp file: `"++tmpf++"'" + +-- --------------------------------------------------------------------- +-- | Get a new temp file, unique from those in /tmp, and from those +-- modules already loaded. Very nice for merge/eval uses. +-- +-- Will run for a long time if we can't create a temp file, luckily +-- mkstemps gives us a pretty big search space +-- +mkUnique :: IO FilePath +mkUnique = do (t,h) <- hMkUnique + hClose h >> return t + +hMkUnique :: IO (FilePath,Handle) +hMkUnique = do (t,h) <- mkTemp + alreadyLoaded <- isLoaded t -- not unique! + if alreadyLoaded + then hClose h >> removeFile t >> hMkUnique + else return (t,h) + +mkUniqueIn :: FilePath -> IO FilePath +mkUniqueIn dir = do (t,h) <- hMkUniqueIn dir + hClose h >> return t + +hMkUniqueIn :: FilePath -> IO (FilePath,Handle) +hMkUniqueIn dir = do (t,h) <- mkTempIn dir + alreadyLoaded <- isLoaded t -- not unique! + if alreadyLoaded + then hClose h >> removeFile t >> hMkUniqueIn dir + else return (t,h) + +-- --------------------------------------------------------------------- +-- +-- | execute a command and it's arguments, returning the +-- (stdout,stderr), waiting for it to exit, too. +-- + +exec :: String -> [String] -> IO ([String],[String]) + +#if CABAL == 1 || __GLASGOW_HASKELL__ >= 604 +-- +-- Use the forkProcess library +-- +exec prog args = do + (_,outh,errh,proc_hdl) <- runInteractiveProcess prog args Nothing Nothing + b <- waitForProcess proc_hdl -- wait + out <- hGetContents outh + err <- hGetContents errh + case b of + _exit_status -> return ( lines $ out, lines $ err ) + +#else +-- +-- 6.2.2 Posix version. +-- +exec prog args = do + (out,err,pid) <- popen prog args Nothing + b <- getProcessStatus True False pid -- wait + case b of + Nothing -> return ([], ["process `"++prog++"' has disappeared"]) + _ -> return ( lines $! out, lines $! err ) +#endif + +-- --------------------------------------------------------------------- +-- some filename manipulation stuff + +-- +-- | , <.> : join two path components +-- +infixr 6 +infixr 6 <.> + +(), (<.>), (<+>), (<>) :: FilePath -> FilePath -> FilePath +[] b = b +a b = a ++ "/" ++ b + +[] <.> b = b +a <.> b = a ++ "." ++ b + +[] <+> b = b +a <+> b = a ++ " " ++ b + +[] <> b = b +a <> b = a ++ b + +-- +-- | dirname : return the directory portion of a file path +-- if null, return "." +-- +dirname :: FilePath -> FilePath +dirname p = + case reverse $ dropWhile (/= '/') $ reverse p of + [] -> "." + p' -> p' + +-- +-- | basename : return the filename portion of a path +-- +basename :: FilePath -> FilePath +basename p = reverse $ takeWhile (/= '/') $ reverse p + +-- +-- drop suffix +-- +dropSuffix :: FilePath -> FilePath +dropSuffix f = reverse . tail . dropWhile (/= '.') $ reverse f + +-- +-- | work out the mod name from a filepath +mkModid :: String -> String +mkModid = (takeWhile (/= '.')) . reverse . (takeWhile (/= '/')) . reverse + +-- | return the object file, given the .conf file +-- i.e. /home/dons/foo.rc -> /home/dons/foo.o +-- +-- we depend on the suffix we are given having a lead '.' +-- +replaceSuffix :: FilePath -> String -> FilePath +replaceSuffix [] _ = [] -- ? +replaceSuffix f suf = + case reverse $ dropWhile (/= '.') $ reverse f of + [] -> f ++ suf -- no '.' in file name + f' -> f' ++ tail suf + +-- +-- Normally we create the .hi and .o files next to the .hs files. +-- For some uses this is annoying (i.e. true EDSL users don't actually +-- want to know that their code is compiled at all), and for hmake-like +-- applications. +-- +-- This code checks if "-o foo" or "-odir foodir" are supplied as args +-- to make(), and if so returns a modified file path, otherwise it +-- uses the source file to determing the path to where the object and +-- .hi file will be put. +-- +outFilePath :: FilePath -> [Arg] -> (FilePath,FilePath) +outFilePath src args = + let objs = find_o args -- user sets explicit object path + paths = find_p args -- user sets a directory to put stuff in + in case () of { _ + | not (null objs) + -> let obj = last objs in (obj, mk_hi obj) + + | not (null paths) + -> let obj = last paths mk_o (basename src) in (obj, mk_hi obj) + + | otherwise + -> (mk_o src, mk_hi src) + } + where + outpath = "-o" + outdir = "-odir" + + mk_hi s = replaceSuffix s hiSuf + mk_o s = replaceSuffix s objSuf + + find_o [] = [] + find_o (f:f':fs) | f == outpath = [f'] + | otherwise = find_o $! f':fs + find_o _ = [] + + find_p [] = [] + find_p (f:f':fs) | f == outdir = [f'] + | otherwise = find_p $! f':fs + find_p _ = [] + +------------------------------------------------------------------------ + +-- +-- | is file1 newer than file2? +-- +-- needs some fixing to work with 6.0.x series. (is this true?) +-- +-- fileExist still seems to throw exceptions on some platforms: ia64 in +-- particular. +-- +-- invarient : we already assume the first file, 'a', exists +-- +newer :: FilePath -> FilePath -> IO Bool +newer a b = do + a_t <- getModificationTime a + b_exists <- doesFileExist b + if not b_exists + then return True -- needs compiling + else do b_t <- getModificationTime b + return ( a_t > b_t ) -- maybe need recompiling + +------------------------------------------------------------------------ +-- +-- | return the Z-Encoding of the string. +-- +-- Stolen from GHC. Use -package ghc as soon as possible +-- +type EncodedString = String + +encode :: String -> EncodedString +encode [] = [] +encode (c:cs) = encode_ch c ++ encode cs + +unencodedChar :: Char -> Bool -- True for chars that don't need encoding +unencodedChar 'Z' = False +unencodedChar 'z' = False +unencodedChar c = c >= 'a' && c <= 'z' + || c >= 'A' && c <= 'Z' + || c >= '0' && c <= '9' + +-- +-- Decode is used for user printing. +-- +decode :: EncodedString -> String +decode [] = [] +decode ('Z' : d : rest) | isDigit d = decode_tuple d rest + | otherwise = decode_upper d : decode rest +decode ('z' : d : rest) | isDigit d = decode_num_esc d rest + | otherwise = decode_lower d : decode rest +decode (c : rest) = c : decode rest + +decode_upper, decode_lower :: Char -> Char + +decode_upper 'L' = '(' +decode_upper 'R' = ')' +decode_upper 'M' = '[' +decode_upper 'N' = ']' +decode_upper 'C' = ':' +decode_upper 'Z' = 'Z' +decode_upper ch = error $ "decode_upper can't handle this char `"++[ch]++"'" + +decode_lower 'z' = 'z' +decode_lower 'a' = '&' +decode_lower 'b' = '|' +decode_lower 'c' = '^' +decode_lower 'd' = '$' +decode_lower 'e' = '=' +decode_lower 'g' = '>' +decode_lower 'h' = '#' +decode_lower 'i' = '.' +decode_lower 'l' = '<' +decode_lower 'm' = '-' +decode_lower 'n' = '!' +decode_lower 'p' = '+' +decode_lower 'q' = '\'' +decode_lower 'r' = '\\' +decode_lower 's' = '/' +decode_lower 't' = '*' +decode_lower 'u' = '_' +decode_lower 'v' = '%' +decode_lower ch = error $ "decode_lower can't handle this char `"++[ch]++"'" + +-- Characters not having a specific code are coded as z224U +decode_num_esc :: Char -> [Char] -> String +decode_num_esc d cs + = go (digitToInt d) cs + where + go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest + go n ('U' : rest) = chr n : decode rest + go _ other = error $ + "decode_num_esc can't handle this: \""++other++"\"" + + +encode_ch :: Char -> EncodedString +encode_ch c | unencodedChar c = [c] -- Common case first + +-- Constructors +encode_ch '(' = "ZL" -- Needed for things like (,), and (->) +encode_ch ')' = "ZR" -- For symmetry with ( +encode_ch '[' = "ZM" +encode_ch ']' = "ZN" +encode_ch ':' = "ZC" +encode_ch 'Z' = "ZZ" + +-- Variables +encode_ch 'z' = "zz" +encode_ch '&' = "za" +encode_ch '|' = "zb" +encode_ch '^' = "zc" +encode_ch '$' = "zd" +encode_ch '=' = "ze" +encode_ch '>' = "zg" +encode_ch '#' = "zh" +encode_ch '.' = "zi" +encode_ch '<' = "zl" +encode_ch '-' = "zm" +encode_ch '!' = "zn" +encode_ch '+' = "zp" +encode_ch '\'' = "zq" +encode_ch '\\' = "zr" +encode_ch '/' = "zs" +encode_ch '*' = "zt" +encode_ch '_' = "zu" +encode_ch '%' = "zv" +encode_ch c = 'z' : shows (ord c) "U" + +decode_tuple :: Char -> EncodedString -> String +decode_tuple d cs + = go (digitToInt d) cs + where + go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest + go 0 ['T'] = "()" + go n ['T'] = '(' : replicate (n-1) ',' ++ ")" + go 1 ['H'] = "(# #)" + go n ['H'] = '(' : '#' : replicate (n-1) ',' ++ "#)" + go _ other = error $ "decode_tuple \'"++other++"'" + +-- --------------------------------------------------------------------- + +-- +-- 'isSublistOf' takes two arguments and returns 'True' iff the first +-- list is a sublist of the second list. This means that the first list +-- is wholly contained within the second list. Both lists must be +-- finite. + +isSublistOf :: Eq a => [a] -> [a] -> Bool +isSublistOf [] _ = True +isSublistOf _ [] = False +isSublistOf x y@(_:ys) + | isPrefixOf x y = True + | otherwise = isSublistOf x ys + diff --git a/src/plugins/plugins.conf.in.cpp b/src/plugins/plugins.conf.in.cpp new file mode 100644 index 0000000..87c50ba --- /dev/null +++ b/src/plugins/plugins.conf.in.cpp @@ -0,0 +1,63 @@ +#if CABAL == 0 && GLASGOW_HASKELL < 604 +Package { + name = "plugins", + auto = False, +#ifdef INSTALLING + import_dirs = [ "${LIBDIR}/imports" ], + library_dirs = [ "${LIBDIR}/" ], +#else + import_dirs = [ "${TOP}/src/plugins" ], + library_dirs = [ "${TOP}/src/plugins" ], +#endif + hs_libraries = [ "HSplugins" ], + c_includes = [ "Linker.h" ], + include_dirs = [], + source_dirs = [], + extra_libraries = [], + package_deps = [ "altdata", "hi", "unix", "haskell-src", "posix" ], + extra_ghc_opts = [], + extra_cc_opts = [], + extra_ld_opts = [] +} + +#else + +name: plugins +version: 0.9.8 +license: LGPL +maintainer: dons@cse.unsw.edu.au +exposed: True +exposed-modules: + Plugins.Consts, + Plugins.Env, + Plugins.Load, + Plugins.Make, + Plugins.MkTemp, + Plugins.PackageAPI, + Plugins.ParsePkgConfCabal, + Plugins.Parser, + Plugins.Utils, + Plugins + +hidden-modules: +#ifdef INSTALLING +import-dirs: LIBDIR/imports +library-dirs: LIBDIR +#else +import-dirs: TOP/src/plugins +library-dirs: TOP/src/plugins +#endif +hs-libraries: HSplugins +extra-libraries: +include-dirs: +includes: Linker.h +depends: altdata, hi, unix, haskell-src, posix, Cabal +hugs-options: +cc-options: +ld-options: +framework-dirs: +frameworks: +haddock-interfaces: +haddock-html: + +#endif diff --git a/src/printf/Makefile b/src/printf/Makefile new file mode 100644 index 0000000..e908c81 --- /dev/null +++ b/src/printf/Makefile @@ -0,0 +1,16 @@ +PKG = printf +UPKG = Printf + +YOBJ = $(UPKG)/Parser.hs +YSRC = $(UPKG)/Parser.y + +XOBJ = $(UPKG)/Lexer.hs +XSRC = $(UPKG)/Lexer.x + +TOP=../.. +include ../build.mk + +HC_OPTS += -package-conf $(TOP)/plugins.conf.inplace +HC_OPTS += -package eval + +install: install-me diff --git a/src/printf/Printf.hs b/src/printf/Printf.hs new file mode 100644 index 0000000..d83d4a2 --- /dev/null +++ b/src/printf/Printf.hs @@ -0,0 +1,25 @@ +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +module Printf ( + module Printf.Compile + ) where + +import Printf.Compile {-all-} + diff --git a/src/printf/Printf/Compile.hs b/src/printf/Printf/Compile.hs new file mode 100644 index 0000000..42a1871 --- /dev/null +++ b/src/printf/Printf/Compile.hs @@ -0,0 +1,390 @@ +{-# OPTIONS -fglasgow-exts #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +-- USA +-- + +-- +-- compile and run haskell strings at runtime. +-- +-- Some of the backend code is based on Ian Lynagh's TH version of +-- Printf. +-- +-- The specification of this implementation is taken from +-- the OpenBSD 3.5 man page for printf(3) +-- + +module Printf.Compile ( + printf, + (!), + ($>), ($<), + ) where + +import Printf.Lexer +import Printf.Parser + +import Eval.Haskell ( eval ) +import Eval.Utils ( escape ) +import Plugins.Utils ( (<>), (<+>) ) + +import AltData.Dynamic +import AltData.Typeable hiding ( typeOf ) + +import Data.List +import Data.Maybe ( isNothing, isJust ) + +import System.IO.Unsafe ( unsafePerformIO ) + +type Type = String +type Code = String + +-- --------------------------------------------------------------------- +-- +-- Generate a new Haskell function, as compiled native-code, from a +-- printf format string. It isn't applied to its arguments yet. +-- The function will return a String, but we won't typecheck this till +-- application. +-- +printf :: String -> Dynamic -- ([Dynamic] -> String) +printf fmt = run src ["Data.Char","Numeric"] + where + src = compile . parse . scan' . escape $ fmt + scan' s = either (error "lexer failed") (id) (scan s) + + run e i = case unsafePerformIO (eval e i) of + Nothing -> error "source failed to compile" + Just a -> a + +-- +-- application shortcuts. these expect all arguments to be supplied, and +-- if this is so, we can then give the result a type. +-- partial application means type annotations, or retaining everything +-- as a Dynamic +-- + +-- +-- sprintf +-- Apply a new fn to a arg list, returning a String +-- +infixr 0 $< +($<) :: Dynamic -> [Dynamic] -> String +f $< as = fromDynamic $! f `dynAppHList` as + +-- +-- printf +-- Apply a new fn to a arg list, printing out the result +-- +infixr 0 $> +($>) :: Dynamic -> [Dynamic] -> IO () +f $> as = putStr (fromDynamic $! f `dynAppHList` as) + +-- --------------------------------------------------------------------- +-- a printf code generator +-- +-- ToDo handle all the different specifiers +-- +-- Compile a printf format syntax tree into a Haskell string +-- representing a Haskell function to implement this printf. +-- +compile :: [Format] -> String +compile fmt = + let (tys,src) = compile' fmt 0 + in "toDyn $ \\" <> + spacify (map (\(ty,i) -> parens('x':show i <+> "::" <+> ty)) + (zip tys [0..length src])) <+> "->" <+> consify src + + where spacify s = concat (intersperse " " s) + consify s = concat (intersperse "++" s) + +-- --------------------------------------------------------------------- +-- +-- Compile an individual format or string literal + +compile' :: [Format] -> Int -> ([String],[String]) +compile' [] _ = ([],[]) + +compile' ((StrLit s):xs) i = ( ts, ( '"':s++"\"" ):ss ) + where (ts,ss) = compile' xs i + +compile' ((ConvSp _ _ _ _ Percent):xs) i = (ts, "\"%\"":ss) + where (ts,ss) = compile' xs $! i+1 + +compile' (c@(ConvSp _ _ _ _ t):xs) i = + (typeOf t:ts, parens( + (snd.plus.pad.alt.trunc.codeOf) c -- apply transformations + <+> ident i) : ss) + + where (ts, ss) = compile' xs $! i+1 + +-- --------------------------------------------------------------------- +-- +-- What argument type does a conversion specifier generate? +-- should be a FM +-- +typeOf :: Conv -> Type +typeOf x = case x of + D -> "Int" + O -> "Int" + Xx -> "Int" + XX -> "Int" + U -> "Int" + C -> "Char" + S -> "String" + F -> "Double" + Ee -> "Double" + EE -> "Double" + Gg -> "Double" + GG -> "Double" + Percent -> error "typeOf %: conversion specifier has no argument type" + +-- --------------------------------------------------------------------- +-- +-- Generate Haskell code for each particular format +-- +codeOf :: Format -> (Format,Code) +codeOf c@(ConvSp _ _ p _ f) = case f of + +-- diouxX The int (or appropriate variant) argument is converted to signed +-- decimal (d and i), unsigned octal (o), unsigned decimal (u), or +-- unsigned hexadecimal (x and X) notation. The letters abcdef are +-- used for x conversions; the letters ABCDEF are used for X conver- +-- sions. The precision, if any, gives the minimum number of digits +-- that must appear; if the converted value requires fewer digits, +-- it is padded on the left with zeros. + + D -> (c,"(show)") + U -> (c,"(show)") + O -> (c,"(\\v -> showOct v [])") + Xx -> (c,"(\\v -> showHex v [])") + XX -> (c,"(\\v -> map toUpper (showHex v []))") + +-- eE The double argument is rounded and converted in the style +-- [-]d.ddde+-dd where there is one digit before the decimal-point +-- character and the number of digits after it is equal to the pre- +-- cision; if the precision is missing, it is taken as 6; if the +-- precision is zero, no decimal-point character appears. An E con- +-- version uses the letter E (rather than e) to introduce the expo- +-- nent. The exponent always contains at least two digits; if the +-- value is zero, the exponent is 00. + +-- TODO prints exponent differently to printf(3) + + Ee -> let prec = if isNothing p then "Just 6" else show p + in (c,"(\\v->(showEFloat("++prec++")v)[])") + + EE -> let prec = if isNothing p then "Just 6" else show p + in (c,"(\\v->map toUpper((showEFloat ("++prec++")v)[]))") + +-- gG The double argument is converted in style f or e (or E for G con- +-- versions). The precision specifies the number of significant +-- digits. If the precision is missing, 6 digits are given; if the +-- precision is zero, it is treated as 1. Style e is used if the +-- exponent from its conversion is less than -4 or greater than or +-- equal to the precision. Trailing zeros are removed from the +-- fractional part of the result; a decimal point appears only if it +-- is followed by at least one digit. + +-- TODO unimplemented + + Gg -> let prec = if isNothing p then "Just 6" else show p + in (c,"(\\v->(showGFloat("++prec++")v)[])") + + GG -> let prec = if isNothing p then "Just 6" else show p + in (c,"(\\v->map toUpper((showGFloat ("++prec++")v)[]))") + +-- f The double argument is rounded and converted to decimal notation +-- in the style [-]ddd.ddd, where the number of digits after the +-- decimal-point character is equal to the precision specification. +-- If the precision is missing, it is taken as 6; if the precision +-- is explicitly zero, no decimal-point character appears. If a +-- decimal point appears, at least one digit appears before it. + + F -> let prec = if isNothing p then "Just 6" else show p + in (c, "(\\v -> (showFFloat ("++prec++") v) [])") + +-- c The int argument is converted to an unsigned char, and the re- +-- sulting character is written. + + C -> (c,"(\\c -> (showLitChar c) [])") + +-- s The char * argument is expected to be a pointer to an array of +-- character type (pointer to a string). Characters from the array +-- are written up to (but not including) a terminating NUL charac- +-- ter; if a precision is specified, no more than the number speci- +-- fied are written. If a precision is given, no null character +-- need be present; if the precision is not specified, or is greater +-- than the size of the array, the array must contain a terminating +-- NUL character. + + S -> (c,"(id)") + +-- % A `%' is written. No argument is converted. The complete con- +-- version specification is `%%'. + + Percent -> (c,"%") + +codeOf _ = error "codeOf: unknown conversion specifier" + +-- --------------------------------------------------------------------- +-- +-- Do we need a leading + ? +-- +-- A `+' character specifying that a sign always be placed before a +-- number produced by a signed conversion. A `+' overrides a space +-- if both are used. +-- +plus :: (Format, Code) -> (Format, Code) +plus p@(StrLit _,_) = p +plus a@(c@(ConvSp fs _w _ _ x), code) = case x of + D -> prefix + Ee-> prefix + EE-> prefix + Gg-> prefix + GG-> prefix + F -> prefix + _ -> a + + where prefix = let pref | Signed `elem` fs = "\"+\"" + | Space `elem` fs = "\" \"" + | otherwise = "[]" + in (c,parens("\\v ->"<+>pref<+>"++ v") <$> code) + + {- munge = case w of + Just w' | w' > 0 -> "tail" + _ -> "" -} + +-- --------------------------------------------------------------------- +-- Work out padding. +-- +-- A negative field width flag `-' indicates the converted value is +-- to be left adjusted on the field boundary. Except for n conver- +-- sions, the converted value is padded on the right with blanks, +-- rather than on the left with blanks or zeros. A `-' overrides a +-- `0' if both are given. +-- +-- A zero `0' character specifying zero padding. For all conver- +-- sions except n, the converted value is padded on the left with +-- zeros rather than blanks. If a precision is given with a numeric +-- conversion (d, i, o, u, x, and X), the `0' flag is ignored. +-- +pad :: (Format,Code) -> (Format,Code) +pad (c@(ConvSp fs (Just w) p _ x),code) + + | LeftAdjust `elem` fs + = (c, parens(parens("\\i c s -> if length s < i"<+> + "then s ++ take (i-length s) (repeat c) else s") + <+>show w<+>"' '")<$>code ) + + | otherwise + = (c, parens(parens("\\i c s -> if length s < i"<+> + "then take (i-length s) (repeat c) ++ s else s") + <+>show w<+>pad_chr)<$>code) + + where pad_chr | isNumeric x && isJust p = "' '" + | LeadZero `elem` fs = "'0'" + | otherwise = "' '" + +pad (c@(ConvSp _ Nothing _ _ _),code) = (c,code) + +pad ((StrLit _),_) = error "pad: can't pad str lit" + +isNumeric :: Conv -> Bool +isNumeric x = case x of + D -> True + O -> True + U -> True + Xx -> True + XX -> True + _ -> False + +-- --------------------------------------------------------------------- +-- +-- Check the 'alternate' modifier +-- +-- A hash `#' character specifying that the value should be convert- +-- ed to an ``alternate form''. For c, d, i, n, p, s, and u conver- +-- sions, this option has no effect. For o conversions, the preci- +-- sion of the number is increased to force the first character of +-- the output string to a zero (except if a zero value is printed +-- with an explicit precision of zero). For x and X conversions, a +-- non-zero result has the string `0x' (or `0X' for X conversions) +-- prepended to it. For e, E, f, g, and G conversions, the result +-- will always contain a decimal point, even if no digits follow it +-- (normally, a decimal point appears in the results of those con- +-- versions only if a digit follows). For g and G conversions, +-- trailing zeros are not removed from the result as they would oth- +-- erwise be. +-- + +alt :: (Format,Code) -> (Format,Code) +alt a@(c@(ConvSp fs _ _ _ x), code) | Alt `elem` fs = case x of + + Xx -> (c,parens("\\v->if fst (head (readHex v)) /= 0"<+> + "then \"0x\"++v else v")<$>code) + + XX -> (c,parens("\\v->if fst (head (readHex v)) /= 0"<+> + "then \"0X\"++v else v")<$>code) + + O -> (c,parens("\\v->if fst(head(readOct v)) /= 0"<+> + "then \"0\"++v else v")<$>code) + _ -> a + +alt a = a + +-- --------------------------------------------------------------------- +-- +-- Handle precision. Involves truncating strings and decimal points +-- +-- An optional precision, in the form of a period `.' followed by an op- +-- tional digit string. If the digit string is omitted, the precision +-- is taken as zero. This gives the minimum number of digits to appear +-- for d, i, o, u, x, and X conversions, the number of digits to appear +-- after the decimal-point for e, E, and f conversions, the maximum num- +-- ber of significant digits for g and G conversions, or the maximum +-- number of characters to be printed from a string for s conversions. +-- +trunc :: (Format,Code) -> (Format,Code) +trunc (c@(ConvSp _ _ (Just i) _ x), code) = case x of + S -> (c, parens("(\\i s -> if length s > i"<+> + "then take i s else s)"<+>show i)<$>code) + + _ | isNumeric x -> {-TODO-} (c, code) + | otherwise -> (c, code) + +trunc c = c + +-- --------------------------------------------------------------------- +-- make a new variable +ident i = 'x':show i + +-- wrap in parens +parens p = "("++p++")" + +-- lazy operator +infixr 6 <$> +(<$>) :: String -> String -> String +[] <$> a = a +a <$> b = a ++ " $ " ++ b + +-- --------------------------------------------------------------------- +-- +-- This bit of syntax constructs a [Dynamic]. +-- +infixr 6 ! +(!) :: Typeable a => a -> [Dynamic] -> [Dynamic] +a ! xs = toDyn a : xs + diff --git a/src/printf/Printf/Lexer.hs b/src/printf/Printf/Lexer.hs new file mode 100644 index 0000000..171fb53 --- /dev/null +++ b/src/printf/Printf/Lexer.hs @@ -0,0 +1,407 @@ +{-# OPTIONS -fglasgow-exts -cpp #-} +{-# LINE 25 "Printf/Lexer.x" #-} + +{-# OPTIONS -w #-} +-- ^ don't want to see all the warns alex templates produce + +module Printf.Lexer ( scan, Token(..) ) where + + +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +import Data.Char (ord) +import Data.Array.Base (unsafeAt) +#else +import Array +import Char (ord) +#endif +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif +alex_base :: AlexAddr +alex_base = AlexA# "\xf7\xff\xe2\xff\xef\xff\xf9\xff\x04\x00\x00\x00\xe6\xff\xfa\xff\x00\x00\x00\x00\x00\x00"# + +alex_table :: AlexAddr +alex_table = AlexA# "\x00\x00\xff\xff\x06\x00\xff\xff\x00\x00\x06\x00\x06\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x06\x00\xff\xff\x06\x00\x00\x00\x06\x00\x06\x00\x06\x00\x0a\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x08\x00\xff\xff\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\xff\xff\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x0a\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x09\x00\x00\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +alex_check :: AlexAddr +alex_check = AlexA# "\xff\xff\x0a\x00\x20\x00\x0a\x00\xff\xff\x23\x00\x20\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x2b\x00\x0a\x00\x2d\x00\xff\xff\x2b\x00\x30\x00\x2d\x00\x25\x00\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\x2e\x00\x25\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x25\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\xff\xff\xff\xff\x6c\x00\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\xff\xff\x75\x00\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_deflt :: AlexAddr +alex_deflt = AlexA# "\x04\x00\xff\xff\xff\xff\x04\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_accept = listArray (0::Int,10) [[],[(AlexAcc (alex_action_2))],[],[],[(AlexAcc (alex_action_0))],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_6))]] +{-# LINE 54 "Printf/Lexer.x" #-} + + +mkflags, mkconv, mklength, mkint, mkstr, mkdot :: AlexInput -> Int -> Alex Token + +mkflags (_,_,input) len = return (FlagT (take len input)) +mkconv (_,_,(c:_)) _ = return (ConvT c) +mklength (_,_,(c:_)) _ = return (LengthT c) +mkint (_,_,input) len = return (IntT (read (take len input))) +mkstr (_,_,input) len = return (StrT (take len input)) +mkdot _ _ = return DotT + +alexEOF = return EOFT + +data Token + = FlagT [Char] + | ConvT Char + | LengthT Char + | IntT Int + | StrT String + | DotT + | EOFT + deriving (Eq, Show) + +scan :: String -> Either String [Token] +scan str = runAlex str $ do + let loop tks = do + tok <- alexMonadScan; + if tok == EOFT then do return $! reverse tks + else loop $! (tok:tks) + loop [] + + + +flag,fmt :: Int +flag = 1 +fmt = 2 +alex_action_0 = mkstr +alex_action_1 = begin flag +alex_action_2 = mkflags `andBegin` fmt +alex_action_3 = mkint +alex_action_4 = mkdot +alex_action_5 = mklength +alex_action_6 = mkconv `andBegin` 0 +{-# LINE 1 "GenericTemplate.hs" #-} +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + + + + + + + + + + + + + +{-# LINE 34 "GenericTemplate.hs" #-} + + + + + + + + + + + + +data AlexAddr = AlexA# Addr# + +{-# INLINE alexIndexShortOffAddr #-} +alexIndexShortOffAddr (AlexA# arr) off = +#if __GLASGOW_HASKELL__ > 500 + narrow16Int# i +#elif __GLASGOW_HASKELL__ == 500 + intToInt16# i +#else + (i `iShiftL#` 16#) `iShiftRA#` 16# +#endif + where +#if __GLASGOW_HASKELL__ >= 503 + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) +#else + i = word2Int# ((high `shiftL#` 8#) `or#` low) +#endif + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# + + + + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> Maybe (AlexInput,Int,act) +alexScan input (I# (sc)) + = alexScanUser undefined input (I# (sc)) + +alexScanUser user input (I# (sc)) + = case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, input') -> + case alexGetChar input of + Nothing -> + + + + AlexEOF + Just _ -> + + + + AlexError input + + (AlexLastSkip input len, _) -> + + + + AlexSkip input len + + (AlexLastAcc k input len, _) -> + + + + AlexToken input len k + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user orig_input len input s last_acc = + input `seq` -- strict in the input + case s of + -1# -> (last_acc, input) + _ -> alex_scan_tkn' user orig_input len input s last_acc + +alex_scan_tkn' user orig_input len input s last_acc = + let + new_acc = check_accs (alex_accept `unsafeAt` (I# (s))) + in + new_acc `seq` + case alexGetChar input of + Nothing -> (new_acc, input) + Just (c, new_input) -> + + + + let + base = alexIndexShortOffAddr alex_base s + (I# (ord_c)) = ord c + offset = (base +# ord_c) + check = alexIndexShortOffAddr alex_check offset + + new_s = if (offset >=# 0#) && (check ==# ord_c) + then alexIndexShortOffAddr alex_table offset + else alexIndexShortOffAddr alex_deflt s + in + alex_scan_tkn user orig_input (len +# 1#) new_input new_s new_acc + + where + check_accs [] = last_acc + check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len)) + check_accs (AlexAccPred a pred : rest) + | pred user orig_input (I# (len)) input + = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkipPred pred : rest) + | pred user orig_input (I# (len)) input + = AlexLastSkip input (I# (len)) + check_accs (_ : rest) = check_accs rest + +data AlexLastAcc a + = AlexNone + | AlexLastAcc a !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc a user + = AlexAcc a + | AlexAccSkip + | AlexAccPred a (AlexAccPred user) + | AlexAccSkipPred (AlexAccPred user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user in1 len in2 + = p1 user in1 len in2 && p2 user in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext (I# (sc)) user _ _ input = + case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. + +-- used by wrappers +iUnbox (I# (i)) = i +{-# LINE 1 "wrappers.hs" #-} +-- ----------------------------------------------------------------------------- +-- Alex wrapper code. +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- The input type + + +type AlexInput = (AlexPosn, -- current position, + Char, -- previous char + String) -- current input string + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (p,c,s) = c + +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar (p,c,[]) = Nothing +alexGetChar (p,_,(c:s)) = let p' = alexMove p c in p' `seq` + Just (c, (p', c, s)) + +-- ----------------------------------------------------------------------------- +-- Token positions + +-- `Posn' records the location of a token in the input text. It has three +-- fields: the address (number of chacaters preceding the token), line number +-- and column of a token within the file. `start_pos' gives the position of the +-- start of the file and `eof_pos' a standard encoding for the end of file. +-- `move_pos' calculates the new position after traversing a given character, +-- assuming the usual eight character tab stops. + +data AlexPosn = AlexPn !Int !Int !Int + deriving (Eq,Show) + +alexStartPos :: AlexPosn +alexStartPos = AlexPn 0 1 1 + +alexMove :: AlexPosn -> Char -> AlexPosn +alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+7) `div` 8)*8+1) +alexMove (AlexPn a l c) '\n' = AlexPn (a+1) (l+1) 1 +alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1) + + +-- ----------------------------------------------------------------------------- +-- Default monad + + +data AlexState = AlexState { + alex_pos :: !AlexPosn, -- position at current input location + alex_inp :: String, -- the current input + alex_chr :: !Char, -- the character before the input + alex_scd :: !Int -- the current startcode + } + +-- Compile with -funbox-strict-fields for best results! + +runAlex :: String -> Alex a -> Either String a +runAlex input (Alex f) + = case f (AlexState {alex_pos = alexStartPos, + alex_inp = input, + alex_chr = '\n', + alex_scd = 0}) of Left msg -> Left msg + Right ( _, a ) -> Right a + +newtype Alex a = Alex { unAlex :: AlexState -> Either String (AlexState, a) } + +instance Monad Alex where + m >>= k = Alex $ \s -> case unAlex m s of + Left msg -> Left msg + Right (s',a) -> unAlex (k a) s' + return a = Alex $ \s -> Right (s,a) + +alexGetInput :: Alex AlexInput +alexGetInput + = Alex $ \s@AlexState{alex_pos=pos,alex_chr=c,alex_inp=inp} -> + Right (s, (pos,c,inp)) + +alexSetInput :: AlexInput -> Alex () +alexSetInput (pos,c,inp) + = Alex $ \s -> case s{alex_pos=pos,alex_chr=c,alex_inp=inp} of + s@(AlexState{}) -> Right (s, ()) + +alexError :: String -> Alex a +alexError message = Alex $ \s -> Left message + +alexGetStartCode :: Alex Int +alexGetStartCode = Alex $ \s@AlexState{alex_scd=sc} -> Right (s, sc) + +alexSetStartCode :: Int -> Alex () +alexSetStartCode sc = Alex $ \s -> Right (s{alex_scd=sc}, ()) + +alexMonadScan = do + inp <- alexGetInput + sc <- alexGetStartCode + case alexScan inp sc of + AlexEOF -> alexEOF + AlexError inp' -> alexError "lexical error" + AlexSkip inp' len -> do + alexSetInput inp' + alexMonadScan + AlexToken inp' len action -> do + alexSetInput inp' + action inp len + +-- ----------------------------------------------------------------------------- +-- Useful token actions + +type AlexAction result = AlexInput -> Int -> result + +-- just ignore this token and scan another one +-- skip :: AlexAction result +skip input len = alexMonadScan + +-- ignore this token, but set the start code to a new value +-- begin :: Int -> AlexAction result +begin code input len = do alexSetStartCode code; alexMonadScan + +-- perform an action for this token, and set the start code to a new value +-- andBegin :: AlexAction result -> Int -> AlexAction result +(action `andBegin` code) input len = do alexSetStartCode code; action input len + +-- token :: (String -> Int -> token) -> AlexAction token +token t input len = return (t input len) + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper + +{-# LINE 146 "wrappers.hs" #-} + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper + +-- Adds text positions to the basic model. + +{-# LINE 162 "wrappers.hs" #-} + + +-- ----------------------------------------------------------------------------- +-- GScan wrapper + +-- For compatibility with previous versions of Alex, and because we can. + +{-# LINE 180 "wrappers.hs" #-} + diff --git a/src/printf/Printf/Lexer.x b/src/printf/Printf/Lexer.x new file mode 100644 index 0000000..2b9a310 --- /dev/null +++ b/src/printf/Printf/Lexer.x @@ -0,0 +1,86 @@ +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation; either version 2 of +-- the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- + +-- +-- Lexer for printf format strings +-- Based on B1.2 Formatted Output, from Kernighan and Ritchie. +-- + +{ + +{-# OPTIONS -w #-} +-- ^ don't want to see all the warns alex templates produce + +module Printf.Lexer ( scan, Token(..) ) where + +} + +%wrapper "monad" + +$digit = 0-9 +$conv = [dioxXucsfeEgGpn\%] +$len = [hlL] +$flag = [\-\+\ 0\#] +$str = [. # \%] + +printf :- + +<0> $str+ { mkstr } +<0> \% { begin flag } + + $flag* { mkflags `andBegin` fmt } + + $digit+ { mkint } + \. { mkdot } + $len { mklength } + $conv { mkconv `andBegin` 0 } + +{ + + +mkflags, mkconv, mklength, mkint, mkstr, mkdot :: AlexInput -> Int -> Alex Token + +mkflags (_,_,input) len = return (FlagT (take len input)) +mkconv (_,_,(c:_)) _ = return (ConvT c) +mklength (_,_,(c:_)) _ = return (LengthT c) +mkint (_,_,input) len = return (IntT (read (take len input))) +mkstr (_,_,input) len = return (StrT (take len input)) +mkdot _ _ = return DotT + +alexEOF = return EOFT + +data Token + = FlagT [Char] + | ConvT Char + | LengthT Char + | IntT Int + | StrT String + | DotT + | EOFT + deriving (Eq, Show) + +scan :: String -> Either String [Token] +scan str = runAlex str $ do + let loop tks = do + tok <- alexMonadScan; + if tok == EOFT then do return $! reverse tks + else loop $! (tok:tks) + loop [] + +} diff --git a/src/printf/Printf/Parser.hs b/src/printf/Printf/Parser.hs new file mode 100644 index 0000000..82cfb64 --- /dev/null +++ b/src/printf/Printf/Parser.hs @@ -0,0 +1,719 @@ +{-# OPTIONS -fglasgow-exts -cpp -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-incomplete-patterns #-} +-- parser produced by Happy Version 1.14 + + +-- ^ grr. happy needs them all on one line + +module Printf.Parser where + +import Printf.Lexer +import Array +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif + +newtype HappyAbsSyn = HappyAbsSyn (() -> ()) +happyIn4 :: ([Format]) -> (HappyAbsSyn ) +happyIn4 x = unsafeCoerce# x +{-# INLINE happyIn4 #-} +happyOut4 :: (HappyAbsSyn ) -> ([Format]) +happyOut4 x = unsafeCoerce# x +{-# INLINE happyOut4 #-} +happyIn5 :: (Format) -> (HappyAbsSyn ) +happyIn5 x = unsafeCoerce# x +{-# INLINE happyIn5 #-} +happyOut5 :: (HappyAbsSyn ) -> (Format) +happyOut5 x = unsafeCoerce# x +{-# INLINE happyOut5 #-} +happyIn6 :: (Format) -> (HappyAbsSyn ) +happyIn6 x = unsafeCoerce# x +{-# INLINE happyIn6 #-} +happyOut6 :: (HappyAbsSyn ) -> (Format) +happyOut6 x = unsafeCoerce# x +{-# INLINE happyOut6 #-} +happyIn7 :: (Format) -> (HappyAbsSyn ) +happyIn7 x = unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn ) -> (Format) +happyOut7 x = unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: ([Flag]) -> (HappyAbsSyn ) +happyIn8 x = unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn ) -> ([Flag]) +happyOut8 x = unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyIn9 :: (Maybe Prec) -> (HappyAbsSyn ) +happyIn9 x = unsafeCoerce# x +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn ) -> (Maybe Prec) +happyOut9 x = unsafeCoerce# x +{-# INLINE happyOut9 #-} +happyIn10 :: (Maybe Width) -> (HappyAbsSyn ) +happyIn10 x = unsafeCoerce# x +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn ) -> (Maybe Width) +happyOut10 x = unsafeCoerce# x +{-# INLINE happyOut10 #-} +happyIn11 :: (Length) -> (HappyAbsSyn ) +happyIn11 x = unsafeCoerce# x +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn ) -> (Length) +happyOut11 x = unsafeCoerce# x +{-# INLINE happyOut11 #-} +happyIn12 :: (Conv) -> (HappyAbsSyn ) +happyIn12 x = unsafeCoerce# x +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn ) -> (Conv) +happyOut12 x = unsafeCoerce# x +{-# INLINE happyOut12 #-} +happyInTok :: Token -> (HappyAbsSyn ) +happyInTok x = unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> Token +happyOutTok x = unsafeCoerce# x +{-# INLINE happyOutTok #-} + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x0f\x00\x00\x00\x14\x00\x0f\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x15\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x0a\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\xff\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\xfe\xff\x00\x00\x00\x00\xfe\xff\xfc\xff\xfb\xff\xf3\xff\xfa\xff\xf7\xff\xef\xff\xf4\xff\xfd\xff\x00\x00\xf2\xff\xf1\xff\xf0\xff\xf5\xff\xef\xff\xf6\xff\xf8\xff\xee\xff\xed\xff\xec\xff\xeb\xff\xea\xff\xe9\xff\xe8\xff\xe7\xff\xe6\xff\xe5\xff\xe4\xff\xe3\xff\xe2\xff\xe1\xff\x00\x00\xf9\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x08\x00\x01\x00\x02\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x01\x00\x02\x00\x03\x00\x07\x00\x12\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x05\x00\x14\x00\x15\x00\x06\x00\x08\x00\x07\x00\x13\x00\x13\x00\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x23\x00\x0e\x00\x0f\x00\x10\x00\x0b\x00\x03\x00\x04\x00\x05\x00\x06\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x0e\x00\x0f\x00\x10\x00\x22\x00\x11\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x11\x00\x08\x00\x09\x00\x09\x00\x13\x00\x0c\x00\x13\x00\x0b\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = array (1, 30) [ + (1 , happyReduce_1), + (2 , happyReduce_2), + (3 , happyReduce_3), + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11), + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25), + (26 , happyReduce_26), + (27 , happyReduce_27), + (28 , happyReduce_28), + (29 , happyReduce_29), + (30 , happyReduce_30) + ] + +happy_n_terms = 23 :: Int +happy_n_nonterms = 9 :: Int + +happyReduce_1 = happySpecReduce_0 0# happyReduction_1 +happyReduction_1 = happyIn4 + ([] + ) + +happyReduce_2 = happySpecReduce_2 0# happyReduction_2 +happyReduction_2 happy_x_2 + happy_x_1 + = case happyOut5 happy_x_1 of { happy_var_1 -> + case happyOut4 happy_x_2 of { happy_var_2 -> + happyIn4 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_3 = happySpecReduce_1 1# happyReduction_3 +happyReduction_3 happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + happyIn5 + (happy_var_1 + )} + +happyReduce_4 = happySpecReduce_1 1# happyReduction_4 +happyReduction_4 happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn5 + (happy_var_1 + )} + +happyReduce_5 = happySpecReduce_1 2# happyReduction_5 +happyReduction_5 happy_x_1 + = case happyOutTok happy_x_1 of { (StrT happy_var_1) -> + happyIn6 + (StrLit happy_var_1 + )} + +happyReduce_6 = happyReduce 6# 3# happyReduction_6 +happyReduction_6 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut10 happy_x_2 of { happy_var_2 -> + case happyOut9 happy_x_4 of { happy_var_4 -> + case happyOut11 happy_x_5 of { happy_var_5 -> + case happyOut12 happy_x_6 of { happy_var_6 -> + happyIn7 + (ConvSp happy_var_1 happy_var_2 happy_var_4 happy_var_5 happy_var_6 + ) `HappyStk` happyRest}}}}} + +happyReduce_7 = happyReduce 4# 3# happyReduction_7 +happyReduction_7 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut10 happy_x_2 of { happy_var_2 -> + case happyOut11 happy_x_3 of { happy_var_3 -> + case happyOut12 happy_x_4 of { happy_var_4 -> + happyIn7 + (ConvSp happy_var_1 happy_var_2 Nothing happy_var_3 happy_var_4 + ) `HappyStk` happyRest}}}} + +happyReduce_8 = happySpecReduce_1 4# happyReduction_8 +happyReduction_8 happy_x_1 + = case happyOutTok happy_x_1 of { (FlagT happy_var_1) -> + happyIn8 + (mkFlags happy_var_1 + )} + +happyReduce_9 = happySpecReduce_1 5# happyReduction_9 +happyReduction_9 happy_x_1 + = case happyOutTok happy_x_1 of { (IntT happy_var_1) -> + happyIn9 + (Just happy_var_1 + )} + +happyReduce_10 = happySpecReduce_0 5# happyReduction_10 +happyReduction_10 = happyIn9 + (Nothing + ) + +happyReduce_11 = happySpecReduce_1 6# happyReduction_11 +happyReduction_11 happy_x_1 + = case happyOutTok happy_x_1 of { (IntT happy_var_1) -> + happyIn10 + (Just happy_var_1 + )} + +happyReduce_12 = happySpecReduce_0 6# happyReduction_12 +happyReduction_12 = happyIn10 + (Nothing + ) + +happyReduce_13 = happySpecReduce_1 7# happyReduction_13 +happyReduction_13 happy_x_1 + = happyIn11 + (Short + ) + +happyReduce_14 = happySpecReduce_1 7# happyReduction_14 +happyReduction_14 happy_x_1 + = happyIn11 + (Long + ) + +happyReduce_15 = happySpecReduce_1 7# happyReduction_15 +happyReduction_15 happy_x_1 + = happyIn11 + (Double + ) + +happyReduce_16 = happySpecReduce_0 7# happyReduction_16 +happyReduction_16 = happyIn11 + (Default + ) + +happyReduce_17 = happySpecReduce_1 8# happyReduction_17 +happyReduction_17 happy_x_1 + = happyIn12 + (D + ) + +happyReduce_18 = happySpecReduce_1 8# happyReduction_18 +happyReduction_18 happy_x_1 + = happyIn12 + (D + ) + +happyReduce_19 = happySpecReduce_1 8# happyReduction_19 +happyReduction_19 happy_x_1 + = happyIn12 + (O + ) + +happyReduce_20 = happySpecReduce_1 8# happyReduction_20 +happyReduction_20 happy_x_1 + = happyIn12 + (Xx + ) + +happyReduce_21 = happySpecReduce_1 8# happyReduction_21 +happyReduction_21 happy_x_1 + = happyIn12 + (XX + ) + +happyReduce_22 = happySpecReduce_1 8# happyReduction_22 +happyReduction_22 happy_x_1 + = happyIn12 + (U + ) + +happyReduce_23 = happySpecReduce_1 8# happyReduction_23 +happyReduction_23 happy_x_1 + = happyIn12 + (C + ) + +happyReduce_24 = happySpecReduce_1 8# happyReduction_24 +happyReduction_24 happy_x_1 + = happyIn12 + (S + ) + +happyReduce_25 = happySpecReduce_1 8# happyReduction_25 +happyReduction_25 happy_x_1 + = happyIn12 + (F + ) + +happyReduce_26 = happySpecReduce_1 8# happyReduction_26 +happyReduction_26 happy_x_1 + = happyIn12 + (Ee + ) + +happyReduce_27 = happySpecReduce_1 8# happyReduction_27 +happyReduction_27 happy_x_1 + = happyIn12 + (EE + ) + +happyReduce_28 = happySpecReduce_1 8# happyReduction_28 +happyReduction_28 happy_x_1 + = happyIn12 + (Gg + ) + +happyReduce_29 = happySpecReduce_1 8# happyReduction_29 +happyReduction_29 happy_x_1 + = happyIn12 + (GG + ) + +happyReduce_30 = happySpecReduce_1 8# happyReduction_30 +happyReduction_30 happy_x_1 + = happyIn12 + (Percent + ) + +happyNewToken action sts stk [] = + happyDoAction 22# (error "reading EOF!") action sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = happyDoAction i tk action sts stk tks in + case tk of { + LengthT 'h' -> cont 1#; + LengthT 'l' -> cont 2#; + LengthT 'L' -> cont 3#; + ConvT 'd' -> cont 4#; + ConvT 'i' -> cont 5#; + ConvT 'o' -> cont 6#; + ConvT 'x' -> cont 7#; + ConvT 'X' -> cont 8#; + ConvT 'u' -> cont 9#; + ConvT 'c' -> cont 10#; + ConvT 's' -> cont 11#; + ConvT 'f' -> cont 12#; + ConvT 'e' -> cont 13#; + ConvT 'E' -> cont 14#; + ConvT 'g' -> cont 15#; + ConvT 'G' -> cont 16#; + ConvT '%' -> cont 17#; + DotT -> cont 18#; + IntT happy_dollar_dollar -> cont 19#; + StrT happy_dollar_dollar -> cont 20#; + FlagT happy_dollar_dollar -> cont 21#; + _ -> happyError tks + } + +happyThen = \m k -> k m +happyReturn = \a -> a +happyThen1 = happyThen +happyReturn1 = \a tks -> a + +parse tks = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x)) + +happySeq = happyDontSeq + +------------------------------------------------------------------------ +-- +-- abstract syntax for printf format strings +-- +data Format + = StrLit String + | ConvSp { flags :: [Flag], + width :: (Maybe Width), + precision :: (Maybe Prec ), + lenght :: Length, + conv :: Conv } + deriving (Show, Eq) + +type Width = Int +type Prec = Int + +data Flag + = LeftAdjust -- - + | Signed -- + + | Space -- ' ' + | LeadZero -- 0 + | Alt -- # + deriving (Show, Eq) + +data Length + = Short -- h + | Long -- l + | Double -- L + | Default + deriving (Show, Eq) + +data Conv + = D + | O + | Xx | XX + | U + | C + | S + | F + | Ee | EE + | Gg | GG + | Percent + deriving (Show, Eq) + +mkFlags :: [Char] -> [Flag] +mkFlags [] = [] +mkFlags (c:cs) = (case c of + '-' -> LeftAdjust + '+' -> Signed + ' ' -> Space + '0' -> LeadZero + '#' -> Alt) : mkFlags cs + +happyError :: [Token] -> a +happyError [] = error "Parser" "parse error" +happyError tks = error $ "Parser: " ++ show tks +{-# LINE 1 "GenericTemplate.hs" #-} +-- $Id: Parser.hs,v 1.1 2004/06/28 03:56:01 dons Exp $ + + + + + + + + + + + + + +{-# LINE 27 "GenericTemplate.hs" #-} + + + +data Happy_IntList = HappyCons Int# Happy_IntList + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +happyAccept j tk st sts (HappyStk ans _) = (happyTcHack j + (happyTcHack st)) + (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | (n <# (0# :: Int#)) -> {- nothing -} + + (happyReduceArr ! rule) i tk st + where rule = (I# ((negateInt# ((n +# (1# :: Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where new_state = (n -# (1# :: Int#)) + where off = indexShortOffAddr happyActOffsets st + off_i = (off +# i) + check = if (off_i >=# (0# :: Int#)) + then (indexShortOffAddr happyCheck off_i ==# i) + else False + action | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + + + + + + + + + + + +indexShortOffAddr (HappyA# arr) off = +#if __GLASGOW_HASKELL__ > 500 + narrow16Int# i +#elif __GLASGOW_HASKELL__ == 500 + intToInt16# i +#else + (i `iShiftL#` 16#) `iShiftRA#` 16# +#endif + where +#if __GLASGOW_HASKELL__ >= 503 + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) +#else + i = word2Int# ((high `shiftL#` 8#) `or#` low) +#endif + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# + + + + + +data HappyAddr = HappyA# Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 165 "GenericTemplate.hs" #-} + + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k -# (1# :: Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + happyThen1 (fn stk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where off = indexShortOffAddr happyGotoOffsets st + off_i = (off +# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# tk old_st _ stk = +-- trace "failing" $ + happyError + + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/src/printf/Printf/Parser.y b/src/printf/Printf/Parser.y new file mode 100644 index 0000000..ca6fe13 --- /dev/null +++ b/src/printf/Printf/Parser.y @@ -0,0 +1,174 @@ +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation; either version 2 of +-- the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- + +-- +-- Parser for printf format strings +-- Based on B1.2 Formatted Output, from Kernighan and Ritchie. +-- + +{ + +{-# OPTIONS -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-incomplete-patterns #-} +-- ^ grr. happy needs them all on one line + +module Printf.Parser where + +import Printf.Lexer + +} + +%name parse +%tokentype { Token } +%token + + 'h' { LengthT 'h' } + 'l' { LengthT 'l' } + 'L' { LengthT 'L' } + + 'd' { ConvT 'd' } + 'i' { ConvT 'i' } + 'o' { ConvT 'o' } + 'x' { ConvT 'x' } + 'X' { ConvT 'X' } + 'u' { ConvT 'u' } + 'c' { ConvT 'c' } + 's' { ConvT 's' } + 'f' { ConvT 'f' } + 'e' { ConvT 'e' } + 'E' { ConvT 'E' } + 'g' { ConvT 'g' } + 'G' { ConvT 'G' } + '%' { ConvT '%' } + + '.' { DotT } + + INT { IntT $$ } + STRING { StrT $$ } + FLAGS { FlagT $$ } + +%% + +printf :: { [Format] } + : {- epsilon -} { [] } + | format0 printf { $1 : $2 } + +format0 :: { Format } + : string { $1 } + | format { $1 } + +string :: { Format } + : STRING { StrLit $1 } + +format :: { Format } + : flags width '.' precision length conv { ConvSp $1 $2 $4 $5 $6 } + | flags width length conv { ConvSp $1 $2 Nothing $3 $4 } + +flags :: { [Flag] } + : FLAGS { mkFlags $1 } + +precision :: { Maybe Prec } + : INT { Just $1 } + | {- epsilon -} { Nothing } + +width :: { Maybe Width } + : INT { Just $1 } + | {- epsilon -} { Nothing } + +length :: { Length } + : 'h' { Short } + | 'l' { Long } + | 'L' { Double } + | {- epsilon -} { Default} + +conv :: { Conv } + : 'd' { D } + | 'i' { D } -- n.b + | 'o' { O } + | 'x' { Xx } + | 'X' { XX } + | 'u' { U } + | 'c' { C } + | 's' { S } + | 'f' { F } + | 'e' { Ee } + | 'E' { EE } + | 'g' { Gg } + | 'G' { GG } + | '%' { Percent } + +{ + +------------------------------------------------------------------------ +-- +-- abstract syntax for printf format strings +-- +data Format + = StrLit String + | ConvSp { flags :: [Flag], + width :: (Maybe Width), + precision :: (Maybe Prec ), + lenght :: Length, + conv :: Conv } + deriving (Show, Eq) + +type Width = Int +type Prec = Int + +data Flag + = LeftAdjust -- - + | Signed -- + + | Space -- ' ' + | LeadZero -- 0 + | Alt -- # + deriving (Show, Eq) + +data Length + = Short -- h + | Long -- l + | Double -- L + | Default + deriving (Show, Eq) + +data Conv + = D + | O + | Xx | XX + | U + | C + | S + | F + | Ee | EE + | Gg | GG + | Percent + deriving (Show, Eq) + +mkFlags :: [Char] -> [Flag] +mkFlags [] = [] +mkFlags (c:cs) = (case c of + '-' -> LeftAdjust + '+' -> Signed + ' ' -> Space + '0' -> LeadZero + '#' -> Alt) : mkFlags cs + +happyError :: [Token] -> a +happyError [] = error "Parser" "parse error" +happyError tks = error $ "Parser: " ++ show tks + +} diff --git a/src/printf/printf.conf.in.cpp b/src/printf/printf.conf.in.cpp new file mode 100644 index 0000000..9b5b563 --- /dev/null +++ b/src/printf/printf.conf.in.cpp @@ -0,0 +1,54 @@ +#if CABAL == 0 && GLASGOW_HASKELL < 604 +Package { + name = "printf", + auto = False, + hs_libraries = [ "HSprintf" ], +#ifdef INSTALLING + import_dirs = [ "${LIBDIR}/imports" ], + library_dirs = [ "${LIBDIR}/" ], +#else + import_dirs = [ "${TOP}/src/printf" ], + library_dirs = [ "${TOP}/src/printf" ], +#endif + include_dirs = [], + c_includes = [], + source_dirs = [], + extra_libraries = [], + package_deps = [ "eval" ], + extra_ghc_opts = [], + extra_cc_opts = [], + extra_ld_opts = [] +} +#else +name: printf +version: 0.9.8 +license: LGPL +maintainer: dons@cse.unsw.edu.au +exposed: False +exposed-modules: + Printf.Compile, + Printf.Lexer, + Printf.Parser, + Printf + +hidden-modules: +#ifdef INSTALLING +import-dirs: LIBDIR/imports +library-dirs: LIBDIR +#else +import-dirs: TOP/src/printf +library-dirs: TOP/src/printf +#endif +hs-libraries: HSprintf +extra-libraries: +include-dirs: +includes: +depends: eval +hugs-options: +cc-options: +ld-options: +framework-dirs: +frameworks: +haddock-interfaces: +haddock-html: +#endif