diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,37 @@ +.PHONY: build configure doc install linecount nodefault pinstall relib test + +include config.mk +-include custom.mk + +install: + $(CABAL) install $(CABALFLAGS) + +pinstall: CABALFLAGS += --enable-executable-profiling +pinstall: dist/setup-config + $(CABAL) install $(CABALFLAGS) + +build: dist/setup-config + $(CABAL) build $(CABALFLAGS) + +test: + make -C test IDRIS=../dist/build/idris + +test_java: + make -C test IDRIS=../dist/build/idris test_java + +relib: + make -C lib IDRIS=../dist/build/idris/idris RTS=../dist/build/rts/libidris_rts clean + make -C effects IDRIS=../dist/build/idris/idris RTS=../dist/build/rts/libidris_rts DIST=../dist/build clean + make -C javascript IDRIS=../dist/build/idris/idris RTS=../dist/build/rts/libidris_rts DIST=../dist/build clean + $(CABAL) install $(CABALFLAGS) + +linecount: + wc -l src/Idris/*.hs src/Core/*.hs src/IRTS/*.hs src/Pkg/*.hs + +#Note: this doesn't yet link to Hackage properly +doc: dist/setup-config + $(CABAL) haddock --executables --hyperlink-source --html --hoogle --html-location="http://hackage.haskell.org/packages/archive/\$$pkg/latest/doc/html" --haddock-options="--title Idris" + + +dist/setup-config: + $(CABAL) configure $(CABALFLAGS) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -21,7 +21,6 @@ -- After Idris is built, we need to check and install the prelude and other libs make verbosity = P.runProgramInvocation verbosity . P.simpleProgramInvocation "make" -mvn verbosity = P.runProgramInvocation verbosity . P.simpleProgramInvocation "mvn" #ifdef mingw32_HOST_OS -- make on mingw32 exepects unix style separators @@ -38,15 +37,14 @@ cleanStdLib verbosity = do make verbosity [ "-C", "lib", "clean", "IDRIS=idris" ] make verbosity [ "-C", "effects", "clean", "IDRIS=idris" ] + make verbosity [ "-C", "javascript", "clean", "IDRIS=idris" ] -cleanJavaLib verbosity - = do dirty <- doesDirectoryExist ("java" "target") - when dirty $ mvn verbosity [ "-f", "java/pom.xml", "clean" ] - pomExists <- doesFileExist ("java" "pom.xml") - when pomExists $ removeFile ("java" "pom.xml") - execPomExists <- doesFileExist ("java" "executable_pom.xml") - when pomExists $ removeFile ("java" "executable_pom.xml") +cleanJavaPom verbosity + = do execPomExists <- doesFileExist ("java" "executable_pom.xml") + when execPomExists $ removeFile ("java" "executable_pom.xml") +cleanLLVMLib verbosity = make verbosity ["-C", "llvm", "clean"] + installStdLib pkg local withoutEffects verbosity copy = do let dirs = L.absoluteInstallDirs pkg local copy let idir = datadir dirs @@ -63,6 +61,11 @@ , "TARGET=" ++ idir , "IDRIS=" ++ icmd ] + make verbosity + [ "-C", "javascript", "install" + , "TARGET=" ++ idir + , "IDRIS=" ++ icmd + ] let idirRts = idir "rts" putStrLn $ "Installing run time system in " ++ idirRts make verbosity @@ -71,17 +74,14 @@ , "IDRIS=" ++ icmd ] -installJavaLib pkg local verbosity copy version = do - let rtsFile = "idris-" ++ display version ++ ".jar" - putStrLn $ "Installing java libraries" - mvn verbosity [ "install:install-file" - , "-Dfile=" ++ ("java" "target" rtsFile) - , "-DgroupId=org.idris-lang" - , "-DartifactId=idris" - , "-Dversion=" ++ display version - , "-Dpackaging=jar" - , "-DgeneratePom=True" - ] +installLLVMLib verbosity pkg local copy = + let idir = datadir $ L.absoluteInstallDirs pkg local copy in + make verbosity ["-C", "llvm", "install", "TARGET=" ++ idir "llvm"] + +buildLLVMLib verbosity = make verbosity ["-C", "llvm", "all"] + +installJavaPom pkg local verbosity copy version = do + putStrLn $ "Installing java pom template" let dir = datadir $ L.absoluteInstallDirs pkg local copy copyFile ("java" "executable_pom.xml") (dir "executable_pom.xml") @@ -110,17 +110,19 @@ , "IDRIS=" ++ icmd ] make verbosity + [ "-C", "javascript", "check" + , "IDRIS=" ++ icmd + ] + make verbosity [ "-C", "rts", "check" , "IDRIS=" ++ icmd ] -checkJavaLib verbosity = mvn verbosity [ "-f", "java" "pom.xml", "package" ] - -javaFlag flags = - case lookup (FlagName "java") (S.configConfigurationsFlags flags) of +llvmFlag flags = + case lookup (FlagName "llvm") (S.configConfigurationsFlags flags) of Just True -> True Just False -> False - Nothing -> False + Nothing -> True noEffectsFlag flags = case lookup (FlagName "noeffects") (S.configConfigurationsFlags flags) of @@ -129,9 +131,7 @@ Nothing -> False preparePoms version - = do pomTemplate <- TIO.readFile ("java" "pom_template.xml") - TIO.writeFile ("java" "pom.xml") (insertVersion pomTemplate) - execPomTemplate <- TIO.readFile ("java" "executable_pom_template.xml") + = do execPomTemplate <- TIO.readFile ("java" "executable_pom_template.xml") TIO.writeFile ("java" "executable_pom.xml") (insertVersion execPomTemplate) where insertVersion template = @@ -146,29 +146,32 @@ let withoutEffects = noEffectsFlag $ configFlags lbi installStdLib pkg lbi withoutEffects verb (S.fromFlag $ S.copyDest flags) - , postInst = \ _ flags pkg lbi -> do + installJavaPom pkg lbi verb + (S.fromFlag $ S.copyDest flags) + (pkgVersion . package $ localPkgDescr lbi) + when (llvmFlag $ configFlags lbi) + (installLLVMLib verb pkg lbi (S.fromFlag $ S.copyDest flags)) + , postInst = \ _ flags pkg lbi -> do let verb = (S.fromFlag $ S.installVerbosity flags) let withoutEffects = noEffectsFlag $ configFlags lbi installStdLib pkg lbi withoutEffects verb NoCopyDest - when (javaFlag $ configFlags lbi) - (installJavaLib pkg - lbi - verb + installJavaPom pkg lbi verb NoCopyDest (pkgVersion . package $ localPkgDescr lbi) - ) + when (llvmFlag $ configFlags lbi) + (installLLVMLib verb pkg lbi NoCopyDest) , postConf = \ _ flags _ lbi -> do removeLibIdris lbi (S.fromFlag $ S.configVerbosity flags) - when (javaFlag $ configFlags lbi) - (preparePoms . pkgVersion . package $ localPkgDescr lbi) + preparePoms . pkgVersion . package $ localPkgDescr lbi , postClean = \ _ flags _ _ -> do let verb = S.fromFlag $ S.cleanVerbosity flags cleanStdLib verb - cleanJavaLib verb + cleanLLVMLib verb + cleanJavaPom verb , postBuild = \ _ flags _ lbi -> do let verb = S.fromFlag $ S.buildVerbosity flags + when (llvmFlag $ configFlags lbi) (buildLLVMLib verb) let withoutEffects = noEffectsFlag $ configFlags lbi checkStdLib lbi withoutEffects verb - when (javaFlag $ configFlags lbi) (checkJavaLib verb) } diff --git a/config.mk b/config.mk --- a/config.mk +++ b/config.mk @@ -2,8 +2,6 @@ CC :=gcc CABAL :=cabal #CABALFLAGS := -## Enable Java RTS: -#CABALFLAGS :=-f Java ## Disable building of Effects #CABALFLAGS :=-f NoEffects diff --git a/effects/Effect/Memory.idr b/effects/Effect/Memory.idr --- a/effects/Effect/Memory.idr +++ b/effects/Effect/Memory.idr @@ -21,9 +21,9 @@ Peek : (offset : Nat) -> (size : Nat) -> so (offset + size <= i) -> - RawMemory (MemoryChunk n i) (MemoryChunk n i) (Vect Bits8 size) + RawMemory (MemoryChunk n i) (MemoryChunk n i) (Vect size Bits8) Poke : (offset : Nat) -> - (Vect Bits8 size) -> + (Vect size Bits8) -> so (offset <= i && offset + size <= n) -> RawMemory (MemoryChunk n i) (MemoryChunk n (max i (offset + size))) () Move : (src : MemoryChunk src_size src_init) -> @@ -39,7 +39,7 @@ private do_malloc : Nat -> IOExcept String Ptr do_malloc size with (fromInteger (cast size) == size) - | True = do ptr <- ioe_lift $ mkForeign (FFun "malloc" [FInt] FPtr) (cast size) + | True = do ptr <- ioe_lift $ mkForeign (FFun "malloc" [FInt] FPtr) (fromInteger $ cast size) fail <- ioe_lift $ nullPtr ptr if fail then ioe_fail "Cannot allocate memory" else return ptr @@ -48,8 +48,8 @@ private do_memset : Ptr -> Nat -> Bits8 -> Nat -> IO () do_memset ptr offset c size - = mkForeign (FFun "idris_memset" [FPtr, FInt, FChar, FInt] FUnit) - ptr (cast offset) c (cast size) + = mkForeign (FFun "idris_memset" [FPtr, FInt, FByte, FInt] FUnit) + ptr (fromInteger $ cast offset) c (fromInteger $ cast size) private do_free : Ptr -> IO () @@ -59,21 +59,21 @@ do_memmove : Ptr -> Ptr -> Nat -> Nat -> Nat -> IO () do_memmove dest src dest_offset src_offset size = mkForeign (FFun "idris_memmove" [FPtr, FPtr, FInt, FInt, FInt] FUnit) - dest src (cast dest_offset) (cast src_offset) (cast size) + dest src (fromInteger $ cast dest_offset) (fromInteger $ cast src_offset) (fromInteger $ cast size) private -do_peek : Ptr -> Nat -> (size : Nat) -> IO (Vect Bits8 size) -do_peek _ _ O = return (Prelude.Vect.Nil) +do_peek : Ptr -> Nat -> (size : Nat) -> IO (Vect size Bits8) +do_peek _ _ Z = return (Prelude.Vect.Nil) do_peek ptr offset (S n) - = do b <- mkForeign (FFun "idris_peek" [FPtr, FInt] FChar) ptr (cast offset) + = do b <- mkForeign (FFun "idris_peek" [FPtr, FInt] FByte) ptr (fromInteger $ cast offset) bs <- do_peek ptr (S offset) n Prelude.Monad.return (Prelude.Vect.(::) b bs) private -do_poke : Ptr -> Nat -> Vect Bits8 size -> IO () +do_poke : Ptr -> Nat -> Vect size Bits8 -> IO () do_poke _ _ [] = return () do_poke ptr offset (b::bs) - = do mkForeign (FFun "idris_poke" [FPtr, FInt, FChar] FUnit) ptr (cast offset) b + = do mkForeign (FFun "idris_poke" [FPtr, FInt, FByte] FUnit) ptr (fromInteger $ cast offset) b do_poke ptr (S offset) bs instance Handler RawMemory (IOExcept String) where @@ -117,13 +117,13 @@ (offset : Nat) -> (size : Nat) -> so (offset + size <= i) -> - Eff m [RAW_MEMORY (MemoryChunk n i)] (Vect Bits8 size) + Eff m [RAW_MEMORY (MemoryChunk n i)] (Vect size Bits8) peek offset size prf = Peek offset size prf poke : {n : Nat} -> {i : Nat} -> (offset : Nat) -> - Vect Bits8 size -> + Vect size Bits8 -> so (offset <= i && offset + size <= n) -> EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY (MemoryChunk n (max i (offset + size)))] () poke offset content prf = Poke offset content prf diff --git a/effects/Effects.idr b/effects/Effects.idr --- a/effects/Effects.idr +++ b/effects/Effects.idr @@ -48,6 +48,8 @@ updateWith (y :: ys) (x :: xs) (Keep rest) = y :: updateWith ys xs rest updateWith ys (x :: xs) (Drop rest) = x :: updateWith ys xs rest updateWith [] [] SubNil = [] +updateWith (y :: ys) [] SubNil = y :: ys +updateWith [] (x :: xs) (Keep rest) = [] -- put things back, replacing old with new in the sub-environment rebuildEnv : Env m ys' -> (prf : SubList ys xs) -> @@ -55,18 +57,19 @@ rebuildEnv [] SubNil env = env rebuildEnv (x :: xs) (Keep rest) (y :: env) = x :: rebuildEnv xs rest env rebuildEnv xs (Drop rest) (y :: env) = y :: rebuildEnv xs rest env +rebuildEnv (x :: xs) SubNil [] = x :: xs ---- The Effect EDSL itself ---- -- some proof automation findEffElem : Nat -> List (TTName, Binder TT) -> TT -> Tactic -- Nat is maximum search depth -findEffElem O ctxt goal = Refine "Here" `Seq` Solve +findEffElem Z ctxt goal = Refine "Here" `Seq` Solve findEffElem (S n) ctxt goal = GoalType "EffElem" (Try (Refine "Here" `Seq` Solve) (Refine "There" `Seq` (Solve `Seq` findEffElem n ctxt goal))) findSubList : Nat -> List (TTName, Binder TT) -> TT -> Tactic -findSubList O ctxt goal = Refine "SubNil" `Seq` Solve +findSubList Z ctxt goal = Refine "SubNil" `Seq` Solve findSubList (S n) ctxt goal = GoalType "SubList" (Try (Refine "subListId" `Seq` Solve) @@ -160,6 +163,9 @@ = handle val eff' (\res, v => k (res :: env) v) execEff (val :: env) (There p) eff k = execEff env p eff (\env', v => k (val :: env') v) + +-- Q: Instead of m b, implement as StateT (Env m xs') m b, so that state +-- updates can be propagated even through failing computations? eff : Env m xs -> EffM m xs xs' a -> (Env m xs' -> a -> m b) -> m b eff env (value x) k = k env x diff --git a/idris.cabal b/idris.cabal --- a/idris.cabal +++ b/idris.cabal @@ -1,5 +1,5 @@ Name: idris -Version: 0.9.8 +Version: 0.9.9 License: BSD3 License-file: LICENSE Author: Edwin Brady @@ -47,8 +47,8 @@ Build-type: Custom -Data-files: rts/libidris_rts.a rts/idris_rts.h rts/idris_gc.h - rts/idris_stdfgn.h rts/idris_main.c rts/idris_gmp.h +Data-files: rts/idris_rts.h rts/idris_gc.h rts/idris_stdfgn.h + rts/idris_main.c rts/idris_gmp.h rts/libtest.c js/Runtime-common.js js/Runtime-node.js @@ -64,23 +64,184 @@ tutorial/examples/*.idr lib/base.ipkg effects/Makefile effects/*.idr effects/Effect/*.idr effects/effects.ipkg + javascript/Makefile + javascript/JavaScript/*.idr + javascript/*.idr + javascript/javascript.ipkg config.mk rts/*.c rts/*.h rts/Makefile + llvm/*.c llvm/Makefile js/*.js - java/src/main/java/org/idris/rts/*.java + java/*.xml + Makefile + test/Makefile + test/runtest.pl + test/reg001/run + test/reg001/*.idr + test/reg001/expected + test/reg002/run + test/reg002/*.idr + test/reg002/expected + test/reg003/run + test/reg003/*.idr + test/reg003/expected + test/reg004/run + test/reg004/*.idr + test/reg004/expected + test/reg005/run + test/reg005/*.idr + test/reg005/expected + test/reg006/run + test/reg006/*.idr + test/reg006/expected + test/reg007/run + test/reg007/*.lidr + test/reg007/expected + test/reg008/run + test/reg008/*.idr + test/reg008/expected + test/reg009/run + test/reg009/*.lidr + test/reg009/expected + test/reg010/run + test/reg010/*.idr + test/reg010/expected + test/reg011/run + test/reg011/*.idr + test/reg011/expected + test/reg012/run + test/reg012/*.lidr + test/reg012/expected + test/reg013/run + test/reg013/*.idr + test/reg013/expected + test/reg014/run + test/reg014/*.idr + test/reg014/expected + test/reg015/run + test/reg015/*.idr + test/reg015/expected + test/reg016/run + test/reg016/*.idr + test/reg016/expected + test/reg017/run + test/reg017/*.idr + test/reg017/expected + test/reg018/run + test/reg018/*.idr + test/reg018/expected + test/reg019/run + test/reg019/*.idr + test/reg019/expected + test/reg020/run + test/reg020/*.idr + test/reg020/expected + test/test001/run + test/test001/*.idr + test/test001/expected + test/test002/run + test/test002/*.idr + test/test002/expected + test/test003/run + test/test003/*.lidr + test/test003/expected + test/test004/run + test/test004/*.idr + test/test004/expected + test/test005/run + test/test005/*.idr + test/test005/expected + test/test006/run + test/test006/*.idr + test/test006/expected + test/test007/run + test/test007/*.idr + test/test007/expected + test/test008/run + test/test008/*.idr + test/test008/expected + test/test009/run + test/test009/*.idr + test/test009/expected + test/test010/run + test/test010/*.idr + test/test010/expected + test/test011/run + test/test011/*.idr + test/test011/expected + test/test012/run + test/test012/*.idr + test/test012/expected + test/test013/run + test/test013/*.idr + test/test013/expected + test/test014/run + test/test014/*.idr + test/test014/test + test/test014/expected + test/test015/run + test/test015/*.idr + test/test015/expected + test/test016/run + test/test016/*.idr + test/test016/expected + test/test017/run + test/test017/*.idr + test/test017/expected + test/test018/run + test/test018/*.idr + test/test018/expected + test/test019/run + test/test019/*.lidr + test/test019/expected + test/test020/run + test/test020/*.idr + test/test020/expected + test/test021/run + test/test021/*.idr + test/test021/testFile + test/test021/expected + test/test022/run + test/test022/*.idr + test/test022/expected + test/test023/run + test/test023/*.idr + test/test023/expected + test/test024/run + test/test024/*.idr + test/test024/input + test/test024/expected + test/test025/run + test/test025/*.idr + test/test025/expected + test/test026/run + test/test026/*.idr + test/test026/input + test/test026/theType + test/test026/theOtherType + test/test026/expected + test/test027/run + test/test027/*.idr + test/test027/expected + test/test028/run + test/test028/*.idr + test/test028/expected + + source-repository head type: git location: git://github.com/edwinb/Idris-dev.git -Flag Java - Description: Build the Java RTS - Default: False - Flag NoEffects Description: Do not build the effects package Default: False +Flag LLVM + Description: Build the LLVM backend + Default: True + manual: True + Executable idris Main-is: Main.hs hs-source-dirs: src @@ -97,14 +258,15 @@ Idris.Coverage, Idris.IBC, Idris.Unlit, Idris.DataOpts, Idris.Transforms, Idris.DSL, Idris.UnusedArgs, Idris.Docs, Idris.Completion, - Idris.Providers, + Idris.PartialEval, Idris.Providers, Util.Pretty, Util.System, Util.DynamicLinker, Pkg.Package, Pkg.PParser, IRTS.Lang, IRTS.LParser, IRTS.Bytecode, IRTS.Simplified, IRTS.CodegenC, IRTS.Defunctionalise, IRTS.Inliner, - IRTS.Compiler, IRTS.CodegenJava, IRTS.BCImp, + IRTS.Compiler, IRTS.CodegenJava, IRTS.Java.ASTBuilding, + IRTS.Java.JTypes, IRTS.Java.Mangling, IRTS.BCImp, IRTS.CodegenJavaScript, IRTS.CodegenCommon, IRTS.DumpBC @@ -114,7 +276,8 @@ haskeline>=0.7, split, directory, containers, process, transformers, filepath, directory, binary, bytestring, text, pretty, - language-java>=0.2.2, libffi + language-java>=0.2.2, libffi, + vector, vector-binary-instances Extensions: MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TemplateHaskell @@ -129,3 +292,9 @@ if os(windows) cpp-options: -DWINDOWS build-depends: Win32 + if flag(LLVM) + other-modules: IRTS.CodegenLLVM + cpp-options: -DIDRIS_LLVM + build-depends: llvm-general==3.3.5.* + else + other-modules: Util.LLVMStubs diff --git a/java/executable_pom.xml b/java/executable_pom.xml new file mode 100644 --- /dev/null +++ b/java/executable_pom.xml @@ -0,0 +1,66 @@ + + 4.0.0 + org.idris-lang + $ARTIFACT-NAME$ + jar + 1.0 + $ARTIFACT-NAME$ + + + UTF-8 + true + + + + org.idris-lang + idris + 0.9.9 + +$DEPENDENCIES$ + + + + + $ARTIFACT-NAME$ + + + org.apache.maven.plugins + maven-compiler-plugin + 3.0 + + 1.7 + 1.7 + + + + org.apache.maven.plugins + maven-surefire-plugin + 2.14 + + ${skipTests} + + + + org.apache.maven.plugins + maven-shade-plugin + 2.0 + + + package + + shade + + + + + $MAIN-CLASS$ + + + + + + + + + diff --git a/java/executable_pom_template.xml b/java/executable_pom_template.xml new file mode 100644 --- /dev/null +++ b/java/executable_pom_template.xml @@ -0,0 +1,66 @@ + + 4.0.0 + org.idris-lang + $ARTIFACT-NAME$ + jar + 1.0 + $ARTIFACT-NAME$ + + + UTF-8 + true + + + + org.idris-lang + idris + $RTS-VERSION$ + +$DEPENDENCIES$ + + + + + $ARTIFACT-NAME$ + + + org.apache.maven.plugins + maven-compiler-plugin + 3.0 + + 1.7 + 1.7 + + + + org.apache.maven.plugins + maven-surefire-plugin + 2.14 + + ${skipTests} + + + + org.apache.maven.plugins + maven-shade-plugin + 2.0 + + + package + + shade + + + + + $MAIN-CLASS$ + + + + + + + + + diff --git a/java/src/main/java/org/idris/rts/Closure.java b/java/src/main/java/org/idris/rts/Closure.java deleted file mode 100644 --- a/java/src/main/java/org/idris/rts/Closure.java +++ /dev/null @@ -1,17 +0,0 @@ -package org.idris.rts; - -import java.util.concurrent.Callable; - -public abstract class Closure implements Callable, Runnable { - protected final Object [] context; - - protected Closure(final Object ... context) { - this.context = context; - } - - public void run() { - call(); - } - - public abstract Object call(); -} diff --git a/java/src/main/java/org/idris/rts/ForeignPrimitives.java b/java/src/main/java/org/idris/rts/ForeignPrimitives.java deleted file mode 100644 --- a/java/src/main/java/org/idris/rts/ForeignPrimitives.java +++ /dev/null @@ -1,271 +0,0 @@ -package org.idris.rts; - -import java.lang.reflect.InvocationTargetException; -import java.util.Arrays; -import java.util.List; -import java.util.Map; -import java.util.HashMap; -import java.util.Set; -import java.util.HashSet; -import java.io.Closeable; -import java.io.File; -import java.io.IOException; -import java.io.PrintStream; -import java.io.InputStream; -import java.nio.ByteBuffer; -import java.nio.file.Files; -import java.nio.file.OpenOption; -import java.nio.file.StandardOpenOption; -import java.nio.channels.Channels; -import java.nio.channels.SeekableByteChannel; -import java.nio.channels.ReadableByteChannel; -import java.util.concurrent.BlockingQueue; -import java.util.concurrent.LinkedBlockingQueue; -import java.util.concurrent.Semaphore; - -@SuppressWarnings("unchecked") -public class ForeignPrimitives { - - private static final Map> args = new HashMap<>(); - private static final Semaphore messageMutex = new Semaphore(1); - private static final Map> messages = new HashMap<>(); - private static final Set feofFiles = new HashSet<>(); - - public static synchronized void idris_initArgs(Thread t, String[] args) { - ForeignPrimitives.args.put(t, Arrays.asList(args)); - } - - public static synchronized int idris_numArgs(Object thread) { - List argsForThread = ForeignPrimitives.args.get((Thread) thread); - return (argsForThread == null ? 0 : argsForThread.size()); - } - - public static synchronized String idris_getArg(Object thread, int num) { - List argsForThread = ForeignPrimitives.args.get((Thread) thread); - return (argsForThread == null ? null : argsForThread.get(num)); - } - - public static String getenv(String x) { - return System.getenv(x); - } - - public static void exit(int exitCode) { - System.exit(exitCode); - } - - public static void usleep(int microsecs) { - try { - Thread.sleep(microsecs / 1000, microsecs % 1000); - } catch (InterruptedException ex) { - } - } - - public static void idris_sendMessage(Object from, Object dest, Object message) throws InterruptedException { - messageMutex.acquire(); - BlockingQueue messagesForTarget = messages.get((Thread) dest); - if (messagesForTarget == null) { - messagesForTarget = new LinkedBlockingQueue<>(); - messages.put((Thread) dest, messagesForTarget); - } - messagesForTarget.put(message); - messageMutex.release(); - } - - public static int idris_checkMessage(Object dest) throws InterruptedException { - messageMutex.acquire(); - BlockingQueue messagesForTarget = messages.get((Thread) dest); - messageMutex.release(); - return (messagesForTarget == null ? 0 : messagesForTarget.size()); - } - - public static Object idris_recvMessage(Object dest) throws InterruptedException { - messageMutex.acquire(); - BlockingQueue messagesForTarget = messages.get((Thread) dest); - if (messagesForTarget == null) { - messagesForTarget = new LinkedBlockingQueue(); - messages.put((Thread) dest, messagesForTarget); - } - messageMutex.release(); - return messagesForTarget.take(); - } - - public static void putStr(String str) { - System.out.print(str); - } - - public static void putchar(char c) { - System.out.print(c); - } - - public static int getchar() { - try { - return (char) System.in.read(); - } catch (IOException ex) { - return -1; - } - } - - public static SeekableByteChannel fileOpen(String name, String privs) { - try { - OpenOption[] options; - switch (privs) { - case "r": - options = new StandardOpenOption[]{StandardOpenOption.READ}; - break; - case "r+": - options = new StandardOpenOption[]{StandardOpenOption.READ, - StandardOpenOption.WRITE}; - break; - case "w": - options = new StandardOpenOption[]{StandardOpenOption.WRITE, - StandardOpenOption.CREATE}; - break; - case "w+": - options = new StandardOpenOption[]{StandardOpenOption.READ, - StandardOpenOption.WRITE, - StandardOpenOption.CREATE}; - break; - case "a": - options = new StandardOpenOption[]{StandardOpenOption.WRITE, - StandardOpenOption.CREATE, - StandardOpenOption.APPEND}; - break; - case "a+": - options = new StandardOpenOption[]{StandardOpenOption.READ, - StandardOpenOption.WRITE, - StandardOpenOption.CREATE, - StandardOpenOption.APPEND}; - break; - default: - options = new StandardOpenOption[]{}; - break; - } - return Files.newByteChannel(new File(name).toPath(), options); - } catch (IOException ex) { - return null; - } - } - - public static synchronized void fileClose(Object file) throws IOException { - ((Closeable) file).close(); - feofFiles.remove(file); - } - - public static void fputStr(Object file, String string) throws IOException { - if (file instanceof PrintStream) { - ((PrintStream) file).print(string); - } else if (file instanceof SeekableByteChannel) { - ((SeekableByteChannel) file).write(ByteBuffer.wrap(string.getBytes())); - } - } - - public static synchronized String idris_readStr(Object file) throws IOException { - ReadableByteChannel channel = file instanceof InputStream - ? Channels.newChannel((InputStream) file) - : (ReadableByteChannel) file; - ByteBuffer buf = ByteBuffer.allocate(1); - StringBuilder resultBuilder = new StringBuilder(""); - String delimiter = System.getProperty("line.separator"); - int read = 0; - do { - buf.rewind(); - read = channel.read(buf); - if (read > 0) { - resultBuilder.append(new String(buf.array())); - if (resultBuilder.lastIndexOf(delimiter) > -1) { - return resultBuilder.toString(); - } - } - if (read < 0) { - feofFiles.add(file); - } - } while (read >= 0); - return resultBuilder.toString(); - } - - public static int fileEOF(Object file) { - return (feofFiles.contains(file) ? 1 : 0); - } - - public static int isNull(Object o) { - return (o == null ? 1 : 0); - } - - public static Object malloc(int size) { - return ByteBuffer.allocate(size); - } - - public static void idris_memset(Object buf, int offset, Object c, int size) { - ByteBuffer buffer = (ByteBuffer)buf; - buffer.rewind(); - buffer.position(offset); - byte init[] = new byte[size]; - Arrays.fill(init, (Byte)c); - buffer.put(init, offset, size); - buffer.rewind(); - } - - public static void free(Object buf) { - buf = null; - } - - public static Integer idris_peek(Object buf, int offset) { - ByteBuffer buffer = (ByteBuffer)buf; - return Integer.valueOf(buffer.get(offset)); - } - - public static void idris_poke(Object buf, int offset, Object data) { - ByteBuffer buffer = (ByteBuffer)buf; - buffer.put(offset, (Byte)data); - } - - public static void idris_memmove(Object dstBuf, Object srcBuf, int dstOffset, int srcOffset, int size) { - ByteBuffer dst = (ByteBuffer)dstBuf; - ByteBuffer src = (ByteBuffer)srcBuf; - byte [] srcData = new byte[size]; - src.rewind(); - src.position(srcOffset); - src.get(srcData, 0, size); - src.rewind(); - dst.rewind(); - dst.position(dstOffset); - dst.put(srcData, 0, size); - dst.rewind(); - } - - public final static Object idris_K(final Object result, final Object drop) { - return result; - } - - public final static Object idris_flipK(final Object drop, final Object result) { - return result; - } - - public final static Object idris_assignStack(final Object[] context, final int start, final Object... vars) { - int i = start; - for (Object var : vars) { - context[i] = var; - } - return context; - } - - public final static Object invokeOn(final Object obj, final String methodName, Object... args) throws NoSuchMethodException, IllegalAccessException, InvocationTargetException { - Class cls = (obj instanceof Class ? (Class)obj : obj.getClass()); - Class argClasses[] = new Class[args.length]; - int i = 0; - for (Object arg : args) { - argClasses[i] = arg.getClass(); - } - return cls.getMethod(methodName, argClasses).invoke(obj, args); - } - - public final static Object newObject(final Object cls, Object... args) throws NoSuchMethodException, IllegalAccessException, InvocationTargetException, InstantiationException { - Class clazz = (cls instanceof Class ? (Class)cls : cls.getClass()); - Class argClasses[] = new Class[args.length]; - int i = 0; - for (Object arg : args) { - argClasses[i] = arg.getClass(); - } - return clazz.getConstructor(argClasses).newInstance(args); - } -} diff --git a/java/src/main/java/org/idris/rts/IdrisObject.java b/java/src/main/java/org/idris/rts/IdrisObject.java deleted file mode 100644 --- a/java/src/main/java/org/idris/rts/IdrisObject.java +++ /dev/null @@ -1,19 +0,0 @@ -package org.idris.rts; - -public class IdrisObject { - private final int constructorId; - private final Object data[]; - - public IdrisObject(final int constructorId, final Object ... data) { - this.constructorId = constructorId; - this.data = data; - } - - public int getConstructorId() { - return constructorId; - } - - public Object[] getData() { - return data; - } -} diff --git a/java/src/main/java/org/idris/rts/TailCallClosure.java b/java/src/main/java/org/idris/rts/TailCallClosure.java deleted file mode 100644 --- a/java/src/main/java/org/idris/rts/TailCallClosure.java +++ /dev/null @@ -1,26 +0,0 @@ -package org.idris.rts; - -public class TailCallClosure extends Closure { - private final Closure function; - - public TailCallClosure(Closure function) { - super(); - this.function = function; - } - - public final Object call() { - Closure function = this.function; - Object result = null; - while (function != null) { - result = function.call(); - function = null; - if (result instanceof TailCallClosure) { - function = ((TailCallClosure)result).function; - } else { - return result; - } - } - return result; - } -} - diff --git a/javascript/JavaScript.idr b/javascript/JavaScript.idr new file mode 100644 --- /dev/null +++ b/javascript/JavaScript.idr @@ -0,0 +1,101 @@ +module JavaScript + +%access public + +-- TODO: Get rid of this hack, and find a better way. +private +isUndefined : Ptr -> IO Bool +isUndefined p = do + res <- mkForeign ( + FFun "(function(arg) { return arg === undefined;})" [FPtr] FString) p + if res == "false" + then (return False) + else (return True) + +-------------------------------------------------------------------------------- +-- Events +-------------------------------------------------------------------------------- +abstract +data Event : Type where + MkEvent : Ptr -> Event + +-------------------------------------------------------------------------------- +-- Elements +-------------------------------------------------------------------------------- +abstract +data Element : Type where + MkElem : Ptr -> Element + +setText : Element -> String -> IO () +setText (MkElem p) s = + mkForeign (FFun ".textContent=" [FPtr, FString] FUnit) p s + + +setOnClick : Element -> (Event -> IO Bool) -> IO () +setOnClick (MkElem e) f = + mkForeign ( + FFun "['onclick']=" [ FPtr + , FFunction (FAny Event) (FAny (IO Bool)) + ] FUnit) e f +-------------------------------------------------------------------------------- +-- Nodelists +-------------------------------------------------------------------------------- +abstract +data NodeList : Type where + MkNodeList : Ptr -> NodeList + +elemAt : NodeList -> Nat -> IO (Maybe Element) +elemAt (MkNodeList p) i = do + e <- mkForeign (FFun ".item" [FPtr, FInt] FPtr) p (prim__truncBigInt_Int (cast i)) + d <- isUndefined e + if d + then return $ Just (MkElem e) + else return Nothing + +-------------------------------------------------------------------------------- +-- Intervals +-------------------------------------------------------------------------------- +abstract +data Interval : Type where + MkInterval : Ptr -> Interval + +setInterval : (() -> IO ()) -> Float -> IO Interval +setInterval f t = do + e <- mkForeign ( + FFun "setInterval" [FFunction FUnit (FAny (IO ())), FFloat] FPtr) f t + return (MkInterval e) + +clearInterval : Interval -> IO () +clearInterval (MkInterval p) = + mkForeign (FFun "clearInterval" [FPtr] FUnit) p + +-------------------------------------------------------------------------------- +-- Timeouts +-------------------------------------------------------------------------------- +data Timeout : Type where + MkTimeout : Ptr -> Timeout + +setTimeout : (() -> IO ()) -> Float -> IO Timeout +setTimeout f t = do + e <- mkForeign ( + FFun "setTimeout" [FFunction FUnit (FAny (IO ())), FFloat] FPtr) f t + return (MkTimeout e) + +clearTimeout : Timeout -> IO () +clearTimeout (MkTimeout p) = + mkForeign (FFun "clearTimeout" [FPtr] FUnit) p + +-------------------------------------------------------------------------------- +-- Basic IO +-------------------------------------------------------------------------------- +alert : String -> IO () +alert msg = + mkForeign (FFun "alert" [FString] FUnit) msg + +-------------------------------------------------------------------------------- +-- DOM +-------------------------------------------------------------------------------- +query : String -> IO NodeList +query q = do + e <- mkForeign (FFun "document.querySelectorAll" [FString] FPtr) q + return (MkNodeList e) diff --git a/javascript/JavaScript/JSON.idr b/javascript/JavaScript/JSON.idr new file mode 100644 --- /dev/null +++ b/javascript/JavaScript/JSON.idr @@ -0,0 +1,46 @@ +module JSON + +import Data.SortedMap + +data JSONType : Type where + JSONArray : (n : Nat) -> Vect n JSONType -> JSONType + JSONString : JSONType + JSONNumber : JSONType + JSONBool : JSONType + JSONObject : SortedMap String JSONType -> JSONType + JSONNull : JSONType + +mutual + using (ts : Vect n JSONType, fs : SortedMap String JSONType) + namespace JArray + data JArray : (n : Nat) -> Vect n JSONType -> Type where + Nil : JArray 0 [] + (::) : JSON t -> JArray n ts -> JArray (S n) (t :: ts) + + namespace JObject + data JObject : SortedMap String JSONType -> Type where + Nil : JObject empty + (::) : (f : (String, JSON t)) -> + JObject fs -> + JObject (insert (fst f) t fs) + + data JSON : JSONType -> Type where + JSString : String -> JSON JSONString + JSNumber : Float -> JSON JSONNumber + JSBool : Bool -> JSON JSONBool + JSNull : JSON JSONNull + JSArray : JArray n ts -> JSON (JSONArray n ts) + JSObject : JObject fs -> JSON (JSONObject fs) + +index : (i : Fin n) -> JSON (JSONArray n ts) -> JSON (index i ts) +index fZ (JSArray (x :: xs)) = x +index (fS i) (JSArray (x :: xs)) = index i (JSArray xs) + +infixl 8 ++ + +(++) : JSON (JSONArray m ts1) -> + JSON (JSONArray n ts2) -> + JSON (JSONArray (m + n) (ts1 ++ ts2)) +(++) (JSArray []) ys = ys +(++) (JSArray (x :: xs)) ys with ((JSArray xs) ++ ys) + | (JSArray as) = JSArray (x :: as) diff --git a/javascript/Makefile b/javascript/Makefile new file mode 100644 --- /dev/null +++ b/javascript/Makefile @@ -0,0 +1,13 @@ + +check: .PHONY + $(IDRIS) --build javascript.ipkg + +recheck: clean check + +install: + $(IDRIS) --install javascript.ipkg + +clean: .PHONY + $(IDRIS) --clean javascript.ipkg + +.PHONY: diff --git a/javascript/javascript.ipkg b/javascript/javascript.ipkg new file mode 100644 --- /dev/null +++ b/javascript/javascript.ipkg @@ -0,0 +1,5 @@ +package javascript + +opts = "-i ../lib" +modules = JavaScript, JavaScript.JSON + diff --git a/js/Runtime-browser.js b/js/Runtime-browser.js --- a/js/Runtime-browser.js +++ b/js/Runtime-browser.js @@ -1,3 +1,3 @@ -__IDRRT__.print = function(s) { +var __IDRRT__print = function(s) { console.log(s); }; diff --git a/js/Runtime-common.js b/js/Runtime-common.js --- a/js/Runtime-common.js +++ b/js/Runtime-common.js @@ -1,29 +1,34 @@ -var __IDRRT__ = {}; - /** @constructor */ -__IDRRT__.Type = function(type) { +var __IDRRT__Type = function(type) { this.type = type; }; -__IDRRT__.Int = new __IDRRT__.Type('Int'); -__IDRRT__.Char = new __IDRRT__.Type('Char'); -__IDRRT__.String = new __IDRRT__.Type('String'); -__IDRRT__.Integer = new __IDRRT__.Type('Integer'); -__IDRRT__.Float = new __IDRRT__.Type('Float'); -__IDRRT__.Ptr = new __IDRRT__.Type('Pointer') -__IDRRT__.Forgot = new __IDRRT__.Type('Forgot'); +var __IDRRT__Int = new __IDRRT__Type('Int'); +var __IDRRT__Char = new __IDRRT__Type('Char'); +var __IDRRT__String = new __IDRRT__Type('String'); +var __IDRRT__Integer = new __IDRRT__Type('Integer'); +var __IDRRT__Float = new __IDRRT__Type('Float'); +var __IDRRT__Ptr = new __IDRRT__Type('Pointer'); +var __IDRRT__Forgot = new __IDRRT__Type('Forgot'); /** @constructor */ -__IDRRT__.Tailcall = function(f) { this.f = f }; +var __IDRRT__Tailcall = function(f) { this.f = f }; +var __IDRRT__ffiWrap = function(fid) { + return function(arg) { + return __IDRRT__tailcall(function(){ + return __IDR__APPLY0(fid, arg); + }); + }; +}; /** @constructor */ -__IDRRT__.Con = function(i,vars) { +var __IDRRT__Con = function(i,vars) { this.i = i; this.vars = vars; }; -__IDRRT__.tailcall = function(f) { +var __IDRRT__tailcall = function(f) { var __f = f; var ret; while (__f) { @@ -31,7 +36,7 @@ __f = null; ret = f(); - if (ret instanceof __IDRRT__.Tailcall) { + if (ret instanceof __IDRRT__Tailcall) { __f = ret.f; } else { return ret; @@ -43,7 +48,7 @@ BigInteger Javascript code taken from: https://github.com/peterolson */ -__IDRRT__.bigInt = (function () { +var __IDRRT__bigInt = (function () { var base = 10000000, logBase = 7; var sign = { positive: false, @@ -384,5 +389,3 @@ fnReturn.minusOne = MINUS_ONE; return fnReturn; })(); - -var __IDR__ = {}; diff --git a/js/Runtime-node.js b/js/Runtime-node.js --- a/js/Runtime-node.js +++ b/js/Runtime-node.js @@ -1,4 +1,4 @@ -__IDRRT__.print = (function() { +var __IDRRT__print = (function() { var util = require('util'); return function(s) { util.print(s); diff --git a/lib/Builtins.idr b/lib/Builtins.idr --- a/lib/Builtins.idr +++ b/lib/Builtins.idr @@ -25,13 +25,6 @@ lazy : a -> a lazy x = x -- compiled specially --- Give the termination checker a hint. --- assert_smaller x v means that 'v' should be assumed smaller than the --- variable x in this call. - -assert_smaller : a -> b -> b -assert_smaller var smallerval = smallerval -- compiled specially - par : |(thunk:a) -> a par x = x -- compiled specially @@ -239,26 +232,23 @@ (*) : a -> a -> a abs : a -> a - fromInteger : Int -> a + fromInteger : Integer -> a +instance Num Integer where + (+) = prim__addBigInt + (-) = prim__subBigInt + (*) = prim__mulBigInt + abs x = if x < 0 then -x else x + fromInteger = id instance Num Int where (+) = prim__addInt (-) = prim__subInt (*) = prim__mulInt - fromInteger = id - abs x = if x<0 then -x else x - - -instance Num Integer where - (+) = prim__addBigInt - (-) = prim__subBigInt - (*) = prim__mulBigInt - - abs x = if x<0 then -x else x - fromInteger = prim__sextInt_BigInt + fromInteger = prim__truncBigInt_Int + abs x = if x < (prim__truncBigInt_Int 0) then -x else x instance Num Float where @@ -266,16 +256,92 @@ (-) = prim__subFloat (*) = prim__mulFloat - abs x = if x<0 then -x else x - fromInteger = prim__toFloatInt + abs x = if x < (prim__toFloatBigInt 0) then -x else x + fromInteger = prim__toFloatBigInt +instance Num Bits8 where + (+) = prim__addB8 + (-) = prim__subB8 + (*) = prim__mulB8 + abs = id + fromInteger = prim__truncBigInt_B8 + +instance Num Bits16 where + (+) = prim__addB16 + (-) = prim__subB16 + (*) = prim__mulB16 + abs = id + fromInteger = prim__truncBigInt_B16 + +instance Num Bits32 where + (+) = prim__addB32 + (-) = prim__subB32 + (*) = prim__mulB32 + abs = id + fromInteger = prim__truncBigInt_B32 + +instance Num Bits64 where + (+) = prim__addB64 + (-) = prim__subB64 + (*) = prim__mulB64 + abs = id + fromInteger = prim__truncBigInt_B64 + +instance Eq Bits8 where + x == y = intToBool (prim__eqB8 x y) + +instance Eq Bits16 where + x == y = intToBool (prim__eqB16 x y) + +instance Eq Bits32 where + x == y = intToBool (prim__eqB32 x y) + +instance Eq Bits64 where + x == y = intToBool (prim__eqB64 x y) + +instance Ord Bits8 where + (<) = boolOp prim__ltB8 + (>) = boolOp prim__gtB8 + (<=) = boolOp prim__lteB8 + (>=) = boolOp prim__gteB8 + compare l r = if l < r then LT + else if l > r then GT + else EQ + +instance Ord Bits16 where + (<) = boolOp prim__ltB16 + (>) = boolOp prim__gtB16 + (<=) = boolOp prim__lteB16 + (>=) = boolOp prim__gteB16 + compare l r = if l < r then LT + else if l > r then GT + else EQ + +instance Ord Bits32 where + (<) = boolOp prim__ltB32 + (>) = boolOp prim__gtB32 + (<=) = boolOp prim__lteB32 + (>=) = boolOp prim__gteB32 + compare l r = if l < r then LT + else if l > r then GT + else EQ + +instance Ord Bits64 where + (<) = boolOp prim__ltB64 + (>) = boolOp prim__gtB64 + (<=) = boolOp prim__lteB64 + (>=) = boolOp prim__gteB64 + compare l r = if l < r then LT + else if l > r then GT + else EQ + partial -div : Int -> Int -> Int -div = prim__sdivInt +div : Integer -> Integer -> Integer +div = prim__sdivBigInt partial -mod : Int -> Int -> Int -mod = prim__sremInt +mod : Integer -> Integer -> Integer +mod = prim__sremBigInt (/) : Float -> Float -> Float diff --git a/lib/Control/IOExcept.idr b/lib/Control/IOExcept.idr --- a/lib/Control/IOExcept.idr +++ b/lib/Control/IOExcept.idr @@ -8,7 +8,7 @@ ioM : IO (Either err a) -> IOExcept err a instance Functor (IOExcept e) where - fmap f (ioM fn) = ioM (fmap (fmap f) fn) + map f (ioM fn) = ioM (map (map f) fn) instance Applicative (IOExcept e) where pure x = ioM (pure (pure x)) @@ -16,7 +16,6 @@ return (f' <$> a')) instance Monad (IOExcept e) where - return = pure (ioM x) >>= k = ioM (do x' <- x; case x' of Right a => let (ioM ka) = k a in diff --git a/lib/Control/Monad/Identity.idr b/lib/Control/Monad/Identity.idr --- a/lib/Control/Monad/Identity.idr +++ b/lib/Control/Monad/Identity.idr @@ -8,7 +8,7 @@ Id : (runIdentity : a) -> Identity a instance Functor Identity where - fmap fn (Id a) = Id (fn a) + map fn (Id a) = Id (fn a) instance Applicative Identity where pure x = Id x @@ -16,5 +16,4 @@ (Id f) <$> (Id g) = Id (f g) instance Monad Identity where - return x = Id x (Id x) >>= k = k x diff --git a/lib/Control/Monad/State.idr b/lib/Control/Monad/State.idr --- a/lib/Control/Monad/State.idr +++ b/lib/Control/Monad/State.idr @@ -15,7 +15,7 @@ (runStateT : s -> m (a, s)) -> StateT s m a instance Functor f => Functor (StateT s f) where - fmap f (ST g) = ST (\st => fmap (mapFst f) (g st)) where + map f (ST g) = ST (\st => map (mapFst f) (g st)) where mapFst : (a -> x) -> (a, b) -> (x, b) mapFst fn (a, b) = (fn a, b) @@ -27,8 +27,6 @@ return (g b, t)) instance Monad m => Monad (StateT s m) where - return x = ST (\st => return (x, st)) - (ST f) >>= k = ST (\st => do (v, st') <- f st let ST kv = k v kv st') diff --git a/lib/Data/Bits.idr b/lib/Data/Bits.idr --- a/lib/Data/Bits.idr +++ b/lib/Data/Bits.idr @@ -4,11 +4,11 @@ divCeil : Nat -> Nat -> Nat divCeil x y = case x `mod` y of - O => x `div` y + Z => x `div` y S _ => S (x `div` y) nextPow2 : Nat -> Nat -nextPow2 O = O +nextPow2 Z = Z nextPow2 x = if x == (2 `power` l2x) then l2x else S l2x @@ -19,9 +19,9 @@ nextBytes bits = (nextPow2 (bits `divCeil` 8)) machineTy : Nat -> Type -machineTy O = Bits8 -machineTy (S O) = Bits16 -machineTy (S (S O)) = Bits32 +machineTy Z = Bits8 +machineTy (S Z) = Bits16 +machineTy (S (S Z)) = Bits32 machineTy (S (S (S _))) = Bits64 bitsUsed : Nat -> Nat @@ -29,19 +29,20 @@ %assert_total natToBits' : machineTy n -> Nat -> machineTy n -natToBits' a O = a +natToBits' a Z = a natToBits' {n=n} a x with n - natToBits' a (S x') | O = natToBits' (prim__addB8 a (prim__truncInt_B8 1)) x' - natToBits' a (S x') | S O = natToBits' (prim__addB16 a (prim__truncInt_B16 1)) x' - natToBits' a (S x') | S (S O) = natToBits' (prim__addB32 a (prim__truncInt_B32 1)) x' - natToBits' a (S x') | S (S (S _)) = natToBits' (prim__addB64 a (prim__truncInt_B64 1)) x' + -- it seems I have to manually recover the value of n here, instead of being able to reference it + natToBits' a (S x') | Z = natToBits' {n=0} (prim__addB8 a (prim__truncInt_B8 1)) x' + natToBits' a (S x') | S Z = natToBits' {n=1} (prim__addB16 a (prim__truncInt_B16 1)) x' + natToBits' a (S x') | S (S Z) = natToBits' {n=2} (prim__addB32 a (prim__truncInt_B32 1)) x' + natToBits' a (S x') | S (S (S _)) = natToBits' {n=3} (prim__addB64 a (prim__truncInt_B64 1)) x' natToBits : Nat -> machineTy n natToBits {n=n} x with n - | O = natToBits' (prim__truncInt_B8 0) x - | S O = natToBits' (prim__truncInt_B16 0) x - | S (S O) = natToBits' (prim__truncInt_B32 0) x - | S (S (S _)) = natToBits' (prim__truncInt_B64 0) x + | Z = natToBits' {n=0} (prim__truncInt_B8 0) x + | S Z = natToBits' {n=1} (prim__truncInt_B16 0) x + | S (S Z) = natToBits' {n=2} (prim__truncInt_B32 0) x + | S (S (S _)) = natToBits' {n=3} (prim__truncInt_B64 0) x getPad : Nat -> machineTy n getPad n = natToBits ((bitsUsed (nextBytes n)) - n) @@ -93,9 +94,9 @@ shiftLeft' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) shiftLeft' {n=n} x c with (nextBytes n) - | O = pad8' n prim__shlB8 x c - | S O = pad16' n prim__shlB16 x c - | S (S O) = pad32' n prim__shlB32 x c + | Z = pad8' n prim__shlB8 x c + | S Z = pad16' n prim__shlB16 x c + | S (S Z) = pad32' n prim__shlB32 x c | S (S (S _)) = pad64' n prim__shlB64 x c public @@ -104,9 +105,9 @@ shiftRightLogical' : machineTy n -> machineTy n -> machineTy n shiftRightLogical' {n=n} x c with n - | O = prim__lshrB8 x c - | S O = prim__lshrB16 x c - | S (S O) = prim__lshrB32 x c + | Z = prim__lshrB8 x c + | S Z = prim__lshrB16 x c + | S (S Z) = prim__lshrB32 x c | S (S (S _)) = prim__lshrB64 x c public @@ -116,9 +117,9 @@ shiftRightArithmetic' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) shiftRightArithmetic' {n=n} x c with (nextBytes n) - | O = pad8' n prim__ashrB8 x c - | S O = pad16' n prim__ashrB16 x c - | S (S O) = pad32' n prim__ashrB32 x c + | Z = pad8' n prim__ashrB8 x c + | S Z = pad16' n prim__ashrB16 x c + | S (S Z) = pad32' n prim__ashrB32 x c | S (S (S _)) = pad64' n prim__ashrB64 x c public @@ -127,9 +128,9 @@ and' : machineTy n -> machineTy n -> machineTy n and' {n=n} x y with n - | O = prim__andB8 x y - | S O = prim__andB16 x y - | S (S O) = prim__andB32 x y + | Z = prim__andB8 x y + | S Z = prim__andB16 x y + | S (S Z) = prim__andB32 x y | S (S (S _)) = prim__andB64 x y public @@ -138,9 +139,9 @@ or' : machineTy n -> machineTy n -> machineTy n or' {n=n} x y with n - | O = prim__orB8 x y - | S O = prim__orB16 x y - | S (S O) = prim__orB32 x y + | Z = prim__orB8 x y + | S Z = prim__orB16 x y + | S (S Z) = prim__orB32 x y | S (S (S _)) = prim__orB64 x y public @@ -149,20 +150,20 @@ xor' : machineTy n -> machineTy n -> machineTy n xor' {n=n} x y with n - | O = prim__xorB8 x y - | S O = prim__xorB16 x y - | S (S O) = prim__xorB32 x y + | Z = prim__xorB8 x y + | S Z = prim__xorB16 x y + | S (S Z) = prim__xorB32 x y | S (S (S _)) = prim__xorB64 x y public xor : Bits n -> Bits n -> Bits n -xor (MkBits x) (MkBits y) = MkBits (xor' x y) +xor {n} (MkBits x) (MkBits y) = MkBits {n} (xor' {n=nextBytes n} x y) plus' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) plus' {n=n} x y with (nextBytes n) - | O = pad8 n prim__addB8 x y - | S O = pad16 n prim__addB16 x y - | S (S O) = pad32 n prim__addB32 x y + | Z = pad8 n prim__addB8 x y + | S Z = pad16 n prim__addB16 x y + | S (S Z) = pad32 n prim__addB32 x y | S (S (S _)) = pad64 n prim__addB64 x y public @@ -171,9 +172,9 @@ minus' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) minus' {n=n} x y with (nextBytes n) - | O = pad8 n prim__subB8 x y - | S O = pad16 n prim__subB16 x y - | S (S O) = pad32 n prim__subB32 x y + | Z = pad8 n prim__subB8 x y + | S Z = pad16 n prim__subB16 x y + | S (S Z) = pad32 n prim__subB32 x y | S (S (S _)) = pad64 n prim__subB64 x y public @@ -182,9 +183,9 @@ times' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) times' {n=n} x y with (nextBytes n) - | O = pad8 n prim__mulB8 x y - | S O = pad16 n prim__mulB16 x y - | S (S O) = pad32 n prim__mulB32 x y + | Z = pad8 n prim__mulB8 x y + | S Z = pad16 n prim__mulB16 x y + | S (S Z) = pad32 n prim__mulB32 x y | S (S (S _)) = pad64 n prim__mulB64 x y public @@ -194,9 +195,9 @@ partial sdiv' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) sdiv' {n=n} x y with (nextBytes n) - | O = prim__sdivB8 x y - | S O = prim__sdivB16 x y - | S (S O) = prim__sdivB32 x y + | Z = prim__sdivB8 x y + | S Z = prim__sdivB16 x y + | S (S Z) = prim__sdivB32 x y | S (S (S _)) = prim__sdivB64 x y public partial @@ -206,9 +207,9 @@ partial udiv' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) udiv' {n=n} x y with (nextBytes n) - | O = prim__udivB8 x y - | S O = prim__udivB16 x y - | S (S O) = prim__udivB32 x y + | Z = prim__udivB8 x y + | S Z = prim__udivB16 x y + | S (S Z) = prim__udivB32 x y | S (S (S _)) = prim__udivB64 x y public partial @@ -218,9 +219,9 @@ partial srem' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) srem' {n=n} x y with (nextBytes n) - | O = prim__sremB8 x y - | S O = prim__sremB16 x y - | S (S O) = prim__sremB32 x y + | Z = prim__sremB8 x y + | S Z = prim__sremB16 x y + | S (S Z) = prim__sremB32 x y | S (S (S _)) = prim__sremB64 x y public partial @@ -230,9 +231,9 @@ partial urem' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) urem' {n=n} x y with (nextBytes n) - | O = prim__uremB8 x y - | S O = prim__uremB16 x y - | S (S O) = prim__uremB32 x y + | Z = prim__uremB8 x y + | S Z = prim__uremB16 x y + | S (S Z) = prim__uremB32 x y | S (S (S _)) = prim__uremB64 x y public partial @@ -240,39 +241,39 @@ urem (MkBits x) (MkBits y) = MkBits (urem' x y) -- TODO: Proofy comparisons via postulates -lt : machineTy n -> machineTy n -> Int -lt {n=n} x y with n - | O = prim__ltB8 x y - | S O = prim__ltB16 x y - | S (S O) = prim__ltB32 x y +lt : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int +lt {n=n} x y with (nextBytes n) + | Z = prim__ltB8 x y + | S Z = prim__ltB16 x y + | S (S Z) = prim__ltB32 x y | S (S (S _)) = prim__ltB64 x y -lte : machineTy n -> machineTy n -> Int -lte {n=n} x y with n - | O = prim__lteB8 x y - | S O = prim__lteB16 x y - | S (S O) = prim__lteB32 x y +lte : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int +lte {n=n} x y with (nextBytes n) + | Z = prim__lteB8 x y + | S Z = prim__lteB16 x y + | S (S Z) = prim__lteB32 x y | S (S (S _)) = prim__lteB64 x y -eq : machineTy n -> machineTy n -> Int -eq {n=n} x y with n - | O = prim__eqB8 x y - | S O = prim__eqB16 x y - | S (S O) = prim__eqB32 x y +eq : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int +eq {n=n} x y with (nextBytes n) + | Z = prim__eqB8 x y + | S Z = prim__eqB16 x y + | S (S Z) = prim__eqB32 x y | S (S (S _)) = prim__eqB64 x y -gte : machineTy n -> machineTy n -> Int -gte {n=n} x y with n - | O = prim__gteB8 x y - | S O = prim__gteB16 x y - | S (S O) = prim__gteB32 x y +gte : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int +gte {n=n} x y with (nextBytes n) + | Z = prim__gteB8 x y + | S Z = prim__gteB16 x y + | S (S Z) = prim__gteB32 x y | S (S (S _)) = prim__gteB64 x y -gt : machineTy n -> machineTy n -> Int -gt {n=n} x y with n - | O = prim__gtB8 x y - | S O = prim__gtB16 x y - | S (S O) = prim__gtB32 x y +gt : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int +gt {n=n} x y with (nextBytes n) + | Z = prim__gtB8 x y + | S Z = prim__gtB16 x y + | S (S Z) = prim__gtB32 x y | S (S (S _)) = prim__gtB64 x y instance Eq (Bits n) where @@ -292,11 +293,11 @@ complement' : machineTy (nextBytes n) -> machineTy (nextBytes n) complement' {n=n} x with (nextBytes n) - | O = let pad = getPad {n=0} n in + | Z = let pad = getPad {n=0} n in prim__complB8 (x `prim__shlB8` pad) `prim__lshrB8` pad - | S O = let pad = getPad {n=1} n in + | S Z = let pad = getPad {n=1} n in prim__complB16 (x `prim__shlB16` pad) `prim__lshrB16` pad - | S (S O) = let pad = getPad {n=2} n in + | S (S Z) = let pad = getPad {n=2} n in prim__complB32 (x `prim__shlB32` pad) `prim__lshrB32` pad | S (S (S _)) = let pad = getPad {n=3} n in prim__complB64 (x `prim__shlB64` pad) `prim__lshrB64` pad @@ -308,15 +309,15 @@ -- TODO: Prove zext' : machineTy (nextBytes n) -> machineTy (nextBytes (n+m)) zext' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m)) - | (O, O) = believe_me x - | (O, S O) = believe_me (prim__zextB8_B16 (believe_me x)) - | (O, S (S O)) = believe_me (prim__zextB8_B32 (believe_me x)) - | (O, S (S (S _))) = believe_me (prim__zextB8_B64 (believe_me x)) - | (S O, S O) = believe_me x - | (S O, S (S O)) = believe_me (prim__zextB16_B32 (believe_me x)) - | (S O, S (S (S _))) = believe_me (prim__zextB16_B64 (believe_me x)) - | (S (S O), S (S O)) = believe_me x - | (S (S O), S (S (S _))) = believe_me (prim__zextB32_B64 (believe_me x)) + | (Z, Z) = believe_me x + | (Z, S Z) = believe_me (prim__zextB8_B16 (believe_me x)) + | (Z, S (S Z)) = believe_me (prim__zextB8_B32 (believe_me x)) + | (Z, S (S (S _))) = believe_me (prim__zextB8_B64 (believe_me x)) + | (S Z, S Z) = believe_me x + | (S Z, S (S Z)) = believe_me (prim__zextB16_B32 (believe_me x)) + | (S Z, S (S (S _))) = believe_me (prim__zextB16_B64 (believe_me x)) + | (S (S Z), S (S Z)) = believe_me x + | (S (S Z), S (S (S _))) = believe_me (prim__zextB32_B64 (believe_me x)) | (S (S (S _)), S (S (S _))) = believe_me x public @@ -324,93 +325,93 @@ zeroExtend (MkBits x) = MkBits (zext' x) %assert_total -intToBits' : Int -> machineTy (nextBytes n) +intToBits' : Integer -> machineTy (nextBytes n) intToBits' {n=n} x with (nextBytes n) - | O = let pad = getPad {n=0} n in - prim__lshrB8 (prim__shlB8 (prim__truncInt_B8 x) pad) pad - | S O = let pad = getPad {n=1} n in - prim__lshrB16 (prim__shlB16 (prim__truncInt_B16 x) pad) pad - | S (S O) = let pad = getPad {n=2} n in - prim__lshrB32 (prim__shlB32 (prim__truncInt_B32 x) pad) pad + | Z = let pad = getPad {n=0} n in + prim__lshrB8 (prim__shlB8 (prim__truncBigInt_B8 x) pad) pad + | S Z = let pad = getPad {n=1} n in + prim__lshrB16 (prim__shlB16 (prim__truncBigInt_B16 x) pad) pad + | S (S Z) = let pad = getPad {n=2} n in + prim__lshrB32 (prim__shlB32 (prim__truncBigInt_B32 x) pad) pad | S (S (S _)) = let pad = getPad {n=3} n in - prim__lshrB64 (prim__shlB64 (prim__truncInt_B64 x) pad) pad + prim__lshrB64 (prim__shlB64 (prim__truncBigInt_B64 x) pad) pad public -intToBits : Int -> Bits n +intToBits : Integer -> Bits n intToBits n = MkBits (intToBits' n) -instance Cast Int (Bits n) where +instance Cast Integer (Bits n) where cast = intToBits -bitsToInt' : machineTy n -> Int -bitsToInt' {n=n} x with n - | O = prim__zextB8_Int x - | S O = prim__zextB16_Int x - | S (S O) = prim__zextB32_Int x - | S (S (S _)) = prim__truncB64_Int x +bitsToInt' : machineTy (nextBytes n) -> Integer +bitsToInt' {n=n} x with (nextBytes n) + | Z = prim__zextB8_BigInt x + | S Z = prim__zextB16_BigInt x + | S (S Z) = prim__zextB32_BigInt x + | S (S (S _)) = prim__zextB64_BigInt x public -bitsToInt : Bits n -> Int +bitsToInt : Bits n -> Integer bitsToInt (MkBits x) = bitsToInt' x -- Zero out the high bits of a truncated bitstring -zeroUnused : machineTy (nextBytes n) -> machineTy (nextBytes n) -zeroUnused x = x `and'` complement' (intToBits' 0) +--zeroUnused : machineTy (nextBytes n) -> machineTy (nextBytes n) +--zeroUnused {n} x = x `and'` complement' (intToBits' {n=n} 0) -instance Cast Nat (Bits n) where - cast x = MkBits (zeroUnused (natToBits n)) +--instance Cast Nat (Bits n) where +-- cast x = MkBits (zeroUnused (natToBits n)) -- TODO: Prove sext' : machineTy (nextBytes n) -> machineTy (nextBytes (n+m)) sext' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m)) - | (O, O) = let pad = getPad {n=0} n in + | (Z, Z) = let pad = getPad {n=0} n in believe_me (prim__ashrB8 (prim__shlB8 (believe_me x) pad) pad) - | (O, S O) = let pad = getPad {n=0} n in + | (Z, S Z) = let pad = getPad {n=0} n in believe_me (prim__ashrB16 (prim__sextB8_B16 (prim__shlB8 (believe_me x) pad)) (prim__zextB8_B16 pad)) - | (O, S (S O)) = let pad = getPad {n=0} n in + | (Z, S (S Z)) = let pad = getPad {n=0} n in believe_me (prim__ashrB32 (prim__sextB8_B32 (prim__shlB8 (believe_me x) pad)) (prim__zextB8_B32 pad)) - | (O, S (S (S _))) = let pad = getPad {n=0} n in + | (Z, S (S (S _))) = let pad = getPad {n=0} n in believe_me (prim__ashrB64 (prim__sextB8_B64 (prim__shlB8 (believe_me x) pad)) (prim__zextB8_B64 pad)) - | (S O, S O) = let pad = getPad {n=1} n in + | (S Z, S Z) = let pad = getPad {n=1} n in believe_me (prim__ashrB16 (prim__shlB16 (believe_me x) pad) pad) - | (S O, S (S O)) = let pad = getPad {n=1} n in + | (S Z, S (S Z)) = let pad = getPad {n=1} n in believe_me (prim__ashrB32 (prim__sextB16_B32 (prim__shlB16 (believe_me x) pad)) (prim__zextB16_B32 pad)) - | (S O, S (S (S _))) = let pad = getPad {n=1} n in + | (S Z, S (S (S _))) = let pad = getPad {n=1} n in believe_me (prim__ashrB64 (prim__sextB16_B64 (prim__shlB16 (believe_me x) pad)) (prim__zextB16_B64 pad)) - | (S (S O), S (S O)) = let pad = getPad {n=2} n in + | (S (S Z), S (S Z)) = let pad = getPad {n=2} n in believe_me (prim__ashrB32 (prim__shlB32 (believe_me x) pad) pad) - | (S (S O), S (S (S _))) = let pad = getPad {n=2} n in + | (S (S Z), S (S (S _))) = let pad = getPad {n=2} n in believe_me (prim__ashrB64 (prim__sextB32_B64 (prim__shlB32 (believe_me x) pad)) (prim__zextB32_B64 pad)) | (S (S (S _)), S (S (S _))) = let pad = getPad {n=3} n in believe_me (prim__ashrB64 (prim__shlB64 (believe_me x) pad) pad) -public -signExtend : Bits n -> Bits (n+m) -signExtend {m=m} (MkBits x) = MkBits (zeroUnused (sext' x)) +--public +--signExtend : Bits n -> Bits (n+m) +--signExtend {m=m} (MkBits x) = MkBits (zeroUnused (sext' x)) -- TODO: Prove trunc' : machineTy (nextBytes (n+m)) -> machineTy (nextBytes n) trunc' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m)) - | (O, O) = believe_me x - | (O, S O) = believe_me (prim__truncB16_B8 (believe_me x)) - | (O, S (S O)) = believe_me (prim__truncB32_B8 (believe_me x)) - | (O, S (S (S _))) = believe_me (prim__truncB64_B8 (believe_me x)) - | (S O, S O) = believe_me x - | (S O, S (S O)) = believe_me (prim__truncB32_B16 (believe_me x)) - | (S O, S (S (S _))) = believe_me (prim__truncB64_B16 (believe_me x)) - | (S (S O), S (S O)) = believe_me x - | (S (S O), S (S (S _))) = believe_me (prim__truncB64_B32 (believe_me x)) + | (Z, Z) = believe_me x + | (Z, S Z) = believe_me (prim__truncB16_B8 (believe_me x)) + | (Z, S (S Z)) = believe_me (prim__truncB32_B8 (believe_me x)) + | (Z, S (S (S _))) = believe_me (prim__truncB64_B8 (believe_me x)) + | (S Z, S Z) = believe_me x + | (S Z, S (S Z)) = believe_me (prim__truncB32_B16 (believe_me x)) + | (S Z, S (S (S _))) = believe_me (prim__truncB64_B16 (believe_me x)) + | (S (S Z), S (S Z)) = believe_me x + | (S (S Z), S (S (S _))) = believe_me (prim__truncB64_B32 (believe_me x)) | (S (S (S _)), S (S (S _))) = believe_me x -public -truncate : Bits (n+m) -> Bits n -truncate (MkBits x) = MkBits (zeroUnused (trunc' x)) +--public +--truncate : Bits (n+m) -> Bits n +--truncate (MkBits x) = MkBits (zeroUnused (trunc' x)) public bitAt : Fin n -> Bits n @@ -433,7 +434,7 @@ where %assert_total helper : Fin (S n) -> Bits n -> List Char - helper fO _ = [] + helper fZ _ = [] helper (fS x) b = (if getBit x b then '1' else '0') :: helper (weaken x) b instance Show (Bits n) where diff --git a/lib/Data/BoundedList.idr b/lib/Data/BoundedList.idr --- a/lib/Data/BoundedList.idr +++ b/lib/Data/BoundedList.idr @@ -8,7 +8,7 @@ (::) : a -> BoundedList a n -> BoundedList a (S n) length : BoundedList a n -> Fin (S n) -length [] = fO +length [] = fZ length (x :: xs) = fS (length xs) -------------------------------------------------------------------------------- @@ -17,7 +17,7 @@ index : Fin (S n) -> BoundedList a n -> Maybe a index _ [] = Nothing -index fO (x :: _) = Just x +index fZ (x :: _) = Just x index (fS f) (_ :: xs) = index f xs -------------------------------------------------------------------------------- @@ -34,7 +34,7 @@ take : (n : Nat) -> List a -> BoundedList a n take _ [] = [] -take O _ = [] +take Z _ = [] take (S n') (x :: xs) = x :: take n' xs toList : BoundedList a n -> List a @@ -50,7 +50,7 @@ -------------------------------------------------------------------------------- replicate : (n : Nat) -> a -> BoundedList a n -replicate O _ = [] +replicate Z _ = [] replicate (S n) x = x :: replicate n x -------------------------------------------------------------------------------- @@ -79,7 +79,7 @@ %assert_total -- not sure why this isn't accepted - clearly decreasing on n pad : (xs : BoundedList a n) -> (padding : a) -> BoundedList a n -pad {n=O} [] _ = [] +pad {n=Z} [] _ = [] pad {n=S n'} [] padding = padding :: (pad {n=n'} [] padding) pad {n=S n'} (x :: xs) padding = x :: pad {n=n'} xs padding diff --git a/lib/Data/HVect.idr b/lib/Data/HVect.idr new file mode 100644 --- /dev/null +++ b/lib/Data/HVect.idr @@ -0,0 +1,63 @@ +module Data.HVect + +import Data.Vect + +%access public +%default total + +using (k : Nat, ts : Vect k Type) + data HVect : Vect k Type -> Type where + Nil : HVect [] + (::) : t -> HVect ts -> HVect (t::ts) + + index : (i : Fin k) -> HVect ts -> index i ts + index fZ (x::xs) = x + index (fS j) (x::xs) = index j xs + + deleteAt : {us : Vect (S l) Type} -> (i : Fin (S l)) -> HVect us -> HVect (deleteAt i us) + deleteAt fZ (x::xs) = xs + deleteAt {l = S m} (fS j) (x::xs) = x :: deleteAt j xs + deleteAt _ [] impossible + + replaceAt : (i : Fin k) -> t -> HVect ts -> HVect (replaceAt i t ts) + replaceAt fZ y (x::xs) = y::xs + replaceAt (fS j) y (x::xs) = x :: replaceAt j y xs + + updateAt : (i : Fin k) -> (index i ts -> t) -> HVect ts -> HVect (replaceAt i t ts) + updateAt fZ f (x::xs) = f x :: xs + updateAt (fS j) f (x::xs) = x :: updateAt j f xs + + (++) : {us : Vect l Type} -> HVect ts -> HVect us -> HVect (ts ++ us) + (++) [] ys = ys + (++) (x::xs) ys = x :: (xs ++ ys) + + instance Eq (HVect []) where + [] == [] = True + + instance (Eq t, Eq (HVect ts)) => Eq (HVect (t::ts)) where + (x::xs) == (y::ys) = x == y && xs == ys + + class Shows (k : Nat) (ts : Vect k Type) where + shows : HVect ts -> Vect k String + + instance Shows Z [] where + shows [] = [] + + instance (Show t, Shows k ts) => Shows (S k) (t::ts) where + shows (x::xs) = show x :: shows xs + + instance (Shows k ts) => Show (HVect ts) where + show xs = show (shows xs) + + get : {default tactics { applyTactic findElem 100; solve; } p : Elem t ts} -> HVect ts -> t + get {p = Here} (x::xs) = x + get {p = There p'} (x::xs) = get {p = p'} xs + + put : {default tactics { applyTactic findElem 100; solve; } p : Elem t ts} -> t -> HVect ts -> HVect ts + put {p = Here} y (x::xs) = y :: xs + put {p = There p'} y (x::xs) = x :: put {p = p'} y xs + + update : {default tactics { applyTactic findElem 100; solve; } p : Elem t ts} -> (t -> u) -> HVect ts -> HVect (replaceByElem ts p u) + update {p = Here} f (x::xs) = f x :: xs + update {p = There p'} f (x::xs) = x :: update {p = p'} f xs + diff --git a/lib/Data/Mod2.idr b/lib/Data/Mod2.idr --- a/lib/Data/Mod2.idr +++ b/lib/Data/Mod2.idr @@ -25,7 +25,7 @@ %assert_total public -intToMod : {n : Nat} -> Int -> Mod2 n +intToMod : {n : Nat} -> Integer -> Mod2 n intToMod {n=n} x = MkMod2 (intToBits x) instance Eq (Mod2 n) where @@ -56,7 +56,7 @@ where %assert_total helper : Mod2 n -> List Char - helper x = strIndex "0123456789" (bitsToInt (cast (x `rem` 10))) + helper x = strIndex "0123456789" (prim__truncBigInt_Int (bitsToInt (cast (x `rem` 10)))) :: (if x < 10 then [] else helper (x `div` 10)) diff --git a/lib/Data/Morphisms.idr b/lib/Data/Morphisms.idr --- a/lib/Data/Morphisms.idr +++ b/lib/Data/Morphisms.idr @@ -23,14 +23,13 @@ applyEndo (Endo f) a = f a instance Functor (Morphism r) where - fmap f (Mor a) = Mor (f . a) + map f (Mor a) = Mor (f . a) instance Applicative (Morphism r) where pure a = Mor $ const a (Mor f) <$> (Mor a) = Mor $ \r => f r $ a r instance Monad (Morphism r) where - return a = Mor $ const a (Mor h) >>= f = Mor $ \r => applyMor (f $ h r) r instance Semigroup (Endomorphism a) where diff --git a/lib/Data/SortedMap.idr b/lib/Data/SortedMap.idr --- a/lib/Data/SortedMap.idr +++ b/lib/Data/SortedMap.idr @@ -3,7 +3,7 @@ -- TODO: write merge and split data Tree : Nat -> Type -> Type -> Type where - Leaf : k -> v -> Tree O k v + Leaf : k -> v -> Tree Z k v Branch2 : Tree n k v -> k -> Tree n k v -> Tree (S n) k v Branch3 : Tree n k v -> k -> Tree n k v -> k -> Tree n k v -> Tree (S n) k v @@ -123,7 +123,7 @@ Right (a, b, c) => Right (Branch2 a b c) delType : Nat -> Type -> Type -> Type -delType O k v = () +delType Z k v = () delType (S n) k v = Tree n k v treeDelete : Ord k => k -> Tree n k v -> Either (Tree n k v) (delType n k v) @@ -132,7 +132,7 @@ Right () else Left (Leaf k' v) -treeDelete {n=S O} k (Branch2 t1 k' t2) = +treeDelete {n=S Z} k (Branch2 t1 k' t2) = if k <= k' then case treeDelete k t1 of Left t1' => Left (Branch2 t1' k' t2) @@ -141,7 +141,7 @@ case treeDelete k t2 of Left t2' => Left (Branch2 t1 k' t2') Right () => Right t1 -treeDelete {n=S O} k (Branch3 t1 k1 t2 k2 t3) = +treeDelete {n=S Z} k (Branch3 t1 k1 t2 k2 t3) = if k <= k1 then case treeDelete k t1 of Left t1' => Left (Branch3 t1' k1 t2 k2 t3) @@ -201,7 +201,7 @@ lookup k (M _ t) = treeLookup k t insert : Ord k => k -> v -> SortedMap k v -> SortedMap k v -insert k v Empty = M O (Leaf k v) +insert k v Empty = M Z (Leaf k v) insert k v (M _ t) = case treeInsert k v t of Left t' => (M _ t') @@ -209,7 +209,7 @@ delete : Ord k => k -> SortedMap k v -> SortedMap k v delete _ Empty = Empty -delete k (M O t) = +delete k (M Z t) = case treeDelete k t of Left t' => (M _ t') Right () => Empty @@ -226,10 +226,10 @@ toList (M _ t) = treeToList t instance Functor (Tree n k) where - fmap f (Leaf k v) = Leaf k (f v) - fmap f (Branch2 t1 k t2) = Branch2 (fmap f t1) k (fmap f t2) - fmap f (Branch3 t1 k1 t2 k2 t3) = Branch3 (fmap f t1) k1 (fmap f t2) k2 (fmap f t3) + map f (Leaf k v) = Leaf k (f v) + map f (Branch2 t1 k t2) = Branch2 (map f t1) k (map f t2) + map f (Branch3 t1 k1 t2 k2 t3) = Branch3 (map f t1) k1 (map f t2) k2 (map f t3) instance Functor (SortedMap k) where - fmap _ Empty = Empty - fmap f (M _ t) = M _ (fmap f t) + map _ Empty = Empty + map f (M n t) = M _ (map f t) diff --git a/lib/Data/Vect.idr b/lib/Data/Vect.idr new file mode 100644 --- /dev/null +++ b/lib/Data/Vect.idr @@ -0,0 +1,33 @@ +module Data.Vect + +import Language.Reflection + +%access public +%default total + +-------------------------------------------------------------------------------- +-- Elem +-------------------------------------------------------------------------------- + +using (xs : Vect k a) + data Elem : a -> Vect k a -> Type where + Here : Elem x (x::xs) + There : Elem x xs -> Elem x (y::xs) + +findElem : Nat -> List (TTName, Binder TT) -> TT -> Tactic +findElem Z ctxt goal = Refine "Here" `Seq` Solve +findElem (S n) ctxt goal = GoalType "Elem" (Try (Refine "Here" `Seq` Solve) (Refine "There" `Seq` (Solve `Seq` findElem n ctxt goal))) + +replaceElem : (xs : Vect k t) -> Elem x xs -> (y : t) -> (ys : Vect k t ** Elem y ys) +replaceElem (x::xs) Here y = (y :: xs ** Here) +replaceElem (x::xs) (There xinxs) y with (replaceElem xs xinxs y) + | (ys ** yinys) = (x :: ys ** There yinys) + +replaceByElem : (xs : Vect k t) -> Elem x xs -> t -> Vect k t +replaceByElem (x::xs) Here y = y :: xs +replaceByElem (x::xs) (There xinxs) y = x :: replaceByElem xs xinxs y + +mapElem : {xs : Vect k t} -> {f : t -> u} -> Elem x xs -> Elem (f x) (map f xs) +mapElem Here = Here +mapElem (There e) = There (mapElem e) + diff --git a/lib/Data/Vect/Quantifiers.idr b/lib/Data/Vect/Quantifiers.idr --- a/lib/Data/Vect/Quantifiers.idr +++ b/lib/Data/Vect/Quantifiers.idr @@ -1,18 +1,18 @@ module Data.Vect.Quantifiers -data Any : (P : a -> Type) -> Vect a n -> Type where - Here : {P : a -> Type} -> {xs : Vect a n} -> P x -> Any P (x :: xs) - There : {P : a -> Type} -> {xs : Vect a n} -> Any P xs -> Any P (x :: xs) +data Any : (P : a -> Type) -> Vect n a -> Type where + Here : {P : a -> Type} -> {xs : Vect n a} -> P x -> Any P (x :: xs) + There : {P : a -> Type} -> {xs : Vect n a} -> Any P xs -> Any P (x :: xs) anyNilAbsurd : {P : a -> Type} -> Any P Nil -> _|_ anyNilAbsurd Here impossible anyNilAbsurd There impossible -anyElim : {xs : Vect a n} -> {P : a -> Type} -> (Any P xs -> b) -> (P x -> b) -> Any P (x :: xs) -> b +anyElim : {xs : Vect n a} -> {P : a -> Type} -> (Any P xs -> b) -> (P x -> b) -> Any P (x :: xs) -> b anyElim _ f (Here p) = f p anyElim f _ (There p) = f p -any : {P : a -> Type} -> ((x : a) -> Dec (P x)) -> (xs : Vect a n) -> Dec (Any P xs) +any : {P : a -> Type} -> ((x : a) -> Dec (P x)) -> (xs : Vect n a) -> Dec (Any P xs) any _ Nil = No anyNilAbsurd any p (x::xs) with (p x) | Yes prf = Yes (Here prf) @@ -21,23 +21,23 @@ Yes prf' => Yes (There prf') No prf' => No (anyElim prf' prf) -data All : (P : a -> Type) -> Vect a n -> Type where +data All : (P : a -> Type) -> Vect n a -> Type where Nil : {P : a -> Type} -> All P Nil - (::) : {P : a -> Type} -> {xs : Vect a n} -> P x -> All P xs -> All P (x :: xs) + (::) : {P : a -> Type} -> {xs : Vect n a} -> P x -> All P xs -> All P (x :: xs) -negAnyAll : {P : a -> Type} -> {xs : Vect a n} -> Not (Any P xs) -> All (\x => Not (P x)) xs +negAnyAll : {P : a -> Type} -> {xs : Vect n a} -> Not (Any P xs) -> All (\x => Not (P x)) xs negAnyAll {xs=Nil} _ = Nil negAnyAll {xs=(x::xs)} f = (\x => f (Here x)) :: negAnyAll (\x => f (There x)) -notAllHere : {P : a -> Type} -> {xs : Vect a n} -> Not (P x) -> All P (x :: xs) -> _|_ +notAllHere : {P : a -> Type} -> {xs : Vect n a} -> Not (P x) -> All P (x :: xs) -> _|_ notAllHere _ Nil impossible notAllHere np (p :: _) = np p -notAllThere : {P : a -> Type} -> {xs : Vect a n} -> Not (All P xs) -> All P (x :: xs) -> _|_ +notAllThere : {P : a -> Type} -> {xs : Vect n a} -> Not (All P xs) -> All P (x :: xs) -> _|_ notAllThere _ Nil impossible notAllThere np (_ :: ps) = np ps -all : {P : a -> Type} -> ((x : a) -> Dec (P x)) -> (xs : Vect a n) -> Dec (All P xs) +all : {P : a -> Type} -> ((x : a) -> Dec (P x)) -> (xs : Vect n a) -> Dec (All P xs) all _ Nil = Yes Nil all d (x::xs) with (d x) | No prf = No (notAllHere prf) diff --git a/lib/Data/Z.idr b/lib/Data/Z.idr deleted file mode 100644 --- a/lib/Data/Z.idr +++ /dev/null @@ -1,144 +0,0 @@ -module Data.Z - -import Decidable.Equality -import Data.Sign - -%default total -%access public - - --- | An integer is either a positive nat or the negated successor of a nat. --- Zero is chosen to be positive. -data Z = Pos Nat | NegS Nat - -instance Signed Z where - sign (Pos _) = Plus - sign (NegS _) = Minus - -absZ : Z -> Nat -absZ (Pos n) = n -absZ (NegS n) = S n - -instance Show Z where - show (Pos n) = show n - show (NegS n) = "-" ++ show (S n) - -negZ : Z -> Z -negZ (Pos O) = Pos O -negZ (Pos (S n)) = NegS n -negZ (NegS n) = Pos (S n) - -negNat : Nat -> Z -negNat O = Pos O -negNat (S n) = NegS n - -minusNatZ : Nat -> Nat -> Z -minusNatZ n O = Pos n -minusNatZ O (S m) = NegS m -minusNatZ (S n) (S m) = minusNatZ n m - -plusZ : Z -> Z -> Z -plusZ (Pos n) (Pos m) = Pos (n + m) -plusZ (NegS n) (NegS m) = NegS (S (n + m)) -plusZ (Pos n) (NegS m) = minusNatZ n (S m) -plusZ (NegS n) (Pos m) = minusNatZ m (S n) - -subZ : Z -> Z -> Z -subZ n m = plusZ n (negZ m) - -instance Eq Z where - (Pos n) == (Pos m) = n == m - (NegS n) == (NegS m) = n == m - _ == _ = False - - -instance Ord Z where - compare (Pos n) (Pos m) = compare n m - compare (NegS n) (NegS m) = compare m n - compare (Pos _) (NegS _) = GT - compare (NegS _) (Pos _) = LT - - -multZ : Z -> Z -> Z -multZ (Pos n) (Pos m) = Pos $ n * m -multZ (NegS n) (NegS m) = Pos $ (S n) * (S m) -multZ (NegS n) (Pos m) = negNat $ (S n) * m -multZ (Pos n) (NegS m) = negNat $ n * (S m) - -fromInt : Int -> Z -fromInt n = if n < 0 - then NegS $ fromInteger {a=Nat} (-n - 1) - else Pos $ fromInteger {a=Nat} n - -instance Cast Nat Z where - cast n = Pos n - -instance Num Z where - (+) = plusZ - (-) = subZ - (*) = multZ - abs = cast . absZ - fromInteger = fromInt - -instance Cast Z Int where - cast (Pos n) = cast n - cast (NegS n) = (-1) * (cast n + 1) - -instance Cast Int Z where - cast = fromInteger - - --------------------------------------------------------------------------------- --- Properties --------------------------------------------------------------------------------- - -natPlusZPlus : (n : Nat) -> (m : Nat) -> (x : Nat) - -> n + m = x -> (Pos n) + (Pos m) = Pos x -natPlusZPlus n m x h = cong h - -natMultZMult : (n : Nat) -> (m : Nat) -> (x : Nat) - -> n * m = x -> (Pos n) * (Pos m) = Pos x -natMultZMult n m x h = cong h - -doubleNegElim : (z : Z) -> negZ (negZ z) = z -doubleNegElim (Pos O) = refl -doubleNegElim (Pos (S n)) = refl -doubleNegElim (NegS O) = refl -doubleNegElim (NegS (S n)) = refl - --- Injectivity -posInjective : Pos n = Pos m -> n = m -posInjective refl = refl - -negSInjective : NegS n = NegS m -> n = m -negSInjective refl = refl - -posNotNeg : Pos n = NegS m -> _|_ -posNotNeg refl impossible - --- Decidable equality -instance DecEq Z where - decEq (Pos n) (NegS m) = No posNotNeg - decEq (NegS n) (Pos m) = No $ negEqSym posNotNeg - decEq (Pos n) (Pos m) with (decEq n m) - | Yes p = Yes $ cong p - | No p = No $ \h => p $ posInjective h - decEq (NegS n) (NegS m) with (decEq n m) - | Yes p = Yes $ cong p - | No p = No $ \h => p $ negSInjective h - --- Plus -plusZeroLeftNeutralZ : (right : Z) -> 0 + right = right -plusZeroLeftNeutralZ (Pos n) = refl -plusZeroLeftNeutralZ (NegS n) = refl - -plusZeroRightNeutralZ : (left : Z) -> left + 0 = left -plusZeroRightNeutralZ (Pos n) = cong $ plusZeroRightNeutral n -plusZeroRightNeutralZ (NegS n) = refl - -plusCommutativeZ : (left : Z) -> (right : Z) -> (left + right = right + left) -plusCommutativeZ (Pos n) (Pos m) = cong $ plusCommutative n m -plusCommutativeZ (Pos n) (NegS m) = refl -plusCommutativeZ (NegS n) (Pos m) = refl -plusCommutativeZ (NegS n) (NegS m) = cong {f=NegS} $ cong {f=S} $ plusCommutative n m - diff --git a/lib/Data/ZZ.idr b/lib/Data/ZZ.idr new file mode 100644 --- /dev/null +++ b/lib/Data/ZZ.idr @@ -0,0 +1,144 @@ +module Data.ZZ + +import Decidable.Equality +import Data.Sign + +%default total +%access public + + +-- | An integer is either a positive nat or the negated successor of a nat. +-- Zero is chosen to be positive. +data ZZ = Pos Nat | NegS Nat + +instance Signed ZZ where + sign (Pos _) = Plus + sign (NegS _) = Minus + +absZ : ZZ -> Nat +absZ (Pos n) = n +absZ (NegS n) = S n + +instance Show ZZ where + show (Pos n) = show n + show (NegS n) = "-" ++ show (S n) + +negZ : ZZ -> ZZ +negZ (Pos Z) = Pos Z +negZ (Pos (S n)) = NegS n +negZ (NegS n) = Pos (S n) + +negNat : Nat -> ZZ +negNat Z = Pos Z +negNat (S n) = NegS n + +minusNatZ : Nat -> Nat -> ZZ +minusNatZ n Z = Pos n +minusNatZ Z (S m) = NegS m +minusNatZ (S n) (S m) = minusNatZ n m + +plusZ : ZZ -> ZZ -> ZZ +plusZ (Pos n) (Pos m) = Pos (n + m) +plusZ (NegS n) (NegS m) = NegS (S (n + m)) +plusZ (Pos n) (NegS m) = minusNatZ n (S m) +plusZ (NegS n) (Pos m) = minusNatZ m (S n) + +subZ : ZZ -> ZZ -> ZZ +subZ n m = plusZ n (negZ m) + +instance Eq ZZ where + (Pos n) == (Pos m) = n == m + (NegS n) == (NegS m) = n == m + _ == _ = False + + +instance Ord ZZ where + compare (Pos n) (Pos m) = compare n m + compare (NegS n) (NegS m) = compare m n + compare (Pos _) (NegS _) = GT + compare (NegS _) (Pos _) = LT + + +multZ : ZZ -> ZZ -> ZZ +multZ (Pos n) (Pos m) = Pos $ n * m +multZ (NegS n) (NegS m) = Pos $ (S n) * (S m) +multZ (NegS n) (Pos m) = negNat $ (S n) * m +multZ (Pos n) (NegS m) = negNat $ n * (S m) + +fromInt : Integer -> ZZ +fromInt n = if n < 0 + then NegS $ fromInteger {a=Nat} (-n - 1) + else Pos $ fromInteger {a=Nat} n + +instance Cast Nat ZZ where + cast n = Pos n + +instance Num ZZ where + (+) = plusZ + (-) = subZ + (*) = multZ + abs = cast . absZ + fromInteger = fromInt + +instance Cast ZZ Integer where + cast (Pos n) = cast n + cast (NegS n) = (-1) * (cast n + 1) + +instance Cast Integer ZZ where + cast = fromInteger + + +-------------------------------------------------------------------------------- +-- Properties +-------------------------------------------------------------------------------- + +natPlusZPlus : (n : Nat) -> (m : Nat) -> (x : Nat) + -> n + m = x -> (Pos n) + (Pos m) = Pos x +natPlusZPlus n m x h = cong h + +natMultZMult : (n : Nat) -> (m : Nat) -> (x : Nat) + -> n * m = x -> (Pos n) * (Pos m) = Pos x +natMultZMult n m x h = cong h + +doubleNegElim : (z : ZZ) -> negZ (negZ z) = z +doubleNegElim (Pos Z) = refl +doubleNegElim (Pos (S n)) = refl +doubleNegElim (NegS Z) = refl +doubleNegElim (NegS (S n)) = refl + +-- Injectivity +posInjective : Pos n = Pos m -> n = m +posInjective refl = refl + +negSInjective : NegS n = NegS m -> n = m +negSInjective refl = refl + +posNotNeg : Pos n = NegS m -> _|_ +posNotNeg refl impossible + +-- Decidable equality +instance DecEq ZZ where + decEq (Pos n) (NegS m) = No posNotNeg + decEq (NegS n) (Pos m) = No $ negEqSym posNotNeg + decEq (Pos n) (Pos m) with (decEq n m) + | Yes p = Yes $ cong p + | No p = No $ \h => p $ posInjective h + decEq (NegS n) (NegS m) with (decEq n m) + | Yes p = Yes $ cong p + | No p = No $ \h => p $ negSInjective h + +-- Plus +plusZeroLeftNeutralZ : (right : ZZ) -> 0 + right = right +plusZeroLeftNeutralZ (Pos n) = refl +plusZeroLeftNeutralZ (NegS n) = refl + +plusZeroRightNeutralZ : (left : ZZ) -> left + 0 = left +plusZeroRightNeutralZ (Pos n) = cong $ plusZeroRightNeutral n +plusZeroRightNeutralZ (NegS n) = refl + +plusCommutativeZ : (left : ZZ) -> (right : ZZ) -> (left + right = right + left) +plusCommutativeZ (Pos n) (Pos m) = cong $ plusCommutative n m +plusCommutativeZ (Pos n) (NegS m) = refl +plusCommutativeZ (NegS n) (Pos m) = refl +plusCommutativeZ (NegS n) (NegS m) = cong {f=NegS} $ cong {f=S} $ plusCommutative n m + diff --git a/lib/Decidable/Decidable.idr b/lib/Decidable/Decidable.idr --- a/lib/Decidable/Decidable.idr +++ b/lib/Decidable/Decidable.idr @@ -6,6 +6,11 @@ -- Typeclass for decidable n-ary Relations -------------------------------------------------------------------------------- +{- +This can't work yet! The class parameters must appear in the method type +signatures otherwise when defining the instances class resolution doesn't +have any clues... + using (t : Type) class Rel (p : t) where total liftRel : (Type -> Type) -> Type @@ -16,4 +21,4 @@ using (P : Type, p : P) data Given : Dec P -> Type where always : Given (Yes p) - +-} diff --git a/lib/Decidable/Equality.idr b/lib/Decidable/Equality.idr --- a/lib/Decidable/Equality.idr +++ b/lib/Decidable/Equality.idr @@ -41,13 +41,13 @@ -- Nat -------------------------------------------------------------------------------- -total OnotS : O = S n -> _|_ +total OnotS : Z = S n -> _|_ OnotS refl impossible instance DecEq Nat where - decEq O O = Yes refl - decEq O (S _) = No OnotS - decEq (S _) O = No (negEqSym OnotS) + decEq Z Z = Yes refl + decEq Z (S _) = No OnotS + decEq (S _) Z = No (negEqSym OnotS) decEq (S n) (S m) with (decEq n m) | Yes p = Yes $ cong p | No p = No $ \h : (S n = S m) => p $ succInjective n m h @@ -88,15 +88,69 @@ -- Fin -------------------------------------------------------------------------------- -total fONotfS : {f : Fin n} -> fO {k = n} = fS f -> _|_ -fONotfS refl impossible +total fZNotfS : {f : Fin n} -> fZ {k = n} = fS f -> _|_ +fZNotfS refl impossible instance DecEq (Fin n) where - decEq fO fO = Yes refl - decEq fO (fS f) = No fONotfS - decEq (fS f) fO = No $ negEqSym fONotfS + decEq fZ fZ = Yes refl + decEq fZ (fS f) = No fZNotfS + decEq (fS f) fZ = No $ negEqSym fZNotfS decEq (fS f) (fS f') with (decEq f f') | Yes p = Yes $ cong p | No p = No $ \h => p $ fSinjective {f = f} {f' = f'} h + +-------------------------------------------------------------------------------- +-- Tuple +-------------------------------------------------------------------------------- + +lemma_both_neq : {x : a, y : b, x' : c, y' : d} -> (x = x' -> _|_) -> (y = y' -> _|_) -> ((x, y) = (x', y') -> _|_) +lemma_both_neq p_x_not_x' p_y_not_y' refl = p_x_not_x' refl + +lemma_snd_neq : {x : a, y : b, y' : d} -> (x = x) -> (y = y' -> _|_) -> ((x, y) = (x, y') -> _|_) +lemma_snd_neq refl p refl = p refl + +lemma_fst_neq_snd_eq : {x : a, x' : b, y : c, y' : d} -> + (x = x' -> _|_) -> + (y = y') -> + ((x, y) = (x', y) -> _|_) +lemma_fst_neq_snd_eq p_x_not_x' refl refl = p_x_not_x' refl + +instance (DecEq a, DecEq b) => DecEq (a, b) where + decEq (a, b) (a', b') with (decEq a a') + decEq (a, b) (a, b') | (Yes refl) with (decEq b b') + decEq (a, b) (a, b) | (Yes refl) | (Yes refl) = Yes refl + decEq (a, b) (a, b') | (Yes refl) | (No p) = No (\eq => lemma_snd_neq refl p eq) + decEq (a, b) (a', b') | (No p) with (decEq b b') + decEq (a, b) (a', b) | (No p) | (Yes refl) = No (\eq => lemma_fst_neq_snd_eq p refl eq) + decEq (a, b) (a', b') | (No p) | (No p') = No (\eq => lemma_both_neq p p' eq) + + +-------------------------------------------------------------------------------- +-- List +-------------------------------------------------------------------------------- + +lemma_val_not_nil : {x : t, xs : List t} -> ((x :: xs) = Prelude.List.Nil {a = t} -> _|_) +lemma_val_not_nil refl impossible + +lemma_x_eq_xs_neq : {x : t, xs : List t, y : t, ys : List t} -> (x = y) -> (xs = ys -> _|_) -> ((x :: xs) = (y :: ys) -> _|_) +lemma_x_eq_xs_neq refl p refl = p refl + +lemma_x_neq_xs_eq : {x : t, xs : List t, y : t, ys : List t} -> (x = y -> _|_) -> (xs = ys) -> ((x :: xs) = (y :: ys) -> _|_) +lemma_x_neq_xs_eq p refl refl = p refl + +lemma_x_neq_xs_neq : {x : t, xs : List t, y : t, ys : List t} -> (x = y -> _|_) -> (xs = ys -> _|_) -> ((x :: xs) = (y :: ys) -> _|_) +lemma_x_neq_xs_neq p p' refl = p refl + +instance DecEq a => DecEq (List a) where + decEq [] [] = Yes refl + decEq (x :: xs) [] = No lemma_val_not_nil + decEq [] (x :: xs) = No (negEqSym lemma_val_not_nil) + decEq (x :: xs) (y :: ys) with (decEq x y) + decEq (x :: xs) (x :: ys) | Yes refl with (decEq xs ys) + decEq (x :: xs) (x :: xs) | (Yes refl) | (Yes refl) = Yes refl -- maybe another yes refl + decEq (x :: xs) (x :: ys) | (Yes refl) | (No p) = No (\eq => lemma_x_eq_xs_neq refl p eq) + decEq (x :: xs) (y :: ys) | No p with (decEq xs ys) + decEq (x :: xs) (y :: xs) | (No p) | (Yes refl) = No (\eq => lemma_x_neq_xs_eq p refl eq) + decEq (x :: xs) (y :: ys) | (No p) | (No p') = No (\eq => lemma_x_neq_xs_neq p p' eq) diff --git a/lib/Decidable/Order.idr b/lib/Decidable/Order.idr --- a/lib/Decidable/Order.idr +++ b/lib/Decidable/Order.idr @@ -1,5 +1,10 @@ module Decidable.Order +%access public + +{- +Doesn't work yet, see note in Decidable.idr + import Decidable.Decidable import Decidable.Equality @@ -40,15 +45,17 @@ transitive = NatLTEIsTransitive reflexive = NatLTEIsReflexive -total NatLTEIsAntisymmetric : (m : Nat) -> (n : Nat) -> po m n -> po n m -> m = n +total NatLTEIsAntisymmetric : (m : Nat) -> (n : Nat) -> + NatLTE m n -> NatLTE n m -> m = n NatLTEIsAntisymmetric n n nEqn nEqn = refl NatLTEIsAntisymmetric n m nEqn (nLTESm _) impossible NatLTEIsAntisymmetric n m (nLTESm _) nEqn impossible +NatLTEIsAntisymmetric n m (nLTESm _) (nLTESm _) impossible instance Poset Nat NatLTE where antisymmetric = NatLTEIsAntisymmetric -total zeroNeverGreater : {n : Nat} -> NatLTE (S n) O -> _|_ +total zeroNeverGreater : {n : Nat} -> NatLTE (S n) Z -> _|_ zeroNeverGreater {n} (nLTESm _) impossible zeroNeverGreater {n} nEqn impossible @@ -59,8 +66,8 @@ total decideNatLTE : (n : Nat) -> (m : Nat) -> Dec (NatLTE n m) -decideNatLTE O O = Yes nEqn -decideNatLTE (S x) O = No zeroNeverGreater +decideNatLTE Z Z = Yes nEqn +decideNatLTE (S x) Z = No zeroNeverGreater decideNatLTE x (S y) with (decEq x (S y)) | Yes eq = rewrite eq in Yes nEqn | No _ with (decideNatLTE x y) @@ -75,3 +82,6 @@ lte : (m : Nat) -> (n : Nat) -> Dec (NatLTE m n) lte m n = decide {p = NatLTE} m n + +-} + diff --git a/lib/Effects.idr b/lib/Effects.idr deleted file mode 100644 --- a/lib/Effects.idr +++ /dev/null @@ -1,228 +0,0 @@ -module Effects - -import Prelude -import Prelude.Catchable - -import Language.Reflection -import Control.Monad.Identity -import Effective - ------------ Effects ------------ - -Effect : Type -Effect = Type -> Type -> Type -> Type - -data EFF : Type where - MkEff : Type -> Effect -> EFF - -class Effective (e : Effect) (m : Type -> Type) where - runEffect : res -> (eff : e res res' t) -> (res' -> t -> m a) -> m a - -class Catchable (m : Type -> Type) t where - throw : t -> m a - catch : m a -> (t -> m a) -> m a - - - - - - - - - - - - - ---------------------- - -using (xs : Vect a m, ys : Vect a n) - data SubList : Vect a m -> Vect a n -> Type where - SubNil : SubList {a} [] [] - Keep : SubList xs ys -> SubList (x :: xs) (x :: ys) - Drop : SubList xs ys -> SubList xs (x :: ys) - - subListId : SubList xs xs - subListId {xs = Nil} = SubNil - subListId {xs = x :: xs} = Keep subListId - -effType : EFF -> Type -effType (MkEff t _) = t - -using (m : Type -> Type, - xs : Vect EFF n, xs' : Vect EFF n, xs'' : Vect EFF n, - ys : Vect EFF p) - - data Env : (m : Type -> Type) -> Vect EFF n -> Type where - Nil : Env m Nil - (::) : Effective eff m => a -> Env m xs -> Env m (MkEff a eff :: xs) - - data EffElem : (Type -> Type -> Type -> Type) -> Type -> - Vect EFF n -> Type where - Here : EffElem x a (MkEff a x :: xs) - There : EffElem x a xs -> EffElem x a (y :: xs) - - -- make an environment corresponding to a sub-list - dropEnv : Env m ys -> SubList xs ys -> Env m xs - dropEnv [] SubNil = [] - dropEnv (v :: vs) (Keep rest) = v :: dropEnv vs rest - dropEnv (v :: vs) (Drop rest) = dropEnv vs rest - - updateWith : {ys : Vect a p} -> - (ys' : Vect a p) -> (xs : Vect a n) -> - SubList ys xs -> Vect a n - updateWith (y :: ys) (x :: xs) (Keep rest) = y :: updateWith ys xs rest - updateWith ys (x :: xs) (Drop rest) = x :: updateWith ys xs rest - updateWith [] [] SubNil = [] - - -- put things back, replacing old with new in the sub-environment - rebuildEnv : {ys' : Vect _ p} -> - Env m ys' -> (prf : SubList ys xs) -> - Env m xs -> Env m (updateWith ys' xs prf) - rebuildEnv [] SubNil env = env - rebuildEnv (x :: xs) (Keep rest) (y :: env) = x :: rebuildEnv xs rest env - rebuildEnv xs (Drop rest) (y :: env) = y :: rebuildEnv xs rest env - ----- The Effect EDSL itself ---- - -using (m : Type -> Type, - xs : Vect EFF n, xs' : Vect EFF n, xs'' : Vect EFF n, - ys : Vect EFF p, ys' : Vect EFF p) - - -- some proof automation - findEffElem : Nat -> Tactic -- Nat is maximum search depth - findEffElem O = Refine "Here" `Seq` Solve - findEffElem (S n) = GoalType "EffElem" - (Try (Refine "Here" `Seq` Solve) - (Refine "There" `Seq` (Solve `Seq` findEffElem n))) - - findSubList : Nat -> Tactic - findSubList O = Refine "SubNil" `Seq` Solve - findSubList (S n) - = GoalType "SubList" - (Try (Refine "subListId" `Seq` Solve) - ((Try (Refine "Keep" `Seq` Solve) - (Refine "Drop" `Seq` Solve)) `Seq` findSubList n)) - - updateResTy : (xs : Vect EFF n) -> EffElem e a xs -> e a b t -> - Vect EFF n - updateResTy {b} (MkEff a e :: xs) Here n = (MkEff b e) :: xs - updateResTy (x :: xs) (There p) n = x :: updateResTy xs p n - - infix 5 :::, :-, := - - data LRes : lbl -> Type -> Type where - (:=) : (x : lbl) -> res -> LRes x res - - (:::) : lbl -> EFF -> EFF - (:::) {lbl} x (MkEff r eff) = MkEff (LRes x r) eff - - unlabel : {l : ty} -> Env m [l ::: x] -> Env m [x] - unlabel {m} {x = MkEff a eff} [l := v] = [v] - - relabel : (l : ty) -> Env m [x] -> Env m [l ::: x] - relabel {x = MkEff a eff} l [v] = [l := v] - - -- the language of Effects - - data EffM : (m : Type -> Type) -> - Vect EFF n -> Vect EFF n -> Type -> Type where - value : a -> EffM m xs xs a - ebind : EffM m xs xs' a -> (a -> EffM m xs' xs'' b) -> EffM m xs xs'' b - effect : {a, b: _} -> {e : Effect} -> - {default tactics { reflect findEffElem 10; solve; } - prf : EffElem e a xs} -> - (eff : e a b t) -> - EffM m xs (updateResTy xs prf eff) t - lift' : (prf : SubList ys xs) -> - EffM m ys ys' t -> EffM m xs (updateWith ys' xs prf) t - new : Effective e m => - res -> EffM m (MkEff res e :: xs) (MkEff res' e :: xs') a -> - EffM m xs xs' a - catch : Catchable m err => - EffM m xs xs' a -> (err -> EffM m xs xs' a) -> - EffM m xs xs' a - (:-) : (l : ty) -> EffM m [x] [y] t -> EffM m [l ::: x] [l ::: y] t - --- Eff : List (EFF m) -> Type -> Type - - implicit - lift : {default tactics { reflect findSubList 10; solve; } - prf : SubList ys xs} -> - EffM m ys ys' t -> EffM m xs (updateWith ys' xs prf) t - lift {prf} e = lift' prf e - - -- for 'do' notation - - return : a -> EffM m xs xs a - return x = value x - - (>>=) : EffM m xs xs' a -> (a -> EffM m xs' xs'' b) -> EffM m xs xs'' b - (>>=) = ebind - - -- for idiom brackets - - infixl 2 <$> - - pure : Monad m => a -> EffM m xs xs a - pure = value - - (<$>) : Monad m => EffM m xs xs (a -> b) -> EffM m xs xs a -> EffM m xs xs b - (<$>) prog v = do fn <- prog - arg <- v - return (fn arg) - - -- an interpreter - - execEff : Monad m => Env m xs -> (p : EffElem e res xs) -> - (eff : e res b a) -> - (Env m (updateResTy xs p eff) -> a -> m t) -> m t - execEff (val :: env) Here eff' k - = runEffect val eff' (\res, v => k (res :: env) v) - execEff (val :: env) (There p) eff k - = execEff env p eff (\env', v => k (val :: env') v) - - eff : Monad m => - Env m xs -> EffM m xs xs' a -> (Env m xs' -> a -> m b) -> m b - eff env (value x) k = k env x - eff env (prog `ebind` c) k - = eff env prog (\env', p' => eff env' (c p') k) - eff env (effect {prf} effP) k = execEff env prf effP k - eff env (lift' prf effP) k - = let env' = dropEnv env prf in - eff env' effP (\envk, p' => k (rebuildEnv envk prf env) p') - eff env (new r prog) k - = let env' = r :: env in - eff env' prog (\(v :: envk), p' => k envk p') - eff env (catch prog handler) k - = Effective.catch (eff env prog k) - (\e => eff env (handler e) k) - eff {xs = [l ::: x]} env (l :- prog) k - = let env' = unlabel {l} env in - eff env' prog (\envk, p' => k (relabel l envk) p') - - run : Monad m => Env m xs -> EffM m xs xs' a -> m a - run env prog = eff env prog (\env, r => return r) - - runEnv : Monad m => Env m xs -> EffM m xs xs' a -> m (Env m xs', a) - runEnv env prog = eff env prog (\env, r => return (env, r)) - - runPure : Env Identity xs -> EffM Identity xs xs' a -> a - runPure env prog = case eff env prog (\env, r => return r) of - Id v => v - -syntax Eff [xs] [a] = Monad m => EffM m xs xs a -syntax EffT [m] [xs] [t] = EffM m xs xs t - --- some higher order things - -mapE : Monad m => {xs : Vect EFF n} -> - (a -> EffM m xs xs b) -> List a -> EffM m xs xs (List b) -mapE f [] = pure [] -mapE f (x :: xs) = [| f x :: mapE f xs |] - -when : Monad m => {xs : Vect EFF n} -> - Bool -> EffM m xs xs () -> EffM m xs xs () -when True e = e -when False e = return () - diff --git a/lib/IO.idr b/lib/IO.idr --- a/lib/IO.idr +++ b/lib/IO.idr @@ -21,32 +21,72 @@ run__IO : IO () -> IO () run__IO v = io_bind v (\v' => io_return v') -data IntTy = ITNative | IT8 | IT16 | IT32 | IT64 -data FTy = FIntT IntTy | FFloat | FString | FPtr | FAny Type | FUnit +data IntTy = ITChar | ITNative | IT8 | IT16 | IT32 | IT64 | IT8x16 | IT16x8 | IT32x4 | IT64x2 +data FTy = FIntT IntTy + | FFunction FTy FTy + | FFloat + | FString + | FPtr + | FAny Type + | FUnit FInt : FTy FInt = FIntT ITNative FChar : FTy -FChar = FIntT IT8 +FChar = FIntT ITChar +FByte : FTy +FByte = FIntT IT8 + FShort : FTy FShort = FIntT IT16 FLong : FTy FLong = FIntT IT64 +FBits8 : FTy +FBits8 = FIntT IT8 + +FBits16 : FTy +FBits16 = FIntT IT16 + +FBits32 : FTy +FBits32 = FIntT IT32 + +FBits64 : FTy +FBits64 = FIntT IT64 + +FBits8x16 : FTy +FBits8x16 = FIntT IT8x16 + +FBits16x8 : FTy +FBits16x8 = FIntT IT16x8 + +FBits32x4 : FTy +FBits32x4 = FIntT IT32x4 + +FBits64x2 : FTy +FBits64x2 = FIntT IT64x2 + interpFTy : FTy -> Type interpFTy (FIntT ITNative) = Int -interpFTy (FIntT IT8) = Bits8 -interpFTy (FIntT IT16) = Bits16 -interpFTy (FIntT IT32) = Bits32 -interpFTy (FIntT IT64) = Bits64 -interpFTy FFloat = Float -interpFTy FString = String -interpFTy FPtr = Ptr -interpFTy (FAny t) = t -interpFTy FUnit = () +interpFTy (FIntT ITChar) = Char +interpFTy (FIntT IT8) = Bits8 +interpFTy (FIntT IT16) = Bits16 +interpFTy (FIntT IT32) = Bits32 +interpFTy (FIntT IT64) = Bits64 +interpFTy (FAny t) = t +interpFTy FFloat = Float +interpFTy FString = String +interpFTy FPtr = Ptr +interpFTy (FIntT IT8x16) = Bits8x16 +interpFTy (FIntT IT16x8) = Bits16x8 +interpFTy (FIntT IT32x4) = Bits32x4 +interpFTy (FIntT IT64x2) = Bits64x2 +interpFTy FUnit = () + +interpFTy (FFunction a b) = interpFTy a -> interpFTy b ForeignTy : (xs:List FTy) -> (t:FTy) -> Type ForeignTy Nil rt = IO (interpFTy rt) diff --git a/lib/Language/Reflection.idr b/lib/Language/Reflection.idr --- a/lib/Language/Reflection.idr +++ b/lib/Language/Reflection.idr @@ -1,5 +1,7 @@ module Language.Reflection +import Prelude.Vect + %access public data TTName = UN String @@ -86,15 +88,15 @@ instance Functor Binder where - fmap f (Lam x) = Lam (f x) - fmap f (Pi x) = Pi (f x) - fmap f (Let x y) = Let (f x) (f y) - fmap f (NLet x y) = NLet (f x) (f y) - fmap f (Hole x) = Hole (f x) - fmap f (GHole x) = GHole (f x) - fmap f (Guess x y) = Guess (f x) (f y) - fmap f (PVar x) = PVar (f x) - fmap f (PVTy x) = PVTy (f x) + map f (Lam x) = Lam (f x) + map f (Pi x) = Pi (f x) + map f (Let x y) = Let (f x) (f y) + map f (NLet x y) = NLet (f x) (f y) + map f (Hole x) = Hole (f x) + map f (GHole x) = GHole (f x) + map f (Guess x y) = Guess (f x) (f y) + map f (PVar x) = PVar (f x) + map f (PVTy x) = PVTy (f x) total traverse : (Applicative f) => (a -> f b) -> Binder a -> f (Binder b) diff --git a/lib/Network/Cgi.idr b/lib/Network/Cgi.idr --- a/lib/Network/Cgi.idr +++ b/lib/Network/Cgi.idr @@ -28,8 +28,8 @@ getAction (MkCGI act) = act instance Functor CGI where - fmap f (MkCGI c) = MkCGI (\s => do (a, i) <- c s - return (f a, i)) + map f (MkCGI c) = MkCGI (\s => do (a, i) <- c s + return (f a, i)) instance Applicative CGI where pure v = MkCGI (\s => return (v, s)) @@ -41,8 +41,6 @@ instance Monad CGI where { (>>=) (MkCGI f) k = MkCGI (\s => do v <- f s getAction (k (fst v)) (snd v)) - - return v = MkCGI (\s => return (v, s)) } setInfo : CGIInfo -> CGI () diff --git a/lib/Prelude.idr b/lib/Prelude.idr --- a/lib/Prelude.idr +++ b/lib/Prelude.idr @@ -22,11 +22,7 @@ -- Show and instances class Show a where - show : a -> String - -instance Show Nat where - show O = "O" - show (S k) = "s" ++ show k + partial show : a -> String instance Show Int where show = prim__toStrInt @@ -43,10 +39,125 @@ instance Show String where show = id +instance Show Nat where + show n = show (the Integer (cast n)) + instance Show Bool where show True = "True" show False = "False" +instance Show Bits8 where + show = prim__toStrB8 + +instance Show Bits16 where + show = prim__toStrB16 + +instance Show Bits32 where + show = prim__toStrB32 + +instance Show Bits64 where + show = prim__toStrB64 + +%assert_total +viewB8x16 : Bits8x16 -> (Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8) +viewB8x16 x = ( prim__indexB8x16 x (prim__truncBigInt_B32 0) + , prim__indexB8x16 x (prim__truncBigInt_B32 1) + , prim__indexB8x16 x (prim__truncBigInt_B32 2) + , prim__indexB8x16 x (prim__truncBigInt_B32 3) + , prim__indexB8x16 x (prim__truncBigInt_B32 4) + , prim__indexB8x16 x (prim__truncBigInt_B32 5) + , prim__indexB8x16 x (prim__truncBigInt_B32 6) + , prim__indexB8x16 x (prim__truncBigInt_B32 7) + , prim__indexB8x16 x (prim__truncBigInt_B32 8) + , prim__indexB8x16 x (prim__truncBigInt_B32 9) + , prim__indexB8x16 x (prim__truncBigInt_B32 10) + , prim__indexB8x16 x (prim__truncBigInt_B32 11) + , prim__indexB8x16 x (prim__truncBigInt_B32 12) + , prim__indexB8x16 x (prim__truncBigInt_B32 13) + , prim__indexB8x16 x (prim__truncBigInt_B32 14) + , prim__indexB8x16 x (prim__truncBigInt_B32 15) + ) + +instance Show Bits8x16 where + show x = + case viewB8x16 x of + (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) => + "<" ++ prim__toStrB8 a + ++ ", " ++ prim__toStrB8 b + ++ ", " ++ prim__toStrB8 c + ++ ", " ++ prim__toStrB8 d + ++ ", " ++ prim__toStrB8 e + ++ ", " ++ prim__toStrB8 f + ++ ", " ++ prim__toStrB8 g + ++ ", " ++ prim__toStrB8 h + ++ ", " ++ prim__toStrB8 i + ++ ", " ++ prim__toStrB8 j + ++ ", " ++ prim__toStrB8 k + ++ ", " ++ prim__toStrB8 l + ++ ", " ++ prim__toStrB8 m + ++ ", " ++ prim__toStrB8 n + ++ ", " ++ prim__toStrB8 o + ++ ", " ++ prim__toStrB8 p + ++ ">" + +%assert_total +viewB16x8 : Bits16x8 -> (Bits16, Bits16, Bits16, Bits16, Bits16, Bits16, Bits16, Bits16) +viewB16x8 x = ( prim__indexB16x8 x (prim__truncBigInt_B32 0) + , prim__indexB16x8 x (prim__truncBigInt_B32 1) + , prim__indexB16x8 x (prim__truncBigInt_B32 2) + , prim__indexB16x8 x (prim__truncBigInt_B32 3) + , prim__indexB16x8 x (prim__truncBigInt_B32 4) + , prim__indexB16x8 x (prim__truncBigInt_B32 5) + , prim__indexB16x8 x (prim__truncBigInt_B32 6) + , prim__indexB16x8 x (prim__truncBigInt_B32 7) + ) + +instance Show Bits16x8 where + show x = + case viewB16x8 x of + (a, b, c, d, e, f, g, h) => + "<" ++ prim__toStrB16 a + ++ ", " ++ prim__toStrB16 b + ++ ", " ++ prim__toStrB16 c + ++ ", " ++ prim__toStrB16 d + ++ ", " ++ prim__toStrB16 e + ++ ", " ++ prim__toStrB16 f + ++ ", " ++ prim__toStrB16 g + ++ ", " ++ prim__toStrB16 h + ++ ">" + +%assert_total +viewB32x4 : Bits32x4 -> (Bits32, Bits32, Bits32, Bits32) +viewB32x4 x = ( prim__indexB32x4 x (prim__truncBigInt_B32 0) + , prim__indexB32x4 x (prim__truncBigInt_B32 1) + , prim__indexB32x4 x (prim__truncBigInt_B32 2) + , prim__indexB32x4 x (prim__truncBigInt_B32 3) + ) + +instance Show Bits32x4 where + show x = + case viewB32x4 x of + (a, b, c, d) => + "<" ++ prim__toStrB32 a + ++ ", " ++ prim__toStrB32 b + ++ ", " ++ prim__toStrB32 c + ++ ", " ++ prim__toStrB32 d + ++ ">" + +%assert_total +viewB64x2 : Bits64x2 -> (Bits64, Bits64) +viewB64x2 x = ( prim__indexB64x2 x (prim__truncBigInt_B32 0) + , prim__indexB64x2 x (prim__truncBigInt_B32 1) + ) + +instance Show Bits64x2 where + show x = + case viewB64x2 x of + (a, b) => + "<" ++ prim__toStrB64 a + ++ ", " ++ prim__toStrB64 b + ++ ">" + instance (Show a, Show b) => Show (a, b) where show (x, y) = "(" ++ show x ++ ", " ++ show y ++ ")" @@ -56,9 +167,9 @@ show' acc [x] = acc ++ show x show' acc (x :: xs) = show' (acc ++ show x ++ ", ") xs -instance Show a => Show (Vect a n) where +instance Show a => Show (Vect n a) where show xs = "[" ++ show' xs ++ "]" where - show' : Vect a n -> String + show' : Vect n a -> String show' [] = "" show' [x] = show x show' (x :: xs) = show x ++ ", " ++ show' xs @@ -70,18 +181,15 @@ ---- Functor instances instance Functor IO where - fmap f io = io_bind io (io_return . f) + map f io = io_bind io (io_return . f) instance Functor Maybe where - fmap f (Just x) = Just (f x) - fmap f Nothing = Nothing + map f (Just x) = Just (f x) + map f Nothing = Nothing instance Functor (Either e) where - fmap f (Left l) = Left l - fmap f (Right r) = Right (f r) - -instance Functor List where - fmap = map + map f (Left l) = Left l + map f (Right r) = Right (f r) ---- Applicative instances @@ -108,6 +216,11 @@ fs <$> vs = concatMap (\f => map f vs) fs +instance Applicative (Vect k) where + pure = replicate _ + + fs <$> vs = zipWith ($) fs vs + ---- Alternative instances instance Alternative Maybe where @@ -124,32 +237,29 @@ ---- Monad instances instance Monad IO where - return t = io_return t b >>= k = io_bind b k instance Monad Maybe where - return t = Just t - Nothing >>= k = Nothing (Just x) >>= k = k x instance Monad (Either e) where - return = Right - (Left n) >>= _ = Left n (Right r) >>= f = f r instance Monad List where - return x = [x] m >>= f = concatMap f m +instance Monad (Vect n) where + m >>= f = diag (map f m) + ---- some mathematical operations -%include "math.h" -%lib "m" +%include C "math.h" +%lib C "m" pow : (Num a) => a -> Nat -> a -pow x O = 1 +pow x Z = 1 pow x (S n) = x * (pow x n) exp : Float -> Float @@ -235,6 +345,18 @@ uncurry : (a -> b -> c) -> (a, b) -> c uncurry f (a, b) = f a b +uniformB8x16 : Bits8 -> Bits8x16 +uniformB8x16 x = prim__mkB8x16 x x x x x x x x x x x x x x x x + +uniformB16x8 : Bits16 -> Bits16x8 +uniformB16x8 x = prim__mkB16x8 x x x x x x x x + +uniformB32x4 : Bits32 -> Bits32x4 +uniformB32x4 x = prim__mkB32x4 x x x x + +uniformB64x2 : Bits64 -> Bits64x2 +uniformB64x2 x = prim__mkB64x2 x x + ---- some basic io partial @@ -259,7 +381,7 @@ partial getChar : IO Char -getChar = fmap cast $ mkForeign (FFun "getchar" [] FInt) +getChar = map cast $ mkForeign (FFun "getchar" [] FInt) ---- some basic file handling diff --git a/lib/Prelude/Applicative.idr b/lib/Prelude/Applicative.idr --- a/lib/Prelude/Applicative.idr +++ b/lib/Prelude/Applicative.idr @@ -13,11 +13,11 @@ infixl 2 <$ (<$) : Applicative f => f a -> f b -> f a -a <$ b = fmap const a <$> b +a <$ b = map const a <$> b infixl 2 $> ($>) : Applicative f => f a -> f b -> f b -a $> b = fmap (const id) a <$> b +a $> b = map (const id) a <$> b infixl 3 <|> class Applicative f => Alternative (f : Type -> Type) where @@ -32,7 +32,7 @@ sequence : Applicative f => List (f a) -> f (List a) sequence [] = pure [] -sequence (x :: xs) = fmap (::) x <$> sequence xs +sequence (x :: xs) = map (::) x <$> sequence xs sequence_ : Applicative f => List (f a) -> f () sequence_ [] = pure () diff --git a/lib/Prelude/Fin.idr b/lib/Prelude/Fin.idr --- a/lib/Prelude/Fin.idr +++ b/lib/Prelude/Fin.idr @@ -4,42 +4,65 @@ import Prelude.Either data Fin : Nat -> Type where - fO : Fin (S k) + fZ : Fin (S k) fS : Fin k -> Fin (S k) instance Eq (Fin n) where - (==) fO fO = True + (==) fZ fZ = True (==) (fS k) (fS k') = k == k' (==) _ _ = False finToNat : Fin n -> Nat -> Nat -finToNat fO a = a +finToNat fZ a = a finToNat (fS x) a = finToNat x (S a) instance Cast (Fin n) Nat where - cast x = finToNat x O + cast x = finToNat x Z -finToInt : Fin n -> Int -> Int -finToInt fO a = a +finToInt : Fin n -> Integer -> Integer +finToInt fZ a = a finToInt (fS x) a = finToInt x (a + 1) -instance Cast (Fin n) Int where +instance Cast (Fin n) Integer where cast x = finToInt x 0 weaken : Fin n -> Fin (S n) -weaken fO = fO +weaken fZ = fZ weaken (fS k) = fS (weaken k) strengthen : Fin (S n) -> Either (Fin (S n)) (Fin n) -strengthen {n = S k} fO = Right fO +strengthen {n = S k} fZ = Right fZ strengthen {n = S k} (fS i) with (strengthen i) strengthen (fS k) | Left x = Left (fS x) strengthen (fS k) | Right x = Right (fS x) strengthen f = Left f last : Fin (S n) -last {n=O} = fO +last {n=Z} = fZ last {n=S _} = fS last total fSinjective : {f : Fin n} -> {f' : Fin n} -> (fS f = fS f') -> f = f' fSinjective refl = refl + + +-- Construct a Fin from an integer literal which must fit in the given Fin + +natToFin : Nat -> (n : Nat) -> Maybe (Fin n) +natToFin Z (S j) = Just fZ +natToFin (S k) (S j) with (natToFin k j) + | Just k' = Just (fS k') + | Nothing = Nothing +natToFin _ _ = Nothing + +integerToFin : Integer -> (n : Nat) -> Maybe (Fin n) +integerToFin x = natToFin (cast x) + +data IsJust : Maybe a -> Type where + ItIsJust : IsJust {a} (Just x) + +fromInteger : (x : Integer) -> + {default (ItIsJust _ _) + prf : (IsJust (integerToFin x n))} -> Fin n +fromInteger {n} x {prf} with (integerToFin x n) + fromInteger {n} x {prf = ItIsJust} | Just y = y + diff --git a/lib/Prelude/Functor.idr b/lib/Prelude/Functor.idr --- a/lib/Prelude/Functor.idr +++ b/lib/Prelude/Functor.idr @@ -1,4 +1,4 @@ module Prelude.Functor class Functor (f : Type -> Type) where - fmap : (a -> b) -> f a -> f b + map : (a -> b) -> f a -> f b diff --git a/lib/Prelude/Heap.idr b/lib/Prelude/Heap.idr --- a/lib/Prelude/Heap.idr +++ b/lib/Prelude/Heap.idr @@ -27,7 +27,7 @@ isEmpty _ = False total size : MaxiphobicHeap a -> Nat -size Empty = O +size Empty = Z size (Node s l e r) = s isValidHeap : Ord a => MaxiphobicHeap a -> Bool @@ -148,7 +148,7 @@ disjointTy False = () disjointTy True = _|_ -total isEmptySizeZero : (h : MaxiphobicHeap a) -> (isEmpty h = True) -> size h = O +total isEmptySizeZero : (h : MaxiphobicHeap a) -> (isEmpty h = True) -> size h = Z isEmptySizeZero Empty p = refl isEmptySizeZero (Node s l e r) p = ?isEmptySizeZeroNodeAbsurd diff --git a/lib/Prelude/List.idr b/lib/Prelude/List.idr --- a/lib/Prelude/List.idr +++ b/lib/Prelude/List.idr @@ -3,6 +3,7 @@ import Builtins import Prelude.Algebra +import Prelude.Functor import Prelude.Maybe import Prelude.Nat @@ -84,12 +85,12 @@ -------------------------------------------------------------------------------- take : Nat -> List a -> List a -take O xs = [] +take Z xs = [] take (S n) [] = [] take (S n) (x::xs) = x :: take n xs drop : Nat -> List a -> List a -drop O xs = xs +drop Z xs = xs drop (S n) [] = [] drop (S n) (x::xs) = drop n xs @@ -123,11 +124,11 @@ partial repeat : a -> List a -repeat x = x :: repeat x +repeat x = x :: lazy (repeat x) -%assert_total replicate : Nat -> a -> List a -replicate n x = take n (repeat x) +replicate Z x = [] +replicate (S n) x = x :: replicate n x -------------------------------------------------------------------------------- -- Instances @@ -163,6 +164,10 @@ -- instance VerifiedSemigroup (List a) where -- semigroupOpIsAssociative = appendAssociative +instance Functor List where + map f [] = [] + map f (x::xs) = f x :: map f xs + -------------------------------------------------------------------------------- -- Zips and unzips -------------------------------------------------------------------------------- @@ -201,10 +206,6 @@ -- Maps -------------------------------------------------------------------------------- -map : (a -> b) -> List a -> List b -map f [] = [] -map f (x::xs) = f x :: map f xs - mapMaybe : (a -> Maybe b) -> List a -> List b mapMaybe f [] = [] mapMaybe f (x::xs) = @@ -324,7 +325,7 @@ find p xs findIndex : (a -> Bool) -> List a -> Maybe Nat -findIndex = findIndex' O +findIndex = findIndex' Z where -- findIndex' : Nat -> (a -> Bool) -> List a -> Maybe Nat findIndex' cnt p [] = Nothing @@ -335,7 +336,7 @@ findIndex' (S cnt) p xs findIndices : (a -> Bool) -> List a -> List Nat -findIndices = findIndices' O +findIndices = findIndices' Z where -- findIndices' : Nat -> (a -> Bool) -> List a -> List Nat findIndices' cnt p [] = [] @@ -399,6 +400,7 @@ break : (a -> Bool) -> List a -> (List a, List a) break p = span (not . p) +%assert_total split : (a -> Bool) -> List a -> List (List a) split p [] = [] split p xs = diff --git a/lib/Prelude/Monad.idr b/lib/Prelude/Monad.idr --- a/lib/Prelude/Monad.idr +++ b/lib/Prelude/Monad.idr @@ -11,8 +11,10 @@ infixl 5 >>= class Applicative m => Monad (m : Type -> Type) where - return : a -> m a (>>=) : m a -> (a -> m b) -> m b flatten : Monad m => m (m a) -> m a flatten a = a >>= id + +return : Monad m => a -> m a +return = pure diff --git a/lib/Prelude/Nat.idr b/lib/Prelude/Nat.idr --- a/lib/Prelude/Nat.idr +++ b/lib/Prelude/Nat.idr @@ -9,7 +9,7 @@ %default total data Nat - = O + = Z | S Nat -------------------------------------------------------------------------------- @@ -17,11 +17,11 @@ -------------------------------------------------------------------------------- total isZero : Nat -> Bool -isZero O = True +isZero Z = True isZero (S n) = False total isSucc : Nat -> Bool -isSucc O = False +isSucc Z = False isSucc (S n) = True -------------------------------------------------------------------------------- @@ -29,27 +29,27 @@ -------------------------------------------------------------------------------- total plus : Nat -> Nat -> Nat -plus O right = right +plus Z right = right plus (S left) right = S (plus left right) total mult : Nat -> Nat -> Nat -mult O right = O +mult Z right = Z mult (S left) right = plus right $ mult left right total minus : Nat -> Nat -> Nat -minus O right = O -minus left O = left +minus Z right = Z +minus left Z = left minus (S left) (S right) = minus left right total power : Nat -> Nat -> Nat -power base O = S O +power base Z = S Z power base (S exp) = mult base $ power base exp hyper : Nat -> Nat -> Nat -> Nat -hyper O a b = S b -hyper (S O) a O = a -hyper (S(S O)) a O = O -hyper n a O = S O +hyper Z a b = S b +hyper (S Z) a Z = a +hyper (S(S Z)) a Z = Z +hyper n a Z = S Z hyper (S pn) a (S pb) = hyper pn a (hyper (S pn) a pb) @@ -58,7 +58,7 @@ -------------------------------------------------------------------------------- data LTE : Nat -> Nat -> Type where - lteZero : LTE O right + lteZero : LTE Z right lteSucc : LTE left right -> LTE (S left) (S right) total GTE : Nat -> Nat -> Type @@ -71,8 +71,8 @@ GT left right = LT right left total lte : Nat -> Nat -> Bool -lte O right = True -lte left O = False +lte Z right = True +lte left Z = False lte (S left) (S right) = lte left right total gte : Nat -> Nat -> Bool @@ -103,18 +103,18 @@ -------------------------------------------------------------------------------- instance Eq Nat where - O == O = True + Z == Z = True (S l) == (S r) = l == r _ == _ = False -instance Cast Nat Int where - cast O = 0 +instance Cast Nat Integer where + cast Z = 0 cast (S k) = 1 + cast k instance Ord Nat where - compare O O = EQ - compare O (S k) = LT - compare (S k) O = GT + compare Z Z = EQ + compare Z (S k) = LT + compare (S k) Z = GT compare (S x) (S y) = compare x y instance Num Nat where @@ -127,14 +127,17 @@ fromInteger x = fromInteger' x where %assert_total - fromInteger' : Int -> Nat - fromInteger' 0 = O + fromInteger' : Integer -> Nat + fromInteger' 0 = Z fromInteger' n = if (n > 0) then S (fromInteger' (n - 1)) else - O + Z +instance Cast Integer Nat where + cast = fromInteger + record Multiplicative : Type where getMultiplicative : Nat -> Multiplicative @@ -168,10 +171,10 @@ getAdditive m => m instance Monoid Multiplicative where - neutral = getMultiplicative $ S O + neutral = getMultiplicative $ S Z instance Monoid Additive where - neutral = getAdditive O + neutral = getAdditive Z instance MeetSemilattice Nat where meet = minimum @@ -182,14 +185,14 @@ instance Lattice Nat where { } instance BoundedJoinSemilattice Nat where - bottom = O + bottom = Z -------------------------------------------------------------------------------- -- Auxilliary notions -------------------------------------------------------------------------------- total pred : Nat -> Nat -pred O = O +pred Z = Z pred (S n) = n -------------------------------------------------------------------------------- @@ -197,8 +200,8 @@ -------------------------------------------------------------------------------- total fib : Nat -> Nat -fib O = O -fib (S O) = S O +fib Z = Z +fib (S Z) = S Z fib (S (S n)) = fib (S n) + fib n -------------------------------------------------------------------------------- @@ -210,11 +213,11 @@ -------------------------------------------------------------------------------- total mod : Nat -> Nat -> Nat -mod left O = left +mod left Z = left mod left (S right) = mod' left left right where total mod' : Nat -> Nat -> Nat -> Nat - mod' O centre right = centre + mod' Z centre right = centre mod' (S left) centre right = if lte centre right then centre @@ -222,21 +225,21 @@ mod' left (centre - (S right)) right total div : Nat -> Nat -> Nat -div left O = S left -- div by zero +div left Z = S left -- div by zero div left (S right) = div' left left right where total div' : Nat -> Nat -> Nat -> Nat - div' O centre right = O + div' Z centre right = Z div' (S left) centre right = if lte centre right then - O + Z else S (div' left (centre - (S right)) right) %assert_total log2 : Nat -> Nat -log2 O = O -log2 (S O) = O +log2 Z = Z +log2 (S Z) = Z log2 n = S (log2 (n `div` 2)) -------------------------------------------------------------------------------- @@ -257,28 +260,28 @@ plusZeroLeftNeutral right = refl total plusZeroRightNeutral : (left : Nat) -> left + 0 = left -plusZeroRightNeutral O = refl +plusZeroRightNeutral Z = refl plusZeroRightNeutral (S n) = let inductiveHypothesis = plusZeroRightNeutral n in ?plusZeroRightNeutralStepCase total plusSuccRightSucc : (left : Nat) -> (right : Nat) -> S (left + right) = left + (S right) -plusSuccRightSucc O right = refl +plusSuccRightSucc Z right = refl plusSuccRightSucc (S left) right = let inductiveHypothesis = plusSuccRightSucc left right in ?plusSuccRightSuccStepCase total plusCommutative : (left : Nat) -> (right : Nat) -> left + right = right + left -plusCommutative O right = ?plusCommutativeBaseCase +plusCommutative Z right = ?plusCommutativeBaseCase plusCommutative (S left) right = let inductiveHypothesis = plusCommutative left right in ?plusCommutativeStepCase total plusAssociative : (left : Nat) -> (centre : Nat) -> (right : Nat) -> left + (centre + right) = (left + centre) + right -plusAssociative O centre right = refl +plusAssociative Z centre right = refl plusAssociative (S left) centre right = let inductiveHypothesis = plusAssociative left centre right in ?plusAssociativeStepCase @@ -296,38 +299,38 @@ total plusLeftCancel : (left : Nat) -> (right : Nat) -> (right' : Nat) -> (p : left + right = left + right') -> right = right' -plusLeftCancel O right right' p = ?plusLeftCancelBaseCase +plusLeftCancel Z right right' p = ?plusLeftCancelBaseCase plusLeftCancel (S left) right right' p = let inductiveHypothesis = plusLeftCancel left right right' in ?plusLeftCancelStepCase total plusRightCancel : (left : Nat) -> (left' : Nat) -> (right : Nat) -> (p : left + right = left' + right) -> left = left' -plusRightCancel left left' O p = ?plusRightCancelBaseCase +plusRightCancel left left' Z p = ?plusRightCancelBaseCase plusRightCancel left left' (S right) p = let inductiveHypothesis = plusRightCancel left left' right in ?plusRightCancelStepCase total plusLeftLeftRightZero : (left : Nat) -> (right : Nat) -> - (p : left + right = left) -> right = O -plusLeftLeftRightZero O right p = ?plusLeftLeftRightZeroBaseCase + (p : left + right = left) -> right = Z +plusLeftLeftRightZero Z right p = ?plusLeftLeftRightZeroBaseCase plusLeftLeftRightZero (S left) right p = let inductiveHypothesis = plusLeftLeftRightZero left right in ?plusLeftLeftRightZeroStepCase -- Mult -total multZeroLeftZero : (right : Nat) -> O * right = O +total multZeroLeftZero : (right : Nat) -> Z * right = Z multZeroLeftZero right = refl -total multZeroRightZero : (left : Nat) -> left * O = O -multZeroRightZero O = refl +total multZeroRightZero : (left : Nat) -> left * Z = Z +multZeroRightZero Z = refl multZeroRightZero (S left) = let inductiveHypothesis = multZeroRightZero left in ?multZeroRightZeroStepCase total multRightSuccPlus : (left : Nat) -> (right : Nat) -> left * (S right) = left + (left * right) -multRightSuccPlus O right = refl +multRightSuccPlus Z right = refl multRightSuccPlus (S left) right = let inductiveHypothesis = multRightSuccPlus left right in ?multRightSuccPlusStepCase @@ -338,40 +341,40 @@ total multCommutative : (left : Nat) -> (right : Nat) -> left * right = right * left -multCommutative O right = ?multCommutativeBaseCase +multCommutative Z right = ?multCommutativeBaseCase multCommutative (S left) right = let inductiveHypothesis = multCommutative left right in ?multCommutativeStepCase total multDistributesOverPlusRight : (left : Nat) -> (centre : Nat) -> (right : Nat) -> left * (centre + right) = (left * centre) + (left * right) -multDistributesOverPlusRight O centre right = refl +multDistributesOverPlusRight Z centre right = refl multDistributesOverPlusRight (S left) centre right = let inductiveHypothesis = multDistributesOverPlusRight left centre right in ?multDistributesOverPlusRightStepCase total multDistributesOverPlusLeft : (left : Nat) -> (centre : Nat) -> (right : Nat) -> (left + centre) * right = (left * right) + (centre * right) -multDistributesOverPlusLeft O centre right = refl +multDistributesOverPlusLeft Z centre right = refl multDistributesOverPlusLeft (S left) centre right = let inductiveHypothesis = multDistributesOverPlusLeft left centre right in ?multDistributesOverPlusLeftStepCase total multAssociative : (left : Nat) -> (centre : Nat) -> (right : Nat) -> left * (centre * right) = (left * centre) * right -multAssociative O centre right = refl +multAssociative Z centre right = refl multAssociative (S left) centre right = let inductiveHypothesis = multAssociative left centre right in ?multAssociativeStepCase total multOneLeftNeutral : (right : Nat) -> 1 * right = right -multOneLeftNeutral O = refl +multOneLeftNeutral Z = refl multOneLeftNeutral (S right) = let inductiveHypothesis = multOneLeftNeutral right in ?multOneLeftNeutralStepCase total multOneRightNeutral : (left : Nat) -> left * 1 = left -multOneRightNeutral O = refl +multOneRightNeutral Z = refl multOneRightNeutral (S left) = let inductiveHypothesis = multOneRightNeutral left in ?multOneRightNeutralStepCase @@ -381,51 +384,51 @@ (S left) - (S right) = left - right minusSuccSucc left right = refl -total minusZeroLeft : (right : Nat) -> 0 - right = O +total minusZeroLeft : (right : Nat) -> 0 - right = Z minusZeroLeft right = refl total minusZeroRight : (left : Nat) -> left - 0 = left -minusZeroRight O = refl +minusZeroRight Z = refl minusZeroRight (S left) = refl -total minusZeroN : (n : Nat) -> O = n - n -minusZeroN O = refl +total minusZeroN : (n : Nat) -> Z = n - n +minusZeroN Z = refl minusZeroN (S n) = minusZeroN n -total minusOneSuccN : (n : Nat) -> S O = (S n) - n -minusOneSuccN O = refl +total minusOneSuccN : (n : Nat) -> S Z = (S n) - n +minusOneSuccN Z = refl minusOneSuccN (S n) = minusOneSuccN n total minusSuccOne : (n : Nat) -> S n - 1 = n -minusSuccOne O = refl +minusSuccOne Z = refl minusSuccOne (S n) = refl -total minusPlusZero : (n : Nat) -> (m : Nat) -> n - (n + m) = O -minusPlusZero O m = refl +total minusPlusZero : (n : Nat) -> (m : Nat) -> n - (n + m) = Z +minusPlusZero Z m = refl minusPlusZero (S n) m = minusPlusZero n m total minusMinusMinusPlus : (left : Nat) -> (centre : Nat) -> (right : Nat) -> left - centre - right = left - (centre + right) -minusMinusMinusPlus O O right = refl -minusMinusMinusPlus (S left) O right = refl -minusMinusMinusPlus O (S centre) right = refl +minusMinusMinusPlus Z Z right = refl +minusMinusMinusPlus (S left) Z right = refl +minusMinusMinusPlus Z (S centre) right = refl minusMinusMinusPlus (S left) (S centre) right = let inductiveHypothesis = minusMinusMinusPlus left centre right in ?minusMinusMinusPlusStepCase total plusMinusLeftCancel : (left : Nat) -> (right : Nat) -> (right' : Nat) -> (left + right) - (left + right') = right - right' -plusMinusLeftCancel O right right' = refl +plusMinusLeftCancel Z right right' = refl plusMinusLeftCancel (S left) right right' = let inductiveHypothesis = plusMinusLeftCancel left right right' in ?plusMinusLeftCancelStepCase total multDistributesOverMinusLeft : (left : Nat) -> (centre : Nat) -> (right : Nat) -> (left - centre) * right = (left * right) - (centre * right) -multDistributesOverMinusLeft O O right = refl -multDistributesOverMinusLeft (S left) O right = +multDistributesOverMinusLeft Z Z right = refl +multDistributesOverMinusLeft (S left) Z right = ?multDistributesOverMinusLeftBaseCase -multDistributesOverMinusLeft O (S centre) right = refl +multDistributesOverMinusLeft Z (S centre) right = refl multDistributesOverMinusLeft (S left) (S centre) right = let inductiveHypothesis = multDistributesOverMinusLeft left centre right in ?multDistributesOverMinusLeftStepCase @@ -442,35 +445,35 @@ total multPowerPowerPlus : (base : Nat) -> (exp : Nat) -> (exp' : Nat) -> (power base exp) * (power base exp') = power base (exp + exp') -multPowerPowerPlus base O exp' = ?multPowerPowerPlusBaseCase +multPowerPowerPlus base Z exp' = ?multPowerPowerPlusBaseCase multPowerPowerPlus base (S exp) exp' = let inductiveHypothesis = multPowerPowerPlus base exp exp' in ?multPowerPowerPlusStepCase -total powerZeroOne : (base : Nat) -> power base 0 = S O +total powerZeroOne : (base : Nat) -> power base 0 = S Z powerZeroOne base = refl total powerOneNeutral : (base : Nat) -> power base 1 = base -powerOneNeutral O = refl +powerOneNeutral Z = refl powerOneNeutral (S base) = let inductiveHypothesis = powerOneNeutral base in ?powerOneNeutralStepCase -total powerOneSuccOne : (exp : Nat) -> power 1 exp = S O -powerOneSuccOne O = refl +total powerOneSuccOne : (exp : Nat) -> power 1 exp = S Z +powerOneSuccOne Z = refl powerOneSuccOne (S exp) = let inductiveHypothesis = powerOneSuccOne exp in ?powerOneSuccOneStepCase total powerSuccSuccMult : (base : Nat) -> power base 2 = mult base base -powerSuccSuccMult O = refl +powerSuccSuccMult Z = refl powerSuccSuccMult (S base) = let inductiveHypothesis = powerSuccSuccMult base in ?powerSuccSuccMultStepCase total powerPowerMultPower : (base : Nat) -> (exp : Nat) -> (exp' : Nat) -> power (power base exp) exp' = power base (exp * exp') -powerPowerMultPower base exp O = ?powerPowerMultPowerBaseCase +powerPowerMultPower base exp Z = ?powerPowerMultPowerBaseCase powerPowerMultPower base exp (S exp') = let inductiveHypothesis = powerPowerMultPower base exp exp' in ?powerPowerMultPowerStepCase @@ -481,9 +484,9 @@ total minusSuccPred : (left : Nat) -> (right : Nat) -> left - (S right) = pred (left - right) -minusSuccPred O right = refl -minusSuccPred (S left) O = - let inductiveHypothesis = minusSuccPred left O in +minusSuccPred Z right = refl +minusSuccPred (S left) Z = + let inductiveHypothesis = minusSuccPred left Z in ?minusSuccPredStepCase minusSuccPred (S left) (S right) = let inductiveHypothesis = minusSuccPred left right in @@ -517,69 +520,69 @@ -- Orders total lteNTrue : (n : Nat) -> lte n n = True -lteNTrue O = refl +lteNTrue Z = refl lteNTrue (S n) = lteNTrue n -total lteSuccZeroFalse : (n : Nat) -> lte (S n) O = False -lteSuccZeroFalse O = refl +total lteSuccZeroFalse : (n : Nat) -> lte (S n) Z = False +lteSuccZeroFalse Z = refl lteSuccZeroFalse (S n) = refl -- Minimum and maximum -total minimumZeroZeroRight : (right : Nat) -> minimum 0 right = O -minimumZeroZeroRight O = refl +total minimumZeroZeroRight : (right : Nat) -> minimum 0 right = Z +minimumZeroZeroRight Z = refl minimumZeroZeroRight (S right) = minimumZeroZeroRight right -total minimumZeroZeroLeft : (left : Nat) -> minimum left 0 = O -minimumZeroZeroLeft O = refl +total minimumZeroZeroLeft : (left : Nat) -> minimum left 0 = Z +minimumZeroZeroLeft Z = refl minimumZeroZeroLeft (S left) = refl total minimumSuccSucc : (left : Nat) -> (right : Nat) -> minimum (S left) (S right) = S (minimum left right) -minimumSuccSucc O O = refl -minimumSuccSucc (S left) O = refl -minimumSuccSucc O (S right) = refl +minimumSuccSucc Z Z = refl +minimumSuccSucc (S left) Z = refl +minimumSuccSucc Z (S right) = refl minimumSuccSucc (S left) (S right) = let inductiveHypothesis = minimumSuccSucc left right in ?minimumSuccSuccStepCase total minimumCommutative : (left : Nat) -> (right : Nat) -> minimum left right = minimum right left -minimumCommutative O O = refl -minimumCommutative O (S right) = refl -minimumCommutative (S left) O = refl +minimumCommutative Z Z = refl +minimumCommutative Z (S right) = refl +minimumCommutative (S left) Z = refl minimumCommutative (S left) (S right) = let inductiveHypothesis = minimumCommutative left right in ?minimumCommutativeStepCase -total maximumZeroNRight : (right : Nat) -> maximum O right = right -maximumZeroNRight O = refl +total maximumZeroNRight : (right : Nat) -> maximum Z right = right +maximumZeroNRight Z = refl maximumZeroNRight (S right) = refl -total maximumZeroNLeft : (left : Nat) -> maximum left O = left -maximumZeroNLeft O = refl +total maximumZeroNLeft : (left : Nat) -> maximum left Z = left +maximumZeroNLeft Z = refl maximumZeroNLeft (S left) = refl total maximumSuccSucc : (left : Nat) -> (right : Nat) -> S (maximum left right) = maximum (S left) (S right) -maximumSuccSucc O O = refl -maximumSuccSucc (S left) O = refl -maximumSuccSucc O (S right) = refl +maximumSuccSucc Z Z = refl +maximumSuccSucc (S left) Z = refl +maximumSuccSucc Z (S right) = refl maximumSuccSucc (S left) (S right) = let inductiveHypothesis = maximumSuccSucc left right in ?maximumSuccSuccStepCase total maximumCommutative : (left : Nat) -> (right : Nat) -> maximum left right = maximum right left -maximumCommutative O O = refl -maximumCommutative (S left) O = refl -maximumCommutative O (S right) = refl +maximumCommutative Z Z = refl +maximumCommutative (S left) Z = refl +maximumCommutative Z (S right) = refl maximumCommutative (S left) (S right) = let inductiveHypothesis = maximumCommutative left right in ?maximumCommutativeStepCase -- div and mod -total modZeroZero : (n : Nat) -> mod 0 n = O -modZeroZero O = refl +total modZeroZero : (n : Nat) -> mod 0 n = Z +modZeroZero Z = refl modZeroZero (S n) = refl -------------------------------------------------------------------------------- @@ -610,7 +613,7 @@ powerOneSuccOneStepCase = proof { intros; rewrite inductiveHypothesis; - rewrite sym (plusZeroRightNeutral (power (S O) exp)); + rewrite sym (plusZeroRightNeutral (power (S Z) exp)); trivial; } diff --git a/lib/Prelude/Strings.idr b/lib/Prelude/Strings.idr --- a/lib/Prelude/Strings.idr +++ b/lib/Prelude/Strings.idr @@ -116,5 +116,4 @@ unwords = pack . unwords' . map unpack length : String -> Nat -length = fromInteger . prim_lenString - +length = fromInteger . prim__zextInt_BigInt . prim_lenString diff --git a/lib/Prelude/Vect.idr b/lib/Prelude/Vect.idr --- a/lib/Prelude/Vect.idr +++ b/lib/Prelude/Vect.idr @@ -1,6 +1,7 @@ module Prelude.Vect import Prelude.Fin +import Prelude.Functor import Prelude.List import Prelude.Nat @@ -9,50 +10,54 @@ infixr 7 :: -data Vect : Type -> Nat -> Type where - Nil : Vect a O - (::) : a -> Vect a n -> Vect a (S n) +data Vect : Nat -> Type -> Type where + Nil : Vect Z a + (::) : a -> Vect n a -> Vect (S n) a -------------------------------------------------------------------------------- -- Indexing into vectors -------------------------------------------------------------------------------- -tail : Vect a (S n) -> Vect a n +tail : Vect (S n) a -> Vect n a tail (x::xs) = xs -head : Vect a (S n) -> a +head : Vect (S n) a -> a head (x::xs) = x -last : Vect a (S n) -> a +last : Vect (S n) a -> a last (x::[]) = x last (x::y::ys) = last $ y::ys -init : Vect a (S n) -> Vect a n +init : Vect (S n) a -> Vect n a init (x::[]) = [] init (x::y::ys) = x :: init (y::ys) -index : Fin n -> Vect a n -> a -index fO (x::xs) = x +index : Fin n -> Vect n a -> a +index fZ (x::xs) = x index (fS k) (x::xs) = index k xs -index fO [] impossible +index fZ [] impossible -deleteAt : Fin (S n) -> Vect a (S n) -> Vect a n -deleteAt fO (x::xs) = xs +deleteAt : Fin (S n) -> Vect (S n) a -> Vect n a +deleteAt fZ (x::xs) = xs deleteAt {n = S m} (fS k) (x::xs) = x :: deleteAt k xs deleteAt _ [] impossible +replaceAt : Fin n -> t -> Vect n t -> Vect n t +replaceAt fZ y (x::xs) = y::xs +replaceAt (fS k) y (x::xs) = x :: replaceAt k y xs + -------------------------------------------------------------------------------- -- Subvectors -------------------------------------------------------------------------------- -take : Fin n -> Vect a n -> (p ** Vect a p) -take fO xs = (_ ** []) +take : Fin n -> Vect n a -> (p ** Vect p a) +take fZ xs = (_ ** []) take (fS k) [] impossible take (fS k) (x::xs) with (take k xs) | (_ ** tail) = (_ ** x::tail) -drop : Fin n -> Vect a n -> (p ** Vect a p) -drop fO xs = (_ ** xs) +drop : Fin n -> Vect n a -> (p ** Vect p a) +drop fZ xs = (_ ** xs) drop (fS k) [] impossible drop (fS k) (x::xs) = drop k xs @@ -60,11 +65,11 @@ -- Conversions to and from list -------------------------------------------------------------------------------- -toList : Vect a n -> List a +toList : Vect n a -> List a toList [] = [] toList (x::xs) = x :: toList xs -fromList : (l : List a) -> Vect a (length l) +fromList : (l : List a) -> Vect (length l) a fromList [] = [] fromList (x::xs) = x :: fromList xs @@ -72,26 +77,26 @@ -- Building (bigger) vectors -------------------------------------------------------------------------------- -(++) : Vect a m -> Vect a n -> Vect a (m + n) +(++) : Vect m a -> Vect n a -> Vect (m + n) a (++) [] ys = ys (++) (x::xs) ys = x :: xs ++ ys -replicate : (n : Nat) -> a -> Vect a n -replicate O x = [] +replicate : (n : Nat) -> a -> Vect n a +replicate Z x = [] replicate (S k) x = x :: replicate k x -------------------------------------------------------------------------------- -- Zips and unzips -------------------------------------------------------------------------------- -zipWith : (a -> b -> c) -> Vect a n -> Vect b n -> Vect c n +zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c zipWith f [] [] = [] zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys -zip : Vect a n -> Vect b n -> Vect (a, b) n +zip : Vect n a -> Vect n b -> Vect n (a, b) zip = zipWith (\x => \y => (x,y)) -unzip : Vect (a, b) n -> (Vect a n, Vect b n) +unzip : Vect n (a, b) -> (Vect n a, Vect n b) unzip [] = ([], []) unzip ((l, r)::xs) with (unzip xs) | (lefts, rights) = (l::lefts, r::rights) @@ -100,12 +105,12 @@ -- Maps -------------------------------------------------------------------------------- -map : (a -> b) -> Vect a n -> Vect b n -map f [] = [] -map f (x::xs) = f x :: map f xs +instance Functor (Vect n) where + map f [] = [] + map f (x::xs) = f x :: map f xs -- XXX: causes Idris to enter an infinite loop when type checking in the REPL ---mapMaybe : (a -> Maybe b) -> Vect a n -> (p ** Vect b p) +--mapMaybe : (a -> Maybe b) -> Vect n a -> (p ** Vect b p) --mapMaybe f [] = (_ ** []) --mapMaybe f (x::xs) = mapMaybe' (f x) -- XXX: working around the type restrictions on case statements @@ -118,11 +123,11 @@ -- Folds -------------------------------------------------------------------------------- -total foldl : (a -> b -> a) -> a -> Vect b m -> a +total foldl : (a -> b -> a) -> a -> Vect m b -> a foldl f e [] = e foldl f e (x::xs) = foldl f (f e x) xs -total foldr : (a -> b -> b) -> b -> Vect a m -> b +total foldr : (a -> b -> b) -> b -> Vect m a -> b foldr f e [] = e foldr f e (x::xs) = f x (foldr f e xs) @@ -130,39 +135,39 @@ -- Special folds -------------------------------------------------------------------------------- -concat : Vect (Vect a n) m -> Vect a (m * n) +concat : Vect m (Vect n a) -> Vect (m * n) a concat [] = [] concat (v::vs) = v ++ concat vs -total and : Vect Bool m -> Bool +total and : Vect m Bool -> Bool and = foldr (&&) True -total or : Vect Bool m -> Bool +total or : Vect m Bool -> Bool or = foldr (||) False -total any : (a -> Bool) -> Vect a m -> Bool +total any : (a -> Bool) -> Vect m a -> Bool any p = Vect.or . map p -total all : (a -> Bool) -> Vect a m -> Bool +total all : (a -> Bool) -> Vect m a -> Bool all p = Vect.and . map p -------------------------------------------------------------------------------- -- Transformations -------------------------------------------------------------------------------- -total reverse : Vect a n -> Vect a n +total reverse : Vect n a -> Vect n a reverse = reverse' [] where - total reverse' : Vect a m -> Vect a n -> Vect a (m + n) + total reverse' : Vect m a -> Vect n a -> Vect (m + n) a reverse' acc [] ?= acc reverse' acc (x::xs) ?= reverse' (x::acc) xs -total intersperse' : a -> Vect a m -> (p ** Vect a p) +total intersperse' : a -> Vect m a -> (p ** Vect p a) intersperse' sep [] = (_ ** []) intersperse' sep (y::ys) with (intersperse' sep ys) | (_ ** tail) = (_ ** sep::y::tail) -total intersperse : a -> Vect a m -> (p ** Vect a p) +total intersperse : a -> Vect m a -> (p ** Vect p a) intersperse sep [] = (_ ** []) intersperse sep (x::xs) with (intersperse' sep xs) | (_ ** tail) = (_ ** x::tail) @@ -171,56 +176,56 @@ -- Membership tests -------------------------------------------------------------------------------- -elemBy : (a -> a -> Bool) -> a -> Vect a n -> Bool +elemBy : (a -> a -> Bool) -> a -> Vect n a -> Bool elemBy p e [] = False elemBy p e (x::xs) with (p e x) | True = True | False = elemBy p e xs -elem : Eq a => a -> Vect a n -> Bool +elem : Eq a => a -> Vect n a -> Bool elem = elemBy (==) -lookupBy : (a -> a -> Bool) -> a -> Vect (a, b) n -> Maybe b +lookupBy : (a -> a -> Bool) -> a -> Vect n (a, b) -> Maybe b lookupBy p e [] = Nothing lookupBy p e ((l, r)::xs) with (p e l) | True = Just r | False = lookupBy p e xs -lookup : Eq a => a -> Vect (a, b) n -> Maybe b +lookup : Eq a => a -> Vect n (a, b) -> Maybe b lookup = lookupBy (==) -hasAnyBy : (a -> a -> Bool) -> Vect a m -> Vect a n -> Bool +hasAnyBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool hasAnyBy p elems [] = False hasAnyBy p elems (x::xs) with (elemBy p x elems) | True = True | False = hasAnyBy p elems xs -hasAny : Eq a => Vect a m -> Vect a n -> Bool +hasAny : Eq a => Vect m a -> Vect n a -> Bool hasAny = hasAnyBy (==) -------------------------------------------------------------------------------- -- Searching with a predicate -------------------------------------------------------------------------------- -find : (a -> Bool) -> Vect a n -> Maybe a +find : (a -> Bool) -> Vect n a -> Maybe a find p [] = Nothing find p (x::xs) with (p x) | True = Just x | False = find p xs -findIndex : (a -> Bool) -> Vect a n -> Maybe Nat +findIndex : (a -> Bool) -> Vect n a -> Maybe Nat findIndex = findIndex' 0 where - findIndex' : Nat -> (a -> Bool) -> Vect a n -> Maybe Nat + findIndex' : Nat -> (a -> Bool) -> Vect n a -> Maybe Nat findIndex' cnt p [] = Nothing findIndex' cnt p (x::xs) with (p x) | True = Just cnt | False = findIndex' (S cnt) p xs -total findIndices : (a -> Bool) -> Vect a m -> (p ** Vect Nat p) +total findIndices : (a -> Bool) -> Vect m a -> (p ** Vect p Nat) findIndices = findIndices' 0 where - total findIndices' : Nat -> (a -> Bool) -> Vect a m -> (p ** Vect Nat p) + total findIndices' : Nat -> (a -> Bool) -> Vect m a -> (p ** Vect p Nat) findIndices' cnt p [] = (_ ** []) findIndices' cnt p (x::xs) with (findIndices' (S cnt) p xs) | (_ ** tail) = @@ -229,23 +234,23 @@ else (_ ** tail) -elemIndexBy : (a -> a -> Bool) -> a -> Vect a m -> Maybe Nat +elemIndexBy : (a -> a -> Bool) -> a -> Vect m a -> Maybe Nat elemIndexBy p e = findIndex $ p e -elemIndex : Eq a => a -> Vect a m -> Maybe Nat +elemIndex : Eq a => a -> Vect m a -> Maybe Nat elemIndex = elemIndexBy (==) -total elemIndicesBy : (a -> a -> Bool) -> a -> Vect a m -> (p ** Vect Nat p) +total elemIndicesBy : (a -> a -> Bool) -> a -> Vect m a -> (p ** Vect p Nat) elemIndicesBy p e = findIndices $ p e -total elemIndices : Eq a => a -> Vect a m -> (p ** Vect Nat p) +total elemIndices : Eq a => a -> Vect m a -> (p ** Vect p Nat) elemIndices = elemIndicesBy (==) -------------------------------------------------------------------------------- -- Filters -------------------------------------------------------------------------------- -total filter : (a -> Bool) -> Vect a n -> (p ** Vect a p) +total filter : (a -> Bool) -> Vect n a -> (p ** Vect p a) filter p [] = ( _ ** [] ) filter p (x::xs) with (filter p xs) | (_ ** tail) = @@ -254,17 +259,17 @@ else (_ ** tail) -nubBy : (a -> a -> Bool) -> Vect a n -> (p ** Vect a p) +nubBy : (a -> a -> Bool) -> Vect n a -> (p ** Vect p a) nubBy = nubBy' [] where - nubBy' : Vect a m -> (a -> a -> Bool) -> Vect a n -> (p ** Vect a p) + nubBy' : Vect m a -> (a -> a -> Bool) -> Vect n a -> (p ** Vect p a) nubBy' acc p [] = (_ ** []) nubBy' acc p (x::xs) with (elemBy p x acc) | True = nubBy' acc p xs | False with (nubBy' (x::acc) p xs) | (_ ** tail) = (_ ** x::tail) -nub : Eq a => Vect a n -> (p ** Vect a p) +nub : Eq a => Vect n a -> (p ** Vect p a) nub = nubBy (==) -------------------------------------------------------------------------------- @@ -275,31 +280,31 @@ -- Predicates -------------------------------------------------------------------------------- -isPrefixOfBy : (a -> a -> Bool) -> Vect a m -> Vect a n -> Bool +isPrefixOfBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool isPrefixOfBy p [] right = True isPrefixOfBy p left [] = False isPrefixOfBy p (x::xs) (y::ys) with (p x y) | True = isPrefixOfBy p xs ys | False = False -isPrefixOf : Eq a => Vect a m -> Vect a n -> Bool +isPrefixOf : Eq a => Vect m a -> Vect n a -> Bool isPrefixOf = isPrefixOfBy (==) -isSuffixOfBy : (a -> a -> Bool) -> Vect a m -> Vect a n -> Bool +isSuffixOfBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool isSuffixOfBy p left right = isPrefixOfBy p (reverse left) (reverse right) -isSuffixOf : Eq a => Vect a m -> Vect a n -> Bool +isSuffixOf : Eq a => Vect m a -> Vect n a -> Bool isSuffixOf = isSuffixOfBy (==) -------------------------------------------------------------------------------- -- Conversions -------------------------------------------------------------------------------- -total maybeToVect : Maybe a -> (p ** Vect a p) +total maybeToVect : Maybe a -> (p ** Vect p a) maybeToVect Nothing = (_ ** []) maybeToVect (Just j) = (_ ** [j]) -total vectToMaybe : Vect a n -> Maybe a +total vectToMaybe : Vect n a -> Maybe a vectToMaybe [] = Nothing vectToMaybe (x::xs) = Just x @@ -307,19 +312,19 @@ -- Misc -------------------------------------------------------------------------------- -catMaybes : Vect (Maybe a) n -> (p ** Vect a p) +catMaybes : Vect n (Maybe a) -> (p ** Vect p a) catMaybes [] = (_ ** []) catMaybes (Nothing::xs) = catMaybes xs catMaybes ((Just j)::xs) with (catMaybes xs) | (_ ** tail) = (_ ** j::tail) -range : Vect (Fin n) n -range = - reverse range_ - where - range_ : Vect (Fin n) n - range_ {n=O} = Nil - range_ {n=(S _)} = last :: map weaken range_ +diag : Vect n (Vect n a) -> Vect n a +diag [] = [] +diag ((x::xs)::xss) = x :: diag (map tail xss) + +range : Vect n (Fin n) +range {n=Z} = [] +range {n=S _} = fZ :: map fS range -------------------------------------------------------------------------------- -- Proofs diff --git a/lib/System/Concurrency/Process.idr b/lib/System/Concurrency/Process.idr --- a/lib/System/Concurrency/Process.idr +++ b/lib/System/Concurrency/Process.idr @@ -16,14 +16,13 @@ lift : IO a -> Process msg a instance Functor (Process msg) where - fmap f (lift a) = lift (fmap f a) + map f (lift a) = lift (map f a) instance Applicative (Process msg) where pure = lift . return (lift f) <$> (lift a) = lift (f <$> a) instance Monad (Process msg) where - return = lift . return (lift io) >>= k = lift (do x <- io case k x of lift v => v) diff --git a/lib/Uninhabited.idr b/lib/Uninhabited.idr --- a/lib/Uninhabited.idr +++ b/lib/Uninhabited.idr @@ -3,10 +3,10 @@ class Uninhabited t where total uninhabited : t -> _|_ -instance Uninhabited (Fin O) where - uninhabited fO impossible +instance Uninhabited (Fin Z) where + uninhabited fZ impossible uninhabited (fS f) impossible -instance Uninhabited (O = S n) where +instance Uninhabited (Z = S n) where uninhabited refl impossible diff --git a/lib/base.ipkg b/lib/base.ipkg --- a/lib/base.ipkg +++ b/lib/base.ipkg @@ -22,10 +22,10 @@ Language.Reflection, Language.Reflection.Utils, Data.Morphisms, --- Data.Bits, Data.Mod2, - Data.Z, Data.Sign, + Data.Bits, Data.Mod2, + Data.ZZ, Data.Sign, Data.SortedMap, Data.SortedSet, Data.BoundedList, - Data.Vect.Quantifiers, + Data.Vect, Data.HVect, Data.Vect.Quantifiers, Control.Monad.Identity, Control.Monad.State, Control.Category, Control.Arrow, diff --git a/llvm/Makefile b/llvm/Makefile new file mode 100644 --- /dev/null +++ b/llvm/Makefile @@ -0,0 +1,24 @@ +include ../config.mk + +CFLAGS=-c -O2 -Wall -Wextra -fPIC -Wno-unused-parameter +SOURCES=defs.c +OBJECTS=$(SOURCES:.c=.o) +LIB=libidris_rts.a + +all: $(SOURCES) $(LIB) + +$(LIB): $(OBJECTS) + ar r $@ $(OBJECTS) + ranlib $@ + +.c.o: + $(CC) $(CFLAGS) $< -o $@ + +install: $(LIB) .PHONY + mkdir -p $(TARGET) + install $(LIB) $(TARGET) + +clean: .PHONY + rm -f $(OBJECTS) $(LIB) + +.PHONY: diff --git a/llvm/defs.c b/llvm/defs.c new file mode 100644 --- /dev/null +++ b/llvm/defs.c @@ -0,0 +1,160 @@ +#include +#include +#include +#include +#include + +void putStr(const char *str) { + fputs(str, stdout); +} + +void mpz_init_set_ull(mpz_t n, unsigned long long ull) +{ + mpz_init_set_ui(n, (unsigned int)(ull >> 32)); /* n = (unsigned int)(ull >> 32) */ + mpz_mul_2exp(n, n, 32); /* n <<= 32 */ + mpz_add_ui(n, n, (unsigned int)ull); /* n += (unsigned int)ull */ +} + +void mpz_init_set_sll(mpz_t n, long long sll) +{ + mpz_init_set_si(n, (int)(sll >> 32)); /* n = (int)sll >> 32 */ + mpz_mul_2exp(n, n, 32 ); /* n <<= 32 */ + mpz_add_ui(n, n, (unsigned int)sll); /* n += (unsigned int)sll */ +} + +void mpz_set_sll(mpz_t n, long long sll) +{ + mpz_set_si(n, (int)(sll >> 32)); /* n = (int)sll >> 32 */ + mpz_mul_2exp(n, n, 32 ); /* n <<= 32 */ + mpz_add_ui(n, n, (unsigned int)sll); /* n += (unsigned int)sll */ +} + +unsigned long long mpz_get_ull(mpz_t n) +{ + unsigned int lo, hi; + mpz_t tmp; + + mpz_init( tmp ); + mpz_mod_2exp( tmp, n, 64 ); /* tmp = (lower 64 bits of n) */ + + lo = mpz_get_ui( tmp ); /* lo = tmp & 0xffffffff */ + mpz_div_2exp( tmp, tmp, 32 ); /* tmp >>= 32 */ + hi = mpz_get_ui( tmp ); /* hi = tmp & 0xffffffff */ + + mpz_clear( tmp ); + + return (((unsigned long long)hi) << 32) + lo; +} + +char *__idris_strCons(char c, char *s) { + size_t len = strlen(s); + char *result = GC_malloc_atomic(len+2); + result[0] = c; + memcpy(result+1, s, len); + result[len+1] = 0; + return result; +} + +#define BUFSIZE 256 +char *__idris_readStr(FILE* h) { +// Modified from 'safe-fgets.c' in the gdb distribution. +// (see http://www.gnu.org/software/gdb/current/) + char *line_ptr; + char* line_buf = (char *) GC_malloc (BUFSIZE); + int line_buf_size = BUFSIZE; + + /* points to last byte */ + line_ptr = line_buf + line_buf_size - 1; + + /* so we can see if fgets put a 0 there */ + *line_ptr = 1; + if (fgets (line_buf, line_buf_size, h) == 0) + return ""; + + /* we filled the buffer? */ + while (line_ptr[0] == 0 && line_ptr[-1] != '\n') + { + /* Make the buffer bigger and read more of the line */ + line_buf_size += BUFSIZE; + line_buf = (char *) GC_realloc (line_buf, line_buf_size); + + /* points to last byte again */ + line_ptr = line_buf + line_buf_size - 1; + /* so we can see if fgets put a 0 there */ + *line_ptr = 1; + + if (fgets (line_buf + line_buf_size - BUFSIZE - 1, BUFSIZE + 1, h) == 0) + return ""; + } + + return line_buf; +} + +void* fileOpen(char* name, char* mode) { + FILE* f = fopen(name, mode); + return (void*)f; +} + +void fileClose(void* h) { + FILE* f = (FILE*)h; + fclose(f); +} + +int fileEOF(void* h) { + FILE* f = (FILE*)h; + return feof(f); +} + +int fileError(void* h) { + FILE* f = (FILE*)h; + return ferror(f); +} + +void fputStr(void* h, char* str) { + FILE* f = (FILE*)h; + fputs(str, f); +} + +int isNull(void* ptr) { + return ptr==NULL; +} + +void idris_memset(void* ptr, size_t offset, uint8_t c, size_t size) { + memset(((uint8_t*)ptr) + offset, c, size); +} + +uint8_t idris_peek(void* ptr, size_t offset) { + return *(((uint8_t*)ptr) + offset); +} + +void idris_poke(void* ptr, size_t offset, uint8_t data) { + *(((uint8_t*)ptr) + offset) = data; +} + +void idris_memmove(void* dest, void* src, size_t dest_offset, size_t src_offset, size_t size) { + memmove(dest + dest_offset, src + src_offset, size); +} + +void *__idris_gmpMalloc(size_t size) { + return GC_malloc(size); +} + +void *__idris_gmpRealloc(void *ptr, size_t oldSize, size_t size) { + return GC_realloc(ptr, size); +} + +void __idris_gmpFree(void *ptr, size_t oldSize) { + GC_free(ptr); +} + +char *__idris_strRev(const char *s) { + int x = strlen(s); + int y = 0; + char *t = GC_malloc(x+1); + + t[x] = '\0'; + while(x>0) { + t[y++] = s[--x]; + } + return t; +} diff --git a/rts/idris_bitstring.h b/rts/idris_bitstring.h --- a/rts/idris_bitstring.h +++ b/rts/idris_bitstring.h @@ -32,7 +32,7 @@ VAL idris_b8And(VM *vm, VAL a, VAL b); VAL idris_b8Or(VM *vm, VAL a, VAL b); VAL idris_b8Neg(VM *vm, VAL a); -VAL idris_b8XOr(VM *vm, VAL a, VAL b); +VAL idris_b8Xor(VM *vm, VAL a, VAL b); VAL idris_b8Shl(VM *vm, VAL a, VAL b); VAL idris_b8LShr(VM *vm, VAL a, VAL b); VAL idris_b8AShr(VM *vm, VAL a, VAL b); @@ -64,7 +64,7 @@ VAL idris_b16And(VM *vm, VAL a, VAL b); VAL idris_b16Or(VM *vm, VAL a, VAL b); VAL idris_b16Neg(VM *vm, VAL a); -VAL idris_b16XOr(VM *vm, VAL a, VAL b); +VAL idris_b16Xor(VM *vm, VAL a, VAL b); VAL idris_b16Shl(VM *vm, VAL a, VAL b); VAL idris_b16LShr(VM *vm, VAL a, VAL b); VAL idris_b16AShr(VM *vm, VAL a, VAL b); @@ -91,7 +91,7 @@ VAL idris_b32And(VM *vm, VAL a, VAL b); VAL idris_b32Or(VM *vm, VAL a, VAL b); VAL idris_b32Neg(VM *vm, VAL a); -VAL idris_b32XOr(VM *vm, VAL a, VAL b); +VAL idris_b32Xor(VM *vm, VAL a, VAL b); VAL idris_b32Shl(VM *vm, VAL a, VAL b); VAL idris_b32LShr(VM *vm, VAL a, VAL b); VAL idris_b32AShr(VM *vm, VAL a, VAL b); @@ -117,7 +117,7 @@ VAL idris_b64And(VM *vm, VAL a, VAL b); VAL idris_b64Or(VM *vm, VAL a, VAL b); VAL idris_b64Neg(VM *vm, VAL a); -VAL idris_b64XOr(VM *vm, VAL a, VAL b); +VAL idris_b64Xor(VM *vm, VAL a, VAL b); VAL idris_b64Shl(VM *vm, VAL a, VAL b); VAL idris_b64LShr(VM *vm, VAL a, VAL b); VAL idris_b64AShr(VM *vm, VAL a, VAL b); diff --git a/rts/idris_gmp.c b/rts/idris_gmp.c --- a/rts/idris_gmp.c +++ b/rts/idris_gmp.c @@ -308,6 +308,30 @@ } } +VAL idris_castBigFloat(VM* vm, VAL i) { + if (ISINT(i)) { + return MKFLOAT(vm, GETINT(i)); + } else { + return MKFLOAT(vm, mpz_get_d(GETMPZ(i))); + } +} + +VAL idris_castFloatBig(VM* vm, VAL f) { + double val = GETFLOAT(f); + + mpz_t* bigint; + VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*) + + sizeof(mpz_t), 0); + bigint = (mpz_t*)(((char*)cl) + sizeof(ClosureType) + sizeof(void*)); + + mpz_init_set_d(*bigint, val); + + SETTY(cl, BIGINT); + cl -> info.ptr = (void*)bigint; + + return cl; +} + VAL idris_castStrBig(VM* vm, VAL i) { return MKBIGC(vm, GETSTR(i)); } diff --git a/rts/idris_gmp.h b/rts/idris_gmp.h --- a/rts/idris_gmp.h +++ b/rts/idris_gmp.h @@ -24,6 +24,8 @@ VAL idris_castIntBig(VM* vm, VAL i); VAL idris_castBigInt(VM* vm, VAL i); +VAL idris_castFloatBig(VM* vm, VAL i); +VAL idris_castBigFloat(VM* vm, VAL i); VAL idris_castStrBig(VM* vm, VAL i); VAL idris_castBigStr(VM* vm, VAL i); diff --git a/rts/libidris_rts.a b/rts/libidris_rts.a deleted file mode 100644 Binary files a/rts/libidris_rts.a and /dev/null differ diff --git a/src/Core/CaseTree.hs b/src/Core/CaseTree.hs --- a/src/Core/CaseTree.hs +++ b/src/Core/CaseTree.hs @@ -64,6 +64,7 @@ instance TermSize SC where termsize n (Case n' as) = termsize n as + termsize n (ProjCase n' as) = termsize n as termsize n (STerm t) = termsize n t termsize n _ = 1 @@ -79,7 +80,7 @@ small :: Name -> [Name] -> SC -> Bool small n args t = let as = findAllUsedArgs t args in length as == length (nub as) && - termsize n t < 5 + termsize n t < 10 namesUsed :: SC -> [Name] namesUsed sc = nub $ nu' [] sc where @@ -227,17 +228,16 @@ toPat' (P (TCon t a) n _) args | tc = do args' <- mapM (\x -> toPat' x []) args return $ PCon n t args' - toPat' (Constant IType) [] | tc = return $ PCon (UN "Int") 1 [] - toPat' (Constant FlType) [] | tc = return $ PCon (UN "Float") 2 [] - toPat' (Constant ChType) [] | tc = return $ PCon (UN "Char") 3 [] + toPat' (Constant (AType (ATInt ITNative))) [] + | tc = return $ PCon (UN "Int") 1 [] + toPat' (Constant (AType ATFloat)) [] | tc = return $ PCon (UN "Float") 2 [] + toPat' (Constant (AType (ATInt ITChar))) [] | tc = return $ PCon (UN "Char") 3 [] toPat' (Constant StrType) [] | tc = return $ PCon (UN "String") 4 [] toPat' (Constant PtrType) [] | tc = return $ PCon (UN "Ptr") 5 [] - toPat' (Constant BIType) [] | tc = return $ PCon (UN "Integer") 6 [] - toPat' (Constant B8Type) [] | tc = return $ PCon (UN "Bits8") 7 [] - toPat' (Constant B16Type) [] | tc = return $ PCon (UN "Bits16") 8 [] - toPat' (Constant B32Type) [] | tc = return $ PCon (UN "Bits32") 9 [] - toPat' (Constant B64Type) [] | tc = return $ PCon (UN "Bits64") 10 [] - + toPat' (Constant (AType (ATInt ITBig))) [] + | tc = return $ PCon (UN "Integer") 6 [] + toPat' (Constant (AType (ATInt (ITFixed n)))) [] + | tc = return $ PCon (UN (fixedN n)) (7 + fromEnum n) [] -- 7-10 inclusive toPat' (P Bound n _) [] = do ns <- get if n `elem` ns then return PAny @@ -246,6 +246,11 @@ toPat' (App f a) args = toPat' f (a : args) toPat' (Constant x) [] = return $ PConst x toPat' _ _ = return PAny + + fixedN IT8 = "Bits8" + fixedN IT16 = "Bits16" + fixedN IT32 = "Bits32" + fixedN IT64 = "Bits64" data Partition = Cons [Clause] diff --git a/src/Core/CoreParser.hs b/src/Core/CoreParser.hs --- a/src/Core/CoreParser.hs +++ b/src/Core/CoreParser.hs @@ -36,7 +36,8 @@ "using", "namespace", "class", "instance", "public", "private", "abstract", "implicit", "Int", "Integer", "Float", "Char", "String", "Ptr", - "Bits8", "Bits16", "Bits32", "Bits64"] + "Bits8", "Bits16", "Bits32", "Bits64", + "Bits8x16", "Bits16x8", "Bits32x4", "Bits64x2"] } -- | The characters allowed in operator names @@ -57,13 +58,16 @@ where simpleSpace = skipMany1 (satisfy isSpace) - oneLineComment = do try (do string ("--") - satisfy (\x -> x /= '|' && x /= '^')) - skipMany (satisfy (/= '\n')) - return () - multiLineComment = do try (do string "{-" - satisfy (\x -> x /= '|' && x /= '^')) - inCommentMulti + oneLineComment = + try (void $ string "--\n") <|> + do try (do string "--" + satisfy (\x -> x /= '|' && x /= '^')) + skipMany (satisfy (/= '\n')) + multiLineComment = + try (void $ string "{--}") <|> + do try (do string "{-" + satisfy (\x -> x /= '|' && x /= '^')) + inCommentMulti inCommentMulti = do{ try (string "-}") ; return () } diff --git a/src/Core/Elaborate.hs b/src/Core/Elaborate.hs --- a/src/Core/Elaborate.hs +++ b/src/Core/Elaborate.hs @@ -91,6 +91,10 @@ getAux = do ES (ps, a) _ _ <- get return a +unifyLog :: Bool -> Elab' aux () +unifyLog log = do ES (ps, a) l p <- get + put (ES (ps { unifylog = log }, a) l p) + processTactic' t = do ES (p, a) logs prev <- get (p', log) <- lift $ processTactic t p put (ES (p', a) (logs ++ log) prev) @@ -235,6 +239,9 @@ fill :: Raw -> Elab' aux () fill t = processTactic' (Fill t) +match_fill :: Raw -> Elab' aux () +match_fill t = processTactic' (MatchFill t) + prep_fill :: Name -> [Name] -> Elab' aux () prep_fill n ns = processTactic' (PrepFill n ns) @@ -256,6 +263,9 @@ compute :: Elab' aux () compute = processTactic' Compute +simplify :: Elab' aux () +simplify = processTactic' Simplify + hnf_compute :: Elab' aux () hnf_compute = processTactic' HNF_Compute @@ -277,9 +287,15 @@ letbind :: Name -> Raw -> Raw -> Elab' aux () letbind n t v = processTactic' (LetBind n t v) +expandLet :: Name -> Term -> Elab' aux () +expandLet n v = processTactic' (ExpandLet n v) + rewrite :: Raw -> Elab' aux () rewrite tm = processTactic' (Rewrite tm) +equiv :: Raw -> Elab' aux () +equiv tm = processTactic' (Equiv tm) + patvar :: Name -> Elab' aux () patvar n = do env <- get_env if (n `elem` map fst env) then do apply (Var n) []; solve @@ -375,10 +391,16 @@ rebind hs (App f a) = App (rebind hs f) (rebind hs a) rebind hs t = t -apply :: Raw -> [(Bool, Int)] -> Elab' aux [Name] -apply fn imps = +apply, match_apply :: Raw -> [(Bool, Int)] -> Elab' aux [Name] +apply = apply' fill +match_apply = apply' match_fill + +apply' :: (Raw -> Elab' aux ()) -> Raw -> [(Bool, Int)] -> Elab' aux [Name] +apply' fillt fn imps = do args <- prepare_apply fn (map fst imps) - fill (raw_apply fn (map Var args)) + env <- get_env + g <- goal + fillt (raw_apply fn (map Var args)) -- _Don't_ solve the arguments we're specifying by hand. -- (remove from unified list before calling end_unify) -- HMMM: Actually, if we get it wrong, the typechecker will complain! @@ -473,24 +495,25 @@ mkMN (NS n ns) = NS (mkMN n) ns -- If the goal is not a Pi-type, invent some names and make it a pi type -checkPiGoal :: Elab' aux () -checkPiGoal = do g <- goal +checkPiGoal :: Name -> Elab' aux () +checkPiGoal n + = do g <- goal case g of Bind _ (Pi _) _ -> return () - _ -> do a <- unique_hole (MN 0 "argTy") - b <- unique_hole (MN 0 "retTy") - f <- unique_hole (MN 0 "f") + _ -> do a <- unique_hole (MN 0 "pargTy") + b <- unique_hole (MN 0 "pretTy") + f <- unique_hole (MN 0 "pf") claim a RType claim b RType - claim f (RBind (MN 0 "aX") (Pi (Var a)) (Var b)) + claim f (RBind n (Pi (Var a)) (Var b)) movelast a movelast b fill (Var f) solve focus f -simple_app :: Elab' aux () -> Elab' aux () -> Elab' aux () -simple_app fun arg = +simple_app :: Elab' aux () -> Elab' aux () -> String -> Elab' aux () +simple_app fun arg appstr = do a <- unique_hole (MN 0 "argTy") b <- unique_hole (MN 0 "retTy") f <- unique_hole (MN 0 "f") @@ -502,24 +525,21 @@ start_unify s claim s (Var a) prep_fill f [s] - -- try elaborating in both orders, since we might learn something useful - -- either way --- try (do focus s; arg --- focus f; fun) --- (do focus f; fun --- focus s; arg) focus f; fun focus s; arg tm <- get_term ps <- get_probs complete_fill hs <- get_holes - -- We don't need a and b in the hole queue any more since they were just for - -- checking f, so discard them if they are still there. If they haven't been solved, - -- regret will fail - when (a `elem` hs) $ do focus a; regret - when (b `elem` hs) $ do focus b; regret + env <- get_env + -- We don't need a and b in the hole queue any more since they were + -- just for checking f, so discard them if they are still there. + -- If they haven't been solved, regret will fail + when (a `elem` hs) $ do focus a; regretWith (CantInferType appstr) + when (b `elem` hs) $ do focus b; regretWith (CantInferType appstr) end_unify + where regretWith err = try regret + (lift $ tfail err) -- Abstract over an argument of unknown type, giving a name for the hole -- which we'll fill with the argument type too. diff --git a/src/Core/Evaluate.hs b/src/Core/Evaluate.hs --- a/src/Core/Evaluate.hs +++ b/src/Core/Evaluate.hs @@ -19,20 +19,24 @@ import Core.TT import Core.CaseTree -data EvalState = ES { limited :: [(Name, Int)] } +data EvalState = ES { limited :: [(Name, Int)], + nexthole :: Int } type Eval a = State EvalState a data EvalOpt = Spec | HNF | Simplify Bool | AtREPL deriving (Show, Eq) -initEval = ES [] +initEval = ES [] 0 -- VALUES (as HOAS) --------------------------------------------------------- -- | A HOAS representation of values data Value = VP NameType Name Value | VV Int - | VBind Name (Binder Value) (Value -> Eval Value) + -- True for Bool indicates safe to reduce + | VBind Bool Name (Binder Value) (Value -> Eval Value) + -- For frozen let bindings when simplifying + | VBLet Int Name Value Value Value | VApp Value Value | VType UExp | VErased @@ -83,7 +87,9 @@ specialise :: Context -> Env -> [(Name, Int)] -> TT Name -> TT Name specialise ctxt env limits t - = evalState (do val <- eval False ctxt limits (map finalEntry env) (finalise t) [] + = evalState (do val <- eval False ctxt [] + (map finalEntry env) (finalise t) + [Spec] quote 0 val) (initEval { limited = limits }) -- | Like normalise, but we only reduce functions that are marked as okay to @@ -121,18 +127,38 @@ unbindEnv [] tm = tm unbindEnv (_:bs) (Bind n b sc) = unbindEnv bs sc -usable :: Bool -> Name -> [(Name, Int)] -> (Bool, [(Name, Int)]) -usable _ _ ns@((MN 0 "STOP", _) : _) = (False, ns) -usable True (UN "io_bind") ns = (False, ns) -usable s n [] = (True, []) -usable s n ns = case lookup n ns of - Just 0 -> (False, ns) - Just i -> (True, (n, abs (i-1)) : filter (\ (n', _) -> n/=n') ns) - _ -> if s then (True, (n, 0) : filter (\ (n', _) -> n/=n') ns) - else (True, (n, 100) : filter (\ (n', _) -> n/=n') ns) +usable :: Bool -> Bool -> Name -> [(Name, Int)] -> Eval (Bool, [(Name, Int)]) +usable _ _ _ ns@((MN 0 "STOP", _) : _) = return (False, ns) +usable True _ (UN "io_bind") ns = return (False, ns) +usable simpl False n [] = return (True, []) +usable simpl True n ns + = do ES ls num <- get + case lookup n ls of + Just 0 -> return (False, ns) + Just i -> return (True, ns) + _ -> return (False, ns) +usable simpl False n ns + = case lookup n ns of + Just 0 -> return (False, ns) + Just i -> return $ (True, (n, abs (i-1)) : filter (\ (n', _) -> n/=n') ns) + _ -> if simpl then return $ (True, (n, 0) : filter (\ (n', _) -> n/=n') ns) + else return $ (True, (n, 100) : filter (\ (n', _) -> n/=n') ns) + +deduct :: Name -> Eval () +deduct n = do ES ls num <- get + case lookup n ls of + Just i -> do put $ ES ((n, (i-1)) : + filter (\ (n', _) -> n/=n') ls) num + _ -> return () + -- | Evaluate in a context of locally named things (i.e. not de Bruijn indexed, -- such as we might have during construction of a proof) + +-- The (Name, Int) pair in the arguments is the maximum depth of unfolding of +-- a name. The corresponding pair in the state is the maximum number of +-- unfoldings overall. + eval :: Bool -> Context -> [(Name, Int)] -> Env -> TT Name -> [EvalOpt] -> Eval Value eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where @@ -149,45 +175,54 @@ | Just (Let t v) <- lookup n genv = ev ntimes stk top env v ev ntimes_in stk top env (P Ref n ty) | not top && hnf = liftM (VP Ref n) (ev ntimes stk top env ty) - | (True, ntimes) <- usable simpl n ntimes_in - = do let val = lookupDefAcc n atRepl ctxt - case val of - [(Function _ tm, Public)] -> - ev ntimes (n:stk) True env tm - [(TyDecl nt ty, _)] -> do vty <- ev ntimes stk True env ty - return $ VP nt n vty - [(CaseOp inl inr _ _ _ [] tree _ _, acc)] - | acc == Public || simpl -> -- unoptimised version - if canSimplify inl inr n stk - then liftM (VP Ref n) (ev ntimes stk top env ty) - else do c <- evCase ntimes (n:stk) top env [] [] tree - case c of - (Nothing, _) -> liftM (VP Ref n) (ev ntimes stk top env ty) - (Just v, _) -> return v - _ -> liftM (VP Ref n) (ev ntimes stk top env ty) - ev ntimes stk top env (P nt n ty) = liftM (VP nt n) (ev ntimes stk top env ty) - ev ntimes stk top env (V i) | i < length env = return $ env !! i + | otherwise + = do (u, ntimes) <- usable simpl spec n ntimes_in + if u then + do let val = lookupDefAcc n atRepl ctxt + case val of + [(Function _ tm, Public)] -> + ev ntimes (n:stk) True env tm + [(TyDecl nt ty, _)] -> do vty <- ev ntimes stk True env ty + return $ VP nt n vty + [(CaseOp inl inr _ _ _ [] tree _ _, acc)] + | acc == Public || simpl -> -- unoptimised version + if canSimplify inl inr n stk + then liftM (VP Ref n) (ev ntimes stk top env ty) + else do c <- evCase ntimes n (n:stk) top env [] [] tree + case c of + (Nothing, _) -> liftM (VP Ref n) (ev ntimes stk top env ty) + (Just v, _) -> return v + _ -> liftM (VP Ref n) (ev ntimes stk top env ty) + else liftM (VP Ref n) (ev ntimes stk top env ty) + ev ntimes stk top env (P nt n ty) + = liftM (VP nt n) (ev ntimes stk top env ty) + ev ntimes stk top env (V i) + | i < length env && i >= 0 = return $ env !! i | otherwise = return $ VV i ev ntimes stk top env (Bind n (Let t v) sc) --- | not simpl || vinstances 0 sc < 2 + | not simpl -- - || vinstances 0 sc < 2 = do v' <- ev ntimes stk top env v --(finalise v) sc' <- ev ntimes stk top (v' : env) sc wknV (-1) sc' -{- | otherwise -- put this back when the Bind works properly + | otherwise = do t' <- ev ntimes stk top env t v' <- ev ntimes stk top env v --(finalise v) -- use Tmp as a placeholder, then make it a variable reference -- again when evaluation finished - sc' <- ev ntimes stk top (v' : env) sc - return $ VBind n (Let t' v') (\x -> return sc') -} + hs <- get + let vd = nexthole hs + put (hs { nexthole = vd + 1 }) + sc' <- ev ntimes stk top (VP Bound (MN vd "vlet") VErased : env) sc + return $ VBLet vd n t' v' sc' ev ntimes stk top env (Bind n (NLet t v) sc) = do t' <- ev ntimes stk top env (finalise t) v' <- ev ntimes stk top env (finalise v) sc' <- ev ntimes stk top (v' : env) sc - return $ VBind n (Let t' v') (\x -> return sc') + return $ VBind True n (Let t' v') (\x -> return sc') ev ntimes stk top env (Bind n b sc) = do b' <- vbind env b - return $ VBind n b' (\x -> ev ntimes stk False (x:env) sc) + return $ VBind (not simpl || vinstances 0 sc < 2) + n b' (\x -> ev ntimes stk False (x:env) sc) where vbind env t | simpl = fmapMB (\tm -> ev ((MN 0 "STOP", 0) : ntimes) @@ -209,37 +244,41 @@ evApply ntimes stk top env (a:args) f evApply ntimes stk top env args f = apply ntimes stk top env f args - apply ntimes stk top env (VBind n (Lam t) sc) (a:as) - = do a' <- sc a - app <- apply ntimes stk top env a' as - wknV (-1) app + apply ntimes stk top env (VBind True n (Lam t) sc) (a:as) + = do a' <- sc a + app <- apply ntimes stk top env a' as + wknV (-1) app -- apply ntimes stk False env f args -- | spec = specApply ntimes stk env f args apply ntimes_in stk top env f@(VP Ref n ty) args | not top && hnf = case args of [] -> return f _ -> return $ unload env f args - | (True, ntimes) <- usable simpl n ntimes_in - = traceWhen traceon (show stk) $ - do let val = lookupDefAcc n atRepl ctxt - case val of - [(CaseOp inl inr _ _ _ ns tree _ _, acc)] - | acc == Public -> -- unoptimised version - if canSimplify inl inr n stk - then return $ unload env (VP Ref n ty) args - else do c <- evCase ntimes (n:stk) top env ns args tree - case c of - (Nothing, _) -> return $ unload env (VP Ref n ty) args - (Just v, rest) -> evApply ntimes stk top env rest v - [(Operator _ i op, _)] -> - if (i <= length args) - then case op (take i args) of - Nothing -> return $ unload env (VP Ref n ty) args - Just v -> evApply ntimes stk top env (drop i args) v - else return $ unload env (VP Ref n ty) args - _ -> case args of - [] -> return f - _ -> return $ unload env f args + | otherwise + = do (u, ntimes) <- usable simpl spec n ntimes_in + if u then + do let val = lookupDefAcc n atRepl ctxt + case val of + [(CaseOp inl inr _ _ _ ns tree _ _, acc)] + | acc == Public -> -- unoptimised version + if canSimplify inl inr n stk + then return $ unload env (VP Ref n ty) args + else do c <- evCase ntimes n (n:stk) top env ns args tree + case c of + (Nothing, _) -> return $ unload env (VP Ref n ty) args + (Just v, rest) -> evApply ntimes stk top env rest v + [(Operator _ i op, _)] -> + if (i <= length args) + then case op (take i args) of + Nothing -> return $ unload env (VP Ref n ty) args + Just v -> evApply ntimes stk top env (drop i args) v + else return $ unload env (VP Ref n ty) args + _ -> case args of + [] -> return f + _ -> return $ unload env f args + else case args of + (a : as) -> return $ unload env f (a:as) + [] -> return f apply ntimes stk top env f (a:as) = return $ unload env f (a:as) apply ntimes stk top env f [] = return f @@ -255,10 +294,11 @@ unload env f [] = f unload env f (a:as) = unload env (VApp f a) as - evCase ntimes stk top env ns args tree + evCase ntimes n stk top env ns args tree | length ns <= length args = do let args' = take (length ns) args let rest = drop (length ns) args + when spec $ deduct n -- successful, so deduct usages t <- evTree ntimes stk top env (zipWith (\n t -> (n, t)) ns args') tree return (t, rest) @@ -320,26 +360,30 @@ findConst c [] = Nothing findConst c (ConstCase c' v : xs) | c == c' = Just v - findConst IType (ConCase n 1 [] v : xs) = Just v - findConst FlType (ConCase n 2 [] v : xs) = Just v - findConst ChType (ConCase n 3 [] v : xs) = Just v + findConst (AType (ATInt ITNative)) (ConCase n 1 [] v : xs) = Just v + findConst (AType ATFloat) (ConCase n 2 [] v : xs) = Just v + findConst (AType (ATInt ITChar)) (ConCase n 3 [] v : xs) = Just v findConst StrType (ConCase n 4 [] v : xs) = Just v - findConst PtrType (ConCase n 5 [] v : xs) = Just v + findConst PtrType (ConCase n 5 [] v : xs) = Just v + findConst (AType (ATInt ITBig)) (ConCase n 6 [] v : xs) = Just v + findConst (AType (ATInt (ITFixed ity))) (ConCase n tag [] v : xs) + | tag == 7 + fromEnum ity = Just v + findConst (AType (ATInt (ITVec ity count))) (ConCase n tag [] v : xs) + | tag == (fromEnum ity + 1) * 1000 + count = Just v findConst c (_ : xs) = findConst c xs getValArgs tm = getValArgs' tm [] getValArgs' (VApp f a) as = getValArgs' f (a:as) getValArgs' f as = (f, as) -tmpToV i (VTmp 0) = return $ VV i -tmpToV i (VP nt n v) = liftM (VP nt n) (tmpToV i v) - -tmpToV i (VBind n b sc) = do b' <- fmapMB (tmpToV i) b - let sc' = \x -> do x' <- sc x - tmpToV (i + 1) x' - return (VBind n b' sc') -tmpToV i (VApp f a) = liftM2 VApp (tmpToV i f) (tmpToV i a) -tmpToV i x = return x +-- tmpToV i vd (VLetHole j) | vd == j = return $ VV i +-- tmpToV i vd (VP nt n v) = liftM (VP nt n) (tmpToV i vd v) +-- tmpToV i vd (VBind n b sc) = do b' <- fmapMB (tmpToV i vd) b +-- let sc' = \x -> do x' <- sc x +-- tmpToV (i + 1) vd x' +-- return (VBind n b' sc') +-- tmpToV i vd (VApp f a) = liftM2 VApp (tmpToV i vd f) (tmpToV i vd a) +-- tmpToV i vd x = return x class Quote a where quote :: Int -> a -> Eval (TT Name) @@ -347,10 +391,16 @@ instance Quote Value where quote i (VP nt n v) = liftM (P nt n) (quote i v) quote i (VV x) = return $ V x - quote i (VBind n b sc) = do sc' <- sc (VTmp i) - b' <- quoteB b - liftM (Bind n b') (quote (i+1) sc') + quote i (VBind _ n b sc) = do sc' <- sc (VTmp i) + b' <- quoteB b + liftM (Bind n b') (quote (i+1) sc') where quoteB t = fmapMB (quote i) t + quote i (VBLet vd n t v sc) + = do sc' <- quote i sc + t' <- quote i t + v' <- quote i v + let sc'' = pToV (MN vd "vlet") (addBinder sc') + return (Bind n (Let t' v') sc'') quote i (VApp f a) = liftM2 App (quote i f) (quote i a) quote i (VType u) = return $ TType u quote i VErased = return $ Erased @@ -376,9 +426,9 @@ wknV :: Int -> Value -> Eval Value wknV i (VV x) = return $ VV (x + i) -wknV i (VBind n b sc) = do b' <- fmapMB (wknV i) b - return $ VBind n b' (\x -> do x' <- sc x - wknV i x') +wknV i (VBind red n b sc) = do b' <- fmapMB (wknV i) b + return $ VBind red n b' (\x -> do x' <- sc x + wknV i x') wknV i (VApp f a) = liftM2 VApp (wknV i f) (wknV i a) wknV i t = return t @@ -503,16 +553,16 @@ findConst c [] = Nothing findConst c (ConstCase c' v : xs) | c == c' = Just v - findConst IType (ConCase n 1 [] v : xs) = Just v - findConst FlType (ConCase n 2 [] v : xs) = Just v - findConst ChType (ConCase n 3 [] v : xs) = Just v + findConst (AType (ATInt ITNative)) (ConCase n 1 [] v : xs) = Just v + findConst (AType ATFloat) (ConCase n 2 [] v : xs) = Just v + findConst (AType (ATInt ITChar)) (ConCase n 3 [] v : xs) = Just v findConst StrType (ConCase n 4 [] v : xs) = Just v findConst PtrType (ConCase n 5 [] v : xs) = Just v - findConst BIType (ConCase n 6 [] v : xs) = Just v - findConst B8Type (ConCase n 7 [] v : xs) = Just v - findConst B16Type (ConCase n 8 [] v : xs) = Just v - findConst B32Type (ConCase n 9 [] v : xs) = Just v - findConst B64Type (ConCase n 10 [] v : xs) = Just v + findConst (AType (ATInt ITBig)) (ConCase n 6 [] v : xs) = Just v + findConst (AType (ATInt (ITFixed ity))) (ConCase n tag [] v : xs) + | tag == 7 + fromEnum ity = Just v + findConst (AType (ATInt (ITVec ity count))) (ConCase n tag [] v : xs) + | tag == (fromEnum ity + 1) * 1000 + count = Just v findConst c (_ : xs) = findConst c xs getValArgs (HApp t env args) = (t, env, args) @@ -752,11 +802,12 @@ [(CaseOp inl inr ty [] ps args sc args' sc', acc, tot)] -> ctxt -- nothing to simplify (or already done...) [(CaseOp inl inr ty ps_in ps args sc args' sc', acc, tot)] -> - let pdef = map debind $ map simpl ps_in in + let ps_in' = map simpl ps_in + pdef = map debind ps_in' in case simpleCase False True CompileTime (FC "" 0) pdef of OK (CaseDef args sc _) -> addDef n (CaseOp inl inr - ty ps_in ps args sc args' sc', + ty ps_in' ps args sc args' sc', acc, tot) ctxt _ -> ctxt in uctxt { definitions = ctxt' } diff --git a/src/Core/Execute.hs b/src/Core/Execute.hs --- a/src/Core/Execute.hs +++ b/src/Core/Execute.hs @@ -3,10 +3,10 @@ import Idris.AbsSyntax import Idris.AbsSyntaxTree -import IRTS.Lang( IntTy(..) - , intTyToConst - , FType(..)) +import IRTS.Lang(FType(..)) +import Idris.Primitives(Prim(..), primitives) + import Core.TT import Core.Evaluate import Core.CaseTree @@ -32,6 +32,10 @@ import System.IO +readMay :: (Read a) => String -> Maybe a +readMay s = case reads s of + [(x, "")] -> Just x + _ -> Nothing data Lazy = Delayed ExecEnv Context Term | Forced ExecVal deriving Show @@ -274,6 +278,16 @@ Just r -> return (mkEApp r (drop (length argTs) xs)) | otherwise = return (mkEApp f args) +execApp' env ctxt c@(EP (DCon _ arity) n _) args = + do args' <- mapM tryForce (take arity args) + let restArgs = drop arity args + execApp' env ctxt (mkEApp c args') restArgs + +execApp' env ctxt c@(EP (TCon _ arity) n _) args = + do args' <- mapM tryForce (take arity args) + let restArgs = drop arity args + execApp' env ctxt (mkEApp c args') restArgs + execApp' env ctxt f@(EP _ n _) args = do let val = lookupDef n ctxt case val of @@ -294,89 +308,6 @@ do res <- execCase env ctxt ns sc args return $ fromMaybe (mkEApp f args) res thing -> return $ mkEApp f args - where getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal) - getOp (UN "prim__addInt") [EConstant (I i1), EConstant (I i2)] = - primRes I (i1 + i2) - getOp (UN "prim__andInt") [EConstant (I i1), EConstant (I i2)] = - primRes I (i1 .&. i2) - getOp (UN "prim__charToInt") [EConstant (Ch c)] = - primRes I (fromEnum c) - getOp (UN "prim__complInt") [EConstant (I i)] = - primRes I (complement i) - getOp (UN "prim__concat") [EConstant (Str s1), EConstant (Str s2)] = - primRes Str (s1 ++ s2) - getOp (UN "prim__divInt") [EConstant (I i1), EConstant (I i2)] = - primRes I (i1 `div` i2) - getOp (UN "prim__eqChar") [EConstant (Ch c1), EConstant (Ch c2)] = - primResBool (c1 == c2) - getOp (UN "prim__eqInt") [EConstant (I i1), EConstant (I i2)] = - primResBool (i1 == i2) - getOp (UN "prim__eqString") [EConstant (Str s1), EConstant (Str s2)] = - primResBool (s1 == s2) - getOp (UN "prim__gtChar") [EConstant (Ch i1), EConstant (Ch i2)] = - primResBool (i1 > i2) - getOp (UN "prim__gteChar") [EConstant (Ch i1), EConstant (Ch i2)] = - primResBool (i1 >= i2) - getOp (UN "prim__gtInt") [EConstant (I i1), EConstant (I i2)] = - primResBool (i1 > i2) - getOp (UN "prim__gteInt") [EConstant (I i1), EConstant (I i2)] = - primResBool (i1 >= i2) - getOp (UN "prim__intToFloat") [EConstant (I i)] = - primRes Fl (fromRational (toRational i)) - getOp (UN "prim__intToStr") [EConstant (I i)] = - primRes Str (show i) - getOp (UN "prim_lenString") [EConstant (Str s)] = - primRes I (length s) - getOp (UN "prim__ltChar") [EConstant (Ch i1), EConstant (Ch i2)] = - primResBool (i1 < i2) - getOp (UN "prim__lteChar") [EConstant (Ch i1), EConstant (Ch i2)] = - primResBool (i1 <= i2) - getOp (UN "prim__lteInt") [EConstant (I i1), EConstant (I i2)] = - primResBool (i1 <= i2) - getOp (UN "prim__ltInt") [EConstant (I i1), EConstant (I i2)] = - primResBool (i1 < i2) - getOp (UN "prim__modInt") [EConstant (I i1), EConstant (I i2)] = - primRes I (i1 `mod` i2) - getOp (UN "prim__mulBigInt") [EConstant (BI i1), EConstant (BI i2)] = - primRes BI (i1 * i2) - getOp (UN "prim__mulFloat") [EConstant (Fl i1), EConstant (Fl i2)] = - primRes Fl (i1 * i2) - getOp (UN "prim__mulInt") [EConstant (I i1), EConstant (I i2)] = - primRes I (i1 * i2) - getOp (UN "prim__orInt") [EConstant (I i1), EConstant (I i2)] = - primRes I (i1 .|. i2) - getOp (UN "prim__readString") [EP _ (UN "prim__stdin") _] = - Just $ do line <- execIO getLine - return (EConstant (Str line)) - getOp (UN "prim__readString") [EHandle h] = - Just $ do contents <- execIO $ hGetLine h - return (EConstant (Str contents)) - getOp (UN "prim__shLInt") [EConstant (I i1), EConstant (I i2)] = - primRes I (shiftL i1 i2) - getOp (UN "prim__shRInt") [EConstant (I i1), EConstant (I i2)] = - primRes I (shiftR i1 i2) - getOp (UN "prim__strCons") [EConstant (Ch c), EConstant (Str s)] = - primRes Str (c:s) - getOp (UN "prim__strHead") [EConstant (Str (c:s))] = - primRes Ch c - getOp (UN "prim__strRev") [EConstant (Str s)] = - primRes Str (reverse s) - getOp (UN "prim__strTail") [EConstant (Str (c:s))] = - primRes Str s - getOp (UN "prim__subFloat") [EConstant (Fl i1), EConstant (Fl i2)] = - primRes Fl (i1 - i2) - getOp (UN "prim__subInt") [EConstant (I i1), EConstant (I i2)] = - primRes I (i1 - i2) - getOp (UN "prim__xorInt") [EConstant (I i1), EConstant (I i2)] = - primRes I (i1 `xor` i2) - getOp n args = trace ("No prim " ++ show n ++ " for " ++ take 1000 (show args)) Nothing - - primRes :: (a -> Const) -> a -> Maybe (Exec ExecVal) - primRes constr = Just . return . EConstant . constr - - primResBool :: Bool -> Maybe (Exec ExecVal) - primResBool b = primRes I (if b then 1 else 0) - execApp' env ctxt bnd@(EBind n b body) (arg:args) = do ret <- body arg let (f', as) = unApplyV ret execApp' env ctxt f' (as ++ args) @@ -385,10 +316,33 @@ execApp' env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp' env ctxt f (args1 ++ args2) execApp' env ctxt f args = return (mkEApp f args) +-- | Look up primitive operations in the global table and transform them into ExecVal functions +getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal) +getOp (UN "prim__believe_me") [_, _, x] = Just (return x) +getOp (UN "prim__readString") [EP _ (UN "prim__stdin") _] = + Just $ do line <- execIO getLine + return (EConstant (Str line)) +getOp (UN "prim__readString") [EHandle h] = + Just $ do contents <- execIO $ hGetLine h + return (EConstant (Str (contents ++ "\n"))) +getOp n args = getPrim n primitives >>= flip applyPrim args + where getPrim :: Name -> [Prim] -> Maybe ([ExecVal] -> Maybe ExecVal) + getPrim n [] = Nothing + getPrim n ((Prim pn _ arity def _ _) : prims) | n == pn = Just $ execPrim def + | otherwise = getPrim n prims + execPrim :: ([Const] -> Maybe Const) -> [ExecVal] -> Maybe ExecVal + execPrim f args = EConstant <$> (mapM getConst args >>= f) + getConst (EConstant c) = Just c + getConst _ = Nothing + applyPrim :: ([ExecVal] -> Maybe ExecVal) -> [ExecVal] -> Maybe (Exec ExecVal) + applyPrim fn args = return <$> fn args + + + -- | Overall wrapper for case tree execution. If there are enough arguments, it takes them, -- evaluates them, then begins the checks for matching cases. execCase :: ExecEnv -> Context -> [Name] -> SC -> [ExecVal] -> Exec (Maybe ExecVal) @@ -431,9 +385,7 @@ idrisType :: FType -> ExecVal idrisType FUnit = EP Ref unitTy EErased idrisType ft = EConstant (idr ft) - where idr (FInt ty) = intTyToConst ty - idr FDouble = FlType - idr FChar = ChType + where idr (FArith ty) = AType ty idr FString = StrType idr FPtr = PtrType @@ -448,20 +400,27 @@ Just f -> do res <- call' f args retType return . Just . ioWrap $ res where call' :: ForeignFun -> [ExecVal] -> FType -> Exec ExecVal - call' (Fun _ h) args (FInt ITNative) = do res <- execIO $ callFFI h retCInt (prepArgs args) - return (EConstant (I (fromIntegral res))) - call' (Fun _ h) args (FInt IT8) = do res <- execIO $ callFFI h retCChar (prepArgs args) - return (EConstant (B8 (fromIntegral res))) - call' (Fun _ h) args (FInt IT16) = do res <- execIO $ callFFI h retCWchar (prepArgs args) - return (EConstant (B16 (fromIntegral res))) - call' (Fun _ h) args (FInt IT32) = do res <- execIO $ callFFI h retCInt (prepArgs args) - return (EConstant (B32 (fromIntegral res))) - call' (Fun _ h) args (FInt IT64) = do res <- execIO $ callFFI h retCLong (prepArgs args) - return (EConstant (B64 (fromIntegral res))) - call' (Fun _ h) args FDouble = do res <- execIO $ callFFI h retCDouble (prepArgs args) - return (EConstant (Fl (realToFrac res))) - call' (Fun _ h) args FChar = do res <- execIO $ callFFI h retCChar (prepArgs args) - return (EConstant (Ch (castCCharToChar res))) + call' (Fun _ h) args (FArith (ATInt ITNative)) = do + res <- execIO $ callFFI h retCInt (prepArgs args) + return (EConstant (I (fromIntegral res))) + call' (Fun _ h) args (FArith (ATInt (ITFixed IT8))) = do + res <- execIO $ callFFI h retCChar (prepArgs args) + return (EConstant (B8 (fromIntegral res))) + call' (Fun _ h) args (FArith (ATInt (ITFixed IT16))) = do + res <- execIO $ callFFI h retCWchar (prepArgs args) + return (EConstant (B16 (fromIntegral res))) + call' (Fun _ h) args (FArith (ATInt (ITFixed IT32))) = do + res <- execIO $ callFFI h retCInt (prepArgs args) + return (EConstant (B32 (fromIntegral res))) + call' (Fun _ h) args (FArith (ATInt (ITFixed IT64))) = do + res <- execIO $ callFFI h retCLong (prepArgs args) + return (EConstant (B64 (fromIntegral res))) + call' (Fun _ h) args (FArith ATFloat) = do + res <- execIO $ callFFI h retCDouble (prepArgs args) + return (EConstant (Fl (realToFrac res))) + call' (Fun _ h) args (FArith (ATInt ITChar)) = do + res <- execIO $ callFFI h retCChar (prepArgs args) + return (EConstant (Ch (castCCharToChar res))) call' (Fun _ h) args FString = do res <- execIO $ callFFI h retCString (prepArgs args) hStr <- execIO $ peekCString res -- lift $ free res @@ -500,16 +459,16 @@ getFTy :: ExecVal -> Maybe FType getFTy (EApp (EP _ (UN "FIntT") _) (EP _ (UN intTy) _)) = case intTy of - "ITNative" -> Just $ FInt ITNative - "IT8" -> Just $ FInt IT8 - "IT16" -> Just $ FInt IT16 - "IT32" -> Just $ FInt IT32 - "IT64" -> Just $ FInt IT64 + "ITNative" -> Just (FArith (ATInt ITNative)) + "ITChar" -> Just (FArith (ATInt ITChar)) + "IT8" -> Just (FArith (ATInt (ITFixed IT8))) + "IT16" -> Just (FArith (ATInt (ITFixed IT16))) + "IT32" -> Just (FArith (ATInt (ITFixed IT32))) + "IT64" -> Just (FArith (ATInt (ITFixed IT64))) _ -> Nothing getFTy (EP _ (UN t) _) = case t of - "FFloat" -> Just FDouble - "FChar" -> Just FChar + "FFloat" -> Just (FArith ATFloat) "FString" -> Just FString "FPtr" -> Just FPtr "FUnit" -> Just FUnit diff --git a/src/Core/ProofState.hs b/src/Core/ProofState.hs --- a/src/Core/ProofState.hs +++ b/src/Core/ProofState.hs @@ -37,6 +37,7 @@ previous :: Maybe ProofState, -- for undo context :: Context, plog :: String, + unifylog :: Bool, done :: Bool } @@ -49,6 +50,7 @@ | Reorder Name | Exact Raw | Fill Raw + | MatchFill Raw | PrepFill Name [Name] | CompleteFill | Regret @@ -56,6 +58,7 @@ | StartUnify Name | EndUnify | Compute + | Simplify | HNF_Compute | EvalIn Raw | CheckIn Raw @@ -63,7 +66,9 @@ | IntroTy Raw (Maybe Name) | Forall Name Raw | LetBind Name Raw Raw + | ExpandLet Name Term | Rewrite Raw + | Equiv Raw | PatVar Name | PatBind Name | Focus Name @@ -80,8 +85,9 @@ -- Some utilites on proof and tactic states instance Show ProofState where - show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _) = show nm ++ ": no more goals" - show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _) + show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _) + = show nm ++ ": no more goals" + show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _) = let OK g = goal (Just h) tm wkenv = premises g in "Other goals: " ++ show hs ++ "\n" ++ @@ -104,12 +110,12 @@ showG ps b = showEnv ps (binderTy b) instance Pretty ProofState where - pretty (PS nm [] _ _ trm _ _ _ _ _ _ _ _ _ _ _ _ _) = + pretty (PS nm [] _ _ trm _ _ _ _ _ _ _ _ _ _ _ _ _ _) = if size nm > breakingSize then pretty nm <> colon $$ nest nestingSize (text " no more goals.") else pretty nm <> colon <+> text " no more goals." - pretty p@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _) = + pretty p@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _) = let OK g = goal (Just h) tm in let wkEnv = premises g in text "Other goals" <+> colon <+> pretty hs $$ @@ -154,19 +160,31 @@ qshow :: Fails -> String qshow fs = show (map (\ (x, y, _, _) -> (x, y)) fs) -unify' :: Context -> Env -> TT Name -> TT Name -> StateT TState TC [(Name, TT Name)] +match_unify' :: Context -> Env -> TT Name -> TT Name -> + StateT TState TC [(Name, TT Name)] +match_unify' ctxt env topx topy = + do ps <- get + let dont = dontunify ps + u <- lift $ match_unify ctxt env topx topy dont (holes ps) + let (h, ns) = unified ps + put (ps { unified = (h, u ++ ns) }) + return u + +unify' :: Context -> Env -> TT Name -> TT Name -> + StateT TState TC [(Name, TT Name)] unify' ctxt env topx topy = do ps <- get let dont = dontunify ps (u, fails) <- -- trace ("Trying " ++ show (topx, topy)) $ lift $ unify ctxt env topx topy dont (holes ps) --- trace ("Unified " ++ show (topx, topy) ++ " without " ++ show dont ++ --- -- " in " ++ show env ++ --- "\n" ++ show u ++ "\n" ++ qshow fails ++ "\nCurrent problems:\n" --- ++ qshow (problems ps) ++ "\n" ++ show (holes ps) ++ "\n" + traceWhen (unifylog ps) + ("Unified " ++ show (topx, topy) ++ " without " ++ show dont ++ + " in " ++ show env ++ + "\n" ++ show u ++ "\n" ++ qshow fails ++ "\nCurrent problems:\n" + ++ qshow (problems ps) ++ "\n" ++ show (holes ps) ++ "\n" -- ++ show (pterm ps) --- ++ "\n----------") $ - case fails of + ++ "\n----------") $ + case fails of -- [] -> return u err -> do ps <- get @@ -199,7 +217,7 @@ (P Bound h ty')) ty [] (h, []) [] Nothing [] [] [] [] - Nothing ctxt "" False + Nothing ctxt "" False False type TState = ProofState -- [TacticAction]) type RunTactic = Context -> Env -> Term -> StateT TState TC Term @@ -348,7 +366,8 @@ do action (\ps -> let hs = holes ps in ps { holes = hs \\ [x] }) return sc -regret ctxt env (Bind x (Hole t) _) = fail $ show x ++ " : " ++ show t ++ " is not solved" +regret ctxt env (Bind x (Hole t) _) + = fail $ show x ++ " : " ++ show t ++ " is not solved..." exact :: Raw -> RunTactic exact guess ctxt env (Bind x (Hole ty) sc) = @@ -372,6 +391,21 @@ return $ Bind x (Guess ty val) sc fill _ _ _ _ = fail "Can't fill here." +-- As fill, but attempts to solve other goals by matching + +match_fill :: Raw -> RunTactic +match_fill guess ctxt env (Bind x (Hole ty) sc) = + do (val, valty) <- lift $ check ctxt env guess +-- let valtyn = normalise ctxt env valty +-- let tyn = normalise ctxt env ty + ns <- match_unify' ctxt env valty ty + ps <- get + let (uh, uns) = unified ps +-- put (ps { unified = (uh, uns ++ ns) }) +-- addLog (show (uh, uns ++ ns)) + return $ Bind x (Guess ty val) sc +match_fill _ _ _ _ = fail "Can't fill here." + prep_fill :: Name -> [Name] -> RunTactic prep_fill f as ctxt env (Bind x (Hole ty) sc) = do let val = mkApp (P Ref f Erased) (map (\n -> P Ref n Erased) as) @@ -472,6 +506,10 @@ return $ Bind n (Let tyv valv) (Bind x (Hole t) (P Bound x t)) letbind n ty val ctxt env _ = fail "Can't let bind here" +expandLet :: Name -> Term -> RunTactic +expandLet n v ctxt env tm = + return $ subst n v tm + rewrite :: Raw -> RunTactic rewrite tm ctxt env (Bind x (Hole t) xp@(P _ x' _)) | x == x' = do (tmv, tmt) <- lift $ check ctxt env tm @@ -508,6 +546,13 @@ rname = MN 0 "replaced" rewrite _ _ _ _ = fail "Can't rewrite here" +equiv :: Raw -> RunTactic +equiv tm ctxt env (Bind x (Hole t) sc) = + do (tmv, tmt) <- lift $ check ctxt env tm + lift $ converts ctxt env tmv t + return $ Bind x (Hole tmv) sc +equiv tm ctxt env _ = fail "Can't equiv here" + patbind :: Name -> RunTactic patbind n ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do let t' = case t of @@ -531,6 +576,12 @@ return $ Bind x (Hole ty') sc hnf_compute ctxt env t = return t +-- reduce let bindings only +simplify :: RunTactic +simplify ctxt env (Bind x (Hole ty) sc) = + do return $ Bind x (Hole (specialise ctxt env [] ty)) sc +simplify ctxt env t = return t + check_in :: Raw -> RunTactic check_in t ctxt env tm = do (val, valty) <- lift $ check ctxt env t @@ -680,18 +731,22 @@ mktac (Claim n r) = claim n r mktac (Exact r) = exact r mktac (Fill r) = fill r + mktac (MatchFill r) = match_fill r mktac (PrepFill n ns) = prep_fill n ns mktac CompleteFill = complete_fill mktac Regret = regret mktac Solve = solve mktac (StartUnify n) = start_unify n mktac Compute = compute + mktac Simplify = Core.ProofState.simplify mktac HNF_Compute = hnf_compute mktac (Intro n) = intro n mktac (IntroTy ty n) = introTy ty n mktac (Forall n t) = forall n t mktac (LetBind n t v) = letbind n t v + mktac (ExpandLet n b) = expandLet n b mktac (Rewrite t) = rewrite t + mktac (Equiv t) = equiv t mktac (PatVar n) = patvar n mktac (PatBind n) = patbind n mktac (CheckIn r) = check_in r diff --git a/src/Core/TT.hs b/src/Core/TT.hs --- a/src/Core/TT.hs +++ b/src/Core/TT.hs @@ -25,8 +25,11 @@ import qualified Data.Map as Map import Data.Char import Data.List +import Data.Vector.Unboxed (Vector) +import qualified Data.Vector.Unboxed as V import qualified Data.Binary as B import Data.Binary hiding (get, put) +import Foreign.Storable (sizeOf) import Util.Pretty hiding (Str) @@ -57,6 +60,8 @@ -- unification succeed | InfiniteUnify Name Term [(Name, Type)] | CantConvert Term Term [(Name, Type)] + | UnifyScope Name Name Term [(Name, Type)] + | CantInferType String | NonFunctionType Term Term | CantIntroduce Term | NoSuchVariable Name @@ -82,6 +87,7 @@ size (CantUnify _ left right err _ score) = size left + size right + size err size (InfiniteUnify _ right _) = size right size (CantConvert left right _) = size left + size right + size (UnifyScope _ _ right _) = size right size (NoSuchVariable name) = size name size (NoTypeDecl name) = size name size (NotInjective l c r) = size l + size c + size r @@ -100,6 +106,7 @@ score (CantResolve _) = 20 score (NoSuchVariable _) = 1000 score (ProofSearchFail _) = 10000 +score (InternalMsg _) = -1 score _ = 0 instance Show Err where @@ -274,12 +281,48 @@ addAlist [] ctxt = ctxt addAlist ((n, tm) : ds) ctxt = addDef n tm (addAlist ds ctxt) -data Const = I Int | BI Integer | Fl Double | Ch Char | Str String - | IType | BIType | FlType | ChType | StrType +data NativeTy = IT8 | IT16 | IT32 | IT64 + deriving (Show, Eq, Ord, Enum) - | B8 Word8 | B16 Word16 | B32 Word32 | B64 Word64 - | B8Type | B16Type | B32Type | B64Type +instance Pretty NativeTy where + pretty IT8 = text "Bits8" + pretty IT16 = text "Bits16" + pretty IT32 = text "Bits32" + pretty IT64 = text "Bits64" +data IntTy = ITFixed NativeTy | ITNative | ITBig | ITChar + | ITVec NativeTy Int + deriving (Show, Eq, Ord) + +data ArithTy = ATInt IntTy | ATFloat -- TODO: Float vectors + deriving (Show, Eq, Ord) + +instance Pretty ArithTy where + pretty (ATInt ITNative) = text "Int" + pretty (ATInt ITBig) = text "BigInt" + pretty (ATInt ITChar) = text "Char" + pretty (ATInt (ITFixed n)) = pretty n + pretty (ATInt (ITVec e c)) = pretty e <> text "x" <> (text . show $ c) + pretty ATFloat = text "Float" + +nativeTyWidth :: NativeTy -> Int +nativeTyWidth IT8 = 8 +nativeTyWidth IT16 = 16 +nativeTyWidth IT32 = 32 +nativeTyWidth IT64 = 64 + +{-# DEPRECATED intTyWidth "Non-total function, use nativeTyWidth and appropriate casing" #-} +intTyWidth :: IntTy -> Int +intTyWidth (ITFixed n) = nativeTyWidth n +intTyWidth ITNative = 8 * sizeOf (0 :: Int) +intTyWidth ITChar = error "IRTS.Lang.intTyWidth: Characters have platform and backend dependent width" +intTyWidth ITBig = error "IRTS.Lang.intTyWidth: Big integers have variable width" + +data Const = I Int | BI Integer | Fl Double | Ch Char | Str String + | B8 Word8 | B16 Word16 | B32 Word32 | B64 Word64 + | B8V (Vector Word8) | B16V (Vector Word16) + | B32V (Vector Word32) | B64V (Vector Word64) + | AType ArithTy | StrType | PtrType | VoidType | Forgot deriving (Eq, Ord) {-! @@ -295,18 +338,15 @@ pretty (Fl f) = text . show $ f pretty (Ch c) = text . show $ c pretty (Str s) = text s - pretty IType = text "Int" - pretty BIType = text "BigInt" - pretty FlType = text "Float" - pretty ChType = text "Char" + pretty (AType a) = pretty a pretty StrType = text "String" pretty PtrType = text "Ptr" pretty VoidType = text "Void" pretty Forgot = text "Forgot" - pretty B8Type = text "Bits8" - pretty B16Type = text "Bits16" - pretty B32Type = text "Bits32" - pretty B64Type = text "Bits64" + pretty (B8 w) = text . show $ w + pretty (B16 w) = text . show $ w + pretty (B32 w) = text . show $ w + pretty (B64 w) = text . show $ w data Raw = Var Name | RBind Name (Binder Raw) Raw @@ -482,7 +522,11 @@ termsize n (Bind n' (Let t v) sc) = let rn = if n == n' then MN 0 "noname" else n in termsize rn v + termsize rn sc + termsize n (Bind n' b sc) + = let rn = if n == n' then MN 0 "noname" else n in + termsize rn sc termsize n (App f a) = termsize n f + termsize n a + termsize n (Proj t i) = termsize n t termsize n _ = 1 instance Sized a => Sized (TT a) where @@ -548,6 +592,15 @@ subst i (Proj x idx) = Proj (subst i x) idx subst i t = t +substV :: TT n -> TT n -> TT n +substV x tm = dropV 0 (instantiate x tm) where + dropV i (V x) | x > i = V (x - 1) + | otherwise = V x + dropV i (Bind x b sc) = Bind x (fmap (dropV i) b) (dropV (i+1) sc) + dropV i (App f a) = App (dropV i f) (dropV i a) + dropV i (Proj x idx) = Proj (dropV i x) idx + dropV i t = t + explicitNames :: TT n -> TT n explicitNames (Bind x b sc) = let b' = fmap explicitNames b in Bind x b' @@ -563,12 +616,23 @@ pToV' n i (Bind x b sc) -- We can assume the inner scope has been pToVed already, so continue to -- resolve names from the *outer* scope which may happen to have the same id. --- | n == x = Bind x (fmap (pToV' n i) b) sc + | n == x = Bind x (fmap (pToV' n i) b) sc | otherwise = Bind x (fmap (pToV' n i) b) (pToV' n (i+1) sc) pToV' n i (App f a) = App (pToV' n i f) (pToV' n i a) pToV' n i (Proj t idx) = Proj (pToV' n i t) idx pToV' n i t = t +-- increase de Bruijn indices, as if a binder has been added +addBinder :: TT n -> TT n +addBinder t = ab 0 t + where + ab top (V i) | i >= top = V (i + 1) + | otherwise = V i + ab top (Bind x b sc) = Bind x (fmap (ab top) b) (ab (top + 1) sc) + ab top (App f a) = App (ab top f) (ab top a) + ab top (Proj t idx) = Proj (ab top t) idx + ab top t = t + -- | Convert several names. First in the list comes out as V 0 pToVs :: Eq n => [n] -> TT n -> TT n pToVs ns tm = pToVs' ns tm 0 where @@ -709,9 +773,14 @@ instance (Eq n, Show n) => Show (TT n) where show t = showEnv [] t +itBitsName IT8 = "Bits8" +itBitsName IT16 = "Bits16" +itBitsName IT32 = "Bits32" +itBitsName IT64 = "Bits64" + instance Show Const where show (I i) = show i - show (BI i) = show i ++ "L" + show (BI i) = show i show (Fl f) = show f show (Ch c) = show c show (Str s) = show s @@ -719,16 +788,18 @@ show (B16 x) = show x show (B32 x) = show x show (B64 x) = show x - show IType = "Int" - show BIType = "Integer" - show FlType = "Float" - show ChType = "Char" + show (B8V x) = "<" ++ intercalate "," (map show (V.toList x)) ++ ">" + show (B16V x) = "<" ++ intercalate "," (map show (V.toList x)) ++ ">" + show (B32V x) = "<" ++ intercalate "," (map show (V.toList x)) ++ ">" + show (B64V x) = "<" ++ intercalate "," (map show (V.toList x)) ++ ">" + show (AType ATFloat) = "Float" + show (AType (ATInt ITBig)) = "Integer" + show (AType (ATInt ITNative)) = "Int" + show (AType (ATInt ITChar)) = "Char" + show (AType (ATInt (ITFixed it))) = itBitsName it + show (AType (ATInt (ITVec it c))) = itBitsName it ++ "x" ++ show c show StrType = "String" show PtrType = "Ptr" - show B8Type = "Bits8" - show B16Type = "Bits16" - show B32Type = "Bits32" - show B64Type = "Bits64" show VoidType = "Void" showEnv env t = showEnv' env t False @@ -787,7 +858,8 @@ showEnv' env t dbg = se 10 env t where se p env (P nt n t) = show n ++ if dbg then "{" ++ show nt ++ " : " ++ se 10 env t ++ "}" else "" - se p env (V i) | i < length env = (show $ fst $ env!!i) ++ + se p env (V i) | i < length env && i >= 0 + = (show $ fst $ env!!i) ++ if dbg then "{" ++ show i ++ "}" else "" | otherwise = "!!V " ++ show i ++ "!!" se p env (Bind n b@(Pi t) sc) diff --git a/src/Core/Typecheck.hs b/src/Core/Typecheck.hs --- a/src/Core/Typecheck.hs +++ b/src/Core/Typecheck.hs @@ -5,6 +5,7 @@ import Control.Monad.State import Debug.Trace +import qualified Data.Vector.Unboxed as V (length) import Core.TT import Core.Evaluate @@ -98,15 +99,19 @@ return (TType (UVar v), TType (UVar (v+1))) chk env (RConstant Forgot) = return (Erased, Erased) chk env (RConstant c) = return (Constant c, constType c) - where constType (I _) = Constant IType - constType (BI _) = Constant BIType - constType (Fl _) = Constant FlType - constType (Ch _) = Constant ChType + where constType (I _) = Constant (AType (ATInt ITNative)) + constType (BI _) = Constant (AType (ATInt ITBig)) + constType (Fl _) = Constant (AType ATFloat) + constType (Ch _) = Constant (AType (ATInt ITChar)) constType (Str _) = Constant StrType - constType (B8 _) = Constant B8Type - constType (B16 _) = Constant B16Type - constType (B32 _) = Constant B32Type - constType (B64 _) = Constant B64Type + constType (B8 _) = Constant (AType (ATInt (ITFixed IT8))) + constType (B16 _) = Constant (AType (ATInt (ITFixed IT16))) + constType (B32 _) = Constant (AType (ATInt (ITFixed IT32))) + constType (B64 _) = Constant (AType (ATInt (ITFixed IT64))) + constType (B8V a) = Constant (AType (ATInt (ITVec IT8 (V.length a)))) + constType (B16V a) = Constant (AType (ATInt (ITVec IT16 (V.length a)))) + constType (B32V a) = Constant (AType (ATInt (ITVec IT32 (V.length a)))) + constType (B64V a) = Constant (AType (ATInt (ITVec IT64 (V.length a)))) constType Forgot = Erased constType _ = TType (UVal 0) chk env (RForce t) = do (_, ty) <- chk env t diff --git a/src/Core/Unify.hs b/src/Core/Unify.hs --- a/src/Core/Unify.hs +++ b/src/Core/Unify.hs @@ -1,12 +1,13 @@ {-# LANGUAGE PatternGuards #-} -module Core.Unify(unify, Fails) where +module Core.Unify(match_unify, unify, Fails) where import Core.TT import Core.Evaluate import Control.Monad import Control.Monad.State +import Data.List import Debug.Trace -- Unification is applied inside the theorem prover. We're looking for holes @@ -27,13 +28,104 @@ | UPartOK a | UFail Err +-- Solve metavariables by matching terms against each other +-- Not really unification, of course! + +match_unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> + TC [(Name, TT Name)] +match_unify ctxt env topx topy dont holes = +-- trace ("Matching " ++ show (topx, topy)) $ + case runStateT (un [] topx topy) (UI 0 []) of + OK (v, UI _ []) -> return (filter notTrivial v) + res -> + let topxn = normalise ctxt env topx + topyn = normalise ctxt env topy in + case runStateT (un [] topxn topyn) + (UI 0 []) of + OK (v, UI _ fails) -> + return (filter notTrivial v) + Error e -> tfail e + where + un names (P _ x _) tm + | holeIn env x || x `elem` holes + = do sc 1; checkCycle names (x, tm) + un names tm (P _ y _) + | holeIn env y || y `elem` holes + = do sc 1; checkCycle names (y, tm) + un bnames (V i) (P _ x _) + | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return [] + un bnames (P _ x _) (V i) + | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return [] + un names (App fx ax) (App fy ay) + = do hf <- un names fx fy + ha <- un names ax ay + combine names hf ha + un names x y + | OK True <- convEq' ctxt x y = do sc 1; return [] + | otherwise = do UI s f <- get + let r = recoverable x y + let err = CantUnify r + topx topy (CantUnify r x y (Msg "") [] s) (errEnv env) s + if (not r) then lift $ tfail err + else do put (UI s ((x, y, env, err) : f)) + lift $ tfail err + + + -- TODO: there's an annoying amount of repetition between this and the + -- main unification function. Consider lifting it out. + + sc i = do UI s f <- get + put (UI (s+i) f) + + unifyFail x y = do UI s f <- get + let r = recoverable x y + let err = CantUnify r + topx topy (CantUnify r x y (Msg "") [] s) (errEnv env) s + put (UI s ((x, y, env, err) : f)) + lift $ tfail err + combine bnames as [] = return as + combine bnames as ((n, t) : bs) + = case lookup n as of + Nothing -> combine bnames (as ++ [(n,t)]) bs + Just t' -> do ns <- un bnames t t' + -- make sure there's n mapping from n in ns + let ns' = filter (\ (x, _) -> x/=n) ns + sc 1 + combine bnames as (ns' ++ bs) + + checkCycle ns p@(x, P _ _ _) = return [p] + checkCycle ns (x, tm) + | not (x `elem` freeNames tm) = checkScope ns (x, tm) + | otherwise = lift $ tfail (InfiniteUnify x tm (errEnv env)) + + checkScope ns (x, tm) = + case boundVs (envPos x 0 env) tm of + [] -> return [(x, tm)] + (i:_) -> lift $ tfail (UnifyScope x (fst (ns!!i)) + (inst ns tm) (errEnv env)) + where inst [] tm = tm + inst ((n, _) : ns) tm = inst ns (substV (P Bound n Erased) tm) + +notTrivial (x, P _ x' _) = x /= x' +notTrivial _ = True + +expandLets env (x, tm) = (x, doSubst (reverse env) tm) + where + doSubst [] tm = tm + doSubst ((n, Let v t) : env) tm + = doSubst env (subst n v tm) + doSubst (_ : env) tm + = doSubst env tm + + unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> TC ([(Name, TT Name)], Fails) unify ctxt env topx topy dont holes = -- trace ("Unifying " ++ show (topx, topy)) $ -- don't bother if topx and topy are different at the head case runStateT (un False [] topx topy) (UI 0 []) of - OK (v, UI _ []) -> return (filter notTrivial v, []) + OK (v, UI _ []) -> return (filter notTrivial v, + []) res -> let topxn = normalise ctxt env topx topyn = normalise ctxt env topy in @@ -45,17 +137,14 @@ -- Error e@(CantUnify False _ _ _ _ _) -> tfail e Error e -> tfail e where - notTrivial (x, P _ x' _) = x /= x' - notTrivial _ = True - headDiff (P (DCon _ _) x _) (P (DCon _ _) y _) = x /= y headDiff (P (TCon _ _) x _) (P (TCon _ _) y _) = x /= y headDiff _ _ = False injective (P (DCon _ _) _ _) = True injective (P (TCon _ _) _ _) = True - injective (App f (P _ _ _)) = injective f - injective (App f (Constant _)) = injective f +-- injective (App f (P _ _ _)) = injective f +-- injective (App f (Constant _)) = injective f injective (App f a) = injective f -- && injective a injective _ = False @@ -114,7 +203,7 @@ -- put (UI s ((tm, topx, topy) : i) f) then unifyTmpFail xtm tm else do sc 1 - checkCycle (x, tm) + checkCycle bnames (x, tm) | not (injective xtm) && injective tm = unifyFail xtm tm un' fn bnames tm ytm@(P _ y _) | holeIn env y || y `elem` holes @@ -125,17 +214,50 @@ -- put (UI s ((tm, topx, topy) : i) f) then unifyTmpFail tm ytm else do sc 1 - checkCycle (y, tm) + checkCycle bnames (y, tm) | not (injective ytm) && injective tm = unifyFail ytm tm un' fn bnames (V i) (P _ x _) | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return [] un' fn bnames (P _ x _) (V i) | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return [] - un' fn bnames appx@(App fx ax) appy@(App fy ay) - | (injective fx && sameArgStruct appx appy && metavarApp appy) - || (injective fy && sameArgStruct appx appy && metavarApp appx) - || (injective fx && injective fy) + un' fn bnames appx@(App _ _) appy@(App _ _) + = unApp fn bnames appx appy +-- = uplus (unApp fn bnames appx appy) +-- (unifyTmpFail appx appy) -- take the whole lot + + un' fn bnames x (Bind n (Lam t) (App y (P Bound n' _))) + | n == n' = un' False bnames x y + un' fn bnames (Bind n (Lam t) (App x (P Bound n' _))) y + | n == n' = un' False bnames x y + un' fn bnames x (Bind n (Lam t) (App y (V 0))) + = un' False bnames x y + un' fn bnames (Bind n (Lam t) (App x (V 0))) y + = un' False bnames x y +-- un' fn bnames (Bind x (PVar _) sx) (Bind y (PVar _) sy) +-- = un' False ((x,y):bnames) sx sy +-- un' fn bnames (Bind x (PVTy _) sx) (Bind y (PVTy _) sy) +-- = un' False ((x,y):bnames) sx sy + un' fn bnames (Bind x bx sx) (Bind y by sy) + = do h1 <- uB bnames bx by + h2 <- un' False ((x,y):bnames) sx sy + combine bnames h1 h2 + un' fn bnames x y + | OK True <- convEq' ctxt x y = do sc 1; return [] + | otherwise = do UI s f <- get + let r = recoverable x y + let err = CantUnify r + topx topy (CantUnify r x y (Msg "") [] s) (errEnv env) s + if (not r) then lift $ tfail err + else do put (UI s ((x, y, env, err) : f)) + return [] -- lift $ tfail err + + unApp fn bnames appx@(App fx ax) appy@(App fy ay) + | (injective fx && injective fy) + || (injective fx && rigid appx && metavarApp appy) + || (injective fy && rigid appy && metavarApp appx) + || (injective fx && metavarApp fy && ax == ay) + || (injective fy && metavarApp fx && ax == ay) = do let (headx, _) = unApply fx let (heady, _) = unApply fy -- fail quickly if the heads are disjoint @@ -157,19 +279,21 @@ hf <- un' False bnames fx' fy' sc 1 combine bnames hf ha) - | otherwise = + | otherwise = -- trace (show (appx, appy, injective fx, metavarApp appy, sameArgStruct appx appy)) $ do let (headx, argsx) = unApply appx let (heady, argsy) = unApply appy -- traceWhen (headx == heady) (show (appx, appy)) $ - if (length argsx == length argsy && - ((headx == heady && inenv headx) || (argsx == argsy) || - (and (zipWith sameStruct (headx:argsx) (heady:argsy))))) - then --- (notFn headx && notFn heady))) then - do uf <- un' True bnames headx heady - unArgs uf argsx argsy - else -- trace ("TMPFAIL " ++ show (appx, appy, injective appx, injective appy)) $ - unifyTmpFail appx appy + uplus ( + if (length argsx == length argsy && + ((headx == heady && inenv headx) || (argsx == argsy) || + (and (zipWith sameStruct (headx:argsx) (heady:argsy))))) + then +-- (notFn headx && notFn heady))) then + do uf <- un' True bnames headx heady + unArgs uf argsx argsy + else -- trace ("TMPFAIL " ++ show (appx, appy, injective appx, injective appy)) $ + unifyTmpFail appx appy) + (unifyTmpFail appx appy) -- whole application fails where hnormalise [] _ _ t = t hnormalise ns ctxt env t = normalise ctxt env t checkHeads (P (DCon _ _) x _) (P (DCon _ _) y _) @@ -191,15 +315,20 @@ unArgs vs xs ys metavarApp tm = let (f, args) = unApply tm in - all (\x -> metavar x || inenv x) (f : args) + all (\x -> metavar x) (f : args) + && nub args == args metavarArgs tm = let (f, args) = unApply tm in all (\x -> metavar x || inenv x) args + && nub args == args metavarApp' tm = let (f, args) = unApply tm in all (\x -> pat x || metavar x) (f : args) + && nub args == args - sameArgStruct appx appy = let (_, ax) = unApply appx - (_, ay) = unApply appy in - and (zipWith sameStruct ax ay) + sameArgStruct appx appy + = let (_, ax) = unApply appx + (_, ay) = unApply appy in + length ax == length ay && + and (zipWith sameStruct ax ay) sameStruct fapp@(App f x) gapp@(App g y) = let (f',a') = unApply fapp @@ -217,6 +346,13 @@ sameStruct (Bind n t sc) (Bind n' t' sc') = sameStruct sc sc' sameStruct _ _ = False + rigid (P (DCon _ _) _ _) = True + rigid (P (TCon _ _) _ _) = True + rigid t@(P Ref _ _) = inenv t + rigid (Constant _) = True + rigid (App f a) = rigid f && rigid a + rigid t = not (metavar t) + metavar t = case t of P _ x _ -> (x `elem` holes || holeIn env x) && not (x `elem` dont) @@ -230,38 +366,13 @@ notFn t = injective t || metavar t || inenv t - un' fn bnames x (Bind n (Lam t) (App y (P Bound n' _))) - | n == n' = un' False bnames x y - un' fn bnames (Bind n (Lam t) (App x (P Bound n' _))) y - | n == n' = un' False bnames x y - un' fn bnames x (Bind n (Lam t) (App y (V 0))) - = un' False bnames x y - un' fn bnames (Bind n (Lam t) (App x (V 0))) y - = un' False bnames x y --- un' fn bnames (Bind x (PVar _) sx) (Bind y (PVar _) sy) --- = un' False ((x,y):bnames) sx sy --- un' fn bnames (Bind x (PVTy _) sx) (Bind y (PVTy _) sy) --- = un' False ((x,y):bnames) sx sy - un' fn bnames (Bind x bx sx) (Bind y by sy) - = do h1 <- uB bnames bx by - h2 <- un' False ((x,y):bnames) sx sy - combine bnames h1 h2 - un' fn bnames x y - | OK True <- convEq' ctxt x y = do sc 1; return [] - | otherwise = do UI s f <- get - let r = recoverable x y - let err = CantUnify r - topx topy (CantUnify r x y (Msg "") [] s) (errEnv env) s - if (not r) then lift $ tfail err - else do put (UI s ((x, y, env, err) : f)) - return [] -- lift $ tfail err unifyTmpFail x y = do UI s f <- get let r = recoverable x y let err = CantUnify r topx topy (CantUnify r x y (Msg "") [] s) (errEnv env) s - put (UI s ((x, y, env, err) : f)) + put (UI s ((topx, topy, env, err) : f)) return [] -- shortcut failure, if we *know* nothing can fix it @@ -269,7 +380,7 @@ let r = recoverable x y let err = CantUnify r topx topy (CantUnify r x y (Msg "") [] s) (errEnv env) s - put (UI s ((x, y, env, err) : f)) + put (UI s ((topx, topy, env, err) : f)) lift $ tfail err @@ -295,11 +406,19 @@ put (UI s ((binderTy x, binderTy y, env, err) : f)) return [] -- lift $ tfail err - checkCycle p@(x, P _ _ _) = return [p] - checkCycle (x, tm) - | not (x `elem` freeNames tm) = return [(x, tm)] + checkCycle ns p@(x, P _ _ _) = return [p] + checkCycle ns (x, tm) + | not (x `elem` freeNames tm) = checkScope ns (x, tm) | otherwise = lift $ tfail (InfiniteUnify x tm (errEnv env)) + checkScope ns (x, tm) = + case boundVs (envPos x 0 env) tm of + [] -> return [(x, tm)] + (i:_) -> lift $ tfail (UnifyScope x (fst (ns!!i)) + (inst ns tm) (errEnv env)) + where inst [] tm = tm + inst ((n, _) : ns) tm = inst ns (substV (P Bound n Erased) tm) + combineArgs bnames args = ca [] args where ca acc [] = return acc ca acc (x : xs) = do x' <- combine bnames acc x @@ -315,30 +434,44 @@ sc 1 combine bnames as (ns' ++ bs) - -- If there are any clashes of constructors, deem it unrecoverable, otherwise some - -- more work may help. - -- FIXME: Depending on how overloading gets used, this may cause problems. Better - -- rethink overloading properly... +boundVs :: Int -> Term -> [Int] +boundVs i (V j) | j <= i = [] + | otherwise = [j] +boundVs i (Bind n b sc) = boundVs (i + 1) sc +boundVs i (App f x) = let fs = boundVs i f + xs = boundVs i x in + nub (fs ++ xs) +boundVs i _ = [] - recoverable (P (DCon _ _) x _) (P (DCon _ _) y _) - | x == y = True - | otherwise = False - recoverable (P (TCon _ _) x _) (P (TCon _ _) y _) - | x == y = True - | otherwise = False - recoverable (Constant _) (P (DCon _ _) y _) = False - recoverable (P (DCon _ _) x _) (Constant _) = False - recoverable (Constant _) (P (TCon _ _) y _) = False - recoverable (P (TCon _ _) x _) (Constant _) = False - recoverable (P (DCon _ _) x _) (P (TCon _ _) y _) = False - recoverable (P (TCon _ _) x _) (P (DCon _ _) y _) = False - recoverable p@(Constant _) (App f a) = recoverable p f - recoverable (App f a) p@(Constant _) = recoverable f p - recoverable p@(P _ n _) (App f a) = recoverable p f +envPos x i [] = 0 +envPos x i ((y, _) : ys) | x == y = i + | otherwise = envPos x (i + 1) ys + + +-- If there are any clashes of constructors, deem it unrecoverable, otherwise some +-- more work may help. +-- FIXME: Depending on how overloading gets used, this may cause problems. Better +-- rethink overloading properly... + +recoverable (P (DCon _ _) x _) (P (DCon _ _) y _) + | x == y = True + | otherwise = False +recoverable (P (TCon _ _) x _) (P (TCon _ _) y _) + | x == y = True + | otherwise = False +recoverable (Constant _) (P (DCon _ _) y _) = False +recoverable (P (DCon _ _) x _) (Constant _) = False +recoverable (Constant _) (P (TCon _ _) y _) = False +recoverable (P (TCon _ _) x _) (Constant _) = False +recoverable (P (DCon _ _) x _) (P (TCon _ _) y _) = False +recoverable (P (TCon _ _) x _) (P (DCon _ _) y _) = False +recoverable p@(Constant _) (App f a) = recoverable p f +recoverable (App f a) p@(Constant _) = recoverable f p +recoverable p@(P _ n _) (App f a) = recoverable p f -- recoverable (App f a) p@(P _ _ _) = recoverable f p - recoverable (App f a) (App f' a') - = recoverable f f' -- && recoverable a a' - recoverable _ _ = True +recoverable (App f a) (App f' a') + = recoverable f f' -- && recoverable a a' +recoverable _ _ = True errEnv = map (\(x, b) -> (x, binderTy b)) diff --git a/src/IRTS/CodegenC.hs b/src/IRTS/CodegenC.hs --- a/src/IRTS/CodegenC.hs +++ b/src/IRTS/CodegenC.hs @@ -229,39 +229,41 @@ -c_irts (FInt ITNative) l x = l ++ "MKINT((i_int)(" ++ x ++ "))" -c_irts (FInt ty) l x = l ++ "idris_b" ++ show (intTyWidth ty) ++ "const(vm, " ++ x ++ ")" -c_irts FChar l x = l ++ "MKINT((i_int)(" ++ x ++ "))" +c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))" +c_irts (FArith (ATInt ITChar)) l x = c_irts (FArith (ATInt ITNative)) l x +c_irts (FArith (ATInt (ITFixed ity))) l x + = l ++ "idris_b" ++ show (nativeTyWidth ity) ++ "const(vm, " ++ x ++ ")" c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")" c_irts FUnit l x = x c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")" -c_irts FDouble l x = l ++ "MKFLOAT(vm, " ++ x ++ ")" +c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")" c_irts FAny l x = l ++ x -irts_c (FInt ITNative) x = "GETINT(" ++ x ++ ")" -irts_c (FInt ty) x = "(" ++ x ++ "->info.bits" ++ show (intTyWidth ty) ++ ")" -irts_c FChar x = "GETINT(" ++ x ++ ")" +irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")" +irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x +irts_c (FArith (ATInt (ITFixed ity))) x + = "(" ++ x ++ "->info.bits" ++ show (nativeTyWidth ity) ++ ")" irts_c FString x = "GETSTR(" ++ x ++ ")" irts_c FUnit x = x irts_c FPtr x = "GETPTR(" ++ x ++ ")" -irts_c FDouble x = "GETFLOAT(" ++ x ++ ")" +irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")" irts_c FAny x = x -bitOp v op ty args = v ++ "idris_b" ++ show (intTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")" +bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")" bitCoerce v op input output arg - = v ++ "idris_b" ++ show (intTyWidth input) ++ op ++ show (intTyWidth output) ++ "(vm, " ++ creg arg ++ ")" + = v ++ "idris_b" ++ show (nativeTyWidth input) ++ op ++ show (nativeTyWidth output) ++ "(vm, " ++ creg arg ++ ")" -signedTy :: IntTy -> String -signedTy t = "int" ++ show (intTyWidth t) ++ "_t" +signedTy :: NativeTy -> String +signedTy t = "int" ++ show (nativeTyWidth t) ++ "_t" -doOp v (LPlus ITNative) [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")" -doOp v (LMinus ITNative) [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")" -doOp v (LTimes ITNative) [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LPlus (ATInt ITNative)) [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LMinus (ATInt ITNative)) [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LTimes (ATInt ITNative)) [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LUDiv ITNative) [l, r] = v ++ "UINTOP(/," ++ creg l ++ ", " ++ creg r ++ ")" -doOp v (LSDiv ITNative) [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LSDiv (ATInt ITNative)) [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LURem ITNative) [l, r] = v ++ "UINTOP(%," ++ creg l ++ ", " ++ creg r ++ ")" -doOp v (LSRem ITNative) [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LSRem (ATInt ITNative)) [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LAnd ITNative) [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LOr ITNative) [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LXOr ITNative) [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")" @@ -269,33 +271,55 @@ doOp v (LLSHR ITNative) [l, r] = v ++ "UINTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LASHR ITNative) [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LCompl ITNative) [x] = v ++ "INTOP(~," ++ creg x ++ ")" -doOp v (LEq ITNative) [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")" -doOp v (LLt ITNative) [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")" -doOp v (LLe ITNative) [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")" -doOp v (LGt ITNative) [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")" -doOp v (LGe ITNative) [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LEq (ATInt ITNative)) [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LLt (ATInt ITNative)) [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LLe (ATInt ITNative)) [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LGt (ATInt ITNative)) [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LGe (ATInt ITNative)) [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")" -doOp v LFPlus [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")" -doOp v LFMinus [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")" -doOp v LFTimes [l, r] = v ++ "FLOATOP(*," ++ creg l ++ ", " ++ creg r ++ ")" -doOp v LFDiv [l, r] = v ++ "FLOATOP(/," ++ creg l ++ ", " ++ creg r ++ ")" -doOp v LFEq [l, r] = v ++ "FLOATBOP(==," ++ creg l ++ ", " ++ creg r ++ ")" -doOp v LFLt [l, r] = v ++ "FLOATBOP(<," ++ creg l ++ ", " ++ creg r ++ ")" -doOp v LFLe [l, r] = v ++ "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")" -doOp v LFGt [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")" -doOp v LFGe [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LPlus (ATInt ITChar)) [l, r] = doOp v (LPlus (ATInt ITNative)) [l, r] +doOp v (LMinus (ATInt ITChar)) [l, r] = doOp v (LMinus (ATInt ITNative)) [l, r] +doOp v (LTimes (ATInt ITChar)) [l, r] = doOp v (LTimes (ATInt ITNative)) [l, r] +doOp v (LUDiv ITChar) [l, r] = doOp v (LUDiv ITNative) [l, r] +doOp v (LSDiv (ATInt ITChar)) [l, r] = doOp v (LSDiv (ATInt ITNative)) [l, r] +doOp v (LURem ITChar) [l, r] = doOp v (LURem ITNative) [l, r] +doOp v (LSRem (ATInt ITChar)) [l, r] = doOp v (LSRem (ATInt ITNative)) [l, r] +doOp v (LAnd ITChar) [l, r] = doOp v (LAnd ITNative) [l, r] +doOp v (LOr ITChar) [l, r] = doOp v (LOr ITNative) [l, r] +doOp v (LXOr ITChar) [l, r] = doOp v (LXOr ITNative) [l, r] +doOp v (LSHL ITChar) [l, r] = doOp v (LSHL ITNative) [l, r] +doOp v (LLSHR ITChar) [l, r] = doOp v (LLSHR ITNative) [l, r] +doOp v (LASHR ITChar) [l, r] = doOp v (LASHR ITNative) [l, r] +doOp v (LCompl ITChar) [x] = doOp v (LCompl ITNative) [x] +doOp v (LEq (ATInt ITChar)) [l, r] = doOp v (LEq (ATInt ITNative)) [l, r] +doOp v (LLt (ATInt ITChar)) [l, r] = doOp v (LLt (ATInt ITNative)) [l, r] +doOp v (LLe (ATInt ITChar)) [l, r] = doOp v (LLe (ATInt ITNative)) [l, r] +doOp v (LGt (ATInt ITChar)) [l, r] = doOp v (LGt (ATInt ITNative)) [l, r] +doOp v (LGe (ATInt ITChar)) [l, r] = doOp v (LGe (ATInt ITNative)) [l, r] -doOp v (LPlus ITBig) [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")" -doOp v (LMinus ITBig) [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")" -doOp v (LTimes ITBig) [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")" -doOp v (LSDiv ITBig) [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")" -doOp v (LSRem ITBig) [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")" -doOp v (LEq ITBig) [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")" -doOp v (LLt ITBig) [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")" -doOp v (LLe ITBig) [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")" -doOp v (LGt ITBig) [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")" -doOp v (LGe ITBig) [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LPlus ATFloat) [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LMinus ATFloat) [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LTimes ATFloat) [l, r] = v ++ "FLOATOP(*," ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LSDiv ATFloat) [l, r] = v ++ "FLOATOP(/," ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LEq ATFloat) [l, r] = v ++ "FLOATBOP(==," ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LLt ATFloat) [l, r] = v ++ "FLOATBOP(<," ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LLe ATFloat) [l, r] = v ++ "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LGt ATFloat) [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LGe ATFloat) [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LIntFloat ITBig) [x] = v ++ "idris_castBigFloat(vm, " ++ creg x ++ ")" +doOp v (LFloatInt ITBig) [x] = v ++ "idris_castFloatBig(vm, " ++ creg x ++ ")" +doOp v (LPlus (ATInt ITBig)) [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LMinus (ATInt ITBig)) [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LTimes (ATInt ITBig)) [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LSDiv (ATInt ITBig)) [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LSRem (ATInt ITBig)) [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LEq (ATInt ITBig)) [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LLt (ATInt ITBig)) [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LLe (ATInt ITBig)) [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LGt (ATInt ITBig)) [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")" +doOp v (LGe (ATInt ITBig)) [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")" + doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")" @@ -316,55 +340,80 @@ doOp _ LPrintNum [x] = "printf(\"%ld\\n\", GETINT(" ++ creg x ++ "))" doOp _ LPrintStr [x] = "fputs(GETSTR(" ++ creg x ++ "), stdout)" -doOp v (LLt ty) [x, y] = bitOp v "Lt" ty [x, y] -doOp v (LLe ty) [x, y] = bitOp v "Lte" ty [x, y] -doOp v (LEq ty) [x, y] = bitOp v "Eq" ty [x, y] -doOp v (LGe ty) [x, y] = bitOp v "Gte" ty [x, y] -doOp v (LGt ty) [x, y] = bitOp v "Gt" ty [x, y] +doOp v (LLt (ATInt (ITFixed ty))) [x, y] = bitOp v "Lt" ty [x, y] +doOp v (LLe (ATInt (ITFixed ty))) [x, y] = bitOp v "Lte" ty [x, y] +doOp v (LEq (ATInt (ITFixed ty))) [x, y] = bitOp v "Eq" ty [x, y] +doOp v (LGe (ATInt (ITFixed ty))) [x, y] = bitOp v "Gte" ty [x, y] +doOp v (LGt (ATInt (ITFixed ty))) [x, y] = bitOp v "Gt" ty [x, y] -doOp v (LSHL ty) [x, y] = bitOp v "Shl" ty [x, y] -doOp v (LLSHR ty) [x, y] = bitOp v "Shr" ty [x, y] -doOp v (LASHR ty) [x, y] = bitOp v "AShr" ty [x, y] -doOp v (LAnd ty) [x, y] = bitOp v "And" ty [x, y] -doOp v (LOr ty) [x, y] = bitOp v "Or" ty [x, y] -doOp v (LXOr ty) [x, y] = bitOp v "Xor" ty [x, y] -doOp v (LCompl ty) [x] = bitOp v "Compl" ty [x] +doOp v (LSHL (ITFixed ty)) [x, y] = bitOp v "Shl" ty [x, y] +doOp v (LLSHR (ITFixed ty)) [x, y] = bitOp v "LShr" ty [x, y] +doOp v (LASHR (ITFixed ty)) [x, y] = bitOp v "AShr" ty [x, y] +doOp v (LAnd (ITFixed ty)) [x, y] = bitOp v "And" ty [x, y] +doOp v (LOr (ITFixed ty)) [x, y] = bitOp v "Or" ty [x, y] +doOp v (LXOr (ITFixed ty)) [x, y] = bitOp v "Xor" ty [x, y] +doOp v (LCompl (ITFixed ty)) [x] = bitOp v "Compl" ty [x] -doOp v (LPlus ty) [x, y] = bitOp v "Plus" ty [x, y] -doOp v (LMinus ty) [x, y] = bitOp v "Minus" ty [x, y] -doOp v (LTimes ty) [x, y] = bitOp v "Times" ty [x, y] -doOp v (LUDiv ty) [x, y] = bitOp v "UDiv" ty [x, y] -doOp v (LSDiv ty) [x, y] = bitOp v "SDiv" ty [x, y] -doOp v (LURem ty) [x, y] = bitOp v "URem" ty [x, y] -doOp v (LSRem ty) [x, y] = bitOp v "SRem" ty [x, y] +doOp v (LPlus (ATInt (ITFixed ty))) [x, y] = bitOp v "Plus" ty [x, y] +doOp v (LMinus (ATInt (ITFixed ty))) [x, y] = bitOp v "Minus" ty [x, y] +doOp v (LTimes (ATInt (ITFixed ty))) [x, y] = bitOp v "Times" ty [x, y] +doOp v (LUDiv (ITFixed ty)) [x, y] = bitOp v "UDiv" ty [x, y] +doOp v (LSDiv (ATInt (ITFixed ty))) [x, y] = bitOp v "SDiv" ty [x, y] +doOp v (LURem (ITFixed ty)) [x, y] = bitOp v "URem" ty [x, y] +doOp v (LSRem (ATInt (ITFixed ty))) [x, y] = bitOp v "SRem" ty [x, y] -doOp v (LSExt from ITBig) [x] = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")" -doOp v (LSExt ITNative to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))" -doOp v (LSExt from ITNative) [x] = v ++ "MKINT((i_int)((" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ "))" -doOp v (LSExt from to) [x] - | intTyWidth from < intTyWidth to = bitCoerce v "S" from to x -doOp v (LZExt ITNative to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ ")" -doOp v (LZExt from ITNative) [x] = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")" -doOp v (LZExt from ITBig) [x] = v ++ "MKBIGUI(vm, " ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")" -doOp v (LZExt from to) [x] - | intTyWidth from < intTyWidth to = bitCoerce v "Z" from to x -doOp v (LTrunc ITNative to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))" -doOp v (LTrunc from ITNative) [x] = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")" -doOp v (LTrunc ITBig to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, mpz_get_ui(GETMPZ(" ++ creg x ++ "))" -doOp v (LTrunc from to) [x] - | intTyWidth from > intTyWidth to = bitCoerce v "T" from to x +doOp v (LSExt (ITFixed from) ITBig) [x] + = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")" +doOp v (LZExt ITNative ITBig) [x] + = v ++ "MKBIGSI(vm, GETINT(" ++ creg x ++ "))" +doOp v (LSExt ITNative (ITFixed to)) [x] + = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))" +doOp v (LSExt ITChar (ITFixed to)) [x] + = doOp v (LSExt ITNative (ITFixed to)) [x] +doOp v (LSExt (ITFixed from) ITNative) [x] + = v ++ "MKINT((i_int)((" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ "))" +doOp v (LSExt (ITFixed from) ITChar) [x] + = doOp v (LSExt (ITFixed from) ITNative) [x] +doOp v (LSExt (ITFixed from) (ITFixed to)) [x] + | nativeTyWidth from < nativeTyWidth to = bitCoerce v "S" from to x +doOp v (LZExt ITNative (ITFixed to)) [x] + = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ ")" +doOp v (LZExt ITChar (ITFixed to)) [x] + = doOp v (LZExt ITNative (ITFixed to)) [x] +doOp v (LZExt (ITFixed from) ITNative) [x] + = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")" +doOp v (LZExt (ITFixed from) ITChar) [x] + = doOp v (LZExt (ITFixed from) ITNative) [x] +doOp v (LZExt (ITFixed from) ITBig) [x] + = v ++ "MKBIGUI(vm, " ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")" +-- doOp v (LZExt ITNative ITBig) [x] +-- = v ++ "MKBIGUI(vm, (uintptr_t)GETINT(" ++ creg x ++ "))" +doOp v (LZExt (ITFixed from) (ITFixed to)) [x] + | nativeTyWidth from < nativeTyWidth to = bitCoerce v "Z" from to x +doOp v (LTrunc ITNative (ITFixed to)) [x] + = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))" +doOp v (LTrunc ITChar (ITFixed to)) [x] + = doOp v (LTrunc ITNative (ITFixed to)) [x] +doOp v (LTrunc (ITFixed from) ITNative) [x] + = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")" +doOp v (LTrunc (ITFixed from) ITChar) [x] + = doOp v (LTrunc (ITFixed from) ITNative) [x] +doOp v (LTrunc ITBig (ITFixed to)) [x] + = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : mpz_get_ui(GETMPZ(" ++ creg x ++ ")))" +doOp v (LTrunc (ITFixed from) (ITFixed to)) [x] + | nativeTyWidth from > nativeTyWidth to = bitCoerce v "T" from to x -doOp v LFExp [x] = v ++ "MKFLOAT(exp(GETFLOAT(" ++ creg x ++ ")))" -doOp v LFLog [x] = v ++ "MKFLOAT(log(GETFLOAT(" ++ creg x ++ ")))" -doOp v LFSin [x] = v ++ "MKFLOAT(sin(GETFLOAT(" ++ creg x ++ ")))" -doOp v LFCos [x] = v ++ "MKFLOAT(cos(GETFLOAT(" ++ creg x ++ ")))" -doOp v LFTan [x] = v ++ "MKFLOAT(tan(GETFLOAT(" ++ creg x ++ ")))" -doOp v LFASin [x] = v ++ "MKFLOAT(asin(GETFLOAT(" ++ creg x ++ ")))" -doOp v LFACos [x] = v ++ "MKFLOAT(acos(GETFLOAT(" ++ creg x ++ ")))" -doOp v LFATan [x] = v ++ "MKFLOAT(atan(GETFLOAT(" ++ creg x ++ ")))" -doOp v LFSqrt [x] = v ++ "MKFLOAT(floor(GETFLOAT(" ++ creg x ++ ")))" -doOp v LFFloor [x] = v ++ "MKFLOAT(ceil(GETFLOAT(" ++ creg x ++ ")))" -doOp v LFCeil [x] = v ++ "MKFLOAT(sqrt(GETFLOAT(" ++ creg x ++ ")))" +doOp v LFExp [x] = v ++ flUnOp "exp" (creg x) +doOp v LFLog [x] = v ++ flUnOp "log" (creg x) +doOp v LFSin [x] = v ++ flUnOp "sin" (creg x) +doOp v LFCos [x] = v ++ flUnOp "cos" (creg x) +doOp v LFTan [x] = v ++ flUnOp "tan" (creg x) +doOp v LFASin [x] = v ++ flUnOp "asin" (creg x) +doOp v LFACos [x] = v ++ flUnOp "acos" (creg x) +doOp v LFATan [x] = v ++ flUnOp "atan" (creg x) +doOp v LFSqrt [x] = v ++ flUnOp "sqrt" (creg x) +doOp v LFFloor [x] = v ++ flUnOp "floor" (creg x) +doOp v LFCeil [x] = v ++ flUnOp "ceil" (creg x) doOp v LStrHead [x] = v ++ "idris_strHead(vm, " ++ creg x ++ ")" doOp v LStrTail [x] = v ++ "idris_strTail(vm, " ++ creg x ++ ")" @@ -380,6 +429,11 @@ doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))" doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)" doOp v (LChInt ITNative) args = v ++ creg (last args) +doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args doOp v (LIntCh ITNative) args = v ++ creg (last args) +doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args doOp v LNoOp args = v ++ creg (last args) doOp _ op _ = "FAIL /* " ++ show op ++ " */" + +flUnOp :: String -> String -> String +flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))" diff --git a/src/IRTS/CodegenCommon.hs b/src/IRTS/CodegenCommon.hs --- a/src/IRTS/CodegenCommon.hs +++ b/src/IRTS/CodegenCommon.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - module IRTS.CodegenCommon where import Core.TT @@ -14,9 +12,4 @@ environment :: String -> IO (Maybe String) environment x = Control.Exception.catch (do e <- getEnv x return (Just e)) -#if MIN_VERSION_base(4,0,0) (\y-> do return (y::SomeException); return Nothing) -#endif -#if !MIN_VERSION_base(4,0,0) - (\_-> return Nothing) -#endif diff --git a/src/IRTS/CodegenJava.hs b/src/IRTS/CodegenJava.hs --- a/src/IRTS/CodegenJava.hs +++ b/src/IRTS/CodegenJava.hs @@ -1,1588 +1,714 @@ -module IRTS.CodegenJava (codegenJava) where - -import Core.TT -import IRTS.BCImp -import IRTS.CodegenCommon -import IRTS.Lang -import IRTS.Simplified -import Paths_idris -import Util.System - -import Control.Applicative -import Control.Arrow -import Control.Monad -import qualified Control.Monad.Trans as T -import Control.Monad.Trans.State -import Data.Char -import Data.Maybe (fromJust) -import Data.List (isPrefixOf, isSuffixOf, intercalate, foldl') -import Data.Int -import qualified Data.Text as T -import qualified Data.Text.IO as TIO -import Language.Java.Parser -import Language.Java.Pretty -import Language.Java.Syntax hiding (Name) -import qualified Language.Java.Syntax as J -import System.Directory -import System.Exit -import System.FilePath -import System.IO -import System.Process - -data CodeGenerationEnv = CodeGenerationEnv { globalVariablePositions :: [(Name, Integer)] } - -type CodeGeneration = StateT (CodeGenerationEnv) (Either String) - -codegenJava :: [(Name, SExp)] -> -- initialization of globals - [(Name, SDecl)] -> - FilePath -> -- output file name - [String] -> -- headers - [String] -> -- libs - OutputType -> - IO () -codegenJava globalInit defs out hdrs libs exec = do - withTempdir (takeBaseName out) $ \ tmpDir -> do - let srcdir = tmpDir "src" "main" "java" - createDirectoryIfMissing True srcdir - let (Ident clsName) = - either error id (evalStateT (mkClassName out) (mkCodeGenEnv globalInit)) - let outjava = srcdir clsName <.> "java" - let jout = either error - (flatIndent . prettyPrint) - (evalStateT (mkCompilationUnit globalInit defs hdrs out) (mkCodeGenEnv globalInit)) - writeFile outjava jout - if (exec == Raw) - then copyFile outjava (takeDirectory out clsName <.> "java") - else do - execPom <- getExecutablePom - execPomTemplate <- TIO.readFile execPom - let execPom = T.replace (T.pack "$MAIN-CLASS$") - (T.pack clsName) - (T.replace (T.pack "$ARTIFACT-NAME$") - (T.pack $ takeBaseName out) - (T.replace (T.pack "$DEPENDENCIES$") - (mkPomDependencies libs) - execPomTemplate - ) - ) - TIO.writeFile (tmpDir "pom.xml") execPom - mvnCmd <- getMvn - let args = ["-f", (tmpDir "pom.xml")] - (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ ["compile"]) "" - when (exit /= ExitSuccess) $ error ("FAILURE: " ++ mvnCmd ++ " compile\n" ++ err ++ mvout) - if (exec == Object) - then do - classFiles <- - map (\ clsFile -> tmpDir "target" "classes" clsFile) - . filter ((".class" ==) . takeExtension) - <$> getDirectoryContents (tmpDir "target" "classes") - mapM_ (\ clsFile -> copyFile clsFile (takeDirectory out takeFileName clsFile)) - classFiles - else do - (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ ["package"]) "" - when (exit /= ExitSuccess) (error ("FAILURE: " ++ mvnCmd ++ " package\n" ++ err ++ mvout)) - copyFile (tmpDir "target" (takeBaseName out) <.> "jar") out - handle <- openBinaryFile out ReadMode - contents <- TIO.hGetContents handle - hClose handle - handle <- openBinaryFile out WriteMode - TIO.hPutStr handle (T.append (T.pack jarHeader) contents) - hFlush handle - hClose handle - perms <- getPermissions out - setPermissions out (setOwnerExecutable True perms) - readProcess mvnCmd (args ++ ["clean"]) "" - removeFile (tmpDir "pom.xml") - -jarHeader :: String -jarHeader = - "#!/bin/sh\n" - ++ "MYSELF=`which \"$0\" 2>/dev/null`\n" - ++ "[ $? -gt 0 -a -f \"$0\" ] && MYSELF=\"./$0\"\n" - ++ "java=java\n" - ++ "if test -n \"$JAVA_HOME\"; then\n" - ++ " java=\"$JAVA_HOME/bin/java\"\n" - ++ "fi\n" - ++ "exec \"$java\" $java_args -jar $MYSELF \"$@\"" - ++ "exit 1\n" - -mkPomDependencies :: [String] -> T.Text -mkPomDependencies deps = - T.concat $ map (T.concat . map (T.append (T.pack " ")) . mkDependency . T.pack) deps - where - mkDependency s = - case T.splitOn (T.pack ":") s of - [g, a, v] -> - [ T.pack $ "\n" - , T.append (T.pack " ") $ mkGroupId g - , T.append (T.pack " ") $ mkArtifactId a - , T.append (T.pack " ") $ mkVersion v - , T.pack $ "\n" - ] - _ -> [] - mkGroupId g = T.append (T.pack $ "") (T.append g $ T.pack "\n") - mkArtifactId a = T.append (T.pack $ "") (T.append a $ T.pack "\n") - mkVersion v = T.append (T.pack $ "") (T.append v $ T.pack "\n") - -mkCodeGenEnv :: [(Name, SExp)] -> CodeGenerationEnv -mkCodeGenEnv globalInit = - CodeGenerationEnv $ zipWith (\ (name, _) pos -> (name, pos)) globalInit [0..] - -mkCompilationUnit :: [(Name, SExp)] -> [(Name, SDecl)] -> [String] -> FilePath -> CodeGeneration CompilationUnit -mkCompilationUnit globalInit defs hdrs out = - CompilationUnit Nothing ( [ ImportDecl False idrisRts True - , ImportDecl True idrisForeign True - , ImportDecl False bigInteger False - , ImportDecl False stringBuffer False - , ImportDecl False runtimeException False - , ImportDecl False scanner False - , ImportDecl False arrays False - ] ++ otherHdrs - ) - <$> mkTypeDecl globalInit defs out - where - idrisRts = J.Name $ map Ident ["org", "idris", "rts"] - idrisForeign = J.Name $ map Ident ["org", "idris", "rts", "ForeignPrimitives"] - bigInteger = J.Name $ map Ident ["java", "math", "BigInteger"] - stringBuffer = J.Name $ map Ident ["java", "lang", "StringBuffer"] - runtimeException = J.Name $ map Ident ["java", "lang", "RuntimeException"] - scanner = J.Name $ map Ident ["java", "util", "Scanner"] - arrays = J.Name $ map Ident ["java", "util", "Arrays"] - otherHdrs = map ( (\ name -> ImportDecl False name False) - . J.Name - . map (Ident . T.unpack) - . T.splitOn (T.pack ".") - . T.pack) - $ filter (not . isSuffixOf ".h") hdrs - -flatIndent :: String -> String -flatIndent (' ' : ' ' : xs) = flatIndent xs -flatIndent (x:xs) = x:flatIndent xs -flatIndent [] = [] - -prefixCallNamespaces :: Ident -> SExp -> SExp -prefixCallNamespaces (Ident name) (SApp tail (NS n ns) args) = SApp tail (NS n (name:ns)) args -prefixCallNamespaces name (SLet var e1 e2) = SLet var (prefixCallNamespaces name e1) (prefixCallNamespaces name e2) -prefixCallNamespaces name (SUpdate var e) = SUpdate var (prefixCallNamespaces name e) -prefixCallNamespaces name (SCase var alts) = SCase var (map (prefixCallNamespacesCase name) alts) -prefixCallNamespaces name (SChkCase var alts) = SChkCase var (map (prefixCallNamespacesCase name) alts) -prefixCallNamespaces _ exp = exp - -prefixCallNamespacesCase :: Ident -> SAlt -> SAlt -prefixCallNamespacesCase name (SConCase x y n ns e) = SConCase x y n ns (prefixCallNamespaces name e) -prefixCallNamespacesCase name (SConstCase c e) = SConstCase c (prefixCallNamespaces name e) -prefixCallNamespacesCase name (SDefaultCase e) = SDefaultCase (prefixCallNamespaces name e) - -prefixCallNamespacesDecl :: Ident -> SDecl -> SDecl -prefixCallNamespacesDecl name (SFun fname args i e) = SFun fname args i (prefixCallNamespaces name e) - -mkTypeDecl :: [(Name, SExp)] -> [(Name, SDecl)] -> FilePath -> CodeGeneration [TypeDecl] -mkTypeDecl globalInit defs out = - (\ name body -> [ClassTypeDecl $ ClassDecl [ Public - , Annotation $ SingleElementAnnotation - (J.Name [Ident "SuppressWarnings"]) - (EVVal . InitExp . Lit $ String "unchecked") - ] - name - [] - Nothing - [] - body]) - <$> mkClassName out - <*> ( mkClassName out - >>= (\ ident -> mkClassBody globalInit (map (second (prefixCallNamespacesDecl ident)) defs)) - ) - -mkClassName :: FilePath -> CodeGeneration Ident -mkClassName path = - T.lift $ left (\ err -> "Parser error in \"" ++ path ++ "\": " ++ (show err)) - (parser ident . takeBaseName $ takeFileName path) - -mkClassBody :: [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration ClassBody -mkClassBody globalInit defs = - (\ globals defs -> ClassBody . (globals++) . addMainMethod . mergeInnerClasses $ defs) - <$> mkGlobalContext globalInit - <*> mapM mkDecl defs - -mkGlobalContext :: [(Name, SExp)] -> CodeGeneration [Decl] -mkGlobalContext [] = return [] -mkGlobalContext initExps = - (\ exps -> [ MemberDecl $ FieldDecl [Private, Static, Final] - objectArrayType - [VarDecl (VarId $ Ident "globalContext") - (Just . InitArray $ ArrayInit exps) - ] - ] - ) - <$> mapM (\ (_, exp) -> InitExp <$> mkExp exp) initExps - - - -addMainMethod :: [Decl] -> [Decl] -addMainMethod decls - | findMain decls = mkMainMethod : decls - | otherwise = decls - where - findMain ((MemberDecl (MemberClassDecl (ClassDecl _ (Ident "Main") _ _ _ (ClassBody body)))):_) = - findMainMethod body - findMain (_:decls) = findMain decls - findMain [] = False - - findMainMethod ((MemberDecl (MethodDecl _ _ _ (Ident "main") [] _ _)):_) = True - findMainMethod (_:decls) = findMainMethod decls - findMainMethod [] = False - -mkMainMethod :: Decl -mkMainMethod = - MemberDecl $ MethodDecl [Public, Static] - [] - Nothing - (Ident "main") - [FormalParam [] stringArrayType False (VarId $ Ident "args")] - [] - (MethodBody . Just $ Block [ BlockStmt . ExpStmt . MethodInv $ - MethodCall (J.Name [Ident "idris_initArgs"]) - [ MethodInv $ TypeMethodCall - (J.Name [Ident "Thread"]) - [] - (Ident "currentThread") - [] - , ExpName $ J.Name [Ident "args"] - ] - , BlockStmt . ExpStmt . MethodInv $ - MethodCall (J.Name [Ident "runMain_0"]) - [] - ] - ) - -mergeInnerClasses :: [Decl] -> [Decl] -mergeInnerClasses = foldl' mergeInner [] - where - mergeInner ((decl@(MemberDecl (MemberClassDecl (ClassDecl priv name targs ext imp (ClassBody body))))):decls) - decl'@(MemberDecl (MemberClassDecl (ClassDecl _ name' _ ext' imp' (ClassBody body')))) - | name == name' = - (MemberDecl $ MemberClassDecl $ - ClassDecl priv - name - targs - (mplus ext ext') - (imp ++ imp') - (ClassBody $ mergeInnerClasses (body ++ body'))) - : decls - | otherwise = decl:(mergeInner decls decl') - mergeInner (decl:decls) decl' = decl:(mergeInner decls decl') - mergeInner [] decl' = [decl'] - - -mkIdentifier :: Name -> CodeGeneration Ident -mkIdentifier (NS name _) = mkIdentifier name -mkIdentifier (MN i name) = (\ (Ident x) -> Ident $ x ++ ('_' : show i)) - <$> mkIdentifier (UN name) -mkIdentifier (UN name) = - T.lift $ left (\ err -> "Parser error in \"" ++ name ++ "\": " ++ (show err)) - ( parser ident - . cleanReserved - . cleanNonLetter - . cleanStart - $ cleanWs False name) - where - cleanStart (x:xs) - | isNumber x = '_' : (x:xs) - | otherwise = (x:xs) - cleanStart [] = [] - cleanNonLetter (x:xs) - | x == '#' = "_Hash" ++ cleanNonLetter xs - | x == '@' = "_At" ++ cleanNonLetter xs - | x == '$' = "_Dollar" ++ cleanNonLetter xs - | x == '!' = "_Bang" ++ cleanNonLetter xs - | x == '.' = "_Dot" ++ cleanNonLetter xs - | x == '\'' = "_Prime" ++ cleanNonLetter xs - | x == '*' = "_Times" ++ cleanNonLetter xs - | x == '+' = "_Plus" ++ cleanNonLetter xs - | x == '/' = "_Divide" ++ cleanNonLetter xs - | x == '-' = "_Minus" ++ cleanNonLetter xs - | x == '%' = "_Mod" ++ cleanNonLetter xs - | x == '<' = "_LessThan" ++ cleanNonLetter xs - | x == '=' = "_Equals" ++ cleanNonLetter xs - | x == '>' = "_MoreThan" ++ cleanNonLetter xs - | x == '[' = "_LSBrace" ++ cleanNonLetter xs - | x == ']' = "_RSBrace" ++ cleanNonLetter xs - | x == '(' = "_LBrace" ++ cleanNonLetter xs - | x == ')' = "_RBrace" ++ cleanNonLetter xs - | x == '_' = "__" ++ cleanNonLetter xs - | not (isAlphaNum x) = "_" ++ (show $ ord x) ++ xs - | otherwise = x:cleanNonLetter xs - cleanNonLetter [] = [] - cleanWs capitalize (x:xs) - | isSpace x = cleanWs True xs - | capitalize = (toUpper x) : (cleanWs False xs) - | otherwise = x : (cleanWs False xs) - cleanWs _ [] = [] - - - cleanReserved "param" = "_param" - cleanReserved "globalContext" = "_globalContext" - cleanReserved "context" = "_context" - cleanReserved "newcontext" = "_newcontext" - - cleanReserved "void" = "_void" - cleanReserved "null" = "_null" - cleanReserved "int" = "_int" - cleanReserved "long" = "_long" - cleanReserved "char" = "_char" - cleanReserved "byte" = "_byte" - cleanReserved "double" = "_double" - cleanReserved "float" = "_float" - cleanReserved "boolean" = "_boolean" - cleanReserved "Object" = "_Object" - cleanReserved "String" = "_String" - cleanReserved "StringBuilder" = "_StringBuilder" - cleanReserved "StringBuffer" = "_StringBuffer" - cleanReserved "Scanner" = "_Scanner" - cleanReserved "Integer" = "_Integer" - cleanReserved "Double" = "_Double" - cleanReserved "Byte" = "_Byte" - cleanReserved "Character" = "_Character" - cleanReserved "BigInteger" = "_BigInteger" - cleanReserved "Boolean" = "_Boolean" - cleanReserved "Closure" = "_Closure" - cleanReserved "IdrisObject" = "_IdrisObject" - cleanReserved "TailCallClosure" = "_TailCallClosure" - cleanReserved "System" = "_System" - cleanReserved "Math" = "_Math" - cleanReserved "Arrays" = "_Arrays" - cleanReserved "RuntimeException" = "_RuntimeException" - cleanReserved "Comparable" = "_Comparable" - - cleanReserved "class" = "_class" - cleanReserved "enum" = "_enum" - cleanReserved "interface" = "_interface" - cleanReserved "extends" = "_extends" - cleanReserved "implements" = "_implements" - cleanReserved "public" = "_public" - cleanReserved "private" = "_private" - cleanReserved "protected" = "_protected" - cleanReserved "static" = "_static" - cleanReserved "final" = "_final" - cleanReserved "abstract" = "_abstract" - cleanReserved "strict" = "_strict" - cleanReserved "volatile" = "_volatile" - cleanReserved "transient" = "_transient" - cleanReserved "native" = "_native" - cleanReserved "const" = "_const" - - cleanReserved "import" = "_import" - cleanReserved "package" = "_package" - - cleanReserved "throw" = "_throw" - cleanReserved "throws" = "_throws" - cleanReserved "try" = "_try" - cleanReserved "catch" = "_catch" - - cleanReserved "synchronized" = "_synchronized" - - cleanReserved "if" = "_if" - cleanReserved "else" = "_else" - cleanReserved "switch" = "_switch" - cleanReserved "case" = "_case" - cleanReserved "default" = "_default" - - cleanReserved "while" = "_while" - cleanReserved "for" = "_for" - cleanReserved "do" = "_do" - cleanReserved "break" = "_break" - cleanReserved "continue" = "_continue" - cleanReserved "goto" = "_goto" - - cleanReserved "this" = "_this" - cleanReserved "super" = "_super" - cleanReserved "new" = "_new" - cleanReserved "return" = "_return" - - cleanReserved "idris_initArgs" = "_idris_initArgs" - cleanReserved "idris_numArgs" = "_idris_numArgs" - cleanReserved "idris_getArg" = "_idris_getArg" - cleanReserved "getenv" = "_getenv" - cleanReserved "exit" = "_exit" - cleanReserved "usleep" = "_usleep" - cleanReserved "idris_sendMessage" = "_idris_sendMessage" - cleanReserved "idris_checkMessage" = "_idris_checkMessage" - cleanReserved "idris_recvMessage" = "_idris_recvMessage" - cleanReserved "putStr" = "_putStr" - cleanReserved "putchar" = "_putchar" - cleanReserved "getchar" = "_getchar" - cleanReserved "fileOpen" = "_fileOpen" - cleanReserved "fileClose" = "_fileClose" - cleanReserved "fputStr" = "_fputStr" - cleanReserved "fileEOF" = "_fileEOF" - cleanReserved "isNull" = "_isNull" - cleanReserved "idris_K" = "_idris_K" - cleanReserved "idris_flipK" = "_idris_flipK" - cleanReserved "idris_assignStack" = "_idris_assignStack" - cleanReserved "free" = "_free" - cleanReserved "malloc" = "_malloc" - cleanReserved "idris_memset" = "_idris_memset" - cleanReserved "idris_peek" = "_idris_peek" - cleanReserved "idris_poke" = "_idris_poke" - cleanReserved "idris_memmove" = "_idris_memmove" - - cleanReserved x = x - -mkName :: Name -> CodeGeneration J.Name -mkName (NS name nss) = (\ n ns -> J.Name (n:ns)) - <$> mkIdentifier name - <*> mapM (mkIdentifier . UN) nss -mkName n = J.Name . (:[]) <$> mkIdentifier n - -voidType :: ClassType -voidType = ClassType [(Ident "Void", [])] - -objectType :: ClassType -objectType = ClassType [(Ident "Object", [])] - -objectArrayType :: Language.Java.Syntax.Type -objectArrayType = RefType . ArrayType . RefType . ClassRefType $ objectType - -idrisClosureType :: ClassType -idrisClosureType = ClassType [(Ident "Closure", [])] - -idrisTailCallClosureType :: ClassType -idrisTailCallClosureType = ClassType [(Ident "TailCallClosure", [])] - -idrisObjectType :: ClassType -idrisObjectType = ClassType [(Ident "IdrisObject", [])] - -contextArray :: LVar -> Exp -contextArray (Loc _) = ExpName $ J.Name [Ident "context"] -contextArray (Glob _) = ExpName $ J.Name [Ident "globalContext"] - -charType :: ClassType -charType = ClassType [(Ident "Character", [])] - -byteType :: ClassType -byteType = ClassType [(Ident "Byte", [])] - -shortType :: ClassType -shortType = ClassType [(Ident "Short", [])] - -integerType :: ClassType -integerType = ClassType [(Ident "Integer", [])] - -longType :: ClassType -longType = ClassType [(Ident "Long", [])] - -nextIntTy :: IntTy -> IntTy -nextIntTy IT8 = IT16 -nextIntTy IT16 = IT32 -nextIntTy IT32 = IT64 -nextIntTy IT64 = IT64 -nextIntTy ITNative = IT64 - -intTyToIdent :: IntTy -> Ident -intTyToIdent IT8 = Ident "Byte" -intTyToIdent IT16 = Ident "Short" -intTyToIdent IT32 = Ident "Integer" -intTyToIdent IT64 = Ident "Long" -intTyToIdent ITNative = Ident "Integer" -intTyToIdent ITBig = Ident "BigInteger" - -intTyToClass :: IntTy -> ClassType -intTyToClass ty = ClassType [(intTyToIdent ty, [])] - -intTyToMethod :: IntTy -> String -intTyToMethod IT8 = "byteValue" -intTyToMethod IT16 = "shortValue" -intTyToMethod IT32 = "intValue" -intTyToMethod IT64 = "longValue" -intTyToMethod ITNative = "intValue" - -intTyToPrimTy :: IntTy -> PrimType -intTyToPrimTy IT8 = ByteT -intTyToPrimTy IT16 = ShortT -intTyToPrimTy IT32 = IntT -intTyToPrimTy IT64 = LongT -intTyToPrimTy ITNative = IntT - -bigIntegerType :: ClassType -bigIntegerType = ClassType [(Ident "BigInteger", [])] - -doubleType :: ClassType -doubleType = ClassType [(Ident "Double", [])] - -stringType :: ClassType -stringType = ClassType [(Ident "String", [])] - -stringArrayType :: Language.Java.Syntax.Type -stringArrayType = RefType . ArrayType . RefType . ClassRefType $ stringType - -exceptionType :: ClassType -exceptionType = ClassType [(Ident "Throwable", [])] - -runtimeExceptionType :: ClassType -runtimeExceptionType = ClassType [(Ident "RuntimeException", [])] - -comparableType :: ClassType -comparableType = ClassType [(Ident "Comparable", [])] - -mkDecl :: (Name, SDecl) -> CodeGeneration Decl -mkDecl ((NS n (ns:nss)), decl) = - (\ name body -> MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body) - <$> mkIdentifier (UN ns) - <*> mkClassBody [] [(NS n nss, decl)] -mkDecl (_, SFun name params stackSize body) = - (\ name params paramNames methodBody -> - MemberDecl $ MethodDecl [Public, Static] - [] - (Just . RefType $ ClassRefType objectType) - name - params - [] - (MethodBody . Just $ Block - [ LocalVars [Final] - objectArrayType - [ VarDecl (VarDeclArray . VarId $ Ident "context") - (Just . InitArray . ArrayInit $ - paramNames - ++ replicate stackSize (InitExp . Lit $ Null)) - ] - , BlockStmt . Return $ Just methodBody - ] - ) - ) - <$> mkIdentifier name - <*> mapM mkFormalParam params - <*> mapM (\ p -> (InitExp . ExpName) <$> mkName p) params - <*> mkExp body - - -mkClosure :: [Name] -> Int -> SExp -> CodeGeneration Exp -mkClosure params stackSize body = - (\ paramArray body -> - InstanceCreation [] - idrisClosureType - [paramArray] - (Just $ ClassBody [body]) - ) - <$> mkStackInit params stackSize - <*> mkClosureCall body - -mkFormalParam :: Name -> CodeGeneration FormalParam -mkFormalParam name = - (\ name -> FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId name)) - <$> mkIdentifier name - -mkClosureCall :: SExp -> CodeGeneration Decl -mkClosureCall body = - (\ body -> MemberDecl $ MethodDecl [Public] [] (Just . RefType $ ClassRefType objectType) (Ident "call") [] [] body) - <$> mkMethodBody body - -mkMethodBody :: SExp -> CodeGeneration MethodBody -mkMethodBody exp = - (\ exp -> MethodBody . Just . Block $ [BlockStmt . Return . Just $ exp]) - <$> mkExp exp - -mkStackInit :: [Name] -> Int -> CodeGeneration Exp -mkStackInit params stackSize = - (\ localVars -> ArrayCreateInit objectArrayType 0 . ArrayInit $ - (map (InitExp . ExpName) localVars) - ++ (replicate (stackSize) (InitExp $ Lit Null))) - <$> mapM mkName params - -mkK :: Exp -> Exp -> Exp -mkK result drop = - MethodInv $ MethodCall (J.Name [Ident "idris_K"]) [ result, drop ] - -mkFlipK :: Exp -> Exp -> Exp -mkFlipK drop result = - MethodInv $ MethodCall (J.Name [Ident "idris_flipK"]) [ drop, result ] - -mkLet :: LVar -> SExp -> SExp -> CodeGeneration Exp -mkLet (Loc pos) oldExp newExp = - (\ oldExp newExp -> - mkFlipK ( Assign ( ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "context"]) - (Lit $ Int (toInteger pos))) - EqualA - newExp - ) - oldExp - ) - <$> mkExp oldExp - <*> mkExp newExp -mkLet (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable" - -reverseNameSpace :: J.Name -> J.Name -reverseNameSpace (J.Name ids) = - J.Name ((tail ids) ++ [head ids]) - -mkCase :: Bool -> LVar -> [SAlt] -> CodeGeneration Exp -mkCase checked var ((SConCase parentStackPos consIndex _ params branchExpression):cases) = - mkConsCase checked - var - parentStackPos - consIndex - params - branchExpression - (SCase var cases) -mkCase checked var (c@(SConstCase constant branchExpression):cases) = - (\ constant branchExpression alternative var-> - Cond ( MethodInv $ PrimaryMethodCall (constant) - [] - (Ident "equals") - [var] - ) - branchExpression - alternative - ) - <$> mkExp (SConst constant) - <*> mkExp branchExpression - <*> mkCase checked var cases - <*> mkVarAccess Nothing var -mkCase checked var (SDefaultCase exp:cases) = mkExp exp -mkCase checked _ [] = mkExp (SError "Non-exhaustive pattern") - -mkConsCase :: Bool -> LVar -> Int -> Int -> [Name] -> SExp -> SExp -> CodeGeneration Exp -mkConsCase checked - toDeconstruct - parentStackStart - consIndex - params - branchExpression - alternative = - (\ caseBinding alternative var varCasted-> - Cond (BinOp (InstanceOf (var) - (ClassRefType idrisObjectType) - ) - CAnd - ( BinOp - ( MethodInv $ PrimaryMethodCall (varCasted) - [] - (Ident "getConstructorId") - [] - ) - Equal - (Lit $ Int (toInteger consIndex)) - ) - ) - (caseBinding) - alternative - ) - <$> mkCaseBinding checked toDeconstruct parentStackStart params branchExpression - <*> mkExp alternative - <*> mkVarAccess (Nothing) toDeconstruct - <*> mkVarAccess (Just idrisObjectType) toDeconstruct - - -mkCaseBinding :: Bool -> LVar -> Int -> [Name] -> SExp -> CodeGeneration Exp -mkCaseBinding True var parentStackStart params branchExpression = - (\ branchExpression deconstruction -> - mkFlipK (MethodInv $ MethodCall (J.Name [Ident "idris_assignStack"]) - ( (ExpName $ J.Name [Ident "context"]) - : (Lit $ Int (toInteger parentStackStart)) - : deconstruction - )) - (branchExpression) - ) - <$> mkExp branchExpression - <*> mkCaseBindingDeconstruction var params -mkCaseBinding False var parentStackStart params branchExpression = - (\ bindingMethod deconstruction -> - MethodInv $ PrimaryMethodCall - ( MethodInv $ PrimaryMethodCall (InstanceCreation [] - (ClassType [(Ident "Object", [])]) - [] - (Just $ ClassBody [MemberDecl $ bindingMethod]) - ) - [] - (Ident "apply") - ( contextArray (Loc undefined) : deconstruction ) - ) - [] - (Ident "call") - [] - ) - <$> mkCaseBindingMethod parentStackStart params branchExpression - <*> mkCaseBindingDeconstruction var params - -mkCaseBindingDeconstruction :: LVar -> [Name] -> CodeGeneration [Exp] -mkCaseBindingDeconstruction var members = - mapM (mkProjection var) ([0..(length members - 1)]) - -mkCaseBindingMethod :: Int -> [Name] -> SExp -> CodeGeneration MemberDecl -mkCaseBindingMethod parentStackStart params branchExpression = - (\ formalParams caseBindingStack branchExpression -> - MethodDecl [Final, Public] - [] - (Just . RefType $ ClassRefType idrisClosureType) - (Ident "apply") - (mkContextParam:formalParams) - [] - (MethodBody . Just . Block $ - caseBindingStack ++ - [BlockStmt . Return $ Just branchExpression])) - <$> mapM mkFormalParam params - <*> mkBindingStack False parentStackStart params - <*> mkBindingClosure branchExpression - -mkContextParam :: FormalParam -mkContextParam = - FormalParam [Final] (objectArrayType) False (VarId (Ident "context")) - -mkBindingClosure :: SExp -> CodeGeneration Exp -mkBindingClosure oldExp = - (\ oldCall -> - InstanceCreation [] - idrisClosureType - [ ExpName $ J.Name [Ident "new_context"] ] - (Just $ ClassBody [oldCall]) - ) - <$> mkClosureCall oldExp - - -mkBindingStack :: Bool -> Int -> [Name] -> CodeGeneration [BlockStmt] -mkBindingStack checked parentStackStart params = - (\ paramNames -> - ( LocalVars [Final] - objectArrayType - [ VarDecl (VarDeclArray . VarId $ Ident "new_context") - (Just . InitExp $ mkContextCopy checked parentStackStart params) - ]) - : ( map (\ (param, pos) -> - BlockStmt . ExpStmt $ - Assign (ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "new_context"]) - (Lit $ Int (toInteger pos))) - EqualA - (ExpName param)) $ zip paramNames [parentStackStart..] - ) - ) - <$> mapM mkName params - -mkContextCopy :: Bool -> Int -> [Name] -> Exp -mkContextCopy True parentStackStart params = - MethodInv $ PrimaryMethodCall (ExpName $ J.Name [Ident "context"]) - [] - (Ident "clone") - [] -mkContextCopy False parentStackStart params = - MethodInv $ TypeMethodCall (J.Name [Ident "Arrays"]) - [] - (Ident "copyOf") - [ ExpName $ J.Name [Ident "context"] - , MethodInv - $ TypeMethodCall (J.Name [Ident "Math"]) - [] - (Ident "max") - [ FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "context"]) - (Ident "length") - , Lit . Int $ toInteger (parentStackStart + length params) - ] - ] - -mkProjection :: LVar -> Int -> CodeGeneration Exp -mkProjection var memberNr = - (\ var -> ArrayAccess $ ArrayIndex ( MethodInv $ PrimaryMethodCall - (var) - [] - (Ident "getData") - [] - ) - (Lit $ Int (toInteger memberNr)) - ) - <$> mkVarAccess (Just idrisObjectType) var - -type ClassName = String - -mkPrimitive :: ClassName -> Literal -> Exp -mkPrimitive className value = - MethodInv $ TypeMethodCall (J.Name [Ident className]) - [] - (Ident "valueOf") - [Lit $ value] - -mkClass :: ClassType -> Exp -mkClass classType = - ClassLit . Just . RefType .ClassRefType $ classType - -mkBinOpExp :: ClassType -> Op -> [LVar] -> CodeGeneration Exp -mkBinOpExp castTo op (var:vars) = do - start <- mkVarAccess (Just castTo) var - foldM (\ exp var -> BinOp exp op <$> mkVarAccess (Just castTo) var) start vars - -mkBinOpExpTrans :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> Op -> [LVar] -> CodeGeneration Exp -mkBinOpExpTrans opTransformation resultTransformation castTo op (var:vars) = do - start <- (mkVarAccess (Just castTo) var) - foldM (\ exp var -> resultTransformation - . BinOp (opTransformation exp) op - . opTransformation - <$> mkVarAccess (Just castTo) var) - start - vars - -mkBinOpExpConv :: String -> PrimType -> ClassType -> Op -> [LVar] -> CodeGeneration Exp -mkBinOpExpConv fromMethodName toType fromType@(ClassType [(cls@(Ident _), [])]) op args = - mkBinOpExpTrans (\ exp -> MethodInv $ TypeMethodCall (J.Name [cls]) - [] - (Ident fromMethodName) - [exp] - ) - (\ exp -> MethodInv $ TypeMethodCall (J.Name [cls]) - [] - (Ident "valueOf") - [Cast (PrimType $ toType) exp] - ) - fromType - op - args - -mkLogicalBinOpExp :: ClassType -> Op -> [LVar] -> CodeGeneration Exp -mkLogicalBinOpExp castTo op (var:vars) = do - start <- mkVarAccess (Just castTo) var - foldM (\ exp var -> mkBoolToNumber castTo . BinOp exp op <$> mkVarAccess (Just castTo) var) - start - vars - -mkMethodOpChain1 :: (Exp -> Exp) -> ClassType -> String -> [LVar] -> CodeGeneration Exp -mkMethodOpChain1 = mkMethodOpChain id - -mkMethodOpChain :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> String -> [LVar] -> CodeGeneration Exp -mkMethodOpChain initialTransformation resultTransformation castTo method (arg:args) = do - start <- initialTransformation <$> mkVarAccess (Just $ castTo) arg - foldM (\ exp arg' -> - resultTransformation - . MethodInv - . PrimaryMethodCall exp [] (Ident method) - . (:[]) - <$> mkVarAccess (Just $ castTo) arg' - ) - start - args - -mkBoolToNumber :: ClassType -> Exp -> Exp -mkBoolToNumber (ClassType [(Ident name, [])]) boolExp = - Cond boolExp (mkPrimitive name (Int 1)) (mkPrimitive name (Int 0)) - -mkZeroExt :: String -> Int -> ClassType -> ClassType -> LVar -> CodeGeneration Exp -mkZeroExt toMethod bits fromType toType@(ClassType [(toTypeName, [])]) var = do - (\ var sext -> - MethodInv $ TypeMethodCall (J.Name [toTypeName]) - [] - (Ident "valueOf") - [ Cond ( BinOp (var) - LThan - (Lit $ Int 0) - ) - ( BinOp (Lit $ Int (2^bits)) - Add - (sext) - ) - sext - ] - ) - <$> mkVarAccess (Just $ fromType) var - <*> mkSignedExt' toMethod fromType var - -mkSignedExt :: String -> ClassType -> ClassType -> LVar -> CodeGeneration Exp -mkSignedExt toMethod fromType (ClassType [(toTypeName, [])]) var = - (\ sext -> MethodInv $ TypeMethodCall (J.Name [toTypeName]) - [] - (Ident "valueOf") - [ sext ] - ) - <$> mkSignedExt' toMethod fromType var - -mkSignedExt' :: String -> ClassType -> LVar -> CodeGeneration Exp -mkSignedExt' toMethod fromType var = - (\ var -> MethodInv $ PrimaryMethodCall (var) - [] - (Ident toMethod) - [] - ) - <$> mkVarAccess (Just $ fromType) var - -data SPartialOrder - = SLt - | SLe - | SEq - | SGe - | SGt - -mkPartialOrder :: SPartialOrder -> Exp -> Exp -mkPartialOrder SLt x = (BinOp (Lit $ Int (-1)) Equal x) -mkPartialOrder SLe x = - BinOp (BinOp (Lit $ Int (-1)) Equal x) - COr - (BinOp (Lit $ Int 0) Equal x) -mkPartialOrder SEq x = BinOp (Lit $ Int 0) Equal x -mkPartialOrder SGe x = - BinOp (BinOp (Lit $ Int 1) Equal x) - COr - (BinOp (Lit $ Int 0) Equal x) -mkPartialOrder SGt x = (BinOp (Lit $ Int 1) Equal x) - -varPos :: LVar -> CodeGeneration Integer -varPos (Loc i) = return (toInteger i) -varPos (Glob name) = do - positions <- globalVariablePositions <$> get - case lookup name positions of - (Just pos) -> return pos - Nothing -> T.lift . Left $ "Invalid global variable id: " ++ show name - -mkVarAccess :: Maybe ClassType -> LVar -> CodeGeneration Exp -mkVarAccess Nothing var = - (\ pos -> ArrayAccess $ ArrayIndex (contextArray var) (Lit $ Int pos)) - <$> varPos var -mkVarAccess (Just castTo) var = - Cast (RefType . ClassRefType $ castTo) <$> (mkVarAccess Nothing var) - -mkPrimitiveCast :: ClassType -> ClassType -> LVar -> CodeGeneration Exp -mkPrimitiveCast fromType (ClassType [(toType, [])]) var = - (\ var -> - MethodInv $ TypeMethodCall (J.Name [toType]) - [] - (Ident "valueOf") - [var] - ) - <$> mkVarAccess (Just fromType) var - -mkToString :: ClassType -> LVar -> CodeGeneration Exp -mkToString castTo var = - (\ var -> MethodInv $ PrimaryMethodCall (var) - [] - (Ident "toString") - [] - ) - <$> mkVarAccess (Just castTo) var -data Std = In | Out | Err - -instance Show Std where - show In = "in" - show Out = "out" - show Err = "err" - -mkSystemStd :: Std -> Exp -mkSystemStd std = FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "System"]) (Ident $ show std) - -mkSystemOutPrint :: Exp -> Exp -mkSystemOutPrint value = - MethodInv $ PrimaryMethodCall (mkSystemStd Out) - [] - (Ident "print") - [value] - -mkMathFun :: String -> LVar -> CodeGeneration Exp -mkMathFun funName var = - (\ var -> MethodInv $ TypeMethodCall (J.Name [Ident "Double"]) - [] - (Ident "valueOf") - [ MethodInv $ TypeMethodCall (J.Name [Ident "Math"]) - [] - (Ident funName) - [var] - ] - ) - <$> mkVarAccess (Just doubleType) var - -mkStringAtIndex :: LVar -> Exp -> CodeGeneration Exp -mkStringAtIndex var indexExp = - (\ var -> MethodInv $ TypeMethodCall (J.Name [Ident "Integer"]) - [] - (Ident "valueOf") - [ MethodInv $ PrimaryMethodCall (var) - [] - (Ident "charAt") - [indexExp] - ] - ) - <$> mkVarAccess (Just stringType) var - -mkForeignType :: FType -> Maybe ClassType -mkForeignType (FInt ty) = return (intTyToClass ty) -mkForeignType FChar = return integerType -mkForeignType FString = return stringType -mkForeignType FPtr = return objectType -mkForeignType FDouble = return doubleType -mkForeignType FAny = return objectType -mkForeignType FUnit = Nothing - -mkForeignVarAccess :: FType -> LVar -> CodeGeneration Exp -mkForeignVarAccess (FInt ty) var = - (\ var -> MethodInv $ PrimaryMethodCall var - [] - (Ident (intTyToMethod ty)) - [] - ) - <$> mkVarAccess (Just $ intTyToClass ty) var -mkForeignVarAccess FChar var = Cast (PrimType CharT) <$> mkForeignVarAccess (FInt IT32) var -mkForeignVarAccess FDouble var = - (\ var -> MethodInv $ PrimaryMethodCall (var) - [] - (Ident "doubleValue") - [] - ) - <$> mkVarAccess (Just doubleType) var -mkForeignVarAccess otherType var = mkVarAccess (mkForeignType otherType) var - -mkFromForeignType :: FType -> Exp -> Exp -mkFromForeignType (FInt ty) from = - MethodInv $ TypeMethodCall (J.Name [intTyToIdent ty]) - [] - (Ident "valueOf") - [from] -mkFromForeignType FChar from = mkFromForeignType (FInt IT32) from -mkFromForeignType FDouble from = - MethodInv $ TypeMethodCall (J.Name [Ident "Double"]) - [] - (Ident "valueOf") - [from] -mkFromForeignType _ from = from - -mkForeignInvoke :: FType -> String -> [(FType, LVar)] -> CodeGeneration Exp -mkForeignInvoke fType method args = - (\ foreignInvokeMeth -> - MethodInv $ PrimaryMethodCall (InstanceCreation [] - objectType - [] - (Just $ ClassBody [ MemberDecl $ foreignInvokeMeth ]) - ) - [] - (Ident "foreignInvoke") - [] - ) - <$> mkForeignInvokeMethod fType method args - - -mkForeignInvokeMethod :: FType -> String -> [(FType, LVar)] -> CodeGeneration MemberDecl -mkForeignInvokeMethod fType method args = - (\ tryBlock -> - MethodDecl [Public, Final] - [] - (Just . RefType $ ClassRefType objectType) - (Ident "foreignInvoke") - [] - [] - (MethodBody . Just $ Block - [ BlockStmt - $ Try tryBlock - [ Catch (FormalParam [] - (RefType $ ClassRefType exceptionType) - False - (VarId $ Ident "ex") - ) - (Block [ BlockStmt - . Throw - $ InstanceCreation [] - runtimeExceptionType - [ExpName $ J.Name [Ident "ex"]] - Nothing - ] - ) - ] - Nothing - ] - ) - ) - <$> mkForeignInvokeTryBlock fType method args - - -mkForeignInvokeTryBlock :: FType -> String -> [(FType, LVar)] -> CodeGeneration Block -mkForeignInvokeTryBlock FUnit method args = - (\ method args -> Block [ BlockStmt . ExpStmt . MethodInv $ MethodCall method args - , BlockStmt $ Return (Just $ Lit Null) - ] - ) - <$> ( T.lift $ left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err)) - (parser name method) - ) - <*> mapM (uncurry mkForeignVarAccess) args -mkForeignInvokeTryBlock fType method args = - (\ method args -> Block [ BlockStmt . Return - . Just - . mkFromForeignType fType - . MethodInv - $ MethodCall method args - ] - ) - <$> ( T.lift $ left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err)) - (parser name method) - ) - <*> mapM (uncurry mkForeignVarAccess) args - -mkMethodClosure :: Name -> [LVar] -> CodeGeneration Exp -mkMethodClosure name args = - (\ name args -> - InstanceCreation [] - idrisClosureType - [ (ExpName $ J.Name [Ident "context"]) ] - ( Just - $ ClassBody - [ MemberDecl - $ MethodDecl [Public, Final] - [] - (Just . RefType $ ClassRefType objectType) - (Ident "call") - [] - [] - ( MethodBody - . Just - $ Block [ BlockStmt - . Return - . Just - . MethodInv - $ MethodCall (reverseNameSpace name) - args - ] - ) - ] - ) - ) - <$> mkName name - <*> mapM (mkExp . SV) args - -mkThread :: LVar -> CodeGeneration Exp -mkThread arg = - (\ eval -> - MethodInv - $ PrimaryMethodCall (InstanceCreation [] - (ClassType [(Ident "Thread", [])]) - [ eval ] - ( Just - $ ClassBody [ MemberDecl - $ MethodDecl [Public, Final] - [] - (Just . RefType $ ClassRefType objectType) - (Ident "_start") - [] - [] - ( MethodBody - . Just - $ Block [ BlockStmt - . ExpStmt - . MethodInv - $ MethodCall (J.Name [Ident "start"]) - [] - , BlockStmt - . Return - . Just - $ This - ] - ) - ] - ) - ) - [] - (Ident "_start") - [] - ) - <$> mkThreadBinding arg - -mkThreadBinding :: LVar -> CodeGeneration Exp -mkThreadBinding var = - (\ bindingMethod var -> - MethodInv $ PrimaryMethodCall ( InstanceCreation [] - objectType - [] - (Just $ ClassBody [MemberDecl $ bindingMethod]) - ) - [] - (Ident "apply") - [ var ] - ) - <$> mkThreadBindingMethod - <*> mkVarAccess Nothing var - - -mkThreadBindingMethod :: CodeGeneration MemberDecl -mkThreadBindingMethod = - (\ compute -> - MethodDecl [Final, Public] - [] - (Just . RefType $ ClassRefType idrisClosureType) - (Ident "apply") - [ FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId $ Ident "param") ] - [] - (MethodBody . Just $ Block - [ mkThreadBindingStack - , BlockStmt . Return $ Just compute - ] - ) - ) - <$> mkBindingClosure (SUpdate (Loc 0) (SApp False (MN 0 "EVAL") [Loc 0])) - - -mkThreadBindingStack :: BlockStmt -mkThreadBindingStack = - LocalVars [Final] - objectArrayType - [ VarDecl (VarDeclArray . VarId $ Ident "new_context") - (Just . InitArray $ ArrayInit [InitExp . ExpName $ J.Name [Ident "param"]]) - ] - - -mkExp :: SExp -> CodeGeneration Exp -mkExp (SV var) = mkVarAccess Nothing var -mkExp (SApp False name args) = - (\ methClosure -> - MethodInv $ PrimaryMethodCall ( InstanceCreation [] - idrisTailCallClosureType - [ methClosure ] - Nothing - ) - [] - (Ident "call") - [] - ) - <$> mkMethodClosure name args -mkExp (SApp True name args) = - (\ methClosure -> - ( InstanceCreation [] - idrisTailCallClosureType - [ methClosure ] - Nothing - ) - ) - <$> mkMethodClosure name args -mkExp (SLet var new old) = - mkLet var old new -mkExp (SUpdate var exp) = - (\ rhs varPos -> Assign (ArrayLhs $ ArrayIndex (contextArray var) (Lit $ Int varPos)) - EqualA - rhs - ) - <$> mkExp exp - <*> varPos var -mkExp (SCon conId name args) = - (\ args -> InstanceCreation [] - idrisObjectType - ((Lit $ Int (toInteger conId)):args) - Nothing) - <$> mapM (mkExp .SV) args -mkExp (SCase var alts) = mkCase False var alts -mkExp (SChkCase var alts) = mkCase True var alts -mkExp (SProj var i) = mkProjection var i -mkExp (SConst (I x)) = - let x' :: Int32; x' = fromInteger (toInteger x) in - return $ mkPrimitive "Integer" (Int (fromInteger (toInteger x'))) -mkExp (SConst (BI x)) = - return $ InstanceCreation [] - (ClassType [(Ident "BigInteger", [])]) - [Lit $ String (show x)] - Nothing -mkExp (SConst (Fl x)) = return $ mkPrimitive "Double" (Double x) -mkExp (SConst (Ch x)) = return $ mkPrimitive "Integer" (Char x) -mkExp (SConst (Str x)) = return $ Lit $ String x -mkExp (SConst IType) = return $ mkClass integerType -mkExp (SConst BIType) = return $ mkClass bigIntegerType -mkExp (SConst FlType) = return $ mkClass doubleType -mkExp (SConst ChType) = return $ mkClass charType -mkExp (SConst StrType) = return $ mkClass stringType -mkExp (SConst (B8 x)) = return $ mkPrimitive "Byte" (String (show x)) -mkExp (SConst (B16 x)) = return $ mkPrimitive "Short" (String (show x)) -mkExp (SConst (B32 x)) = return $ mkPrimitive "Integer" (Int (toInteger x)) -mkExp (SConst (B64 x)) = return $ mkPrimitive "Long" (String (show x)) -mkExp (SConst (B8Type))= return $ mkClass byteType -mkExp (SConst (B16Type)) = return $ mkClass shortType -mkExp (SConst (B32Type)) = return $ mkClass integerType -mkExp (SConst (B64Type)) = return $ mkClass longType -mkExp (SConst (PtrType)) = return $ mkClass objectType -mkExp (SConst (VoidType)) = return $ mkClass voidType -mkExp (SConst (Forgot)) = return $ mkClass objectType -mkExp (SForeign _ fType meth args) = mkForeignInvoke fType meth args -mkExp (SOp (LPlus ITNative) args) = mkExp (SOp (LPlus IT32) args) -mkExp (SOp (LMinus ITNative) args) = mkExp (SOp (LMinus IT32) args) -mkExp (SOp (LTimes ITNative) args) = mkExp (SOp (LTimes IT32) args) -mkExp (SOp (LSDiv ITNative) args) = mkExp (SOp (LSDiv IT32) args) -mkExp (SOp (LSRem ITNative) args) = mkExp (SOp (LSRem IT32) args) -mkExp (SOp (LAnd ITNative) args) = mkExp (SOp (LAnd IT32) args) -mkExp (SOp (LOr ITNative) args) = mkExp (SOp (LOr IT32) args) -mkExp (SOp (LXOr ITNative) args) = mkExp (SOp (LXOr IT32) args) -mkExp (SOp (LCompl ITNative) args) = mkExp (SOp (LCompl IT32) args) -mkExp (SOp (LSHL ITNative) args) = mkExp (SOp (LSHL IT32) args) -mkExp (SOp (LASHR ITNative) args) = mkExp (SOp (LASHR IT32) args) -mkExp (SOp (LEq ITNative) args) = mkExp (SOp (LEq IT32) args) -mkExp (SOp (LLt ITNative) args) = mkExp (SOp (LLt IT32) args) -mkExp (SOp (LLe ITNative) args) = mkExp (SOp (LLe IT32) args) -mkExp (SOp (LGt ITNative) args) = mkExp (SOp (LGt IT32) args) -mkExp (SOp (LGe ITNative) args) = mkExp (SOp (LGe IT32) args) -mkExp (SOp LFPlus args) = mkBinOpExp doubleType Add args -mkExp (SOp LFMinus args) = mkBinOpExp doubleType Sub args -mkExp (SOp LFTimes args) = mkBinOpExp doubleType Mult args -mkExp (SOp LFDiv args) = mkBinOpExp doubleType Div args -mkExp (SOp LFEq args) = - mkMethodOpChain1 (mkBoolToNumber doubleType) doubleType "equals" args -mkExp (SOp LFLt args) = mkLogicalBinOpExp integerType LThan args -mkExp (SOp LFLe args) = mkLogicalBinOpExp integerType LThanE args -mkExp (SOp LFGt args) = mkLogicalBinOpExp integerType GThan args -mkExp (SOp LFGe args) = mkLogicalBinOpExp integerType GThanE args -mkExp (SOp (LPlus ITBig) args) = mkMethodOpChain1 id bigIntegerType "add" args -mkExp (SOp (LMinus ITBig) args) = mkMethodOpChain1 id bigIntegerType "subtract" args -mkExp (SOp (LTimes ITBig) args) = mkMethodOpChain1 id bigIntegerType "multiply" args -mkExp (SOp (LSDiv ITBig) args) = mkMethodOpChain1 id bigIntegerType "divide" args -mkExp (SOp (LSRem ITBig) args) = mkMethodOpChain1 id bigIntegerType "mod" args -mkExp (SOp (LEq ITBig) args) = - mkMethodOpChain1 (mkBoolToNumber bigIntegerType) bigIntegerType "equals" args -mkExp (SOp (LLt ITBig) args) = - mkMethodOpChain1 ( mkBoolToNumber bigIntegerType - . mkPartialOrder SLt - ) - bigIntegerType - "compareTo" - args -mkExp (SOp (LLe ITBig) args) = - mkMethodOpChain1 ( mkBoolToNumber bigIntegerType - . mkPartialOrder SLe - ) - bigIntegerType - "compareTo" - args -mkExp (SOp (LGt ITBig) args) = - mkMethodOpChain1 ( mkBoolToNumber bigIntegerType - . mkPartialOrder SGt - ) - bigIntegerType - "compareTo" - args -mkExp (SOp (LGe ITBig) args) = - mkMethodOpChain1 ( mkBoolToNumber bigIntegerType - . mkPartialOrder SGe - ) - bigIntegerType - "compareTo" - args -mkExp (SOp LStrConcat args) = - mkMethodOpChain (\ exp -> InstanceCreation [] - (ClassType [(Ident "StringBuilder", [])]) - [exp] - Nothing - ) - (\ exp -> MethodInv $ PrimaryMethodCall exp [] (Ident "toString") []) - stringType - "append" - args -mkExp (SOp LStrLt args@[_, _]) = - mkMethodOpChain1 ( mkBoolToNumber integerType - . mkPartialOrder SLt - ) - stringType - "compareTo" - args -mkExp (SOp LStrEq args@[_, _]) = - mkMethodOpChain1 ( mkBoolToNumber integerType) - stringType - "equals" - args -mkExp (SOp LStrLen [arg]) = - (\ var -> MethodInv $ PrimaryMethodCall var [] (Ident "length") []) - <$> mkVarAccess (Just stringType) arg -mkExp (SOp (LIntFloat ity) [arg]) = - mkPrimitiveCast (intTyToClass ity) doubleType arg -mkExp (SOp (LFloatInt ity) [arg]) = - mkPrimitiveCast doubleType (intTyToClass ity) arg -mkExp (SOp (LIntStr ITBig) [arg]) = - (\ var -> InstanceCreation [] bigIntegerType [var] Nothing) - <$> mkVarAccess (Just stringType) arg -mkExp (SOp (LIntStr ity) [arg]) = - mkToString (intTyToClass ity) arg -mkExp (SOp (LStrInt ity) [arg]) = - mkPrimitiveCast stringType (intTyToClass ity) arg -mkExp (SOp LFloatStr [arg]) = - mkToString doubleType arg -mkExp (SOp LStrFloat [arg]) = - mkPrimitiveCast doubleType stringType arg -mkExp (SOp (LSExt ITNative ITBig) [arg]) = - mkPrimitiveCast integerType bigIntegerType arg -mkExp (SOp (LTrunc ITBig ITNative) [arg]) = - mkPrimitiveCast bigIntegerType integerType arg -mkExp (SOp (LChInt ITNative) [arg]) = - mkVarAccess (Just integerType) arg -mkExp (SOp (LIntCh ITNative) [arg]) = - mkVarAccess (Just integerType) arg -mkExp (SOp LPrintNum [arg]) = - mkSystemOutPrint <$> (mkVarAccess Nothing arg) -mkExp (SOp LPrintStr [arg]) = - mkSystemOutPrint <$> (mkVarAccess (Just stringType) arg) -mkExp (SOp LReadStr [arg]) = mkExp (SForeign LANG_C FString "idris_readStr" [(FPtr, arg)]) -mkExp (SOp (LLt ty) args) = mkLogicalBinOpExp (intTyToClass ty) LThan args -mkExp (SOp (LLe ty) args) = mkLogicalBinOpExp (intTyToClass ty) LThanE args -mkExp (SOp (LEq ty) args) = - mkMethodOpChain1 (mkBoolToNumber (intTyToClass ty)) (intTyToClass ty) "equals" args -mkExp (SOp (LGt ty) args) = mkLogicalBinOpExp (intTyToClass ty) GThan args -mkExp (SOp (LGe ty) args) = mkLogicalBinOpExp (intTyToClass ty) GThanE args -mkExp (SOp (LPlus ty) args) = mkBinOpExp (intTyToClass ty) Add args -mkExp (SOp (LMinus ty) args) = mkBinOpExp (intTyToClass ty) Sub args -mkExp (SOp (LTimes ty) args) = mkBinOpExp (intTyToClass ty) Mult args -mkExp (SOp (LUDiv IT64) (arg:args)) = do - (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args) - return $ foldl (\ exp arg -> - MethodInv $ PrimaryMethodCall - ( MethodInv $ PrimaryMethodCall - ( MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"]) - [] - (Ident "valueOf") - [ exp ] - ) - [] - (Ident "divide") - [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"]) - [] - (Ident "valueOf") - [ arg ] - ] - ) - [] - (Ident "longValue") - [] - ) - arg - args -mkExp (SOp (LUDiv ty) args) = - mkBinOpExpConv (intTyToMethod $ nextIntTy ty) - (intTyToPrimTy $ nextIntTy ty) - (intTyToClass ty) - Div - args -mkExp (SOp (LSDiv ty) args) = mkBinOpExp (intTyToClass ty) Div args -mkExp (SOp (LURem IT64) (arg:args)) = do - (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args) - return $ foldl (\ exp arg -> - MethodInv $ PrimaryMethodCall - ( MethodInv $ PrimaryMethodCall - ( MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"]) - [] - (Ident "valueOf") - [ exp ] - ) - [] - (Ident "remainder") - [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"]) - [] - (Ident "valueOf") - [ arg ] - ] - ) - [] - (Ident "longValue") - [] - ) - arg - args -mkExp (SOp (LURem ty) args) = - mkBinOpExpConv (intTyToMethod $ nextIntTy ty) - (intTyToPrimTy $ nextIntTy ty) - (intTyToClass ty) - Rem - args -mkExp (SOp (LSRem ty) args) = mkBinOpExp (intTyToClass ty) Rem args -mkExp (SOp (LSHL ty) args) = mkBinOpExp (intTyToClass ty) LShift args -mkExp (SOp (LLSHR ty) args) = mkBinOpExp (intTyToClass ty) RRShift args -mkExp (SOp (LASHR ty) args) = mkBinOpExp (intTyToClass ty) RShift args -mkExp (SOp (LAnd ty) args) = mkBinOpExp (intTyToClass ty) And args -mkExp (SOp (LOr ty) args) = mkBinOpExp (intTyToClass ty) Or args -mkExp (SOp (LXOr ty) args) = mkBinOpExp (intTyToClass ty) Xor args -mkExp (SOp (LCompl ty) [var]) = PreBitCompl <$> mkVarAccess (Just $ intTyToClass ty) var -mkExp (SOp (LZExt from to) [var]) - | intTyWidth from < intTyWidth to - = mkZeroExt (intTyToMethod to) (intTyWidth from) (intTyToClass from) (intTyToClass to) var -mkExp (SOp (LSExt from to) [var]) - | intTyWidth from < intTyWidth to - = mkSignedExt (intTyToMethod to) (intTyToClass from) (intTyToClass to) var -mkExp (SOp (LTrunc from to) [var]) - | intTyWidth from > intTyWidth to - = (\ var -> MethodInv $ - TypeMethodCall (J.Name [intTyToIdent to]) - [] - (Ident "valueOf") - [ MethodInv - $ PrimaryMethodCall var [] (Ident (intTyToMethod to)) [] ] - ) - <$> mkVarAccess (Just $ intTyToClass from) var -mkExp (SOp LFExp [arg]) = mkMathFun "exp" arg -mkExp (SOp LFLog [arg]) = mkMathFun "log" arg -mkExp (SOp LFSin [arg]) = mkMathFun "sin" arg -mkExp (SOp LFCos [arg]) = mkMathFun "cos" arg -mkExp (SOp LFTan [arg]) = mkMathFun "tan" arg -mkExp (SOp LFASin [arg]) = mkMathFun "asin" arg -mkExp (SOp LFACos [arg]) = mkMathFun "acos" arg -mkExp (SOp LFATan [arg]) = mkMathFun "atan" arg -mkExp (SOp LFSqrt [arg]) = mkMathFun "sqrt" arg -mkExp (SOp LFFloor [arg]) = mkMathFun "floor" arg -mkExp (SOp LFCeil [arg]) = mkMathFun "ceil" arg -mkExp (SOp LStrHead [arg]) = mkStringAtIndex arg (Lit $ Int 0) -mkExp (SOp LStrTail [arg]) = - (\ var -> MethodInv $ PrimaryMethodCall (var) - [] - (Ident "substring") - [Lit $ Int 1] - ) - <$> mkVarAccess (Just stringType) arg -mkExp (SOp LStrCons [c, cs]) = - (\ cVar csVar -> MethodInv $ - PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation [] - (ClassType [(Ident "StringBuilder", [])]) - [csVar] - Nothing - ) - [] - (Ident "insert") - [ Lit $ Int 0, - Cast (PrimType CharT) - (MethodInv $ PrimaryMethodCall - (cVar) - [] - (Ident "intValue") - [] - ) - ] - ) - [] - (Ident "toString") - [] - ) - <$> mkVarAccess (Just integerType) c - <*> mkVarAccess (Just stringType) cs -mkExp (SOp LStrIndex [str, i]) = mkVarAccess (Just integerType) i >>= mkStringAtIndex str -mkExp (SOp LStrRev [str]) = - (\ var -> MethodInv $ - PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation [] - (ClassType [(Ident "StringBuffer", [])]) - [var] - Nothing - ) - [] - (Ident "reverse") - [] - ) - [] - (Ident "toString") - [] - ) - <$> mkVarAccess (Just stringType) str -mkExp (SOp LStdIn []) = return $ mkSystemStd In -mkExp (SOp LStdOut []) = return $ mkSystemStd Out -mkExp (SOp LStdErr []) = return $ mkSystemStd Err -mkExp (SOp LFork [arg]) = mkThread arg -mkExp (SOp LPar [arg]) = mkExp (SV arg) -mkExp (SOp LVMPtr []) = - return $ MethodInv $ TypeMethodCall (J.Name [Ident "Thread"]) [] (Ident "currentThread") [] -mkExp (SOp LNoOp args) = mkExp . SV $ last args -mkExp (SNothing) = return $ Lit Null -mkExp (SError err) = - return . MethodInv $ - PrimaryMethodCall (InstanceCreation [] - runtimeExceptionType - [Lit $ String err] - ( Just $ ClassBody - [ MemberDecl $ MethodDecl [Public, Final] - [] - (Just . RefType $ ClassRefType objectType) - (Ident "throwSelf") - [] - [] - ( MethodBody . Just $ - Block [ BlockStmt (Throw This) ] - ) - ] - ) - ) - [] - (Ident "throwSelf") - [] -mkExp other = error (show other) +{-# LANGUAGE PatternGuards #-} +module IRTS.CodegenJava (codegenJava) where + +import Core.TT hiding (mkApp) +import IRTS.BCImp +import IRTS.CodegenCommon +import IRTS.Java.ASTBuilding +import IRTS.Java.JTypes +import IRTS.Java.Mangling +import IRTS.Lang +import IRTS.Simplified +import Paths_idris +import Util.System + +import Control.Applicative hiding (Const) +import Control.Arrow +import Control.Monad +import Control.Monad.Error +import qualified Control.Monad.Trans as T +import Control.Monad.Trans.State +import Data.Int +import Data.List (foldl', intercalate, isPrefixOf, + isSuffixOf) +import Data.Maybe (fromJust) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import qualified Data.Vector.Unboxed as V +import Language.Java.Parser +import Language.Java.Pretty +import Language.Java.Syntax hiding (Name) +import qualified Language.Java.Syntax as J +import System.Directory +import System.Exit +import System.FilePath +import System.IO +import System.Process + +----------------------------------------------------------------------- +-- Main function + +codegenJava :: [(Name, SExp)] -> -- initialization of globals + [(Name, SDecl)] -> + FilePath -> -- output file name + [String] -> -- headers + [String] -> -- libs + OutputType -> + IO () +codegenJava globalInit defs out hdrs libs exec = do + withTempdir (takeBaseName out) $ \ tmpDir -> do + let srcdir = tmpDir "src" "main" "java" + createDirectoryIfMissing True srcdir + let (Ident clsName) = either error id (mkClassName out) + let outjava = srcdir clsName <.> "java" + let jout = either error + (prettyPrint)-- flatIndent . prettyPrint) + (evalStateT (mkCompilationUnit globalInit defs hdrs out) mkCodeGenEnv) + writeFile outjava jout + if (exec == Raw) + then copyFile outjava (takeDirectory out clsName <.> "java") + else do + execPom <- getExecutablePom + execPomTemplate <- TIO.readFile execPom + let execPom = T.replace (T.pack "$MAIN-CLASS$") + (T.pack clsName) + (T.replace (T.pack "$ARTIFACT-NAME$") + (T.pack $ takeBaseName out) + (T.replace (T.pack "$DEPENDENCIES$") + (mkPomDependencies libs) + execPomTemplate + ) + ) + TIO.writeFile (tmpDir "pom.xml") execPom + mvnCmd <- getMvn + let args = ["-f", (tmpDir "pom.xml")] + (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ ["compile"]) "" + when (exit /= ExitSuccess) $ error ("FAILURE: " ++ mvnCmd ++ " compile\n" ++ err ++ mvout) + if (exec == Object) + then do + classFiles <- + map (\ clsFile -> tmpDir "target" "classes" clsFile) + . filter ((".class" ==) . takeExtension) + <$> getDirectoryContents (tmpDir "target" "classes") + mapM_ (\ clsFile -> copyFile clsFile (takeDirectory out takeFileName clsFile)) + classFiles + else do + (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ ["package"]) "" + when (exit /= ExitSuccess) (error ("FAILURE: " ++ mvnCmd ++ " package\n" ++ err ++ mvout)) + copyFile (tmpDir "target" (takeBaseName out) <.> "jar") out + handle <- openBinaryFile out ReadMode + contents <- TIO.hGetContents handle + hClose handle + handle <- openBinaryFile out WriteMode + TIO.hPutStr handle (T.append (T.pack jarHeader) contents) + hFlush handle + hClose handle + perms <- getPermissions out + setPermissions out (setOwnerExecutable True perms) + readProcess mvnCmd (args ++ ["clean"]) "" + removeFile (tmpDir "pom.xml") + +----------------------------------------------------------------------- +-- Jar and Pom infrastructure + +jarHeader :: String +jarHeader = + "#!/bin/sh\n" + ++ "MYSELF=`which \"$0\" 2>/dev/null`\n" + ++ "[ $? -gt 0 -a -f \"$0\" ] && MYSELF=\"./$0\"\n" + ++ "java=java\n" + ++ "if test -n \"$JAVA_HOME\"; then\n" + ++ " java=\"$JAVA_HOME/bin/java\"\n" + ++ "fi\n" + ++ "exec \"$java\" $java_args -jar $MYSELF \"$@\"" + ++ "exit 1\n" + +mkPomDependencies :: [String] -> T.Text +mkPomDependencies deps = + T.concat $ map (T.concat . map (T.append (T.pack " ")) . mkDependency . T.pack) deps + where + mkDependency s = + case T.splitOn (T.pack ":") s of + [g, a, v] -> + [ T.pack $ "\n" + , T.append (T.pack " ") $ mkGroupId g + , T.append (T.pack " ") $ mkArtifactId a + , T.append (T.pack " ") $ mkVersion v + , T.pack $ "\n" + ] + _ -> [] + mkGroupId g = T.append (T.pack $ "") (T.append g $ T.pack "\n") + mkArtifactId a = T.append (T.pack $ "") (T.append a $ T.pack "\n") + mkVersion v = T.append (T.pack $ "") (T.append v $ T.pack "\n") + +----------------------------------------------------------------------- +-- Code generation environment + +data CodeGenerationEnv + = CodeGenerationEnv + { globalVariables :: [(Name, ArrayIndex)] + , localVariables :: [[(Int, Ident)]] + , localVarCounter :: Int + } + +type CodeGeneration = StateT (CodeGenerationEnv) (Either String) + +mkCodeGenEnv :: CodeGenerationEnv +mkCodeGenEnv = CodeGenerationEnv [] [] 0 + +varPos :: LVar -> CodeGeneration (Either ArrayIndex Ident) +varPos (Loc i) = do + vars <- (concat . localVariables) <$> get + case lookup i vars of + (Just varName) -> return (Right varName) + Nothing -> throwError $ "Invalid local variable id: " ++ show i +varPos (Glob name) = do + vars <- globalVariables <$> get + case lookup name vars of + (Just varIdx) -> return (Left varIdx) + Nothing -> throwError $ "Invalid global variable id: " ++ show name + +pushScope :: CodeGeneration () +pushScope = + modify (\ env -> env { localVariables = []:(localVariables env) }) + +popScope :: CodeGeneration () +popScope = do + env <- get + let lVars = tail $ localVariables env + let vC = if null lVars then 0 else localVarCounter env + put $ env { localVariables = tail (localVariables env) + , localVarCounter = vC } + +setVariable :: LVar -> CodeGeneration (Either ArrayIndex Ident) +setVariable (Loc i) = do + env <- get + let lVars = localVariables env + let getter = localVar $ localVarCounter env + let lVars' = ((i, getter) : head lVars) : tail lVars + put $ env { localVariables = lVars' + , localVarCounter = 1 + localVarCounter env} + return (Right getter) +setVariable (Glob n) = do + env <- get + let gVars = globalVariables env + let getter = globalContext @! length gVars + let gVars' = (n, getter):gVars + put (env { globalVariables = gVars' }) + return (Left getter) + +pushParams :: [Ident] -> CodeGeneration () +pushParams paramNames = + let varMap = zipWith (flip (,)) paramNames [0..] in + modify (\ env -> env { localVariables = varMap:(localVariables env) + , localVarCounter = (length varMap) + (localVarCounter env) }) + +flatIndent :: String -> String +flatIndent (' ' : ' ' : xs) = flatIndent xs +flatIndent (x:xs) = x:flatIndent xs +flatIndent [] = [] + +----------------------------------------------------------------------- +-- Maintaining control structures over code blocks + +data BlockPostprocessor + = BlockPostprocessor + { ppInnerBlock :: [BlockStmt] -> Exp -> CodeGeneration [BlockStmt] + , ppOuterBlock :: [BlockStmt] -> CodeGeneration [BlockStmt] + } + +ppExp :: BlockPostprocessor -> Exp -> CodeGeneration [BlockStmt] +ppExp pp exp = ((ppInnerBlock pp) [] exp) >>= ppOuterBlock pp + +addReturn :: BlockPostprocessor +addReturn = + BlockPostprocessor + { ppInnerBlock = (\ block exp -> return $ block ++ [jReturn exp]) + , ppOuterBlock = return + } + +ignoreResult :: BlockPostprocessor +ignoreResult = + BlockPostprocessor + { ppInnerBlock = (\ block exp -> return block) + , ppOuterBlock = return + } + +ignoreOuter :: BlockPostprocessor -> BlockPostprocessor +ignoreOuter pp = pp { ppOuterBlock = return } + +throwRuntimeException :: BlockPostprocessor -> BlockPostprocessor +throwRuntimeException pp = + pp + { ppInnerBlock = + (\ blk exp -> return $ + blk ++ [ BlockStmt $ Throw + ( InstanceCreation + [] + (toClassType runtimeExceptionType) + [exp] + Nothing + ) + ] + ) + } + + +rethrowAsRuntimeException :: BlockPostprocessor -> BlockPostprocessor +rethrowAsRuntimeException pp = + pp + { ppOuterBlock = + (\ blk -> do + ex <- ppInnerBlock (throwRuntimeException pp) [] (ExpName $ J.Name [Ident "ex"]) + ppOuterBlock pp + $ [ BlockStmt $ Try + (Block blk) + [Catch (FormalParam [] exceptionType False (VarId (Ident "ex"))) $ + Block ex + ] + Nothing + ] + ) + } + +----------------------------------------------------------------------- +-- File structure + +mkCompilationUnit :: [(Name, SExp)] -> [(Name, SDecl)] -> [String] -> FilePath -> CodeGeneration CompilationUnit +mkCompilationUnit globalInit defs hdrs out = do + clsName <- mkClassName out + CompilationUnit Nothing ( [ ImportDecl False idrisRts True + , ImportDecl True idrisPrelude True + , ImportDecl False bigInteger False + , ImportDecl False runtimeException False + ] ++ otherHdrs + ) + <$> mkTypeDecl clsName globalInit defs + where + idrisRts = J.Name $ map Ident ["org", "idris", "rts"] + idrisPrelude = J.Name $ map Ident ["org", "idris", "rts", "Prelude"] + bigInteger = J.Name $ map Ident ["java", "math", "BigInteger"] + runtimeException = J.Name $ map Ident ["java", "lang", "RuntimeException"] + otherHdrs = map ( (\ name -> ImportDecl False name False) + . J.Name + . map (Ident . T.unpack) + . T.splitOn (T.pack ".") + . T.pack) + $ filter (not . isSuffixOf ".h") hdrs + +----------------------------------------------------------------------- +-- Main class + +mkTypeDecl :: Ident -> [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration [TypeDecl] +mkTypeDecl name globalInit defs = + (\ body -> [ClassTypeDecl $ ClassDecl [ Public + , Annotation $ SingleElementAnnotation + (jName "SuppressWarnings") + (EVVal . InitExp $ jString "unchecked") + ] + name + [] + Nothing + [] + body]) + <$> mkClassBody globalInit (map (second (prefixCallNamespaces name)) defs) + +mkClassBody :: [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration ClassBody +mkClassBody globalInit defs = + (\ globals defs -> ClassBody . (globals++) . addMainMethod . mergeInnerClasses $ defs) + <$> mkGlobalContext globalInit + <*> mapM mkDecl defs + +mkGlobalContext :: [(Name, SExp)] -> CodeGeneration [Decl] +mkGlobalContext [] = return [] +mkGlobalContext initExps = do + pushScope + varInit <- + mapM (\ (name, exp) -> do + pos <- setVariable (Glob name) + mkUpdate ignoreResult (Glob name) exp + ) initExps + popScope + return [ MemberDecl $ FieldDecl [Private, Static, Final] + (array objectType) + [ VarDecl (VarId $ globalContextID). Just . InitExp + $ ArrayCreate objectType [jInt $ length initExps] 0 + ] + , InitDecl True (Block $ concat varInit) + ] + +addMainMethod :: [Decl] -> [Decl] +addMainMethod decls + | findMain decls = mkMainMethod : decls + | otherwise = decls + where + findMain ((MemberDecl (MemberClassDecl (ClassDecl _ name _ _ _ (ClassBody body)))):_) + | name == mangle' (UN "Main") = findMainMethod body + findMain (_:decls) = findMain decls + findMain [] = False + + innerMainMethod = (either error id $ mangle (UN "main")) + findMainMethod ((MemberDecl (MethodDecl _ _ _ name [] _ _)):_) + | name == mangle' (UN "main") = True + findMainMethod (_:decls) = findMainMethod decls + findMainMethod [] = False + +mkMainMethod :: Decl +mkMainMethod = + simpleMethod + [Public, Static] + Nothing + "main" + [FormalParam [] (array stringType) False (VarId $ Ident "args")] + $ Block [ BlockStmt . ExpStmt + $ call "idris_initArgs" [ (threadType ~> "currentThread") [] + , jConst "args" + ] + , BlockStmt . ExpStmt $ call (mangle' (MN 0 "runMain")) [] + ] + +----------------------------------------------------------------------- +-- Inner classes (idris namespaces) + +mergeInnerClasses :: [Decl] -> [Decl] +mergeInnerClasses = foldl' mergeInner [] + where + mergeInner ((decl@(MemberDecl (MemberClassDecl (ClassDecl priv name targs ext imp (ClassBody body))))):decls) + decl'@(MemberDecl (MemberClassDecl (ClassDecl _ name' _ ext' imp' (ClassBody body')))) + | name == name' = + (MemberDecl $ MemberClassDecl $ + ClassDecl priv + name + targs + (mplus ext ext') + (imp ++ imp') + (ClassBody $ mergeInnerClasses (body ++ body'))) + : decls + | otherwise = decl:(mergeInner decls decl') + mergeInner (decl:decls) decl' = decl:(mergeInner decls decl') + mergeInner [] decl' = [decl'] + + + +mkDecl :: (Name, SDecl) -> CodeGeneration Decl +mkDecl ((NS n (ns:nss)), decl) = + (\ name body -> + MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body) + <$> mangle (UN ns) + <*> mkClassBody [] [(NS n nss, decl)] +mkDecl (_, SFun name params stackSize body) = do + (Ident methodName) <- mangle name + methodParams <- mapM mkFormalParam params + paramNames <- mapM mangle params + pushParams paramNames + methodBody <- mkExp addReturn body + popScope + return $ + simpleMethod [Public, Static] (Just objectType) methodName methodParams + (Block methodBody) + +mkFormalParam :: Name -> CodeGeneration FormalParam +mkFormalParam name = + (\ name -> FormalParam [Final] objectType False (VarId name)) + <$> mangle name + +----------------------------------------------------------------------- +-- Expressions + +-- | Compile a simple expression and use the given continuation to postprocess +-- the resulting value. +mkExp :: BlockPostprocessor -> SExp -> CodeGeneration [BlockStmt] +-- Variables +mkExp pp (SV var) = + (Nothing <>@! var) >>= ppExp pp + +-- Applications +mkExp pp (SApp pushTail name args) = + mkApp pushTail name args >>= ppExp pp + +-- Bindings +mkExp pp (SLet var newExp inExp) = + mkLet pp var newExp inExp +mkExp pp (SUpdate var newExp) = + mkUpdate pp var newExp + +-- Objects +mkExp pp (SCon conId _ args) = + mkIdrisObject conId args >>= ppExp pp + +-- Case expressions +mkExp pp (SCase var alts) = mkCase pp True var alts +mkExp pp (SChkCase var alts) = mkCase pp False var alts + +-- Projections +mkExp pp (SProj var i) = + mkProjection var i >>= ppExp pp + +-- Constants +mkExp pp (SConst c) = + ppExp pp $ mkConstant c + +-- Foreign function calls +mkExp pp (SForeign lang resTy text params) = + mkForeign pp lang resTy text params + +-- Primitive functions +mkExp pp (SOp LFork [arg]) = + (mkThread arg) >>= ppExp pp +mkExp pp (SOp LPar [arg]) = + (Nothing <>@! arg) >>= ppExp pp +mkExp pp (SOp LNoOp args) = + (Nothing <>@! (last args)) >>= ppExp pp +mkExp pp (SOp op args) = + (mkPrimitiveFunction op args) >>= ppExp pp + +-- Empty expressions +mkExp pp (SNothing) = ppExp pp $ Lit Null + +-- Errors +mkExp pp (SError err) = ppExp (throwRuntimeException pp) (jString err) + +----------------------------------------------------------------------- +-- Variable access + +(<>@!) :: Maybe J.Type -> LVar -> CodeGeneration Exp +(<>@!) Nothing var = + either ArrayAccess (\ n -> ExpName $ J.Name [n]) <$> varPos var +(<>@!) (Just castTo) var = + (castTo <>) <$> (Nothing <>@! var) + +----------------------------------------------------------------------- +-- Application (wrap method calls in tail call closures) + +mkApp :: Bool -> Name -> [LVar] -> CodeGeneration Exp +mkApp False name args = + (\ methodName params -> + (idrisClosureType ~> "unwrapTailCall") [call methodName params] + ) + <$> mangleFull name + <*> mapM (Nothing <>@!) args +mkApp True name args = mkMethodCallClosure name args + +mkMethodCallClosure :: Name -> [LVar] -> CodeGeneration Exp +mkMethodCallClosure name args = + (\ name args -> closure (call name args)) + <$> mangleFull name + <*> mapM (Nothing <>@!) args + +----------------------------------------------------------------------- +-- Updates (change context array) and Let bindings (Update, execute) + +mkUpdate :: BlockPostprocessor -> LVar -> SExp -> CodeGeneration [BlockStmt] +mkUpdate pp var exp = + mkExp + ( pp + { ppInnerBlock = + (\ blk rhs -> do + pos <- setVariable var + vExp <- Nothing <>@! var + ppInnerBlock pp (blk ++ [pos @:= rhs]) vExp + ) + } + ) exp + +mkLet :: BlockPostprocessor -> LVar -> SExp -> SExp -> CodeGeneration [BlockStmt] +mkLet pp var@(Loc pos) newExp inExp = + mkUpdate (pp { ppInnerBlock = + (\ blk _ -> do + inBlk <- mkExp pp inExp + return (blk ++ inBlk) + ) + } + ) var newExp +mkLet _ (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable" + +----------------------------------------------------------------------- +-- Object creation + +mkIdrisObject :: Int -> [LVar] -> CodeGeneration Exp +mkIdrisObject conId args = + (\ args -> + InstanceCreation [] (toClassType idrisObjectType) ((jInt conId):args) Nothing + ) + <$> mapM (Nothing <>@!) args + +----------------------------------------------------------------------- +-- Case expressions + +mkCase :: BlockPostprocessor -> Bool -> LVar -> [SAlt] -> CodeGeneration [BlockStmt] +mkCase pp checked var cases + | isDefaultOnlyCase cases = mkDefaultMatch pp cases + | isConstCase cases = do + ifte <- mkConstMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases + ppOuterBlock pp [BlockStmt ifte] + | otherwise = do + switchExp <- mkGetConstructorId checked var + matchBlocks <- mkConsMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases + ppOuterBlock pp [BlockStmt $ Switch switchExp matchBlocks] + +isConstCase :: [SAlt] -> Bool +isConstCase ((SConstCase _ _):_) = True +isConstCase ((SDefaultCase _):cases) = isConstCase cases +isConstCase _ = False + +isDefaultOnlyCase :: [SAlt] -> Bool +isDefaultOnlyCase [SDefaultCase _] = True +isDefaultOnlyCase [] = True +isDefaultOnlyCase _ = False + +mkDefaultMatch :: BlockPostprocessor -> [SAlt] -> CodeGeneration [BlockStmt] +mkDefaultMatch pp (x@(SDefaultCase branchExpression):_) = + do pushScope + stmt <- mkExp pp branchExpression + popScope + return stmt +mkDefaultMatch pp (x:xs) = mkDefaultMatch pp xs +mkDefaultMatch pp [] = + ppExp (throwRuntimeException pp) (jString "Non-exhaustive pattern") + +mkMatchConstExp :: LVar -> Const -> CodeGeneration Exp +mkMatchConstExp var c + | isPrimitive cty = + (\ var -> (primFnType ~> opName (LEq undefined)) [var, jc] ~==~ jInt 1) + <$> (Just cty <>@! var) + | isArray cty = + (\ var -> (arraysType ~> "equals") [var, jc]) + <$> (Just cty <>@! var) + | isString cty = + (\ var -> ((primFnType ~> opName (LStrEq)) [var, jc] ~==~ jInt 1)) + <$> (Just cty <>@! var) + | otherwise = + (\ var -> (var ~> "equals") [jc]) + <$> (Just cty <>@! var) + where + cty = constType c + jc = mkConstant c + +mkConstMatch :: BlockPostprocessor -> + (BlockPostprocessor -> CodeGeneration [BlockStmt]) -> + LVar -> + [SAlt] -> + CodeGeneration Stmt +mkConstMatch pp getDefaultStmts var ((SConstCase constant branchExpression):cases) = do + matchExp <- mkMatchConstExp var constant + pushScope + branchBlock <- mkExp pp branchExpression + popScope + otherBranches <- mkConstMatch pp getDefaultStmts var cases + return + $ IfThenElse matchExp (StmtBlock $ Block branchBlock) otherBranches +mkConstMatch pp getDefaultStmts var (c:cases) = mkConstMatch pp getDefaultStmts var cases +mkConstMatch pp getDefaultStmts _ [] = do + defaultBlock <- getDefaultStmts pp + return $ StmtBlock (Block defaultBlock) + +mkGetConstructorId :: Bool -> LVar -> CodeGeneration Exp +mkGetConstructorId True var = + (\ var -> ((idrisObjectType <> var) ~> "getConstructorId") []) + <$> (Nothing <>@! var) +mkGetConstructorId False var = + (\ var match -> + Cond (InstanceOf var (toRefType idrisObjectType)) match (jInt (-1)) + ) + <$> (Nothing <>@! var) + <*> mkGetConstructorId True var + +mkConsMatch :: BlockPostprocessor -> + (BlockPostprocessor -> CodeGeneration [BlockStmt]) -> + LVar -> + [SAlt] -> + CodeGeneration [SwitchBlock] +mkConsMatch pp getDefaultStmts var ((SConCase parentStackPos consIndex _ params branchExpression):cases) = do + pushScope + caseBranch <- mkCaseBinding pp var parentStackPos params branchExpression + popScope + otherBranches <- mkConsMatch pp getDefaultStmts var cases + return $ + (SwitchBlock (SwitchCase $ jInt consIndex) caseBranch):otherBranches +mkConsMatch pp getDefaultStmts var (c:cases) = mkConsMatch pp getDefaultStmts var cases +mkConsMatch pp getDefaultStmts _ [] = do + defaultBlock <- getDefaultStmts pp + return $ + [SwitchBlock Default defaultBlock] + +mkCaseBinding :: BlockPostprocessor -> LVar -> Int -> [Name] -> SExp -> CodeGeneration [BlockStmt] +mkCaseBinding pp var stackStart params branchExpression = + mkExp pp (toLetIn var stackStart params branchExpression) + where + toLetIn :: LVar -> Int -> [Name] -> SExp -> SExp + toLetIn var stackStart members start = + foldr + (\ pos inExp -> SLet (Loc (stackStart + pos)) (SProj var pos) inExp) + start + [0.. (length members - 1)] + +----------------------------------------------------------------------- +-- Projection (retrieve the n-th field of an object) + +mkProjection :: LVar -> Int -> CodeGeneration Exp +mkProjection var memberNr = + (\ var -> ArrayAccess $ ((var ~> "getData") []) @! memberNr) + <$> (Just idrisObjectType <>@! var) + +----------------------------------------------------------------------- +-- Constants + +mkConstantArray :: (V.Unbox a) => J.Type -> (a -> Const) -> V.Vector a -> Exp +mkConstantArray cty elemToConst elems = + ArrayCreateInit + cty + 0 + (ArrayInit . map (InitExp . mkConstant . elemToConst) $ V.toList elems) + +mkConstant :: Const -> Exp +mkConstant c@(I x) = constType c <> (Lit . Word $ toInteger x) +mkConstant c@(BI x) = bigInteger (show x) +mkConstant c@(Fl x) = constType c <> (Lit . Double $ x) +mkConstant c@(Ch x) = constType c <> (Lit . Char $ x) +mkConstant c@(Str x) = constType c <> (Lit . String $ x) +mkConstant c@(B8 x) = constType c <> (Lit . Word $ toInteger x) +mkConstant c@(B16 x) = constType c <> (Lit . Word $ toInteger x) +mkConstant c@(B32 x) = constType c <> (Lit . Word $ toInteger x) +mkConstant c@(B64 x) = (bigInteger (show c) ~> "longValue") [] +mkConstant c@(B8V x) = mkConstantArray (constType c) B8 x +mkConstant c@(B16V x) = mkConstantArray (constType c) B16 x +mkConstant c@(B32V x) = mkConstantArray (constType c) B32 x +mkConstant c@(B64V x) = mkConstantArray (constType c) B64 x +mkConstant c@(AType x) = ClassLit (Just $ box (constType c)) +mkConstant c@(StrType ) = ClassLit (Just $ stringType) +mkConstant c@(PtrType ) = ClassLit (Just $ objectType) +mkConstant c@(VoidType ) = ClassLit (Just $ voidType) +mkConstant c@(Forgot ) = ClassLit (Just $ objectType) + +----------------------------------------------------------------------- +-- Foreign function calls + +mkForeign :: BlockPostprocessor -> FLang -> FType -> String -> [(FType, LVar)] -> CodeGeneration [BlockStmt] +mkForeign pp (LANG_C) resTy text params = mkForeign pp (LANG_JAVA FStatic) resTy text params +mkForeign pp (LANG_JAVA callType) resTy text params + | callType <- FStatic = do + method <- liftParsed (parser name text) + args <- foreignVarAccess params + wrapReturn resTy (call method args) + | callType <- FObject = do + method <- liftParsed (parser ident text) + (tgt:args) <- foreignVarAccess params + wrapReturn resTy ((tgt ~> (show $ pretty method)) args) + | callType <- FConstructor = do + clsTy <- liftParsed (parser classType text) + args <- foreignVarAccess params + wrapReturn resTy (InstanceCreation [] clsTy args Nothing) + where + foreignVarAccess args = + mapM (\ (fty, var) -> (foreignType fty <>@! var)) args + + pp' = rethrowAsRuntimeException pp + + wrapReturn FUnit exp = + ((ppInnerBlock pp') [BlockStmt $ ExpStmt exp] (Lit Null)) >>= ppOuterBlock pp' + wrapReturn _ exp = + ((ppInnerBlock pp') [] exp) >>= ppOuterBlock pp' + +----------------------------------------------------------------------- +-- Primitive functions + +mkPrimitiveFunction :: PrimFn -> [LVar] -> CodeGeneration Exp +mkPrimitiveFunction op args = + (\ args -> (primFnType ~> opName op) args) + <$> sequence (zipWith (\ a t -> (Just t) <>@! a) args (sourceTypes op)) + +mkThread :: LVar -> CodeGeneration Exp +mkThread arg = + (\ closure -> (closure ~> "fork") []) <$> mkMethodCallClosure (MN 0 "EVAL") [arg] + + diff --git a/src/IRTS/CodegenJavaScript.hs b/src/IRTS/CodegenJavaScript.hs --- a/src/IRTS/CodegenJavaScript.hs +++ b/src/IRTS/CodegenJavaScript.hs @@ -16,11 +16,13 @@ import Data.List import qualified Data.Map as Map import System.IO +import System.Directory idrNamespace :: String idrNamespace = "__IDR__" +idrRTNamespace = "__IDRRT__" -data JSTarget = Node | JavaScript +data JSTarget = Node | JavaScript deriving Eq codegenJavaScript :: JSTarget @@ -29,17 +31,24 @@ -> OutputType -> IO () codegenJavaScript target definitions filename outputType = do - let runtime = case target of - Node -> "-node" - JavaScript -> "-browser" + let (header, runtime) = case target of + Node -> + ("#!/usr/bin/env node\n", "-node") + JavaScript -> + ("", "-browser") path <- getDataDir idrRuntime <- readFile $ path ++ "/js/Runtime-common.js" tgtRuntime <- readFile $ concat [path, "/js/Runtime", runtime, ".js"] - writeFile filename (idrRuntime + writeFile filename ( header + ++ idrRuntime ++ tgtRuntime - ++ modules ++ functions ++ mainLoop) + + setPermissions filename (emptyPermissions { readable = True + , executable = target == Node + , writable = True + }) where def = map (first translateNamespace) definitions @@ -47,19 +56,10 @@ mainLoop :: String mainLoop = intercalate "\n" [ "\nfunction main() {" - , createTailcall "__IDR__.runMain0()" + , createTailcall "__IDR__runMain0()" , "}\n\nmain();\n" ] - modules = - concatMap allocMod mods - where - allocMod m = intercalate "." m ++ " = {};\n" - sortMods a b = compare (length a) (length b) - - mods = - drop 1 $ sortBy sortMods $ nub $ concatMap (inits . fst) def - translateIdentifier :: String -> String translateIdentifier = replaceReserved . concatMap replaceBadChars @@ -118,10 +118,10 @@ , "yield" ] -translateNamespace :: Name -> [String] -translateNamespace (UN _) = [idrNamespace] -translateNamespace (NS _ ns) = idrNamespace : map translateIdentifier ns -translateNamespace (MN _ _) = [idrNamespace] +translateNamespace :: Name -> String +translateNamespace (UN _) = idrNamespace +translateNamespace (NS _ ns) = idrNamespace ++ concatMap translateIdentifier ns +translateNamespace (MN _ _) = idrNamespace translateName :: Name -> String translateName (UN name) = translateIdentifier name @@ -130,17 +130,17 @@ translateConstant :: Const -> String translateConstant (I i) = show i -translateConstant (BI i) = "__IDRRT__.bigInt('" ++ show i ++ "')" +translateConstant (BI i) = idrRTNamespace ++ "bigInt('" ++ show i ++ "')" translateConstant (Fl f) = show f translateConstant (Ch c) = show c translateConstant (Str s) = show s -translateConstant IType = "__IDRRT__.Int" -translateConstant ChType = "__IDRRT__.Char" -translateConstant StrType = "__IDRRT__.String" -translateConstant BIType = "__IDRRT__.Integer" -translateConstant FlType = "__IDRRT__.Float" -translateConstant PtrType = "__IDRRT__.Ptr" -translateConstant Forgot = "__IDRRT__.Forgot" +translateConstant (AType (ATInt ITNative)) = idrRTNamespace ++ "Int" +translateConstant StrType = idrRTNamespace ++ "String" +translateConstant (AType (ATInt ITBig)) = idrRTNamespace ++ "Integer" +translateConstant (AType ATFloat) = idrRTNamespace ++ "Float" +translateConstant (AType (ATInt ITChar)) = idrRTNamespace ++ "Char" +translateConstant PtrType = idrRTNamespace ++ "Ptr" +translateConstant Forgot = idrRTNamespace ++ "Forgot" translateConstant c = "(function(){throw 'Unimplemented Const: " ++ show c ++ "';})()" @@ -149,9 +149,9 @@ where translateParameter (MN i name) = translateIdentifier name ++ show i translateParameter (UN name) = translateIdentifier name -translateDeclaration :: ([String], SDecl) -> String +translateDeclaration :: (String, SDecl) -> String translateDeclaration (path, SFun name params stackSize body) = - intercalate "." (path ++ [translateName name]) + "var " ++ path ++ translateName name ++ " = function(" ++ intercalate "," p ++ "){\n" @@ -197,12 +197,57 @@ createTailcall $ translateFunctionCall name vars translateExpression (SApp True name vars) = - "new __IDRRT__.Tailcall(" + "new " ++ idrRTNamespace ++ "Tailcall(" ++ "function(){\n" ++ "return " ++ translateFunctionCall name vars - ++ ";\n});" + ++ ";\n})" translateExpression (SOp op vars) + | LNoOp <- op = translateVariableName (last vars) + + | (LZExt _ ITBig) <- op = + idrRTNamespace ++ "bigInt(" ++ translateVariableName (last vars) ++ ")" + + | (LPlus (ATInt ITBig)) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp ".add(" lhs rhs ++ ")" + | (LMinus (ATInt ITBig)) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp ".minus(" lhs rhs ++ ")" + | (LTimes (ATInt ITBig)) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp ".times(" lhs rhs ++ ")" + | (LSDiv (ATInt ITBig)) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp ".divide(" lhs rhs ++ ")" + | (LSRem (ATInt ITBig)) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp ".mod(" lhs rhs ++ ")" + | (LEq (ATInt ITBig)) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp ".equals(" lhs rhs ++ ")" + | (LLt (ATInt ITBig)) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp ".lesser(" lhs rhs ++ ")" + | (LLe (ATInt ITBig)) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp ".lesserOrEquals(" lhs rhs ++ ")" + | (LGt (ATInt ITBig)) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp ".greater(" lhs rhs ++ ")" + | (LGe (ATInt ITBig)) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp ".greaterOrEquals(" lhs rhs ++ ")" + + | (LPlus ATFloat) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs + | (LMinus ATFloat) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs + | (LTimes ATFloat) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs + | (LSDiv ATFloat) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs + | (LEq ATFloat) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs + | (LLt ATFloat) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs + | (LLe ATFloat) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs + | (LGt ATFloat) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs + | (LGe ATFloat) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs + | (LPlus _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs | (LMinus _) <- op @@ -219,7 +264,7 @@ , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs | (LLe _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs - | (LGt _) <- op + | (LGt _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs | (LGe _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs @@ -236,46 +281,6 @@ | (LCompl _) <- op , (arg:_) <- vars = '~' : translateVariableName arg - | (LPlus ITBig) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp ".add(" lhs rhs ++ ")" - | (LMinus ITBig) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp ".minus(" lhs rhs ++ ")" - | (LTimes ITBig) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp ".times(" lhs rhs ++ ")" - | (LSDiv ITBig) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp ".divide(" lhs rhs ++ ")" - | (LSRem ITBig) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp ".mod(" lhs rhs ++ ")" - | (LEq ITBig) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp ".equals(" lhs rhs ++ ")" - | (LLt ITBig) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp ".lesser(" lhs rhs ++ ")" - | (LLe ITBig) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp ".lesserOrEquals(" lhs rhs ++ ")" - | (LGt ITBig) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp ".greater(" lhs rhs ++ ")" - | (LGe ITBig) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp ".greaterOrEquals(" lhs rhs ++ ")" - - | LFPlus <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs - | LFMinus <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs - | LFTimes <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs - | LFDiv <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs - | LFEq <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs - | LFLt <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs - | LFLe <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs - | LFGt <- op - , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs - | LFGe <- op - , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs - | LStrConcat <- op , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs | LStrEq <- op @@ -290,13 +295,13 @@ | (LIntStr ITNative) <- op , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")" | (LSExt ITNative ITBig) <- op - , (arg:_) <- vars = "__IDRRT__.bigInt(" ++ translateVariableName arg ++ ")" + , (arg:_) <- vars = idrRTNamespace ++ "bigInt(" ++ translateVariableName arg ++ ")" | (LTrunc ITBig ITNative) <- op , (arg:_) <- vars = translateVariableName arg ++ ".valueOf()" | (LIntStr ITBig) <- op , (arg:_) <- vars = translateVariableName arg ++ ".toString()" | (LStrInt ITBig) <- op - , (arg:_) <- vars = "__IDRRT__.bigInt(" ++ translateVariableName arg ++ ")" + , (arg:_) <- vars = idrRTNamespace ++ "bigInt(" ++ translateVariableName arg ++ ")" | LFloatStr <- op , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")" | LStrFloat <- op @@ -340,7 +345,7 @@ , (arg:_) <- vars = translateVariableName arg ++ "[0]" | LStrRev <- op , (arg:_) <- vars = let v = translateVariableName arg in - v ++ "split('').reverse().join('')" + v ++ ".split('').reverse().join('')" | LStrIndex <- op , (lhs:rhs:_) <- vars = let l = translateVariableName lhs r = translateVariableName rhs in @@ -356,20 +361,28 @@ ++ translateVariableName rhs translateExpression (SError msg) = - "(function(){throw \'" ++ msg ++ "\';})();" + "(function(){throw \'" ++ msg ++ "\';})()" translateExpression (SForeign _ _ "putStr" [(FString, var)]) = - "__IDRRT__.print(" ++ translateVariableName var ++ ");" + idrRTNamespace ++ "print(" ++ translateVariableName var ++ ")" translateExpression (SForeign _ _ fun args) - | "." `isPrefixOf` fun, "[]=" `isSuffixOf` fun + | "[]=" `isSuffixOf` fun , (obj:idx:val:[]) <- args = - concat [object obj, field, index idx, assign val] + concat [object obj, index idx, assign val] - | "." `isPrefixOf` fun, "[]" `isSuffixOf` fun + | "[]" `isSuffixOf` fun , (obj:idx:[]) <- args = - concat [object obj, field, index idx] + object obj ++ index idx + | "[" `isPrefixOf` fun && "]=" `isSuffixOf` fun + , (obj:val:[]) <- args = + concat [object obj, '[' : name ++ "]", assign val] + + | "[" `isPrefixOf` fun && "]" `isSuffixOf` fun + , (obj:[]) <- args = + object obj ++ '[' : name ++ "]" + | "." `isPrefixOf` fun, "=" `isSuffixOf` fun , (obj:val:[]) <- args = concat [object obj, field, assign val] @@ -402,10 +415,17 @@ array = name object o = translateVariableName (snd o) index i = "[" ++ translateVariableName (snd i) ++ "]" - assign v = '=' : translateVariableName (snd v) + assign v = '=' : generateWrapper v arguments as = - '(' : intercalate "," (map (translateVariableName . snd) as) ++ ")" + '(' : intercalate "," (map generateWrapper as) ++ ")" + generateWrapper (ffunc, name) + | FFunction <- ffunc = idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")" + | FFunctionIO <- ffunc = idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")" + + generateWrapper (_, name) = + translateVariableName name + translateExpression (SChkCase var cases) = "(function(e){\n" ++ intercalate " else " (map (translateCase "e") cases) @@ -421,7 +441,7 @@ ++ ")" translateExpression (SCon i name vars) = - concat [ "new __IDRRT__.Con(" + concat [ "new " ++ idrRTNamespace ++ "Con(" , show i , ",[" , intercalate "," $ map translateVariableName vars @@ -446,18 +466,18 @@ createIfBlock "true" (translateExpression e) translateCase var (SConstCase ty e) - | ChType <- ty = matchHelper "Char" - | StrType <- ty = matchHelper "String" - | IType <- ty = matchHelper "Int" - | BIType <- ty = matchHelper "Integer" - | FlType <- ty = matchHelper "Float" - | PtrType <- ty = matchHelper "Ptr" - | Forgot <- ty = matchHelper "Forgot" + | StrType <- ty = matchHelper "String" + | PtrType <- ty = matchHelper "Ptr" + | Forgot <- ty = matchHelper "Forgot" + | (AType ATFloat) <- ty = matchHelper "Float" + | (AType (ATInt ITBig)) <- ty = matchHelper "Integer" + | (AType (ATInt ITNative)) <- ty = matchHelper "Int" + | (AType (ATInt ITChar)) <- ty = matchHelper "Char" where matchHelper tyName = translateTypeMatch var tyName e translateCase var (SConstCase cst@(BI _) e) = - let cond = var ++ ".equals(" ++ translateConstant cst ++ ")" in + let cond = idrRTNamespace ++ "bigInt(" ++ var ++ ").equals(" ++ translateConstant cst ++ ")" in createIfBlock cond (translateExpression e) translateCase var (SConstCase cst e) = @@ -465,7 +485,7 @@ createIfBlock cond (translateExpression e) translateCase var (SConCase a i name vars e) = - let isCon = var ++ " instanceof __IDRRT__.Con" + let isCon = var ++ " instanceof " ++ idrRTNamespace ++ "Con" isI = show i ++ " == " ++ var ++ ".i" params = intercalate "," $ map (("__var_" ++) . show) [a..(a+length vars)] args = ".apply(this," ++ var ++ ".vars)" @@ -480,7 +500,7 @@ translateTypeMatch var ty exp = let e = translateExpression exp in createIfBlock (var - ++ " instanceof __IDRRT__.Type && " + ++ " instanceof " ++ idrRTNamespace ++ "Type && " ++ var ++ ".type == '"++ ty ++"'") e @@ -490,11 +510,10 @@ ++ ";\n}" createTailcall call = - "__IDRRT__.tailcall(function(){return " ++ call ++ "})" + idrRTNamespace ++ "tailcall(function(){return " ++ call ++ "})" translateFunctionCall name vars = - concat (intersperse "." $ translateNamespace name) - ++ "." + translateNamespace name ++ translateName name ++ "(" ++ intercalate "," (map translateVariableName vars) diff --git a/src/IRTS/CodegenLLVM.hs b/src/IRTS/CodegenLLVM.hs new file mode 100644 --- /dev/null +++ b/src/IRTS/CodegenLLVM.hs @@ -0,0 +1,1179 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module IRTS.CodegenLLVM (codegenLLVM) where + +import IRTS.CodegenCommon +import IRTS.Lang +import IRTS.Simplified +import qualified Core.TT as TT +import Core.TT (ArithTy(..), IntTy(..), NativeTy(..), nativeTyWidth) + +import Util.System +import Paths_idris + +import LLVM.General.Context +import LLVM.General.Diagnostic +import LLVM.General.AST +import LLVM.General.AST.AddrSpace +import LLVM.General.Target ( TargetMachine + , withTargetOptions, withTargetMachine, getTargetMachineDataLayout + , initializeAllTargets, lookupTarget + ) +import LLVM.General.AST.DataLayout +import LLVM.General.PassManager +import qualified LLVM.General.Module as M +import qualified LLVM.General.AST.IntegerPredicate as IPred +import qualified LLVM.General.AST.Linkage as L +import qualified LLVM.General.AST.Visibility as V +import qualified LLVM.General.AST.CallingConvention as CC +import qualified LLVM.General.AST.Attribute as A +import qualified LLVM.General.AST.Global as G +import qualified LLVM.General.AST.Constant as C +import qualified LLVM.General.AST.Float as F +import qualified LLVM.General.Relocation as R +import qualified LLVM.General.CodeModel as CM +import qualified LLVM.General.CodeGenOpt as CGO + +import Data.List +import Data.Maybe +import Data.Word +import Data.Set (Set) +import qualified Data.Set as S +import qualified Data.Map as M +import qualified Data.Vector.Unboxed as V +import Control.Applicative +import Control.Monad.RWS +import Control.Monad.Writer +import Control.Monad.State +import Control.Monad.Error + +import qualified System.Info as SI (arch, os) +import System.IO +import System.Directory (removeFile) +import System.FilePath (()) +import System.Process (rawSystem) +import System.Exit (ExitCode(..)) +import Debug.Trace + +data Target = Target { triple :: String, dataLayout :: DataLayout } + +codegenLLVM :: [(TT.Name, SDecl)] -> + String -> -- target triple + String -> -- target CPU + Int -> -- Optimization degree + FilePath -> -- output file name + OutputType -> + IO () +codegenLLVM defs triple cpu optimize file outty = withContext $ \context -> do + initializeAllTargets + (target, _) <- failInIO $ lookupTarget Nothing triple + withTargetOptions $ \options -> + withTargetMachine target triple cpu S.empty options R.Default CM.Default CGO.Default $ \tm -> + do layout <- getTargetMachineDataLayout tm + let ast = codegen (Target triple layout) (map snd defs) + result <- runErrorT . M.withModuleFromAST context ast $ \m -> + do let opts = defaultCuratedPassSetSpec + { optLevel = Just optimize + , simplifyLibCalls = Just True + , useInlinerWithThreshold = Just 225 + } + when (optimize /= 0) $ withPassManager opts $ void . flip runPassManager m + outputModule tm file outty m + case result of + Right _ -> return () + Left msg -> ierror msg + +failInIO :: ErrorT String IO a -> IO a +failInIO = either fail return <=< runErrorT + +outputModule :: TargetMachine -> FilePath -> OutputType -> M.Module -> IO () +outputModule _ file Raw m = failInIO $ M.writeBitcodeToFile file m +outputModule tm file Object m = failInIO $ M.writeObjectToFile tm file m +outputModule tm file Executable m = withTmpFile $ \obj -> do + outputModule tm obj Object m + cc <- getCC + defs <- ( "llvm" "libidris_rts.a") <$> getDataDir + exit <- rawSystem cc [obj, defs, "-lm", "-lgmp", "-lgc", "-o", file] + when (exit /= ExitSuccess) $ ierror "FAILURE: Linking" + +withTmpFile :: (FilePath -> IO a) -> IO a +withTmpFile f = do + (path, handle) <- tempfile + hClose handle + result <- f path + removeFile path + return result + +ierror :: String -> a +ierror msg = error $ "INTERNAL ERROR: IRTS.CodegenLLVM: " ++ msg + +mainDef :: Global +mainDef = + functionDefaults + { G.returnType = IntegerType 32 + , G.parameters = + ([ Parameter (IntegerType 32) (Name "argc") [] + , Parameter (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0)) (Name "argv") [] + ], False) + , G.name = Name "main" + , G.basicBlocks = + [ BasicBlock (UnName 0) + [ Do $ simpleCall "GC_init" [] -- Initialize Boehm GC + , Do $ simpleCall "__gmp_set_memory_functions" + [ ConstantOperand . C.GlobalReference . Name $ "__idris_gmpMalloc" + , ConstantOperand . C.GlobalReference . Name $ "__idris_gmpRealloc" + , ConstantOperand . C.GlobalReference . Name $ "__idris_gmpFree" + ] + , UnName 1 := idrCall "{runMain0}" [] ] + (Do $ Ret (Just (ConstantOperand (C.Int 32 0))) []) + ]} + +initDefs :: Target -> [Definition] +initDefs tgt = + [ TypeDefinition (Name "valTy") + (Just $ StructureType False + [ IntegerType 32 + , ArrayType 0 (PointerType valueType (AddrSpace 0)) + ]) + , TypeDefinition (Name "mpz") + (Just $ StructureType False + [ IntegerType 32 + , IntegerType 32 + , PointerType intPtr (AddrSpace 0) + ]) + , GlobalDefinition $ globalVariableDefaults + { G.name = Name "__idris_intFmtStr" + , G.linkage = L.Internal + , G.isConstant = True + , G.hasUnnamedAddr = True + , G.type' = ArrayType 5 (IntegerType 8) + , G.initializer = Just $ C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) "%lld" ++ [C.Int 8 0]) + } + , rtsFun "intStr" ptrI8 [IntegerType 64] + [ BasicBlock (UnName 0) + [ UnName 1 := simpleCall "GC_malloc_atomic" [ConstantOperand (C.Int (tgtWordSize tgt) 21)] + , UnName 2 := simpleCall "snprintf" + [ LocalReference (UnName 1) + , ConstantOperand (C.Int (tgtWordSize tgt) 21) + , ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_intFmtStr") [C.Int 32 0, C.Int 32 0] + , LocalReference (UnName 0) + ] + ] + (Do $ Ret (Just (LocalReference (UnName 1))) []) + ] + , exfun "llvm.trap" VoidType [] False + -- , exfun "llvm.llvm.memcpy.p0i8.p0i8.i32" VoidType [ptrI8, ptrI8, IntegerType 32, IntegerType 32, IntegerType 1] False + -- , exfun "llvm.llvm.memcpy.p0i8.p0i8.i64" VoidType [ptrI8, ptrI8, IntegerType 64, IntegerType 32, IntegerType 1] False + , exfun "memcpy" ptrI8 [ptrI8, ptrI8, intPtr] False + , exfun "llvm.invariant.start" (PointerType (StructureType False []) (AddrSpace 0)) [IntegerType 64, ptrI8] False + , exfun "snprintf" (IntegerType 32) [ptrI8, intPtr, ptrI8] True + , exfun "strcmp" (IntegerType 32) [ptrI8, ptrI8] False + , exfun "strlen" intPtr [ptrI8] False + , exfun "GC_init" VoidType [] False + , exfun "GC_malloc" ptrI8 [intPtr] False + , exfun "GC_malloc_atomic" ptrI8 [intPtr] False + , exfun "__gmp_set_memory_functions" VoidType + [ PointerType (FunctionType ptrI8 [intPtr] False) (AddrSpace 0) + , PointerType (FunctionType ptrI8 [ptrI8, intPtr, intPtr] False) (AddrSpace 0) + , PointerType (FunctionType VoidType [ptrI8, intPtr] False) (AddrSpace 0) + ] False + , exfun "__gmpz_init" VoidType [pmpz] False + , exfun "__gmpz_init_set_str" (IntegerType 32) [pmpz, ptrI8, IntegerType 32] False + , exfun "__gmpz_get_str" ptrI8 [ptrI8, IntegerType 32, pmpz] False + , exfun "__gmpz_get_ui" intPtr [pmpz] False + , exfun "__gmpz_cmp" (IntegerType 32) [pmpz, pmpz] False + , exfun "__gmpz_fdiv_q_2exp" VoidType [pmpz, pmpz, intPtr] False + , exfun "__gmpz_mul_2exp" VoidType [pmpz, pmpz, intPtr] False + , exfun "mpz_get_ull" (IntegerType 64) [pmpz] False + , exfun "mpz_init_set_ull" VoidType [pmpz, IntegerType 64] False + , exfun "mpz_init_set_sll" VoidType [pmpz, IntegerType 64] False + , exfun "__idris_strCons" ptrI8 [IntegerType 8, ptrI8] False + , exfun "__idris_readStr" ptrI8 [ptrI8] False -- Actually pointer to FILE, but it's opaque anyway + , exfun "__idris_gmpMalloc" ptrI8 [intPtr] False + , exfun "__idris_gmpRealloc" ptrI8 [ptrI8, intPtr, intPtr] False + , exfun "__idris_gmpFree" VoidType [ptrI8, intPtr] False + , exfun "__idris_strRev" ptrI8 [ptrI8] False + , exfun "strtoll" (IntegerType 64) [ptrI8, PointerType ptrI8 (AddrSpace 0), IntegerType 32] False + , exVar (stdinName tgt) ptrI8 + , exVar (stdoutName tgt) ptrI8 + , exVar (stderrName tgt) ptrI8 + , GlobalDefinition mainDef + ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"] + where + intPtr = IntegerType (tgtWordSize tgt) + ptrI8 = PointerType (IntegerType 8) (AddrSpace 0) + pmpz = PointerType mpzTy (AddrSpace 0) + + mpzBinFun n = exfun ("__gmpz_" ++ n) VoidType [pmpz, pmpz, pmpz] False + + rtsFun :: String -> Type -> [Type] -> [BasicBlock] -> Definition + rtsFun name rty argtys def = + GlobalDefinition $ functionDefaults + { G.linkage = L.Internal + , G.returnType = rty + , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], False) + , G.name = Name $ "__idris_" ++ name + , G.basicBlocks = def + } + + exfun :: String -> Type -> [Type] -> Bool -> Definition + exfun name rty argtys vari = + GlobalDefinition $ functionDefaults + { G.returnType = rty + , G.name = Name name + , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], vari) + } + exVar :: String -> Type -> Definition + exVar name ty = GlobalDefinition $ globalVariableDefaults { G.name = Name name, G.type' = ty } + +isApple :: Target -> Bool +isApple (Target { triple = t }) = isJust . stripPrefix "-apple" $ dropWhile (/= '-') t + +stdinName, stdoutName, stderrName :: Target -> String +stdinName t | isApple t = "__stdinp" +stdinName _ = "stdin" +stdoutName t | isApple t = "__stdoutp" +stdoutName _ = "stdout" +stderrName t | isApple t = "__stderrp" +stderrName _ = "stderr" + +getStdIn, getStdOut, getStdErr :: Codegen Operand +getStdIn = ConstantOperand . C.GlobalReference . Name . stdinName <$> asks target +getStdOut = ConstantOperand . C.GlobalReference . Name . stdoutName <$> asks target +getStdErr = ConstantOperand . C.GlobalReference . Name . stderrName <$> asks target + +codegen :: Target -> [SDecl] -> Module +codegen tgt defs = Module "idris" (Just . dataLayout $ tgt) (Just . triple $ tgt) (initDefs tgt ++ globals ++ gendefs) + where + (gendefs, _, globals) = runRWS (mapM cgDef defs) tgt 0 + +valueType :: Type +valueType = NamedTypeReference (Name "valTy") + +nullValue :: C.Constant +nullValue = C.Null (PointerType valueType (AddrSpace 0)) + +primTy :: Type -> Type +primTy inner = StructureType False [IntegerType 32, inner] + +mpzTy :: Type +mpzTy = NamedTypeReference (Name "mpz") + +conType :: Word64 -> Type +conType nargs = StructureType False + [ IntegerType 32 + , ArrayType nargs (PointerType valueType (AddrSpace 0)) + ] + +type Modgen = RWS Target [Definition] Word + +cgDef :: SDecl -> Modgen Definition +cgDef (SFun name argNames _ expr) = do + nextGlobal <- get + tgt <- ask + let (_, CGS { nextGlobalName = nextGlobal' }, (allocas, bbs, globals)) = + runRWS (do r <- cgExpr expr + case r of + Nothing -> terminate $ Unreachable [] + Just r' -> terminate $ Ret (Just r') []) + (CGR tgt (show name)) + (CGS 0 nextGlobal (Name "begin") [] (map (Just . LocalReference . Name . show) argNames) S.empty) + entryTerm = case bbs of + [] -> Do $ Ret Nothing [] + BasicBlock n _ _:_ -> Do $ Br n [] + tell globals + put nextGlobal' + return . GlobalDefinition $ functionDefaults + { G.linkage = L.Internal + , G.callingConvention = CC.Fast + , G.name = Name (show name) + , G.returnType = PointerType valueType (AddrSpace 0) + , G.parameters = (flip map argNames $ \argName -> + Parameter (PointerType valueType (AddrSpace 0)) (Name (show argName)) [] + , False) + , G.basicBlocks = + BasicBlock (Name "entry") + (map (\(n, t) -> n := Alloca t Nothing 0 []) allocas) + entryTerm + : bbs + } + +type CGW = ([(Name, Type)], [BasicBlock], [Definition]) + +type Env = [Maybe Operand] + +data CGS = CGS { nextName :: Word + , nextGlobalName :: Word + , currentBlockName :: Name + , instAccum :: [Named Instruction] + , lexenv :: Env + , foreignSyms :: Set String + } + +data CGR = CGR { target :: Target + , funcName :: String } + +type Codegen = RWS CGR CGW CGS + +getFuncName :: Codegen String +getFuncName = asks funcName + +getGlobalUnName :: Codegen Name +getGlobalUnName = do + i <- gets nextGlobalName + modify $ \s -> s { nextGlobalName = 1 + i } + return (UnName i) + +getUnName :: Codegen Name +getUnName = do + i <- gets nextName + modify $ \s -> s { nextName = 1 + i } + return (UnName i) + +getName :: String -> Codegen Name +getName n = do + i <- gets nextName + modify $ \s -> s { nextName = 1 + i } + return (Name $ n ++ show i) + +alloca :: Name -> Type -> Codegen () +alloca n t = tell ([(n, t)], [], []) + +terminate :: Terminator -> Codegen () +terminate term = do + name <- gets currentBlockName + insts <- gets instAccum + modify $ \s -> s { instAccum = ierror "Not in a block" + , currentBlockName = ierror "Not in a block" } + tell ([], [BasicBlock name insts (Do term)], []) + +newBlock :: Name -> Codegen () +newBlock name = modify $ \s -> s { instAccum = [] + , currentBlockName = name + } + +inst :: Instruction -> Codegen Operand +inst i = do + n <- getUnName + modify $ \s -> s { instAccum = instAccum s ++ [n := i] } + return $ LocalReference n + +ninst :: String -> Instruction -> Codegen Operand +ninst name i = do + n <- getName name + modify $ \s -> s { instAccum = instAccum s ++ [n := i] } + return $ LocalReference n + +inst' :: Instruction -> Codegen () +inst' i = modify $ \s -> s { instAccum = instAccum s ++ [Do i] } + +insts :: [Named Instruction] -> Codegen () +insts is = modify $ \s -> s { instAccum = instAccum s ++ is } + +var :: LVar -> Codegen (Maybe Operand) +var (Loc level) = (!! level) <$> gets lexenv +var (Glob n) = return . Just . ConstantOperand . C.GlobalReference . Name $ show n + +binds :: Env -> Codegen (Maybe Operand) -> Codegen (Maybe Operand) +binds vals cg = do + envLen <- length <$> gets lexenv + modify $ \s -> s { lexenv = lexenv s ++ vals } + value <- cg + modify $ \s -> s { lexenv = take envLen $ lexenv s } + return value + +replaceElt :: Int -> a -> [a] -> [a] +replaceElt _ val [] = error "replaceElt: Ran out of list" +replaceElt 0 val (x:xs) = val:xs +replaceElt n val (x:xs) = x : replaceElt (n-1) val xs + +alloc' :: Operand -> Codegen Operand +alloc' size = inst $ simpleCall "GC_malloc" [size] + +allocAtomic :: Operand -> Codegen Operand +allocAtomic size = inst $ simpleCall "GC_malloc_atomic" [size] + +alloc :: Type -> Codegen Operand +alloc ty = do + size <- sizeOf ty + mem <- alloc' size + inst $ BitCast mem (PointerType ty (AddrSpace 0)) [] + +sizeOf :: Type -> Codegen Operand +sizeOf ty = ConstantOperand . C.PtrToInt + (C.GetElementPtr True (C.Null (PointerType ty (AddrSpace 0))) [C.Int 32 1]) + . IntegerType <$> getWordSize + +loadInv :: Operand -> Instruction +loadInv ptr = Load False ptr Nothing 0 [("invariant.load", MetadataNode [])] + +tgtWordSize :: Target -> Word32 +tgtWordSize (Target { dataLayout = DataLayout { pointerLayouts = l } }) = + fst . fromJust $ M.lookup (AddrSpace 0) l + +getWordSize :: Codegen Word32 +getWordSize = tgtWordSize <$> asks target + +cgExpr :: SExp -> Codegen (Maybe Operand) +cgExpr (SV v) = var v +cgExpr (SApp tailcall fname args) = do + argSlots <- mapM var args + case sequence argSlots of + Nothing -> return Nothing + Just argVals -> do + fn <- var (Glob fname) + Just <$> inst ((idrCall (show fname) argVals) { isTailCall = tailcall }) +cgExpr (SLet _ varExpr bodyExpr) = do + val <- cgExpr varExpr + binds [val] $ cgExpr bodyExpr +cgExpr (SUpdate (Loc level) expr) = do + val <- cgExpr expr + modify $ \s -> s { lexenv = replaceElt level val (lexenv s) } + return val +cgExpr (SCon tag name args) = do + argSlots <- mapM var args + case sequence argSlots of + Nothing -> return Nothing + Just argVals -> do + let ty = conType . fromIntegral . length $ argVals + con <- alloc ty + tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] [] + inst' $ Store False tagPtr (ConstantOperand (C.Int 32 (fromIntegral tag))) Nothing 0 [] + forM_ (zip argVals [0..]) $ \(arg, i) -> do + ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0) + , ConstantOperand (C.Int 32 1) + , ConstantOperand (C.Int 32 i)] [] + inst' $ Store False ptr arg Nothing 0 [] + ptrI8 <- inst $ BitCast con (PointerType (IntegerType 8) (AddrSpace 0)) [] + inst' $ simpleCall "llvm.invariant.start" [ConstantOperand $ C.Int 64 (-1), ptrI8] + Just <$> inst (BitCast con (PointerType valueType (AddrSpace 0)) []) +cgExpr (SCase inspect alts) = do + val <- var inspect + case val of + Nothing -> return Nothing + Just v -> cgCase v alts +cgExpr (SChkCase inspect alts) = do + mval <- var inspect + case mval of + Nothing -> return Nothing + Just val -> + do endBBN <- getName "endChkCase" + notNullBBN <- getName "notNull" + originBlock <- gets currentBlockName + isNull <- inst $ ICmp IPred.EQ val (ConstantOperand nullValue) [] + terminate $ CondBr isNull endBBN notNullBBN [] + newBlock notNullBBN + ptr <- inst $ BitCast val (PointerType (IntegerType 32) (AddrSpace 0)) [] + flag <- inst $ loadInv ptr + isVal <- inst $ ICmp IPred.EQ flag (ConstantOperand (C.Int 32 (-1))) [] + conBBN <- getName "constructor" + terminate $ CondBr isVal endBBN conBBN [] + newBlock conBBN + result <- cgCase val alts + caseExitBlock <- gets currentBlockName + case result of + Nothing -> do + terminate $ Unreachable [] + newBlock endBBN + return $ Just val + Just caseVal -> do + terminate $ Br endBBN [] + newBlock endBBN + Just <$> inst (Phi (PointerType valueType (AddrSpace 0)) + [(val, originBlock), (val, notNullBBN), (caseVal, caseExitBlock)] []) +cgExpr (SProj conVar idx) = do + val <- var conVar + case val of + Nothing -> return Nothing + Just v -> + do ptr <- inst $ GetElementPtr True v + [ ConstantOperand (C.Int 32 0) + , ConstantOperand (C.Int 32 1) + , ConstantOperand (C.Int 32 (fromIntegral idx)) + ] [] + Just <$> inst (loadInv ptr) +cgExpr (SConst c) = Just <$> cgConst c +cgExpr (SForeign LANG_C rty fname args) = do + func <- ensureCDecl fname rty (map fst args) + argVals <- forM args $ \(fty, v) -> do + v' <- var v + case v' of + Just val -> return $ Just (fty, val) + Nothing -> return Nothing + case sequence argVals of + Nothing -> return Nothing + Just argVals' -> do + argUVals <- mapM (uncurry unbox) argVals' + result <- inst Call { isTailCall = False + , callingConvention = CC.C + , returnAttributes = [] + , function = Right func + , arguments = map (\v -> (v, [])) argUVals + , functionAttributes = [] + , metadata = [] + } + Just <$> box rty result +cgExpr (SOp fn args) = do + argVals <- mapM var args + case sequence argVals of + Just ops -> Just <$> cgOp fn ops + Nothing -> return Nothing +cgExpr SNothing = return . Just . ConstantOperand $ nullValue +cgExpr (SError msg) = do -- TODO: Print message + str <- addGlobal' (ArrayType (2 + fromIntegral (length msg)) (IntegerType 8)) + (cgConst' (TT.Str (msg ++ "\n"))) + inst' $ simpleCall "putStr" [ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0 + , C.Int 32 0]] + inst' Call { isTailCall = True + , callingConvention = CC.C + , returnAttributes = [] + , function = Right . ConstantOperand . C.GlobalReference . Name $ "llvm.trap" + , arguments = [] + , functionAttributes = [A.NoReturn] + , metadata = [] + } + return Nothing + +cgCase :: Operand -> [SAlt] -> Codegen (Maybe Operand) +cgCase val alts = + case find isConstCase alts of + Just (SConstCase (TT.BI _) _) -> cgChainCase val defExp constAlts + Just (SConstCase (TT.Str _) _) -> cgChainCase val defExp constAlts + Just (SConstCase _ _) -> cgPrimCase val defExp constAlts + Nothing -> cgConCase val defExp conAlts + where + defExp = getDefExp =<< find isDefCase alts + constAlts = filter isConstCase alts + conAlts = filter isConCase alts + + isConstCase (SConstCase {}) = True + isConstCase _ = False + + isConCase (SConCase {}) = True + isConCase _ = False + + isDefCase (SDefaultCase _) = True + isDefCase _ = False + + getDefExp (SDefaultCase e) = Just e + getDefExp _ = Nothing + +cgPrimCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand) +cgPrimCase caseValPtr defExp alts = do + let caseTy = case head alts of + SConstCase (TT.I _) _ -> IntegerType 32 + SConstCase (TT.B8 _) _ -> IntegerType 8 + SConstCase (TT.B16 _) _ -> IntegerType 16 + SConstCase (TT.B32 _) _ -> IntegerType 32 + SConstCase (TT.B64 _) _ -> IntegerType 64 + SConstCase (TT.Fl _) _ -> FloatingPointType 64 IEEE + SConstCase (TT.Ch _) _ -> IntegerType 32 + realPtr <- inst $ BitCast caseValPtr (PointerType (primTy caseTy) (AddrSpace 0)) [] + valPtr <- inst $ GetElementPtr True realPtr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] [] + caseVal <- inst $ loadInv valPtr + defBlockName <- getName "default" + exitBlockName <- getName "caseExit" + namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts + terminate $ Switch caseVal defBlockName (map (\(n, SConstCase c _) -> (cgConst' c, n)) namedAlts) [] + initEnv <- gets lexenv + defResult <- cgDefaultAlt exitBlockName defBlockName defExp + results <- forM namedAlts $ \(name, SConstCase _ exp) -> cgAlt initEnv exitBlockName name Nothing exp + finishCase initEnv exitBlockName (defResult:results) + +cgConCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand) +cgConCase con defExp alts = do + tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] [] + tag <- inst $ loadInv tagPtr + defBlockName <- getName "default" + exitBlockName <- getName "caseExit" + namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts + terminate $ Switch tag defBlockName (map (\(n, SConCase _ tag _ _ _) -> + (C.Int 32 (fromIntegral tag), n)) namedAlts) [] + initEnv <- gets lexenv + defResult <- cgDefaultAlt exitBlockName defBlockName defExp + results <- forM namedAlts $ \(name, SConCase _ _ _ argns exp) -> + cgAlt initEnv exitBlockName name (Just (con, map show argns)) exp + finishCase initEnv exitBlockName (defResult:results) + +cgChainCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand) +cgChainCase caseValPtr defExp alts = do + let (caseTy, comparator) = + case head alts of + SConstCase (TT.BI _) _ -> (FArith (ATInt ITBig), "__gmpz_cmp") + SConstCase (TT.Str _) _ -> (FString, "strcmp") + caseVal <- unbox caseTy caseValPtr + defBlockName <- getName "default" + exitBlockName <- getName "caseExit" + namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts + initEnv <- gets lexenv + results <- forM namedAlts $ \(name, SConstCase c e) -> + do const <- unbox caseTy =<< cgConst c + cmp <- inst $ simpleCall comparator [const, caseVal] + cmpResult <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) [] + elseName <- getName "else" + terminate $ CondBr cmpResult name elseName [] + result <- cgAlt initEnv exitBlockName name Nothing e + newBlock elseName + return result + modify $ \s -> s { lexenv = initEnv } + fname <- getFuncName + defaultVal <- cgExpr (fromMaybe (SError $ "Inexhaustive case failure in " ++ fname) defExp) + defaultBlock <- gets currentBlockName + defaultEnv <- gets lexenv + defResult <- case defaultVal of + Just v -> do + terminate $ Br exitBlockName [] + return $ Just (v, defaultBlock, defaultEnv) + Nothing -> do + terminate $ Unreachable [] + return Nothing + finishCase initEnv exitBlockName (defResult:results) + +finishCase :: Env -> Name -> [Maybe (Operand, Name, Env)] -> Codegen (Maybe Operand) +finishCase initEnv exitBlockName results = do + let definedResults = mapMaybe id results + case definedResults of + [] -> do modify $ \s -> s { lexenv = initEnv } + return Nothing + xs -> do + newBlock exitBlockName + mergeEnvs $ map (\(_, altBlock, altEnv) -> (altBlock, altEnv)) xs + Just <$> inst (Phi (PointerType valueType (AddrSpace 0)) + (map (\(altVal, altBlock, _) -> (altVal, altBlock)) xs) []) + + +cgDefaultAlt :: Name -> Name -> Maybe SExp -> Codegen (Maybe (Operand, Name, Env)) +cgDefaultAlt exitName name exp = do + newBlock name + fname <- getFuncName + val <- cgExpr (fromMaybe (SError $ "Inexhaustive case failure in " ++ fname) exp) + env <- gets lexenv + block <- gets currentBlockName + case val of + Just v -> + do terminate $ Br exitName [] + return $ Just (v, block, env) + Nothing -> + do terminate $ Unreachable [] + return Nothing + +cgAlt :: Env -> Name -> Name -> Maybe (Operand, [String]) -> SExp + -> Codegen (Maybe (Operand, Name, Env)) +cgAlt initEnv exitBlockName name destr exp = do + modify $ \s -> s { lexenv = initEnv } + newBlock name + locals <- case destr of + Nothing -> return [] + Just (con, argns) -> + forM (zip argns [0..]) $ \(argName, i) -> + do ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0) + , ConstantOperand (C.Int 32 1) + , ConstantOperand (C.Int 32 i)] [] + Just <$> ninst argName (loadInv ptr) + altVal <- binds locals $ cgExpr exp + altEnv <- gets lexenv + altBlock <- gets currentBlockName + case altVal of + Just v -> do + terminate $ Br exitBlockName [] + return $ Just (v, altBlock, altEnv) + Nothing -> do + terminate $ Unreachable [] + return Nothing + +mergeEnvs :: [(Name, Env)] -> Codegen () +mergeEnvs es = do + let vars = transpose + . map (\(block, env) -> map (\x -> (x, block)) env) + $ es + env <- forM vars $ \var -> + case var of + [] -> ierror "mergeEnvs: impossible" + [(v, _)] -> return v + vs@((v, _):_) + | all (== v) (map fst vs) -> return v + | otherwise -> + let valid = map (\(a, b) -> (fromJust a, b)) . filter (isJust . fst) $ vs in + Just <$> inst (Phi (PointerType valueType (AddrSpace 0)) valid []) + modify $ \s -> s { lexenv = env } + +nameAlt :: Name -> SAlt -> Codegen Name +nameAlt d (SDefaultCase _) = return d +nameAlt _ (SConCase _ _ name _ _) = getName (show name) +nameAlt _ (SConstCase const _) = getName (show const) + +box :: FType -> Operand -> Codegen Operand +box FUnit _ = return $ ConstantOperand nullValue +box fty fval = do + let ty = primTy (ftyToTy fty) + val <- alloc ty + tagptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] [] + valptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] [] + inst' $ Store False tagptr (ConstantOperand (C.Int 32 (-1))) Nothing 0 [] + inst' $ Store False valptr fval Nothing 0 [] + ptrI8 <- inst $ BitCast val (PointerType (IntegerType 8) (AddrSpace 0)) [] + inst' $ simpleCall "llvm.invariant.start" [ConstantOperand $ C.Int 64 (-1), ptrI8] + inst $ BitCast val (PointerType valueType (AddrSpace 0)) [] + +unbox :: FType -> Operand -> Codegen Operand +unbox FUnit x = return x +unbox fty bval = do + val <- inst $ BitCast bval (PointerType (primTy (ftyToTy fty)) (AddrSpace 0)) [] + fvalptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] [] + inst $ loadInv fvalptr + +cgConst' :: TT.Const -> C.Constant +cgConst' (TT.I i) = C.Int 32 (fromIntegral i) +cgConst' (TT.B8 i) = C.Int 8 (fromIntegral i) +cgConst' (TT.B16 i) = C.Int 16 (fromIntegral i) +cgConst' (TT.B32 i) = C.Int 32 (fromIntegral i) +cgConst' (TT.B64 i) = C.Int 64 (fromIntegral i) +cgConst' (TT.B8V v) = C.Vector (map ((C.Int 8) . fromIntegral) . V.toList $ v) +cgConst' (TT.B16V v) = C.Vector (map ((C.Int 16) . fromIntegral) . V.toList $ v) +cgConst' (TT.B32V v) = C.Vector (map ((C.Int 32) . fromIntegral) . V.toList $ v) +cgConst' (TT.B64V v) = C.Vector (map ((C.Int 64) . fromIntegral) . V.toList $ v) + +cgConst' (TT.BI i) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) (show i) ++ [C.Int 8 0]) +cgConst' (TT.Fl f) = C.Float (F.Double f) +cgConst' (TT.Ch c) = C.Int 32 . fromIntegral . fromEnum $ c +cgConst' (TT.Str s) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) s ++ [C.Int 8 0]) +cgConst' x = ierror $ "Unsupported constant: " ++ show x + +cgConst :: TT.Const -> Codegen Operand +cgConst c@(TT.I _) = box (FArith (ATInt ITNative)) (ConstantOperand $ cgConst' c) +cgConst c@(TT.B8 _) = box (FArith (ATInt (ITFixed IT8))) (ConstantOperand $ cgConst' c) +cgConst c@(TT.B16 _) = box (FArith (ATInt (ITFixed IT16))) (ConstantOperand $ cgConst' c) +cgConst c@(TT.B32 _) = box (FArith (ATInt (ITFixed IT32))) (ConstantOperand $ cgConst' c) +cgConst c@(TT.B64 _) = box (FArith (ATInt (ITFixed IT64))) (ConstantOperand $ cgConst' c) +cgConst c@(TT.B8V v) = box (FArith (ATInt (ITVec IT8 (V.length v)))) (ConstantOperand $ cgConst' c) +cgConst c@(TT.B16V v) = box (FArith (ATInt (ITVec IT16 (V.length v)))) (ConstantOperand $ cgConst' c) +cgConst c@(TT.B32V v) = box (FArith (ATInt (ITVec IT32 (V.length v)))) (ConstantOperand $ cgConst' c) +cgConst c@(TT.B64V v) = box (FArith (ATInt (ITVec IT64 (V.length v)))) (ConstantOperand $ cgConst' c) +cgConst c@(TT.Fl _) = box (FArith ATFloat) (ConstantOperand $ cgConst' c) +cgConst c@(TT.Ch _) = box (FArith (ATInt ITChar)) (ConstantOperand $ cgConst' c) +cgConst c@(TT.Str s) = do + str <- addGlobal' (ArrayType (1 + fromIntegral (length s)) (IntegerType 8)) (cgConst' c) + box FString (ConstantOperand $ C.GetElementPtr True str [C.Int 32 0, C.Int 32 0]) +cgConst c@(TT.BI i) = do + str <- addGlobal' (ArrayType (1 + fromInteger (numDigits 10 i)) (IntegerType 8)) (cgConst' c) + mpz <- alloc mpzTy + inst $ simpleCall "__gmpz_init_set_str" [mpz + , ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0, C.Int 32 0] + , ConstantOperand $ C.Int 32 10 + ] + box (FArith (ATInt ITBig)) mpz +cgConst x = return $ ConstantOperand nullValue + +numDigits :: Integer -> Integer -> Integer +numDigits b n = 1 + fst (ilog b n) where + ilog b n + | n < b = (0, n) + | otherwise = let (e, r) = ilog (b*b) n + in if r < b then (2*e, r) else (2*e+1, r `div` b) + +addGlobal :: Global -> Codegen () +addGlobal def = tell ([], [], [GlobalDefinition def]) + +addGlobal' :: Type -> C.Constant -> Codegen C.Constant +addGlobal' ty val = do + name <- getGlobalUnName + addGlobal $ globalVariableDefaults + { G.name = name + , G.linkage = L.Internal + , G.hasUnnamedAddr = True + , G.isConstant = True + , G.type' = ty + , G.initializer = Just val + } + return . C.GlobalReference $ name + + +ensureCDecl :: String -> FType -> [FType] -> Codegen Operand +ensureCDecl name rty argtys = do + syms <- gets foreignSyms + unless (S.member name syms) $ + do addGlobal (ffunDecl name rty argtys) + modify $ \s -> s { foreignSyms = S.insert name (foreignSyms s) } + return $ ConstantOperand (C.GlobalReference (Name name)) + +ffunDecl :: String -> FType -> [FType] -> Global +ffunDecl name rty argtys = + functionDefaults + { G.returnType = ftyToTy rty + , G.name = Name name + , G.parameters = (flip map argtys $ \fty -> + Parameter (ftyToTy fty) (UnName 0) [] + , False) + } + +ftyToTy :: FType -> Type +ftyToTy (FArith (ATInt ITNative)) = IntegerType 32 +ftyToTy (FArith (ATInt ITBig)) = PointerType mpzTy (AddrSpace 0) +ftyToTy (FArith (ATInt (ITFixed ty))) = IntegerType (fromIntegral $ nativeTyWidth ty) +ftyToTy (FArith (ATInt (ITVec e c))) + = VectorType (fromIntegral c) (IntegerType (fromIntegral $ nativeTyWidth e)) +ftyToTy (FArith (ATInt ITChar)) = IntegerType 32 +ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0) +ftyToTy FUnit = VoidType +ftyToTy FPtr = PointerType (IntegerType 8) (AddrSpace 0) +ftyToTy (FArith ATFloat) = FloatingPointType 64 IEEE +ftyToTy FAny = valueType + +-- Only use when known not to be ITBig +itWidth :: IntTy -> Word32 +itWidth ITNative = 32 +itWidth ITChar = 32 +itWidth (ITFixed x) = fromIntegral $ nativeTyWidth x +itWidth x = ierror $ "itWidth: " ++ show x + +itConst :: IntTy -> Integer -> C.Constant +itConst (ITFixed n) x = C.Int (fromIntegral $ nativeTyWidth n) x +itConst ITNative x = itConst (ITFixed IT32) x +itConst ITChar x = itConst (ITFixed IT32) x +itConst (ITVec elts size) x = C.Vector (replicate size (itConst (ITFixed elts) x)) + +cgOp :: PrimFn -> [Operand] -> Codegen Operand +cgOp (LTrunc ITBig ity) [x] = do + nx <- unbox (FArith (ATInt ITBig)) x + val <- inst $ simpleCall "mpz_get_ull" [nx] + v <- case ity of + (ITFixed IT64) -> return val + _ -> inst $ Trunc val (ftyToTy (FArith (ATInt ity))) [] + box (FArith (ATInt ity)) v +cgOp (LZExt from ITBig) [x] = do + nx <- unbox (FArith (ATInt from)) x + nx' <- case from of + (ITFixed IT64) -> return nx + _ -> inst $ ZExt nx (IntegerType 64) [] + mpz <- alloc mpzTy + inst' $ simpleCall "mpz_init_set_ull" [mpz, nx'] + box (FArith (ATInt ITBig)) mpz +cgOp (LSExt from ITBig) [x] = do + nx <- unbox (FArith (ATInt from)) x + nx' <- case from of + (ITFixed IT64) -> return nx + _ -> inst $ SExt nx (IntegerType 64) [] + mpz <- alloc mpzTy + inst' $ simpleCall "mpz_init_set_sll" [mpz, nx'] + box (FArith (ATInt ITBig)) mpz + +-- ITChar, ITNative, and IT32 all share representation +cgOp (LChInt ITNative) [x] = return x +cgOp (LIntCh ITNative) [x] = return x + +cgOp (LLt (ATInt ITBig)) [x,y] = mpzCmp IPred.SLT x y +cgOp (LLe (ATInt ITBig)) [x,y] = mpzCmp IPred.SLE x y +cgOp (LEq (ATInt ITBig)) [x,y] = mpzCmp IPred.EQ x y +cgOp (LGe (ATInt ITBig)) [x,y] = mpzCmp IPred.SGE x y +cgOp (LGt (ATInt ITBig)) [x,y] = mpzCmp IPred.SGT x y +cgOp (LPlus (ATInt ITBig)) [x,y] = mpzBin "add" x y +cgOp (LMinus (ATInt ITBig)) [x,y] = mpzBin "sub" x y +cgOp (LTimes (ATInt ITBig)) [x,y] = mpzBin "mul" x y +cgOp (LSDiv (ATInt ITBig)) [x,y] = mpzBin "fdiv_q" x y +cgOp (LSRem (ATInt ITBig)) [x,y] = mpzBin "fdiv_r" x y +cgOp (LAnd ITBig) [x,y] = mpzBin "and" x y +cgOp (LOr ITBig) [x,y] = mpzBin "ior" x y +cgOp (LXOr ITBig) [x,y] = mpzBin "xor" x y +cgOp (LCompl ITBig) [x] = mpzUn "com" x +cgOp (LSHL ITBig) [x,y] = mpzBit "mul_2exp" x y +cgOp (LASHR ITBig) [x,y] = mpzBit "fdiv_q_2exp" x y + +cgOp (LTrunc ITNative (ITFixed to)) [x] + | 32 >= nativeTyWidth to = iCoerce Trunc IT32 to x +cgOp (LZExt ITNative (ITFixed to)) [x] + | 32 <= nativeTyWidth to = iCoerce ZExt IT32 to x +cgOp (LSExt ITNative (ITFixed to)) [x] + | 32 <= nativeTyWidth to = iCoerce SExt IT32 to x + +cgOp (LTrunc (ITFixed from) ITNative) [x] + | nativeTyWidth from >= 32 = iCoerce Trunc from IT32 x +cgOp (LZExt (ITFixed from) ITNative) [x] + | nativeTyWidth from <= 32 = iCoerce ZExt from IT32 x +cgOp (LSExt (ITFixed from) ITNative) [x] + | nativeTyWidth from <= 32 = iCoerce SExt from IT32 x + +cgOp (LTrunc (ITFixed from) (ITFixed to)) [x] + | nativeTyWidth from > nativeTyWidth to = iCoerce Trunc from to x +cgOp (LZExt (ITFixed from) (ITFixed to)) [x] + | nativeTyWidth from < nativeTyWidth to = iCoerce ZExt from to x +cgOp (LSExt (ITFixed from) (ITFixed to)) [x] + | nativeTyWidth from < nativeTyWidth to = iCoerce SExt from to x + +cgOp (LLt (ATInt ity)) [x,y] = iCmp ity IPred.ULT x y +cgOp (LLe (ATInt ity)) [x,y] = iCmp ity IPred.ULE x y +cgOp (LEq (ATInt ity)) [x,y] = iCmp ity IPred.EQ x y +cgOp (LGe (ATInt ity)) [x,y] = iCmp ity IPred.UGE x y +cgOp (LGt (ATInt ity)) [x,y] = iCmp ity IPred.UGT x y +cgOp (LPlus (ATInt ity)) [x,y] = ibin ity x y (Add False False) +cgOp (LMinus (ATInt ity)) [x,y] = ibin ity x y (Sub False False) +cgOp (LTimes (ATInt ity)) [x,y] = ibin ity x y (Mul False False) +cgOp (LSDiv (ATInt ity)) [x,y] = ibin ity x y (SDiv False) +cgOp (LSRem (ATInt ity)) [x,y] = ibin ity x y SRem +cgOp (LUDiv ity) [x,y] = ibin ity x y (UDiv False) +cgOp (LURem ity) [x,y] = ibin ity x y URem +cgOp (LAnd ity) [x,y] = ibin ity x y And +cgOp (LOr ity) [x,y] = ibin ity x y Or +cgOp (LXOr ity) [x,y] = ibin ity x y Xor +cgOp (LCompl ity) [x] = iun ity x (Xor . ConstantOperand $ itConst ity (-1)) +cgOp (LSHL ity) [x,y] = ibin ity x y (Shl False False) +cgOp (LLSHR ity) [x,y] = ibin ity x y (LShr False) +cgOp (LASHR ity) [x,y] = ibin ity x y (AShr False) + +cgOp LNoOp xs = return $ last xs + +cgOp (LMkVec ety c) xs | c == length xs = do + nxs <- mapM (unbox (FArith (ATInt (ITFixed ety)))) xs + vec <- foldM (\v (e, i) -> inst $ InsertElement v e (ConstantOperand (C.Int 32 i)) []) + (ConstantOperand $ C.Vector (replicate c (C.Undef (IntegerType . fromIntegral $ nativeTyWidth ety)))) + (zip nxs [0..]) + box (FArith (ATInt (ITVec ety c))) vec + +cgOp (LIdxVec ety c) [v,i] = do + nv <- unbox (FArith (ATInt (ITVec ety c))) v + ni <- unbox (FArith (ATInt (ITFixed IT32))) i + elt <- inst $ ExtractElement nv ni [] + box (FArith (ATInt (ITFixed ety))) elt + +cgOp (LUpdateVec ety c) [v,i,e] = do + let fty = FArith (ATInt (ITVec ety c)) + nv <- unbox fty v + ni <- unbox (FArith (ATInt (ITFixed IT32))) i + ne <- unbox (FArith (ATInt (ITFixed ety))) e + nv' <- inst $ InsertElement nv ne ni [] + box fty nv' + +cgOp (LBitCast from to) [x] = do + nx <- unbox (FArith from) x + nx' <- inst $ BitCast nx (ftyToTy (FArith to)) [] + box (FArith to) nx' + +cgOp LStrEq [x,y] = do + x' <- unbox FString x + y' <- unbox FString y + cmp <- inst $ simpleCall "strcmp" [x', y'] + flag <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) [] + val <- inst $ ZExt flag (IntegerType 32) [] + box (FArith (ATInt (ITFixed IT32))) val + +cgOp LStrLt [x,y] = do + nx <- unbox FString x + ny <- unbox FString y + cmp <- inst $ simpleCall "strcmp" [nx, ny] + flag <- inst $ ICmp IPred.ULT cmp (ConstantOperand (C.Int 32 0)) [] + val <- inst $ ZExt flag (IntegerType 32) [] + box (FArith (ATInt (ITFixed IT32))) val + +cgOp (LIntStr ITBig) [x] = do + x' <- unbox (FArith (ATInt ITBig)) x + ustr <- inst $ simpleCall "__gmpz_get_str" + [ ConstantOperand (C.Null (PointerType (IntegerType 8) (AddrSpace 0))) + , ConstantOperand (C.Int 32 10) + , x' + ] + box FString ustr +cgOp (LIntStr ity) [x] = do + x' <- unbox (FArith (ATInt ity)) x + x'' <- if itWidth ity < 64 + then inst $ SExt x' (IntegerType 64) [] + else return x' + box FString =<< inst (idrCall "__idris_intStr" [x'']) +cgOp (LStrInt ITBig) [s] = do + ns <- unbox FString s + mpz <- alloc mpzTy + inst $ simpleCall "__gmpz_init_set_str" [mpz, ns, ConstantOperand $ C.Int 32 10] + box (FArith (ATInt ITBig)) mpz +cgOp (LStrInt ity) [s] = do + ns <- unbox FString s + nx <- inst $ simpleCall "strtoll" + [ns + , ConstantOperand $ C.Null (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0)) + , ConstantOperand $ C.Int 32 10 + ] + nx' <- case ity of + (ITFixed IT64) -> return nx + _ -> inst $ Trunc nx (IntegerType (itWidth ity)) [] + box (FArith (ATInt ity)) nx' + +cgOp LStrConcat [x,y] = cgStrCat x y + +cgOp LStrCons [c,s] = do + nc <- unbox (FArith (ATInt ITChar)) c + ns <- unbox FString s + nc' <- inst $ Trunc nc (IntegerType 8) [] + r <- inst $ simpleCall "__idris_strCons" [nc', ns] + box FString r + +cgOp LStrHead [c] = do + s <- unbox FString c + c <- inst $ loadInv s + c' <- inst $ ZExt c (IntegerType 32) [] + box (FArith (ATInt ITChar)) c' + +cgOp LStrIndex [s, i] = do + ns <- unbox FString s + ni <- unbox (FArith (ATInt (ITFixed IT32))) i + p <- inst $ GetElementPtr True ns [ni] [] + c <- inst $ loadInv p + c' <- inst $ ZExt c (IntegerType 32) [] + box (FArith (ATInt ITChar)) c' + +cgOp LStrTail [c] = do + s <- unbox FString c + c <- inst $ GetElementPtr True s [ConstantOperand $ C.Int 32 1] [] + box FString c + +cgOp LStrLen [s] = do + ns <- unbox FString s + len <- inst $ simpleCall "strlen" [ns] + ws <- getWordSize + len' <- case ws of + 32 -> return len + x | x > 32 -> inst $ Trunc len (IntegerType 32) [] + | x < 32 -> inst $ ZExt len (IntegerType 32) [] + box (FArith (ATInt (ITFixed IT32))) len' + +cgOp LStrRev [s] = do + ns <- unbox FString s + box FString =<< inst (simpleCall "__idris_strRev" [ns]) + +cgOp LReadStr [p] = do + np <- unbox FPtr p + s <- inst $ simpleCall "__idris_readStr" [np] + box FString s + +cgOp LStdIn [] = do + stdin <- getStdIn + ptr <- inst $ loadInv stdin + box FPtr ptr +cgOp LStdOut [] = do + stdout <- getStdOut + ptr <- inst $ loadInv stdout + box FPtr ptr +cgOp LStdErr [] = do + stdErr <- getStdErr + ptr <- inst $ loadInv stdErr + box FPtr ptr + +cgOp prim args = ierror $ "Unimplemented primitive: <" ++ show prim ++ ">(" + ++ intersperse ',' (take (length args) ['a'..]) ++ ")" + +iCoerce :: (Operand -> Type -> InstructionMetadata -> Instruction) -> NativeTy -> NativeTy -> Operand -> Codegen Operand +iCoerce _ from to x | from == to = return x +iCoerce operator from to x = do + x' <- unbox (FArith (ATInt (ITFixed from))) x + x'' <- inst $ operator x' (ftyToTy (FArith (ATInt (ITFixed to)))) [] + box (FArith (ATInt (ITFixed to))) x'' + +cgStrCat :: Operand -> Operand -> Codegen Operand +cgStrCat x y = do + x' <- unbox FString x + y' <- unbox FString y + xlen <- inst $ simpleCall "strlen" [x'] + ylen <- inst $ simpleCall "strlen" [y'] + zlen <- inst $ Add False True xlen ylen [] + ws <- getWordSize + total <- inst $ Add False True zlen (ConstantOperand (C.Int ws 1)) [] + mem <- allocAtomic total + inst $ simpleCall "memcpy" [mem, x', xlen] + i <- inst $ PtrToInt mem (IntegerType ws) [] + offi <- inst $ Add False True i xlen [] + offp <- inst $ IntToPtr offi (PointerType (IntegerType 8) (AddrSpace 0)) [] + inst $ simpleCall "memcpy" [offp, y', ylen] + j <- inst $ PtrToInt offp (IntegerType ws) [] + offj <- inst $ Add False True j ylen [] + end <- inst $ IntToPtr offj (PointerType (IntegerType 8) (AddrSpace 0)) [] + inst' $ Store False end (ConstantOperand (C.Int 8 0)) Nothing 0 [] + box FString mem + +ibin :: IntTy -> Operand -> Operand + -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand +ibin ity x y instCon = do + nx <- unbox (FArith (ATInt ity)) x + ny <- unbox (FArith (ATInt ity)) y + nr <- inst $ instCon nx ny [] + box (FArith (ATInt ity)) nr + +iun :: IntTy -> Operand -> (Operand -> InstructionMetadata -> Instruction) -> Codegen Operand +iun ity x instCon = do + nx <- unbox (FArith (ATInt ity)) x + nr <- inst $ instCon nx [] + box (FArith (ATInt ity)) nr + +iCmp :: IntTy -> IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand +iCmp ity pred x y = do + nx <- unbox (FArith (ATInt ity)) x + ny <- unbox (FArith (ATInt ity)) y + nr <- inst $ ICmp pred nx ny [] + nr' <- inst $ SExt nr (ftyToTy $ cmpResultTy ity) [] + box (cmpResultTy ity) nr' + +cmpResultTy :: IntTy -> FType +cmpResultTy v@(ITVec _ _) = FArith (ATInt v) +cmpResultTy _ = FArith (ATInt (ITFixed IT32)) + +mpzBin :: String -> Operand -> Operand -> Codegen Operand +mpzBin name x y = do + nx <- unbox (FArith (ATInt ITBig)) x + ny <- unbox (FArith (ATInt ITBig)) y + nz <- alloc mpzTy + inst' $ simpleCall "__gmpz_init" [nz] + inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, ny] + box (FArith (ATInt ITBig)) nz + +mpzBit :: String -> Operand -> Operand -> Codegen Operand +mpzBit name x y = do + nx <- unbox (FArith (ATInt ITBig)) x + ny <- unbox (FArith (ATInt ITBig)) y + bitcnt <- inst $ simpleCall "__gmpz_get_ui" [ny] + nz <- alloc mpzTy + inst' $ simpleCall "__gmpz_init" [nz] + inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, bitcnt] + box (FArith (ATInt ITBig)) nz + +mpzUn :: String -> Operand -> Codegen Operand +mpzUn name x = do + nx <- unbox (FArith (ATInt ITBig)) x + nz <- alloc mpzTy + inst' $ simpleCall "__gmpz_init" [nz] + inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx] + box (FArith (ATInt ITBig)) nz + +mpzCmp :: IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand +mpzCmp pred x y = do + nx <- unbox (FArith (ATInt ITBig)) x + ny <- unbox (FArith (ATInt ITBig)) y + cmp <- inst $ simpleCall "__gmpz_cmp" [nx, ny] + result <- inst $ ICmp pred cmp (ConstantOperand (C.Int 32 0)) [] + i <- inst $ ZExt result (IntegerType 32) [] + box (FArith (ATInt (ITFixed IT32))) i + +simpleCall :: String -> [Operand] -> Instruction +simpleCall name args = + Call { isTailCall = False + , callingConvention = CC.C + , returnAttributes = [] + , function = Right . ConstantOperand . C.GlobalReference . Name $ name + , arguments = map (\x -> (x, [])) args + , functionAttributes = [] + , metadata = [] + } + +idrCall :: String -> [Operand] -> Instruction +idrCall name args = + Call { isTailCall = False + , callingConvention = CC.Fast + , returnAttributes = [] + , function = Right . ConstantOperand . C.GlobalReference . Name $ name + , arguments = map (\x -> (x, [])) args + , functionAttributes = [] + , metadata = [] + } + +assert :: Operand -> String -> Codegen () +assert condition message = do + passed <- getName "assertPassed" + failed <- getName "assertFailed" + terminate $ CondBr condition passed failed [] + newBlock failed + cgExpr (SError message) + terminate $ Unreachable [] + newBlock passed diff --git a/src/IRTS/Compiler.hs b/src/IRTS/Compiler.hs --- a/src/IRTS/Compiler.hs +++ b/src/IRTS/Compiler.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PatternGuards, TypeSynonymInstances #-} +{-# LANGUAGE PatternGuards, TypeSynonymInstances, CPP #-} module IRTS.Compiler where @@ -10,6 +10,11 @@ import IRTS.CodegenJava import IRTS.DumpBC import IRTS.CodegenJavaScript +#ifdef IDRIS_LLVM +import IRTS.CodegenLLVM +#else +import Util.LLVMStubs +#endif import IRTS.Inliner import Idris.AbsSyntax @@ -29,8 +34,8 @@ import Paths_idris -compile :: Target -> FilePath -> Term -> Idris () -compile target f tm +compile :: Codegen -> FilePath -> Term -> Idris () +compile codegen f tm = do checkMVs let tmnames = namesUsed (STerm tm) usedIn <- mapM (allNames []) tmnames @@ -38,9 +43,9 @@ defsIn <- mkDecls tm (concat used) findUnusedArgs (concat used) maindef <- irMain tm - objs <- getObjectFiles - libs <- getLibs - hdrs <- getHdrs + objs <- getObjectFiles codegen + libs <- getLibs codegen + hdrs <- getHdrs codegen let defs = defsIn ++ [(MN 0 "runMain", maindef)] -- iputStrLn $ showSep "\n" (map show defs) let (nexttag, tagged) = addTags 65536 (liftAll defs) @@ -63,9 +68,12 @@ case dumpDefun of Nothing -> return () Just f -> liftIO $ writeFile f (dumpDefuns defuns) + triple <- targetTriple + cpu <- targetCPU + optimize <- optLevel iLOG "Building output" case checked of - OK c -> liftIO $ case target of + OK c -> liftIO $ case codegen of ViaC -> codegenC c f outty hdrs (concatMap mkObj objs) @@ -74,8 +82,9 @@ codegenJava [] c f hdrs libs outty ViaJavaScript -> codegenJavaScript JavaScript c f outty - ViaNode -> + ViaNode -> codegenJavaScript Node c f outty + ViaLLVM -> codegenLLVM c triple cpu optimize f outty Bytecode -> dumpBC c f Error e -> fail $ show e @@ -228,10 +237,10 @@ where mkUnused u i [] = [] mkUnused u i (x : xs) | i `elem` u = LNothing : mkUnused u (i + 1) xs | otherwise = x : mkUnused u (i + 1) xs --- ir' env (P _ (NS (UN "O") ["Nat", "Prelude"]) _) +-- ir' env (P _ (NS (UN "Z") ["Nat", "Prelude"]) _) -- = return $ LConst (BI 0) ir' env (P _ n _) = return $ LV (Glob n) - ir' env (V i) | i < length env = return $ LV (Glob (env!!i)) + ir' env (V i) | i >= 0 && i < length env = return $ LV (Glob (env!!i)) | otherwise = error $ "IR fail " ++ show i ++ " " ++ show tm ir' env (Bind n (Lam _) sc) = do let n' = uniqueName n env @@ -287,21 +296,42 @@ mkIty' (P _ (UN ty) _) = mkIty ty mkIty' (App (P _ (UN "FIntT") _) (P _ (UN intTy) _)) = mkIntIty intTy +mkIty' (App (App (P _ (UN "FFunction") _) _) (App (P _ (UN "FAny") _) (App (P _ (UN "IO") _) _))) = FFunctionIO +mkIty' (App (App (P _ (UN "FFunction") _) _) _) = FFunction mkIty' _ = FAny -mkIty "FFloat" = FDouble -mkIty "FChar" = FChar -mkIty "FString" = FString -mkIty "FPtr" = FPtr -mkIty "FUnit" = FUnit +-- would be better if these FInt types were evaluated at compile time +-- TODO: add %eval directive for such things -mkIntIty "ITNative" = FInt ITNative -mkIntIty "IT8" = FInt IT8 -mkIntIty "IT16" = FInt IT16 -mkIntIty "IT32" = FInt IT32 -mkIntIty "IT64" = FInt IT64 +mkIty "FFloat" = FArith ATFloat +mkIty "FInt" = mkIntIty "ITNative" +mkIty "FChar" = mkIntIty "ITChar" +mkIty "FByte" = mkIntIty "IT8" +mkIty "FShort" = mkIntIty "IT16" +mkIty "FLong" = mkIntIty "IT64" +mkIty "FBits8" = mkIntIty "IT8" +mkIty "FBits16" = mkIntIty "IT16" +mkIty "FBits32" = mkIntIty "IT32" +mkIty "FBits64" = mkIntIty "IT64" +mkIty "FString" = FString +mkIty "FPtr" = FPtr +mkIty "FUnit" = FUnit +mkIty "FFunction" = FFunction +mkIty "FFunctionIO" = FFunctionIO +mkIty "FBits8x16" = FArith (ATInt (ITVec IT8 16)) +mkIty "FBits16x8" = FArith (ATInt (ITVec IT16 8)) +mkIty "FBits32x4" = FArith (ATInt (ITVec IT32 4)) +mkIty "FBits64x2" = FArith (ATInt (ITVec IT64 2)) +mkIty x = error $ "Unknown type " ++ x -zname = NS (UN "O") ["Nat","Prelude"] +mkIntIty "ITNative" = FArith (ATInt ITNative) +mkIntIty "ITChar" = FArith (ATInt ITChar) +mkIntIty "IT8" = FArith (ATInt (ITFixed IT8)) +mkIntIty "IT16" = FArith (ATInt (ITFixed IT16)) +mkIntIty "IT32" = FArith (ATInt (ITFixed IT32)) +mkIntIty "IT64" = FArith (ATInt (ITFixed IT64)) + +zname = NS (UN "Z") ["Nat","Prelude"] sname = NS (UN "S") ["Nat","Prelude"] instance ToIR ([Name], SC) where @@ -321,7 +351,7 @@ return $ LCase (LV (Glob n)) alts' ir' ImpossibleCase = return LNothing - -- special cases for O and S + -- special cases for Z and S -- Needs rethink: projections make this fail -- mkIRAlt n (ConCase z _ [] rhs) | z == zname -- = mkIRAlt n (ConstCase (BI 0) rhs) @@ -353,15 +383,15 @@ matchable (Str _) = True matchable _ = False - matchableTy IType = True - matchableTy BIType = True - matchableTy ChType = True + matchableTy (AType (ATInt ITNative)) = True + matchableTy (AType (ATInt ITBig)) = True + matchableTy (AType (ATInt ITChar)) = True matchableTy StrType = True - matchableTy B8Type = True - matchableTy B16Type = True - matchableTy B32Type = True - matchableTy B64Type = True + matchableTy (AType (ATInt (ITFixed IT8))) = True + matchableTy (AType (ATInt (ITFixed IT16))) = True + matchableTy (AType (ATInt (ITFixed IT32))) = True + matchableTy (AType (ATInt (ITFixed IT64))) = True matchableTy _ = False diff --git a/src/IRTS/Defunctionalise.hs b/src/IRTS/Defunctionalise.hs --- a/src/IRTS/Defunctionalise.hs +++ b/src/IRTS/Defunctionalise.hs @@ -218,7 +218,8 @@ mkBigCase (MN 0 "APPLY") 256 (DApp False (MN 0 "EVAL") [DV (Glob (MN 0 "fn"))]) - cases)) + (cases ++ + [DDefaultCase DNothing]))) where applyCase (n, t, ApplyCase x) = Just x applyCase _ = Nothing diff --git a/src/IRTS/Java/ASTBuilding.hs b/src/IRTS/Java/ASTBuilding.hs new file mode 100644 --- /dev/null +++ b/src/IRTS/Java/ASTBuilding.hs @@ -0,0 +1,141 @@ +module IRTS.Java.ASTBuilding where + +import IRTS.Java.JTypes + +import Language.Java.Syntax hiding (Name) +import qualified Language.Java.Syntax as J + +toClassType :: J.Type -> ClassType +toClassType (RefType (ClassRefType ct)) = ct +toClassType t = error $ "Not a class type: " ++ (show t) + +toRefType :: J.Type -> RefType +toRefType (RefType rt) = rt +toRefType t = error $ "Not a ref type: " ++ (show t) + +class InvocationTarget a where + (~>) :: a -> String -> [Argument] -> Exp + +instance InvocationTarget ClassType where + (~>) (ClassType ts) method args = + MethodInv $ TypeMethodCall + (J.Name $ map fst ts) + (concatMap (map fromActType . snd) ts) + (Ident method) + args + where + fromActType (ActualType refType) = refType + +instance InvocationTarget Exp where + (~>) exp method args = + MethodInv $ PrimaryMethodCall + exp + [] + (Ident method) + args + +instance InvocationTarget J.Type where + (~>) t method args = ((toClassType t) ~> method) args + +class Callable a where + call :: a -> [Argument] -> Exp + +instance Callable String where + call method args = + MethodInv $ MethodCall (J.Name [Ident method]) args + +instance Callable Ident where + call method args = + MethodInv $ MethodCall (J.Name [method]) args + +instance Callable J.Name where + call method args = + MethodInv $ MethodCall method args + +(<>) :: Type -> Exp -> Exp +(<>) = Cast + +localVar :: Int -> Ident +localVar i = Ident $ "loc" ++ show i + +(@!) :: Exp -> Int -> ArrayIndex +(@!) target pos = + ArrayIndex target (Lit $ Int (toInteger pos)) + +(@:=) :: Either ArrayIndex Ident -> Exp -> BlockStmt +(@:=) (Right lhs) rhs = + LocalVars [Final] objectType [VarDecl (VarId lhs) (Just $ InitExp rhs)] +(@:=) (Left lhs) rhs = + BlockStmt . ExpStmt $ Assign (ArrayLhs lhs) EqualA rhs + +(~&&~) :: Exp -> Exp -> Exp +(~&&~) e1 e2 = BinOp e1 CAnd e2 + +(~==~) :: Exp -> Exp -> Exp +(~==~) e1 e2 = BinOp e1 Equal e2 + +addToBlock :: [BlockStmt] -> Exp -> [BlockStmt] +addToBlock blk exp = blk ++ [BlockStmt $ ExpStmt exp] + +jName :: String -> J.Name +jName n = J.Name [Ident n] + +jConst :: String -> Exp +jConst = ExpName . jName + +jReturn :: Exp -> BlockStmt +jReturn = BlockStmt . Return . Just + +jInt :: Int -> Exp +jInt = Lit . Int . toInteger + +jString :: String -> Exp +jString = Lit . String + +simpleMethod :: [Modifier] -> Maybe J.Type -> String -> [FormalParam] -> Block -> Decl +simpleMethod mods t name params body = + MemberDecl $ MethodDecl + mods + [] + t + (Ident $ name) + params + [] + (MethodBody . Just $ body) + +declareFinalObjectArray :: Ident -> Maybe VarInit -> BlockStmt +declareFinalObjectArray name init = + LocalVars [Final] + (array objectType) + [ VarDecl + (VarDeclArray . VarId $ name) + init + ] + +arrayInitExps :: [Exp] -> VarInit +arrayInitExps = InitArray . ArrayInit . map (InitExp) + +extendWithNull :: [Exp] -> Int -> [Exp] +extendWithNull exps additionalZeros = + exps ++ (replicate additionalZeros (Lit $ Null)) + +closure :: Exp -> Exp +closure body = + InstanceCreation + [] + (toClassType idrisClosureType) + [] + (Just $ ClassBody + [ simpleMethod + [Public, Final] (Just objectType) "call" [] + (Block [jReturn body]) + ] + ) + +bigInteger :: String -> Exp +bigInteger s = + InstanceCreation + [] + (toClassType bigIntegerType) + [Lit $ String s] + Nothing diff --git a/src/IRTS/Java/JTypes.hs b/src/IRTS/Java/JTypes.hs new file mode 100644 --- /dev/null +++ b/src/IRTS/Java/JTypes.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE PatternGuards #-} +module IRTS.Java.JTypes where + +import Core.TT +import IRTS.Lang +import Language.Java.Syntax +import qualified Language.Java.Syntax as J + +import qualified Data.Vector.Unboxed as V + +----------------------------------------------------------------------- +-- Primitive types + +charType :: J.Type +charType = + PrimType CharT + +byteType :: J.Type +byteType = PrimType ByteT + +shortType :: J.Type +shortType = PrimType ShortT + +integerType :: J.Type +integerType = PrimType IntT + +longType :: J.Type +longType = PrimType LongT + +doubleType :: J.Type +doubleType = PrimType DoubleT + +array :: J.Type -> J.Type +array t = RefType . ArrayType $ t + +----------------------------------------------------------------------- +-- Boxed types + +objectType :: J.Type +objectType = + RefType . ClassRefType $ ClassType [(Ident "Object", [])] + +bigIntegerType :: J.Type +bigIntegerType = + RefType . ClassRefType $ ClassType [(Ident "BigInteger", [])] + +stringType :: J.Type +stringType = + RefType . ClassRefType $ ClassType [(Ident "String", [])] + +threadType :: J.Type +threadType = + RefType . ClassRefType $ ClassType [(Ident "Thread", [])] + +callableType :: J.Type +callableType = + RefType . ClassRefType $ ClassType [(Ident "Callable", [])] + +voidType :: J.Type +voidType = + RefType . ClassRefType $ ClassType [(Ident "Void", [])] + +box :: J.Type -> J.Type +box (PrimType CharT ) = RefType . ClassRefType $ ClassType [(Ident "Character", [])] +box (PrimType ByteT ) = RefType . ClassRefType $ ClassType [(Ident "Byte", [])] +box (PrimType ShortT ) = RefType . ClassRefType $ ClassType [(Ident "Short", [])] +box (PrimType IntT ) = RefType . ClassRefType $ ClassType [(Ident "Integer", [])] +box (PrimType LongT ) = RefType . ClassRefType $ ClassType [(Ident "Long", [])] +box (PrimType DoubleT) = RefType . ClassRefType $ ClassType [(Ident "Double", [])] +box t = t + +isFloating :: J.Type -> Bool +isFloating (PrimType DoubleT) = True +isFloating (PrimType FloatT) = True +isFloating _ = False + +isPrimitive :: J.Type -> Bool +isPrimitive (PrimType _) = True +isPrimitive _ = False + +isArray :: J.Type -> Bool +isArray (RefType (ArrayType _)) = True +isArray _ = False + +isString :: J.Type -> Bool +isString (RefType (ClassRefType (ClassType [(Ident "String", _)]))) = True +isString _ = False + +----------------------------------------------------------------------- +-- Idris rts classes + +idrisClosureType :: J.Type +idrisClosureType = + RefType . ClassRefType $ ClassType [(Ident "Closure", [])] + +idrisTailCallClosureType :: J.Type +idrisTailCallClosureType = + RefType . ClassRefType $ ClassType [(Ident "TailCallClosure", [])] + +idrisObjectType :: J.Type +idrisObjectType = + RefType . ClassRefType $ ClassType [(Ident "IdrisObject", [])] + +foreignWrapperType :: J.Type +foreignWrapperType = + RefType . ClassRefType $ ClassType [(Ident "ForeignWrapper", [])] + +primFnType :: J.Type +primFnType = + RefType . ClassRefType $ ClassType [(Ident "PrimFn", [])] + +----------------------------------------------------------------------- +-- Java utility classes + +arraysType :: J.Type +arraysType = + RefType . ClassRefType $ ClassType [(Ident "Arrays", [])] + +mathType :: J.Type +mathType = + RefType . ClassRefType $ ClassType [(Ident "Math", [])] + + +----------------------------------------------------------------------- +-- Exception types + +exceptionType :: J.Type +exceptionType = + RefType . ClassRefType $ ClassType [(Ident "Exception", [])] + +runtimeExceptionType :: J.Type +runtimeExceptionType = + RefType . ClassRefType $ ClassType [(Ident "RuntimeException", [])] + +nativeTyToJType :: NativeTy -> J.Type +nativeTyToJType IT8 = byteType +nativeTyToJType IT16 = shortType +nativeTyToJType IT32 = integerType +nativeTyToJType IT64 = longType + +intTyToJType :: IntTy -> J.Type +intTyToJType (ITFixed nt) = nativeTyToJType nt +intTyToJType (ITNative) = integerType +intTyToJType (ITBig) = bigIntegerType +intTyToJType (ITChar) = charType +intTyToJType (ITVec nt _) = array $ nativeTyToJType nt + +arithTyToJType :: ArithTy -> J.Type +arithTyToJType (ATInt it) = intTyToJType it +arithTyToJType (ATFloat) = doubleType + +----------------------------------------------------------------------- +-- Context variables + +localContextID :: Ident +localContextID = Ident "context" + +localContext :: Exp +localContext = ExpName $ Name [localContextID] + +globalContextID :: Ident +globalContextID = Ident "globalContext" + +globalContext :: Exp +globalContext = ExpName $ Name [globalContextID] + +newContextID :: Ident +newContextID = Ident "new_context" + +newContext :: Exp +newContext = ExpName $ Name [newContextID] + +contextArray :: LVar -> Exp +contextArray (Loc _) = localContext +contextArray (Glob _) = globalContext + +contextParam :: FormalParam +contextParam = FormalParam [Final] (array objectType) False (VarId localContextID) + +----------------------------------------------------------------------- +-- Constant types + +constType :: Const -> J.Type +constType (I _) = arithTyToJType (ATInt ITNative) +constType (BI _) = arithTyToJType (ATInt ITBig ) +constType (Fl _) = arithTyToJType (ATFloat ) +constType (Ch _) = arithTyToJType (ATInt ITChar ) +constType (Str _) = stringType +constType (B8 _) = arithTyToJType (ATInt $ ITFixed IT8 ) +constType (B16 _) = arithTyToJType (ATInt $ ITFixed IT16) +constType (B32 _) = arithTyToJType (ATInt $ ITFixed IT32) +constType (B64 _) = arithTyToJType (ATInt $ ITFixed IT64) +constType (B8V v) = arithTyToJType (ATInt . ITVec IT8 $ V.length v) +constType (B16V v) = arithTyToJType (ATInt . ITVec IT16 $ V.length v) +constType (B32V v) = arithTyToJType (ATInt . ITVec IT32 $ V.length v) +constType (B64V v) = arithTyToJType (ATInt . ITVec IT64 $ V.length v) +constType _ = objectType + +----------------------------------------------------------------------- +-- Foreign types + +foreignType :: FType -> Maybe J.Type +foreignType (FArith at) = Just $ arithTyToJType at +foreignType (FFunction ) = Just $ callableType +foreignType (FFunctionIO ) = Just $ callableType +foreignType (FString ) = Just $ stringType +foreignType (FUnit ) = Nothing +foreignType (FPtr ) = Just $ objectType +foreignType (FAny ) = Just $ objectType + +----------------------------------------------------------------------- +-- Primitive operation analysis + +opName :: PrimFn -> String +opName x + | (LSExt _ to) <- x = "LSExt" ++ (suffixFor to) + | (LZExt _ to) <- x = "LZExt" ++ (suffixFor to) + | (LTrunc _ to) <- x = "LTrunc" ++ (suffixFor to) + | (LFloatInt to) <- x = "LFloatInt" ++ (suffixFor to) + | (LStrInt to) <- x = "LStrInt" ++ (suffixFor to) + | otherwise = takeWhile ((/=) ' ') $ show x + where + suffixFor (ITFixed nt) = show nt + suffixFor (ITNative) = show IT32 + suffixFor (ITBig) = show ITBig + suffixFor (ITChar) = show ITChar + suffixFor (ITVec nt _) = "ITVec" ++ (show $ nativeTyWidth nt) + +sourceTypes :: PrimFn -> [J.Type] +sourceTypes (LPlus from) = [arithTyToJType from, arithTyToJType from] +sourceTypes (LMinus from) = [arithTyToJType from, arithTyToJType from] +sourceTypes (LTimes from) = [arithTyToJType from, arithTyToJType from] +sourceTypes (LUDiv from) = [intTyToJType from, intTyToJType from] +sourceTypes (LSDiv from) = [arithTyToJType from, arithTyToJType from] +sourceTypes (LURem from) = [intTyToJType from, intTyToJType from] +sourceTypes (LSRem from) = [arithTyToJType from, arithTyToJType from] +sourceTypes (LAnd from) = [intTyToJType from, intTyToJType from] +sourceTypes (LOr from) = [intTyToJType from, intTyToJType from] +sourceTypes (LXOr from) = [intTyToJType from, intTyToJType from] +sourceTypes (LCompl from) = [intTyToJType from] +sourceTypes (LSHL from) = [intTyToJType from, intTyToJType from] +sourceTypes (LLSHR from) = [intTyToJType from, intTyToJType from] +sourceTypes (LASHR from) = [intTyToJType from, intTyToJType from] +sourceTypes (LEq from) = [arithTyToJType from, arithTyToJType from] +sourceTypes (LLt from) = [arithTyToJType from, arithTyToJType from] +sourceTypes (LLe from) = [arithTyToJType from, arithTyToJType from] +sourceTypes (LGt from) = [arithTyToJType from, arithTyToJType from] +sourceTypes (LGe from) = [arithTyToJType from, arithTyToJType from] +sourceTypes (LSExt from _) = [intTyToJType from] +sourceTypes (LZExt from _) = [intTyToJType from] +sourceTypes (LTrunc from _) = [intTyToJType from] +sourceTypes (LStrConcat) = repeat stringType +sourceTypes (LStrLt) = [stringType, stringType] +sourceTypes (LStrEq) = [stringType, stringType] +sourceTypes (LStrLen) = [stringType] +sourceTypes (LIntFloat from) = [intTyToJType from] +sourceTypes (LFloatInt _) = [doubleType] +sourceTypes (LIntStr from) = [intTyToJType from] +sourceTypes (LStrInt from) = [stringType] +sourceTypes (LFloatStr) = [doubleType] +sourceTypes (LStrFloat) = [stringType] +sourceTypes (LChInt _) = [charType] +sourceTypes (LIntCh from) = [intTyToJType from] +sourceTypes (LPrintNum) = [objectType] +sourceTypes (LPrintStr) = [stringType] +sourceTypes (LReadStr) = [objectType] +sourceTypes (LFExp) = [doubleType] +sourceTypes (LFLog) = [doubleType] +sourceTypes (LFSin) = [doubleType] +sourceTypes (LFCos) = [doubleType] +sourceTypes (LFTan) = [doubleType] +sourceTypes (LFASin) = [doubleType] +sourceTypes (LFACos) = [doubleType] +sourceTypes (LFATan) = [doubleType] +sourceTypes (LFSqrt) = [doubleType] +sourceTypes (LFFloor) = [doubleType] +sourceTypes (LFCeil) = [doubleType] +sourceTypes (LMkVec nt n) = replicate n (nativeTyToJType nt) +sourceTypes (LIdxVec nt _) = [array $ nativeTyToJType nt, integerType] +sourceTypes (LUpdateVec nt _) = [array $ nativeTyToJType nt, integerType, nativeTyToJType nt] +sourceTypes (LStrHead) = [stringType] +sourceTypes (LStrTail) = [stringType] +sourceTypes (LStrCons) = [charType, stringType] +sourceTypes (LStrIndex) = [stringType, integerType] +sourceTypes (LStrRev) = [stringType] +sourceTypes (LStdIn) = [] +sourceTypes (LStdOut) = [] +sourceTypes (LStdErr) = [] +sourceTypes (LFork) = [objectType] +sourceTypes (LPar) = [objectType] +sourceTypes (LVMPtr) = [] +sourceTypes (LNoOp) = repeat objectType + + diff --git a/src/IRTS/Java/Mangling.hs b/src/IRTS/Java/Mangling.hs new file mode 100644 --- /dev/null +++ b/src/IRTS/Java/Mangling.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module IRTS.Java.Mangling where + +import Core.TT +import IRTS.Lang +import IRTS.Simplified + +import Control.Applicative +import Control.Monad +import Control.Monad.Error +import Data.Char + +import Language.Java.Parser +import Language.Java.Pretty +import Language.Java.Syntax hiding (Name) +import qualified Language.Java.Syntax as J + +import System.FilePath + +prefixCallNamespaces :: Ident -> SDecl -> SDecl +prefixCallNamespaces name (SFun fname args i e) = + SFun fname args i (prefixCallNamespacesExp name e) + where + prefixCallNamespacesExp :: Ident -> SExp -> SExp + prefixCallNamespacesExp (Ident name) (SApp tail (NS n ns) args) = + SApp tail (NS n (name:ns)) args + prefixCallNamespacesExp name (SLet var e1 e2) = + SLet var (prefixCallNamespacesExp name e1) (prefixCallNamespacesExp name e2) + prefixCallNamespacesExp name (SUpdate var e) = + SUpdate var (prefixCallNamespacesExp name e) + prefixCallNamespacesExp name (SCase var alts) = + SCase var (map (prefixCallNamespacesCase name) alts) + prefixCallNamespacesExp name (SChkCase var alts) = + SChkCase var (map (prefixCallNamespacesCase name) alts) + prefixCallNamespacesExp _ exp = exp + + prefixCallNamespacesCase :: Ident -> SAlt -> SAlt + prefixCallNamespacesCase name (SConCase x y n ns e) = + SConCase x y n ns (prefixCallNamespacesExp name e) + prefixCallNamespacesCase name (SConstCase c e) = + SConstCase c (prefixCallNamespacesExp name e) + prefixCallNamespacesCase name (SDefaultCase e) = + SDefaultCase (prefixCallNamespacesExp name e) + +liftParsed :: (Show e, MonadError String m) => Either e a -> m a +liftParsed = either (\ err -> throwError $ "Parser error: " ++ (show err)) + (return) + +mkClassName :: (MonadError String m) => FilePath -> m Ident +mkClassName path = + liftParsed . parser ident . takeBaseName $ takeFileName path + +mangleWithPrefix :: (Applicative m, MonadError String m) => String -> Name -> m Ident +mangleWithPrefix prefix (NS name _) = mangleWithPrefix prefix name +mangleWithPrefix prefix (MN i name) = + (\ (Ident x) -> Ident $ x ++ ('_' : show i)) + <$> mangleWithPrefix prefix (UN name) +mangleWithPrefix prefix (UN name) = + liftParsed + . parser ident + . (prefix ++) + . cleanNonLetter + $ cleanWs False name + where + cleanNonLetter (x:xs) + | x == '#' = "_Hash" ++ cleanNonLetter xs + | x == '@' = "_At" ++ cleanNonLetter xs + | x == '$' = "_Dollar" ++ cleanNonLetter xs + | x == '!' = "_Bang" ++ cleanNonLetter xs + | x == '.' = "_Dot" ++ cleanNonLetter xs + | x == '\'' = "_Prime" ++ cleanNonLetter xs + | x == '*' = "_Times" ++ cleanNonLetter xs + | x == '+' = "_Plus" ++ cleanNonLetter xs + | x == '/' = "_Divide" ++ cleanNonLetter xs + | x == '-' = "_Minus" ++ cleanNonLetter xs + | x == '%' = "_Mod" ++ cleanNonLetter xs + | x == '<' = "_LessThan" ++ cleanNonLetter xs + | x == '=' = "_Equals" ++ cleanNonLetter xs + | x == '>' = "_MoreThan" ++ cleanNonLetter xs + | x == '[' = "_LSBrace" ++ cleanNonLetter xs + | x == ']' = "_RSBrace" ++ cleanNonLetter xs + | x == '(' = "_LBrace" ++ cleanNonLetter xs + | x == ')' = "_RBrace" ++ cleanNonLetter xs + | x == '_' = "__" ++ cleanNonLetter xs + | not (isAlphaNum x) = "_" ++ (show $ ord x) ++ xs + | otherwise = x:cleanNonLetter xs + cleanNonLetter [] = [] + cleanWs capitalize (x:xs) + | isSpace x = cleanWs True xs + | capitalize = (toUpper x) : (cleanWs False xs) + | otherwise = x : (cleanWs False xs) + cleanWs _ [] = [] + +mangle :: (Applicative m, MonadError String m) => Name -> m Ident +mangle = mangleWithPrefix "__IDRCG__" + +mangle' :: Name -> Ident +mangle' = either error id . mangleWithPrefix "__IDRCG__" + +mangleFull :: (Applicative m, MonadError String m) => Name -> m J.Name +mangleFull (NS name (rootns:nss)) = + (\ r n ns -> J.Name (r:(ns ++ [n]))) + <$> mangleWithPrefix "" (UN rootns) + <*> mangle name + <*> mapM (mangle . UN) nss +mangleFull n = J.Name . (:[]) <$> mangle n diff --git a/src/IRTS/LParser.hs b/src/IRTS/LParser.hs --- a/src/IRTS/LParser.hs +++ b/src/IRTS/LParser.hs @@ -49,8 +49,8 @@ chlit = PTok.charLiteral lexer lchar = lexeme.char -fovm :: Target -> OutputType -> FilePath -> IO () -fovm tgt outty f +fovm :: Codegen -> OutputType -> FilePath -> IO () +fovm cgn outty f = do defs <- parseFOVM f let (nexttag, tagged) = addTags 0 (liftAll defs) ctxtIn = addAlist tagged emptyContext @@ -59,7 +59,7 @@ let checked = checkDefs defuns (toAlist defuns) -- print checked case checked of - OK c -> case tgt of + OK c -> case cgn of ViaC -> codegenC c "a.out" outty ["math.h"] "" "" TRACE ViaJava -> codegenJava [] c "a.out" [] [] outty Error e -> fail $ show e @@ -92,39 +92,49 @@ pLExp = buildExpressionParser optable pLExp' -optable = [[binary "*" (\x y -> LOp (LTimes ITNative) [x,y]) AssocLeft, - binary "/" (\x y -> LOp (LSDiv ITNative) [x,y]) AssocLeft, - binary "*." (\x y -> LOp LFTimes [x,y]) AssocLeft, - binary "/." (\x y -> LOp LFDiv [x,y]) AssocLeft, - binary "*:" (\x y -> LOp (LTimes ITBig) [x,y]) AssocLeft, - binary "/:" (\x y -> LOp (LSDiv ITBig) [x,y]) AssocLeft +optable = [[binary "*" (\x y -> LOp (LTimes (ATInt ITNative)) [x,y]) AssocLeft, + binary "/" (\x y -> LOp (LSDiv (ATInt ITNative)) [x,y]) AssocLeft, + binary "*." (\x y -> LOp (LTimes ATFloat) [x,y]) AssocLeft, + binary "/." (\x y -> LOp (LSDiv ATFloat) [x,y]) AssocLeft, + binary "*:" (\x y -> LOp (LTimes (ATInt ITBig)) [x,y]) AssocLeft, + binary "/:" (\x y -> LOp (LSDiv (ATInt ITBig)) [x,y]) AssocLeft, + binary "*," (\x y -> LOp (LTimes (ATInt ITChar)) [x, y]) AssocLeft, + binary "/," (\x y -> LOp (LSDiv (ATInt ITChar)) [x, y]) AssocLeft ], [ - binary "+" (\x y -> LOp (LPlus ITNative) [x,y]) AssocLeft, - binary "-" (\x y -> LOp (LMinus ITNative) [x,y]) AssocLeft, + binary "+" (\x y -> LOp (LPlus (ATInt ITNative)) [x,y]) AssocLeft, + binary "-" (\x y -> LOp (LMinus (ATInt ITNative)) [x,y]) AssocLeft, binary "++" (\x y -> LOp LStrConcat [x,y]) AssocLeft, - binary "+." (\x y -> LOp LFPlus [x,y]) AssocLeft, - binary "-." (\x y -> LOp LFMinus [x,y]) AssocLeft, - binary "+:" (\x y -> LOp (LPlus ITBig) [x,y]) AssocLeft, - binary "-:" (\x y -> LOp (LMinus ITBig) [x,y]) AssocLeft + binary "+." (\x y -> LOp (LPlus ATFloat) [x,y]) AssocLeft, + binary "-." (\x y -> LOp (LMinus ATFloat) [x,y]) AssocLeft, + binary "+:" (\x y -> LOp (LPlus (ATInt ITBig)) [x,y]) AssocLeft, + binary "-:" (\x y -> LOp (LMinus (ATInt ITBig)) [x,y]) AssocLeft, + binary "+," (\x y -> LOp (LPlus (ATInt ITChar)) [x,y]) AssocLeft, + binary "-," (\x y -> LOp (LMinus (ATInt ITChar)) [x,y]) AssocLeft ], [ - binary "==" (\x y -> LOp (LEq ITNative) [x, y]) AssocNone, - binary "==." (\x y -> LOp LFEq [x, y]) AssocNone, - binary "<" (\x y -> LOp (LLt ITNative) [x, y]) AssocNone, - binary "<." (\x y -> LOp LFLt [x, y]) AssocNone, - binary ">" (\x y -> LOp (LGt ITNative) [x, y]) AssocNone, - binary ">." (\x y -> LOp LFGt [x, y]) AssocNone, - binary "<=" (\x y -> LOp (LLe ITNative) [x, y]) AssocNone, - binary "<=." (\x y -> LOp LFLe [x, y]) AssocNone, - binary ">=" (\x y -> LOp (LGe ITNative) [x, y]) AssocNone, - binary ">=." (\x y -> LOp LFGe [x, y]) AssocNone, + binary "==" (\x y -> LOp (LEq (ATInt ITNative)) [x, y]) AssocNone, + binary "==." (\x y -> LOp (LEq ATFloat) [x, y]) AssocNone, + binary "<" (\x y -> LOp (LLt (ATInt ITNative)) [x, y]) AssocNone, + binary "<." (\x y -> LOp (LLt ATFloat) [x, y]) AssocNone, + binary ">" (\x y -> LOp (LGt (ATInt ITNative)) [x, y]) AssocNone, + binary ">." (\x y -> LOp (LGt ATFloat) [x, y]) AssocNone, + binary "<=" (\x y -> LOp (LLe (ATInt ITNative)) [x, y]) AssocNone, + binary "<=." (\x y -> LOp (LLe ATFloat) [x, y]) AssocNone, + binary ">=" (\x y -> LOp (LGe (ATInt ITNative)) [x, y]) AssocNone, + binary ">=." (\x y -> LOp (LGe ATFloat) [x, y]) AssocNone, - binary "==:" (\x y -> LOp (LEq ITBig) [x, y]) AssocNone, - binary "<:" (\x y -> LOp (LLt ITBig) [x, y]) AssocNone, - binary ">:" (\x y -> LOp (LGt ITBig) [x, y]) AssocNone, - binary "<=:" (\x y -> LOp (LLe ITBig) [x, y]) AssocNone, - binary ">=:" (\x y -> LOp (LGe ITBig) [x, y]) AssocNone + binary "==:" (\x y -> LOp (LEq (ATInt ITBig)) [x, y]) AssocNone, + binary "<:" (\x y -> LOp (LLt (ATInt ITBig)) [x, y]) AssocNone, + binary ">:" (\x y -> LOp (LGt (ATInt ITBig)) [x, y]) AssocNone, + binary "<=:" (\x y -> LOp (LLe (ATInt ITBig)) [x, y]) AssocNone, + binary ">=:" (\x y -> LOp (LGe (ATInt ITBig)) [x, y]) AssocNone, + + binary "==," (\x y -> LOp (LEq (ATInt ITChar)) [x, y]) AssocNone, + binary "<," (\x y -> LOp (LLt (ATInt ITChar)) [x, y]) AssocNone, + binary ">," (\x y -> LOp (LGt (ATInt ITChar)) [x, y]) AssocNone, + binary "<=," (\x y -> LOp (LLe (ATInt ITChar)) [x, y]) AssocNone, + binary ">=," (\x y -> LOp (LGe (ATInt ITChar)) [x, y]) AssocNone ]] binary name f assoc = Infix (do reservedOp name; return f) assoc @@ -164,8 +174,9 @@ pLang = do reserved "C"; return LANG_C -pType = do reserved "Int"; return (FInt ITNative) - <|> do reserved "Float"; return FDouble +pType = do reserved "Int"; return (FArith (ATInt ITNative)) + <|> do reserved "Char"; return (FArith (ATInt ITChar)) + <|> do reserved "Float"; return (FArith ATFloat) <|> do reserved "String"; return FString <|> do reserved "Unit"; return FUnit <|> do reserved "Ptr"; return FPtr diff --git a/src/IRTS/Lang.hs b/src/IRTS/Lang.hs --- a/src/IRTS/Lang.hs +++ b/src/IRTS/Lang.hs @@ -1,10 +1,9 @@ module IRTS.Lang where -import Core.TT -import Control.Monad.State hiding(lift) -import Data.List -import Foreign.Storable (sizeOf) -import Debug.Trace +import Control.Monad.State hiding (lift) +import Core.TT +import Data.List +import Debug.Trace data LVar = Loc Int | Glob Name deriving (Show, Eq) @@ -29,59 +28,51 @@ -- Primitive operators. Backends are not *required* to implement all -- of these, but should report an error if they are unable -data IntTy = ITNative | IT8 | IT16 | IT32 | IT64 | ITBig - deriving (Show, Eq) - -intTyWidth :: IntTy -> Int -intTyWidth IT8 = 8 -intTyWidth IT16 = 16 -intTyWidth IT32 = 32 -intTyWidth IT64 = 64 -intTyWidth ITNative = 8 * sizeOf (0 :: Int) -intTyWidth ITBig = error "IRTS.Lang.intTyWidth: Big integers have variable width" - -intTyToConst :: IntTy -> Const -intTyToConst IT8 = B8Type -intTyToConst IT16 = B16Type -intTyToConst IT32 = B32Type -intTyToConst IT64 = B64Type -intTyToConst ITBig = BIType -intTyToConst ITNative = IType - -data PrimFn = LPlus IntTy | LMinus IntTy | LTimes IntTy - | LUDiv IntTy | LSDiv IntTy | LURem IntTy | LSRem IntTy +data PrimFn = LPlus ArithTy | LMinus ArithTy | LTimes ArithTy + | LUDiv IntTy | LSDiv ArithTy | LURem IntTy | LSRem ArithTy | LAnd IntTy | LOr IntTy | LXOr IntTy | LCompl IntTy | LSHL IntTy | LLSHR IntTy | LASHR IntTy - | LEq IntTy | LLt IntTy | LLe IntTy | LGt IntTy | LGe IntTy + | LEq ArithTy | LLt ArithTy | LLe ArithTy | LGt ArithTy | LGe ArithTy | LSExt IntTy IntTy | LZExt IntTy IntTy | LTrunc IntTy IntTy - | LFPlus | LFMinus | LFTimes | LFDiv - | LFEq | LFLt | LFLe | LFGt | LFGe | LStrConcat | LStrLt | LStrEq | LStrLen | LIntFloat IntTy | LFloatInt IntTy | LIntStr IntTy | LStrInt IntTy | LFloatStr | LStrFloat | LChInt IntTy | LIntCh IntTy | LPrintNum | LPrintStr | LReadStr + | LBitCast ArithTy ArithTy -- Only for values of equal width | LFExp | LFLog | LFSin | LFCos | LFTan | LFASin | LFACos | LFATan | LFSqrt | LFFloor | LFCeil + -- construction element extraction element insertion + | LMkVec NativeTy Int | LIdxVec NativeTy Int | LUpdateVec NativeTy Int + | LStrHead | LStrTail | LStrCons | LStrIndex | LStrRev | LStdIn | LStdOut | LStdErr - | LFork + | LFork | LPar -- evaluate argument anywhere, possibly on another -- core or another machine. 'id' is a valid implementation - | LVMPtr + | LVMPtr | LNoOp deriving (Show, Eq) -- Supported target languages for foreign calls -data FLang = LANG_C +data FCallType = FStatic | FObject | FConstructor deriving (Show, Eq) -data FType = FInt IntTy | FChar | FString | FUnit | FPtr | FDouble | FAny +data FLang = LANG_C | LANG_JAVA FCallType deriving (Show, Eq) +data FType = FArith ArithTy + | FFunction + | FFunctionIO + | FString + | FUnit + | FPtr + | FAny + deriving (Show, Eq) + data LAlt = LConCase Int Name [Name] LExp | LConstCase Const LExp | LDefaultCase LExp @@ -99,9 +90,9 @@ addTags :: Int -> [(Name, LDecl)] -> (Int, [(Name, LDecl)]) addTags i ds = tag i ds [] where tag i ((n, LConstructor n' (-1) a) : as) acc - = tag (i + 1) as ((n, LConstructor n' i a) : acc) + = tag (i + 1) as ((n, LConstructor n' i a) : acc) tag i ((n, LConstructor n' t a) : as) acc - = tag i as ((n, LConstructor n' t a) : acc) + = tag i as ((n, LConstructor n' t a) : acc) tag i (x : as) acc = tag i as (x : acc) tag i [] acc = (i, reverse acc) @@ -115,7 +106,7 @@ liftAll xs = concatMap (\ (x, d) -> lambdaLift x d) xs lambdaLift :: Name -> LDecl -> [(Name, LDecl)] -lambdaLift n (LFun _ _ args e) +lambdaLift n (LFun _ _ args e) = let (e', (LS _ _ decls)) = runState (lift args e) (LS n 0 []) in (n, LFun [] n args e') : decls lambdaLift n x = [(n, x)] @@ -141,7 +132,7 @@ lift env (LLazyApp n args) = do args' <- mapM (lift env) args return (LLazyApp n args') lift env (LLazyExp (LConst c)) = return (LConst c) --- lift env (LLazyExp (LApp tc (LV (Glob f)) args)) +-- lift env (LLazyExp (LApp tc (LV (Glob f)) args)) -- = lift env (LLazyApp f args) lift env (LLazyExp e) = do e' <- lift env e let usedArgs = nub $ usedIn env e' @@ -149,7 +140,7 @@ addFn fn (LFun [NoInline] fn usedArgs e') return (LLazyApp fn (map (LV . Glob) usedArgs)) lift env (LForce e) = do e' <- lift env e - return (LForce e') + return (LForce e') lift env (LLet n v e) = do v' <- lift env v e' <- lift (env ++ [n]) e return (LLet n v' e') @@ -189,8 +180,8 @@ | otherwise = [] usedIn :: [Name] -> LExp -> [Name] -usedIn env (LV (Glob n)) = usedArg env n -usedIn env (LApp _ e args) = usedIn env e ++ concatMap (usedIn env) args +usedIn env (LV (Glob n)) = usedArg env n +usedIn env (LApp _ e args) = usedIn env e ++ concatMap (usedIn env) args usedIn env (LLazyApp n args) = concatMap (usedIn env) args ++ usedArg env n usedIn env (LLazyExp e) = usedIn env e usedIn env (LForce e) = usedIn env e @@ -214,7 +205,7 @@ showSep ", " (map (show' env) args) ++")" show' env (LApp _ e args) = show' env e ++ "(" ++ showSep ", " (map (show' env) args) ++")" - show' env (LLazyExp e) = "%lazy(" ++ show' env e ++ ")" + show' env (LLazyExp e) = "%lazy(" ++ show' env e ++ ")" show' env (LForce e) = "%force(" ++ show' env e ++ ")" show' env (LLet n v e) = "let " ++ show n ++ " = " ++ show' env v ++ " in " ++ show' (env ++ [show n]) e @@ -231,7 +222,7 @@ show' env (LError str) = "error " ++ show str show' env LNothing = "____" - showAlt env (LConCase _ n args e) + showAlt env (LConCase _ n args e) = show n ++ "(" ++ showSep ", " (map show args) ++ ") => " ++ show' env e showAlt env (LConstCase c e) = show c ++ " => " ++ show' env e diff --git a/src/Idris/AbsSyntax.hs b/src/Idris/AbsSyntax.hs --- a/src/Idris/AbsSyntax.hs +++ b/src/Idris/AbsSyntax.hs @@ -30,18 +30,21 @@ getContext :: Idris Context getContext = do i <- getIState; return (tt_ctxt i) -getObjectFiles :: Idris [FilePath] -getObjectFiles = do i <- getIState; return (idris_objs i) +forCodegen :: Codegen -> [(Codegen, a)] -> [a] +forCodegen tgt xs = [x | (tgt', x) <- xs, tgt == tgt'] -addObjectFile :: FilePath -> Idris () -addObjectFile f = do i <- getIState; putIState $ i { idris_objs = f : idris_objs i } +getObjectFiles :: Codegen -> Idris [FilePath] +getObjectFiles tgt = do i <- getIState; return (forCodegen tgt $ idris_objs i) -getLibs :: Idris [String] -getLibs = do i <- getIState; return (idris_libs i) +addObjectFile :: Codegen -> FilePath -> Idris () +addObjectFile tgt f = do i <- getIState; putIState $ i { idris_objs = (tgt, f) : idris_objs i } -addLib :: String -> Idris () -addLib f = do i <- getIState; putIState $ i { idris_libs = f : idris_libs i } +getLibs :: Codegen -> Idris [String] +getLibs tgt = do i <- getIState; return (forCodegen tgt $ idris_libs i) +addLib :: Codegen -> String -> Idris () +addLib tgt f = do i <- getIState; putIState $ i { idris_libs = (tgt, f) : idris_libs i } + addDyLib :: [String] -> Idris (Either DynamicLib String) addDyLib libs = do i <- getIState handle <- lift $ mapM (\l -> catchIO (tryLoadLib l) (\_ -> return Nothing)) libs @@ -52,12 +55,16 @@ putIState $ i { idris_dynamic_libs = x:ls } return (Left x) -addHdr :: String -> Idris () -addHdr f = do i <- getIState; putIState $ i { idris_hdrs = f : idris_hdrs i } +addHdr :: Codegen -> String -> Idris () +addHdr tgt f = do i <- getIState; putIState $ i { idris_hdrs = (tgt, f) : idris_hdrs i } addLangExt :: LanguageExt -> Idris () addLangExt TypeProviders = do i <- getIState ; putIState $ i { idris_language_extensions = [TypeProviders] } +addTrans :: (Term, Term) -> Idris () +addTrans t = do i <- getIState + putIState $ i { idris_transforms = t : idris_transforms i } + totcheck :: (FC, Name) -> Idris () totcheck n = do i <- getIState; putIState $ i { idris_totcheck = idris_totcheck i ++ [n] } @@ -160,8 +167,8 @@ clearIBC :: Idris () clearIBC = do i <- getIState; putIState $ i { ibc_write = [] } -getHdrs :: Idris [String] -getHdrs = do i <- getIState; return (idris_hdrs i) +getHdrs :: Codegen -> Idris [String] +getHdrs tgt = do i <- getIState; return (forCodegen tgt $ idris_hdrs i) setErrLine :: Int -> Idris () setErrLine x = do i <- getIState; @@ -261,7 +268,7 @@ s -> liftIO $ putStrLn s IdeSlave n -> let good = SexpList [SymbolAtom "error", toSExp s] in - liftIO $ putStrLn $ convSExp "return" good n + liftIO . putStrLn $ convSExp "return" good n iputStrLn :: String -> Idris () iputStrLn s = do i <- getIState @@ -274,13 +281,31 @@ ([], msg) -> write (num, ':':msg) -> iWarn (FC fn (read num)) msg _ -> write - where write = liftIO $ putStrLn $ convSExp "write-string" s n + where write = liftIO . putStrLn $ convSExp "write-string" s n +ideslavePutSExp :: SExpable a => String -> a -> Idris () +ideslavePutSExp cmd info = do i <- getIState + case idris_outputmode i of + IdeSlave n -> liftIO . putStrLn $ convSExp cmd info n + _ -> return () + +-- this needs some typing magic and more structured output towards emacs +iputGoal :: String -> Idris () +iputGoal s = do i <- getIState + case idris_outputmode i of + RawOutput -> liftIO $ putStrLn s + IdeSlave n -> liftIO . putStrLn $ convSExp "write-goal" s n + +isetPrompt :: String -> Idris () +isetPrompt p = do i <- getIState + case idris_outputmode i of + IdeSlave n -> liftIO . putStrLn $ convSExp "set-prompt" p n + iWarn :: FC -> String -> Idris () iWarn fc err = do i <- getIState case idris_outputmode i of RawOutput -> liftIO $ putStrLn (show fc ++ ":" ++ err) - IdeSlave n -> liftIO $ putStrLn $ convSExp "warning" (fc_fname fc, fc_line fc, err) n + IdeSlave n -> liftIO . putStrLn $ convSExp "warning" (fc_fname fc, fc_line fc, err) n setLogLevel :: Int -> Idris () setLogLevel l = do i <- getIState @@ -337,16 +362,21 @@ let opt' = opts { opt_quiet = q } putIState $ i { idris_options = opt' } -setTarget :: Target -> Idris () -setTarget t = do i <- getIState - let opts = idris_options i - let opt' = opts { opt_target = t } - putIState $ i { idris_options = opt' } +getQuiet :: Idris Bool +getQuiet = do i <- getIState + let opts = idris_options i + return (opt_quiet opts) -target :: Idris Target -target = do i <- getIState - return (opt_target (idris_options i)) +setCodegen :: Codegen -> Idris () +setCodegen t = do i <- getIState + let opts = idris_options i + let opt' = opts { opt_codegen = t } + putIState $ i { idris_options = opt' } +codegen :: Idris Codegen +codegen = do i <- getIState + return (opt_codegen (idris_options i)) + setOutputTy :: OutputType -> Idris () setOutputTy t = do i <- getIState let opts = idris_options i @@ -362,6 +392,36 @@ putIState $ i { idris_outputmode = (IdeSlave 0) } setIdeSlave False = return () +setTargetTriple :: String -> Idris () +setTargetTriple t = do i <- getIState + let opts = idris_options i + opt' = opts { opt_triple = t } + putIState $ i { idris_options = opt' } + +targetTriple :: Idris String +targetTriple = do i <- getIState + return (opt_triple (idris_options i)) + +setTargetCPU :: String -> Idris () +setTargetCPU t = do i <- getIState + let opts = idris_options i + opt' = opts { opt_cpu = t } + putIState $ i { idris_options = opt' } + +targetCPU :: Idris String +targetCPU = do i <- getIState + return (opt_cpu (idris_options i)) + +setOptLevel :: Int -> Idris () +setOptLevel t = do i <- getIState + let opts = idris_options i + opt' = opts { opt_optLevel = t } + putIState $ i { idris_options = opt' } + +optLevel :: Idris Int +optLevel = do i <- getIState + return (opt_optLevel (idris_options i)) + verbose :: Idris Bool verbose = do i <- getIState return (opt_verbose (idris_options i)) @@ -560,12 +620,13 @@ PLet n' (en ty) (en v) (en (shadow n n' s)) | otherwise = PLet n (en ty) (en v) (en s) en (PEq f l r) = PEq f (en l) (en r) - en (PRewrite f l r) = PRewrite f (en l) (en r) + en (PRewrite f l r g) = PRewrite f (en l) (en r) (fmap en g) en (PTyped l r) = PTyped (en l) (en r) en (PPair f l r) = PPair f (en l) (en r) en (PDPair f l t r) = PDPair f (en l) (en t) (en r) en (PAlternative a as) = PAlternative a (map en as) en (PHidden t) = PHidden (en t) + en (PUnifyLog t) = PUnifyLog (en t) en (PDoBlock ds) = PDoBlock (map (fmap en) ds) en (PProof ts) = PProof (map (fmap en) ts) en (PTactics ts) = PTactics (map (fmap en) ts) @@ -696,7 +757,7 @@ pri (PFalse _) = 0 pri (PRefl _ _) = 1 pri (PEq _ l r) = max 1 (max (pri l) (pri r)) - pri (PRewrite _ l r) = max 1 (max (pri l) (pri r)) + pri (PRewrite _ l r _) = max 1 (max (pri l) (pri r)) pri (PApp _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.getTm) as))) pri (PCase _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.snd) as))) pri (PTyped l r) = pri l @@ -793,17 +854,20 @@ return tm' implicitise :: SyntaxInfo -> [Name] -> IState -> PTerm -> (PTerm, [PArg]) -implicitise syn ignore ist tm - = let (declimps, ns') = execState (imps True [] tm) ([], []) +implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $ + let (declimps, ns') = execState (imps True [] tm) ([], []) ns = filter (\n -> implicitable n || elem n (map fst uvars)) $ - ns' \\ (map fst pvars ++ no_imp syn ++ ignore) in + ns' \\ (map fst pvars ++ no_imp syn ++ ignore) + nsOrder = filter (not . inUsing) ns ++ filter inUsing ns in if null ns then (tm, reverse declimps) - else implicitise syn ignore ist (pibind uvars ns tm) + else implicitise syn ignore ist (pibind uvars nsOrder tm) where uvars = map ipair (filter uimplicit (using syn)) pvars = syn_params syn + inUsing n = n `elem` map fst uvars + ipair (UImplicit x y) = (x, y) uimplicit (UImplicit _ _) = True uimplicit _ = False @@ -850,7 +914,7 @@ = do (decls, ns) <- get let isn = namesIn uvars ist l ++ namesIn uvars ist r put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) - imps top env (PRewrite _ l r) + imps top env (PRewrite _ l r _) = do (decls, ns) <- get let isn = namesIn uvars ist l ++ namesIn uvars ist r put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) @@ -877,6 +941,7 @@ = do imps False env ty imps False (n:env) sc imps top env (PHidden tm) = imps False env tm + imps top env (PUnifyLog tm) = imps False env tm imps top env _ = return () pibind using [] sc = sc @@ -913,9 +978,10 @@ ai env (PEq fc l r) = let l' = ai env l r' = ai env r in PEq fc l' r' - ai env (PRewrite fc l r) = let l' = ai env l - r' = ai env r in - PRewrite fc l' r' + ai env (PRewrite fc l r g) = let l' = ai env l + r' = ai env r + g' = fmap (ai env) g in + PRewrite fc l' r' g' ai env (PTyped l r) = let l' = ai env l r' = ai env r in PTyped l' r' @@ -960,6 +1026,7 @@ ai env (PHidden tm) = PHidden (ai env tm) ai env (PProof ts) = PProof (map (fmap (ai env)) ts) ai env (PTactics ts) = PTactics (map (fmap (ai env)) ts) + ai env (PUnifyLog tm) = PUnifyLog (ai env tm) ai env tm = tm handleErr (Left err) = PElabError err @@ -1176,7 +1243,7 @@ match (PEq _ l r) (PEq _ l' r') = do ml <- match' l l' mr <- match' r r' return (ml ++ mr) - match (PRewrite _ l r) (PRewrite _ l' r') + match (PRewrite _ l r _) (PRewrite _ l' r' _) = do ml <- match' l l' mr <- match' r r' return (ml ++ mr) @@ -1222,6 +1289,8 @@ ms <- match' s s' return (mt ++ mty ++ ms) match (PHidden x) (PHidden y) = match' x y + match (PUnifyLog x) y = match' x y + match x (PUnifyLog y) = match' x y match Placeholder _ = return [] match _ Placeholder = return [] match (PResolveTC _) _ = return [] @@ -1258,17 +1327,22 @@ PPi p x' (sm (x':xs) (substMatch x (PRef (FC "" 0) x') t)) (sm (x':xs) (substMatch x (PRef (FC "" 0) x') sc)) | otherwise = PPi p x (sm xs t) (sm (x : xs) sc) - sm xs (PApp f x as) = PApp f (sm xs x) (map (fmap (sm xs)) as) + sm xs (PApp f x as) = fullApp $ PApp f (sm xs x) (map (fmap (sm xs)) as) sm xs (PCase f x as) = PCase f (sm xs x) (map (pmap (sm xs)) as) sm xs (PEq f x y) = PEq f (sm xs x) (sm xs y) - sm xs (PRewrite f x y) = PRewrite f (sm xs x) (sm xs y) + sm xs (PRewrite f x y tm) = PRewrite f (sm xs x) (sm xs y) + (fmap (sm xs) tm) sm xs (PTyped x y) = PTyped (sm xs x) (sm xs y) sm xs (PPair f x y) = PPair f (sm xs x) (sm xs y) sm xs (PDPair f x t y) = PDPair f (sm xs x) (sm xs t) (sm xs y) sm xs (PAlternative a as) = PAlternative a (map (sm xs) as) sm xs (PHidden x) = PHidden (sm xs x) + sm xs (PUnifyLog x) = PUnifyLog (sm xs x) sm xs x = x + fullApp (PApp _ (PApp fc f args) xs) = fullApp (PApp fc f (args ++ xs)) + fullApp x = x + shadow :: Name -> Name -> PTerm -> PTerm shadow n n' t = sm t where sm (PRef fc x) | n == x = PRef fc n' @@ -1277,12 +1351,13 @@ sm (PApp f x as) = PApp f (sm x) (map (fmap sm) as) sm (PCase f x as) = PCase f (sm x) (map (pmap sm) as) sm (PEq f x y) = PEq f (sm x) (sm y) - sm (PRewrite f x y) = PRewrite f (sm x) (sm y) + sm (PRewrite f x y tm) = PRewrite f (sm x) (sm y) (fmap sm tm) sm (PTyped x y) = PTyped (sm x) (sm y) sm (PPair f x y) = PPair f (sm x) (sm y) sm (PDPair f x t y) = PDPair f (sm x) (sm t) (sm y) sm (PAlternative a as) = PAlternative a (map sm as) sm (PHidden x) = PHidden (sm x) + sm (PUnifyLog x) = PUnifyLog (sm x) sm x = x diff --git a/src/Idris/AbsSyntaxTree.hs b/src/Idris/AbsSyntaxTree.hs --- a/src/Idris/AbsSyntaxTree.hs +++ b/src/Idris/AbsSyntaxTree.hs @@ -33,10 +33,13 @@ opt_repl :: Bool, opt_verbose :: Bool, opt_quiet :: Bool, - opt_target :: Target, + opt_codegen :: Codegen, opt_outputTy :: OutputType, opt_ibcsubdir :: FilePath, opt_importdirs :: [FilePath], + opt_triple :: String, + opt_cpu :: String, + opt_optLevel :: Int, opt_cmdline :: [Opt] -- remember whole command line } deriving (Show, Eq) @@ -50,10 +53,13 @@ , opt_repl = True , opt_verbose = True , opt_quiet = False - , opt_target = ViaC + , opt_codegen = ViaC , opt_outputTy = Executable , opt_ibcsubdir = "" , opt_importdirs = [] + , opt_triple = "" + , opt_cpu = "" + , opt_optLevel = 2 , opt_cmdline = [] } @@ -91,13 +97,14 @@ idris_name :: Int, idris_metavars :: [Name], -- ^ The currently defined but not proven metavariables idris_coercions :: [Name], + idris_transforms :: [(Term, Term)], syntax_rules :: [Syntax], syntax_keywords :: [String], imported :: [FilePath], -- ^ The imported modules idris_scprims :: [(Name, (Int, PrimFn))], - idris_objs :: [FilePath], - idris_libs :: [String], - idris_hdrs :: [String], + idris_objs :: [(Codegen, FilePath)], + idris_libs :: [(Codegen, String)], + idris_hdrs :: [(Codegen, String)], proof_list :: [(Name, [String])], errLine :: Maybe Int, lastParse :: Maybe Name, @@ -145,13 +152,14 @@ | IBCSyntax Syntax | IBCKeyword String | IBCImport FilePath - | IBCObj FilePath - | IBCLib String + | IBCObj Codegen FilePath + | IBCLib Codegen String | IBCDyLib String - | IBCHeader String + | IBCHeader Codegen String | IBCAccess Name Accessibility | IBCTotal Name Totality | IBCFlags Name [FnOpt] + | IBCTrans (Term, Term) | IBCCG Name | IBCDoc Name | IBCCoercion Name @@ -161,7 +169,7 @@ idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext - [] "" defaultOpts 6 [] [] [] [] [] [] [] [] [] + [] "" defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] Nothing Nothing [] [] [] Hidden False [] Nothing [] [] RawOutput -- | The monad for the main REPL - reading and processing files and updating @@ -171,11 +179,12 @@ -- Commands in the REPL -data Target = ViaC - | ViaJava - | ViaNode - | ViaJavaScript - | Bytecode +data Codegen = ViaC + | ViaJava + | ViaNode + | ViaJavaScript + | ViaLLVM + | Bytecode deriving (Show, Eq) -- | REPL commands @@ -190,7 +199,7 @@ | ChangeDirectory FilePath | ModImport String | Edit - | Compile Target String + | Compile Codegen String | Execute | ExecVal PTerm | NewCompile String @@ -250,9 +259,13 @@ | DumpDefun String | DumpCases String | FOVM String - | UseTarget Target + | UseCodegen Codegen | OutputTy OutputType | Extension LanguageExt + | InterpretScript String + | TargetTriple String + | TargetCPU String + | OptLevel Int deriving (Show, Eq) -- Parsed declarations @@ -321,7 +334,7 @@ | Coinductive | AssertTotal | TCGen | Implicit -- implicit coercion | CExport String -- export, with a C name - | Specialise [Name] -- specialise it, freeze these names + | Specialise [(Name, Maybe Int)] -- specialise it, freeze these names deriving (Show, Eq) {-! deriving instance Binary FnOpt @@ -364,7 +377,12 @@ | PMutual FC [PDecl' t] -- ^ Mutual block | PDirective (Idris ()) -- ^ Compiler directive. The parser inserts the corresponding action in the Idris monad. | PProvider SyntaxInfo FC Name t t -- ^ Type provider. The first t is the type, the second is the term - deriving Functor + | PTransform FC Bool t t -- ^ Source-to-source transformation rule. If + -- bool is True, lhs and rhs must be convertible + | PReflection FC Name -- type to reflect to + t -- type of variables + [PClause' t] -- ^ Pattern clauses + deriving Functor {-! deriving instance Binary PDecl' !-} @@ -493,13 +511,14 @@ | PLet Name PTerm PTerm PTerm | PTyped PTerm PTerm -- ^ Term with explicit type | PApp FC PTerm [PArg] + | PMatchApp FC Name -- ^ Make an application by type matching | PCase FC PTerm [(PTerm, PTerm)] | PTrue FC | PFalse FC | PRefl FC PTerm | PResolveTC FC | PEq FC PTerm PTerm - | PRewrite FC PTerm PTerm + | PRewrite FC PTerm PTerm (Maybe PTerm) | PPair FC PTerm PTerm | PDPair FC PTerm PTerm PTerm | PAlternative Bool [PTerm] -- True if only one may work @@ -516,6 +535,7 @@ | PElabError Err -- ^ Error to report on elaboration | PImpossible -- ^ Special case for declaring when an LHS can't typecheck | PCoerced PTerm -- ^ To mark a coerced argument, so as not to coerce twice + | PUnifyLog PTerm -- ^ dump a trace of unifications when building term deriving Eq {-! deriving instance Binary PTerm @@ -526,7 +546,8 @@ mpt (PLam n t s) = PLam n (mapPT f t) (mapPT f s) mpt (PPi p n t s) = PPi p n (mapPT f t) (mapPT f s) mpt (PLet n ty v s) = PLet n (mapPT f ty) (mapPT f v) (mapPT f s) - mpt (PRewrite fc t s) = PRewrite fc (mapPT f t) (mapPT f s) + mpt (PRewrite fc t s g) = PRewrite fc (mapPT f t) (mapPT f s) + (fmap (mapPT f) g) mpt (PApp fc t as) = PApp fc (mapPT f t) (map (fmap (mapPT f)) as) mpt (PCase fc c os) = PCase fc (mapPT f c) (map (pmap (mapPT f)) os) mpt (PEq fc l r) = PEq fc (mapPT f l) (mapPT f r) @@ -538,11 +559,14 @@ mpt (PDoBlock ds) = PDoBlock (map (fmap (mapPT f)) ds) mpt (PProof ts) = PProof (map (fmap (mapPT f)) ts) mpt (PTactics ts) = PTactics (map (fmap (mapPT f)) ts) + mpt (PUnifyLog tm) = PUnifyLog (mapPT f tm) mpt x = x data PTactic' t = Intro [Name] | Intros | Focus Name | Refine Name [Bool] | Rewrite t + | Equiv t + | MatchRefine Name | LetTac Name t | LetTacTy Name t t | Exact t | Compute | Trivial | Solve @@ -949,7 +973,7 @@ prettySe 10 l <+> text "=" $$ nest nestingSize (prettySe 10 r) else prettySe 10 l <+> text "=" <+> prettySe 10 r - prettySe p (PRewrite _ l r) = + prettySe p (PRewrite _ l r _) = bracket p 2 $ if size r > breakingSize then text "rewrite" <+> prettySe 10 l <+> text "in" $$ nest nestingSize (prettySe 10 r) @@ -1045,6 +1069,7 @@ se p e | Just str <- slist p e = str | Just num <- snat p e = show num + se p (PMatchApp _ f) = "match " ++ show f se p (PApp _ (PRef _ f) []) | not impl = show f se p (PApp _ (PRef _ op@(UN (f:_))) args) @@ -1065,7 +1090,7 @@ se p (PTrue _) = "()" se p (PFalse _) = "_|_" se p (PEq _ l r) = bracket p 2 $ se 10 l ++ " = " ++ se 10 r - se p (PRewrite _ l r) = bracket p 2 $ "rewrite " ++ se 10 l ++ " in " ++ se 10 r + se p (PRewrite _ l r _) = bracket p 2 $ "rewrite " ++ se 10 l ++ " in " ++ se 10 r se p (PTyped l r) = "(" ++ se 10 l ++ " : " ++ se 10 r ++ ")" se p (PPair _ l r) = "(" ++ se 10 l ++ ", " ++ se 10 r ++ ")" se p (PDPair _ l t r) = "(" ++ se 10 l ++ " ** " ++ se 10 r ++ ")" @@ -1081,6 +1106,7 @@ se p (PDoBlock _) = "do block show not implemented" se p (PElabError s) = show s se p (PCoerced t) = se p t + se p (PUnifyLog t) = "%unifyLog " ++ se p t -- se p x = "Not implemented" slist' p (PApp _ (PRef _ nil) _) @@ -1102,10 +1128,10 @@ xs -> "[" ++ intercalate "," (map (se p) xs) ++ "]" slist _ _ = Nothing - -- since Prelude is always imported, S & O are unqualified iff they're the + -- since Prelude is always imported, S & Z are unqualified iff they're the -- Nat ones. snat p (PRef _ o) - | show o == (natns++"O") || show o == "O" = Just 0 + | show o == (natns++"Z") || show o == "Z" = Just 0 snat p (PApp _ s [PExp {getTm=n}]) | show s == (natns++"S") || show s == "S", Just n' <- snat p n @@ -1142,11 +1168,12 @@ size (PRefl fc _) = 1 size (PResolveTC fc) = 1 size (PEq fc left right) = 1 + size left + size right - size (PRewrite fc left right) = 1 + size left + size right + size (PRewrite fc left right _) = 1 + size left + size right size (PPair fc left right) = 1 + size left + size right size (PDPair fs left ty right) = 1 + size left + size ty + size right size (PAlternative a alts) = 1 + size alts size (PHidden hidden) = size hidden + size (PUnifyLog tm) = size tm size PType = 1 size (PConstant const) = 1 + size const size Placeholder = 1 @@ -1175,12 +1202,13 @@ ni env (PPi _ n ty sc) = ni env ty ++ ni (n:env) sc ni env (PHidden tm) = ni env tm ni env (PEq _ l r) = ni env l ++ ni env r - ni env (PRewrite _ l r) = ni env l ++ ni env r + ni env (PRewrite _ l r _) = ni env l ++ ni env r ni env (PTyped l r) = ni env l ++ ni env r ni env (PPair _ l r) = ni env l ++ ni env r ni env (PDPair _ (PRef _ n) t r) = ni env t ++ ni (n:env) r ni env (PDPair _ l t r) = ni env l ++ ni env t ++ ni env r ni env (PAlternative a ls) = concatMap (ni env) ls + ni env (PUnifyLog tm) = ni env tm ni env _ = [] -- Return names which are free in the given term. @@ -1198,13 +1226,14 @@ ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc ni env (PPi _ n ty sc) = ni env ty ++ ni (n:env) sc ni env (PEq _ l r) = ni env l ++ ni env r - ni env (PRewrite _ l r) = ni env l ++ ni env r + ni env (PRewrite _ l r _) = ni env l ++ ni env r ni env (PTyped l r) = ni env l ++ ni env r ni env (PPair _ l r) = ni env l ++ ni env r ni env (PDPair _ (PRef _ n) t r) = ni env t ++ ni (n:env) r ni env (PDPair _ l t r) = ni env l ++ ni env t ++ ni env r ni env (PAlternative a as) = concatMap (ni env) as ni env (PHidden tm) = ni env tm + ni env (PUnifyLog tm) = ni env tm ni env _ = [] -- Return which of the given names are used in the given term. @@ -1222,11 +1251,12 @@ ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc ni env (PPi _ n ty sc) = ni env ty ++ ni (n:env) sc ni env (PEq _ l r) = ni env l ++ ni env r - ni env (PRewrite _ l r) = ni env l ++ ni env r + ni env (PRewrite _ l r _) = ni env l ++ ni env r ni env (PTyped l r) = ni env l ++ ni env r ni env (PPair _ l r) = ni env l ++ ni env r ni env (PDPair _ (PRef _ n) t r) = ni env t ++ ni (n:env) r ni env (PDPair _ l t r) = ni env l ++ ni env t ++ ni env r ni env (PAlternative a as) = concatMap (ni env) as ni env (PHidden tm) = ni env tm + ni env (PUnifyLog tm) = ni env tm ni env _ = [] diff --git a/src/Idris/Completion.hs b/src/Idris/Completion.hs --- a/src/Idris/Completion.hs +++ b/src/Idris/Completion.hs @@ -28,9 +28,9 @@ -- | A list of available tactics and their argument requirements tacticArgs :: [(String, Maybe TacticArg)] -tacticArgs = [ ("intro", Nothing) - , ("intros", Nothing) +tacticArgs = [ ("intro", Nothing) -- FIXME syntax for intro (fresh name) , ("refine", Just ExprTArg) + , ("mrefine", Just ExprTArg) , ("rewrite", Just ExprTArg) , ("let", Nothing) -- FIXME syntax for let , ("focus", Just ExprTArg) @@ -40,7 +40,7 @@ , ("fill", Just ExprTArg) , ("try", Just AltsTArg) ] ++ map (\x -> (x, Nothing)) [ - "intro", "intros", "compute", "trivial", "solve", "attack", + "intros", "compute", "trivial", "solve", "attack", "state", "term", "undo", "qed", "abandon", ":q" ] tactics = map fst tacticArgs @@ -63,7 +63,8 @@ mapMaybe (nameString . fst) (ctxtAlist ctxt) ++ -- Explicitly add primitive types, as these are special-cased in the parser ["Int", "Integer", "Float", "Char", "String", "Type", - "Ptr", "Bits8", "Bits16", "Bits32", "Bits64"] + "Ptr", "Bits8", "Bits16", "Bits32", "Bits64", + "Bits8x16", "Bits16x8", "Bits32x4", "Bits64x2"] metavars :: Idris [String] metavars = do i <- get diff --git a/src/Idris/Coverage.hs b/src/Idris/Coverage.hs --- a/src/Idris/Coverage.hs +++ b/src/Idris/Coverage.hs @@ -46,18 +46,23 @@ let lhss = map (getLHS i) xs let argss = transpose lhss let all_args = map (genAll i) argss - logLvl 7 $ "COVERAGE of " ++ show n + logLvl 5 $ "COVERAGE of " ++ show n + logLvl 5 $ show (map length argss) ++ "\n" ++ show (map length all_args) logLvl 10 $ show argss ++ "\n" ++ show all_args logLvl 10 $ "Original: \n" ++ showSep "\n" (map (\t -> showImp True (delab' i t True)) xs) + -- add an infinite supply of explicit arguments to update the possible + -- cases for (the return type may be variadic, or function type, sp + -- there may be more case splitting that the idris_implicits record + -- suggests) let parg = case lookupCtxt n (idris_implicits i) of - (p : _) -> p + (p : _) -> p ++ repeat (PExp 0 False Placeholder "") _ -> repeat (pexp Placeholder) let tryclauses = mkClauses parg all_args logLvl 2 $ show (length tryclauses) ++ " initially to check" - let new = mnub i $ filter (noMatch i) tryclauses + let new = filter (noMatch i) (mnub i tryclauses) logLvl 1 $ show (length new) ++ " clauses to check for impossibility" - logLvl 7 $ "New clauses: \n" ++ showSep "\n" (map (showImp True) new) + logLvl 5 $ "New clauses: \n" ++ showSep "\n" (map (showImp True) new) -- ++ " from:\n" ++ showSep "\n" (map (showImp True) tryclauses) return new -- return (map (\t -> PClause n t [] PImpossible []) new) @@ -70,11 +75,16 @@ mnub i [] = [] mnub i (x : xs) = - if (any (\t -> case matchClause i x t of - Right _ -> True - Left _ -> False) xs) then mnub i xs - else x : mnub i xs + let xs' = filter (\t -> case matchClause i x t of + Right _ -> False + Left _ -> True) xs in + x : mnub i xs' +-- if (any (\t -> case matchClause i x t of +-- Right _ -> True +-- Left _ -> False) xs) then mnub i xs +-- else x : mnub i xs + noMatch i tm = all (\x -> case matchClause i (delab' i x True) tm of Right _ -> False Left miss -> True) xs @@ -94,31 +104,51 @@ as' <- mkArg as return (a':as') -fnub xs = fnub' [] xs where - fnub' acc (x : xs) | x `elem` acc = fnub' acc xs - | otherwise = fnub' (x : acc) xs - fnub' acc [] = acc +fnub xs = fnub' [] xs +fnub' acc (x : xs) | x `qelem` acc = fnub' acc (filter (not.(quickEq x)) xs) + | otherwise = fnub' (x : acc) xs +fnub' acc [] = acc + +-- quick check for constructor equality +quickEq :: PTerm -> PTerm -> Bool +quickEq (PRef _ n) (PRef _ n') = n == n' +quickEq (PApp _ t as) (PApp _ t' as') + | length as == length as' + = quickEq t t' && and (zipWith quickEq (map getTm as) (map getTm as')) +quickEq Placeholder Placeholder = True +quickEq _ _ = False + +qelem x [] = False +qelem x (y : ys) | x `quickEq` y = True + | otherwise = qelem x ys + -- FIXME: Just look for which one is the deepest, then generate all -- possibilities up to that depth. genAll :: IState -> [PTerm] -> [PTerm] -genAll i args = case filter (/=Placeholder) $ concatMap otherPats (nub args) of - [] -> [Placeholder] - xs -> nub xs +genAll i args + = case filter (/=Placeholder) $ fnub (concatMap otherPats (fnub args)) of + [] -> [Placeholder] + xs -> xs where conForm (PApp _ (PRef fc n) _) = isConName n (tt_ctxt i) conForm (PRef fc n) = isConName n (tt_ctxt i) conForm _ = False + nubMap f acc [] = acc + nubMap f acc (x : xs) = nubMap f (fnub' acc (f x)) xs + otherPats :: PTerm -> [PTerm] otherPats o@(PRef fc n) = ops fc n [] o otherPats o@(PApp _ (PRef fc n) xs) = ops fc n xs o otherPats arg = return Placeholder - ops fc n xs o + ops fc n xs_in o | (TyDecl c@(DCon _ arity) ty : _) <- lookupDef n (tt_ctxt i) - = do xs' <- mapM otherPats (map getTm xs) + = do let force = getForceable i n -- no need to generate forceable positions + let xs = dropForce force xs_in 0 + xs' <- mapM otherPats (map getTm xs) let p = PApp fc (PRef fc n) (zipWith upd xs' xs) let tyn = getTy n (tt_ctxt i) case lookupCtxt tyn (idris_datatypes i) of @@ -126,6 +156,16 @@ _ -> [p] ops fc n arg o = return Placeholder + getForceable i n = case lookupCtxt n (idris_optimisation i) of + [Optimise _ fs _] -> fs + _ -> [] + + dropForce force (x : xs) i | i `elem` force + = upd Placeholder x : dropForce force xs (i + 1) + dropForce force (x : xs) i = x : dropForce force xs (i + 1) + dropForce _ [] _ = [] + + getTy n ctxt = case lookupTy n ctxt of (t : _) -> case unApply (getRetTy t) of (P _ tyn _, _) -> tyn @@ -311,15 +351,85 @@ ist <- getIState case lookupCtxt n (idris_callgraph ist) of [cg] -> case lookupDef n (tt_ctxt ist) of - [CaseOp _ _ _ _ _ args sc _ _] -> - do logLvl 3 $ "Building SCG for " ++ show n ++ " from\n" - ++ show sc - let newscg = buildSCG' ist sc args + [CaseOp _ _ _ pats _ args sc _ _] -> + do logLvl 2 $ "Building SCG for " ++ show n ++ " from\n" + ++ show pats ++ "\n" ++ show sc + let newscg = buildSCG' ist (rights pats) args logLvl 5 $ show newscg addToCG n ( cg { scg = newscg } ) [] -> logLvl 5 $ "Could not build SCG for " ++ show n ++ "\n" x -> error $ "buildSCG: " ++ show (n, x) +buildSCG' :: IState -> [(Term, Term)] -> [Name] -> [SCGEntry] +buildSCG' ist pats args = nub $ concatMap scgPat pats where + scgPat (lhs, rhs) = let (f, pargs) = unApply (dePat lhs) in + findCalls (dePat rhs) (patvars lhs) pargs + + findCalls ap@(App f a) pvs pargs + | (P _ (UN "lazy") _, [_, arg]) <- unApply ap + = findCalls arg pvs pargs + | (P _ n _, args) <- unApply ap + = mkChange n args pargs ++ + concatMap (\x -> findCalls x pvs pargs) args + findCalls (App f a) pvs pargs + = findCalls f pvs pargs ++ findCalls a pvs pargs + findCalls (Bind n (Let t v) e) pvs pargs + = findCalls v pvs pargs ++ findCalls e (n : pvs) pargs + findCalls (Bind n _ e) pvs pargs + = findCalls e (n : pvs) pargs + findCalls (P _ f _ ) pvs pargs + | not (f `elem` pvs) = [(f, [])] + findCalls _ _ _ = [] + + mkChange n args pargs = [(n, sizes args)] + where + sizes [] = [] + sizes (a : as) = checkSize a pargs 0 : sizes as + + -- find which argument in pargs is smaller than, if any + checkSize a (p : ps) i + | a == p = Just (i, Same) + | smaller Nothing a (p, Nothing) = Just (i, Smaller) + | otherwise = checkSize a ps (i + 1) + checkSize a [] i = Nothing + + -- the smaller thing we find must be the same type as , and + -- not be coinductive - so carry the type of the constructor we've + -- gone under. + + smaller (Just tyn) a (t, Just tyt) + | a == t = isInductive (fst (unApply (getRetTy tyn))) + (fst (unApply (getRetTy tyt))) + smaller ty a (ap@(App f s), _) + | (P (DCon _ _) n _, args) <- unApply ap + = let tyn = getType n in + any (smaller (ty `mplus` Just tyn) a) + (zip args (map toJust (getArgTys tyn))) + -- check higher order recursive arguments + smaller ty (App f s) a = smaller ty f a + smaller _ _ _ = False + + toJust (n, t) = Just t + + getType n = case lookupTy n (tt_ctxt ist) of + [ty] -> ty -- must exist + + isInductive (P _ nty _) (P _ nty' _) = + let co = case lookupCtxt nty (idris_datatypes ist) of + [TI _ x _] -> x + _ -> False in + nty == nty' && not co + isInductive _ _ = False + +-- getTypeFam t | (P _ n _, _) <- unApply t + + dePat (Bind x (PVar ty) sc) = dePat (instantiate (P Bound x ty) sc) + dePat t = t + + patvars (Bind x (PVar _) sc) = x : patvars sc + patvars _ = [] + +{- buildSCG' :: IState -> SC -> [Name] -> [SCGEntry] buildSCG' ist sc args = -- trace ("Building SCG for " ++ show sc) $ nub $ scg sc (zip args args) @@ -406,6 +516,7 @@ getArgPos i n [] = Nothing getArgPos i n (x : xs) | n == x = Just i | otherwise = getArgPos (i + 1) n xs +-} checkSizeChange :: Name -> Idris Totality checkSizeChange n = do diff --git a/src/Idris/DSL.hs b/src/Idris/DSL.hs --- a/src/Idris/DSL.hs +++ b/src/Idris/DSL.hs @@ -31,12 +31,15 @@ (map (fmap (expandDo dsl)) args) expandDo dsl (PCase fc s opts) = PCase fc (expandDo dsl s) (map (pmap (expandDo dsl)) opts) +expandDo dsl (PEq fc l r) = PEq fc (expandDo dsl l) (expandDo dsl r) expandDo dsl (PPair fc l r) = PPair fc (expandDo dsl l) (expandDo dsl r) expandDo dsl (PDPair fc l t r) = PDPair fc (expandDo dsl l) (expandDo dsl t) (expandDo dsl r) expandDo dsl (PAlternative a as) = PAlternative a (map (expandDo dsl) as) expandDo dsl (PHidden t) = PHidden (expandDo dsl t) expandDo dsl (PReturn fc) = dsl_return dsl +expandDo dsl (PRewrite fc r t ty) + = PRewrite fc r (expandDo dsl t) ty expandDo dsl (PDoBlock ds) = expandDo dsl $ block (dsl_bind dsl) ds where block b [DoExp fc tm] = tm diff --git a/src/Idris/Delaborate.hs b/src/Idris/Delaborate.hs --- a/src/Idris/Delaborate.hs +++ b/src/Idris/Delaborate.hs @@ -112,6 +112,14 @@ "Can't convert " ++ showImp imps (delab i x) ++ " with " ++ showImp imps (delab i y) ++ if (opt_errContext (idris_options i)) then showSc i env else "" +pshow i (UnifyScope n out tm env) + = let imps = opt_showimp (idris_options i) in + "Can't unify " ++ show n ++ " with " + ++ showImp imps (delab i tm) ++ " as " ++ show out ++ + " is not in scope" ++ + if (opt_errContext (idris_options i)) then showSc i env else "" +pshow i (CantInferType t) + = "Can't infer type for " ++ t pshow i (NonFunctionType f ty) = let imps = opt_showimp (idris_options i) in showImp imps (delab i f) ++ " does not have a function type (" diff --git a/src/Idris/ElabDecls.hs b/src/Idris/ElabDecls.hs --- a/src/Idris/ElabDecls.hs +++ b/src/Idris/ElabDecls.hs @@ -12,6 +12,9 @@ import Idris.Coverage import Idris.DataOpts import Idris.Providers +import Idris.Primitives +import Idris.PartialEval +import IRTS.Lang import Paths_idris import Core.TT @@ -210,6 +213,43 @@ | otherwise = count n ts mParam args (_ : rest) = Nothing : mParam args rest +-- | Elaborate primitives + +elabPrims :: Idris () +elabPrims = do mapM_ (elabDecl EAll toplevel) + (map (PData "" defaultSyntax (FC "builtin" 0) False) + [inferDecl, unitDecl, falseDecl, pairDecl, eqDecl]) + mapM_ elabPrim primitives + -- Special case prim__believe_me because it doesn't work on just constants + elabBelieveMe + where elabPrim :: Prim -> Idris () + elabPrim (Prim n ty i def sc tot) + = do updateContext (addOperator n ty i (valuePrim def)) + setTotality n tot + i <- getIState + putIState i { idris_scprims = (n, sc) : idris_scprims i } + + valuePrim :: ([Const] -> Maybe Const) -> [Value] -> Maybe Value + valuePrim prim vals = fmap VConstant (mapM getConst vals >>= prim) + + getConst (VConstant c) = Just c + getConst _ = Nothing + + + p_believeMe [_,_,x] = Just x + p_believeMe _ = Nothing + believeTy = Bind (UN "a") (Pi (TType (UVar (-2)))) + (Bind (UN "b") (Pi (TType (UVar (-2)))) + (Bind (UN "x") (Pi (V 1)) (V 1))) + elabBelieveMe = do let prim__believe_me = (UN "prim__believe_me") + updateContext (addOperator prim__believe_me believeTy 3 p_believeMe) + setTotality prim__believe_me (Partial NotCovering) + i <- getIState + putIState i { + idris_scprims = (prim__believe_me, (3, LNoOp)) : idris_scprims i + } + + -- | Elaborate a type provider elabProvider :: ElabInfo -> SyntaxInfo -> FC -> Name -> PTerm -> PTerm -> Idris () elabProvider info syn fc n ty tm @@ -258,7 +298,40 @@ , tp == tp' = True isProviderOf _ _ = False +-- | Elaborate a type provider +elabTransform :: ElabInfo -> FC -> Bool -> PTerm -> PTerm -> Idris () +elabTransform info fc safe lhs_in rhs_in + = do ctxt <- getContext + i <- getIState + let lhs = addImplPat i lhs_in + ((lhs', dlhs, []), _) <- + tclift $ elaborate ctxt (MN 0 "transLHS") infP [] + (erun fc (buildTC i info True False (UN "transform") + (infTerm lhs))) + let lhs_tm = orderPats (getInferTerm lhs') + let lhs_ty = getInferType lhs' + let newargs = pvars i lhs_tm + (clhs_tm, clhs_ty) <- recheckC fc [] lhs_tm + logLvl 3 ("Transform LHS " ++ show clhs_tm) + let rhs = addImplBound i (map fst newargs) rhs_in + ((rhs', defer), _) <- + tclift $ elaborate ctxt (MN 0 "transRHS") clhs_ty [] + (do pbinds lhs_tm + erun fc (build i info False (UN "transform") rhs) + erun fc $ psolve lhs_tm + tt <- get_term + let (tm, ds) = runState (collectDeferred tt) [] + return (tm, ds)) + (crhs_tm, crhs_ty) <- recheckC fc [] rhs' + logLvl 3 ("Transform RHS " ++ show crhs_tm) + when safe $ case converts ctxt [] clhs_tm crhs_tm of + OK _ -> return () + Error e -> ierror (At fc (CantUnify False clhs_tm crhs_tm e [] 0)) + addTrans (clhs_tm, crhs_tm) + addIBC (IBCTrans (clhs_tm, crhs_tm)) + + elabRecord :: ElabInfo -> SyntaxInfo -> String -> FC -> Name -> PTerm -> String -> Name -> PTerm -> Idris () elabRecord info syn doc fc tyn ty cdoc cn cty @@ -443,12 +516,13 @@ putIState (ist { idris_optimisation = opts }) addIBC (IBCOpt n) ist <- getIState - let pats = pats_in + let pats = doTransforms ist pats_in + -- logLvl 3 (showSep "\n" (map (\ (l,r) -> -- show l ++ " = " ++ -- show r) pats)) let tcase = opt_typecase (idris_options ist) - let pdef = map debind $ map (simpl False (tt_ctxt ist)) pats + let pdef = map debind $ map (simpl (tt_ctxt ist)) pats numArgs <- tclift $ sameLength pdef @@ -457,9 +531,13 @@ (take numArgs (repeat Erased)), Erased)] else stripCollapsed pats - logLvl 5 $ "Patterns:\n" ++ show pats + logLvl 5 $ "Patterns:\n" ++ show pats_in + case specNames opts of + Just _ -> logLvl 5 $ "Partially evaluated:\n" ++ show pats + _ -> return () + logLvl 3 $ "SIMPLIFIED: \n" ++ show pdef - let optpdef = map debind $ map (simpl True (tt_ctxt ist)) optpats + let optpdef = map debind $ map (simpl (tt_ctxt ist)) optpats tree@(CaseDef scargs sc _) <- tclift $ simpleCase tcase False CompileTime fc pdef cov <- coverage @@ -560,11 +638,13 @@ getLHS (_, l, _) = l - simpl rt ctxt (Right (x, y)) = Right (normalise ctxt [] x, - simplify ctxt rt [] y) --- simpl rt ctxt (Right (x, y)) = Right (x, y) - simpl rt ctxt t = t + simpl ctxt (Right (x, y)) = Right (normalise ctxt [] x, y) + simpl ctxt t = t + specNames [] = Nothing + specNames (Specialise ns : _) = Just ns + specNames (_ : xs) = specNames xs + sameLength ((_, x, _) : xs) = do l <- sameLength xs let (f, as) = unApply x @@ -572,6 +652,13 @@ else tfail (At fc (Msg "Clauses have differing numbers of arguments ")) sameLength [] = return 0 + -- apply all transformations (just specialisation for now, add + -- user defined transformation rules later) + doTransforms ist pats = + case specNames opts of + Nothing -> pats + Just ns -> partial_eval (tt_ctxt ist) ns pats + elabVal :: ElabInfo -> Bool -> PTerm -> Idris (Term, Type) elabVal info aspat tm_in = do ctxt <- getContext @@ -647,7 +734,8 @@ let lhs_ty = getInferType lhs' logLvl 3 ("Elaborated: " ++ show lhs_tm) logLvl 3 ("Elaborated type: " ++ show lhs_ty) - (clhs, clhsty) <- recheckC fc [] lhs_tm + (clhs_c, clhsty) <- recheckC fc [] lhs_tm + let clhs = normalise ctxt [] clhs_c logLvl 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty) -- Elaborate where block ist <- getIState @@ -764,6 +852,7 @@ addP t = t propagateParams ps (PRef fc n) = PApp fc (PRef fc n) (map (\x -> pimp x (PRef fc x)) ps) + propagateParams ps x = x elabClause info tcgen (_, PWith fc fname lhs_in withs wval_in withblock) = do ctxt <- getContext @@ -938,6 +1027,9 @@ -- build instance constructor type -- decorate names of functions to ensure they can't be referred -- to elsewhere in the class declaration + -- TODO: Remove mdec to make it a dependent record, which would + -- allow dependent type classes, but building instances will + -- then need some attention. let cty = impbind ps $ conbind constraints $ pibind (map (\ (n, ty) -> (mdec n, ty)) methods) constraint @@ -1129,7 +1221,7 @@ -- mapM_ (elabDecl EAll info) (concat fns) where intInst = case ps of - [PConstant IType] -> True + [PConstant (AType (ATInt ITNative))] -> True _ -> False checkNotOverlapping i t n @@ -1357,11 +1449,13 @@ | what /= EDefns = do iLOG $ "Elaborating type provider " ++ show n elabProvider info syn fc n tp tm +elabDecl' what info (PTransform fc safety old new) + = elabTransform info fc safety old new elabDecl' _ _ _ = return () -- skipped this time elabCaseBlock info d@(PClauses f o n ps) = do addIBC (IBCDef n) --- iputStrLn $ "CASE BLOCK: " ++ show (n, d) + logLvl 6 $ "CASE BLOCK: " ++ show (n, d) elabDecl' EAll info d -- elabDecl' info (PImport i) = loadModule i diff --git a/src/Idris/ElabTerm.hs b/src/Idris/ElabTerm.hs --- a/src/Idris/ElabTerm.hs +++ b/src/Idris/ElabTerm.hs @@ -95,7 +95,9 @@ elab :: IState -> ElabInfo -> Bool -> Bool -> Name -> PTerm -> ElabD () elab ist info pattern tcgen fn tm - = do elabE (False, False) tm -- (in argument, guarded) + = do let loglvl = opt_logLevel (idris_options ist) + when (loglvl > 5) $ unifyLog True + elabE (False, False) tm -- (in argument, guarded) end_unify when pattern -- convert remaining holes to pattern vars (do update_term orderPats @@ -232,7 +234,7 @@ -- let sc' = mapPT (repN n n') sc ptm <- get_term g <- goal - checkPiGoal + checkPiGoal n attack; intro (Just n); -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm) elabE (True, a) sc; solve @@ -242,7 +244,7 @@ = do hsin <- get_holes ptmin <- get_term tyn <- unique_hole (MN 0 "lamty") - checkPiGoal + checkPiGoal n claim tyn RType attack ptm <- get_term @@ -283,8 +285,12 @@ elabE (True, a) ty focus valn elabE (True, a) val + env <- get_env elabE (True, a) sc - ptm <- get_term + -- HACK: If the name leaks into its type, it may leak out of + -- scope outside, so substitute in the outer scope. + expandLet n (case lookup n env of + Just (Let t v) -> v) solve elab' ina tm@(PApp fc (PInferRef _ f) args) = do rty <- goal @@ -331,6 +337,12 @@ Just xs@(_:_) -> NS n xs _ -> n + elab' (ina, g) (PMatchApp fc fn) + = do (fn', imps) <- case lookupCtxtName fn (idris_implicits ist) of + [(n, args)] -> return (n, map (const True) args) + _ -> lift $ tfail (NoSuchVariable fn) + ns <- match_apply (Var fn') (map (\x -> (x,0)) imps) + solve -- if f is local, just do a simple_app elab' (ina, g) tm@(PApp fc (PRef _ f) args') = do let args = {- case lookupCtxt f (inblock info) of @@ -342,6 +354,7 @@ then -- simple app, as below do simple_app (elabE (ina, g) (PRef fc f)) (elabE (True, g) (getTm (head args'))) + (show tm) solve else do ivs <- get_instances @@ -394,9 +407,10 @@ setInjective (PApp _ (PRef _ n) _) = setinj n setInjective _ = return () - elab' ina@(_, a) (PApp fc f [arg]) + elab' ina@(_, a) tm@(PApp fc f [arg]) = erun fc $ do simple_app (elabE ina f) (elabE (True, a) (getTm arg)) + (show tm) solve elab' ina Placeholder = do (h : hs) <- get_holes movelast h @@ -411,7 +425,7 @@ | not pattern = do mapM_ (runTac False ist) ts | otherwise = elab' ina Placeholder elab' ina (PElabError e) = fail (pshow ist e) - elab' ina (PRewrite fc r sc) + elab' ina (PRewrite fc r sc newg) = do attack tyn <- unique_hole (MN 0 "rty") claim tyn RType @@ -426,8 +440,24 @@ rewrite (Var letn) g' <- goal when (g == g') $ lift $ tfail (NoRewriting g) - elab' ina sc + case newg of + Nothing -> elab' ina sc + Just t -> doEquiv t sc solve + where doEquiv t sc = + do attack + tyn <- unique_hole (MN 0 "ety") + claim tyn RType + valn <- unique_hole (MN 0 "eqval") + claim valn (Var tyn) + letn <- unique_hole (MN 0 "equiv_val") + letbind letn (Var tyn) (Var valn) + focus tyn + elab' ina t + focus valn + elab' ina sc + elab' ina (PRef fc letn) + solve elab' ina@(_, a) c@(PCase fc scr opts) = do attack tyn <- unique_hole (MN 0 "scty") @@ -444,8 +474,9 @@ elab' ina (PMetavar cname') let newdef = PClauses fc [] cname' (caseBlock fc cname' (reverse args) opts) - -- fail $ "Not implemented " ++ show c ++ "\n" ++ show args -- elaborate case + env <- get_env + g <- goal updateAux (newdef : ) -- if we haven't got the type yet, hopefully we'll get it later! movelast tyn @@ -457,6 +488,9 @@ mkN n = case namespace info of Just xs@(_:_) -> NS n xs _ -> n + elab' ina (PUnifyLog t) = do unifyLog True + elab' ina t + unifyLog False elab' ina x = fail $ "Something's gone wrong. Did you miss a semi-colon somewhere?" caseBlock :: FC -> Name -> [(Name, Binder Term)] -> @@ -613,9 +647,11 @@ if True -- all (\n -> not (n `elem` hs)) (freeNames g) then try' (trivial ist) (do t <- goal - let insts = findInstances ist t let (tc, ttypes) = unApply t scopeOnly <- needsDefault t tc ttypes + let insts_in = findInstances ist t + let insts = if scopeOnly then filter chaser insts_in + else insts_in tm <- get_term -- traceWhen (depth > 6) ("GOAL: " ++ show t ++ "\nTERM: " ++ show tm) $ -- (tryAll (map elabTC (map fst (ctxtAlist (tt_ctxt ist))))) @@ -631,9 +667,15 @@ elabTC n | n /= fn && tcname n = (resolve n depth, show n) | otherwise = (fail "Can't resolve", show n) + -- HACK! Rather than giving a special name, better to have some kind + -- of flag in ClassInfo structure + chaser (UN ('@':'@':_)) = True + chaser (NS n _) = chaser n + chaser _ = False + needsDefault t num@(P _ (NS (UN "Num") ["Builtins"]) _) [P Bound a _] = do focus a - fill (RConstant IType) -- default Int + fill (RConstant (AType (ATInt ITBig))) -- default Integer solve return False needsDefault t f as @@ -718,6 +760,18 @@ bname _ = Nothing runT (Exact tm) = do elab ist toplevel False False (MN 0 "tac") tm when autoSolve solveAll + runT (MatchRefine fn) + = do (fn', imps) <- case lookupCtxtName fn (idris_implicits ist) of + [] -> do a <- envArgs fn + return (fn, a) + [(n, args)] -> return $ (n, map (const True) args) + ns <- match_apply (Var fn') (map (\x -> (x, 0)) imps) + when autoSolve solveAll + where envArgs n = do e <- get_env + case lookup n e of + Just t -> return $ map (const False) + (getArgTys (binderTy t)) + _ -> return [] runT (Refine fn []) = do (fn', imps) <- case lookupCtxtName fn (idris_implicits ist) of [] -> do a <- envArgs fn @@ -735,6 +789,18 @@ _ -> return [] runT (Refine fn imps) = do ns <- apply (Var fn) (map (\x -> (x,0)) imps) when autoSolve solveAll + runT (Equiv tm) -- let bind tm, then + = do attack + tyn <- unique_hole (MN 0 "ety") + claim tyn RType + valn <- unique_hole (MN 0 "eqval") + claim valn (Var tyn) + letn <- unique_hole (MN 0 "equiv_val") + letbind letn (Var tyn) (Var valn) + focus tyn + elab ist toplevel False False (MN 0 "tac") tm + focus valn + when autoSolve solveAll runT (Rewrite tm) -- to elaborate tm, let bind it, then rewrite by that = do attack; -- (h:_) <- get_holes tyn <- unique_hole (MN 0 "rty") @@ -1028,15 +1094,15 @@ reifyTTBinderApp _ f args = fail ("Unknown reflection binder: " ++ show (f, args)) reifyTTConst :: Term -> ElabD Const -reifyTTConst (P _ n _) | n == reflm "IType" = return $ IType -reifyTTConst (P _ n _) | n == reflm "BIType" = return $ BIType -reifyTTConst (P _ n _) | n == reflm "FlType" = return $ FlType -reifyTTConst (P _ n _) | n == reflm "ChType" = return $ ChType +reifyTTConst (P _ n _) | n == reflm "IType" = return (AType (ATInt ITNative)) +reifyTTConst (P _ n _) | n == reflm "BIType" = return (AType (ATInt ITBig)) +reifyTTConst (P _ n _) | n == reflm "FlType" = return (AType ATFloat) +reifyTTConst (P _ n _) | n == reflm "ChType" = return (AType (ATInt ITChar)) reifyTTConst (P _ n _) | n == reflm "StrType" = return $ StrType -reifyTTConst (P _ n _) | n == reflm "B8Type" = return $ B8Type -reifyTTConst (P _ n _) | n == reflm "B16Type" = return $ B16Type -reifyTTConst (P _ n _) | n == reflm "B32Type" = return $ B32Type -reifyTTConst (P _ n _) | n == reflm "B64Type" = return $ B64Type +reifyTTConst (P _ n _) | n == reflm "B8Type" = return (AType (ATInt (ITFixed IT8))) +reifyTTConst (P _ n _) | n == reflm "B16Type" = return (AType (ATInt (ITFixed IT16))) +reifyTTConst (P _ n _) | n == reflm "B32Type" = return (AType (ATInt (ITFixed IT32))) +reifyTTConst (P _ n _) | n == reflm "B64Type" = return (AType (ATInt (ITFixed IT64))) reifyTTConst (P _ n _) | n == reflm "PtrType" = return $ PtrType reifyTTConst (P _ n _) | n == reflm "VoidType" = return $ VoidType reifyTTConst (P _ n _) | n == reflm "Forgot" = return $ Forgot @@ -1146,19 +1212,19 @@ reflectConstant c@(Fl _) = reflCall "Fl" [RConstant c] reflectConstant c@(Ch _) = reflCall "Ch" [RConstant c] reflectConstant c@(Str _) = reflCall "Str" [RConstant c] -reflectConstant (IType) = Var (reflm "IType") -reflectConstant (BIType) = Var (reflm "BIType") -reflectConstant (FlType) = Var (reflm "FlType") -reflectConstant (ChType) = Var (reflm "ChType") +reflectConstant (AType (ATInt ITNative)) = Var (reflm "IType") +reflectConstant (AType (ATInt ITBig)) = Var (reflm "BIType") +reflectConstant (AType ATFloat) = Var (reflm "FlType") +reflectConstant (AType (ATInt ITChar)) = Var (reflm "ChType") reflectConstant (StrType) = Var (reflm "StrType") reflectConstant c@(B8 _) = reflCall "B8" [RConstant c] reflectConstant c@(B16 _) = reflCall "B16" [RConstant c] reflectConstant c@(B32 _) = reflCall "B32" [RConstant c] reflectConstant c@(B64 _) = reflCall "B64" [RConstant c] -reflectConstant (B8Type) = Var (reflm "B8Type") -reflectConstant (B16Type) = Var (reflm "B16Type") -reflectConstant (B32Type) = Var (reflm "B32Type") -reflectConstant (B64Type) = Var (reflm "B64Type") +reflectConstant (AType (ATInt (ITFixed IT8))) = Var (reflm "B8Type") +reflectConstant (AType (ATInt (ITFixed IT16))) = Var (reflm "B16Type") +reflectConstant (AType (ATInt (ITFixed IT32))) = Var (reflm "B32Type") +reflectConstant (AType (ATInt (ITFixed IT64))) = Var (reflm "B64Type") reflectConstant (PtrType) = Var (reflm "PtrType") reflectConstant (VoidType) = Var (reflm "VoidType") reflectConstant (Forgot) = Var (reflm "Forgot") diff --git a/src/Idris/IBC.hs b/src/Idris/IBC.hs --- a/src/Idris/IBC.hs +++ b/src/Idris/IBC.hs @@ -11,6 +11,7 @@ import Idris.Error import Data.Binary +import Data.Vector.Binary import Data.List import Data.ByteString.Lazy as B hiding (length, elem) import Control.Monad @@ -23,7 +24,7 @@ import Paths_idris ibcVersion :: Word8 -ibcVersion = 29 +ibcVersion = 32 data IBCFile = IBCFile { ver :: Word8, sourcefile :: FilePath, @@ -38,16 +39,17 @@ ibc_optimise :: [(Name, OptInfo)], ibc_syntax :: [Syntax], ibc_keywords :: [String], - ibc_objs :: [FilePath], - ibc_libs :: [String], + ibc_objs :: [(Codegen, FilePath)], + ibc_libs :: [(Codegen, String)], ibc_dynamic_libs :: [String], - ibc_hdrs :: [String], + ibc_hdrs :: [(Codegen, String)], ibc_access :: [(Name, Accessibility)], ibc_total :: [(Name, Totality)], ibc_flags :: [(Name, [FnOpt])], ibc_cg :: [(Name, CGInfo)], ibc_defs :: [(Name, Def)], ibc_docstrings :: [(Name, String)], + ibc_transforms :: [(Term, Term)], ibc_coercions :: [Name] } deriving Show @@ -56,7 +58,7 @@ !-} initIBC :: IBCFile -initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] +initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] loadIBC :: FilePath -> Idris () loadIBC fp = do iLOG $ "Loading ibc " ++ fp @@ -112,10 +114,10 @@ ibc i (IBCSyntax n) f = return f { ibc_syntax = n : ibc_syntax f } ibc i (IBCKeyword n) f = return f { ibc_keywords = n : ibc_keywords f } ibc i (IBCImport n) f = return f { ibc_imports = n : ibc_imports f } -ibc i (IBCObj n) f = return f { ibc_objs = n : ibc_objs f } -ibc i (IBCLib n) f = return f { ibc_libs = n : ibc_libs f } +ibc i (IBCObj tgt n) f = return f { ibc_objs = (tgt, n) : ibc_objs f } +ibc i (IBCLib tgt n) f = return f { ibc_libs = (tgt, n) : ibc_libs f } ibc i (IBCDyLib n) f = return f {ibc_dynamic_libs = n : ibc_dynamic_libs f } -ibc i (IBCHeader n) f = return f { ibc_hdrs = n : ibc_hdrs f } +ibc i (IBCHeader tgt n) f = return f { ibc_hdrs = (tgt, n) : ibc_hdrs f } ibc i (IBCDef n) f = case lookupDef n (tt_ctxt i) of [v] -> return f { ibc_defs = (n,v) : ibc_defs f } _ -> fail "IBC write failed" @@ -129,16 +131,18 @@ ibc i (IBCAccess n a) f = return f { ibc_access = (n,a) : ibc_access f } ibc i (IBCFlags n a) f = return f { ibc_flags = (n,a) : ibc_flags f } ibc i (IBCTotal n a) f = return f { ibc_total = (n,a) : ibc_total f } +ibc i (IBCTrans t) f = return f { ibc_transforms = t : ibc_transforms f } process :: IBCFile -> FilePath -> Idris () process i fn | ver i /= ibcVersion = do iLOG "ibc out of date" fail "Incorrect ibc version" - | otherwise = + | otherwise = do srcok <- liftIO $ doesFileExist (sourcefile i) when srcok $ liftIO $ timestampOlder (sourcefile i) fn v <- verbose - when (v && srcok) $ iputStrLn $ "Skipping " ++ sourcefile i + quiet <- getQuiet + when (v && srcok && not quiet) $ iputStrLn $ "Skipping " ++ sourcefile i pImports (ibc_imports i) pImps (ibc_implicits i) pFixes (ibc_fixes i) @@ -160,6 +164,7 @@ pCG (ibc_cg i) pDocs (ibc_docstrings i) pCoercions (ibc_coercions i) + pTrans (ibc_transforms i) timestampOlder :: FilePath -> FilePath -> IO () timestampOlder src ibc = do srct <- getModificationTime src @@ -242,11 +247,11 @@ pKeywords k = do i <- getIState putIState (i { syntax_keywords = k ++ syntax_keywords i }) -pObjs :: [FilePath] -> Idris () -pObjs os = mapM_ addObjectFile os +pObjs :: [(Codegen, FilePath)] -> Idris () +pObjs os = mapM_ (uncurry addObjectFile) os -pLibs :: [String] -> Idris () -pLibs ls = mapM_ addLib ls +pLibs :: [(Codegen, String)] -> Idris () +pLibs ls = mapM_ (uncurry addLib) ls pDyLibs :: [String] -> Idris () pDyLibs ls = do res <- mapM (addDyLib . return) ls @@ -255,8 +260,8 @@ where checkLoad (Left _) = return () checkLoad (Right err) = fail err -pHdrs :: [String] -> Idris () -pHdrs hs = mapM_ addHdr hs +pHdrs :: [(Codegen, String)] -> Idris () +pHdrs hs = mapM_ (uncurry addHdr) hs pDefs :: [(Name, Def)] -> Idris () pDefs ds = mapM_ (\ (n, d) -> @@ -289,6 +294,9 @@ pCoercions :: [Name] -> Idris () pCoercions ns = mapM_ (\ n -> addCoercion n) ns +pTrans :: [(Term, Term)] -> Idris () +pTrans ts = mapM_ addTrans ts + ----- Generated by 'derive' instance Binary SizeChange where @@ -363,7 +371,7 @@ 3 -> return NErased _ -> error "Corrupted binary data for Name" - + instance Binary Const where put x = case x of @@ -382,17 +390,23 @@ B32 x1 -> putWord8 7 >> put x1 B64 x1 -> putWord8 8 >> put x1 - IType -> putWord8 9 - BIType -> putWord8 10 - FlType -> putWord8 11 - ChType -> putWord8 12 + (AType (ATInt ITNative)) -> putWord8 9 + (AType (ATInt ITBig)) -> putWord8 10 + (AType ATFloat) -> putWord8 11 + (AType (ATInt ITChar)) -> putWord8 12 StrType -> putWord8 13 PtrType -> putWord8 14 Forgot -> putWord8 15 - B8Type -> putWord8 16 - B16Type -> putWord8 17 - B32Type -> putWord8 18 - B64Type -> putWord8 19 + (AType (ATInt (ITFixed ity))) -> putWord8 (fromIntegral (16 + fromEnum ity)) -- 16-19 inclusive + (AType (ATInt (ITVec ity count))) -> do + putWord8 20 + putWord8 (fromIntegral . fromEnum $ ity) + putWord8 (fromIntegral count) + + B8V x1 -> putWord8 21 >> put x1 + B16V x1 -> putWord8 22 >> put x1 + B32V x1 -> putWord8 23 >> put x1 + B64V x1 -> putWord8 24 >> put x1 get = do i <- getWord8 case i of @@ -411,19 +425,29 @@ 7 -> fmap B32 get 8 -> fmap B64 get - 9 -> return IType - 10 -> return BIType - 11 -> return FlType - 12 -> return ChType + 9 -> return (AType (ATInt ITNative)) + 10 -> return (AType (ATInt ITBig)) + 11 -> return (AType ATFloat) + 12 -> return (AType (ATInt ITChar)) 13 -> return StrType 14 -> return PtrType 15 -> return Forgot - 16 -> return B8Type - 17 -> return B16Type - 18 -> return B32Type - 19 -> return B64Type + 16 -> return (AType (ATInt (ITFixed IT8))) + 17 -> return (AType (ATInt (ITFixed IT16))) + 18 -> return (AType (ATInt (ITFixed IT32))) + 19 -> return (AType (ATInt (ITFixed IT64))) + 20 -> do + e <- getWord8 + c <- getWord8 + return (AType (ATInt (ITVec (toEnum . fromIntegral $ e) (fromIntegral c)))) + + 21 -> fmap B8V get + 22 -> fmap B16V get + 23 -> fmap B32V get + 24 -> fmap B64V get + _ -> error "Corrupted binary data for Const" @@ -763,7 +787,7 @@ _ -> error "Corrupted binary data for Totality" instance Binary IBCFile where - put x@(IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24) + put x@(IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25) = {-# SCC "putIBCFile" #-} do put x1 put x2 @@ -789,6 +813,7 @@ put x22 put x23 put x24 + put x25 get = do x1 <- get if x1 == ibcVersion then @@ -815,7 +840,8 @@ x22 <- get x23 <- get x24 <- get - return (IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24) + x25 <- get + return (IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25) else return (initIBC { ver = x1 }) instance Binary FnOpt where @@ -1019,6 +1045,11 @@ put x4 put x5 put x6 + PReflection x1 x2 x3 x4 -> do putWord8 13 + put x1 + put x2 + put x3 + put x4 get = do i <- getWord8 case i of @@ -1094,6 +1125,11 @@ x5 <- get x6 <- get return (PPostulate x1 x2 x3 x4 x5 x6) + 13 -> do x1 <- get + x2 <- get + x3 <- get + x4 <- get + return (PReflection x1 x2 x3 x4) _ -> error "Corrupted binary data for PDecl'" instance Binary Using where @@ -1288,10 +1324,11 @@ PInferRef x1 x2 -> do putWord8 29 put x1 put x2 - PRewrite x1 x2 x3 -> do putWord8 30 - put x1 - put x2 - put x3 + PRewrite x1 x2 x3 x4 -> do putWord8 30 + put x1 + put x2 + put x3 + put x4 get = do i <- getWord8 case i of @@ -1379,7 +1416,8 @@ 30 -> do x1 <- get x2 <- get x3 <- get - return (PRewrite x1 x2 x3) + x4 <- get + return (PRewrite x1 x2 x3 x4) _ -> error "Corrupted binary data for PTerm" instance (Binary t) => Binary (PTactic' t) where @@ -1676,3 +1714,22 @@ 4 -> do x1 <- get return (Binding x1) _ -> error "Corrupted binary data for SSymbol" + +instance Binary Codegen where + put x + = case x of + ViaC -> putWord8 0 + ViaJava -> putWord8 1 + ViaNode -> putWord8 2 + ViaJavaScript -> putWord8 3 + Bytecode -> putWord8 4 + get + = do i <- getWord8 + case i of + 0 -> return ViaC + 1 -> return ViaJava + 2 -> return ViaNode + 3 -> return ViaJavaScript + 4 -> return Bytecode + _ -> error "Corrupted binary data for Codegen" + diff --git a/src/Idris/IdeSlave.hs b/src/Idris/IdeSlave.hs --- a/src/Idris/IdeSlave.hs +++ b/src/Idris/IdeSlave.hs @@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, IncoherentInstances #-} -module Idris.IdeSlave(parseMessage, convSExp, IdeSlaveCommand(..), sexpToCommand, toSExp, SExp(..)) where +module Idris.IdeSlave(parseMessage, convSExp, IdeSlaveCommand(..), sexpToCommand, toSExp, SExp(..), SExpable) where import Text.Printf import Numeric @@ -8,6 +8,8 @@ -- import qualified Data.Text as T import Text.Parsec +import Core.TT + data SExp = SexpList [SExp] | StringAtom String | BoolAtom Bool @@ -42,6 +44,11 @@ instance SExpable Int where toSExp n = IntegerAtom (toInteger n) + +instance SExpable Name where + toSExp s = StringAtom (show s) + + instance (SExpable a) => SExpable (Maybe a) where toSExp Nothing = SexpList [SymbolAtom "Nothing"] toSExp (Just a) = SexpList [SymbolAtom "Just", toSExp a] @@ -94,7 +101,7 @@ sexpToCommand (SexpList [SymbolAtom "interpret", StringAtom cmd]) = Just (Interpret cmd) sexpToCommand (SexpList [SymbolAtom "repl-completions", StringAtom prefix]) = Just (REPLCompletions prefix) sexpToCommand (SexpList [SymbolAtom "load-file", StringAtom filename]) = Just (LoadFile filename) -sexpToCommand _ = Nothing +sexpToCommand _ = Nothing parseMessage :: String -> (SExp, Integer) parseMessage x = case receiveString x of diff --git a/src/Idris/Parser.hs b/src/Idris/Parser.hs --- a/src/Idris/Parser.hs +++ b/src/Idris/Parser.hs @@ -344,7 +344,8 @@ <|> pInstance syn <|> do d <- pDSL syn; return [d] <|> pDirective syn - <|> pProvider syn + <|> try (pProvider syn) + <|> pTransform syn <|> try (do reserved "import"; fp <- identifier fail "imports must be at the top of file") @@ -607,6 +608,8 @@ pNoExtExpr syn = try (pApp syn) + <|> try (pMatchApp syn) + <|> try (pUnifyLog syn) <|> pRecordType syn <|> try (pSimpleExpr syn) <|> pLambda syn @@ -709,12 +712,17 @@ <|> do reserved "partial"; pFnOpts (PartialFn : (opts \\ [TotalFn])) <|> try (do lchar '%'; reserved "export"; c <- strlit; pFnOpts (CExport c : opts)) - <|> do lchar '%'; reserved "assert_total"; pFnOpts (AssertTotal : opts) + <|> try (do lchar '%'; reserved "assert_total"; + pFnOpts (AssertTotal : opts)) <|> do lchar '%'; reserved "specialise"; - lchar '['; ns <- sepBy pfName (lchar ','); lchar ']' + lchar '['; ns <- sepBy nameTimes (lchar ','); lchar ']' pFnOpts (Specialise ns : opts) <|> do reserved "implicit"; pFnOpts (Implicit : opts) <|> return opts + where nameTimes = do n <- pfName + t <- option Nothing (do reds <- natural + return (Just (fromInteger reds))) + return (n, t) addAcc :: Name -> Maybe Accessibility -> IParser () addAcc n a = do i <- getState @@ -808,22 +816,21 @@ modifyConst :: SyntaxInfo -> FC -> PTerm -> PTerm modifyConst syn fc (PConstant (BI x)) - | not (fitsInt x) = PAlternative False - [PConstant (BI x), - PApp fc (PRef fc (UN "fromInteger")) - [pexp (PConstant (I (fromInteger x)))]] | not (inPattern syn) = PAlternative False - [PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (I (fromInteger x)))], - PConstant (I (fromInteger x)), PConstant (BI x)] - | otherwise = PAlternative False - [PConstant (I (fromInteger x)), PConstant (BI x)] + (PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (BI (fromInteger x)))] + : consts) + | otherwise = PAlternative False consts + where + consts = [ PConstant (BI x) + , PConstant (I (fromInteger x)) + , PConstant (B8 (fromInteger x)) + , PConstant (B16 (fromInteger x)) + , PConstant (B32 (fromInteger x)) + , PConstant (B64 (fromInteger x)) + ] modifyConst syn fc x = x -fitsInt :: Integer -> Bool -fitsInt x = let xInt :: Int = fromInteger x - xInteger :: Integer = toInteger xInt in - x == xInteger pList syn = do lchar '['; fc <- pfc; xs <- sepBy (pExpr syn) (lchar ','); lchar ']' return (mkList fc xs) @@ -874,6 +881,19 @@ return $ PHidden e <|> pSimpleExpr syn +pMatchApp syn = do ty <- pSimpleExpr syn + symbol "<==" + fc <- pfc + f <- pfName + return (PLet (MN 0 "match") + ty + (PMatchApp fc f) + (PRef fc (MN 0 "match"))) + +pUnifyLog syn = do lchar '%'; reserved "unifyLog"; + tm <- pSimpleExpr syn + return (PUnifyLog tm) + pApp syn = do f <- pSimpleExpr syn fc <- pfc args <- many1 (do notEndApp @@ -960,9 +980,13 @@ do reserved "rewrite" fc <- pfc prf <- pExpr syn + giving <- option Nothing + (do symbol "==>"; tm <- pExpr' syn + return (Just tm)) reserved "in"; sc <- pExpr syn return (PRewrite fc - (PApp fc (PRef fc (UN "sym")) [pexp prf]) sc) + (PApp fc (PRef fc (UN "sym")) [pexp prf]) sc + giving) pLet syn = try (do reserved "let"; n <- pName; ty <- option Placeholder (do lchar ':'; pExpr' syn) @@ -1125,16 +1149,20 @@ return (PIdiom fc e) pConstant :: IParser Const -pConstant = do reserved "Integer";return BIType - <|> do reserved "Int"; return IType - <|> do reserved "Char"; return ChType - <|> do reserved "Float"; return FlType +pConstant = do reserved "Integer";return (AType (ATInt ITBig)) + <|> do reserved "Int"; return (AType (ATInt ITNative)) + <|> do reserved "Char"; return (AType (ATInt ITChar)) + <|> do reserved "Float"; return (AType ATFloat) <|> do reserved "String"; return StrType <|> do reserved "Ptr"; return PtrType - <|> do reserved "Bits8"; return B8Type - <|> do reserved "Bits16"; return B16Type - <|> do reserved "Bits32"; return B32Type - <|> do reserved "Bits64"; return B64Type + <|> do reserved "Bits8"; return (AType (ATInt (ITFixed IT8))) + <|> do reserved "Bits16"; return (AType (ATInt (ITFixed IT16))) + <|> do reserved "Bits32"; return (AType (ATInt (ITFixed IT32))) + <|> do reserved "Bits64"; return (AType (ATInt (ITFixed IT64))) + <|> do reserved "Bits8x16"; return (AType (ATInt (ITVec IT8 16))) + <|> do reserved "Bits16x8"; return (AType (ATInt (ITVec IT16 8))) + <|> do reserved "Bits32x4"; return (AType (ATInt (ITVec IT32 4))) + <|> do reserved "Bits64x2"; return (AType (ATInt (ITVec IT64 2))) <|> try (do f <- float; return $ Fl f) <|> try (do i <- natural; return $ BI i) <|> try (do s <- strlit; return $ Str s) @@ -1149,7 +1177,7 @@ table fixes = [[prefix "-" (\fc x -> PApp fc (PRef fc (UN "-")) - [pexp (PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (I 0))]), pexp x])]] + [pexp (PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (BI 0))]), pexp x])]] ++ toTable (reverse fixes) ++ [[backtick], [binary "=" PEq AssocLeft], @@ -1358,17 +1386,20 @@ pRHS :: SyntaxInfo -> Name -> IParser PTerm pRHS syn n = do lchar '='; pExpr syn - <|> do symbol "?="; rhs <- pExpr syn; - return (addLet rhs) + <|> do symbol "?="; + name <- option n' (do symbol "{"; n <- pfName; symbol "}"; + return n) + rhs <- pExpr syn + return (addLet name rhs) <|> do reserved "impossible"; return PImpossible where mkN (UN x) = UN (x++"_lemma_1") mkN (NS x n) = NS (mkN x) n n' = mkN n - addLet (PLet n ty val rhs) = PLet n ty val (addLet rhs) - addLet (PCase fc t cs) = PCase fc t (map addLetC cs) - where addLetC (l, r) = (l, addLet r) - addLet rhs = (PLet (UN "value") Placeholder rhs (PMetavar n')) + addLet nm (PLet n ty val rhs) = PLet n ty val (addLet nm rhs) + addLet nm (PCase fc t cs) = PCase fc t (map addLetC cs) + where addLetC (l, r) = (l, addLet nm r) + addLet nm rhs = (PLet (UN "value") Placeholder rhs (PMetavar nm)) pClause :: SyntaxInfo -> IParser PClause pClause syn @@ -1395,6 +1426,27 @@ setState (ist { lastParse = Just n }) return $ PClause fc n capp wargs rhs wheres) <|> try (do pushIndent + ty <- pSimpleExpr syn + symbol "<==" + fc <- pfc + n_in <- pfName; let n = expandNS syn n_in + rhs <- pRHS syn n + ist <- getState + let ctxt = tt_ctxt ist + let wsyn = syn { syn_namespace = [] } + (wheres, nmap) <- choice [do x <- pWhereblock n wsyn + popIndent + return x, + do pTerminator + return ([], [])] + let capp = PLet (MN 0 "match") + ty + (PMatchApp fc n) + (PRef fc (MN 0 "match")) + ist <- getState + setState (ist { lastParse = Just n }) + return $ PClause fc n capp [] rhs wheres) + <|> try (do pushIndent wargs <- many1 (pWExpr syn) ist <- getState n <- case lastParse ist of @@ -1441,7 +1493,7 @@ let withs = concat ds closeBlock return $ PWithR fc wargs wval withs) - + <|> do pushIndent l <- pArgExpr syn op <- operator @@ -1500,18 +1552,26 @@ closeBlock return (concat ds, map (\x -> (x, decoration syn x)) dns) +pCodegen :: IParser Codegen +pCodegen = try (do reserved "C"; return ViaC) + <|> try (do reserved "Java"; return ViaJava) + <|> try (do reserved "JavaScript"; return ViaJavaScript) + <|> try (do reserved "Node"; return ViaNode) + <|> try (do reserved "LLVM"; return ViaLLVM) + <|> try (do reserved "Bytecode"; return Bytecode) + pDirective :: SyntaxInfo -> IParser [PDecl] -pDirective syn = try (do lchar '%'; reserved "lib"; lib <- strlit; - return [PDirective (do addLib lib - addIBC (IBCLib lib))]) - <|> try (do lchar '%'; reserved "link"; obj <- strlit; +pDirective syn = try (do lchar '%'; reserved "lib"; cgn <- pCodegen; lib <- strlit; + return [PDirective (do addLib cgn lib + addIBC (IBCLib cgn lib))]) + <|> try (do lchar '%'; reserved "link"; cgn <- pCodegen; obj <- strlit; return [PDirective (do datadir <- liftIO getDataDir o <- liftIO $ findInPath [".", datadir] obj - addIBC (IBCObj o) - addObjectFile o)]) - <|> try (do lchar '%'; reserved "include"; hdr <- strlit; - return [PDirective (do addHdr hdr - addIBC (IBCHeader hdr))]) + addIBC (IBCObj cgn o) + addObjectFile cgn o)]) + <|> try (do lchar '%'; reserved "include"; cgn <- pCodegen; hdr <- strlit; + return [PDirective (do addHdr cgn hdr + addIBC (IBCHeader cgn hdr))]) <|> try (do lchar '%'; reserved "hide"; n <- iName [] return [PDirective (do setAccessibility n Hidden addIBC (IBCAccess n Hidden))]) @@ -1545,6 +1605,18 @@ e <- pExpr syn return [PProvider syn fc n t e] +pTransform :: SyntaxInfo -> IParser [PDecl] +pTransform syn = do lchar '%'; reserved "transform"; + -- leave it unchecked, until we work out what this should + -- actually mean... +-- safety <- option True (do reserved "unsafe" +-- return False) + lhs <- pExpr syn + fc <- pfc + symbol "==>" + rhs <- pExpr syn + return [PTransform fc False lhs rhs] + pTactic :: SyntaxInfo -> IParser PTactic pTactic syn = do reserved "intro"; ns <- sepBy pName (lchar ',') return $ Intro ns @@ -1555,9 +1627,15 @@ <|> do reserved "refine"; n <- pName i <- getState return $ Refine n [] + <|> do reserved "mrefine"; n <- pName + i <- getState + return $ MatchRefine n <|> do reserved "rewrite"; t <- pExpr syn; i <- getState return $ Rewrite (desugar syn i t) + <|> do reserved "equiv"; t <- pExpr syn; + i <- getState + return $ Equiv (desugar syn i t) <|> try (do reserved "let"; n <- pName; lchar ':'; ty <- pExpr' syn; lchar '='; t <- pExpr syn; i <- getState diff --git a/src/Idris/PartialEval.hs b/src/Idris/PartialEval.hs new file mode 100644 --- /dev/null +++ b/src/Idris/PartialEval.hs @@ -0,0 +1,20 @@ +module Idris.PartialEval(partial_eval) where + +import Idris.AbsSyntax + +import Core.TT +import Core.Evaluate + +import Debug.Trace + +partial_eval :: Context -> [(Name, Maybe Int)] -> + [Either Term (Term, Term)] -> + [Either Term (Term, Term)] +partial_eval ctxt ns tms = map peClause tms where + peClause (Left t) = Left t + peClause (Right (lhs, rhs)) + = let rhs' = specialise ctxt [] (map toLimit ns) rhs in + Right (lhs, rhs') + + toLimit (n, Nothing) = (n, 65536) -- somewhat arbitrary reduction limit + toLimit (n, Just l) = (n, l) diff --git a/src/Idris/Primitives.hs b/src/Idris/Primitives.hs --- a/src/Idris/Primitives.hs +++ b/src/Idris/Primitives.hs @@ -1,9 +1,7 @@ {-# LANGUAGE RankNTypes, ScopedTypeVariables, PatternGuards #-} -module Idris.Primitives(elabPrims) where +module Idris.Primitives(primitives, Prim(..)) where -import Idris.ElabDecls -import Idris.ElabTerm import Idris.AbsSyntax import IRTS.Lang @@ -13,160 +11,154 @@ import Data.Bits import Data.Word import Data.Int +import Data.Char +import Data.Vector.Unboxed (Vector) +import qualified Data.Vector.Unboxed as V data Prim = Prim { p_name :: Name, p_type :: Type, p_arity :: Int, - p_def :: [Value] -> Maybe Value, + p_def :: [Const] -> Maybe Const, p_lexp :: (Int, PrimFn), p_total :: Totality } +ty :: [Const] -> Const -> Type ty [] x = Constant x ty (t:ts) x = Bind (MN 0 "T") (Pi (Constant t)) (ty ts x) -believeTy = Bind (UN "a") (Pi (TType (UVar (-2)))) - (Bind (UN "b") (Pi (TType (UVar (-2)))) - (Bind (UN "x") (Pi (V 1)) (V 1))) - +total, partial :: Totality total = Total [] -partial = Partial NotCovering +partial = Partial NotCovering +primitives :: [Prim] primitives = -- operators - [Prim (UN "prim__eqChar") (ty [ChType, ChType] IType) 2 (bcBin (==)) - (2, LEq ITNative) total, - Prim (UN "prim__ltChar") (ty [ChType, ChType] IType) 2 (bcBin (<)) - (2, LLt ITNative) total, - Prim (UN "prim__lteChar") (ty [ChType, ChType] IType) 2 (bcBin (<=)) - (2, LLe ITNative) total, - Prim (UN "prim__gtChar") (ty [ChType, ChType] IType) 2 (bcBin (>)) - (2, LGt ITNative) total, - Prim (UN "prim__gteChar") (ty [ChType, ChType] IType) 2 (bcBin (>=)) - (2, LGe ITNative) total, - - iCoerce IT8 IT16 "zext" zext LZExt, - iCoerce IT8 IT32 "zext" zext LZExt, - iCoerce IT8 IT64 "zext" zext LZExt, - iCoerce IT8 ITBig "zext" zext LZExt, - iCoerce IT8 ITNative "zext" zext LZExt, - iCoerce IT16 IT32 "zext" zext LZExt, - iCoerce IT16 IT64 "zext" zext LZExt, - iCoerce IT16 ITBig "zext" zext LZExt, - iCoerce IT16 ITNative "zext" zext LZExt, - iCoerce IT32 IT64 "zext" zext LZExt, - iCoerce IT32 ITBig "zext" zext LZExt, - iCoerce IT32 ITNative "zext" zext LZExt, - iCoerce IT64 ITBig "zext" zext LZExt, + [iCoerce (ITFixed IT8) (ITFixed IT16) "zext" zext LZExt, + iCoerce (ITFixed IT8) (ITFixed IT32) "zext" zext LZExt, + iCoerce (ITFixed IT8) (ITFixed IT64) "zext" zext LZExt, + iCoerce (ITFixed IT8) ITBig "zext" zext LZExt, + iCoerce (ITFixed IT8) ITNative "zext" zext LZExt, + iCoerce (ITFixed IT16) (ITFixed IT32) "zext" zext LZExt, + iCoerce (ITFixed IT16) (ITFixed IT64) "zext" zext LZExt, + iCoerce (ITFixed IT16) ITBig "zext" zext LZExt, + iCoerce (ITFixed IT16) ITNative "zext" zext LZExt, + iCoerce (ITFixed IT32) (ITFixed IT64) "zext" zext LZExt, + iCoerce (ITFixed IT32) ITBig "zext" zext LZExt, + iCoerce (ITFixed IT32) ITNative "zext" zext LZExt, + iCoerce (ITFixed IT64) ITBig "zext" zext LZExt, iCoerce ITNative ITBig "zext" zext LZExt, - iCoerce ITNative IT64 "zext" zext LZExt, - iCoerce ITNative IT32 "zext" zext LZExt, - iCoerce ITNative IT16 "zext" zext LZExt, + iCoerce ITNative (ITFixed IT64) "zext" zext LZExt, + iCoerce ITNative (ITFixed IT32) "zext" zext LZExt, + iCoerce ITNative (ITFixed IT16) "zext" zext LZExt, + iCoerce ITChar ITBig "zext" zext LZExt, - iCoerce IT8 IT16 "sext" sext LSExt, - iCoerce IT8 IT32 "sext" sext LSExt, - iCoerce IT8 IT64 "sext" sext LSExt, - iCoerce IT8 ITBig "sext" sext LSExt, - iCoerce IT8 ITNative "sext" sext LSExt, - iCoerce IT16 IT32 "sext" sext LSExt, - iCoerce IT16 IT64 "sext" sext LSExt, - iCoerce IT16 ITBig "sext" sext LSExt, - iCoerce IT16 ITNative "sext" sext LSExt, - iCoerce IT32 IT64 "sext" sext LSExt, - iCoerce IT32 ITBig "sext" sext LSExt, - iCoerce IT32 ITNative "sext" sext LSExt, - iCoerce IT64 ITBig "sext" sext LSExt, + iCoerce (ITFixed IT8) (ITFixed IT16) "sext" sext LSExt, + iCoerce (ITFixed IT8) (ITFixed IT32) "sext" sext LSExt, + iCoerce (ITFixed IT8) (ITFixed IT64) "sext" sext LSExt, + iCoerce (ITFixed IT8) ITBig "sext" sext LSExt, + iCoerce (ITFixed IT8) ITNative "sext" sext LSExt, + iCoerce (ITFixed IT16) (ITFixed IT32) "sext" sext LSExt, + iCoerce (ITFixed IT16) (ITFixed IT64) "sext" sext LSExt, + iCoerce (ITFixed IT16) ITBig "sext" sext LSExt, + iCoerce (ITFixed IT16) ITNative "sext" sext LSExt, + iCoerce (ITFixed IT32) (ITFixed IT64) "sext" sext LSExt, + iCoerce (ITFixed IT32) ITBig "sext" sext LSExt, + iCoerce (ITFixed IT32) ITNative "sext" sext LSExt, + iCoerce (ITFixed IT64) ITBig "sext" sext LSExt, iCoerce ITNative ITBig "sext" sext LSExt, iCoerce ITNative ITBig "sext" sext LSExt, - iCoerce ITNative IT64 "sext" sext LSExt, - iCoerce ITNative IT32 "sext" sext LSExt, - iCoerce ITNative IT16 "sext" sext LSExt, + iCoerce ITNative (ITFixed IT64) "sext" sext LSExt, + iCoerce ITNative (ITFixed IT32) "sext" sext LSExt, + iCoerce ITNative (ITFixed IT16) "sext" sext LSExt, + iCoerce ITChar ITBig "sext" sext LSExt, - iCoerce IT16 IT8 "trunc" trunc LTrunc, - iCoerce IT32 IT8 "trunc" trunc LTrunc, - iCoerce IT64 IT8 "trunc" trunc LTrunc, - iCoerce ITBig IT8 "trunc" trunc LTrunc, - iCoerce ITNative IT8 "trunc" trunc LTrunc, - iCoerce IT32 IT16 "trunc" trunc LTrunc, - iCoerce IT64 IT16 "trunc" trunc LTrunc, - iCoerce ITBig IT16 "trunc" trunc LTrunc, - iCoerce ITNative IT16 "trunc" trunc LTrunc, - iCoerce IT64 IT32 "trunc" trunc LTrunc, - iCoerce ITBig IT32 "trunc" trunc LTrunc, - iCoerce ITNative IT32 "trunc" trunc LTrunc, - iCoerce ITBig IT64 "trunc" trunc LTrunc, - iCoerce IT16 ITNative "trunc" trunc LTrunc, - iCoerce IT32 ITNative "trunc" trunc LTrunc, - iCoerce IT64 ITNative "trunc" trunc LTrunc, + iCoerce (ITFixed IT16) (ITFixed IT8) "trunc" trunc LTrunc, + iCoerce (ITFixed IT32) (ITFixed IT8) "trunc" trunc LTrunc, + iCoerce (ITFixed IT64) (ITFixed IT8) "trunc" trunc LTrunc, + iCoerce ITBig (ITFixed IT8) "trunc" trunc LTrunc, + iCoerce ITNative (ITFixed IT8) "trunc" trunc LTrunc, + iCoerce (ITFixed IT32) (ITFixed IT16) "trunc" trunc LTrunc, + iCoerce (ITFixed IT64) (ITFixed IT16) "trunc" trunc LTrunc, + iCoerce ITBig (ITFixed IT16) "trunc" trunc LTrunc, + iCoerce ITNative (ITFixed IT16) "trunc" trunc LTrunc, + iCoerce (ITFixed IT64) (ITFixed IT32) "trunc" trunc LTrunc, + iCoerce ITBig (ITFixed IT32) "trunc" trunc LTrunc, + iCoerce ITNative (ITFixed IT32) "trunc" trunc LTrunc, + iCoerce ITBig (ITFixed IT64) "trunc" trunc LTrunc, + iCoerce (ITFixed IT16) ITNative "trunc" trunc LTrunc, + iCoerce (ITFixed IT32) ITNative "trunc" trunc LTrunc, + iCoerce (ITFixed IT64) ITNative "trunc" trunc LTrunc, iCoerce ITBig ITNative "trunc" trunc LTrunc, - iCoerce ITNative IT64 "trunc" trunc LTrunc, + iCoerce ITNative (ITFixed IT64) "trunc" trunc LTrunc, + iCoerce ITBig ITChar "trunc" trunc LTrunc, - Prim (UN "prim__addFloat") (ty [FlType, FlType] FlType) 2 (fBin (+)) - (2, LFPlus) total, - Prim (UN "prim__subFloat") (ty [FlType, FlType] FlType) 2 (fBin (-)) - (2, LFMinus) total, - Prim (UN "prim__mulFloat") (ty [FlType, FlType] FlType) 2 (fBin (*)) - (2, LFTimes) total, - Prim (UN "prim__divFloat") (ty [FlType, FlType] FlType) 2 (fBin (/)) - (2, LFDiv) total, - Prim (UN "prim__eqFloat") (ty [FlType, FlType] IType) 2 (bfBin (==)) - (2, LFEq) total, - Prim (UN "prim__ltFloat") (ty [FlType, FlType] IType) 2 (bfBin (<)) - (2, LFLt) total, - Prim (UN "prim__lteFloat") (ty [FlType, FlType] IType) 2 (bfBin (<=)) - (2, LFLe) total, - Prim (UN "prim__gtFloat") (ty [FlType, FlType] IType) 2 (bfBin (>)) - (2, LFGt) total, - Prim (UN "prim__gteFloat") (ty [FlType, FlType] IType) 2 (bfBin (>=)) - (2, LFGe) total, + Prim (UN "prim__addFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (+)) + (2, LPlus ATFloat) total, + Prim (UN "prim__subFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (-)) + (2, LMinus ATFloat) total, + Prim (UN "prim__mulFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (*)) + (2, LTimes ATFloat) total, + Prim (UN "prim__divFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (/)) + (2, LSDiv ATFloat) total, + Prim (UN "prim__eqFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (==)) + (2, LEq ATFloat) total, + Prim (UN "prim__ltFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<)) + (2, LLt ATFloat) total, + Prim (UN "prim__lteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<=)) + (2, LLe ATFloat) total, + Prim (UN "prim__gtFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>)) + (2, LGt ATFloat) total, + Prim (UN "prim__gteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>=)) + (2, LGe ATFloat) total, Prim (UN "prim__concat") (ty [StrType, StrType] StrType) 2 (sBin (++)) (2, LStrConcat) total, - Prim (UN "prim__eqString") (ty [StrType, StrType] IType) 2 (bsBin (==)) + Prim (UN "prim__eqString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (==)) (2, LStrEq) total, - Prim (UN "prim__ltString") (ty [StrType, StrType] IType) 2 (bsBin (<)) + Prim (UN "prim__ltString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (<)) (2, LStrLt) total, - Prim (UN "prim_lenString") (ty [StrType] IType) 1 (p_strLen) + Prim (UN "prim_lenString") (ty [StrType] (AType (ATInt ITNative))) 1 (p_strLen) (1, LStrLen) total, -- Conversions - Prim (UN "prim__charToInt") (ty [ChType] IType) 1 (c_charToInt) + Prim (UN "prim__charToInt") (ty [(AType (ATInt ITChar))] (AType (ATInt ITNative))) 1 (c_charToInt) (1, LChInt ITNative) total, - Prim (UN "prim__intToChar") (ty [IType] ChType) 1 (c_intToChar) + Prim (UN "prim__intToChar") (ty [(AType (ATInt ITNative))] (AType (ATInt ITChar))) 1 (c_intToChar) (1, LIntCh ITNative) total, - Prim (UN "prim__strToFloat") (ty [StrType] FlType) 1 (c_strToFloat) + Prim (UN "prim__strToFloat") (ty [StrType] (AType ATFloat)) 1 (c_strToFloat) (1, LStrFloat) total, - Prim (UN "prim__floatToStr") (ty [FlType] StrType) 1 (c_floatToStr) + Prim (UN "prim__floatToStr") (ty [(AType ATFloat)] StrType) 1 (c_floatToStr) (1, LFloatStr) total, - Prim (UN "prim__floatExp") (ty [FlType] FlType) 1 (p_floatExp) + Prim (UN "prim__floatExp") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatExp) (1, LFExp) total, - Prim (UN "prim__floatLog") (ty [FlType] FlType) 1 (p_floatLog) + Prim (UN "prim__floatLog") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatLog) (1, LFLog) total, - Prim (UN "prim__floatSin") (ty [FlType] FlType) 1 (p_floatSin) + Prim (UN "prim__floatSin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSin) (1, LFSin) total, - Prim (UN "prim__floatCos") (ty [FlType] FlType) 1 (p_floatCos) + Prim (UN "prim__floatCos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCos) (1, LFCos) total, - Prim (UN "prim__floatTan") (ty [FlType] FlType) 1 (p_floatTan) + Prim (UN "prim__floatTan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatTan) (1, LFTan) total, - Prim (UN "prim__floatASin") (ty [FlType] FlType) 1 (p_floatASin) + Prim (UN "prim__floatASin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatASin) (1, LFASin) total, - Prim (UN "prim__floatACos") (ty [FlType] FlType) 1 (p_floatACos) + Prim (UN "prim__floatACos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatACos) (1, LFACos) total, - Prim (UN "prim__floatATan") (ty [FlType] FlType) 1 (p_floatATan) + Prim (UN "prim__floatATan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatATan) (1, LFATan) total, - Prim (UN "prim__floatSqrt") (ty [FlType] FlType) 1 (p_floatSqrt) + Prim (UN "prim__floatSqrt") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSqrt) (1, LFSqrt) total, - Prim (UN "prim__floatFloor") (ty [FlType] FlType) 1 (p_floatFloor) + Prim (UN "prim__floatFloor") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatFloor) (1, LFFloor) total, - Prim (UN "prim__floatCeil") (ty [FlType] FlType) 1 (p_floatCeil) + Prim (UN "prim__floatCeil") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCeil) (1, LFCeil) total, - Prim (UN "prim__strHead") (ty [StrType] ChType) 1 (p_strHead) + Prim (UN "prim__strHead") (ty [StrType] (AType (ATInt ITChar))) 1 (p_strHead) (1, LStrHead) partial, Prim (UN "prim__strTail") (ty [StrType] StrType) 1 (p_strTail) (1, LStrTail) partial, - Prim (UN "prim__strCons") (ty [ChType, StrType] StrType) 2 (p_strCons) + Prim (UN "prim__strCons") (ty [(AType (ATInt ITChar)), StrType] StrType) 2 (p_strCons) (2, LStrCons) total, - Prim (UN "prim__strIndex") (ty [StrType, IType] ChType) 2 (p_strIndex) + Prim (UN "prim__strIndex") (ty [StrType, (AType (ATInt ITNative))] (AType (ATInt ITChar))) 2 (p_strIndex) (2, LStrIndex) partial, Prim (UN "prim__strRev") (ty [StrType] StrType) 1 (p_strRev) (1, LStrRev) total, @@ -176,24 +168,35 @@ (0, LVMPtr) total, -- Streams Prim (UN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce) - (0, LStdIn) partial, - Prim (UN "prim__believe_me") believeTy 3 (p_believeMe) - (3, LNoOp) partial -- ahem - ] ++ concatMap intOps [IT8, IT16, IT32, IT64, ITBig, ITNative] + (0, LStdIn) partial + ] ++ concatMap intOps [ITFixed IT8, ITFixed IT16, ITFixed IT32, ITFixed IT64, ITBig, ITNative, ITChar] + ++ concatMap vecOps vecTypes + ++ vecBitcasts vecTypes -intOps ity = - [ iCmp ity "lt" (bCmp ity (<)) LLt total - , iCmp ity "lte" (bCmp ity (<=)) LLe total - , iCmp ity "eq" (bCmp ity (==)) LEq total - , iCmp ity "gte" (bCmp ity (>=)) LGe total - , iCmp ity "gt" (bCmp ity (>)) LGt total - , iBinOp ity "add" (bitBin ity (+)) LPlus total - , iBinOp ity "sub" (bitBin ity (-)) LMinus total - , iBinOp ity "mul" (bitBin ity (*)) LTimes total +vecTypes :: [IntTy] +vecTypes = [ITVec IT8 16, ITVec IT16 8, ITVec IT32 4, ITVec IT64 2] + +intOps :: IntTy -> [Prim] +intOps ity = intCmps ity ++ intArith ity ++ intConv ity + +intCmps :: IntTy -> [Prim] +intCmps ity = + [ iCmp ity "lt" False (bCmp ity (<)) (LLt . ATInt) total + , iCmp ity "lte" False (bCmp ity (<=)) (LLe . ATInt) total + , iCmp ity "eq" False (bCmp ity (==)) (LEq . ATInt) total + , iCmp ity "gte" False (bCmp ity (>=)) (LGe . ATInt) total + , iCmp ity "gt" False (bCmp ity (>)) (LGt . ATInt) total + ] + +intArith :: IntTy -> [Prim] +intArith ity = + [ iBinOp ity "add" (bitBin ity (+)) (LPlus . ATInt) total + , iBinOp ity "sub" (bitBin ity (-)) (LMinus . ATInt) total + , iBinOp ity "mul" (bitBin ity (*)) (LTimes . ATInt) total , iBinOp ity "udiv" (bitBin ity div) LUDiv partial - , iBinOp ity "sdiv" (bsdiv ity) LSDiv partial + , iBinOp ity "sdiv" (bsdiv ity) (LSDiv . ATInt) partial , iBinOp ity "urem" (bitBin ity rem) LURem partial - , iBinOp ity "srem" (bsrem ity) LSRem partial + , iBinOp ity "srem" (bsrem ity) (LSRem . ATInt) partial , iBinOp ity "shl" (bitBin ity (\x y -> shiftL x (fromIntegral y))) LSHL total , iBinOp ity "lshr" (bitBin ity (\x y -> shiftR x (fromIntegral y))) LLSHR total , iBinOp ity "ashr" (bashr ity) LASHR total @@ -201,196 +204,419 @@ , iBinOp ity "or" (bitBin ity (.|.)) LOr total , iBinOp ity "xor" (bitBin ity (xor)) LXOr total , iUnOp ity "compl" (bUn ity complement) LCompl total - , Prim (UN $ "prim__toStr" ++ intTyName ity) (ty [intTyToConst ity] StrType) 1 intToStr + ] + +intConv :: IntTy -> [Prim] +intConv ity = + [ Prim (UN $ "prim__toStr" ++ intTyName ity) (ty [AType . ATInt $ ity] StrType) 1 intToStr (1, LIntStr ity) total - , Prim (UN $ "prim__fromStr" ++ intTyName ity) (ty [StrType] (intTyToConst ity)) 1 (strToInt ity) + , Prim (UN $ "prim__fromStr" ++ intTyName ity) (ty [StrType] (AType . ATInt $ ity)) 1 (strToInt ity) (1, LStrInt ity) total - , Prim (UN $ "prim__toFloat" ++ intTyName ity) (ty [intTyToConst ity] FlType) 1 intToFloat + , Prim (UN $ "prim__toFloat" ++ intTyName ity) (ty [AType . ATInt $ ity] (AType ATFloat)) 1 intToFloat (1, LIntFloat ity) total - , Prim (UN $ "prim__fromFloat" ++ intTyName ity) (ty [FlType] (intTyToConst ity)) 1 (floatToInt ity) + , Prim (UN $ "prim__fromFloat" ++ intTyName ity) (ty [AType ATFloat] (AType . ATInt $ ity)) 1 (floatToInt ity) (1, LFloatInt ity) total ] -intTyName :: IntTy -> String -intTyName ITNative = "Int" -intTyName ITBig = "BigInt" -intTyName sized = "B" ++ show (intTyWidth sized) +vecCmps :: IntTy -> [Prim] +vecCmps ity = + [ iCmp ity "lt" True (bCmp ity (<)) (LLt . ATInt) total + , iCmp ity "lte" True (bCmp ity (<=)) (LLe . ATInt) total + , iCmp ity "eq" True (bCmp ity (==)) (LEq . ATInt) total + , iCmp ity "gte" True (bCmp ity (>=)) (LGe . ATInt) total + , iCmp ity "gt" True (bCmp ity (>)) (LGt . ATInt) total + ] -iCmp ity op impl irop totality = Prim (UN $ "prim__" ++ op ++ intTyName ity) (ty (replicate 2 $ intTyToConst ity) IType) 2 impl (2, irop ity) totality -iBinOp ity op impl irop totality = Prim (UN $ "prim__" ++ op ++ intTyName ity) (ty (replicate 2 $ intTyToConst ity) (intTyToConst ity)) 2 impl (2, irop ity) totality -iUnOp ity op impl irop totality = Prim (UN $ "prim__" ++ op ++ intTyName ity) (ty [intTyToConst ity] (intTyToConst ity)) 1 impl (1, irop ity) totality -iCoerce from to op impl irop = - Prim (UN $ "prim__" ++ op ++ intTyName from ++ "_" ++ intTyName to) - (ty [intTyToConst from] (intTyToConst to)) 1 (impl from to) (1, irop from to) total +vecOps :: IntTy -> [Prim] +vecOps ity@(ITVec elem count) = + [ Prim (UN $ "prim__mk" ++ intTyName ity) + (ty (replicate count . AType . ATInt . ITFixed $ elem) (AType . ATInt $ ity)) + count (mkVecCon elem count) (count, LMkVec elem count) total + , Prim (UN $ "prim__index" ++ intTyName ity) + (ty [AType . ATInt $ ity, AType (ATInt (ITFixed IT32))] (AType . ATInt . ITFixed $ elem)) + 2 (mkVecIndex count) (2, LIdxVec elem count) partial -- TODO: Ensure this reduces + , Prim (UN $ "prim__update" ++ intTyName ity) + (ty [AType . ATInt $ ity, AType (ATInt (ITFixed IT32)), AType . ATInt . ITFixed $ elem] + (AType . ATInt $ ity)) + 3 (mkVecUpdate elem count) (3, LUpdateVec elem count) partial -- TODO: Ensure this reduces + ] ++ intArith ity ++ vecCmps ity -p_believeMe [_,_,x] = Just x -p_believeMe _ = Nothing +bitcastPrim :: ArithTy -> ArithTy -> (ArithTy -> [Const] -> Maybe Const) -> PrimFn -> Prim +bitcastPrim from to impl prim = + Prim (UN $ "prim__bitcast" ++ aTyName from ++ "_" ++ aTyName to) (ty [AType from] (AType to)) 1 (impl to) + (1, prim) total -iUn op [VConstant (I x)] = Just $ VConstant (I (op x)) -iUn _ _ = Nothing +vecBitcasts :: [IntTy] -> [Prim] +vecBitcasts tys = [bitcastPrim from to bitcastVec (LBitCast from to) + | from <- map ATInt vecTypes, to <- map ATInt vecTypes, from /= to] -iBin op [VConstant (I x), VConstant (I y)] = Just $ VConstant (I (op x y)) -iBin _ _ = Nothing +mapHalf :: (V.Unbox a, V.Unbox b) => ((a, a) -> b) -> Vector a -> Vector b +mapHalf f xs = V.generate (V.length xs `div` 2) (\i -> f (xs V.! (i*2), xs V.! (i*2+1))) -bBin op [VConstant (BI x), VConstant (BI y)] = Just $ VConstant (BI (op x y)) -bBin _ _ = Nothing +mapDouble :: (V.Unbox a, V.Unbox b) => (Bool -> a -> b) -> Vector a -> Vector b +mapDouble f xs = V.generate (V.length xs * 2) (\i -> f (i `rem` 2 == 0) (xs V.! (i `div` 2))) -bBini op [VConstant (BI x), VConstant (BI y)] = Just $ VConstant (I (op x y)) -bBini _ _ = Nothing +concatWord8 :: (Word8, Word8) -> Word16 +concatWord8 (high, low) = fromIntegral high .|. (fromIntegral low `shiftL` 8) -biBin op = iBin (\x y -> if (op x y) then 1 else 0) -bbBin op = bBini (\x y -> if (op x y) then 1 else 0) +concatWord16 :: (Word16, Word16) -> Word32 +concatWord16 (high, low) = fromIntegral high .|. (fromIntegral low `shiftL` 16) -fBin op [VConstant (Fl x), VConstant (Fl y)] = Just $ VConstant (Fl (op x y)) +concatWord32 :: (Word32, Word32) -> Word64 +concatWord32 (high, low) = fromIntegral high .|. (fromIntegral low `shiftL` 32) + +truncWord16 :: Bool -> Word16 -> Word8 +truncWord16 True x = fromIntegral (x `shiftR` 8) +truncWord16 False x = fromIntegral x + +truncWord32 :: Bool -> Word32 -> Word16 +truncWord32 True x = fromIntegral (x `shiftR` 16) +truncWord32 False x = fromIntegral x + +truncWord64 :: Bool -> Word64 -> Word32 +truncWord64 True x = fromIntegral (x `shiftR` 32) +truncWord64 False x = fromIntegral x + +bitcastVec :: ArithTy -> [Const] -> Maybe Const +bitcastVec (ATInt (ITVec IT8 n)) [x@(B8V v)] + | V.length v == n = Just x +bitcastVec (ATInt (ITVec IT16 n)) [B8V v] + | V.length v == n*2 = Just . B16V . mapHalf concatWord8 $ v +bitcastVec (ATInt (ITVec IT32 n)) [B8V v] + | V.length v == n*4 = Just . B32V . mapHalf concatWord16 . mapHalf concatWord8 $ v +bitcastVec (ATInt (ITVec IT64 n)) [B8V v] + | V.length v == n*8 = Just . B64V . mapHalf concatWord32 . mapHalf concatWord16 . mapHalf concatWord8 $ v + +bitcastVec (ATInt (ITVec IT8 n)) [B16V v] + | V.length v * 2 == n = Just . B8V . mapDouble truncWord16 $ v +bitcastVec (ATInt (ITVec IT16 n)) [x@(B16V v)] + | V.length v == n = Just x +bitcastVec (ATInt (ITVec IT32 n)) [B16V v] + | V.length v == n*2 = Just . B32V . mapHalf concatWord16 $ v +bitcastVec (ATInt (ITVec IT64 n)) [B16V v] + | V.length v == n*4 = Just . B64V . mapHalf concatWord32 . mapHalf concatWord16 $ v + +bitcastVec (ATInt (ITVec IT8 n)) [B32V v] + | V.length v * 4 == n = Just . B8V . mapDouble truncWord16 . mapDouble truncWord32 $ v +bitcastVec (ATInt (ITVec IT16 n)) [B32V v] + | V.length v * 2 == n = Just . B16V . mapDouble truncWord32 $ v +bitcastVec (ATInt (ITVec IT32 n)) [x@(B32V v)] + | V.length v == n = Just x +bitcastVec (ATInt (ITVec IT64 n)) [B32V v] + | V.length v == n*2 = Just . B64V . mapHalf concatWord32 $ v + +bitcastVec (ATInt (ITVec IT8 n)) [B64V v] + | V.length v * 8 == n = Just . B8V . mapDouble truncWord16 . mapDouble truncWord32 . mapDouble truncWord64 $ v +bitcastVec (ATInt (ITVec IT16 n)) [B64V v] + | V.length v * 4 == n = Just . B16V . mapDouble truncWord32 . mapDouble truncWord64 $ v +bitcastVec (ATInt (ITVec IT32 n)) [B64V v] + | V.length v == n*2 = Just . B32V . mapDouble truncWord64 $ v +bitcastVec (ATInt (ITVec IT64 n)) [x@(B64V v)] + | V.length v == n = Just x + +bitcastVec _ _ = Nothing + +mkVecCon :: NativeTy -> Int -> [Const] -> Maybe Const +mkVecCon ity count args + | length ints == count = Just (mkVec ity count ints) + | otherwise = Nothing + where + ints = getInt args + mkVec :: NativeTy -> Int -> [Integer] -> Const + mkVec IT8 len values = B8V $ V.generate len (fromInteger . (values !!)) + mkVec IT16 len values = B16V $ V.generate len (fromInteger . (values !!)) + mkVec IT32 len values = B32V $ V.generate len (fromInteger . (values !!)) + mkVec IT64 len values = B64V $ V.generate len (fromInteger . (values !!)) + +mkVecIndex count [vec, B32 i] = Just (idxVec vec) + where + idxVec :: Const -> Const + idxVec (B8V v) = B8 $ V.unsafeIndex v (fromIntegral i) + idxVec (B16V v) = B16 $ V.unsafeIndex v (fromIntegral i) + idxVec (B32V v) = B32 $ V.unsafeIndex v (fromIntegral i) + idxVec (B64V v) = B64 $ V.unsafeIndex v (fromIntegral i) +mkVecIndex _ _ = Nothing + +mkVecUpdate ity count [vec, B32 i, newElem] = updateVec vec newElem + where + updateVec :: Const -> Const -> Maybe Const + updateVec (B8V v) (B8 e) = Just . B8V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e)) + updateVec (B16V v) (B16 e) = Just . B16V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e)) + updateVec (B32V v) (B32 e) = Just . B32V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e)) + updateVec (B64V v) (B64 e) = Just . B64V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e)) + updateVec _ _ = Nothing +mkVecUpdate _ _ _ = Nothing + +aTyName :: ArithTy -> String +aTyName (ATInt t) = intTyName t +aTyName ATFloat = "Float" + +intTyName :: IntTy -> String +intTyName ITNative = "Int" +intTyName ITBig = "BigInt" +intTyName (ITFixed sized) = "B" ++ show (nativeTyWidth sized) +intTyName (ITChar) = "Char" +intTyName (ITVec ity count) = "B" ++ show (nativeTyWidth ity) ++ "x" ++ show count + +iCmp :: IntTy -> String -> Bool -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim +iCmp ity op self impl irop totality + = Prim (UN $ "prim__" ++ op ++ intTyName ity) + (ty (replicate 2 . AType . ATInt $ ity) (AType (ATInt (if self then ity else ITNative)))) + 2 impl (2, irop ity) totality + +iBinOp, iUnOp :: IntTy -> String -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim +iBinOp ity op impl irop totality + = Prim (UN $ "prim__" ++ op ++ intTyName ity) + (ty (replicate 2 . AType . ATInt $ ity) (AType . ATInt $ ity)) + 2 impl (2, irop ity) totality +iUnOp ity op impl irop totality + = Prim (UN $ "prim__" ++ op ++ intTyName ity) + (ty [AType . ATInt $ ity] (AType . ATInt $ ity)) + 1 impl (1, irop ity) totality + +iCoerce :: IntTy -> IntTy -> String -> (IntTy -> IntTy -> [Const] -> Maybe Const) -> (IntTy -> IntTy -> PrimFn) -> Prim +iCoerce from to op impl irop = + Prim (UN $ "prim__" ++ op ++ intTyName from ++ "_" ++ intTyName to) + (ty [AType . ATInt $ from] (AType . ATInt $ to)) 1 (impl from to) (1, irop from to) total + +fBin :: (Double -> Double -> Double) -> [Const] -> Maybe Const +fBin op [Fl x, Fl y] = Just $ Fl (op x y) fBin _ _ = Nothing -bfBin op [VConstant (Fl x), VConstant (Fl y)] = let i = (if op x y then 1 else 0) in - Just $ VConstant (I i) +bfBin :: (Double -> Double -> Bool) -> [Const] -> Maybe Const +bfBin op [Fl x, Fl y] = let i = (if op x y then 1 else 0) in + Just $ I i bfBin _ _ = Nothing -bcBin op [VConstant (Ch x), VConstant (Ch y)] = let i = (if op x y then 1 else 0) in - Just $ VConstant (I i) +bcBin :: (Char -> Char -> Bool) -> [Const] -> Maybe Const +bcBin op [Ch x, Ch y] = let i = (if op x y then 1 else 0) in + Just $ I i bcBin _ _ = Nothing -bsBin op [VConstant (Str x), VConstant (Str y)] +bsBin :: (String -> String -> Bool) -> [Const] -> Maybe Const +bsBin op [Str x, Str y] = let i = (if op x y then 1 else 0) in - Just $ VConstant (I i) + Just $ I i bsBin _ _ = Nothing -sBin op [VConstant (Str x), VConstant (Str y)] = Just $ VConstant (Str (op x y)) +sBin :: (String -> String -> String) -> [Const] -> Maybe Const +sBin op [Str x, Str y] = Just $ Str (op x y) sBin _ _ = Nothing -bsrem IT8 [VConstant (B8 x), VConstant (B8 y)] - = Just $ VConstant (B8 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int8))) -bsrem IT16 [VConstant (B16 x), VConstant (B16 y)] - = Just $ VConstant (B16 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int16))) -bsrem IT32 [VConstant (B32 x), VConstant (B32 y)] - = Just $ VConstant (B32 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int32))) -bsrem IT64 [VConstant (B64 x), VConstant (B64 y)] - = Just $ VConstant (B64 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int64))) -bsrem ITNative [VConstant (I x), VConstant (I y)] = Just $ VConstant (I (x `rem` y)) +bsrem :: IntTy -> [Const] -> Maybe Const +bsrem ITBig [BI x, BI y] = Just . BI $ x `rem` y +bsrem (ITFixed IT8) [B8 x, B8 y] + = Just $ B8 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int8)) +bsrem (ITFixed IT16) [B16 x, B16 y] + = Just $ B16 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int16)) +bsrem (ITFixed IT32) [B32 x, B32 y] + = Just $ B32 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int32)) +bsrem (ITFixed IT64) [B64 x, B64 y] + = Just $ B64 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int64)) +bsrem ITNative [I x, I y] = Just $ I (x `rem` y) +bsrem ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `rem` (ord y)) +bsrem (ITVec IT8 _) [B8V x, B8V y] + = Just . B8V $ + V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int8))) x y +bsrem (ITVec IT16 _) [B16V x, B16V y] + = Just . B16V $ + V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int16))) x y +bsrem (ITVec IT32 _) [B32V x, B32V y] + = Just . B32V $ + V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int64))) x y +bsrem (ITVec IT64 _) [B64V x, B64V y] + = Just . B64V $ + V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int64))) x y bsrem _ _ = Nothing -bsdiv IT8 [VConstant (B8 x), VConstant (B8 y)] - = Just $ VConstant (B8 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int8))) -bsdiv IT16 [VConstant (B16 x), VConstant (B16 y)] - = Just $ VConstant (B16 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int16))) -bsdiv IT32 [VConstant (B32 x), VConstant (B32 y)] - = Just $ VConstant (B32 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int32))) -bsdiv IT64 [VConstant (B64 x), VConstant (B64 y)] - = Just $ VConstant (B64 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int64))) -bsdiv ITNative [VConstant (I x), VConstant (I y)] = Just $ VConstant (I (x `div` y)) +bsdiv :: IntTy -> [Const] -> Maybe Const +bsdiv ITBig [BI x, BI y] = Just . BI $ x `div` y +bsdiv (ITFixed IT8) [B8 x, B8 y] + = Just $ B8 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int8)) +bsdiv (ITFixed IT16) [B16 x, B16 y] + = Just $ B16 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int16)) +bsdiv (ITFixed IT32) [B32 x, B32 y] + = Just $ B32 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int32)) +bsdiv (ITFixed IT64) [B64 x, B64 y] + = Just $ B64 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int64)) +bsdiv ITNative [I x, I y] = Just $ I (x `div` y) +bsdiv ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `div` (ord y)) +bsdiv (ITVec IT8 _) [B8V x, B8V y] + = Just . B8V $ + V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int8))) x y +bsdiv (ITVec IT16 _) [B16V x, B16V y] + = Just . B16V $ + V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int16))) x y +bsdiv (ITVec IT32 _) [B32V x, B32V y] + = Just . B32V $ + V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int64))) x y +bsdiv (ITVec IT64 _) [B64V x, B64V y] + = Just . B64V $ + V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int64))) x y bsdiv _ _ = Nothing -bashr IT8 [VConstant (B8 x), VConstant (B8 y)] - = Just $ VConstant (B8 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int8))) -bashr IT16 [VConstant (B16 x), VConstant (B16 y)] - = Just $ VConstant (B16 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int16))) -bashr IT32 [VConstant (B32 x), VConstant (B32 y)] - = Just $ VConstant (B32 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int32))) -bashr IT64 [VConstant (B64 x), VConstant (B64 y)] - = Just $ VConstant (B64 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int64))) -bashr ITNative [VConstant (I x), VConstant (I y)] = Just $ VConstant (I (x `shiftR` y)) +bashr :: IntTy -> [Const] -> Maybe Const +bashr ITBig [BI x, BI y] = Just $ BI (x `shiftR` fromIntegral y) +bashr (ITFixed IT8) [B8 x, B8 y] + = Just $ B8 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int8)) +bashr (ITFixed IT16) [B16 x, B16 y] + = Just $ B16 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int16)) +bashr (ITFixed IT32) [B32 x, B32 y] + = Just $ B32 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int32)) +bashr (ITFixed IT64) [B64 x, B64 y] + = Just $ B64 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int64)) +bashr ITNative [I x, I y] = Just $ I (x `shiftR` y) +bashr ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `shiftR` (ord y)) +bashr (ITVec IT8 _) [B8V x, B8V y] + = Just . B8V $ + V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int8))) x y +bashr (ITVec IT16 _) [B16V x, B16V y] + = Just . B16V $ + V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int16))) x y +bashr (ITVec IT32 _) [B32V x, B32V y] + = Just . B32V $ + V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int64))) x y +bashr (ITVec IT64 _) [B64V x, B64V y] + = Just . B64V $ + V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int64))) x y bashr _ _ = Nothing -bUn :: IntTy -> (forall a. Bits a => a -> a) -> [Value] -> Maybe Value -bUn IT8 op [VConstant (B8 x)] = Just $ VConstant (B8 (op x)) -bUn IT16 op [VConstant (B16 x)] = Just $ VConstant (B16 (op x)) -bUn IT32 op [VConstant (B32 x)] = Just $ VConstant (B32 (op x)) -bUn IT64 op [VConstant (B64 x)] = Just $ VConstant (B64 (op x)) -bUn ITBig op [VConstant (BI x)] = Just $ VConstant (BI (op x)) -bUn ITNative op [VConstant (I x)] = Just $ VConstant (I (op x)) -bUn _ _ _ = Nothing +bUn :: IntTy -> (forall a. Bits a => a -> a) -> [Const] -> Maybe Const +bUn (ITFixed IT8) op [B8 x] = Just $ B8 (op x) +bUn (ITFixed IT16) op [B16 x] = Just $ B16 (op x) +bUn (ITFixed IT32) op [B32 x] = Just $ B32 (op x) +bUn (ITFixed IT64) op [B64 x] = Just $ B64 (op x) +bUn ITBig op [BI x] = Just $ BI (op x) +bUn ITNative op [I x] = Just $ I (op x) +bUn ITChar op [Ch x] = Just $ Ch (chr $ op (ord x)) +bUn (ITVec IT8 _) op [B8V x] = Just . B8V $ V.map op x +bUn (ITVec IT16 _) op [B16V x] = Just . B16V $ V.map op x +bUn (ITVec IT32 _) op [B32V x] = Just . B32V $ V.map op x +bUn (ITVec IT64 _) op [B64V x] = Just . B64V $ V.map op x +bUn _ _ _ = Nothing -bitBin :: IntTy -> (forall a. (Bits a, Integral a) => a -> a -> a) -> [Value] -> Maybe Value -bitBin IT8 op [VConstant (B8 x), VConstant (B8 y)] = Just $ VConstant (B8 (op x y)) -bitBin IT16 op [VConstant (B16 x), VConstant (B16 y)] = Just $ VConstant (B16 (op x y)) -bitBin IT32 op [VConstant (B32 x), VConstant (B32 y)] = Just $ VConstant (B32 (op x y)) -bitBin IT64 op [VConstant (B64 x), VConstant (B64 y)] = Just $ VConstant (B64 (op x y)) -bitBin ITBig op [VConstant (BI x), VConstant (BI y)] = Just $ VConstant (BI (op x y)) -bitBin ITNative op [VConstant (I x), VConstant (I y)] = Just $ VConstant (I (op x y)) -bitBin _ _ _ = Nothing +bitBin :: IntTy -> (forall a. (Bits a, Integral a) => a -> a -> a) -> [Const] -> Maybe Const +bitBin (ITFixed IT8) op [B8 x, B8 y] = Just $ B8 (op x y) +bitBin (ITFixed IT16) op [B16 x, B16 y] = Just $ B16 (op x y) +bitBin (ITFixed IT32) op [B32 x, B32 y] = Just $ B32 (op x y) +bitBin (ITFixed IT64) op [B64 x, B64 y] = Just $ B64 (op x y) +bitBin ITBig op [BI x, BI y] = Just $ BI (op x y) +bitBin ITNative op [I x, I y] = Just $ I (op x y) +bitBin ITChar op [Ch x, Ch y] = Just $ Ch (chr $ op (ord x) (ord y)) +bitBin (ITVec IT8 _) op [B8V x, B8V y] = Just . B8V $ V.zipWith op x y +bitBin (ITVec IT16 _) op [B16V x, B16V y] = Just . B16V $ V.zipWith op x y +bitBin (ITVec IT32 _) op [B32V x, B32V y] = Just . B32V $ V.zipWith op x y +bitBin (ITVec IT64 _) op [B64V x, B64V y] = Just . B64V $ V.zipWith op x y +bitBin _ _ _ = Nothing -bCmp :: IntTy -> (forall a. Ord a => a -> a -> Bool) -> [Value] -> Maybe Value -bCmp IT8 op [VConstant (B8 x), VConstant (B8 y)] = Just $ VConstant (I (if (op x y) then 1 else 0)) -bCmp IT16 op [VConstant (B16 x), VConstant (B16 y)] = Just $ VConstant (I (if (op x y) then 1 else 0)) -bCmp IT32 op [VConstant (B32 x), VConstant (B32 y)] = Just $ VConstant (I (if (op x y) then 1 else 0)) -bCmp IT64 op [VConstant (B64 x), VConstant (B64 y)] = Just $ VConstant (I (if (op x y) then 1 else 0)) -bCmp ITBig op [VConstant (BI x), VConstant (BI y)] = Just $ VConstant (I (if (op x y) then 1 else 0)) -bCmp ITNative op [VConstant (I x), VConstant (I y)] = Just $ VConstant (I (if (op x y) then 1 else 0)) -bCmp _ _ _ = Nothing +bCmp :: IntTy -> (forall a. Ord a => a -> a -> Bool) -> [Const] -> Maybe Const +bCmp (ITFixed IT8) op [B8 x, B8 y] = Just $ I (if (op x y) then 1 else 0) +bCmp (ITFixed IT16) op [B16 x, B16 y] = Just $ I (if (op x y) then 1 else 0) +bCmp (ITFixed IT32) op [B32 x, B32 y] = Just $ I (if (op x y) then 1 else 0) +bCmp (ITFixed IT64) op [B64 x, B64 y] = Just $ I (if (op x y) then 1 else 0) +bCmp ITBig op [BI x, BI y] = Just $ I (if (op x y) then 1 else 0) +bCmp ITNative op [I x, I y] = Just $ I (if (op x y) then 1 else 0) +bCmp ITChar op [Ch x, Ch y] = Just $ I (if (op x y) then 1 else 0) +bCmp (ITVec IT8 _) op [B8V x, B8V y] + = Just . B8V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y +bCmp (ITVec IT16 _) op [B16V x, B16V y] + = Just . B16V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y +bCmp (ITVec IT32 _) op [B32V x, B32V y] + = Just . B32V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y +bCmp (ITVec IT64 _) op [B64V x, B64V y] + = Just . B64V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y +bCmp _ _ _ = Nothing -toInt IT8 x = VConstant (B8 (fromIntegral x)) -toInt IT16 x = VConstant (B16 (fromIntegral x)) -toInt IT32 x = VConstant (B32 (fromIntegral x)) -toInt IT64 x = VConstant (B64 (fromIntegral x)) -toInt ITBig x = VConstant (BI (fromIntegral x)) -toInt ITNative x = VConstant (I (fromIntegral x)) +toInt :: Integral a => IntTy -> a -> Const +toInt (ITFixed IT8) x = B8 (fromIntegral x) +toInt (ITFixed IT16) x = B16 (fromIntegral x) +toInt (ITFixed IT32) x = B32 (fromIntegral x) +toInt (ITFixed IT64) x = B64 (fromIntegral x) +toInt ITBig x = BI (fromIntegral x) +toInt ITNative x = I (fromIntegral x) +toInt ITChar x = Ch (chr $ fromIntegral x) -intToInt IT8 out [VConstant (B8 x)] = Just $ toInt out x -intToInt IT16 out [VConstant (B16 x)] = Just $ toInt out x -intToInt IT32 out [VConstant (B32 x)] = Just $ toInt out x -intToInt IT64 out [VConstant (B64 x)] = Just $ toInt out x -intToInt ITBig out [VConstant (BI x)] = Just $ toInt out x -intToInt ITNative out [VConstant (I x)] = Just $ toInt out x +intToInt :: IntTy -> IntTy -> [Const] -> Maybe Const +intToInt (ITFixed IT8) out [B8 x] = Just $ toInt out x +intToInt (ITFixed IT16) out [B16 x] = Just $ toInt out x +intToInt (ITFixed IT32) out [B32 x] = Just $ toInt out x +intToInt (ITFixed IT64) out [B64 x] = Just $ toInt out x +intToInt ITBig out [BI x] = Just $ toInt out x +intToInt ITNative out [I x] = Just $ toInt out x +intToInt ITChar out [Ch x] = Just $ toInt out (ord x) intToInt _ _ _ = Nothing +zext :: IntTy -> IntTy -> [Const] -> Maybe Const zext from ITBig val = intToInt from ITBig val zext ITBig _ _ = Nothing -zext from to val - | intTyWidth from < intTyWidth to = intToInt from to val +zext f@(ITFixed from) t@(ITFixed to) val + | nativeTyWidth from < nativeTyWidth to = intToInt f t val +zext ITNative to [I x] = Just $ toInt to (fromIntegral x :: Word) +zext from ITNative val = intToInt from ITNative val zext _ _ _ = Nothing -sext IT8 out [VConstant (B8 x)] = Just $ toInt out (fromIntegral x :: Int8) -sext IT16 out [VConstant (B16 x)] = Just $ toInt out (fromIntegral x :: Int16) -sext IT32 out [VConstant (B32 x)] = Just $ toInt out (fromIntegral x :: Int32) -sext IT64 out [VConstant (B64 x)] = Just $ toInt out (fromIntegral x :: Int64) -sext ITBig _ _ = Nothing -sext from to val = intToInt from to val +sext :: IntTy -> IntTy -> [Const] -> Maybe Const +sext (ITFixed IT8) out [B8 x] = Just $ toInt out (fromIntegral x :: Int8) +sext (ITFixed IT16) out [B16 x] = Just $ toInt out (fromIntegral x :: Int16) +sext (ITFixed IT32) out [B32 x] = Just $ toInt out (fromIntegral x :: Int32) +sext (ITFixed IT64) out [B64 x] = Just $ toInt out (fromIntegral x :: Int64) +sext ITBig _ _ = Nothing +sext from to val = intToInt from to val +trunc :: IntTy -> IntTy -> [Const] -> Maybe Const trunc ITBig to val = intToInt ITBig to val trunc _ ITBig _ = Nothing -trunc from to val | intTyWidth from > intTyWidth to = intToInt from to val +trunc f@(ITFixed from) t@(ITFixed to) val | nativeTyWidth from > nativeTyWidth to = intToInt f t val +trunc ITNative to [I x] = Just $ toInt to x +trunc from ITNative val = intToInt from ITNative val trunc _ _ _ = Nothing -getInt :: [Value] -> Maybe Integer -getInt [VConstant (B8 x)] = Just . toInteger $ x -getInt [VConstant (B16 x)] = Just . toInteger $ x -getInt [VConstant (B32 x)] = Just . toInteger $ x -getInt [VConstant (B64 x)] = Just . toInteger $ x -getInt [VConstant (I x)] = Just . toInteger $ x -getInt [VConstant (BI x)] = Just x -getInt _ = Nothing - -intToStr val | Just i <- getInt val = Just $ VConstant (Str (show i)) +intToStr :: [Const] -> Maybe Const +intToStr val | [i] <- getInt val = Just $ Str (show i) intToStr _ = Nothing -strToInt ity [VConstant (Str x)] = case reads x of - [(n,"")] -> Just $ toInt ity (n :: Integer) - _ -> Just $ VConstant (I 0) +getInt :: [Const] -> [Integer] +getInt (B8 x : xs) = toInteger x : getInt xs +getInt (B16 x : xs) = toInteger x : getInt xs +getInt (B32 x : xs) = toInteger x : getInt xs +getInt (B64 x : xs) = toInteger x : getInt xs +getInt (I x : xs) = toInteger x : getInt xs +getInt (BI x : xs) = x : getInt xs +getInt _ = [] + +strToInt :: IntTy -> [Const] -> Maybe Const +strToInt ity [Str x] = case reads x of + [(n,"")] -> Just $ toInt ity (n :: Integer) + _ -> Just $ I 0 strToInt _ _ = Nothing -intToFloat val | Just i <- getInt val = Just $ VConstant (Fl (fromIntegral i)) +intToFloat :: [Const] -> Maybe Const +intToFloat val | [i] <- getInt val = Just $ Fl (fromIntegral i) intToFloat _ = Nothing -floatToInt ity [VConstant (Fl x)] = Just $ toInt ity (truncate x :: Integer) +floatToInt :: IntTy -> [Const] -> Maybe Const +floatToInt ity [Fl x] = Just $ toInt ity (truncate x :: Integer) floatToInt _ _ = Nothing -c_intToChar [VConstant (I x)] = Just $ VConstant (Ch (toEnum x)) +c_intToChar, c_charToInt :: [Const] -> Maybe Const +c_intToChar [(I x)] = Just . Ch . toEnum $ x c_intToChar _ = Nothing -c_charToInt [VConstant (Ch x)] = Just $ VConstant (I (fromEnum x)) +c_charToInt [(Ch x)] = Just . I . fromEnum $ x c_charToInt _ = Nothing -c_floatToStr [VConstant (Fl x)] = Just $ VConstant (Str (show x)) +c_floatToStr :: [Const] -> Maybe Const +c_floatToStr [Fl x] = Just $ Str (show x) c_floatToStr _ = Nothing -c_strToFloat [VConstant (Str x)] = case reads x of - [(n,"")] -> Just $ VConstant (Fl n) - _ -> Just $ VConstant (Fl 0) +c_strToFloat [Str x] = case reads x of + [(n,"")] -> Just $ Fl n + _ -> Just $ Fl 0 c_strToFloat _ = Nothing -p_fPrim f [VConstant (Fl x)] = Just $ VConstant (Fl (f x)) +p_fPrim :: (Double -> Double) -> [Const] -> Maybe Const +p_fPrim f [Fl x] = Just $ Fl (f x) p_fPrim f _ = Nothing +p_floatExp, p_floatLog, p_floatSin, p_floatCos, p_floatTan, p_floatASin, p_floatACos, p_floatATan, p_floatSqrt, p_floatFloor, p_floatCeil :: [Const] -> Maybe Const p_floatExp = p_fPrim exp p_floatLog = p_fPrim log p_floatSin = p_fPrim sin @@ -403,32 +629,20 @@ p_floatFloor = p_fPrim (fromInteger . floor) p_floatCeil = p_fPrim (fromInteger . ceiling) -p_strLen [VConstant (Str xs)] = Just $ VConstant (I (length xs)) +p_strLen, p_strHead, p_strTail, p_strIndex, p_strCons, p_strRev :: [Const] -> Maybe Const +p_strLen [Str xs] = Just $ I (length xs) p_strLen _ = Nothing -p_strHead [VConstant (Str (x:xs))] = Just $ VConstant (Ch x) +p_strHead [Str (x:xs)] = Just $ Ch x p_strHead _ = Nothing -p_strTail [VConstant (Str (x:xs))] = Just $ VConstant (Str xs) +p_strTail [Str (x:xs)] = Just $ Str xs p_strTail _ = Nothing -p_strIndex [VConstant (Str xs), VConstant (I i)] - | i < length xs = Just $ VConstant (Ch (xs!!i)) +p_strIndex [Str xs, I i] + | i < length xs = Just $ Ch (xs!!i) p_strIndex _ = Nothing -p_strCons [VConstant (Ch x), VConstant (Str xs)] = Just $ VConstant (Str (x:xs)) +p_strCons [Ch x, Str xs] = Just $ Str (x:xs) p_strCons _ = Nothing -p_strRev [VConstant (Str xs)] = Just $ VConstant (Str (reverse xs)) +p_strRev [Str xs] = Just $ Str (reverse xs) p_strRev _ = Nothing +p_cantreduce :: a -> Maybe b p_cantreduce _ = Nothing - -elabPrim :: Prim -> Idris () -elabPrim (Prim n ty i def sc tot) - = do updateContext (addOperator n ty i def) - setTotality n tot - i <- getIState - putIState i { idris_scprims = (n, sc) : idris_scprims i } - -elabPrims :: Idris () -elabPrims = do mapM_ (elabDecl EAll toplevel) - (map (PData "" defaultSyntax (FC "builtin" 0) False) - [inferDecl, unitDecl, falseDecl, pairDecl, eqDecl]) - mapM_ elabPrim primitives - diff --git a/src/Idris/Prover.hs b/src/Idris/Prover.hs --- a/src/Idris/Prover.hs +++ b/src/Idris/Prover.hs @@ -14,6 +14,7 @@ import Idris.Error import Idris.DataOpts import Idris.Completion +import Idris.IdeSlave import System.Console.Haskeline import System.Console.Haskeline.History @@ -41,26 +42,31 @@ break = "\n" ++ bird proverSettings :: ElabState [PDecl] -> Settings Idris -proverSettings e = setComplete (proverCompletion assumptionNames) defaultSettings - where assumptionNames = case envAtFocus (proof e) of - OK env -> names env - names [] = [] - names ((MN _ _, _) : bs) = names bs - names ((n, _) : bs) = show n : names bs +proverSettings e = setComplete (proverCompletion (assumptionNames e)) defaultSettings +assumptionNames :: ElabState [PDecl] -> [String] +assumptionNames e + = case envAtFocus (proof e) of + OK env -> names env + where names [] = [] + names ((MN _ _, _) : bs) = names bs + names ((n, _) : bs) = show n : names bs + prove :: Context -> Bool -> Name -> Type -> Idris () -prove ctxt lit n ty +prove ctxt lit n ty = do let ps = initElaborator n ctxt ty + ideslavePutSExp "start-proof-mode" n (tm, prf) <- ploop True ("-" ++ show n) [] (ES (ps, []) "" Nothing) Nothing iLOG $ "Adding " ++ show tm iputStrLn $ showProof lit n prf i <- getIState + ideslavePutSExp "end-proof-mode" n let proofs = proof_list i putIState (i { proof_list = (n, prf) : proofs }) let tree = simpleCase False True CompileTime (FC "proof" 0) [([], P Ref n ty, tm)] logLvl 3 (show tree) (ptm, pty) <- recheckC (FC "proof" 0) [] tm - logLvl 5 ("Proof type: " ++ show pty ++ "\n" ++ + logLvl 5 ("Proof type: " ++ show pty ++ "\n" ++ "Expected type:" ++ show ty) case converts ctxt [] ty pty of OK _ -> return () @@ -68,7 +74,7 @@ ptm' <- applyOpts ptm updateContext (addCasedef n True False True False [Right (P Ref n ty, ptm)] - [([], P Ref n ty, ptm)] + [([], P Ref n ty, ptm)] [([], P Ref n ty, ptm')] ty) solveDeferred n elabStep :: ElabState [PDecl] -> ElabD a -> Idris (a, ElabState [PDecl]) @@ -77,13 +83,13 @@ Error a -> do i <- getIState fail (pshow i a) -dumpState :: IState -> ProofState -> IO () -dumpState ist (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _) = - putStrLn . render $ pretty nm <> colon <+> text "No more goals." -dumpState ist ps@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ problems i _ _ ctxy _ _) = do +dumpState :: IState -> ProofState -> Idris () +dumpState ist (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _) = + iputGoal . render $ pretty nm <> colon <+> text "No more goals." +dumpState ist ps@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ problems i _ _ ctxy _ _ _) = do let OK ty = goalAtFocus ps let OK env = envAtFocus ps - putStrLn . render $ + iputGoal . render $ prettyOtherGoals hs $$ prettyAssumptions env $$ prettyGoal ty @@ -124,46 +130,69 @@ lifte st e = do (v, _) <- elabStep st e return v +receiveInput :: ElabState [PDecl] -> Idris (Maybe String) +receiveInput e = + do i <- getIState + l <- liftIO $ getLine + let (sexp, id) = parseMessage l + putIState $ i { idris_outputmode = (IdeSlave id) } + case sexpToCommand sexp of + Just (REPLCompletions prefix) -> + do (unused, compls) <- proverCompletion (assumptionNames e) (reverse prefix, "") + let good = SexpList [SymbolAtom "ok", toSExp (map replacement compls, reverse unused)] + ideslavePutSExp "return" good + receiveInput e + Just (Interpret cmd) -> return (Just cmd) + Nothing -> return Nothing + ploop :: Bool -> String -> [String] -> ElabState [PDecl] -> Maybe History -> Idris (Term, [String]) ploop d prompt prf e h = do i <- getIState - when d $ liftIO $ dumpState i (proof e) - (x, h') <- runInputT (proverSettings e) $ - -- Manually track the history so that we can use the proof state - do _ <- case h of - Just history -> putHistory history - Nothing -> return () - l <- getInputLine (prompt ++ "> ") - h' <- getHistory - return (l, Just h') + when d $ dumpState i (proof e) + (x, h') <- + case idris_outputmode i of + RawOutput -> runInputT (proverSettings e) $ + -- Manually track the history so that we can use the proof state + do _ <- case h of + Just history -> putHistory history + Nothing -> return () + l <- getInputLine (prompt ++ "> ") + h' <- getHistory + return (l, Just h') + IdeSlave n -> + do isetPrompt prompt + i <- receiveInput e + return (i, h) (cmd, step) <- case x of - Nothing -> fail "Abandoned" + Nothing -> do iFail ""; fail "Abandoned" Just input -> do return (parseTac i input, input) case cmd of - Right Abandon -> fail "Abandoned" + Right Abandon -> do iFail ""; fail "Abandoned" _ -> return () (d, st, done, prf') <- idrisCatch (case cmd of - Left err -> do iputStrLn (show err) + Left err -> do iFail (show err) return (False, e, False, prf) - Right Undo -> - do (_, st) <- elabStep e loadState - return (True, st, False, init prf) - Right ProofState -> - return (True, e, False, prf) - Right ProofTerm -> - do tm <- lifte e get_term - iputStrLn $ "TT: " ++ show tm ++ "\n" - return (False, e, False, prf) + Right Undo -> do (_, st) <- elabStep e loadState + iResult "" + return (True, st, False, init prf) + Right ProofState -> do iResult "" + return (True, e, False, prf) + Right ProofTerm -> do tm <- lifte e get_term + iResult $ "TT: " ++ show tm ++ "\n" + return (False, e, False, prf) Right Qed -> do hs <- lifte e get_holes when (not (null hs)) $ fail "Incomplete proof" + iResult "Proof completed!" return (False, e, True, prf) Right tac -> do (_, e) <- elabStep e saveState (_, st) <- elabStep e (runTac True i tac) --- trace (show (problems (proof st))) $ +-- trace (show (problems (proof st))) $ + iResult "" return (True, st, False, prf ++ [step])) - (\err -> do iputStrLn (show err) + (\err -> do iFail (show err) return (False, e, False, prf)) + ideslavePutSExp "write-proof-state" (prf', length prf') if done then do (tm, _) <- elabStep st get_term return (tm, prf') else ploop d prompt prf' st h' diff --git a/src/Idris/Providers.hs b/src/Idris/Providers.hs --- a/src/Idris/Providers.hs +++ b/src/Idris/Providers.hs @@ -3,7 +3,6 @@ import Core.TT import Core.Evaluate -import Core.Execute import Idris.AbsSyntax import Idris.AbsSyntaxTree import Idris.Error diff --git a/src/Idris/REPL.hs b/src/Idris/REPL.hs --- a/src/Idris/REPL.hs +++ b/src/Idris/REPL.hs @@ -1,5 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveFunctor, - PatternGuards #-} + PatternGuards, CPP #-} module Idris.REPL where @@ -38,7 +38,11 @@ -- import RTS.Bytecode -- import RTS.PreC -- import RTS.CodegenC - +#ifdef IDRIS_LLVM +import LLVM.General.Target +#else +import Util.LLVMStubs +#endif import System.Console.Haskeline as H import System.FilePath import System.Exit @@ -87,7 +91,7 @@ = do i <- getIState case idris_outputmode i of IdeSlave n -> - when (mods /= []) (do liftIO $ putStrLn $ convSExp "set-prompt" (mkPrompt mods) n) + when (mods /= []) (do isetPrompt (mkPrompt mods)) ideslave orig mods @@ -105,6 +109,11 @@ _ -> "" case parseCmd i cmd of Left err -> iFail $ show err + Right (Prove n') -> do iResult "" + idrisCatch + (do process fn (Prove n')) + (\e -> do iFail $ show e) + isetPrompt (mkPrompt mods) Right cmd -> idrisCatch (do ideslaveProcess fn cmd) (\e -> do iFail $ show e) @@ -118,8 +127,13 @@ idris_outputmode = (IdeSlave id) }) loadModule filename iucheck - liftIO $ putStrLn $ convSExp "set-prompt" (mkPrompt [filename]) id - -- report success! or failure! + isetPrompt (mkPrompt [filename]) + + -- Report either success or failure + i <- getIState + case (errLine i) of + Nothing -> iResult $ "loaded " ++ filename + Just x -> iFail $ "didn't load " ++ filename ideslave orig [filename] Nothing -> do iFail "did not understand") (\e -> do iFail $ show e) @@ -145,7 +159,6 @@ ideslaveProcess fn (Spec t) = process fn (Spec t) -- RmProof and AddProof not supported! ideslaveProcess fn (ShowProof n') = process fn (ShowProof n') -ideslaveProcess fn (Prove n') = process fn (Prove n') ideslaveProcess fn (HNF t) = process fn (HNF t) --ideslaveProcess fn TTShell = process fn TTShell -- need some prove mode! @@ -155,8 +168,8 @@ iResult "" ideslaveProcess fn (NewCompile f) = do process fn (NewCompile f) iResult "" -ideslaveProcess fn (Compile target f) = do process fn (Compile target f) - iResult "" +ideslaveProcess fn (Compile codegen f) = do process fn (Compile codegen f) + iResult "" ideslaveProcess fn (LogLvl i) = do process fn (LogLvl i) iResult "" ideslaveProcess fn (Pattelab t) = process fn (Pattelab t) @@ -310,13 +323,16 @@ showImp imp (delabTy ist n)) ts iResult "" [] -> iFail $ "No such variable " ++ show n -process fn (Check t) = do (tm, ty) <- elabVal toplevel False t - ctxt <- getContext - ist <- getIState - imp <- impShow - let ty' = normaliseC ctxt [] ty - iResult (showImp imp (delab ist tm) ++ " : " ++ - showImp imp (delab ist ty)) +process fn (Check t) + = do (tm, ty) <- elabVal toplevel False t + ctxt <- getContext + ist <- getIState + imp <- impShow + let ty' = normaliseC ctxt [] ty + case tm of + TType _ -> iResult ("Type : Type 1") + _ -> iResult (showImp imp (delab ist tm) ++ " : " ++ + showImp imp (delab ist ty)) process fn (DocStr n) = do i <- getIState case lookupCtxtName n (idris_docstrings i) of @@ -362,7 +378,7 @@ let di = lookupCtxt n (idris_datatypes i) when (not (null di)) $ iputStrLn (show di) let d = lookupDef n (tt_ctxt i) - when (not (null d)) $ iputStrLn (show (head d)) + when (not (null d)) $ iputStrLn $ "Definition: " ++ (show (head d)) let cg = lookupCtxtName n (idris_callgraph i) findUnusedArgs (map fst cg) i <- getIState @@ -465,7 +481,7 @@ -- (PRef (FC "main" 0) (NS (UN "main") ["main"])) (tmpn, tmph) <- liftIO tempfile liftIO $ hClose tmph - t <- target + t <- codegen compile t tmpn m liftIO $ system tmpn return () @@ -476,11 +492,11 @@ [pexp $ PRef fc (NS (UN "main") ["Main"])]) compileEpic f m where fc = FC "main" 0 -process fn (Compile target f) +process fn (Compile codegen f) = do (m, _) <- elabVal toplevel False (PApp fc (PRef fc (UN "run__IO")) [pexp $ PRef fc (NS (UN "main") ["Main"])]) - compile target f m + compile codegen f m where fc = FC "main" 0 process fn (LogLvl i) = setLogLevel i -- Elaborate as if LHS of a pattern (debug command) @@ -560,13 +576,14 @@ l ++ take (c1 - length l) (repeat ' ') ++ m ++ take (c2 - length m) (repeat ' ') ++ r ++ "\n" -parseTarget :: String -> Target -parseTarget "C" = ViaC -parseTarget "Java" = ViaJava -parseTarget "bytecode" = Bytecode -parseTarget "javascript" = ViaJavaScript -parseTarget "node" = ViaNode -parseTarget _ = error "unknown target" -- FIXME: partial function +parseCodegen :: String -> Codegen +parseCodegen "C" = ViaC +parseCodegen "Java" = ViaJava +parseCodegen "bytecode" = Bytecode +parseCodegen "javascript" = ViaJavaScript +parseCodegen "node" = ViaNode +parseCodegen "llvm" = ViaLLVM +parseCodegen _ = error "unknown codegen" -- FIXME: partial function parseArgs :: [String] -> [Opt] parseArgs [] = [] @@ -604,8 +621,17 @@ parseArgs ("-c":ns) = OutputTy Object : (parseArgs ns) parseArgs ("--dumpdefuns":n:ns) = DumpDefun n : (parseArgs ns) parseArgs ("--dumpcases":n:ns) = DumpCases n : (parseArgs ns) -parseArgs ("--target":n:ns) = UseTarget (parseTarget n) : (parseArgs ns) +parseArgs ("--codegen":n:ns) = UseCodegen (parseCodegen n) : (parseArgs ns) +parseArgs ["--exec"] = InterpretScript "Main.main" : [] +parseArgs ("--exec":expr:ns) = InterpretScript expr : parseArgs ns parseArgs ("-XTypeProviders":ns) = Extension TypeProviders : (parseArgs ns) +parseArgs ("-O3":ns) = OptLevel 3 : parseArgs ns +parseArgs ("-O2":ns) = OptLevel 2 : parseArgs ns +parseArgs ("-O1":ns) = OptLevel 1 : parseArgs ns +parseArgs ("-O0":ns) = OptLevel 0 : parseArgs ns +parseArgs ("-O":n:ns) = OptLevel (read n) : parseArgs ns +parseArgs ("--target":n:ns) = TargetTriple n : parseArgs ns +parseArgs ("--cpu":n:ns) = TargetCPU n : parseArgs ns parseArgs (n:ns) = Filename n : (parseArgs ns) helphead = @@ -634,28 +660,45 @@ let bcs = opt getBC opts let vm = opt getFOVM opts let pkgdirs = opt getPkgDir opts + let optimize = case opt getOptLevel opts of + [] -> 2 + xs -> last xs + trpl <- case opt getTriple opts of + [] -> liftIO $ getDefaultTargetTriple + xs -> return (last xs) + tcpu <- case opt getCPU opts of + [] -> liftIO $ getHostCPUName + xs -> return (last xs) let outty = case opt getOutputTy opts of [] -> Executable xs -> last xs - let tgt = case opt getTarget opts of + let cgn = case opt getCodegen opts of [] -> ViaC xs -> last xs + script <- case opt getExecScript opts of + [] -> return Nothing + x:y:xs -> do iputStrLn "More than one interpreter expression found." + liftIO $ exitWith (ExitFailure 1) + [expr] -> return (Just expr) when (DefaultTotal `elem` opts) $ do i <- getIState putIState (i { default_total = True }) mapM_ addLangExt (opt getLanguageExt opts) setREPL runrepl - setQuiet quiet + setQuiet (quiet || isJust script) setIdeSlave idesl setVerbose runrepl setCmdLine opts setOutputTy outty - setTarget tgt + setCodegen cgn + setTargetTriple trpl + setTargetCPU tcpu + setOptLevel optimize when (Verbose `elem` opts) $ setVerbose True mapM_ makeOption opts -- if we have the --fovm flag, drop into the first order VM testing case vm of [] -> return () - xs -> liftIO $ mapM_ (fovm tgt outty) xs + xs -> liftIO $ mapM_ (fovm cgn outty) xs -- if we have the --bytecode flag, drop into the bytecode assembler case bcs of [] -> return () @@ -670,16 +713,19 @@ elabPrims when (not (NoPrelude `elem` opts)) $ do x <- loadModule "Prelude" return () - when (runrepl && not quiet && not idesl) $ iputStrLn banner + when (runrepl && not quiet && not idesl && not (isJust script)) $ iputStrLn banner ist <- getIState mods <- mapM loadModule inputs ok <- noErrors when ok $ case output of [] -> return () - (o:_) -> process "" (Compile tgt o) + (o:_) -> process "" (Compile cgn o) when ok $ case newoutput of [] -> return () - (o:_) -> process "" (NewCompile o) + (o:_) -> process "" (NewCompile o) + case script of + Nothing -> return () + Just expr -> execScript expr when (runrepl && not idesl) $ runInputT replSettings $ repl ist inputs when (idesl) $ ideslaveStart ist inputs ok <- noErrors @@ -696,6 +742,16 @@ addPkgDir p = do ddir <- liftIO $ getDataDir addImportDir (ddir p) +execScript :: String -> Idris () +execScript expr = do i <- getIState + case parseExpr i expr of + Left err -> do iputStrLn $ show err + liftIO $ exitWith (ExitFailure 1) + Right term -> do ctxt <- getContext + (tm, _) <- elabVal toplevel False term + res <- execute tm + liftIO $ exitWith ExitSuccess + getFile :: Opt -> Maybe String getFile (Filename str) = Just str getFile _ = Nothing @@ -737,10 +793,14 @@ getPkgClean (PkgClean str) = Just str getPkgClean _ = Nothing -getTarget :: Opt -> Maybe Target -getTarget (UseTarget x) = Just x -getTarget _ = Nothing +getCodegen :: Opt -> Maybe Codegen +getCodegen (UseCodegen x) = Just x +getCodegen _ = Nothing +getExecScript :: Opt -> Maybe String +getExecScript (InterpretScript expr) = Just expr +getExecScript _ = Nothing + getOutputTy :: Opt -> Maybe OutputType getOutputTy (OutputTy t) = Just t getOutputTy _ = Nothing @@ -748,6 +808,18 @@ getLanguageExt :: Opt -> Maybe LanguageExt getLanguageExt (Extension e) = Just e getLanguageExt _ = Nothing + +getTriple :: Opt -> Maybe String +getTriple (TargetTriple x) = Just x +getTriple _ = Nothing + +getCPU :: Opt -> Maybe String +getCPU (TargetCPU x) = Just x +getCPU _ = Nothing + +getOptLevel :: Opt -> Maybe Int +getOptLevel (OptLevel x) = Just x +getOptLevel _ = Nothing opt :: (Opt -> Maybe a) -> [Opt] -> [a] opt = mapMaybe diff --git a/src/Idris/Transforms.hs b/src/Idris/Transforms.hs --- a/src/Idris/Transforms.hs +++ b/src/Idris/Transforms.hs @@ -39,7 +39,7 @@ natTrans = [TermTrans zero, TermTrans suc, CaseTrans natcase] -zname = NS (UN "O") ["Nat","Prelude"] +zname = NS (UN "Z") ["Nat","Prelude"] sname = NS (UN "S") ["Nat","Prelude"] zero :: TT Name -> TT Name diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -91,10 +91,16 @@ "\t--log [level] Type debugging log level\n" ++ "\t-S Do no further compilation of code generator output\n" ++ "\t-c Compile to object files rather than an executable\n" ++ - "\t--ideslave Ideslave mode (for editors; in/ouput wrapped in s-expressions)\n" ++ + "\t--exec [expr] Execute the expression expr in the interpreter,\n" ++ + "\t defaulting to Main.main if none provided, and exit.\n" ++ + "\t--ideslave Ideslave mode (for editors; in/ouput wrapped in \n" ++ + "\t s-expressions)\n" ++ "\t--libdir Show library install directory and exit\n" ++ "\t--link Show C library directories and exit (for C linking)\n" ++ "\t--include Show C include directories and exit (for C linking)\n" ++ - "\t--target [target] Type the target: C, Java, bytecode, javascript, node\n" + "\t--codegen [cg] Select code generator: C, Java, bytecode, javascript,\n" ++ + "\t node or llvm\n" ++ + "\t--target [triple] Select target triple (for LLVM codegen)\n" ++ + "\t--cpu [cpu] Select target architecture (for LLVM codegen)\n" diff --git a/src/Pkg/Package.hs b/src/Pkg/Package.hs --- a/src/Pkg/Package.hs +++ b/src/Pkg/Package.hs @@ -69,6 +69,7 @@ buildMods :: [Opt] -> [Name] -> IO () buildMods opts ns = do let f = map (toPath . show) ns +-- putStrLn $ "MODULE: " ++ show f idris (map Filename f ++ opts) return () where toPath n = foldl1' () $ splitOn "." n diff --git a/src/Util/DynamicLinker.hs b/src/Util/DynamicLinker.hs --- a/src/Util/DynamicLinker.hs +++ b/src/Util/DynamicLinker.hs @@ -21,6 +21,11 @@ hostDynamicLibExt = "dylib" #elif WINDOWS hostDynamicLibExt = "dll" +#else +hostDynamicLibExt = error $ unwords + [ "Undefined file extension for dynamic libraries" + , "in Idris' Util.DynamicLinker." + ] #endif data ForeignFun = forall a. Fun { fun_name :: String diff --git a/src/Util/LLVMStubs.hs b/src/Util/LLVMStubs.hs new file mode 100644 --- /dev/null +++ b/src/Util/LLVMStubs.hs @@ -0,0 +1,30 @@ +{-- + +Things needed to build without LLVM +Replaces stuff from LLVM.General.Target and IRTS.CodegenLLVM. + +--} + +module Util.LLVMStubs where + +import qualified Core.TT as TT +import IRTS.Simplified +import IRTS.CodegenCommon + + +getDefaultTargetTriple :: IO String +getDefaultTargetTriple = return "" + +getHostCPUName :: IO String +getHostCPUName = return "" + + +codegenLLVM :: [(TT.Name, SDecl)] -> + String -> -- target triple + String -> -- target CPU + Int -> -- Optimization degree + FilePath -> -- output file name + OutputType -> + IO () + +codegenLLVM _ _ _ _ _ _ = fail "This Idris was compiled without the LLVM backend." diff --git a/src/Util/System.hs b/src/Util/System.hs --- a/src/Util/System.hs +++ b/src/Util/System.hs @@ -15,22 +15,15 @@ import System.Environment import System.IO import System.IO.Error -#if MIN_VERSION_base(4,0,0) import Control.Exception as CE -#endif import Paths_idris -#if MIN_VERSION_base(4,0,0) catchIO :: IO a -> (IOError -> IO a) -> IO a catchIO = CE.catch throwIO :: IOError -> IO a throwIO = CE.throw -#else -catchIO = catch -throwIO = throw -#endif @@ -43,7 +36,11 @@ getMvn :: IO String getMvn = do env <- environment "IDRIS_MVN" case env of +#ifdef mingw32_HOST_OS + Nothing -> return "mvn.bat" +#else Nothing -> return "mvn" +#endif Just mvn -> return mvn tempfile :: IO (FilePath, Handle) diff --git a/test/Makefile b/test/Makefile new file mode 100644 --- /dev/null +++ b/test/Makefile @@ -0,0 +1,65 @@ +test: + perl ./runtest.pl all + +test_java: + perl ./runtest.pl all --codegen Java + +test_js: + @perl ./runtest.pl reg001 --codegen node + @perl ./runtest.pl reg002 --codegen node + @perl ./runtest.pl reg003 --codegen node + @perl ./runtest.pl reg004 --codegen node + @perl ./runtest.pl reg005 --codegen node + @perl ./runtest.pl reg006 --codegen node + @perl ./runtest.pl reg007 --codegen node + @perl ./runtest.pl reg008 --codegen node + @perl ./runtest.pl reg009 --codegen node + @perl ./runtest.pl reg010 --codegen node + @perl ./runtest.pl reg011 --codegen node + @perl ./runtest.pl reg012 --codegen node + @perl ./runtest.pl reg013 --codegen node + @perl ./runtest.pl reg014 --codegen node + @perl ./runtest.pl reg015 --codegen node + @#perl ./runtest.pl reg016 --codegen node + @perl ./runtest.pl reg017 --codegen node + @perl ./runtest.pl reg018 --codegen node + @perl ./runtest.pl reg019 --codegen node + @perl ./runtest.pl reg020 --codegen node + @perl ./runtest.pl test001 --codegen node + @perl ./runtest.pl test002 --codegen node + @perl ./runtest.pl test003 --codegen node + @#perl ./runtest.pl test004 --codegen node + @perl ./runtest.pl test005 --codegen node + @perl ./runtest.pl test006 --codegen node + @perl ./runtest.pl test007 --codegen node + @perl ./runtest.pl test008 --codegen node + @perl ./runtest.pl test009 --codegen node + @perl ./runtest.pl test010 --codegen node + @perl ./runtest.pl test011 --codegen node + @perl ./runtest.pl test012 --codegen node + @perl ./runtest.pl test013 --codegen node + @#perl ./runtest.pl test014 --codegen node + @perl ./runtest.pl test015 --codegen node + @perl ./runtest.pl test016 --codegen node + @perl ./runtest.pl test017 --codegen node + @#perl ./runtest.pl test018 --codegen node + @perl ./runtest.pl test019 --codegen node + @perl ./runtest.pl test020 --codegen node + @#perl ./runtest.pl test021 --codegen node + @perl ./runtest.pl test022 --codegen node + @perl ./runtest.pl test023 --codegen node + @perl ./runtest.pl test024 --codegen node + @#perl ./runtest.pl test025 --codegen node + @perl ./runtest.pl test026 --codegen node + @perl ./runtest.pl test027 --codegen node + @perl ./runtest.pl test028 --codegen node + +update: + perl ./runtest.pl all -u + +diff: + perl ./runtest.pl all -d + +distclean: + rm -f *~ + rm -f */output diff --git a/test/reg001/expected b/test/reg001/expected new file mode 100644 --- /dev/null +++ b/test/reg001/expected diff --git a/test/reg001/reg001.idr b/test/reg001/reg001.idr new file mode 100644 --- /dev/null +++ b/test/reg001/reg001.idr @@ -0,0 +1,11 @@ +apply : (a -> b) -> a -> b +apply f x = f x + +class Functor f => VerifiedFunctor (f : Type -> Type) where + identity : (fa : f a) -> map id fa = fa + +data Imp : Type where + MkImp : {any : Type} -> any -> Imp + +testVal : Imp +testVal = MkImp (apply id Z) diff --git a/test/reg001/run b/test/reg001/run new file mode 100644 --- /dev/null +++ b/test/reg001/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris reg001.idr --check +rm -rf reg001.ibc + diff --git a/test/reg002/expected b/test/reg002/expected new file mode 100644 --- /dev/null +++ b/test/reg002/expected @@ -0,0 +1,1 @@ +[2, 1, 4, 3, 5] diff --git a/test/reg002/reg002.idr b/test/reg002/reg002.idr new file mode 100644 --- /dev/null +++ b/test/reg002/reg002.idr @@ -0,0 +1,31 @@ +module Main + +%default total + +data CoNat + = Co Nat + | Infinity + +S : CoNat -> CoNat +S (Co n) = Co (S n) +S Infinity = Infinity + +Sn_notzero : Main.S n = Co 0 -> _|_ +Sn_notzero = believe_me + +S_Co_not_Inf : Main.S (Co n) = Infinity -> _|_ +S_Co_not_Inf = believe_me + +S_inj : (n : CoNat) -> (m : CoNat) -> Main.S n = Main.S m -> n = m +S_inj (Co n) (Co _) refl = refl +S_inj (Co n) Infinity p = FalseElim (S_Co_not_Inf p) +S_inj Infinity (Co m) p = FalseElim (S_Co_not_Inf (sym p)) +S_inj Infinity Infinity refl = refl + +swap : {n : Nat} -> Vect n a -> Vect n a +swap Nil = Nil +swap (x :: Nil) = x :: Nil +swap (x :: y :: xs) = (y :: x :: (swap xs)) + +main : IO () +main = print (swap [1,2,3,4,5]) diff --git a/test/reg002/run b/test/reg002/run new file mode 100644 --- /dev/null +++ b/test/reg002/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris reg002.idr -o reg002 +./reg002 +rm -f reg002 *.ibc diff --git a/test/reg003/expected b/test/reg003/expected new file mode 100644 --- /dev/null +++ b/test/reg003/expected @@ -0,0 +1,4 @@ +reg003a.idr:4:No such variable OddList +reg003a.idr:7:No such variable EvenList +reg003a.idr:10:No such variable EvenList +reg003a.idr:10:No type declaration for test diff --git a/test/reg003/reg003.idr b/test/reg003/reg003.idr new file mode 100644 --- /dev/null +++ b/test/reg003/reg003.idr @@ -0,0 +1,13 @@ + +mutual + namespace Even + data EvenList : Type where + Nil : EvenList + (::) : Nat -> OddList -> EvenList + + namespace Odd + data OddList : Type where + (::) : Nat -> EvenList -> OddList + +test : EvenList +test = [1, 2, 3, 4, 5, 6] diff --git a/test/reg003/reg003a.idr b/test/reg003/reg003a.idr new file mode 100644 --- /dev/null +++ b/test/reg003/reg003a.idr @@ -0,0 +1,10 @@ + +data EvenList : Type where + ENil : EvenList + ECons : Nat -> OddList -> EvenList + +data OddList : Type where + OCons : Nat -> EvenList -> OddList + +test : EvenList +test = ECons 1 ENil diff --git a/test/reg003/run b/test/reg003/run new file mode 100644 --- /dev/null +++ b/test/reg003/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris --check reg003.idr +idris --check reg003a.idr +rm -f *.ibc diff --git a/test/reg004/expected b/test/reg004/expected new file mode 100644 --- /dev/null +++ b/test/reg004/expected @@ -0,0 +1,2 @@ +0 +1 diff --git a/test/reg004/reg004.idr b/test/reg004/reg004.idr new file mode 100644 --- /dev/null +++ b/test/reg004/reg004.idr @@ -0,0 +1,16 @@ +module Main + +h : Bool -> Nat +h False = r1 where + r : Nat + r = S Z + r1 : Nat + r1 = r +h True = r2 where + r : Nat + r = Z + r2 : Nat + r2 = r + +main : IO () +main = do print (h True); print (h False) diff --git a/test/reg004/run b/test/reg004/run new file mode 100644 --- /dev/null +++ b/test/reg004/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris reg004.idr -o reg004 +./reg004 +rm -f reg004 *.ibc diff --git a/test/reg005/expected b/test/reg005/expected new file mode 100644 --- /dev/null +++ b/test/reg005/expected @@ -0,0 +1,1 @@ +1f4o1b4a1r1b3a1z diff --git a/test/reg005/reg005.idr b/test/reg005/reg005.idr new file mode 100644 --- /dev/null +++ b/test/reg005/reg005.idr @@ -0,0 +1,50 @@ +module Main + +rep : (n : Nat) -> Char -> Vect n Char +rep Z x = [] +rep (S k) x = x :: rep k x + +data RLE : Vect n Char -> Type where + REnd : RLE [] + RChar : {xs : Vect k Char} -> + (n : Nat) -> (x : Char) -> RLE xs -> + RLE (rep (S n) x ++ xs) + +eq : (x : Char) -> (y : Char) -> Maybe (x = y) +eq x y = if x == y then Just ?eqCharOK else Nothing + +------------ + +rle : (xs : Vect n Char) -> RLE xs +rle [] = REnd +rle (x :: xs) with (rle xs) + rle (x :: Vect.Nil) | REnd = RChar Z x REnd + rle (x :: rep (S n) yvar ++ ys) | RChar n yvar rs with (eq x yvar) + rle (x :: rep (S n) x ++ ys) | RChar n x rs | Just refl + = RChar (S n) x rs + rle (x :: rep (S n) y ++ ys) | RChar n y rs | Nothing + = RChar Z x (RChar n y rs) + +compress : Vect n Char -> String +compress xs with (rle xs) + compress Nil | REnd = "" + compress (rep (S n) x ++ xs) | RChar _ _ rs + = let ni : Integer = cast (S n) in + show ni ++ show x ++ compress xs + +compressString : String -> String +compressString xs = compress (fromList (unpack xs)) + +main : IO () +main = putStrLn (compressString "foooobaaaarbaaaz") + + + +---------- Proofs ---------- + +Main.eqCharOK = proof { + intros; + refine believe_me; + exact x = x; +} + diff --git a/test/reg005/run b/test/reg005/run new file mode 100644 --- /dev/null +++ b/test/reg005/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris $@ reg005.idr -o reg005 +./reg005 +rm -f reg005 *.ibc diff --git a/test/reg006/expected b/test/reg006/expected new file mode 100644 --- /dev/null +++ b/test/reg006/expected @@ -0,0 +1,1 @@ +reg006.idr:17:RBTree.lookup is possibly not total due to: RBTree.lookup_case diff --git a/test/reg006/reg006.idr b/test/reg006/reg006.idr new file mode 100644 --- /dev/null +++ b/test/reg006/reg006.idr @@ -0,0 +1,27 @@ +module RBTree + +data Colour = Red | Black + +data RBTree : Type -> Type -> Nat -> Colour -> Type where + Leaf : RBTree k v Z Black + RedBranch : k -> v -> RBTree k v n Black -> RBTree k v n Black -> RBTree k v n Red + BlackBranch : k -> v -> RBTree k v n x -> RBTree k v n y -> RBTree k v (S n) Black + +toBlack : RBTree k v n c -> (m ** (RBTree k v m Black, Either (m = n) (m = (S n)))) +toBlack (RedBranch k v l r) = (_ ** (BlackBranch k v l r, Right refl)) +toBlack Leaf = (_ ** (Leaf, Left refl)) +toBlack (BlackBranch k v l r) = (_ ** (BlackBranch k v l r, Left refl)) + +total +lookup : Ord k => k -> RBTree k v n Black -> Maybe v +lookup k Leaf = Nothing +lookup k (BlackBranch k0 v0 l r) = + case compare k k0 of + EQ => Just v0 + LT => + let (_ ** (t, _)) = toBlack l in + lookup k t + GT => + let (_ ** (t, _)) = toBlack r in + lookup k t + diff --git a/test/reg006/run b/test/reg006/run new file mode 100644 --- /dev/null +++ b/test/reg006/run @@ -0,0 +1,3 @@ +#!/bin/bash +idris $@ reg006.idr -o reg006 +rm -f *.ibc diff --git a/test/reg007/A.lidr b/test/reg007/A.lidr new file mode 100644 --- /dev/null +++ b/test/reg007/A.lidr @@ -0,0 +1,5 @@ +> module A + +> n : Nat +> n = ?lala + diff --git a/test/reg007/expected b/test/reg007/expected new file mode 100644 --- /dev/null +++ b/test/reg007/expected @@ -0,0 +1,1 @@ +reg007.lidr:8:A.n is already defined diff --git a/test/reg007/reg007.lidr b/test/reg007/reg007.lidr new file mode 100644 --- /dev/null +++ b/test/reg007/reg007.lidr @@ -0,0 +1,12 @@ +> module B + +> import A + +> isSame : A.n = A.lala +> isSame = refl + +> A.n = O -- This is where it's at! +> A.lala = S O + +> hurrah : O = S O +> hurrah = isSame diff --git a/test/reg007/run b/test/reg007/run new file mode 100644 --- /dev/null +++ b/test/reg007/run @@ -0,0 +1,3 @@ +#!/bin/bash +idris --check $@ reg007.lidr +rm -f *.ibc diff --git a/test/reg008/expected b/test/reg008/expected new file mode 100644 --- /dev/null +++ b/test/reg008/expected diff --git a/test/reg008/reg008.idr b/test/reg008/reg008.idr new file mode 100644 --- /dev/null +++ b/test/reg008/reg008.idr @@ -0,0 +1,15 @@ +module NatCmp + +data Cmp : Nat -> Nat -> Type where + cmpLT : (y : _) -> Cmp x (x + S y) + cmpEQ : Cmp x x + cmpGT : (x : _) -> Cmp (y + S x) y + +total cmp : (x, y : Nat) -> Cmp x y +cmp Z Z = cmpEQ +cmp Z (S k) = cmpLT _ +cmp (S k) Z = cmpGT _ +cmp (S x) (S y) with (cmp x y) + cmp (S x) (S (x + (S k))) | cmpLT k = cmpLT k + cmp (S x) (S x) | cmpEQ = cmpEQ + cmp (S (y + (S k))) (S y) | cmpGT k = cmpGT k diff --git a/test/reg008/run b/test/reg008/run new file mode 100644 --- /dev/null +++ b/test/reg008/run @@ -0,0 +1,3 @@ +#!/bin/bash +idris $@ reg008.idr --check +rm -f *.ibc diff --git a/test/reg009/expected b/test/reg009/expected new file mode 100644 --- /dev/null +++ b/test/reg009/expected diff --git a/test/reg009/reg009.lidr b/test/reg009/reg009.lidr new file mode 100644 --- /dev/null +++ b/test/reg009/reg009.lidr @@ -0,0 +1,19 @@ +> isAnyBy : (alpha -> Bool) -> (n : Nat ** Vect n alpha) -> Bool +> isAnyBy _ (_ ** Nil) = False +> isAnyBy p (_ ** (a :: as)) = p a || isAnyBy p (_ ** as) + + +> filterTagP : (p : alpha -> Bool) -> +> (as : Vect n alpha) -> +> so (isAnyBy p (n ** as)) -> +> (m : Nat ** (Vect m (a : alpha ** so (p a)), so (m > Z))) +> filterTagP {n = S m} p (a :: as) q with (p a) +> | True = (_ +> ** +> ((a ** believe_me oh) +> :: +> (fst (getProof (filterTagP p as (believe_me oh)))), +> oh +> ) +> ) +> | False = filterTagP p as (believe_me oh) diff --git a/test/reg009/run b/test/reg009/run new file mode 100644 --- /dev/null +++ b/test/reg009/run @@ -0,0 +1,3 @@ +#!/bin/bash +idris $@ reg009.lidr --check +rm -f reg009 *.ibc diff --git a/test/reg010/expected b/test/reg010/expected new file mode 100644 --- /dev/null +++ b/test/reg010/expected @@ -0,0 +1,4 @@ +reg010.idr:5:Can't unify P x with P y + +Specifically: + Can't unify P x with P y diff --git a/test/reg010/reg010.idr b/test/reg010/reg010.idr new file mode 100644 --- /dev/null +++ b/test/reg010/reg010.idr @@ -0,0 +1,5 @@ +module usubst + +total unsafeSubst : (P : a -> Type) -> (x : a) -> (y : a) -> P x -> P y +unsafeSubst P x y px with (Z) + unsafeSubst P x x px | _ = px diff --git a/test/reg010/run b/test/reg010/run new file mode 100644 --- /dev/null +++ b/test/reg010/run @@ -0,0 +1,2 @@ +#!/bin/bash +idris $@ reg010.idr --check diff --git a/test/reg011/expected b/test/reg011/expected new file mode 100644 --- /dev/null +++ b/test/reg011/expected diff --git a/test/reg011/reg011.idr b/test/reg011/reg011.idr new file mode 100644 --- /dev/null +++ b/test/reg011/reg011.idr @@ -0,0 +1,9 @@ +vfoldl : (P : Nat -> Type) -> + ((x : Nat) -> P x -> a -> P (S x)) -> P Z + -> Vect m a -> P m +-- vfoldl P cons nil [] +-- = nil +vfoldl P cons nil (x :: xs) + = vfoldl (\k => P (S k)) (\ n => cons (S n)) (cons Z nil x) xs +-- vfoldl P cons nil (x :: xs) +-- = vfoldl (\n => P (S n)) (\ n => cons _) (cons _ nil x) xs diff --git a/test/reg011/run b/test/reg011/run new file mode 100644 --- /dev/null +++ b/test/reg011/run @@ -0,0 +1,3 @@ +#!/bin/bash +idris $@ reg011.idr --check +rm -f *.ibc diff --git a/test/reg012/expected b/test/reg012/expected new file mode 100644 --- /dev/null +++ b/test/reg012/expected diff --git a/test/reg012/reg012.lidr b/test/reg012/reg012.lidr new file mode 100644 --- /dev/null +++ b/test/reg012/reg012.lidr @@ -0,0 +1,34 @@ +> total soElim : (C : (b : Bool) -> so b -> Type) -> +> C True oh -> +> (b : Bool) -> (s : so b) -> (C b s) +> soElim C coh .True .oh = coh + +> soFalseElim : so False -> a +> soFalseElim x = FalseElim (soElim C () False x) +> where +> C : (b : Bool) -> so b -> Type +> C True s = () +> C False s = _|_ + +> soTrue : so b -> b = True +> soTrue {b = False} x = soFalseElim x +> soTrue {b = True} x = refl + +> class Eq alpha => ReflEqEq alpha where +> reflexive_eqeq : (a : alpha) -> so (a == a) + +> modifyFun : (Eq alpha) => +> (alpha -> beta) -> +> (alpha, beta) -> +> (alpha -> beta) +> modifyFun f (a, b) a' = if a' == a then b else f a' + +> modifyFunLemma : (ReflEqEq alpha) => +> (f : alpha -> beta) -> +> (ab : (alpha, beta)) -> +> modifyFun f ab (fst ab) = snd ab +> modifyFunLemma f (a,b) = +> rewrite soTrue (reflexive_eqeq a) in refl + + replace {P = \ z => boolElim (a == a) b (f a) = boolElim z b (f a)} + (soTrue (reflexive_eqeq a)) refl diff --git a/test/reg012/run b/test/reg012/run new file mode 100644 --- /dev/null +++ b/test/reg012/run @@ -0,0 +1,3 @@ +#!/bin/bash +idris $@ reg012.lidr --check +rm -f *.ibc diff --git a/test/reg013/expected b/test/reg013/expected new file mode 100644 --- /dev/null +++ b/test/reg013/expected @@ -0,0 +1,3 @@ +5 +1 +0 diff --git a/test/reg013/reg013.idr b/test/reg013/reg013.idr new file mode 100644 --- /dev/null +++ b/test/reg013/reg013.idr @@ -0,0 +1,8 @@ +module Main + +main : IO () +main = do + print $ prim_lenString "hallo" + print $ prim_lenString "1" + print $ prim_lenString "" + diff --git a/test/reg013/run b/test/reg013/run new file mode 100644 --- /dev/null +++ b/test/reg013/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris $@ reg013.idr -o reg013 +./reg013 +rm -f reg013 *.ibc diff --git a/test/reg014/expected b/test/reg014/expected new file mode 100644 --- /dev/null +++ b/test/reg014/expected diff --git a/test/reg014/reg014.idr b/test/reg014/reg014.idr new file mode 100644 --- /dev/null +++ b/test/reg014/reg014.idr @@ -0,0 +1,12 @@ +module reg014 + +Matrix : Type -> Nat -> Nat -> Type +Matrix a n m = Vect n (Vect m a) + +transpose : Matrix a (S n) (S m) -> Matrix a (S m) (S n) +transpose ((x:: []) :: []) = [[x]] +transpose [x :: y :: xs] = [x] :: (transpose [y :: xs]) +transpose (x :: y :: xs) + = let tx = transpose [x] in + let ux = transpose (y :: xs) in zipWith (++) tx ux + diff --git a/test/reg014/run b/test/reg014/run new file mode 100644 --- /dev/null +++ b/test/reg014/run @@ -0,0 +1,3 @@ +#!/bin/bash +idris $@ reg014.idr --check +rm -f *.ibc diff --git a/test/reg015/expected b/test/reg015/expected new file mode 100644 --- /dev/null +++ b/test/reg015/expected diff --git a/test/reg015/reg015.idr b/test/reg015/reg015.idr new file mode 100644 --- /dev/null +++ b/test/reg015/reg015.idr @@ -0,0 +1,3 @@ +using (A : Type, B : A->Type, C : Type) + foo : ((x:A) -> B x -> C) -> ((x:A ** B x) -> C) + foo f p = f (getWitness p) (getProof p) diff --git a/test/reg015/run b/test/reg015/run new file mode 100644 --- /dev/null +++ b/test/reg015/run @@ -0,0 +1,3 @@ +#!/bin/bash +idris $@ reg015.idr --check +rm -f *.ibc diff --git a/test/reg016/expected b/test/reg016/expected new file mode 100644 --- /dev/null +++ b/test/reg016/expected @@ -0,0 +1,6 @@ +4294967295 +4294967296 +4294967297 +-1 +0 +1 diff --git a/test/reg016/reg016.idr b/test/reg016/reg016.idr new file mode 100644 --- /dev/null +++ b/test/reg016/reg016.idr @@ -0,0 +1,11 @@ +module Main + +main : IO () +main = do print $ the Integer 4294967295 + print $ the Integer 4294967296 + print $ the Integer 4294967297 + print $ the Int 4294967295 + print $ the Int 4294967296 + print $ the Int 4294967297 + + diff --git a/test/reg016/run b/test/reg016/run new file mode 100644 --- /dev/null +++ b/test/reg016/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris $@ reg016.idr -o reg016 +./reg016 +rm -f reg016 *.ibc diff --git a/test/reg017/expected b/test/reg017/expected new file mode 100644 --- /dev/null +++ b/test/reg017/expected @@ -0,0 +1,1 @@ +4 diff --git a/test/reg017/reg017.idr b/test/reg017/reg017.idr new file mode 100644 --- /dev/null +++ b/test/reg017/reg017.idr @@ -0,0 +1,13 @@ +module Main + +foo : { t : Type } -> + (a : t) -> + { default tactics { refine refl; solve; } prfA : a = a } -> + (b : Nat) -> + (c : Nat) -> + { default tactics { refine refl; solve; } prfBC : b = c } -> + Nat +foo {t} a {prfA = p} b c {prfBC} = b + +main : IO () +main = print $ foo 3 4 4 diff --git a/test/reg017/run b/test/reg017/run new file mode 100644 --- /dev/null +++ b/test/reg017/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris $@ reg017.idr -o reg017 +./reg017 +rm -f reg017 *.ibc diff --git a/test/reg018/expected b/test/reg018/expected new file mode 100644 --- /dev/null +++ b/test/reg018/expected @@ -0,0 +1,4 @@ +reg018a.idr:16:conat.minusCoNat is not productive +reg018b.idr:8:A.showB is possibly not total due to recursive path A.showB +reg018c.idr:19:CodataTest.inf is not productive +reg018d.idr:5:Main.pull is not total as there are missing cases diff --git a/test/reg018/reg018a.idr b/test/reg018/reg018a.idr new file mode 100644 --- /dev/null +++ b/test/reg018/reg018a.idr @@ -0,0 +1,21 @@ +module conat + +%default total + +codata CoNat = Z | S CoNat + +infinity : CoNat +infinity = S infinity + +plusCoNat : CoNat -> CoNat -> CoNat +plusCoNat Z x = x +plusCoNat (S x) y = S (plusCoNat x y) + +--I don't think this should be definable +minusCoNat : CoNat -> CoNat -> CoNat +minusCoNat Z n = Z +minusCoNat (S n) Z = S n +minusCoNat (S n) (S m) = plusCoNat Z (minusCoNat n m) + +loopForever : CoNat +loopForever = minusCoNat infinity infinity diff --git a/test/reg018/reg018b.idr b/test/reg018/reg018b.idr new file mode 100644 --- /dev/null +++ b/test/reg018/reg018b.idr @@ -0,0 +1,14 @@ +module A + +%default total + +codata B = Z B | I B + +showB : B -> String +showB (I x) = "I" ++ showB x +showB (Z x) = "Z" ++ showB x + +instance Show B where show = showB + +os : B +os = Z os diff --git a/test/reg018/reg018c.idr b/test/reg018/reg018c.idr new file mode 100644 --- /dev/null +++ b/test/reg018/reg018c.idr @@ -0,0 +1,20 @@ +module CodataTest +%default total + +codata InfStream a = (::) a (InfStream a) +-- +-- natStream : InfStream Nat +-- natStream = natFromStream 0 where +-- natFromStream : Nat -> InfStream Nat +-- natFromStream n = (::) n (natFromStream (S n)) + +take : (n: Nat) -> InfStream a -> Vect n a +take Z _ = [] +take (S n) (x :: xs) = x :: take n xs + +hdtl : InfStream a -> (a, InfStream a) +hdtl (x :: xs) = (x, xs) + +inf : InfStream a -> InfStream a +inf (x :: xs) with (hdtl xs) + | (hd, tl) = inf xs diff --git a/test/reg018/reg018d.idr b/test/reg018/reg018d.idr new file mode 100644 --- /dev/null +++ b/test/reg018/reg018d.idr @@ -0,0 +1,12 @@ +module Main + +total +pull : Fin (S n) -> Vect (S n) a -> (a, Vect n a) +pull {n=Z} _ (x :: xs) = (x, xs) +-- pull {n=S q} fZ (Vect.(::) {n=S _} x xs) = (x, xs) +pull {n=S _} (fS n) (x :: xs) = + let (v, vs) = pull n xs in + (v, x::vs) + +main : IO () +main = print (pull fZ [0, 1, 2]) diff --git a/test/reg018/run b/test/reg018/run new file mode 100644 --- /dev/null +++ b/test/reg018/run @@ -0,0 +1,5 @@ +#!/bin/bash +idris $@ reg018a.idr --check +idris $@ reg018b.idr --check +idris $@ reg018c.idr --check +idris $@ reg018d.idr --check diff --git a/test/reg019/expected b/test/reg019/expected new file mode 100644 --- /dev/null +++ b/test/reg019/expected diff --git a/test/reg019/reg019.idr b/test/reg019/reg019.idr new file mode 100644 --- /dev/null +++ b/test/reg019/reg019.idr @@ -0,0 +1,7 @@ +m_add : Maybe (Either Bool Int) -> Maybe (Either Bool Int) -> + Maybe (Either Bool Int) +m_add x y = do x' <- x -- Extract value from x + y' <- y -- Extract value from y + case x' of + Left _ => Nothing + Right _ => Nothing diff --git a/test/reg019/run b/test/reg019/run new file mode 100644 --- /dev/null +++ b/test/reg019/run @@ -0,0 +1,3 @@ +#!/bin/bash +idris $@ reg019.idr --check +rm -f *.ibc diff --git a/test/reg020/expected b/test/reg020/expected new file mode 100644 --- /dev/null +++ b/test/reg020/expected @@ -0,0 +1,7 @@ +length of: '' is: 0 +length of: 'hello world!' is: 12 +length of: ' ' is: 1 +length of: ' ' is: 1 +length of: ' +' is: 1 +length of all matches sum of all lengths: True diff --git a/test/reg020/reg020.idr b/test/reg020/reg020.idr new file mode 100644 --- /dev/null +++ b/test/reg020/reg020.idr @@ -0,0 +1,41 @@ +module Main + +emptyString : String +emptyString = "" + +helloWorld : String +helloWorld = "hello world!" + +spaceOnly : String +spaceOnly = " " + +tabOnly : String +tabOnly = "\t" + +linebreakOnly : String +linebreakOnly = "\n" + +all : Vect 5 String +all = + [ emptyString + , helloWorld + , spaceOnly + , tabOnly + , linebreakOnly + ] + +lengthAll : Nat +lengthAll = Strings.length $ foldl (++) (head all) (tail all) + +sumOfAllLengths : Nat +sumOfAllLengths = foldl (\ l, s => l + (Strings.length s)) (Strings.length $ head all) (tail all) + + +main : IO () +main = do putStrLn $ "length of: '" ++ emptyString ++ "' is: " ++ (show $ length emptyString) + putStrLn $ "length of: '" ++ helloWorld ++ "' is: " ++ (show $ length helloWorld) + putStrLn $ "length of: '" ++ spaceOnly ++ "' is: " ++ (show $ length spaceOnly) + putStrLn $ "length of: '" ++ tabOnly ++ "' is: " ++ (show $ length tabOnly) + putStrLn $ "length of: '" ++ linebreakOnly ++ "' is: " ++ (show $ length linebreakOnly) + putStrLn $ "length of all matches sum of all lengths: " ++ (show $ lengthAll == sumOfAllLengths) + diff --git a/test/reg020/run b/test/reg020/run new file mode 100644 --- /dev/null +++ b/test/reg020/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris $@ reg020.idr -o reg020 +./reg020 +rm -f reg020 *.ibc diff --git a/test/runtest.pl b/test/runtest.pl new file mode 100644 --- /dev/null +++ b/test/runtest.pl @@ -0,0 +1,110 @@ +#!/usr/bin/perl + +use Cwd; + +my $exitstatus = 0; + +sub runtest { + my ($test, $update) = @_; + + chdir($test); + + print "Running $test..."; + $got = `sh ./run @idrOpts`; + $exp = `cat expected`; + + open(OUT,">output"); + print OUT $got; + close(OUT); + +# $ok = system("diff output expected &> /dev/null"); +# Mangle newlines in $got and $exp + $got =~ s/\r\n/\n/g; + $exp =~ s/\r\n/\n/g; + +# Normalize paths in $got and $exp, so the expected outcomes don't change between platforms + while($got =~ /(^|.*?\n)(.*?)\\(.*?):(\d+):(.*)/ms) + { + $got = "$1$2/$3:$4:$5"; + } + while($exp =~ /(^|.*?\n)(.*?)\\(.*?):(\d+):(.*)/ms) + { + $exp = "$1$2/$3:$4:$5"; + } + + if ($got eq $exp) { + print "success\n"; + } else { + if ($update == 0) { + $exitstatus = 1; + print "FAILURE\n"; + } else { + system("cp output expected"); + print "UPDATED\n"; + } + } + chdir(".."); +} + +if ($#ARGV>=0) { + $test=shift(@ARGV); + if ($test eq "all") { + opendir(DIR, "."); + @list = readdir(DIR); + foreach $file (@list) { + if ($file =~ /[0-9][0-9][0-9]/) { + push(@tests,$file); + } + } + @tests = sort @tests; + } + else + { + push(@tests, $test); + } + @opts = @ARGV; +} else { + print "Give a test name, or 'all' to run all.\n"; + exit; +} + +$update=0; +$diff=0; +$show=0; +$usejava = 0; +@idrOpts=(); + +while ($opt=shift(@opts)) { + if ($opt eq "-u") { $update = 1; } + elsif ($opt eq "-d") { $diff = 1; } + elsif ($opt eq "-s") { $show = 1; } + else { push(@idrOpts, $opt); } +} + +my $idris = $ENV{IDRIS}; +my $path = $ENV{PATH}; +$ENV{PATH}=cwd() . "/" . $idris . ":" . $path; + +foreach $test (@tests) { + + if ($diff == 0 && $show == 0) { + runtest($test,$update); + } + else { + chdir($test); + + if ($show == 1) { + system("cat output"); + } + if ($diff == 1) { + print "Differences in $test:\n"; + $ok = system("diff output expected"); + if ($ok == 0) { + print "No differences found.\n"; + } + } + chdir(".."); + } + +} +exit $exitstatus; diff --git a/test/test001/expected b/test/test001/expected new file mode 100644 --- /dev/null +++ b/test/test001/expected @@ -0,0 +1,2 @@ +24 +12 diff --git a/test/test001/run b/test/test001/run new file mode 100644 --- /dev/null +++ b/test/test001/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris $@ test001.idr -o test001 +./test001 +rm -f test001 test001.ibc diff --git a/test/test001/test001.idr b/test/test001/test001.idr new file mode 100644 --- /dev/null +++ b/test/test001/test001.idr @@ -0,0 +1,96 @@ +module Main + +data Ty = TyInt | TyBool| TyFun Ty Ty + +interpTy : Ty -> Type +interpTy TyInt = Int +interpTy TyBool = Bool +interpTy (TyFun s t) = interpTy s -> interpTy t + +using (G : Vect n Ty) + + data Env : Vect n Ty -> Type where + Nil : Env Nil + (::) : interpTy a -> Env G -> Env (a :: G) + + data HasType : (i : Fin n) -> Vect n Ty -> Ty -> Type where + stop : HasType fZ (t :: G) t + pop : HasType k G t -> HasType (fS k) (u :: G) t + + lookup : HasType i G t -> Env G -> interpTy t + lookup stop (x :: xs) = x + lookup (pop k) (x :: xs) = lookup k xs + lookup stop [] impossible + + data Expr : Vect n Ty -> Ty -> Type where + Var : HasType i G t -> Expr G t + Val : (x : Int) -> Expr G TyInt + Lam : Expr (a :: G) t -> Expr G (TyFun a t) + App : Expr G (TyFun a t) -> Expr G a -> Expr G t + Op : (interpTy a -> interpTy b -> interpTy c) -> Expr G a -> Expr G b -> + Expr G c + If : Expr G TyBool -> Expr G a -> Expr G a -> Expr G a + Bind : Expr G a -> (interpTy a -> Expr G b) -> Expr G b + + dsl expr + lambda = Lam + variable = Var + index_first = stop + index_next = pop + + interp : Env G -> {static} Expr G t -> interpTy t + interp env (Var i) = lookup i env + interp env (Val x) = x + interp env (Lam sc) = \x => interp (x :: env) sc + interp env (App f s) = (interp env f) (interp env s) + interp env (Op op x y) = op (interp env x) (interp env y) + interp env (If x t e) = if interp env x then interp env t else interp env e + interp env (Bind v f) = interp env (f (interp env v)) + + eId : Expr G (TyFun TyInt TyInt) + eId = expr (\x => x) + + eTEST : Expr G (TyFun TyInt (TyFun TyInt TyInt)) + eTEST = expr (\x, y => y) + + eAdd : Expr G (TyFun TyInt (TyFun TyInt TyInt)) + eAdd = expr (\x, y => Op (+) x y) + +-- eDouble : Expr G (TyFun TyInt TyInt) +-- eDouble = Lam (App (App (Lam (Lam (Op' (+) (Var fZ) (Var (fS fZ))))) (Var fZ)) (Var fZ)) + + eDouble : Expr G (TyFun TyInt TyInt) + eDouble = expr (\x => App (App eAdd x) (Var stop)) + + app : |(f : Expr G (TyFun a t)) -> Expr G a -> Expr G t + app = \f, a => App f a + + eFac : Expr G (TyFun TyInt TyInt) + eFac = expr (\x => If (Op (==) x (Val 0)) + (Val 1) + (Op (*) (app eFac (Op (-) x (Val 1))) x)) + + -- Exercise elaborator: Complicated way of doing \x y => x*4 + y*2 + + eProg : Expr G (TyFun TyInt (TyFun TyInt TyInt)) + eProg = Lam (Lam + (Bind (App eDouble (Var (pop stop))) + (\x => Bind (App eDouble (Var stop)) + (\y => Bind (App eDouble (Val x)) + (\z => App (App eAdd (Val y)) (Val z)))))) + +test : Int +test = interp [] eProg 2 2 + +testFac : Int +testFac = interp [] eFac 4 + +testEnv : Int -> Env [TyInt,TyInt] +testEnv x = [x,x] + +main : IO () +main = do { print testFac + print test } + + + diff --git a/test/test002/expected b/test/test002/expected new file mode 100644 --- /dev/null +++ b/test/test002/expected @@ -0,0 +1,1 @@ +test002.idr:5:Universe inconsistency diff --git a/test/test002/run b/test/test002/run new file mode 100644 --- /dev/null +++ b/test/test002/run @@ -0,0 +1,3 @@ +#!/bin/bash +idris $@ test002.idr --check --noprelude +rm -f *.ibc diff --git a/test/test002/test002.idr b/test/test002/test002.idr new file mode 100644 --- /dev/null +++ b/test/test002/test002.idr @@ -0,0 +1,29 @@ +myid : a -> a +myid x = x + +idid : (a : Type) -> a -> a +idid = myid ![myid] + +app : (a -> b) -> a -> b +app f x = f x + +foo : a -> b -> c -> d -> e -> e +foo a b c d e = e + +doapp : a -> a +doapp x = app myid x + +{- + +id : (b : Type k) -> b -> b : Type l, k < l + +foo = id ((a : Type k) -> a -> a) id + Type m, k < m + +So we have k < m, k < l, m <= k + + when converting Type m against Type n, we must have m <= n + if we can reach m from n, we have an inconsistency + + + -} diff --git a/test/test003/Lit.lidr b/test/test003/Lit.lidr new file mode 100644 --- /dev/null +++ b/test/test003/Lit.lidr @@ -0,0 +1,19 @@ +> module Lit + +Test some string primitives while we're at it + +> st : String +> st = "abcdefg" + +Literate main program + +> main : IO () +> main = do { putStrLn (show (strHead st)) +> putStrLn (show (strIndex st 3)) +> putStrLn (strCons 'z' st) +> putStrLn (reverse st) +> let x = unpack st +> putStrLn (show (reverse x)) +> putStrLn (pack x) +> } + diff --git a/test/test003/expected b/test/test003/expected new file mode 100644 --- /dev/null +++ b/test/test003/expected @@ -0,0 +1,7 @@ +./test003a.lidr:1:Program line next to comment +a +d +zabcdefg +gfedcba +[g, f, e, d, c, b, a] +abcdefg diff --git a/test/test003/run b/test/test003/run new file mode 100644 --- /dev/null +++ b/test/test003/run @@ -0,0 +1,5 @@ +#!/bin/bash +idris $@ test003a.lidr --check +idris $@ test003.lidr -o test003 +./test003 +rm -f test003 test003.ibc Lit.ibc diff --git a/test/test003/test003.lidr b/test/test003/test003.lidr new file mode 100644 --- /dev/null +++ b/test/test003/test003.lidr @@ -0,0 +1,8 @@ +> module Main + +Import the literate module + +> import Lit + +> main : IO () +> main = Lit.main diff --git a/test/test003/test003a.lidr b/test/test003/test003a.lidr new file mode 100644 --- /dev/null +++ b/test/test003/test003a.lidr @@ -0,0 +1,3 @@ +Broken +> main : IO (); +> main = putStrLn "Foo"; diff --git a/test/test004/expected b/test/test004/expected new file mode 100644 --- /dev/null +++ b/test/test004/expected @@ -0,0 +1,7 @@ +Reading testfile +Hello! +World! + +--- +Hello! +World! diff --git a/test/test004/run b/test/test004/run new file mode 100644 --- /dev/null +++ b/test/test004/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris $@ test004.idr -o test004 +./test004 +rm -f test004 test004.ibc testfile diff --git a/test/test004/test004.idr b/test/test004/test004.idr new file mode 100644 --- /dev/null +++ b/test/test004/test004.idr @@ -0,0 +1,21 @@ +module Main + +dumpFile : String -> IO () +dumpFile fn = do { h <- openFile fn Read + while (do { x <- feof h + return (not x) }) + (do { l <- fread h + putStr l }) + closeFile h } + +main : IO () +main = do { h <- openFile "testfile" Write + fwrite h "Hello!\nWorld!\n" + closeFile h + putStrLn "Reading testfile" + f <- readFile "testfile" + putStrLn f + putStrLn "---" + dumpFile "testfile" + } + diff --git a/test/test005/expected b/test/test005/expected new file mode 100644 --- /dev/null +++ b/test/test005/expected @@ -0,0 +1,6 @@ +8 +1 +(abc, 123) +(abc, 123) +([1, 2], [3, 4, 5]) +([1, 2], [3, 4, 5]) diff --git a/test/test005/run b/test/test005/run new file mode 100644 --- /dev/null +++ b/test/test005/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris $@ test005.idr -o test005 +./test005 +rm -f test005 test005.ibc diff --git a/test/test005/test005.idr b/test/test005/test005.idr new file mode 100644 --- /dev/null +++ b/test/test005/test005.idr @@ -0,0 +1,15 @@ +module Main + +tstr : String +tstr = "abc123" + +tlist : List Int +tlist = [1, 2, 3, 4, 5] + +main : IO () +main = do print (abs (-8)) + print (abs (S Z)) + print (span isAlpha tstr) + print (break isDigit tstr) + print (span (\x => x < 3) tlist) + print (break (\x => x > 2) tlist) diff --git a/test/test006/expected b/test/test006/expected new file mode 100644 --- /dev/null +++ b/test/test006/expected @@ -0,0 +1,1 @@ +[False, True, False, True, False, True] diff --git a/test/test006/run b/test/test006/run new file mode 100644 --- /dev/null +++ b/test/test006/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris $@ test006.idr -o test006 +./test006 +rm -f test006 test006.ibc diff --git a/test/test006/test006.idr b/test/test006/test006.idr new file mode 100644 --- /dev/null +++ b/test/test006/test006.idr @@ -0,0 +1,39 @@ +module Main + +data Parity : Nat -> Type where + even : Parity (n + n) + odd : Parity (S (n + n)) + +parity : (n:Nat) -> Parity n +parity Z = even {n=Z} +parity (S Z) = odd {n=Z} +parity (S (S k)) with (parity k) + parity (S (S (j + j))) | (even {n = j}) ?= even {n=S j} + parity (S (S (S (j + j)))) | (odd {n = j}) ?= odd {n=S j} + +natToBin : Nat -> List Bool +natToBin Z = Nil +natToBin k with (parity k) + natToBin (j + j) | even {n = j} = False :: natToBin j + natToBin (S (j + j)) | odd {n = j} = True :: natToBin j + +main : IO () +main = do print (natToBin 42) + +---------- Proofs ---------- + +Main.parity_lemma_2 = proof { + intro; + intro; + rewrite sym (plusSuccRightSucc j j); + trivial; +}; + +Main.parity_lemma_1 = proof { + intro j; + intro; + rewrite sym (plusSuccRightSucc j j); + trivial; +}; + + diff --git a/test/test007/expected b/test/test007/expected new file mode 100644 --- /dev/null +++ b/test/test007/expected @@ -0,0 +1,4 @@ +Just 8 +Just 9 +Just 42 +Nothing diff --git a/test/test007/run b/test/test007/run new file mode 100644 --- /dev/null +++ b/test/test007/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris $@ test007.idr -o test007 +./test007 +rm -f test007 test007.ibc diff --git a/test/test007/test007.idr b/test/test007/test007.idr new file mode 100644 --- /dev/null +++ b/test/test007/test007.idr @@ -0,0 +1,41 @@ +module Main + +data Expr = Var String + | Val Int + | Add Expr Expr + +data Eval : Type -> Type where + MkEval : (List (String, Int) -> Maybe a) -> Eval a + +fetch : String -> Eval Int +fetch x = MkEval (\e => fetchVal e) where + fetchVal : List (String, Int) -> Maybe Int + fetchVal [] = Nothing + fetchVal ((v, val) :: xs) = if (x == v) then (Just val) else (fetchVal xs) + +instance Functor Eval where + map f (MkEval g) = MkEval (\e => map f (g e)) + +instance Applicative Eval where + pure x = MkEval (\e => Just x) + + (<$>) (MkEval f) (MkEval g) = MkEval (\x => appAux (f x) (g x)) where + appAux : Maybe (a -> b) -> Maybe a -> Maybe b + appAux (Just fx) (Just gx) = Just (fx gx) + appAux _ _ = Nothing + +eval : Expr -> Eval Int +eval (Var x) = fetch x +eval (Val x) = [| x |] +eval (Add x y) = [| eval x + eval y |] + +runEval : List (String, Int) -> Expr -> Maybe Int +runEval env e with (eval e) { + | MkEval envFn = envFn env +} + +main : IO () +main = do print [| (\x => x *2) (Just 4) |] + print [| plus (Just 4) (Just 5) |] + print (runEval [("x",21), ("y", 20)] (Add (Val 1) (Add (Var "x") (Var "y")))) + print (runEval [("x",21)] (Add (Val 1) (Add (Var "x") (Var "y")))) diff --git a/test/test008/expected b/test/test008/expected new file mode 100644 --- /dev/null +++ b/test/test008/expected @@ -0,0 +1,3 @@ +First and second? 2 +1 +2 diff --git a/test/test008/run b/test/test008/run new file mode 100644 --- /dev/null +++ b/test/test008/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris $@ test008.idr -o test008 +./test008 +rm -f test008 test008.ibc diff --git a/test/test008/test008.idr b/test/test008/test008.idr new file mode 100644 --- /dev/null +++ b/test/test008/test008.idr @@ -0,0 +1,28 @@ +module Main + +testlist : List (String, Int) +testlist = [("foo", 1), ("bar", 2)] + +getVal : String -> a -> List (String, a) -> a +getVal x b xs = case lookup x xs of + Just v => case lookup x xs of + Just v' => v + Nothing => b + +foo : (Int, String) +foo = (4, "foo") + + +ioVals : IO (String, String) +ioVals = do { return ("First", "second") } + +main : IO () +main = do (a, b) <- ioVals + putStr (show a ++ " and " ++ show b ++ "? ") + let x = "bar" + putStrLn (show (getVal x 7 testlist)) + let ((y, z) :: _) = testlist + print z + case lookup x testlist of + Just v => putStrLn (show v) + Nothing => putStrLn "Not there!" diff --git a/test/test009/expected b/test/test009/expected new file mode 100644 --- /dev/null +++ b/test/test009/expected @@ -0,0 +1,1 @@ +[(3, (4, 5)), (6, (8, 10)), (5, (12, 13)), (9, (12, 15)), (8, (15, 17)), (12, (16, 20)), (15, (20, 25)), (7, (24, 25)), (10, (24, 26)), (20, (21, 29)), (18, (24, 30)), (16, (30, 34)), (21, (28, 35)), (12, (35, 37)), (15, (36, 39)), (24, (32, 40)), (9, (40, 41)), (27, (36, 45)), (30, (40, 50)), (14, (48, 50))] diff --git a/test/test009/run b/test/test009/run new file mode 100644 --- /dev/null +++ b/test/test009/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris $@ test009.idr -o test009 +./test009 +rm -f test009 test009.ibc diff --git a/test/test009/test009.idr b/test/test009/test009.idr new file mode 100644 --- /dev/null +++ b/test/test009/test009.idr @@ -0,0 +1,9 @@ +module Main + +pythag : Int -> List (Int, Int, Int) +pythag n = [ (x, y, z) | z <- [1..n], y <- [1..z], x <- [1..y], + x*x + y*y == z*z ] + +main : IO () +main = putStrLn (show (pythag 50)) + diff --git a/test/test010/expected b/test/test010/expected new file mode 100644 --- /dev/null +++ b/test/test010/expected @@ -0,0 +1,3 @@ +test010.idr:13:foo is possibly not total due to: MkBad +test010a.idr:9:main.bar is possibly not total due to: main.MkBad +test010b.idr:9:main.bar is possibly not total due to: main.MkBad diff --git a/test/test010/run b/test/test010/run new file mode 100644 --- /dev/null +++ b/test/test010/run @@ -0,0 +1,6 @@ +#!/bin/bash +idris $@ test010.idr -o test010 +idris $@ test010a.idr -o test010 +idris $@ test010b.idr -o test010 + +rm -f *.ibc diff --git a/test/test010/test010.idr b/test/test010/test010.idr new file mode 100644 --- /dev/null +++ b/test/test010/test010.idr @@ -0,0 +1,15 @@ +data MyNat = MyO | MyS MyNat + +%default total + +data Bad = MkBad (Bad -> Int) Int + | MkBad' Int + +vapp : Vect n a -> Vect m a -> Vect (n + m) a +vapp [] ys = ys +vapp (x :: xs) ys = x :: vapp xs ys + +foo : Bad -> Int +foo (MkBad f i) = f (MkBad' i) +foo (MkBad' x) = x + diff --git a/test/test010/test010a.idr b/test/test010/test010a.idr new file mode 100644 --- /dev/null +++ b/test/test010/test010a.idr @@ -0,0 +1,9 @@ +module main + +%default total + +data Bad = MkBad (Bad -> Int) Int + | MkBad' Int + +bar : Bad +bar = MkBad (\x => 3) 3 diff --git a/test/test010/test010b.idr b/test/test010/test010b.idr new file mode 100644 --- /dev/null +++ b/test/test010/test010b.idr @@ -0,0 +1,9 @@ +module main + +%default total + +data Bad = MkBad (Bad -> Int) Int + | MkBad' Int + +bar : Bad +bar = MkBad (\x => 3) 3 diff --git a/test/test011/expected b/test/test011/expected new file mode 100644 --- /dev/null +++ b/test/test011/expected @@ -0,0 +1,5 @@ +foo +Fred +[1, 2, 3] +[b, a] +25 diff --git a/test/test011/run b/test/test011/run new file mode 100644 --- /dev/null +++ b/test/test011/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris $@ test011.idr -o test011 +./test011 +rm -f test011 test011.ibc diff --git a/test/test011/test011.idr b/test/test011/test011.idr new file mode 100644 --- /dev/null +++ b/test/test011/test011.idr @@ -0,0 +1,26 @@ +module Main + +record Foo : Nat -> Type where + MkFoo : (name : String) -> + (things : Vect n a) -> + (more_things : Vect m b) -> + Foo n + +record Person : Type where + MkPerson : (name : String) -> (age : Int) -> Person + +testFoo : Foo 3 +testFoo = MkFoo "name" [1,2,3] [4,5,6,7] + +person : Person +person = MkPerson "Fred" 30 + +main : IO () +main = do let x = record { name = "foo", + more_things = reverse ["a","b"] } testFoo + print $ name x + print $ name person + print $ things x + print $ more_things x + print $ age (record { age = 25 } person) + diff --git a/test/test012/expected b/test/test012/expected new file mode 100644 --- /dev/null +++ b/test/test012/expected @@ -0,0 +1,1 @@ +test012a.idr:7:x is not an accessible pattern variable diff --git a/test/test012/run b/test/test012/run new file mode 100644 --- /dev/null +++ b/test/test012/run @@ -0,0 +1,2 @@ +#!/bin/bash +idris $@ test012a.idr -o test012a diff --git a/test/test012/test012a.idr b/test/test012/test012a.idr new file mode 100644 --- /dev/null +++ b/test/test012/test012a.idr @@ -0,0 +1,10 @@ +module Main + +f : Nat -> Nat +f x = x + 1 + +foo : Nat -> Nat +foo (f x) = x + +main : IO () +main = putStrLn (show (foo 1)) diff --git a/test/test013/expected b/test/test013/expected new file mode 100644 --- /dev/null +++ b/test/test013/expected @@ -0,0 +1,12 @@ +Counting: +Number 1 +Number 2 +Number 3 +Number 4 +Number 5 +Number 6 +Number 7 +Number 8 +Number 9 +Number 10 +Done! diff --git a/test/test013/run b/test/test013/run new file mode 100644 --- /dev/null +++ b/test/test013/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris $@ test013.idr -o test013 +./test013 +rm -f test013 test013.ibc diff --git a/test/test013/test013.idr b/test/test013/test013.idr new file mode 100644 --- /dev/null +++ b/test/test013/test013.idr @@ -0,0 +1,15 @@ +module Main + +forLoop : List a -> (a -> IO ()) -> IO () +forLoop [] f = return () +forLoop (x :: xs) f = do f x + forLoop xs f + +syntax for {x} "in" [xs] ":" [body] = forLoop xs (\x => body) + +main : IO () +main = do putStrLn "Counting:" + for x in [1..10]: + putStrLn $ "Number " ++ show x + putStrLn "Done!" + diff --git a/test/test014/Resimp.idr b/test/test014/Resimp.idr new file mode 100644 --- /dev/null +++ b/test/test014/Resimp.idr @@ -0,0 +1,168 @@ +module Resimp + +-- IO operations which read a resource +data Reader : Type -> Type where + MkReader : IO a -> Reader a + +getReader : Reader a -> IO a +getReader (MkReader x) = x + +ior : IO a -> Reader a +ior = MkReader + +-- IO operations which update a resource +data Updater : Type -> Type where + MkUpdater : IO a -> Updater a + +getUpdater : Updater a -> IO a +getUpdater (MkUpdater x) = x + +iou : IO a -> Updater a +iou = MkUpdater + +-- IO operations which create a resource +data Creator : Type -> Type where + MkCreator : IO a -> Creator a + +getCreator : Creator a -> IO a +getCreator (MkCreator x) = x + +ioc : IO a -> Creator a +ioc = MkCreator + +infixr 5 :-> + +using (i: Fin n, gam : Vect n Ty, gam' : Vect n Ty, gam'' : Vect n Ty) + + data Ty = R Type + | Val Type + | Choice Type Type + | (:->) Type Ty + + interpTy : Ty -> Type + interpTy (R t) = IO t + interpTy (Val t) = t + interpTy (Choice x y) = Either x y + interpTy (a :-> b) = a -> interpTy b + + data HasType : Vect n Ty -> Fin n -> Ty -> Type where + stop : HasType (a :: gam) fZ a + pop : HasType gam i b -> HasType (a :: gam) (fS i) b + + data Env : Vect n Ty -> Type where + Nil : Env Nil + (::) : interpTy a -> Env gam -> Env (a :: gam) + + envLookup : HasType gam i a -> Env gam -> interpTy a + envLookup stop (x :: xs) = x + envLookup (pop k) (x :: xs) = envLookup k xs + + update : (gam : Vect n Ty) -> HasType gam i b -> Ty -> Vect n Ty + update (x :: xs) stop y = y :: xs + update (x :: xs) (pop k) y = x :: update xs k y + update Nil stop _ impossible + + total + envUpdate : (p:HasType gam i a) -> (val:interpTy b) -> + Env gam -> Env (update gam p b) + envUpdate stop val (x :: xs) = val :: xs + envUpdate (pop k) val (x :: xs) = x :: envUpdate k val xs + envUpdate stop _ Nil impossible + + total + envUpdateVal : (p:HasType gam i a) -> (val:b) -> + Env gam -> Env (update gam p (Val b)) + envUpdateVal stop val (x :: xs) = val :: xs + envUpdateVal (pop k) val (x :: xs) = x :: envUpdateVal k val xs + envUpdateVal stop _ Nil impossible + + envTail : Env (a :: gam) -> Env gam + envTail (x :: xs) = xs + + data Args : Vect n Ty -> List Type -> Type where + ANil : Args gam [] + ACons : HasType gam i a -> + Args gam as -> Args gam (interpTy a :: as) + + funTy : List Type -> Ty -> Ty + funTy list.Nil t = t + funTy (a :: as) t = a :-> funTy as t + + data Res : Vect n Ty -> Vect n Ty -> Ty -> Type where + +{-- Resource creation and usage. 'Let' creates a resource - the type + at the end means that the resource must have been consumed by the time + it goes out of scope, where "consumed" simply means that it has been + replaced with a value of type '()'. --} + + Let : Creator (interpTy a) -> + Res (a :: gam) (Val () :: gam') (R t) -> + Res gam gam' (R t) + Update : (a -> Updater b) -> (p:HasType gam i (Val a)) -> + Res gam (update gam p (Val b)) (R ()) + Use : (a -> Reader b) -> HasType gam i (Val a) -> + Res gam gam (R b) + +{-- Control structures --} + + Lift : |(action:IO a) -> Res gam gam (R a) + Check : (p:HasType gam i (Choice (interpTy a) (interpTy b))) -> + (failure:Res (update gam p a) (update gam p c) t) -> + (success:Res (update gam p b) (update gam p c) t) -> + Res gam (update gam p c) t + While : Res gam gam (R Bool) -> + Res gam gam (R ()) -> Res gam gam (R ()) + Return : a -> Res gam gam (R a) + (>>=) : Res gam gam' (R a) -> (a -> Res gam' gam'' (R t)) -> + Res gam gam'' (R t) + + ioret : a -> IO a + ioret = return + + interp : Env gam -> {static} Res gam gam' t -> + (Env gam' -> interpTy t -> IO u) -> IO u + + interp env (Let val scope) k + = do x <- getCreator val + interp (x :: env) scope + (\env', scope' => k (envTail env') scope') + interp env (Update method x) k + = do x' <- getUpdater (method (envLookup x env)) + k (envUpdateVal x x' env) (return ()) + interp env (Use method x) k + = do x' <- getReader (method (envLookup x env)) + k env (return x') + interp env (Lift io) k + = k env io + interp env (Check x left right) k = + either (envLookup x env) + (\a => interp (envUpdate x a env) left k) + (\b => interp (envUpdate x b env) right k) + interp env (While test body) k + = interp env test + (\env', result => + do r <- result + if (not r) + then (k env' (return ())) + else (interp env' body + (\env'', body' => + do v <- body' -- make sure it's evalled + interp env'' (While test body) k ))) + interp env (Return v) k = k env (return v) + interp env (v >>= f) k + = interp env v (\env', v' => do n <- v' + interp env' (f n) k) + +-- run : {static} Res [] [] (R t) -> IO t +-- run prog = interp [] prog (\env, res => res) + +syntax run [prog] = interp [] prog (\env, res => res) + +dsl res + variable = id + let = Let + index_first = stop + index_next = pop + +syntax RES [x] = {gam:Vect n Ty} -> Res gam gam (R x) + diff --git a/test/test014/expected b/test/test014/expected new file mode 100644 --- /dev/null +++ b/test/test014/expected @@ -0,0 +1,2 @@ +foo + diff --git a/test/test014/run b/test/test014/run new file mode 100644 --- /dev/null +++ b/test/test014/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris $@ test014.idr -o test014 +./test014 +rm -f test014 resimp.ibc test014.ibc diff --git a/test/test014/test b/test/test014/test new file mode 100644 --- /dev/null +++ b/test/test014/test @@ -0,0 +1,2 @@ +foo +bar diff --git a/test/test014/test014.idr b/test/test014/test014.idr new file mode 100644 --- /dev/null +++ b/test/test014/test014.idr @@ -0,0 +1,66 @@ +module Main + +import Resimp + +data Purpose = Reading | Writing + +pstring : Purpose -> String +pstring Reading = "r" +pstring Writing = "w" + +data FILE : Purpose -> Type where + OpenH : File -> FILE p + +syntax ifM [test] then [t] else [e] + = test >>= (\b => if b then t else e) + +open : String -> (p:Purpose) -> Creator (Either () (FILE p)) +open fn p = ioc (do h <- fopen fn (pstring p) + ifM validFile h + then return (Right (OpenH h)) + else return (Left ())) + +close : FILE p -> Updater () +close (OpenH h) = iou (closeFile h) + +readLine : FILE Reading -> Reader String +readLine (OpenH h) = ior (fread h) + +eof : FILE Reading -> Reader Bool +eof (OpenH h) = ior (feof h) + +syntax rclose [h] = Update close h +syntax rreadLine [h] = Use readLine h +syntax reof [h] = Use eof h + +syntax rputStrLn [s] = Lift (putStrLn s) + +syntax if opened [f] then [e] else [t] = Check f t e + + + + + + + + + + + + + + + +-------- + +readH : String -> RES () +readH fn = res (do let x = open fn Reading + if opened x then + do str <- rreadLine x + rputStrLn str + rclose x + else rputStrLn "Error") + +main : IO () +main = run (readH "test") + diff --git a/test/test015/Parity.idr b/test/test015/Parity.idr new file mode 100644 --- /dev/null +++ b/test/test015/Parity.idr @@ -0,0 +1,28 @@ +module Parity + +data Parity : Nat -> Type where + even : Parity (n + n) + odd : Parity (S (n + n)) + +parity : (n:Nat) -> Parity n +parity Z = even {n=Z} +parity (S Z) = odd {n=Z} +parity (S (S k)) with (parity k) + parity (S (S (j + j))) | even ?= even {n=S j} + parity (S (S (S (j + j)))) | odd ?= odd {n=S j} + + +parity_lemma_2 = proof { + intro; + intro; + rewrite sym (plusSuccRightSucc j j); + trivial; +} + +parity_lemma_1 = proof { + intro j; + intro; + rewrite sym (plusSuccRightSucc j j); + trivial; +} + diff --git a/test/test015/expected b/test/test015/expected new file mode 100644 --- /dev/null +++ b/test/test015/expected @@ -0,0 +1,3 @@ +00101010 +01011001 +010000011 diff --git a/test/test015/run b/test/test015/run new file mode 100644 --- /dev/null +++ b/test/test015/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris $@ test015.idr -o test015 +./test015 +rm -f test015 parity.ibc test015.ibc diff --git a/test/test015/test015.idr b/test/test015/test015.idr new file mode 100644 --- /dev/null +++ b/test/test015/test015.idr @@ -0,0 +1,143 @@ +module Main + +import Parity +import System + +data Bit : Nat -> Type where + b0 : Bit Z + b1 : Bit (S Z) + +instance Show (Bit n) where + show = show' where + show' : Bit x -> String + show' b0 = "0" + show' b1 = "1" + +infixl 5 # + +data Binary : (width : Nat) -> (value : Nat) -> Type where + zero : Binary Z Z + (#) : Binary w v -> Bit bit -> Binary (S w) (bit + 2 * v) + +instance Show (Binary w k) where + show zero = "" + show (bin # bit) = show bin ++ show bit + +pad : Binary w n -> Binary (S w) n +pad zero = zero # b0 +pad (num # x) = pad num # x + +natToBin : (width : Nat) -> (n : Nat) -> + Maybe (Binary width n) +natToBin Z (S k) = Nothing +natToBin Z Z = Just zero +natToBin (S k) Z = do x <- natToBin k Z + Just (pad x) +natToBin (S w) (S k) with (parity k) + natToBin (S w) (S (plus j j)) | even = do jbin <- natToBin w j + let value = jbin # b1 + ?ntbEven + natToBin (S w) (S (S (plus j j))) | odd = do jbin <- natToBin w (S j) + let value = jbin # b0 + ?ntbOdd + +testBin : Maybe (Binary 8 42) +testBin = natToBin _ _ + +pattern syntax bitpair [x] [y] = (_ ** (_ ** (x, y, _))) +term syntax bitpair [x] [y] = (_ ** (_ ** (x, y, refl))) + +addBit : Bit x -> Bit y -> Bit c -> + (bX ** (bY ** (Bit bX, Bit bY, c + x + y = bY + 2 * bX))) +addBit b0 b0 b0 = bitpair b0 b0 +addBit b0 b0 b1 = bitpair b0 b1 +addBit b0 b1 b0 = bitpair b0 b1 +addBit b0 b1 b1 = bitpair b1 b0 +addBit b1 b0 b0 = bitpair b0 b1 +addBit b1 b0 b1 = bitpair b1 b0 +addBit b1 b1 b0 = bitpair b1 b0 +addBit b1 b1 b1 = bitpair b1 b1 + +adc : Binary w x -> Binary w y -> Bit c -> Binary (S w) (c + x + y) +adc zero zero carry ?= zero # carry +adc (numx # bX) (numy # bY) carry + ?= let (bitpair carry0 lsb) = addBit bX bY carry in + adc numx numy carry0 # lsb + +readNum : IO Nat +readNum = do putStr "Enter a number:" + i <- getLine + let n : Integer = cast i + return (fromInteger n) + +main : IO () +main = do let Just bin1 = natToBin 8 42 + print bin1 + let Just bin2 = natToBin 8 89 + print bin2 + print (adc bin1 bin2 b0) + + + + + + + +---------- Proofs ---------- + +Main.ntbOdd = proof { + intro w,j; + rewrite sym (plusZeroRightNeutral j); + rewrite plusSuccRightSucc j j; + intros; + refine Just; + trivial; +} + +Main.ntbEven = proof { + compute; + intro w,j; + rewrite sym (plusZeroRightNeutral j); + intros; + refine Just; + trivial; +} + +-- There is almost certainly an easier proof. I don't care, for now :) + +Main.adc_lemma_2 = proof { + intro c,w,v,bit0,num0; + intro b0,v1,bit1,num1,b1; + intro bc,x,x1,bX,bX1; + rewrite sym (plusZeroRightNeutral x); + rewrite sym (plusZeroRightNeutral v1); + rewrite sym (plusZeroRightNeutral (plus (plus x v) v1)); + rewrite sym (plusZeroRightNeutral v); + intros; + rewrite sym (plusAssociative (plus c (plus bit0 (plus v v))) bit1 (plus v1 v1)); + rewrite (plusAssociative c (plus bit0 (plus v v)) bit1); + rewrite (plusAssociative bit0 (plus v v) bit1); + rewrite plusCommutative bit1 (plus v v); + rewrite sym (plusAssociative c bit0 (plus bit1 (plus v v))); + rewrite sym (plusAssociative (plus c bit0) bit1 (plus v v)); + rewrite sym b; + rewrite plusAssociative x1 (plus x x) (plus v v); + rewrite plusAssociative x x (plus v v); + rewrite sym (plusAssociative x v v); + rewrite plusCommutative v (plus x v); + rewrite sym (plusAssociative x v (plus x v)); + rewrite (plusAssociative x1 (plus (plus x v) (plus x v)) (plus v1 v1)); + rewrite sym (plusAssociative (plus (plus x v) (plus x v)) v1 v1); + rewrite (plusAssociative (plus x v) (plus x v) v1); + rewrite (plusCommutative v1 (plus x v)); + rewrite sym (plusAssociative (plus x v) v1 (plus x v)); + rewrite (plusAssociative (plus (plus x v) v1) (plus x v) v1); + trivial; +} + +Main.adc_lemma_1 = proof { + intros; + rewrite sym (plusZeroRightNeutral c) ; + trivial; +} + diff --git a/test/test016/expected b/test/test016/expected new file mode 100644 --- /dev/null +++ b/test/test016/expected @@ -0,0 +1,1 @@ +[10, 11, 12, 13, 14, 15, 16, 17, 18, 19] diff --git a/test/test016/run b/test/test016/run new file mode 100644 --- /dev/null +++ b/test/test016/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris $@ test016.idr -o test016 +./test016 +rm -f test016 *.ibc diff --git a/test/test016/test016.idr b/test/test016/test016.idr new file mode 100644 --- /dev/null +++ b/test/test016/test016.idr @@ -0,0 +1,17 @@ +module Main + +%default total + +codata Stream a = Nil | (::) a (Stream a) + +countFrom : Int -> Stream Int +countFrom x = x :: countFrom (x + 1) + +take : Nat -> Stream a -> List a +take Z _ = [] +take (S n) (x :: xs) = x :: take n xs +take n [] = [] + +main : IO () +main = do print (take 10 (Main.countFrom 10)) + diff --git a/test/test017/expected b/test/test017/expected new file mode 100644 --- /dev/null +++ b/test/test017/expected @@ -0,0 +1,2 @@ +test017a.idr:5:scg.vtrans is possibly not total due to recursive path scg.vtrans --> scg.vtrans +test017b.idr:4:foo.foo is possibly not total due to recursive path foo.foo diff --git a/test/test017/run b/test/test017/run new file mode 100644 --- /dev/null +++ b/test/test017/run @@ -0,0 +1,5 @@ +#!/bin/bash +idris $@ --check test017.idr +idris $@ --check test017a.idr +idris $@ --check test017b.idr +rm -f *.ibc diff --git a/test/test017/test017.idr b/test/test017/test017.idr new file mode 100644 --- /dev/null +++ b/test/test017/test017.idr @@ -0,0 +1,96 @@ +module scg + +%default total + +data Ord = Zero | Suc Ord | Sup (Nat -> Ord) + +natElim : (n : Nat) -> (P : Nat -> Type) -> + (P Z) -> ((n : Nat) -> (P n) -> (P (S n))) -> (P n) +natElim Z P mO mS = mO +natElim (S k) P mO mS = mS k (natElim k P mO mS) + +ordElim : (x : Ord) -> + (P : Ord -> Type) -> + (P Zero) -> + ((x : Ord) -> P x -> P (Suc x)) -> + ((f : Nat -> Ord) -> ((n : Nat) -> P (f n)) -> + P (Sup f)) -> P x +ordElim Zero P mZ mSuc mSup = mZ +ordElim (Suc o) P mZ mSuc mSup = mSuc o (ordElim o P mZ mSuc mSup) +ordElim (Sup f) P mZ mSuc mSup = + mSup f (\n => ordElim (f n) P mZ mSuc mSup) + +myplus' : Nat -> Nat -> Nat +myplus : Nat -> Nat -> Nat + +myplus Z y = y +myplus (S k) y = S (myplus' k y) + +myplus' Z y = y +myplus' (S k) y = S (myplus y k) + +mnubBy : (a -> a -> Bool) -> List a -> List a +mnubBy = nubBy' [] + where + nubBy' : List a -> (a -> a -> Bool) -> List a -> List a + nubBy' acc p [] = [] + nubBy' acc p (x::xs) = + if elemBy p x acc then + nubBy' acc p xs + else + x :: nubBy' (x::acc) p xs + +partial +vtrans : Vect n a -> Vect n a -> List a +vtrans [] _ = [] +vtrans (x :: xs) ys = x :: vtrans ys ys + +even : Nat -> Bool +even Z = True +even (S k) = odd k + where + odd : Nat -> Bool + odd Z = False + odd (S k) = even k + +ack : Nat -> Nat -> Nat +ack Z n = S n +ack (S m) Z = ack m (S Z) +ack (S m) (S n) = ack m (ack (S m) n) + +data Bin = eps | c0 Bin | c1 Bin + +foo : Bin -> Nat +foo eps = Z +foo (c0 eps) = Z +foo (c0 (c1 x)) = S (foo (c1 x)) +foo (c0 (c0 x)) = foo (c0 x) +foo (c1 x) = S (foo x) + +bar : Nat -> Nat -> Nat +bar x y = mp x y where + mp : Nat -> Nat -> Nat + mp Z y = y + mp (S k) y = S (bar k y) + +total mfib : Nat -> Nat +mfib Z = Z +mfib (S Z) = S Z +mfib (S (S n)) = mfib (S n) + mfib n + +maxCommutative : (left : Nat) -> (right : Nat) -> + maximum left right = maximum right left +maxCommutative Z Z = refl +maxCommutative (S left) Z = refl +maxCommutative Z (S right) = refl +maxCommutative (S left) (S right) = + let inductiveHypothesis = maxCommutative left right in + ?maxCommutativeStepCase + +maxCommutativeStepCase = proof { + intros; + rewrite (boolElimSuccSucc (lte left right) right left); + rewrite (boolElimSuccSucc (lte right left) left right); + rewrite inductiveHypothesis; + trivial; +} diff --git a/test/test017/test017a.idr b/test/test017/test017a.idr new file mode 100644 --- /dev/null +++ b/test/test017/test017a.idr @@ -0,0 +1,7 @@ +module scg + +total +vtrans : Vect n a -> Vect n a -> List a +vtrans [] _ = [] +vtrans (x :: xs) ys = x :: vtrans ys ys + diff --git a/test/test017/test017b.idr b/test/test017/test017b.idr new file mode 100644 --- /dev/null +++ b/test/test017/test017b.idr @@ -0,0 +1,5 @@ +module foo + +total foo : _|_ +foo = foo + diff --git a/test/test018/expected b/test/test018/expected new file mode 100644 --- /dev/null +++ b/test/test018/expected @@ -0,0 +1,15 @@ +Sending +Hello! +Received +Hello to you too! +Finished +Sending +Hello! +Received +Hello to you too! +Finished +Sending +Hello! +Received +Hello to you too! +Finished diff --git a/test/test018/run b/test/test018/run new file mode 100644 --- /dev/null +++ b/test/test018/run @@ -0,0 +1,6 @@ +#!/bin/bash +idris $@ test018.idr -o test018 +idris $@ test018a.idr -o test018a +./test018 +#./test018a +rm -f test018 test018a *.ibc diff --git a/test/test018/test018.idr b/test/test018/test018.idr new file mode 100644 --- /dev/null +++ b/test/test018/test018.idr @@ -0,0 +1,31 @@ +module Main + +import System +import System.Concurrency.Raw + +recvMsg : IO (Ptr, String) +recvMsg = getMsg + +pong : IO () +pong = do -- putStrLn "Waiting for ping" + (sender, x) <- recvMsg + putStrLn x + putStrLn "Received" + sendToThread sender "Hello to you too!" + +ping : Ptr -> IO () +ping thread = sendToThread thread (prim__vm, "Hello!") + +pingpong : IO () +pingpong + = do th <- fork pong + putStrLn "Sending" + ping th + reply <- getMsg + putStrLn reply + usleep 100000 + putStrLn "Finished" + +main : IO () +main = do pingpong; pingpong; pingpong + diff --git a/test/test018/test018a.idr b/test/test018/test018a.idr new file mode 100644 --- /dev/null +++ b/test/test018/test018a.idr @@ -0,0 +1,35 @@ +module Main + +import System.Concurrency.Process + +ping : ProcID String -> ProcID String -> Process String () +ping main proc + = do lift (usleep 1000) + send proc "Hello!" + lift (putStrLn "Sent ping") + msg <- recv + lift (putStrLn ("Reply: " ++ show msg)) + send main "Done" + +pong : Process String () +pong = do -- lift (putStrLn "Waiting for message") + (sender, m) <- recvWithSender + lift $ putStrLn ("Received " ++ m) + send sender ("Hello back!") + +mainProc : Process String () +mainProc = do mainID <- myID + pongth <- create pong + pingth <- create (ping mainID pongth) + recv -- block until everything done + return () + +repeatIO : Int -> IO () +repeatIO 0 = return () +repeatIO n = do print n + run mainProc + repeatIO (n - 1) + +main : IO () +main = repeatIO 100 + diff --git a/test/test019/expected b/test/test019/expected new file mode 100644 --- /dev/null +++ b/test/test019/expected @@ -0,0 +1,1 @@ +1 diff --git a/test/test019/run b/test/test019/run new file mode 100644 --- /dev/null +++ b/test/test019/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris $@ test019.lidr -o test019 +./test019 +rm -f test019 *.ibc diff --git a/test/test019/test019.lidr b/test/test019/test019.lidr new file mode 100644 --- /dev/null +++ b/test/test019/test019.lidr @@ -0,0 +1,16 @@ +> module Main + +> ifTrue : so True -> Nat +> ifTrue oh = S Z + +> ifFalse : so False -> Nat +> ifFalse oh impossible + +> test : (f : Nat -> Bool) -> (n : Nat) -> so (f n) -> Nat +> test f n x with (f n) +> | True = ifTrue x +> | False = ifFalse x + +> main : IO () +> main = print (test ((S 4) ==) 5 oh) + diff --git a/test/test020/expected b/test/test020/expected new file mode 100644 --- /dev/null +++ b/test/test020/expected @@ -0,0 +1,6 @@ +test020a.idr:16:Can't unify Vect n a with List a + +Specifically: + Can't unify Vect n a with List a +[3, 2, 1] +Number 42 diff --git a/test/test020/run b/test/test020/run new file mode 100644 --- /dev/null +++ b/test/test020/run @@ -0,0 +1,5 @@ +#!/bin/bash +idris $@ test020.idr -o test020 +idris $@ test020a.idr --check +./test020 +rm -f test020 *.ibc diff --git a/test/test020/test020.idr b/test/test020/test020.idr new file mode 100644 --- /dev/null +++ b/test/test020/test020.idr @@ -0,0 +1,25 @@ +module Main + +implicit +natInt : Nat -> Integer +natInt x = cast x + +implicit +forget : Vect n a -> List a +forget [] = [] +forget (x :: xs) = x :: forget xs + +foo : Vect n a -> List a +foo xs = reverse xs + +implicit intString : Integer -> String +intString = show + +test : Integer -> String +test x = "Number " ++ x + +main : IO () +main = do print (foo [1,2,3]) + print (test 42) + + diff --git a/test/test020/test020a.idr b/test/test020/test020a.idr new file mode 100644 --- /dev/null +++ b/test/test020/test020a.idr @@ -0,0 +1,18 @@ +module Main + +implicit +forget : Vect n a -> List a +forget [] = [] +forget (x :: xs) = x :: forget xs + +implicit +forget' : Vect n a -> List a +forget' [] = [] +forget' (x :: xs) = forget xs + +foo : Vect n a -> List a +foo xs = reverse xs + +main : IO () +main = print (foo [1,2,3]) + diff --git a/test/test021/expected b/test/test021/expected new file mode 100644 --- /dev/null +++ b/test/test021/expected @@ -0,0 +1,6 @@ +[HELLO!!! +, WORLD!!! +, ] +3 +15 +Answer: 99 diff --git a/test/test021/run b/test/test021/run new file mode 100644 --- /dev/null +++ b/test/test021/run @@ -0,0 +1,6 @@ +#!/bin/bash +idris -p effects $@ test021.idr -o test021 +idris -p effects $@ test021a.idr -o test021a +./test021 +./test021a +rm -f test021 test021a *.ibc diff --git a/test/test021/test021.idr b/test/test021/test021.idr new file mode 100644 --- /dev/null +++ b/test/test021/test021.idr @@ -0,0 +1,38 @@ +module Main + +import Effect.File +import Effect.State +import Effect.StdIO +import Control.IOExcept + +data FName = Count | NotCount + +FileIO : Type -> Type -> Type +FileIO st t + = Eff (IOExcept String) [FILE_IO st, STDIO, Count ::: STATE Int] t + +readFile : FileIO (OpenFile Read) (List String) +readFile = readAcc [] where + readAcc : List String -> FileIO (OpenFile Read) (List String) + readAcc acc = do e <- eof + if (not e) + then do str <- readLine + ls <- Count :- get + Count :- put (ls + 1) + readAcc (str :: acc) + else return (reverse acc) + +testFile : FileIO () () +testFile = catch (do open "testFile" Read + str <- readFile + putStrLn (show str) + ls <- Count :- get + close + putStrLn (show ls)) + (\err => putStrLn ("Handled: " ++ show err)) + +main : IO () +main = do ioe_run (run [(), (), Count := 0] testFile) + (\err => print err) (\ok => return ()) + + diff --git a/test/test021/test021a.idr b/test/test021/test021a.idr new file mode 100644 --- /dev/null +++ b/test/test021/test021a.idr @@ -0,0 +1,42 @@ +module Main + +import Effect.State +import Effect.Exception +import Effect.Random +import Effect.StdIO + +data Expr = Var String + | Val Integer + | Add Expr Expr + | Random Integer + +Env : Type +Env = List (String, Integer) + +-- Evaluator : Type -> Type +-- Evaluator t +-- = Eff m [EXCEPTION String, RND, STATE Env] t + +eval : Expr -> Eff IO [EXCEPTION String, STDIO, RND, STATE Env] Integer +eval (Var x) = do vs <- get + case lookup x vs of + Nothing => raise ("No such variable " ++ x) + Just val => return val +eval (Val x) = return x +eval (Add l r) = [| eval l + eval r |] +eval (Random upper) = do val <- rndInt 0 upper + putStrLn (show val) + return val + +testExpr : Expr +testExpr = Add (Add (Var "foo") (Val 42)) (Random 100) + +runEval : List (String, Integer) -> Expr -> IO Integer +runEval args expr = run [(), (), 123456, args] (eval expr) + +main : IO () +main = do let x = 42 + val <- runEval [("foo", x)] testExpr + putStrLn $ "Answer: " ++ show val + + diff --git a/test/test021/testFile b/test/test021/testFile new file mode 100644 --- /dev/null +++ b/test/test021/testFile @@ -0,0 +1,2 @@ +HELLO!!! +WORLD!!! diff --git a/test/test022/expected b/test/test022/expected new file mode 100644 --- /dev/null +++ b/test/test022/expected @@ -0,0 +1,2 @@ +Type checking ./test022.idr +0.9995736030415051 : Float diff --git a/test/test022/run b/test/test022/run new file mode 100644 --- /dev/null +++ b/test/test022/run @@ -0,0 +1,3 @@ +#!/bin/bash +echo ":x x" | idris --quiet test022.idr +rm -f test021 test021a *.ibc diff --git a/test/test022/test022.idr b/test/test022/test022.idr new file mode 100644 --- /dev/null +++ b/test/test022/test022.idr @@ -0,0 +1,6 @@ +module Main + +%dynamic "dummy", "libm", "msvcrt" + +x : Float +x = unsafePerformIO (mkForeign (FFun "sin" [FFloat] FFloat) 1.6) diff --git a/test/test023/expected b/test/test023/expected new file mode 100644 --- /dev/null +++ b/test/test023/expected @@ -0,0 +1,1 @@ +Type provider error: Always fails diff --git a/test/test023/run b/test/test023/run new file mode 100644 --- /dev/null +++ b/test/test023/run @@ -0,0 +1,3 @@ +#!/bin/bash +idris --quiet test023.idr -o test023 +rm -f test023 *.ibc diff --git a/test/test023/test023.idr b/test/test023/test023.idr new file mode 100644 --- /dev/null +++ b/test/test023/test023.idr @@ -0,0 +1,23 @@ +module Main + +-- Simple test case for trivial type providers. + +import Providers + +%language TypeProviders + +-- Provide the Unit type +goodProvider : IO (Provider Type) +goodProvider = return (Provide (the Type ())) + +%provide (Unit : Type) with goodProvider + +foo : Unit +foo = () + +-- Always fail +badProvider : IO (Provider Type) +badProvider = return (Error "Always fails") + +%provide (t : Type) with badProvider + diff --git a/test/test024/expected b/test/test024/expected new file mode 100644 --- /dev/null +++ b/test/test024/expected @@ -0,0 +1,3 @@ +Type checking ./test024.idr +testtest +() : () diff --git a/test/test024/input b/test/test024/input new file mode 100644 --- /dev/null +++ b/test/test024/input @@ -0,0 +1,2 @@ +:x unsafePerformIO main +test diff --git a/test/test024/run b/test/test024/run new file mode 100644 --- /dev/null +++ b/test/test024/run @@ -0,0 +1,3 @@ +#!/bin/bash +idris --quiet test024.idr < input +rm -f *.ibc diff --git a/test/test024/test024.idr b/test/test024/test024.idr new file mode 100644 --- /dev/null +++ b/test/test024/test024.idr @@ -0,0 +1,6 @@ +module Main + +main : IO () +main = do l <- getLine + let ll = l ++ l + putStrLn ll diff --git a/test/test025/expected b/test/test025/expected new file mode 100644 --- /dev/null +++ b/test/test025/expected @@ -0,0 +1,1 @@ +[1, 2, 3, 4] diff --git a/test/test025/run b/test/test025/run new file mode 100644 --- /dev/null +++ b/test/test025/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris -p effects $@ test025.idr -o test025 +./test025 +rm -f test025 *.ibc diff --git a/test/test025/test025.idr b/test/test025/test025.idr new file mode 100644 --- /dev/null +++ b/test/test025/test025.idr @@ -0,0 +1,34 @@ +module Main + +import Effects +import Effect.Memory +import Control.IOExcept + +MemoryIO : Type -> Type -> Type -> Type +MemoryIO td ts r = Eff (IOExcept String) [ Dst ::: RAW_MEMORY td + , Src ::: RAW_MEMORY ts ] r + +inpVect : Vect 5 Bits8 +inpVect = map prim__truncInt_B8 [0, 1, 2, 3, 5] + +sub1 : Vect n Bits8 -> Vect n Bits8 +sub1 xs = map (prim__truncInt_B8 . (\ x => x - 1) . prim__zextB8_Int) xs + +testMemory : MemoryIO () () (Vect 4 Int) +testMemory = do Src :- allocate 5 + Src :- poke 0 inpVect oh + Dst :- allocate 5 + Dst :- initialize (prim__truncInt_B8 1) 2 oh + move 2 2 3 oh oh + Src :- free + end <- Dst :- peek 4 (S Z) oh + Dst :- poke 4 (sub1 end) oh + res <- Dst :- peek 1 (S(S(S(S Z)))) oh + Dst :- free + return (map (prim__zextB8_Int) res) + +main : IO () +main = do ioe_run (run [Dst := (), Src := ()] testMemory) + (\err => print err) (\ok => print ok) + + diff --git a/test/test026/expected b/test/test026/expected new file mode 100644 --- /dev/null +++ b/test/test026/expected @@ -0,0 +1,3 @@ +Type checking ./test026.idr +2 : Int +2 : Nat diff --git a/test/test026/input b/test/test026/input new file mode 100644 --- /dev/null +++ b/test/test026/input @@ -0,0 +1,2 @@ +foo +bar diff --git a/test/test026/run b/test/test026/run new file mode 100644 --- /dev/null +++ b/test/test026/run @@ -0,0 +1,3 @@ +#!/bin/bash +idris --quiet test026.idr < input +rm -f *.ibc diff --git a/test/test026/test026.idr b/test/test026/test026.idr new file mode 100644 --- /dev/null +++ b/test/test026/test026.idr @@ -0,0 +1,26 @@ +module Main + +-- Simple test case for trivial type providers. + +import Providers + +%language TypeProviders + +strToType : String -> Type +strToType "Int" = Int +strToType _ = Nat + +-- If the file contains "Int", provide Int as a type, otherwise provide Nat +fromFile : String -> IO (Provider Type) +fromFile fname = do str <- readFile fname + return (Provide (strToType (trim str))) + +%provide (T1 : Type) with fromFile "theType" +%provide (T2 : Type) with fromFile "theOtherType" + +foo : T1 +foo = 2 + +bar : T2 +bar = 2 + diff --git a/test/test026/theOtherType b/test/test026/theOtherType new file mode 100644 --- /dev/null +++ b/test/test026/theOtherType @@ -0,0 +1,1 @@ +Nat diff --git a/test/test026/theType b/test/test026/theType new file mode 100644 --- /dev/null +++ b/test/test026/theType @@ -0,0 +1,1 @@ +Int diff --git a/test/test027/expected b/test/test027/expected new file mode 100644 --- /dev/null +++ b/test/test027/expected @@ -0,0 +1,3 @@ +[1, 1, 3, 5, 5, 8, 9] +55 +3628800 diff --git a/test/test027/run b/test/test027/run new file mode 100644 --- /dev/null +++ b/test/test027/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris $@ test027.idr -o test027 +./test027 +rm -f test027 *.ibc diff --git a/test/test027/test027.idr b/test/test027/test027.idr new file mode 100644 --- /dev/null +++ b/test/test027/test027.idr @@ -0,0 +1,25 @@ +module Main + +using (Ord a, Num n) + + isort : List a -> List a + isort [] = [] + isort (x :: xs) = insert x (isort xs) + where -- insert : a -> List a -> List a + insert x [] = [x] + insert x (y :: ys) = if x < y then x :: y :: ys + else y :: insert x ys + + msum : Num n => List n -> n + msum [] = 0 + msum (x :: xs) = x + msum xs + + mprod : List n -> n + mprod [] = 1 + mprod (x :: xs) = x * mprod xs + +main : IO () +main = do print $ isort [1,5,3,5,1,9,8] + print $ msum [1..10] + print $ mprod [1..10] + diff --git a/test/test028/expected b/test/test028/expected new file mode 100644 --- /dev/null +++ b/test/test028/expected @@ -0,0 +1,1 @@ +hello, world! diff --git a/test/test028/run b/test/test028/run new file mode 100644 --- /dev/null +++ b/test/test028/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris $@ test028.idr -o test028 +./test028 +rm -f test028 test028.ibc diff --git a/test/test028/test028.idr b/test/test028/test028.idr new file mode 100644 --- /dev/null +++ b/test/test028/test028.idr @@ -0,0 +1,5 @@ +{--} +module Main +-- +main : IO () +main = print "hello, world!" diff --git a/tutorial/examples/binary.idr b/tutorial/examples/binary.idr --- a/tutorial/examples/binary.idr +++ b/tutorial/examples/binary.idr @@ -1,7 +1,7 @@ module Main data Binary : Nat -> Type where - bEnd : Binary O + bEnd : Binary Z bO : Binary n -> Binary (n + n) bI : Binary n -> Binary (S (n + n)) @@ -15,21 +15,21 @@ odd : Parity (S (n + n)) parity : (n:Nat) -> Parity n -parity O = even {n=O} -parity (S O) = odd {n=O} +parity Z = even {n=Z} +parity (S Z) = odd {n=Z} parity (S (S k)) with (parity k) parity (S (S (j + j))) | even ?= even {n=S j} parity (S (S (S (j + j)))) | odd ?= odd {n=S j} natToBin : (n:Nat) -> Binary n -natToBin O = bEnd +natToBin Z = bEnd natToBin (S k) with (parity k) natToBin (S (j + j)) | even = bI (natToBin j) natToBin (S (S (j + j))) | odd ?= bO (natToBin (S j)) intToNat : Int -> Nat -intToNat 0 = O -intToNat x = if (x>0) then (S (intToNat (x-1))) else O +intToNat 0 = Z +intToNat x = if (x>0) then (S (intToNat (x-1))) else Z main : IO () main = do putStr "Enter a number: " diff --git a/tutorial/examples/idiom.idr b/tutorial/examples/idiom.idr --- a/tutorial/examples/idiom.idr +++ b/tutorial/examples/idiom.idr @@ -14,7 +14,7 @@ fetchVal ((v, val) :: xs) = if (x == v) then (Just val) else (fetchVal xs) instance Functor Eval where - fmap f (MkEval g) = MkEval (\e => fmap f (g e)) + map f (MkEval g) = MkEval (\e => map f (g e)) instance Applicative Eval where pure x = MkEval (\e => Just x) diff --git a/tutorial/examples/interp.idr b/tutorial/examples/interp.idr --- a/tutorial/examples/interp.idr +++ b/tutorial/examples/interp.idr @@ -7,21 +7,21 @@ interpTy TyBool = Bool interpTy (TyFun s t) = interpTy s -> interpTy t -using (G : Vect Ty n) +using (G : Vect n Ty) - data Env : Vect Ty n -> Type where + data Env : Vect n Ty -> Type where Nil : Env Nil (::) : interpTy a -> Env G -> Env (a :: G) - data HasType : (i : Fin n) -> Vect Ty n -> Ty -> Type where - stop : HasType fO (t :: G) t + data HasType : (i : Fin n) -> Vect n Ty -> Ty -> Type where + stop : HasType fZ (t :: G) t pop : HasType k G t -> HasType (fS k) (u :: G) t lookup : HasType i G t -> Env G -> interpTy t lookup stop (x :: xs) = x lookup (pop k) (x :: xs) = lookup k xs - data Expr : Vect Ty n -> Ty -> Type where + data Expr : Vect n Ty -> Ty -> Type where Var : HasType i G t -> Expr G t Val : (x : Int) -> Expr G TyInt Lam : Expr (a :: G) t -> Expr G (TyFun a t) diff --git a/tutorial/examples/theorems.idr b/tutorial/examples/theorems.idr --- a/tutorial/examples/theorems.idr +++ b/tutorial/examples/theorems.idr @@ -5,15 +5,15 @@ twoPlusTwo : 2 + 2 = 4 twoPlusTwo = refl -total disjoint : (n : Nat) -> O = S n -> _|_ +total disjoint : (n : Nat) -> Z = S n -> _|_ disjoint n p = replace {P = disjointTy} p () where disjointTy : Nat -> Type - disjointTy O = () + disjointTy Z = () disjointTy (S k) = _|_ total acyclic : (n : Nat) -> n = S n -> _|_ -acyclic O p = disjoint _ p +acyclic Z p = disjoint _ p acyclic (S k) p = acyclic k (succInjective _ _ p) empty1 : _|_ @@ -24,33 +24,33 @@ empty2 : _|_ empty2 = empty2 -plusReduces : (n:Nat) -> plus O n = n +plusReduces : (n:Nat) -> plus Z n = n plusReduces n = refl -plusReducesO : (n:Nat) -> n = plus n O -plusReducesO O = refl -plusReducesO (S k) = cong (plusReducesO k) +plusReducesZ : (n:Nat) -> n = plus n Z +plusReducesZ Z = refl +plusReducesZ (S k) = cong (plusReducesZ k) plusReducesS : (n:Nat) -> (m:Nat) -> S (plus n m) = plus n (S m) -plusReducesS O m = refl +plusReducesS Z m = refl plusReducesS (S k) m = cong (plusReducesS k m) -plusReducesO' : (n:Nat) -> n = plus n O -plusReducesO' O = ?plusredO_O -plusReducesO' (S k) = let ih = plusReducesO' k in - ?plusredO_S +plusReducesZ' : (n:Nat) -> n = plus n Z +plusReducesZ' Z = ?plusredZ_Z +plusReducesZ' (S k) = let ih = plusReducesZ' k in + ?plusredZ_S ---------- Proofs ---------- -plusredO_S = proof { +plusredZ_S = proof { intro; intro; rewrite ih; trivial; } -plusredO_O = proof { +plusredZ_Z = proof { compute; trivial; } diff --git a/tutorial/examples/usefultypes.idr b/tutorial/examples/usefultypes.idr --- a/tutorial/examples/usefultypes.idr +++ b/tutorial/examples/usefultypes.idr @@ -1,16 +1,16 @@ -intVec : Vect Int 5 +intVec : Vect 5 Int intVec = [1, 2, 3, 4, 5] double : Int -> Int double x = x * 2 -vec : (n ** Vect Int n) +vec : (n ** Vect n Int) vec = (_ ** [3, 4]) list_lookup : Nat -> List a -> Maybe a list_lookup _ Nil = Nothing -list_lookup O (x :: xs) = Just x +list_lookup Z (x :: xs) = Just x list_lookup (S k) (x :: xs) = list_lookup k xs lookup_default : Nat -> List a -> a -> a diff --git a/tutorial/examples/vbroken.idr b/tutorial/examples/vbroken.idr --- a/tutorial/examples/vbroken.idr +++ b/tutorial/examples/vbroken.idr @@ -1,4 +1,4 @@ -vapp : Vect a n -> Vect a m -> Vect a (n + m) +vapp : Vect n a -> Vect m a -> Vect (n + m) a vapp Nil ys = ys vapp (x :: xs) ys = x :: vapp xs xs -- BROKEN diff --git a/tutorial/examples/views.idr b/tutorial/examples/views.idr --- a/tutorial/examples/views.idr +++ b/tutorial/examples/views.idr @@ -5,14 +5,14 @@ odd : Parity (S (n + n)) parity : (n:Nat) -> Parity n -parity O = even {n=O} -parity (S O) = odd {n=O} +parity Z = even {n=Z} +parity (S Z) = odd {n=Z} parity (S (S k)) with (parity k) parity (S (S (j + j))) | even ?= even {n=S j} parity (S (S (S (j + j)))) | odd ?= odd {n=S j} natToBin : Nat -> List Bool -natToBin O = Nil +natToBin Z = Nil natToBin k with (parity k) natToBin (j + j) | even = False :: natToBin j natToBin (S (j + j)) | odd = True :: natToBin j diff --git a/tutorial/examples/wheres.idr b/tutorial/examples/wheres.idr --- a/tutorial/examples/wheres.idr +++ b/tutorial/examples/wheres.idr @@ -1,13 +1,13 @@ module wheres even : Nat -> Bool -even O = True +even Z = True even (S k) = odd k where - odd O = False + odd Z = False odd (S k) = even k test : List Nat -test = [c (S 1), c O, d (S O)] +test = [c (S 1), c Z, d (S Z)] where c x = 42 + x d y = c (y + 1 + z y) where z w = y + w