ref: b27f4ee22b4eaa99d82c1bb3bf841d2109207dd3
parent: 9d32c4872a1e18d8d231dc279ba11721b05c4ada
parent: 22dc68832db4d88b0f27442c74bcfba6b5dab81f
author: Lennart Augustsson <lennart@augustsson.net>
date: Sun Nov 5 10:34:34 EST 2023
Merge branch 'class-ovl'
--- a/Example.hs
+++ b/Example.hs
@@ -10,4 +10,4 @@
let
rs = map fac [1,2,3,10]
putStrLn "Some factorials"
- putStrLn $ showList showInt rs
+ print rs
--- a/Makefile
+++ b/Makefile
@@ -4,14 +4,14 @@
BOOTDIR=ghc-boot
OUTDIR=ghc-out
TOOLS=Tools
-PROF= #-prof -fprof-auto
-EXTS= -XScopedTypeVariables -XQualifiedDo -XTupleSections
+PROF= -prof -fprof-late #-prof -fprof-auto
+EXTS= -XScopedTypeVariables -XTupleSections
GHCB=ghc $(PROF) -outputdir $(BOOTDIR)
-GHCFLAGS=-i -ighc -ilib -i$(BOOTDIR) -hide-all-packages -XNoImplicitPrelude $(EXTS) -F -pgmF $(TOOLS)/convertY.sh
+GHCFLAGS=-i -ighc -ilib -i$(BOOTDIR) -hide-all-packages -XNoImplicitPrelude -XRebindableSyntax $(EXTS) -F -pgmF $(TOOLS)/convertY.sh
GHCC=$(GHCB) $(GHCFLAGS)
GHC=ghc
# $(CURDIR) might not be quite right
-GHCE=$(GHC) $(EXTS) -package mtl -F -pgmF Tools/convertX.sh -outputdir $(OUTDIR)
+GHCE=$(GHC) $(EXTS) -package mtl -package pretty -F -pgmF Tools/convertX.sh -outputdir $(OUTDIR)
GCC=gcc
UPX=upx
ALLSRC=src/*/*.hs lib/*.hs lib/*/*.hs ghc/*.hs ghc/*/*.hs
@@ -22,7 +22,8 @@
all: $(EVAL) $(BIN)/$(MHS)
-everytest: runtest example examplecomb bootboottest bootcombtest
+#everytest: runtest example examplecomb bootboottest bootcombtest
+everytest: runtest example examplecomb bootcombtest
###
### Build evaluator (runtime system)
@@ -30,13 +31,13 @@
# 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)
+ $(GCC) -Wall -O3 src/runtime/eval.c -lm -o $(EVAL)
###
### 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)
+ $(GHCE) -ighc -isrc -Wall -Wno-unrecognised-warning-flags -Wno-x-partial -O src/MicroHs/Main.hs -main-is MicroHs.Main -o $(BIN)/$(MHS)
###
### Build the compiler with ghc, using MicroHs libraries (Prelude, Data.List, etc)
@@ -46,25 +47,42 @@
$(BIN)/boot$(MHS): $(ALLSRC) $(TOOLS)/convertY.sh
rm -rf $(BOOTDIR)
$(GHCB) -c ghc/Primitives.hs
+ $(GHCB) -c ghc/PrimFromInteger.hs
$(GHCB) -c ghc/Data/Bool_Type.hs
+ $(GHCB) -c ghc/Data/Char_Type.hs
+ $(GHCB) -c ghc/Data/List_Type.hs
+ $(GHCB) -c lib/Data/Maybe_Type.hs
$(GHCB) -c ghc/Data/Ordering_Type.hs
$(GHCB) -c ghc/Data/Double.hs
- $(GHCB) -c src/PrimTable.hs
+ $(GHCB) -c ghc/PrimTable.hs
$(GHCC) -c lib/Control/Error.hs
+ $(GHCC) -c lib/Data/Eq.hs
+ $(GHCC) -c lib/Text/Show.hs
+ $(GHCC) -c lib/Data/Bounded.hs
+ $(GHCC) -c lib/Data/Ord.hs
$(GHCC) -c lib/Data/Bool.hs
+ $(GHCC) -c lib/Data/Function.hs
+ $(GHCC) -c lib/Data/Tuple.hs
+ $(GHCC) -c lib/Data/Functor.hs
+ $(GHCC) -c lib/Control/Applicative.hs
+ $(GHCC) -c lib/Control/Monad.hs
+ $(GHCC) -c lib/Data/Integer_Type.hs
+ $(GHCC) -c lib/Data/Num.hs
+ $(GHCC) -c lib/Data/Integral.hs
+ $(GHCC) -c lib/Data/Fractional.hs
$(GHCC) -c lib/Data/Int.hs
$(GHCC) -c lib/Data/Double.hs
$(GHCC) -c lib/Data/Char.hs
$(GHCC) -c lib/Data/Either.hs
- $(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/Data/Maybe.hs
+ $(GHCC) -c lib/Control/Alternative.hs
$(GHCC) -c lib/Text/String.hs
$(GHCC) -c lib/Data/Word.hs
$(GHCC) -c lib/System/IO.hs
$(GHCC) -c lib/System/Environment.hs
+ $(GHCC) -c lib/Data/Integer.hs
$(GHCC) -c lib/Prelude.hs
$(GHCC) -c lib/PreludeNoIO.hs
$(GHCC) -c lib/Data/Map.hs
@@ -76,9 +94,9 @@
$(GHCC) -c lib/Control/DeepSeq.hs
# $(GHCC) -c lib/Debug/Trace.hs
$(GHCC) -c lib/Control/Exception.hs
+ $(GHCC) -c lib/Text/PrettyPrint/HughesPJ.hs
$(GHCC) -c src/System/Console/SimpleReadline.hs
$(GHCC) -c src/Text/ParserComb.hs
- $(GHCC) -c src/MicroHs/Pretty.hs
$(GHCC) -c src/MicroHs/Ident.hs
$(GHCC) -c src/MicroHs/Expr.hs
$(GHCC) -c src/MicroHs/Graph.hs
--- a/MicroHs.cabal
+++ b/MicroHs.cabal
@@ -1,6 +1,6 @@
cabal-version: 3.6
name: MicroHs
-version: 0.2
+version: 0.5
synopsis: A compiler for a small subset of Haskell
license: Apache-2.0
license-file: LICENSE
@@ -22,8 +22,7 @@
Tools/convertY.sh
Tools/Addcombs.hs
comb/*.comb
- ghc/Primitives.hs
- ghc/Data/Bool_Type.hs
+ ghc/**/*.hs
lib/**/*.hs
src/runtime/eval.c
tests/Makefile
@@ -37,9 +36,9 @@
executable mhs
default-language: Haskell98
hs-source-dirs: src ghc
- ghc-options: -Wall -F -pgmF ./Tools/convertX.sh -main-is MicroHs.Main
+ ghc-options: -Wall -Wno-unrecognised-warning-flags -Wno-x-partial -F -pgmF ./Tools/convertX.sh -main-is MicroHs.Main
main-is: MicroHs/Main.hs
- default-extensions: ScopedTypeVariables QualifiedDo PatternGuards TupleSections
+ default-extensions: ScopedTypeVariables PatternGuards TupleSections
other-modules: MicroHs.Compile
MicroHs.Desugar
MicroHs.Exp
@@ -48,7 +47,6 @@
MicroHs.Ident
MicroHs.Lex
MicroHs.Parse
- MicroHs.Pretty
MicroHs.StateIO
MicroHs.IdentMap
MicroHs.Interactive
@@ -58,6 +56,7 @@
PreludeNoIO
Text.ParserComb
System.Console.SimpleReadline
+ Control.Alternative
Data.Double
Compat
CompatIO
@@ -66,6 +65,7 @@
build-depends: base >= 4.10 && < 4.20,
containers >= 0.5 && < 0.8,
deepseq >= 1.1 && < 1.6,
- ghc-prim >= 0.5 && < 0.11,
+ ghc-prim >= 0.5 && < 0.12,
mtl >= 2.0 && < 2.4,
- time >= 1.1 && < 1.15
+ time >= 1.1 && < 1.15,
+ pretty >= 1.0 && < 1.2
--- a/TODO
+++ b/TODO
@@ -1,7 +1,6 @@
* Add strict constructors
* Put on hackage
* Have compile return a Stats record of timing etc
-* Add overloading
* Implement deriving
* Add the possibility to save a compiler cache in a file
- Add SHA checksumming to the C code
@@ -33,3 +32,16 @@
- The IORef will need GC support
* Redo type synonym expansion
- Only non-injective synonyms necessitate expansion(?)
+ - Do expansion during unification
+* Redo handling of synonym and instance tables.
+ - These tables can persist during the compilation
+ and only grow
+* Implement two level tables for instances even in the tricky cases
+* Handle tupled dictionaries better for recursive calls
+* Implement fundeps
+* instance Bits ...
+* Split eval.c
+* Implement defaulting
+
+Bugs
+ * Removing [] from prim table
--- a/Tools/Addcombs.hs
+++ b/Tools/Addcombs.hs
@@ -10,7 +10,7 @@
in as : chunkify n bs
showChunk :: [Char] -> String
-showChunk = concatMap (\ c -> showInt (ord c) ++ ",")
+showChunk = concatMap (\ c -> show (ord c) ++ ",")
main :: IO ()
main = do
@@ -24,7 +24,7 @@
let size = length file
chunks = chunkify 20 file
putStrLn $ "struct { BFILE mets; size_t b_size; size_t b_pos; uint8_t b_buffer[]; } combs =\n { { getb_buf, ungetb_buf, closeb_buf }, "- ++ showInt size ++ ", 0, {"+ ++ show size ++ ", 0, {"mapM_ (putStrLn . showChunk) chunks
putStrLn "}};"
putStrLn "BFILE *comb_internal = (BFILE*)&combs;"
--- a/Tools/Compress.hs
+++ b/Tools/Compress.hs
@@ -35,13 +35,13 @@
t' = if s < maxDict then M.insertBy compareString p' s t else t
in
-- trace ("compress " ++ showString p') $--- trace (showList (showPair showString showInt) (M.toList t)) $
+-- trace show (M.toList t)) $
case M.lookupBy compareString p' t of
Just _ ->
-- trace "found" $
compress t cs p'
Nothing ->
--- trace ("not found p=" ++ showString p ++ " " ++ showMaybe showInt (M.lookupBy compareString p t)) $+-- trace ("not found p=" ++ show p ++ " " ++ show (M.lookupBy compareString p t)) $(t ! p) : compress t' cs [c]
-- Initial table is ' ' .. '~', and '\n'
@@ -59,7 +59,7 @@
in b1 : b2 : b3 : toBytes is
bad :: Char -> Bool
-bad c = not (isPrint c || eqChar c '\n')
+bad c = not (isPrint c || c == '\n')
main :: IO ()
main = do
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
-v4.0
-1051
-((A :0 _935) ((A :1 ((B _981) _0)) ((A :2 (((S' _981) _0) I)) ((A :3 _905) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _934) ((C _75) _5))) ((A :7 (((C' _6) (_952 _71)) ((_75 _950) _70))) ((A :8 ((B ((S _981) _950)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_75 _190)) _10)) ((A :12 ((B (B (_73 _9))) (((C' B) ((B C) _10)) (B _10)))) ((A :13 ((B (B (_73 _9))) (((C' B) ((B C) _10)) (BK _10)))) ((A :14 ((B (_73 _9)) P)) ((A :15 ((B (B (_73 _9))) ((B ((C' C) _10)) (B P)))) ((A :16 _15) ((A :17 ((B (_73 _9)) (B (P _863)))) ((A :18 ((B (_73 _9)) (BK (P _863)))) ((A :19 ((_73 _9) ((S P) I))) ((A :20 ((B (_73 _9)) ((C (S' P)) I))) ((A :21 ((B Y) ((B (B (P (_14 _115)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _116)))))) ((A :22 ((B Y) ((B (B (P (_14 _863)))) ((B (C' B)) (B _13))))) ((A :23 _3) ((A :24 (T (_14 _863))) ((A :25 (_21 _76)) ((A :26 (R _33)) ((A :27 (T _32)) ((A :28 ((P _33) _32)) ((A :29 _33) ((A :30 ((C ((C S') _28)) I)) ((A :31 ((C S) _28)) ((A :32 K) ((A :33 A) ((A :34 _910) ((A :35 _911) ((A :36 (((S' _27) (_902 #97)) ((C _902) #122))) ((A :37 (((S' _27) (_902 #65)) ((C _902) #90))) ((A :38 (((S' _26) _36) _37)) ((A :39 (((S' _27) (_902 #48)) ((C _902) #57))) ((A :40 (((S' _27) (_902 #32)) ((C _902) #126))) ((A :41 _899) ((A :42 _900) ((A :43 _902) ((A :44 _901) ((A :45 (((S' _26) ((C _41) #32)) (((S' _26) ((C _41) #9)) ((C _41) #10)))) ((A :46 ((S ((S (((S' _27) (_43 #65)) ((C _43) #90))) (_33 (((_862 "lib/Data/Char.hs") #3) #8)))) ((B _34) (((C' _82) (((C' _83) _35) (_35 #65))) (_35 #97))))) ((A :47 ((S ((S (((S' _27) (_43 #97)) ((C _43) #97))) (_33 (((_862 "lib/Data/Char.hs") #3) #8)))) ((B _34) (((C' _82) (((C' _83) _35) (_35 #97))) (_35 #65))))) ((A :48 _870) ((A :49 _871) ((A :50 _872) ((A :51 _873) ((A :52 (_49 %0.0)) ((A :53 _48) ((A :54 _49) ((A :55 _50) ((A :56 _51) ((A :57 _874) ((A :58 _875) ((A :59 _57) ((A :60 _58) ((A :61 _876) ((A :62 _877) ((A :63 _878) ((A :64 _879) ((A :65 _61) ((A :66 _62) ((A :67 _63) ((A :68 _64) ((A :69 _880) ((A :70 ((B BK) T)) ((A :71 (BK T)) ((A :72 P) ((A :73 I) ((A :74 (S _907)) ((A :75 B) ((A :76 I) ((A :77 K) ((A :78 C) ((A :79 _906) ((A :80 ((C ((C S') _190)) _191)) ((A :81 (((C' (S' (C' B))) B) I)) ((A :82 _864) ((A :83 _865) ((A :84 _866) ((A :85 _867) ((A :86 _868) ((A :87 _869) ((A :88 (_83 #0)) ((A :89 _887) ((A :90 _888) ((A :91 _889) ((A :92 _890) ((A :93 _891) ((A :94 _892) ((A :95 _89) ((A :96 (BK K)) ((A :97 ((B BK) ((B (B BK)) P))) ((A :98 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :99 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B) ((B (S' S')) (((C' B) ((B _26) (_92 #0))) (_89 #0)))) ((B (B ((C' P) (_87 #1)))) _82))) (C P))) _85)) _86)) ((A :100 _96) ((A :101 (((S' C) ((B (P _178)) (((C' (C' B)) (((C' C) _89) _178)) _179))) ((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') (_89 #0))))) ((B ((C' (C' C)) ((B (B ((S' S') (_89 #1)))) ((B ((C' C) ((B ((C' S') (_89 #2))) (C _101)))) (C _101))))) (C _101))))) (C _101)))) (T K))) (T A)))) ((C _99) #4)))) ((A :102 (_108 _77)) ((A :103 ((_123 (_80 _102)) _100)) ((A :104 ((C (((C' B) ((P _115) (((C' (C' O)) P) K))) (((S' (C' (C' (C' B)))) ((B (B (B (B _105)))) (((S' (C' (C' B))) ((B (B (B _105))) (((S' (C' B)) ((B (B _105)) (((C' B) ((B _121) (T #0))) _104))) (((C' B) ((B _121) (T #1))) _104)))) (((C' B) ((B _121) (T #2))) _104)))) (((C' B) ((B _121) (T #3))) _104)))) ((B T) ((B (B P)) ((C' _82) (_84 #4)))))) ((A :105 ((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) _91)))) ((B ((C' B) _116)) _105)))))) ((B ((C' B) _116)) (C _105)))))))))) (((_862 "lib/Data/IntMap.hs") #3) #8))))))))) ((A :106 ((_75 (_121 _190)) _104)) ((A :107 (((C' C) (((C' C) (C _101)) (_3 "Data.IntMap.!"))) I)) ((A :108 ((B ((C' B) T)) ((B (B Y)) (((C' (C' (S' (S' C)))) ((B ((S' B) ((B (S' P)) (C _97))
\ No newline at end of file
+v4.1
+1418
+((A :0 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :1 (T (BK (BK (BK K))))) ((A :2 (T (K (BK (BK K))))) ((A :3 (T (K (K (BK K))))) ((A :4 (T (K (K (K K))))) ((A :5 (T (K (K (K A))))) ((A :6 (K (noDefault "Alternative.empty"))) ((A :7 (K (noDefault "Alternative.<|>"))) ((A :8 ((S (((S' S') ((B _14) _1)) (((C' _212) ((B _12) _1)) _395))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _394))) ((A :10 (((S' P) _2) (((C' _13) _1) _1165))) ((A :11 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :12 (T (BK (BK (BK K))))) ((A :13 (T (K (BK (BK K))))) ((A :14 (T (K (K (BK K))))) ((A :15 (T (K (K (K K))))) ((A :16 (T (K (K (K A))))) ((A :17 (K (noDefault "Applicative.pure"))) ((A :18 (K (noDefault "Applicative.<*>"))) ((A :19 (((S' B) _14) (((C' _209) _12) _200))) ((A :20 (((S' B) _14) (((C' _212) _12) _201))) ((A :21 _1250) ((A :22 ((B _1291) _21)) ((A :23 (((S' _1291) _21) I)) ((A :24 _1220) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _1249) ((C _199) _26))) ((A :28 (((C' _27) ((_208 _1261) _111)) ((_199 (_34 _1263)) _110))) ((A :29 ((B ((S _1291) (_34 _1263))) _24)) ((A :30 ((B (B (B C))) ((B (B C)) P))) ((A :31 (T (BK (BK K)))) ((A :32 (T (K (BK K)))) ((A :33 (T (K (K K)))) ((A :34 (T (K (K A)))) ((A :35 (K (noDefault "Monad.>>="))) ((A :36 (((C' (C' B)) _32) K)) ((A :37 ((B _13) _31)) ((A :38 (((S' (C' B)) _32) (((S' (C' B)) _32) (B' _34)))) ((A :39 P) ((A :40 (T K)) ((A :41 (T A)) ((A :42 (K _24)) ((A :43 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _394)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _395)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _1165)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _1165))) ((A :46 ((C _43) _200)) ((A :47 ((B _202) _32)) ((A :48 ((B C) ((B C') _32))) ((A :49 ((B _202) _48)) ((A :50 T) ((A :51 ((_207 ((B (B (_197 _50))) ((B ((C' C) _54)) (B P)))) (_211 _51))) ((A :52 (((((_11 _51) ((B (_197 _50)) P)) (_38 _53)) ((B (B (_197 _50))) (((C' B) ((B C) _54)) (BK _54)))) (_20 _52))) ((A :53 ((((_30 _52) ((B (B (_197 _50))) (((C' B) ((B C) _54)) (B _54)))) (_15 _52)) (_13 _52))) ((A :54 (T I)) ((A :55 ((B (_199 _467)) _54)) ((A :56 ((B (_197 _50)) (B (P _1165)))) ((A :57 ((B (_197 _50)) (BK (P _1165)))) ((A :58 ((_197 _50) ((S P) I))) ((A :59 ((B (_197 _50)) ((C (S' P)) I))) ((A :60 ((_137 ((C ((C S') _65)) I)) (_141 _60))) ((A :61 (((_1389 (K ((P (_1398 "False")) (_1398 "True")))) (_1394 _61)) (_1395 _61))) ((A :62 ((_69 _67) _68)) ((A :63 (R _68)) ((A :64 (T _67)) ((A :65 ((P _68) _67)) ((A :66 _68) ((A :67 K) ((A :68 A) ((A :69 P) ((A :70 (T K)) ((A :71 (T A)) ((A :72 (K (noDefault "Bounded.minBound"))) ((A :73 (K (noDefault "Bounded.maxBound"))) ((A :74 ((_137 _1214) _1215)) ((A :75 ((((((((_427 _74) (_436 _75)) _1216) _1217) _1218) _1219) (_441 _75)) (_442 _75))) ((A :76 ((_137 _1224) (_141 _76))) ((A :77 ((((((((_427 _76) _1223) (((C' (C' (_138 _443))) _1223) _447)) (((C' (C' (_139 _443))) _1223) _449)) (((C' (C' (_138 _443))) _1223) _449)) (((C' (C' (_139 _443))) _1223) _449)) (_441 _77)) (_442 _77))) ((A :78 ((_69 (_79 #0)) (_79 #127))) ((A :79 _1225) ((A :80 _1226) ((A :81 (((S' _64) (_1217 #97)) ((C _1217) #122))) ((A :82 (((S' _64) (_1217 #65)) ((C _1217) #90))) ((A :83 (((S' _63) _81) _82)) ((A :84 (((S' _64) (_1217 #48)) ((C _1217) #57))) ((A :85 (((S' _63) _84) (((S' _63) (((S' _64) (_1217 #97)) ((C _1217) #102))) (((S' _64) (_1217 #70)) ((C _1217) #70))))) ((A :86 (((S' _63) _83) _84)) ((A :87 (((S' _64) (_1217 #32)) ((C _1217) #126))) ((A :88 (((S' _63) ((C (_138 _74)) #32)) (((S' _63) ((C (_138 _74)) #9)) ((C (_138 _74)) #10)))) ((A :89 ((S ((S (((S' _64) (_1217 #48)) ((C _1217) #57))) ((S ((S (((S' _64) (_1217 #97)) ((C _1217) #102))) ((S ((C (((S' _64) (_1217 #65)) ((C _1217) #70))) (_24 "digitToInt"))) (((C' (_413 _213)) _80) (((_413 _213) (_80 #65)) #10))))) (((C' (_413 _213)) _80) (((_413 _213) (_80 #97)) #10))))) (((C' (_413 _213)) _80) (_80 #48)))) ((A :90 ((S ((S (((S' _64) (_1217 #65)) ((C _1217) #90))) (_68 (((noMatch "lib/Data/Char.hs") #82) #9)))) ((B _79) ((
\ No newline at end of file
--- /dev/null
+++ b/ghc/Control/Alternative.hs
@@ -1,0 +1,6 @@
+module Control.Alternative(
+ Alternative(..),
+ guard,
+ ) where
+import Control.Applicative
+import Control.Monad
--- /dev/null
+++ b/ghc/Data/Char_Type.hs
@@ -1,0 +1,1 @@
+module Data.Char_Type(Char, String) where
--- /dev/null
+++ b/ghc/Data/List_Type.hs
@@ -1,0 +1,2 @@
+module Data.List_Type((++)) where
+-- There is no need to export anything, ghc always provides the list syntax.
--- /dev/null
+++ b/ghc/PrimFromInteger.hs
@@ -1,0 +1,5 @@
+module PrimFromInteger where
+import qualified Prelude as P
+
+fromInteger :: P.Integer -> P.Int
+fromInteger = P.fromInteger
--- /dev/null
+++ b/ghc/PrimTable.hs
@@ -1,0 +1,91 @@
+module PrimTable(module PrimTable) where
+import Data.Char
+import Data.Maybe
+import System.IO
+import Unsafe.Coerce
+import GHC.Types(Any)
+
+primitive :: String -> Any
+primitive s = fromMaybe (error $ "primitive: " ++ s) $ lookup s primOps
+
+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 "Y" (\ f -> let r = f r in r)
+ , 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 "*" (*)
+ , arith "quot" quot
+ , arith "rem" rem
+ , arith "subtract" subtract
+ , farith "fadd" (+)
+ , farith "fsub" (-)
+ , farith "fmul" (*)
+ , cmp "feq" (==)
+ , cmp "fne" (/=)
+ , cmp "flt" (<)
+ , cmp "fle" (<=)
+ , cmp "fgt" (>)
+ , cmp "fge" (>=)
+ , comb "fshow" (show :: Double -> String)
+ , cmp "==" (==)
+ , cmp "/=" (/=)
+ , cmp "<" (<)
+ , cmp "<=" (<=)
+ , cmp ">" (>)
+ , cmp ">=" (>=)
+ , cmp "error" err
+ , comb "ord" ord
+ , comb "chr" chr
+ , comb "IO.>>=" iobind
+ , comb "IO.>>" iothen
+ , comb "IO.return" ioret
+-- , comb "IO.getChar" getc
+ , comb "IO.putChar" putc
+ , comb "IO.stdin" stdin
+ , comb "IO.stdout" stdout
+ , comb "IO.stderr" stderr
+ ]
+ where
+ comb n f = (n, unsafeCoerce f)
+ arith :: String -> (Int -> Int -> Int) -> (String, Any)
+ arith = comb
+ farith :: String -> (Double -> Double -> Double) -> (String, Any)
+ farith = comb
+ cmp :: String -> (Int -> Int -> Bool) -> (String, Any)
+ cmp n f = comb n (\ x y -> if f x y then cTrue else cFalse)
+ cTrue _x y = y
+ cFalse x _y = x
+ iobind :: DIO a -> (a -> DIO b) -> DIO b
+ iobind a k = DIO (unDIO a >>= \ x -> unDIO (k x))
+ iothen :: DIO a -> DIO b -> DIO b
+ iothen a b = DIO (unDIO a >> unDIO b)
+ ioret :: a -> DIO a
+ ioret a = DIO (return a)
+-- getc h = undefined -- fromEnum <$> hGetChar h -- XXX
+ putc :: Handle -> Int -> DIO ()
+ putc h c = DIO $ do
+-- let h = unsafeCoerce hh :: Handle
+-- c = unsafeCoerce cc :: Int
+-- print (h, c)
+ hPutChar h (toEnum c)
+-- open = undefined
+-- close = undefined
+-- isnull = undefined
+
+ err _ = error "ERROR"
--- a/ghc/Primitives.hs
+++ b/ghc/Primitives.hs
@@ -8,7 +8,10 @@
IO,
Word,
NFData(..),
+ Type,
) where
+import Prelude hiding(fromInteger, fromRational)
+import qualified Prelude as P
import Control.DeepSeq
import Control.Exception(try)
import Data.Time
@@ -18,7 +21,7 @@
import System.IO.Unsafe
import System.Environment
import Unsafe.Coerce
-import GHC.Types(Any)
+import GHC.Types(Any, Type)
primIntAdd :: Int -> Int -> Int
primIntAdd = (+)
@@ -86,8 +89,8 @@
primError :: String -> a
primError = error
-primEqString :: String -> String -> Bool
-primEqString = (==)
+primStringEQ :: String -> String -> Bool
+primStringEQ = (==)
primUnsafeCoerce :: a -> b
primUnsafeCoerce = unsafeCoerce
@@ -164,6 +167,9 @@
primDoubleRead :: [Char] -> Double
primDoubleRead = read
+primDoubleFromInt :: Int -> Double
+primDoubleFromInt = fromIntegral
+
------
primBind :: IO a -> (a -> IO b) -> IO b
@@ -237,3 +243,12 @@
primRnf :: (NFData a) => a -> ()
primRnf = rnf
+
+--fromInteger :: Integer -> Int
+--fromInteger = P.fromInteger
+
+fromRational :: Rational -> Double
+fromRational = P.fromRational
+
+ifThenElse :: Bool -> a -> a -> a
+ifThenElse c t e = if c then t else e
--- /dev/null
+++ b/lib/Control/Alternative.hs
@@ -1,0 +1,21 @@
+module Control.Alternative(module Control.Alternative) where
+import Primitives
+import Control.Applicative
+import Data.Bool_Type
+import Data.Functor
+import Data.List
+
+infixl 3 <|>
+
+class Applicative f => Alternative (f :: Type -> Type) where
+ empty :: forall a . f a
+ (<|>) :: forall a . f a -> f a -> f a
+
+ some :: forall a . f a -> f [a]
+ some a = (:) <$> a <*> many a
+
+ many :: forall a . f a -> f [a]
+ many a = some a <|> pure []
+
+guard :: forall (f :: Type -> Type) a . Alternative f => Bool -> f ()
+guard b = if b then pure () else empty
--- /dev/null
+++ b/lib/Control/Applicative.hs
@@ -1,0 +1,16 @@
+module Control.Applicative(module Control.Applicative) where
+import Primitives -- for fixity
+import Data.Functor
+import Data.Function
+
+infixl 4 <*>
+infixl 4 *>
+infixl 4 <*
+
+class Functor f => Applicative (f :: Type -> Type) where
+ pure :: forall a . a -> f a
+ (<*>) :: forall a b . f (a -> b) -> f a -> f b
+ (*>) :: forall a b . f a -> f b -> f b
+ (<*) :: forall a b . f a -> f b -> f a
+ a1 *> a2 = (id <$ a1) <*> a2
+ a1 <* a2 = (const <$> a1) <*> a2
--- a/lib/Control/Error.hs
+++ b/lib/Control/Error.hs
@@ -2,8 +2,9 @@
-- See LICENSE file for full license.
module Control.Error(module Control.Error) where
import Primitives
+import Data.Char_Type
-error :: forall a . [Char] -> a
+error :: forall a . String -> a
error = primError
undefined :: forall a . a
--- /dev/null
+++ b/lib/Control/Monad.hs
@@ -1,0 +1,90 @@
+module Control.Monad(module Control.Monad) where
+import Primitives -- for fixity
+import Control.Applicative
+import Control.Error
+import Data.Bool
+import Data.Char_Type
+import Data.Function
+import Data.Functor
+import Data.List_Type
+--import Data.Maybe
+
+infixl 1 >>
+infixl 1 >>=
+
+class (Applicative m) => Monad (m :: Type -> Type) where
+ (>>=) :: forall a b . m a -> (a -> m b) -> m b
+ (>>) :: forall a b . m a -> m b -> m b
+ ma >> mb = ma >>= \ _ -> mb
+
+ -- Maybe remove this
+ return :: forall a . a -> m a
+ return = pure
+
+ap :: forall (m :: Type -> Type) a b . Monad m => m (a -> b) -> m a -> m b
+ap f a = do
+ f' <- f
+ a' <- a
+ return (f' a')
+
+class Monad m => MonadFail (m :: Type -> Type) where
+ fail :: forall a . String -> m a
+ fail = error
+
+mapM :: forall (m :: Type -> Type) a b . Monad m => (a -> m b) -> [a] -> m [b]
+mapM f =
+ let
+ rec arg =
+ case arg of
+ [] -> return []
+ a : as -> do
+ b <- f a
+ bs <- rec as
+ return (b : bs)
+ in rec
+
+mapM_ :: forall (m :: Type -> Type) a b . Monad m => (a -> m b) -> [a] -> m ()
+mapM_ f =
+ let
+ rec arg =
+ case arg of
+ [] -> return ()
+ a : as -> do
+ _ <- f a
+ rec as
+ in rec
+
+when :: forall (m :: Type -> Type) . Monad m => Bool -> m () -> m ()
+when False _ = return ()
+when True ma = ma
+
+sequence :: forall (m :: Type -> Type) a . Monad m => [m a] -> m [a]
+sequence = mapM id
+
+(=<<) :: forall (m :: Type -> Type) a b . Monad m => (a -> m b) -> m a -> m b
+(=<<) = flip (>>=)
+
+infixr 1 <=<
+(<=<) :: forall (m :: Type -> Type) a b c . Monad m => (b -> m c) -> (a -> m b) -> (a -> m c)
+f <=< g = \ a -> do
+ b <- g a
+ f b
+
+infixr 1 >=>
+(>=>) :: forall (m :: Type -> Type) a b c . Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)
+(>=>) = flip (<=<)
+
+{-+-- Same for Maybe
+instance Functor Maybe where
+ fmap _ Nothing = Nothing
+ fmap f (Just a) = Just (f a)
+
+instance Applicative Maybe where
+ pure a = Just a
+ (<*>) = ap
+
+instance Monad Maybe where
+ Nothing >>= _ = Nothing
+ Just a >>= f = f a
+-}
--- a/lib/Control/Monad/State/Strict.hs
+++ b/lib/Control/Monad/State/Strict.hs
@@ -1,9 +1,32 @@
{-# LANGUAGE QualifiedDo #-}-module Control.Monad.State.Strict(module Control.Monad.State.Strict) where
+module Control.Monad.State.Strict(
+ module Control.Monad.State.Strict,
+ module Control.Monad,
+ ) where
import Prelude
+import Control.Monad
data State s a = S (s -> (a, s))
+instance forall s . Functor (State s) where
+ fmap f sa = S $ \ s ->
+ case runState sa s of
+ (a, ss) -> (f a, ss)
+
+instance forall s . Applicative (State s) where
+ pure a = S $ \ s -> (a, s)
+ (<*>) = ap
+ (*>) m k = S $ \ s ->
+ case runState m s of
+ (_, ss) -> runState k ss
+
+instance forall s . Monad (State s) where
+ (>>=) m k = S $ \ s ->
+ case runState m s of
+ (a, ss) -> runState (k a) ss
+ (>>) = (*>)
+ return = pure
+
runState :: forall s a . State s a -> (s -> (a,s))
runState (S x) = x
@@ -10,6 +33,7 @@
evalState :: forall s a . State s a -> (s -> a)
evalState sa = fst . runState sa
+{-(>>=) :: forall s a b . State s a -> (a -> State s b) -> State s b
(>>=) m k = S $ \ s ->
case runState m s of
@@ -31,6 +55,13 @@
(<$>) :: forall s a b . (a -> b) -> State s a -> State s b
(<$>) = Control.Monad.State.Strict.fmap
+(<*>) :: forall s a b . State s (a -> b) -> State s a -> State s b
+(<*>) sf sa = Control.Monad.State.Strict.do
+ f <- sf
+ a <- sa
+ Control.Monad.State.Strict.return (f a)
+-}
+
modify :: forall s . (s -> s) -> State s ()
modify f = S $ \ s -> ((), f s)
@@ -43,6 +74,7 @@
gets :: forall s a . (s -> a) -> State s a
gets f = S $ \ s -> (f s, s)
+{-mapM :: forall s a b . (a -> State s b) -> [a] -> State s [b]
mapM f =
let
@@ -75,3 +107,4 @@
sequence :: forall s a . [State s a] -> State s [a]
sequence = Control.Monad.State.Strict.mapM id
+-}
--- /dev/null
+++ b/lib/Data/Bits.hs
@@ -1,0 +1,93 @@
+module Data.Bits(module Data.Bits) where
+import Primitives
+import Control.Error
+import Data.Bool
+import Data.Eq
+import Data.Int()
+import Data.Maybe
+import Data.Ord
+import Data.Num
+
+infixl 8 `shift`, `rotate`, `shiftL`, `shiftR`, `rotateL`, `rotateR`
+infixl 7 .&.
+infixl 6 `xor`
+infixl 5 .|.
+
+class Eq a => Bits a where
+ (.&.) :: a -> a -> a
+ (.|.) :: a -> a -> a
+ xor :: a -> a -> a
+ complement :: a -> a
+ shift :: a -> Int -> a
+ rotate :: a -> Int -> a
+ zeroBits :: a
+ bit :: Int -> a
+ setBit :: a -> Int -> a
+ clearBit :: a -> Int -> a
+ complementBit :: a -> Int -> a
+ testBit :: a -> Int -> Bool
+ shiftL :: a -> Int -> a
+ unsafeShiftL :: a -> Int -> a
+ shiftR :: a -> Int -> a
+ unsafeShiftR :: a -> Int -> a
+ rotateL :: a -> Int -> a
+ rotateR :: a -> Int -> a
+ popCount :: a -> Int
+ bitSizeMaybe :: a -> Maybe Int
+ bitSize :: a -> Int
+
+ x `shift` i | i<0 = x `shiftR` (negate i)
+ | i>0 = x `shiftL` i
+ | otherwise = x
+
+
+ x `rotate` i | i<0 = x `rotateR` (negate i)
+ | i>0 = x `rotateL` i
+ | otherwise = x
+
+ {-+ x `rotate` i | i<0 && isSigned x && x<0
+ = let left = i+bitSize x in
+ ((x `shift` i) .&. complement ((-1) `shift` left))
+ .|. (x `shift` left)
+ | i<0 = (x `shift` i) .|. (x `shift` (i+bitSize x))
+ | i==0 = x
+ | i>0 = (x `shift` i) .|. (x `shift` (i-bitSize x))
+ -}
+
+ zeroBits = clearBit (bit 0) 0
+ bitSize b = fromMaybe (error "bitSize is undefined") (bitSizeMaybe b)
+ x `setBit` i = x .|. bit i
+ x `clearBit` i = x .&. complement (bit i)
+ x `complementBit` i = x `xor` bit i
+
+ x `shiftL` i = x `shift` i
+ x `unsafeShiftL` i = x `shiftL` i
+ x `shiftR` i = x `shift` (negate i)
+ x `unsafeShiftR` i = x `shiftR` i
+
+ x `rotateL` i = x `rotate` i
+
+ x `rotateR` i = x `rotate` (negate i)
+
+
+class Bits b => FiniteBits b where
+ finiteBitSize :: b -> Int
+ countLeadingZeros :: b -> Int
+ countTrailingZeros :: b -> Int
+
+ countLeadingZeros x = (w - 1) - go (w - 1)
+ where
+ go i | i < 0 = i -- no bit set
+ | testBit x i = i
+ | otherwise = go (i - 1)
+
+ w = finiteBitSize x
+
+ countTrailingZeros x = go 0
+ where
+ go i | i >= w = i
+ | testBit x i = i
+ | otherwise = go (i + 1)
+
+ w = finiteBitSize x
--- a/lib/Data/Bool.hs
+++ b/lib/Data/Bool.hs
@@ -6,7 +6,22 @@
) where
import Primitives
import Data.Bool_Type
+import Data.Bounded
+import Data.Eq
+import Text.Show
+instance Eq Bool where
+ False == x = not x
+ True == x = x
+
+instance Show Bool where
+ showsPrec _ False = showString "False"
+ showsPrec _ True = showString "True"
+
+instance Bounded Bool where
+ minBound = False
+ maxBound = True
+
infixr 2 ||
(||) :: Bool -> Bool -> Bool
(||) False y = y
@@ -23,11 +38,3 @@
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
--- /dev/null
+++ b/lib/Data/Bounded.hs
@@ -1,0 +1,6 @@
+module Data.Bounded(module Data.Bounded) where
+import Primitives
+
+class Bounded a where
+ minBound :: a
+ maxBound :: a
--- a/lib/Data/Char.hs
+++ b/lib/Data/Char.hs
@@ -1,12 +1,47 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
-module Data.Char(module Data.Char, Char) where
+module Data.Char(
+ module Data.Char,
+ module Data.Char_Type -- exports Char and String
+ ) where
import Primitives
+import Control.Error
import Data.Bool
+import Data.Bounded
+import Data.Char_Type
+import Data.Eq
+import Data.Function
import Data.Int
+import Data.List_Type
+import Data.Num
+import Data.Ord
+import Text.Show
-type String = [Char]
+instance Eq Char where
+ (==) = primCharEQ
+ (/=) = primCharNE
+instance Ord Char where
+ (<) = primCharLT
+ (<=) = primCharLE
+ (>) = primCharGT
+ (>=) = primCharGE
+
+instance Eq String where
+ (==) = primStringEQ
+
+instance Ord String where
+ compare = primCompare
+ x < y = primCompare x y == LT
+ x <= y = primCompare x y /= GT
+ x > y = primCompare x y == GT
+ x >= y = primCompare x y /= GT
+
+-- ASCII only for now
+instance Bounded Char where
+ minBound = chr 0
+ maxBound = chr 127
+
chr :: Int -> Char
chr = primChr
@@ -25,28 +60,47 @@
isDigit :: Char -> Bool
isDigit c = (primCharLE '0' c) && (primCharLE c '9')
+isHexDigit :: Char -> Bool
+isHexDigit c = isDigit c || (primCharLE 'a' c && primCharLE c 'f') || (primCharLE 'F' c && primCharLE c 'F')
+
+isAlphaNum :: Char -> Bool
+isAlphaNum c = isAlpha c || isDigit c
+
isPrint :: Char -> Bool
isPrint c = primCharLE ' ' c && primCharLE c '~'
-eqChar :: Char -> Char -> Bool
-eqChar = primCharEQ
-
-neChar :: Char -> Char -> Bool
-neChar = primCharNE
-
-leChar :: Char -> Char -> Bool
-leChar = primCharLE
-
-ltChar :: Char -> Char -> Bool
-ltChar = primCharLT
-
isSpace :: Char -> Bool
-isSpace c = eqChar c ' ' || eqChar c '\t' || eqChar c '\n'
+isSpace c = c == ' ' || c == '\t' || c == '\n'
+digitToInt :: Char -> Int
+digitToInt c | (primCharLE '0' c) && (primCharLE c '9') = ord c - ord '0'
+ | (primCharLE 'a' c) && (primCharLE c 'f') = ord c - (ord 'a' - 10)
+ | (primCharLE 'A' c) && (primCharLE c 'F') = ord c - (ord 'A' - 10)
+ | otherwise = error "digitToInt"
+
toLower :: Char -> Char
-toLower c | leChar 'A' c && leChar c 'Z' = chr (ord c - ord 'A' + ord 'a')
+toLower c | primCharLE 'A' c && primCharLE c 'Z' = chr (ord c - ord 'A' + ord 'a')
| True = c
toUpper :: Char -> Char
-toUpper c | leChar 'a' c && leChar c 'a' = chr (ord c - ord 'a' + ord 'A')
+toUpper c | primCharLE 'a' c && primCharLE c 'a' = chr (ord c - ord 'a' + ord 'A')
| True = c
+
+instance Show Char where
+ showsPrec _ '\'' = showString "'\\''"
+ showsPrec _ c = showChar '\'' . showString (encodeChar c) . showChar '\''
+ showList s = showChar '"' . f s
+ where f [] = showChar '"'
+ f (c:cs) =
+ if c == '"' then showString "\\\"" . f cs
+ else showString (encodeChar c) . f cs
+
+-- XXX should not export this
+encodeChar :: Char -> String
+encodeChar c =
+ let
+ spec = [('\n', "\\n"), ('\r', "\\r"), ('\t', "\\t"), ('\b', "\\b"),+ ('\\', "\\\\")]+ look [] = if isPrint c then [c] else "'\\" ++ show (ord c) ++ "'"
+ look ((d,s):xs) = if d == c then s else look xs
+ in look spec
--- /dev/null
+++ b/lib/Data/Char_Type.hs
@@ -1,0 +1,5 @@
+module Data.Char_Type(Char, String) where
+import Primitives
+import Data.List_Type
+
+type String = [Char]
--- a/lib/Data/Double.hs
+++ b/lib/Data/Double.hs
@@ -2,73 +2,74 @@
-- See LICENSE file for full license.
module Data.Double(module Data.Double, Double) where
import Primitives
+import Control.Error
import Data.Bool_Type
+import Data.Eq
+import Data.Floating
+import Data.Fractional
+import Data.Integer
+import Data.Ord
+import Data.Ratio
+import Data.Real
+import Data.Num
+import Text.Show
-infixl 6 +,-
-infixl 7 *
+instance Num Double where
+ (+) = primDoubleAdd
+ (-) = primDoubleSub
+ (*) = primDoubleMul
+ abs x = if x < 0.0 then negate x else x
+ signum x =
+ case compare x 0.0 of
+ LT -> -1.0
+ EQ -> 0.0
+ GT -> 1.0
+ fromInteger = _integerToDouble
--- Arithmetic
-(+) :: Double -> Double -> Double
-(+) = primDoubleAdd
-(-) :: Double -> Double -> Double
-(-) = primDoubleSub
-(*) :: Double -> Double -> Double
-(*) = primDoubleMul
-(/) :: Double -> Double -> Double
-(/) = primDoubleDiv
+instance Fractional Double where
+ (/) = primDoubleDiv
+ -- This version of fromRational can go horribly wrong
+ -- if the integers are bigger than can be represented in a Double.
+ -- It'll do for now.
+ fromRational x = fromInteger (numerator x) `primDoubleDiv` fromInteger (denominator x)
-negate :: Double -> Double
-negate x = 0.0 - x
+instance Eq Double where
+ (==) = primDoubleEQ
+ (/=) = primDoubleNE
-addDouble :: Double -> Double -> Double
-addDouble = (+)
-subDouble :: Double -> Double -> Double
-subDouble = (-)
-mulDouble :: Double -> Double -> Double
-mulDouble = (*)
-divDouble :: Double -> Double -> Double
-divDouble = (/)
-
---------------------------------
-
-infix 4 ==,/=,<,<=,>,>=
-
--- Comparison
-(==) :: Double -> Double -> Bool
-(==) = primDoubleEQ
-(/=) :: Double -> Double -> Bool
-(/=) = primDoubleNE
-
-eqDouble :: Double -> Double -> Bool
-eqDouble = (==)
-neqDouble :: Double -> Double -> Bool
-neqDouble = (/=)
-
-(<) :: Double -> Double -> Bool
-(<) = primDoubleLT
-(<=) :: Double -> Double -> Bool
-(<=) = primDoubleLE
-(>) :: Double -> Double -> Bool
-(>) = primDoubleGT
-(>=) :: Double -> Double -> Bool
-(>=) = primDoubleGE
-
-ltDouble :: Double -> Double -> Bool
-ltDouble = (<)
-
-leDouble :: Double -> Double -> Bool
-leDouble = (<=)
-
-gtDouble :: Double -> Double -> Bool
-gtDouble = (>)
-
-geDouble :: Double -> Double -> Bool
-geDouble = (>=)
-
+instance Ord Double where
+ (<) = primDoubleLT
+ (<=) = primDoubleLE
+ (>) = primDoubleGT
+ (>=) = primDoubleGE
+
-- | this primitive will print doubles with up to 6 decimal points
-- it turns out that doubles are extremely tricky, and just printing them is a
-- herculean task of its own...
-showDouble :: Double -> [Char]
-showDouble = primDoubleShow
+instance Show Double where
+ show = primDoubleShow
+instance Real Double where
+ toRational _ = error "Double.toRational not implemented"
--------------------------------
+instance Floating Double where
+ pi = 3.141592653589793
+ log x = primPerformIO (clog x)
+ exp x = primPerformIO (cexp x)
+ sqrt x = primPerformIO (csqrt x)
+ sin x = primPerformIO (csin x)
+ cos x = primPerformIO (ccos x)
+ tan x = primPerformIO (ctan x)
+ asin x = primPerformIO (casin x)
+ acos x = primPerformIO (cacos x)
+ atan x = primPerformIO (catan x)
+
+foreign import ccall "log" clog :: Double -> IO Double
+foreign import ccall "exp" cexp :: Double -> IO Double
+foreign import ccall "sqrt" csqrt :: Double -> IO Double
+foreign import ccall "sin" csin :: Double -> IO Double
+foreign import ccall "cos" ccos :: Double -> IO Double
+foreign import ccall "tan" ctan :: Double -> IO Double
+foreign import ccall "asin" casin :: Double -> IO Double
+foreign import ccall "acos" cacos :: Double -> IO Double
+foreign import ccall "atan" catan :: Double -> IO Double
--- a/lib/Data/Either.hs
+++ b/lib/Data/Either.hs
@@ -2,9 +2,24 @@
-- See LICENSE file for full license.
module Data.Either(module Data.Either) where
import Primitives
+import Data.Bool
+import Data.Eq
+import Data.Function
+import Data.Int
+import Data.Ord
+import Text.Show
data Either a b = Left a | Right b
+instance forall a b . (Eq a, Eq b) => Eq (Either a b) where
+ Left a == Left a' = a == a'
+ Right b == Right b' = b == b'
+ _ == _ = False
+
either :: forall a b r . (a -> r) -> (b -> r) -> Either a b -> r
either f _ (Left a) = f a
either _ f (Right b) = f b
+
+instance forall a b . (Show a, Show b) => Show (Either a b) where
+ showsPrec p (Left a) = showParen (p>=appPrec1) (showString "Left " . showsPrec appPrec1 a)
+ showsPrec p (Right b) = showParen (p>=appPrec1) (showString "Right " . showsPrec appPrec1 b)
--- /dev/null
+++ b/lib/Data/Enum.hs
@@ -1,0 +1,70 @@
+module Data.Enum(module Data.Enum) where
+import Primitives
+import Control.Error
+import Data.Bool
+import Data.Char_Type
+import Data.Bounded
+import Data.Function
+import Data.Int
+import Data.List
+import Data.Num
+import Data.Ord
+
+class Enum a where
+ succ :: a -> a
+ pred :: a -> a
+ toEnum :: Int -> a
+ fromEnum :: a -> Int
+
+ enumFrom :: a -> [a]
+ enumFromThen :: a -> a -> [a]
+ enumFromTo :: a -> a -> [a]
+ enumFromThenTo :: a -> a -> a -> [a]
+
+ succ = toEnum . (+ 1) . fromEnum
+ pred = toEnum . (subtract 1) . fromEnum
+ enumFrom x = map toEnum [fromEnum x ..]
+ enumFromThen x y = map toEnum [fromEnum x, fromEnum y ..]
+ enumFromTo x y = map toEnum [fromEnum x .. fromEnum y]
+ enumFromThenTo x1 x2 y = map toEnum [fromEnum x1, fromEnum x2 .. fromEnum y]
+
+boundedEnumFrom :: forall a . (Enum a, Bounded a) => a -> [a]
+boundedEnumFrom n = map toEnum [fromEnum n .. fromEnum (maxBound `asTypeOf` n)]
+
+boundedEnumFromThen :: forall a . (Enum a, Bounded a) => a -> a -> [a]
+boundedEnumFromThen n1 n2
+ | i_n2 >= i_n1 = map toEnum [i_n1, i_n2 .. fromEnum (maxBound `asTypeOf` n1)]
+ | otherwise = map toEnum [i_n1, i_n2 .. fromEnum (minBound `asTypeOf` n1)]
+ where
+ i_n1 = fromEnum n1
+ i_n2 = fromEnum n2
+
+-- This instance is difficult to put in Data.Int,
+-- so it gets to live here.
+instance Enum Int where
+ succ x = x + 1
+ pred x = x - 1
+ toEnum x = x
+ fromEnum x = x
+ enumFrom n = n : enumFrom (n+1)
+ enumFromThen n m = from n
+ where d = m - n
+ from i = i : from (i+d)
+ enumFromTo l h = takeWhile (<= h) (enumFrom l)
+ enumFromThenTo l m h =
+ if m > l then
+ takeWhile (<= h) (enumFromThen l m)
+ else
+ takeWhile (>= h) (enumFromThen l m)
+
+-- Likewise for Bool
+instance Enum Bool where
+ fromEnum False = 0
+ fromEnum True = 1
+ toEnum 0 = False
+ toEnum 1 = True
+ toEnum _ = error "Enum.Bool.toEnum: bad arg"
+
+instance Enum Char where
+ fromEnum = primOrd
+ toEnum = primChr
--- /dev/null
+++ b/lib/Data/Eq.hs
@@ -1,0 +1,13 @@
+module Data.Eq(
+ module Data.Eq
+ ) where
+import Primitives
+import Data.Bool_Type
+
+infix 4 ==,/=
+
+class Eq a where
+ (==) :: a -> a -> Bool
+ (/=) :: a -> a -> Bool
+ x /= y = if x == y then False else True
+
--- /dev/null
+++ b/lib/Data/Floating.hs
@@ -1,0 +1,45 @@
+module Data.Floating(module Data.Floating) where
+import Primitives
+import Data.Fractional
+import Data.Num
+
+infixr 8 **
+
+class (Fractional a) => Floating a where
+ pi :: a
+ exp :: a -> a
+ log :: a -> a
+ sqrt :: a -> a
+ (**) :: a -> a -> a
+ logBase :: a -> a -> a
+ sin :: a -> a
+ cos :: a -> a
+ tan :: a -> a
+ asin :: a -> a
+ acos :: a -> a
+ atan :: a -> a
+ sinh :: a -> a
+ cosh :: a -> a
+ tanh :: a -> a
+ asinh :: a -> a
+ acosh :: a -> a
+ atanh :: a -> a
+ log1p :: a -> a
+ expm1 :: a -> a
+ log1pexp :: a -> a
+ log1mexp :: a -> a
+
+ x ** y = exp (log x * y)
+ logBase x y = log y / log x
+ sqrt x = x ** (1/2)
+ tan x = sin x / cos x
+ sinh x = (exp x - exp (negate x)) / 2
+ cosh x = (exp x + exp (negate x)) / 2
+ tanh x = sinh x / cosh x
+ asinh x = log (x + sqrt (x*x + 1))
+ acosh x = log (x + sqrt (x*x - 1))
+ atanh x = log ((x + 1) / (x - 1)) / 2
+ log1p x = log (1 + x)
+ expm1 x = exp x - 1
+ log1pexp x = log1p (exp x)
+ log1mexp x = log1p (negate (exp x))
--- /dev/null
+++ b/lib/Data/Fractional.hs
@@ -1,0 +1,19 @@
+-- Copyright 2023 Lennart Augustsson
+-- See LICENSE file for full license.
+module Data.Fractional(module Data.Fractional) where
+import Primitives
+import Data.Integral
+import Data.Num
+import Data.Ord
+import Data.Ratio_Type
+
+class Num a => Fractional a where
+ (/) :: a -> a -> a
+ recip :: a -> a
+ fromRational :: Rational -> a
+
+ recip x = 1 / x
+
+infixr 8 ^^
+(^^) :: forall a b . (Fractional a, Integral b, Ord b) => a -> b -> a
+x ^^ n = if n >= 0 then x^n else recip (x^(negate n))
--- a/lib/Data/Function.hs
+++ b/lib/Data/Function.hs
@@ -2,7 +2,7 @@
-- See LICENSE file for full license.
module Data.Function(module Data.Function) where
import Primitives
-import Data.Tuple
+--import Data.Tuple
infixr 0 $
($) :: forall a b . (a -> b) -> a -> b
@@ -29,8 +29,11 @@
fix = primFix
uncurry :: forall a b c . (a -> b -> c) -> (a, b) -> c
-uncurry f ab = f (fst ab) (snd ab)
+uncurry f (a, b) = f a b -- XXX not lazy
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)
+
+asTypeOf :: forall a . a -> a -> a
+asTypeOf = const
--- /dev/null
+++ b/lib/Data/Functor.hs
@@ -1,0 +1,15 @@
+module Data.Functor(module Data.Functor) where
+import Primitives -- for fixity
+import Data.Function
+
+class Functor (f :: Type -> Type) where
+ fmap :: forall a b . (a -> b) -> f a -> f b
+ (<$) :: forall a b . a -> f b -> f a
+ (<$) = fmap . const
+
+infixl 4 <$>
+(<$>) :: forall (f :: Type -> Type) a b . Functor f => (a -> b) -> f a -> f b
+(<$>) = fmap
+
+--void :: forall f a . Functor f => f a -> f ()
+--void = fmap (const ())
--- /dev/null
+++ b/lib/Data/Identity.hs
@@ -1,0 +1,24 @@
+module Data.Identity(Data.Identity) where
+import Primitives
+import Control.Applicative
+import Control.Monad
+import Data.Function
+import Data.Functor
+import Data.Int
+import Data.Ord
+import Text.Show
+
+newtype Identity a = Identity a
+
+instance Functor Identity where
+ fmap f (Identity a) = Identity (f a)
+
+instance Applicative Identity where
+ pure a = Identity a
+ Identity f <*> Identity a = Identity (f a)
+
+instance Monad Identity where
+ Identity a >>= f = f a
+
+instance forall a . (Show a) => Show (Identity a) where
+ showsPrec p (Identity a) = showParen (p >= 11) (showString "Identity " . showsPrec 11 a)
--- a/lib/Data/Int.hs
+++ b/lib/Data/Int.hs
@@ -3,48 +3,76 @@
module Data.Int(module Data.Int, Int) where
import Primitives
import Data.Bool_Type
+import Data.Bounded
+import Data.Char_Type
+import Data.Eq
+import Data.Integer_Type
+import Data.Integral
+import Data.List_Type
+import Data.Num
+import Data.Ord
+import Data.Ratio_Type
+import Data.Real
+import Text.Show
-infixl 6 +,-
-infixl 7 *,`quot`,`rem`
+instance Num Int where
+ (+) = primIntAdd
+ (-) = primIntSub
+ (*) = primIntMul
+ negate x = primIntNeg x
+ abs x = if x < 0 then negate x else x
+ signum x =
+ case compare x 0 of
+ LT -> -1
+ EQ -> 0
+ GT -> 1
+ fromInteger = _integerToInt
--- Arithmetic
-(+) :: Int -> Int -> Int
-(+) = primIntAdd
-(-) :: Int -> Int -> Int
-(-) = primIntSub
-(*) :: Int -> Int -> Int
-(*) = primIntMul
-quot :: Int -> Int -> Int
-quot = primIntQuot
-rem :: Int -> Int -> Int
-rem = primIntRem
+instance Integral Int where
+ quot = primIntQuot
+ rem = primIntRem
+ toInteger = _intToInteger
-subtract :: Int -> Int -> Int
-subtract = primIntSubR
+instance Bounded Int where
+ minBound = primWordToInt ((-1::Word) `primWordQuot` 2) + 1
+ maxBound = primWordToInt ((-1::Word) `primWordQuot` 2)
-negate :: Int -> Int
-negate x = 0 - x
+instance Real Int where
+ toRational i = _integerToRational (_intToInteger i)
--------------------------------
-infix 4 ==,/=,<,<=,>,>=
+instance Eq Int where
+ (==) = primIntEQ
+ (/=) = primIntNE
--- Comparison
-(==) :: Int -> Int -> Bool
-(==) = primIntEQ
-(/=) :: Int -> Int -> Bool
-(/=) = primIntNE
+instance Ord Int where
+ (<) = primIntLT
+ (<=) = primIntLE
+ (>) = primIntGT
+ (>=) = primIntGE
-(<) :: Int -> Int -> Bool
-(<) = primIntLT
-(<=) :: Int -> Int -> Bool
-(<=) = primIntLE
-(>) :: Int -> Int -> Bool
-(>) = primIntGT
-(>=) :: Int -> Int -> Bool
-(>=) = primIntGE
-
-eqInt :: Int -> Int -> Bool
-eqInt = (==)
+--------------------------------
+instance Show Int where
+ show = showInt_
--------------------------------
+-- XXX these should not be exported
+-- XXX wrong for minInt
+showInt_ :: Int -> String
+showInt_ n =
+ if n < 0 then
+ '-' : _showUnsignedNegInt n
+ else
+ _showUnsignedNegInt (negate n)
+
+-- Some trickery to show minBound correctly.
+-- To print the number n, pass -n.
+_showUnsignedNegInt :: Int -> String
+_showUnsignedNegInt n =
+ let
+ c = primChr (primOrd '0' - rem n 10)
+ in if n > -10 then
+ [c]
+ else
+ _showUnsignedNegInt (quot n 10) ++ [c]
--- a/lib/Data/IntMap.hs
+++ b/lib/Data/IntMap.hs
@@ -4,7 +4,7 @@
IntMap,
empty, lookup, insert, fromList, toList, insertWith, (!), keys
) where
-import Prelude --Xhiding(lookup)
+import Prelude hiding(lookup)
data IntMap a
= Empty
--- a/lib/Data/Integer.hs
+++ b/lib/Data/Integer.hs
@@ -1,25 +1,33 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
--- *** WIP, do not use! ***
module Data.Integer(
Integer,
- addI, subI, mulI, quotI, remI,
- negateI, absI,
- quotRemI,
- eqI, neI, ltI, leI, gtI, geI,
- intToInteger,
- showInteger,
+ readInteger,
+ _intToInteger,
+ _integerToInt,
+ _wordToInteger,
+ _integerToWord,
+ _integerToDouble,
+ _integerToRational,
+ _integerToIntList,
+ _intListToInteger,
) where
-import Prelude
-{--import Prelude hiding(Integer)
-import qualified Prelude as P
+import Primitives
+import Control.Error
+import Data.Bool
import Data.Char
-import Compat
-import Test.QuickCheck
-import GHC.Stack
-import Debug.Trace
--}
+import Data.Enum
+import Data.Eq
+import Data.Function
+import Data.Int
+import Data.Integer_Type
+import Data.Integral
+import Data.List
+import Data.Num
+import Data.Ord
+import Data.Ratio_Type
+import Data.Real
+import Text.Show
--
-- The Integer is stored in sign-magniture format with digits in base maxD (2^31)
@@ -26,21 +34,80 @@
-- It has the following invariants:
-- * each digit is >= 0 and < maxD
-- * least signification digits first, most significant last
--- * no tariling 0s in the digits
+-- * no trailing 0s in the digits
-- * 0 is positive
+{- These definitions are in Integer_Typedata Integer = I Sign [Digit]
--deriving Show
type Digit = Int
+maxD :: Digit
+maxD = 2147483648 -- 2^31, this is used so multiplication of two digit doesn't overflow a 64 bit Int
+
data Sign = Plus | Minus
--deriving Show
+-}
-eqSign :: Sign -> Sign -> Bool
-eqSign Plus Plus = True
-eqSign Minus Minus = True
-eqSign _ _ = False
+instance Eq Integer where
+ (==) = eqI
+ (/=) = neI
+instance Ord Integer where
+ (<) = ltI
+ (<=) = leI
+ (>) = gtI
+ (>=) = geI
+
+instance Show Integer where
+ show i = showInteger i
+
+instance Num Integer where
+ (+) = addI
+ (-) = subI
+ (*) = mulI
+ negate = negateI
+ abs = absI
+ signum x =
+ case compare x zeroI of
+ LT -> negOneI
+ EQ -> zeroI
+ GT -> oneI
+ fromInteger x = x
+
+instance Integral Integer where
+ quotRem = quotRemI
+ toInteger x = x
+
+instance Real Integer where
+ toRational i = _integerToRational i
+
+instance Enum Integer where
+ succ x = x + 1
+ pred x = x - 1
+ toEnum x = _intToInteger x
+ fromEnum x = _integerToInt x
+ enumFrom n = n : enumFrom (n+1)
+ enumFromThen n m = from n
+ where d = m - n
+ from i = i : from (i+d)
+ enumFromTo l h = takeWhile (<= h) (enumFrom l)
+ enumFromThenTo l m h =
+ if m > l then
+ takeWhile (<= h) (enumFromThen l m)
+ else
+ takeWhile (>= h) (enumFromThen l m)
+
+------------------------------------------------
+
+isZero :: Integer -> Bool
+isZero (I _ ds) = null ds
+
+instance Eq Sign where
+ (==) Plus Plus = True
+ (==) Minus Minus = True
+ (==) _ _ = False
+
-- Trim off 0s and make an Integer
sI :: Sign -> [Digit] -> Integer
sI s ds =
@@ -48,20 +115,9 @@
[] -> I Plus []
ds' -> I s ds'
-intToInteger :: Int -> Integer
-intToInteger i | i >= 0 = I Plus (f i)
- | i == negate i = I Minus [0,0,2] -- we are at minBound::Int. XXX deal with this in a more portable way.
- | otherwise = I Minus (f (negate i))
- where
- f 0 = []
- f x = rem x maxD : f (quot x maxD)
-
zeroD :: Digit
zeroD = 0
-maxD :: Digit
-maxD = 2147483648 -- 2^31, this is used so multiplication of two digit doesn't overflow a 64 bit Int
-
addI :: Integer -> Integer -> Integer
addI (I Plus xs) (I Plus ys) = I Plus (add xs ys)
addI (I Plus xs) (I Minus ys) | ltW xs ys = sI Minus (sub ys xs)
@@ -115,7 +171,7 @@
-- Remove trailing 0s
trim0 :: [Digit] -> [Digit]
-trim0 = reverse . dropWhile (== 0) . reverse
+trim0 = reverse . dropWhile (== (0::Int)) . reverse
-- Is axs < ays?
ltW :: [Digit] -> [Digit] -> Bool
@@ -135,7 +191,7 @@
mulI (I sx xs) (I sy ys) = I (mulSign sx sy) (mulM xs ys)
mulSign :: Sign -> Sign -> Sign
-mulSign s t = if eqSign s t then Plus else Minus
+mulSign s t = if s == t then Plus else Minus
-- Multiply with a single digit, and add carry.
mulD :: Digit -> [Digit] -> Digit -> [Digit]
@@ -149,15 +205,9 @@
mulM :: [Digit] -> [Digit] -> [Digit]
mulM xs ys =
let rs = map (mulD zeroD xs) ys
- ss = zipWith (++) (map (`replicate` 0) [0..]) rs
+ ss = zipWith (++) (map (`replicate` (0::Int)) [0::Int ..]) rs
in foldl1 add ss
-quotI :: Integer -> Integer -> Integer
-quotI x y = fst (quotRemI x y)
-
-remI :: Integer -> Integer -> Integer
-remI x y = snd (quotRemI x y)
-
-- Signs:
-- + + -> (+,+)
-- + - -> (-,+)
@@ -166,7 +216,7 @@
quotRemI :: Integer -> Integer -> (Integer, Integer)
quotRemI _ (I _ []) = error "Integer: division by 0" -- n / 0
quotRemI (I _ []) _ = (I Plus [], I Plus []) -- 0 / n
-quotRemI (I sx xs) (I sy ys) | all (== 0) ys' =
+quotRemI (I sx xs) (I sy ys) | all (== (0::Int)) ys' =
-- All but the MSD are 0. Scale numerator accordingly and divide.
-- Then add back (the ++) the remainder we scaled off.
case quotRemD xs' y of
@@ -180,6 +230,11 @@
qrRes :: Sign -> Sign -> ([Digit], [Digit]) -> (Integer, Integer)
qrRes sx sy (ds, rs) = (sI (mulSign sx sy) ds, sI sx rs)
+quotI :: Integer -> Integer -> Integer
+quotI x y =
+ case quotRemI x y of
+ (q, _) -> q
+
-- Divide by a single digit.
-- Does not return normalized numbers.
quotRemD :: [Digit] -> Digit -> ([Digit], [Digit])
@@ -197,7 +252,7 @@
quotRemB xs ys =
let n = I Plus xs
d = I Plus ys
- a = I Plus $ replicate (length ys - 1) 0 ++ [last ys] -- only MSD of ys
+ a = I Plus $ replicate (length ys - (1::Int)) (0::Int) ++ [last ys] -- only MSD of ys
aq = quotI n a
ar = addI d oneI
loop q r =
@@ -227,6 +282,12 @@
twoI :: Integer
twoI = I Plus [2]
+tenI :: Integer
+tenI = I Plus [10]
+
+negOneI :: Integer
+negOneI = I Minus [1]
+
--------------
showInteger :: Integer -> String
@@ -240,8 +301,15 @@
where
(xs', [d]) = quotRemD xs 10
+readInteger :: String -> Integer
+readInteger ('-':ds) = negate (readUnsignedInteger ds)+readInteger ds = readUnsignedInteger ds
+
+readUnsignedInteger :: String -> Integer
+readUnsignedInteger = foldl (\ r c -> r * tenI + _intToInteger (ord c - ord '0')) zeroI
+
eqI :: Integer -> Integer -> Bool
-eqI (I sx xs) (I sy ys) = eqSign sx sy && eqList (==) xs ys
+eqI (I sx xs) (I sy ys) = sx == sy && xs == ys
neI :: Integer -> Integer -> Bool
neI x y = not (eqI x y)
@@ -261,6 +329,19 @@
geI :: Integer -> Integer -> Bool
geI x y = not (ltI x y)
+-- These two functions return an (opaque) representation of an
+-- Integer as [Int].
+-- This is used by the compiler to generate Integer literals.
+-- First _integerToIntList is used in the compiler to get a list of
+-- Int, and the generated code will have a call to _intListToInteger.
+_integerToIntList :: Integer -> [Int]
+_integerToIntList (I Plus ds) = ds
+_integerToIntList (I Minus ds) = (-1::Int) : ds
+
+_intListToInteger :: [Int] -> Integer
+_intListToInteger (-1 : ds) = I Minus ds
+_intListToInteger ds = I Plus ds
+
---------------------------------
{-pIntegerToInteger :: P.Integer -> Integer
@@ -287,7 +368,7 @@
instance Enum Integer where
fromEnum = fromEnum . integerToPInteger
- toEnum = intToInteger
+ toEnum = _intToInteger
instance Real Integer where
toRational = toRational . toInteger
--- /dev/null
+++ b/lib/Data/Integer_Type.hs
@@ -1,0 +1,59 @@
+-- Copyright 2023 Lennart Augustsson
+-- See LICENSE file for full license.
+module Data.Integer_Type(module Data.Integer_Type) where
+import Primitives
+import Data.Bool_Type
+--Yimport PrimFromInteger
+import Data.List_Type
+
+data Integer = I Sign [Digit]
+
+data Sign = Plus | Minus
+
+type Digit = Int
+
+maxD :: Digit
+maxD = 2147483648 -- 2^31, this is used so multiplication of two digit doesn't overflow a 64 bit Int
+
+_intToInteger :: Int -> Integer
+_intToInteger i | i `primIntGE` 0 = I Plus (f i)
+ | i `primIntEQ` ni = I Minus [0::Int,0::Int,2::Int] -- we are at minBound::Int. XXX deal with this in a more portable way.
+ | True = I Minus (f ni)
+ where
+ ni = (0::Int) `primIntSub` i
+ f :: Int -> [Int]
+ f 0 = []
+ f x = primIntRem x maxD : f (primIntQuot x maxD)
+
+_integerToInt :: Integer -> Int
+_integerToInt (I sign ds) = s `primIntMul` i
+ where
+ i =
+ case ds of
+ [] -> 0::Int
+ [d1] -> d1
+ [d1,d2] -> d1 `primIntAdd` (maxD `primIntMul` d2)
+ d1:d2:d3:_ -> d1 `primIntAdd` (maxD `primIntMul` (d2 `primIntAdd` (maxD `primIntMul` d3)))
+ s =
+ case sign of
+ Plus -> 1::Int
+ Minus -> 0 `primIntSub` 1
+
+_wordToInteger :: Word -> Integer
+_wordToInteger i = I Plus (f i)
+ where
+ f :: Word -> [Int]
+ f x = if x `primWordEQ` (0::Word) then [] else primWordToInt (primWordRem x (primIntToWord maxD)) : f (primWordQuot x (primIntToWord maxD))
+
+_integerToWord :: Integer -> Word
+_integerToWord x = primIntToWord (_integerToInt x)
+
+_integerToDouble :: Integer -> Double
+_integerToDouble (I sign ds) = s `primDoubleMul` loop ds
+ where
+ loop [] = 0.0::Double
+ loop (i : is) = primDoubleFromInt i `primDoubleAdd` (primDoubleFromInt maxD `primDoubleMul` loop is)
+ s =
+ case sign of
+ Plus -> 1.0::Double
+ Minus -> 0.0 `primDoubleSub` 1.0
--- /dev/null
+++ b/lib/Data/Integral.hs
@@ -1,0 +1,58 @@
+-- Copyright 2023 Lennart Augustsson
+-- See LICENSE file for full license.
+module Data.Integral(module Data.Integral) where
+import Primitives
+import Control.Error
+import Data.Bool
+import Data.Eq
+import Data.Integer_Type
+import Data.Num
+import Data.Ord
+
+infixl 7 `quot`,`rem`
+
+class {-(Real a, Enum a) => -} (Eq a, Num a) => Integral a where+ quot :: a -> a -> a
+ rem :: a -> a -> a
+ div :: a -> a -> a
+ mod :: a -> a -> a
+ quotRem :: a -> a -> (a, a)
+ divMod :: a -> a -> (a, a)
+ toInteger :: a -> Integer
+
+ n `quot` d = q where (q,r) = quotRem n d
+ n `rem` d = r where (q,r) = quotRem n d
+ n `div` d = q where (q,r) = divMod n d
+ n `mod` d = r where (q,r) = divMod n d
+ divMod n d = if signum r == negate (signum d) then (q - 1, r + d) else qr
+ where qr@(q,r) = quotRem n d
+ quotRem n d = (quot n d, rem n d)
+
+gcd :: forall a . (Integral a) => a -> a -> a
+gcd x y = gcd' (abs x) (abs y)
+ where gcd' a b = if b == 0 then a else gcd' b (a `rem` b)
+
+lcm :: forall a . (Integral a) => a -> a -> a
+lcm x y =
+ if x == 0 || y == 0 then
+ 0
+ else
+ abs ((x `quot` (gcd x y)) * y)
+
+even :: forall a . (Integral a) => a -> Bool
+even n = n `rem` 2 == 0
+
+odd :: forall a . (Integral a) => a -> Bool
+odd n = not (even n)
+
+infixr 8 ^
+(^) :: forall a b . (Num a, Integral b, Ord b) => a -> b -> a
+x0 ^ y0 | y0 < 0 = error "Data.Integral.^: negative exponent"
+ | otherwise = pow x0 y0
+ -- This does not do the minimal number of multiplications, but it's simple.
+ where pow x y | y == 0 = 1
+ | even y = pow (x * x) (y `quot` 2)
+ | otherwise = x * pow (x * x) (y `quot` 2)
+
+fromIntegral :: forall a b . (Integral a, Num b) => a -> b
+fromIntegral x = fromInteger (toInteger x)
--- a/lib/Data/List.hs
+++ b/lib/Data/List.hs
@@ -1,30 +1,52 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
-module Data.List(module Data.List) where
-import Primitives as P
+module Data.List(
+ module Data.List,
+ module Data.List_Type
+ ) where
+import Primitives
+import Control.Applicative
import Control.Error
+import Control.Monad
import Data.Bool
+import Data.Eq
import Data.Function
+import Data.Functor
import Data.Int
-import Data.Maybe
+import Data.List_Type
+import Data.Num
+import Data.Ord
+import Data.Maybe_Type
import Data.Tuple
+import Text.Show
--Yimport Data.Char
---Y{--infixr 5 :
-data [] a = [] | (:) a [a] -- Parser hacks makes this acceptable
---Y-}
+instance {-# OVERLAPPABLE #-} forall a . Eq a => Eq [a] where+ [] == [] = True
+ (x:xs) == (y:ys) = x == y && xs == ys
+ _ == _ = False
+instance Functor [] where
+ fmap = map
+
+instance Applicative [] where
+ pure a = [a]
+ (<*>) = ap
+
+instance Monad [] where
+ (>>=) = flip concatMap
+
+instance MonadFail [] where
+ fail _ = []
+
+instance forall a . Show a => Show [a] where
+ showsPrec _ = showList
+
null :: forall a . [a] -> Bool
null [] = True
null _ = False
-infixr 5 ++
-(++) :: forall a . [a] -> [a] -> [a]
-(++) [] ys = ys
-(++) (x : xs) ys = x : xs ++ ys
-
concat :: forall a . [[a]] -> [a]
concat = foldr (++) []
@@ -64,10 +86,18 @@
foldl1 _ [] = error "foldl1"
foldl1 f (x : xs) = foldl f x xs
-sum :: [P.Int] -> P.Int
+minimum :: forall a . Ord a => [a] -> a
+minimum [] = error "minimum"
+minimum (x:ys) = foldr (\ y m -> if y < m then y else m) x ys
+
+maximum :: forall a . Ord a => [a] -> a
+maximum [] = error "maximum"
+maximum (x:ys) = foldr (\ y m -> if y > m then y else m) x ys
+
+sum :: forall a . Num a => [a] -> a
sum = foldr (+) 0
-product :: [P.Int] -> P.Int
+product :: forall a . Num a => [a] -> a
product = foldr (*) 1
and :: [Bool] -> Bool
@@ -82,33 +112,33 @@
all :: forall a . (a -> Bool) -> [a] -> Bool
all p = and . map p
-take :: forall a . P.Int -> [a] -> [a]
+take :: forall a . Int -> [a] -> [a]
take n arg =
- if n <= 0 then
+ if n <= (0::Int) then
[]
else
case arg of
[] -> []
- x : xs -> x : take (n - 1) xs
+ x : xs -> x : take (n - (1::Int)) xs
-drop :: forall a . P.Int -> [a] -> [a]
+drop :: forall a . Int -> [a] -> [a]
drop n arg =
- if n <= 0 then
+ if n <= (0::Int) then
arg
else
case arg of
[] -> []
- _ : xs -> drop (n - 1) xs
+ _ : xs -> drop (n - (1::Int)) xs
-length :: forall a . [a] -> P.Int
+length :: forall a . [a] -> Int
length =
-- Make it tail recursive and strict
let
rec r [] = r
rec r (_:xs) =
- let r' = r + 1
+ let r' = r + (1::Int)
in r' `primSeq` rec r' xs
- in rec 0
+ in rec (0::Int)
zip :: forall a b . [a] -> [b] -> [(a, b)]
zip = zipWith (\ x y -> (x, y))
@@ -135,6 +165,9 @@
case unzip3 xyzs of
(xs, ys, zs) -> (x:xs, y:ys, z:zs)
+stripPrefix :: forall a . Eq a => [a] -> [a] -> Maybe [a]
+stripPrefix = stripPrefixBy (==)
+
stripPrefixBy :: forall a . (a -> a -> Bool) -> [a] -> [a] -> Maybe [a]
stripPrefixBy eq [] s = Just s
stripPrefixBy eq (c:cs) [] = Nothing
@@ -141,12 +174,15 @@
stripPrefixBy eq (c:cs) (d:ds) | eq c d = stripPrefixBy eq cs ds
| otherwise = Nothing
+isPrefixOf :: forall a . Eq a => [a] -> [a] -> Bool
+isPrefixOf = isPrefixOfBy (==)
+
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
+isPrefixOfBy _ [] _ = True
+isPrefixOfBy _ _ _ = False
-splitAt :: forall a . P.Int -> [a] -> ([a], [a])
+splitAt :: forall a . Int -> [a] -> ([a], [a])
splitAt n xs = (take n xs, drop n xs)
reverse :: forall a . [a] -> [a]
@@ -204,37 +240,37 @@
intercalate :: forall a . [a] -> [[a]] -> [a]
intercalate xs xss = concat (intersperse xs xss)
+elem :: forall a . (Eq a) => a -> [a] -> Bool
+elem = elemBy (==)
+
+notElem :: forall a . (Eq a) => a -> [a] -> Bool
+notElem a as = not (elem a as)
+
elemBy :: forall a . (a -> a -> Bool) -> a -> [a] -> Bool
elemBy eq a = any (eq a)
-enumFrom :: P.Int -> [P.Int]
-enumFrom n = n : enumFrom (n+1)
-
-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
+lookup :: forall a b . Eq a => a -> [(a, b)] -> Maybe b
+lookup = lookupBy (==)
+
lookupBy :: forall a b . (a -> a -> Bool) -> a -> [(a, b)] -> Maybe b
-lookupBy eq x xys = fmapMaybe snd (find (eq x . fst) xys)
+lookupBy eq x xys =
+ case find (eq x . fst) xys of
+ Nothing -> Nothing
+ Just (_, b) -> Just b
+union :: forall a . Eq a => [a] -> [a] -> [a]
+union = unionBy (==)
+
unionBy :: forall a . (a -> a -> Bool) -> [a] -> [a] -> [a]
unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs
+intersect :: forall a . Eq a => [a] -> [a] -> [a]
+intersect = intersectBy (==)
+
intersectBy :: forall a . (a -> a -> Bool) -> [a] -> [a] -> [a]
intersectBy eq xs ys = filter (\ x -> not (elemBy eq x ys)) xs
@@ -246,11 +282,14 @@
deleteAllBy _ _ [] = []
deleteAllBy eq x (y:ys) = if eq x y then deleteAllBy eq x ys else y : deleteAllBy eq x ys
+nub :: forall a . Eq a => [a] -> [a]
+nub = nubBy (==)
+
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 . P.Int -> a -> [a]
+replicate :: forall a . Int -> a -> [a]
replicate n x = take n (repeat x)
repeat :: forall a . a -> [a]
@@ -259,31 +298,34 @@
xs = x:xs
in xs
+infix 5 \\
+(\\) :: forall a . Eq a => [a] -> [a] -> [a]
+(\\) = deleteFirstsBy (==)
+
deleteFirstsBy :: forall a . (a -> a -> Bool) -> [a] -> [a] -> [a]
deleteFirstsBy eq = foldl (flip (deleteBy eq))
+-- Delete all from the second argument from the first argument
deleteAllsBy :: forall a . (a -> a -> Bool) -> [a] -> [a] -> [a]
deleteAllsBy eq = foldl (flip (deleteAllBy eq))
infixl 9 !!
-(!!) :: forall a . [a] -> P.Int -> a
+(!!) :: forall a . [a] -> Int -> a
(!!) axs i =
- if i < 0 then
+ if i < (0::Int) then
error "!!: <0"
else
let
nth _ [] = error "!!: empty"
- nth n (x:xs) = if n == 0 then x else nth (n - 1) xs
+ nth n (x:xs) = if n == (0::Int) then x else nth (n - (1::Int)) xs
in nth i axs
-eqList :: forall a . (a -> a -> Bool) -> [a] -> [a] -> Bool
-eqList _ [] [] = True
-eqList eq (x:xs) (y:ys) = eq x y && eqList eq xs ys
-eqList _ _ _ = False
-
partition :: forall a . (a -> Bool) -> [a] -> ([a], [a])
partition p xs = (filter p xs, filter (not . p) xs)
+sort :: forall a . Ord a => [a] -> [a]
+sort = sortLE (<=)
+
-- A simple "quicksort" for now.
sortLE :: forall a . (a -> a -> Bool) -> [a] -> [a]
sortLE _ [] = []
@@ -291,17 +333,6 @@
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
@@ -311,6 +342,9 @@
init [] = error "init: []"
init [_] = []
init (x:xs) = x : init xs
+
+anySame :: forall a . Eq a => [a] -> Bool
+anySame = anySameBy (==)
anySameBy :: forall a . (a -> a -> Bool) -> [a] -> Bool
anySameBy _ [] = False
--- /dev/null
+++ b/lib/Data/List_Type.hs
@@ -1,0 +1,12 @@
+module Data.List_Type(module Data.List_Type) where
+import Primitives
+
+infixr 5 :
+data [] a = [] | (:) a [a] -- Parser hacks makes this acceptable
+
+-- This does not really belong here, but it makes the module structure
+-- much simpler.
+infixr 5 ++
+(++) :: forall a . [a] -> [a] -> [a]
+(++) [] ys = ys
+(++) (x : xs) ys = x : xs ++ ys
--- a/lib/Data/Maybe.hs
+++ b/lib/Data/Maybe.hs
@@ -1,11 +1,46 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
-module Data.Maybe(module Data.Maybe) where
+module Data.Maybe(module Data.Maybe, module Data.Maybe_Type) where
import Primitives
+import Control.Applicative
+import Control.Monad
import Data.Bool
+import Data.Char
+import Data.Eq
+import Data.Function
+import Data.Functor
+import Data.Int
+import Data.List
+import Data.Maybe_Type
+import Data.Ord
+import Text.Show
-data Maybe a = Nothing | Just a
+instance forall a . Eq a => Eq (Maybe a) where
+ Nothing == Nothing = True
+ Just x == Just x' = x == x'
+ _ == _ = False
+instance forall a . (Show a) => Show (Maybe a) where
+ showsPrec _ Nothing = showString "Nothing"
+ showsPrec p (Just a) = showParen (p >= 11) (showString "Just " . showsPrec 11 a)
+
+instance Functor Maybe where
+ fmap _ Nothing = Nothing
+ fmap f (Just a) = Just (f a)
+
+instance Applicative Maybe where
+ pure = Just
+ Just f <*> Just a = Just (f a)
+ _ <*> _ = Nothing
+
+instance Monad Maybe where
+ return = pure
+ Nothing >>= _ = Nothing
+ Just a >>= f = f a
+
+instance MonadFail Maybe where
+ fail _ = Nothing
+
maybe :: forall a r . r -> (a -> r) -> Maybe a -> r
maybe r _ Nothing = r
maybe _ f (Just a) = f a
@@ -14,10 +49,6 @@
fromMaybe a Nothing = a
fromMaybe _ (Just a) = a
-fmapMaybe :: forall a b . (a -> b) -> Maybe a -> Maybe b
-fmapMaybe _ Nothing = Nothing
-fmapMaybe f (Just a) = Just (f a)
-
catMaybes :: forall a . [Maybe a] -> [a]
catMaybes mxs = [ x | Just x <- mxs ]
@@ -25,7 +56,14 @@
isJust Nothing = False
isJust (Just _) = True
-{--mapMaybe is in Data.List to avoid recursive modules
-maybeToList is in Data.List to avoid recursive modules
--}
+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]
+
--- /dev/null
+++ b/lib/Data/Maybe_Type.hs
@@ -1,0 +1,5 @@
+-- Copyright 2023 Lennart Augustsson
+-- See LICENSE file for full license.
+module Data.Maybe_Type(module Data.Maybe_Type) where
+
+data Maybe a = Nothing | Just a
--- /dev/null
+++ b/lib/Data/Monoid.hs
@@ -1,0 +1,8 @@
+module Data.Monoid(module Data.Monoid) where
+import Primitives
+import Data.Semigroup
+
+class Semigroup a => Monoid a where
+ mempty :: a
+ mappend :: a -> a -> a
+ mappend = (<>)
--- /dev/null
+++ b/lib/Data/Num.hs
@@ -1,0 +1,24 @@
+-- Copyright 2023 Lennart Augustsson
+-- See LICENSE file for full license.
+module Data.Num(module Data.Num) where
+import Primitives
+--Yimport PrimFromInteger
+import Data.Integer_Type
+
+infixl 6 +,-
+infixl 7 *
+
+class Num a where
+ (+) :: a -> a -> a
+ (-) :: a -> a -> a
+ (*) :: a -> a -> a
+ negate :: a -> a
+ abs :: a -> a
+ signum :: a -> a
+ fromInteger :: Integer -> a
+--Y{-+ negate x = 0 - x
+--Y-}
+
+subtract :: forall a . Num a => a -> a -> a
+subtract x y = y - x
--- a/lib/Data/Ord.hs
+++ b/lib/Data/Ord.hs
@@ -1,18 +1,48 @@
module Data.Ord(
- Ordering(..),
- eqOrdering,
- isEQ,
+ module Data.Ord,
+ module Data.Ordering_Type,
) where
+import Primitives
import Data.Bool_Type
+import Data.Bounded
import Data.Ordering_Type
-import Data.Int
+import Data.Eq
+import Text.Show
+infix 4 <,<=,>,>=
+
+class Eq a => Ord a where
+ compare :: a -> a -> Ordering
+ (<) :: a -> a -> Bool
+ (<=) :: a -> a -> Bool
+ (>) :: a -> a -> Bool
+ (>=) :: a -> a -> Bool
+ max :: a -> a -> a
+ min :: a -> a -> a
+ -- XXX Check with the Haskell report
+ compare x y = if x <= y then (if y <= x then EQ else LT) else GT
+ x < y = if y <= x then False else True
+ x > y = if x <= y then False else True
+ x >= y = x <= y
+ min x y = if x <= y then x else y
+ max x y = if x <= y then y else x
+
+instance Eq Ordering where
+ LT == LT = True
+ EQ == EQ = True
+ GT == GT = True
+ _ == _ = False
+
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
+instance Show Ordering where
+ showsPrec _ LT = showString "LT"
+ showsPrec _ EQ = showString "EQ"
+ showsPrec _ GT = showString "GT"
+
+instance Bounded Ordering where
+ minBound = LT
+ maxBound = GT
+
--- /dev/null
+++ b/lib/Data/Ratio.hs
@@ -1,0 +1,83 @@
+module Data.Ratio(
+ Ratio, Rational,
+ (%),
+ numerator, denominator,
+ rationalInfinity,
+ rationalNaN,
+ Rational,
+ ) where
+import Primitives
+import Control.Error
+import Data.Bool
+import Data.Eq
+import Data.Fractional
+import Data.Function
+--import Data.Int
+import Data.Integer
+import Data.Integral
+import Data.Num
+import Data.Ord
+import Data.Ratio_Type
+import Text.Show
+
+{- in Data.Ratio_Type+data Ratio a = (:%) a a -- XXX should be strict
+
+type Rational = Ratio Integer
+-}
+
+instance forall a . Eq a => Eq (Ratio a) where
+ (x :% y) == (x' :% y') = x == x' && y == y'
+
+instance forall a . (Integral a, Ord a) => Ord (Ratio a) where
+ (x :% y) <= (x' :% y') = x * y' <= x' * y
+ (x :% y) < (x' :% y') = x * y' < x' * y
+ (x :% y) >= (x' :% y') = x * y' >= x' * y
+ (x :% y) > (x' :% y') = x * y' > x' * y
+
+instance forall a . (Integral a) => Num (Ratio a) where
+ (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
+ (x:%y) - (x':%y') = reduce (x*y' - x'*y) (y*y')
+ (x:%y) * (x':%y') = reduce (x * x') (y * y')
+ negate (x:%y) = (negate x) :% y
+ abs (x:%y) = abs x :% y
+ signum (x:%_) = signum x :% 1
+ fromInteger x = fromInteger x :% 1
+
+instance forall a . (Integral a, Ord a) => Fractional (Ratio a) where
+ (x:%y) / (x':%y') = (x*y') % (y*x')
+ recip (x:%y)
+ | y == 0 = error "Data.Ratio.recip: division by 0"
+ | x < 0 = negate y :% negate x
+ | otherwise = y :% x
+ fromRational (x:%y) = fromInteger x % fromInteger y
+
+instance forall a . (Show a) => Show (Ratio a) where
+ showsPrec p (x:%y) = showParen (p > 7) $
+ showsPrec 8 x .
+ showString " % " .
+ showsPrec 8 y
+
+rationalInfinity :: Rational
+rationalInfinity = 1 :% 0
+
+rationalNaN :: Rational
+rationalNaN = 0 :% 0
+
+infixl 7 %
+(%) :: forall a . (Integral a) => a -> a -> Ratio a
+x % y = reduce (x * signum y) (abs y)
+
+reduce :: forall a . (Integral a) => a -> a -> Ratio a
+reduce x y =
+ if y == 0 then
+ error "Data.Ratio.%: 0 denominator"
+ else
+ let d = gcd x y
+ in (x `quot` d) :% (y `quot` d)
+
+numerator :: forall a . Ratio a -> a
+numerator (x :% _) = x
+
+denominator :: forall a . Ratio a -> a
+denominator (_ :% y) = y
--- /dev/null
+++ b/lib/Data/Ratio_Type.hs
@@ -1,0 +1,13 @@
+module Data.Ratio_Type(module Data.Ratio_Type) where
+import Primitives
+import Data.Integer_Type
+
+data Ratio a = (:%) a a -- XXX should be strict
+
+type Rational = Ratio Integer
+
+_integerToRational :: Integer -> Rational
+_integerToRational x = x :% (1::Integer)
+
+_mkRational :: Integer -> Integer -> Rational
+_mkRational = (:%)
--- /dev/null
+++ b/lib/Data/Real.hs
@@ -1,0 +1,6 @@
+module Data.Real(module Data.Real) where
+import Primitives
+import Data.Ratio_Type
+
+class Real a where
+ toRational :: a -> Rational
--- /dev/null
+++ b/lib/Data/Semigroup.hs
@@ -1,0 +1,6 @@
+module Data.Semigroup(Data.Semigroup) where
+import Primitive
+
+infixr 6 <>
+class Semigroup a where
+ (<>) :: a -> a -> a
--- a/lib/Data/Tuple.hs
+++ b/lib/Data/Tuple.hs
@@ -1,12 +1,18 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
-module Data.Tuple(module Data.Tuple
+module Data.Tuple(
+ module Data.Tuple,
--Y{-- , ()(..)
+ ()(..)
--Y-}
- ) where
+ ) where
import Primitives -- for ()
+--Yimport PrimFromInteger
import Data.Bool
+import Data.Bounded
+import Data.Eq
+import Data.Function
+import Text.Show
--data (a,b) = (a,b) -- all tuples are built in
--data (a,b,c) = (a,b,c)
@@ -18,5 +24,40 @@
snd :: forall a b . (a, b) -> b
snd (_, b) = b
-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
+instance forall a b . (Eq a, Eq b) => Eq (a, b) where
+ (a1, b1) == (a2, b2) = a1 == a2 && b1 == b2
+
+instance forall a b c . (Eq a, Eq b, Eq c) => Eq (a, b, c) where
+ (a1, b1, c1) == (a2, b2, c2) = a1 == a2 && b1 == b2 && c1 == c2
+
+instance forall a b c d . (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) where
+ (a1, b1, c1, d1) == (a2, b2, c2, d2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2
+
+instance Show () where
+ showsPrec _ () = showString "()"
+
+instance forall a b . (Show a, Show b) => Show (a, b) where
+ showsPrec _ (a, b) = showParen True (showsPrec 0 a . showString "," . showsPrec 0 b)
+
+instance forall a b c . (Show a, Show b, Show c) => Show (a, b, c) where
+ showsPrec _ (a, b, c) = showParen True (showsPrec 0 a . showString "," . showsPrec 0 b . showString "," . showsPrec 0 c)
+
+instance forall a b c d . (Show a, Show b, Show c, Show d) => Show (a, b, c, d) where
+ showsPrec _ (a, b, c, d) = showParen True (showsPrec 0 a . showString "," . showsPrec 0 b . showString "," . showsPrec 0 c .
+ showString "," . showsPrec 0 d)
+
+instance Bounded () where
+ minBound = ()
+ maxBound = ()
+
+instance forall a b . (Bounded a, Bounded b) => Bounded (a, b) where
+ minBound = (minBound, minBound)
+ maxBound = (maxBound, maxBound)
+
+instance forall a b c . (Bounded a, Bounded b, Bounded c) => Bounded (a, b, c) where
+ minBound = (minBound, minBound, minBound)
+ maxBound = (maxBound, maxBound, maxBound)
+
+instance forall a b c d . (Bounded a, Bounded b, Bounded c, Bounded d) => Bounded (a, b, c, d) where
+ minBound = (minBound, minBound, minBound, minBound)
+ maxBound = (maxBound, maxBound, maxBound, maxBound)
--- a/lib/Data/Word.hs
+++ b/lib/Data/Word.hs
@@ -2,61 +2,98 @@
-- See LICENSE file for full license.
module Data.Word(module Data.Word, Word) where
import Primitives
+import Data.Bits
import Data.Bool_Type
-import qualified Data.Char as C
-import qualified Data.Int as I
+import Data.Bounded
+import Data.Char
+import Data.Enum
+import Data.Eq
+import Data.Int() -- instances only
+import Data.Integer
+import Data.Integral
import Data.List
-import Text.String
+import Data.Num
+import Data.Ord
+import Data.Real
+import Text.Show
-infixl 6 +,-
-infixl 7 *,`quot`,`rem`
+instance Num Word where
+ (+) = primWordAdd
+ (-) = primWordSub
+ (*) = primWordMul
+ abs x = x
+ signum x = if x == 0 then 0 else 1
+ fromInteger x = primIntToWord (_integerToInt x)
--- Arithmetic
-(+) :: Word -> Word -> Word
-(+) = primWordAdd
-(-) :: Word -> Word -> Word
-(-) = primWordSub
-(*) :: Word -> Word -> Word
-(*) = primWordMul
-quot :: Word -> Word -> Word
-quot = primWordQuot
-rem :: Word -> Word -> Word
-rem = primWordRem
+instance Integral Word where
+ quot = primWordQuot
+ rem = primWordRem
+ toInteger = _wordToInteger
---------------------------------
+instance Bounded Word where
+ minBound = 0::Word
+ maxBound = (-1::Word)
+
+instance Real Word where
+ toRational i = _integerToRational (_wordToInteger i)
-infix 4 ==,/=,<,<=,>,>=
-
--- Comparison
-(==) :: Word -> Word -> Bool
-(==) = primWordEQ
-(/=) :: Word -> Word -> Bool
-(/=) = primWordNE
+--------------------------------
-(<) :: Word -> Word -> Bool
-(<) = primWordLT
-(<=) :: Word -> Word -> Bool
-(<=) = primWordLE
-(>) :: Word -> Word -> Bool
-(>) = primWordGT
-(>=) :: Word -> Word -> Bool
-(>=) = primWordGE
+instance Enum Word where
+ succ x = x + 1
+ pred x = x - 1
+ toEnum = primIntToWord
+ fromEnum = primWordToInt
+ enumFrom n = n : enumFrom (n+1)
+ enumFromThen n m = from n
+ where d = m - n
+ from i = i : from (i+d)
+ enumFromTo l h = takeWhile (<= h) (enumFrom l)
+ enumFromThenTo l m h =
+ if m > l then
+ takeWhile (<= h) (enumFromThen l m)
+ else
+ takeWhile (>= h) (enumFromThen l m)
-eqWord :: Word -> Word -> Bool
-eqWord = (==)
-
-intToWord :: Int -> Word
-intToWord = primUnsafeCoerce
+--------------------------------
-wordToInt :: Word -> Int
-wordToInt = primUnsafeCoerce
+instance Eq Word where
+ (==) = primWordEQ
+ (/=) = primWordNE
---------------------------------
+instance Ord Word where
+ (<) = primWordLT
+ (<=) = primWordLE
+ (>) = primWordGT
+ (>=) = primWordGE
+
+instance Enum Word where
+ toEnum = primIntToWord
+ fromEnum = primWordToInt
-showWord :: Word -> C.String
-showWord n =
- let
- c = C.chr ((I.+) (C.ord '0') (wordToInt (rem n (intToWord 10))))
- in case n < intToWord 10 of
- False -> showWord (quot n (intToWord 10)) ++ [c]
- True -> [c]
+--------------------------------
+
+instance Bits Word where
+ (.&.) = primWordAnd
+ (.|.) = primWordOr
+ xor = primWordXor
+ complement = primWordInv
+ shiftL = primWordShl
+ shiftR = primWordShr
+-- bitSizeMaybe _ = Just 64 -- XXX
+ bitSize _ = 64
+ bit n = primWordShl 1 n
+ zeroBits = 0
+
+--------------------------------
+
+instance Show Word where
+ show = showWord
+ where
+ showWord :: Word -> String
+ showWord n =
+ let
+ c = chr (ord '0' + primWordToInt (rem n (10::Word)))
+ in case n < (10::Word) of
+ False -> showWord (quot n (10::Word)) ++ [c]
+ True -> [c]
--- a/lib/Prelude.hs
+++ b/lib/Prelude.hs
@@ -1,35 +1,68 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
module Prelude(
+ module Control.Applicative,
module Control.Error,
+ module Control.Monad,
module Data.Bool,
+ module Data.Bounded,
module Data.Char,
+ module Data.Double,
module Data.Either,
+ module Data.Enum,
+ module Data.Eq,
+ module Data.Floating,
+ module Data.Fractional,
module Data.Function,
+ module Data.Functor,
module Data.Int,
+ module Data.Integer,
+ module Data.Integral,
module Data.List,
module Data.Maybe,
+ module Data.Num,
module Data.Ord,
+ module Data.Ratio,
+ module Data.Real,
module Data.Tuple,
module System.IO,
+ module Text.Show,
module Text.String,
- _noMatch,
+ --Ymodule Primitives,
) where
+--Yimport Primitives(ifThenElse)
+import Control.Applicative
import Control.Error
+import Control.Monad
import Data.Bool
+import Data.Bounded
import Data.Char
+import Data.Double
import Data.Either
+import Data.Enum
+import Data.Eq
+import Data.Floating
+import Data.Fractional
import Data.Function
+import Data.Functor
import Data.Int
+import Data.Integer
+import Data.Integral
import Data.List
import Data.Maybe
+import Data.Num
import Data.Ord
+import Data.Ratio(Rational)
+import Data.Real
import Data.Tuple
import System.IO
+import Text.Show
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
@@ -2,9 +2,12 @@
-- See LICENSE file for full license.
module Primitives(module Primitives) where
import Data.Bool_Type
+--import Data.List_Type
import Data.Ordering_Type
infixr -1 ->
+infixr -2 =>
+infix 4 ~
data Any
data Char
@@ -14,6 +17,9 @@
data IO a
data Word
+-- Type equality as a constraint.
+class a ~ b {-x | a -> b, b -> a-}+
data () = () -- Parser hacks allows () to be used
primIntAdd :: Int -> Int -> Int
@@ -28,6 +34,8 @@
primIntRem = primitive "rem"
primIntSubR :: Int -> Int -> Int
primIntSubR = primitive "subtract"
+primIntNeg :: Int -> Int
+primIntNeg = primitive "neg"
primDoubleAdd :: Double -> Double -> Double
primDoubleAdd = primitive "fadd"
@@ -53,6 +61,8 @@
primDoubleShow = primitive "fshow"
primDoubleRead :: [Char] -> Double
primDoubleRead = primitive "fread"
+primDoubleFromInt :: Int -> Double
+primDoubleFromInt = primitive "itof"
primWordAdd :: Word -> Word -> Word
primWordAdd = primitive "+"
@@ -64,6 +74,24 @@
primWordQuot = primitive "uquot"
primWordRem :: Word -> Word -> Word
primWordRem = primitive "urem"
+primWordAnd :: Word -> Word -> Word
+primWordAnd = primitive "and"
+primWordOr :: Word -> Word -> Word
+primWordOr = primitive "or"
+primWordXor :: Word -> Word -> Word
+primWordXor = primitive "xor"
+primWordShl :: Word -> Int -> Word
+primWordShl = primitive "shl"
+primWordShr :: Word -> Int -> Word
+primWordShr = primitive "shr"
+primWordAshr :: Word -> Int -> Word
+primWordAshr = primitive "ashr"
+primWordInv :: Word -> Word
+primWordInv = primitive "inv"
+primWordToDoubleRaw :: Word -> Double
+primWordToDoubleRaw = primitive "ffromraw"
+primWordFromDoubleRaw :: Double -> Word
+primWordFromDoubleRaw = primitive "ftoraw"
primIntEQ :: Int -> Int -> Bool
primIntEQ = primitive "=="
@@ -91,6 +119,11 @@
primWordGE :: Word -> Word -> Bool
primWordGE = primitive ">="
+primWordToInt :: Word -> Int
+primWordToInt = primitive "I"
+primIntToWord :: Int -> Word
+primIntToWord = primitive "I"
+
primCharEQ :: Char -> Char -> Bool
primCharEQ = primitive "=="
primCharNE :: Char -> Char -> Bool
@@ -116,12 +149,11 @@
--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"
+primStringEQ :: [Char] -> [Char] -> Bool
+primStringEQ = primitive "equal"
primChr :: Int -> Char
primChr = primitive "I"
@@ -181,9 +213,3 @@
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,19 +1,43 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
-module System.IO(module System.IO, Handle, IO) where
+module System.IO(
+ module System.IO, Handle, IO,
+ module Data.Functor,
+ module Control.Applicative,
+ module Control.Monad,
+ ) where
import Primitives
+import Control.Applicative
import Control.Error
+import Control.Monad
import Data.Bool
import Data.Char
+import Data.Eq
+import Data.Functor
import Data.Int
import Data.List
import Data.Maybe
+import Data.Num
import Data.Tuple
+import Text.Show
type FilePath = String
data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
+instance Functor IO where
+ fmap f ioa = ioa `primBind` \ a -> primReturn (f a)
+instance Applicative IO where
+ pure = primReturn
+ (<*>) = ap
+instance Monad IO where
+ (>>=) = primBind
+ (>>) = primThen
+ return = primReturn
+instance MonadFail IO where
+ fail = error
+
+{-infixl 1 >>=
(>>=) :: forall a b . IO a -> (a -> IO b) -> IO b
(>>=) = primBind
@@ -30,6 +54,7 @@
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 = primHSerialize
@@ -49,7 +74,7 @@
hGetChar :: Handle -> IO Char
hGetChar h = do
c <- primHGetChar h
- if c == negate 1 then
+ if c == (-1::Int) then
error "hGetChar: EOF"
else
return (chr c)
@@ -61,10 +86,10 @@
openFileM p m = do
let
n = case m of
- ReadMode -> 0
- WriteMode -> 1
- AppendMode -> 2
- ReadWriteMode -> 3
+ ReadMode -> 0::Int
+ WriteMode -> 1::Int
+ AppendMode -> 2::Int
+ ReadWriteMode -> 3::Int
hdl <- primOpenFile p n
if primIsNullHandle hdl then
return Nothing
@@ -84,31 +109,12 @@
getChar :: IO Char
getChar = hGetChar stdin
-print :: forall a . a -> IO ()
-print = primHPrint stdout
+cprint :: forall a . a -> IO ()
+cprint = primHPrint stdout
-mapM :: forall a b . (a -> IO b) -> [a] -> IO [b]
-mapM f =
- let
- rec [] = return []
- rec (a : as) = do
- b <- f a
- bs <- rec as
- return (b : bs)
- in rec
+print :: forall a . (Show a) => a -> IO ()
+print a = putStrLn (show a)
-mapM_ :: forall a b . (a -> IO b) -> [a] -> IO ()
-mapM_ f =
- let
- rec [] = return ()
- rec (a : as) = do
- f a
- rec as
- in rec
-
-when :: Bool -> IO () -> IO ()
-when b io = if b then io else return ()
-
putStr :: String -> IO ()
putStr = hPutStr stdout
@@ -139,7 +145,7 @@
hGetContents :: Handle -> IO String
hGetContents h = do
c <- primHGetChar h
- if c == negate 1 then do
+ if c == (-1::Int) then do
hClose h -- EOF, so close the handle
return ""
else do
--- /dev/null
+++ b/lib/Text/PrettyPrint/HughesPJ.hs
@@ -1,0 +1,368 @@
+-- Based on the pretty-printer outlined in the paper
+-- 'The Design of a Pretty-printing Library' by
+-- John Hughes in Advanced Functional Programming, 1995.
+-- With inspiration and code from the from the Hackage package pretty.
+module Text.PrettyPrint.HughesPJ(
+ Doc,
+ text, empty,
+ (<>), (<+>), ($$), ($+$),
+ hcat, hsep,
+ vcat,
+ sep, cat,
+ nest, hang,
+ punctuate,
+ parens, brackets, braces,
+ maybeParens,
+ Style,
+ render, renderStyle,
+ ) where
+import Prelude
+
+infixl 6 <>, <+>
+infixl 5 $$, $+$
+
+data Doc
+ = Empty -- ^ An empty span, see 'empty'.
+ | NilAbove Doc -- ^ @text "" $$ x@.
+ | TextBeside String Doc -- ^ @text s <> x@.
+ | Nest Int Doc -- ^ @nest k x@.
+ | Union Doc Doc -- ^ @ul `union` ur@.
+ | NoDoc -- ^ The empty set of documents.
+ | Beside Doc Bool Doc -- ^ True <=> space between.
+ | Above Doc Bool Doc -- ^ True <=> never overlap.
+
+type RDoc = Doc
+
+text :: String -> Doc
+text s = TextBeside s Empty
+
+empty :: Doc
+empty = Empty
+
+reduceDoc :: Doc -> RDoc
+reduceDoc (Beside p g q) = beside p g (reduceDoc q)
+reduceDoc (Above p g q) = above p g (reduceDoc q)
+reduceDoc p = p
+
+hcat :: [Doc] -> Doc
+hcat = snd . reduceHoriz . foldr (\p q -> Beside p False q) empty
+
+hsep :: [Doc] -> Doc
+hsep = snd . reduceHoriz . foldr (\p q -> Beside p True q) empty
+
+vcat :: [Doc] -> Doc
+vcat = snd . reduceVert . foldr (\p q -> Above p False q) empty
+
+nest :: Int -> Doc -> Doc
+nest k p = mkNest k (reduceDoc p)
+
+-- | @hang d1 n d2 = sep [d1, nest n d2]@
+hang :: Doc -> Int -> Doc -> Doc
+hang d1 n d2 = sep [d1, nest n d2]
+
+punctuate :: Doc -> [Doc] -> [Doc]
+punctuate _ [] = []
+punctuate p (x:xs) = go x xs
+ where go y [] = [y]
+ go y (z:zs) = (y <> p) : go z zs
+
+maybeParens :: Bool -> Doc -> Doc
+maybeParens False = id
+maybeParens True = parens
+
+parens :: Doc -> Doc
+parens p = text "(" <> p <> text ")"+braces :: Doc -> Doc
+braces p = text "{" <> p <> text "}"+brackets :: Doc -> Doc
+brackets p = text "[" <> p <> text "]"
+
+-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
+mkNest :: Int -> Doc -> Doc
+mkNest k _ | k `seq` False = undefined
+mkNest k (Nest k1 p) = mkNest (k + k1) p
+mkNest _ NoDoc = NoDoc
+mkNest _ Empty = Empty
+mkNest 0 p = p
+mkNest k p = nest_ k p
+
+-- mkUnion checks for an empty document
+mkUnion :: Doc -> Doc -> Doc
+mkUnion Empty _ = Empty
+mkUnion p q = p `union_` q
+
+data IsEmpty = IsEmpty | NotEmpty
+
+reduceHoriz :: Doc -> (IsEmpty, Doc)
+reduceHoriz (Beside p g q) = eliminateEmpty Beside (snd (reduceHoriz p)) g (reduceHoriz q)
+reduceHoriz doc = (NotEmpty, doc)
+
+reduceVert :: Doc -> (IsEmpty, Doc)
+reduceVert (Above p g q) = eliminateEmpty Above (snd (reduceVert p)) g (reduceVert q)
+reduceVert doc = (NotEmpty, doc)
+
+eliminateEmpty ::
+ (Doc -> Bool -> Doc -> Doc) ->
+ Doc -> Bool -> (IsEmpty, Doc) -> (IsEmpty, Doc)
+eliminateEmpty _ Empty _ q = q
+eliminateEmpty cons p g q =
+ (NotEmpty,
+ case q of
+ (NotEmpty, q') -> cons p g q'
+ (IsEmpty, _) -> p
+ )
+
+nilAbove_ :: RDoc -> RDoc
+nilAbove_ = NilAbove
+
+-- | Arg of a TextBeside is always an RDoc.
+textBeside_ :: String -> RDoc -> RDoc
+textBeside_ = TextBeside
+
+nest_ :: Int -> RDoc -> RDoc
+nest_ = Nest
+
+union_ :: RDoc -> RDoc -> RDoc
+union_ = Union
+
+($$) :: Doc -> Doc -> Doc
+p $$ q = above_ p False q
+
+-- | Above, with no overlapping.
+-- '$+$' is associative, with identity 'empty'.
+($+$) :: Doc -> Doc -> Doc
+p $+$ q = above_ p True q
+
+above_ :: Doc -> Bool -> Doc -> Doc
+above_ p _ Empty = p
+above_ Empty _ q = q
+above_ p g q = Above p g q
+
+above :: Doc -> Bool -> RDoc -> RDoc
+above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)
+above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q)
+above p g q = aboveNest p g 0 (reduceDoc q)
+
+-- Specfication: aboveNest p g k q = p $g$ (nest k q)
+aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc
+aboveNest _ _ k _ | k `seq` False = undefined
+aboveNest NoDoc _ _ _ = NoDoc
+aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
+ aboveNest p2 g k q
+
+aboveNest Empty _ k q = mkNest k q
+aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q)
+ -- p can't be Empty, so no need for mkNest
+
+aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
+aboveNest (TextBeside s p) g k q = TextBeside s rest
+ where
+ k1 = k - length s
+ rest = case p of
+ Empty -> nilAboveNest g k1 q
+ _ -> aboveNest p g k1 q
+
+aboveNest (Above _ _ _) _ _ _ = error "aboveNest Above"
+aboveNest (Beside _ _ _) _ _ _ = error "aboveNest Beside"
+
+-- Specification: text s <> nilaboveNest g k q
+-- = text s <> (text "" $g$ nest k q)
+nilAboveNest :: Bool -> Int -> RDoc -> RDoc
+nilAboveNest _ k _ | k `seq` False = undefined
+nilAboveNest _ _ Empty = Empty
+ -- Here's why the "text s <>" is in the spec!
+nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
+nilAboveNest g k q | not g && k > 0 -- No newline if no overlap
+ = textBeside_ (replicate k ' ') q
+ | otherwise -- Put them really above
+ = nilAbove_ (mkNest k q)
+
+(<>) :: Doc -> Doc -> Doc
+p <> q = beside_ p False q
+
+-- | Beside, separated by space, unless one of the arguments is 'empty'.
+-- '<+>' is associative, with identity 'empty'.
+(<+>) :: Doc -> Doc -> Doc
+p <+> q = beside_ p True q
+
+beside_ :: Doc -> Bool -> Doc -> Doc
+beside_ p _ Empty = p
+beside_ Empty _ q = q
+beside_ p g q = Beside p g q
+
+-- Specification: beside g p q = p <g> q
+beside :: Doc -> Bool -> RDoc -> RDoc
+beside NoDoc _ _ = NoDoc
+beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q
+beside Empty _ q = q
+beside (Nest k p) g q = nest_ k $! beside p g q
+beside p@(Beside p1 g1 q1) g2 q2
+ | g1 == g2 = beside p1 g1 $! beside q1 g2 q2
+ | otherwise = beside (reduceDoc p) g2 q2
+beside p@(Above _ _ _) g q = let { d = reduceDoc p } in beside d g q+beside (NilAbove p) g q = nilAbove_ $! beside p g q
+beside (TextBeside t p) g q = TextBeside t rest
+ where
+ rest = case p of
+ Empty -> nilBeside g q
+ _ -> beside p g q
+
+-- Specification: text "" <> nilBeside g p
+-- = text "" <g> p
+nilBeside :: Bool -> RDoc -> RDoc
+nilBeside _ Empty = Empty -- Hence the text "" in the spec
+nilBeside g (Nest _ p) = nilBeside g p
+nilBeside g p | g = textBeside_ " " p
+ | otherwise = p
+
+sep :: [Doc] -> Doc
+sep = sepX True -- Separate with spaces
+
+-- | Either 'hcat' or 'vcat'.
+cat :: [Doc] -> Doc
+cat = sepX False -- Don't
+
+sepX :: Bool -> [Doc] -> Doc
+sepX _ [] = empty
+sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps
+
+
+-- Specification: sep1 g k ys = sep (x : map (nest k) ys)
+-- = oneLiner (x <g> nest k (hsep ys))
+-- `union` x $$ nest k (vcat ys)
+sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc
+sep1 _ _ k _ | k `seq` False = undefined
+sep1 _ NoDoc _ _ = NoDoc
+sep1 g (p `Union` q) k ys = sep1 g p k ys `union_`
+ aboveNest q False k (reduceDoc (vcat ys))
+
+sep1 g Empty k ys = mkNest k (sepX g ys)
+sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys)
+
+sep1 _ (NilAbove p) k ys = nilAbove_
+ (aboveNest p False k (reduceDoc (vcat ys)))
+sep1 g (TextBeside s p) k ys = textBeside_ s (sepNB g p (k - length s) ys)
+sep1 _ (Above _ _ _) _ _ = error "sep1 Above"
+sep1 _ (Beside _ _ _) _ _ = error "sep1 Beside"
+
+sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc
+sepNB g (Nest _ p) k ys
+ = sepNB g p k ys
+sepNB g Empty k ys
+ = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion`
+ nilAboveNest False k (reduceDoc (vcat ys))
+ where
+ rest | g = hsep ys
+ | otherwise = hcat ys
+sepNB g p k ys
+ = sep1 g p k ys
+
+oneLiner :: Doc -> Doc
+oneLiner NoDoc = NoDoc
+oneLiner Empty = Empty
+oneLiner (NilAbove _) = NoDoc
+oneLiner (TextBeside s p) = textBeside_ s (oneLiner p)
+oneLiner (Nest k p) = nest_ k (oneLiner p)
+oneLiner (p `Union` _) = oneLiner p
+oneLiner (Above _ _ _) = error "oneLiner Above"
+oneLiner (Beside _ _ _) = error "oneLiner Beside"
+
+-- ---------------------------------------------------------------------------
+-- Rendering
+
+-- | A rendering style. Allows us to specify constraints to choose among the
+-- many different rendering options.
+data Style = Style Int Rat
+lineLength :: Style -> Int
+lineLength (Style l _) = l
+ribbonsPerLine :: Style -> Rat
+ribbonsPerLine (Style _ r) = r
+
+type Rat = (Int, Int)
+
+style :: Style
+style = Style 100 (3, 2)
+
+-- | Render the @Doc@ to a String using the default @Style@ (see 'style').
+render :: Doc -> String
+render = renderStyle style
+
+-- | Render the @Doc@ to a String using the given @Style@.
+renderStyle :: Style -> Doc -> String
+renderStyle s = fullRender (lineLength s) (ribbonsPerLine s) ""
+
+-- | The general rendering interface. Please refer to the @Style@ and @Mode@
+-- types for a description of rendering mode, line length and ribbons.
+fullRender :: Int -- ^ Line length.
+ -> Rat -- ^ Ribbons per line.
+ -> String -- ^ What to do at the end.
+ -> Doc -- ^ The document.
+ -> String -- ^ Result.
+fullRender lineLen (num, den) rest doc
+ = display lineLen ribbonLen rest doc'
+ where
+ doc' = best bestLineLen ribbonLen (reduceDoc doc)
+
+ ribbonLen = (lineLen * den) `quot` num
+ bestLineLen = lineLen
+
+display :: Int -> Int -> String -> Doc -> String
+display _page_width _ribbon_width end doc
+ = let lay :: Int -> Doc -> String
+ lay k (Nest k1 p) = lay (k + k1) p
+ lay _ Empty = end
+ lay k (NilAbove p) = "\n" ++ lay k p
+ lay k (TextBeside s p) = lay1 k s p
+ lay _ _ = error "display lay"
+
+ lay1 k s p = let r = k + length s
+ in replicate k ' ' ++ (s ++ lay2 r p)
+
+ lay2 :: Int -> Doc -> String
+ lay2 k (NilAbove p) = "\n" ++ lay k p
+ lay2 k (TextBeside s p) = s ++ lay2 (k + length s) p
+ lay2 k (Nest _ p) = lay2 k p
+ lay2 _ Empty = end
+ lay2 _ _ = error "display lay2"
+ in lay 0 doc
+
+best :: Int -- Line length.
+ -> Int -- Ribbon length.
+ -> RDoc
+ -> RDoc -- No unions in here!.
+best w0 r = get w0
+ where
+ get _ Empty = Empty
+ get _ NoDoc = NoDoc
+ get w (NilAbove p) = nilAbove_ (get w p)
+ get w (TextBeside s p) = textBeside_ s (get1 w (length s) p)
+ get w (Nest k p) = nest_ k (get (w - k) p)
+ get w (p `Union` q) = nicest w r (get w p) (get w q)
+ get _ _ = error "best get"
+
+ get1 _ _ Empty = Empty
+ get1 _ _ NoDoc = NoDoc
+ get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p)
+ get1 w sl (TextBeside s p) = textBeside_ s (get1 w (sl + length s) p)
+ get1 w sl (Nest _ p) = get1 w sl p
+ get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
+ (get1 w sl q)
+ get1 _ _ _ = error "best get1"
+
+nicest :: Int -> Int -> Doc -> Doc -> Doc
+nicest w r = nicest1 w r 0
+
+nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc
+nicest1 w r sl p q | fits (minWR - sl) p = p
+ | otherwise = q
+ where minWR = if w < r then w else r
+
+fits :: Int -- Space available
+ -> Doc
+ -> Bool -- True if *first line* of Doc fits in space available
+fits n _ | n < 0 = False
+fits _ NoDoc = False
+fits _ Empty = True
+fits _ (NilAbove _) = True
+fits n (TextBeside s p) = fits (n - length s) p
+fits _ _ = error "fits"
--- /dev/null
+++ b/lib/Text/Show.hs
@@ -1,0 +1,42 @@
+module Text.Show(module Text.Show) where
+import Primitives
+--Yimport PrimFromInteger
+import Data.Bool_Type
+import Data.Char_Type
+import Data.List_Type
+
+type ShowS = String -> String
+
+class Show a where
+ showsPrec :: Int -> a -> ShowS
+ show :: a -> String
+ showList :: [a] -> ShowS
+
+ showsPrec _ x s = show x ++ s
+ show x = showsPrec 0 x ""
+ showList = showListWith shows
+
+shows :: forall a . Show a => a -> ShowS
+shows = showsPrec 0
+
+showChar :: Char -> ShowS
+showChar = (:)
+
+showString :: String -> ShowS
+showString = (++)
+
+showParen :: Bool -> ShowS -> ShowS
+showParen False sh = sh
+showParen True sh = \ x -> '(' : sh (')' : x)+
+showListWith :: forall a . (a -> ShowS) -> [a] -> ShowS
+showListWith _ [] s = '[' : ']' : s
+showListWith sh (x:xs) s = '[' : sh x (shl xs)
+ where
+ shl [] = ']' : s
+ shl (y:ys) = ',' : sh y (shl ys)
+
+appPrec :: Int
+appPrec = 10
+appPrec1 :: Int
+appPrec1 = 11
--- a/lib/Text/String.hs
+++ b/lib/Text/String.hs
@@ -5,98 +5,58 @@
import Data.Bool
import Data.Char
import Data.Either
+import Data.Eq
+import Data.Fractional
import Data.Function
import Data.Int
-import qualified Data.Double as DD
+import Data.Integer
+import Data.Integral
import Data.List
import Data.Maybe
+import Data.Num
import Data.Ord
+import Data.Ratio
+import Data.Real
import Data.Tuple
+import Text.Show
-showChar :: Char -> String
-showChar c = "'" ++ encodeChar c ++ "'"
+xshowChar :: Char -> String
+xshowChar c = "'" ++ xencodeChar c ++ "'"
-encodeChar :: Char -> String
-encodeChar c =
+xencodeChar :: Char -> String
+xencodeChar c =
let
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) ++ "'"
+ case lookup c spec of
+ Nothing -> if isPrint c then [c] else "'\\" ++ show (ord c) ++ "'"
Just s -> s
-showString :: String -> String
-showString s = "\"" ++ concatMap encodeChar s ++ "\""
-
--- XXX wrong for minInt
-showInt :: Int -> String
-showInt 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 if n < 10 then
- [c]
- else
- showUnsignedInt (quot n 10) ++ [c]
-
readInt :: String -> Int
readInt cs =
let
- rd = foldl (\ a c -> a * 10 + ord c - ord '0') 0
- in if eqChar (head cs) '-' then 0 - rd (tail cs) else rd cs
+ rd = foldl (\ a c -> a * (10::Int) + ord c - ord '0') (0::Int)
+ in if head cs == '-' then (0::Int) - rd (tail cs) else rd cs
readDouble :: String -> Double
readDouble = primDoubleRead
-showBool :: Bool -> String
-showBool arg =
- case arg of
- False -> "False"
- True -> "True"
+showListS :: forall a . (a -> String) -> [a] -> String
+showListS sa as = showListWith (\ a s -> sa a ++ s) as ""
-showUnit :: () -> String
-showUnit arg =
- case arg of
- () -> "()"
+showPairS :: forall a b . (a -> String) -> (b -> String) -> (a, b) -> String
+showPairS sa sb (a, b) = "(" ++ sa a ++ "," ++ sb b ++ ")"-showPair :: forall a b . (a -> String) -> (b -> String) -> (a, b) -> String
-showPair sa sb ab =
- case ab of
- (a, b) -> "(" ++ sa a ++ "," ++ sb b ++ ")"-
-showList :: forall a . (a -> String) -> [a] -> String
-showList sa as = "[" ++ intercalate "," (map sa as) ++ "]"
-
-showMaybe :: forall a . (a -> String) -> Maybe a -> String
-showMaybe _ Nothing = "Nothing"
-showMaybe fa (Just a) = "(Just " ++ fa a ++ ")"
-
-showEither :: forall a b . (a -> String) -> (b -> String) -> Either a b -> String
-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
+ case span (not . (== '\n')) s of
(l, s') -> case s' of { [] -> [l]; _:s'' -> l : lines s'' }unlines :: [String] -> String
unlines = concatMap (++ "\n")
-
words :: String -> [String]
words s =
case dropWhile isSpace s of
@@ -107,33 +67,6 @@
unwords :: [String] -> String
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
- [] ->
- case ays of
- [] -> True
- _ -> False
- x:xs ->
- case ays of
- [] -> False
- y:ys -> eqChar x y && eqString xs ys
--}
-leString :: String -> String -> Bool
-leString s t = not (eqOrdering GT (compareString s t))
-{--leString axs ays =
- case axs of
- [] -> True
- x:xs ->
- case ays of
- [] -> False
- y:ys -> ltChar x y || eqChar x y && leString xs ys
--}
-
padLeft :: Int -> String -> String
padLeft n s = replicate (n - length s) ' ' ++ s
@@ -141,29 +74,29 @@
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
+-- Convert string in scientific notation to a rational number.
+readRational :: String -> Rational
+readRational acs@(sgn:as) | sgn == '-' = negate $ rat1 as
+ | otherwise = rat1 acs
+ where
+ rat1 s1 =
+ case span isDigit s1 of
+ (ds1, cr1) | ('.':r1) <- cr1 -> rat2 f1 r1+ | (c:r1) <- cr1, toLower c == 'e' -> rat3 f1 r1
+ | otherwise -> f1
+ where f1 = toRational (readInteger ds1)
+
+ rat2 f1 s2 =
+ case span isDigit s2 of
+ (ds2, cr2) | (c:r2) <- cr2, toLower c == 'e' -> rat3 f2 r2
+ | otherwise -> f2
+ where f2 = f1 + toRational (readInteger ds2) * 10 ^^ (negate $ length ds2)
+
+ rat3 f2 ('+':s) = f2 * expo s+ rat3 f2 ('-':s) = f2 / expo s+ rat3 f2 s = f2 * expo s
+
+ expo s = 10 ^ readInteger s
--- a/src/Compat.hs
+++ b/src/Compat.hs
@@ -4,9 +4,10 @@
module Compat(module Compat) where
--import Control.Exception
import qualified Data.Function as F
+import Data.Char
import Data.Time
import Data.Time.Clock.POSIX
-import qualified Control.Monad as M
+--import qualified Control.Monad as M
import Control.Exception
import Data.List
import System.Environment
@@ -32,29 +33,33 @@
readInt :: String -> Int
readInt = read
+readInteger :: String -> Integer
+readInteger = read
+
readDouble :: String -> Double
readDouble = read
-showInt :: Int -> String
-showInt = show
+_integerToInt :: Integer -> Int
+_integerToInt = fromInteger
-showDouble :: Double -> String
-showDouble = show
+_intToInteger :: Int -> Integer
+_intToInteger = fromIntegral
-showChar :: Char -> String
-showChar = show
+_integerToDouble :: Integer -> Double
+_integerToDouble = fromIntegral
-showBool :: Bool -> String
-showBool = show
+-- Same as in Data.Integer
+_integerToIntList :: Integer -> [Int]
+_integerToIntList i | i < 0 = -1 : to (-i)
+ | otherwise = to i
+ where to 0 = []
+ to n = fromInteger r : to q where (q, r) = quotRem n 2147483648
-showUnit :: () -> String
-showUnit = show
+xshowChar :: Char -> String
+xshowChar = show
-showString :: String -> String
-showString = show
-
-showList :: (a -> String) -> [a] -> String
-showList sa arg =
+showListS :: (a -> String) -> [a] -> String
+showListS sa arg =
let
showRest as =
case as of
@@ -65,11 +70,8 @@
[] -> "[]"
a : as -> "[" ++ sa a ++ showRest as
-showMaybe :: (a -> String) -> Maybe a -> String
-showMaybe fa arg =
- case arg of
- Nothing -> "Nothing"
- Just a -> "(Just " ++ fa a ++ ")"
+showPairS :: (a -> String) -> (b -> String) -> (a, b) -> String
+showPairS f g (a, b) = "(" ++ f a ++ "," ++ g b ++ ")"elemBy :: (a -> a -> Bool) -> a -> [a] -> Bool
elemBy eq a = any (eq a)
@@ -90,35 +92,6 @@
lookupBy :: (a -> a -> Bool) -> a -> [(a, b)] -> Maybe b
lookupBy eq x xys = fmap snd (find (eq x . fst) xys)
-pair :: a -> b -> (a, b)
-pair = (,)
-
-eqList :: (a -> a -> Bool) -> [a] -> [a] -> Bool
-eqList eq axs ays =
- case axs of
- [] ->
- case ays of
- [] -> True
- _:_ -> False
- x:xs ->
- case ays of
- [] -> False
- y:ys -> eq x y && eqList eq xs ys
-
-eqPair :: (a -> a -> Bool) -> (b -> b -> Bool) -> (a, b) -> (a, b) -> Bool
-eqPair eqa eqb ab1 ab2 =
- case ab1 of
- (a1, b1) ->
- case ab2 of
- (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 = (==)
-
openFileM :: FilePath -> IOMode -> IO (Maybe Handle)
openFileM path m = do
r <- (try $ openFile path m) :: IO (Either IOError Handle)
@@ -126,8 +99,8 @@
Left _ -> return Nothing
Right h -> return (Just h)
-when :: Bool -> IO () -> IO ()
-when = M.when
+--when :: Bool -> IO () -> IO ()
+--when = M.when
on :: (a -> a -> b) -> (c -> a) -> (c -> c -> b)
on = F.on
@@ -205,6 +178,34 @@
compareString :: String -> String -> Ordering
compareString = compare
+anySame :: (Eq a) => [a] -> Bool
+anySame = anySameBy (==)
+
anySameBy :: (a -> a -> Bool) -> [a] -> Bool
anySameBy _ [] = False
anySameBy eq (x:xs) = elemBy eq x xs || anySameBy eq xs
+
+-- Convert string in scientific notation to a rational number.
+readRational :: String -> Rational
+readRational "" = undefined
+readRational acs@(sgn:as) | sgn == '-' = negate $ rat1 as
+ | otherwise = rat1 acs
+ where
+ rat1 s1 =
+ case span isDigit s1 of
+ (ds1, cr1) | ('.':r1) <- cr1 -> rat2 f1 r1+ | (c:r1) <- cr1, toLower c == 'e' -> rat3 f1 r1
+ | otherwise -> f1
+ where f1 = toRational (readInteger ds1)
+
+ rat2 f1 s2 =
+ case span isDigit s2 of
+ (ds2, cr2) | (c:r2) <- cr2, toLower c == 'e' -> rat3 f2 r2
+ | otherwise -> f2
+ where f2 = f1 + toRational (readInteger ds2) * 10 ^^ (negate $ length ds2)
+
+ rat3 f2 ('+':s) = f2 * expo s+ rat3 f2 ('-':s) = f2 / expo s+ rat3 f2 s = f2 * expo s
+
+ expo s = 10 ^ readInteger s
--- a/src/MicroHs/Compile.hs
+++ b/src/MicroHs/Compile.hs
@@ -6,11 +6,11 @@
compileCacheTop,
Cache, emptyCache, deleteFromCache,
) where
-import Prelude --Xhiding (Monad(..), mapM, showString, showList)
-import qualified System.IO as IO
+import Prelude
+import System.IO
import Control.DeepSeq
import qualified MicroHs.IdentMap as M
-import MicroHs.StateIO as S
+import MicroHs.StateIO
import MicroHs.Desugar
import MicroHs.Exp
import MicroHs.Expr
@@ -18,26 +18,27 @@
import MicroHs.Parse
import MicroHs.TypeCheck
--Ximport Compat
---Ximport qualified CompatIO as IO
---Ximport System.IO(Handle)
-data Flags = Flags Int Bool [String] String
+data Flags = Flags Int Bool [String] String Bool
--Xderiving (Show)
type Time = Int
verbose :: Flags -> Int
-verbose (Flags x _ _ _) = x
+verbose (Flags x _ _ _ _) = x
runIt :: Flags -> Bool
-runIt (Flags _ x _ _) = x
+runIt (Flags _ x _ _ _) = x
paths :: Flags -> [String]
-paths (Flags _ _ x _) = x
+paths (Flags _ _ x _ _) = x
output :: Flags -> String
-output (Flags _ _ _ x) = x
+output (Flags _ _ _ x _) = x
+loading :: Flags -> Bool
+loading (Flags _ _ _ _ x) = x
+
-----------------
type CModule = TModule [LDef]
@@ -62,104 +63,104 @@
-----------------
compileCacheTop :: Flags -> Ident -> Cache -> IO ([(Ident, Exp)], Cache)
-compileCacheTop flags mn ch = IO.do
+compileCacheTop flags mn ch = do
(ds, ch') <- compile flags mn ch
t1 <- getTimeMilli
let
dsn = [ (n, compileOpt e) | (n, e) <- ds ]
- () <- IO.return (rnf dsn)
+ () <- return (rnf dsn)
t2 <- getTimeMilli
- IO.when (verbose flags > 0) $
- putStrLn $ "combinator conversion " ++ padLeft 6 (showInt (t2-t1)) ++ "ms"
- IO.return (dsn, ch')
+ when (verbose flags > 0) $
+ putStrLn $ "combinator conversion " ++ padLeft 6 (show (t2-t1)) ++ "ms"
+ return (dsn, ch')
--compileTop :: Flags -> IdentModule -> IO [LDef]
compileTop :: Flags -> Ident -> IO [(Ident, Exp)]
-compileTop flags mn = IO.fmap fst $ compileCacheTop flags mn emptyCache
+compileTop flags mn = fmap fst $ compileCacheTop flags mn emptyCache
compile :: Flags -> IdentModule -> Cache -> IO ([LDef], Cache)
-compile flags nm ach = IO.do
+compile flags nm ach = 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, ch)
+ when (verbose flags > 0) $
+ putStrLn $ "total import time " ++ padLeft 6 (show t) ++ "ms"
+ return (concatMap bindingsOf $ M.elems $ cache ch, ch)
-- Compile a module with the given name.
-- If the module has already been compiled, return the cached result.
compileModuleCached :: Flags -> IdentModule -> StateIO Cache (CModule, Time)
-compileModuleCached flags nm = S.do
+compileModuleCached flags mn = do
ch <- gets cache
- case M.lookup nm ch of
- Nothing -> S.do
+ case M.lookup mn ch of
+ Nothing -> do
ws <- gets working
- S.when (elemBy eqIdent nm ws) $
- error $ "recursive module: " ++ showIdent nm
- modify $ \ c -> updWorking (nm : working c) c
- S.when (verbose flags > 0) $
- 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 ++ ")"+ when (elem mn ws) $
+ error $ "recursive module: " ++ showIdent mn ++ ", import chain: " ++ unwords (map showIdent ws)
+ modify $ \ c -> updWorking (mn : working c) c
+ when (verbose flags > 0) $
+ liftIO $ putStrLn $ "importing " ++ showIdent mn
+ (cm, tp, tt, ts) <- compileModule flags mn
+ when (verbose flags > 0) $
+ liftIO $ putStrLn $ "importing done " ++ showIdent mn ++ ", " ++ show (tp + tt) ++
+ "ms (" ++ show tp ++ " + " ++ show tt ++ ")"+ when (loading flags && mn /= mkIdent "Interactive") $
+ liftIO $ putStrLn $ "import " ++ showIdent mn
c <- get
- put $ Cache (tail (working c)) (M.insert nm cm (cache c))
- S.return (cm, tp + tt + ts)
- Just cm -> S.do
- S.when (verbose flags > 0) $
- liftIO $ putStrLn $ "importing cached " ++ showIdent nm
- S.return (cm, 0)
+ put $ Cache (tail (working c)) (M.insert mn cm (cache c))
+ return (cm, tp + tt + ts)
+ Just cm -> do
+ when (verbose flags > 0) $
+ liftIO $ putStrLn $ "importing cached " ++ showIdent mn
+ return (cm, 0)
-- Find and compile a module with the given name.
-- The times are (parsing, typecheck+desugar, imported modules)
compileModule :: Flags -> IdentModule -> StateIO Cache (CModule, Time, Time, Time)
-compileModule flags nm = S.do
+compileModule flags nm = do
t1 <- liftIO getTimeMilli
let
- fn = map (\ c -> if eqChar c '.' then '/' else c) (unIdent nm) ++ ".hs"
+ fn = map (\ c -> if c == '.' then '/' else c) (unIdent nm) ++ ".hs"
(pathfn, file) <- liftIO (readFilePath (paths flags) fn)
let mdl@(EModule nmn _ defs) = parseDie pTop pathfn file
-- liftIO $ putStrLn $ showEModule mdl
-- liftIO $ putStrLn $ showEDefs defs
- S.when (not (eqIdent nm nmn)) $
+ when (nm /= nmn) $
error $ "module name does not agree with file name: " ++ showIdent nm ++ " " ++ showIdent nmn
let
specs = [ s | Import s <- defs ]
t2 <- liftIO getTimeMilli
- (impMdls, ts) <- S.fmap unzip $ S.mapM (compileModuleCached flags) [ m | ImportSpec _ m _ _ <- specs ]
+ (impMdls, ts) <- fmap unzip $ mapM (compileModuleCached flags) [ m | ImportSpec _ m _ _ <- specs ]
t3 <- liftIO getTimeMilli
let
tmdl = typeCheck (zip specs impMdls) mdl
- S.when (verbose flags > 2) $
+ when (verbose flags > 2) $
liftIO $ putStrLn $ "type checked:\n" ++ showTModule showEDefs tmdl ++ "-----\n"
let
dmdl = desugar tmdl
- liftIO $ putStr $ drop 1000000 $ showTModule showLDefs dmdl
+ () <- return $ rnf $ bindingsOf dmdl
t4 <- liftIO getTimeMilli
- S.when (verbose flags > 2) $
+ when (verbose flags > 2) $
(liftIO $ putStrLn $ "desugared:\n" ++ showTModule showLDefs dmdl)
- S.return (dmdl, t2-t1, t4-t3, sum ts)
+ return (dmdl, t2-t1, t4-t3, sum ts)
------------------
readFilePath :: [FilePath] -> FilePath -> IO (FilePath, String)
-readFilePath path name = IO.do
+readFilePath path name = do
mh <- openFilePath path name
case mh of
- Nothing -> error $ "File not found: " ++ showString name ++ "\npath=" ++ showList showString path
- Just (fn, h) -> IO.do
- file <- IO.hGetContents h
- IO.return (fn, file)
+ Nothing -> error $ "File not found: " ++ show name ++ "\npath=" ++ show path
+ Just (fn, h) -> do
+ file <- hGetContents h
+ return (fn, file)
openFilePath :: [FilePath] -> FilePath -> IO (Maybe (FilePath, Handle))
openFilePath adirs fileName =
case adirs of
- [] -> IO.return Nothing
- dir:dirs -> IO.do
+ [] -> return Nothing
+ dir:dirs -> do
let
path = dir ++ "/" ++ fileName
- mh <- openFileM path IO.ReadMode
+ mh <- openFileM path ReadMode
case mh of
Nothing -> openFilePath dirs fileName -- If opening failed, try the next directory
- Just hdl -> IO.return (Just (path, hdl))
+ Just hdl -> return (Just (path, hdl))
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -1,19 +1,21 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
-{-# OPTIONS_GHC -Wno-type-defaults -Wno-incomplete-uni-patterns -Wno-unused-imports -Wno-dodgy-imports #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-unused-imports -Wno-dodgy-imports #-}module MicroHs.Desugar(
desugar,
LDef, showLDefs,
+ encodeInteger,
) where
-import Prelude --Xhiding(showList)
+import Prelude
import Data.Char
import Data.List
import Data.Maybe
+import Data.Ratio
import Control.Monad.State.Strict as S --Xhiding(ap)
--Ximport Control.Monad as S hiding(ap)
--Ximport Compat
--Ximport GHC.Stack
---Ximport Debug.Trace
+import Debug.Trace
import MicroHs.Expr
import MicroHs.Exp
@@ -26,8 +28,8 @@
desugar :: TModule [EDef] -> TModule [LDef]
desugar atm =
case atm of
- TModule mn fxs tys syns vals ds ->
- TModule mn fxs tys syns vals $ checkDup $ concatMap (dsDef mn) ds
+ TModule mn fxs tys syns clss insts vals ds ->
+ TModule mn fxs tys syns clss insts vals $ map lazier $ checkDup $ concatMap (dsDef mn) ds
dsDef :: IdentModule -> EDef -> [LDef]
dsDef mn adef =
@@ -34,14 +36,14 @@
case adef of
Data _ cs ->
let
- f i = mkIdent ("$f" ++ showInt i)- fs = [f i | (i, _) <- zip (enumFrom 0) cs]
+ f i = mkIdent ("$f" ++ show i)+ fs = [f i | (i, _) <- zip [0::Int ..] cs]
dsConstr i (Constr c ets) =
let
ts = either id (map snd) ets
- xs = [mkIdent ("$x" ++ showInt j) | (j, _) <- zip (enumFrom 0) ts]+ xs = [mkIdent ("$x" ++ show j) | (j, _) <- zip [0::Int ..] ts]in (qualIdent mn c, lams xs $ lams fs $ apps (Var (f i)) (map Var xs))
- in zipWith dsConstr (enumFrom 0) cs
+ in zipWith dsConstr [0::Int ..] cs
Newtype _ (Constr c _) -> [ (qualIdent mn c, Lit (LPrim "I")) ]
Type _ _ -> []
Fcn f eqns -> [(f, dsEqns (getSLocIdent f) eqns)]
@@ -49,6 +51,16 @@
Import _ -> []
ForImp ie i _ -> [(i, Lit $ LForImp ie)]
Infix _ _ -> []
+ Class ctx (c, _) _ bs ->
+ let f = mkIdent "$f"
+ meths :: [Ident]
+ meths = [ qualIdent mn i | (BSign i _) <- bs ]
+ supers :: [Ident]
+ supers = [ qualIdent mn $ mkSuperSel c i | i <- [1 .. length ctx] ]
+ xs = [ mkIdent ("$x" ++ show j) | j <- [ 1 .. length ctx + length meths ] ]+ in (qualIdent mn $ mkClassConstructor c, lams xs $ Lam f $ apps (Var f) (map Var xs)) :
+ zipWith (\ i x -> (expectQualified i, Lam f $ App (Var f) (lams xs $ Var x))) (supers ++ meths) xs
+ Instance _ _ _ _ -> []
oneAlt :: Expr -> EAlts
oneAlt e = EAlts [([], e)] []
@@ -70,7 +82,7 @@
Eqn aps _ : _ ->
let
vs = allVarsBind $ BFcn (mkIdent "") eqns
- xs = take (length aps) $ newVars "q" vs
+ 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')
@@ -105,7 +117,7 @@
dsAlt :: Expr -> [EStmt] -> Expr -> Expr
dsAlt _ [] rhs = rhs
dsAlt dflt (SBind p e : ss) rhs = ECase e [(p, EAlts [(ss, rhs)] []), (EVar dummyIdent, oneAlt dflt)]
-dsAlt dflt (SThen (EVar i) : ss) rhs | eqIdent i (mkIdent "Data.Bool.otherwise") = dsAlt dflt ss rhs
+dsAlt dflt (SThen (EVar i) : ss) rhs | isIdent "Data.Bool.otherwise" i = dsAlt dflt ss rhs
dsAlt dflt (SThen e : ss) rhs = EIf e (dsAlt dflt ss rhs) dflt
dsAlt dflt (SLet bs : ss) rhs = ELet bs (dsAlt dflt ss rhs)
@@ -114,12 +126,12 @@
dsBinds ads ret =
let
avs = concatMap allVarsBind ads
- pvs = newVars "p" avs
- mvs = newVars "m" avs
+ 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
+ asccs = stronglyConnComp (<=) gr
loop _ [] = ret
loop vs (AcyclicSCC (i, e) : sccs) =
letE i e $ loop vs sccs
@@ -131,7 +143,8 @@
in loop mvs asccs
letE :: Ident -> Exp -> Exp -> Exp
-letE i e b = App (Lam i b) e
+letE i e b = eLet i e b -- do some minor optimizations
+ --App (Lam i b) e
letRecE :: Ident -> Exp -> Exp -> Exp
letRecE i e b = letE i (App (Lit (LPrim "Y")) (Lam i e)) b
@@ -154,11 +167,23 @@
let (is, es) = unzip ies
n = length is
ev = Var v
- one m i = letE i (mkTupleSel m n ev)
+ one m i = letE i (mkTupleSelE m n ev)
bnds = foldr (.) id $ zipWith one [0..] is
- in letRecE v (bnds $ mkTuple es) $
+ in letRecE v (bnds $ mkTupleE es) $
bnds body
+encodeInteger :: Integer -> Exp
+encodeInteger i | toInteger (minBound::Int) <= i && i < toInteger (maxBound::Int) =
+-- trace ("*** small integer " ++ show i) $+ App (Var (mkIdent "Data.Integer_Type._intToInteger")) (Lit (LInt (_integerToInt i)))
+ | otherwise =
+-- trace ("*** large integer " ++ show i) $+ App (Var (mkIdent "Data.Integer._intListToInteger")) (encodeList (map (Lit . LInt) (_integerToIntList i)))
+
+encodeRational :: Rational -> Exp
+encodeRational r =
+ App (App (Var (mkIdent "Data.Ratio_Type._mkRational")) (encodeInteger (numerator r))) (encodeInteger (denominator r))
+
dsExpr :: Expr -> Exp
dsExpr aexpr =
case aexpr of
@@ -166,6 +191,8 @@
EApp f a -> App (dsExpr f) (dsExpr a)
ELam qs -> dsEqns (getSLocExpr aexpr) qs
ELit _ (LChar c) -> Lit (LInt (ord c))
+ ELit _ (LInteger i) -> encodeInteger i
+ ELit _ (LRat i) -> encodeRational i
ELit _ l -> Lit l
ECase e as -> dsCase (getSLocExpr aexpr) e as
ELet ads e -> dsBinds ads (dsExpr e)
@@ -172,7 +199,7 @@
ETuple es -> Lam (mkIdent "$f") $ foldl App (Var $ mkIdent "$f") $ map dsExpr es
EIf e1 e2 e3 ->
app2 (dsExpr e1) (dsExpr e3) (dsExpr e2)
- EListish (LList es) -> foldr (app2 cCons) cNil $ map dsExpr es
+ EListish (LList es) -> encodeList $ map dsExpr es
EListish (LCompr e astmts) ->
case astmts of
[] -> dsExpr (EListish (LList [e]))
@@ -191,24 +218,24 @@
let
ci = conIdent c
in
- if eqChar (head $ unIdent ci) ',' then
- let
- xs = [mkIdent ("x" ++ showInt i) | i <- enumFromTo 1 (untupleConstr ci) ]- body = mkTuple $ map Var xs
- in foldr Lam body xs
- else
- Var (conIdent c)
+ case getTupleConstr ci of
+ Just n ->
+ let
+ xs = [mkIdent ("x" ++ show i) | i <- [1 .. n] ]+ body = mkTupleE $ map Var xs
+ in foldr Lam body xs
+ Nothing -> Var (conIdent c)
_ -> impossible
-- Use tuple encoding to make a tuple
-mkTuple :: [Exp] -> Exp
-mkTuple = Lam (mkIdent "$f") . foldl App (Var (mkIdent "$f"))
+mkTupleE :: [Exp] -> Exp
+mkTupleE = Lam (mkIdent "$f") . foldl App (Var (mkIdent "$f"))
-- Select component m from an n-tuple
-mkTupleSel :: Int -> Int -> Exp -> Exp
-mkTupleSel m n tup =
+mkTupleSelE :: Int -> Int -> Exp -> Exp
+mkTupleSelE m n tup =
let
- xs = [mkIdent ("x" ++ showInt i) | i <- enumFromTo 1 n ]+ xs = [mkIdent ("x" ++ show i) | i <- [1 .. n] ]in App tup (foldr Lam (Var (xs !! m)) xs)
-- Handle special syntax for lists and tuples
@@ -226,19 +253,17 @@
ELit _ _ -> ap
_ -> impossible
+iNil :: Ident
+iNil = mkIdent $ listPrefix ++ "[]"
+
+iCons :: Ident
+iCons = mkIdent $ listPrefix ++ ":"
+
consCon :: EPat
-consCon =
- let
- n = mkIdent "Data.List.[]"
- c = mkIdent "Data.List.:"
- in ECon $ ConData [(n, 0), (c, 2)] c
+consCon = ECon $ ConData [(iNil, 0), (iCons, 2)] iCons
nilCon :: EPat
-nilCon =
- let
- n = mkIdent "Data.List.[]"
- c = mkIdent "Data.List.:"
- in ECon $ ConData [(n, 0), (c, 2)] n
+nilCon = ECon $ ConData [(iNil, 0), (iCons, 2)] iNil
tupleCon :: SLoc -> Int -> EPat
tupleCon loc n =
@@ -246,9 +271,6 @@
c = tupleConstr loc n
in ECon $ ConData [(c, n)] c
-dummyIdent :: Ident
-dummyIdent = mkIdent "_"
-
lams :: [Ident] -> Exp -> Exp
lams xs e = foldr Lam e xs
@@ -256,10 +278,10 @@
apps f = foldl App f
newVars :: String -> [Ident] -> [Ident]
-newVars s is = deleteAllsBy eqIdent [ mkIdent (s ++ showInt i) | i <- enumFrom 1 ] is
+newVars s is = deleteAllsBy (==) [ mkIdent (s ++ show i) | i <- [1::Int ..] ] is
newVar :: [Ident] -> Ident
-newVar = head . newVars "q"
+newVar = head . newVars "$q"
showLDefs :: [LDef] -> String
showLDefs = unlines . map showLDef
@@ -267,7 +289,7 @@
showLDef :: LDef -> String
showLDef a =
case a of
- (i, e) -> showIdent i ++ " = " ++ showExp e
+ (i, e) -> showIdent i ++ " = " ++ show e
----------------
@@ -286,29 +308,29 @@
type Matrix = [Arm]
--showArm :: Arm -> String
---showArm (ps, _, b) = showList showExpr ps ++ "," ++ showBool b
+--showArm (ps, _, b) = showListS showExpr ps ++ "," ++ show b
newIdents :: Int -> M [Ident]
-newIdents n = S.do
+newIdents n = do
is <- get
put (drop n is)
- S.return (take n is)
+ return (take n is)
newIdent :: M Ident
-newIdent = S.do
+newIdent = do
is <- get
put (tail is)
- S.return (head is)
+ return (head is)
runS :: SLoc -> [Ident] -> [Exp] -> Matrix -> Exp
runS loc used ss mtrx =
let
- supply = newVars "x" used
+ supply = newVars "$x" used
ds xs aes =
case aes of
[] -> dsMatrix (eMatchErr loc) (reverse xs) mtrx
- e:es -> letBind (S.return e) $ \ x -> ds (x:xs) es
- in S.evalState (ds [] ss) supply
+ e:es -> letBind (return e) $ \ x -> ds (x:xs) es
+ in evalState (ds [] ss) supply
data SPat = SPat Con [Ident] -- simple pattern
--Xderiving(Show, Eq)
@@ -323,11 +345,11 @@
Exp -> [Exp] -> Matrix -> M Exp
dsMatrix dflt iis aarms =
if null aarms then
- S.return dflt
+ return dflt
else
case iis of
- [] -> let { (_, f, _) : _ = aarms } in S.return $ f dflt- i:is -> S.do
+ [] -> let { (_, f, _) : _ = aarms } in return $ f dflt+ i:is -> do
let
(arms, darms, rarms) = splitArms aarms
ndarms = map (\ (EVar x : ps, ed, g) -> (ps, substAlpha x i . ed, g) ) darms
@@ -335,13 +357,13 @@
letBind (dsMatrix dflt iis rarms) $ \ drest ->
letBind (dsMatrix drest is ndarms) $ \ ndflt ->
if null arms then
- S.return ndflt
- else S.do
+ return ndflt
+ else do
let
idOf (p:_, _, _) = pConOf p
idOf _ = impossible
- grps = groupEq (on eqCon idOf) arms
- oneGroup grp = S.do
+ grps = groupEq (on (==) idOf) arms
+ oneGroup grp = do
let
(pat:_, _, _) : _ = grp
con = pConOf pat
@@ -355,26 +377,26 @@
_ -> (pArgs p ++ ps, e, g)
_ -> impossible
cexp <- dsMatrix ndflt (map Var xs ++ is) (map one grp)
- S.return (SPat con xs, cexp)
+ return (SPat con xs, cexp)
-- traceM $ "grps " ++ show grps
- narms <- S.mapM oneGroup grps
- S.return $ mkCase i narms ndflt
+ narms <- mapM oneGroup grps
+ return $ mkCase i narms ndflt
eMatchErr :: SLoc -> Exp
eMatchErr (SLoc fn l c) =
- App (App (App (Var (mkIdent "Prelude._noMatch")) (Lit (LStr fn))) (Lit (LInt l))) (Lit (LInt c))
+ App (App (App (Lit (LPrim "noMatch")) (Lit (LStr fn))) (Lit (LInt l))) (Lit (LInt c))
-- 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
+letBind me f = do
e <- me
if cheap e then
f e
- else S.do
+ else do
x <- newIdent
r <- f (Var x)
- S.return $ eLet x e r
+ return $ eLet x e r
cheap :: Exp -> Bool
cheap ae =
@@ -383,16 +405,14 @@
Lit _ -> True
_ -> False
--- Could use Prim "==", but that misses out some optimizations
eEqInt :: Exp
-eEqInt = Var $ mkIdent "Data.Int.=="
+eEqInt = Lit (LPrim "==")
eEqChar :: Exp
-eEqChar = Var $ mkIdent "Data.Char.eqChar"
+eEqChar = Lit (LPrim "==")
eEqStr :: Exp
-eEqStr = --Var $ mkIdent "Text.String.eqString"
- Lit (LPrim "equal")
+eEqStr = Lit (LPrim "equal")
mkCase :: Exp -> [(SPat, Exp)] -> Exp -> Exp
mkCase var pes dflt =
@@ -414,7 +434,7 @@
arm ck =
let
(c, k) = ck
- (vs, rhs) = head $ [ (xs, e) | (SPat (ConData _ i) xs, e) <- pes, eqIdent c i ] ++
+ (vs, rhs) = head $ [ (xs, e) | (SPat (ConData _ i) xs, e) <- pes, c == i ] ++
[ (replicate k dummyIdent, dflt) ]
in (SPat (ConData cs c) vs, rhs)
in eCase var (map arm cs)
@@ -422,8 +442,8 @@
eCase :: Exp -> [(SPat, Exp)] -> Exp
eCase e as =
- --trace ("eCase " ++ showExp e ++ "\n" ++- -- unlines [ unwords (conIdent c : xs) ++ " -> " ++ showExp r | (SPat c xs, r) <- as ]) $
+-- trace ("eCase " ++ show e ++ "\n" +++-- unlines [ unwords (map showIdent (conIdent c : xs)) ++ " -> " ++ show r | (SPat c xs, r) <- as ]) $
apps e [lams xs r | (SPat _ xs, r) <- as ]
-- Split the matrix into segments so each first column has initially patterns -- followed by variables, followed by the rest.
@@ -444,7 +464,7 @@
-- Change from x to y inside e.
substAlpha :: Ident -> Exp -> Exp -> Exp
substAlpha x y e =
- if eqIdent x dummyIdent then
+ if x == dummyIdent then
e
else
substExp x y e
@@ -451,13 +471,13 @@
eLet :: Ident -> Exp -> Exp -> Exp
eLet i e b =
- if eqIdent i dummyIdent then
+ if i == dummyIdent then
b
else
case b of
- Var j | eqIdent i j -> e
+ Var j | i == j -> e
_ ->
- case filter (eqIdent i) (freeVars b) of
+ case filter (== i) (freeVars b) of
[] -> b -- no occurences, no need to bind
[_] -> substExp i e b -- single occurrence, substitute XXX could be worse if under lambda
_ -> App (Lam i b) e -- just use a beta redex
@@ -494,8 +514,36 @@
checkDup :: [LDef] -> [LDef]
checkDup ds =
- case getDups eqIdent (filter (not . eqIdent dummyIdent) $ map fst ds) of
+ case getDups (==) (filter (/= dummyIdent) $ map fst ds) of
[] -> ds
- (i1:i2:_) : _ ->
- errorMessage (getSLocIdent i1) $ "Duplicate " ++ showIdent i1 ++ " " ++ showSLoc (getSLocIdent i2)
+ (i1:_i2:_) : _ ->
+ errorMessage (getSLocIdent i1) $ "duplicate definition " ++ showIdent i1
+ -- XXX mysteriously the location for i2 is the same as i1
+ -- ++ ", also at " ++ showSLoc (getSLocIdent i2)
_ -> error "checkDup"
+
+-- Make recursive definitions lazier.
+-- The idea is that we have
+-- f x y = ... (f x) ...
+-- we turn this into
+-- f x = letrec f' y = ... f' ... in f'
+-- thus avoiding the extra argument passing.
+-- XXX should generalize for an arbitrary length prefix of variables.
+-- This gives a small speedup with overloading.
+lazier :: LDef -> LDef
+lazier def@(fcn, Lam x (Lam y body)) =
+ let fcn' = addIdentSuffix fcn "@"
+ vfcn' = Var fcn'
+ repl :: Exp -> State Bool Exp
+ repl (Lam i e) = Lam i <$> repl e
+ repl (App (Var af) (Var ax)) | af == fcn && ax == x = do
+ put True
+ return vfcn'
+ repl (App f a) = App <$> repl f <*> repl a
+ repl e@(Var _) = return e
+ repl e@(Lit _) = return e
+ in case runState (repl body) False of
+ (_, False) -> def
+ (e', True) -> (fcn, Lam x $ letRecE fcn' (Lam y e') vfcn')
+
+lazier def = def
--- a/src/MicroHs/Exp.hs
+++ b/src/MicroHs/Exp.hs
@@ -6,21 +6,23 @@
compileOpt,
-- compileOptX,
substExp,
- Exp(..), showExp, eqExp, toStringP,
+ Exp(..), toStringP,
PrimOp,
encodeString,
app2, cCons, cNil, cFlip,
allVarsExp, freeVars,
+ encodeList,
) where
-import Prelude
+import Prelude --Xhiding((<>))
import Data.Char
import Data.List
import MicroHs.Ident
-import MicroHs.Expr(Lit(..), showLit, eqLit)
+import MicroHs.Expr(Lit(..), showLit)
+import Text.PrettyPrint.HughesPJ
--Ximport Control.DeepSeq
--Ximport Compat
--Yimport Primitives(NFData(..))
---import Debug.Trace
+import Debug.Trace
type PrimOp = String
@@ -50,16 +52,18 @@
| App Exp Exp
| Lam Ident Exp
| Lit Lit
- --Xderiving (Show, Eq)
+--pattern Let :: Ident -> Exp -> Exp -> Exp
+--pattern Let i e b = App (Lam i b) e
+
--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
+instance Eq Exp where
+ (==) (Var i1) (Var i2) = i1 == i2
+ (==) (App f1 a1) (App f2 a2) = f1 == f2 && a1 == a2
+ (==) (Lam i1 e1) (Lam i2 e2) = i1 == i2 && e1 == e2
+ (==) (Lit l1) (Lit l2) = l1 == l2
+ (==) _ _ = False
data MaybeApp = NotApp | IsApp Exp Exp
@@ -69,16 +73,10 @@
App f a -> IsApp f a
_ -> NotApp
-getVar :: Exp -> Maybe Ident
-getVar ae =
- case ae of
- Var v -> Just v
- _ -> Nothing
-
isPrim :: String -> Exp -> Bool
isPrim s ae =
case ae of
- Lit (LPrim ss) -> eqString s ss
+ Lit (LPrim ss) -> s == ss
_ -> False
isK :: Exp -> Bool
@@ -129,32 +127,6 @@
--cR :: Exp
--cR = Lit (LPrim "R")
-{--eqExp :: Exp -> Exp -> Bool
-eqExp ae1 ae2 =
- case ae1 of
- Var i1 ->
- case ae2 of
- Var i2 -> eqIdent i1 i2
- _ -> False
- App e11 e12 ->
- case ae2 of
- App e21 e22 -> eqExp e11 e21 && eqExp e12 e22
- _ -> False
- Lam i1 e1 ->
- case ae2 of
- Lam i2 e2 -> eqIdent i1 i2 && eqExp e1 e2
- _ -> False
- Int i1 ->
- case ae2 of
- Int i2 -> i1 == i2
- _ -> False
- Prim p1 ->
- case ae2 of
- Prim p2 -> eqString p1 p2
- _ -> False
--}
-
-- Avoid quadratic concatenation by using difference lists,
-- turning concatenation into function composition.
toStringP :: Exp -> (String -> String)
@@ -167,6 +139,8 @@
(quoteString s ++)
else
toStringP (encodeString s)
+ Lit (LInteger _) -> undefined
+ Lit (LRat _) -> undefined
Lit l -> (showLit l ++)
Lam x e -> (("(\\" ++ showIdent x ++ " ") ++) . toStringP e . (")" ++) App f a -> ("(" ++) . toStringP f . (" " ++) . toStringP a . (")" ++)@@ -174,17 +148,19 @@
quoteString :: String -> String
quoteString s =
let
- char c =
- if eqChar c '"' || eqChar c '\\' || ltChar c ' ' || ltChar '~' c then
- '\\' : showInt (ord c) ++ ['&']
+ achar c =
+ if c == '"' || c == '\\' || c < ' ' || c > '~' then
+ '\\' : show (ord c) ++ ['&']
else
[c]
- in '"' : concatMap char s ++ ['"']
+ in '"' : concatMap achar s ++ ['"']
encodeString :: String -> Exp
-encodeString [] = cNil
-encodeString (c:cs) = app2 cCons (Lit (LInt (ord c))) (encodeString cs)
+encodeString = encodeList . map (Lit . LInt . ord)
+encodeList :: [Exp] -> Exp
+encodeList = foldr (app2 cCons) cNil
+
compileOpt :: Exp -> Exp
compileOpt = improveT . compileExp
@@ -198,7 +174,7 @@
abstract :: Ident -> Exp -> Exp
abstract x ae =
case ae of
- Var y -> if eqIdent x y then cId else cK (Var y)
+ Var y -> if x == y then cId else cK (Var y)
App f a -> cS (abstract x f) (abstract x a)
Lam y e -> abstract x $ abstract y e
Lit _ -> cK ae
@@ -287,16 +263,8 @@
r
cC2 :: Exp -> Exp -> Exp
-cC2 a1 a2 =
- let
- r = app2 cFlip a1 a2
- in
- case getVar a1 of
- Nothing -> r
- Just op ->
- case lookupBy eqIdent op flipOps of
- Just oq -> App (Var oq) a2
- Nothing -> r
+cC2 a1 a2 = app2 cFlip a1 a2
+
{-cC (App (App CB e1) e2) e3 = cCC e1 e2 e3 -- C (B e1 e2) e3 = C' e1 e2 e3
cC (Var op) e2 | Just op' <- lookup op flipOps = App (Var op') e2 -- C op e = flip-op e
@@ -359,6 +327,7 @@
cCC :: Exp -> Exp -> Exp -> Exp
cCC e1 e2 e3 = app3 (Lit (LPrim "C'")) e1 e2 e3
+{--- This is a hack, it assumes things about the Prelude
flipOps :: [(Ident, Ident)]
flipOps =
@@ -372,6 +341,7 @@
,(mkIdent "Data.Int.>", mkIdent "Data.Int.<")
,(mkIdent "Data.Int.>=", mkIdent "Data.Int.<=")
]
+-}
improveT :: Exp -> Exp
improveT ae =
@@ -434,26 +404,30 @@
improveT e = e
-}
-showExp :: Exp -> String
-showExp ae =
+instance Show Exp where
+ show = render . ppExp
+
+ppExp :: Exp -> Doc
+ppExp ae =
case ae of
- Var i -> showIdent i
- App f a -> "(" ++ showExp f ++ " " ++ showExp a ++ ")"- Lam i e -> "(\\" ++ showIdent i ++ ". " ++ showExp e ++ ")"
- Lit l -> showLit l
+-- Let i e b -> sep [ text "let" <+> ppIdent i <+> text "=" <+> ppExp e, text "in" <+> ppExp b ]
+ Var i -> ppIdent i
+ App f a -> parens $ ppExp f <+> ppExp a
+ Lam i e -> parens $ text "\\" <> ppIdent i <> text "." <+> ppExp e
+ Lit l -> text (showLit l)
substExp :: Ident -> Exp -> Exp -> Exp
substExp si se ae =
case ae of
- Var i -> if eqIdent i si then se else ae
+ Var i -> if i == si then se else ae
App f a -> App (substExp si se f) (substExp si se a)
- Lam i e -> if eqIdent si i then
+ Lam i e -> if si == i then
ae
- else if elemBy eqIdent i (freeVars se) then
+ else if elem i (freeVars se) then
let
fe = allVarsExp e
ase = allVarsExp se
- j = 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::Int), let { v = mkIdent ("a" ++ show n) }, not (elem v ase), not (elem v fe) ]in
--trace ("substExp " ++ unwords [si, i, j]) $Lam j (substExp si se (substExp i (Var j) e))
@@ -466,7 +440,7 @@
case ae of
Var i -> [i]
App f a -> freeVars f ++ freeVars a
- Lam i e -> deleteAllBy eqIdent i (freeVars e)
+ Lam i e -> deleteAllBy (==) i (freeVars e)
Lit _ -> []
allVarsExp :: Exp -> [Ident]
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -5,39 +5,43 @@
ImportSpec(..),
ImportItem(..),
EDef(..), showEDefs,
- Expr(..), eLam, showExpr,
+ Expr(..), eLam, eEqns, showExpr, eqExpr,
Listish(..),
- Lit(..), showLit, eqLit,
- EBind(..), showEBind,
+ Lit(..), showLit,
+ EBind(..), showEBind, showEBinds,
Eqn(..),
EStmt(..),
EAlts(..),
EAlt,
ECaseArm,
- EType, showEType,
+ FunDep,
+ EType, showEType, eqEType,
+ EConstraint,
EPat, patVars, isPVar, isPConApp,
- EKind, kType,
+ EKind, kType, kConstraint,
IdKind(..), idKindIdent,
LHS,
Constr(..), ConstrField,
ConTyInfo,
- Con(..), conIdent, conArity, eqCon, getSLocCon,
- tupleConstr, untupleConstr, isTupleConstr,
+ Con(..), conIdent, conArity, getSLocCon,
+ tupleConstr, getTupleConstr,
+ mkTupleSel,
subst,
- allVarsExpr, allVarsBind,
+ allVarsExpr, allVarsBind, allVarsEqn,
getSLocExpr, setSLocExpr,
+ getSLocEqns,
errorMessage,
- Assoc(..), eqAssoc, Fixity
+ Assoc(..), Fixity,
+ getBindsVars,
) where
-import Prelude --Xhiding (Monad(..), Applicative(..), MonadFail(..), Functor(..), (<$>), showString, showChar, showList, (<>))
+import Prelude --Xhiding (Monad(..), Applicative(..), MonadFail(..), Functor(..), (<$>), (<>))
import Data.Maybe
import MicroHs.Ident
-import qualified Data.Double as D
+import Text.PrettyPrint.HughesPJ
--Ximport Compat
--Ximport GHC.Stack
--Ximport Control.DeepSeq
--Yimport Primitives(NFData(..))
-import MicroHs.Pretty
type IdentModule = Ident
@@ -62,6 +66,8 @@
| Import ImportSpec
| ForImp String Ident EType
| Infix Fixity [Ident]
+ | Class [EConstraint] LHS [FunDep] [EBind] -- XXX will probable need initial forall with FD
+ | Instance [IdKind] [EConstraint] EConstraint [EBind] -- no deriving yet
--Xderiving (Show, Eq)
data ImportSpec = ImportSpec Bool Ident (Maybe Ident) (Maybe (Bool, [ImportItem])) -- first Bool indicates 'qualified', second 'hiding'
@@ -96,15 +102,19 @@
| EForall [IdKind] Expr -- only in types
--Xderiving (Show, Eq)
+type FunDep = ([Ident], [Ident])
+
eLam :: [EPat] -> Expr -> Expr
-eLam ps e = ELam [Eqn ps (EAlts [([], e)] [])]
+eLam ps e = ELam $ eEqns ps e
+eEqns :: [EPat] -> Expr -> [Eqn]
+eEqns ps e = [Eqn ps (EAlts [([], e)] [])]
+
data Con
= ConData ConTyInfo Ident
| ConNew Ident
| ConLit Lit
--- | ConTup Int
- --Xderiving(Show, Eq)
+ --Xderiving(Show)
data Listish
= LList [Expr]
@@ -122,33 +132,38 @@
conIdent _ = error "conIdent"
conArity :: Con -> Int
-conArity (ConData cs i) = fromMaybe (error "conArity") $ lookupBy eqIdent i cs
+conArity (ConData cs i) = fromMaybe (error "conArity") $ lookup i cs
conArity (ConNew _) = 1
conArity (ConLit _) = 0
-eqCon :: Con -> Con -> Bool
-eqCon (ConData _ i) (ConData _ j) = eqIdent i j
-eqCon (ConNew i) (ConNew j) = eqIdent i j
-eqCon (ConLit l) (ConLit k) = eqLit l k
-eqCon _ _ = False
+instance Eq Con where
+ (==) (ConData _ i) (ConData _ j) = i == j
+ (==) (ConNew i) (ConNew j) = i == j
+ (==) (ConLit l) (ConLit k) = l == k
+ (==) _ _ = False
data Lit
= LInt Int
- | LDouble D.Double
+ | LInteger Integer
+ | LDouble Double
+ | LRat Rational
| LChar Char
| LStr String
| LPrim String
| LForImp String
- --Xderiving (Show, Eq)
---Winstance NFData Lit where rnf (LInt i) = rnf i; rnf (LDouble d) = rnf d; rnf (LChar c) = rnf c; rnf (LStr s) = rnf s; rnf (LPrim s) = rnf s; rnf (LForImp s) = rnf s
+ --Xderiving (Show)
+--Winstance NFData Lit where rnf (LInt i) = rnf i; rnf (LInteger i) = rnf i; rnf (LDouble d) = rnf d; rnf (LRat r) = rnf r; 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
-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
+instance Eq Lit where
+ (==) (LInt x) (LInt y) = x == y
+ (==) (LInteger x) (LInteger y) = x == y
+ (==) (LDouble x) (LDouble y) = x == y
+ (==) (LRat x) (LRat y) = x == y
+ (==) (LChar x) (LChar y) = x == y
+ (==) (LStr x) (LStr y) = x == y
+ (==) (LPrim x) (LPrim y) = x == y
+ (==) (LForImp x) (LForImp y) = x == y
+ (==) _ _ = False
type ECaseArm = (EPat, EAlts)
@@ -196,6 +211,8 @@
-- * before desugaring: EApp, EVar, ETuple, EList
type EType = Expr
+type EConstraint = EType
+
data IdKind = IdKind Ident EKind
--Xderiving (Show, Eq)
@@ -207,25 +224,34 @@
kType :: EKind
kType = EVar (Ident noSLoc "Primitives.Type")
+kConstraint :: EKind
+kConstraint = EVar (Ident noSLoc "Primitives.Constraint")
+
tupleConstr :: SLoc -> Int -> Ident
tupleConstr loc n = mkIdentSLoc loc (replicate (n - 1) ',')
-untupleConstr :: Ident -> Int
-untupleConstr i = length (unIdent i) + 1
+-- Check if it is a suple constructor
+getTupleConstr :: Ident -> Maybe Int
+getTupleConstr i =
+ case unIdent i of
+ ',':xs -> Just (length xs + 2) -- "," is 2-tuple
+ _ -> Nothing
-isTupleConstr :: Int -> Ident -> Bool
-isTupleConstr n i = eqChar (head (unIdent i)) ',' && untupleConstr i == n
+-- Create a tuple selector, component i (0 based) of n
+mkTupleSel :: Int -> Int -> Expr
+mkTupleSel i n = eLam [ETuple [ EVar $ if k == i then x else dummyIdent | k <- [0 .. n - 1] ]] (EVar x)
+ where x = mkIdent "$x"
---------------------------------
data Assoc = AssocLeft | AssocRight | AssocNone
- --Xderiving (Eq, Show)
+ --Xderiving (Show)
-eqAssoc :: Assoc -> Assoc -> Bool
-eqAssoc AssocLeft AssocLeft = True
-eqAssoc AssocRight AssocRight = True
-eqAssoc AssocNone AssocNone = True
-eqAssoc _ _ = False
+instance Eq Assoc where
+ AssocLeft == AssocLeft = True
+ AssocRight == AssocRight = True
+ AssocNone == AssocNone = True
+ _ == _ = False
type Fixity = (Assoc, Int)
@@ -233,19 +259,39 @@
-- Enough to handle subsitution in types
subst :: [(Ident, Expr)] -> Expr -> Expr
+subst [] = id
subst s =
let
sub ae =
case ae of
- EVar i -> fromMaybe ae $ lookupBy eqIdent i s
+ EVar i -> fromMaybe ae $ lookup i s
EApp f a -> EApp (sub f) (sub a)
ESign e t -> ESign (sub e) t
EUVar _ -> ae
+ EForall iks t -> EForall iks $ subst [ x | x@(i, _) <- s, not (elem i is) ] t
+ where is = map idKindIdent iks
_ -> error "subst unimplemented"
in sub
---------------------------------
+-- XXX needs more?
+eqEType :: EType -> EType -> Bool
+eqEType = eqExpr
+
+-- Very partial implementation of Expr equality.
+-- It is only used to compare instances, so this suffices.
+eqExpr :: --XHasCallStack =>
+ Expr -> Expr -> Bool
+eqExpr (EVar i) (EVar i') = i == i'
+eqExpr (EVar _) (EApp _ _) = False
+eqExpr (EApp f a) (EApp f' a') = eqExpr f f' && eqExpr a a'
+eqExpr (EApp _ _) (EVar _) = False
+eqExpr _ _ = False -- XXX good enough for instances
+--eqExpr e1 e2 = error $ "eqExpr: unimplemented " ++ showExpr e1 ++ " == " ++ showExpr e2
+
+---------------------------------
+
allVarsBind :: EBind -> [Ident]
allVarsBind abind =
case abind of
@@ -314,6 +360,9 @@
getSLocExpr :: Expr -> SLoc
getSLocExpr e = head $ filter (not . isNoSLoc) (map getSLocIdent (allVarsExpr e)) ++ [noSLoc]
+getSLocEqns :: [Eqn] -> SLoc
+getSLocEqns eqns = getSLocExpr $ ELet [BFcn dummyIdent eqns] (EVar dummyIdent)
+
getSLocCon :: Con -> SLoc
getSLocCon (ConData _ i) = getSLocIdent i
getSLocCon (ConNew i) = getSLocIdent i
@@ -336,24 +385,6 @@
----------------
-{--showEModule :: EModule -> String
-showEModule am =
- case am of
- EModule i es ds -> "module " ++ i ++ "(\n" ++
- unlines (intersperse "," (map showExportItem es)) ++
- "\n) where\n" ++
- showEDefs ds
-
-showExportItem :: ExportItem -> String
-showExportItem ae =
- case ae of
- ExpModule i -> "module " ++ i
- ExpTypeCon i -> i ++ "(..)"
- ExpType i -> i
- ExpValue i -> i
--}
-
showExpr :: Expr -> String
showExpr = render . ppExpr
@@ -363,6 +394,9 @@
showEBind :: EBind -> String
showEBind = render . ppEBind
+showEBinds :: [EBind] -> String
+showEBinds = render . vcat . map ppEBind
+
showEType :: EType -> String
showEType = render . ppEType
@@ -386,10 +420,19 @@
case mis of
Nothing -> empty
Just (h, is) -> text (if h then " hiding" else "") <> parens (hsep $ punctuate (text ", ") (map ppImportItem is))
- ForImp ie i t -> text ("foreign import ccall " ++ showString ie) <+> ppIdent i <+> text "::" <+> ppEType t- Infix (a, p) is -> text ("infix" ++ f a) <+> text (showInt p) <+> hsep (punctuate (text ", ") (map ppIdent is))+ ForImp ie i t -> text ("foreign import ccall " ++ show ie) <+> ppIdent i <+> text "::" <+> ppEType t+ Infix (a, p) is -> text ("infix" ++ f a) <+> text (show p) <+> hsep (punctuate (text ", ") (map ppIdent is))where f AssocLeft = "l"; f AssocRight = "r"; f AssocNone = ""
+ Class sup lhs fds bs -> ppWhere (text "class" <+> ctx sup <+> ppLHS lhs <+> ppFunDeps fds) bs
+ Instance vs ct ty bs -> ppWhere (text "instance" <+> ppForall vs <+> ctx ct <+> ppEType ty) bs
+ where ctx [] = empty
+ ctx ts = ppEType (ETuple ts) <+> text "=>"
+ppFunDeps :: [FunDep] -> Doc
+ppFunDeps [] = empty
+ppFunDeps fds =
+ text "|" <+> hsep (punctuate (text ",") (map (\ (is, os) -> hsep (map ppIdent is) <+> text "-" <+> hsep (map ppIdent os)) fds))
+
ppEqns :: Doc -> Doc -> [Eqn] -> Doc
ppEqns name sepr = vcat . map (\ (Eqn ps alts) -> sep [name <+> hsep (map ppEPat ps), ppAlts sepr alts])
@@ -405,14 +448,17 @@
ppIdKind (IdKind i k) = parens $ ppIdent i <> text "::" <> ppEKind k
ppEDefs :: [EDef] -> Doc
-ppEDefs ds = vcat (map ppEDef ds)
+ppEDefs ds = vcat (map pp ds)
+ where pp d@(Sign _ _) = ppEDef d
+ pp d@(Import _) = ppEDef d
+ pp d = ppEDef d $+$ text ""
ppAlts :: Doc -> EAlts -> Doc
-ppAlts asep (EAlts alts bs) = ppAltsL asep alts <> ppWhere bs
+ppAlts asep (EAlts alts bs) = ppWhere (ppAltsL asep alts) bs
-ppWhere :: [EBind] -> Doc
-ppWhere [] = empty
-ppWhere bs = text "where" $+$ nest 2 (vcat (map ppEBind bs))
+ppWhere :: Doc -> [EBind] -> Doc
+ppWhere d [] = d
+ppWhere d bs = (d <+> text "where") $+$ nest 2 (vcat (map ppEBind bs))
ppAltsL :: Doc -> [EAlt] -> Doc
ppAltsL asep [([], e)] = text "" <+> asep <+> ppExpr e
@@ -424,7 +470,10 @@
ppExpr :: Expr -> Doc
ppExpr ae =
case ae of
- EVar v -> ppIdent v
+ EVar i | isOperChar cop -> parens (text op)
+ | otherwise -> text op
+ where op = unIdent (unQualIdent i)
+ cop = head op
EApp _ _ -> ppApp [] ae
EOper e ies -> ppExpr (foldl (\ e1 (i, e2) -> EApp (EApp (EVar i) e1) e2) e ies)
ELam qs -> parens $ text "\\" <> ppEqns empty (text "->") qs
@@ -440,17 +489,24 @@
EListish l -> ppListish l
ESign e t -> ppExpr e <+> text "::" <+> ppEType t
EAt i e -> ppIdent i <> text "@" <> ppExpr e
- EUVar i -> text ("a" ++ showInt i)+ EUVar i -> text ("a" ++ show i)ECon c -> ppCon c
- EForall iks e -> text "forall" <+> hsep (map ppIdKind iks) <+> text "." <+> ppEType e
- where
- ppApp as (EApp f a) = ppApp (a:as) f
- ppApp as (EVar i) | eqString op "->", [a, b] <- as = parens $ ppExpr a <+> text "->" <+> ppExpr b
- | eqChar (head op) ',' = ppExpr (ETuple as)
- | eqString op "[]", length as == 1 = ppExpr (EListish (LList as))
- where op = unQualString (unIdent i)
- ppApp as f = parens $ hsep (map ppExpr (f:as))
+ EForall iks e -> ppForall iks <+> ppEType e
+-- where
+ppApp :: [Expr] -> Expr -> Doc
+ppApp as (EApp f a) = ppApp (a:as) f
+ppApp as (EVar i) | isOperChar cop, [a, b] <- as = parens $ ppExpr a <+> text op <+> ppExpr b
+ | isOperChar cop, [a] <- as = parens $ ppExpr a <+> text op
+ | cop == ',' = ppExpr (ETuple as)
+ | op == "[]", length as == 1 = ppExpr (EListish (LList as))
+ where op = unIdent (unQualIdent i)
+ cop = head op
+ppApp as f = parens $ hsep (map ppExpr (f:as))
+ppForall :: [IdKind] -> Doc
+ppForall [] = empty
+ppForall iks = text "forall" <+> hsep (map ppIdKind iks) <+> text "."
+
ppListish :: Listish -> Doc
ppListish _ = text "<<Listish>>"
@@ -469,12 +525,14 @@
showLit :: Lit -> String
showLit l =
case l of
- LInt i -> '#' : showInt i
- LDouble d -> '%' : D.showDouble d
- LChar c -> showChar c
- LStr s -> showString s
- LPrim s -> s
- LForImp s -> '^' : s
+ LInt i -> '#' : show i
+ LInteger i -> '#' : '#' : show i
+ LDouble d -> '&' : show d
+ LRat r -> '%' : show r
+ LChar c -> xshowChar c
+ LStr s -> show s
+ LPrim s -> s
+ LForImp s -> '^' : s
ppEStmt :: EStmt -> Doc
ppEStmt as =
@@ -506,3 +564,12 @@
ppList :: forall a . (a -> Doc) -> [a] -> Doc
ppList pp xs = brackets $ hsep $ punctuate (text ",") (map pp xs)
+getBindVars :: EBind -> [Ident]
+getBindVars abind =
+ case abind of
+ BFcn i _ -> [i]
+ BPat p _ -> patVars p
+ BSign _ _ -> []
+
+getBindsVars :: [EBind] -> [Ident]
+getBindsVars = concatMap getBindVars
--- a/src/MicroHs/Ident.hs
+++ b/src/MicroHs/Ident.hs
@@ -3,23 +3,26 @@
module MicroHs.Ident(
Line, Col, Loc,
Ident(..),
- mkIdent, mkIdentLoc, unIdent, eqIdent, leIdent, qualIdent, showIdent, getSLocIdent, setSLocIdent,
+ mkIdent, mkIdentLoc, unIdent, isIdent,
+ qualIdent, showIdent, getSLocIdent, setSLocIdent,
ppIdent,
mkIdentSLoc,
isLower_, isIdentChar, isOperChar, isConIdent,
- isDummyIdent,
+ dummyIdent, isDummyIdent,
unQualIdent,
unQualString,
+ addIdentSuffix,
SLoc(..), noSLoc, isNoSLoc,
showSLoc,
- compareIdent,
+ expectQualified,
) where
-import Prelude --Xhiding(showString)
+import Data.Eq
+import Prelude
+import Data.Char
+import Text.PrettyPrint.HughesPJ
--Ximport Control.DeepSeq
--Yimport Primitives(NFData(..))
-import Data.Char
---Ximport Compat
-import MicroHs.Pretty
+--Ximport GHC.Stack
type Line = Int
type Col = Int
@@ -29,14 +32,24 @@
--Xderiving (Show, Eq)
data Ident = Ident SLoc String
- --Xderiving (Show, Eq)
+ --Xderiving (Show)
--Winstance NFData Ident where rnf (Ident _ s) = rnf s
+instance Eq Ident where
+ Ident _ i == Ident _ j = i == j
+
+instance Ord Ident where
+ compare (Ident _ i) (Ident _ j) = compare i j
+ Ident _ i < Ident _ j = i < j
+ Ident _ i <= Ident _ j = i <= j
+ Ident _ i > Ident _ j = i > j
+ Ident _ i >= Ident _ j = i >= j
+
noSLoc :: SLoc
noSLoc = SLoc "" 0 0
isNoSLoc :: SLoc -> Bool
-isNoSLoc (SLoc "" 0 0) = True
+isNoSLoc (SLoc _ 0 0) = True
isNoSLoc _ = False
mkIdent :: String -> Ident
@@ -63,41 +76,60 @@
ppIdent :: Ident -> Doc
ppIdent (Ident _ i) = text i
-eqIdent :: Ident -> Ident -> Bool
-eqIdent (Ident _ i) (Ident _ j) = eqString i j
+isIdent :: String -> Ident -> Bool
+isIdent s (Ident _ i) = s == i
-leIdent :: Ident -> Ident -> Bool
-leIdent (Ident _ i) (Ident _ j) = leString i j
+qualIdent :: --XHasCallStack =>
+ Ident -> Ident -> Ident
+--XqualIdent _ (Ident _ i) | isQual i = error $ "already qualified " ++ i
+qualIdent (Ident _ qi) (Ident loc i) = Ident loc (qi ++ "." ++ i)
-qualIdent :: Ident -> Ident -> Ident
-qualIdent (Ident loc qi) (Ident _ i) = Ident loc (qi ++ "." ++ i)
+expectQualified :: --XHasCallStack =>
+ Ident -> Ident
+--XexpectQualified (Ident _ s) | not (isQual s) = error $ "not qualified " ++ s
+expectQualified i = i
+--XisQual :: String -> Bool
+--XisQual (c:'.':_:_) | isAlphaNum c = True
+--XisQual (_:cs) = isQual cs
+--XisQual "" = False
+
+addIdentSuffix :: Ident -> String -> Ident
+addIdentSuffix (Ident loc i) s = Ident loc (i ++ s)
+
+unQualString :: --XHasCallStack =>
+ String -> String
+unQualString [] = ""
+unQualString s@(c:_) =
+ if isIdentChar c then
+ case dropWhile (/= '.') s of
+ "" -> s
+ '.':r -> unQualString r
+ _ -> undefined -- This cannot happen, but GHC doesn't know that
+ else
+ s
+
unQualIdent :: Ident -> Ident
unQualIdent (Ident l s) = Ident l (unQualString s)
-unQualString :: String -> String
-unQualString s =
- case span isIdentChar s of
- ("", r) -> r- (r, "") -> r -- XXX bug! swapping with next line goes wrong
- (_, '.':r) -> unQualString r
- x -> error $ "unQualString: " ++ showPair showString (showPair showString showString) (s, x)
-
isConIdent :: Ident -> Bool
isConIdent (Ident _ i) =
let
c = head i
- in isUpper c || eqChar c ':' || eqChar c ',' || eqString i "[]" || eqString i "()"
+ in isUpper c || c == ':' || c == ',' || i == "[]" || i == "()"
isOperChar :: Char -> Bool
-isOperChar c = elemBy eqChar c "@\\=+-:<>.!#$%^&*/|~?"
+isOperChar c = elem c "@\\=+-:<>.!#$%^&*/|~?"
isIdentChar :: Char -> Bool
-isIdentChar c = isLower_ c || isUpper c || isDigit c || eqChar c '\''
+isIdentChar c = isLower_ c || isUpper c || isDigit c || c == '\''
isLower_ :: Char -> Bool
-isLower_ c = isLower c || eqChar c '_'
+isLower_ c = isLower c || c == '_'
+dummyIdent :: Ident
+dummyIdent = mkIdent "_"
+
isDummyIdent :: Ident -> Bool
isDummyIdent (Ident _ "_") = True
isDummyIdent _ = False
@@ -105,9 +137,4 @@
showSLoc :: SLoc -> String
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
-
-
+ show fn ++ ": " ++ "line " ++ show l ++ ", col " ++ show c
--- a/src/MicroHs/IdentMap.hs
+++ b/src/MicroHs/IdentMap.hs
@@ -6,9 +6,15 @@
--
module MicroHs.IdentMap(
Map,
- insert, fromListWith, fromList, lookup, empty, elems, size, toList, delete,
+ empty, singleton,
+ insertWith, insert,
+ fromListWith, fromList,
+ delete,
+ lookup,
+ size,
+ toList, elems,
) where
-import Prelude --Xhiding(lookup)
+import Prelude hiding(lookup)
import MicroHs.Ident
--Ximport Compat
@@ -26,6 +32,9 @@
empty :: forall a . Map a
empty = Nil
+singleton :: forall a . Ident -> a -> Map a
+singleton i a = One i a
+
elems :: forall v . Map v -> [v]
elems = map snd . toList
@@ -55,10 +64,12 @@
lookup k = look
where
look Nil = Nothing
- look (One key val) | isEQ (compareIdent k key) = Just val
- | otherwise = Nothing
+ look (One key val) =
+ case compare k key of
+ EQ -> Just val
+ _ -> Nothing
look (Node left _ key val right) =
- case k `compareIdent` key of
+ case k `compare` key of
LT -> look left
EQ -> Just val
GT -> look right
@@ -72,7 +83,7 @@
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
+ case k `compare` key of
LT -> balance (ins left) key val right
EQ -> node left k (comb v val) right
GT -> balance left key val (ins right)
@@ -81,10 +92,10 @@
delete k = del
where
del Nil = Nil
- del t@(One a _) | isEQ (k `compareIdent` a) = Nil
+ del t@(One a _) | isEQ (k `compare` a) = Nil
| otherwise = t
del (Node left _ key val right) =
- case k `compareIdent` key of
+ case k `compare` key of
LT -> balance (del left) key val right
EQ -> glue left right
GT -> balance left key val (del right)
--- a/src/MicroHs/Interactive.hs
+++ b/src/MicroHs/Interactive.hs
@@ -1,8 +1,9 @@
module MicroHs.Interactive(module MicroHs.Interactive) where
import Prelude
-import Control.DeepSeq
+--Ximport Data.List
+--import Control.DeepSeq
import Control.Exception
-import qualified MicroHs.StateIO as S
+import MicroHs.StateIO
import MicroHs.Compile
import MicroHs.Exp(Exp)
import MicroHs.Ident(Ident, mkIdent)
@@ -16,31 +17,37 @@
type IState = (String, Flags, Cache)
-type I a = S.StateIO IState a
+type I a = StateIO IState a
mainInteractive :: Flags -> IO ()
-mainInteractive flags = do
+mainInteractive (Flags a b c d _) = do
putStrLn "Welcome to interactive MicroHs!"
putStrLn "Type ':quit' to quit, ':help' for help"
- _ <- S.runStateIO repl (preamble, flags, emptyCache)
+ let flags' = Flags a b c d True
+ _ <- runStateIO start (preamble, flags', emptyCache)
return ()
preamble :: String
preamble = "module " ++ interactiveName ++ "(module " ++ interactiveName ++
- ") where\nimport Prelude\nimport Unsafe.Coerce\n"
+ ") where\nimport Prelude\n"
+start :: I ()
+start = do
+ reload
+ repl
+
repl :: I ()
-repl = S.do
- ms <- S.liftIO $ getInputLineHist ".mhsi" "> "
+repl = do
+ ms <- liftIO $ getInputLineHist ".mhsi" "> "
case ms of
Nothing -> repl
Just s ->
case s of
[] -> repl
- ':':r -> S.do
+ ':':r -> do
c <- command r
- if c then repl else S.liftIO $ putStrLn "Bye"
- _ -> S.do
+ if c then repl else liftIO $ putStrLn "Bye"
+ _ -> do
oneline s
repl
@@ -47,41 +54,53 @@
command :: String -> I Bool
command s =
case words s of
- [] -> S.return True
+ [] -> return True
c : ws ->
- case filter (isPrefixOfBy eqChar c . fst) commands of
- [] -> S.do
- S.liftIO $ putStrLn "Unrecognized command"
- S.return True
+ case filter (isPrefixOf c . fst) commands of
+ [] -> do
+ liftIO $ putStrLn "Unrecognized command"
+ return True
[(_, cmd)] ->
cmd (unwords ws)
- xs -> S.do
- S.liftIO $ putStrLn $ "Ambiguous command: " ++ unwords (map fst xs)
- S.return True
+ xs -> do
+ liftIO $ putStrLn $ "Ambiguous command: " ++ unwords (map fst xs)
+ return True
commands :: [(String, String -> I Bool)]
commands =
- [ ("quit", const $ S.return False)- , ("clear", const $ S.do+ [ ("quit", const $ return False)+ , ("clear", const $ doupdateLines (const preamble)
- S.modify $ \ (ls, flgs, _) -> (ls, flgs, emptyCache)
- S.return True
+ modify $ \ (ls, flgs, _) -> (ls, flgs, emptyCache)
+ return True
)
- , ("delete", \ del -> S.do- updateLines (unlines . filter (not . isPrefixOfBy eqChar del) . lines)
- S.return True
+ , ("reload", const $ do+ modify $ \ (ls, flgs, _) -> (ls, flgs, emptyCache)
+ reload
+ return True
)
- , ("help", \ _ -> S.do- S.liftIO $ putStrLn helpText
- S.return True
+ , ("delete", \ del -> do+ updateLines (unlines . filter (not . isPrefixOf del) . lines)
+ return True
)
+ , ("help", \ _ -> do+ liftIO $ putStrLn helpText
+ return True
+ )
]
+reload :: I ()
+reload = do
+ (ls, _, _) <- get
+ _ <- tryCompile ls -- reload modules right away
+ return ()
+
+
helpText :: String
-helpText = "Commands:\n :quit quit MicroHs\n :clear clear all definitions\n :delete d delete definition(s) d\n :help this text\n expr evaluate expression\n defn add top level definition\n"
+helpText = "Commands:\n :quit quit MicroHs\n :reload reload modules\n :clear clear all definitions\n :delete d delete definition(s) d\n :help this text\n expr evaluate expression\n defn add top level definition\n"
updateLines :: (String -> String) -> I ()
-updateLines f = S.modify $ \ (ls, flgs, cache) -> (f ls, flgs, cache)
+updateLines f = modify $ \ (ls, flgs, cache) -> (f ls, flgs, cache)
interactiveName :: String
interactiveName = "Interactive"
@@ -90,55 +109,52 @@
itName = "_it"
mkIt :: String -> String
-mkIt l = itName ++ " :: Any\n" ++ itName ++ " = unsafeCoerce (" ++ l ++ ")\n"+mkIt l = itName ++ " :: IO ()\n" ++ itName ++ " = print (" ++ l ++ ")\n"err :: Exn -> IO ()
err (Exn s) = putStrLn $ "Error: " ++ s
oneline :: String -> I ()
-oneline line = S.do
- (ls, _, _) <- S.get
+oneline line = do
+ (ls, _, _) <- get
case parse pExprTop "" line of
- Right _ -> S.do
+ Right _ -> 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
+ Left e -> liftIO $ err e
+ Left _ -> 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
+ Left e -> liftIO $ err e
tryCompile :: String -> I (Either Exn [LDef])
-tryCompile file = S.do
- (ls, flgs, cache) <- S.get
+tryCompile file = do
+ (ls, flgs, cache) <- get
let
iid = mkIdent interactiveName
- S.liftIO $ writeFile (interactiveName ++ ".hs") file
- res <- S.liftIO $ try $ compileCacheTop flgs iid cache
+ liftIO $ writeFile (interactiveName ++ ".hs") file
+ res <- 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)
+ Left e -> return (Left e)
+ Right (m, cache') -> do
+ put (ls, flgs, deleteFromCache iid cache')
+ 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 $
+evalExpr cmdl = do
+ let ares = translate (mkIdent (interactiveName ++ "." ++ itName), cmdl)
+ res = unsafeCoerce ares :: IO ()
+ mval <- liftIO $ try (seq res (return res))
+ 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 ()
+ Right val -> do
+ mio <- try val
+ case mio of
+ Left e -> err e
+ Right _ -> return ()
--- a/src/MicroHs/Lex.hs
+++ b/src/MicroHs/Lex.hs
@@ -2,10 +2,9 @@
lexTop,
Token(..), showToken,
tokensLoc) where
-import Prelude --Xhiding(lex, showChar, showString)
+import Prelude --Xhiding(lex)
import Data.Char
import Data.List
-import qualified Data.Double as D
--Ximport Compat
import MicroHs.Ident
@@ -13,8 +12,8 @@
= TIdent Loc [String] String
| TString Loc String
| TChar Loc Char
- | TInt Loc Int
- | TDouble Loc D.Double
+ | TInt Loc Integer
+ | TRat Loc Rational
| TSpec Loc Char
| TError Loc String
| TBrace Loc
@@ -23,10 +22,10 @@
showToken :: Token -> String
showToken (TIdent _ ss s) = intercalate "." (ss ++ [s])
-showToken (TString _ s) = showString s
-showToken (TChar _ c) = showChar c
-showToken (TInt _ i) = showInt i
-showToken (TDouble _ d) = D.showDouble d
+showToken (TString _ s) = show s
+showToken (TChar _ c) = show c
+showToken (TInt _ i) = show i
+showToken (TRat _ d) = show d
showToken (TSpec _ c) = [c]
showToken (TError _ s) = "ERROR " ++ s
showToken (TBrace _) = "TBrace"
@@ -81,7 +80,7 @@
lex loc ('{':'-':cs) = skipNest (addCol loc 2) 1 cs lex loc ('-':'-':cs) | isComm rs = skipLine (addCol loc $ 2+length ds) cswhere
- (ds, rs) = span (eqChar '-') cs
+ (ds, rs) = span (== '-') cs
isComm [] = True
isComm (d:_) = not (isOperChar d)
lex loc (d:cs) | isLower_ d =
@@ -88,6 +87,7 @@
case span isIdentChar cs of
(ds, rs) -> tIdent loc [] (d:ds) (lex (addCol loc $ 1 + length ds) rs)
lex loc cs@(d:_) | isUpper d = upperIdent loc loc [] cs
+lex loc ('0':x:cs) | toLower x == 'x' = hexNumber loc cs lex loc ('-':cs@(d:_)) | isDigit d = number loc "-" cslex loc cs@(d:_) | isDigit d = number loc "" cs
lex loc (d:cs) | isOperChar d =
@@ -102,28 +102,33 @@
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 loc (d:_) = [TError loc $ "Unrecognized input: " ++ xshowChar d]
lex _ [] = []
-number :: Loc -> String -> String -> [Token] -- neg=1 means negative, neg=0 means positive
+hexNumber :: Loc -> String -> [Token]
+hexNumber loc cs =
+ case span isHexDigit cs of
+ (ds, rs) -> TInt loc (readHex ds) : lex (addCol loc $ length ds + 2) rs
+
+number :: Loc -> String -> String -> [Token] -- neg="-" means negative, neg=0 means positive
number loc sign cs =
case span isDigit cs of
- (ds, rs) | null rs || not (eqChar (head rs) '.') || eqString (take 2 rs) ".." ->
+ (ds, rs) | null rs || not (head rs == '.') || (take 2 rs) == ".." ->
let s = sign ++ ds
- i = readInt s
+ i = readInteger s
in TInt loc i : lex (addCol loc $ length s) rs
| otherwise ->
case span isDigit (tail rs) of
(ns, rs') ->
let s = sign ++ ds ++ '.':ns
- mkD x r = TDouble loc (readDouble x) : lex (addCol loc $ length x) r
+ mkD x r = TRat loc (readRational x) : lex (addCol loc $ length x) r
in case expo rs' of
Nothing -> mkD s rs'
Just (es, rs'') -> mkD (s ++ es) rs''
where
- expo (e:'-':xs@(d:_)) | eqChar (toLower e) 'w' && isDigit d = Just ('e':'-':as, bs) where (as, bs) = span isDigit xs- expo (e:'+':xs@(d:_)) | eqChar (toLower e) 'w' && isDigit d = Just ('e':'+':as, bs) where (as, bs) = span isDigit xs- expo (e: xs@(d:_)) | eqChar (toLower e) 'w' && isDigit d = Just ('e': as, bs) where (as, bs) = span isDigit xs+ expo (e:'-':xs@(d:_)) | toLower e == 'e' && isDigit d = Just ('e':'-':as, bs) where (as, bs) = span isDigit xs+ expo (e:'+':xs@(d:_)) | toLower e == 'e' && isDigit d = Just ('e':'+':as, bs) where (as, bs) = span isDigit xs+ expo (e: xs@(d:_)) | toLower e == 'e' && isDigit d = Just ('e': as, bs) where (as, bs) = span isDigit xsexpo _ = Nothing
-- Skip a {- -} style comment@@ -154,7 +159,7 @@
takeChars loc fn c n str ('\\':cs) =case decodeChar (n+1) cs of
(d, m, rs) -> takeChars loc fn c m (d:str) rs
-takeChars _ fn c n str (d:cs) | eqChar c d = (fn (reverse str), n, cs)
+takeChars _ fn c n str (d:cs) | c == d = (fn (reverse str), n, cs)
takeChars loc fn c n str (d:cs) = takeChars loc fn c (n+1) (d:str) cs
decodeChar :: Int -> String -> (Char, Int, String)
@@ -166,7 +171,7 @@
decodeChar n [] = ('X', n, [])isSpec :: Char -> Bool
-isSpec c = elemBy eqChar c "()[],{}`;"+isSpec c = elem c "()[],{}`;"upperIdent :: Loc -> Loc -> [String] -> String -> [Token]
--upperIdent l c qs acs | trace (show (l, c, qs, acs)) False = undefined
@@ -185,7 +190,7 @@
_ -> TIdent sloc (reverse qs) ds : lex (addCol loc $ length ds) rs
tIdent :: Loc -> [String] -> String -> [Token] -> [Token]
-tIdent loc qs kw ats | elemBy eqString kw ["let", "where", "do", "of"]
+tIdent loc qs kw ats | elem kw ["let", "where", "do", "of"]
= ti : tBrace ats
| otherwise = ti : ats
where {@@ -202,7 +207,7 @@
tokensLoc (TString loc _ :_) = loc
tokensLoc (TChar loc _ :_) = loc
tokensLoc (TInt loc _ :_) = loc
-tokensLoc (TDouble loc _ : _) = loc
+tokensLoc (TRat loc _ : _) = loc
tokensLoc (TSpec loc _ :_) = loc
tokensLoc (TError loc _ :_) = loc
tokensLoc (TBrace loc :_) = loc
@@ -222,3 +227,6 @@
layout ms (t : ts) = t : layout ms ts
layout (_ : ms) [] = TSpec (mkLoc 0 0) '}' : layout ms []
layout [] [] = []
+
+readHex :: String -> Integer
+readHex = foldl (\ r c -> r * 16 + toInteger (digitToInt c)) 0
--- a/src/MicroHs/Main.hs
+++ b/src/MicroHs/Main.hs
@@ -3,12 +3,14 @@
{-# OPTIONS_GHC -Wno-unused-do-bind #-}module MicroHs.Main(main) where
import Prelude
-import qualified MicroHs.IdentMap as M
+--Ximport Data.List
+import Control.Monad
import Data.Maybe
import System.Environment
import MicroHs.Compile
import MicroHs.Exp
import MicroHs.Ident
+import qualified MicroHs.IdentMap as M
import MicroHs.Translate
import MicroHs.Interactive
--Ximport Compat
@@ -17,12 +19,13 @@
main = do
aargs <- getArgs
let
- args = takeWhile (not . eqString "--") aargs
- 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"])
+ args = takeWhile (/= "--") aargs
+ ss = filter ((/= "-") . take 1) args
+ flags = Flags (length (filter (== "-v") args))
+ (elem "-r" args)
+ ("." : catMaybes (map (stripPrefix "-i") args))+ (head $ catMaybes (map (stripPrefix "-o") args) ++ ["out.comb"])
+ (elem "-l" args)
case ss of
[] -> mainInteractive flags
[s] -> mainCompile flags (mkIdent s)
@@ -35,8 +38,8 @@
let
mainName = qualIdent mn (mkIdent "main")
cmdl = (mainName, ds)
- ref i = Var $ mkIdent $ "_" ++ showInt i
- defs = M.fromList [ (n, ref i) | ((n, _), i) <- zip ds (enumFrom 0) ]
+ ref i = Var $ mkIdent $ "_" ++ show i
+ defs = M.fromList [ (n, ref i) | ((n, _), i) <- zip ds (enumFrom (0::Int)) ]
findIdent n = fromMaybe (error $ "main: findIdent: " ++ showIdent n) $
M.lookup n defs
emain = findIdent mainName
@@ -47,11 +50,11 @@
e -> e
def :: ((Ident, Exp), Int) -> (String -> String) -> (String -> String)
def ((_, e), i) r =
- (("((A :" ++ showInt i ++ " ") ++) . toStringP (substv e) . (") " ++) . r . (")" ++)+ (("((A :" ++ show 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
+ putStrLn $ "top level defns: " ++ show numDefs
when (verbose flags > 1) $
mapM_ (\ (i, e) -> putStrLn $ showIdent i ++ " = " ++ toStringP e "") ds
if runIt flags then do
@@ -62,10 +65,10 @@
prg
-- putStrLn "done"
else do
- writeFile (output flags) $ version ++ showInt numDefs ++ "\n" ++ res
+ writeFile (output flags) $ version ++ show numDefs ++ "\n" ++ res
t2 <- getTimeMilli
when (verbose flags > 0) $
- putStrLn $ "final pass " ++ padLeft 6 (showInt (t2-t1)) ++ "ms"
+ putStrLn $ "final pass " ++ padLeft 6 (show (t2-t1)) ++ "ms"
version :: String
-version = "v4.0\n"
+version = "v4.1\n"
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -2,7 +2,7 @@
-- See LICENSE file for full license.
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-unused-do-bind #-}module MicroHs.Parse(pTop, parseDie, parse, pExprTop) where
-import Prelude --Xhiding (Monad(..), Applicative(..), MonadFail(..), Functor(..), (<$>), showString, showChar, showList)
+import Prelude --Xhiding (Monad(..), Applicative(..), MonadFail(..), Functor(..), (<$>))
import Data.Char
import Data.List
import Text.ParserComb as P
@@ -11,7 +11,6 @@
import MicroHs.Ident
--Ximport Compat
-
type P a = Prsr FilePath Token a
getFileName :: P FilePath
@@ -35,9 +34,9 @@
--X ++ unlines (map (show . fst) as)
getLoc :: P Loc
-getLoc = P.do
+getLoc = do
t <- nextToken
- P.pure (tokensLoc [t])
+ pure (tokensLoc [t])
pTop :: P EModule
pTop = pModule <* eof
@@ -51,7 +50,7 @@
(pKeyword "where" *> pBlock pDef)
pQIdent :: P Ident
-pQIdent = P.do
+pQIdent = do
fn <- getFileName
let
is (TIdent loc qs s) | isAlpha_ (head s) = Just (qualName fn loc qs s)
@@ -59,7 +58,7 @@
satisfyM "QIdent" is
pUIdentA :: P Ident
-pUIdentA = P.do
+pUIdentA = do
fn <- getFileName
let
is (TIdent loc [] s) | isUpper (head s) = Just (mkIdentLoc fn loc s)
@@ -75,7 +74,7 @@
pUIdentSym = pUIdent <|< pParens pUSymOper
pUIdentSpecial :: P Ident
-pUIdentSpecial = P.do
+pUIdentSpecial = do
fn <- getFileName
loc <- getLoc
let
@@ -86,7 +85,7 @@
<|< (mk "[]" <$ (pSpec '[' *> pSpec ']')) -- Allow [] as a constructor name
pUQIdentA :: P Ident
-pUQIdentA = P.do
+pUQIdentA = do
fn <- getFileName
let
is (TIdent loc qs s) | isUpper (head s) = Just (qualName fn loc qs s)
@@ -99,36 +98,41 @@
<|< pUIdentSpecial
pLIdent :: P Ident
-pLIdent = P.do
+pLIdent = do
fn <- getFileName
let
- is (TIdent loc [] s) | isLower_ (head s) && not (elemBy eqString s keywords) = Just (mkIdentLoc fn loc s)
+ is (TIdent loc [] s) | isLower_ (head s) && not (elem s keywords) = Just (mkIdentLoc fn loc s)
is _ = Nothing
satisfyM "LIdent" is
pLQIdent :: P Ident
-pLQIdent = P.do
+pLQIdent = do
fn <- getFileName
let
- is (TIdent loc qs s) | isLower_ (head s) && not (elemBy eqString s keywords) = Just (qualName fn loc qs s)
+ is (TIdent loc qs s) | isLower_ (head s) && not (elem s keywords) = Just (qualName fn loc qs s)
is _ = Nothing
satisfyM "LQIdent" is
+-- Type names can be any operator
+pTypeIdentSym :: P Ident
+pTypeIdentSym = pUIdent <|< pParens pSymOper
+
keywords :: [String]
-keywords = ["case", "data", "do", "else", "forall", "foreign", "if", "import",
- "in", "infix", "infixl", "infixr",
- "let", "module", "newtype", "of", "primitive", "then", "type", "where"]
+keywords =
+ ["case", "class", "data", "do", "else", "forall", "foreign", "if", "import",
+ "in", "infix", "infixl", "infixr", "instance",
+ "let", "module", "newtype", "of", "primitive", "then", "type", "where"]
pSpec :: Char -> P ()
pSpec c = () <$ satisfy [c] is
where
- is (TSpec _ d) = eqChar c d
+ is (TSpec _ d) = c == d
is _ = False
pSymbol :: String -> P ()
pSymbol sym = () <$ satisfy sym is
where
- is (TIdent _ [] s) = eqString s sym
+ is (TIdent _ [] s) = s == sym
is _ = False
pOper :: P Ident
@@ -135,41 +139,41 @@
pOper = pQSymOper <|< (pSpec '`' *> pQIdent <* pSpec '`')
pQSymOper :: P Ident
-pQSymOper = P.do
+pQSymOper = do
fn <- getFileName
let
- is (TIdent loc qs s) | not (isAlpha_ (head s)) && not (elemBy eqString s reservedOps) = Just (qualName fn loc qs s)
+ is (TIdent loc qs s) | not (isAlpha_ (head s)) && not (elem s reservedOps) = Just (qualName fn loc qs s)
is _ = Nothing
satisfyM "QSymOper" is
pSymOper :: P Ident
-pSymOper = P.do
+pSymOper = do
fn <- getFileName
let
- is (TIdent loc [] s) | not (isAlpha_ (head s)) && not (elemBy eqString s reservedOps) = Just (mkIdentLoc fn loc s)
+ is (TIdent loc [] s) | not (isAlpha_ (head s)) && not (elem s reservedOps) = Just (mkIdentLoc fn loc s)
is _ = Nothing
satisfyM "SymOper" is
pUQSymOper :: P Ident
-pUQSymOper = P.do
+pUQSymOper = do
s <- pQSymOper
guard (isUOper s)
- P.pure s
+ pure s
isUOper :: Ident -> Bool
-isUOper = eqChar ':' . head . unIdent
+isUOper = (== ':') . head . unIdent
pUSymOper :: P Ident
-pUSymOper = P.do
+pUSymOper = do
s <- pSymOper
guard (isUOper s)
- P.pure s
+ pure s
pLQSymOper :: P Ident
-pLQSymOper = P.do
+pLQSymOper = do
s <- pQSymOper
guard (not (isUOper s))
- P.pure s
+ pure s
-- Allow -> as well
pLQSymOperArr :: P Ident
@@ -177,7 +181,7 @@
-- Parse ->, possibly qualified
pQArrow :: P Ident
-pQArrow = P.do
+pQArrow = do
fn <- getFileName
let
is (TIdent loc qs s@"->") = Just (qualName fn loc qs s)
@@ -185,10 +189,10 @@
satisfyM "->" is
pLSymOper :: P Ident
-pLSymOper = P.do
+pLSymOper = do
s <- pSymOper
guard (not (isUOper s))
- P.pure s
+ pure s
reservedOps :: [String]
reservedOps = ["=", "|", "::", "<-", "@", "..", "->"]
@@ -206,13 +210,13 @@
pParens p = pSpec '(' *> p <* pSpec ')'pLit :: P Expr
-pLit = P.do
+pLit = do
fn <- getFileName
let
is (TString (l, c) s) = Just (ELit (SLoc fn l c) (LStr s))
is (TChar (l, c) a) = Just (ELit (SLoc fn l c) (LChar a))
- is (TInt (l, c) i) = Just (ELit (SLoc fn l c) (LInt i))
- is (TDouble (l, c) d) = Just (ELit (SLoc fn l c) (LDouble d))
+ is (TInt (l, c) i) = Just (ELit (SLoc fn l c) (LInteger i))
+ is (TRat (l, c) d) = Just (ELit (SLoc fn l c) (LRat d))
is _ = Nothing
satisfyM "literal" is
@@ -234,11 +238,11 @@
pKeyword :: String -> P ()
pKeyword kw = () <$ satisfy kw is
where
- is (TIdent _ [] s) = eqString kw s
+ is (TIdent _ [] s) = kw == s
is _ = False
pBlock :: forall a . P a -> P [a]
-pBlock p = P.do
+pBlock p = do
pSpec '{'as <- esepBy p (pSpec ';')
eoptional (pSpec ';')
@@ -248,28 +252,36 @@
pDef :: P EDef
pDef =
Data <$> (pKeyword "data" *> pLHS) <*> ((pSymbol "=" *> esepBy1 (Constr <$> pUIdentSym <*> pFields) (pSymbol "|"))
- <|< P.pure [])
+ <|< pure [])
<|< Newtype <$> (pKeyword "newtype" *> pLHS) <*> (pSymbol "=" *> (Constr <$> pUIdentSym <*> pField))
<|< Type <$> (pKeyword "type" *> pLHS) <*> (pSymbol "=" *> pType)
<|< uncurry Fcn <$> pEqns
<|< Sign <$> (pLIdentSym <* pSymbol "::") <*> pType
- <|< Import <$> (pKeyword "import" *> pImportSpec)
+ <|< Import <$> (pKeyword "import" *> pImportSpec)
<|< ForImp <$> (pKeyword "foreign" *> pKeyword "import" *> pKeyword "ccall" *> pString) <*> pLIdent <*> (pSymbol "::" *> pType)
<|< Infix <$> ((,) <$> pAssoc <*> pPrec) <*> esepBy1 pTypeOper (pSpec ',')
+ <|< Class <$> (pKeyword "class" *> pContext) <*> pLHS <*> pFunDeps <*> pWhere pClsBind
+ <|< Instance <$> (pKeyword "instance" *> pForall) <*> pContext <*> pTypeApp <*> pWhere pClsBind
where
pAssoc = (AssocLeft <$ pKeyword "infixl") <|< (AssocRight <$ pKeyword "infixr") <|< (AssocNone <$ pKeyword "infix")
- dig (TInt _ i) | -1 <= i && i <= 9 = Just i
+ dig (TInt _ ii) | -2 <= i && i <= 9 = Just i where i = _integerToInt ii
dig _ = Nothing
pPrec = satisfyM "digit" dig
+ pContext = (pCtx <* pSymbol "=>") <|< pure []
+ pCtx = pParens (emany pType) <|< ((:[]) <$> pTypeApp)
+
pFields = Left <$> emany pAType <|<
Right <$> (pSpec '{' *> esepBy ((,) <$> (pLIdentSym <* pSymbol "::") <*> pType) (pSpec ',') <* pSpec '}')- pField = P.do
+ pField = do
fs <- pFields
guard $ either length length fs == 1
- P.pure fs
+ pure fs
+ pFunDeps = (pSpec '|' *> esome pFunDep) <|< pure []
+ pFunDep = (,) <$> esome pLIdent <*> (pSymbol "->" *> esome pLIdent)
pLHS :: P LHS
-pLHS = (,) <$> pUIdentSym <*> emany pIdKind
+pLHS = (,) <$> pTypeIdentSym <*> emany pIdKind
+ <|< (\ a c b -> (c, [a,b])) <$> pIdKind <*> pSymOper <*> pIdKind
pImportSpec :: P ImportSpec
pImportSpec =
@@ -300,22 +312,25 @@
-- Including '->' in pExprOp interacts poorly with '->'
-- in lambda and 'case'.
pType :: P EType
-pType = P.do
- vs <- (pKeyword "forall" *> esome pIdKind <* pSymbol ".") <|< pure []
+pType = do
+ vs <- pForall
t <- pTypeOp
pure $ if null vs then t else EForall vs t
+pForall :: P [IdKind]
+pForall = (pKeyword "forall" *> esome pIdKind <* pSymbol ".") <|< pure []
+
pTypeOp :: P EType
pTypeOp = pOperators pTypeOper pTypeArg
pTypeOper :: P Ident
-pTypeOper = pOper <|< (mkIdent "->" <$ pSymbol "->")
+pTypeOper = pOper <|< (mkIdent "->" <$ pSymbol "->") <|< (mkIdent "=>" <$ pSymbol "=>")
pTypeArg :: P EType
pTypeArg = pTypeApp
pTypeApp :: P EType
-pTypeApp = P.do
+pTypeApp = do
f <- pAType
as <- emany pAType
mt <- eoptional (pSymbol "::" *> pType)
@@ -341,7 +356,7 @@
-- is separate.
pAPat :: P EPat
pAPat =
- (P.do
+ (do
i <- pLIdentSym
(EAt i <$> (pSymbol "@" *> pAPat)) <|< pure (EVar i)
)
@@ -360,7 +375,7 @@
pPatArg = pPatApp
pPatApp :: P EPat
-pPatApp = P.do
+pPatApp = do
f <- pAPat
as <- emany pAPat
guard (null as || isPConApp f)
@@ -367,7 +382,7 @@
pure $ foldl EApp f as
pPatNotVar :: P EPat
-pPatNotVar = P.do
+pPatNotVar = do
p <- pPat
guard (not (isPVar p))
pure p
@@ -375,22 +390,22 @@
-------------
pEqns :: P (Ident, [Eqn])
-pEqns = P.do
+pEqns = do
(name, eqn@(Eqn ps alts)) <- pEqn (\ _ _ -> True)
case (ps, alts) of
([], EAlts [_] []) ->
-- don't collect equations when of the form 'i = e'
- P.pure (name, [eqn])
- _ -> P.do
- neqns <- emany (pSpec ';' *> pEqn (\ n l -> eqIdent n name && l == length ps))
- P.pure (name, eqn : map snd neqns)
+ pure (name, [eqn])
+ _ -> do
+ neqns <- emany (pSpec ';' *> pEqn (\ n l -> n == name && l == length ps))
+ pure (name, eqn : map snd neqns)
pEqn :: (Ident -> Int -> Bool) -> P (Ident, Eqn)
-pEqn test = P.do
+pEqn test = do
(name, pats) <- pEqnLHS
alts <- pAlts (pSymbol "=")
guard (test name (length pats))
- P.pure (name, Eqn pats alts)
+ pure (name, Eqn pats alts)
pEqnLHS :: P (Ident, [EPat])
pEqnLHS =
@@ -401,16 +416,16 @@
((\ (i, ps1) ps2 -> (i, ps1 ++ ps2)) <$> pParens pOpLHS <*> emany pAPat)
where
pOpLHS = (\ p1 i p2 -> (i, [p1,p2])) <$> pPatApp <*> pLOper <*> pPatApp
- pLOper = P.do
+ pLOper = do
i <- pOper
guard (not (isConIdent i))
- P.pure i
+ pure i
pAlts :: P () -> P EAlts
-pAlts sep = P.do
+pAlts sep = do
alts <- pAltsL sep
- bs <- pWhere
- P.pure (EAlts alts bs)
+ bs <- pWhere pBind
+ pure (EAlts alts bs)
pAltsL :: P () -> P [EAlt]
pAltsL sep =
@@ -417,10 +432,10 @@
esome ((,) <$> (pSymbol "|" *> esepBy1 pStmt (pSpec ',')) <*> (sep *> pExpr))
<|< ((\ e -> [([], e)]) <$> (sep *> pExpr))
-pWhere :: P [EBind]
-pWhere =
- (pKeyword "where" *> pBlock pBind)
- <|< P.pure []
+pWhere :: P EBind -> P [EBind]
+pWhere pb =
+ (pKeyword "where" *> pBlock pb)
+ <|< pure []
-------------
-- Statements
@@ -441,7 +456,7 @@
pExprArg = pExprApp <|< pLam <|< pCase <|< pLet <|< pIf <|< pDo
pExprApp :: P Expr
-pExprApp = P.do
+pExprApp = do
f <- pAExpr
as <- emany pAExpr
mt <- eoptional (pSymbol "::" *> pType)
@@ -468,7 +483,7 @@
pIf = EIf <$> (pKeyword "if" *> pExpr) <*> (pKeyword "then" *> pExpr) <*> (pKeyword "else" *> pExpr)
pQualDo :: P Ident
-pQualDo = P.do
+pQualDo = do
fn <- getFileName
let
is (TIdent loc qs@(_:_) "do") = Just (mkIdentLoc fn loc (intercalate "." qs))
@@ -495,20 +510,20 @@
-- <?> "aexpr"
pListish :: P Listish
-pListish = P.do
+pListish = do
e1 <- pExpr
let
- pMore = P.do
+ pMore = 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])
+ <|< pure (LList [e1,e2])
(pSpec ',' *> pMore)
<|< (LCompr e1 <$> (pSymbol "|" *> esepBy1 pStmt (pSpec ',')))
<|< (LFromTo e1 <$> (pSymbol ".." *> pExpr))
<|< (LFrom e1 <$ pSymbol "..")
- <|< P.pure (LList [e1])
+ <|< pure (LList [e1])
pExprOp :: P Expr
pExprOp = pOperators pOper pExprArg
@@ -523,8 +538,12 @@
pBind :: P EBind
pBind =
+ BPat <$> (pPatNotVar <* pSymbol "=") <*> pExpr
+ <|< pClsBind
+
+pClsBind :: P EBind
+pClsBind =
uncurry BFcn <$> pEqns
- <|< BPat <$> (pPatNotVar <* pSymbol "=") <*> pExpr
<|< BSign <$> (pLIdentSym <* pSymbol "::") <*> pType
-------------
@@ -550,4 +569,4 @@
in
showSLoc sloc ++ ":\n"
++ " found: " ++ head (map showToken ts ++ ["EOF"]) ++ "\n"
- ++ " expected: " ++ unwords (nubBy eqString msgs)
+ ++ " expected: " ++ unwords (nub msgs)
--- a/src/MicroHs/Pretty.hs
+++ /dev/null
@@ -1,372 +1,0 @@
--- Based on the pretty-printer outlined in the paper
--- 'The Design of a Pretty-printing Library' by
--- John Hughes in Advanced Functional Programming, 1995.
--- With inspiration and code from the from the Hackage package pretty.
---module Text.PrettyPrint.HughesPJ(
-module MicroHs.Pretty(
- Doc,
- text, empty,
- (<>), (<+>), ($$), ($+$),
- hcat, hsep,
- vcat,
- sep, cat,
- nest, hang,
- punctuate,
- parens, brackets, braces,
- maybeParens,
- Style,
- render, renderStyle,
- ) where
-import Prelude --X hiding((<>))
---Ximport Compat
-
-infixl 6 <>, <+>
-infixl 5 $$, $+$
-
-data Doc
- = Empty -- ^ An empty span, see 'empty'.
- | NilAbove Doc -- ^ @text "" $$ x@.
- | TextBeside String Doc -- ^ @text s <> x@.
- | Nest Int Doc -- ^ @nest k x@.
- | Union Doc Doc -- ^ @ul `union` ur@.
- | NoDoc -- ^ The empty set of documents.
- | Beside Doc Bool Doc -- ^ True <=> space between.
- | Above Doc Bool Doc -- ^ True <=> never overlap.
-
-type RDoc = Doc
-
-text :: String -> Doc
-text s = TextBeside s Empty
-
-empty :: Doc
-empty = Empty
-
-reduceDoc :: Doc -> RDoc
-reduceDoc (Beside p g q) = beside p g (reduceDoc q)
-reduceDoc (Above p g q) = above p g (reduceDoc q)
-reduceDoc p = p
-
-hcat :: [Doc] -> Doc
-hcat = snd . reduceHoriz . foldr (\p q -> Beside p False q) empty
-
--- | List version of '<+>'.
-hsep :: [Doc] -> Doc
-hsep = snd . reduceHoriz . foldr (\p q -> Beside p True q) empty
-
--- | List version of '$$'.
-vcat :: [Doc] -> Doc
-vcat = snd . reduceVert . foldr (\p q -> Above p False q) empty
-
-nest :: Int -> Doc -> Doc
-nest k p = mkNest k (reduceDoc p)
-
--- | @hang d1 n d2 = sep [d1, nest n d2]@
-hang :: Doc -> Int -> Doc -> Doc
-hang d1 n d2 = sep [d1, nest n d2]
-
-punctuate :: Doc -> [Doc] -> [Doc]
-punctuate _ [] = []
-punctuate p (x:xs) = go x xs
- where go y [] = [y]
- go y (z:zs) = (y <> p) : go z zs
-
-maybeParens :: Bool -> Doc -> Doc
-maybeParens False = id
-maybeParens True = parens
-
-parens :: Doc -> Doc
-parens p = text "(" <> p <> text ")"-braces :: Doc -> Doc
-braces p = text "{" <> p <> text "}"-brackets :: Doc -> Doc
-brackets p = text "[" <> p <> text "]"
-
--- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
-mkNest :: Int -> Doc -> Doc
-mkNest k _ | k `seq` False = undefined
-mkNest k (Nest k1 p) = mkNest (k + k1) p
-mkNest _ NoDoc = NoDoc
-mkNest _ Empty = Empty
-mkNest 0 p = p
-mkNest k p = nest_ k p
-
--- mkUnion checks for an empty document
-mkUnion :: Doc -> Doc -> Doc
-mkUnion Empty _ = Empty
-mkUnion p q = p `union_` q
-
-data IsEmpty = IsEmpty | NotEmpty
-
-reduceHoriz :: Doc -> (IsEmpty, Doc)
-reduceHoriz (Beside p g q) = eliminateEmpty Beside (snd (reduceHoriz p)) g (reduceHoriz q)
-reduceHoriz doc = (NotEmpty, doc)
-
-reduceVert :: Doc -> (IsEmpty, Doc)
-reduceVert (Above p g q) = eliminateEmpty Above (snd (reduceVert p)) g (reduceVert q)
-reduceVert doc = (NotEmpty, doc)
-
-eliminateEmpty ::
- (Doc -> Bool -> Doc -> Doc) ->
- Doc -> Bool -> (IsEmpty, Doc) -> (IsEmpty, Doc)
-eliminateEmpty _ Empty _ q = q
-eliminateEmpty cons p g q =
- (NotEmpty,
- case q of
- (NotEmpty, q') -> cons p g q'
- (IsEmpty, _) -> p
- )
-
-nilAbove_ :: RDoc -> RDoc
-nilAbove_ = NilAbove
-
--- | Arg of a TextBeside is always an RDoc.
-textBeside_ :: String -> RDoc -> RDoc
-textBeside_ = TextBeside
-
-nest_ :: Int -> RDoc -> RDoc
-nest_ = Nest
-
-union_ :: RDoc -> RDoc -> RDoc
-union_ = Union
-
-($$) :: Doc -> Doc -> Doc
-p $$ q = above_ p False q
-
--- | Above, with no overlapping.
--- '$+$' is associative, with identity 'empty'.
-($+$) :: Doc -> Doc -> Doc
-p $+$ q = above_ p True q
-
-above_ :: Doc -> Bool -> Doc -> Doc
-above_ p _ Empty = p
-above_ Empty _ q = q
-above_ p g q = Above p g q
-
-above :: Doc -> Bool -> RDoc -> RDoc
-above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)
-above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q)
-above p g q = aboveNest p g 0 (reduceDoc q)
-
--- Specfication: aboveNest p g k q = p $g$ (nest k q)
-aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc
-aboveNest _ _ k _ | k `seq` False = undefined
-aboveNest NoDoc _ _ _ = NoDoc
-aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
- aboveNest p2 g k q
-
-aboveNest Empty _ k q = mkNest k q
-aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q)
- -- p can't be Empty, so no need for mkNest
-
-aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
-aboveNest (TextBeside s p) g k q = TextBeside s rest
- where
- k1 = k - length s
- rest = case p of
- Empty -> nilAboveNest g k1 q
- _ -> aboveNest p g k1 q
-
-aboveNest (Above _ _ _) _ _ _ = error "aboveNest Above"
-aboveNest (Beside _ _ _) _ _ _ = error "aboveNest Beside"
-
--- Specification: text s <> nilaboveNest g k q
--- = text s <> (text "" $g$ nest k q)
-nilAboveNest :: Bool -> Int -> RDoc -> RDoc
-nilAboveNest _ k _ | k `seq` False = undefined
-nilAboveNest _ _ Empty = Empty
- -- Here's why the "text s <>" is in the spec!
-nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
-nilAboveNest g k q | not g && k > 0 -- No newline if no overlap
- = textBeside_ (replicate k ' ') q
- | otherwise -- Put them really above
- = nilAbove_ (mkNest k q)
-
-(<>) :: Doc -> Doc -> Doc
-p <> q = beside_ p False q
-
--- | Beside, separated by space, unless one of the arguments is 'empty'.
--- '<+>' is associative, with identity 'empty'.
-(<+>) :: Doc -> Doc -> Doc
-p <+> q = beside_ p True q
-
-beside_ :: Doc -> Bool -> Doc -> Doc
-beside_ p _ Empty = p
-beside_ Empty _ q = q
-beside_ p g q = Beside p g q
-
--- Specification: beside g p q = p <g> q
-beside :: Doc -> Bool -> RDoc -> RDoc
-beside NoDoc _ _ = NoDoc
-beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q
-beside Empty _ q = q
-beside (Nest k p) g q = nest_ k $! beside p g q
-beside p@(Beside p1 g1 q1) g2 q2
- | eqBool g1 g2 = beside p1 g1 $! beside q1 g2 q2
- | otherwise = beside (reduceDoc p) g2 q2
-beside p@(Above _ _ _) g q = let { d = reduceDoc p } in beside d g q-beside (NilAbove p) g q = nilAbove_ $! beside p g q
-beside (TextBeside t p) g q = TextBeside t rest
- where
- rest = case p of
- Empty -> nilBeside g q
- _ -> beside p g q
-
--- Specification: text "" <> nilBeside g p
--- = text "" <g> p
-nilBeside :: Bool -> RDoc -> RDoc
-nilBeside _ Empty = Empty -- Hence the text "" in the spec
-nilBeside g (Nest _ p) = nilBeside g p
-nilBeside g p | g = textBeside_ " " p
- | otherwise = p
-
-sep :: [Doc] -> Doc
-sep = sepX True -- Separate with spaces
-
--- | Either 'hcat' or 'vcat'.
-cat :: [Doc] -> Doc
-cat = sepX False -- Don't
-
-sepX :: Bool -> [Doc] -> Doc
-sepX _ [] = empty
-sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps
-
-
--- Specification: sep1 g k ys = sep (x : map (nest k) ys)
--- = oneLiner (x <g> nest k (hsep ys))
--- `union` x $$ nest k (vcat ys)
-sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc
-sep1 _ _ k _ | k `seq` False = undefined
-sep1 _ NoDoc _ _ = NoDoc
-sep1 g (p `Union` q) k ys = sep1 g p k ys `union_`
- aboveNest q False k (reduceDoc (vcat ys))
-
-sep1 g Empty k ys = mkNest k (sepX g ys)
-sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys)
-
-sep1 _ (NilAbove p) k ys = nilAbove_
- (aboveNest p False k (reduceDoc (vcat ys)))
-sep1 g (TextBeside s p) k ys = textBeside_ s (sepNB g p (k - length s) ys)
-sep1 _ (Above _ _ _) _ _ = error "sep1 Above"
-sep1 _ (Beside _ _ _) _ _ = error "sep1 Beside"
-
-sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc
-sepNB g (Nest _ p) k ys
- = sepNB g p k ys
-sepNB g Empty k ys
- = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion`
- nilAboveNest False k (reduceDoc (vcat ys))
- where
- rest | g = hsep ys
- | otherwise = hcat ys
-sepNB g p k ys
- = sep1 g p k ys
-
-oneLiner :: Doc -> Doc
-oneLiner NoDoc = NoDoc
-oneLiner Empty = Empty
-oneLiner (NilAbove _) = NoDoc
-oneLiner (TextBeside s p) = textBeside_ s (oneLiner p)
-oneLiner (Nest k p) = nest_ k (oneLiner p)
-oneLiner (p `Union` _) = oneLiner p
-oneLiner (Above _ _ _) = error "oneLiner Above"
-oneLiner (Beside _ _ _) = error "oneLiner Beside"
-
--- ---------------------------------------------------------------------------
--- Rendering
-
--- | A rendering style. Allows us to specify constraints to choose among the
--- many different rendering options.
-data Style = Style Int Rat
-lineLength :: Style -> Int
-lineLength (Style l _) = l
-ribbonsPerLine :: Style -> Rat
-ribbonsPerLine (Style _ r) = r
-
-type Rat = (Int, Int)
-
-style :: Style
-style = Style 100 (3, 2)
-
--- | Render the @Doc@ to a String using the default @Style@ (see 'style').
-render :: Doc -> String
-render = renderStyle style
-
--- | Render the @Doc@ to a String using the given @Style@.
-renderStyle :: Style -> Doc -> String
-renderStyle s = fullRender (lineLength s) (ribbonsPerLine s) ""
-
--- | The general rendering interface. Please refer to the @Style@ and @Mode@
--- types for a description of rendering mode, line length and ribbons.
-fullRender :: Int -- ^ Line length.
- -> Rat -- ^ Ribbons per line.
- -> String -- ^ What to do at the end.
- -> Doc -- ^ The document.
- -> String -- ^ Result.
-fullRender lineLen (num, den) rest doc
- = display lineLen ribbonLen rest doc'
- where
- doc' = best bestLineLen ribbonLen (reduceDoc doc)
-
- ribbonLen = (lineLen * den) `quot` num
- bestLineLen = lineLen
-
-display :: Int -> Int -> String -> Doc -> String
-display _page_width _ribbon_width end doc
- = let lay :: Int -> Doc -> String
- lay k (Nest k1 p) = lay (k + k1) p
- lay _ Empty = end
- lay k (NilAbove p) = "\n" ++ lay k p
- lay k (TextBeside s p) = lay1 k s p
- lay _ _ = error "display lay"
-
- lay1 k s p = let r = k + length s
- in replicate k ' ' ++ (s ++ lay2 r p)
-
- lay2 :: Int -> Doc -> String
- lay2 k (NilAbove p) = "\n" ++ lay k p
- lay2 k (TextBeside s p) = s ++ lay2 (k + length s) p
- lay2 k (Nest _ p) = lay2 k p
- lay2 _ Empty = end
- lay2 _ _ = error "display lay2"
- in lay 0 doc
-
-best :: Int -- Line length.
- -> Int -- Ribbon length.
- -> RDoc
- -> RDoc -- No unions in here!.
-best w0 r = get w0
- where
- get _ Empty = Empty
- get _ NoDoc = NoDoc
- get w (NilAbove p) = nilAbove_ (get w p)
- get w (TextBeside s p) = textBeside_ s (get1 w (length s) p)
- get w (Nest k p) = nest_ k (get (w - k) p)
- get w (p `Union` q) = nicest w r (get w p) (get w q)
- get _ _ = error "best get"
-
- get1 _ _ Empty = Empty
- get1 _ _ NoDoc = NoDoc
- get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p)
- get1 w sl (TextBeside s p) = textBeside_ s (get1 w (sl + length s) p)
- get1 w sl (Nest _ p) = get1 w sl p
- get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
- (get1 w sl q)
- get1 _ _ _ = error "best get1"
-
-nicest :: Int -> Int -> Doc -> Doc -> Doc
-nicest w r = nicest1 w r 0
-
-nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc
-nicest1 w r sl p q | fits (minWR - sl) p = p
- | otherwise = q
- where minWR = if w < r then w else r
-
-fits :: Int -- Space available
- -> Doc
- -> Bool -- True if *first line* of Doc fits in space available
-fits n _ | n < 0 = False
-fits _ NoDoc = False
-fits _ Empty = True
-fits _ (NilAbove _) = True
-fits n (TextBeside s p) = fits (n - length s) p
-fits _ _ = error "fits"
--- a/src/MicroHs/StateIO.hs
+++ b/src/MicroHs/StateIO.hs
@@ -1,10 +1,18 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
-{-# OPTIONS_GHC -Wno-unused-imports #-}+{-# OPTIONS_GHC -Wno-unused-imports -Wno-dodgy-imports #-}-- State monad over IO
-module MicroHs.StateIO(module MicroHs.StateIO) where
-import Prelude --Xhiding (Monad(..), mapM)
-import qualified System.IO as IO
+module MicroHs.StateIO(
+ module MicroHs.StateIO,
+ module Control.Applicative,
+ module Control.Monad,
+ module Data.Functor,
+ ) where
+import Prelude
+import Control.Applicative
+import Control.Monad
+import Data.Functor --Xhiding(unzip)
+--import qualified System.IO as IO
--Ximport qualified CompatIO as IO
data StateIO s a = S (s -> IO (a,s))
@@ -16,61 +24,46 @@
{-execStateIO :: forall s a . StateIO s a -> s -> IO s
-execStateIO sa s = IO.do
+execStateIO sa s = do
as <- runStateIO sa s
case as of
- (_, ss) -> IO.return ss
+ (_, ss) -> return ss
-}
-(>>=) :: forall s a b . StateIO s a -> (a -> StateIO s b) -> StateIO s b
-(>>=) m k = S $ \ s -> IO.do
- (a, ss) <- runStateIO m s
- runStateIO (k a) ss
+instance forall s . Functor (StateIO s) where
+ fmap f sa = S $ \ s -> do
+ (a, ss) <- runStateIO sa s
+ return (f a, ss)
-(>>) :: forall s a b . StateIO s a -> StateIO s b -> StateIO s b
-(>>) m k = S $ \ s -> IO.do
- (_, ss) <- runStateIO m s
- runStateIO k ss
+instance forall s . Applicative (StateIO s) where
+ pure a = S $ \ s -> return (a, s)
+ (<*>) = ap
+ (*>) m k = S $ \ s -> do
+ (_, ss) <- runStateIO m s
+ runStateIO k ss
-return :: forall s a . a -> StateIO s a
-return a = S $ \ s -> IO.return (a, s)
+instance forall s . Monad (StateIO s) where
+ (>>=) m k = S $ \ s -> do
+ (a, ss) <- runStateIO m s
+ runStateIO (k a) ss
+ (>>) = (*>)
-fmap :: forall s a b . (a -> b) -> StateIO s a -> StateIO s b
-fmap f sa = S $ \ s -> IO.do
- (a, ss) <- runStateIO sa s
- IO.return (f a, ss)
+instance forall s . MonadFail (StateIO s) where
+ fail = error
gets :: forall s a . (s -> a) -> StateIO s a
-gets f = S $ \ s -> IO.return (f s, s)
+gets f = S $ \ s -> return (f s, s)
-when :: forall s . Bool -> StateIO s () -> StateIO s ()
-when b s = if b then s else MicroHs.StateIO.return ()
-
modify :: forall s . (s -> s) -> StateIO s ()
-modify f = S $ \ s -> IO.return ((), f s)
+modify f = S $ \ s -> return ((), f s)
put :: forall s . s -> StateIO s ()
-put s = S $ \ _ -> IO.return ((), s)
+put s = S $ \ _ -> return ((), s)
get :: forall s . StateIO s s
-get = S $ \ s -> IO.return (s, s)
+get = S $ \ s -> return (s, s)
liftIO :: forall s a . IO a -> StateIO s a
-liftIO io = S $ \ s -> IO.do
+liftIO io = S $ \ s -> do
a <- io
- IO.return (a, s)
-
-mapM :: forall s a b . (a -> StateIO s b) -> [a] -> StateIO s [b]
-mapM f =
- let
- rec arg =
- case arg of
- [] -> MicroHs.StateIO.return []
- a : as -> MicroHs.StateIO.do
- b <- f a
- bs <- rec as
- MicroHs.StateIO.return (b : bs)
- in rec
-
-fail :: forall s a . String -> StateIO s a
-fail = error
+ return (a, s)
--- a/src/MicroHs/TCMonad.hs
+++ b/src/MicroHs/TCMonad.hs
@@ -1,7 +1,7 @@
{-# OPTIONS_GHC -Wno-orphans -Wno-dodgy-imports -Wno-unused-imports #-}module MicroHs.TCMonad(
TC, tcRun,
- fmap, (<$>),
+ fmap, (<$>), (<*>),
(>>=), (>>), return, fail,
get, put, gets,
mapM, mapM_,
@@ -13,7 +13,9 @@
--Ximport Data.Functor.Identity
--Ximport GHC.Stack
import Data.Char -- for String
+import Control.Applicative
import Control.Monad.State.Strict --Xhiding(ap)
+import Data.Functor
import MicroHs.Ident
import MicroHs.Expr
--- a/src/MicroHs/Translate.hs
+++ b/src/MicroHs/Translate.hs
@@ -12,6 +12,7 @@
--Ximport Compat
--Wimport PrimTable
+import MicroHs.Desugar(encodeInteger)
import MicroHs.Expr
import MicroHs.Exp
import MicroHs.Ident
@@ -22,7 +23,7 @@
-- Drop all argument up to '--'
args <- getArgs
let prog = unsafeCoerce $ translate defs
- withDropArgs (length (takeWhile (not . eqString "--") args) + 1)
+ withDropArgs (length (takeWhile (/= "--") args) + 1)
prog
--translate :: (Ident, [LDef]) -> Any
@@ -29,7 +30,7 @@
translate :: (Ident, [(Ident, Exp)]) -> Any
translate (mainName, ds) =
let
- look m n = fromMaybe (error $ "not found " ++ showIdent n) $ M.lookup n m
+ look m n = fromMaybe (error $ "translate: not found " ++ showIdent n) $ M.lookup n m
mp = M.fromList [(n, trans (look mp) d) | (n, d) <- ds ]
in look mp mainName
@@ -39,9 +40,12 @@
Var n -> r n
App f a -> unsafeCoerce (trans r f) (trans r a)
Lit (LInt i) -> unsafeCoerce i
+ Lit (LDouble i) -> unsafeCoerce i
Lit (LStr s) -> trans r (encodeString s)
- Lit (LPrim p) -> fromMaybe (error $ "primlookup: " ++ p) $ lookupBy eqString p primTable
- _ -> error "trans: impossible"
+ Lit (LPrim p) -> fromMaybe (error $ "trans: no primop " ++ p) $ lookup p primTable
+ Lit (LInteger i) -> trans r (encodeInteger i)
+ Lit (LForImp s) -> trans r (App (Lit (LPrim "dynsym")) (Lit (LStr s)))
+ _ -> error $ "trans: impossible: " ++ show ae
-- Use linear search in this table.
-- 99% of the hits are among the combinators.
@@ -69,6 +73,16 @@
("rem", primitive "rem"), ("uquot", primitive "uquot"), ("urem", primitive "urem"),+ ("neg", primitive "neg"),+ ("and", primitive "and"),+ ("or", primitive "or"),+ ("xor", primitive "xor"),+ ("inv", primitive "inv"),+ ("shl", primitive "shl"),+ ("shr", primitive "shr"),+ ("ashr", primitive "ashr"),+ ("ftoraw", primitive "ftoraw"),+ ("ffromraw", primitive "ffromraw"), ("subtract", primitive "subtract"), ("==", primitive "=="), ("/=", primitive "/="),@@ -92,11 +106,14 @@
("fge", primitive "fge"), ("fshow", primitive "fshow"), ("fread", primitive "fread"),+ ("itof", primitive "itof"), ("seq", primitive "seq"), ("error", primitive "error"), ("equal", primitive "equal"), ("compare", primitive "compare"), ("rnf", primitive "rnf"),+ ("noMatch", primitive "noMatch"),+ ("noDefault", primitive "noDefault"), ("IO.>>=", primitive "IO.>>="), ("IO.>>", primitive "IO.>>"), ("IO.return", primitive "IO.return"),@@ -117,6 +134,5 @@
("IO.performIO", primitive "IO.performIO"), ("IO.getTimeMilli", primitive "IO.getTimeMilli"), ("IO.catch", primitive "IO.catch"),- ("isInt", primitive "isInt"),- ("isIO", primitive "isIO")+ ("dynsym", primitive "dynsym")]
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -1,12 +1,19 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-unused-imports #-}+{-# LANGUAGE FlexibleContexts #-}module MicroHs.TypeCheck(
typeCheck,
TModule(..), showTModule,
impossible,
+ mkClassConstructor,
+ mkSuperSel,
+ bindingsOf,
+ boolPrefix,
+ listPrefix,
) where
-import Prelude --Xhiding(showList)
+import Data.Eq -- XXX why needed?
+import Prelude
import Data.Char
import Data.List
import Data.Maybe
@@ -19,15 +26,43 @@
--Ximport GHC.Stack
--Ximport Debug.Trace
+boolPrefix :: String
+boolPrefix = "Data.Bool_Type."
+
+listPrefix :: String
+listPrefix = "Data.List_Type."
+
+nameInt :: String
+nameInt = "Primitives.Int"
+
+nameWord :: String
+nameWord = "Primitives.Word"
+
+nameDouble :: String
+nameDouble = "Primitives.Double"
+
+nameChar :: String
+nameChar = "Primitives.Char"
+
+nameInteger :: String
+nameInteger = "Data.Integer_Type.Integer"
+
+----------------------
+
data TModule a = TModule
IdentModule -- module names
[FixDef] -- all fixities, exported or not
[TypeExport] -- exported types
[SynDef] -- all type synonyms, exported or not
+ [ClsDef] -- all classes
+ [InstDef] -- all instances
[ValueExport] -- exported values (including from T(..))
a -- bindings
--Xderiving (Show)
+bindingsOf :: forall a . TModule a -> a
+bindingsOf (TModule _ _ _ _ _ _ _ a) = a
+
data TypeExport = TypeExport
Ident -- unqualified name
Entry -- symbol table entry
@@ -41,7 +76,11 @@
type FixDef = (Ident, Fixity)
type SynDef = (Ident, EType)
+type ClsDef = (Ident, ClassInfo)
+type InstDef= (Ident, InstInfo)
+type ClassInfo = ([IdKind], [EConstraint], EType, [Ident]) -- class tyvars, superclasses, methods
+
-- Symbol table entry for symbol i.
data Entry = Entry
Expr -- convert (EVar i) to this expression; sometimes just (EVar i)
@@ -48,6 +87,10 @@
EType -- type/kind of identifier
--Xderiving(Show)
+instance Eq Entry where
+ Entry x _ == Entry y _ = getIdent x == getIdent y
+
+
entryType :: Entry -> EType
entryType (Entry _ t) = t
@@ -57,7 +100,33 @@
type SynTable = M.Map EType -- body of type synonyms
type FixTable = M.Map Fixity -- precedence and associativity of operators
type AssocTable = M.Map [Ident] -- maps a type identifier to its associated construcors/selectors/methods
+type ClassTable = M.Map ClassInfo -- maps a class identifier to its associated information
+type InstTable = M.Map InstInfo -- indexed by class name
+type Constraints= [(Ident, EConstraint)]
+-- To make type checking fast it is essential to solve constraints fast.
+-- The naive implementation of InstInfo would be [InstDict], but
+-- that is slow.
+-- Instead, the data structure is specialized
+-- * For single parameter type classes for atomic types, e.g., Eq Int
+-- we use the type name (i.e., Int) to index into a map that gives
+-- the dictionary directly. This map is also used for dictionary arguments
+-- of type, e.g., Eq a.
+-- * NOT IMPLEMENTED: look up by type name of the left-most type
+-- * As a last resort, just look through dictionaries.
+data InstInfo = InstInfo
+ (M.Map Expr) -- map for direct lookup of atomic types
+ [InstDict] -- slow path
+ --Xderiving (Show)
+
+-- This is the dictionary expression, instance variables, instance context,
+-- and instance.
+type InstDictC = (Expr, [IdKind], [EConstraint], EConstraint)
+-- This is the dictionary expression, instance context, and types.
+-- An instance (C T1 ... Tn) has the type list [T1,...,Tn]
+-- The types and constraint have their type variables normalized to EUVar (-1), EUVar (-2), etc
+type InstDict = (Expr, [EConstraint], [EType])
+
type Sigma = EType
--type Tau = EType
type Rho = EType
@@ -65,27 +134,30 @@
typeCheck :: forall a . [(ImportSpec, TModule a)] -> EModule -> TModule [EDef]
typeCheck aimps (EModule mn exps defs) =
--- trace (show amdl) $
+-- trace (unlines $ map (showTModuleExps . snd) aimps) $
let
imps = map filterImports aimps
- (fs, ts, ss, vs, as) = mkTables imps
- in case tcRun (tcDefs defs) (initTC mn fs ts ss vs as) of
+ (fs, ts, ss, cs, is, vs, as) = mkTables imps
+ in case tcRun (tcDefs defs) (initTC mn fs ts ss cs is vs as) of
(tds, tcs) ->
let
thisMdl = (mn, mkTModule tds tcs)
impMdls = [(fromMaybe m mm, tm) | (ImportSpec _ m mm _, tm) <- imps]
impMap = M.fromList [(i, m) | (i, m) <- thisMdl : impMdls]
- (texps, vexps) =
- unzip $ map (getTVExps impMap (typeTable tcs) (valueTable tcs) (assocTable tcs)) exps
- fexps = [ fe | TModule _ fe _ _ _ _ <- M.elems impMap ]
- sexps = [ se | TModule _ _ _ se _ _ <- M.elems impMap ]
- in tModule mn (nubBy (eqIdent `on` fst) (concat fexps)) (concat texps) (concat sexps) (concat vexps) tds
+ (texps, cexps, vexps) =
+ unzip3 $ map (getTVExps impMap (typeTable tcs) (valueTable tcs) (assocTable tcs) (classTable tcs)) exps
+ fexps = [ fe | TModule _ fe _ _ _ _ _ _ <- M.elems impMap ]
+ sexps = M.toList (synTable tcs)
+ iexps = M.toList (instTable tcs)
+ in tModule mn (nubBy ((==) `on` fst) (concat fexps)) (concat texps) sexps (concat cexps) iexps (concat vexps) tds
-- A hack to force evaluation of errors.
-- This should be redone to all happen in the T monad.
-tModule :: IdentModule -> [FixDef] -> [TypeExport] -> [SynDef] -> [ValueExport] -> [EDef] ->
+tModule :: IdentModule -> [FixDef] -> [TypeExport] -> [SynDef] -> [ClsDef] -> [InstDef] -> [ValueExport] -> [EDef] ->
TModule [EDef]
-tModule mn fs ts ss vs ds = seqL ts `seq` seqL vs `seq` TModule mn fs ts ss vs ds
+tModule mn fs ts ss cs is vs ds =
+-- trace ("tmodule " ++ showIdent mn ++ ":\n" ++ show vs) $+ seqL ts `seq` seqL vs `seq` TModule mn fs ts ss cs is vs ds
where
seqL :: forall a . [a] -> ()
seqL [] = ()
@@ -93,9 +165,9 @@
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) =
+filterImports (imp@(ImportSpec _ _ _ (Just (hide, is))), TModule mn fx ts ss cs ins vs a) =
let
- keep x xs = elemBy eqIdent x xs `neBool` hide
+ keep x xs = elem x xs /= hide
ivs = [ i | ImpValue i <- is ]
vs' = filter (\ (ValueExport i _) -> keep i ivs) vs
cts = [ i | ImpTypeCon i <- is ]
@@ -104,27 +176,34 @@
filter (\ (TypeExport i _ _) -> keep i its) ts
in
--trace (show (ts, vs)) $
- (imp, TModule mn fx ts' ss vs' a)
+ (imp, TModule mn fx ts' ss cs ins vs' a)
-- Type and value exports
-getTVExps :: forall a . M.Map (TModule a) -> TypeTable -> ValueTable -> AssocTable -> ExportItem ->
- ([TypeExport], [ValueExport])
-getTVExps impMap _ _ _ (ExpModule m) =
+getTVExps :: forall a . M.Map (TModule a) -> TypeTable -> ValueTable -> AssocTable -> ClassTable -> ExportItem ->
+ ([TypeExport], [ClsDef], [ValueExport])
+getTVExps impMap _ _ _ _ (ExpModule m) =
case M.lookup m impMap of
- Just (TModule _ _ te _ ve _) -> (te, ve)
+ Just (TModule _ _ te _ ce _ ve _) -> (te, ce, ve)
_ -> expErr m
-getTVExps _ tys vals ast (ExpTypeCon i) =
+getTVExps _ tys vals ast cls (ExpTypeCon i) =
let
e = expLookup i tys
qi = tyQIdent e
ves = getAssocs vals ast qi
- in ([TypeExport i e ves], [])
-getTVExps _ tys _ _ (ExpType i) =
+ cl = case M.lookup qi cls of
+ Just ci -> [(qi, ci)]
+ Nothing -> []
+ in ([TypeExport i e ves], cl, [])
+getTVExps _ tys _ _ cls (ExpType i) =
let
e = expLookup i tys
- in ([TypeExport i e []], [])
-getTVExps _ _ vals _ (ExpValue i) =
- ([], [ValueExport i (expLookup i vals)])
+ qi = tyQIdent e
+ cl = case M.lookup qi cls of
+ Just ci -> [(qi, ci)]
+ Nothing -> []
+ in ([TypeExport i e []], cl, [])
+getTVExps _ _ vals _ _ (ExpValue i) =
+ ([], [], [ValueExport i (expLookup i vals)])
-- Export all fixities and synonyms.
-- The synonyms might be needed, and the fixities are harmless
@@ -141,12 +220,20 @@
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
+expErr i = errorMessage (getSLocIdent i) $ "export undefined " ++ showIdent i
+getAppCon :: EType -> Ident
+getAppCon (EVar i) = i
+getAppCon (EApp f _) = getAppCon f
+getAppCon _ = error "getAppCon"
+
+getApp :: EType -> (Ident, [EType])
+getApp = loop []
+ where loop as (EVar i) = (i, as)
+ loop as (EApp f a) = loop (a:as) f
+ loop _ _ = error "getApp"
+
-- Construct a dummy TModule for the currently compiled module.
-- It has all the relevant export tables.
-- The value&type export tables will later be filtered through the export list.
@@ -157,6 +244,8 @@
tt = typeTable tcs
at = assocTable tcs
vt = valueTable tcs
+ ct = classTable tcs
+ it = instTable tcs
-- Find the Entry for a type.
tentry i =
@@ -173,6 +262,7 @@
tes =
[ TypeExport i (tentry i) (assoc i) | Data (i, _) _ <- tds ] ++
[ TypeExport i (tentry i) (assoc i) | Newtype (i, _) _ <- tds ] ++
+ [ TypeExport i (tentry i) (assoc i) | Class _ (i, _) _ _ <- tds ] ++
[ TypeExport i (tentry i) [] | Type (i, _) _ <- tds ]
-- All type synonym definitions.
@@ -180,8 +270,15 @@
-- All fixity declaration.
fes = [ (qualIdent mn i, fx) | Infix fx is <- tds, i <- is ]
- in TModule mn fes tes ses ves impossible
+ -- All classes
+ -- XXX only export the locally defined classes
+ ces = M.toList ct
+
+ -- All instances
+ ies = M.toList it
+ in TModule mn fes tes ses ces ies ves impossible
+
-- Find all value Entry for names associated with a type.
getAssocs :: ValueTable -> AssocTable -> Ident -> [ValueExport]
getAssocs vt at ai =
@@ -191,7 +288,8 @@
_ -> impossible
in map (\ qi -> ValueExport (unQualIdent qi) (val qi)) qis
-mkTables :: forall a . [(ImportSpec, TModule a)] -> (FixTable, TypeTable, SynTable, ValueTable, AssocTable)
+mkTables :: forall a . [(ImportSpec, TModule a)] ->
+ (FixTable, TypeTable, SynTable, ClassTable, InstTable, ValueTable, AssocTable)
mkTables mdls =
let
qns (ImportSpec q _ mas _) mn i =
@@ -201,39 +299,52 @@
allValues :: ValueTable
allValues =
let
- syms (is, TModule mn _ tes _ ves _) =
+ syms (is, TModule mn _ tes _ cls _ 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 stFromListWith (unionBy eqEntry) $ concatMap syms mdls
+ [ (v, [e]) | TypeExport _ _ cs <- tes, ValueExport i e <- cs, v <- qns is mn i ] ++
+ [ (v, [Entry (EVar v) t]) | (i, (_, _, t, _)) <- cls, let { v = mkClassConstructor i } ]+ in stFromListWith union $ concatMap syms mdls
allSyns =
let
- syns (_, TModule _ _ _ ses _ _) = ses
+ syns (_, TModule _ _ _ ses _ _ _ _) = ses
in M.fromList (concatMap syns mdls)
allTypes :: TypeTable
allTypes =
let
- types (is, TModule mn _ tes _ _ _) = [ (v, [e]) | TypeExport i e _ <- tes, v <- qns is mn i ]
- in stFromListWith (unionBy eqEntry) $ concatMap types mdls
+ types (is, TModule mn _ tes _ _ _ _ _) = [ (v, [e]) | TypeExport i e _ <- tes, v <- qns is mn i ]
+ in stFromListWith union $ concatMap types mdls
allFixes =
let
- fixes (_, TModule _ fes _ _ _ _) = fes
+ fixes (_, TModule _ fes _ _ _ _ _ _) = fes
in M.fromList (concatMap fixes mdls)
allAssocs :: AssocTable
allAssocs =
let
- assocs (ImportSpec _ _ mas _, TModule mn _ tes _ _ _) =
+ assocs (ImportSpec _ _ mas _, TModule mn _ tes _ _ _ _ _) =
let
m = fromMaybe mn mas
in [ (qualIdent m i, [qualIdent m a | ValueExport a _ <- cs]) | TypeExport i _ cs <- tes ]
in M.fromList $ concatMap assocs mdls
- in (allFixes, allTypes, allSyns, allValues, allAssocs)
+ allClasses :: ClassTable
+ allClasses =
+ let
+ clss (_, TModule _ _ _ _ ces _ _ _) = ces
+ in --(\ m -> trace ("allClasses: " ++ showListS showIdentClassInfo (M.toList m)) m) $+ M.fromList $ concatMap clss mdls
+ allInsts :: InstTable
+ allInsts =
+ let
+ insts (_, TModule _ _ _ _ _ ies _ _) = ies
+ in M.fromListWith mergeInstInfo $ concatMap insts mdls
+ in (allFixes, allTypes, allSyns, allClasses, allInsts, allValues, allAssocs)
-eqEntry :: Entry -> Entry -> Bool
-eqEntry x y =
- case x of
- Entry ix _ ->
- case y of
- Entry iy _ -> eqIdent (getIdent ix) (getIdent iy)
+mergeInstInfo :: InstInfo -> InstInfo -> InstInfo
+mergeInstInfo (InstInfo m1 l1) (InstInfo m2 l2) =
+ let
+ m = foldr (uncurry $ M.insertWith mrg) m2 (M.toList m1)
+ mrg e1 _e2 = e1 -- XXX improve this if eqExpr e1 e2 then e1 else errorMessage (getSLocExpr e1) $ "Multiple instances: " ++ showSLoc (getSLocExpr e2)
+ l = unionBy eqInstDict l1 l2
+ in InstInfo m l
getIdent :: Expr -> Ident
getIdent ae =
@@ -242,11 +353,28 @@
ECon c -> conIdent c
_ -> impossible
+-- Approximate equality for dictionaries.
+-- The important thing is to avoid exact duplicates in the instance table.
+eqInstDict :: InstDict -> InstDict -> Bool
+eqInstDict (e, _, _) (e', _, _) = eqExpr e e'
+
--------------------------
type Typed a = (a, EType)
-data TCState = TC IdentModule Int FixTable TypeTable SynTable ValueTable AssocTable (IM.IntMap EType) TCMode
+data TCState = TC
+ IdentModule -- current module name
+ Int -- unique number
+ FixTable -- fixities, indexed by QIdent
+ TypeTable -- type symbol table
+ SynTable -- synonyms, indexed by QIdent
+ ValueTable -- value symbol table
+ AssocTable -- values associated with a type, indexed by QIdent
+ (IM.IntMap EType) -- mapping from unique id to type
+ TCMode -- pattern, value, or type
+ ClassTable -- class info, indexed by QIdent
+ InstTable -- instances
+ Constraints -- constraints that have to be solved
--Xderiving (Show)
data TCMode = TCExpr | TCPat | TCType
@@ -253,84 +381,149 @@
--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
+fixTable (TC _ _ ft _ _ _ _ _ _ _ _ _) = ft
assocTable :: TCState -> AssocTable
-assocTable (TC _ _ _ _ _ _ ast _ _) = ast
+assocTable (TC _ _ _ _ _ _ ast _ _ _ _ _) = ast
uvarSubst :: TCState -> IM.IntMap EType
-uvarSubst (TC _ _ _ _ _ _ _ sub _) = sub
+uvarSubst (TC _ _ _ _ _ _ _ sub _ _ _ _) = sub
moduleName :: TCState -> IdentModule
-moduleName (TC mn _ _ _ _ _ _ _ _) = mn
+moduleName (TC mn _ _ _ _ _ _ _ _ _ _ _) = mn
+classTable :: TCState -> ClassTable
+classTable (TC _ _ _ _ _ _ _ _ _ ct _ _) = ct
+
tcMode :: TCState -> TCMode
-tcMode (TC _ _ _ _ _ _ _ _ m) = m
+tcMode (TC _ _ _ _ _ _ _ _ m _ _ _) = m
+instTable :: TCState -> InstTable
+instTable (TC _ _ _ _ _ _ _ _ _ _ is _) = is
+
+constraints :: TCState -> Constraints
+constraints (TC _ _ _ _ _ _ _ _ _ _ _ e) = e
+
putValueTable :: ValueTable -> T ()
-putValueTable venv = T.do
- TC mn n fx tenv senv _ ast sub m <- get
- put (TC mn n fx tenv senv venv ast sub m)
+putValueTable venv = do
+ TC mn n fx tenv senv _ ast sub m cs is es <- get
+ put (TC mn n fx tenv senv venv ast sub m cs is es)
putTypeTable :: TypeTable -> T ()
-putTypeTable tenv = T.do
- TC mn n fx _ senv venv ast sub m <- get
- put (TC mn n fx tenv senv venv ast sub m)
+putTypeTable tenv = do
+ TC mn n fx _ senv venv ast sub m cs is es <- get
+ put (TC mn n fx tenv senv venv ast sub m cs is es)
putSynTable :: SynTable -> T ()
-putSynTable senv = T.do
- TC mn n fx tenv _ venv ast sub m <- get
- put (TC mn n fx tenv senv venv ast sub m)
+putSynTable senv = do
+ TC mn n fx tenv _ venv ast sub m cs is es <- get
+ put (TC mn n fx tenv senv venv ast sub m cs is es)
putUvarSubst :: IM.IntMap EType -> T ()
-putUvarSubst sub = T.do
- TC mn n fx tenv senv venv ast _ m <- get
- put (TC mn n fx tenv senv venv ast sub m)
+putUvarSubst sub = do
+ TC mn n fx tenv senv venv ast _ m cs is es <- get
+ put (TC mn n fx tenv senv venv ast sub m cs is es)
putTCMode :: TCMode -> T ()
-putTCMode m = T.do
- TC mn n fx tenv senv venv ast sub _ <- get
- put (TC mn n fx tenv senv venv ast sub m)
+putTCMode m = do
+ TC mn n fx tenv senv venv ast sub _ cs is es <- get
+ put (TC mn n fx tenv senv venv ast sub m cs is es)
+putInstTable :: InstTable -> T ()
+putInstTable is = do
+ TC mn n fx tenv senv venv ast sub m cs _ es <- get
+ put (TC mn n fx tenv senv venv ast sub m cs is es)
+
+putConstraints :: Constraints -> T ()
+putConstraints es = do
+ TC mn n fx tenv senv venv ast sub m cs is _ <- get
+ put (TC mn n fx tenv senv venv ast sub m cs is es)
+
withTCMode :: forall a . TCMode -> T a -> T a
-withTCMode m ta = T.do
+withTCMode m ta = do
om <- gets tcMode
putTCMode m
a <- ta
putTCMode om
- T.return a
+ return a
-- 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 fx tt st vt ast sub m <- get
- put (TC mn n fx primKindTable M.empty tt ast sub m)
+withTypeTable ta = do
+ TC mn n fx tt st vt ast sub m cs is es <- get
+ put (TC mn n fx primKindTable st tt ast sub m cs is es)
a <- ta
- TC mnr nr _ _ _ ttr astr subr mr <- get
- put (TC mnr nr fx ttr st vt astr subr mr)
- T.return a
+ -- Discard kind table, it will not have changed
+ TC mnr nr fxr _kr str ttr astr subr mr csr isr esr <- get
+ -- Keep everyting, except that the returned value table
+ -- becomes the type tables, and the old type table is restored.
+ put (TC mnr nr fxr ttr str vt astr subr mr csr isr esr)
+ return a
addAssocTable :: Ident -> [Ident] -> T ()
-addAssocTable i is = T.do
- TC mn n fx tt st vt ast sub m <- get
- put $ TC mn n fx tt st vt (M.insert i is ast) sub m
+addAssocTable i ids = do
+ TC mn n fx tt st vt ast sub m cs is es <- get
+ put $ TC mn n fx tt st vt (M.insert i ids ast) sub m cs is es
-initTC :: IdentModule -> FixTable -> TypeTable -> SynTable -> ValueTable -> AssocTable -> TCState
-initTC mn fs ts ss vs as =
--- trace ("initTC " ++ show (ts, vs)) $+addClassTable :: Ident -> ClassInfo -> T ()
+addClassTable i x = do
+ TC mn n fx tt st vt ast sub m cs is es <- get
+ put $ TC mn n fx tt st vt ast sub m (M.insert i x cs) is es
+
+addInstTable :: [InstDictC] -> T ()
+addInstTable ics = do
let
+ -- Change type variable to unique unification variables.
+ -- These unification variables will never leak, but as an extra caution
+ -- we use negative numbers..
+ freshSubst iks =
+ zipWith (\ ik j -> (idKindIdent ik, EUVar j)) iks [-1, -2 ..]
+
+ mkInstInfo :: InstDictC -> T (Ident, InstInfo)
+ mkInstInfo (e, iks, ctx, ct) = do
+ ct' <- expandSyn ct
+ case (iks, ctx, getApp ct') of
+ ([], [], (c, [EVar i])) -> return $ (c, InstInfo (M.singleton i e) [])
+ (_, _, (c, ts )) -> return $ (c, InstInfo M.empty [(e, ctx', ts')])
+ where ctx' = map (subst s) ctx
+ ts' = map (subst s) ts
+ s = freshSubst iks
+ iis <- mapM mkInstInfo ics
+ it <- gets instTable
+ putInstTable $ foldr (uncurry $ M.insertWith mergeInstInfo) it iis
+
+addConstraint :: Ident -> EConstraint -> T ()
+addConstraint d ctx = do
+-- traceM $ "addConstraint: " ++ msg ++ " " ++ showIdent d ++ " :: " ++ showEType ctx
+ ctx' <- expandSyn ctx
+ TC mn n fx tt st vt ast sub m cs is es <- get
+ put $ TC mn n fx tt st vt ast sub m cs is ((d, ctx') : es)
+
+withDict :: forall a . Ident -> EConstraint -> T a -> T a
+withDict i c ta = do
+ is <- gets instTable
+ ics <- expandDict (EVar i) c
+ addInstTable ics
+ a <- ta
+ putInstTable is
+ return a
+
+initTC :: IdentModule -> FixTable -> TypeTable -> SynTable -> ClassTable -> InstTable -> ValueTable -> AssocTable -> TCState
+initTC mn fs ts ss cs is vs as =
+-- trace ("**** initTC " ++ showIdent mn ++ ": " ++ showListS (showPairS showIdent showEType) (M.toList ss)) $+ let
xts = foldr (uncurry stInsertGlb) ts primTypes
xvs = foldr (uncurry stInsertGlb) vs primValues
- in TC mn 1 fs xts ss xvs as IM.empty TCExpr
+ in TC mn 1 fs xts ss xvs as IM.empty TCExpr cs is []
kTypeS :: EType
kTypeS = kType
@@ -341,6 +534,14 @@
kTypeTypeTypeS :: EType
kTypeTypeTypeS = kArrow kType $ kArrow kType kType
+-- (=>) :: Constraint -> Type -> Type
+kConstraintTypeTypeS :: EType
+kConstraintTypeTypeS = kArrow kConstraint $ kArrow kType kType
+
+-- (~) :: Type -> Type -> Constraint
+kTypeTypeConstraintS :: EType
+kTypeTypeConstraintS = kArrow kType (kArrow kType kConstraint)
+
builtinLoc :: SLoc
builtinLoc = SLoc "builtin" 0 0
@@ -353,10 +554,12 @@
entry i = Entry (EVar (mkIdentB i))
in stFromList [
-- 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])
+ (mkIdentB "Primitives.Type", [entry "Primitives.Type" kTypeS]),
+ (mkIdentB "Type", [entry "Primitives.Type" kTypeS]),
+ (mkIdentB "Constraint", [entry "Primitives.Constraint" kTypeS]),
+ (mkIdentB "Primitives.Constraint", [entry "Primitives.Constraint" kTypeS]),
+ (mkIdentB "Primitives.->", [entry "Primitives.->" kTypeTypeTypeS]),
+ (mkIdentB "->", [entry "Primitives.->" kTypeTypeTypeS])
]
primTypes :: [(Ident, [Entry])]
@@ -363,16 +566,23 @@
primTypes =
let
entry i = Entry (EVar (mkIdentB i))
+ k = mkIdent "k"
+ kv = EVar k
+ kk = IdKind k kTypeS
tuple n =
let
i = tupleConstr builtinLoc n
- in (i, [entry (unIdent i) $ foldr kArrow kType (replicate n kType)])
- in
+ in (i, [entry (unIdent i) $ EForall [kk] $ foldr kArrow kv (replicate n kv)])
+ in
[
- -- The function arrow is bothersome to define in Primtives, so keep it here.
+ -- The function arrow et al are bothersome to define in Primitives, so keep them here.
+ -- But the fixity is defined in Primitives.
(mkIdentB "->", [entry "Primitives.->" kTypeTypeTypeS]),
+ (mkIdentB "=>", [entry "Primitives.=>" kConstraintTypeTypeS]),
+ (mkIdentB "~", [entry "Primitives.~" kTypeTypeConstraintS]),
-- Primitives.hs uses the type [], and it's annoying to fix that.
- (mkIdentB "Data.List.[]", [entry "Data.List.[]" kTypeTypeS])
+ -- XXX should not be needed
+ (mkIdentB (listPrefix ++ "[]"), [entry (listPrefix ++ "[]") kTypeTypeS])
] ++
map tuple (enumFromTo 2 10)
@@ -382,7 +592,7 @@
tuple n =
let
c = tupleConstr builtinLoc n
- vks = [IdKind (mkIdent ("a" ++ showInt i)) kType | i <- enumFromTo 1 n]+ vks = [IdKind (mkIdent ("a" ++ show i)) kType | i <- enumFromTo 1 n]ts = map tVarK vks
r = tApps c ts
in (c, [Entry (ECon $ ConData [(c, n)] c) $ EForall vks $ foldr tArrow r ts ])
@@ -405,6 +615,9 @@
tArrow :: EType -> EType -> EType
tArrow a r = tApp (tApp (tConI builtinLoc "Primitives.->") a) r
+tImplies :: EType -> EType -> EType
+tImplies a r = tApp (tApp (tConI builtinLoc "Primitives.=>") a) r
+
kArrow :: EKind -> EKind -> EKind
kArrow = tArrow
@@ -415,9 +628,14 @@
getArrow :: EType -> Maybe (EType, EType)
getArrow (EApp (EApp (EVar n) a) b) =
- if eqIdent n (mkIdent "->") || eqIdent n (mkIdent "Primitives.->") then Just (a, b) else Nothing
+ if isIdent "->" n || isIdent "Primitives.->" n then Just (a, b) else Nothing
getArrow _ = Nothing
+getImplies :: EType -> Maybe (EType, EType)
+getImplies (EApp (EApp (EVar n) a) b) =
+ if isIdent "=>" n || isIdent "Primitives.=>" n then Just (a, b) else Nothing
+getImplies _ = Nothing
+
{-getTuple :: Int -> EType -> Maybe [EType]
getTuple n t = loop t []
@@ -427,9 +645,9 @@
-}
setUVar :: TRef -> EType -> T ()
-setUVar i t = T.do
- TC mn n fx tenv senv venv ast sub m <- get
- put (TC mn n fx tenv senv venv ast (IM.insert i t sub) m)
+setUVar i t = do
+ TC mn n fx tenv senv venv ast sub m cs is es <- get
+ put (TC mn n fx tenv senv venv ast (IM.insert i t sub) m cs is es)
getUVar :: Int -> T (Maybe EType)
getUVar i = gets (IM.lookup i . uvarSubst)
@@ -436,7 +654,7 @@
munify :: --XHasCallStack =>
SLoc -> Expected -> EType -> T ()
-munify _ (Infer r) b = tSetRefType r b
+munify loc (Infer r) b = tSetRefType loc r b
munify loc (Check a) b = unify loc a b
expandSyn :: --XHasCallStack =>
@@ -445,19 +663,19 @@
let
syn ts t =
case t of
- EApp f a -> T.do
+ EApp f a -> do
aa <- expandSyn a
syn (aa:ts) f
- EVar i -> T.do
+ EVar i -> do
syns <- gets synTable
case M.lookup i syns of
- Nothing -> T.return $ foldl tApp t ts
+ Nothing -> return $ foldl tApp t ts
Just (EForall vks tt) ->
if length vks /= length ts then tcError (getSLocIdent i) $ "bad synonym use"
--X ++ "\nXX " ++ show (i, vks, ts)
else expandSyn $ subst (zip (map idKindIdent vks) ts) tt
Just _ -> impossible
- EUVar _ -> T.return $ foldl tApp t ts
+ EUVar _ -> 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
@@ -466,26 +684,35 @@
derefUVar :: EType -> T EType
derefUVar at =
case at of
- EApp f a -> T.do
+ EApp f a -> do
fx <- derefUVar f
ax <- derefUVar a
- T.return $ EApp fx ax
- EUVar i -> T.do
+ return $ EApp fx ax
+ EUVar i -> do
mt <- getUVar i
case mt of
- Nothing -> T.return at
- Just t -> T.do
+ Nothing -> return at
+ Just t -> do
t' <- derefUVar t
setUVar i t'
- T.return t'
- EVar _ -> T.return at
+ return t'
+ EVar _ -> return at
ESign t k -> flip ESign k <$> derefUVar t
EForall iks t -> EForall iks <$> derefUVar t
_ -> impossible
+tcErrorTK :: --XHasCallStack =>
+ SLoc -> String -> T ()
+tcErrorTK loc msg = do
+ tcm <- gets tcMode
+ let s = case tcm of
+ TCType -> "kind"
+ _ -> "type"
+ tcError loc $ s ++ " error: " ++ msg
+
unify :: --XHasCallStack =>
SLoc -> EType -> EType -> T ()
-unify loc a b = T.do
+unify loc a b = do
aa <- expandSyn a
bb <- expandSyn b
unifyR loc aa bb
@@ -493,17 +720,17 @@
-- XXX should do occur check
unifyR :: --XHasCallStack =>
SLoc -> EType -> EType -> T ()
-unifyR _ (EVar x1) (EVar x2) | eqIdent x1 x2 = T.return ()
-unifyR loc (EApp f1 a1) (EApp f2 a2) = T.do { unifyR loc f1 f2; unifyR loc a1 a2 }-unifyR _ (EUVar r1) (EUVar r2) | r1 == r2 = T.return ()
+unifyR _ (EVar x1) (EVar x2) | x1 == x2 = return ()
+unifyR loc (EApp f1 a1) (EApp f2 a2) = do { unifyR loc f1 f2; unifyR loc a1 a2 }+unifyR _ (EUVar r1) (EUVar r2) | r1 == r2 = return ()
unifyR loc (EUVar r1) t2 = unifyVar loc r1 t2
unifyR loc t1 (EUVar r2) = unifyVar loc r2 t1
unifyR loc t1 t2 =
- tcError loc $ "Cannot unify " ++ showExpr t1 ++ " and " ++ showExpr t2 ++ "\n"
+ tcErrorTK loc $ "cannot unify " ++ showExpr t1 ++ " and " ++ showExpr t2
unifyVar :: --XHasCallStack =>
SLoc -> TRef -> EType -> T ()
-unifyVar loc r t = T.do
+unifyVar loc r t = do
mt <- getUVar r
case mt of
Nothing -> unifyUnboundVar loc r t
@@ -510,72 +737,25 @@
Just t' -> unify loc t' t
unifyUnboundVar :: --XHasCallStack =>
- SLoc -> TRef -> EType -> T ()
-unifyUnboundVar loc r1 at2@(EUVar r2) = T.do
+ SLoc -> TRef -> EType -> T ()
+unifyUnboundVar loc r1 at2@(EUVar r2) = do
-- We know r1 /= r2
mt2 <- getUVar r2
case mt2 of
Nothing -> setUVar r1 at2
Just t2 -> unify loc (EUVar r1) t2
-unifyUnboundVar loc r1 t2 = T.do
+unifyUnboundVar loc r1 t2 = do
vs <- getMetaTyVars [t2]
if elemBy (==) r1 vs then
- tcError loc $ "Cyclic type"
+ tcErrorTK loc $ "cyclic " ++ showExpr (EUVar r1) ++ " = " ++ showExpr t2
else
setUVar r1 t2
-{--unify :: --XHasCallStack =>
- SLoc -> EType -> EType -> T ()
-unify loc a b = T.do
--- traceM ("unify1 " ++ showExpr a ++ " = " ++ showExpr b)- aa <- expandType a
- bb <- expandType b
--- traceM ("unify2 " ++ showExpr aa ++ " = " ++ showExpr bb)- unifyR loc aa bb
-
--- XXX should do occur check
-unifyR :: --XHasCallStack =>
- SLoc -> EType -> EType -> T ()
-unifyR loc a b = T.do
- let
- bad = tcError loc $ "Cannot unify " ++ showExpr a ++ " and " ++ showExpr b ++ "\n"
- case a of
- EVar ia ->
- case b of
- EVar ib -> if eqIdent ia ib then T.return () else bad
- EApp _ _ -> bad
- EUVar i -> addUVar i a
- _ -> impossible
- EApp fa xa ->
- case b of
- EVar _ -> bad
- EApp fb xb -> T.do { unify loc fa fb; unify loc xa xb }- EUVar i -> addUVar i a
- _ ->
- --Xtrace ("impossible unify 1 " ++ showExpr a ++ " = " ++ showExpr b) $- impossible
- EUVar i -> addUVar i b
- _ -> --Xtrace ("impossible unify 2 " ++ showExpr a ++ " = " ++ showExpr b) $- impossible
--}
-
-{--unMType :: Expected -> T EType
-unMType mt =
- case mt of
- Infer r -> T.do
- t <- newUVar
- tSetRefType r t
- T.return t
- Check t -> T.return t
--}
-
--- Reset type variable and unification map
+-- Reset unification map
tcReset :: T ()
-tcReset = T.do
- TC mn u fx tenv senv venv ast _ m <- get
- put (TC mn u fx tenv senv venv ast IM.empty m)
+tcReset = do
+ TC mn u fx tenv senv venv ast _ m cs is es <- get
+ put (TC mn u fx tenv senv venv ast IM.empty m cs is es)
newUVar :: T EType
newUVar = EUVar <$> newUniq
@@ -583,41 +763,65 @@
type TRef = Int
newUniq :: T TRef
-newUniq = T.do
- TC mn n fx tenv senv venv ast sub m <- get
- put (TC mn (n+1) fx tenv senv venv ast sub m)
- T.return n
+newUniq = do
+ TC mn n fx tenv senv venv ast sub m cs is es <- get
+ let n' = n+1
+ put (seq n' $ TC mn n' fx tenv senv venv ast sub m cs is es)
+ return n
-tLookupInst :: --XHasCallStack =>
- String -> Ident -> T (Expr, EType)
-tLookupInst msg i = T.do
- (e, s) <- tLookup msg i
--- traceM ("lookup " ++ show (i, s))- t <- tInst s
- T.return (e, t)
+newIdent :: SLoc -> String -> T Ident
+newIdent loc s = do
+ u <- newUniq
+ return $ mkIdentSLoc loc $ s ++ "$" ++ show u
tLookup :: --XHasCallStack =>
String -> Ident -> T (Expr, EType)
-tLookup msg i = T.do
+tLookup msg i = do
env <- gets valueTable
case stLookup msg i env of
- Right (Entry e s) -> T.return (setSLocExpr (getSLocIdent i) e, s)
- Left e -> tcError (getSLocIdent i) e
+ Right (Entry e s) -> return (setSLocExpr (getSLocIdent i) e, s)
+ Left e -> do
+-- let SymTab m _ = env
+-- traceM (showListS showIdent (map fst (M.toList m)))
+ tcError (getSLocIdent i) e
-tInst :: EType -> T EType
-tInst as =
- case as of
- EForall vks t ->
- if null vks then T.return t
- else T.do
- let vs = map idKindIdent vks
- us <- T.mapM (const newUVar) vks
- T.return (subst (zip vs us) t)
- t -> T.return t
+tLookupV :: --XHasCallStack =>
+ Ident -> T (Expr, EType)
+tLookupV i = do
+ tcm <- gets tcMode
+ let s = case tcm of
+ TCType -> "type"
+ _ -> "value"
+ tLookup s i
+-- Maybe iterate these?
+tInst :: (Expr, EType) -> T (Expr, EType)
+tInst t = tInst' t >>= tDict >>= tInst'
+
+tInst' :: (Expr, EType) -> T (Expr, EType)
+tInst' (ae, EForall vks t) =
+ if null vks then
+ return (ae, t)
+ else do
+ let vs = map idKindIdent vks
+ us <- mapM (const newUVar) vks
+-- tInst' (ae, subst (zip vs us) t)
+ return (ae, subst (zip vs us) t)
+tInst' et = return et
+
+tDict :: (Expr, EType) -> T (Expr, EType)
+tDict (ae, at) | Just (ctx, t) <- getImplies at = do
+ u <- newUniq
+ let d = mkIdentSLoc loc ("dict$" ++ show u)+ loc = getSLocExpr ae
+ --traceM $ "addConstraint: " ++ showIdent d ++ " :: " ++ showEType ctx ++ " " ++ showSLoc loc
+ addConstraint d ctx
+ tDict (EApp ae (EVar d), t)
+tDict at = return at
+
extValE :: --XHasCallStack =>
Ident -> EType -> Expr -> T ()
-extValE i t e = T.do
+extValE i t e = do
venv <- gets valueTable
putValueTable (stInsertLcl i (Entry e t) venv)
@@ -625,7 +829,7 @@
-- Add both qualified and unqualified versions of i.
extValETop :: --XHasCallStack =>
Ident -> EType -> Expr -> T ()
-extValETop i t e = T.do
+extValETop i t e = do
mn <- gets moduleName
venv <- gets valueTable
let qi = qualIdent mn i
@@ -638,7 +842,7 @@
-- Add both qualified and unqualified versions of i.
extValQTop :: --XHasCallStack =>
Ident -> EType -> T ()
-extValQTop i t = T.do
+extValQTop i t = do
mn <- gets moduleName
extValETop i t (EVar (qualIdent mn i))
@@ -648,117 +852,134 @@
extVals :: --XHasCallStack =>
[(Ident, EType)] -> T ()
-extVals = T.mapM_ (uncurry extVal)
+extVals = mapM_ (uncurry extVal)
extTyp :: Ident -> EType -> T ()
-extTyp i t = T.do
+extTyp i t = do
tenv <- gets typeTable
putTypeTable (stInsertLcl i (Entry (EVar i) t) tenv)
extTyps :: [(Ident, EType)] -> T ()
-extTyps = T.mapM_ (uncurry extTyp)
+extTyps = mapM_ (uncurry extTyp)
extSyn :: Ident -> EType -> T ()
-extSyn i t = T.do
+extSyn i t = do
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 ast sub m <- get
- put $ TC mn n (M.insert i fx fenv) tenv senv venv ast sub m
- T.return ()
+extFix i fx = do
+ TC mn n fenv tenv senv venv ast sub m cs is es <- get
+ put $ TC mn n (M.insert i fx fenv) tenv senv venv ast sub m cs is es
+ return ()
withExtVal :: forall a . --XHasCallStack =>
Ident -> EType -> T a -> T a
-withExtVal i t ta = T.do
+withExtVal i t ta = do
venv <- gets valueTable
extVal i t
a <- ta
putValueTable venv
- T.return a
+ return a
withExtVals :: forall a . --XHasCallStack =>
[(Ident, EType)] -> T a -> T a
-withExtVals env ta = T.do
+withExtVals env ta = do
venv <- gets valueTable
extVals env
a <- ta
putValueTable venv
- T.return a
+ return a
withExtTyps :: forall a . [IdKind] -> T a -> T a
-withExtTyps iks ta = T.do
+withExtTyps iks ta = do
let env = map (\ (IdKind v k) -> (v, k)) iks
venv <- gets typeTable
extTyps env
a <- ta
putTypeTable venv
- T.return a
+ return a
tcDefs :: [EDef] -> T [EDef]
-tcDefs ds = T.do
- T.mapM_ tcAddInfix ds
+tcDefs ds = do
+ mapM_ tcAddInfix ds
dst <- tcDefsType ds
- T.mapM_ addTypeSyn dst
- tcDefsValue dst
+ mapM_ addTypeSyn dst
+ dst' <- tcExpand dst
+-- traceM (showEDefs dst')
+ tcDefsValue dst'
tcAddInfix :: EDef -> T ()
-tcAddInfix (Infix fx is) = T.do
+tcAddInfix (Infix fx is) = do
mn <- gets moduleName
- T.mapM_ (\ i -> extFix (qualIdent mn i) fx) is
-tcAddInfix _ = T.return ()
+ mapM_ (\ i -> extFix (qualIdent mn i) fx) is
+tcAddInfix _ = return ()
+-- Check type definitions
tcDefsType :: [EDef] -> T [EDef]
-tcDefsType ds = withTypeTable $ T.do
- dsk <- T.mapM tcDefKind ds -- Check&rename kinds in all type definitions
- T.mapM_ addTypeKind dsk -- Add the kind of each type to the environment
- T.mapM tcDefType dsk
+tcDefsType ds = withTypeTable $ do
+ dsk <- mapM tcDefKind ds -- Check&rename kinds in all type definitions
+ mapM_ addTypeKind dsk -- Add the kind of each type to the environment
+ mapM tcDefType dsk -- Kind check all type expressions (except local signatures)
+-- Expand class and instance definitions (must be done after type synonym processing)
+tcExpand :: [EDef] -> T [EDef]
+tcExpand dst = withTypeTable $ do
+ dsc <- mapM expandClass dst -- Expand all class definitions
+ dsi <- mapM expandInst (concat dsc) -- Expand all instance definitions
+ return (concat dsi)
+
+-- Make sure that the kind expressions are well formed.
tcDefKind :: EDef -> T EDef
-tcDefKind adef = T.do
+tcDefKind adef = do
tcReset
case adef of
- Data (i, vks) cs -> withVks vks kType $ \ vvks _ -> T.return $ Data (i, vvks) cs
- Newtype (i, vks) c -> withVks vks kType $ \ vvks _ -> T.return $ Newtype (i, vvks) c
+ Data (i, vks) cs -> withVks vks kType $ \ vvks _ -> return $ Data (i, vvks) cs
+ Newtype (i, vks) c -> withVks vks kType $ \ vvks _ -> return $ Newtype (i, vvks) c
Type (i, vks) at ->
case at of
- ESign t k -> withVks vks k $ \ vvks kr -> T.return $ Type (i, vvks) (ESign t kr)
- _ -> withVks vks kType $ \ vvks _ -> T.return $ Type (i, vvks) at
- _ -> T.return adef
+ ESign t k -> withVks vks k $ \ vvks kr -> return $ Type (i, vvks) (ESign t kr)
+ _ -> withVks vks kType $ \ vvks _ -> return $ Type (i, vvks) at
+ Class ctx (i, vks) fds ms-> withVks vks kConstraint $ \ vvks _ -> return $ Class ctx (i, vvks) fds ms
+ Instance vks ctx t d -> withVks vks kConstraint $ \ vvks _ -> return $ Instance vvks ctx t d
+ _ -> return adef
-- Check&rename the given kinds, apply reconstruction at the end
withVks :: forall a . [IdKind] -> EKind -> ([IdKind] -> EKind -> T a) -> T a
-withVks vks kr fun = T.do
+withVks vks kr fun = do
(nvks, nkr) <-
- withTypeTable $ T.do
+ withTypeTable $ do
let
- loop r [] = T.do
- kkr <- tcInferTypeT kr
- T.return (reverse r, kkr)
- loop r (IdKind i k : iks) = T.do
- kk <- tcInferTypeT k
+ loop r [] = do
+ kkr <- tInferTypeT kr
+ return (reverse r, kkr)
+ loop r (IdKind i k : iks) = do
+ kk <- tInferTypeT k
withExtVal i kk $ loop (IdKind i kk : r) iks
loop [] vks
fun nvks nkr
+-- Add symbol table entries (with kind) for all top level typeish definitions
addTypeKind :: EDef -> T ()
-addTypeKind adef = T.do
+addTypeKind adef = do
let
- addAssoc i is = T.do
+ addAssoc i is = do
mn <- gets moduleName
addAssocTable (qualIdent mn i) (map (qualIdent mn) is)
assocData (Constr c (Left _)) = [c]
assocData (Constr c (Right its)) = c : map fst its
case adef of
- Data lhs@(i, _) cs -> T.do
+ Data lhs@(i, _) cs -> do
addLHSKind lhs kType
- addAssoc i (nubBy eqIdent $ concatMap assocData cs)
- Newtype lhs@(i, _) c -> T.do
+ addAssoc i (nub $ concatMap assocData cs)
+ Newtype lhs@(i, _) c -> do
addLHSKind lhs kType
addAssoc i (assocData c)
- Type lhs t -> addLHSKind lhs (getTypeKind t)
- _ -> T.return ()
+ Type lhs t -> addLHSKind lhs (getTypeKind t)
+ Class _ lhs@(i, _) _ ms -> do
+ addLHSKind lhs kConstraint
+ addAssoc i [ m | BSign m _ <- ms ]
+ _ -> return ()
getTypeKind :: EType -> EKind
getTypeKind (ESign _ k) = k
@@ -772,89 +993,268 @@
lhsKind :: [IdKind] -> EKind -> EKind
lhsKind vks kret = foldr (\ (IdKind _ k) -> kArrow k) kret vks
--- Add type synonyms to the value table
+-- Add type synonyms to the synonym table
addTypeSyn :: EDef -> T ()
addTypeSyn adef =
case adef of
- Type (i, vs) t -> T.do
- extSyn i (EForall vs t)
+ Type (i, vs) t -> do
+ let t' = EForall vs t
+ extSyn i t'
mn <- gets moduleName
- extSyn (qualIdent mn i) (EForall vs t)
- _ -> T.return ()
+ extSyn (qualIdent mn i) t'
+ _ -> return ()
+-- Do kind checking of all typeish definitions.
tcDefType :: EDef -> T EDef
-tcDefType d = T.do
+tcDefType d = do
tcReset
case d of
- Data lhs cs -> Data lhs <$> withVars (snd lhs) (T.mapM tcConstr cs)
- Newtype lhs c -> Newtype lhs <$> withVars (snd lhs) (tcConstr c)
- Type lhs t -> Type lhs <$> withVars (snd lhs) (tcInferTypeT t)
- Sign i t -> (Sign i ) <$> tcTypeT (Check kType) t
- ForImp ie i t -> (ForImp ie i) <$> tcTypeT (Check kType) t
- _ -> T.return d
+ Data lhs@(_, iks) cs -> withVars iks $ Data lhs <$> mapM tcConstr cs
+ Newtype lhs@(_, iks) c -> withVars iks $ Newtype lhs <$> tcConstr c
+ Type lhs@(_, iks) t -> withVars iks $ Type lhs <$> tInferTypeT t
+ Sign i t -> Sign i <$> tCheckTypeT kType t
+ ForImp ie i t -> ForImp ie i <$> tCheckTypeT kType t
+ Class ctx lhs@(_, iks) fds ms -> withVars iks $ Class <$> tcCtx ctx <*> return lhs <*> mapM tcFD fds <*> mapM tcMethod ms
+ Instance iks ctx c m -> withVars iks $ Instance iks <$> tcCtx ctx <*> tCheckTypeT kConstraint c <*> return m
+ _ -> return d
+ where
+ tcCtx = mapM (tCheckTypeT kConstraint)
+ tcMethod (BSign i t) = BSign i <$> tcTypeT (Check kType) t
+ tcMethod m = return m
+ tcFD (is, os) = (,) <$> mapM tcV is <*> mapM tcV os
+ where tcV i = do { _ <- tLookup "fundep" i; return i }withVars :: forall a . [IdKind] -> T a -> T a
withVars aiks ta =
case aiks of
[] -> ta
- IdKind i k : iks -> T.do
+ IdKind i k : iks -> do
withExtVal i k $ withVars iks ta
tcConstr :: Constr -> T Constr
tcConstr (Constr c ets) =
- Constr c <$> either (\ x -> Left T.<$> T.mapM (\ t -> tcTypeT (Check kType) t) x)
- (\ x -> Right T.<$> T.mapM (\ (i,t) -> (i,) <$> tcTypeT (Check kType) t) x) ets
+ Constr c <$> either (\ x -> Left <$> mapM (\ t -> tcTypeT (Check kType) t) x)
+ (\ x -> Right <$> mapM (\ (i,t) -> (i,) <$> tcTypeT (Check kType) t) x) ets
+
+-- Expand a class defintion to
+-- * a "data" type for the dictionary, with kind Constraint
+-- * superclass selectors
+-- * method selectors
+-- * default methods
+-- E.g.
+-- class Eq a where
+-- (==) :: a -> a -> Bool
+-- (/=) :: a -> a -> a
+-- x /= y = not (x == y)
+-- expands to
+-- data Eq a = Eq$ (a -> a -> Bool) (a -> a -> Bool)
+-- :: Constraint
+-- == :: forall a . Eq a -> (a -> a -> Bool)
+-- == (Eq x _) = x
+-- /= :: forall a . Eq a -> (a -> a -> Bool)
+-- /= (Eq _ x) = x
+-- ==$dflt :: forall a . (Eq a) => (a -> a -> Bool)
+-- ==$dflt = _noDefault "Eq.=="
+-- /=$dflt :: forall a . (Eq a) => (a -> a -> Bool)
+-- /=$dflt x y = not (x == y)
+--
+-- class (Eq a) => Ord a where
+-- (<=) :: a -> a -> Bool
+-- expands to
+-- data Ord a = Ord$ (Eq a) (a -> a -> Bool)
+-- Ord$super1 :: forall a . Ord a -> Eq a
+-- <= :: forall a . Ord a -> (a -> a -> Bool)
+-- <=$dflt = _noDefault "Ord.<="
+--
+-- instance Eq Int where (==) = primEqInt
+-- expands to
+-- inst$999 = Eq$ meth$1 meth$2
+-- where meth$1 = primEqInt
+-- meth$2 = /=$dflt dict$999
+--
+-- instance Ord Int where (<=) = primLEInt
+-- expands to
+-- inst$888 = Ord$ dict$ meth$1
+-- where meth$1 = primLEInt
+-- where dict$ is a special magic identifier that the type checker expands
+-- to whatever dictionary is forced by the type.
+-- In this case (dict$ :: Eq Int), so it with be inst$999
+--
+-- The actual definitions for the constructor and methods are added
+-- in the desugaring pass.
+-- Default methods are added as actual definitions.
+-- The constructor and methods are added to the symbol table in addValueType.
+-- XXX FunDep
+expandClass :: EDef -> T [EDef]
+expandClass dcls@(Class ctx (iCls, vks) _fds ms) = do
+ mn <- gets moduleName
+ let
+ meths = [ b | b@(BSign _ _) <- ms ]
+ methIds = map (\ (BSign i _) -> i) meths
+ mdflts = [ (i, eqns) | BFcn i eqns <- ms ]
+ tCtx = tApps (qualIdent mn iCls) (map (EVar . idKindIdent) vks)
+ mkDflt (BSign methId t) = [ Sign iDflt $ EForall vks $ tCtx `tImplies` t, def $ lookup methId mdflts ]
+ where def Nothing = Fcn iDflt [Eqn [] $ EAlts [([], noDflt)] []]
+ def (Just eqns) = Fcn iDflt eqns
+ iDflt = mkDefaultMethodId methId
+ -- XXX This isn't right, "Prelude._nodefault" might not be in scope
+ noDflt = EApp noDefaultE (ELit noSLoc (LStr (unIdent iCls ++ "." ++ unIdent methId)))
+ mkDflt _ = impossible
+ dDflts = concatMap mkDflt meths
+ addClassTable (qualIdent mn iCls) (vks, ctx, EUVar 0, methIds) -- Initial entry, no type needed.
+ return $ dcls : dDflts
+expandClass d = return [d]
+
+noDefaultE :: Expr
+noDefaultE = ELit noSLoc $ LPrim "noDefault"
+
+-- Turn (unqualified) class and method names into a default method name
+mkDefaultMethodId :: Ident -> Ident
+mkDefaultMethodId meth = addIdentSuffix meth "$dflt"
+
+{-+clsToDict :: EType -> T EType
+clsToDict = do
+ -- XXX for now, only allow contexts of the form (C t1 ... tn)
+ let usup as (EVar c) | isConIdent c = return (tApps c as)
+ usup as (EApp f a) = usup (a:as) f
+ usup _ t = tcError (getSLocExpr t) ("bad context " ++ showEType t)+ usup []
+-}
+
+addConstraints :: [EConstraint] -> EType -> EType
+addConstraints [] t = t
+addConstraints cs t = tupleConstraints cs `tImplies` t
+
+tupleConstraints :: [EConstraint] -> EConstraint
+tupleConstraints [] = error "tupleConstraints"
+tupleConstraints [c] = c
+tupleConstraints cs = tApps (tupleConstr noSLoc (length cs)) cs
+
+expandInst :: EDef -> T [EDef]
+expandInst dinst@(Instance vks ctx cc bs) = do
+ let loc = getSLocExpr cc
+ qiCls = getAppCon cc
+ iInst <- newIdent loc "inst"
+ let sign = Sign iInst (eForall vks $ addConstraints ctx cc)
+-- (e, _) <- tLookupV iCls
+ ct <- gets classTable
+-- let qiCls = getAppCon e
+ (_, supers, _, mis) <-
+ case M.lookup qiCls ct of
+ Nothing -> tcError loc $ "not a class " ++ showIdent qiCls
+ Just x -> return x
+ -- XXX this ignores type signatures and other bindings
+ -- XXX should tack on signatures with ESign
+ let ies = [(i, ELam qs) | BFcn i qs <- bs]
+ meth i = fromMaybe (EVar $ setSLocIdent loc $ mkDefaultMethodId i) $ lookup i ies
+ meths = map meth mis
+ sups = map (const (EVar $ mkIdentSLoc loc "dict$")) supers
+ args = sups ++ meths
+ let bind = Fcn iInst $ eEqns [] $ foldl EApp (EVar $ mkClassConstructor qiCls) args
+ mn <- gets moduleName
+ addInstTable [(EVar $ qualIdent mn iInst, vks, ctx, cc)]
+ return [dinst, sign, bind]
+expandInst d = return [d]
+
+eForall :: [IdKind] -> EType -> EType
+eForall [] t = t
+eForall vs t = EForall vs t
+
+---------------------
+
tcDefsValue :: [EDef] -> T [EDef]
-tcDefsValue ds = T.do
- T.mapM_ addValueType ds
- T.mapM (\ d -> T.do { tcReset; tcDefValue d}) ds+tcDefsValue ds = do
+ mapM_ addValueType ds
+ mapM (\ d -> do { tcReset; tcDefValue d}) dsaddValueType :: EDef -> T ()
-addValueType adef = T.do
+addValueType adef = do
mn <- gets moduleName
case adef of
Sign i t -> extValQTop i t
- Data (i, vks) cs -> T.do
+ Data (i, vks) cs -> do
let
cti = [ (qualIdent mn c, either length length ets) | Constr c ets <- cs ]
tret = foldl tApp (tCon (qualIdent mn i)) (map tVarK vks)
- addCon (Constr c ets) = T.do
+ addCon (Constr c ets) = do
let ts = either id (map snd) ets
extValETop c (EForall vks $ foldr tArrow tret ts) (ECon $ ConData cti (qualIdent mn c))
- T.mapM_ addCon cs
- Newtype (i, vks) (Constr c fs) -> T.do
+ mapM_ addCon cs
+ Newtype (i, vks) (Constr c fs) -> do
let
t = head $ either id (map snd) fs
tret = foldl tApp (tCon (qualIdent mn i)) (map tVarK vks)
extValETop c (EForall vks $ tArrow t tret) (ECon $ ConNew (qualIdent mn c))
ForImp _ i t -> extValQTop i t
- _ -> T.return ()
+ Class ctx (i, vks) fds ms -> addValueClass ctx i vks fds ms
+ _ -> return ()
+-- XXX FunDep
+addValueClass :: [EConstraint] -> Ident -> [IdKind] -> [FunDep] -> [EBind] -> T ()
+addValueClass ctx iCls vks _fds ms = do
+ mn <- gets moduleName
+ let
+ meths = [ b | b@(BSign _ _) <- ms ]
+ methTys = map (\ (BSign _ t) -> t) meths
+ methIds = map (\ (BSign i _) -> i) meths
+ supTys = ctx -- XXX should do some checking
+ targs = supTys ++ methTys
+ qiCls = qualIdent mn iCls
+ tret = tApps qiCls (map tVarK vks)
+ cti = [ (qualIdent mn iCon, length targs) ]
+ iCon = mkClassConstructor iCls
+ iConTy = EForall vks $ foldr tArrow tret targs
+ extValETop iCon iConTy (ECon $ ConData cti (qualIdent mn iCon))
+ let addMethod (BSign i t) = extValETop i (EForall vks $ tApps qiCls (map (EVar . idKindIdent) vks) `tImplies` t) (EVar $ qualIdent mn i)
+ addMethod _ = impossible
+-- traceM ("addValueClass " ++ showEType (ETuple ctx))+ mapM_ addMethod meths
+ -- Update class table, now with actual constructor type.
+ addClassTable qiCls (vks, ctx, iConTy, methIds)
+
+{-+bundleConstraints :: [EConstraint] -> EType -> EType
+bundleConstraints [] t = t
+bundleConstraints [c] t = tImplies c t
+bundleConstraints cs t = tImplies (ETuple cs) t
+-}
+
+mkClassConstructor :: Ident -> Ident
+mkClassConstructor i = addIdentSuffix i "$C"
+
+{-unForall :: EType -> ([IdKind], EType)
unForall (EForall iks t) = (iks, t)
unForall t = ([], t)
+-}
tcDefValue :: --XHasCallStack =>
EDef -> T EDef
tcDefValue adef =
case adef of
- Fcn i eqns -> T.do
--- traceM $ "tcDefValue: " ++ show i -- ++ " = " ++ showExpr rhs
- (_, tt) <- tLookup "no type signature" i
- let (iks, tfn) = unForall tt
+ Fcn i eqns -> do
+ (_, tt) <- tLookup "type signature" i
+-- traceM $ "tcDefValue: " ++ showIdent i ++ " :: " ++ showExpr tt
+-- traceM $ "tcDefValue: def=" ++ showEDefs [adef]
mn <- gets moduleName
- teqns <- withExtTyps iks $ tcEqns tfn eqns
--- traceM (showEDefs [Fcn i eqns, Fcn i teqns])
- T.return $ Fcn (qualIdent mn i) teqns
- ForImp ie i t -> T.do
+ teqns <- tcEqns tt eqns
+-- traceM ("tcDefValue: after " ++ showEDefs [adef, Fcn i teqns])+ -- Defaulting should be done here
+ checkConstraints
+ return $ Fcn (qualIdent mn i) teqns
+ ForImp ie i t -> do
mn <- gets moduleName
- T.return (ForImp ie (qualIdent mn i) t)
- _ -> T.return adef
+ return (ForImp ie (qualIdent mn i) t)
+ _ -> return adef
-tcInferTypeT :: EType -> T EType
-tcInferTypeT t = fst <$> tInfer tcTypeT t
+tCheckTypeT :: EType -> EType -> T EType
+tCheckTypeT = tCheck tcTypeT
+tInferTypeT :: EType -> T EType
+tInferTypeT t = fst <$> tInfer tcTypeT t
+
-- Kind check a type while already in type checking mode
tcTypeT :: --XHasCallStack =>
Expected -> EType -> T EType
@@ -881,11 +1281,11 @@
tInfer :: forall a . --XHasCallStack =>
(Expected -> a -> T a) -> a -> T (Typed a)
-tInfer tc a = T.do
+tInfer tc a = do
ref <- newUniq
a' <- tc (Infer ref) a
t <- tGetRefType ref
- T.return (a', t)
+ return (a', t)
tCheck :: forall a . (Expected -> a -> T a) -> EType -> a -> T a
tCheck tc t = tc (Check t)
@@ -896,138 +1296,194 @@
tCheckExpr :: --XHasCallStack =>
EType -> Expr -> T Expr
-tCheckExpr = tCheck tcExpr
+tCheckExpr t e | Just (ctx, t') <- getImplies t = do
+ _ <- undefined -- XXX
+ u <- newUniq
+ let d = mkIdentSLoc (getSLocExpr e) ("adict$" ++ show u)+ e' <- withDict d ctx $ tCheckExpr t' e
+ return $ eLam [EVar d] e'
+tCheckExpr t e = tCheck tcExpr t e
tGetRefType :: --XHasCallStack =>
TRef -> T EType
-tGetRefType ref = T.do
+tGetRefType ref = do
m <- gets uvarSubst
case IM.lookup ref m of
- Nothing -> error "tGetRefType"
- Just t -> T.return t
+ Nothing -> return (EUVar ref) -- error "tGetRefType"
+ Just t -> return t
-- Set the type for an Infer
tSetRefType :: --XHasCallStack =>
- TRef -> EType -> T ()
-tSetRefType ref t = T.do
+ SLoc -> TRef -> EType -> T ()
+tSetRefType loc ref t = do
m <- gets uvarSubst
case IM.lookup ref m of
Nothing -> putUvarSubst (IM.insert ref t m)
- Just _ -> error "tSetRefType"
+ Just tt -> unify loc tt t
-- Get the type of an already set Expected
tGetExpType :: Expected -> T EType
-tGetExpType (Check t) = T.return t
+tGetExpType (Check t) = return t
tGetExpType (Infer r) = tGetRefType r
--- Get the type of an unset Expected
-tGetExpTypeSet :: Expected -> T EType
-tGetExpTypeSet (Check t) = T.return t
-tGetExpTypeSet (Infer r) = T.do
+{-+-- Get the type of a possibly unset Expected
+tGetExpTypeSet :: SLoc -> Expected -> T EType
+tGetExpTypeSet _ (Check t) = return t
+tGetExpTypeSet loc (Infer r) = tGetRefType r {-dot <- newUVar
- tSetRefType r t
- T.return t
+ tSetRefType loc r t
+ return t-}
+-}
tcExpr :: --XHasCallStack =>
Expected -> Expr -> T Expr
-tcExpr mt ae = T.do
--- traceM ("tcExpr enter: " ++ showExpr ae ++ " :: " ++ showMaybe showExpr mt)+tcExpr mt ae = do
+-- traceM ("tcExpr enter: " ++ showExpr ae)r <- tcExprR mt ae
--- t <- expandType (snd r)
--- traceM ("tcExpr exit: " ++ showExpr (fst r) ++ " :: " ++ showExpr t)- T.return r
+-- traceM ("tcExpr exit: " ++ showExpr r)+ return r
tcExprR :: --XHasCallStack =>
Expected -> Expr -> T Expr
tcExprR mt ae =
let { loc = getSLocExpr ae } incase ae of
- EVar i -> T.do
+ EVar i -> do
tcm <- gets tcMode
case tcm of
- TCPat | isDummyIdent i -> T.do
+ TCPat | isDummyIdent i -> do
-- _ can be anything, so just ignore it
- _ <- tGetExpTypeSet mt
- T.return ae
+ _ <- tGetExpType mt
+ return ae
- | isConIdent i -> T.do
- (p, pt) <- tLookupInst "constructor" i
+ | isConIdent i -> do
+ ipt <- tLookupV i
+ (p, pt) <- tInst' ipt -- XXX
-- We will only have an expected type for a non-nullary constructor
case mt of
- Check ext -> subsCheck loc ext pt
- Infer r -> tSetRefType r pt
- T.return p
+ Check ext -> subsCheck loc p ext pt
+ Infer r -> do { tSetRefType loc r pt; return p }- | otherwise -> T.do
+ | otherwise -> do
-- All pattern variables are in the environment as
-- type references. Assign the reference the given type.
- ext <- tGetExpTypeSet mt
- (p, t) <- tLookup "IMPOSSIBLE" i
+ ext <- tGetExpType mt
+ (p, t) <- tLookupV i
case t of
- EUVar r -> tSetRefType r ext
+ EUVar r -> tSetRefType loc r ext
_ -> impossible
- T.return p
+ return p
- _ -> T.do
+ _ | isIdent "dict$" i -> do
+ -- Magic variable that just becomes the dictionary
+ d <- newIdent (getSLocIdent i) "dict$"
+ case mt of
+ Infer _ -> impossible
+ Check t -> addConstraint d t
+ return (EVar d)
+
+ _ -> do
-- Type checking an expression (or type)
- T.when (isDummyIdent i) impossible
- (e, t) <- tLookup "variable" i
- -- Variables bound in patterns start with an (EUVar ref) type,
+ when (isDummyIdent i) impossible
+ (e, t) <- tLookupV i
+ -- Variables bound in patterns start out with an (EUVar ref) type,
-- which can be instantiated to a polytype.
-- Dereference such a ref.
t' <-
case t of
- EUVar r -> T.fmap (fromMaybe t) (getUVar r)
- _ -> T.return t
+ EUVar r -> fmap (fromMaybe t) (getUVar r)
+ _ -> return t
-- traceM ("EVar " ++ showIdent i ++ " :: " ++ showExpr t ++ " = " ++ showExpr t')- instSigma loc t' mt
- T.return e
+ instSigma loc e t' mt
- EApp f a -> T.do
+ EApp f a -> do
(f', ft) <- tInferExpr f
+-- traceM $ "EApp f=" ++ showExpr f ++ "; e'=" ++ showExpr f' ++ " :: " ++ showEType ft
(at, rt) <- unArrow loc ft
tcm <- gets tcMode
+-- traceM ("tcExpr EApp: " ++ showExpr f ++ " :: " ++ showEType ft)case tcm of
- TCPat -> T.do
+ TCPat -> do
a' <- tCheckExpr at a
instPatSigma loc rt mt
- T.return (EApp f' a')
- _ -> T.do
+ return (EApp f' a')
+ _ -> do
a' <- checkSigma a at
- instSigma loc rt mt
- T.return (EApp f' a')
+ instSigma loc (EApp f' a') rt mt
- EOper e ies -> T.do e' <- tcOper e ies; tcExpr mt e'
+ EOper e ies -> do e' <- tcOper e ies; tcExpr mt e'
ELam qs -> tcExprLam mt qs
- ELit loc' l -> tcLit mt loc' l
- ECase a arms -> T.do
+ ELit loc' l -> do
+ tcm <- gets tcMode
+-- traceM ("tcExpr EApp: " ++ showExpr f ++ " :: " ++ showEType ft)+ case tcm of
+ -- XXX This is temporary hack. Don't allow polymorphic constrants in patterns
+ TCPat ->
+ case l of
+ LInteger i -> tcLit mt loc' (LInt (_integerToInt i))
+ _ -> tcLit mt loc' l
+ _ -> do
+ let getExpected (Infer _) = pure Nothing
+ getExpected (Check t) = do
+ t' <- derefUVar t >>= expandSyn
+ case t' of
+ EVar v -> pure (Just v)
+ _ -> pure Nothing
+ case l of
+ LInteger i -> do
+ mex <- getExpected mt
+ case mex of
+ -- Convert to Int in the compiler, that way (99::Int) will never involve fromInteger
+ -- (which is not always in scope).
+ Just v | v == mkIdent nameInt -> tcLit mt loc' (LInt (_integerToInt i))
+ | v == mkIdent nameWord -> tcLit' mt loc' (LInt (_integerToInt i)) (tConI loc' nameWord)
+ | v == mkIdent nameDouble -> tcLit mt loc' (LDouble (_integerToDouble i))
+ | v == mkIdent nameInteger -> tcLit mt loc' l
+ _ -> do
+ (f, ft) <- tInferExpr (EVar (mkIdentSLoc loc' "fromInteger")) -- XXX should have this qualified somehow
+ (_at, rt) <- unArrow loc ft
+ -- We don't need to check that _at is Integer, it's part of the fromInteger type.
+ instSigma loc (EApp f ae) rt mt
+ LRat r -> do
+ mex <- getExpected mt
+ case mex of
+ Just v | v == mkIdent nameDouble -> tcLit mt loc' (LDouble (fromRational r))
+ _ -> do
+ (f, ft) <- tInferExpr (EVar (mkIdentSLoc loc' "fromRational")) -- XXX should have this qualified somehow
+ (_at, rt) <- unArrow loc ft
+ -- We don't need to check that _at is Rational, it's part of the fromRational type.
+ instSigma loc (EApp f ae) rt mt
+ -- Not LInteger, LRat
+ _ -> tcLit mt loc' l
+ ECase a arms -> do
(ea, ta) <- tInferExpr a
- tt <- tGetExpTypeSet mt
- earms <- T.mapM (tcArm tt ta) arms
- T.return (ECase ea earms)
- ELet bs a -> tcBinds bs $ \ ebs -> T.do { ea <- tcExpr mt a; T.return (ELet ebs ea) }- ETuple es -> T.do
+ tt <- tGetExpType mt
+ earms <- mapM (tcArm tt ta) arms
+ return (ECase ea earms)
+ ELet bs a -> tcBinds bs $ \ ebs -> do { ea <- tcExpr mt a; return (ELet ebs ea) }+ ETuple es -> do
let
n = length es
- (ees, tes) <- T.fmap unzip (T.mapM tInferExpr es)
+ (ees, tes) <- fmap unzip (mapM tInferExpr es)
let
ttup = tApps (tupleConstr loc n) tes
munify loc mt ttup
- T.return (ETuple ees)
- EDo mmn ass -> T.do
+ return (ETuple ees)
+ EDo mmn ass -> do
case ass of
[] -> impossible
[as] ->
case as of
SThen a -> tcExpr mt a
- _ -> tcError loc $ "bad do "
- as : ss -> T.do
+ _ -> tcError loc $ "bad final do statement"
+ as : ss -> do
case as of
- SBind p a -> T.do
+ SBind p a -> 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
+ SThen a -> do
let
sthen = maybe (mkIdentSLoc loc ">>") (\ mn -> qualIdent mn (mkIdentSLoc loc ">>") ) mmn
tcExpr mt (EApp (EApp (EVar sthen) a) (EDo mmn ss))
@@ -1036,44 +1492,44 @@
tcExpr mt (ELet bs (EDo mmn ss))
ESectL e i -> tcExpr mt (EApp (EVar i) e)
- ESectR i e -> T.do
+ ESectR i e -> do
let x = eVarI loc "$x"
tcExpr mt (eLam [x] (EApp (EApp (EVar i) x) e))
- EIf e1 e2 e3 -> T.do
+ EIf e1 e2 e3 -> do
e1' <- tCheckExpr (tBool (getSLocExpr e1)) e1
case mt of
- Check t -> T.do
+ Check t -> do
e2' <- checkSigma e2 t
e3' <- checkSigma e3 t
- T.return (EIf e1' e2' e3')
- Infer ref -> T.do
- (e2', t1) <- tInferExpr e2
- (e3', t2) <- tInferExpr e3
- subsCheck loc t1 t2
- subsCheck loc t2 t1
- tSetRefType ref t1
- T.return (EIf e1' e2' e3')
+ return (EIf e1' e2' e3')
+ Infer ref -> do
+ (e2', t2) <- tInferExpr e2
+ (e3', t3) <- tInferExpr e3
+ e2'' <- subsCheck loc e2' t2 t3
+ e3'' <- subsCheck loc e3' t3 t2
+ tSetRefType loc ref t2
+ return (EIf e1' e2'' e3'')
- EListish (LList es) -> T.do
+ EListish (LList es) -> do
te <- newUVar
munify loc mt (tApp (tList loc) te)
- es' <- T.mapM (tCheckExpr te) es
- T.return (EListish (LList es'))
- EListish (LCompr eret ass) -> T.do
+ es' <- mapM (tCheckExpr te) es
+ return (EListish (LList es'))
+ EListish (LCompr eret ass) -> do
let
doStmts :: [EStmt] -> [EStmt] -> T ([EStmt], Typed Expr)
doStmts rss xs =
case xs of
- [] -> T.do
+ [] -> do
r <- tInferExpr eret
- T.return (reverse rss, r)
+ return (reverse rss, r)
as : ss ->
case as of
- SBind p a -> T.do
+ SBind p a -> do
v <- newUVar
ea <- tCheckExpr (tApp (tList loc) v) a
tCheckPat v p $ \ ep -> doStmts (SBind ep ea : rss) ss
- SThen a -> T.do
+ SThen a -> do
ea <- tCheckExpr (tBool (getSLocExpr a)) a
doStmts (SThen ea : rss) ss
SLet bs ->
@@ -1083,33 +1539,33 @@
let
tr = tApp (tList loc) ta
munify loc mt tr
- T.return (EListish (LCompr ea rss))
+ return (EListish (LCompr ea rss))
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
+ ESign e t -> do
t' <- tcType (Check kType) t
tcm <- gets tcMode
case tcm of
- TCPat -> T.do
+ TCPat -> do
instPatSigma loc t' mt
tCheckExpr t' e
- _ -> T.do
- instSigma loc t' mt
- checkSigma e t'
- EAt i e -> T.do
- (_, ti) <- tLookup "IMPOSSIBLE" i
+ _ -> do
+ e' <- instSigma loc e t' mt
+ checkSigma e' t'
+ EAt i e -> do
+ (_, ti) <- tLookupV i
e' <- tcExpr mt e
tt <- tGetExpType mt
case ti of
- EUVar r -> tSetRefType r tt
+ EUVar r -> tSetRefType loc r tt
_ -> impossible
- T.return (EAt i e')
+ return (EAt i e')
EForall vks t ->
- withVks vks kType $ \ vvks _ -> T.do
+ withVks vks kType $ \ vvks _ -> do
tt <- withVars vvks (tcExpr mt t)
- T.return (EForall vvks tt)
+ return (EForall vvks tt)
_ -> impossible
enum :: SLoc -> String -> [Expr] -> Expr
@@ -1116,20 +1572,24 @@
enum loc f = foldl EApp (EVar (mkIdentSLoc loc ("enum" ++ f)))tcLit :: Expected -> SLoc -> Lit -> T Expr
-tcLit mt loc l = T.do
- let lit t = instSigma loc t mt
- case l of
- 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 _ -> newUVar T.>>= lit -- pretend it is anything
- LForImp _ -> impossible
- T.return (ELit loc l)
+tcLit mt loc l@(LPrim _) = newUVar >>= tcLit' mt loc l
+tcLit mt loc l = do
+ let t =
+ case l of
+ LInt _ -> tConI loc nameInt
+ LInteger _ -> tConI loc nameInteger
+ LDouble _ -> tConI loc nameDouble
+ LChar _ -> tConI loc nameChar
+ LStr _ -> tApp (tList loc) (tConI loc nameChar)
+ _ -> impossible
+ tcLit' mt loc l t
+tcLit' :: Expected -> SLoc -> Lit -> EType -> T Expr
+tcLit' mt loc l t = instSigma loc (ELit loc l) t mt
+
tcOper :: --XHasCallStack =>
Expr -> [(Ident, Expr)] -> T Expr
-tcOper ae aies = T.do
+tcOper ae aies = do
let
doOp (e1:e2:es) o os ies =
let e = EApp (EApp o e2) e1
@@ -1141,9 +1601,9 @@
calc es ((o, _):os) [] = doOp es o os []
calc es oos@((oy, (ay, py)):os) iies@((oo@(ox, (ax, px)), e) : ies) =
-- traceM (show ((unIdent (getIdent (fst o)), ay, py), (unIdent i, ax, px)))
- if px == py && (not (eqAssoc ax ay) || eqAssoc ax AssocNone) then
- errorMessage (getSLocExpr ox) "Ambiguous operator expression"
- else if px < py || eqAssoc ax AssocLeft && px == py then
+ if px == py && (ax /= ay || ax == AssocNone) then
+ errorMessage (getSLocExpr ox) "ambiguous operator expression"
+ else if px < py || ax == AssocLeft && px == py then
doOp es oy os iies
else
calc (e:es) (oo : oos) ies
@@ -1152,26 +1612,26 @@
calc _ _ _ = impossible
opfix :: FixTable -> (Ident, Expr) -> T ((Expr, Fixity), Expr)
- opfix fixs (i, e) = T.do
- (ei, _) <- tLookup "operator" i
+ opfix fixs (i, e) = do
+ (ei, _) <- tLookupV i
let fx = getFixity fixs (getIdent ei)
- T.return ((EVar i, fx), e)
+ return ((EVar i, fx), e)
fixs <- gets fixTable
-- traceM $ unlines $ map show [(unIdent i, fx) | (i, fx) <- M.toList fixs]
- ites <- T.mapM (opfix fixs) aies
- T.return $ calc [ae] [] ites
+ ites <- mapM (opfix fixs) aies
+ return $ calc [ae] [] ites
unArrow :: --XHasCallStack =>
SLoc -> EType -> T (EType, EType)
-unArrow loc t = T.do
+unArrow loc t = do
case getArrow t of
- Just ar -> T.return ar
- Nothing -> T.do
+ Just ar -> return ar
+ Nothing -> do
a <- newUVar
r <- newUVar
unify loc t (tArrow a r)
- T.return (a, r)
+ return (a, r)
getFixity :: FixTable -> Ident -> Fixity
getFixity fixs i = fromMaybe (AssocLeft, 9) $ M.lookup i fixs
@@ -1178,31 +1638,60 @@
tcPats :: forall a . EType -> [EPat] -> (EType -> [EPat] -> T a) -> T a
tcPats t [] ta = ta t []
-tcPats t (p:ps) ta = T.do
+tcPats t (p:ps) ta = do
(tp, tr) <- unArrow (getSLocExpr p) t
tCheckPat tp p $ \ pp -> tcPats tr ps $ \ tt pps -> ta tt (pp : pps)
tcExprLam :: Expected -> [Eqn] -> T Expr
-tcExprLam mt qs = T.do
- t <- tGetExpTypeSet mt
+tcExprLam mt qs = do
+ t <- tGetExpType mt
ELam <$> tcEqns t qs
tcEqns :: EType -> [Eqn] -> T [Eqn]
-tcEqns t eqns = T.mapM (tcEqn t) eqns
+--tcEqns t eqns | trace ("tcEqns: " ++ showEBind (BFcn dummyIdent eqns) ++ " :: " ++ showEType t) False = undefined+tcEqns (EForall iks t) eqns = withExtTyps iks $ tcEqns t eqns
+tcEqns t eqns | Just (ctx, t') <- getImplies t = do
+ let loc = getSLocEqns eqns
+ d <- newIdent loc "adict"
+ f <- newIdent loc "fcnD"
+ withDict d ctx $ do
+ eqns' <- tcEqns t' eqns
+ let eqn =
+ case eqns' of
+ [Eqn [] alts] -> Eqn [EVar d] alts
+ _ -> Eqn [EVar d] $ EAlts [([], EVar f)] [BFcn f eqns']
+ return [eqn]
+tcEqns t eqns = do
+ let loc = getSLocEqns eqns
+ f <- newIdent loc "fcnS"
+ (eqns', ds) <- solveLocalConstraints $ mapM (tcEqn t) eqns
+ case ds of
+ [] -> return eqns'
+ _ -> do
+ let
+ bs = eBinds ds
+ eqn = Eqn [] $ EAlts [([], EVar f)] (bs ++ [BFcn f eqns'])
+ return [eqn]
tcEqn :: EType -> Eqn -> T Eqn
+--tcEqn t _eqn | trace ("tcEqn: " ++ showEType t) False = undefinedtcEqn t eqn =
case eqn of
- Eqn ps alts -> tcPats t ps $ \ tt ps' -> T.do
+ Eqn ps alts -> tcPats t ps $ \ tt ps' -> do
aalts <- tcAlts tt alts
- T.return (Eqn ps' aalts)
+ return (Eqn ps' aalts)
tcAlts :: EType -> EAlts -> T EAlts
tcAlts tt (EAlts alts bs) =
- tcBinds bs $ \ bbs -> T.do { aalts <- T.mapM (tcAlt tt) alts; T.return (EAlts aalts bbs) }+-- trace ("tcAlts: bs in " ++ showEBinds bs) $+ tcBinds bs $ \ bbs -> do
+-- traceM ("tcAlts: bs out " ++ showEBinds bbs)+ aalts <- mapM (tcAlt tt) alts
+ return (EAlts aalts bbs)
tcAlt :: EType -> EAlt -> T EAlt
-tcAlt t (ss, rhs) = tcGuards ss $ \ sss -> T.do { rrhs <- tCheckExpr t rhs; T.return (sss, rrhs) }+--tcAlt t (_, rhs) | trace ("tcAlt: " ++ showExpr rhs ++ " :: " ++ showEType t) False = undefined+tcAlt t (ss, rhs) = tcGuards ss $ \ sss -> do { rrhs <- tCheckExpr t rhs; return (sss, rrhs) }tcGuards :: forall a . [EStmt] -> ([EStmt] -> T a) -> T a
tcGuards [] ta = ta []
@@ -1209,10 +1698,10 @@
tcGuards (s:ss) ta = tcGuard s $ \ rs -> tcGuards ss $ \ rss -> ta (rs:rss)
tcGuard :: forall a . EStmt -> (EStmt -> T a) -> T a
-tcGuard (SBind p e) ta = T.do
+tcGuard (SBind p e) ta = do
(ee, tt) <- tInferExpr e
tCheckPat tt p $ \ pp -> ta (SBind pp ee)
-tcGuard (SThen e) ta = T.do
+tcGuard (SThen e) ta = do
ee <- tCheckExpr (tBool (getSLocExpr e)) e
ta (SThen ee)
tcGuard (SLet bs) ta = tcBinds bs $ \ bbs -> ta (SLet bbs)
@@ -1220,37 +1709,40 @@
tcArm :: EType -> EType -> ECaseArm -> T ECaseArm
tcArm t tpat arm =
case arm of
- (p, alts) -> tCheckPat tpat p $ \ pp -> T.do
+ (p, alts) -> tCheckPat tpat p $ \ pp -> do
aalts <- tcAlts t alts
- T.return (pp, aalts)
+ return (pp, aalts)
+eBinds :: [(Ident, Expr)] -> [EBind]
+eBinds ds = [BFcn i [Eqn [] (EAlts [([], e)] [])] | (i, e) <- ds]
instPatSigma :: --XHasCallStack =>
SLoc -> Sigma -> Expected -> T ()
-instPatSigma _ pt (Infer r) = tSetRefType r pt
-instPatSigma loc pt (Check t) = subsCheck loc t pt
+instPatSigma loc pt (Infer r) = tSetRefType loc r pt
+instPatSigma loc pt (Check t) = do { _ <- subsCheck loc undefined t pt; return () } -- XXX really?subsCheck :: --XHasCallStack =>
- SLoc -> Sigma -> Sigma -> T ()
+ SLoc -> Expr -> Sigma -> Sigma -> T Expr
-- (subsCheck args off exp) checks that
-- 'off' is at least as polymorphic as 'args -> exp'
-subsCheck loc sigma1 sigma2 = T.do -- Rule DEEP-SKOL
+subsCheck loc exp1 sigma1 sigma2 = do -- Rule DEEP-SKOL
(skol_tvs, rho2) <- skolemise sigma2
- subsCheckRho loc sigma1 rho2
+ exp1' <- subsCheckRho loc exp1 sigma1 rho2
esc_tvs <- getFreeTyVars [sigma1,sigma2]
- let bad_tvs = filter (\ i -> elemBy eqIdent i esc_tvs) skol_tvs
- T.when (not (null bad_tvs)) $
- tcError loc "Subsumption check failed"
+ let bad_tvs = filter (\ i -> elem i esc_tvs) skol_tvs
+ when (not (null bad_tvs)) $
+ tcErrorTK loc "Subsumption check failed"
+ return exp1'
tCheckPat :: forall a . EType -> EPat -> (EPat -> T a) -> T a
-tCheckPat t p@(EVar v) ta | not (isConIdent v) = T.do -- simple special case
+tCheckPat t p@(EVar v) ta | not (isConIdent v) = do -- simple special case
withExtVals [(v, t)] $ ta p
-tCheckPat t ap ta = T.do
+tCheckPat t ap ta = do
-- traceM $ "tcPat: " ++ show ap
let vs = patVars ap
multCheck vs
- env <- T.mapM (\ v -> (v,) <$> newUVar) vs
- withExtVals env $ T.do
+ env <- mapM (\ v -> (v,) <$> newUVar) vs
+ withExtVals env $ do
pp <- withTCMode TCPat $ tCheckExpr t ap
() <- checkArity 0 pp
ta pp
@@ -1257,12 +1749,12 @@
multCheck :: [Ident] -> T ()
multCheck vs =
- T.when (anySameBy eqIdent vs) $ T.do
+ when (anySame vs) $ do
let v = head vs
tcError (getSLocIdent v) $ "Multiply defined: " ++ showIdent v
checkArity :: Int -> EPat -> T ()
-checkArity n (EApp f a) = T.do
+checkArity n (EApp f a) = do
checkArity (n+1) f
checkArity 0 a
checkArity n (ECon c) =
@@ -1272,7 +1764,7 @@
else if n > a then
tcError (getSLocCon c) "too many arguments"
else
- T.return ()
+ return ()
checkArity n (EAt _ p) = checkArity n p
checkArity n (ESign p _) = checkArity n p
checkArity n p =
@@ -1285,50 +1777,42 @@
--Xerror (show p)
impossible
where
- check0 = if n /= 0 then tcError (getSLocExpr p) "Bad pattern" else T.return ()
+ check0 = if n /= 0 then tcError (getSLocExpr p) "Bad pattern" else return ()
tcBinds :: forall a . [EBind] -> ([EBind] -> T a) -> T a
-tcBinds xbs ta = T.do
+tcBinds xbs ta = do
let
tmap = M.fromList [ (i, t) | BSign i t <- xbs ]
- xs = concatMap getBindVars xbs
+ xs = getBindsVars xbs
multCheck xs
- xts <- T.mapM (tcBindVarT tmap) xs
- withExtVals xts $ T.do
- nbs <- T.mapM tcBind xbs
+ xts <- mapM (tcBindVarT tmap) xs
+ withExtVals xts $ do
+ nbs <- mapM tcBind xbs
ta nbs
tcBindVarT :: M.Map EType -> Ident -> T (Ident, EType)
-tcBindVarT tmap x = T.do
+tcBindVarT tmap x = do
case M.lookup x tmap of
- Nothing -> T.do
+ Nothing -> do
t <- newUVar
- T.return (x, t)
- Just t -> T.do
+ return (x, t)
+ Just t -> do
tt <- withTypeTable $ tcTypeT (Check kType) t
- T.return (x, tt)
+ return (x, tt)
tcBind :: EBind -> T EBind
tcBind abind =
case abind of
- BFcn i eqns -> T.do
- (_, tt) <- tLookup "impossible!" i
- let (iks, tfn) = unForall tt
- teqns <- withExtTyps iks $ tcEqns tfn eqns
- T.return $ BFcn i teqns
- BPat p a -> T.do
+ BFcn i eqns -> do
+ (_, tt) <- tLookupV i
+ teqns <- tcEqns tt eqns
+ return $ BFcn i teqns
+ BPat p a -> do
(ep, tp) <- withTCMode TCPat $ tInferExpr p -- pattern variables already bound
ea <- tCheckExpr tp a
- T.return $ BPat ep ea
- BSign _ _ -> T.return abind
+ return $ BPat ep ea
+ BSign _ _ -> return abind
-getBindVars :: EBind -> [Ident]
-getBindVars abind =
- case abind of
- BFcn i _ -> [i]
- BPat p _ -> patVars p
- BSign _ _ -> []
-
-- Desugar [T] and (T,T,...)
dsType :: EType -> EType
dsType at =
@@ -1346,13 +1830,13 @@
tConI loc = tCon . mkIdentSLoc loc
tListI :: SLoc -> Ident
-tListI loc = mkIdentSLoc loc "Data.List.[]"
+tListI loc = mkIdentSLoc loc $ listPrefix ++ "[]"
tList :: SLoc -> EType
tList = tCon . tListI
tBool :: SLoc -> EType
-tBool loc = tConI loc "Data.Bool_Type.Bool"
+tBool loc = tConI loc $ boolPrefix ++ "Bool"
impossible :: --XHasCallStack =>
forall a . a
@@ -1361,7 +1845,7 @@
showTModule :: forall a . (a -> String) -> TModule a -> String
showTModule sh amdl =
case amdl of
- TModule mn _ _ _ _ a -> "Tmodule " ++ showIdent mn ++ "\n" ++ sh a ++ "\n"
+ TModule mn _ _ _ _ _ _ a -> "Tmodule " ++ showIdent mn ++ "\n" ++ sh a ++ "\n"
{-showValueTable :: ValueTable -> String
@@ -1372,14 +1856,14 @@
-----------------------------------------------------
getFreeTyVars :: [EType] -> T [TyVar]
-getFreeTyVars tys = T.do
- tys' <- T.mapM derefUVar tys
- T.return (freeTyVars tys')
+getFreeTyVars tys = do
+ tys' <- mapM derefUVar tys
+ return (freeTyVars tys')
getMetaTyVars :: [EType] -> T [TRef]
-getMetaTyVars tys = T.do
- tys' <- T.mapM derefUVar tys
- T.return (metaTvs tys')
+getMetaTyVars tys = do
+ tys' <- mapM derefUVar tys
+ return (metaTvs tys')
getEnvTypes :: T [EType]
getEnvTypes = gets (map entryType . stElemsLcl . valueTable)
@@ -1387,19 +1871,19 @@
{-quantify :: [MetaTv] -> Rho -> T Sigma
-- Quantify over the specified type variables (all flexible)
-quantify tvs ty = T.do
- T.mapM_ bind (tvs `zip` new_bndrs) -- 'bind' is just a cunning way
+quantify tvs ty = do
+ mapM_ bind (tvs `zip` new_bndrs) -- 'bind' is just a cunning way
ty' <- zonkType ty -- of doing the substitution
- T.return (EForall new_bndrs_kind ty')
+ return (EForall new_bndrs_kind ty')
where
used_bndrs = tyVarBndrs ty -- Avoid quantified type variables in use
- new_bndrs = deleteFirstsBy eqIdent allBinders used_bndrs
+ new_bndrs = allBinders \\ used_bndrs
bind (tv, name) = writeTcRef tv (EVar name)
new_bndrs_kind = map (\ i -> IdKind i undefined) new_bndrs
allBinders :: [Ident] -- a,b,..z, a1, b1,... z1, a2, b2,...
allBinders = [ mkIdent [chr x] | x <- [ord 'a' .. ord 'z'] ] ++
- [ mkIdent (chr x : showInt i) | i <- [1 ..], x <- [ord 'a' .. ord 'z']]
+ [ mkIdent (chr x : show i) | i <- [1 ..], x <- [ord 'a' .. ord 'z']]
-}
skolemise :: --XHasCallStack =>
@@ -1406,25 +1890,25 @@
Sigma -> T ([TyVar], Rho)
-- Performs deep skolemisation, returning the
-- skolem constants and the skolemised type
-skolemise (EForall tvs ty) = T.do -- Rule PRPOLY
- sks1 <- T.mapM (newSkolemTyVar . idKindIdent) tvs
+skolemise (EForall tvs ty) = do -- Rule PRPOLY
+ sks1 <- mapM (newSkolemTyVar . idKindIdent) tvs
(sks2, ty') <- skolemise (subst (zip (map idKindIdent tvs) (map EVar sks1)) ty)
- T.return (sks1 ++ sks2, ty')
-skolemise t@(EApp _ _) | Just (arg_ty, res_ty) <- getArrow t = T.do -- Rule PRFUN
+ return (sks1 ++ sks2, ty')
+skolemise t@(EApp _ _) | Just (arg_ty, res_ty) <- getArrow t = do -- Rule PRFUN
(sks, res_ty') <- skolemise res_ty
- T.return (sks, arg_ty `tArrow` res_ty')
-skolemise (EApp f a) = T.do
+ return (sks, arg_ty `tArrow` res_ty')
+skolemise (EApp f a) = do
(sks1, f') <- skolemise f
(sks2, a') <- skolemise a
- T.return (sks1 ++ sks2, EApp f' a')
+ return (sks1 ++ sks2, EApp f' a')
skolemise ty =
- T.return ([], ty) -- Rule PRMONO
+ return ([], ty) -- Rule PRMONO
-- Skolem tyvars are just identifiers that start with a uniq
newSkolemTyVar :: Ident -> T Ident
-newSkolemTyVar tv = T.do
+newSkolemTyVar tv = do
uniq <- newUniq
- T.return (mkIdentSLoc (getSLocIdent tv) (showInt uniq ++ unIdent tv))
+ return (mkIdentSLoc (getSLocIdent tv) (unIdent tv ++ "#" ++ show uniq))
freeTyVars :: [EType] -> [TyVar]
-- Get the free TyVars from a type; no duplicates in result
@@ -1435,8 +1919,9 @@
-> [TyVar] -- Accumulates result
-> [TyVar]
go bound (EVar tv) acc
- | elemBy eqIdent tv bound = acc
- | elemBy eqIdent tv acc = acc
+ | elem tv bound = acc
+ | elem tv acc = acc
+ | isConIdent tv = acc
| otherwise = tv : acc
go bound (EForall tvs ty) acc = go (map idKindIdent tvs ++ bound) ty acc
go bound (EApp fun arg) acc = go bound fun (go bound arg acc)
@@ -1448,7 +1933,7 @@
metaTvs tys = foldr go [] tys
where
go (EUVar tv) acc
- | elemBy eqInt tv acc = acc
+ | elem tv acc = acc
| otherwise = tv : acc
go (EVar _) acc = acc
go (EForall _ ty) acc = go ty acc
@@ -1459,7 +1944,7 @@
tyVarBndrs :: Rho -> [TyVar]
-- Get all the binders used in ForAlls in the type, so that
-- when quantifying an outer for-all we can avoid these inner ones
-tyVarBndrs ty = nubBy eqIdent (bndrs ty)
+tyVarBndrs ty = nub (bndrs ty)
where
bndrs (EForall tvs body) = map idKindIdent tvs ++ bndrs body
bndrs (EApp arg res) = bndrs arg ++ bndrs res
@@ -1467,70 +1952,268 @@
bndrs _ = undefined
inferSigma :: Expr -> T (Expr, Sigma)
-inferSigma e = T.do
+inferSigma e = do
(e', exp_ty) <- inferRho e
env_tys <- getEnvTypes
env_tvs <- getMetaTyVars env_tys
res_tvs <- getMetaTyVars [exp_ty]
- let forall_tvs = deleteFirstsBy eqInt res_tvs env_tvs
+ let forall_tvs = res_tvs \\ env_tvs
(e',) <$> quantify forall_tvs exp_ty
-}
-checkSigma :: Expr -> Sigma -> T Expr
-checkSigma expr sigma = T.do
+checkSigma :: --XHasCallStack =>
+ Expr -> Sigma -> T Expr
+checkSigma expr sigma = do
(skol_tvs, rho) <- skolemise sigma
expr' <- tCheckExpr rho expr
if null skol_tvs then
-- Fast special case
- T.return expr'
- else T.do
+ return expr'
+ else do
env_tys <- getEnvTypes
esc_tvs <- getFreeTyVars (sigma : env_tys)
- let bad_tvs = filter (\ i -> elemBy eqIdent i esc_tvs) skol_tvs
- T.when (not (null bad_tvs)) $
- tcError (getSLocExpr expr) "Type not polymorphic enough"
- T.return expr'
+ let bad_tvs = filter (\ i -> elem i esc_tvs) skol_tvs
+ when (not (null bad_tvs)) $
+ tcErrorTK (getSLocExpr expr) $ "not polymorphic enough: " ++ unwords (map showIdent bad_tvs)
+ return expr'
-subsCheckRho :: SLoc -> Sigma -> Rho -> T ()
-subsCheckRho loc sigma1@(EForall _ _) rho2 = T.do -- Rule SPEC
- rho1 <- tInst sigma1
- subsCheckRho loc rho1 rho2
-subsCheckRho loc rho1 rho2 | Just (a2, r2) <- getArrow rho2 = T.do -- Rule FUN
+subsCheckRho :: --XHasCallStack =>
+ SLoc -> Expr -> Sigma -> Rho -> T Expr
+--subsCheckRho _ e1 t1 t2 | trace ("subsCheckRho: " ++ {-showExpr e1 ++ " :: " ++ -} showEType t1 ++ " = " ++ showEType t2) False = undefined+subsCheckRho loc exp1 sigma1@(EForall _ _) rho2 = do -- Rule SPEC
+ (exp1', rho1) <- tInst (exp1, sigma1)
+ subsCheckRho loc exp1' rho1 rho2
+subsCheckRho loc exp1 rho1 rho2 | Just (a2, r2) <- getArrow rho2 = do -- Rule FUN
(a1, r1) <- unArrow loc rho1
- subsCheckFun loc a1 r1 a2 r2
-subsCheckRho loc rho1 rho2 | Just (a1, r1) <- getArrow rho1 = T.do -- Rule FUN
+ subsCheckFun loc exp1 a1 r1 a2 r2
+subsCheckRho loc exp1 rho1 rho2 | Just (a1, r1) <- getArrow rho1 = do -- Rule FUN
(a2,r2) <- unArrow loc rho2
- subsCheckFun loc a1 r1 a2 r2
-subsCheckRho loc tau1 tau2 -- Rule MONO
- = unify loc tau1 tau2 -- Revert to ordinary unification
+ subsCheckFun loc exp1 a1 r1 a2 r2
+subsCheckRho loc exp1 tau1 tau2 = do -- Rule MONO
+ unify loc tau1 tau2 -- Revert to ordinary unification
+ return exp1
-subsCheckFun :: SLoc -> Sigma -> Rho -> Sigma -> Rho -> T ()
-subsCheckFun loc a1 r1 a2 r2 = T.do
- subsCheck loc a2 a1
- subsCheckRho loc r1 r2
+subsCheckFun :: --XHasCallStack =>
+ SLoc -> Expr -> Sigma -> Rho -> Sigma -> Rho -> T Expr
+subsCheckFun loc e1 a1 r1 a2 r2 = do
+ _ <- subsCheck loc undefined a2 a1 -- XXX
+ subsCheckRho loc e1 r1 r2
-instSigma :: SLoc -> Sigma -> Expected -> T ()
-instSigma loc t1 (Check t2) = subsCheckRho loc t1 t2
-instSigma _ t1 (Infer r) = T.do
- t1' <- tInst t1
- tSetRefType r t1'
+instSigma :: --XHasCallStack =>
+ SLoc -> Expr -> Sigma -> Expected -> T Expr
+instSigma loc e1 t1 (Check t2) = do
+-- traceM ("instSigma: Check " ++ showEType t1 ++ " = " ++ showEType t2)+ subsCheckRho loc e1 t1 t2
+instSigma loc e1 t1 (Infer r) = do
+ (e1', t1') <- tInst (e1, t1)
+-- traceM ("instSigma: Infer " ++ showEType t1 ++ " ==> " ++ showEType t1')+ tSetRefType loc r t1'
+ return e1'
----------------------
+-----
+-- Given a dictionary of a (constraint type), split it up
+-- * name components of a tupled constraint
+-- * name superclasses of a constraint
+expandDict :: Expr -> EConstraint -> T [InstDictC]
+expandDict edict acn = do
+ cn <- expandSyn acn
+ let
+ (iCls, args) = getApp cn
+ case getTupleConstr iCls of
+ Just _ -> concat <$> mapM (\ (i, a) -> expandDict (mkTupleSel i (length args) `EApp` edict) a) (zip [0..] args)
+ Nothing -> do
+ ct <- gets classTable
+ let (iks, sups, _, _) = fromMaybe impossible $ M.lookup iCls ct
+ sub = zip (map idKindIdent iks) args
+ sups' = map (subst sub) sups
+-- mn <- gets moduleName
+ insts <- concat <$> mapM (\ (i, sup) -> expandDict (EVar (expectQualified $ mkSuperSel iCls i) `EApp` edict) sup) (zip [1 ..] sups')
+ return $ (edict, [], [], cn) : insts
+
+mkSuperSel :: --XHasCallStack =>
+ Ident -> Int -> Ident
+mkSuperSel c i = addIdentSuffix c ("$super" ++ show i)+
+---------------------------------
+
+-- Solve constraints generated locally in 'ta'.
+-- Keep any unsolved ones for later.
+solveLocalConstraints :: forall a . T a -> T (a, [(Ident, Expr)])
+solveLocalConstraints ta = do
+ cs <- gets constraints -- old constraints
+ putConstraints [] -- start empty
+ a <- ta -- compute, generating constraints
+ ds <- solveConstraints -- solve those
+ un <- gets constraints -- get remaining unsolved
+ putConstraints (un ++ cs) -- put back unsolved and old constraints
+ return (a, ds)
+
+{-+showInstInfo :: InstInfo -> String
+showInstInfo (InstInfo m ds) = "InstInfo " ++ showListS (showPair showIdent showExpr) (M.toList m) ++ " " ++ showList showInstDict ds
+
+showInstDict :: InstDict -> String
+showInstDict (e, iks, ctx, ts) = showExpr e ++ " :: " ++ showEType (eForall iks $ addConstraints ctx (tApps (mkIdent "X") ts))
+
+showInstDef :: InstDef -> String
+showInstDef (cls, InstInfo m ds) = "instDef " ++ showIdent cls ++ ": "
+ ++ showListS (showPair showIdent showExpr) (M.toList m) ++ ", " ++ showList showInstDict ds
+
+showConstraint :: (Ident, EConstraint) -> String
+showConstraint (i, t) = showIdent i ++ " :: " ++ showEType t
+
+showMatch :: (Expr, [EConstraint]) -> String
+showMatch (e, ts) = showExpr e ++ " " ++ showListS showEType ts
+-}
+
+-- Solve as many constraints as possible.
+-- Return bindings for the dictionary witnesses.
+-- Unimplemented:
+-- instances with a context
+solveConstraints :: T [(Ident, Expr)]
+solveConstraints = do
+ cs <- gets constraints
+ if null cs then
+ return []
+ else do
+-- traceM "------------------------------------------\nsolveConstraints"
+ cs' <- mapM (\ (i,t) -> do { t' <- derefUVar t; return (i,t') }) cs+-- traceM ("constraints:\n" ++ unlines (map showConstraint cs'))+ it <- gets instTable
+-- traceM ("instances:\n" ++ unlines (map showInstDef (M.toList it)))+ let solve :: [(Ident, EType)] -> [(Ident, EType)] -> [(Ident, Expr)] -> T ([(Ident, EType)], [(Ident, Expr)])
+ solve [] uns sol = return (uns, sol)
+ solve (cns@(di, ct) : cnss) uns sol = do
+-- traceM ("trying " ++ showEType ct)+ let loc = getSLocIdent di
+ (iCls, cts) = getApp ct
+ case getTupleConstr iCls of
+ Just _ -> do
+ goals <- mapM (\ c -> do { d <- newIdent loc "dict"; return (d, c) }) cts+-- traceM ("split tuple " ++ showListS showConstraint goals)+ solve (goals ++ cnss) uns ((di, ETuple (map (EVar . fst) goals)) : sol)
+ Nothing ->
+ case M.lookup iCls it of
+ Nothing -> do
+-- traceM ("class missing " ++ showIdent iCls)+ solve cnss (cns : uns) sol -- no instances, so no chance
+ Just (InstInfo atomMap insts) ->
+ case cts of
+ [EVar i] -> do
+-- traceM ("solveSimple " ++ showIdent i ++ " -> " ++ showMaybe showExpr (M.lookup i atomMap))+ solveSimple (M.lookup i atomMap) cns cnss uns sol
+ _ -> solveGen loc insts cns cnss uns sol
+
+ -- An instance of the form (C T)
+ solveSimple Nothing cns cnss uns sol = solve cnss (cns : uns) sol -- no instance
+ solveSimple (Just e) (di, _) cnss uns sol = solve cnss uns ((di, e) : sol) -- e is the dictionary expression
+
+ solveGen loc insts cns@(di, ct) cnss uns sol = do
+-- traceM ("solveGen " ++ showEType ct)+ let (_, ts) = getApp ct
+ matches = getBestMatches $ findMatches insts ts
+-- traceM ("matches " ++ showListS showMatch matches)+ case matches of
+ [] -> solve cnss (cns : uns) sol
+ [(de, ctx)] ->
+ if null ctx then
+ solve cnss uns ((di, de) : sol)
+ else do
+ d <- newIdent loc "dict"
+-- traceM ("constraint " ++ showIdent di ++ " :: " ++ showEType ct ++ "\n" +++-- " turns into " ++ showIdent d ++ " :: " ++ showEType (tupleConstraints ctx) ++ ", " ++
+-- showIdent di ++ " = " ++ showExpr (EApp de (EVar d)))
+ solve ((d, tupleConstraints ctx) : cnss) uns ((di, EApp de (EVar d)) : sol)
+ _ -> tcError loc $ "Multiple constraint solutions for: " ++ showEType ct
+
+ (unsolved, solved) <- solve cs' [] []
+ putConstraints unsolved
+-- traceM ("solved:\n" ++ unlines [ showIdent i ++ " = " ++ showExpr e | (i, e) <- solved ])+-- traceM ("unsolved:\n" ++ unlines [ showIdent i ++ " :: " ++ showEType t | (i, t) <- unsolved ])+ return solved
+
+type TySubst = [(TRef, EType)]
+
+-- Given some instances and a constraint, find the matching instances.
+-- For each matching instance return: (subst-size, (dict-expression, new-constraints))
+-- The subst-size is the size of the substitution that made the input instance match.
+-- It is a measure of how exact the match is.
+findMatches :: [InstDict] -> [EType] -> [(Int, (Expr, [EConstraint]))]
+findMatches ds its =
+ let rrr =
+ [ (length s, (de, map (substEUVar s) ctx))
+ | (de, ctx, ts) <- ds, Just s <- [matchTypes [] ts its] ]
+ in --trace ("findMatches: " ++ showListS showInstDict ds ++ "; " ++ showEType ct ++ "; " ++ show rrr)+ rrr
+ where
+
+ -- Length of lists match, because of kind correctness
+ matchTypes :: TySubst -> [EType] -> [EType] -> Maybe TySubst
+ matchTypes r (t:ts) (t':ts') =
+ case matchType r t t' of
+ Nothing -> Nothing
+ Just r' -> matchTypes r' ts ts'
+ matchTypes r _ _ = Just r
+
+ -- Match two types, instantiate variables in the first type.
+ matchType r (EVar i) (EVar i') | i == i' = Just r
+ matchType r (EApp f a) (EApp f' a') = -- XXX should use Maybe monad
+ case matchType r f f' of
+ Nothing -> Nothing
+ Just r' -> matchType r' a a'
+ matchType r (EUVar i) t =
+ -- For a variable, check that any previous match is the same.
+ case lookup i r of
+ Just t' -> if eqEType t t' then Just r else Nothing
+ Nothing -> Just ((i, t) : r)
+ matchType _ _ _ = Nothing
+
+ -- Do substitution for EUVar.
+ -- XXX similar to derefUVar
+ substEUVar [] t = t
+ substEUVar _ t@(EVar _) = t
+ substEUVar s (EApp f a) = EApp (substEUVar s f) (substEUVar s a)
+ substEUVar s t@(EUVar i) = fromMaybe t $ lookup i s
+ substEUVar s (EForall iks t) = EForall iks (substEUVar s t)
+ substEUVar _ _ = impossible
+
+
+-- Get the best matches. These are the matches with the smallest substitution.
+getBestMatches :: [(Int, (Expr, [EConstraint]))] -> [(Expr, [EConstraint])]
+getBestMatches [] = []
+getBestMatches ms =
+ let b = minimum (map fst ms) -- minimum substitution size
+ in [ ec | (s, ec) <- ms, s == b ] -- pick out the smallest
+
+-- Check that there are no unsolved constraints.
+checkConstraints :: T ()
+checkConstraints = do
+ cs <- gets constraints
+ case cs of
+ [] -> return ()
+ (i, t) : _ -> do
+ t' <- derefUVar t
+ --is <- gets instTable
+ --traceM $ "Cannot satisfy constraint: " ++ unlines (map (\ (i, ii) -> showIdent i ++ ":\n" ++ showInstInfo ii) (M.toList is))
+ tcError (getSLocIdent i) $ "Cannot satisfy constraint: " ++ showExpr t'
+
+---------------------
+
data SymTab a = SymTab (M.Map [a]) [(Ident, a)]
--Xderiving(Show)
-stLookup :: forall a . --XShow a =>
- String -> Ident -> SymTab a -> Either String a
+stLookup :: --forall a . --XShow a =>
+ String -> Ident -> SymTab Entry -> Either String Entry
stLookup msg i (SymTab genv lenv) =
- case lookupBy eqIdent i lenv of
+ case lookup i lenv of
Just e -> Right e
Nothing ->
case M.lookup i genv of
Just [e] -> Right e
- Just _ -> Left $ "ambiguous " ++ msg ++ ": " ++ showIdent i
+ Just es -> Left $ "ambiguous " ++ msg ++ ": " ++ showIdent i ++ " " ++ showListS (showIdent . getAppCon) [ e | Entry e _ <- es ]
Nothing -> Left $ "undefined " ++ msg ++ ": " ++ showIdent i
- --X ++ "\n" ++ show lenv ++ "\n" ++ show genv
+ -- ++ "\n" ++ show lenv ++ "\n" ++ show genv
stFromListWith :: forall a . ([a] -> [a] -> [a]) -> [(Ident, [a])] -> SymTab a
stFromListWith comb ias = SymTab (M.fromListWith comb ias) []
@@ -1547,3 +2230,28 @@
-- XXX Use insertWith to follow Haskell semantics.
stInsertGlb :: forall a . Ident -> [a] -> SymTab a -> SymTab a
stInsertGlb i as (SymTab genv lenv) = SymTab (M.insert i as genv) lenv
+
+-----------------------------
+{-+showSymTab :: SymTab Entry -> String
+showSymTab (SymTab im ies) = showListS showIdent (map fst (M.toList im) ++ map fst ies)
+
+showTModuleExps :: TModule a -> String
+showTModuleExps (TModule mn _fxs tys _syns _clss _insts vals _defs) =
+ showIdent mn ++ ":\n" ++
+ unlines (map ((" " ++) . showValueExport) vals) +++ unlines (map ((" " ++) . showTypeExport) tys)+
+showValueExport :: ValueExport -> String
+showValueExport (ValueExport i (Entry qi t)) =
+ showIdent i ++ " = " ++ showExpr qi ++ " :: " ++ showEType t
+
+showTypeExport :: TypeExport -> String
+showTypeExport (TypeExport i (Entry qi t) vs) =
+ showIdent i ++ " = " ++ showExpr qi ++ " :: " ++ showEType t ++ " assoc=" ++ showListS showValueExport vs
+
+showIdentClassInfo :: (Ident, ClassInfo) -> String
+showIdentClassInfo (i, (_vks, _ctx, cc, ms)) =
+ showIdent i ++ " :: " ++ showEType cc ++
+ " has " ++ showListS showIdent ms
+-}
--- a/src/PrimTable.hs
+++ /dev/null
@@ -1,91 +1,0 @@
-module PrimTable(module PrimTable) where
-import Data.Char
-import Data.Maybe
-import System.IO
-import Unsafe.Coerce
-import GHC.Types(Any)
-
-primitive :: String -> Any
-primitive s = fromMaybe (error $ "primitive: " ++ s) $ lookup s primOps
-
-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 "Y" (\ f -> let r = f r in r)
- , 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 "*" (*)
- , arith "quot" quot
- , arith "rem" rem
- , arith "subtract" subtract
- , farith "fadd" (+)
- , farith "fsub" (-)
- , farith "fmul" (*)
- , cmp "feq" (==)
- , cmp "fne" (/=)
- , cmp "flt" (<)
- , cmp "fle" (<=)
- , cmp "fgt" (>)
- , cmp "fge" (>=)
- , comb "fshow" (show :: Double -> String)
- , cmp "==" (==)
- , cmp "/=" (/=)
- , cmp "<" (<)
- , cmp "<=" (<=)
- , cmp ">" (>)
- , cmp ">=" (>=)
- , cmp "error" err
- , comb "ord" ord
- , comb "chr" chr
- , comb "IO.>>=" iobind
- , comb "IO.>>" iothen
- , comb "IO.return" ioret
--- , comb "IO.getChar" getc
- , comb "IO.putChar" putc
- , comb "IO.stdin" stdin
- , comb "IO.stdout" stdout
- , comb "IO.stderr" stderr
- ]
- where
- comb n f = (n, unsafeCoerce f)
- arith :: String -> (Int -> Int -> Int) -> (String, Any)
- arith = comb
- farith :: String -> (Double -> Double -> Double) -> (String, Any)
- farith = comb
- cmp :: String -> (Int -> Int -> Bool) -> (String, Any)
- cmp n f = comb n (\ x y -> if f x y then cTrue else cFalse)
- cTrue _x y = y
- cFalse x _y = x
- iobind :: DIO a -> (a -> DIO b) -> DIO b
- iobind a k = DIO (unDIO a >>= \ x -> unDIO (k x))
- iothen :: DIO a -> DIO b -> DIO b
- iothen a b = DIO (unDIO a >> unDIO b)
- ioret :: a -> DIO a
- ioret a = DIO (return a)
--- getc h = undefined -- fromEnum <$> hGetChar h -- XXX
- putc :: Handle -> Int -> DIO ()
- putc h c = DIO $ do
--- let h = unsafeCoerce hh :: Handle
--- c = unsafeCoerce cc :: Int
--- print (h, c)
- hPutChar h (toEnum c)
--- open = undefined
--- close = undefined
--- isnull = undefined
-
- err _ = error "ERROR"
--- a/src/System/Console/SimpleReadline.hs
+++ b/src/System/Console/SimpleReadline.hs
@@ -9,6 +9,7 @@
) where
import Primitives
import Prelude
+import Control.Monad
import Data.Char
import System.IO
--Ximport Compat
@@ -80,7 +81,7 @@
loop hist "" (reverse before ++ after)
eol = do
putStr after
- loop hist (before ++ reverse after) ""
+ loop hist (reverse after ++ before) ""
bs = do
case before of
[] -> noop
@@ -101,7 +102,7 @@
case ms of
Nothing -> []
Just "" -> []
- Just s | not (null o) && eqString s (last o) -> []
+ Just s | not (null o) && s == last o -> []
| otherwise -> [s]
h = o ++ l
return (h, ms)
--- a/src/Text/ParserComb.hs
+++ b/src/Text/ParserComb.hs
@@ -21,7 +21,9 @@
LastFail(..),
) where
--Ximport Prelude()
-import PreludeNoIO
+import Prelude
+import Control.Alternative
+import Control.Monad --Xhiding(guard)
data LastFail t
= LastFail Int [t] [String]
@@ -55,6 +57,38 @@
runP :: forall s t a . Prsr s t a -> (([t], s) -> Res s t a)
runP (P p) = p
+instance forall s t . Functor (Prsr s t) where
+ fmap f p = P $ \ t ->
+ case runP p t of
+ Many aus lf -> Many [ (f a, u) | (a, u) <- aus ] lf
+
+instance forall s t . Applicative (Prsr s t) where
+ pure a = P $ \ t -> Many [(a, t)] noFail
+ (<*>) = ap
+ (*>) p k = p >>= \ _ -> k
+
+instance forall s t . Monad (Prsr s t) where
+ (>>=) p k = P $ \ t ->
+ case runP p t of
+ Many aus plf ->
+ let { xss = [ runP (k a) u | au <- aus, let { (a, u) = au } ] }+ in case unzip [ (rs, lf) | xs <- xss, let { Many rs lf = xs } ] of+ (rss, lfs) -> Many (concat rss) (longests (plf : lfs))
+ return = pure
+
+instance forall s t . MonadFail (Prsr s t) where
+ fail m = P $ \ (ts, _) -> Many [] (LastFail (length ts) (take 1 ts) [m])
+
+instance forall s t . Alternative (Prsr s t) where
+ empty = P $ \ (ts, _) -> Many [] (LastFail (length ts) (take 1 ts) [])
+
+ (<|>) p q = P $ \ t ->
+ case runP p t of
+ Many a lfa ->
+ case runP q t of
+ Many b lfb -> Many (a ++ b) (longest lfa lfb)
+
+{-pure :: forall s t a . a -> Prsr s t a
pure a = P $ \ t -> Many [(a, t)] noFail
@@ -109,6 +143,7 @@
fail :: forall s t a . String -> Prsr s t a
fail m = P $ \ (ts, _) -> Many [] (LastFail (length ts) (take 1 ts) [m])
+-}
get :: forall s t . Prsr s t s
get = P $ \ t@(_, s) -> Many [(s, t)] noFail
@@ -129,11 +164,13 @@
Many b lfb -> Many b (longest lfa lfb)
r -> r
+{-many :: forall s t a . Prsr s t a -> Prsr s t [a]
many p = some p <|> pure []
some :: forall s t a . Prsr s t a -> Prsr s t [a]
some p = (:) <$> p <*> many p
+-}
optional :: forall s t a . Prsr s t a -> Prsr s t (Maybe a)
optional p = (Just <$> p) <|> pure Nothing
--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -8,6 +8,7 @@
#include <locale.h>
#include <ctype.h>
#include <setjmp.h>
+#include <math.h>
#define GCRED 1 /* do some reductions during GC */
#define FASTTAGS 1 /* compute tag by pointer subtraction */
@@ -135,7 +136,7 @@
/***************************************/
-#define VERSION "v4.0\n"
+#define VERSION "v4.1\n"
/* Keep permanent nodes for LOW_INT <= i < HIGH_INT */
#define LOW_INT (-10)
@@ -147,20 +148,21 @@
#define ERR(s) do { fprintf(stderr, "ERR: %s\n", s); exit(1); } while(0) enum node_tag { T_FREE, T_IND, T_AP, T_INT, T_DOUBLE, T_HDL, T_S, T_K, T_I, T_B, T_C,- T_A, T_Y, T_SS, T_BB, T_CC, T_P, T_R, T_O, T_T, T_BK, T_ADD, T_SUB, T_MUL,
- T_QUOT, T_REM, T_SUBR, T_UQUOT, T_UREM,
- T_FADD, T_FSUB, T_FMUL, T_FDIV,
+ T_A, T_Y, T_SS, T_BB, T_CC, T_P, T_R, T_O, T_T, T_BK,
+ T_ADD, T_SUB, T_MUL, T_QUOT, T_REM, T_SUBR, T_UQUOT, T_UREM, T_NEG,
+ T_AND, T_OR, T_XOR, T_INV, T_SHL, T_SHR, T_ASHR,
+ T_FADD, T_FSUB, T_FMUL, T_FDIV, T_ITOF,
T_FEQ, T_FNE, T_FLT, T_FLE, T_FGT, T_FGE, T_FSHOW, T_FREAD,
+ T_FTORAW, T_FFROMRAW,
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_EQUAL, T_COMPARE, T_RNF,
+ T_ERROR, T_NODEFAULT, T_NOMATCH, 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_CATCH,
- T_IO_CCALL, T_IO_GETRAW, T_IO_FLUSH,
+ T_IO_CCALL, T_IO_GETRAW, T_IO_FLUSH, T_DYNSYM,
T_STR,
- T_ISINT, T_ISIO,
T_LAST_TAG,
};
@@ -648,10 +650,19 @@
{ "uquot", T_UQUOT }, { "urem", T_UREM }, { "subtract", T_SUBR },+ { "neg", T_NEG },+ { "and", T_AND },+ { "or", T_OR },+ { "xor", T_XOR },+ { "inv", T_INV },+ { "shl", T_SHL },+ { "shr", T_SHR },+ { "ashr", T_ASHR }, { "fadd" , T_FADD}, { "fsub" , T_FSUB}, { "fmul" , T_FMUL}, { "fdiv", T_FDIV},+ { "itof", T_ITOF}, { "feq", T_FEQ}, { "fne", T_FNE}, { "flt", T_FLT},@@ -660,6 +671,8 @@
{ "fge", T_FGE}, { "fshow", T_FSHOW}, { "fread", T_FREAD},+ { "ftoraw", T_FTORAW},+ { "ffromraw", T_FFROMRAW}, { "==", T_EQ }, { "/=", T_NE }, { "<", T_LT },@@ -672,6 +685,8 @@
{ ">=", T_GE }, { "seq", T_SEQ }, { "error", T_ERROR },+ { "noDefault", T_NODEFAULT },+ { "noMatch", T_NOMATCH }, { "equal", T_EQUAL }, { "compare", T_COMPARE }, { "rnf", T_RNF },@@ -697,8 +712,7 @@
{ "IO.getTimeMilli", T_IO_GETTIMEMILLI }, { "IO.performIO", T_IO_PERFORMIO }, { "IO.catch", T_IO_CATCH },- { "isInt", T_ISINT },- { "isIO", T_ISIO },+ { "dynsym", T_DYNSYM },};
void
@@ -906,8 +920,6 @@
mark(&stack[i]);
t = gettime();
gc_mark_time += t;
- if (verbose > 1)
- fprintf(stderr, "gc scan\n");
if (num_marked > max_num_marked)
max_num_marked = num_marked;
@@ -940,14 +952,24 @@
* II int name(int)
* IIV void name(int, int)
* III int name(int, int)
+ * DD double name(double)
* 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;+ enum { FFI_V, FFI_I, FFI_IV, FFI_II, FFI_IIV, FFI_III, FFI_DD } ffi_how; } ffi_table[] = { { "llabs", (funptr_t)llabs, FFI_II },+ { "log", (funptr_t)log, FFI_DD },+ { "exp", (funptr_t)exp, FFI_DD },+ { "sqrt", (funptr_t)sqrt, FFI_DD },+ { "sin", (funptr_t)sin, FFI_DD },+ { "cos", (funptr_t)cos, FFI_DD },+ { "tan", (funptr_t)tan, FFI_DD },+ { "asin", (funptr_t)asin, FFI_DD },+ { "acos", (funptr_t)acos, FFI_DD },+ { "atan", (funptr_t)atan, FFI_DD },};
/* Look up an FFI function by name */
@@ -1083,7 +1105,7 @@
ARG(r) = parse(f);
if (!gobble(f, ')')) ERR("parse ')'");return r;
- case '%':
+ case '&':
d = parse_double(f);
r = mkDouble(d);
return r;
@@ -1379,10 +1401,19 @@
case T_UQUOT: fprintf(f, "uquot"); break;
case T_UREM: fprintf(f, "urem"); break;
case T_SUBR: fprintf(f, "subtract"); break;
+ case T_NEG: fprintf(f, "neg"); break;
+ case T_AND: fprintf(f, "and"); break;
+ case T_OR: fprintf(f, "or"); break;
+ case T_XOR: fprintf(f, "xor"); break;
+ case T_INV: fprintf(f, "inv"); break;
+ case T_SHL: fprintf(f, "shl"); break;
+ case T_SHR: fprintf(f, "shr"); break;
+ case T_ASHR: fprintf(f, "ashr"); break;
case T_FADD: fprintf(f, "fadd"); break;
case T_FSUB: fprintf(f, "fsub"); break;
case T_FMUL: fprintf(f, "fmul"); break;
case T_FDIV: fprintf(f, "fdiv"); break;
+ case T_ITOF: fprintf(f, "itof"); break;
case T_FEQ: fprintf(f, "feq"); break;
case T_FNE: fprintf(f, "fne"); break;
case T_FLT: fprintf(f, "flt"); break;
@@ -1391,6 +1422,8 @@
case T_FGE: fprintf(f, "fge"); break;
case T_FSHOW: fprintf(f, "fshow"); break;
case T_FREAD: fprintf(f, "fread"); break;
+ case T_FTORAW: fprintf(f, "ftoraw"); break;
+ case T_FFROMRAW: fprintf(f, "ffromraw"); break;
case T_EQ: fprintf(f, "=="); break;
case T_NE: fprintf(f, "/="); break;
case T_LT: fprintf(f, "<"); break;
@@ -1402,6 +1435,8 @@
case T_UGT: fprintf(f, "u>"); break;
case T_UGE: fprintf(f, "u>="); break;
case T_ERROR: fprintf(f, "error"); break;
+ case T_NODEFAULT: fprintf(f, "noDefault"); break;
+ case T_NOMATCH: fprintf(f, "noMatch"); break;
case T_EQUAL: fprintf(f, "equal"); break;
case T_COMPARE: fprintf(f, "compare"); break;
case T_RNF: fprintf(f, "rnf"); break;
@@ -1425,8 +1460,7 @@
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;
+ case T_DYNSYM: fprintf(f, "dynsym"); break;
default: ERR("print tag");}
}
@@ -1758,8 +1792,10 @@
#define SETINT(n,r) do { SETTAG((n), T_INT); SETVALUE((n), (r)); } while(0) #define SETDOUBLE(n,d) do { SETTAG((n), T_DOUBLE); SETDOUBLEVALUE((n), (d)); } while(0)+#define OPINT1(e) do { CHECK(1); xi = evalint(ARG(TOP(0))); e; POP(1); n = TOP(-1); } 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 ARITHUN(op) do { OPINT1(r = op xi); SETINT(n, r); RET; } while(0) #define ARITHBIN(op) do { OPINT2(r = xi op 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@@ -1821,11 +1857,20 @@
case T_SUBR: OPINT2(r = yi - xi); SETINT(n, r); RET;
case T_UQUOT: ARITHBINU(/);
case T_UREM: ARITHBINU(%);
+ case T_NEG: ARITHUN(-);
+ case T_AND: ARITHBIN(&);
+ case T_OR: ARITHBIN(|);
+ case T_XOR: ARITHBIN(^);
+ case T_INV: ARITHUN(~);
+ case T_SHL: ARITHBIN(<<);
+ case T_SHR: ARITHBINU(>>);
+ case T_ASHR: ARITHBIN(>>);
case T_FADD: FARITHBIN(+);
case T_FSUB: FARITHBIN(-);
case T_FMUL: FARITHBIN(*);
case T_FDIV: FARITHBIN(/);
+ case T_ITOF: OPINT1(rd = (double)xi); SETDOUBLE(n, rd); RET;
case T_FEQ: CMPF(==);
case T_FNE: CMPF(!=);
case T_FLT: CMPF(<);
@@ -1868,6 +1913,25 @@
// update n to be s
GOIND(s);
+ case T_FTORAW:
+ CHECK(1);
+ x = evali(ARG(TOP(0)));
+ GCCHECK(1);
+ y = alloc_node(T_INT);
+ SETVALUE(y, GETVALUE(x));
+ POP(1);
+ n = TOP(-1);
+ GOIND(y);
+ case T_FFROMRAW:
+ CHECK(1);
+ x = evali(ARG(TOP(0)));
+ GCCHECK(1);
+ y = alloc_node(T_DOUBLE);
+ SETVALUE(y, GETVALUE(x));
+ POP(1);
+ n = TOP(-1);
+ GOIND(y);
+
case T_EQ: CMP(==);
case T_NE: CMP(!=);
case T_LT: CMP(<);
@@ -1879,7 +1943,35 @@
case T_UGT: CMPU(>);
case T_UGE: CMPU(>=);
+ case T_NOMATCH:
+ {+ CHECK(3);
+ msg = evalstring(ARG(TOP(0)));
+ xi = evalint(ARG(TOP(1)));
+ yi = evalint(ARG(TOP(2)));
+ int sz = strlen(msg) + 100;
+ char *res = malloc(sz);
+ snprintf(res, sz, "no match at %s, line %"PRIvalue", col %"PRIvalue, msg, xi, yi);
+ POP(2);
+ ARG(TOP(0)) = mkStringC(res);
+ free(res);
+ free(msg);
+ goto err; /* XXX not right message if the error is caught */
+ }
+ case T_NODEFAULT:
+ {+ CHECK(1);
+ msg = evalstring(ARG(TOP(0)));
+ int sz = strlen(msg) + 100;
+ char *res = malloc(sz);
+ snprintf(res, sz, "no default for %s", msg);
+ ARG(TOP(0)) = mkStringC(res);
+ free(res);
+ free(msg);
+ goto err; /* XXX not right message if the error is caught */
+ }
case T_ERROR:
+ err:
if (cur_handler) {/* Pass the string to the handler */
CHKARG1;
@@ -1923,6 +2015,19 @@
case T_IO_CATCH:
RET;
+ case T_DYNSYM:
+ /* A dynamic FFI lookup */
+ CHECK(1);
+ msg = evalstring(ARG(TOP(0)));
+ GCCHECK(1);
+ x = alloc_node(T_IO_CCALL);
+ SETVALUE(x, lookupFFIname(msg));
+ free(msg);
+ POP(1);
+ n = TOP(-1);
+ GOIND(x);
+
+#if 0
case T_ISINT:
CHECK(1);
x = evali(ARG(TOP(0)));
@@ -1937,7 +2042,7 @@
POP(1);
l = GETTAG(x);
GOIND(T_IO_BIND <= l && l <= T_IO_FLUSH ? combTrue : combFalse);
-
+#endif
default:
fprintf(stderr, "bad tag %d\n", GETTAG(n));
ERR("eval tag");@@ -2122,7 +2227,9 @@
int a = (int)GETVALUE(n);
funptr_t f = ffi_table[a].ffi_fun;
value_t r, x, y;
+ double rd, xd;
#define INTARG(n) evalint(ARG(TOP(n)))
+#define DBLARG(n) evaldouble(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. */
@@ -2131,8 +2238,9 @@
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);
+ case FFI_IIV: FFIV(2); x = INTARG(1); y = INTARG(2); (*(void (*)(value_t, value_t))f)(x,y); RETIO(combUnit);
+ case FFI_III: FFI (2); x = INTARG(1); y = INTARG(2); r = (*(value_t (*)(value_t, value_t))f)(x,y); n = mkInt(r); RETIO(n);
+ case FFI_DD: FFI (1); xd = DBLARG(1); rd= (*(double (*)(double ))f)(xd); n = mkDouble(rd); RETIO(n);
default: ERR("T_IO_CCALL");}
}
@@ -2299,7 +2407,7 @@
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 expired time\n", run_time); printf("%15.2fs total gc time\n", gc_mark_time);#if GCRED && 0
printf(" GC reductions A=%d, K=%d, I=%d, int=%d\n", red_a, red_k, red_i, red_int);--- a/tests/Arith.hs
+++ b/tests/Arith.hs
@@ -3,6 +3,6 @@
main :: IO ()
main = do
- putStrLn $ showList showInt [ op x y | x <- [0 - 5,0 - 2,0 - 1,0,1,2,5], y <- [0 - 5,0 - 2,0 - 1,0,1,2,5], op <- [(+),( - ),(*)] ]
- putStrLn $ showList showInt [ op x y | x <- [0 - 5,0 - 2,0 - 1,0,1,2,5], y <- [0 - 5,0 - 2,0 - 1,1,2,5], op <- [quot, rem] ]
- putStrLn $ showList showBool [ op x y | x <- [0 - 5,0 - 2,0 - 1,0,1,2,5], y <- [0 - 5,0 - 2,0 - 1,0,1,2,5], op <- [(==),(/=),(<),(<=),(>),(>=)] ]
+ putStrLn $ show [ op x y | x <- [0 - 5,0 - 2,0 - 1,0,1,2,5]::[Int], y <- [0 - 5,0 - 2,0 - 1,0,1,2,5::Int], op <- [(+),( - ),(*)] ]
+ putStrLn $ show [ op x y | x <- [0 - 5,0 - 2,0 - 1,0,1,2,5]::[Int], y <- [0 - 5,0 - 2,0 - 1,1,2,5::Int], op <- [quot, rem] ]
+ putStrLn $ show [ op x y | x <- [0 - 5,0 - 2,0 - 1,0,1,2,5]::[Int], y <- [0 - 5,0 - 2,0 - 1,0,1,2,5::Int], op <- [(==),(/=),(<),(<=),(>),(>=)] ]
--- a/tests/Case.hs
+++ b/tests/Case.hs
@@ -3,16 +3,16 @@
main :: IO ()
main = do
- putStrLn $ showBool $ f1 False
- putStrLn $ showInt $ f2 False
- putStrLn $ showInt $ f2 True
+ putStrLn $ show $ f1 False
+ putStrLn $ show $ f2 False
+ putStrLn $ show $ f2 True
-- putStrLn $ showInt $ f3 False
- putStrLn $ showList showRGB $ map f4 [R,G,B]
- putStrLn $ showInt $ f5 [(3,4)]
+ putStrLn $ show $ map f4 [R,G,B]
+ putStrLn $ show $ f5 [(3::Int,4::Int)]
--putStrLn $ showInt $ f6 [(3,4)]
- putStrLn $ showList showInt $ [ i | Just i <- [Just 1, Nothing, Just 2] ]
- (x,y) <- return (2,3)
- putStrLn $ showInt $ x + y
+ putStrLn $ show $ [ i | Just i <- [Just (1::Int), Nothing, Just 2] ]
+ (x,y) <- return (2::Int,3::Int)
+ putStrLn $ show $ x + y
f1 :: Bool -> Bool
f1 b =
@@ -31,6 +31,9 @@
True -> 1
data RGB = R | G | B
+
+instance Show RGB where
+ show = showRGB
showRGB :: RGB -> String
showRGB c =
--- a/tests/Catch.hs
+++ b/tests/Catch.hs
@@ -5,6 +5,6 @@
main :: IO ()
main = do
x <- catch (return ("o" ++ "k")) (\ _ -> return "what?")- putStrLn $ showString x
+ putStrLn $ show x
y <- catch (do { error "bang!"; return "huh?" }) (\ (Exn s) -> return s)- putStrLn $ showString y
+ putStrLn $ show y
--- /dev/null
+++ b/tests/Class.hs
@@ -1,0 +1,45 @@
+module Class(main) where
+import Primitives
+import Prelude
+
+class Eqq a where
+ (===) :: a -> a -> Bool
+ (/==) :: a -> a -> Bool
+ x /== y = not (x === y)
+
+instance Eqq Int where
+ (===) = primIntEQ
+
+instance Eqq Char where
+ (===) = primCharEQ
+
+instance forall a . Eqq a => Eqq [a] where
+ [] === [] = True
+ (x:xs) === (y:ys) = x === y && xs === ys
+ _ === _ = False
+
+class (Eqq a) => Ordd a where
+ (<==) :: a -> a -> Bool
+
+instance Ordd Int where
+ (<==) = (<=)
+
+instance forall a b . (Eqq a, Eqq b) => Eqq (a, b) where
+ (a, b) === (a', b') = a === a' && b === b'
+
+f :: forall a . Eqq a => a -> Bool
+f x = x === x
+
+g :: forall a . Ordd a => a -> Bool
+g x = x /== x
+
+h :: forall a b . (Eqq a, Eqq b) => a -> b -> Bool
+h a b = a === a && b === b
+
+main :: IO ()
+main = do
+ putStrLn $ show $ f (5::Int)
+ putStrLn $ show $ g (5::Int)
+ putStrLn $ show $ h (5::Int) 'a'
+ putStrLn $ show $ f [88::Int]
+ putStrLn $ show $ f (1::Int, 'a')
--- /dev/null
+++ b/tests/Class.ref
@@ -1,0 +1,5 @@
+True
+False
+True
+True
+True
--- a/tests/Enum.hs
+++ b/tests/Enum.hs
@@ -3,10 +3,10 @@
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 ..]
+ putStrLn $ show [1::Int .. 5]
+ putStrLn $ show [1::Int .. 1]
+ putStrLn $ show [1::Int .. 0]
+ putStrLn $ show [1,3::Int .. 10]
+ putStrLn $ show [1::Int, -1 .. -5]
+ putStrLn $ show $ take 5 [1::Int ..]
+ putStrLn $ show $ take 5 [1,3::Int ..]
--- /dev/null
+++ b/tests/Eq.hs
@@ -1,0 +1,20 @@
+module Eq(main) where
+import Prelude
+import Data.Double()
+
+main :: IO ()
+main = do
+ putStrLn $ show [1==(1::Int), 'a'=='a', 1.1==(1.1::Double),
+ True==True, False==False,
+ (Nothing::Maybe Int)==Nothing, Just (1::Int) == Just 1,
+ [1,2,3] == [1,2,3::Int],
+ (1,2) == (1::Int,2::Int),
+ (Left 1 :: Either Int Char) == Left 1, (Right 'a' :: Either Int Char) == Right 'a'
+ ]
+ putStrLn $ show [1==(2::Int), 'a'=='b', 1.1==(1.2::Double),
+ True==False, False==True,
+ Nothing==Just (1::Int), Just (1::Int) == Nothing,
+ [1,2,3] == [1,2,4::Int],
+ (1,2) == (1::Int,4::Int),
+ Left (1::Int) == Right 'a', Right 'a' == Left (1::Int)
+ ]
--- /dev/null
+++ b/tests/Eq.ref
@@ -1,0 +1,2 @@
+[True,True,True,True,True,True,True,True,True,True,True]
+[False,False,False,False,False,False,False,False,False,False,False]
--- a/tests/FArith.hs
+++ b/tests/FArith.hs
@@ -1,25 +1,24 @@
module FArith(module FArith) where
import Prelude
-import qualified Data.Double as D
import Text.String
-list1 :: [D.Double]
-list1 = [-100.343241, -53.3248973, -0.0, 0.0, 1.0, 1.23453523, 3243534.34534, 999.999]
+list1 :: [Double]
+list1 = [-100.343241, -53.3248973, 0.0, 1.0, 1.23453523, 3243534.34534, 999.999]
-list2 :: [D.Double]
-list2 = [-100.343241, -53.3248973, -0.0, 0.0, 1.0, 1.23453523, 3243534.34534, 999.999]
+list2 :: [Double]
+list2 = [-100.343241, -53.3248973, 0.0, 1.0, 1.23453523, 3243534.34534, 999.999, 1.2e33]
-divide :: D.Double -> D.Double -> D.Double
-divide x y = if D.eqDouble y 0.0 then 0.0 else D.divDouble x y
+divide :: Double -> Double -> Double
+divide x y = if y == 0.0 then 0.0 else x / y
main :: IO ()
main = do
- putStrLn $ showList D.showDouble [ op x y | x <- list1, y <- list2, op <- [D.addDouble, D.subDouble, D.mulDouble, divide] ]
- putStrLn $ showList showBool [ op x y | x <- list1, y <- list2, op <- [D.eqDouble, D.neqDouble, D.ltDouble, D.leDouble, D.gtDouble, D.geDouble] ]
- putStrLn $ showList D.showDouble [ D.divDouble x y | x <- [2.234983, 1.232, 23.0], y <- [1.0, 5.0, 10.0, 100.0]]
- putStrLn $ showList D.showDouble [ D.divDouble x y | x <- [-2.234983, -1.232, -23.0], y <- [1.0, -5.0, 10.0, -100.0]]
+ putStrLn $ show [ op x y | x <- list1, y <- list2, op <- [(+), (-), (*), divide] ]
+ putStrLn $ show [ op x y | x <- list1, y <- list2, op <- [(==), (/=), (<), (<=), (>), (>=)] ]
+ putStrLn $ show [ x / y | x <- [2.234983, 1.232, 23.0::Double], y <- [1.0, 5.0, 10.0, 100.0]]
+ putStrLn $ show [ x / y | x <- [-2.234983, -1.232, -23.0::Double], y <- [1.0, -5.0, 10.0, -100.0]]
let str = readDouble "1.576"
- putStrLn $ D.showDouble str
- putStrLn $ D.showDouble $ D.addDouble 1.0 $ readDouble "2.5"
- putStrLn $ showList D.showDouble $ map readDouble ["1.5e42", "1.2e-90"]
+ putStrLn $ show str
+ putStrLn $ show $ 1.0 + readDouble "2.5"
+ putStrLn $ show $ map readDouble ["1.5e42", "1.2e-90"]
--- a/tests/FArith.ref
+++ b/tests/FArith.ref
@@ -1,5 +1,5 @@
-[-200.686482,0.0,10068.76601438408,1.0,-153.6681383,-47.0183437,5350.79302107415,1.881733413108702,-100.343241,-100.343241,0.0,0.0,-100.343241,-100.343241,-0.0,0.0,-99.34324100000001,-101.343241,-100.343241,-100.343241,-99.10870577,-101.57777623,-123.8772661068804,-81.28017618419848,3243434.002099,-3243634.688581,-325466748.5062289,-3.093638923360364e-05,899.655759,-1100.342241,-100343.140656759,-0.1003433413433413,-153.6681383,47.0183437,5350.79302107415,0.53142490484237,-106.6497946,0.0,2843.544672055548,1.0,-53.3248973,-53.3248973,0.0,0.0,-53.3248973,-53.3248973,-0.0,0.0,-52.3248973,-54.3248973,-53.3248973,-53.3248973,-52.09036207,-54.55943253,-65.83146435298188,-43.19430989425875,3243481.0204427,-3243587.6702373,-172961135.8542782,-1.644036770463433e-05,946.6741027,-1053.3238973,-53324.8439751027,-0.05332495062495063,-100.343241,100.343241,0.0,0.0,-53.3248973,53.3248973,0.0,0.0,-0.0,0.0,0.0,0.0,0.0,-0.0,-0.0,0.0,1.0,-1.0,-0.0,-0.0,1.23453523,-1.23453523,-0.0,-0.0,3243534.34534,-3243534.34534,-0.0,-0.0,999.999,-999.999,-0.0,-0.0,-100.343241,100.343241,-0.0,-0.0,-53.3248973,53.3248973,-0.0,-0.0,0.0,0.0,-0.0,0.0,0.0,0.0,0.0,0.0,1.0,-1.0,0.0,0.0,1.23453523,-1.23453523,0.0,0.0,3243534.34534,-3243534.34534,0.0,0.0,999.999,-999.999,0.0,0.0,-99.34324100000001,101.343241,-100.343241,-0.009965793311380085,-52.3248973,54.3248973,-53.3248973,-0.01875296626215912,1.0,1.0,-0.0,0.0,1.0,1.0,0.0,0.0,2.0,0.0,1.0,1.0,2.23453523,-0.2345352300000001,1.23453523,0.8100214361642801,3243535.34534,-3243533.34534,3243534.34534,3.083056609024981e-07,1000.999,-998.999,999.999,0.001000001000001,-99.10870577,101.57777623,-123.8772661068804,-0.01230312293779708,-52.09036207,54.55943253,-65.83146435298188,-0.02315119751763685,1.23453523,1.23453523,-0.0,0.0,1.23453523,1.23453523,0.0,0.0,2.23453523,0.2345352300000001,1.23453523,1.23453523,2.46907046,0.0,1.524077234111153,1.0,3243535.57987523,-3243533.11080477,4004257.419037217,3.806141999925675e-07,1001.23353523,-998.76446477,1234.53399546477,0.001234536464536465,3243434.002099,3243634.688581,-325466748.5062289,-32324.39288402096,3243481.0204427,3243587.6702373,-172961135.8542782,-60825.89014831539,3243534.34534,3243534.34534,-0.0,0.0,3243534.34534,3243534.34534,0.0,0.0,3243535.34534,3243533.34534,3243534.34534,3243534.34534,3243535.57987523,3243533.11080477,4004257.419037217,2627332.348660475,6487068.69068,0.0,10520515049400.18,1.0,3244534.34434,3242534.34634,3243531101.805655,3243.537588877589,899.655759,1100.342241,-100343.140656759,-9.965783345586773,946.6741027,1053.3238973,-53324.8439751027,-18.75294750919286,999.999,999.999,-0.0,0.0,999.999,999.999,0.0,0.0,1000.999,998.999,999.999,999.999,1001.23353523,998.76446477,1234.53399546477,810.020626142844,3244534.34434,-3242534.34634,3243531101.805655,0.0003083053525968371,1999.998,0.0,999998.000001,1.0]
-[True,False,False,True,False,True,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,False,False,True,True,True,False,False,True,False,True,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,False,False,True,True,False,True,False,False,True,True,True,False,False,True,False,True,True,False,False,True,False,True,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,False,False,True,True,False,True,False,False,True,True,True,False,False,True,False,True,True,False,False,True,False,True,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,True,False,False,True,False,True,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,True,False,False,True,False,True,False,True,True,True,False,False,False,True,True,True,False,False,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,True,False,False,True,False,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,True,True,False,False,True,False,False,True,False,True]
+[-200.686482,0.0,10068.76601438408,1.0,-153.6681383,-47.0183437,5350.79302107415,1.881733413108702,-100.343241,-100.343241,-0.0,0.0,-99.34324100000001,-101.343241,-100.343241,-100.343241,-99.10870577,-101.57777623,-123.8772661068804,-81.28017618419848,3243434.002099,-3243634.688581,-325466748.5062289,-3.093638923360364e-05,899.655759,-1100.342241,-100343.140656759,-0.1003433413433413,1.2e+33,-1.2e+33,-1.204118892e+35,-8.36193675e-32,-153.6681383,47.0183437,5350.79302107415,0.53142490484237,-106.6497946,0.0,2843.544672055548,1.0,-53.3248973,-53.3248973,-0.0,0.0,-52.3248973,-54.3248973,-53.3248973,-53.3248973,-52.09036207,-54.55943253,-65.83146435298188,-43.19430989425875,3243481.0204427,-3243587.6702373,-172961135.8542782,-1.644036770463433e-05,946.6741027,-1053.3238973,-53324.8439751027,-0.05332495062495063,1.2e+33,-1.2e+33,-6.398987676000001e+34,-4.443741441666667e-32,-100.343241,100.343241,-0.0,-0.0,-53.3248973,53.3248973,-0.0,-0.0,0.0,0.0,0.0,0.0,1.0,-1.0,0.0,0.0,1.23453523,-1.23453523,0.0,0.0,3243534.34534,-3243534.34534,0.0,0.0,999.999,-999.999,0.0,0.0,1.2e+33,-1.2e+33,0.0,0.0,-99.34324100000001,101.343241,-100.343241,-0.009965793311380085,-52.3248973,54.3248973,-53.3248973,-0.01875296626215912,1.0,1.0,0.0,0.0,2.0,0.0,1.0,1.0,2.23453523,-0.2345352300000001,1.23453523,0.8100214361642801,3243535.34534,-3243533.34534,3243534.34534,3.083056609024981e-07,1000.999,-998.999,999.999,0.001000001000001,1.2e+33,-1.2e+33,1.2e+33,8.333333333333333e-34,-99.10870577,101.57777623,-123.8772661068804,-0.01230312293779708,-52.09036207,54.55943253,-65.83146435298188,-0.02315119751763685,1.23453523,1.23453523,0.0,0.0,2.23453523,0.2345352300000001,1.23453523,1.23453523,2.46907046,0.0,1.524077234111153,1.0,3243535.57987523,-3243533.11080477,4004257.419037217,3.806141999925675e-07,1001.23353523,-998.76446477,1234.53399546477,0.001234536464536465,1.2e+33,-1.2e+33,1.481442276e+33,1.028779358333333e-33,3243434.002099,3243634.688581,-325466748.5062289,-32324.39288402096,3243481.0204427,3243587.6702373,-172961135.8542782,-60825.89014831539,3243534.34534,3243534.34534,0.0,0.0,3243535.34534,3243533.34534,3243534.34534,3243534.34534,3243535.57987523,3243533.11080477,4004257.419037217,2627332.348660475,6487068.69068,0.0,10520515049400.18,1.0,3244534.34434,3242534.34634,3243531101.805655,3243.537588877589,1.2e+33,-1.2e+33,3.892241214408e+39,2.702945287783333e-27,899.655759,1100.342241,-100343.140656759,-9.965783345586773,946.6741027,1053.3238973,-53324.8439751027,-18.75294750919286,999.999,999.999,0.0,0.0,1000.999,998.999,999.999,999.999,1001.23353523,998.76446477,1234.53399546477,810.020626142844,3244534.34434,-3242534.34634,3243531101.805655,0.0003083053525968371,1999.998,0.0,999998.000001,1.0,1.2e+33,-1.2e+33,1.1999988e+36,8.333325e-31]
+[True,False,False,True,False,True,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,False,False,True,True,True,False,False,True,False,True,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,False,False,True,True,False,True,False,False,True,True,True,False,False,True,False,True,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,True,False,False,True,False,True,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,True,False,False,True,False,True,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,True,False,False,True,False,True,False,True,False,False,True,True,False,True,True,True,False,False,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,True,True,False,False,True,False,False,True,False,True,False,True,True,True,False,False]
[2.234983,0.4469966,0.2234983,0.02234983,1.232,0.2464,0.1232,0.01232,23.0,4.6,2.3,0.23]
[-2.234983,0.4469966,-0.2234983,0.02234983,-1.232,0.2464,-0.1232,0.01232,-23.0,4.6,-2.3,0.23]
1.576
--- a/tests/Fac.ref
+++ b/tests/Fac.ref
@@ -1,2 +1,2 @@
-#720
-#6321337
+720
+6321337
--- /dev/null
+++ b/tests/Floating.hs
@@ -1,0 +1,8 @@
+module Floating(main) where
+import Prelude
+
+main :: IO ()
+main = do
+ print $ log (1000::Double)
+ print $ cos (pi::Double)
+ print $ sqrt (4::Double)
--- /dev/null
+++ b/tests/Floating.ref
@@ -1,0 +1,3 @@
+6.907755278982137
+-1.0
+2.0
--- a/tests/Foreign.hs
+++ b/tests/Foreign.hs
@@ -6,6 +6,6 @@
main :: IO ()
main = do
x1 <- abs (3 - 8)
- putStrLn $ showInt x1
+ putStrLn $ show x1
x2 <- abs (10 - 8)
- putStrLn $ showInt x2
+ putStrLn $ show x2
--- a/tests/Guard.hs
+++ b/tests/Guard.hs
@@ -12,4 +12,4 @@
main :: IO ()
main = do
- putStrLn $ showList showInt [f [0 - 7], f [5], f [20], f [2,3], f [1,2,3], f[1,2,3,4]]
+ putStrLn $ show [f [0 - 7], f [5], f [20], f [2,3], f [1,2,3], f[1,2,3,4]]
--- a/tests/IOTest.hs
+++ b/tests/IOTest.hs
@@ -8,7 +8,7 @@
f x = x*2+1
foo :: IO ()
-foo = IO.do
+foo = do
putStrLn "foo 1"
putStrLn "foo 2"
@@ -23,7 +23,7 @@
p
p
p
- print (+)
+ cprint ((+) :: Int->Int->Int)
hout <- openFile "test.tmp" WriteMode
hPutChar hout 'a'
hPutChar hout 'z'
@@ -31,18 +31,18 @@
hin <- openFile "test.tmp" ReadMode
c1 <- hGetChar hin
c2 <- hGetChar hin
- putStrLn $ showPair showChar showChar (c1, c2)
+ putStrLn $ show (c1, c2)
writeFile "test2.tmp" "more\n"
s <- readFile "test2.tmp"
- putStrLn (showString s)
+ putStrLn (show s)
writeSerialized "f.tmp" f
g <- readSerialized "f.tmp"
- putStrLn $ showInt $ g 5
+ putStrLn $ show $ (g (5::Int) :: Int)
foo
- putStrLn $ showInt $ trace "tracing" 5
+ putStrLn $ show $ trace "tracing" (5::Int)
as <- getArgs
- putStrLn $ showList showString as
- putStrLn $ showInt $ seq (1 + 2) 5
- putStrLn $ showInt $ seq (1 + trace "seq" 2) 5
+ putStrLn $ show as
+ putStrLn $ show $ seq ((1::Int) + (2::Int)) (5::Int)
+ putStrLn $ show $ seq ((1::Int) + trace "seq" (2::Int)) (5::Int)
tend <- getTimeMilli
- putStrLn $ showInt (tend - tstart) ++ "ms execution time"
+ putStrLn $ show (tend - tstart) ++ "ms execution time"
--- a/tests/Infix.hs
+++ b/tests/Infix.hs
@@ -16,4 +16,4 @@
main :: IO ()
main = do
- putStrLn $ showBool $ 2 +++ 3 &&& 4 === 17
+ putStrLn $ show $ 2 +++ 3 &&& 4 === 17
--- a/tests/ListTest.hs
+++ b/tests/ListTest.hs
@@ -3,7 +3,7 @@
main :: IO ()
main = do
- putStrLn $ showInt $ sum [1,2,3]
- putStrLn $ showInt $ product [1,2,3,4]
- putStrLn $ showBool $ and [True]
- putStrLn $ showBool $ and [True, False]
+ putStrLn $ show $ sum [1,2,3::Int]
+ putStrLn $ show $ product [1,2,3,4::Int]
+ putStrLn $ show $ and [True]
+ putStrLn $ show $ and [True, False]
--- a/tests/LitMatch.hs
+++ b/tests/LitMatch.hs
@@ -25,7 +25,7 @@
main :: IO ()
main = do
- putStrLn $ showList showInt [f 0, f 1, f 10]
- putStrLn $ showList showInt [g 1 0, g 1 1, g 2 0, g 2 1, g 2 2]
- putStrLn $ showList showInt [h 'a', h 'b', h 'c']
- putStrLn $ showList showInt [s "aaa", s "apa", s "foo"]
+ putStrLn $ show [f 0, f 1, f 10]
+ putStrLn $ show [g 1 0, g 1 1, g 2 0, g 2 1, g 2 2]
+ putStrLn $ show [h 'a', h 'b', h 'c']
+ putStrLn $ show [s "aaa", s "apa", s "foo"]
--- a/tests/LocalPoly.hs
+++ b/tests/LocalPoly.hs
@@ -3,7 +3,7 @@
main :: IO ()
main = do
- putStrLn $ showPair (showPair showInt showString) (showPair showString showString) $ f 1 "a"
+ putStrLn $ show $ f 1 "a"
f :: forall b . Int -> b -> ((Int, b), (b, b))
f x b = (i x, i b)
--- a/tests/Makefile
+++ b/tests/Makefile
@@ -24,6 +24,9 @@
$(MHS) Catch && $(EVAL) > Catch.out && diff Catch.ref Catch.out
$(MHS) FArith && $(EVAL) > FArith.out && diff FArith.ref FArith.out
$(MHS) Infix && $(EVAL) > Infix.out && diff Infix.ref Infix.out
+ $(MHS) Class && $(EVAL) > Class.out && diff Class.ref Class.out
+ $(MHS) Eq && $(EVAL) > Eq.out && diff Eq.ref Eq.out
+ $(MHS) Floating && $(EVAL) > Floating.out && diff Floating.ref Floating.out
errtest:
sh errtester.sh < errmsg.test
@@ -34,4 +37,3 @@
clean:
rm -f *.out *.tmp
-
--- a/tests/Misc.hs
+++ b/tests/Misc.hs
@@ -8,4 +8,4 @@
main :: IO ()
main = do
- print $ first (10,20)
+ print $ first (10::Int,20::Int)
--- a/tests/Misc.ref
+++ b/tests/Misc.ref
@@ -1,1 +1,1 @@
-#10
+10
--- a/tests/MutRec.hs
+++ b/tests/MutRec.hs
@@ -5,4 +5,4 @@
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]
+ putStrLn $ show $ map even [1::Int .. 5] ++ map odd [1 .. 5]
--- a/tests/Newtype.hs
+++ b/tests/Newtype.hs
@@ -15,6 +15,5 @@
main :: IO ()
main = do
- putStrLn $ showList showInt [f (N 1), f (N 2)]
- putStrLn $ showM showInt (g (M (3,4)))
-
+ putStrLn $ show [f (N 1), f (N 2)]
+ putStrLn $ showM show (g (M (3,4)))
--- a/tests/Rank2.hs
+++ b/tests/Rank2.hs
@@ -2,10 +2,10 @@
import Prelude
f :: (forall a . a -> a) -> (Int, Bool)
-f i = (i 1, i True)
+f i = (i (1::Int), i True)
g :: (forall a . a -> Int -> a) -> (Int, Bool)
-g c = (c 1 1, c True 1)
+g c = (c (1::Int) (1::Int), c True (1::Int))
data Id = Id (forall a . a -> a)
@@ -14,7 +14,7 @@
main :: IO ()
main = do
- putStrLn $ showPair showInt showBool $ f id
- putStrLn $ showPair showInt showBool $ g const
+ putStrLn $ show $ f id
+ putStrLn $ show $ g const
case iD of
- Id i -> putStrLn $ showPair showInt showBool (i 1, i True)
+ Id i -> putStrLn $ show (i (1::Int), i True)
--- a/tests/StringTest.hs
+++ b/tests/StringTest.hs
@@ -3,20 +3,20 @@
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)
- putStrLn $ showChar 'x'
- putStrLn $ showChar '\n'
- putStrLn $ showBool False
+ putStrLn $ if (==) "abc" "abc" then "yes" else "no"
+ putStrLn $ if (==) "abc" "adc" then "yes" else "no"
+ putStrLn $ show (1234::Int)
+ putStrLn $ show (0::Int)
+ putStrLn $ show (negate (567::Int))
+ putStrLn $ show 'x'
+ putStrLn $ show '\n'
+ putStrLn $ show False
-- putStrLn $ showUnit ()
- putStrLn $ showList showInt [1,20,3]
- putStrLn $ showList showInt [1]
- putStrLn $ showList showInt []
- putStrLn $ showPair showInt showChar (123, 'a')
- putStrLn $ showMaybe showInt Nothing
- putStrLn $ showMaybe showInt (Just 890)
- putStrLn $ showEither showInt showBool (Left 678)
- putStrLn $ showEither showInt showBool (Right True)
+ putStrLn $ show [1,20,3::Int]
+ putStrLn $ show [1::Int]
+ putStrLn $ show ([] :: [Int])
+ putStrLn $ show (123::Int, 'a')
+ putStrLn $ show (Nothing :: Maybe Int)
+ putStrLn $ show (Just 890 :: Maybe Int)
+ putStrLn $ show (Left 678 :: Either Int Bool)
+ putStrLn $ show (Right True :: Either Int Bool)
--- a/tests/StringTest.ref
+++ b/tests/StringTest.ref
@@ -11,6 +11,6 @@
[]
(123,'a')
Nothing
-(Just 890)
-(Left 678)
-(Right True)
+Just 890
+Left 678
+Right True
--- a/tests/Word.hs
+++ b/tests/Word.hs
@@ -1,13 +1,13 @@
module Word(main) where
import Prelude
-import qualified Data.Word as W
+import Data.Word
main :: IO ()
main = do
- putStrLn $ showInt 4294967295
- putStrLn $ W.showWord (W.intToWord 1000)
- putStrLn $ W.showWord twoTo32M1
- putStrLn $ W.showWord $ (W.*) twoTo32M1 twoTo32M1
+ putStrLn $ show (4294967295::Int)
+ putStrLn $ show (1000::Word)
+ putStrLn $ show twoTo32M1
+ putStrLn $ show $ (*) twoTo32M1 twoTo32M1
-twoTo32M1 :: W.Word
-twoTo32M1 = W.intToWord 4294967295
+twoTo32M1 :: Word
+twoTo32M1 = 4294967295::Word
--- a/tests/errmsg.test
+++ b/tests/errmsg.test
@@ -1,22 +1,134 @@
+amodule M() where
+-----
+mhs: "../tmp/E.hs": line 2, col 1:
+ found: amodule
+ expected: module
+
+=====
+module M() where
+x :: Int
+x = 1 +
+y = 0
+-----
+mhs: "../tmp/E.hs": line 5, col 1:
+ found: ;
+ expected: LQIdent ( UQIdent [ literal primitive \ case let if QualDo do
+
+=====
+module E() where
+import Prelude
x = y
-----
-mhs: "../tmp/E.hs": line 3, col 1: undefined no type signature: x
+mhs: "../tmp/E.hs": line 4, col 1: no type signature: x
+
=====
+module E() where
+import Prelude
x :: Int
x = y
-----
-mhs: "../tmp/E.hs": line 4, col 5: undefined variable: y
+mhs: "../tmp/E.hs": line 5, col 5: undefined value identifier: y
+
=====
+module E() where
+import Prelude
+x :: Int
+x = A
+-----
+mhs: "../tmp/E.hs": line 5, col 5: undefined value identifier: A
+
+=====
+module E() where
+import Prelude
+import Control.Monad.State.Strict
+x :: Int
+x = fmap
+-----
+mhs: "../tmp/E.hs": line 6, col 5: ambiguous value identifier: fmap
+
+=====
+module E() where
+import Prelude
x :: T
x = 1
-----
-mhs: "../tmp/E.hs": line 3, col 6: undefined variable: T
+mhs: "../tmp/E.hs": line 4, col 6: undefined type identifier: T
+
=====
+module E() where
+import Prelude
+x :: a
+x = 1
+-----
+mhs: "../tmp/E.hs": line 4, col 6: undefined type identifier: a
+
+=====
+module E() where
+import Prelude
+x :: Int
+x = 1
+y :: Int
+y = 2
+x :: Int
+x = 3
+-----
+mhs: "../tmp/E.hs": line 2, col 8: duplicate definition E.x
+
+=====
+module E() where
+import Prelude
type T a = [a]
data D (f :: Type -> Type) = D (f Int)
x :: D T
x = [0]
-----
-mhs: "../tmp/E.hs": line 5, col 8: bad synonym use
+mhs: "../tmp/E.hs": line 6, col 8: bad synonym use
+
+=====
+module E(fmap) where
+import Prelude
+import Control.Monad.State.Strict
+-----
+mhs: "../tmp/E.hs": line 2, col 10: ambiguous export fmap
+
+=====
+module E(module M) where
+-----
+mhs: "../tmp/E.hs": line 2, col 17: export undefined M
+
+=====
+module E(M) where
+-----
+mhs: "../tmp/E.hs": line 2, col 10: export undefined M
+
+=====
+module E() where
+import Prelude
+infixl 5 +++
+infixr 5 ***
+(+++) :: Int -> Int -> Int
+(+++) = (+)
+(***) :: Int -> Int -> Int
+(***) = (*)
+x :: Int
+x = 1 +++ 2 *** 3
+-----
+mhs: "../tmp/E.hs": line 11, col 13: ambiguous operator expression
+
+=====
+module E() where
+import Prelude
+a :: Int
+a = 'a'
+-----
+mhs: "../tmp/E.hs": line 5, col 5: type error: cannot unify Primitives.Char and Primitives.Int
+
+=====
+module E() where
+import Prelude
+data T = C Maybe
+-----
+mhs: "../tmp/E.hs": line 4, col 12: kind error: cannot unify Primitives.Type and (a0 -> a1)
+
=====
END
--- a/tests/errtester.sh
+++ b/tests/errtester.sh
@@ -3,12 +3,12 @@
tmp=../tmp
out=$tmp/E.hs
err=$tmp/err
+terr=$tmp/terr
cerr=$tmp/cerr
comp=../bin/mhs
read -r line
while [ "$line" != "END" ]; do
- echo "module E(module E) where" > $out
- echo "import Prelude" >> $out
+ echo > $out
while true; do
if [ "$line" = "-----" ]; then
break
@@ -16,13 +16,13 @@
echo "$line" >> $out
read -r line
done
- cp /dev/null $err
+ echo > $terr
read -r line
while true; do
if [ "$line" = "=====" ]; then
break
fi
- echo "$line" >> $err
+ echo "$line" >> $terr
read -r line
done
read -r line
@@ -33,6 +33,7 @@
#cat $err
#echo "==="
#echo "next: $line"
+ sed -e '/^ *$/d' $terr > $err
$comp -i../lib -i../tmp E 2>&1 | sed -e '/CallStack/,$d' -e '/^XX/d' > $cerr
diff $err $cerr || exit 1
done
--
⑨