packages feed

idris 0.9.8 → 0.9.9

raw patch · 278 files changed

+9041/−4125 lines, 278 filesdep +llvm-generaldep +vectordep +vector-binary-instancessetup-changed

Dependencies added: llvm-general, vector, vector-binary-instances

Files

+ Makefile view
@@ -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)
Setup.hs view
@@ -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)         }
config.mk view
@@ -2,8 +2,6 @@ CC              :=gcc CABAL           :=cabal #CABALFLAGS	:=-## Enable Java RTS:-#CABALFLAGS    :=-f Java ## Disable building of Effects #CABALFLAGS :=-f NoEffects
effects/Effect/Memory.idr view
@@ -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
effects/Effects.idr view
@@ -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
idris.cabal view
@@ -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
+ java/executable_pom.xml view
@@ -0,0 +1,66 @@+<project xmlns="http://maven.apache.org/POM/4.0.0" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"+  xsi:schemaLocation="http://maven.apache.org/POM/4.0.0 http://maven.apache.org/maven-v4_0_0.xsd">+  <modelVersion>4.0.0</modelVersion>+  <groupId>org.idris-lang</groupId>+  <artifactId>$ARTIFACT-NAME$</artifactId>+  <packaging>jar</packaging>+  <version>1.0</version>+  <name>$ARTIFACT-NAME$</name>++  <properties>+    <project.build.sourceEncoding>UTF-8</project.build.sourceEncoding>+    <skipTests>true</skipTests>+  </properties>+  <dependencies>+    <dependency>+      <groupId>org.idris-lang</groupId>+    	<artifactId>idris</artifactId>+    	<version>0.9.9</version>+    </dependency>+$DEPENDENCIES$+  </dependencies>+++  <build>+    <finalName>$ARTIFACT-NAME$</finalName>+    <plugins>+      <plugin>+        <groupId>org.apache.maven.plugins</groupId>+        <artifactId>maven-compiler-plugin</artifactId>+        <version>3.0</version>+        <configuration>+          <source>1.7</source>+          <target>1.7</target>+        </configuration>+      </plugin>+      <plugin>+        <groupId>org.apache.maven.plugins</groupId>+          <artifactId>maven-surefire-plugin</artifactId>+          <version>2.14</version>+          <configuration>+            <skipTests>${skipTests}</skipTests>+          </configuration>+      </plugin>+      <plugin>+        <groupId>org.apache.maven.plugins</groupId>+        <artifactId>maven-shade-plugin</artifactId>+        <version>2.0</version>+        <executions>+          <execution>+            <phase>package</phase>+            <goals>+              <goal>shade</goal>+            </goals>+            <configuration>+              <transformers>+                <transformer implementation="org.apache.maven.plugins.shade.resource.ManifestResourceTransformer">+                  <mainClass>$MAIN-CLASS$</mainClass>+                </transformer>+              </transformers>+            </configuration>+          </execution>+        </executions>+      </plugin>+    </plugins>+  </build>+</project>
+ java/executable_pom_template.xml view
@@ -0,0 +1,66 @@+<project xmlns="http://maven.apache.org/POM/4.0.0" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"+  xsi:schemaLocation="http://maven.apache.org/POM/4.0.0 http://maven.apache.org/maven-v4_0_0.xsd">+  <modelVersion>4.0.0</modelVersion>+  <groupId>org.idris-lang</groupId>+  <artifactId>$ARTIFACT-NAME$</artifactId>+  <packaging>jar</packaging>+  <version>1.0</version>+  <name>$ARTIFACT-NAME$</name>++  <properties>+    <project.build.sourceEncoding>UTF-8</project.build.sourceEncoding>+    <skipTests>true</skipTests>+  </properties>+  <dependencies>+    <dependency>+      <groupId>org.idris-lang</groupId>+    	<artifactId>idris</artifactId>+    	<version>$RTS-VERSION$</version>+    </dependency>+$DEPENDENCIES$+  </dependencies>+++  <build>+    <finalName>$ARTIFACT-NAME$</finalName>+    <plugins>+      <plugin>+        <groupId>org.apache.maven.plugins</groupId>+        <artifactId>maven-compiler-plugin</artifactId>+        <version>3.0</version>+        <configuration>+          <source>1.7</source>+          <target>1.7</target>+        </configuration>+      </plugin>+      <plugin>+        <groupId>org.apache.maven.plugins</groupId>+          <artifactId>maven-surefire-plugin</artifactId>+          <version>2.14</version>+          <configuration>+            <skipTests>${skipTests}</skipTests>+          </configuration>+      </plugin>+      <plugin>+        <groupId>org.apache.maven.plugins</groupId>+        <artifactId>maven-shade-plugin</artifactId>+        <version>2.0</version>+        <executions>+          <execution>+            <phase>package</phase>+            <goals>+              <goal>shade</goal>+            </goals>+            <configuration>+              <transformers>+                <transformer implementation="org.apache.maven.plugins.shade.resource.ManifestResourceTransformer">+                  <mainClass>$MAIN-CLASS$</mainClass>+                </transformer>+              </transformers>+            </configuration>+          </execution>+        </executions>+      </plugin>+    </plugins>+  </build>+</project>
− java/src/main/java/org/idris/rts/Closure.java 
@@ -1,17 +0,0 @@-package org.idris.rts;--import java.util.concurrent.Callable;--public abstract class Closure implements Callable<Object>, Runnable {-    protected final Object [] context;--    protected Closure(final Object ... context) {-	this.context = context;-    }--    public void run() {-	call();-    }--    public abstract Object call();-}
− java/src/main/java/org/idris/rts/ForeignPrimitives.java 
@@ -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<Thread, List<String>> args = new HashMap<>();-    private static final Semaphore messageMutex = new Semaphore(1);-    private static final Map<Thread, BlockingQueue<Object>> messages = new HashMap<>();-    private static final Set<Object> 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<String> argsForThread = ForeignPrimitives.args.get((Thread) thread);-        return (argsForThread == null ? 0 : argsForThread.size());-    }--    public static synchronized String idris_getArg(Object thread, int num) {-        List<String> 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<Object> 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<Object> 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<Object> 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);-    }-}
− java/src/main/java/org/idris/rts/IdrisObject.java 
@@ -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;-    }-}
− java/src/main/java/org/idris/rts/TailCallClosure.java 
@@ -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;-    }-}-
+ javascript/JavaScript.idr view
@@ -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)
+ javascript/JavaScript/JSON.idr view
@@ -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)
+ javascript/Makefile view
@@ -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:
+ javascript/javascript.ipkg view
@@ -0,0 +1,5 @@+package javascript++opts    = "-i ../lib"+modules = JavaScript, JavaScript.JSON+
js/Runtime-browser.js view
@@ -1,3 +1,3 @@-__IDRRT__.print = function(s) {+var __IDRRT__print = function(s) {   console.log(s); };
js/Runtime-common.js view
@@ -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__ = {};
js/Runtime-node.js view
@@ -1,4 +1,4 @@-__IDRRT__.print = (function() {+var __IDRRT__print = (function() {   var util = require('util');   return function(s) {     util.print(s);
lib/Builtins.idr view
@@ -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
lib/Control/IOExcept.idr view
@@ -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
lib/Control/Monad/Identity.idr view
@@ -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
lib/Control/Monad/State.idr view
@@ -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')
lib/Data/Bits.idr view
@@ -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
lib/Data/BoundedList.idr view
@@ -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
+ lib/Data/HVect.idr view
@@ -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+
lib/Data/Mod2.idr view
@@ -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))
lib/Data/Morphisms.idr view
@@ -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
lib/Data/SortedMap.idr view
@@ -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)
+ lib/Data/Vect.idr view
@@ -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)+
lib/Data/Vect/Quantifiers.idr view
@@ -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)
− lib/Data/Z.idr 
@@ -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-
+ lib/Data/ZZ.idr view
@@ -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+
lib/Decidable/Decidable.idr view
@@ -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)-+-}
lib/Decidable/Equality.idr view
@@ -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)
lib/Decidable/Order.idr view
@@ -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++-}+
− lib/Effects.idr 
@@ -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 ()-
lib/IO.idr view
@@ -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)
lib/Language/Reflection.idr view
@@ -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)
lib/Network/Cgi.idr view
@@ -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 ()
lib/Prelude.idr view
@@ -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
lib/Prelude/Applicative.idr view
@@ -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 ()
lib/Prelude/Fin.idr view
@@ -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+
lib/Prelude/Functor.idr view
@@ -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
lib/Prelude/Heap.idr view
@@ -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
lib/Prelude/List.idr view
@@ -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 =
lib/Prelude/Monad.idr view
@@ -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
lib/Prelude/Nat.idr view
@@ -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; }
lib/Prelude/Strings.idr view
@@ -116,5 +116,4 @@ unwords = pack . unwords' . map unpack  length : String -> Nat-length = fromInteger . prim_lenString-+length = fromInteger . prim__zextInt_BigInt . prim_lenString
lib/Prelude/Vect.idr view
@@ -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
lib/System/Concurrency/Process.idr view
@@ -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)
lib/Uninhabited.idr view
@@ -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
lib/base.ipkg view
@@ -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,
+ llvm/Makefile view
@@ -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:
+ llvm/defs.c view
@@ -0,0 +1,160 @@+#include <stdio.h>+#include <gmp.h>+#include <gc.h>+#include <string.h>+#include <inttypes.h>++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;+}
rts/idris_bitstring.h view
@@ -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);
rts/idris_gmp.c view
@@ -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)); }
rts/idris_gmp.h view
@@ -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);
− rts/libidris_rts.a

binary file changed (64872 → absent bytes)

src/Core/CaseTree.hs view
@@ -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]
src/Core/CoreParser.hs view
@@ -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 () }
src/Core/Elaborate.hs view
@@ -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.
src/Core/Evaluate.hs view
@@ -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' }
src/Core/Execute.hs view
@@ -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
src/Core/ProofState.hs view
@@ -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
src/Core/TT.hs view
@@ -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)
src/Core/Typecheck.hs view
@@ -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
src/Core/Unify.hs view
@@ -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))
src/IRTS/CodegenC.hs view
@@ -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 ++ ")))"
src/IRTS/CodegenCommon.hs view
@@ -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
src/IRTS/CodegenJava.hs view
@@ -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 $ "<dependency>\n"-          , T.append (T.pack "  ") $ mkGroupId g-          , T.append (T.pack "  ") $ mkArtifactId a-          , T.append (T.pack "  ") $ mkVersion v-          , T.pack $ "</dependency>\n"-          ]-        _     -> []-    mkGroupId g    = T.append (T.pack $ "<groupId>")    (T.append g $ T.pack "</groupId>\n")-    mkArtifactId a = T.append (T.pack $ "<artifactId>") (T.append a $ T.pack "</artifactId>\n")-    mkVersion v    = T.append (T.pack $ "<version>")    (T.append v $ T.pack "</version>\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 $ "<dependency>\n"+          , T.append (T.pack "  ") $ mkGroupId g+          , T.append (T.pack "  ") $ mkArtifactId a+          , T.append (T.pack "  ") $ mkVersion v+          , T.pack $ "</dependency>\n"+          ]+        _     -> []+    mkGroupId g    = T.append (T.pack $ "<groupId>")    (T.append g $ T.pack "</groupId>\n")+    mkArtifactId a = T.append (T.pack $ "<artifactId>") (T.append a $ T.pack "</artifactId>\n")+    mkVersion v    = T.append (T.pack $ "<version>")    (T.append v $ T.pack "</version>\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]++
src/IRTS/CodegenJavaScript.hs view
@@ -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)
+ src/IRTS/CodegenLLVM.hs view
@@ -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
src/IRTS/Compiler.hs view
@@ -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
src/IRTS/Defunctionalise.hs view
@@ -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
+ src/IRTS/Java/ASTBuilding.hs view
@@ -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
+ src/IRTS/Java/JTypes.hs view
@@ -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++
+ src/IRTS/Java/Mangling.hs view
@@ -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
src/IRTS/LParser.hs view
@@ -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
src/IRTS/Lang.hs view
@@ -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
src/Idris/AbsSyntax.hs view
@@ -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
src/Idris/AbsSyntaxTree.hs view
@@ -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 _               = []
src/Idris/Completion.hs view
@@ -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
src/Idris/Coverage.hs view
@@ -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 <a> 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 <a>, 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
src/Idris/DSL.hs view
@@ -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
src/Idris/Delaborate.hs view
@@ -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 ("
src/Idris/ElabDecls.hs view
@@ -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
src/Idris/ElabTerm.hs view
@@ -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")
src/Idris/IBC.hs view
@@ -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"+
src/Idris/IdeSlave.hs view
@@ -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
src/Idris/Parser.hs view
@@ -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
+ src/Idris/PartialEval.hs view
@@ -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)
src/Idris/Primitives.hs view
@@ -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-
src/Idris/Prover.hs view
@@ -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'
src/Idris/Providers.hs view
@@ -3,7 +3,6 @@  import Core.TT import Core.Evaluate-import Core.Execute import Idris.AbsSyntax import Idris.AbsSyntaxTree import Idris.Error
src/Idris/REPL.hs view
@@ -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
src/Idris/Transforms.hs view
@@ -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
src/Main.hs view
@@ -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"
src/Pkg/Package.hs view
@@ -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
src/Util/DynamicLinker.hs view
@@ -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
+ src/Util/LLVMStubs.hs view
@@ -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."
src/Util/System.hs view
@@ -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)
+ test/Makefile view
@@ -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
+ test/reg001/expected view
+ test/reg001/reg001.idr view
@@ -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)
+ test/reg001/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris reg001.idr --check+rm -rf reg001.ibc+
+ test/reg002/expected view
@@ -0,0 +1,1 @@+[2, 1, 4, 3, 5]
+ test/reg002/reg002.idr view
@@ -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])
+ test/reg002/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris reg002.idr -o reg002+./reg002+rm -f reg002 *.ibc
+ test/reg003/expected view
@@ -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
+ test/reg003/reg003.idr view
@@ -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]
+ test/reg003/reg003a.idr view
@@ -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 
+ test/reg003/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris --check reg003.idr +idris --check reg003a.idr +rm -f *.ibc
+ test/reg004/expected view
@@ -0,0 +1,2 @@+0+1
+ test/reg004/reg004.idr view
@@ -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)
+ test/reg004/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris reg004.idr -o reg004+./reg004+rm -f reg004 *.ibc
+ test/reg005/expected view
@@ -0,0 +1,1 @@+1f4o1b4a1r1b3a1z
+ test/reg005/reg005.idr view
@@ -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;+}+
+ test/reg005/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris $@ reg005.idr -o reg005+./reg005+rm -f reg005 *.ibc
+ test/reg006/expected view
@@ -0,0 +1,1 @@+reg006.idr:17:RBTree.lookup is possibly not total due to: RBTree.lookup_case
+ test/reg006/reg006.idr view
@@ -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 +
+ test/reg006/run view
@@ -0,0 +1,3 @@+#!/bin/bash+idris $@ reg006.idr -o reg006+rm -f *.ibc
+ test/reg007/A.lidr view
@@ -0,0 +1,5 @@+> module A++> n : Nat+> n = ?lala+
+ test/reg007/expected view
@@ -0,0 +1,1 @@+reg007.lidr:8:A.n is already defined
+ test/reg007/reg007.lidr view
@@ -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
+ test/reg007/run view
@@ -0,0 +1,3 @@+#!/bin/bash+idris --check $@ reg007.lidr +rm -f *.ibc
+ test/reg008/expected view
+ test/reg008/reg008.idr view
@@ -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
+ test/reg008/run view
@@ -0,0 +1,3 @@+#!/bin/bash+idris $@ reg008.idr --check+rm -f *.ibc
+ test/reg009/expected view
+ test/reg009/reg009.lidr view
@@ -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)
+ test/reg009/run view
@@ -0,0 +1,3 @@+#!/bin/bash+idris $@ reg009.lidr --check+rm -f reg009 *.ibc
+ test/reg010/expected view
@@ -0,0 +1,4 @@+reg010.idr:5:Can't unify P x with P y++Specifically:+	Can't unify P x with P y
+ test/reg010/reg010.idr view
@@ -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
+ test/reg010/run view
@@ -0,0 +1,2 @@+#!/bin/bash+idris $@ reg010.idr --check
+ test/reg011/expected view
+ test/reg011/reg011.idr view
@@ -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
+ test/reg011/run view
@@ -0,0 +1,3 @@+#!/bin/bash+idris $@ reg011.idr --check+rm -f *.ibc
+ test/reg012/expected view
+ test/reg012/reg012.lidr view
@@ -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
+ test/reg012/run view
@@ -0,0 +1,3 @@+#!/bin/bash+idris $@ reg012.lidr --check+rm -f *.ibc
+ test/reg013/expected view
@@ -0,0 +1,3 @@+5+1+0
+ test/reg013/reg013.idr view
@@ -0,0 +1,8 @@+module Main++main : IO ()+main = do+  print $ prim_lenString "hallo"+  print $ prim_lenString "1"+  print $ prim_lenString ""+
+ test/reg013/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris $@ reg013.idr -o reg013+./reg013+rm -f reg013 *.ibc
+ test/reg014/expected view
+ test/reg014/reg014.idr view
@@ -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+
+ test/reg014/run view
@@ -0,0 +1,3 @@+#!/bin/bash+idris $@ reg014.idr --check+rm -f *.ibc
+ test/reg015/expected view
+ test/reg015/reg015.idr view
@@ -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)
+ test/reg015/run view
@@ -0,0 +1,3 @@+#!/bin/bash+idris $@ reg015.idr --check+rm -f *.ibc
+ test/reg016/expected view
@@ -0,0 +1,6 @@+4294967295+4294967296+4294967297+-1+0+1
+ test/reg016/reg016.idr view
@@ -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++
+ test/reg016/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris $@ reg016.idr -o reg016+./reg016+rm -f reg016 *.ibc
+ test/reg017/expected view
@@ -0,0 +1,1 @@+4
+ test/reg017/reg017.idr view
@@ -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
+ test/reg017/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris $@ reg017.idr -o reg017+./reg017+rm -f reg017 *.ibc
+ test/reg018/expected view
@@ -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
+ test/reg018/reg018a.idr view
@@ -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
+ test/reg018/reg018b.idr view
@@ -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
+ test/reg018/reg018c.idr view
@@ -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
+ test/reg018/reg018d.idr view
@@ -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])
+ test/reg018/run view
@@ -0,0 +1,5 @@+#!/bin/bash+idris $@ reg018a.idr --check+idris $@ reg018b.idr --check+idris $@ reg018c.idr --check+idris $@ reg018d.idr --check
+ test/reg019/expected view
+ test/reg019/reg019.idr view
@@ -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
+ test/reg019/run view
@@ -0,0 +1,3 @@+#!/bin/bash+idris $@ reg019.idr --check+rm -f *.ibc
+ test/reg020/expected view
@@ -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
+ test/reg020/reg020.idr view
@@ -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)+
+ test/reg020/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris $@ reg020.idr -o reg020+./reg020+rm -f reg020 *.ibc
+ test/runtest.pl view
@@ -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;
+ test/test001/expected view
@@ -0,0 +1,2 @@+24+12
+ test/test001/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris $@ test001.idr -o test001+./test001+rm -f test001 test001.ibc
+ test/test001/test001.idr view
@@ -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 }+++
+ test/test002/expected view
@@ -0,0 +1,1 @@+test002.idr:5:Universe inconsistency
+ test/test002/run view
@@ -0,0 +1,3 @@+#!/bin/bash+idris $@ test002.idr --check --noprelude+rm -f *.ibc
+ test/test002/test002.idr view
@@ -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+++ -}
+ test/test003/Lit.lidr view
@@ -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)+>           }+
+ test/test003/expected view
@@ -0,0 +1,7 @@+./test003a.lidr:1:Program line next to comment+a+d+zabcdefg+gfedcba+[g, f, e, d, c, b, a]+abcdefg
+ test/test003/run view
@@ -0,0 +1,5 @@+#!/bin/bash+idris $@ test003a.lidr --check+idris $@ test003.lidr -o test003+./test003+rm -f test003 test003.ibc Lit.ibc
+ test/test003/test003.lidr view
@@ -0,0 +1,8 @@+> module Main++Import the literate module++> import Lit++> main : IO ()+> main = Lit.main
+ test/test003/test003a.lidr view
@@ -0,0 +1,3 @@+Broken+> main : IO ();+> main = putStrLn "Foo";
+ test/test004/expected view
@@ -0,0 +1,7 @@+Reading testfile+Hello!+World!++---+Hello!+World!
+ test/test004/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris $@ test004.idr -o test004+./test004+rm -f test004 test004.ibc testfile
+ test/test004/test004.idr view
@@ -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"+          }+
+ test/test005/expected view
@@ -0,0 +1,6 @@+8+1+(abc, 123)+(abc, 123)+([1, 2], [3, 4, 5])+([1, 2], [3, 4, 5])
+ test/test005/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris $@ test005.idr -o test005+./test005+rm -f test005 test005.ibc
+ test/test005/test005.idr view
@@ -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)
+ test/test006/expected view
@@ -0,0 +1,1 @@+[False, True, False, True, False, True]
+ test/test006/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris $@ test006.idr -o test006+./test006+rm -f test006 test006.ibc
+ test/test006/test006.idr view
@@ -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;+};++
+ test/test007/expected view
@@ -0,0 +1,4 @@+Just 8+Just 9+Just 42+Nothing
+ test/test007/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris $@ test007.idr -o test007+./test007+rm -f test007 test007.ibc
+ test/test007/test007.idr view
@@ -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"))))
+ test/test008/expected view
@@ -0,0 +1,3 @@+First and second? 2+1+2
+ test/test008/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris $@ test008.idr -o test008+./test008+rm -f test008 test008.ibc
+ test/test008/test008.idr view
@@ -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!"
+ test/test009/expected view
@@ -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))]
+ test/test009/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris $@ test009.idr -o test009+./test009+rm -f test009 test009.ibc
+ test/test009/test009.idr view
@@ -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))+      
+ test/test010/expected view
@@ -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
+ test/test010/run view
@@ -0,0 +1,6 @@+#!/bin/bash+idris $@ test010.idr -o test010+idris $@ test010a.idr -o test010+idris $@ test010b.idr -o test010++rm -f *.ibc
+ test/test010/test010.idr view
@@ -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+
+ test/test010/test010a.idr view
@@ -0,0 +1,9 @@+module main++%default total++data Bad = MkBad (Bad -> Int) Int+         | MkBad' Int++bar : Bad+bar = MkBad (\x => 3) 3
+ test/test010/test010b.idr view
@@ -0,0 +1,9 @@+module main++%default total++data Bad = MkBad (Bad -> Int) Int+         | MkBad' Int++bar : Bad+bar = MkBad (\x => 3) 3
+ test/test011/expected view
@@ -0,0 +1,5 @@+foo+Fred+[1, 2, 3]+[b, a]+25
+ test/test011/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris $@ test011.idr -o test011+./test011+rm -f test011 test011.ibc
+ test/test011/test011.idr view
@@ -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)+
+ test/test012/expected view
@@ -0,0 +1,1 @@+test012a.idr:7:x is not an accessible pattern variable
+ test/test012/run view
@@ -0,0 +1,2 @@+#!/bin/bash+idris $@ test012a.idr -o test012a
+ test/test012/test012a.idr view
@@ -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))
+ test/test013/expected view
@@ -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!
+ test/test013/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris $@ test013.idr -o test013+./test013+rm -f test013 test013.ibc
+ test/test013/test013.idr view
@@ -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!"+
+ test/test014/Resimp.idr view
@@ -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)+
+ test/test014/expected view
@@ -0,0 +1,2 @@+foo+
+ test/test014/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris $@ test014.idr -o test014+./test014+rm -f test014 resimp.ibc test014.ibc
+ test/test014/test view
@@ -0,0 +1,2 @@+foo+bar
+ test/test014/test014.idr view
@@ -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")+
+ test/test015/Parity.idr view
@@ -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;+}+
+ test/test015/expected view
@@ -0,0 +1,3 @@+00101010+01011001+010000011
+ test/test015/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris $@ test015.idr -o test015+./test015+rm -f test015 parity.ibc test015.ibc
+ test/test015/test015.idr view
@@ -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;+}+
+ test/test016/expected view
@@ -0,0 +1,1 @@+[10, 11, 12, 13, 14, 15, 16, 17, 18, 19]
+ test/test016/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris $@ test016.idr -o test016+./test016+rm -f test016 *.ibc
+ test/test016/test016.idr view
@@ -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))+
+ test/test017/expected view
@@ -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
+ test/test017/run view
@@ -0,0 +1,5 @@+#!/bin/bash+idris $@ --check test017.idr+idris $@ --check test017a.idr+idris $@ --check test017b.idr+rm -f *.ibc
+ test/test017/test017.idr view
@@ -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;+}
+ test/test017/test017a.idr view
@@ -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+
+ test/test017/test017b.idr view
@@ -0,0 +1,5 @@+module foo++total foo : _|_+foo = foo+
+ test/test018/expected view
@@ -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
+ test/test018/run view
@@ -0,0 +1,6 @@+#!/bin/bash+idris $@ test018.idr -o test018+idris $@ test018a.idr -o test018a+./test018+#./test018a+rm -f test018 test018a *.ibc
+ test/test018/test018.idr view
@@ -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+
+ test/test018/test018a.idr view
@@ -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+
+ test/test019/expected view
@@ -0,0 +1,1 @@+1
+ test/test019/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris $@ test019.lidr -o test019+./test019+rm -f test019 *.ibc
+ test/test019/test019.lidr view
@@ -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)+
+ test/test020/expected view
@@ -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
+ test/test020/run view
@@ -0,0 +1,5 @@+#!/bin/bash+idris $@ test020.idr -o test020+idris $@ test020a.idr --check+./test020+rm -f test020 *.ibc
+ test/test020/test020.idr view
@@ -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)++
+ test/test020/test020a.idr view
@@ -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])+
+ test/test021/expected view
@@ -0,0 +1,6 @@+[HELLO!!!+, WORLD!!!+, ]+3+15+Answer: 99
+ test/test021/run view
@@ -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
+ test/test021/test021.idr view
@@ -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 ())++
+ test/test021/test021a.idr view
@@ -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++
+ test/test021/testFile view
@@ -0,0 +1,2 @@+HELLO!!!+WORLD!!!
+ test/test022/expected view
@@ -0,0 +1,2 @@+Type checking ./test022.idr+0.9995736030415051 : Float
+ test/test022/run view
@@ -0,0 +1,3 @@+#!/bin/bash+echo ":x x" | idris --quiet  test022.idr+rm -f test021 test021a *.ibc
+ test/test022/test022.idr view
@@ -0,0 +1,6 @@+module Main++%dynamic "dummy", "libm", "msvcrt"++x : Float+x = unsafePerformIO (mkForeign (FFun "sin" [FFloat] FFloat) 1.6)
+ test/test023/expected view
@@ -0,0 +1,1 @@+Type provider error: Always fails
+ test/test023/run view
@@ -0,0 +1,3 @@+#!/bin/bash+idris --quiet test023.idr -o test023+rm -f test023 *.ibc
+ test/test023/test023.idr view
@@ -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+
+ test/test024/expected view
@@ -0,0 +1,3 @@+Type checking ./test024.idr+testtest+() : ()
+ test/test024/input view
@@ -0,0 +1,2 @@+:x unsafePerformIO main+test
+ test/test024/run view
@@ -0,0 +1,3 @@+#!/bin/bash+idris --quiet  test024.idr < input+rm -f *.ibc
+ test/test024/test024.idr view
@@ -0,0 +1,6 @@+module Main++main : IO ()+main = do l <- getLine+          let ll = l ++ l+          putStrLn ll
+ test/test025/expected view
@@ -0,0 +1,1 @@+[1, 2, 3, 4]
+ test/test025/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris -p effects $@ test025.idr -o test025+./test025+rm -f test025 *.ibc
+ test/test025/test025.idr view
@@ -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)++
+ test/test026/expected view
@@ -0,0 +1,3 @@+Type checking ./test026.idr+2 : Int+2 : Nat
+ test/test026/input view
@@ -0,0 +1,2 @@+foo+bar
+ test/test026/run view
@@ -0,0 +1,3 @@+#!/bin/bash+idris --quiet test026.idr < input+rm -f *.ibc
+ test/test026/test026.idr view
@@ -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+
+ test/test026/theOtherType view
@@ -0,0 +1,1 @@+Nat
+ test/test026/theType view
@@ -0,0 +1,1 @@+Int
+ test/test027/expected view
@@ -0,0 +1,3 @@+[1, 1, 3, 5, 5, 8, 9]+55+3628800
+ test/test027/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris $@ test027.idr -o test027+./test027+rm -f test027 *.ibc
+ test/test027/test027.idr view
@@ -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]+
+ test/test028/expected view
@@ -0,0 +1,1 @@+hello, world!
+ test/test028/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris $@ test028.idr -o test028+./test028+rm -f test028 test028.ibc
+ test/test028/test028.idr view
@@ -0,0 +1,5 @@+{--}+module Main+--+main : IO ()+main = print "hello, world!"
tutorial/examples/binary.idr view
@@ -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: "
tutorial/examples/idiom.idr view
@@ -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)
tutorial/examples/interp.idr view
@@ -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)
tutorial/examples/theorems.idr view
@@ -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; }
tutorial/examples/usefultypes.idr view
@@ -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
tutorial/examples/vbroken.idr view
@@ -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 
tutorial/examples/views.idr view
@@ -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
tutorial/examples/wheres.idr view
@@ -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