ref: 718921b726a379782b191d62fbcd27edd14d2b25
parent: beb1d90b96a2b970460b50900caa57deb917f7a9
parent: 2ff4d2ebbe312878f1304c20f443c430f5fd70d6
author: Rewbert <krookr@chalmers.se>
date: Fri Sep 22 09:37:24 EDT 2023
Merge branch 'augustss-master'
--- /dev/null
+++ b/.gitattributes
@@ -1,0 +1,1 @@
+*.comb binary
--- a/Makefile
+++ b/Makefile
@@ -3,7 +3,7 @@
OUTDIR=ghc-out
TOOLS=Tools
PROF= #-prof -fprof-auto
-EXTS= -XScopedTypeVariables -XQualifiedDo
+EXTS= -XScopedTypeVariables -XQualifiedDo -XTupleSections
GHCB=ghc $(PROF) -outputdir $(BOOTDIR)
GHCFLAGS=-i -ighc -ilib -i$(BOOTDIR) -hide-all-packages -XNoImplicitPrelude $(EXTS) -F -pgmF $(TOOLS)/convertY.sh
GHCC=$(GHCB) $(GHCFLAGS)
@@ -16,26 +16,36 @@
MHS=mhs
COMB=comb/
EVAL=$(BIN)/eval
-.PHONY: all alltest everytest boottest bootboottest bootcombtest $(MHS)test test alltest time example bootstraptest
+.PHONY: all alltest everytest runtest bootboottest bootcombtest $(MHS)test test alltest time example bootstraptest
all: $(EVAL) $(BIN)/$(MHS)
-alltest: test boottest
+everytest: runtest example examplecomb bootboottest bootcombtest
-everytest: alltest example exampleboot examplecomb bootboottest bootcombtest
-
+###
+### Build evaluator (runtime system)
+###
# On MINGW you might need the additional flags -Wl,--stack,50000000 to increase stack space.
$(EVAL): src/runtime/eval.c
@mkdir -p bin
$(GCC) -Wall -O3 src/runtime/eval.c -o $(EVAL)
-$(BIN)/$(MHS): src/*.hs src/*/*.hs lib/Primitives.hs $(TOOLS)/convertX.sh
- $(GHCE) -isrc -Wall -O src/MicroHs/Main.hs -main-is MicroHs.Main -o $(BIN)/$(MHS)
+###
+### Build the compiler with ghc, using standard libraries (Prelude, Data.List, etc)
+###
+$(BIN)/$(MHS): src/*.hs src/*/*.hs $(TOOLS)/convertX.sh
+ $(GHCE) -ighc -isrc -Wall -O src/MicroHs/Main.hs -main-is MicroHs.Main -o $(BIN)/$(MHS)
+###
+### Build the compiler with ghc, using MicroHs libraries (Prelude, Data.List, etc)
+###
+# Due to a ghc bug we need to list all the commands.
+# The bug is that OPTIONS_GHC does not accept the -package flag.
$(BIN)/boot$(MHS): $(ALLSRC) $(TOOLS)/convertY.sh
rm -rf $(BOOTDIR)
$(GHCB) -c ghc/Primitives.hs
$(GHCB) -c ghc/Data/Bool_Type.hs
+ $(GHCB) -c ghc/Data/Ordering_Type.hs
$(GHCB) -c src/PrimTable.hs
$(GHCC) -c lib/Control/Error.hs
$(GHCC) -c lib/Data/Bool.hs
@@ -45,6 +55,7 @@
$(GHCC) -c lib/Data/Tuple.hs
$(GHCC) -c lib/Data/Function.hs
$(GHCC) -c lib/Data/Maybe.hs
+ $(GHCC) -c lib/Data/Ord.hs
$(GHCC) -c lib/Data/List.hs
$(GHCC) -c lib/Text/String.hs
$(GHCC) -c lib/Data/Word.hs
@@ -54,17 +65,21 @@
$(GHCC) -c lib/PreludeNoIO.hs
$(GHCC) -c lib/Data/Map.hs
$(GHCC) -c lib/Data/IntMap.hs
+ $(GHCC) -c lib/Data/IntSet.hs
$(GHCC) -c lib/Unsafe/Coerce.hs
$(GHCC) -c lib/Data/Integer.hs
$(GHCC) -c lib/Control/Monad/State/Strict.hs
+ $(GHCC) -c lib/Control/DeepSeq.hs
+# $(GHCC) -c lib/Debug/Trace.hs
+ $(GHCC) -c lib/Control/Exception.hs
+ $(GHCC) -c src/System/Console/SimpleReadline.hs
$(GHCC) -c src/Text/ParserComb.hs
$(GHCC) -c src/MicroHs/Ident.hs
$(GHCC) -c src/MicroHs/Expr.hs
+ $(GHCC) -c src/MicroHs/Graph.hs
$(GHCC) -c src/MicroHs/Lex.hs
$(GHCC) -c src/MicroHs/Parse.hs
$(GHCC) -c src/MicroHs/IdentMap.hs
- $(GHCC) -c src/MicroHs/StringMapFast.hs
-# $(GHCC) -c -package containers -package base src/MicroHs/StringMap.hs
$(GHCC) -c src/MicroHs/Exp.hs
$(GHCC) -c src/MicroHs/TCMonad.hs
$(GHCC) -c src/MicroHs/TypeCheck.hs
@@ -72,13 +87,14 @@
$(GHCC) -c src/MicroHs/StateIO.hs
$(GHCC) -c src/MicroHs/Compile.hs
$(GHCC) -c src/MicroHs/Translate.hs
+ $(GHCC) -c src/MicroHs/Interactive.hs
$(GHCC) -c -main-is MicroHs.Main src/MicroHs/Main.hs
- $(GHC) $(PROF) -hide-all-packages -package time -o $(BIN)/boot$(MHS) $(BOOTDIR)/*.o $(BOOTDIR)/*/*.o $(BOOTDIR)/*/*/*/*.o
+ $(GHC) $(PROF) -hide-all-packages -package time -o $(BIN)/boot$(MHS) $(BOOTDIR)/*.o $(BOOTDIR)/*/*.o $(BOOTDIR)/*/*/*.o $(BOOTDIR)/*/*/*/*.o
# $(GHC) $(PROF) -hide-all-packages -package containers -o $(BIN)/boot$(MHS) $(BOOTDIR)/*.o $(BOOTDIR)/*/*.o $(BOOTDIR)/*/*/*/*.o
-# Test Haskell version with local libraries
-boottest: $(BIN)/boot$(MHS)
- $(BIN)/boot$(MHS) -ilib Example
+# Self compile using comb/mhs.comb
+$(COMB)$(MHS)-new.comb: $(EVAL)
+ $(EVAL) +RTS -r$(COMB)$(MHS).comb -RTS -ilib -isrc -o$(COMB)$(MHS)-new.comb MicroHs.Main
# Compare version compiled with normal GHC libraries and $(MHS) libraries
bootboottest: $(BIN)/$(MHS) $(BIN)/boot$(MHS)
@@ -92,16 +108,24 @@
$(EVAL) +RTS -v -r$(COMB)$(MHS).comb -RTS -ilib -isrc -omain-comb.comb MicroHs.Main
cmp main-$(MHS).comb main-comb.comb
-# Test normal Haskell version
-test: $(EVAL) $(BIN)/$(MHS) tests/*.hs
+###
+### Run test examples with ghc-compiled compiler
+###
+runtest: $(EVAL) $(BIN)/$(MHS) tests/*.hs
cd tests; make test
+###
+### Run test examples with MicroHs compiler
+###
+runtestcomb: $(EVAL) $(COMB)$(MHS).comb
+ cd tests; make MHS='../$(EVAL) +RTS -r../$(COMB)$(MHS).comb -RTS -i../lib'
+
+###
+### Build combinator file for the compiler, using ghc-compiled compiler
+###
$(COMB)$(MHS).comb: $(BIN)/$(MHS) $(ALLSRC)
$(BIN)/$(MHS) -ilib -isrc -o$(COMB)$(MHS).comb MicroHs.Main
-$(MHS)comp: $(EVAL) $(COMB)$(MHS).comb
- $(EVAL) +RTS -v -r$(COMB)$(MHS).comb -RTS $(ARG)
-
time: $(EVAL) $(BIN)/$(MHS) tests/*.hs
cd tests; make time
@@ -116,26 +140,33 @@
$(EVAL) +RTS -r$(COMB)$(MHS).comb -RTS -r -ilib Example
clean:
- rm -rf src/*/*.hi src/*/*.o eval Main *.comb *.tmp *~ $(BIN)/* a.out $(BOOTDIR) $(OUTDIR) tmp/eval.c Tools/*.o Tools/*.hi
+ rm -rf src/*/*.hi src/*/*.o eval Main *.comb *.tmp *~ $(BIN)/* a.out $(BOOTDIR) $(OUTDIR) tmp/eval.c Tools/*.o Tools/*.hi dist-newstyle
cd tests; make clean
-#$(BIN)/addcombs: Tools/Addcombs.hs
-# $(GHC) -main-is -make -iTools Addcomb.main Tools/Addcombs.hs -o $(BIN)/addcombs
-
-tmp/eval.c: src/runtime/eval.c $(BIN)/eval
+###
+### Make an eval.c that contains the combinator code.
+###
+tmp/eval.c: src/runtime/eval.c $(BIN)/eval $(COMB)$(MHS).comb
@mkdir -p tmp
cp src/runtime/eval.c tmp/eval.c
-# $(BIN)/addcombs $(COMB)$(MHS).comb >> tmp/eval.c
$(BIN)/eval +RTS -K10M -r$(COMB)$(MHS).comb -RTS -ilib -iTools -r Addcombs -- $(COMB)$(MHS).comb >> tmp/eval.c
+###
+### Make an executable that contains the combinator code.
+###
$(BIN)/cmhs: tmp/eval.c
$(GCC) -Wall -O3 tmp/eval.c -o $(BIN)/cmhs
strip $(BIN)/cmhs
+###
+### Compress the binary (broken on MacOS)
+###
$(BIN)/umhs: $(BIN)/cmhs
- $(UPX) -o$(BIN)/umhs $(BIN)/cmhs
-
-# Test that the compiler can bootstrap
+ rm -f $(BIN)/umhs
+ $(UPX) -q -q -o$(BIN)/umhs $(BIN)/cmhs
+###
+### Test that the compiler can bootstrap
+###
bootstraptest: $(EVAL)
@mkdir -p tmp
@echo Build stage 1 with distribution combinator file
--- a/MicroHs.cabal
+++ b/MicroHs.cabal
@@ -1,6 +1,6 @@
cabal-version: 3.6
name: MicroHs
-version: 0.1
+version: 0.2
synopsis: A compiler for a small subset of Haskell
license: Apache-2.0
license-file: LICENSE
@@ -36,30 +36,34 @@
executable mhs
default-language: Haskell98
- hs-source-dirs: src
+ hs-source-dirs: src ghc
ghc-options: -Wall -F -pgmF ./Tools/convertX.sh -main-is MicroHs.Main
main-is: MicroHs/Main.hs
- default-extensions: ScopedTypeVariables QualifiedDo PatternGuards
+ default-extensions: ScopedTypeVariables QualifiedDo PatternGuards TupleSections
other-modules: MicroHs.Compile
MicroHs.Desugar
MicroHs.Exp
MicroHs.Expr
+ MicroHs.Graph
MicroHs.Ident
MicroHs.Lex
MicroHs.Parse
MicroHs.StateIO
MicroHs.IdentMap
- MicroHs.StringMapFast
+ MicroHs.Interactive
MicroHs.TCMonad
MicroHs.Translate
MicroHs.TypeCheck
PreludeNoIO
Text.ParserComb
+ System.Console.SimpleReadline
Compat
CompatIO
PrimTable
+ Primitives
build-depends: base >= 4.10 && < 4.20,
containers >= 0.5 && < 0.8,
+ deepseq >= 1.1 && < 1.6,
ghc-prim >= 0.5 && < 0.11,
mtl >= 2.0 && < 2.4,
time >= 1.1 && < 1.15
--- a/README.md
+++ b/README.md
@@ -4,6 +4,24 @@
The compiler can compile itself.
+## Compiling MicroHs
+There are three different ways to compile MicroHs
+* Using GHC with standard `Prelude` and libraries. `Makefile` target `bin/mhs`
+* Using GHC, but with `Prelude` and libraries from MicroHs. `Makefile` target `bin/bootmhs`
+* Using mhs, with the supplied `comb/mhs.comb`. `Makefile` target `comb/mhs-new.comb`
+
+These different ways of compiling need slightly different imports etc.
+To accomodate this each source file is preprocessed for the first two targets.
+When compiling with GHC and standard libraries the strings `--X` and `--W` are removed from the source file.
+When compiling with GHC and MicroHs libraries the strings `--Y` and `--W` are removed from the source file.
+This way anything special things needed with GHC is just treated as comments by mhs.
+
+Compiling MicroHs is really best done using `make`, but there is also a `MicroHs.cabal` file
+for use with `cabal`. This only builds what corresponds to the first target.
+
+Also note that there is no need to have a Haskell compiler to run MicroHs.
+All you need is a C compiler, and MicroHs can bootstrap, given the included combinator file (`comb/mhs.comb`).
+
## Language
The language is a subset of Haskell. There is only simple Hindley-Milner polymorphism,
no type classes (yet).
@@ -16,7 +34,7 @@
* character literals
* string (list of characters) literals
* case expressions
-* let expressions, no mutual recursion (yet)
+* let expressions
* tuples
* list syntax
* list comprehensions
@@ -25,10 +43,11 @@
* data (and newtype) type declarations
* type synonyms
* type signatures
-* importing of other modules, `qualified` and `as` supported, but no import list
+* importing of other modules, `qualified` and `as` supported
* exporting with mandatory export list
* the `Prelude` has to be imported explicitely
-* terrible, terrible error messages
+* mandatory type signatures at the top level, with mandatory `forall` for polymorphism
+* terrible error messages, some errors are not even flagged
## Example
The file `Example.hs` contains the following:
@@ -99,6 +118,23 @@
* `Translate`, convert an expression tree to its value.
* `TypeCheck`, type checker.
+## Interactive mode
+If no module name is given the compiler enters interactive mode.
+You can enter expressions to be evaluated, or top level definitions.
+Simple line editing is available.
+
+All definitions is saved in the file `Interactive.hs` and all input
+lines as saved in `.mhsi`. The latter file is read on startup so
+the command history is persisted.
+
+Available commands:
+
+* `:quit` Quit the interactive system
+* `:clear` Clear all definitions
+* `:del STR` Delete all definitions that begin with `STR`
+* `expr` Evaluate expression. ***NOTE*** Currently only expressions of type `Int` are allowed.
+* `defn` Add definition (can also be an `import`)
+
## Runtime
The runtime system is written in C and is in `eval.c`.
It uses combinators for handling variables, and has primitive operations
@@ -152,7 +188,7 @@
## Bootstrapping
It is possible to recompile the compiler without access to a Haskell compiler.
The combinator file for the compiler itself is available in `comb/mhs.comb`.
-The bootstrapping process takes about 15s (on a modern machine).
+The bootstrapping process takes about 20s (on a modern machine).
To bootstrap:
* build the evaluator, `make bin/eval`, this requires a C compiler
* compile the compiler
@@ -163,7 +199,7 @@
identical to `comb/mhs.comb`.
* It is also possible to bake the combinator code into the binary.
See `make` target `bin/cmhs` for how it is done.
- * For systems where `upx` works you can compress further compress
+ * For systems where `upx` works you can further compress
the binary. See `bin/umhs` target.
**NOTE** The GC mark phase currently uses a ridiculously deep stack.
@@ -175,14 +211,15 @@
* A: Maybe some time, maybe never.
*
* Q: Why are the error messages so bad?
- * A: Error messages are boring. But I plan to add location information to them.
+ * A: Error messages are boring.
*
* Q: Why is the so much source code?
- * A: I wonder this myself. Over 5500 lines of Haskell seems excessive.
- 1600 lines of C is also more than I'd like for such a simple system.
+ * A: I wonder this myself. Over 5000 lines of Haskell seems excessive.
+ 2000 lines of C is also more than I'd like for such a simple system.
*
* Q: Why are the binaries so big?
- * A: The combinator file is rather verbose. Compressed the combinator file
- for the compiler shrinks from 150kB to 20kB. The evaluator is about 40kB so
- the total size for runtime and (compressed) compiler is about 40k.
+ * A: The combinator file is rather verbose. The combinator file
+ for the compiler shrinks from 170kB to 30kB when compressed.
+ The evaluator is about 60kB.
+ The total compressed size for runtime and compiler is about 50k.
I'm sorry if you're running on a 16 bit system.
--- a/TODO
+++ b/TODO
@@ -1,29 +1,13 @@
* Add strict constructors
-* Add infix declarations
- - Parse as a string of atom oper atom oper ... atom
- - Resolve fixity in type checker
- - Add fixity table to TModule
* Put on hackage
* Have compile return a Stats record of timing etc
-* Special noMatch function with location
* Add overloading
* Implement deriving
-* Add forall to the syntax of types so it can be nested
- - Rank-N requires small changes in the type checker
-* Implement mutual recursion in let
- - Use SCC
-* Add [x..y] syntax
+* Make sure rank-N works correctly
* Add the possibility to save a compiler cache in a file
- Add SHA checksumming to the C code
- Use filename as the cache lookup key and SHA for validation
-* use 'data = primitive "Int"' for primitive types.
-* make an interactive version
- - implement a simple readline
- - implement catch (and maybe throw) using setjmp & longjmp
- - make the runtime system catch ^C and stop execution
-* implement low level equality
- - maybe?
- - could be used instead of derived when all is derived
+* make the runtime system catch ^C and stop execution
* use pointer stack during GC instead of recursion.
ROBERT * add Double primitive type
* implement Data.Integer
--- /dev/null
+++ b/Tools/Count.hs
@@ -1,0 +1,9 @@
+import System.Environment
+import Data.List
+
+main = do
+ [pat, fn] <- getArgs
+ file <- readFile fn
+ let n = length $ filter (isPrefixOf pat) (tails file)
+ print n
+
--- /dev/null
+++ b/Tools/Stats.hs
@@ -1,0 +1,21 @@
+import System.Environment
+import qualified Data.Map as M
+import Data.Function
+import Data.List
+
+main = do
+ [fn] <- getArgs
+ file <- readFile fn
+ let res = loop M.empty file
+ loop m "" = m
+ loop m cs@(_:ds) | Just (x,y) <- getComb cs = loop (M.insertWith (+) x 1 m) y
+ | otherwise = loop m ds
+ getComb ('(':'$':cs) = --Just ('$':xs, tail ys) where (xs, ys) = span (/= ')') cs+ let (k1, r) = span (/= ' ') cs
+ in case r of
+ ' ':'$':s -> let (k2, t) = span (/= ')') s in Just ("($" ++ k1 ++ " $" ++ k2 ++ ")", tail t)+ _ -> Nothing
+ getComb _ = Nothing
+ srt = sortBy (compare `on` snd) $ M.toList res
+ mapM print srt
+
--- a/Tools/convertX.sh
+++ b/Tools/convertX.sh
@@ -1,2 +1,2 @@
#!/bin/sh
-( echo "{-# LINE 1 \"$1\" #-}" ; sed -e 's/--X//' $2 ) > $3+( echo "{-# LINE 1 \"$1\" #-}" ; sed -e 's/--[XW]//' $2 ) > $3--- a/Tools/convertY.sh
+++ b/Tools/convertY.sh
@@ -1,2 +1,2 @@
#!/bin/sh
-( echo "{-# LINE 1 \"$1\" #-}" ; sed -e 's/--Y//' -e '/--Z/d' $2 ) > $3+( echo "{-# LINE 1 \"$1\" #-}" ; sed -e 's/--[YW]//' $2 ) > $3--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
-v3.2
-760
-(($A :0 ((_568 _521) (($B ((($S' ($C ((($C' ($S' _568)) (($B ($C _2)) _508)) (($B ($B (_568 _596))) ((($C' ($S' $C)) ((($C' ($C' $C)) ((($C' ($C' ($C' $S'))) (($B ($B ($B $C))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($S' $B))))) ((($C' ($C' ($C' ($C' ($C' $S))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' ($C' $B)))))) ((($C' ($C' ($C' ($S' ($C' $B))))) (($B ($B ($B ($B $B')))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' (($B $C') (($B ($S' _569)) ((($C' $B) (($B _657) (($B _586) ((($C' _695) _8) 0)))) (($B (_657 _589)) (($B (_602 "top level defns: ")) _550)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _569)) ((($C' $B) (($B _657) (($B _586) ((($C' _695) _8) 1)))) (_585 ($T (($B ($B (_657 _589))) ((($C' $B) (($B _602) _512)) (($B (_602 " = ")) _358))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _569))) ((($C' $B) ($B' (($B _657) (($B _591) _11)))) (($B ($B (_602 _1))) (($B (($C' _602) _550)) (_602 (($O 10) $K))))))) (($B ($B (_568 _596))) ((($C' $B) ($B' (($B _657) (($B _586) ((($C' _695) _8) 0))))) (($B ($B (_657 _589))) (($B ($B (_602 "final pass "))) ((($C' ($C' _602)) (($B ($B (_563 6))) (($B ($B _550)) _689))) "ms")))))))) _3)))) _547))) (($B (($C' $C) (($B ($C _607)) _358))) (($C _620) (_637 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B ($B ($B (_602 "(($A :"))))) (($B ($B (($C' $B) (($B _602) _550)))) (($B ($B ($B (_602 (($O 32) $K))))) ((($C' $B) (($B ($C' _602)) ($B _358))) (($B (_602 ") ")) (($C _602) (($O 41) $K))))))))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _335)) $I))) ($BK $K))) $K))))) $T)) (($B (($S' _657) (($B _654) (($B (_657 _704)) (($B (_602 "main: findIdent: ")) _512))))) (($C' _540) _510)))) (($B ($B _544)) (($B (($C' _604) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _510))) $K)))))) (($C _620) (_637 0)))))) (($B (_657 _334)) (($B (_657 _508)) (($B (_602 (($O 95) $K))) _550)))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _619) (_606 (_561 "-v")))) ((_636 _561) "-r"))) (($B (_600 (($O 46) $K))) (($B _656) (_605 ((_624 _680) "-i")))))) (($B (_657 _631)) ((($C' _602) (($B _656) (_605 ((_624 _680) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _691) _619) 1)) (_704 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _631)) (_606 ((_658 _700) ((_658 (_561 (($O 45) $K))) (_617 1))))))) (_627 ((_658 _700) (_561 "--")))))) (($A :1 "v3.2\10&") (($A :2 ((($S' ($S' _568)) _16) (($B ($B ($B (_568 _596)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _569) (($B (_657 _587)) (($B (_657 (_618 1000000))) _191)))))) (($B ($B ($B ($B (_568 _596))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _569))) ((($C' $B) ($B' (($B _657) (($B _586) ((($C' _695) _8) 0))))) (($B ($B (_657 _589))) (($B ($B (_602 "combinator conversion "))) ((($C' ($C' _602)) (($B ($B (_563 6))) (($B ($B _550)) _689))) "ms"))))))) (($B ($B _570)) (($B $P) (($C _514) (_508 "main")))))))) (_604 ($T ((($C' ($C' $O)) ((($C' $B) $P) _361)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_568 _521)))) (($B ($B ($B (($C' _522) ((($C' _684) (($B _619) (_627 ((_658 _700) (_561 "--"))))) 1))))) (($B ($B ($B (_657 _6)))) ($C $C))))) (($B ($B $Y)) (($B ($B ($B _499))) (($C' ($C' _604)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _657) (($B _654) (($B (_657 _704)) (($B (_602 "not found ")) _512))))) ($C _500))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _360))) (($B (_657 (_654 (_704 "primlookup")))) (($C (_640 _561)) _5))))) (_704 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "S'") $S')) (($O (($P (($O 80) $K)) $P)) (($
\ No newline at end of file
+v3.5
+882
+(($A :0 _769) (($A :1 (($B _815) _0)) (($A :2 ((($S' _815) _0) $I)) (($A :3 _739) (($A :4 (_3 "undefined")) (($A :5 $I) (($A :6 ((($C' $B) _768) (($C _48) _5))) (($A :7 ((($C' _6) (_786 _45)) ((_48 _784) _44))) (($A :8 (($B (($S _815) _784)) _3)) (($A :9 $T) (($A :10 ($T $I)) (($A :11 (($B (_48 _159)) _10)) (($A :12 (($B ($B (_47 _9))) ((($C' $B) (($B $C) _10)) ($B _10)))) (($A :13 (($B ($B (_47 _9))) ((($C' $B) (($B $C) _10)) ($BK _10)))) (($A :14 (($B (_47 _9)) $P)) (($A :15 (($B ($B (_47 _9))) (($B (($C' $C) _10)) ($B $P)))) (($A :16 _15) (($A :17 (($B (_47 _9)) ($B ($P _709)))) (($A :18 (($B (_47 _9)) ($BK ($P _709)))) (($A :19 ((_47 _9) (($S $P) $I))) (($A :20 (($B (_47 _9)) (($C ($S' $P)) $I))) (($A :21 (($B $Y) (($B ($B ($P (_14 _88)))) ((($C' $B) (($B ($C' $B)) ($B _12))) ((($C' ($C' $B)) ($B _12)) (($B ($B _14)) _89)))))) (($A :22 (($B $Y) (($B ($B ($P (_14 _709)))) (($B ($C' $B)) ($B _13))))) (($A :23 _3) (($A :24 ($T (_14 _709))) (($A :25 (($C $C) _32)) (($A :26 ($T _31)) (($A :27 (($P _32) _31)) (($A :28 _32) (($A :29 (($C (($C $S') _27)) $I)) (($A :30 (($C $S) _27)) (($A :31 $K) (($A :32 $A) (($A :33 _744) (($A :34 _745) (($A :35 ((($S' _26) (_736 97)) (($C _736) 122))) (($A :36 ((($S' _26) (_736 65)) (($C _736) 90))) (($A :37 ((($S' _25) _35) _36)) (($A :38 ((($S' _26) (_736 48)) (($C _736) 57))) (($A :39 ((($S' _26) (_736 32)) (($C _736) 126))) (($A :40 _733) (($A :41 _734) (($A :42 _736) (($A :43 _735) (($A :44 (($B $BK) $T)) (($A :45 ($BK $T)) (($A :46 $P) (($A :47 $I) (($A :48 $B) (($A :49 $I) (($A :50 $K) (($A :51 $C) (($A :52 _740) (($A :53 (($C (($C $S') _159)) _160)) (($A :54 ((($C' ($S' ($C' $B))) $B) $I)) (($A :55 _710) (($A :56 _711) (($A :57 _712) (($A :58 _713) (($A :59 _714) (($A :60 _715) (($A :61 (_56 0)) (($A :62 _721) (($A :63 _722) (($A :64 _723) (($A :65 _724) (($A :66 _725) (($A :67 _726) (($A :68 _62) (($A :69 ($BK $K)) (($A :70 (($B $BK) (($B ($B $BK)) $P))) (($A :71 (($B ($B ($B $BK))) (($B ($B ($B $BK))) (($B ($B ($B $C))) (($B ($B $C)) $P))))) (($A :72 ((($S' $S) ((($S' ($S' $C)) ((($C' ($C' $S)) ((($C' $B) (($B ($S' $S')) ((($C' $B) (($B _25) (_65 0))) (_62 0)))) (($B ($B (($C' $P) (_60 1)))) _55))) ($C $P))) _58)) _59)) (($A :73 _69) (($A :74 ((($S' $C) (($B ($P _148)) ((($C' ($C' $B)) ((($C' $C) _62) _148)) _149))) (($B (($C' ($C' ($C' $C))) ((($C' ($C' ($C' $C))) ((($C' ($C' ($C' ($C' $S')))) (($B ($B ($B ($B $C)))) (($B (($C' ($C' ($C' $C))) (($B ($B ($B (($S' $S') (_62 0))))) (($B (($C' ($C' $C)) (($B ($B (($S' $S') (_62 1)))) (($B (($C' $C) (($B (($C' $S') (_62 2))) ($C _74)))) ($C _74))))) ($C _74))))) ($C _74)))) ($T $K))) ($T $A)))) (($C _72) 4)))) (($A :75 (_81 _50)) (($A :76 ((_96 (_53 _75)) _73)) (($A :77 (($C ((($C' $B) (($P _88) ((($C' ($C' $O)) $P) $K))) ((($S' ($C' ($C' ($C' $B)))) (($B ($B ($B ($B _78)))) ((($S' ($C' ($C' $B))) (($B ($B ($B _78))) ((($S' ($C' $B)) (($B ($B _78)) ((($C' $B) (($B _94) ($T 0))) _77))) ((($C' $B) (($B _94) ($T 1))) _77)))) ((($C' $B) (($B _94) ($T 2))) _77)))) ((($C' $B) (($B _94) ($T 3))) _77)))) (($B $T) (($B ($B $P)) (($C' _55) (_57 4)))))) (($A :78 (($S $S) (($B $BK) (($B $BK) ((($S' $S) $T) (($B $BK) (($B $BK) (($C ((($S' $C') $S) (($B ($B ($B ($S $B)))) (($B ($B ($B ($B ($B $BK))))) (($B (($S' ($C' $B)) (($B $B') $B'))) (($B ($B ($B ($B ($B ($S $B)))))) (($B ($B ($B ($B ($B ($B ($B $BK))))))) ((($C' $B) ($B' ($B' (($B ($C' ($C' ($C' $C)))) (($B (($C' $B) ($B' (($B $C) _64)))) (($B (($C' $B) _89)) _78)))))) (($B (($C' $B) _89)) ($C _78)))))))))) (((_708 "lib/Data/IntMap.hs") 3) 8))))))))) (($A :79 ((_48 (_94 _159)) _77)) (($A :80 ((($C' $C) ((($C' $C) ($C _74)) (_3 "Data.IntMap.!"))) $I)) (($A :81 (($B (($C' $B) $T)) (($B ($B $Y)) ((($C' ($C' ($S' ($S' $C)))) (($B (($S' $B) (($B ($S' $P)) ($C _70)))) (($B ($B (($C' ($S' $C)) (($B (($S' ($S' $S')) _62)) ((($C' ($C' $B)) (($B $B') ($B _47))) ((($C' ($C' _47)) _75) ((((_71 _69) _69) _69) _69))))))) ($B (($C' $B) _70))))) ((($C' $B) (($B ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($S' ($S' ($S' ($S' ($S' $C))
\ No newline at end of file
--- /dev/null
+++ b/ghc/Data/Ordering_Type.hs
@@ -1,0 +1,1 @@
+module Data.Ordering_Type(Ordering(..)) where
--- a/ghc/Primitives.hs
+++ b/ghc/Primitives.hs
@@ -1,19 +1,23 @@
module Primitives(
module Primitives,
+ Any,
Char,
+ Handle,
Int,
- Word,
IO,
- Handle,
+ Word,
+ NFData(..),
) where
+import Control.DeepSeq
import Control.Exception(try)
import Data.Time
import Data.Time.Clock.POSIX
-import Data.Word
+--import Data.Word
import System.IO
import System.IO.Unsafe
import System.Environment
import Unsafe.Coerce
+import GHC.Types(Any)
primIntAdd :: Int -> Int -> Int
primIntAdd = (+)
@@ -81,6 +85,9 @@
primError :: String -> a
primError = error
+primEqString :: String -> String -> Bool
+primEqString = (==)
+
primUnsafeCoerce :: a -> b
primUnsafeCoerce = unsafeCoerce
@@ -134,7 +141,7 @@
primHGetChar h = do eof <- hIsEOF h; if eof then pure (-1) else fromEnum <$> hGetChar h
primOpenFile :: String -> Int -> IO Handle
primOpenFile s m = do
- r <- (try $ openFile s (case m of 0->ReadMode; 1->WriteMode; 2->AppendMode; 3->ReadWriteMode)) :: IO (Either IOError Handle)
+ r <- (try $ openFile s (case m of 0->ReadMode; 1->WriteMode; 2->AppendMode; 3->ReadWriteMode; _->undefined)) :: IO (Either IOError Handle)
-- A gruesome hack to signal a failed as a Handle
case r of
Left _ -> return $ unsafeCoerce (0 :: Int)
@@ -141,12 +148,21 @@
Right h -> return h
primIsNullHandle :: Handle -> Bool
primIsNullHandle h = unsafeCoerce h == (0 :: Int)
+primHSerialize :: Handle -> a -> IO ()
primHSerialize = undefined
+primHDeserialize :: Handle -> IO a
primHDeserialize = undefined
+primHPrint :: Handle -> a -> IO ()
primHPrint = undefined
+primHClose :: Handle -> IO ()
primHClose = hClose
+primHFlush :: Handle -> IO ()
+primHFlush = hFlush
+primStdin :: Handle
primStdin = stdin
+primStdout :: Handle
primStdout = stdout
+primStderr :: Handle
primStderr = stderr
primGetArgs :: IO [[Char]]
primGetArgs = getArgs
@@ -159,3 +175,28 @@
-- Current time (since 1970-01-01T00:00:00UTC) in ms
primGetTimeMilli :: IO Int
primGetTimeMilli = floor . (1000 *) . nominalDiffTimeToSeconds . utcTimeToPOSIXSeconds <$> getCurrentTime
+primGetRaw :: IO Int
+primGetRaw = return (-1) -- not implemented
+
+primCatch :: forall a . IO a -> (String -> IO a) -> IO a
+primCatch = error "primCatch"
+
+-- Temporary until overloading
+primIsInt :: Any -> Bool
+primIsInt = error "primIsInt"
+primIsIO :: Any -> Bool
+primIsIO = error "primIsIO"
+
+{-+primCompare :: String -> String -> Int
+primCompare s t =
+ case compare s t of
+ LT -> -1
+ EQ -> 0
+ GT -> 1
+-}
+primCompare :: String -> String -> Ordering
+primCompare = compare
+
+primRnf :: (NFData a) => a -> ()
+primRnf = rnf
--- /dev/null
+++ b/ghc/System/Console/SimpleReadline.hs
@@ -1,0 +1,4 @@
+module System.Console.SimpleReadline where
+
+getInputLineHist :: FilePath -> String -> IO (Maybe String)
+getInputLineHist _ _ = error "getInputLineHist"
--- /dev/null
+++ b/lib/Control/DeepSeq.hs
@@ -1,0 +1,15 @@
+module Control.DeepSeq(module Control.DeepSeq) where
+import Primitives --Yhiding(rnf)
+import Prelude
+
+rnf :: forall a . --YNFData a =>
+ a -> ()
+rnf = primRnf
+
+deepseq :: forall a b . --YNFData a =>
+ a -> b -> b
+deepseq a b = rnf a `seq` b
+
+force :: forall a . --YNFData a =>
+ a -> a
+force x = rnf x `seq` x
--- /dev/null
+++ b/lib/Control/Exception.hs
@@ -1,0 +1,20 @@
+module Control.Exception(
+ catch, try,
+ throwIO,
+ Exn(..)
+ ) where
+import Primitives
+import Prelude
+
+newtype Exn = Exn String
+
+catch :: forall a . IO a -> (Exn -> IO a) -> IO a
+catch ioa hdl = primCatch ioa (hdl . Exn)
+
+try :: forall a . IO a -> IO (Either Exn a)
+try ioa = catch (fmap Right ioa) (return . Left)
+
+throwIO :: forall a . Exn -> IO a
+throwIO (Exn s) =
+ let e = error s
+ in seq e (return e)
--- a/lib/Control/Monad/State/Strict.hs
+++ b/lib/Control/Monad/State/Strict.hs
@@ -29,7 +29,7 @@
(a, ss) -> (f a, ss)
(<$>) :: forall s a b . (a -> b) -> State s a -> State s b
-(<$>) = fmap
+(<$>) = Control.Monad.State.Strict.fmap
modify :: forall s . (s -> s) -> State s ()
modify f = S $ \ s -> ((), f s)
@@ -68,3 +68,7 @@
fail :: forall s a . String -> State s a
fail = error
+
+when :: forall s . Bool -> State s () -> State s ()
+when True s = s
+when False _ = Control.Monad.State.Strict.return ()
--- a/lib/Data/Bool.hs
+++ b/lib/Data/Bool.hs
@@ -4,14 +4,15 @@
module Data.Bool,
module Data.Bool_Type
) where
+import Primitives
import Data.Bool_Type
---Yinfixr 2 ||
+infixr 2 ||
(||) :: Bool -> Bool -> Bool
(||) False y = y
(||) True _ = True
---Yinfixr 3 &&
+infixr 3 &&
(&&) :: Bool -> Bool -> Bool
(&&) False _ = False
(&&) True y = y
@@ -22,3 +23,11 @@
otherwise :: Bool
otherwise = True
+
+eqBool :: Bool -> Bool -> Bool
+eqBool True x = x
+eqBool False x = not x
+
+neBool :: Bool -> Bool -> Bool
+neBool True x = not x
+neBool False x = x
--- a/lib/Data/Char.hs
+++ b/lib/Data/Char.hs
@@ -1,43 +1,41 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
-module Data.Char(module Data.Char) where
-import qualified Primitives as P
+module Data.Char(module Data.Char, Char) where
+import Primitives
import Data.Bool
import Data.Int
---Ytype Char = P.Char
---Ytype Int = P.Int
type String = [Char]
chr :: Int -> Char
-chr = P.primChr
+chr = primChr
ord :: Char -> Int
-ord = P.primOrd
+ord = primOrd
isLower :: Char -> Bool
-isLower c = (P.primCharLE 'a' c) && (P.primCharLE c 'z')
+isLower c = (primCharLE 'a' c) && (primCharLE c 'z')
isUpper :: Char -> Bool
-isUpper c = (P.primCharLE 'A' c) && (P.primCharLE c 'Z')
+isUpper c = (primCharLE 'A' c) && (primCharLE c 'Z')
isAlpha :: Char -> Bool
isAlpha c = isLower c || isUpper c
isDigit :: Char -> Bool
-isDigit c = (P.primCharLE '0' c) && (P.primCharLE c '9')
+isDigit c = (primCharLE '0' c) && (primCharLE c '9')
isPrint :: Char -> Bool
-isPrint c = P.primCharLE ' ' c && P.primCharLE c '~'
+isPrint c = primCharLE ' ' c && primCharLE c '~'
eqChar :: Char -> Char -> Bool
-eqChar = P.primCharEQ
+eqChar = primCharEQ
neChar :: Char -> Char -> Bool
-neChar = P.primCharNE
+neChar = primCharNE
leChar :: Char -> Char -> Bool
-leChar = P.primCharLE
+leChar = primCharLE
ltChar :: Char -> Char -> Bool
-ltChar = P.primCharLT
+ltChar = primCharLT
--- a/lib/Data/Either.hs
+++ b/lib/Data/Either.hs
@@ -1,6 +1,7 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
module Data.Either(module Data.Either) where
+import Primitives
data Either a b = Left a | Right b
--- a/lib/Data/Function.hs
+++ b/lib/Data/Function.hs
@@ -4,11 +4,11 @@
import Primitives
import Data.Tuple
---Yinfixr 0 $
+infixr 0 $
($) :: forall a b . (a -> b) -> a -> b
($) f x = f x
---Yinfixr 9 .
+infixr 9 .
(.) :: forall a b c . (b -> c) -> (a -> b) -> (a -> c)
(.) f g x = f (g x)
@@ -27,5 +27,6 @@
uncurry :: forall a b c . (a -> b -> c) -> (a, b) -> c
uncurry f ab = f (fst ab) (snd ab)
+infixl 0 `on`
on :: forall a b c . (a -> a -> b) -> (c -> a) -> (c -> c -> b)
on op sel x y = op (sel x) (sel y)
--- a/lib/Data/Int.hs
+++ b/lib/Data/Int.hs
@@ -1,52 +1,50 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
-module Data.Int(module Data.Int) where
+module Data.Int(module Data.Int, Int) where
import Primitives
import Data.Bool_Type
---type Int = Primitives.Int
+infixl 6 +,-
+infixl 7 *,`quot`,`rem`
---Yinfixl 6 +,-
---Yinfixl 7 *
-
-- Arithmetic
-(+) :: {-Data.Int.-}Int -> {-Data.Int.-}Int -> {-Data.Int.-}Int+(+) :: Int -> Int -> Int
(+) = primIntAdd
-(-) :: {-Data.Int.-}Int -> {-Data.Int.-}Int -> {-Data.Int.-}Int+(-) :: Int -> Int -> Int
(-) = primIntSub
-(*) :: {-Data.Int.-}Int -> {-Data.Int.-}Int -> {-Data.Int.-}Int+(*) :: Int -> Int -> Int
(*) = primIntMul
-quot :: {-Data.Int.-}Int -> {-Data.Int.-}Int -> {-Data.Int.-}Int+quot :: Int -> Int -> Int
quot = primIntQuot
-rem :: {-Data.Int.-}Int -> {-Data.Int.-}Int -> {-Data.Int.-}Int+rem :: Int -> Int -> Int
rem = primIntRem
-subtract :: {-Data.Int.-}Int -> {-Data.Int.-}Int -> {-Data.Int.-}Int+subtract :: Int -> Int -> Int
subtract = primIntSubR
-negate :: {-Data.Int.-}Int -> {-Data.Int.-}Int+negate :: Int -> Int
negate x = 0 - x
--------------------------------
---Yinfix 4 ==,/=,<,<=,>,>=
+infix 4 ==,/=,<,<=,>,>=
-- Comparison
-(==) :: {-Data.Int.-}Int -> {-Data.Int.-}Int -> Bool+(==) :: Int -> Int -> Bool
(==) = primIntEQ
-(/=) :: {-Data.Int.-}Int -> {-Data.Int.-}Int -> Bool+(/=) :: Int -> Int -> Bool
(/=) = primIntNE
-(<) :: {-Data.Int.-}Int -> {-Data.Int.-}Int -> Bool+(<) :: Int -> Int -> Bool
(<) = primIntLT
-(<=) :: {-Data.Int.-}Int -> {-Data.Int.-}Int -> Bool+(<=) :: Int -> Int -> Bool
(<=) = primIntLE
-(>) :: {-Data.Int.-}Int -> {-Data.Int.-}Int -> Bool+(>) :: Int -> Int -> Bool
(>) = primIntGT
-(>=) :: {-Data.Int.-}Int -> {-Data.Int.-}Int -> Bool+(>=) :: Int -> Int -> Bool
(>=) = primIntGE
-eqInt :: {-Data.Int.-}Int -> {-Data.Int.-}Int -> Bool+eqInt :: Int -> Int -> Bool
eqInt = (==)
--------------------------------
--- a/lib/Data/IntMap.hs
+++ b/lib/Data/IntMap.hs
@@ -1,6 +1,9 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
-module Data.IntMap(module Data.IntMap) where
+module Data.IntMap(
+ IntMap,
+ empty, lookup, insert, fromList, toList, insertWith, (!), keys
+ ) where
import Prelude --Xhiding(lookup)
data IntMap a
@@ -38,14 +41,49 @@
else lookup d m3
insert :: forall a . Int -> a -> IntMap a -> IntMap a
-insert ak a =
+insert = insertWith const
+
+fromList :: forall a . [(Int, a)] -> IntMap a
+fromList = foldr (uncurry insert) empty
+
+-- XXX There must be a better way
+toList :: forall a . IntMap a -> [(Int, a)]
+toList am =
let
+ f o (k, a) = (k*4 + o, a)
+ in
+ case am of
+ Empty -> []
+ Leaf l a -> [(l, a)]
+ Node m0 m1 m2 m3 ->
+ map (f 0) (toList m0) `merge`
+ map (f 1) (toList m1) `merge`
+ map (f 2) (toList m2) `merge`
+ map (f 3) (toList m3)
+
+merge :: forall a . [(Int, a)] -> [(Int, a)] -> [(Int, a)]
+merge [] ys = ys
+merge xs [] = xs
+merge xxs@(xa@(x,_):xs) yys@(yb@(y,b):ys) = if x < y then xa : merge xs yys else yb : merge xxs ys
+
+keys :: forall a . IntMap a -> [Int]
+keys = map fst . toList
+
+(!) :: forall a . IntMap a -> Int -> a
+(!) m k =
+ case lookup k m of
+ Just i -> i
+ Nothing -> error "Data.IntMap.!"
+
+insertWith :: forall a . (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
+insertWith comb ak a =
+ let
ins k am =
case am of
Empty -> Leaf k a
Leaf i b ->
if k == i then
- Leaf k a
+ Leaf k (comb a b)
else
ins k $ insert i b $ Node Empty Empty Empty Empty
Node m0 m1 m2 m3 ->
@@ -56,20 +94,3 @@
else if m == 2 then Node m0 m1 (ins d m2) m3
else Node m0 m1 m2 (ins d m3)
in ins ak
-
-fromList :: forall a . [(Int, a)] -> IntMap a
-fromList = foldr (uncurry insert) empty
-
-toList :: forall a . IntMap a -> [(Int, a)]
-toList am =
- let
- f o (k, a) = (k*4 + o, a)
- in
- case am of
- Empty -> []
- Leaf l a -> [(l, a)]
- Node m0 m1 m2 m3 ->
- map (f 0) (toList m0) ++
- map (f 1) (toList m1) ++
- map (f 2) (toList m2) ++
- map (f 3) (toList m3)
--- /dev/null
+++ b/lib/Data/IntSet.hs
@@ -1,0 +1,29 @@
+-- Copyright 2023 Lennart Augustsson
+-- See LICENSE file for full license.
+module Data.IntSet(
+ IntSet,
+ empty, member, insert, fromList, toList
+ ) where
+import Prelude
+import qualified Data.IntMap as M
+
+newtype IntSet = I (M.IntMap ())
+
+empty :: IntSet
+empty = I M.empty
+
+member :: Int -> IntSet -> Bool
+member k (I m) =
+ case M.lookup k m of
+ Nothing -> False
+ Just _ -> True
+
+insert :: Int -> IntSet -> IntSet
+insert k (I m) = I (M.insert k () m)
+
+fromList :: [Int] -> IntSet
+fromList is = I (M.fromList (zip is (repeat ())))
+
+toList :: IntSet -> [Int]
+toList (I m) = map fst (M.toList m)
+
--- a/lib/Data/List.hs
+++ b/lib/Data/List.hs
@@ -1,6 +1,7 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
module Data.List(module Data.List) where
+import Primitives as P
import Control.Error
import Data.Bool
import Data.Function
@@ -9,9 +10,11 @@
import Data.Tuple
--Yimport Data.Char
---type Int = P.Int
-data [] a = [] | (:) a [a] -- Parser hacks makes this acceptable --Z
+--Y{-+infixr 5 :
+data [] a = [] | (:) a [a] -- Parser hacks makes this acceptable
+--Y-}
null :: forall a . [a] -> Bool
null [] = True
@@ -60,10 +63,10 @@
foldl1 _ [] = error "foldl1"
foldl1 f (x : xs) = foldl f x xs
-sum :: [Int] -> Int
+sum :: [P.Int] -> P.Int
sum = foldr (+) 0
-product :: [Int] -> Int
+product :: [P.Int] -> P.Int
product = foldr (*) 1
and :: [Bool] -> Bool
@@ -78,7 +81,7 @@
all :: forall a . (a -> Bool) -> [a] -> Bool
all p = and . map p
-take :: forall a . Int -> [a] -> [a]
+take :: forall a . P.Int -> [a] -> [a]
take n arg =
if n <= 0 then
[]
@@ -87,7 +90,7 @@
[] -> []
x : xs -> x : take (n - 1) xs
-drop :: forall a . Int -> [a] -> [a]
+drop :: forall a . P.Int -> [a] -> [a]
drop n arg =
if n <= 0 then
arg
@@ -96,9 +99,15 @@
[] -> []
_ : xs -> drop (n - 1) xs
-length :: forall a . [a] -> Int
-length [] = 0
-length (_:xs) = 1 + length xs
+length :: forall a . [a] -> P.Int
+length =
+ -- Make it tail recursive and strict
+ let
+ rec r [] = r
+ rec r (_:xs) =
+ let r' = r + 1
+ in r' `primSeq` rec r' xs
+ in rec 0
zip :: forall a b . [a] -> [b] -> [(a, b)]
zip = zipWith (\ x y -> (x, y))
@@ -107,6 +116,7 @@
zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys
zipWith _ _ _ = []
+-- XXX not as lazy as it could be
unzip :: forall a b . [(a, b)] -> ([a], [b])
unzip axys =
case axys of
@@ -115,6 +125,7 @@
case unzip xys of
(xs, ys) -> (x:xs, y:ys)
+-- XXX not as lazy as it could be
unzip3 :: forall a b c . [(a, b, c)] -> ([a], [b], [c])
unzip3 axyzs =
case axyzs of
@@ -129,7 +140,12 @@
stripPrefixBy eq (c:cs) (d:ds) | eq c d = stripPrefixBy eq cs ds
| otherwise = Nothing
-splitAt :: forall a . Int -> [a] -> ([a], [a])
+isPrefixOfBy :: forall a . (a -> a -> Bool) -> [a] -> [a] -> Bool
+isPrefixOfBy _ [] _ = True
+isPrefixOfBy _ _ [] = False
+isPrefixOfBy eq (c:cs) (d:ds) = eq c d && isPrefixOfBy eq cs ds
+
+splitAt :: forall a . P.Int -> [a] -> ([a], [a])
splitAt n xs = (take n xs, drop n xs)
reverse :: forall a . [a] -> [a]
@@ -179,12 +195,11 @@
intersperse :: forall a . a -> [a] -> [a]
intersperse _ [] = []
-intersperse sep (x:xs) = x : prependToAll sep xs
+intersperse sep (a:as) = a : prepend as
+ where
+ prepend [] = []
+ prepend (x:xs) = sep : x : prepend xs
-prependToAll :: forall a . a -> [a] -> [a]
-prependToAll _ [] = []
-prependToAll sep (x:xs) = sep : x : prependToAll sep xs
-
intercalate :: forall a . [a] -> [[a]] -> [a]
intercalate xs xss = concat (intersperse xs xss)
@@ -191,12 +206,24 @@
elemBy :: forall a . (a -> a -> Bool) -> a -> [a] -> Bool
elemBy eq a = any (eq a)
-enumFrom :: Int -> [Int]
+enumFrom :: P.Int -> [P.Int]
enumFrom n = n : enumFrom (n+1)
-enumFromTo :: Int -> Int -> [Int]
+enumFromThen :: P.Int -> P.Int -> [P.Int]
+enumFromThen n m = from n
+ where d = m - n
+ from i = i : from (i+d)
+
+enumFromTo :: P.Int -> P.Int -> [P.Int]
enumFromTo l h = takeWhile (<= h) (enumFrom l)
+enumFromThenTo :: P.Int -> P.Int -> P.Int -> [P.Int]
+enumFromThenTo l m h =
+ if m - l > 0 then
+ takeWhile (<= h) (enumFromThen l m)
+ else
+ takeWhile (>= h) (enumFromThen l m)
+
find :: forall a . (a -> Bool) -> [a] -> Maybe a
find p [] = Nothing
find p (x:xs) = if p x then Just x else find p xs
@@ -214,11 +241,15 @@
deleteBy _ _ [] = []
deleteBy eq x (y:ys) = if eq x y then ys else y : deleteBy eq x ys
+deleteAllBy :: forall a . (a -> a -> Bool) -> a -> [a] -> [a]
+deleteAllBy _ _ [] = []
+deleteAllBy eq x (y:ys) = if eq x y then deleteAllBy eq x ys else y : deleteAllBy eq x ys
+
nubBy :: forall a . (a -> a -> Bool) -> [a] -> [a]
nubBy _ [] = []
nubBy eq (x:xs) = x : nubBy eq (filter (\ y -> not (eq x y)) xs)
-replicate :: forall a . Int -> a -> [a]
+replicate :: forall a . P.Int -> a -> [a]
replicate n x = take n (repeat x)
repeat :: forall a . a -> [a]
@@ -230,8 +261,12 @@
deleteFirstsBy :: forall a . (a -> a -> Bool) -> [a] -> [a] -> [a]
deleteFirstsBy eq = foldl (flip (deleteBy eq))
-(!!) :: forall a . Int -> [a] -> a
-(!!) i =
+deleteAllsBy :: forall a . (a -> a -> Bool) -> [a] -> [a] -> [a]
+deleteAllsBy eq = foldl (flip (deleteAllBy eq))
+
+infixl 9 !!
+(!!) :: forall a . [a] -> P.Int -> a
+(!!) axs i =
if i < 0 then
error "!!: <0"
else
@@ -238,7 +273,7 @@
let
nth _ [] = error "!!: empty"
nth n (x:xs) = if n == 0 then x else nth (n - 1) xs
- in nth i
+ in nth i axs
eqList :: forall a . (a -> a -> Bool) -> [a] -> [a] -> Bool
eqList _ [] [] = True
@@ -247,3 +282,26 @@
partition :: forall a . (a -> Bool) -> [a] -> ([a], [a])
partition p xs = (filter p xs, filter (not . p) xs)
+
+-- A simple "quicksort" for now.
+sortLE :: forall a . (a -> a -> Bool) -> [a] -> [a]
+sortLE _ [] = []
+sortLE le (x:xs) =
+ case partition (le x) xs of
+ (ge, lt) -> sortLE le lt ++ (x : sortLE le ge)
+
+mapMaybe :: forall a b . (a -> Maybe b) -> [a] -> [b]
+mapMaybe _ [] = []
+mapMaybe f (a:as) =
+ case f a of
+ Nothing -> mapMaybe f as
+ Just b -> b : mapMaybe f as
+
+maybeToList :: forall a . Maybe a -> [a]
+maybeToList Nothing = []
+maybeToList (Just a) = [a]
+
+last :: forall a . [a] -> a
+last [] = error "last: []"
+last [x] = x
+last (_:xs) = last xs
--- a/lib/Data/Maybe.hs
+++ b/lib/Data/Maybe.hs
@@ -1,6 +1,7 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
module Data.Maybe(module Data.Maybe) where
+import Primitives
data Maybe a = Nothing | Just a
@@ -18,3 +19,8 @@
catMaybes :: forall a . [Maybe a] -> [a]
catMaybes mxs = [ x | Just x <- mxs ]
+
+{-+mapMaybe is in Data.List to avoid recursive modules
+maybeToList is in Data.List to avoid recursive modules
+-}
--- /dev/null
+++ b/lib/Data/Ord.hs
@@ -1,0 +1,18 @@
+module Data.Ord(
+ Ordering(..),
+ eqOrdering,
+ isEQ,
+ ) where
+import Data.Bool_Type
+import Data.Ordering_Type
+import Data.Int
+
+isEQ :: Ordering -> Bool
+isEQ EQ = True
+isEQ _ = False
+
+eqOrdering :: Ordering -> Ordering -> Bool
+eqOrdering LT LT = True
+eqOrdering EQ EQ = True
+eqOrdering GT GT = True
+eqOrdering _ _ = False
--- /dev/null
+++ b/lib/Data/Ordering_Type.hs
@@ -1,0 +1,2 @@
+module Data.Ordering_Type(Ordering(..)) where
+data Ordering = LT | EQ | GT
--- a/lib/Data/Tuple.hs
+++ b/lib/Data/Tuple.hs
@@ -1,10 +1,13 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
-module Data.Tuple(module Data.Tuple) where
+module Data.Tuple(module Data.Tuple
+--Y{-+ , ()(..)
+--Y-}
+ ) where
+import Primitives -- for ()
import Data.Bool
-data () = () -- Parser hacks allows () to be used --Z
-
--data (a,b) = (a,b) -- all tuples are built in
--data (a,b,c) = (a,b,c)
-- etc
@@ -14,9 +17,6 @@
snd :: forall a b . (a, b) -> b
snd (_, b) = b
-
-pair :: forall a b . a -> b -> (a, b)
-pair x y = (x, y)
eqPair :: forall a b . (a -> a -> Bool) -> (b -> b -> Bool) -> (a, b) -> (a, b) -> Bool
eqPair eqa eqb (a1, b1) (a2, b2) = eqa a1 a2 && eqb b1 b2
--- a/lib/Data/Word.hs
+++ b/lib/Data/Word.hs
@@ -1,6 +1,6 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
-module Data.Word(module Data.Word) where
+module Data.Word(module Data.Word, Word) where
import Primitives
import Data.Bool_Type
import qualified Data.Char as C
@@ -8,43 +8,41 @@
import Data.List
import Text.String
---type Word = Primitives.Word
+infixl 6 +,-
+infixl 7 *,`quot`,`rem`
---Yinfixl 6 +,-
---Yinfixl 7 *
-
-- Arithmetic
-(+) :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> {-Data.Word.-}Word+(+) :: Word -> Word -> Word
(+) = primWordAdd
-(-) :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> {-Data.Word.-}Word+(-) :: Word -> Word -> Word
(-) = primWordSub
-(*) :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> {-Data.Word.-}Word+(*) :: Word -> Word -> Word
(*) = primWordMul
-quot :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> {-Data.Word.-}Word+quot :: Word -> Word -> Word
quot = primWordQuot
-rem :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> {-Data.Word.-}Word+rem :: Word -> Word -> Word
rem = primWordRem
--------------------------------
---Yinfix 4 ==,/=,<,<=,>,>=
+infix 4 ==,/=,<,<=,>,>=
-- Comparison
-(==) :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> Bool+(==) :: Word -> Word -> Bool
(==) = primWordEQ
-(/=) :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> Bool+(/=) :: Word -> Word -> Bool
(/=) = primWordNE
-(<) :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> Bool+(<) :: Word -> Word -> Bool
(<) = primWordLT
-(<=) :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> Bool+(<=) :: Word -> Word -> Bool
(<=) = primWordLE
-(>) :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> Bool+(>) :: Word -> Word -> Bool
(>) = primWordGT
-(>=) :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> Bool+(>=) :: Word -> Word -> Bool
(>=) = primWordGE
-eqWord :: {-Data.Word.-}Word -> {-Data.Word.-}Word -> Bool+eqWord :: Word -> Word -> Bool
eqWord = (==)
intToWord :: Int -> Word
--- a/lib/Prelude.hs
+++ b/lib/Prelude.hs
@@ -9,9 +9,11 @@
module Data.Int,
module Data.List,
module Data.Maybe,
+ module Data.Ord,
module Data.Tuple,
module System.IO,
- module Text.String
+ module Text.String,
+ _noMatch,
) where
import Control.Error
import Data.Bool
@@ -21,6 +23,13 @@
import Data.Int
import Data.List
import Data.Maybe
+import Data.Ord
import Data.Tuple
import System.IO
import Text.String
+
+-- Called on pattern match failure.
+_noMatch :: forall a . [Char] -> Int -> Int -> a
+_noMatch fn l c = error $ "no match at " ++
+ if null fn then "no location" else
+ showString fn ++ ": " ++ "line " ++ showInt l ++ ", col " ++ showInt c
--- a/lib/Primitives.hs
+++ b/lib/Primitives.hs
@@ -1,8 +1,20 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
module Primitives(module Primitives) where
---import Data.Bool_Type
+import Data.Bool_Type
+import Data.Ordering_Type
+infixr -1 ->
+
+data Any
+data Char
+data Handle
+data Int
+data IO a
+data Word
+
+data () = () -- Parser hacks allows () to be used
+
primIntAdd :: Int -> Int -> Int
primIntAdd = primitive "+"
primIntSub :: Int -> Int -> Int
@@ -96,6 +108,16 @@
primSeq :: forall a b . a -> b -> b
primSeq = primitive "seq"
+--primEqual :: forall a . a -> a -> Bool
+--primEqual = primitive "equal"
+
+--primCompare :: forall a . a -> a -> Int
+primCompare :: [Char] -> [Char] -> Ordering
+primCompare = primitive "compare"
+
+primEqString :: [Char] -> [Char] -> Bool
+primEqString = primitive "equal"
+
primChr :: Int -> Char
primChr = primitive "I"
primOrd :: Char -> Int
@@ -104,8 +126,6 @@
primUnsafeCoerce :: forall a b . a -> b
primUnsafeCoerce = primitive "I"
---data List a = Nil | (:) a (List a)
-
primBind :: forall a b . IO a -> (a -> IO b) -> IO b
primBind = primitive "IO.>>="
primThen :: forall a b . IO a -> IO b -> IO b
@@ -116,7 +136,7 @@
primHPutChar = primitive "IO.putChar"
primHGetChar :: Handle -> IO Int
primHGetChar = primitive "IO.getChar"
-primOpenFile :: String -> Int -> IO Handle
+primOpenFile :: [Char] -> Int -> IO Handle
primOpenFile = primitive "IO.open"
primIsNullHandle :: Handle -> Bool
primIsNullHandle = primitive "IO.isNullHandle"
@@ -128,6 +148,8 @@
primHDeserialize = primitive "IO.deserialize"
primHClose :: Handle -> IO ()
primHClose = primitive "IO.close"
+primHFlush :: Handle -> IO ()
+primHFlush = primitive "IO.flush"
primStdin :: Handle
primStdin = primitive "IO.stdin"
primStdout :: Handle
@@ -142,6 +164,21 @@
primPerformIO = primitive "IO.performIO"
primGetTimeMilli :: IO Int
primGetTimeMilli = primitive "IO.getTimeMilli"
+primGetRaw :: IO Int
+primGetRaw = primitive "IO.getRaw"
primWithDropArgs :: forall a . Int -> IO a -> IO a
primWithDropArgs i ioa = primThen (primDropArgs i) ioa
+
+-- Use string for the exception until we can do better.
+primCatch :: forall a . IO a -> ([Char] -> IO a) -> IO a
+primCatch = primitive "IO.catch"
+
+primRnf :: forall a . a -> ()
+primRnf = primitive "rnf"
+
+-- Temporary until overloading
+primIsInt :: Any -> Bool
+primIsInt = primitive "isInt"
+primIsIO :: Any -> Bool
+primIsIO = primitive "isIO"
--- a/lib/System/IO.hs
+++ b/lib/System/IO.hs
@@ -1,7 +1,7 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
-module System.IO(module System.IO) where
-import qualified Primitives as P
+module System.IO(module System.IO, Handle, IO) where
+import Primitives
import Control.Error
import Data.Bool
import Data.Char
@@ -10,40 +10,45 @@
import Data.Maybe
import Data.Tuple
---Ytype IO = P.IO
---Ytype Handle = P.Handle
-
type FilePath = String
data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
---Yinfixl 1 >>=
+infixl 1 >>=
(>>=) :: forall a b . IO a -> (a -> IO b) -> IO b
-(>>=) = P.primBind
+(>>=) = primBind
---Yinfixl 1 >>
+infixl 1 >>
(>>) :: forall a b . IO a -> IO b -> IO b
-(>>) = P.primThen
+(>>) = primThen
return :: forall a . a -> IO a
-return = P.primReturn
+return = primReturn
+fail :: forall a . String -> IO a
+fail s = error s
+
+fmap :: forall a b . (a -> b) -> IO a -> IO b
+fmap f ioa = ioa >>= \ a -> return (f a)
+
hSerialize :: forall a . Handle -> a -> IO ()
-hSerialize = P.primHSerialize
+hSerialize = primHSerialize
hDeserialize :: forall a . Handle -> IO a
-hDeserialize = P.primHDeserialize
+hDeserialize = primHDeserialize
hClose :: Handle -> IO ()
-hClose = P.primHClose
+hClose = primHClose
+hFlush :: Handle -> IO ()
+hFlush = primHFlush
stdin :: Handle
-stdin = P.primStdin
+stdin = primStdin
stdout :: Handle
-stdout = P.primStdout
+stdout = primStdout
stderr :: Handle
-stderr = P.primStderr
+stderr = primStderr
hGetChar :: Handle -> IO Char
hGetChar h = do
- c <- P.primHGetChar h
+ c <- primHGetChar h
if c == negate 1 then
error "hGetChar: EOF"
else
@@ -50,7 +55,7 @@
return (chr c)
hPutChar :: Handle -> Char -> IO ()
-hPutChar h c = P.primHPutChar h (ord c)
+hPutChar h c = primHPutChar h (ord c)
openFileM :: FilePath -> IOMode -> IO (Maybe Handle)
openFileM p m = do
@@ -60,8 +65,8 @@
WriteMode -> 1
AppendMode -> 2
ReadWriteMode -> 3
- hdl <- P.primOpenFile p n
- if P.primIsNullHandle hdl then
+ hdl <- primOpenFile p n
+ if primIsNullHandle hdl then
return Nothing
else
return (Just hdl)
@@ -80,7 +85,7 @@
getChar = hGetChar stdin
print :: forall a . a -> IO ()
-print = P.primHPrint stdout
+print = primHPrint stdout
mapM :: forall a b . (a -> IO b) -> [a] -> IO [b]
mapM f =
@@ -133,7 +138,7 @@
-- Lazy hGetContents
hGetContents :: Handle -> IO String
hGetContents h = do
- c <- P.primHGetChar h
+ c <- primHGetChar h
if c == negate 1 then do
hClose h -- EOF, so close the handle
return ""
@@ -141,13 +146,13 @@
cs <- unsafeInterleaveIO (hGetContents h)
return (chr c : cs)
-writeSerialized :: forall a . String -> a -> IO ()
+writeSerialized :: forall a . FilePath -> a -> IO ()
writeSerialized p s = do
h <- openFile p WriteMode
hSerialize h s
hClose h
-readSerialized :: forall a . String -> IO a
+readSerialized :: forall a . FilePath -> IO a
readSerialized p = do
h <- openFile p ReadMode
a <- hDeserialize h
@@ -155,10 +160,10 @@
return a
getTimeMilli :: IO Int
-getTimeMilli = P.primGetTimeMilli
+getTimeMilli = primGetTimeMilli
unsafeInterleaveIO :: forall a . IO a -> IO a
-unsafeInterleaveIO ioa = return (P.primPerformIO ioa)
+unsafeInterleaveIO ioa = return (primPerformIO ioa)
seq :: forall a b . a -> b -> b
-seq = P.primSeq
+seq = primSeq
--- a/lib/Text/String.hs
+++ b/lib/Text/String.hs
@@ -1,51 +1,50 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
module Text.String(module Text.String) where
+import Primitives
import Data.Bool
import Data.Char
import Data.Either
+import Data.Function
import Data.Int
import qualified Data.Double as DD
import Data.List
import Data.Maybe
+import Data.Ord
import Data.Tuple
showChar :: Char -> String
-showChar c =
+showChar c = "'" ++ encodeChar c ++ "'"
+
+encodeChar :: Char -> String
+encodeChar c =
let
- spec = [('\n', "'\\n'"), ('\r', "'\\r'"), ('\t', "'\\t'"),- ('\\', "'\\\\'"), ('\'', "'\\''")]+ spec = [('\n', "\\n"), ('\r', "\\r"), ('\t', "\\t"), ('\b', "\\b"),+ ('\\', "\\\\"), ('\'', "\\'"), ('"', "\"")]in
case lookupBy eqChar c spec of
- Nothing -> if isPrint c then ['\'', c, '\''] else "'\\" ++ showInt (ord c) ++ "'"
+ Nothing -> if isPrint c then [c] else "'\\" ++ showInt (ord c) ++ "'"
Just s -> s
showString :: String -> String
-showString s =
- let
- loop arg =
- case arg of
- [] -> "\""
- c : cs ->
- case ord c == ord '\n' of
- False -> c : loop cs
- True -> '\\' : 'n' : loop cs
- in '"' : loop s
+showString s = "\"" ++ concatMap encodeChar s ++ "\""
-- XXX wrong for minInt
showInt :: Int -> String
showInt n =
- case n < 0 of
- False -> showUnsignedInt n
- True -> '-' : showUnsignedInt (negate n)
+ if n < 0 then
+ '-' : showUnsignedInt (negate n)
+ else
+ showUnsignedInt n
showUnsignedInt :: Int -> String
showUnsignedInt n =
let
c = chr (ord '0' + rem n 10)
- in case n < 10 of
- False -> showUnsignedInt (quot n 10) ++ [c]
- True -> [c]
+ in if n < 10 then
+ [c]
+ else
+ showUnsignedInt (quot n 10) ++ [c]
readInt :: String -> Int
readInt cs =
@@ -70,36 +69,37 @@
(a, b) -> "(" ++ sa a ++ "," ++ sb b ++ ")"showList :: forall a . (a -> String) -> [a] -> String
-showList sa arg =
- let
- showRest as =
- case as of
- [] -> "]"
- x : xs -> "," ++ sa x ++ showRest xs
- in
- case arg of
- [] -> "[]"
- a : as -> "[" ++ sa a ++ showRest as
+showList sa as = "[" ++ intercalate "," (map sa as) ++ "]"
showMaybe :: forall a . (a -> String) -> Maybe a -> String
-showMaybe fa arg =
- case arg of
- Nothing -> "Nothing"
- Just a -> "(Just " ++ fa a ++ ")"
+showMaybe _ Nothing = "Nothing"
+showMaybe fa (Just a) = "(Just " ++ fa a ++ ")"
showEither :: forall a b . (a -> String) -> (b -> String) -> Either a b -> String
-showEither fa fb arg =
- case arg of
- Left a -> "(Left " ++ fa a ++ ")"
- Right b -> "(Right " ++ fb b ++ ")"
+showEither fa _ (Left a) = "(Left " ++ fa a ++ ")"
+showEither _ fb (Right b) = "(Right " ++ fb b ++ ")"
+showOrdering :: Ordering -> String
+showOrdering LT = "LT"
+showOrdering EQ = "EQ"
+showOrdering GT = "GT"
+
+lines :: String -> [String]
+lines "" = []
+lines s =
+ case span (not . eqChar '\n') s of
+ (l, s') -> case s' of { [] -> [l]; _:s'' -> l : lines s'' }+
unlines :: [String] -> String
unlines = concatMap (++ "\n")
unwords :: [String] -> String
-unwords ss = concat (intersperse " " ss)
+unwords ss = intercalate " " ss
+-- Using a primitive for string equality makes a huge speed difference.
eqString :: String -> String -> Bool
+eqString = primEqString
+{-eqString axs ays =
case axs of
[] ->
@@ -110,6 +110,7 @@
case ays of
[] -> False
y:ys -> eqChar x y && eqString xs ys
+-}
leString :: String -> String -> Bool
leString axs ays =
@@ -122,3 +123,34 @@
padLeft :: Int -> String -> String
padLeft n s = replicate (n - length s) ' ' ++ s
+
+forceString :: String -> ()
+forceString [] = ()
+forceString (c:cs) = c `primSeq` forceString cs
+
+{-+compareString :: [Char] -> [Char] -> Ordering
+compareString s t =
+ let
+ r1 = compareString1 s t
+ r2 = compareString2 s t
+ in r2
+ if eqOrdering r1 r2 then r1 else
+ primError $ "compareString " ++ showString s ++ showString t ++ showOrdering r1 ++ showOrdering r2
+
+compareString2 :: [Char] -> [Char] -> Ordering
+compareString2 s t =
+ if leString s t then
+ if eqString s t then
+ EQ
+ else
+ LT
+ else
+ GT
+-}
+
+compareString :: String -> String -> Ordering
+compareString = primCompare
+--compareString s t = if r < 0 then LT else if r > 0 then GT else EQ
+-- where r = primCompare s t
+
--- a/lib/Unsafe/Coerce.hs
+++ b/lib/Unsafe/Coerce.hs
@@ -1,4 +1,4 @@
-module Unsafe.Coerce(module Unsafe.Coerce) where
+module Unsafe.Coerce(module Unsafe.Coerce, Any, primIsInt, primIsIO) where
import Primitives
unsafeCoerce :: forall a b . a -> b
--- a/src/Compat.hs
+++ b/src/Compat.hs
@@ -2,6 +2,7 @@
-- See LICENSE file for full license.
-- Functions for GHC that are defined in the UHS libs.
module Compat(module Compat) where
+--import Control.Exception
import qualified Data.Function as F
import Data.Time
import Data.Time.Clock.POSIX
@@ -10,6 +11,7 @@
import Data.List
import System.Environment
import System.IO
+import GHC.Types(Any)
-- Functions needed for ghc
eqChar :: Char -> Char -> Bool
@@ -111,6 +113,9 @@
(a2, b2) ->
eqa a1 a2 && eqb b1 b2
+showPair :: (a -> String) -> (b -> String) -> (a, b) -> String
+showPair f g (a, b) = "(" ++ f a ++ "," ++ g b ++ ")"+
eqInt :: Int -> Int -> Bool
eqInt = (==)
@@ -145,3 +150,57 @@
withDropArgs i ioa = do
as <- getArgs
withArgs (drop i as) ioa
+
+-- A simple "quicksort" for now.
+sortLE :: forall a . (a -> a -> Bool) -> [a] -> [a]
+sortLE _ [] = []
+sortLE le (x:xs) = sortLE le lt ++ (x : sortLE le ge)
+ where (ge, lt) = partition (le x) xs
+
+deleteAllBy :: forall a . (a -> a -> Bool) -> a -> [a] -> [a]
+deleteAllBy _ _ [] = []
+deleteAllBy eq x (y:ys) = if eq x y then deleteAllBy eq x ys else y : deleteAllBy eq x ys
+
+deleteAllsBy :: forall a . (a -> a -> Bool) -> [a] -> [a] -> [a]
+deleteAllsBy eq = foldl (flip (deleteAllBy eq))
+
+forceString :: String -> ()
+forceString [] = ()
+forceString (c:cs) = c `seq` forceString cs
+
+forceList :: forall a . (a -> ()) -> [a] -> ()
+forceList _ [] = ()
+forceList f (a:as) = case f a of { () -> forceList f as }+
+writeSerialized :: FilePath -> a -> IO ()
+writeSerialized _ _ = error "writeSerialized"
+
+eqBool :: Bool -> Bool -> Bool
+eqBool True x = x
+eqBool False x = not x
+
+neBool :: Bool -> Bool -> Bool
+neBool True x = not x
+neBool False x = x
+
+-- Temporary until overloading
+primIsInt :: Any -> Bool
+primIsInt = error "isInt"
+primIsIO :: Any -> Bool
+primIsIO = error "isIO"
+
+newtype Exn = Exn String
+ deriving (Show)
+instance Exception Exn
+
+isPrefixOfBy :: forall a . (a -> a -> Bool) -> [a] -> [a] -> Bool
+isPrefixOfBy _ [] _ = True
+isPrefixOfBy _ _ [] = False
+isPrefixOfBy eq (c:cs) (d:ds) = eq c d && isPrefixOfBy eq cs ds
+
+isEQ :: Ordering -> Bool
+isEQ EQ = True
+isEQ _ = False
+
+compareString :: String -> String -> Ordering
+compareString = compare
--- a/src/CompatIO.hs
+++ b/src/CompatIO.hs
@@ -14,3 +14,9 @@
when :: Bool -> IO () -> IO ()
when = M.when
+
+fail :: forall a . String -> IO a
+fail s = error s
+
+fmap :: (a -> b) -> IO a -> IO b
+fmap = P.fmap
--- a/src/MicroHs/Compile.hs
+++ b/src/MicroHs/Compile.hs
@@ -1,22 +1,25 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
module MicroHs.Compile(
- compile,
- Flags(..), verbose, runIt, output
+ compileTop,
+ Flags(..), verbose, runIt, output,
+ compileCacheTop,
+ Cache, emptyCache, deleteFromCache,
) where
import Prelude --Xhiding (Monad(..), mapM, showString, showList)
import qualified System.IO as IO
---Ximport Compat
---Ximport qualified CompatIO as IO
---Ximport System.IO(Handle)
-
+import Control.DeepSeq
import qualified MicroHs.IdentMap as M
import MicroHs.StateIO as S
import MicroHs.Desugar
+import MicroHs.Exp
import MicroHs.Expr
import MicroHs.Ident
import MicroHs.Parse
import MicroHs.TypeCheck
+--Ximport Compat
+--Ximport qualified CompatIO as IO
+--Ximport System.IO(Handle)
data Flags = Flags Int Bool [String] String
--Xderiving (Show)
@@ -50,26 +53,41 @@
cache :: Cache -> M.Map CModule
cache (Cache _ x) = x
-{--updCache :: M.Map Module -> Cache -> Cache
-updCache x c =
- case c of
- Cache w _ -> Cache w x
--}
+emptyCache :: Cache
+emptyCache = Cache [] M.empty
+deleteFromCache :: Ident -> Cache -> Cache
+deleteFromCache mn (Cache is m) = Cache is (M.delete mn m)
+
-----------------
-compile :: Flags -> IdentModule -> IO [LDef]
-compile flags nm = IO.do
- ((_, t), ch) <- runStateIO (compileModuleCached flags nm) (Cache [] M.empty)
+compileCacheTop :: Flags -> Ident -> Cache -> IO ([(Ident, Exp)], Cache)
+compileCacheTop flags mn ch = IO.do
+ (ds, ch') <- compile flags mn ch
+ t1 <- getTimeMilli
let
- defs (TModule _ _ _ _ ds) = ds
+ dsn = [ (n, compileOpt e) | (n, e) <- ds ]
+ () <- IO.return (rnf dsn)
+ t2 <- getTimeMilli
IO.when (verbose flags > 0) $
+ putStrLn $ "combinator conversion " ++ padLeft 6 (showInt (t2-t1)) ++ "ms"
+ IO.return (dsn, ch')
+
+--compileTop :: Flags -> IdentModule -> IO [LDef]
+compileTop :: Flags -> Ident -> IO [(Ident, Exp)]
+compileTop flags mn = IO.fmap fst $ compileCacheTop flags mn emptyCache
+
+compile :: Flags -> IdentModule -> Cache -> IO ([LDef], Cache)
+compile flags nm ach = IO.do
+ ((_, t), ch) <- runStateIO (compileModuleCached flags nm) ach
+ let
+ defs (TModule _ _ _ _ _ ds) = ds
+ IO.when (verbose flags > 0) $
putStrLn $ "total import time " ++ padLeft 6 (showInt t) ++ "ms"
- IO.return $ concatMap defs $ M.elems $ cache ch
+ IO.return (concatMap defs $ M.elems $ cache ch, ch)
-- Compile a module with the given name.
--- If the module has already been compiled, return the caches result.
+-- If the module has already been compiled, return the cached result.
compileModuleCached :: Flags -> IdentModule -> StateIO Cache (CModule, Time)
compileModuleCached flags nm = S.do
ch <- gets cache
@@ -83,7 +101,8 @@
liftIO $ putStrLn $ "importing " ++ showIdent nm
(cm, tp, tt, ts) <- compileModule flags nm
S.when (verbose flags > 0) $
- liftIO $ putStrLn $ "importing done " ++ showIdent nm ++ ", " ++ showInt (tp + tt) ++ "ms (" ++ showInt tp ++ " + " ++ showInt tt ++ ")"+ liftIO $ putStrLn $ "importing done " ++ showIdent nm ++ ", " ++ showInt (tp + tt) ++
+ "ms (" ++ showInt tp ++ " + " ++ showInt tt ++ ")"c <- get
put $ Cache (tail (working c)) (M.insert nm cm (cache c))
S.return (cm, tp + tt + ts)
@@ -107,7 +126,7 @@
let
specs = [ s | Import s <- defs ]
t2 <- liftIO getTimeMilli
- (impMdls, ts) <- S.fmap unzip $ S.mapM (compileModuleCached flags) [ m | ImportSpec _ m _ <- specs ]
+ (impMdls, ts) <- S.fmap unzip $ S.mapM (compileModuleCached flags) [ m | ImportSpec _ m _ _ <- specs ]
t3 <- liftIO getTimeMilli
let
tmdl = typeCheck (zip specs impMdls) mdl
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -3,10 +3,9 @@
{-# OPTIONS_GHC -Wno-type-defaults -Wno-incomplete-uni-patterns -Wno-unused-imports -Wno-dodgy-imports #-}module MicroHs.Desugar(
desugar,
- LDef, showLDefs
+ LDef, showLDefs,
) where
---import Debug.Trace
-import Prelude
+import Prelude --Xhiding(showList)
import Data.Char
import Data.List
import Data.Maybe
@@ -18,6 +17,7 @@
import MicroHs.Expr
import MicroHs.Exp
+import MicroHs.Graph
import MicroHs.Ident
import MicroHs.TypeCheck
@@ -26,7 +26,8 @@
desugar :: TModule [EDef] -> TModule [LDef]
desugar atm =
case atm of
- TModule mn tys syns vals ds -> TModule mn tys syns vals (concatMap (dsDef mn) ds)
+ TModule mn fxs tys syns vals ds ->
+ TModule mn fxs tys syns vals $ checkDup $ concatMap (dsDef mn) ds
dsDef :: IdentModule -> EDef -> [LDef]
dsDef mn adef =
@@ -42,32 +43,37 @@
in zipWith dsConstr (enumFrom 0) cs
Newtype _ c _ -> [ (qualIdent mn c, Lit (LPrim "I")) ]
Type _ _ -> []
- Fcn f eqns -> [(f, dsEqns eqns)]
+ Fcn f eqns -> [(f, dsEqns (getSLocIdent f) eqns)]
Sign _ _ -> []
Import _ -> []
+ ForImp ie i _ -> [(i, Lit $ LForImp ie)]
+ Infix _ _ -> []
oneAlt :: Expr -> EAlts
oneAlt e = EAlts [([], e)] []
-dsBind :: EBind -> [LDef]
-dsBind abind =
+dsBind :: Ident -> EBind -> [LDef]
+dsBind v abind =
case abind of
- BFcn f eqns -> [(f, dsEqns eqns)]
+ BFcn f eqns -> [(f, dsEqns (getSLocIdent f) eqns)]
BPat p e ->
let
- v = newVar (allVarsBind abind)
de = (v, dsExpr e)
ds = [ (i, dsExpr (ECase (EVar v) [(p, oneAlt $ EVar i)])) | i <- patVars p ]
in de : ds
+ BSign _ _ -> []
-dsEqns :: [Eqn] -> Exp
-dsEqns eqns =
+dsEqns :: SLoc -> [Eqn] -> Exp
+dsEqns loc eqns =
case eqns of
Eqn aps _ : _ ->
let
vs = allVarsBind $ BFcn (mkIdent "") eqns
- xs = take (length aps) $ newVars vs
- ex = runS (vs ++ xs) (map Var xs) [(map dsPat ps, dsAlts alts, hasGuards alts) | Eqn ps alts <- eqns]
+ xs = take (length aps) $ newVars "q" vs
+ mkArm (Eqn ps alts) =
+ let ps' = map dsPat ps
+ in (ps', dsAlts alts, hasGuards alts || any hasLit ps')
+ ex = runS loc (vs ++ xs) (map Var xs) (map mkArm eqns)
in foldr Lam ex xs
_ -> impossible
@@ -75,6 +81,14 @@
hasGuards (EAlts [([], _)] _) = False
hasGuards _ = True
+hasLit :: EPat -> Bool
+hasLit (ELit _ _) = True
+hasLit (EVar _) = False
+hasLit (ECon _) = False
+hasLit (EApp f a) = hasLit f || hasLit a
+hasLit (EAt _ p) = hasLit p
+hasLit _ = impossible
+
dsAlts :: EAlts -> (Exp -> Exp)
dsAlts (EAlts alts bs) = dsBinds bs . dsAltsL alts
@@ -95,80 +109,83 @@
dsAlt dflt (SLet bs : ss) rhs = ELet bs (dsAlt dflt ss rhs)
dsBinds :: [EBind] -> Exp -> Exp
+dsBinds [] ret = ret
dsBinds ads ret =
- case ads of
- [] -> ret
- d:ds ->
- let
- dsd = dsBind d
- de = dsBinds ds ret
- def ir a =
- case ir of
- (i, r) -> App (Lam i a) (App (Lit (LPrim "Y")) (Lam i r))
- in foldr def de dsd
+ let
+ avs = concatMap allVarsBind ads
+ pvs = newVars "p" avs
+ mvs = newVars "m" avs
+ ds = concat $ zipWith dsBind pvs ads
+ node ie@(i, e) = (ie, i, freeVars e)
+ gr = map node $ checkDup ds
+ asccs = stronglyConnComp leIdent gr
+ loop _ [] = ret
+ loop vs (AcyclicSCC (i, e) : sccs) =
+ letE i e $ loop vs sccs
+ loop vs (CyclicSCC [(i, e)] : sccs) =
+ letRecE i e $ loop vs sccs
+ loop vvs (CyclicSCC ies : sccs) =
+ let (v:vs) = vvs
+ in mutualRec v ies (loop vs sccs)
+ in loop mvs asccs
+letE :: Ident -> Exp -> Exp -> Exp
+letE i e b = App (Lam i b) e
+
+letRecE :: Ident -> Exp -> Exp -> Exp
+letRecE i e b = letE i (App (Lit (LPrim "Y")) (Lam i e)) b
+
+-- Do mutual recursion by tupling up all the definitions.
+-- let f = ... g ...
+-- g = ... f ...
+-- in body
+-- turns into
+-- letrec v =
+-- let f = sel_0_2 v
+-- g = sel_1_2 v
+-- in (... g ..., ... f ...)
+-- in
+-- let f = sel_0_2 v
+-- g = sel_1_2 v
+-- in body
+mutualRec :: Ident -> [LDef] -> Exp -> Exp
+mutualRec v ies body =
+ let (is, es) = unzip ies
+ n = length is
+ ev = Var v
+ one m i = letE i (mkTupleSel m n ev)
+ bnds = foldr (.) id $ zipWith one [0..] is
+ in letRecE v (bnds $ mkTuple es) $
+ bnds body
+
dsExpr :: Expr -> Exp
dsExpr aexpr =
case aexpr of
EVar i -> Var i
EApp f a -> App (dsExpr f) (dsExpr a)
- ELam xs e -> dsLam xs e
+ ELam xs e -> dsLam (getSLocExpr aexpr) xs e
ELit _ (LChar c) -> Lit (LInt (ord c))
--- ELit _ (LStr cs) -> dsExpr $ EList $ map (ELit . LChar) cs
ELit _ l -> Lit l
- ECase e as -> dsCase e as
--- For now, just sequential bindings; each recursive
+ ECase e as -> dsCase (getSLocExpr aexpr) e as
ELet ads e -> dsBinds ads (dsExpr e)
- EList es -> foldr (app2 cCons) cNil $ map dsExpr es
ETuple es -> Lam (mkIdent "$f") $ foldl App (Var $ mkIdent "$f") $ map dsExpr es
- EDo mn astmts ->
- case astmts of
- [] -> error "empty do"
- stmt : stmts ->
- case stmt of
- SBind p e ->
- if null stmts then errorMessage (getSLocExpr aexpr) "do without final expression"
- else
--- case p of
--- EVar v -> dsExpr $ EApp (EApp (EVar (mqual mn (mkIdent ">>="))) e) (ELam [v] $ EDo mn stmts)
--- _ ->
- let
- nv = newVar (allVarsExpr aexpr)
- body = ECase (EVar nv) [(p, oneAlt $ EDo mn stmts), (EVar dummyIdent, oneAlt $ eError "dopat")]
- res = dsExpr $ EApp (EApp (EVar (mqual mn (mkIdent ">>="))) e) (ELam [EVar nv] body)
- in res
-
- SThen e ->
- if null stmts then
- dsExpr e
- else
- dsExpr $ EApp (EApp (EVar (mqual mn (mkIdent ">>"))) e) (EDo mn stmts)
- SLet ds ->
- dsExpr $ ELet ds (EDo mn stmts)
-
- ESectL e op ->
- App (dsExpr (EVar op)) (dsExpr e)
- ESectR op e ->
- app2 cFlip (dsExpr (EVar op)) (dsExpr e)
EIf e1 e2 e3 ->
app2 (dsExpr e1) (dsExpr e3) (dsExpr e2)
- ECompr e astmts ->
+ EListish (LList es) -> foldr (app2 cCons) cNil $ map dsExpr es
+ EListish (LCompr e astmts) ->
case astmts of
- [] -> dsExpr (EList [e])
+ [] -> dsExpr (EListish (LList [e]))
stmt : stmts ->
case stmt of
SBind p b ->
let
nv = newVar (allVarsExpr aexpr)
- body = ECase (EVar nv) [(p, oneAlt $ ECompr e stmts), (EVar dummyIdent, oneAlt $ EList [])]
+ body = ECase (EVar nv) [(p, oneAlt $ EListish (LCompr e stmts)), (EVar dummyIdent, oneAlt $ EListish (LList []))]
in app2 (Var (mkIdent "Data.List.concatMap")) (dsExpr (ELam [EVar nv] body)) (dsExpr b)
SThen c ->
- dsExpr (EIf c (ECompr e stmts) (EList []))
+ dsExpr (EIf c (EListish (LCompr e stmts)) (EListish (LList [])))
SLet ds ->
- dsExpr (ELet ds (ECompr e stmts))
- ESign e _ -> dsExpr e
- EAt _ _ -> undefined
- EUVar _ -> undefined
+ dsExpr (ELet ds (EListish (LCompr e stmts)))
ECon c ->
let
ci = conIdent c
@@ -176,25 +193,32 @@
if eqChar (head $ unIdent ci) ',' then
let
xs = [mkIdent ("x" ++ showInt i) | i <- enumFromTo 1 (untupleConstr ci) ]- body = Lam (mkIdent "$f") $ foldl App (Var (mkIdent "$f")) $ map Var xs
+ body = mkTuple $ map Var xs
in foldr Lam body xs
else
Var (conIdent c)
+ _ -> impossible
-dsLam :: [EPat] -> Expr -> Exp
-dsLam ps e =
+-- Use tuple encoding to make a tuple
+mkTuple :: [Exp] -> Exp
+mkTuple = Lam (mkIdent "$f") . foldl App (Var (mkIdent "$f"))
+
+-- Select component m from an n-tuple
+mkTupleSel :: Int -> Int -> Exp -> Exp
+mkTupleSel m n tup =
let
+ xs = [mkIdent ("x" ++ showInt i) | i <- enumFromTo 1 n ]+ in App tup (foldr Lam (Var (xs !! m)) xs)
+
+dsLam :: SLoc -> [EPat] -> Expr -> Exp
+dsLam loc ps e =
+ let
vs = allVarsExpr (ELam ps e)
- xs = take (length ps) (newVars vs)
- ex = runS (vs ++ xs) (map Var xs) [(map dsPat ps, dsAlts $ oneAlt e, False)]
+ xs = take (length ps) (newVars "l" vs)
+ ps' = map dsPat ps
+ ex = runS loc (vs ++ xs) (map Var xs) [(ps', dsAlts $ oneAlt e, any hasLit ps')]
in foldr Lam ex xs
-mqual :: Maybe Ident -> Ident -> Ident
-mqual mqi i =
- case mqi of
- Just qi -> qualIdent qi i
- Nothing -> i
-
-- Handle special syntax for lists and tuples
dsPat :: --XHasCallStack =>
EPat -> EPat
@@ -203,9 +227,10 @@
EVar _ -> ap
ECon _ -> ap
EApp f a -> EApp (dsPat f) (dsPat a)
- EList ps -> dsPat $ foldr (\ x xs -> EApp (EApp consCon x) xs) nilCon ps
- ETuple ps -> dsPat $ foldl EApp (tupleCon (length ps)) ps
+ EListish (LList ps) -> dsPat $ foldr (\ x xs -> EApp (EApp consCon x) xs) nilCon ps
+ ETuple ps -> dsPat $ foldl EApp (tupleCon (getSLocExpr ap) (length ps)) ps
EAt i p -> EAt i (dsPat p)
+ ELit loc (LStr cs) | length cs < 2 -> dsPat (EListish (LList (map (ELit loc . LChar) cs)))
ELit _ _ -> ap
_ -> impossible
@@ -223,18 +248,15 @@
c = mkIdent "Data.List.:"
in ECon $ ConData [(n, 0), (c, 2)] n
-tupleCon :: Int -> EPat
-tupleCon n =
+tupleCon :: SLoc -> Int -> EPat
+tupleCon loc n =
let
- c = tupleConstr n
+ c = tupleConstr loc n
in ECon $ ConData [(c, n)] c
dummyIdent :: Ident
dummyIdent = mkIdent "_"
-eError :: String -> Expr
-eError s = EApp (ELit noSLoc (LPrim "error")) (ELit noSLoc $ LStr s)
-
lams :: [Ident] -> Exp -> Exp
lams xs e = foldr Lam e xs
@@ -241,11 +263,11 @@
apps :: Exp -> [Exp] -> Exp
apps f = foldl App f
-newVars :: [Ident] -> [Ident]
-newVars is = deleteFirstsBy eqIdent [ mkIdent ("q" ++ showInt i) | i <- enumFrom 1 ] is+newVars :: String -> [Ident] -> [Ident]
+newVars s is = deleteAllsBy eqIdent [ mkIdent (s ++ showInt i) | i <- enumFrom 1 ] is
newVar :: [Ident] -> Ident
-newVar = head . newVars
+newVar = head . newVars "q"
showLDefs :: [LDef] -> String
showLDefs = unlines . map showLDef
@@ -257,12 +279,13 @@
----------------
-dsCase :: Expr -> [ECaseArm] -> Exp
-dsCase ae as =
- let
- r = runS (allVarsExpr (ECase ae as)) [dsExpr ae] [([dsPat p], dsAlts alts, hasGuards alts) | (p, alts) <- as]
- in --trace (showExp r) $
- r
+dsCase :: SLoc -> Expr -> [ECaseArm] -> Exp
+dsCase loc ae as =
+ runS loc (allVarsExpr (ECase ae as)) [dsExpr ae] (map mkArm as)
+ where
+ mkArm (p, alts) =
+ let p' = dsPat p
+ in ([p'], dsAlts alts, hasGuards alts || hasLit p')
type MState = [Ident] -- supply of unused variables.
@@ -270,6 +293,9 @@
type Arm = ([EPat], Exp -> Exp, Bool) -- boolean indicates that the arm has guards
type Matrix = [Arm]
+--showArm :: Arm -> String
+--showArm (ps, _, b) = showList showExpr ps ++ "," ++ showBool b
+
newIdents :: Int -> M [Ident]
newIdents n = S.do
is <- get
@@ -282,16 +308,13 @@
put (tail is)
S.return (head is)
-runS :: [Ident] -> [Exp] -> Matrix -> Exp
-runS used ss mtrx =
- --trace ("runS " ++ show (ss, mtrx)) $+runS :: SLoc -> [Ident] -> [Exp] -> Matrix -> Exp
+runS loc used ss mtrx =
let
- supply = deleteFirstsBy eqIdent [ mkIdent ("x" ++ showInt i) | i <- enumFrom 1 ] used--- ds :: [Exp] -> [Exp] -> M Exp
+ supply = newVars "x" used
ds xs aes =
case aes of
- [] -> --letBind (S.return eMatchErr) $ \ d ->
- dsMatrix eMatchErr (reverse xs) mtrx
+ [] -> dsMatrix (eMatchErr loc) (reverse xs) mtrx
e:es -> letBind (S.return e) $ \ x -> ds (x:xs) es
in S.evalState (ds [] ss) supply
@@ -345,10 +368,11 @@
narms <- S.mapM oneGroup grps
S.return $ mkCase i narms ndflt
-eMatchErr :: Exp
-eMatchErr = App (Lit (LPrim "error")) (Lit (LStr "no match"))
+eMatchErr :: SLoc -> Exp
+eMatchErr (SLoc fn l c) =
+ App (App (App (Var (mkIdent "Prelude._noMatch")) (Lit (LStr fn))) (Lit (LInt l))) (Lit (LInt c))
--- If the first expression isn't a variable, the use
+-- If the first expression isn't a variable/literal, then use
-- a let binding and pass variable to f.
letBind :: M Exp -> (Exp -> M Exp) -> M Exp
letBind me f = S.do
@@ -365,7 +389,6 @@
case ae of
Var _ -> True
Lit _ -> True
--- App (Lit _) _ -> True
_ -> False
-- Could use Prim "==", but that misses out some optimizations
@@ -376,7 +399,8 @@
eEqChar = Var $ mkIdent "Data.Char.eqChar"
eEqStr :: Exp
-eEqStr = Var $ mkIdent "Text.String.eqString"
+eEqStr = --Var $ mkIdent "Text.String.eqString"
+ Lit (LPrim "equal")
mkCase :: Exp -> [(SPat, Exp)] -> Exp -> Exp
mkCase var pes dflt =
@@ -420,13 +444,12 @@
loop xs [] = (reverse xs, [])
loop xs pps@(pg@(p:_, _, g) : rps) | not (isPVar p) = (reverse xs, pps)
| otherwise = if g then (reverse (pg:xs), rps)
- else loop (pg:xs) rps
+ else loop (pg:xs) rps
loop _ _ = impossible
(ds, rs) = loop [] nps
in (ps, ds, rs)
-- Change from x to y inside e.
--- XXX Doing it at runtime.
substAlpha :: Ident -> Exp -> Exp -> Exp
substAlpha x y e =
if eqIdent x dummyIdent then
@@ -444,7 +467,7 @@
_ ->
case filter (eqIdent i) (freeVars b) of
[] -> b -- no occurences, no need to bind
- [_] -> substExp i e b -- single occurrence, substitute XXX coule be worse if under lambda
+ [_] -> substExp i e b -- single occurrence, substitute XXX could be worse if under lambda
_ -> App (Lam i b) e -- just use a beta redex
pConOf :: --XHasCallStack =>
@@ -471,6 +494,16 @@
case axs of
[] -> []
x:xs ->
- let
- (es, ns) = partition (eq x) xs
- in (x:es) : groupEq eq ns
+ case partition (eq x) xs of
+ (es, ns) -> (x:es) : groupEq eq ns
+
+getDups :: forall a . (a -> a -> Bool) -> [a] -> [[a]]
+getDups eq = filter ((> 1) . length) . groupEq eq
+
+checkDup :: [LDef] -> [LDef]
+checkDup ds =
+ case getDups eqIdent (filter (not . eqIdent dummyIdent) $ map fst ds) of
+ [] -> ds
+ (i1:i2:_) : _ ->
+ errorMessage (getSLocIdent i1) $ "Duplicate " ++ showIdent i1 ++ " " ++ showSLoc (getSLocIdent i2)
+ _ -> error "checkDup"
--- a/src/MicroHs/Exp.hs
+++ b/src/MicroHs/Exp.hs
@@ -1,20 +1,23 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
module MicroHs.Exp(
compileOpt,
substExp,
- Exp(..), showExp, toStringP,
+ Exp(..), showExp, eqExp, toStringP,
PrimOp,
encodeString,
app2, cCons, cNil, cFlip,
- allVarsExp, freeVars
+ allVarsExp, freeVars,
) where
import Prelude
import Data.Char
import Data.List
import MicroHs.Ident
-import MicroHs.Expr --X(Lit(..), showLit)
+import MicroHs.Expr(Lit(..), showLit, eqLit)
+--Ximport Control.DeepSeq
--Ximport Compat
+--Yimport Primitives(NFData(..))
--import Debug.Trace
type PrimOp = String
@@ -26,6 +29,15 @@
| Lit Lit
--Xderiving (Show, Eq)
+--Winstance NFData Exp where rnf (Var i) = rnf i; rnf (App f a) = rnf f `seq` rnf a; rnf (Lam i e) = rnf i `seq` rnf e; rnf (Lit l) = rnf l
+
+eqExp :: Exp -> Exp -> Bool
+eqExp (Var i1) (Var i2) = eqIdent i1 i2
+eqExp (App f1 a1) (App f2 a2) = eqExp f1 f2 && eqExp a1 a2
+eqExp (Lam i1 e1) (Lam i2 e2) = eqIdent i1 i2 && eqExp e1 e2
+eqExp (Lit l1) (Lit l2) = eqLit l1 l2
+eqExp _ _ = False
+
data MaybeApp = NotApp | IsApp Exp Exp
getApp :: Exp -> MaybeApp
@@ -117,19 +129,21 @@
_ -> False
-}
-toStringP :: Exp -> String
+-- Avoid quadratic concatenation by using difference lists,
+-- turning concatenation into function composition.
+toStringP :: Exp -> (String -> String)
toStringP ae =
case ae of
- Var x -> showIdent x
+ Var x -> (showIdent x ++)
Lit (LStr s) ->
-- Encode very short string directly as combinators.
if length s > 1 then
- quoteString s
+ (quoteString s ++)
else
toStringP (encodeString s)
- Lit l -> showLit l
- Lam x e -> "(\\" ++ showIdent x ++ " " ++ toStringP e ++ ")"
- App f a -> "(" ++ toStringP f ++ " " ++ toStringP a ++ ")"+ Lit l -> (showLit l ++)
+ Lam x e -> (("(\\" ++ showIdent x ++ " ") ++) . toStringP e . (")" ++)+ App f a -> ("(" ++) . toStringP f . (" " ++) . toStringP a . (")" ++)quoteString :: String -> String
quoteString s =
@@ -408,9 +422,7 @@
let
fe = allVarsExp e
ase = allVarsExp se
- j = --head $ deleteFirstsBy eqIdent ["a" ++ showInt n | n <- enumFrom 0] (freeVars se ++ freeVars e)
- --head [ v | n <- enumFrom 0, let { v = "a" ++ showInt n }, not (elemBy eqIdent v fse), not (elemBy eqIdent v fe) ]- head [ v | n <- enumFrom 0, let { v = mkIdent ("a" ++ showInt n) }, not (elemBy eqIdent v ase), not (elemBy eqIdent v fe) ]+ j = head [ v | n <- enumFrom 0, let { v = mkIdent ("a" ++ showInt n) }, not (elemBy eqIdent v ase), not (elemBy eqIdent v fe) ]in
--trace ("substExp " ++ unwords [si, i, j]) $Lam j (substExp si se (substExp i (Var j) e))
@@ -423,7 +435,7 @@
case ae of
Var i -> [i]
App f a -> freeVars f ++ freeVars a
- Lam i e -> deleteBy eqIdent i (freeVars e)
+ Lam i e -> deleteAllBy eqIdent i (freeVars e)
Lit _ -> []
allVarsExp :: Exp -> [Ident]
@@ -457,3 +469,18 @@
--
-- B' :: (a -> b -> c) -> a -> (d -> b) -> d -> c
-- B' k f g x = k f (g x)
+--
+-- Common:
+-- 817: C' B
+-- 616: B BK
+-- 531: C' C
+-- 352: BK K
+-- 305: C' S
+--
+-- BBK = B BK
+-- BBK x y z w = B BK x y z w = BK (x y) z w = x y z
+--
+-- C'C = C' C
+-- C'C x y z w = C' C x y z w = C (x z) y w = x z w y
+
+
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -1,11 +1,13 @@
module MicroHs.Expr(
IdentModule,
EModule(..),
- ExportSpec(..),
+ ExportItem(..),
ImportSpec(..),
+ ImportItem(..),
EDef(..), showEDefs,
Expr(..), showExpr,
- Lit(..), showLit,
+ Listish(..),
+ Lit(..), showLit, eqLit,
EBind(..),
Eqn(..),
EStmt(..),
@@ -12,7 +14,8 @@
EAlts(..),
EAlt,
ECaseArm,
- EType,
+ EType, showEType,
+ ETypeScheme,
EPat, patVars, isPVar, isPConApp,
EKind, kType,
IdKind(..), idKindIdent,
@@ -19,29 +22,31 @@
LHS,
Constr,
ConTyInfo,
- ETypeScheme(..),
Con(..), conIdent, conArity, eqCon,
tupleConstr, untupleConstr,
subst,
allVarsExpr, allVarsBind,
- getSLocExpr,
- errorMessage
+ getSLocExpr, setSLocExpr,
+ errorMessage,
+ Assoc(..), eqAssoc, Fixity
) where
import Prelude --Xhiding (Monad(..), Applicative(..), MonadFail(..), Functor(..), (<$>), showString, showChar, showList)
import Data.List
import Data.Maybe
+import MicroHs.Ident
--Ximport Compat
--Ximport GHC.Stack
-import MicroHs.Ident
+--Ximport Control.DeepSeq
+--Yimport Primitives(NFData(..))
type IdentModule = Ident
----------------------
-data EModule = EModule IdentModule [ExportSpec] [EDef]
+data EModule = EModule IdentModule [ExportItem] [EDef]
--Xderiving (Show, Eq)
-data ExportSpec
+data ExportItem
= ExpModule IdentModule
| ExpTypeCon Ident
| ExpType Ident
@@ -53,27 +58,35 @@
| Newtype LHS Ident EType
| Type LHS EType
| Fcn Ident [Eqn]
- | Sign Ident ETypeScheme
+ | Sign Ident EType
| Import ImportSpec
+ | ForImp String Ident EType
+ | Infix Fixity [Ident]
--Xderiving (Show, Eq)
-data ImportSpec = ImportSpec Bool Ident (Maybe Ident)
+data ImportSpec = ImportSpec Bool Ident (Maybe Ident) (Maybe (Bool, [ImportItem])) -- first Bool indicates 'qualified', second 'hiding'
--Xderiving (Show, Eq)
+data ImportItem
+ = ImpTypeCon Ident
+ | ImpType Ident
+ | ImpValue Ident
+ --Xderiving (Show, Eq)
+
data Expr
= EVar Ident
| EApp Expr Expr
+ | EOper Expr [(Ident, Expr)]
| ELam [EPat] Expr
| ELit SLoc Lit
| ECase Expr [ECaseArm]
| ELet [EBind] Expr
| ETuple [Expr]
- | EList [Expr]
+ | EListish Listish
| EDo (Maybe Ident) [EStmt]
| ESectL Expr Ident
| ESectR Ident Expr
| EIf Expr Expr Expr
- | ECompr Expr [EStmt]
| ESign Expr EType
| EAt Ident Expr -- only in patterns
-- Only while type checking
@@ -80,6 +93,7 @@
| EUVar Int
-- Constructors after type checking
| ECon Con
+ | EForall [IdKind] Expr -- only in types
--Xderiving (Show, Eq)
data Con
@@ -89,17 +103,25 @@
-- | ConTup Int
--Xderiving(Show, Eq)
+data Listish
+ = LList [Expr]
+ | LCompr Expr [EStmt]
+ | LFrom Expr
+ | LFromTo Expr Expr
+ | LFromThen Expr Expr
+ | LFromThenTo Expr Expr Expr
+ --Xderiving(Show, Eq)
+
conIdent :: --XHasCallStack =>
Con -> Ident
conIdent (ConData _ i) = i
conIdent (ConNew i) = i
-conIdent _ = undefined
+conIdent _ = error "conIdent"
conArity :: Con -> Int
-conArity (ConData cs i) = fromMaybe undefined $ lookupBy eqIdent i cs
+conArity (ConData cs i) = fromMaybe (error "conArity") $ lookupBy eqIdent i cs
conArity (ConNew _) = 1
conArity (ConLit _) = 0
---conArity (ConTup n) = n
eqCon :: Con -> Con -> Bool
eqCon (ConData _ i) (ConData _ j) = eqIdent i j
@@ -107,8 +129,15 @@
eqCon (ConLit l) (ConLit k) = eqLit l k
eqCon _ _ = False
-data Lit = LInt Int | LDouble Double | LChar Char | LStr String | LPrim String
+data Lit
+ = LInt Int
+ | LDouble Double
+ | LChar Char
+ | LStr String
+ | LPrim String
+ | LForImp String
--Xderiving (Show, Eq)
+--Winstance NFData Lit where rnf (LInt i) = rnf i; rnf (LChar c) = rnf c; rnf (LStr s) = rnf s; rnf (LPrim s) = rnf s; rnf (LForImp s) = rnf s
eqLit :: Lit -> Lit -> Bool
eqLit (LInt x) (LInt y) = x == y
@@ -115,6 +144,7 @@
eqLit (LChar x) (LChar y) = eqChar x y
eqLit (LStr x) (LStr y) = eqString x y
eqLit (LPrim x) (LPrim y) = eqString x y
+eqLit (LForImp x) (LForImp y) = eqString x y
eqLit _ _ = False
type ECaseArm = (EPat, EAlts)
@@ -122,7 +152,7 @@
data EStmt = SBind EPat Expr | SThen Expr | SLet [EBind]
--Xderiving (Show, Eq)
-data EBind = BFcn Ident [Eqn] | BPat EPat Expr
+data EBind = BFcn Ident [Eqn] | BPat EPat Expr | BSign Ident EType
--Xderiving (Show, Eq)
-- A single equation for a function
@@ -158,20 +188,9 @@
-- * before desugaring: EApp, EVar, ETuple, EList
type EType = Expr
-{--validType :: Expr -> Bool
-validType ae =
- case ae of
- EVar _ -> True
- EApp f a -> validType f && validType a
- EList es -> length es <= 1 && all validType (take 1 es)
- ETuple es -> all validType es
- _ -> False
--}
+-- A type starting with an EForall
+type ETypeScheme = EType
-data ETypeScheme = ETypeScheme [IdKind] EType
- --Xderiving (Show, Eq)
-
data IdKind = IdKind Ident EKind
--Xderiving (Show, Eq)
@@ -183,8 +202,8 @@
kType :: EKind
kType = EVar (Ident noSLoc "Primitives.Type")
-tupleConstr :: Int -> Ident
-tupleConstr n = mkIdent (replicate (n - 1) ',')
+tupleConstr :: SLoc -> Int -> Ident
+tupleConstr loc n = mkIdentSLoc loc (replicate (n - 1) ',')
untupleConstr :: Ident -> Int
untupleConstr i = length (unIdent i) + 1
@@ -191,6 +210,19 @@
---------------------------------
+data Assoc = AssocLeft | AssocRight | AssocNone
+ --Xderiving (Eq, Show)
+
+eqAssoc :: Assoc -> Assoc -> Bool
+eqAssoc AssocLeft AssocLeft = True
+eqAssoc AssocRight AssocRight = True
+eqAssoc AssocNone AssocNone = True
+eqAssoc _ _ = False
+
+type Fixity = (Assoc, Int)
+
+---------------------------------
+
-- Enough to handle subsitution in types
subst :: [(Ident, Expr)] -> Expr -> Expr
subst s =
@@ -204,11 +236,14 @@
_ -> error "subst unimplemented"
in sub
+---------------------------------
+
allVarsBind :: EBind -> [Ident]
allVarsBind abind =
case abind of
BFcn i eqns -> i : concatMap allVarsEqn eqns
BPat p e -> allVarsPat p ++ allVarsExpr e
+ BSign i _ -> [i]
allVarsEqn :: Eqn -> [Ident]
allVarsEqn eqn =
@@ -229,22 +264,32 @@
case aexpr of
EVar i -> [i]
EApp e1 e2 -> allVarsExpr e1 ++ allVarsExpr e2
+ EOper e1 ies -> allVarsExpr e1 ++ concatMap (\ (i,e2) -> i : allVarsExpr e2) ies
ELam ps e -> concatMap allVarsPat ps ++ allVarsExpr e
ELit _ _ -> []
ECase e as -> allVarsExpr e ++ concatMap allVarsCaseArm as
ELet bs e -> concatMap allVarsBind bs ++ allVarsExpr e
ETuple es -> concatMap allVarsExpr es
- EList es -> concatMap allVarsExpr es
+ EListish (LList es) -> concatMap allVarsExpr es
EDo mi ss -> maybe [] (:[]) mi ++ concatMap allVarsStmt ss
ESectL e i -> i : allVarsExpr e
ESectR i e -> i : allVarsExpr e
EIf e1 e2 e3 -> allVarsExpr e1 ++ allVarsExpr e2 ++ allVarsExpr e3
- ECompr e ss -> allVarsExpr e ++ concatMap allVarsStmt ss
+ EListish l -> allVarsListish l
ESign e _ -> allVarsExpr e
EAt i e -> i : allVarsExpr e
EUVar _ -> []
ECon c -> [conIdent c]
+ EForall iks e -> map (\ (IdKind i _) -> i) iks ++ allVarsExpr e
+allVarsListish :: Listish -> [Ident]
+allVarsListish (LList es) = concatMap allVarsExpr es
+allVarsListish (LCompr e ss) = allVarsExpr e ++ concatMap allVarsStmt ss
+allVarsListish (LFrom e) = allVarsExpr e
+allVarsListish (LFromTo e1 e2) = allVarsExpr e1 ++ allVarsExpr e2
+allVarsListish (LFromThen e1 e2) = allVarsExpr e1 ++ allVarsExpr e2
+allVarsListish (LFromThenTo e1 e2 e3) = allVarsExpr e1 ++ allVarsExpr e2 ++ allVarsExpr e3
+
allVarsCaseArm :: ECaseArm -> [Ident]
allVarsCaseArm (p, alts) = allVarsPat p ++ allVarsAlts alts
@@ -255,13 +300,26 @@
SThen e -> allVarsExpr e
SLet bs -> concatMap allVarsBind bs
+-----------------------------
+
-- XXX Should use locations in ELit
getSLocExpr :: Expr -> SLoc
-getSLocExpr e = head $ map getSLocIdent (allVarsExpr e) ++ [noSLoc]
+getSLocExpr e = head $ filter (not . isNoSLoc) (map getSLocIdent (allVarsExpr e)) ++ [noSLoc]
+setSLocExpr :: SLoc -> Expr -> Expr
+setSLocExpr l (EVar i) = EVar (setSLocIdent l i)
+setSLocExpr l (ECon c) = ECon (setSLocCon l c)
+setSLocExpr l (ELit _ k) = ELit l k
+setSLocExpr _ _ = error "setSLocExpr" -- what other cases do we need?
+
+setSLocCon :: SLoc -> Con -> Con
+setSLocCon l (ConData ti i) = ConData ti (setSLocIdent l i)
+setSLocCon l (ConNew i) = ConNew (setSLocIdent l i)
+setSLocCon _ c = c
+
errorMessage :: --XHasCallStack =>
forall a . SLoc -> String -> a
-errorMessage loc msg = error $ showSLoc loc ++ msg
+errorMessage loc msg = error $ showSLoc loc ++ ": " ++ msg
----------------
@@ -270,12 +328,12 @@
showEModule am =
case am of
EModule i es ds -> "module " ++ i ++ "(\n" ++
- unlines (intersperse "," (map showExportSpec es)) ++
+ unlines (intersperse "," (map showExportItem es)) ++
"\n) where\n" ++
showEDefs ds
-showExportSpec :: ExportSpec -> String
-showExportSpec ae =
+showExportItem :: ExportItem -> String
+showExportItem ae =
case ae of
ExpModule i -> "module " ++ i
ExpTypeCon i -> i ++ "(..)"
@@ -283,6 +341,13 @@
ExpValue i -> i
-}
+showImportItem :: ImportItem -> String
+showImportItem ae =
+ case ae of
+ ImpTypeCon i -> showIdent i ++ "(..)"
+ ImpType i -> showIdent i
+ ImpValue i -> showIdent i
+
showEDef :: EDef -> String
showEDef def =
case def of
@@ -290,8 +355,14 @@
Newtype lhs c t -> "newtype " ++ showLHS lhs ++ " = " ++ showIdent c ++ " " ++ showEType t
Type lhs t -> "type " ++ showLHS lhs ++ " = " ++ showEType t
Fcn i eqns -> unlines (map (\ (Eqn ps alts) -> showIdent i ++ " " ++ unwords (map showEPat ps) ++ showAlts "=" alts) eqns)
- Sign i t -> showIdent i ++ " :: " ++ showETypeScheme t
- Import (ImportSpec q m mm) -> "import " ++ (if q then "qualified " else "") ++ showIdent m ++ maybe "" ((" as " ++) . unIdent) mm+ Sign i t -> showIdent i ++ " :: " ++ showEType t
+ Import (ImportSpec q m mm mis) -> "import " ++ (if q then "qualified " else "") ++ showIdent m ++ maybe "" ((" as " ++) . unIdent) mm +++ case mis of
+ Nothing -> ""
+ Just (h, is) -> (if h then " hiding" else "") ++ "(" ++ intercalate ", " (map showImportItem is) ++ ")"+ ForImp ie i t -> "foreign import ccall " ++ showString ie ++ " " ++ showIdent i ++ " :: " ++ showEType t
+ Infix (a, p) is -> "infix" ++ f a ++ " " ++ showInt p ++ " " ++ intercalate ", " (map showIdent is)
+ where f AssocLeft = "l"; f AssocRight = "r"; f AssocNone = ""
showConstr :: Constr -> String
showConstr (i, ts) = unwords (showIdent i : map showEType ts)
@@ -326,29 +397,34 @@
case ae of
EVar v -> showIdent v
EApp _ _ -> showApp [] ae
+ EOper e ies -> showExpr (foldl (\ e1 (i, e2) -> EApp (EApp (EVar i) e1) e2) e ies)
ELam ps e -> "(\\" ++ unwords (map showExpr ps) ++ " -> " ++ showExpr e ++ ")"
ELit _ i -> showLit i
ECase e as -> "case " ++ showExpr e ++ " of {\n" ++ unlines (map showCaseArm as) ++ "}"ELet bs e -> "let\n" ++ unlines (map showEBind bs) ++ "in " ++ showExpr e
ETuple es -> "(" ++ intercalate "," (map showExpr es) ++ ")"- EList es -> showList showExpr es
+ EListish (LList es) -> showList showExpr es
EDo mn ss -> maybe "do" (\ n -> showIdent n ++ ".do\n") mn ++ unlines (map showEStmt ss)
ESectL e i -> "(" ++ showExpr e ++ " " ++ showIdent i ++ ")" ESectR i e -> "(" ++ showIdent i ++ " " ++ showExpr e ++ ")"EIf e1 e2 e3 -> "if " ++ showExpr e1 ++ " then " ++ showExpr e2 ++ " else " ++ showExpr e3
- ECompr _ _ -> "ECompr"
+ EListish l -> showListish l
ESign e t -> showExpr e ++ " :: " ++ showEType t
EAt i e -> showIdent i ++ "@" ++ showExpr e
EUVar i -> "a" ++ showInt i
ECon c -> showCon c
+ EForall iks e -> "forall " ++ unwords (map showIdKind iks) ++ " . " ++ showEType e
where
- showApp as (EApp f a) = showApp (as ++ [a]) f
+ showApp as (EApp f a) = showApp (a:as) f
showApp as (EVar i) | eqString op "->", [a, b] <- as = "(" ++ showExpr a ++ " -> " ++ showExpr b ++ ")"| eqChar (head op) ',' = showExpr (ETuple as)
- | eqString op "[]", length as == 1 = showExpr (EList as)
+ | eqString op "[]", length as == 1 = showExpr (EListish (LList as))
where op = unQualString (unIdent i)
showApp as f = "(" ++ unwords (map showExpr (f:as)) ++ ")"+showListish :: Listish -> String
+showListish _ = "<<Listish>>"
+
showCon :: Con -> String
showCon (ConData _ s) = showIdent s
showCon (ConNew s) = showIdent s
@@ -363,7 +439,8 @@
xs -> 'f':xs
LChar c -> showChar c
LStr s -> showString s
- LPrim s -> '$':s
+ LPrim s -> '$' : s
+ LForImp s -> '#' : s
showEStmt :: EStmt -> String
showEStmt as =
@@ -377,6 +454,7 @@
case ab of
BFcn i eqns -> showEDef (Fcn i eqns)
BPat p e -> showEPat p ++ " = " ++ showExpr e
+ BSign i t -> showIdent i ++ " :: " ++ showEType t
showCaseArm :: ECaseArm -> String
showCaseArm arm =
@@ -391,12 +469,3 @@
showEKind :: EKind -> String
showEKind = showEType
-
-showETypeScheme :: ETypeScheme -> String
-showETypeScheme ts =
- case ts of
- ETypeScheme vs t ->
- if null vs
- then showEType t
- else unwords ("forall" : map showIdKind vs ++ [".", showEType t])-
--- /dev/null
+++ b/src/MicroHs/Graph.hs
@@ -1,0 +1,158 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}+-----------------------------------------------------------------------------
+-- Loosely based on:
+--
+-- Module : Data.Graph
+-- Copyright : (c) The University of Glasgow 2002
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-----------------------------------------------------------------------------
+
+module MicroHs.Graph (
+ stronglyConnComp,
+ SCC(..)
+ ) where
+import Prelude
+--Ximport Compat
+
+import qualified Data.IntSet as IS
+import qualified Data.IntMap as IM
+
+import Data.List
+import Data.Maybe
+
+data Tree a = Node a [Tree a]
+ --deriving (Eq, Ord, Show)
+
+type Forest a = [Tree a]
+
+-- | Strongly connected component.
+data SCC vertex = AcyclicSCC vertex -- ^ A single vertex that is not
+ -- in any cycle.
+ | CyclicSCC [vertex] -- ^ A maximal set of mutually
+ -- reachable vertices.
+ --Xderiving (Show)
+
+stronglyConnComp
+ :: forall key node .
+ (key -> key -> Bool)
+ -> [(node, key, [key])]
+ -- ^ The graph: a list of nodes uniquely identified by keys,
+ -- with a list of keys of nodes this node has edges to.
+ -- The out-list may contain keys that don't correspond to
+ -- nodes of the graph; such edges are ignored.
+ -> [SCC node]
+stronglyConnComp le edges0
+ = map get_node (stronglyConnCompR le edges0)
+ where
+ get_node (AcyclicSCC (n, _, _)) = AcyclicSCC n
+ get_node (CyclicSCC triples) = CyclicSCC [n | (n,_,_) <- triples]
+
+stronglyConnCompR
+ :: forall key node .
+ (key -> key -> Bool)
+ -> [(node, key, [key])]
+ -- ^ The graph: a list of nodes uniquely identified by keys,
+ -- with a list of keys of nodes this node has edges to.
+ -- The out-list may contain keys that don't correspond to
+ -- nodes of the graph; such edges are ignored.
+ -> [SCC (node, key, [key])] -- ^ Reverse topologically sorted
+stronglyConnCompR _ [] = []
+stronglyConnCompR le edges0
+ = map decode forest
+ where
+ (graph, vertex_fn) = graphFromEdges le edges0
+ forest = scc graph
+ mentions_itself v = elemBy (==) v (graph IM.! v)
+ decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
+ | otherwise = AcyclicSCC (vertex_fn v)
+ decode other = CyclicSCC (dec other [])
+ where
+ dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
+
+type Vertex = Int
+type Graph = IM.IntMap [Vertex]
+type Edge = (Vertex, Vertex)
+
+vertices :: Graph -> [Vertex]
+vertices = IM.keys
+
+edges :: Graph -> [Edge]
+edges g = [ (v, w) | v <- vertices g, w <- g IM.! v ]
+
+buildG :: [Vertex] -> [Edge] -> Graph
+buildG vs es =
+ let mt = IM.fromList (zip vs (repeat []))
+ in foldr (\ (v, w) -> IM.insertWith (++) v [w]) mt es
+
+transposeG :: Graph -> Graph
+transposeG g = buildG (vertices g) (reverseE g)
+
+reverseE :: Graph -> [Edge]
+reverseE g = [ (w, v) | (v, w) <- edges g ]
+
+graphFromEdges
+ :: forall key node .
+ (key -> key -> Bool)
+ -> [(node, key, [key])]
+ -> (Graph, Vertex -> (node, key, [key]))
+graphFromEdges le edges0
+ = (graph, \v -> vertex_map IM.! v)
+ where
+ lek (_,k1,_) (_,k2,_) = le k1 k2
+
+ max_v = length edges0 - 1
+ sorted_edges = sortLE lek edges0
+ edges1 = zip [0..] sorted_edges
+
+ key_map = IM.fromList [(v, k) | (v, (_, k, _ )) <- edges1]
+
+ -- key_vertex :: key -> Maybe Vertex
+ -- returns Nothing for non-interesting vertices
+ key_vertex k = findVertex 0 max_v
+ where
+ findVertex a b | a > b
+ = Nothing
+ findVertex a b =
+ if k `le` m then
+ if m `le` k then
+ Just mid
+ else
+ findVertex a (mid - 1)
+ else
+ findVertex (mid + 1) b
+ where
+ mid = a + (b - a) `quot` 2
+ m = key_map IM.! mid
+
+ graph = IM.fromList [(v, mapMaybe key_vertex ks) | (v, (_, _, ks)) <- edges1]
+ vertex_map = IM.fromList edges1
+
+dff :: Graph -> [Tree Vertex]
+dff g = dfs g (vertices g)
+
+dfs :: Graph -> [Vertex] -> Forest Vertex
+dfs g vs0 = snd $ go IS.empty vs0
+ where
+ go :: IS.IntSet -> [Vertex] -> (IS.IntSet, Forest Vertex)
+ go done [] = (done, [])
+ go done (v:vs) =
+ if IS.member v done
+ then go done vs
+ else
+ let (done', as) = go (IS.insert v done) (g IM.! v)
+ (done'', bs) = go done' vs
+ in (done'', Node v as : bs)
+
+
+postorder :: forall a . Tree a -> [a] -> [a]
+postorder (Node a ts) = postorderF ts . (a :)
+
+postorderF :: forall a . [Tree a] -> [a] -> [a]
+postorderF ts = foldr (.) id $ map postorder ts
+
+postOrd :: Graph -> [Vertex]
+postOrd g = postorderF (dff g) []
+
+scc :: Graph -> [Tree Vertex]
+scc g = dfs g (reverse (postOrd (transposeG g)))
--- a/src/MicroHs/Ident.hs
+++ b/src/MicroHs/Ident.hs
@@ -1,12 +1,19 @@
+-- Copyright 2023 Lennart Augustsson
+-- See LICENSE file for full license.
module MicroHs.Ident(
Line, Col, Loc,
Ident(..),
- mkIdent, mkIdentLoc, unIdent, eqIdent, qualIdent, showIdent, getSLocIdent,
+ mkIdent, mkIdentLoc, unIdent, eqIdent, leIdent, qualIdent, showIdent, getSLocIdent, setSLocIdent,
+ mkIdentSLoc,
isLower_, isIdentChar, isOperChar, isConIdent,
unQualString,
- SLoc(..), noSLoc, showSLoc
+ SLoc(..), noSLoc, isNoSLoc,
+ showSLoc,
+ compareIdent,
) where
import Prelude --Xhiding(showString)
+--Ximport Control.DeepSeq
+--Yimport Primitives(NFData(..))
import Data.Char
--Ximport Compat
@@ -17,15 +24,23 @@
data SLoc = SLoc FilePath Line Col
--Xderiving (Show, Eq)
+data Ident = Ident SLoc String
+ --Xderiving (Show, Eq)
+--Winstance NFData Ident where rnf (Ident _ s) = rnf s
+
noSLoc :: SLoc
noSLoc = SLoc "" 0 0
-data Ident = Ident SLoc String
- --Xderiving (Show, Eq)
+isNoSLoc :: SLoc -> Bool
+isNoSLoc (SLoc "" 0 0) = True
+isNoSLoc _ = False
mkIdent :: String -> Ident
mkIdent = Ident noSLoc
+mkIdentSLoc :: SLoc -> String -> Ident
+mkIdentSLoc = Ident
+
mkIdentLoc :: FilePath -> Loc -> String -> Ident
mkIdentLoc fn (l, c) s = Ident (SLoc fn l c) s
@@ -35,6 +50,9 @@
getSLocIdent :: Ident -> SLoc
getSLocIdent (Ident loc _) = loc
+setSLocIdent :: SLoc -> Ident -> Ident
+setSLocIdent l (Ident _ s) = Ident l s
+
showIdent :: Ident -> String
showIdent (Ident _ i) = i
@@ -41,6 +59,9 @@
eqIdent :: Ident -> Ident -> Bool
eqIdent (Ident _ i) (Ident _ j) = eqString i j
+leIdent :: Ident -> Ident -> Bool
+leIdent (Ident _ i) (Ident _ j) = leString i j
+
qualIdent :: Ident -> Ident -> Ident
qualIdent (Ident loc qi) (Ident _ i) = Ident loc (qi ++ "." ++ i)
@@ -48,9 +69,9 @@
unQualString s =
case span isIdentChar s of
("", r) -> r+ (r, "") -> r -- XXX bug! swapping with next line goes wrong
(_, '.':r) -> unQualString r
- (r, "") -> r
- _ -> undefined
+ x -> error $ "unQualString: " ++ showPair showString (showPair showString showString) (s, x)
isConIdent :: Ident -> Bool
isConIdent (Ident _ i) =
@@ -71,3 +92,8 @@
showSLoc (SLoc fn l c) =
if null fn then "no location" else
showString fn ++ ": " ++ "line " ++ showInt l ++ ", col " ++ showInt c
+
+compareIdent :: Ident -> Ident -> Ordering
+compareIdent (Ident _ s) (Ident _ t) = compareString s t
+
+
--- a/src/MicroHs/IdentMap.hs
+++ b/src/MicroHs/IdentMap.hs
@@ -1,113 +1,159 @@
--- Copyright 2023 Lennart Augustsson
--- See LICENSE file for full license.
+{-# OPTIONS_GHC -Wno-name-shadowing #-}+--
+-- Balanced binary trees
+-- Similar to Data.Map
+-- Based on https://ufal.mff.cuni.cz/~straka/papers/2011-bbtree.pdf
+--
module MicroHs.IdentMap(
Map,
- size,
- empty, insert, lookup,
- fromList, fromListWith,
- toList, elems
+ insert, fromListWith, fromList, lookup, empty, elems, size, toList, delete,
) where
import Prelude --Xhiding(lookup)
import MicroHs.Ident
+--Ximport Compat
-{--import qualified Data.Map as M
-import qualified GHC.Maybe
+data Map a
+ = Nil -- empty tree
+ | One Ident a -- singleton
+ | Node -- tree node
+ (Map a) -- left subtree
+ Int -- size of this tree
+ Ident -- key stored in the node
+ a -- element stored in the node
+ (Map a) -- right subtree
+ --Xderiving(Show)
-type Map v = M.Map Ident v
+empty :: forall a . Map a
+empty = Nil
-insert = M.insert
+elems :: forall v . Map v -> [v]
+elems = map snd . toList
-fromListWith = M.fromListWith
+toList :: forall v . Map v -> [(Ident, v)]
+toList t = to t []
+ where
+ to Nil q = q
+ to (One k v) q = (k, v):q
+ to (Node l _ k v r) q = to l ((k, v) : to r q)
-fromList = M.fromList
+fromList :: forall v . [(Ident, v)] -> Map v
+fromList = fromListWith const
---union = M.union
+fromListWith :: forall v . (v -> v -> v) -> [(Ident, v)] -> Map v
+fromListWith comb = foldr (uncurry (insertWith comb)) empty
-lookup k m =
- case M.lookup k m of
- GHC.Maybe.Nothing -> Nothing
- GHC.Maybe.Just v -> Just v
+size :: forall a . Map a -> Int
+size Nil = 0
+size (One _ _) = 1
+size (Node _ s _ _ _) = s
-empty = M.empty
+node :: forall a . Map a -> Ident -> a -> Map a -> Map a
+node Nil key val Nil = One key val
+node left key val right = Node left (size left + 1 + size right) key val right
-elems = M.elems
--}
+lookup :: forall a . Ident -> Map a -> Maybe a
+lookup k = look
+ where
+ look Nil = Nothing
+ look (One key val) | isEQ (compareIdent k key) = Just val
+ | otherwise = Nothing
+ look (Node left _ key val right) =
+ case k `compareIdent` key of
+ LT -> look left
+ EQ -> Just val
+ GT -> look right
--- This is a pretty bad implementation.
-data Map v = Map [(Ident, v)]
- --Xderiving(Show)
+insert :: forall a . Ident -> a -> Map a -> Map a
+insert = insertWith const
-insert k v (Map kvs) = Map ((k, v):kvs)
+insertWith :: forall a . (a -> a -> a) -> Ident -> a -> Map a -> Map a
+insertWith comb k v = ins
+ where
+ ins Nil = One k v
+ ins (One a v) = ins (Node Nil 1 a v Nil)
+ ins (Node left _ key val right) =
+ case k `compareIdent` key of
+ LT -> balance (ins left) key val right
+ EQ -> node left k (comb v val) right
+ GT -> balance left key val (ins right)
-fromListWith un =
- let
- ins ikv akvs =
- case akvs of
- [] -> [ikv]
- kv : kvs ->
- case ikv of
- (ik, iv) ->
- case kv of
- (k, v) ->
- if eqIdent ik k then
- (k, un iv v) : kvs
- else
- kv : ins ikv kvs
- in
- Map . foldr ins []
+delete :: forall a . Ident -> Map a -> Map a
+delete k = del
+ where
+ del Nil = Nil
+ del t@(One a _) | isEQ (k `compareIdent` a) = Nil
+ | otherwise = t
+ del (Node left _ key val right) =
+ case k `compareIdent` key of
+ LT -> balance (del left) key val right
+ EQ -> glue left right
+ GT -> balance left key val (del right)
+ where
+ glue Nil right = right
+ glue left Nil = left
+ glue left right
+ | size left > size right =
+ let (key', val', left') = extractMax left
+ in node left' key' val' right
+ | otherwise =
+ let (key', val', right') = extractMin right
+ in node left key' val' right'
-fromList = Map
+extractMin :: forall a . Map a -> (Ident, a, Map a)
+extractMin Nil = undefined
+extractMin (One key val) = (key, val, Nil)
+extractMin (Node Nil _ key val right) = (key, val, right)
+extractMin (Node left _ key val right) =
+ case extractMin left of
+ (min, vmin, left') -> (min, vmin, balance left' key val right)
-{--union akvs1 akvs2 =
- case akvs1 of
- Map kvs1 ->
- case akvs2 of
- Map kvs2 -> Map (kvs1 ++ kvs2)
--}
+extractMax :: forall a . Map a -> (Ident, a, Map a)
+extractMax Nil = undefined
+extractMax (One key val) = (key, val, Nil)
+extractMax (Node left _ key val Nil) = (key, val, left)
+extractMax (Node left _ key val right) =
+ case extractMax right of
+ (max, vmax, right') -> (max, vmax, balance left key val right')
-lookup ak (Map m) =
- let
- look akvs =
- case akvs of
- [] -> Nothing
- kv : kvs ->
- case kv of
- (k, v) -> if eqIdent ak k then Just v else look kvs
- in look m
+omega :: Int
+omega = 3
+alpha :: Int
+alpha = 2
+delta :: Int
+delta = 0
-empty = Map []
+balance :: forall a . Map a -> Ident -> a -> Map a -> Map a
+balance left key val right
+ | size left + size right <= 1 = node left key val right
+balance (One k v) key val right = balance (Node Nil 1 k v Nil) key val right
+balance left key val (One k v) = balance left key val (Node Nil 1 k v Nil)
+balance left key val right
+ | size right > omega * size left + delta =
+ case right of
+ (Node rl _ _ _ rr) | size rl < alpha*size rr -> singleL left key val right
+ | otherwise -> doubleL left key val right
+ _ -> undefined
+ | size left > omega * size right + delta =
+ case left of
+ (Node ll _ _ _ lr) | size lr < alpha*size ll -> singleR left key val right
+ | otherwise -> doubleR left key val right
+ _ -> undefined
+ | otherwise = node left key val right
-elems (Map kvs) = map snd kvs
+singleL :: forall a . Map a -> Ident -> a -> Map a -> Map a
+singleL l k v (Node rl _ rk rv rr) = node (node l k v rl) rk rv rr
+singleL _ _ _ _ = undefined
-size (Map kvs) = length kvs
+singleR :: forall a . Map a -> Ident -> a -> Map a -> Map a
+singleR (Node ll _ lk lv lr) k v r = node ll lk lv (node lr k v r)
+singleR _ _ _ _ = undefined
-toList (Map kvs) = kvs
+doubleL :: forall a . Map a -> Ident -> a -> Map a -> Map a
+doubleL l k v (Node (Node rll _ rlk rlv rlr) _ rk rv rr) = node (node l k v rll) rlk rlv (node rlr rk rv rr)
+doubleL l k v (Node (One rlk rlv ) _ rk rv rr) = node (node l k v Nil) rlk rlv (node Nil rk rv rr)
+doubleL _ _ _ _ = undefined
-{--import qualified Data.Map as M
-
-type Map v = M.Map Ident v
-
-insert = M.insertBy leIdent
-fromListWith = M.fromListByWith leIdent
-fromList = M.fromListBy leIdent
---union = M.unionBy leIdent
-lookup = M.lookupBy leIdent
-empty = M.empty
-elems = M.elems
-toList = M.toList
--}
-
--------
-
-insert :: forall v . Ident -> v -> Map v -> Map v
-fromListWith :: forall v . (v -> v -> v) -> [(Ident, v)] -> Map v
-fromList :: forall v . [(Ident, v)] -> Map v
---union :: forall v . Map v -> Map v -> Map v
-lookup :: forall v . Ident -> Map v -> Maybe v
-empty :: forall v . Map v
-elems :: forall v . Map v -> [v]
-size :: forall v . Map v -> Int
-toList :: forall v . Map v -> [(Ident, v)]
+doubleR :: forall a . Map a -> Ident -> a -> Map a -> Map a
+doubleR (Node ll _ lk lv (Node lrl _ lrk lrv lrr)) k v r = node (node ll lk lv lrl) lrk lrv (node lrr k v r)
+doubleR (Node ll _ lk lv (One lrk lrv )) k v r = node (node ll lk lv Nil) lrk lrv (node Nil k v r)
+doubleR _ _ _ _ = undefined
--- /dev/null
+++ b/src/MicroHs/Interactive.hs
@@ -1,0 +1,108 @@
+module MicroHs.Interactive(module MicroHs.Interactive) where
+import Prelude
+import Control.DeepSeq
+import Control.Exception
+import qualified MicroHs.StateIO as S
+import MicroHs.Compile
+import MicroHs.Exp(Exp)
+import MicroHs.Ident(Ident, mkIdent)
+import MicroHs.Parse
+import MicroHs.Translate
+import Unsafe.Coerce
+import System.Console.SimpleReadline
+--Ximport Compat
+
+type LDef = (Ident, Exp) -- XXX why?
+
+type IState = (String, Flags, Cache)
+
+type I a = S.StateIO IState a
+
+mainInteractive :: Flags -> IO ()
+mainInteractive flags = do
+ putStrLn "Welcome to interactive MicroHs!"
+ putStrLn "Type ':quit' to quit"
+ _ <- S.runStateIO repl (preamble, flags, emptyCache)
+ return ()
+
+preamble :: String
+preamble = "module " ++ interactiveName ++ "(module " ++ interactiveName ++ ") where\nimport Prelude\nimport Unsafe.Coerce\n"
+
+repl :: I ()
+repl = S.do
+ ms <- S.liftIO $ getInputLineHist ".mhsi" "> "
+ case ms of
+ Nothing -> repl
+ Just ":quit" -> S.liftIO $ putStrLn "Bye"
+ Just ":clear" -> S.do
+ updateLines (const preamble)
+ repl
+ Just s | Just del <- stripPrefixBy eqChar ":del " s -> S.do
+ updateLines (unlines . filter (not . isPrefixOfBy eqChar del) . lines)
+ repl
+ Just s -> S.do
+ oneline s
+ repl
+
+updateLines :: (String -> String) -> I ()
+updateLines f = S.modify $ \ (ls, flgs, cache) -> (f ls, flgs, cache)
+
+interactiveName :: String
+interactiveName = "Interactive"
+
+itName :: String
+itName = "_it"
+
+mkIt :: String -> String
+mkIt l = itName ++ " :: Any\n" ++ itName ++ " = unsafeCoerce (" ++ l ++ ")\n"+
+err :: Exn -> IO ()
+err (Exn s) = putStrLn $ "Error: " ++ s
+
+oneline :: String -> I ()
+oneline line = S.do
+ (ls, _, _) <- S.get
+ case parse pExprTop "" line of
+ Right _ -> S.do
+ -- Looks like an expressions, make it a definition
+ exprTest <- tryCompile (ls ++ "\n" ++ mkIt line)
+ case exprTest of
+ Right m -> evalExpr m
+ Left e -> S.liftIO $ err e
+ Left _ -> S.do
+ -- Not an expression, try adding it as a definition
+ let lls = ls ++ line ++ "\n"
+ defTest <- tryCompile lls
+ case defTest of
+ Right _ -> updateLines (const lls)
+ Left e -> S.liftIO $ err e
+
+tryCompile :: String -> I (Either Exn [LDef])
+tryCompile file = S.do
+ (ls, flgs, cache) <- S.get
+ let
+ iid = mkIdent interactiveName
+ S.liftIO $ writeFile (interactiveName ++ ".hs") file
+ res <- S.liftIO $ try $ compileCacheTop flgs iid cache
+ case res of
+ Left e -> S.return (Left e)
+ Right (m, cache') -> S.do
+ S.put (ls, flgs, deleteFromCache iid cache')
+ S.return (Right m)
+
+evalExpr :: [LDef] -> I ()
+evalExpr cmdl = S.do
+ let res = translate (mkIdent (interactiveName ++ "." ++ itName), cmdl)
+ mval <- S.liftIO $ try (seq res (return res))
+ S.liftIO $
+ case mval of
+ Left e -> err e
+ Right val ->
+ if primIsInt val then
+ putStrLn $ showInt $ unsafeCoerce val
+ else do
+ putStrLn "Warning: not an Int"
+ mio <- try (print (force ((unsafeCoerce val)::Int)))
+ case mio of
+ Left e -> err e
+ Right _ -> return ()
--- a/src/MicroHs/Lex.hs
+++ b/src/MicroHs/Lex.hs
@@ -6,7 +6,6 @@
import Data.Char
import Data.List
--Ximport Compat
---import Debug.Trace
import MicroHs.Ident
data Token
@@ -71,7 +70,6 @@
lexTop :: String -> [Token]
lexTop = layout [] .
- --take 10 .
lex (mkLoc 1 1)
-- | Take a location and string and produce a list of tokens
@@ -81,11 +79,10 @@
lex loc ('\r':cs) = lex loc cs lex loc ('{':'-':cs) = skipNest (addCol loc 2) 1 cs lex loc ('-':'-':cs) | isComm rs = skipLine (addCol loc $ 2+length ds) cs- where {- (ds, rs) = span (eqChar '-') cs;
- isComm [] = True;
+ where
+ (ds, rs) = span (eqChar '-') cs
+ isComm [] = True
isComm (d:_) = not (isOperChar d)
- }
lex loc (d:cs) | isLower_ d =
case span isIdentChar cs of
(ds, rs) -> tIdent loc [] (d:ds) (lex (addCol loc $ 1 + length ds) rs)
@@ -108,19 +105,21 @@
case takeChars loc (TString loc) '"' 0 [] cs of
(t, n, rs) -> t : lex (addCol loc $ 2 + n) rs
lex loc ('\'':cs) =- case takeChars loc (TChar loc . head) '\'' 0 [] cs of -- XXX head of
- (t, n, rs) -> t : lex (addCol loc $ 2 + n) rs
+ let tchar [c] = TChar loc c
+ tchar _ = TError loc "Illegal Char literal"
+ in case takeChars loc tchar '\'' 0 [] cs of -- XXX head of
+ (t, n, rs) -> t : lex (addCol loc $ 2 + n) rs
lex loc (d:_) = [TError loc $ "Unrecognized input: " ++ showChar d]
lex _ [] = []
--- Skip a { - - } style comment+-- Skip a {- -} style commentskipNest :: Loc -> Int -> String -> [Token]
skipNest loc 0 cs = lex loc cs
skipNest loc n ('{':'-':cs) = skipNest (addCol loc 2) (n + 1) cs skipNest loc n ('-':'}':cs) = skipNest (addCol loc 2) (n - 1) cs-skipNest loc n ('\n':cs) = skipNest (incrLine loc) n cs-skipNest loc n ('\r':cs) = skipNest loc n cs-skipNest loc n (_:cs) = skipNest (addCol loc 1) n cs
+skipNest loc n ('\n':cs) = skipNest (incrLine loc) n cs+skipNest loc n ('\r':cs) = skipNest loc n cs+skipNest loc n (_:cs) = skipNest (addCol loc 1) n cs
skipNest loc _ [] = [TError loc "Unclosed {- comment"]-- Skip a -- style comment
@@ -148,6 +147,7 @@
decodeChar n ('n':cs) = ('\n', n+1, cs) decodeChar n ('r':cs) = ('\r', n+1, cs) decodeChar n ('t':cs) = ('\t', n+1, cs)+decodeChar n ('b':cs) = ('\b', n+1, cs)decodeChar n (c :cs) = (c, n+1, cs)
decodeChar n [] = ('X', n, [])@@ -208,4 +208,3 @@
layout ms (t : ts) = t : layout ms ts
layout (_ : ms) [] = TSpec (mkLoc 0 0) '}' : layout ms []
layout [] [] = []
---layout _ _ = TError (mkLoc 0 0) "layout error" : []
--- a/src/MicroHs/Main.hs
+++ b/src/MicroHs/Main.hs
@@ -3,15 +3,14 @@
{-# OPTIONS_GHC -Wno-unused-do-bind #-}module MicroHs.Main(main) where
import Prelude
-import qualified MicroHs.StringMapFast as M
+import qualified MicroHs.IdentMap as M
import Data.Maybe
import System.Environment
import MicroHs.Compile
-import MicroHs.Desugar
-import MicroHs.Expr
import MicroHs.Exp
import MicroHs.Ident
import MicroHs.Translate
+import MicroHs.Interactive
--Ximport Compat
main :: IO ()
@@ -19,22 +18,27 @@
aargs <- getArgs
let
args = takeWhile (not . eqString "--") aargs
- mn =
- let
- ss = filter (not . (eqString "-") . take 1) args
- in if length ss == 1 then head ss else error "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"
+ ss = filter (not . (eqString "-") . take 1) args
flags = Flags (length (filter (eqString "-v") args))
(elemBy eqString "-r" args)
("." : catMaybes (map (stripPrefixBy eqChar "-i") args))(head $ catMaybes (map (stripPrefixBy eqChar "-o") args) ++ ["out.comb"])
- cmdl <- compileTop flags (mkIdent mn)
+ case ss of
+ [] -> mainInteractive flags
+ [s] -> mainCompile flags (mkIdent s)
+ _ -> error "Usage: mhs [-v] [-r] [-iPATH] [-oFILE] [ModuleName]"
+
+mainCompile :: Flags -> Ident -> IO ()
+mainCompile flags mn = do
+ ds <- compileTop flags mn
t1 <- getTimeMilli
let
- (mainName, ds) = cmdl
+ mainName = qualIdent mn (mkIdent "main")
+ cmdl = (mainName, ds)
ref i = Var $ mkIdent $ "_" ++ showInt i
- defs = M.fromList [ (unIdent n, ref i) | ((n, _), i) <- zip ds (enumFrom 0) ]
+ defs = M.fromList [ (n, ref i) | ((n, _), i) <- zip ds (enumFrom 0) ]
findIdent n = fromMaybe (error $ "main: findIdent: " ++ showIdent n) $
- M.lookup (unIdent n) defs
+ M.lookup n defs
emain = findIdent mainName
substv aexp =
case aexp of
@@ -41,21 +45,20 @@
Var n -> findIdent n
App f a -> App (substv f) (substv a)
e -> e
- --def :: ((Ident, Exp), Int) -> String -> String
- def d r =
- case d of
- ((_, e), i) -> "(($A :" ++ showInt i ++ " " ++ toStringP (substv e) ++ ") " ++ r ++ ")"
- -- App2 CT (Lbl i (subst e)) r
- res = foldr def (toStringP emain) (zip ds (enumFrom 0))
+ def :: ((Ident, Exp), Int) -> (String -> String) -> (String -> String)
+ def ((_, e), i) r =
+ (("(($A :" ++ showInt i ++ " ") ++) . toStringP (substv e) . (") " ++) . r . (")" ++)+ res = foldr def (toStringP emain) (zip ds (enumFrom 0)) ""
numDefs = M.size defs
when (verbose flags > 0) $
putStrLn $ "top level defns: " ++ showInt numDefs
when (verbose flags > 1) $
- mapM_ (\ (i, e) -> putStrLn $ showIdent i ++ " = " ++ toStringP e) ds
+ mapM_ (\ (i, e) -> putStrLn $ showIdent i ++ " = " ++ toStringP e "") ds
if runIt flags then do
let
- prg = translate cmdl
+ prg = translateAndRun cmdl
-- putStrLn "Run:"
+-- writeSerialized "ser.comb" prg
prg
-- putStrLn "done"
else do
@@ -65,18 +68,4 @@
putStrLn $ "final pass " ++ padLeft 6 (showInt (t2-t1)) ++ "ms"
version :: String
-version = "v3.2\n"
-
-type Program = (Ident, [LDef])
-
-compileTop :: Flags -> IdentModule -> IO Program
-compileTop flags mn = do
- ds <- compile flags mn
- t1 <- getTimeMilli
- let
- dsn = [ (n, compileOpt e) | (n, e) <- ds ]
- putStr $ drop 1000000 $ showLDefs dsn
- t2 <- getTimeMilli
- when (verbose flags > 0) $
- putStrLn $ "combinator conversion " ++ padLeft 6 (showInt (t2-t1)) ++ "ms"
- return (qualIdent mn (mkIdent "main"), dsn)
+version = "v3.5\n"
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -1,16 +1,11 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-unused-do-bind #-}-module MicroHs.Parse(pTop, parseDie) where
+module MicroHs.Parse(pTop, parseDie, parse, pExprTop) where
import Prelude --Xhiding (Monad(..), Applicative(..), MonadFail(..), Functor(..), (<$>), showString, showChar, showList)
---import Control.Monad
---import Control.Monad.State.Strict
---import Control.Applicative --hiding (many, some)
import Data.Char
import Data.List
import Text.ParserComb as P
---import Debug.Trace
---import MicroHs.Lex
import MicroHs.Lex
import MicroHs.Expr
import MicroHs.Ident
@@ -25,12 +20,18 @@
parseDie :: forall a . --X (Show a) =>
P a -> FilePath -> String -> a
parseDie p fn file =
+ case parse p fn file of
+ Left msg -> error msg
+ Right a -> a
+
+parse :: forall a . --X (Show a) =>
+ P a -> FilePath -> String -> Either String a
+parse p fn file =
let { ts = lexTop file } in--- trace (show ts) $
case runPrsr fn p ts of
- Left lf -> error $ formatFailed fn ts lf
- Right [(a, _)] -> a
- Right as -> error $ "Ambiguous:"
+ Left lf -> Left $ formatFailed fn ts lf
+ Right [(a, _)] -> Right a
+ Right as -> Left $ "Ambiguous:"
--X ++ unlines (map (show . fst) as)
getLoc :: P Loc
@@ -41,9 +42,12 @@
pTop :: P EModule
pTop = pModule <* eof
+pExprTop :: P Expr
+pExprTop = pExpr <* eof
+
pModule :: P EModule
pModule = EModule <$> (pKeyword "module" *> pUQIdentA) <*>
- (pSpec '(' *> esepBy pExportSpec (pSpec ',') <* pSpec ')') <*>+ (pSpec '(' *> esepEndBy pExportItem (pSpec ',') <* pSpec ')') <*>(pKeyword "where" *> pBlock pDef)
pQIdent :: P Ident
@@ -65,7 +69,7 @@
pUIdent :: P Ident
pUIdent =
pUIdentA
- <|> pUIdentSpecial
+ <|< pUIdentSpecial
pUIdentSym :: P Ident
pUIdentSym = pUIdent <|< pParens pUSymOper
@@ -77,9 +81,9 @@
let
mk = mkIdentLoc fn loc
- (mk . map (const ',') <$> (pSpec '(' *> some (pSpec ',') <* pSpec ')'))- <|> (mk "()" <$ (pSpec '(' *> pSpec ')')) -- Allow () as a constructor name- <|> (mk "[]" <$ (pSpec '[' *> pSpec ']')) -- Allow [] as a constructor name
+ (mk . map (const ',') <$> (pSpec '(' *> esome (pSpec ',') <* pSpec ')'))+ <|< (mk "()" <$ (pSpec '(' *> pSpec ')')) -- Allow () as a constructor name+ <|< (mk "[]" <$ (pSpec '[' *> pSpec ']')) -- Allow [] as a constructor name
pUQIdentA :: P Ident
pUQIdentA = P.do
@@ -92,7 +96,7 @@
pUQIdent :: P Ident
pUQIdent =
pUQIdentA
- <|> pUIdentSpecial
+ <|< pUIdentSpecial
pLIdent :: P Ident
pLIdent = P.do
@@ -111,8 +115,9 @@
satisfyM "LQIdent" is
keywords :: [String]
-keywords = ["case", "data", "do", "else", "forall", "if", "import",
- "in", "let", "module", "newtype", "of", "primitive", "then", "type", "where"]
+keywords = ["case", "data", "do", "else", "forall", "foreign", "if", "import",
+ "in", "infix", "infixl", "infixr",
+ "let", "module", "newtype", "of", "primitive", "then", "type", "where"]
pSpec :: Char -> P ()
pSpec c = () <$ satisfy [c] is
@@ -166,6 +171,19 @@
guard (not (isUOper s))
P.pure s
+-- Allow -> as well
+pLQSymOperArr :: P Ident
+pLQSymOperArr = pLQSymOper <|< pQArrow
+
+-- Parse ->, possibly qualified
+pQArrow :: P Ident
+pQArrow = P.do
+ fn <- getFileName
+ let
+ is (TIdent loc qs s@"->") = Just (qualName fn loc qs s)
+ is _ = Nothing
+ satisfyM "->" is
+
pLSymOper :: P Ident
pLSymOper = P.do
s <- pSymOper
@@ -173,13 +191,13 @@
P.pure s
reservedOps :: [String]
-reservedOps = ["=", "|", "::", "<-", "@"]
+reservedOps = ["=", "|", "::", "<-", "@", "..", "->"]
pUQIdentSym :: P Ident
pUQIdentSym = pUQIdent <|< pParens pUQSymOper
pLQIdentSym :: P Ident
-pLQIdentSym = pLQIdent <|< pParens pLQSymOper
+pLQIdentSym = pLQIdent <|< pParens pLQSymOperArr
pLIdentSym :: P Ident
pLIdentSym = pLIdent <|< pParens pLSymOper
@@ -206,12 +224,12 @@
---------------
-pExportSpec :: P ExportSpec
-pExportSpec =
+pExportItem :: P ExportItem
+pExportItem =
ExpModule <$> (pKeyword "module" *> pUQIdent)
- <|> ExpTypeCon <$> (pUQIdentSym <* pSpec '(' <* pSymbol ".." <* pSpec ')')- <|> ExpType <$> pUQIdentSym
- <|> ExpValue <$> pLQIdentSym
+ <|< ExpTypeCon <$> (pUQIdentSym <* pSpec '(' <* pSymbol ".." <* pSpec ')')+ <|< ExpType <$> pUQIdentSym
+ <|< ExpValue <$> pLQIdentSym
pKeyword :: String -> P ()
pKeyword kw = () <$ satisfy kw is
@@ -223,28 +241,43 @@
pBlock p = P.do
pSpec '{'as <- esepBy p (pSpec ';')
- optional (pSpec ';')
+ eoptional (pSpec ';')
pSpec '}'
pure as
pDef :: P EDef
pDef =
- Data <$> (pKeyword "data" *> pLHS <* pSymbol "=") <*> esepBy1 (pair <$> pUIdentSym <*> many pAType) (pSymbol "|")
- <|> Newtype <$> (pKeyword "newtype" *> pLHS <* pSymbol "=") <*> pUIdent <*> pAType
- <|> Type <$> (pKeyword "type" *> pLHS <* pSymbol "=") <*> pType
- <|> uncurry Fcn <$> pEqns
- <|> Sign <$> (pLIdentSym <* pSymbol "::") <*> pTypeScheme
- <|> Import <$> (pKeyword "import" *> pImportSpec)
+ Data <$> (pKeyword "data" *> pLHS) <*> ((pSymbol "=" *> esepBy1 ((,) <$> pUIdentSym <*> emany pAType) (pSymbol "|"))
+ <|< P.pure [])
+ <|< Newtype <$> (pKeyword "newtype" *> pLHS) <*> (pSymbol "=" *> pUIdent) <*> pAType
+ <|< Type <$> (pKeyword "type" *> pLHS) <*> (pSymbol "=" *> pType)
+ <|< uncurry Fcn <$> pEqns
+ <|< Sign <$> (pLIdentSym <* pSymbol "::") <*> pTypeScheme
+ <|< Import <$> (pKeyword "import" *> pImportSpec)
+ <|< ForImp <$> (pKeyword "foreign" *> pKeyword "import" *> pKeyword "ccall" *> pString) <*> pLIdent <*> (pSymbol "::" *> pType)
+ <|< Infix <$> ((,) <$> pAssoc <*> pPrec) <*> esepBy1 pTypeOper (pSpec ',')
+ where
+ pAssoc = (AssocLeft <$ pKeyword "infixl") <|< (AssocRight <$ pKeyword "infixr") <|< (AssocNone <$ pKeyword "infix")
+ dig (TInt _ i) | -1 <= i && i <= 9 = Just i
+ dig _ = Nothing
+ pPrec = satisfyM "digit" dig
pLHS :: P LHS
-pLHS = pair <$> pUIdentSym <*> many pIdKind
+pLHS = (,) <$> pUIdentSym <*> emany pIdKind
pImportSpec :: P ImportSpec
pImportSpec =
let
pQua = (True <$ pKeyword "qualified") <|< pure False
- in ImportSpec <$> pQua <*> pUQIdentA <*> optional (pKeyword "as" *> pUQIdent)
+ in ImportSpec <$> pQua <*> pUQIdentA <*> eoptional (pKeyword "as" *> pUQIdent) <*>
+ eoptional ((,) <$> ((True <$ pKeyword "hiding") <|> pure False) <*> pParens (esepEndBy pImportItem (pSpec ',')))
+pImportItem :: P ImportItem
+pImportItem =
+ ImpTypeCon <$> (pUQIdentSym <* pSpec '(' <* pSymbol ".." <* pSpec ')')+ <|< ImpType <$> pUQIdentSym
+ <|< ImpValue <$> pLQIdentSym
+
--------
-- Types
@@ -251,16 +284,20 @@
pIdKind :: P IdKind
pIdKind =
((\ i -> IdKind i kType) <$> pLIdentSym)
- <|> pParens (IdKind <$> pLIdentSym <*> (pSymbol "::" *> pKind))
+ <|< pParens (IdKind <$> pLIdentSym <*> (pSymbol "::" *> pKind))
pKind :: P EKind
pKind = pType
+{-pTypeScheme :: P ETypeScheme
pTypeScheme = P.do
vs <- (pKeyword "forall" *> esome pIdKind <* pSymbol ".") <|< pure []
t <- pType
- pure $ ETypeScheme vs t
+ pure $ if null vs then t else EForall vs t
+-}
+pTypeScheme :: P ETypeScheme
+pTypeScheme = pType
--
-- Partial copy of pExpr, but that includes '->'.
@@ -267,27 +304,17 @@
-- Including '->' in pExprOp interacts poorly with '->'
-- in lambda and 'case'.
pType :: P EType
-pType = pTypeOp
+pType = P.do
+ vs <- (pKeyword "forall" *> esome pIdKind <* pSymbol ".") <|< pure []
+ t <- pTypeOp
+ pure $ if null vs then t else EForall vs t
pTypeOp :: P EType
-pTypeOp =
- let
-{-- p10 = pTypeArg
- p9 = p10
- p8 = p9
- p7 = p8
- p6 = p7
- p5 = p6
- p4 = p5
- p3 = p4
- p2 = p3
- p1 = p2
- p0 = pRightAssoc (pOpers ["->"]) p1
--}
- p0 = pRightAssoc (pOpers ["->"]) pTypeArg
- in p0
+pTypeOp = pOperators pTypeOper pTypeArg
+pTypeOper :: P Ident
+pTypeOper = pOper <|< (mkIdent "->" <$ pSymbol "->")
+
pTypeArg :: P EType
pTypeArg = pTypeApp
@@ -295,7 +322,7 @@
pTypeApp = P.do
f <- pAType
as <- emany pAType
- mt <- optional (pSymbol "::" *> pType)
+ mt <- eoptional (pSymbol "::" *> pType)
let
r = foldl EApp f as
pure $ maybe r (ESign r) mt
@@ -303,10 +330,10 @@
pAType :: P Expr
pAType =
(EVar <$> pLQIdentSym)
- <|> (EVar <$> pUQIdentSym)
- <|> pLit
- <|> (eTuple <$> (pSpec '(' *> esepBy1 pType (pSpec ',') <* pSpec ')'))- <|> (EList . (:[]) <$> (pSpec '[' *> pType <* pSpec ']')) -- Unlike expressions, only allow a single element.
+ <|< (EVar <$> pUQIdentSym)
+ <|< pLit
+ <|< (eTuple <$> (pSpec '(' *> esepBy1 pType (pSpec ',') <* pSpec ')'))+ <|< (EListish . LList . (:[]) <$> (pSpec '[' *> pType <* pSpec ']')) -- Unlike expressions, only allow a single element.
-------------
-- Patterns
@@ -318,34 +345,20 @@
-- is separate.
pAPat :: P EPat
pAPat =
- (EVar <$> pLIdentSym)
- <|> (EVar <$> pUQIdentSym)
- <|> pLit
- <|> (eTuple <$> (pSpec '(' *> esepBy1 pPat (pSpec ',') <* pSpec ')'))- <|> (EList <$> (pSpec '[' *> esepBy1 pPat (pSpec ',') <* pSpec ']'))
- <|> (EAt <$> (pLIdentSym <* pSymbol "@") <*> pAPat)
+ (P.do
+ i <- pLIdentSym
+ (EAt i <$> (pSymbol "@" *> pAPat)) <|< pure (EVar i)
+ )
+ <|< (EVar <$> pUQIdentSym)
+ <|< pLit
+ <|< (eTuple <$> (pSpec '(' *> esepBy1 pPat (pSpec ',') <* pSpec ')'))+ <|< (EListish . LList <$> (pSpec '[' *> esepBy1 pPat (pSpec ',') <* pSpec ']'))
pPat :: P EPat
pPat = pPatOp
pPatOp :: P EPat
-pPatOp =
- let
-{-- p10 = pPatArg
- p9 = p10
- p8 = p9
- p7 = p8
- p6 = p7
- p5 = pRightAssoc (pOpers [":"]) p6
- p4 = p5
- p3 = p4
- p2 = p3
- p1 = p2
- p0 = p1
--}
- p0 = pRightAssoc (pOpers [":"]) pPatArg
- in p0
+pPatOp = pOperators pOper pPatArg
pPatArg :: P EPat
pPatArg = pPatApp
@@ -387,7 +400,7 @@
pAltsL :: P () -> P [EAlt]
pAltsL sep =
- esome (pair <$> (pSymbol "|" *> esepBy1 pStmt (pSpec ',')) <*> (sep *> pExpr))
+ esome ((,) <$> (pSymbol "|" *> esepBy1 pStmt (pSpec ',')) <*> (sep *> pExpr))
<|< ((\ e -> [([], e)]) <$> (sep *> pExpr))
pWhere :: P [EBind]
@@ -401,8 +414,8 @@
pStmt :: P EStmt
pStmt =
(SBind <$> (pPat <* pSymbol "<-") <*> pExpr)
- <|> (SLet <$> (pKeyword "let" *> pBlock pBind))
- <|> (SThen <$> pExpr)
+ <|< (SLet <$> (pKeyword "let" *> pBlock pBind))
+ <|< (SThen <$> pExpr)
-------------
-- Expressions
@@ -411,13 +424,13 @@
pExpr = pExprOp
pExprArg :: P Expr
-pExprArg = pExprApp <|> pLam <|> pCase <|> pLet <|> pIf <|> pDo
+pExprArg = pExprApp <|< pLam <|< pCase <|< pLet <|< pIf <|< pDo
pExprApp :: P Expr
pExprApp = P.do
f <- pAExpr
as <- emany pAExpr
- mt <- optional (pSymbol "::" *> pType)
+ mt <- eoptional (pSymbol "::" *> pType)
let
r = foldl EApp f as
pure $ maybe r (ESign r) mt
@@ -429,7 +442,7 @@
pCase = ECase <$> (pKeyword "case" *> pExpr) <*> (pKeyword "of" *> pBlock pCaseArm)
pCaseArm :: P ECaseArm
-pCaseArm = pair <$> pPat <*> pAlts (pSymbol "->")
+pCaseArm = (,) <$> pPat <*> pAlts (pSymbol "->")
pLet :: P Expr
pLet = ELet <$> (pKeyword "let" *> pBlock pBind) <*> (pKeyword "in" *> pExpr)
@@ -448,40 +461,49 @@
is _ = Nothing
satisfyM "QualDo" is
+pOperComma :: P Ident
+pOperComma = pOper <|< pComma
+ where
+ pComma = mkIdentLoc <$> getFileName <*> getLoc <*> ("," <$ pSpec ',')+
pAExpr :: P Expr
pAExpr = (
(EVar <$> pLQIdentSym)
- <|> (EVar <$> pUQIdentSym)
- <|> pLit
- <|> (eTuple <$> (pSpec '(' *> esepBy1 pExpr (pSpec ',') <* pSpec ')'))- <|> (EList <$> (pSpec '[' *> esepBy1 pExpr (pSpec ',') <* pSpec ']'))
- <|> (ESectL <$> (pSpec '(' *> pExprArg) <*> (pOper <* pSpec ')'))- <|> (ESectR <$> (pSpec '(' *> pOper) <*> (pExprArg <* pSpec ')'))- <|> (ECompr <$> (pSpec '[' *> pExpr <* pSymbol "|") <*> (esepBy1 pStmt (pSpec ',') <* pSpec ']'))
- <|> (ELit noSLoc . LPrim <$> (pKeyword "primitive" *> pString))
+ <|< (EVar <$> pUQIdentSym)
+ <|< pLit
+ <|< (eTuple <$> (pSpec '(' *> esepBy1 pExpr (pSpec ',') <* pSpec ')'))+ <|< EListish <$> (pSpec '[' *> pListish <* pSpec ']')
+ <|< (ESectL <$> (pSpec '(' *> pExprArg) <*> (pOperComma <* pSpec ')'))+ <|< (ESectR <$> (pSpec '(' *> pOperComma) <*> (pExprArg <* pSpec ')'))+ <|< (ELit noSLoc . LPrim <$> (pKeyword "primitive" *> pString))
)
-- This weirdly slows down parsing
-- <?> "aexpr"
-pExprOp :: P Expr
-pExprOp =
+pListish :: P Listish
+pListish = P.do
+ e1 <- pExpr
let
- p10 = pExprArg
- p9 = pRightAssoc (pOpers ["."]) $
- pLeftAssoc (pOpers ["?", "!!", "<?>"]) p10
- p8 = p9
- p7 = pLeftAssoc (pOpers ["*", "quot", "rem"]) p8
- p6 = pLeftAssoc (pOpers ["+", "-"]) p7
- p5 = pRightAssoc (pOpers [":", "++"]) p6
- p4 = pNonAssoc (pOpers ["==", "/=", "<", "<=", ">", ">="]) $
- pLeftAssoc (pOpers ["<*>", "<*", "*>", "<$>", "<$"]) p5
- p3 = pRightAssoc (pOpers ["&&"]) $
- pLeftAssoc (pOpers ["<|>","<|<"]) p4
- p2 = pRightAssoc (pOpers ["||"]) p3
- p1 = pLeftAssoc (pOpers [">>=", ">>"]) p2
- p0 = pRightAssoc (pOpers ["$"]) p1
- in p0
+ pMore = P.do
+ e2 <- pExpr
+ ((\ es -> LList (e1:e2:es)) <$> esome (pSpec ',' *> pExpr))
+ <|< (LFromThenTo e1 e2 <$> (pSymbol ".." *> pExpr))
+ <|< (LFromThen e1 e2 <$ pSymbol "..")
+ <|< P.pure (LList [e1,e2])
+ (pSpec ',' *> pMore)
+ <|< (LCompr e1 <$> (pSymbol "|" *> esepBy1 pStmt (pSpec ',')))
+ <|< (LFromTo e1 <$> (pSymbol ".." *> pExpr))
+ <|< (LFrom e1 <$ pSymbol "..")
+ <|< P.pure (LList [e1])
+pExprOp :: P Expr
+pExprOp = pOperators pOper pExprArg
+
+pOperators :: P Ident -> P Expr -> P Expr
+pOperators oper one = eOper <$> one <*> emany ((,) <$> oper <*> one)
+ where eOper e [] = e
+ eOper e ies = EOper e ies
+
-------------
-- Bindings
@@ -488,53 +510,15 @@
pBind :: P EBind
pBind =
uncurry BFcn <$> pEqns
- <|> BPat <$> (pPatNotVar <* pSymbol "=") <*> pExpr
+ <|< BPat <$> (pPatNotVar <* pSymbol "=") <*> pExpr
+ <|< BSign <$> (pLIdentSym <* pSymbol "::") <*> pTypeScheme
-------------
-pRightAssoc :: P Ident -> P Expr -> P Expr
-pRightAssoc pOp p = P.do
- e1 <- p
- let
- rest =
- P.do
- op <- pOp
- e2 <- pRightAssoc pOp p
- pure $ appOp op e1 e2
- rest <|< pure e1
-
-pNonAssoc :: P Ident -> P Expr -> P Expr
-pNonAssoc pOp p = P.do
- e1 <- p
- let
- rest =
- P.do
- op <- pOp
- e2 <- p
- pure $ appOp op e1 e2
- rest <|< pure e1
-
-pLeftAssoc :: P Ident -> P Expr -> P Expr
-pLeftAssoc pOp p = P.do
- e1 <- p
- es <- emany (pair <$> pOp <*> p)
- pure $ foldl (\ x (op, y) -> appOp op x y) e1 es
-
-pOpers :: [String] -> P Ident
-pOpers ops = P.do
- op <- pOper
- guard (elemBy eqString (unIdent op) ops)
- pure op
-
--------------
-
eTuple :: [Expr] -> Expr
-eTuple [] = undefined
+eTuple [] = error "eTuple"
eTuple [e] = e
eTuple es = ETuple es
-
-appOp :: Ident -> Expr -> Expr -> Expr
-appOp op e1 e2 = EApp (EApp (EVar op) e1) e2
isAlpha_ :: Char -> Bool
isAlpha_ c = isLower_ c || isUpper c
--- a/src/MicroHs/StringMapFast.hs
+++ /dev/null
@@ -1,186 +1,0 @@
--- Copyright 2023 Lennart Augustsson
--- See LICENSE file for full license.
--- Inspired by https://sortingsearching.com/2020/05/23/2-3-trees.html
-module MicroHs.StringMapFast(module MicroHs.StringMapFast) where
-import Prelude --Xhiding(lookup)
---Ximport Compat
-
-data Map v
- = Empty
- | Leaf String v
- | Node2 Int String (Map v) (Map v)
- | Node3 Int String (Map v) (Map v) (Map v)
- --Xderiving (Show)
-
-data OneOrTwo a
- = OOT1 a
- | OOT2 a a
- --Xderiving (Show)
-
-height :: forall v . Map v -> Int
-height m =
- case m of
- Empty -> undefined
- Leaf _ _ -> 0
- Node2 h _ _ _ -> h
- Node3 h _ _ _ _ -> h
-
-smallest :: forall v . Map v -> String
-smallest m =
- case m of
- Empty -> undefined
- Leaf k _ -> k
- Node2 _ k _ _ -> k
- Node3 _ k _ _ _ -> k
-
-replSmallest :: forall v . (v -> v) -> Map v -> Map v
-replSmallest f m =
- case m of
- Empty -> undefined
- Leaf k v -> Leaf k (f v)
- Node2 h s a b -> Node2 h s (replSmallest f a) b
- Node3 h s a b c -> Node3 h s (replSmallest f a) b c
-
-node2 :: forall v . Map v -> Map v -> Map v
-node2 a b = Node2 (height a + 1) (smallest a) a b
-
-node3 :: forall v . Map v -> Map v -> Map v -> Map v
-node3 a b c = Node3 (height a + 1) (smallest a) a b c
-
-meld :: forall v . OneOrTwo (Map v) -> OneOrTwo (Map v) -> OneOrTwo (Map v)
-meld m1 m2 =
- case m1 of
- OOT1 a ->
- case m2 of
- OOT1 b -> OOT1 $ node2 a b
- OOT2 b c -> OOT1 $ node3 a b c
- OOT2 a b ->
- case m2 of
- OOT1 c -> OOT1 $ node3 a b c
- OOT2 c d -> OOT2 (node2 a b) (node2 c d)
-
-mergeToSameHeight :: forall v . Map v -> Map v -> OneOrTwo (Map v)
-mergeToSameHeight a b =
- if height a < height b then
- case b of
- Node2 _ _ b1 b2 -> meld (mergeToSameHeight a b1) (OOT1 b2)
- Node3 _ _ b1 b2 b3 -> meld (mergeToSameHeight a b1) (OOT2 b2 b3)
- _ -> undefined
- else if height a > height b then
- case a of
- Node2 _ _ a1 a2 -> meld (OOT1 a1) (mergeToSameHeight a2 b)
- Node3 _ _ a1 a2 a3 -> meld (OOT2 a1 a2) (mergeToSameHeight a3 b)
- _ -> undefined
- else
- OOT2 a b
-
--- All elements in aa smaller than elements in ab
-merge :: forall v . Map v -> Map v -> Map v
-merge aa ab =
- case aa of
- Empty -> ab
- _ ->
- case ab of
- Empty -> aa
- _ ->
- case mergeToSameHeight aa ab of
- OOT1 t -> t
- OOT2 t u -> node2 t u
-
-split :: forall v . (String -> Bool) -> Map v -> (Map v, Map v)
-split f am =
- case am of
- Empty -> (Empty, Empty)
- Leaf k _ ->
- if f k then
- (Empty, am)
- else
- (am, Empty)
- Node2 _ _ a b ->
- if f (smallest b) then
- case split f a of
- (a1,a2) -> (a1, merge a2 b)
- else
- case split f b of
- (b1,b2) -> (merge a b1, b2)
- Node3 _ _ a b c ->
- if f (smallest b) then
- case split f a of
- (a1,a2) -> (a1, merge a2 (node2 b c))
- else if f (smallest c) then
- case split f b of
- (b1,b2) -> (merge a b1, merge b2 c)
- else
- case split f c of
- (c1,c2) -> (merge (node2 a b) c1, c2)
-
------------------------------------------
-
-insertWith :: forall v . (v -> v -> v) -> String -> v -> Map v -> Map v
-insertWith f k v a =
- case split (leString k) a of
- (a1, a2) ->
- case a2 of
- Empty -> merge a1 (Leaf k v)
- _ ->
- if leString (smallest a2) k then
- merge a1 (replSmallest (f v) a2)
- else
- merge (merge a1 (Leaf k v)) a2
-
-insert :: forall v . String -> v -> Map v -> Map v
-insert = insertWith const
-
-lookup :: forall v . String -> Map v -> Maybe v
-lookup x am =
- case am of
- Empty -> Nothing
- Leaf k v -> if leString k x && leString x k then Just v else Nothing
- Node2 _ _ a b ->
- if leString (smallest b) x then
- lookup x b
- else
- lookup x a
- Node3 _ _ a b c ->
- if leString (smallest c) x then
- lookup x c
- else if leString (smallest b) x then
- lookup x b
- else
- lookup x a
-
-union :: forall v . Map v -> Map v -> Map v
-union m1 m2 = foldr (uncurry insert) m2 (toList m1)
-
-fromListWith :: forall v . (v -> v -> v) -> [(String, v)] -> Map v
-fromListWith f = foldr (uncurry (insertWith f)) Empty
-
-toList :: forall v . Map v -> [(String, v)]
-toList m =
- let
- pre aa xs =
- case aa of
- Empty -> xs
- Leaf k v -> (k, v) : xs
- Node2 _ _ a b -> pre a (pre b xs)
- Node3 _ _ a b c -> pre a (pre b (pre c xs))
- in pre m []
-
-fromList :: forall v . [(String, v)] -> Map v
-fromList = fromListWith const
-
-empty :: forall v . Map v
-empty = Empty
-
-elems :: forall v . Map v -> [v]
-elems = map snd . toList
-
-size :: forall v . Map v -> Int
-size m =
- case m of
- Empty -> 0
- Leaf _ _ -> 1
- Node2 _ _ m1 m2 -> size m1 + size m2
- Node3 _ _ m1 m2 m3 -> size m1 + size m2 + size m3
--- a/src/MicroHs/TCMonad.hs
+++ b/src/MicroHs/TCMonad.hs
@@ -1,22 +1,28 @@
{-# OPTIONS_GHC -Wno-orphans -Wno-dodgy-imports -Wno-unused-imports #-}module MicroHs.TCMonad(
- TC, runState,
+ TC, tcRun,
fmap, (<$>),
(>>=), (>>), return, fail,
get, put, gets,
- mapM, mapM_
-{-- runState,
- fmap,
- fail,
mapM, mapM_,
- get, gets, put,
--}
+ when,
+ tcError
) where
--Ximport Control.Monad hiding(ap)
--Ximport Data.Functor.Identity
+--Ximport GHC.Stack
+import Data.Char -- for String
import Control.Monad.State.Strict --Xhiding(ap)
+import MicroHs.Ident
+import MicroHs.Expr
type TC s a = State s a
+
+tcRun :: forall s a . TC s a -> s -> (a, s)
+tcRun = runState
+
+tcError :: --XHasCallStack =>
+ forall s a . SLoc -> String -> TC s a
+tcError = errorMessage
--Xinstance MonadFail Identity where fail = error
--- a/src/MicroHs/Translate.hs
+++ b/src/MicroHs/Translate.hs
@@ -1,7 +1,7 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
module MicroHs.Translate(
- translate
+ translate, translateAndRun
) where
import Prelude
import Data.Maybe
@@ -10,26 +10,29 @@
--Ximport GHC.Types
import Unsafe.Coerce
--Ximport Compat
---Ximport PrimTable
---Yimport PrimTable
+--Wimport PrimTable
-import MicroHs.Desugar
-import MicroHs.Expr --X(Lit(..))
+import MicroHs.Expr
import MicroHs.Exp
import MicroHs.Ident
-translate :: (Ident, [LDef]) -> IO ()
-translate (mainName, ds) = do
- let
- look m n = fromMaybe (error $ "not found " ++ showIdent n) $ M.lookup n m
- mp = M.fromList [(n, trans (look mp) d) | (n, d) <- ds ]
-
+--translateAndRun :: (Ident, [LDef]) -> IO ()
+translateAndRun :: (Ident, [(Ident, Exp)]) -> IO ()
+translateAndRun defs = do
-- Drop all argument up to '--'
args <- getArgs
- let prog = unsafeCoerce $ look mp mainName
+ let prog = unsafeCoerce $ translate defs
withDropArgs (length (takeWhile (not . eqString "--") args) + 1)
prog
+--translate :: (Ident, [LDef]) -> Any
+translate :: (Ident, [(Ident, Exp)]) -> Any
+translate (mainName, ds) =
+ let
+ look m n = fromMaybe (error $ "not found " ++ showIdent n) $ M.lookup n m
+ mp = M.fromList [(n, trans (look mp) d) | (n, d) <- ds ]
+ in look mp mainName
+
trans :: (Ident -> Any) -> Exp -> Any
trans r ae =
case ae of
@@ -37,7 +40,7 @@
App f a -> unsafeCoerce (trans r f) (trans r a)
Lit (LInt i) -> unsafeCoerce i
Lit (LStr s) -> trans r (encodeString s)
- Lit (LPrim p) -> fromMaybe (error "primlookup") $ lookupBy eqString p primTable
+ Lit (LPrim p) -> fromMaybe (error $ "primlookup: " ++ p) $ lookupBy eqString p primTable
_ -> error "trans: impossible"
-- Use linear search in this table.
@@ -78,15 +81,20 @@
("u>=", primitive "u>="), ("seq", primitive "seq"), ("error", primitive "error"),+ ("equal", primitive "equal"),+ ("compare", primitive "compare"),+ ("rnf", primitive "rnf"), ("IO.>>=", primitive "IO.>>="), ("IO.>>", primitive "IO.>>"), ("IO.return", primitive "IO.return"), ("IO.getChar", primitive "IO.getChar"),+ ("IO.getRaw", primitive "IO.getRaw"), ("IO.putChar", primitive "IO.putChar"), ("IO.serialize", primitive "IO.serialize"), ("IO.deserialize", primitive "IO.deserialize"), ("IO.open", primitive "IO.open"), ("IO.close", primitive "IO.close"),+ ("IO.flush", primitive "IO.flush"), ("IO.isNullHandle", primitive "IO.isNullHandle"), ("IO.stdin", primitive "IO.stdin"), ("IO.stdout", primitive "IO.stdout"),@@ -93,5 +101,9 @@
("IO.stderr", primitive "IO.stderr"), ("IO.getArgs", primitive "IO.getArgs"), ("IO.dropArgs", primitive "IO.dropArgs"),- ("IO.performIO", primitive "IO.performIO")+ ("IO.performIO", primitive "IO.performIO"),+ ("IO.getTimeMilli", primitive "IO.getTimeMilli"),+ ("IO.catch", primitive "IO.catch"),+ ("isInt", primitive "isInt"),+ ("isIO", primitive "isIO")]
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -1,3 +1,5 @@
+-- Copyright 2023 Lennart Augustsson
+-- See LICENSE file for full license.
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-unused-imports #-}module MicroHs.TypeCheck(
typeCheck,
@@ -16,7 +18,7 @@
--Ximport GHC.Stack
--Ximport Debug.Trace
-data TModule a = TModule IdentModule [TypeExport] [SynDef] [ValueExport] a
+data TModule a = TModule IdentModule [FixDef] [TypeExport] [SynDef] [ValueExport] a
--Xderiving (Show)
data TypeExport = TypeExport Ident Entry [ValueExport]
@@ -25,12 +27,7 @@
data ValueExport = ValueExport Ident Entry
--Xderiving (Show)
-data TypeInfo
- = TAbs EKind
- | TConc EKind [(Ident, ETypeScheme)] -- constructor name, arity, and type
- | TSyn EKind ETypeScheme
- --Xderiving (Show, Eq)
-
+type FixDef = (Ident, Fixity)
type SynDef = (Ident, ETypeScheme)
data Entry = Entry Expr ETypeScheme
@@ -40,34 +37,60 @@
type TypeTable = M.Map [Entry]
type KindTable = M.Map [Entry]
type SynTable = M.Map ETypeScheme
+type FixTable = M.Map Fixity
typeCheck :: forall a . [(ImportSpec, TModule a)] -> EModule -> TModule [EDef]
-typeCheck imps (EModule mn exps defs) =
+typeCheck aimps (EModule mn exps defs) =
-- trace (show amdl) $
let
- (ts, ss, vs) = mkTables imps
- in case runState (tcDefs defs) (initTC mn ts ss vs) of
+ imps = map filterImports aimps
+ (fs, ts, ss, vs) = mkTables imps
+ in case tcRun (tcDefs defs) (initTC mn fs ts ss vs) of
(tds, tcs) ->
let
thisMdl = (mn, mkTModule mn tds impossible)
- impMdls = [(fromMaybe m mm, tm) | (ImportSpec _ m mm, tm) <- imps]
- impMap = M.fromList [(i, m) | (i, m) <- (thisMdl : impMdls)]
+ impMdls = [(fromMaybe m mm, tm) | (ImportSpec _ m mm _, tm) <- imps]
+ impMap = M.fromList [(i, m) | (i, m) <- thisMdl : impMdls]
(texps, sexps, vexps) =
- unzip3 $ map (getExps impMap (typeTable tcs) (synTable tcs) (valueTable tcs)) exps
- in TModule mn (concat texps) (concat sexps) (concat vexps) tds
+ unzip3 $ map (getTVExps impMap (typeTable tcs) (synTable tcs) (valueTable tcs)) exps
+{-+ in TModule mn [] (concat texps) (concat sexps) (concat vexps) tds
+ (texps, vexps) =
+ unzip $ map (getTVExps impMap (typeTable tcs) (valueTable tcs)) exps
+ (fexps, sexps) = unzip $ getFSExps impMap
+-}
+ fexps = [ fe | TModule _ fe _ _ _ _ <- M.elems impMap ]
+ in TModule mn (nubBy (eqIdent `on` fst) (concat fexps)) (concat texps) (concat sexps) (concat vexps) tds
-getExps :: forall a . M.Map (TModule a) -> TypeTable -> SynTable -> ValueTable -> ExportSpec ->
+filterImports :: forall a . (ImportSpec, TModule a) -> (ImportSpec, TModule a)
+filterImports it@(ImportSpec _ _ _ Nothing, _) = it
+filterImports (imp@(ImportSpec _ _ _ (Just (hide, is))), TModule mn fx ts ss vs a) =
+ let
+ keep x xs = elemBy eqIdent x xs `neBool` hide
+ ivs = [ i | ImpValue i <- is ]
+ vs' = filter (\ (ValueExport i _) -> keep i ivs) vs
+ cts = [ i | ImpTypeCon i <- is ]
+ its = [ i | ImpType i <- is ] ++ cts
+ ts' = map (\ te@(TypeExport i e _) -> if keep i cts then te else TypeExport i e []) $
+ filter (\ (TypeExport i _ _) -> keep i its) ts
+ in
+ --trace (show (ts, vs)) $
+ (imp, TModule mn fx ts' ss vs' a)
+
+-- Type and value exports
+getTVExps :: forall a . M.Map (TModule a) -> TypeTable -> SynTable -> ValueTable -> ExportItem ->
([TypeExport], [SynDef], [ValueExport])
-getExps impMap _ _ _ (ExpModule m) =
+getTVExps impMap _ _ _ (ExpModule m) =
case M.lookup m impMap of
- Just (TModule _ te se ve _) -> (te, se, ve)
+ Just (TModule _ _ te se ve _) -> (te, se, ve)
+-- Just (TModule _ _ te _ ve _) -> (te, ve)
_ -> expErr m
-getExps _ tys _ vals (ExpTypeCon i) =
+getTVExps _ tys _ vals (ExpTypeCon i) =
let
e = expLookup i tys
qi = tyQIdent e
- in ([TypeExport i e []], [], constrsOf qi (M.toList vals))
-getExps _ tys syns _ (ExpType i) =
+ in ([TypeExport i e $ constrsOf qi (M.toList vals)], [], [])
+getTVExps _ tys syns _ (ExpType i) =
let
e = expLookup i tys
qi = tyQIdent e
@@ -75,9 +98,15 @@
Nothing -> []
Just ts -> [(qi, ts)]
in ([TypeExport i e []], se, [])
-getExps _ _ _ vals (ExpValue i) =
+-- in ([TypeExport i e []], [])
+getTVExps _ _ _ vals (ExpValue i) =
([], [], [ValueExport i (expLookup i vals)])
+-- Export all fixities and synonyms.
+-- The synonyms might be needed, and the fixities are harmless
+--getFSExps :: forall a . M.Map (TModule a) -> [([FixDef], [SynDef])]
+--getFSExps impMap = [ (fe, se) | TModule _ fe _ se _ _ <- M.elems impMap ]
+
expLookup :: Ident -> M.Map [Entry] -> Entry
expLookup i m =
case M.lookup i m of
@@ -87,13 +116,14 @@
tyQIdent :: Entry -> Ident
tyQIdent (Entry (EVar qi) _) = qi
-tyQIdent _ = undefined
+tyQIdent _ = error "tyQIdent"
constrsOf :: Ident -> [(Ident, [Entry])] -> [ValueExport]
constrsOf qi ies =
- [ ValueExport i e | (i, es) <- ies, e@(Entry (ECon _) (ETypeScheme _ t)) <- es, eqIdent (retTyCon t) qi ]
+ [ ValueExport i e | (i, es) <- ies, e@(Entry (ECon _) t) <- es, eqIdent (retTyCon t) qi ]
retTyCon :: EType -> Ident
+retTyCon (EForall _ t) = retTyCon t
retTyCon t =
case getArrow t of
Nothing -> getAppCon t
@@ -102,11 +132,14 @@
getAppCon :: EType -> Ident
getAppCon (EVar i) = i
getAppCon (EApp f _) = getAppCon f
-getAppCon _ = undefined
+getAppCon _ = error "getAppCon"
-eVarI :: String -> Expr
-eVarI = EVar . mkIdent
+eVarI :: SLoc -> String -> Expr
+eVarI loc = EVar . mkIdentSLoc loc
+--tcExpErr :: forall a . Ident -> T a
+--tcExpErr i = tcError (getSLocIdent i) $ ": export undefined " ++ showIdent i
+
expErr :: forall a . Ident -> a
expErr i = errorMessage (getSLocIdent i) $ ": export undefined " ++ showIdent i
@@ -116,7 +149,7 @@
con ci it vks (ic, ts) =
let
e = ECon $ ConData ci (qualIdent mn ic)
- in ValueExport ic $ Entry e (ETypeScheme vks (foldr tArrow (tApps (qualIdent mn it) (map tVarK vks)) ts))
+ in ValueExport ic $ Entry e (EForall vks (foldr tArrow (tApps (qualIdent mn it) (map tVarK vks)) ts))
cons i vks cs =
let
ci = [ (qualIdent mn c, length ts) | (c, ts) <- cs ]
@@ -124,31 +157,32 @@
conn it vks ic t =
let
e = ECon $ ConNew (qualIdent mn ic)
- in [ValueExport ic $ Entry e (ETypeScheme vks (tArrow t (tApps (qualIdent mn it) (map tVarK vks))))]
- tentry i vks kret = Entry (EVar (qualIdent mn i)) (ETypeScheme [] $ lhsKind vks kret)
+ in [ValueExport ic $ Entry e (EForall vks (tArrow t (tApps (qualIdent mn it) (map tVarK vks))))]
+ tentry i vks kret = Entry (EVar (qualIdent mn i)) (lhsKind vks kret)
ves = [ ValueExport i (Entry (EVar (qualIdent mn i)) ts) | Sign i ts <- tds ]
tes =
[ TypeExport i (tentry i vks kType) (cons i vks cs) | Data (i, vks) cs <- tds ] ++
[ TypeExport i (tentry i vks kType) (conn i vks c t) | Newtype (i, vks) c t <- tds ] ++
[ TypeExport i (tentry i vks kType) [] | Type (i, vks) _ <- tds ] -- XXX kType is wrong
- ses = [ (qualIdent mn i, ETypeScheme vs t) | Type (i, vs) t <- tds ]
- in TModule mn tes ses ves a
+ ses = [ (qualIdent mn i, EForall vs t) | Type (i, vs) t <- tds ]
+ fes = [ (qualIdent mn i, fx) | Infix fx is <- tds, i <- is ]
+ in TModule mn fes tes ses ves a
-mkTables :: forall a . [(ImportSpec, TModule a)] -> (TypeTable, SynTable, ValueTable)
+mkTables :: forall a . [(ImportSpec, TModule a)] -> (FixTable, TypeTable, SynTable, ValueTable)
mkTables mdls =
let
qns aisp mn i =
case aisp of
- ImportSpec q _ mas ->
+ ImportSpec q _ mas _ ->
let
m = fromMaybe mn mas
in if q then [qualIdent m i] else [i, qualIdent m i]
- --XallValues :: M.Map [Entry]
+ allValues :: ValueTable
allValues =
let
syms arg =
case arg of
- (is, TModule mn tes _ ves _) ->
+ (is, TModule mn _ tes _ ves _) ->
[ (v, [e]) | ValueExport i e <- ves, v <- qns is mn i ] ++
[ (v, [e]) | TypeExport _ _ cs <- tes, ValueExport i e <- cs, v <- qns is mn i ]
in M.fromListWith (unionBy eqEntry) $ concatMap syms mdls
@@ -156,16 +190,20 @@
let
syns arg =
case arg of
- (_, TModule _ _ ses _ _) -> [ (i, x) | (i, x) <- ses ]
+ (_, TModule _ _ _ ses _ _) -> [ (i, x) | (i, x) <- ses ]
in M.fromList (concatMap syns mdls)
- --XallTypes :: TypeTable
+ allTypes :: TypeTable
allTypes =
let
types arg =
case arg of
- (is, TModule mn tes _ _ _) -> [ (v, [e]) | TypeExport i e _ <- tes, v <- qns is mn i ]
+ (is, TModule mn _ tes _ _ _) -> [ (v, [e]) | TypeExport i e _ <- tes, v <- qns is mn i ]
in M.fromListWith (unionBy eqEntry) $ concatMap types mdls
- in (allTypes, allSyns, allValues)
+ allFixes =
+ let
+ fixes (_, TModule _ fes _ _ _ _) = fes
+ in M.fromList (concatMap fixes mdls)
+ in (allFixes, allTypes, allSyns, allValues)
eqEntry :: Entry -> Entry -> Bool
eqEntry x y =
@@ -185,103 +223,102 @@
type Typed a = (a, EType)
-data TCState = TC IdentModule Int TypeTable SynTable ValueTable (IM.IntMap EType)
+data TCState = TC IdentModule Int FixTable TypeTable SynTable ValueTable (IM.IntMap EType)
--Xderiving (Show)
typeTable :: TCState -> TypeTable
-typeTable (TC _ _ tt _ _ _) = tt
+typeTable (TC _ _ _ tt _ _ _) = tt
valueTable :: TCState -> ValueTable
-valueTable (TC _ _ _ _ vt _) = vt
+valueTable (TC _ _ _ _ _ vt _) = vt
synTable :: TCState -> SynTable
-synTable (TC _ _ _ st _ _) = st
+synTable (TC _ _ _ _ st _ _) = st
+fixTable :: TCState -> FixTable
+fixTable (TC _ _ ft _ _ _ _) = ft
+
uvarSubst :: TCState -> IM.IntMap EType
-uvarSubst (TC _ _ _ _ _ sub) = sub
+uvarSubst (TC _ _ _ _ _ _ sub) = sub
moduleName :: TCState -> IdentModule
-moduleName (TC mn _ _ _ _ _) = mn
+moduleName (TC mn _ _ _ _ _ _) = mn
putValueTable :: ValueTable -> T ()
putValueTable venv = T.do
- TC mn n tenv senv _ m <- get
- put (TC mn n tenv senv venv m)
+ TC mn n fx tenv senv _ m <- get
+ put (TC mn n fx tenv senv venv m)
putTypeTable :: TypeTable -> T ()
putTypeTable tenv = T.do
- TC mn n _ senv venv m <- get
- put (TC mn n tenv senv venv m)
+ TC mn n fx _ senv venv m <- get
+ put (TC mn n fx tenv senv venv m)
putSynTable :: SynTable -> T ()
putSynTable senv = T.do
- TC mn n tenv _ venv m <- get
- put (TC mn n tenv senv venv m)
+ TC mn n fx tenv _ venv m <- get
+ put (TC mn n fx tenv senv venv m)
-- Use the type table as the value table, and the primKind table as the type table.
withTypeTable :: forall a . T a -> T a
withTypeTable ta = T.do
- TC mn n tt st vt m <- get
---BBB put (TC mn n M.empty M.empty tt m)
- put (TC mn n primKindTable M.empty tt m)
+ TC mn n fx tt st vt m <- get
+ put (TC mn n fx primKindTable M.empty tt m)
a <- ta
- TC mnr nr _ _ ttr mr <- get
- put (TC mnr nr ttr st vt mr)
+ TC mnr nr _ _ _ ttr mr <- get
+ put (TC mnr nr fx ttr st vt mr)
T.return a
-initTC :: IdentModule -> TypeTable -> SynTable -> ValueTable -> TCState
-initTC mn ts ss vs =
+initTC :: IdentModule -> FixTable -> TypeTable -> SynTable -> ValueTable -> TCState
+initTC mn fs ts ss vs =
-- trace ("initTC " ++ show (ts, vs)) $let
xts = foldr (uncurry M.insert) ts primTypes
xvs = foldr (uncurry M.insert) vs primValues
- in TC mn 1 xts ss xvs IM.empty
+ in TC mn 1 fs xts ss xvs IM.empty
--- XXX moduleOf is not correct
-moduleOf :: Ident -> IdentModule
-moduleOf = mkIdent . reverse . tail . dropWhile (neChar '.') . reverse . unIdent
-
kTypeS :: ETypeScheme
-kTypeS = ETypeScheme [] kType
+kTypeS = kType
kTypeTypeS :: ETypeScheme
-kTypeTypeS = ETypeScheme [] $ kArrow kType kType
+kTypeTypeS = kArrow kType kType
kTypeTypeTypeS :: ETypeScheme
-kTypeTypeTypeS = ETypeScheme [] $ kArrow kType $ kArrow kType kType
+kTypeTypeTypeS = kArrow kType $ kArrow kType kType
+builtinLoc :: SLoc
+builtinLoc = SLoc "builtin" 0 0
+
+mkIdentB :: String -> Ident
+mkIdentB = mkIdentSLoc builtinLoc
+
primKindTable :: KindTable
primKindTable =
let
- entry i = Entry (EVar (mkIdent i))
+ entry i = Entry (EVar (mkIdentB i))
in M.fromList [
- (mkIdent "Primitives.Type", [entry "Primitives.Type" kTypeS]),
- (mkIdent "Type", [entry "Primitives.Type" kTypeS]),
- (mkIdent "Primitives.->", [entry "Primitives.->" kTypeTypeTypeS]),
- (mkIdent "->", [entry "Primitives.->" kTypeTypeTypeS])
+ -- The kinds are wired in (for now)
+ (mkIdentB "Primitives.Type", [entry "Primitives.Type" kTypeS]),
+ (mkIdentB "Type", [entry "Primitives.Type" kTypeS]),
+ (mkIdentB "Primitives.->", [entry "Primitives.->" kTypeTypeTypeS]),
+ (mkIdentB "->", [entry "Primitives.->" kTypeTypeTypeS])
]
primTypes :: [(Ident, [Entry])]
primTypes =
let
- entry i = Entry (EVar (mkIdent i))
+ entry i = Entry (EVar (mkIdentB i))
tuple n =
let
- i = tupleConstr n
- in (i, [entry (unIdent i) $ ETypeScheme [] $ foldr kArrow kType (replicate n kType)])
+ i = tupleConstr builtinLoc n
+ in (i, [entry (unIdent i) $ foldr kArrow kType (replicate n kType)])
in
- [(mkIdent "IO", [entry "Primitives.IO" kTypeTypeS]),
- (mkIdent "->", [entry "Primitives.->" kTypeTypeTypeS]),
- (mkIdent "Int", [entry "Primitives.Int" kTypeS]),
- (mkIdent "Double", [entry "Primitives.Double" kTypeS]),
- (mkIdent "Word", [entry "Primitives.Word" kTypeS]),
- (mkIdent "Char", [entry "Primitives.Char" kTypeS]),
- (mkIdent "Handle", [entry "Primitives.Handle" kTypeS]),
- (mkIdent "Any", [entry "Primitives.Any" kTypeS]),
- (mkIdent "String", [entry "Data.Char.String" kTypeS]),
- (mkIdent "[]", [entry "Data.List.[]" kTypeTypeS]),
- (mkIdent "()", [entry "Data.Tuple.()" kTypeS]),
- (mkIdent "Bool", [entry "Data.Bool_Type.Bool" kTypeS])] ++
+ [
+ -- The function arrow is bothersome to define in Primtives, so keep it here.
+ (mkIdentB "->", [entry "Primitives.->" kTypeTypeTypeS]),
+ -- Primitives.hs uses the type [], and it's annoying to fix that.
+ (mkIdentB "Data.List.[]", [entry "Data.List.[]" kTypeTypeS])
+ ] ++
map tuple (enumFromTo 2 10)
primValues :: [(Ident, [Entry])]
@@ -289,11 +326,11 @@
let
tuple n =
let
- c = tupleConstr n
+ c = tupleConstr builtinLoc n
vks = [IdKind (mkIdent ("a" ++ showInt i)) kType | i <- enumFromTo 1 n]ts = map tVarK vks
r = tApps c ts
- in (c, [Entry (ECon $ ConData [(c, n)] c) $ ETypeScheme vks $ foldr tArrow r ts ])
+ in (c, [Entry (ECon $ ConData [(c, n)] c) $ EForall vks $ foldr tArrow r ts ])
in map tuple (enumFromTo 2 10)
type T a = TC TCState a
@@ -301,9 +338,6 @@
tCon :: Ident -> EType
tCon = EVar
---tVar :: Ident -> EType
---tVar = EVar
-
tVarK :: IdKind -> EType
tVarK (IdKind i _) = EVar i
@@ -314,7 +348,7 @@
tApps i ts = foldl tApp (tCon i) ts
tArrow :: EType -> EType -> EType
-tArrow a r = tApp (tApp (tConI "Primitives.->") a) r
+tArrow a r = tApp (tApp (tConI builtinLoc "Primitives.->") a) r
kArrow :: EKind -> EKind -> EKind
kArrow = tArrow
@@ -324,23 +358,12 @@
if eqIdent n (mkIdent "->") || eqIdent n (mkIdent "Primitives.->") then Just (a, b) else Nothing
getArrow _ = Nothing
-{--getArrow2 :: EType -> (EType, EType, EType)
-getArrow2 abc =
- case getArrow abc of
- Nothing -> error "getArrow2"
- Just (a, bc) ->
- case getArrow bc of
- Nothing -> error "getArrow2"
- Just (b, c) -> (a, b, c)
--}
-
addUVar :: Int -> EType -> T ()
addUVar i t = T.do
let
add = T.do
- TC mn n tenv senv venv sub <- get
- put (TC mn n tenv senv venv (IM.insert i t sub))
+ TC mn n fx tenv senv venv sub <- get
+ put (TC mn n fx tenv senv venv (IM.insert i t sub))
case t of
EUVar j -> if i == j then T.return () else add
_ -> add
@@ -369,11 +392,13 @@
syns <- gets synTable
case M.lookup i syns of
Nothing -> T.return $ foldl tApp t ts
- Just (ETypeScheme vks tt) ->
- if length vks /= length ts then errorMessage (getSLocIdent i) $ ": bad synonym use: " --X ++ show (i, vks, ts)
+ Just (EForall vks tt) ->
+ if length vks /= length ts then tcError (getSLocIdent i) $ ": bad synonym use: " --X ++ show (i, vks, ts)
else expandSyn $ subst (zip (map idKindIdent vks) ts) tt
+ Just _ -> impossible
EUVar _ -> T.return $ foldl tApp t ts
ESign a _ -> expandSyn a -- Throw away signatures, they don't affect unification
+ EForall iks tt | null ts -> EForall iks <$> expandSyn tt
_ -> impossible
in syn [] at
@@ -391,6 +416,7 @@
Just t -> derefUVar t
EVar _ -> T.return at
ESign t k -> flip ESign k <$> derefUVar t
+ EForall iks t -> EForall iks <$> derefUVar t
_ -> impossible
unify :: --XHasCallStack =>
@@ -406,15 +432,8 @@
unifyR :: --XHasCallStack =>
SLoc -> EType -> EType -> T ()
unifyR loc a b = T.do
--- venv <- gets valueTable
--- tenv <- gets typeTable
--- senv <- gets synTable
let
- bad = errorMessage loc $ ": "
- ++ "Cannot unify " ++ showExpr a ++ " and " ++ showExpr b ++ "\n"
--- ++ show a ++ " - " ++ show b ++ "\n"
--- ++ show tenv ++ "\n"
--- ++ show senv
+ bad = tcError loc $ "Cannot unify " ++ showExpr a ++ " and " ++ showExpr b ++ "\n"
case a of
EVar ia ->
case b of
@@ -427,7 +446,9 @@
EVar _ -> bad
EApp fb xb -> T.do { unify loc fa fb; unify loc xa xb }EUVar i -> addUVar i a
- _ -> impossible
+ _ ->
+ --trace ("impossible unify " ++ showExpr a ++ " = " ++ showExpr b) $+ impossible
EUVar i -> addUVar i b
_ -> impossible
@@ -440,13 +461,13 @@
-- Reset type variable and unification map
tcReset :: T ()
tcReset = T.do
- TC mn _ tenv senv venv _ <- get
- put (TC mn 0 tenv senv venv IM.empty)
+ TC mn _ fx tenv senv venv _ <- get
+ put (TC mn 0 fx tenv senv venv IM.empty)
newUVar :: T EType
newUVar = T.do
- TC mn n tenv senv venv sub <- get
- put (TC mn (n+1) tenv senv venv sub)
+ TC mn n fx tenv senv venv sub <- get
+ put (TC mn (n+1) fx tenv senv venv sub)
T.return (EUVar n)
tLookupInst :: --XHasCallStack =>
@@ -462,28 +483,21 @@
tLookup msg i = T.do
env <- gets valueTable
case M.lookup i env of
- Nothing -> errorMessage (getSLocIdent i) $ ": undefined " ++ msg ++ ": " ++ showIdent i
+ Nothing -> tcError (getSLocIdent i) $ ": undefined " ++ msg ++ ": " ++ showIdent i
-- ++ "\n" ++ show env ;
- Just aes ->
- case aes of
- [] -> impossible
- eee : es ->
- case eee of -- XXX why parse error if combined with pre
- Entry e s ->
- if null es then
- T.return (e, s)
- else
- errorMessage (getSLocIdent i) $ ": ambiguous " ++ showIdent i
+ Just [Entry e s] -> T.return (setSLocExpr (getSLocIdent i) e, s)
+ Just _ -> tcError (getSLocIdent i) $ ": ambiguous " ++ showIdent i
tInst :: ETypeScheme -> T EType
tInst as =
case as of
- ETypeScheme vks t ->
+ EForall vks t ->
if null vks then T.return t
else T.do
let vs = map idKindIdent vks
us <- T.mapM (const newUVar) (replicate (length vs) ())
T.return (subst (zip vs us) t)
+ t -> T.return t
extValE :: --XHasCallStack =>
Ident -> ETypeScheme -> Expr -> T ()
@@ -518,6 +532,12 @@
senv <- gets synTable
putSynTable (M.insert i t senv)
+extFix :: Ident -> Fixity -> T ()
+extFix i fx = T.do
+ TC mn n fenv tenv senv venv sub <- get
+ put $ TC mn n (M.insert i fx fenv) tenv senv venv sub
+ T.return ()
+
withExtVal :: forall a . --XHasCallStack =>
Ident -> ETypeScheme -> T a -> T a
withExtVal i t ta = T.do
@@ -536,8 +556,9 @@
putValueTable venv
T.return a
-withExtTyps :: forall a . [(Ident, ETypeScheme)] -> T a -> T a
-withExtTyps env ta = T.do
+withExtTyps :: forall a . [IdKind] -> T a -> T a
+withExtTyps iks ta = T.do
+ let env = map (\ (IdKind v k) -> (v, k)) iks
venv <- gets typeTable
extTyps env
a <- ta
@@ -546,20 +567,20 @@
tcDefs :: [EDef] -> T [EDef]
tcDefs ds = T.do
--- traceM ("tcDefs ds=" ++ show ds)+ T.mapM_ tcAddInfix ds
dst <- tcDefsType ds
T.mapM_ addTypeSyn dst
--- traceM ("tcDefs dst=\n" ++ showEDefs dst)--- tenv <- gets typeTable
--- traceM ("tcDefs tenv=\n" ++ show tenv)--- venv <- gets valueTable
--- traceM ("tcDefs venv=\n" ++ show venv)tcDefsValue dst
+tcAddInfix :: EDef -> T ()
+tcAddInfix (Infix fx is) = T.do
+ mn <- gets moduleName
+ T.mapM_ (\ i -> extFix (qualIdent mn i) fx) is
+tcAddInfix _ = T.return ()
+
tcDefsType :: [EDef] -> T [EDef]
tcDefsType ds = withTypeTable $ T.do
dsk <- T.mapM tcDefKind ds -- Check&rename kinds in all type definitions
--- traceM ("tcDefs dsk=\n" ++ showEDefs dsk)T.mapM_ addTypeKind dsk -- Add the kind of each type to the environment
T.mapM tcDefType dsk
@@ -586,7 +607,7 @@
T.return (reverse r, kkr)
loop r (IdKind i k : iks) = T.do
(kk, _) <- tcTypeT Nothing k
- withExtVal i (ETypeScheme [] kk) $ loop (IdKind i kk : r) iks
+ withExtVal i kk $ loop (IdKind i kk : r) iks
loop [] vks
fun nvks nkr
@@ -606,7 +627,7 @@
addLHSKind :: LHS -> EKind -> T ()
addLHSKind (i, vks) kret =
-- trace ("addLHSKind " ++ showIdent i ++ " :: " ++ showExpr (lhsKind vks kret)) $- extQVal i (ETypeScheme [] $ lhsKind vks kret)
+ extQVal i (lhsKind vks kret)
lhsKind :: [IdKind] -> EKind -> EKind
lhsKind vks kret = foldr (\ (IdKind _ k) -> kArrow k) kret vks
@@ -616,9 +637,9 @@
addTypeSyn adef =
case adef of
Type (i, vs) t -> T.do
- extSyn i (ETypeScheme vs t)
+ extSyn i (EForall vs t)
mn <- gets moduleName
- extSyn (qualIdent mn i) (ETypeScheme vs t)
+ extSyn (qualIdent mn i) (EForall vs t)
_ -> T.return ()
tcDefType :: EDef -> T EDef
@@ -628,24 +649,19 @@
Data lhs cs -> Data lhs <$> withVars (snd lhs) (T.mapM tcConstr cs)
Newtype lhs c t -> Newtype lhs c <$> withVars (snd lhs) (fst <$> tcTypeT (Just kType) t)
Type lhs t -> Type lhs <$> withVars (snd lhs) (fst <$> tcTypeT Nothing t)
- Sign i t -> Sign i <$> tcTypeScheme (Just kType) t
+ Sign i t -> (Sign i . fst) <$> tcTypeT (Just kType) t
+ ForImp ie i t -> (ForImp ie i . fst) <$> tcTypeT (Just kType) t
_ -> T.return d
-tcTypeScheme :: --XHasCallStack =>
- Maybe EKind -> ETypeScheme -> T ETypeScheme
-tcTypeScheme mk (ETypeScheme vks t) =
- withVks vks kType $ \ vvks _ ->
- ETypeScheme vvks <$> withVars vvks (fst <$> tcTypeT mk t)
-
withVars :: forall a . [IdKind] -> T a -> T a
withVars aiks ta =
case aiks of
[] -> ta
IdKind i k : iks -> T.do
- withExtVal i (ETypeScheme [] k) $ withVars iks ta
+ withExtVal i k $ withVars iks ta
tcConstr :: Constr -> T Constr
-tcConstr (i, ts) = pair i <$> T.mapM (\ t -> fst <$> tcTypeT (Just kType) t) ts
+tcConstr (i, ts) = (i,) <$> T.mapM (\ t -> fst <$> tcTypeT (Just kType) t) ts
tcDefsValue :: [EDef] -> T [EDef]
tcDefsValue ds = T.do
@@ -664,14 +680,21 @@
cti = [ (qualIdent mn c, length ts) | (c, ts) <- cs ]
tret = foldl tApp (tCon (qualIdent mn i)) (map tVarK vks)
addCon (c, ts) =
- extValE c (ETypeScheme vks $ foldr tArrow tret ts) (ECon $ ConData cti (qualIdent mn c))
+ extValE c (EForall vks $ foldr tArrow tret ts) (ECon $ ConData cti (qualIdent mn c))
T.mapM_ addCon cs
Newtype (i, vks) c t -> T.do
let
tret = foldl tApp (tCon (qualIdent mn i)) (map tVarK vks)
- extValE c (ETypeScheme vks $ tArrow t tret) (ECon $ ConNew (qualIdent mn c))
+ extValE c (EForall vks $ tArrow t tret) (ECon $ ConNew (qualIdent mn c))
+ ForImp _ i t -> T.do
+ extQVal i t
+ extVal (qualIdent mn i) t
_ -> T.return ()
+unForall :: EType -> ([IdKind], EType)
+unForall (EForall iks t) = (iks, t)
+unForall t = ([], t)
+
tcDefValue :: --XHasCallStack =>
EDef -> T EDef
tcDefValue adef =
@@ -678,14 +701,14 @@
case adef of
Fcn i eqns -> T.do
-- traceM $ "tcDefValue: " ++ showLHS (i, vs) ++ " = " ++ showExpr rhs
- (_, ETypeScheme iks tfn) <- tLookup "no type signature" i
+ (_, tt) <- tLookup "no type signature" i
+ let (iks, tfn) = unForall tt
mn <- gets moduleName
- let vks = map (\ (IdKind v k) -> (v, ETypeScheme [] k)) iks
- teqns <- withExtTyps vks $ tcEqns tfn eqns
- --tcExpr (Just t) $ ELam (map EVar vs) rhs
+ teqns <- withExtTyps iks $ tcEqns tfn eqns
T.return $ Fcn (qualIdent mn i) teqns
--- (et, _) <- withExtTyps vks (tcExpr (Just t) (foldr eLam1 rhs vs))
--- T.return (Fcn (qualIdent mn i, vs) (dropLam (length vs) et))
+ ForImp ie i t -> T.do
+ mn <- gets moduleName
+ T.return (ForImp ie (qualIdent mn i) t)
_ -> T.return adef
-- Kind check a type while already in type checking mode
@@ -716,23 +739,36 @@
tcExprR :: --XHasCallStack =>
Maybe EType -> Expr -> T (Typed Expr)
tcExprR mt ae =
+ let { loc = getSLocExpr ae } incase ae of
EVar i ->
if isUnderscore i then
-- this only happens with patterns translated into expressions
- pair ae <$> newUVar
+ (ae,) <$> newUVar
else T.do
(e, t) <- tLookupInst "variable" i
--- traceM $ "*** " ++ i ++ " :: " ++ showExpr t ++ " = " ++ showMaybe showExpr mt
- munify (getSLocIdent i) mt t
- T.return (e, t)
+ case mt of
+ Just tu@(EForall _ tt) -> T.do
+ unify loc tt t -- XXX is this really sufficient?
+ T.return (e, tu)
+ _ -> T.do
+ munify loc mt t
+ T.return (e, t)
EApp f a -> T.do
+ (ef, tf) <- tcExpr Nothing f
+ (ta, tr) <- unArrow loc tf
+ (ea, _) <- tcExpr (Just ta) a
+ munify loc mt tr
+ T.return (EApp ef ea, tr)
+{- slower and uses more memory(ea, ta) <- tcExpr Nothing a
tr <- unMType mt
(ef, _) <- tcExpr (Just (tArrow ta tr)) f
T.return (EApp ef ea, tr)
+-}
+ EOper e ies -> tcOper mt e ies
ELam is e -> tcExprLam mt is e
- ELit loc l -> tcLit mt loc l
+ ELit loc' l -> tcLit mt loc' l
ECase a arms -> T.do
(ea, ta) <- tcExpr Nothing a
tt <- unMType mt
@@ -744,71 +780,52 @@
n = length es
(ees, tes) <- T.fmap unzip (T.mapM (tcExpr Nothing) es)
let
- ttup = tApps (tupleConstr n) tes
- munify (getSLocExpr ae) mt ttup
+ ttup = tApps (tupleConstr loc n) tes
+ munify loc mt ttup
T.return (ETuple ees, ttup)
- EList es -> T.do
- (ees, ts) <- T.fmap unzip (T.mapM (tcExpr Nothing) es)
- te <- case ts of
- [] -> newUVar
- t : _ -> T.return t
- let
- tlist = tApps (mkIdent "Data.List.[]") [te]
- munify (getSLocExpr ae) mt tlist
- T.return (EList ees, tlist)
EDo mmn ass -> T.do
case ass of
[] -> impossible
- as : ss ->
- if null ss then
- case as of
- SThen a -> T.do
- (ea, ta) <- tcExpr mt a
- let
- sbind = maybe (mkIdent ">>=") (\ mn -> qualIdent mn (mkIdent ">>=")) mmn
- (EVar qi, _) <- tLookupInst "variable" sbind
- let
- mn = moduleOf qi
- T.return (EDo (Just mn) [SThen ea], ta)
- _ -> errorMessage (getSLocExpr ae) $ "bad do "
- --X++ show as
- else
- case as of
- SBind p a -> T.do
- let
- sbind = maybe (mkIdent ">>=") (\ mn -> qualIdent mn (mkIdent ">>=")) mmn
- (EApp (EApp _ ea) (ELam _ (ECase _ ((ep, EAlts [(_, EDo mn ys)] _): _)))
- , tr) <-
- tcExpr Nothing (EApp (EApp (EVar sbind) a)
- (ELam [eVarI "$x"] (ECase (eVarI "$x") [(p, EAlts [([], EDo mmn ss)] [])])))
- T.return (EDo mn (SBind ep ea : ys), tr)
- SThen a -> T.do
- let
- sthen = maybe (mkIdent ">>") (\ mn -> qualIdent mn (mkIdent ">>") ) mmn
- (EApp (EApp _ ea) (EDo mn ys), tr) <-
- tcExpr Nothing (EApp (EApp (EVar sthen) a) (EDo mmn ss))
- T.return (EDo mn (SThen ea : ys), tr)
-
- SLet bs -> T.do
- (ELet ebs (EDo mn ys), tr) <-
- tcExpr Nothing (ELet bs (EDo mmn ss))
- T.return (EDo mn (SLet ebs : ys), tr)
-
- ESectL e i -> T.do
- (EApp (EVar ii) ee, t) <- tcExpr mt (EApp (EVar i) e)
- T.return (ESectL ee ii, t)
- ESectR i e -> T.do
- (ELam _ (EApp (EApp var _) ee), t) <- tcExpr mt (ELam [eVarI "$x"] (EApp (EApp (EVar i) (eVarI "$x")) e))
- T.return (ESectR (getIdent var) ee, t)
+ [as] ->
+ case as of
+ SThen a -> tcExpr mt a
+ _ -> tcError loc $ "bad do "
+ as : ss -> T.do
+ case as of
+ SBind p a -> T.do
+ let
+ sbind = maybe (mkIdentSLoc loc ">>=") (\ mn -> qualIdent mn (mkIdentSLoc loc ">>=")) mmn
+ tcExpr mt (EApp (EApp (EVar sbind) a)
+ (ELam [eVarI loc "$x"] (ECase (eVarI loc "$x") [(p, EAlts [([], EDo mmn ss)] [])])))
+ SThen a -> T.do
+ let
+ sthen = maybe (mkIdentSLoc loc ">>") (\ mn -> qualIdent mn (mkIdentSLoc loc ">>") ) mmn
+ tcExpr mt (EApp (EApp (EVar sthen) a) (EDo mmn ss))
+
+ SLet bs ->
+ tcExpr mt (ELet bs (EDo mmn ss))
+
+ ESectL e i -> tcExpr mt (EApp (EVar i) e)
+ ESectR i e ->
+ tcExpr mt (ELam [eVarI loc "$x"] (EApp (EApp (EVar i) (eVarI loc"$x")) e))
EIf e1 e2 e3 -> T.do
- (ee1, _) <- tcExpr (Just tBool) e1
+ (ee1, _) <- tcExpr (Just (tBool (getSLocExpr e1))) e1
(ee2, te2) <- tcExpr mt e2
(ee3, te3) <- tcExpr mt e3
- unify (getSLocExpr ae) te2 te3
+ unify loc te2 te3
T.return (EIf ee1 ee2 ee3, te2)
- ECompr eret ass -> T.do
+ EListish (LList es) -> T.do
+ (ees, ts) <- T.fmap unzip (T.mapM (tcExpr Nothing) es)
+ te <- case ts of
+ [] -> newUVar
+ t : _ -> T.return t
let
- --XdoStmts :: [EStmt] -> [EStmt] -> T ([EStmt], Typed Expr)
+ tlist = tApp (tList loc) te
+ munify loc mt tlist
+ T.return (EListish (LList ees), tlist)
+ EListish (LCompr eret ass) -> T.do
+ let
+ doStmts :: [EStmt] -> [EStmt] -> T ([EStmt], Typed Expr)
doStmts rss xs =
case xs of
[] -> T.do
@@ -818,11 +835,11 @@
case as of
SBind p a -> T.do
v <- newUVar
- (ea, _) <- tcExpr (Just $ tApp tList v) a
+ (ea, _) <- tcExpr (Just $ tApp (tList loc) v) a
tcPat v p $ \ ep ->
doStmts (SBind ep ea : rss) ss
SThen a -> T.do
- (ea, _) <- tcExpr (Just tBool) a
+ (ea, _) <- tcExpr (Just (tBool (getSLocExpr a))) a
doStmts (SThen ea : rss) ss
SLet bs ->
tcBinds bs $ \ ebs ->
@@ -829,38 +846,95 @@
doStmts (SLet ebs : rss) ss
(rss, (ea, ta)) <- doStmts [] ass
let
- tr = tApp tList ta
- munify (getSLocExpr ae) mt tr
- T.return (ECompr ea rss, tr)
+ tr = tApp (tList loc) ta
+ munify loc mt tr
+ T.return (EListish (LCompr ea rss), tr)
+ EListish (LFrom e) -> tcExpr mt (enum loc "From" [e])
+ EListish (LFromTo e1 e2) -> tcExpr mt (enum loc "FromTo" [e1, e2])
+ EListish (LFromThen e1 e2) -> tcExpr mt (enum loc "FromThen" [e1,e2])
+ EListish (LFromThenTo e1 e2 e3) -> tcExpr mt (enum loc "FromThenTo" [e1,e2,e3])
ESign e t -> T.do
(tt, _) <- tcType (Just kType) t
(ee, _) <- tcExpr (Just tt) e
- munify (getSLocExpr ae) mt tt
- T.return (ESign ee tt, tt)
+ munify loc mt tt
+ T.return (ee, tt)
EAt i e -> T.do
(ee, t) <- tcExpr mt e
(_, ti) <- tLookupInst "impossible!" i
- unify (getSLocExpr ae) t ti
+ unify loc t ti
T.return (EAt i ee, t)
- -----
- EUVar _ -> impossible -- shouldn't happen
- ECon _ -> impossible
+ EForall vks t ->
+ withVks vks kType $ \ vvks _ -> T.do
+ (tt, k) <- withVars vvks (tcExpr mt t)
+ T.return (EForall vvks tt, k)
+ _ -> impossible
+enum :: SLoc -> String -> [Expr] -> Expr
+enum loc f = foldl EApp (EVar (mkIdentSLoc loc ("enum" ++ f)))+
tcLit :: Maybe EType -> SLoc -> Lit -> T (Typed Expr)
tcLit mt loc l =
let { lit t = T.do { munify loc mt t; T.return (ELit loc l, t) } } incase l of
- LInt _ -> lit (tConI "Primitives.Int")
- LDouble _ -> lit (tConI "Primitives.Double")
- LChar _ -> lit (tConI "Primitives.Char")
- LStr _ -> lit (tApps (mkIdent "Data.List.[]") [tConI "Primitives.Char"])
+ LInt _ -> lit (tConI loc "Primitives.Int")
+ LDouble _ -> lit (tConI loc "Primitives.Double")
+ LChar _ -> lit (tConI loc "Primitives.Char")
+ LStr _ -> lit (tApp (tConI loc "Data.List.[]") (tConI loc "Primitives.Char"))
LPrim _ -> T.do
t <- unMType mt -- pretend it is anything
T.return (ELit loc l, t)
+ LForImp _ -> impossible
-unArrow :: SLoc -> Maybe EType -> T (EType, EType)
-unArrow _ Nothing = T.do { a <- newUVar; r <- newUVar; T.return (a, r) }-unArrow loc (Just t) =
+
+tcOper :: Maybe EType -> Expr -> [(Ident, Expr)] -> T (Typed Expr)
+tcOper mt ae aies = T.do
+ let
+ appOp (f, ft) (e1, t1) (e2, t2) = T.do
+ let l = getSLocExpr f
+ (fta1, ftr1) <- unArrow l ft
+ (fta2, ftr2) <- unArrow l ftr1
+ unify l fta1 t1
+ unify l fta2 t2
+-- traceM (showExpr (EApp (EApp f e1) e2))
+ T.return (EApp (EApp f e1) e2, ftr2)
+
+ doOp (e1:e2:es) o os ies = T.do
+ e <- appOp o e2 e1
+ calc (e:es) os ies
+ doOp _ _ _ _ = impossible
+
+ calc :: [Typed Expr] -> [(Typed Expr, Fixity)] -> [((Typed Expr, Fixity), Expr)] -> T (Typed Expr)
+ calc [et@(_, t)] [] [] = T.do munify (getSLocExpr ae) mt t; T.return et
+ calc es ((o, _):os) [] = doOp es o os []
+ calc es oos@((oy, (ay, py)):os) iies@((oo@(ox, (ax, px)), e) : ies) = T.do
+-- traceM (show ((unIdent (getIdent (fst o)), ay, py), (unIdent i, ax, px)))
+ if px == py && (not (eqAssoc ax ay) || eqAssoc ax AssocNone) then
+ tcError (getSLocExpr (fst ox)) "Ambiguous operator expression"
+ else if px < py || eqAssoc ax AssocLeft && px == py then
+ doOp es oy os iies
+ else T.do
+ et <- tcExpr Nothing e
+ calc (et:es) (oo : oos) ies
+ calc es [] ((o, e) : ies) = T.do
+ ee <- tcExpr Nothing e
+ calc (ee:es) [o] ies
+ calc _ _ _ = impossible
+
+ opfix fixs (i, e) = T.do
+ o@(ei, _) <- tcExpr Nothing (EVar i)
+ let fx = getFixity fixs (getIdent ei)
+ T.return ((o, fx), e)
+
+ aet <- tcExpr Nothing ae
+ fixs <- gets fixTable
+-- traceM $ unlines $ map show [(unIdent i, fx) | (i, fx) <- M.toList fixs]
+ ites <- T.mapM (opfix fixs) aies
+ et@(_, t) <- calc [aet] [] ites
+ munify (getSLocExpr ae) mt t
+ T.return et
+
+unArrow :: SLoc -> EType -> T (EType, EType)
+unArrow loc t =
case getArrow t of
Just ar -> T.return ar
Nothing -> T.do
@@ -869,10 +943,13 @@
unify loc t (tArrow a r)
T.return (a, r)
+getFixity :: FixTable -> Ident -> Fixity
+getFixity fixs i = fromMaybe (AssocLeft, 9) $ M.lookup i fixs
+
tcPats :: forall a . EType -> [EPat] -> (EType -> [Typed EPat] -> T a) -> T a
tcPats t [] ta = ta t []
tcPats t (p:ps) ta = T.do
- (tp, tr) <- unArrow (getSLocExpr p) (Just t)
+ (tp, tr) <- unArrow (getSLocExpr p) t
tcPat tp p $ \ pp -> tcPats tr ps $ \ tt pps -> ta tt ((pp, tp) : pps)
tcExprLam :: Maybe EType -> [EPat] -> Expr -> T (Typed Expr)
@@ -908,7 +985,7 @@
(ee, tt) <- tcExpr Nothing e
tcPat tt p $ \ pp -> ta (SBind pp ee)
tcGuard (SThen e) ta = T.do
- (ee, _) <- tcExpr (Just tBool) e
+ (ee, _) <- tcExpr (Just (tBool (getSLocExpr e))) e
ta (SThen ee)
tcGuard (SLet bs) ta = tcBinds bs $ \ bbs -> ta (SLet bbs)
@@ -920,9 +997,11 @@
T.return (pp, aalts)
tcPat ::forall a . EType -> EPat -> (EPat -> T a) -> T a
+tcPat t p@(EVar v) ta | not (isConIdent v) = T.do -- simple special case
+ withExtVals [(v, t)] $ ta p
tcPat t ap ta = T.do
-- traceM $ "tcPat: " ++ show ap
- env <- T.mapM (\ v -> (pair v . ETypeScheme []) <$> newUVar) $ filter (not . isUnderscore) $ patVars ap
+ env <- T.mapM (\ v -> (v,) <$> newUVar) $ filter (not . isUnderscore) $ patVars ap
withExtVals env $ T.do
(pp, _) <- tcExpr (Just t) ap
() <- checkArity (getSLocExpr ap) 0 pp
@@ -930,7 +1009,7 @@
checkArity :: SLoc -> Int -> EPat -> T ()
checkArity loc n (EApp f _) = checkArity loc (n+1) f
-checkArity loc n (ECon c) = if n == conArity c then T.return () else errorMessage loc ": con arity"
+checkArity loc n (ECon c) = if n == conArity c then T.return () else tcError loc ": con arity"
checkArity _ _ _ = T.return ()
-- XXX No mutual recursion yet
@@ -937,32 +1016,43 @@
tcBinds :: forall a . [EBind] -> ([EBind] -> T a) -> T a
tcBinds xbs ta = T.do
let
+ tmap = M.fromList [ (i, t) | BSign i t <- xbs ]
xs = concatMap getBindVars xbs
- xts <- T.mapM (\ x -> T.fmap (pair x . ETypeScheme []) newUVar) xs
+ xts <- T.mapM (tcBindVarT tmap) xs
withExtVals xts $ T.do
nbs <- T.mapM tcBind xbs
ta nbs
+tcBindVarT :: M.Map ETypeScheme -> Ident -> T (Ident, ETypeScheme)
+tcBindVarT tmap x = T.do
+ case M.lookup x tmap of
+ Nothing -> T.do
+ t <- newUVar
+ T.return (x, t)
+ Just t -> T.do
+ tt <- fst <$> (withTypeTable $ tcTypeT (Just kType) t)
+ T.return (x, tt)
+
tcBind :: EBind -> T EBind
tcBind abind =
case abind of
BFcn i eqns -> T.do
- (_, t) <- tLookupInst "impossible!" i
- --(ELam _avs ea, _) <- tcExpr (Just t) $ ELam (map EVar vs) a
- teqns <- tcEqns t eqns
+ (_, tt) <- tLookup "impossible!" i
+ let (iks, tfn) = unForall tt
+ teqns <- withExtTyps iks $ tcEqns tfn eqns
T.return $ BFcn i teqns
--- (ea, _) <- tcExpr (Just t) $ foldr eLam1 a vs
--- T.return $ BFcn (i, vs) $ dropLam (length vs) ea
BPat p a -> T.do
(ep, tp) <- tcExpr Nothing p
(ea, _) <- tcExpr (Just tp) a
T.return $ BPat ep ea
+ BSign _ _ -> T.return abind
getBindVars :: EBind -> [Ident]
getBindVars abind =
case abind of
- BFcn i _ -> [i]
- BPat p _ -> patVars p
+ BFcn i _ -> [i]
+ BPat p _ -> patVars p
+ BSign _ _ -> []
-- Desugar [T] and (T,T,...)
dsType :: EType -> EType
@@ -970,23 +1060,22 @@
case at of
EVar _ -> at
EApp f a -> EApp (dsType f) (dsType a)
- EList ts -> tApps listConstr [dsType (head ts)] -- XXX should be [t]
- ETuple ts -> tApps (tupleConstr (length ts)) (map dsType ts)
+ EOper t ies -> EOper (dsType t) [(i, dsType e) | (i, e) <- ies]
+ EListish (LList [t]) -> tApp (tList (getSLocExpr at)) (dsType t)
+ ETuple ts -> tApps (tupleConstr (getSLocExpr at) (length ts)) (map dsType ts)
ESign t k -> ESign (dsType t) k
+ EForall iks t -> EForall iks (dsType t)
_ -> impossible
-listConstr :: Ident
-listConstr = mkIdent "[]"
+tConI :: SLoc -> String -> EType
+tConI loc = tCon . mkIdentSLoc loc
-tConI :: String -> EType
-tConI = tCon . mkIdent
+tList :: SLoc -> EType
+tList loc = tConI loc "Data.List.[]"
-tList :: EType
-tList = tConI "Data.List.[]"
+tBool :: SLoc -> EType
+tBool loc = tConI loc "Data.Bool_Type.Bool"
-tBool :: EType
-tBool = tConI "Data.Bool_Type.Bool"
-
impossible :: --XHasCallStack =>
forall a . a
impossible = error "impossible"
@@ -994,7 +1083,13 @@
showTModule :: forall a . (a -> String) -> TModule a -> String
showTModule sh amdl =
case amdl of
- TModule mn _ _ _ a -> "Tmodule " ++ showIdent mn ++ "\n" ++ sh a
+ TModule mn _ _ _ _ a -> "Tmodule " ++ showIdent mn ++ "\n" ++ sh a
isUnderscore :: Ident -> Bool
isUnderscore = eqString "_" . unIdent
+
+{-+showValueTable :: ValueTable -> String
+showValueTable vt =
+ unlines $ take 5 [showIdent i ++ " : " ++ showExpr t | (i, [Entry _ t]) <- M.toList vt]
+-}
--- a/src/PrimTable.hs
+++ b/src/PrimTable.hs
@@ -1,4 +1,4 @@
-module PrimTable(module PrimTable, Any) where
+module PrimTable(module PrimTable) where
import Data.Char
import Data.Maybe
import System.IO
@@ -8,22 +8,25 @@
primitive :: String -> Any
primitive s = fromMaybe (error $ "primitive: " ++ s) $ lookup s primOps
-data DIO a = DIO { unDIO :: IO a }+newtype DIO a = DIO { unDIO :: IO a }primOps :: [(String, Any)]
primOps =
[ comb "S" (\ f g x -> f x (g x))
+ , comb "S'" (\ k f g x -> k f x (g x))
, comb "K" (\ x _y -> x)
+ , comb "A" (\ _x y -> y)
+ , comb "T" (\ x y -> y x)
, comb "I" (\ x -> x)
- , comb "C" (\ f g x -> f x g)
- , comb "B" (\ f g x -> f (g x))
- , comb "T" (\ _x y -> y)
, comb "Y" (\ f -> let r = f r in r)
- , comb "P" (\ x y f -> f x y)
- , comb "O" (\ x y _g f -> f x y)
- , comb "S'" (\ k f g x -> k f x (g x))
+ , comb "B" (\ f g x -> f (g x))
, comb "B'" (\ k f g x -> k f (g x))
+ , comb "BK" (\ f g _x -> f g)
+ , comb "C" (\ f g x -> f x g)
, comb "C'" (\ k f g x -> k f x g)
+ , comb "P" (\ x y f -> f x y)
+ , comb "O" (\ x y _g f -> f x y)
+
, arith "+" (+)
, arith "-" (-)
, arith "*" (*)
@@ -79,7 +82,7 @@
putc h c = DIO $ do
-- let h = unsafeCoerce hh :: Handle
-- c = unsafeCoerce cc :: Int
- print (h, c)
+-- print (h, c)
hPutChar h (toEnum c)
-- open = undefined
-- close = undefined
--- /dev/null
+++ b/src/System/Console/SimpleReadline.hs
@@ -1,0 +1,164 @@
+-- Copyright 2023 Lennart Augustsson
+-- See LICENSE file for full license.
+--
+-- Simple readline with line editing and history.
+-- Only assumes the terminal is capable of (sane) backspace.
+module System.Console.SimpleReadline(
+ getInputLine,
+ getInputLineHist
+ ) where
+import Primitives
+import Prelude
+import Data.Char
+import System.IO
+--Ximport Compat
+
+-- Get an input line with editing.
+-- Return Nothing if the input is ^D, otherwise the typed string.
+getInputLine :: String -> IO (Maybe String)
+getInputLine prompt = do
+ putStr prompt
+ (_, r) <- loop ([],[]) "" ""
+ return r
+
+
+-- Get an input line with editing.
+-- Return Nothing if the input is ^D, otherwise the typed string.
+-- The FilePath gives the name of a file that stores the history.
+getInputLineHist :: FilePath -> String -> IO (Maybe String)
+getInputLineHist hfn prompt = do
+ mhdl <- openFileM hfn ReadMode
+ hist <-
+ case mhdl of
+ Nothing -> return []
+ Just hdl -> do
+ file <- hGetContents hdl
+ let h = lines file
+ seq (length h) (return h) -- force file to be read
+ putStr prompt
+ (hist', r) <- loop (reverse hist, []) "" ""
+-- putStrLn $ "done: " ++ hfn ++ "\n" ++ unlines hist'
+ writeFile hfn $ unlines hist'
+ return r -- XXX no type error
+
+getRaw :: IO Int
+getRaw = do
+ i <- primGetRaw
+ when (i < 0) $
+ error "getRaw failed"
+ return i
+
+type Hist = ([String], [String])
+
+loop :: Hist -> String -> String -> IO ([String], Maybe String)
+loop hist before after = do
+ hFlush stdout
+ i <- getRaw
+ let
+ cur = reverse before ++ after
+ back n = putStr (replicate n '\b')
+
+ add c = do
+ putChar c
+ putStr after
+ back (length after)
+ loop hist (c:before) after
+ backward =
+ case before of
+ [] -> noop
+ c:cs -> do
+ back 1
+ loop hist cs (c:after)
+ forward =
+ case after of
+ [] -> noop
+ c:cs -> do
+ putChar c
+ loop hist (c:before) cs
+ bol = do
+ back (length before)
+ loop hist "" (reverse before ++ after)
+ eol = do
+ putStr after
+ loop hist (before ++ reverse after) ""
+ bs = do
+ case before of
+ [] -> noop
+ _:cs -> do
+ back 1
+ putStr after
+ putChar ' '
+ back (length after + 1)
+ loop hist cs after
+ send =
+ ret (Just cur)
+ ret ms = do
+ putChar '\n'
+ hFlush stdout
+ let
+ o = reverse (fst hist) ++ snd hist
+ l =
+ case ms of
+ Nothing -> []
+ Just "" -> []
+ Just s | not (null o) && eqString s (last o) -> []
+ | otherwise -> [s]
+ h = o ++ l
+ return (h, ms)
+ erase = do
+ eraseLine
+ loop hist "" ""
+ noop = loop hist before after
+ kill = do
+ putStr after
+ putStr $ concat $ replicate (length after) "\b \b"
+ loop hist before ""
+
+ next =
+ case hist of
+ (_, []) -> noop
+ (p, l:n) -> setLine (l:p, n) l
+ previous =
+ case hist of
+ ([], _) -> noop
+ (l:p, n) -> setLine (p, l:n) l
+ setLine h s = do
+ eraseLine
+ putStr s
+ loop h (reverse s) ""
+
+ eraseLine = do
+ putStr after
+ putStr $ concat $ replicate (length before + length after) "\b \b"
+
+ case i of
+ 4 -> -- CTL-D, EOF
+ if null before && null after then
+ ret Nothing
+ else
+ send
+ 2 -> backward -- CTL-B, backwards
+ 6 -> forward -- CTL-F, forwards
+ 1 -> bol -- CTL-A, beginning of line
+ 5 -> eol -- CTL-E, end of line
+ 8 -> bs -- BS, backspace
+ 127 -> bs -- DEL, backspace
+ 13 -> send -- CR, return
+ 10 -> send -- LF, return
+ 14 -> next -- CTL-N, next line
+ 15 -> previous -- CTL-P, previous line
+ 21 -> erase -- CTL-U, erase line
+ 11 -> kill -- CTL-K, kill to eol
+ 27 -> do -- ESC
+ b <- getRaw
+ if b /= ord '[' then
+ noop
+ else do
+ c <- getRaw
+ case chr c of
+ 'A' -> previous
+ 'B' -> next
+ 'C' -> forward
+ 'D' -> backward
+ _ -> noop
+ _ -> if i >= 32 && i < 127 then add (chr i) else noop
--- a/src/Text/ParserComb.hs
+++ b/src/Text/ParserComb.hs
@@ -13,16 +13,15 @@
many, emany, optional, eoptional,
some, esome,
esepBy, sepBy1, esepBy1,
+ esepEndBy, esepEndBy1,
(<?>), (<|<),
--notFollowedBy,
lookAhead,
inject, nextToken,
- LastFail(..)
+ LastFail(..),
) where
--Ximport Prelude()
import PreludeNoIO
---import Debug.Trace
---import Compat
data LastFail t
= LastFail Int [t] [String]
@@ -59,8 +58,7 @@
pure :: forall s t a . a -> Prsr s t a
pure a = P $ \ t -> Many [(a, t)] noFail
---Xinfixl 1 >>=
---Yinfixl 1 >>=
+infixl 1 >>=
(>>=) :: forall s t a b . Prsr s t a -> (a -> Prsr s t b) -> Prsr s t b
(>>=) p k = P $ \ t ->
case runP p t of
@@ -69,37 +67,29 @@
in case unzip [ (rs, lf) | xs <- xss, let { Many rs lf = xs } ] of(rss, lfs) -> Many (concat rss) (longests (plf : lfs))
--- XXX needs (x,y) <- e
-
---Xinfixl 1 >>
---Yinfixl 1 >>
+infixl 1 >>
(>>) :: forall s t a b . Prsr s t a -> Prsr s t b -> Prsr s t b
(>>) p k = p >>= \ _ -> k
---Xinfixl 4 <*>
---Yinfixl 4 <*>
+infixl 4 <*>
(<*>) :: forall s t a b . Prsr s t (a -> b) -> Prsr s t a -> Prsr s t b
(<*>) m1 m2 = m1 >>= \ x1 -> m2 >>= \ x2 -> pure (x1 x2)
---Xinfixl 4 <*
---Yinfixl 4 <*
+infixl 4 <*
(<*) :: forall s t a b . Prsr s t a -> Prsr s t b -> Prsr s t a
(<*) m1 m2 = m1 >>= \ x1 -> m2 >> pure x1
---Xinfixl 4 *>
---Yinfixl 4 *>
+infixl 4 *>
(*>) :: forall s t a b . Prsr s t a -> Prsr s t b -> Prsr s t b
(*>) m1 m2 = m1 >> m2 >>= \ x2 -> pure x2
---Xinfixl 4 <$>
---Yinfixl 4 <$>
+infixl 4 <$>
(<$>) :: forall s t a b . (a -> b) -> Prsr s t a -> Prsr s t b
(<$>) f p = P $ \ t ->
case runP p t of
Many aus lf -> Many [ (f a, u) | (a, u) <- aus ] lf
---Xinfixl 4 <$
---Yinfixl 4 <$
+infixl 4 <$
(<$) :: forall s t a b . a -> Prsr s t b -> Prsr s t a
(<$) a p = p >> pure a
@@ -109,8 +99,7 @@
empty :: forall s t a . Prsr s t a
empty = P $ \ (ts, _) -> Many [] (LastFail (length ts) (take 1 ts) [])
---Xinfixl 3 <|>
---Yinfixl 3 <|>
+infixl 3 <|>
(<|>) :: forall s t a . Prsr s t a -> Prsr s t a -> Prsr s t a
(<|>) p q = P $ \ t ->
case runP p t of
@@ -131,6 +120,7 @@
modify f = get >>= \ s -> put (f s)
-- Left biased choice
+infixl 3 <|<
(<|<) :: forall s t a . Prsr s t a -> Prsr s t a -> Prsr s t a
(<|<) p q = P $ \ t ->
case runP p t of
@@ -187,6 +177,7 @@
else
Many [] (LastFail (length cs) (take 1 cs) ["eof"])
+infixl 9 <?>
(<?>) :: forall s t a . Prsr s t a -> String -> Prsr s t a
(<?>) p e = P $ \ t ->
-- trace ("<?> " ++ show e) $@@ -225,3 +216,9 @@
esepBy :: forall s t a sep . Prsr s t a -> Prsr s t sep -> Prsr s t [a]
esepBy p sep = esepBy1 p sep <|< pure []
+
+esepEndBy :: forall s t a sep . Prsr s t a -> Prsr s t sep -> Prsr s t [a]
+esepEndBy p sep = esepEndBy1 p sep <|< pure []
+
+esepEndBy1 :: forall s t a sep . Prsr s t a -> Prsr s t sep -> Prsr s t [a]
+esepEndBy1 p sep = (:) <$> p <*> ((sep *> esepEndBy p sep) <|< pure [])
--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -7,6 +7,7 @@
#include <inttypes.h>
#include <locale.h>
#include <ctype.h>
+#include <setjmp.h>
#define GCRED 1 /* do some reductions during GC */
#define FASTTAGS 1 /* compute tag by pointer subtraction */
@@ -14,7 +15,24 @@
#define INTTABLE 1 /* use fixed table of small INT nodes */
#define SANITY 1 /* do some sanity checks */
#define STACKOVL 1 /* check for stack overflow */
+#define GETRAW 1 /* implement raw character get */
+typedef intptr_t value_t; /* Make value the same size as pointers, since they are in a union */
+#define PRIvalue PRIdPTR
+typedef uintptr_t uvalue_t; /* Make unsigned value the same size as pointers, since they are in a union */
+#define PRIuvalue PRIuPTR
+typedef uintptr_t heapoffs_t; /* Heap offsets */
+#define PRIheap PRIuPTR
+typedef uintptr_t tag_t; /* Room for tag, low order bit indicates AP/not-AP */
+typedef intptr_t stackptr_t; /* Index into stack */
+/* These types can be changed for 32 bit platforms. */
+typedef uint64_t counter_t; /* Statistics counter, can be smaller since overflow doesn't matter */
+#define PRIcounter PRIu64
+typedef uint64_t bits_t; /* One word of bits */
+
+/* We cast all FFI functions to this type. It's reasonably portable */
+typedef void (*funptr_t)(void);
+
#if defined(__MINGW32__)
#define ffsl __builtin_ffsll
#endif
@@ -63,6 +81,12 @@
return 0;
}
+int
+getraw()
+{+ return -1; /* too tedious */
+}
+
#else /* defined(_MSC_VER) */
#include <sys/time.h>
@@ -69,10 +93,50 @@
#define PCOMMA "'"
+#if GETRAW
+#include <termios.h>
+#include <unistd.h>
+
+/*
+ * Set the terminal in raw mode and read a single character.
+ * Return this character, or -1 on any kind of failure.
+ */
+int
+getraw(void)
+{+ struct termios old, new;
+ char c;
+ int r;
+
+ if (tcgetattr(0, &old))
+ return -1;
+ cfmakeraw(&new);
+ if (tcsetattr(0, TCSANOW, &new))
+ return -1;
+ r = read(0, &c, 1);
+ (void)tcsetattr(0, TCSANOW, &old);
+ if (r == 1)
+ return c;
+ else
+ return -1;
+}
+#else /* GETRAW */
+
+int
+getraw()
+{+ return -1; /* not implemented */
+}
+
+#endif /* GETRAW */
+
#endif /* !defined(_MSC_VER) */
-#define VERSION "v3.2\n"
+/***************************************/
+
+#define VERSION "v3.5\n"
+
/* Keep permanent nodes for LOW_INT <= i < HIGH_INT */
#define LOW_INT (-10)
#define HIGH_INT 128
@@ -88,18 +152,18 @@
T_FADD, T_FSUB, T_FMUL,
T_FEQ, T_FNE, T_FLT, T_FLE, T_FGT, T_FGE, T_FSHOW,
T_EQ, T_NE, T_LT, T_LE, T_GT, T_GE, T_ULT, T_ULE, T_UGT, T_UGE,
- T_ERROR, T_SEQ,
+ T_ERROR, T_SEQ, T_EQUAL, T_COMPARE, T_RNF,
T_IO_BIND, T_IO_THEN, T_IO_RETURN, T_IO_GETCHAR, T_IO_PUTCHAR,
T_IO_SERIALIZE, T_IO_DESERIALIZE, T_IO_OPEN, T_IO_CLOSE, T_IO_ISNULLHANDLE,
T_IO_STDIN, T_IO_STDOUT, T_IO_STDERR, T_IO_GETARGS, T_IO_DROPARGS,
T_IO_PERFORMIO,
- T_IO_GETTIMEMILLI, T_IO_PRINT,
+ T_IO_GETTIMEMILLI, T_IO_PRINT, T_IO_CATCH,
+ T_IO_CCALL, T_IO_GETRAW, T_IO_FLUSH,
T_STR,
+ T_ISINT, T_ISIO,
T_LAST_TAG,
};
-typedef int64_t value_t;
-
#if NAIVE
/* Naive node representation with minimal unions */
@@ -134,7 +198,7 @@
#define HANDLE(p) (p)->u.file
#define NODE_SIZE sizeof(node)
#define ALLOC_HEAP(n) do { cells = malloc(n * sizeof(node)); if (!cells) memerr(); memset(cells, 0x55, n * sizeof(node)); } while(0)-#define LABEL(n) ((uint64_t)((n) - cells))
+#define LABEL(n) ((heapoffs_t)((n) - cells))
node *cells; /* All cells */
#elif UNIONPTR
@@ -142,7 +206,7 @@
typedef struct node { union {struct node *uufun;
- uint64_t uutag; /* LSB=1 indicates that this is a tag, LSB=0 that this is a T_AP node */
+ tag_t uutag; /* LSB=1 indicates that this is a tag, LSB=0 that this is a T_AP node */
} ufun;
union {struct node *uuarg;
@@ -167,7 +231,7 @@
#define HANDLE(p) (p)->uarg.uufile
#define NODE_SIZE sizeof(node)
#define ALLOC_HEAP(n) do { cells = malloc(n * sizeof(node)); memset(cells, 0x55, n * sizeof(node)); } while(0)-#define LABEL(n) ((uint64_t)((n) - cells))
+#define LABEL(n) ((heapoffs_t)((n) - cells))
node *cells; /* All cells */
#else
@@ -176,14 +240,14 @@
#endif
-uint64_t num_reductions = 0;
-uint64_t num_alloc;
-uint64_t num_gc = 0;
+counter_t num_reductions = 0;
+counter_t num_alloc;
+counter_t num_gc = 0;
double gc_mark_time = 0;
double run_time = 0;
NODEPTR *stack;
-int64_t stack_ptr = -1;
+stackptr_t stack_ptr = -1;
#if STACKOVL
#define PUSH(x) do { if (stack_ptr >= stack_size-1) ERR("stack overflow"); stack[++stack_ptr] = (x); } while(0)#else /* SANITY */
@@ -193,25 +257,32 @@
#define POP(n) stack_ptr -= (n)
#define GCCHECK(n) gc_check((n))
-uint64_t heap_size = HEAP_CELLS; /* number of heap cells */
-uint64_t heap_start; /* first location in heap that needs GC */
-int64_t stack_size = STACK_SIZE;
+heapoffs_t heap_size = HEAP_CELLS; /* number of heap cells */
+heapoffs_t heap_start; /* first location in heap that needs GC */
+stackptr_t stack_size = STACK_SIZE;
-uint64_t num_marked;
-uint64_t max_num_marked = 0;
-uint64_t num_free;
+counter_t num_marked;
+counter_t max_num_marked = 0;
+counter_t num_free;
-#define BITS_PER_UINT64 64
-uint64_t *free_map; /* 1 bit per node, 0=free, 1=used */
-uint64_t free_map_nwords;
-uint64_t next_scan_index;
+#define BITS_PER_WORD (sizeof(bits_t) * 8)
+bits_t *free_map; /* 1 bit per node, 0=free, 1=used */
+heapoffs_t free_map_nwords;
+heapoffs_t next_scan_index;
typedef struct {- size_t b_size;
- size_t b_pos;
+ size_t b_size;
+ size_t b_pos;
uint8_t b_buffer[1];
} BFILE;
+struct handler {+ jmp_buf hdl_buf; /* env storage */
+ struct handler *hdl_old; /* old handler */
+ stackptr_t hdl_stack; /* old stack pointer */
+ NODEPTR hdl_exn; /* used temporarily to pass the exception value */
+} *cur_handler = 0;
+
void
memerr(void)
{@@ -250,30 +321,30 @@
/* Set FREE bit to 0 */
static inline void mark_used(NODEPTR n)
{- uint64_t i = LABEL(n);
+ heapoffs_t i = LABEL(n);
if (i < heap_start)
return;
#if SANITY
- if (i >= free_map_nwords * BITS_PER_UINT64) ERR("mark_used");+ if (i >= free_map_nwords * BITS_PER_WORD) ERR("mark_used");#endif
- free_map[i / BITS_PER_UINT64] &= ~(1ULL << (i % BITS_PER_UINT64));
+ free_map[i / BITS_PER_WORD] &= ~(1ULL << (i % BITS_PER_WORD));
}
/* Test if FREE bit is 0 */
static inline int is_marked_used(NODEPTR n)
{- uint64_t i = LABEL(n);
+ heapoffs_t i = LABEL(n);
if (i < heap_start)
return 1;
#if SANITY
- if (i >= free_map_nwords * BITS_PER_UINT64) ERR("is_marked_used");;+ if (i >= free_map_nwords * BITS_PER_WORD) ERR("is_marked_used");;#endif
- return (free_map[i / BITS_PER_UINT64] & (1ULL << (i % BITS_PER_UINT64))) == 0;
+ return (free_map[i / BITS_PER_WORD] & (1ULL << (i % BITS_PER_WORD))) == 0;
}
static inline void mark_all_free(void)
{- memset(free_map, ~0, free_map_nwords * sizeof(uint64_t));
+ memset(free_map, ~0, free_map_nwords * sizeof(bits_t));
next_scan_index = heap_start;
}
@@ -298,10 +369,10 @@
ERR("alloc_node");#endif
- uint64_t i = next_scan_index / BITS_PER_UINT64;
+ heapoffs_t i = next_scan_index / BITS_PER_WORD;
int k; /* will contain bit pos + 1 */
for(;;) {- uint64_t word = free_map[i];
+ heapoffs_t word = free_map[i];
k = ffsl(word);
if (k)
break;
@@ -311,7 +382,7 @@
ERR("alloc_node free_map");#endif
}
- uint64_t pos = i * BITS_PER_UINT64 + k - 1; /* first free node */
+ heapoffs_t pos = i * BITS_PER_WORD + k - 1; /* first free node */
NODEPTR n = HEAPREF(pos);
mark_used(n);
next_scan_index = pos;
@@ -333,8 +404,9 @@
/* Needed during reduction */
NODEPTR intTable[HIGH_INT - LOW_INT];
-NODEPTR combFalse, comTrue, combUnit, combCons;
-NODEPTR combCC, combIOBIND;
+NODEPTR combFalse, combTrue, combUnit, combCons;
+NODEPTR combCC, combBK, combIOBIND;
+NODEPTR combLT, combEQ, combGT;
/* One node of each kind for primitives, these are never GCd. */
/* We use linear search in this, because almost all lookups
@@ -392,11 +464,15 @@
{ ">=", T_GE }, { "seq", T_SEQ }, { "error", T_ERROR },+ { "equal", T_EQUAL },+ { "compare", T_COMPARE },+ { "rnf", T_RNF },/* IO primops */
{ "IO.>>=", T_IO_BIND }, { "IO.>>", T_IO_THEN }, { "IO.return", T_IO_RETURN }, { "IO.getChar", T_IO_GETCHAR },+ { "IO.getRaw", T_IO_GETRAW }, { "IO.putChar", T_IO_PUTCHAR }, { "IO.serialize", T_IO_SERIALIZE }, { "IO.print", T_IO_PRINT },@@ -403,6 +479,7 @@
{ "IO.deserialize", T_IO_DESERIALIZE }, { "IO.open", T_IO_OPEN }, { "IO.close", T_IO_CLOSE },+ { "IO.flush", T_IO_FLUSH }, { "IO.isNullHandle", T_IO_ISNULLHANDLE }, { "IO.stdin", T_IO_STDIN }, { "IO.stdout", T_IO_STDOUT },@@ -411,6 +488,9 @@
{ "IO.dropArgs", T_IO_DROPARGS }, { "IO.getTimeMilli", T_IO_GETTIMEMILLI }, { "IO.performIO", T_IO_PERFORMIO },+ { "IO.catch", T_IO_CATCH },+ { "isInt", T_ISINT },+ { "isIO", T_ISIO },};
void
@@ -417,8 +497,8 @@
init_nodes(void)
{ALLOC_HEAP(heap_size);
- free_map_nwords = (heap_size + BITS_PER_UINT64 - 1) / BITS_PER_UINT64; /* bytes needed for free map */
- free_map = malloc(free_map_nwords * sizeof(uint64_t));
+ free_map_nwords = (heap_size + BITS_PER_WORD - 1) / BITS_PER_WORD; /* bytes needed for free map */
+ free_map = malloc(free_map_nwords * sizeof(bits_t));
if (!free_map)
memerr();
@@ -432,10 +512,11 @@
SETTAG(n, primops[j].tag);
switch (primops[j].tag) {case T_K: combFalse = n; break;
- case T_A: comTrue = n; break;
+ case T_A: combTrue = n; break;
case T_I: combUnit = n; break;
case T_O: combCons = n; break;
case T_CC: combCC = n; break;
+ case T_BK: combBK = n; break;
case T_IO_BIND: combIOBIND = n; break;
case T_IO_STDIN: SETTAG(n, T_HDL); HANDLE(n) = stdin; break;
case T_IO_STDOUT: SETTAG(n, T_HDL); HANDLE(n) = stdout; break;
@@ -450,10 +531,11 @@
SETTAG(n, t);
switch (t) {case T_K: combFalse = n; break;
- case T_A: comTrue = n; break;
+ case T_A: combTrue = n; break;
case T_I: combUnit = n; break;
case T_O: combCons = n; break;
case T_CC: combCC = n; break;
+ case T_BK: combBK = n; break;
case T_IO_BIND: combIOBIND = n; break;
case T_IO_STDIN: SETTAG(n, T_HDL); HANDLE(n) = stdin; break;
case T_IO_STDOUT: SETTAG(n, T_HDL); HANDLE(n) = stdout; break;
@@ -469,6 +551,16 @@
}
#endif
+ /* The representation of the constructors of
+ * data Ordering = LT | EQ | GT
+ * do not have single constructors.
+ * But we can make compound one, since that are irreducible.
+ */
+#define NEWAP(c, f, a) do { NODEPTR n = HEAPREF(heap_start++); SETTAG(n, T_AP); FUN(n) = (f); ARG(n) = (a); (c) = n;} while(0)+ NEWAP(combLT, combBK, combFalse); /* BK B */
+ NEWAP(combEQ, combFalse, combFalse); /* K K */
+ NEWAP(combGT, combFalse, combTrue); /* K A */
+
#if INTTABLE
/* Allocate permanent Int nodes */
for (int i = LOW_INT; i < HIGH_INT; i++) {@@ -480,15 +572,10 @@
#endif
/* Round up heap_start to the next bitword boundary to avoid the permanent nodes. */
- heap_start = (heap_start + BITS_PER_UINT64 - 1) / BITS_PER_UINT64 * BITS_PER_UINT64;
+ heap_start = (heap_start + BITS_PER_WORD - 1) / BITS_PER_WORD * BITS_PER_WORD;
mark_all_free();
- //for (int64_t i = heap_start; i < heap_size; i++) {- // NODEPTR n = HEAPREF(i);
- // MARK(n) = NOTMARKED;
- // TAG(n) = FREE;
- //}
num_free = heap_size - heap_start;
}
@@ -496,16 +583,22 @@
int red_a, red_k, red_i, red_int;
#endif
+//counter_t mark_depth;
+
/* Mark all used nodes reachable from *np */
void
mark(NODEPTR *np)
{- NODEPTR n = *np;
+ NODEPTR n;
+#if GCRED
value_t i;
+#endif
-#if GCRED
+ // mark_depth++;
+ // if (mark_depth % 10000 == 0)
+ // printf("mark depth %"PRIcounter"\n", mark_depth);top:
-#endif
+ n = *np;
if (GETTAG(n) == T_IND) {#if SANITY
int loop = 0;
@@ -528,6 +621,7 @@
*np = n;
}
if (is_marked_used(n)) {+ // mark_depth--;
return;
}
num_marked++;
@@ -571,8 +665,16 @@
#endif /* INTTABLE */
#endif /* GCRED */
if (GETTAG(n) == T_AP) {+#if 1
mark(&FUN(n));
+ //mark(&ARG(n));
+ np = &ARG(n);
+ goto top; /* Avoid tail recursion */
+#else
mark(&ARG(n));
+ np = &FUN(n);
+ goto top; /* Avoid tail recursion */
+#endif
}
}
@@ -590,7 +692,8 @@
fprintf(stderr, "gc mark\n");
gc_mark_time -= gettime();
mark_all_free();
- for (int64_t i = 0; i <= stack_ptr; i++)
+ // mark_depth = 0;
+ for (stackptr_t i = 0; i <= stack_ptr; i++)
mark(&stack[i]);
t = gettime();
gc_mark_time += t;
@@ -603,7 +706,7 @@
if (num_free < heap_size / 50)
ERR("heap exhausted");if (verbose > 1)
- fprintf(stderr, "gc done, %"PRIu64" free\n", num_free);
+ fprintf(stderr, "gc done, %"PRIcounter" free\n", num_free);
}
/* Check that there are k nodes available, if not then GC. */
@@ -617,6 +720,37 @@
gc();
}
+/*
+ * Table of FFI callable functions.
+ * (For a more flexible solution use dlopen()/dlsym()/dlclose())
+ * The table contains the information needed to do the actual call.
+ * The types are
+ * V void name(void)
+ * I int name(void)
+ * IV void name(int)
+ * II int name(int)
+ * IIV void name(int, int)
+ * III int name(int, int)
+ * more can easily be added.
+ */
+struct {+ const char *ffi_name;
+ const funptr_t ffi_fun;
+ enum { FFI_V, FFI_I, FFI_IV, FFI_II, FFI_IIV, FFI_III } ffi_how;+} ffi_table[] = {+ { "llabs", (funptr_t)llabs, FFI_II },+};
+
+/* Look up an FFI function by name */
+value_t
+lookupFFIname(const char *name)
+{+ for(int i = 0; i < sizeof(ffi_table) / sizeof(ffi_table[0]); i++)
+ if (strcmp(ffi_table[i].ffi_name, name) == 0)
+ return (value_t)i;
+ ERR("lookupFFIname");+}
+
/* If the next input character is c, then consume it, else leave it alone. */
int
gobble(BFILE *f, int c)
@@ -630,10 +764,10 @@
}
}
-int64_t
+value_t
parse_int(BFILE *f)
{- int64_t i = 0;
+ value_t i = 0;
int c = getb(f);
for(;;) {i = i * 10 + c - '0';
@@ -690,15 +824,15 @@
return n;
}
-NODEPTR mkInt(int64_t i);
+NODEPTR mkInt(value_t i);
NODEPTR mkDouble(double d);
/* Table of labelled nodes for sharing during parsing. */
struct shared_entry {- uint64_t label;
+ heapoffs_t label;
NODEPTR node; /* NIL indicates unused */
} *shared_table;
-uint64_t shared_table_size;
+heapoffs_t shared_table_size;
/* Look for the label in the table.
* If it's found, return the node.
@@ -705,7 +839,7 @@
* If not found, return the first empty entry.
*/
NODEPTR *
-find_label(uint64_t label)
+find_label(heapoffs_t label)
{int hash = (int)(label % shared_table_size);
for(int i = hash; ; i++) {@@ -726,7 +860,7 @@
{NODEPTR r;
NODEPTR *nodep;
- int64_t l;
+ heapoffs_t l;
value_t i;
double d;
value_t neg;
@@ -846,6 +980,20 @@
r = mkStrNode(realloc(buffer, p - buffer));
return r;
}
+ case '#':
+ /* An FFI name */
+ for (int j = 0;;) {+ c = getb(f);
+ if (c == ' ' || c == ')') {+ ungetb(c, f);
+ buf[j] = 0;
+ break;
+ }
+ buf[j++] = c;
+ }
+ r = alloc_node(T_IO_CCALL);
+ SETVALUE(r, lookupFFIname(buf));
+ return r;
default:
fprintf(stderr, "parse '%c'\n", c);
ERR("parse default");@@ -870,7 +1018,7 @@
parse_top(BFILE *f)
{checkversion(f);
- uint64_t numLabels = parse_int(f);
+ heapoffs_t numLabels = parse_int(f);
if (!gobble(f, '\n'))
ERR("size parse");gobble(f, '\r'); /* allow extra CR */
@@ -878,7 +1026,7 @@
shared_table = malloc(shared_table_size * sizeof(struct shared_entry));
if (!shared_table)
memerr();
- for(uint64_t i = 0; i < shared_table_size; i++)
+ for(heapoffs_t i = 0; i < shared_table_size; i++)
shared_table[i].node = NIL;
NODEPTR n = parse(f);
free(shared_table);
@@ -924,7 +1072,7 @@
void printrec(FILE *f, NODEPTR n);
-uint64_t num_shared;
+counter_t num_shared;
/* Two bits per node: marked, shared
* 0, 0 -- not visited
@@ -932,22 +1080,22 @@
* 1, 1 -- visited more than once
* 0, 1 -- printed
*/
-uint64_t *marked_bits;
-uint64_t *shared_bits;
-static inline void set_bit(uint64_t *bits, NODEPTR n)
+bits_t *marked_bits;
+bits_t *shared_bits;
+static inline void set_bit(bits_t *bits, NODEPTR n)
{- uint64_t i = LABEL(n);
- bits[i / BITS_PER_UINT64] |= (1ULL << (i % BITS_PER_UINT64));
+ heapoffs_t i = LABEL(n);
+ bits[i / BITS_PER_WORD] |= (1ULL << (i % BITS_PER_WORD));
}
-static inline void clear_bit(uint64_t *bits, NODEPTR n)
+static inline void clear_bit(bits_t *bits, NODEPTR n)
{- uint64_t i = LABEL(n);
- bits[i / BITS_PER_UINT64] &= ~(1ULL << (i % BITS_PER_UINT64));
+ heapoffs_t i = LABEL(n);
+ bits[i / BITS_PER_WORD] &= ~(1ULL << (i % BITS_PER_WORD));
}
-static inline uint64_t test_bit(uint64_t *bits, NODEPTR n)
+static inline int test_bit(bits_t *bits, NODEPTR n)
{- uint64_t i = LABEL(n);
- return bits[i / BITS_PER_UINT64] & (1ULL << (i % BITS_PER_UINT64));
+ heapoffs_t i = LABEL(n);
+ return (bits[i / BITS_PER_WORD] & (1ULL << (i % BITS_PER_WORD))) != 0;
}
/* Mark all reachable nodes, when a marked node is reached, mark it as shared. */
@@ -954,6 +1102,7 @@
void
find_sharing(NODEPTR n)
{+ top:
while (GETTAG(n) == T_IND)
n = INDIR(n);
//printf("find_sharing %p %llu ", n, LABEL(n));@@ -972,7 +1121,8 @@
//printf("unmarked\n");set_bit(marked_bits, n);
find_sharing(FUN(n));
- find_sharing(ARG(n));
+ n = ARG(n);
+ goto top;
}
} else {/* Not an application, so do nothing */
@@ -991,11 +1141,11 @@
/* The node is shared */
if (test_bit(marked_bits, n)) {/* Not yet printed, so emit a label */
- fprintf(f, ":%"PRIu64" ", LABEL(n));
+ fprintf(f, ":%"PRIheap" ", LABEL(n));
clear_bit(marked_bits, n); /* mark as printed */
} else {/* This node has already been printed, so just use a reference. */
- fprintf(f, "_%"PRIu64, LABEL(n));
+ fprintf(f, "_%"PRIheap, LABEL(n));
return;
}
}
@@ -1009,7 +1159,7 @@
printrec(f, ARG(n));
fputc(')', f);break;
- case T_INT: fprintf(f, "%"PRIu64, GETVALUE(n)); break;
+ case T_INT: fprintf(f, "%"PRIvalue, GETVALUE(n)); break;
case T_DOUBLE:
double d;
GETDOUBLEVALUE(n, d);
@@ -1023,6 +1173,8 @@
while ((c = *p++)) { if (c == '"' || c == '\\' || c < ' ' || c > '~') {fprintf(f, "\\%d&", c);
+ } else {+ fputc(c, f);
}
}
fputc('"', f);@@ -1081,11 +1233,15 @@
case T_UGT: fprintf(f, "$u>"); break;
case T_UGE: fprintf(f, "$u>="); break;
case T_ERROR: fprintf(f, "$error"); break;
+ case T_EQUAL: fprintf(f, "$equal"); break;
+ case T_COMPARE: fprintf(f, "$compare"); break;
+ case T_RNF: fprintf(f, "$rnf"); break;
case T_SEQ: fprintf(f, "$seq"); break;
case T_IO_BIND: fprintf(f, "$IO.>>="); break;
case T_IO_THEN: fprintf(f, "$IO.>>"); break;
case T_IO_RETURN: fprintf(f, "$IO.return"); break;
case T_IO_GETCHAR: fprintf(f, "$IO.getChar"); break;
+ case T_IO_GETRAW: fprintf(f, "$IO.getRaw"); break;
case T_IO_PUTCHAR: fprintf(f, "$IO.putChar"); break;
case T_IO_SERIALIZE: fprintf(f, "$IO.serialize"); break;
case T_IO_PRINT: fprintf(f, "$IO.print"); break;
@@ -1092,11 +1248,16 @@
case T_IO_DESERIALIZE: fprintf(f, "$IO.deserialize"); break;
case T_IO_OPEN: fprintf(f, "$IO.open"); break;
case T_IO_CLOSE: fprintf(f, "$IO.close"); break;
+ case T_IO_FLUSH: fprintf(f, "$IO.flush"); break;
case T_IO_ISNULLHANDLE: fprintf(f, "$IO.isNullHandle"); break;
case T_IO_GETARGS: fprintf(f, "$IO.getArgs"); break;
case T_IO_DROPARGS: fprintf(f, "$IO.dropArgs"); break;
case T_IO_GETTIMEMILLI: fprintf(f, "$IO.getTimeMilli"); break;
case T_IO_PERFORMIO: fprintf(f, "$IO.performIO"); break;
+ case T_IO_CCALL: fprintf(f, "#%s", ffi_table[GETVALUE(n)].ffi_name); break;
+ case T_IO_CATCH: fprintf(f, "$IO.catch"); break;
+ case T_ISINT: fprintf(f, "$isInt"); break;
+ case T_ISIO: fprintf(f, "$isIO"); break;
default: ERR("print tag");}
}
@@ -1106,15 +1267,15 @@
print(FILE *f, NODEPTR n, int header)
{num_shared = 0;
- marked_bits = calloc(free_map_nwords, sizeof(uint64_t));
+ marked_bits = calloc(free_map_nwords, sizeof(bits_t));
if (!marked_bits)
memerr();
- shared_bits = calloc(free_map_nwords, sizeof(uint64_t));
+ shared_bits = calloc(free_map_nwords, sizeof(bits_t));
if (!shared_bits)
memerr();
find_sharing(n);
if (header)
- fprintf(f, "%s%"PRIu64"\n", VERSION, num_shared);
+ fprintf(f, "%s%"PRIcounter"\n", VERSION, num_shared);
printrec(f, n);
free(marked_bits);
free(shared_bits);
@@ -1129,7 +1290,7 @@
}
NODEPTR
-mkInt(int64_t i)
+mkInt(value_t i)
{#if INTTABLE
if (LOW_INT <= i && i < HIGH_INT) {@@ -1320,6 +1481,86 @@
return name;
}
+/* Compares anything, but really only works well on strings.
+ * if p < q return -1
+ * if p > q return 1
+ * if p == q return 0
+ */
+int
+compare(NODEPTR p, NODEPTR q)
+{+ int r;
+ value_t x, y;
+ FILE *f, *g;
+
+ top:
+ PUSH(q); /* save for GC */
+ p = evali(p);
+ q = evali(TOP(0));
+ POP(1);
+ enum node_tag ptag = GETTAG(p);
+ enum node_tag qtag = GETTAG(q);
+ if (ptag != qtag) {+ /* Hack to make Nil < Cons */
+ if (ptag == T_K && qtag == T_AP)
+ return -1;
+ if (ptag == T_AP && qtag == T_K)
+ return 1;
+ return ptag < qtag ? -1 : 1;
+ }
+ switch (ptag) {+ case T_AP:
+ PUSH(ARG(p));
+ PUSH(ARG(q));
+ r = compare(FUN(p), FUN(q));
+ if (r != 0) {+ POP(2);
+ return r;
+ }
+ q = TOP(0);
+ p = TOP(1);
+ POP(2);
+ goto top;
+ case T_INT:
+ case T_IO_CCALL:
+ x = GETVALUE(p);
+ y = GETVALUE(q);
+ return x < y ? -1 : x > y ? 1 : 0;
+ case T_HDL:
+ f = HANDLE(p);
+ g = HANDLE(q);
+ return f < g ? -1 : f > g ? 1 : 0;
+ default:
+ return 0;
+ }
+}
+
+void
+rnf_rec(NODEPTR n)
+{+ top:
+ if (test_bit(marked_bits, n))
+ return;
+ set_bit(marked_bits, n);
+ n = evali(n);
+ if (GETTAG(n) == T_AP) {+ rnf_rec(FUN(n));
+ n = ARG(n);
+ goto top;
+ }
+}
+
+void
+rnf(NODEPTR n)
+{+ /* Mark visited nodes to avoid getting stuck in loops. */
+ marked_bits = calloc(free_map_nwords, sizeof(bits_t));
+ if (!marked_bits)
+ memerr();
+ rnf_rec(n);
+ free(marked_bits);
+}
+
NODEPTR evalio(NODEPTR n);
/* Evaluate a node, returns when the node is in WHNF. */
@@ -1326,7 +1567,7 @@
void
eval(NODEPTR n)
{- int64_t stk = stack_ptr;
+ stackptr_t stk = stack_ptr;
NODEPTR x, y, z, w;
value_t xi, yi;
double xd, yd;
@@ -1334,7 +1575,7 @@
double rd;
FILE *hdl;
char *msg;
- int64_t l;
+ heapoffs_t l;
/* Reset stack pointer and return. */
#define RET do { stack_ptr = stk; return; } while(0)@@ -1358,19 +1599,18 @@
#define CHKARG4 do { CHECK(4); POP(4); n = TOP(-1); w = ARG(n); z = ARG(TOP(-2)); y = ARG(TOP(-3)); x = ARG(TOP(-4)); } while(0)/* Alloc a possible GC action, e, between setting x and popping */
-#define CHKARGEV1(e) do { CHECK(1); x = ARG(TOP(0)); e; POP(1); n = TOP(-1); } while(0)+#define CHKARGEV1(e) do { CHECK(1); x = ARG(TOP(0)); e; POP(1); n = TOP(-1); } while(0) #define SETINT(n,r) do { SETTAG((n), T_INT); SETVALUE((n), (r)); } while(0)-#define SETSTRING(n,r) do { SETTAG((n), T_STR); SETVALUE((n), (r)); } while(0) #define SETDOUBLE(n,d) do { SETTAG((n), T_DOUBLE); SETDOUBLEVALUE((n), (d)); } while(0) #define OPINT2(e) do { CHECK(2); xi = evalint(ARG(TOP(0))); yi = evalint(ARG(TOP(1))); e; POP(2); n = TOP(-1); } while(0); #define OPDOUBLE2(e) do { CHECK(2); xd = evaldouble(ARG(TOP(0))); yd = evaldouble(ARG(TOP(1))); e; POP(2); n = TOP(-1); } while(0); #define ARITHBIN(op) do { OPINT2(r = xi op yi); SETINT(n, r); RET; } while(0)-#define ARITHBINU(op) do { OPINT2(r = (int64_t)((uint64_t)xi op (uint64_t)yi)); SETINT(n, r); RET; } while(0)+#define ARITHBINU(op) do { OPINT2(r = (value_t)((uvalue_t)xi op (uvalue_t)yi)); SETINT(n, r); RET; } while(0) #define FARITHBIN(op) do { OPDOUBLE2(rd = xd op yd); SETDOUBLE(n, rd); RET; } while(0) // TODO FIXME #define CMP(op) do { OPINT2(r = xi op yi); GOIND(r ? comTrue : combFalse); } while(0) #define CMPF(op) do { OPDOUBLE2(r = xd op yd); GOIND(r ? comTrue : combFalse); } while(0)-#define CMPU(op) do { OPINT2(r = (uint64_t)xi op (uint64_t)yi); GOIND(r ? comTrue : combFalse); } while(0)+#define CMPU(op) do { OPINT2(r = (uvalue_t)xi op (uvalue_t)yi); GOIND(r ? comTrue : combFalse); } while(0) for(;;) {num_reductions++;
@@ -1379,7 +1619,7 @@
#if FASTTAGSCHECK
if (l < T_IO_BIND) { if (l != GETTAG(n)) {- printf("%lu %lu\n", l, (uint64_t)(GETTAG(n)));+ printf("%lu %lu\n", l, (tag_t)(GETTAG(n))); ERR("bad tag");}
}
@@ -1482,11 +1722,29 @@
case T_UGT: CMPU(>);
case T_UGE: CMPU(>=);
- case T_ERROR: CHKARGEV1(msg = evalstring(x)); fprintf(stderr, "error: %s\n", msg); free(msg); exit(1);
+ case T_ERROR:
+ if (cur_handler) {+ /* Pass the string to the handler */
+ CHKARG1;
+ cur_handler->hdl_exn = x;
+ longjmp(cur_handler->hdl_buf, 1);
+ } else {+ /* No handler, so just die. */
+ CHKARGEV1(msg = evalstring(x));
+ fprintf(stderr, "error: %s\n", msg);
+ free(msg);
+ exit(1);
+ }
case T_SEQ: CHECK(2); eval(ARG(TOP(0))); POP(2); n = TOP(-1); y = ARG(n); GOIND(y); /* seq x y = eval(x); y */
- case T_IO_ISNULLHANDLE: CHKARGEV1(hdl = evalhandleN(x)); GOIND(hdl == 0 ? comTrue : combFalse);
+ case T_EQUAL: r = compare(ARG(TOP(0)), ARG(TOP(1))); POP(2); n = TOP(-1); GOIND(r==0 ? combTrue : combFalse);
+ case T_COMPARE: //r = compare(ARG(TOP(0)), ARG(TOP(1))); POP(2); n = TOP(-1); SETINT(n, r); RET;
+ r = compare(ARG(TOP(0)), ARG(TOP(1))); POP(2); n = TOP(-1); GOIND(r < 0 ? combLT : r > 0 ? combGT : combEQ);
+ case T_RNF: rnf(ARG(TOP(0))); POP(1); n = TOP(-1); GOIND(combUnit);
+
+ case T_IO_ISNULLHANDLE: CHKARGEV1(hdl = evalhandleN(x)); GOIND(hdl == 0 ? combTrue : combFalse);
+
case T_IO_PERFORMIO: CHKARGEV1(x = evalio(x)); GOIND(x);
case T_IO_BIND:
@@ -1493,6 +1751,7 @@
case T_IO_THEN:
case T_IO_RETURN:
case T_IO_GETCHAR:
+ case T_IO_GETRAW:
case T_IO_PUTCHAR:
case T_IO_SERIALIZE:
case T_IO_PRINT:
@@ -1499,11 +1758,29 @@
case T_IO_DESERIALIZE:
case T_IO_OPEN:
case T_IO_CLOSE:
+ case T_IO_FLUSH:
case T_IO_GETARGS:
case T_IO_DROPARGS:
case T_IO_GETTIMEMILLI:
+ case T_IO_CCALL:
+ case T_IO_CATCH:
RET;
+ case T_ISINT:
+ CHECK(1);
+ x = evali(ARG(TOP(0)));
+ n = TOP(0);
+ POP(1);
+ GOIND(GETTAG(x) == T_INT ? combTrue : combFalse);
+
+ case T_ISIO:
+ CHECK(1);
+ x = evali(ARG(TOP(0)));
+ n = TOP(0);
+ POP(1);
+ l = GETTAG(x);
+ GOIND(T_IO_BIND <= l && l <= T_IO_FLUSH ? combTrue : combFalse);
+
default:
fprintf(stderr, "bad tag %d\n", GETTAG(n));
ERR("eval tag");@@ -1516,7 +1793,7 @@
NODEPTR
evalio(NODEPTR n)
{- int64_t stk = stack_ptr;
+ stackptr_t stk = stack_ptr;
NODEPTR f, x;
int c;
int hdr;
@@ -1579,7 +1856,6 @@
case T_IO_RETURN:
CHECKIO(1);
n = ARG(TOP(1));
- POP(1);
RETIO(n);
case T_IO_GETCHAR:
CHECKIO(1);
@@ -1588,6 +1864,12 @@
c = getc(hdl);
n = mkInt(c);
RETIO(n);
+ case T_IO_GETRAW:
+ CHECKIO(0);
+ GCCHECK(1);
+ c = getraw();
+ n = mkInt(c);
+ RETIO(n);
case T_IO_PUTCHAR:
CHECKIO(2);
hdl = evalhandle(ARG(TOP(1)));
@@ -1620,6 +1902,11 @@
HANDLE(n) = 0;
fclose(hdl);
RETIO(combUnit);
+ case T_IO_FLUSH:
+ CHECKIO(1);
+ hdl = evalhandle(ARG(TOP(1)));
+ fflush(hdl);
+ RETIO(combUnit);
case T_IO_OPEN:
CHECKIO(2);
name = evalstring(ARG(TOP(1)));
@@ -1673,6 +1960,55 @@
n = alloc_node(T_INT);
SETVALUE(n, (value_t)(gettime() * 1000));
RETIO(n);
+ case T_IO_CCALL:
+ {+ int a = (int)GETVALUE(n);
+ funptr_t f = ffi_table[a].ffi_fun;
+ value_t r, x, y;
+#define INTARG(n) evalint(ARG(TOP(n)))
+#define FFIV(n) CHECKIO(n)
+#define FFI(n) CHECKIO(n); GCCHECK(1)
+ /* This isn't great, but this is MicroHs, so it's good enough. */
+ switch (ffi_table[a].ffi_how) {+ case FFI_V: FFIV(0); (* f)(); RETIO(combUnit);
+ case FFI_I: FFI (0); r = (*(value_t (*)(void ))f)(); n = mkInt(r); RETIO(n);
+ case FFI_IV: FFIV(1); x = INTARG(1); (*(void (*)(value_t ))f)(x); RETIO(combUnit);
+ case FFI_II: FFI (1); x = INTARG(1); r = (*(value_t (*)(value_t ))f)(x); n = mkInt(r); RETIO(n);
+ case FFI_IIV: FFIV(1); x = INTARG(1); y = INTARG(2); (*(void (*)(value_t, value_t))f)(x,y); RETIO(combUnit);
+ case FFI_III: FFI (1); x = INTARG(1); y = INTARG(2); r = (*(value_t (*)(value_t, value_t))f)(x,y); n = mkInt(r); RETIO(n);
+ default: ERR("T_IO_CCALL");+ }
+ }
+
+ case T_IO_CATCH:
+ {+ struct handler *h = malloc(sizeof *h);
+ if (!h)
+ memerr();
+ CHECKIO(2);
+ h->hdl_old = cur_handler;
+ h->hdl_stack = stack_ptr;
+ cur_handler = h;
+ if (setjmp(h->hdl_buf)) {+ /* An exception occurred: */
+ stack_ptr = h->hdl_stack;
+ x = h->hdl_exn; /* exception value */
+ GCCHECKSAVE(x, 1);
+ f = ARG(TOP(2)); /* second argument, handler */
+ n = new_ap(f, x);
+ cur_handler = h->hdl_old;
+ free(h);
+ POP(3);
+ goto top;
+ } else {+ /* Normal execution: */
+ n = evalio(ARG(TOP(1))); /* execute first argument */
+ cur_handler = h->hdl_old; /* restore old handler */
+ free(h);
+ RETIO(n); /* return result */
+ }
+ }
+
default:
fprintf(stderr, "bad tag %d\n", GETTAG(n));
ERR("evalio tag");@@ -1680,10 +2016,10 @@
}
}
-uint64_t
+heapoffs_t
memsize(const char *p)
{- uint64_t n = atoi(p);
+ heapoffs_t n = atoi(p);
while (isdigit(*p))
p++;
switch (*p) {@@ -1754,7 +2090,7 @@
}
PUSH(prog); gc(); prog = TOP(0); POP(1);
- uint64_t start_size = num_marked;
+ heapoffs_t start_size = num_marked;
if (verbose > 2) {//pp(stdout, prog);
print(stdout, prog, 1);
@@ -1772,16 +2108,16 @@
if (verbose > 1) { printf("\nmain returns ");pp(stdout, res);
- printf("node size=%"PRIu64", heap size bytes=%"PRIu64"\n", (uint64_t)NODE_SIZE, heap_size * NODE_SIZE);+ printf("node size=%"PRIheap", heap size bytes=%"PRIheap"\n", (heapoffs_t)NODE_SIZE, heap_size * NODE_SIZE);}
setlocale(LC_NUMERIC, ""); /* Make %' work on platforms that support it */
- printf("%"PCOMMA"15"PRIu64" combinator file size\n", (uint64_t)file_size);- printf("%"PCOMMA"15"PRIu64" cells at start\n", start_size);- printf("%"PCOMMA"15"PRIu64" cells heap size (%"PCOMMA""PRIu64" bytes)\n", heap_size, heap_size * NODE_SIZE);- printf("%"PCOMMA"15"PRIu64" cells allocated (%"PCOMMA".1f Mbyte/s)\n", num_alloc, num_alloc * NODE_SIZE / run_time / 1000000);- printf("%"PCOMMA"15"PRIu64" GCs\n", num_gc);- printf("%"PCOMMA"15"PRIu64" max cells used\n", max_num_marked);- printf("%"PCOMMA"15"PRIu64" reductions (%"PCOMMA".1f Mred/s)\n", num_reductions, num_reductions / run_time / 1000000);+ printf("%"PCOMMA"15"PRIheap" combinator file size\n", (heapoffs_t)file_size);+ printf("%"PCOMMA"15"PRIheap" cells at start\n", start_size);+ printf("%"PCOMMA"15"PRIheap" cells heap size (%"PCOMMA""PRIheap" bytes)\n", heap_size, heap_size * NODE_SIZE);+ printf("%"PCOMMA"15"PRIcounter" cells allocated (%"PCOMMA".1f Mbyte/s)\n", num_alloc, num_alloc * NODE_SIZE / run_time / 1000000);+ printf("%"PCOMMA"15"PRIcounter" GCs\n", num_gc);+ printf("%"PCOMMA"15"PRIcounter" max cells used\n", max_num_marked);+ printf("%"PCOMMA"15"PRIcounter" reductions (%"PCOMMA".1f Mred/s)\n", num_reductions, num_reductions / run_time / 1000000); printf("%15.2fs total execution time\n", run_time); printf("%15.2fs total gc time\n", gc_mark_time);#if GCRED && 0
--- /dev/null
+++ b/tests/Catch.hs
@@ -1,0 +1,10 @@
+module Catch(main) where
+import Prelude
+import Control.Exception
+
+main :: IO ()
+main = do
+ x <- catch (return ("o" ++ "k")) (\ _ -> return "what?")+ putStrLn $ showString x
+ y <- catch (do { error "bang!"; return "huh?" }) (\ (Exn s) -> return s)+ putStrLn $ showString y
--- /dev/null
+++ b/tests/Catch.ref
@@ -1,0 +1,2 @@
+"ok"
+"bang!"
--- /dev/null
+++ b/tests/Enum.hs
@@ -1,0 +1,12 @@
+module Enum(main) where
+import Prelude
+
+main :: IO ()
+main = do
+ putStrLn $ showList showInt [1 .. 5]
+ putStrLn $ showList showInt [1 .. 1]
+ putStrLn $ showList showInt [1 .. 0]
+ putStrLn $ showList showInt [1,3 .. 10]
+ putStrLn $ showList showInt [1, -1 .. -5]
+ putStrLn $ showList showInt $ take 5 [1 ..]
+ putStrLn $ showList showInt $ take 5 [1,3 ..]
--- /dev/null
+++ b/tests/Enum.ref
@@ -1,0 +1,7 @@
+[1,2,3,4,5]
+[1]
+[]
+[1,3,5,7,9]
+[1,-1,-3,-5]
+[1,2,3,4,5]
+[1,3,5,7,9]
--- /dev/null
+++ b/tests/Foreign.hs
@@ -1,0 +1,11 @@
+module Foreign(main) where
+import Prelude
+
+foreign import ccall "llabs" abs :: Int -> IO Int
+
+main :: IO ()
+main = do
+ x1 <- abs (3 - 8)
+ putStrLn $ showInt x1
+ x2 <- abs (10 - 8)
+ putStrLn $ showInt x2
--- /dev/null
+++ b/tests/Foreign.ref
@@ -1,0 +1,2 @@
+5
+2
--- /dev/null
+++ b/tests/LocalPoly.hs
@@ -1,0 +1,12 @@
+module LocalPoly(main) where
+import Prelude
+
+main :: IO ()
+main = do
+ putStrLn $ showPair (showPair showInt showString) (showPair showString showString) $ f 1 "a"
+
+f :: forall b . Int -> b -> ((Int, b), (b, b))
+f x b = (i x, i b)
+ where
+ i :: forall a . a -> (a, b)
+ i a = (a, b)
--- /dev/null
+++ b/tests/LocalPoly.ref
@@ -1,0 +1,1 @@
+((1,"a"),("a","a"))--- a/tests/Makefile
+++ b/tests/Makefile
@@ -5,6 +5,7 @@
test:
$(MHS) IOTest && (echo q | $(EVAL) a bb ccc | sed 's/^.ms/1ms/' > IOTest.out) && diff IOTest.ref IOTest.out
$(MHS) StringTest && $(EVAL) > StringTest.out && diff StringTest.ref StringTest.out
+<<<<<<< HEAD
$(MHS) ListTest && $(EVAL) > ListTest.out && diff ListTest.ref ListTest.out
$(MHS) Fac && $(EVAL) > Fac.out && diff Fac.ref Fac.out
$(MHS) Misc && $(EVAL) > Misc.out && diff Misc.ref Misc.out
@@ -15,6 +16,23 @@
$(MHS) LitMatch && $(EVAL) > LitMatch.out && diff LitMatch.ref LitMatch.out
$(MHS) Word && $(EVAL) > Word.out && diff Word.ref Word.out
$(MHS) FArith && $(EVAL) > FArith.out && diff FArith.ref FArith.out
+=======
+ $(MHS) ListTest && $(EVAL) > ListTest.out && diff ListTest.ref ListTest.out
+ $(MHS) Fac && $(EVAL) > Fac.out && diff Fac.ref Fac.out
+ $(MHS) Misc && $(EVAL) > Misc.out && diff Misc.ref Misc.out
+ $(MHS) Case && $(EVAL) > Case.out && diff Case.ref Case.out
+ $(MHS) Arith && $(EVAL) > Arith.out && diff Arith.ref Arith.out
+ $(MHS) Guard && $(EVAL) > Guard.out && diff Guard.ref Guard.out
+ $(MHS) Newtype && $(EVAL) > Newtype.out && diff Newtype.ref Newtype.out
+ $(MHS) LitMatch && $(EVAL) > LitMatch.out && diff LitMatch.ref LitMatch.out
+ $(MHS) Word && $(EVAL) > Word.out && diff Word.ref Word.out
+ $(MHS) Enum && $(EVAL) > Enum.out && diff Enum.ref Enum.out
+ $(MHS) Foreign && $(EVAL) > Foreign.out && diff Foreign.ref Foreign.out
+ $(MHS) MutRec && $(EVAL) > MutRec.out && diff MutRec.ref MutRec.out
+ $(MHS) LocalPoly && $(EVAL) > LocalPoly.out && diff LocalPoly.ref LocalPoly.out
+ $(MHS) Rank2 && $(EVAL) > Rank2.out && diff Rank2.ref Rank2.out
+ $(MHS) Catch && $(EVAL) > Catch.out && diff Catch.ref Catch.out
+>>>>>>> augustss-master
time:
@echo Expect about 10s runtime
@@ -22,3 +40,4 @@
clean:
rm -f *.out *.tmp
+
--- /dev/null
+++ b/tests/MutRec.hs
@@ -1,0 +1,8 @@
+module MutRec(main) where
+import Prelude
+
+main :: IO ()
+main = do
+ let even i = if i == 0 then True else odd (i - 1)
+ odd i = if i == 0 then False else even (i - 1)
+ putStrLn $ showList showBool $ map even [1..5] ++ map odd [1..5]
--- /dev/null
+++ b/tests/MutRec.ref
@@ -1,0 +1,1 @@
+[False,True,False,True,False,True,False,True,False,True]
--- a/tests/Nfib.hs
+++ b/tests/Nfib.hs
@@ -1,11 +1,13 @@
-module Nfib(module Nfib) where
+module Nfib(main) where
import Prelude
+nfib :: Int -> Int
nfib n =
case n < 2 of
False -> nfib (n - 1) + nfib (n - 2) + 1
True -> 1
+main :: IO ()
main = print (nfib 38)
-- Typical nfib/s is 10M
--- /dev/null
+++ b/tests/Rank2.hs
@@ -1,0 +1,13 @@
+module Rank2(main) where
+import Prelude
+
+f :: (forall a . a -> a) -> (Int, Bool)
+f i = (i 1, i True)
+
+g :: (forall a . a -> Int -> a) -> (Int, Bool)
+g c = (c 1 1, c True 1)
+
+main :: IO ()
+main = do
+ putStrLn $ showPair showInt showBool $ f id
+ putStrLn $ showPair showInt showBool $ g const
--- /dev/null
+++ b/tests/Rank2.ref
@@ -1,0 +1,2 @@
+(1,True)
+(1,True)
--- /dev/null
+++ b/tests/Readline.hs
@@ -1,0 +1,16 @@
+module Readline(main) where
+import Prelude
+import System.Console.SimpleReadline
+
+main :: IO ()
+main = do
+ putStrLn "Type 'quit' to quit."
+ loop
+
+loop :: IO ()
+loop = do
+ s <- getInputLineHist "hist.txt" "% "
+ case s of
+ Just "quit" -> putStrLn "Bye"
+ _ -> do putStrLn $ showMaybe showString s; loop
+
--- a/tests/StringTest.hs
+++ b/tests/StringTest.hs
@@ -3,6 +3,8 @@
main :: IO ()
main = do
+ putStrLn $ if eqString "abc" "abc" then "yes" else "no"
+ putStrLn $ if eqString "abc" "adc" then "yes" else "no"
putStrLn $ showInt 1234
putStrLn $ showInt 0
putStrLn $ showInt (negate 567)
--- a/tests/StringTest.ref
+++ b/tests/StringTest.ref
@@ -1,3 +1,5 @@
+yes
+no
1234
0
-567
--- a/tests/Word.hs
+++ b/tests/Word.hs
@@ -9,6 +9,5 @@
putStrLn $ W.showWord twoTo32M1
putStrLn $ W.showWord $ (W.*) twoTo32M1 twoTo32M1
-twoTo32M1 :: Word
+twoTo32M1 :: W.Word
twoTo32M1 = W.intToWord 4294967295
-
--
⑨