packages feed

idris 0.9.13.1 → 0.9.14

raw patch · 142 files changed

+5890/−5288 lines, 142 filesdep +base64-bytestringdep +fingertreesetup-changed

Dependencies added: base64-bytestring, fingertree

Files

Makefile view
@@ -1,4 +1,4 @@-.PHONY: build configure doc install linecount nodefault pinstall lib_clean relib test_c test+.PHONY: build configure doc install linecount nodefault pinstall lib_clean relib test_c test lib_doc lib_doc_clean  include config.mk -include custom.mk@@ -45,6 +45,11 @@ doc: dist/setup-config 	$(CABAL) haddock --hyperlink-source --html --hoogle --html-location="http://hackage.haskell.org/packages/archive/\$$pkg/latest/doc/html" --haddock-options="--title Idris" +lib_doc:+	$(MAKE) -C libs IDRIS=../../dist/build/idris/idris doc++lib_doc_clean:+	$(MAKE) -C libs IDRIS=../../dist/build/idris/idris doc_clean  dist/setup-config: 	$(CABAL) configure $(CABALFLAGS)
Setup.hs view
@@ -13,8 +13,9 @@ import Distribution.PackageDescription import Distribution.Text +import System.Environment import System.Exit-import System.FilePath ((</>), splitDirectories)+import System.FilePath ((</>), splitDirectories,isAbsolute) import System.Directory import qualified System.FilePath.Posix as Px import System.Process@@ -70,6 +71,12 @@       Just False -> False       Nothing -> False +isFreestanding :: S.ConfigFlags -> Bool+isFreestanding flags =+  case lookup (FlagName "freestanding") (S.configConfigurationsFlags flags) of+    Just True -> True+    Just False -> False+    Nothing -> False -- ----------------------------------------------------------------------------- -- Clean @@ -98,12 +105,12 @@ -- Put the Git hash into a module for use in the program -- For release builds, just put the empty string in the module generateVersionModule verbosity dir release = do-  hash <- gitHash-  let versionModulePath = dir </> "Version_idris" Px.<.> "hs"-  putStrLn $ "Generating " ++ versionModulePath +++    hash <- gitHash+    let versionModulePath = dir </> "Version_idris" Px.<.> "hs"+    putStrLn $ "Generating " ++ versionModulePath ++              if release then " for release" else (" for prerelease " ++ hash)-  createDirectoryIfMissingVerbose verbosity True dir-  rewriteFile versionModulePath (versionModuleContents hash)+    createDirectoryIfMissingVerbose verbosity True dir+    rewriteFile versionModulePath (versionModuleContents hash)    where versionModuleContents h = "module Version_idris where\n\n" ++                                   "gitHash :: String\n" ++@@ -111,9 +118,38 @@                                     then "gitHash = \"\"\n"                                     else "gitHash = \"-git:" ++ h ++ "\"\n" +-- Generate a module that contains the lib path for a freestanding Idris+generateTargetModule verbosity dir targetDir = do+    absPath <- return $ isAbsolute targetDir+    let targetModulePath = dir </> "Target_idris" Px.<.> "hs"+    putStrLn $ "Generating " ++ targetModulePath+    createDirectoryIfMissingVerbose verbosity True dir+    rewriteFile targetModulePath (versionModuleContents absPath targetDir)+            where versionModuleContents absolute td = "module Target_idris where\n\n" +++                                    "import System.FilePath\n" +++                                    "import System.Environment\n" +++                                    "getDataDir :: IO String\n" +++                                    if absolute+                                        then "getDataDir = return \"" ++ td ++ "\"\n"+                                        else "getDataDir = do \n" +++                                             "   expath <- getExecutablePath\n" +++                                             "   execDir <- return $ dropFileName expath\n" +++                                             "   return $ execDir ++ \"" ++ td ++ "\"\n"+                                    ++ "getDataFileName :: FilePath -> IO FilePath\n"+                                    ++ "getDataFileName name = do\n"+                                    ++ "   dir <- getDataDir\n"+                                    ++ "   return (dir ++ \"/\" ++ name)"++ idrisConfigure _ flags _ local = do       configureRTS       generateVersionModule verbosity (autogenModulesDir local) (isRelease (configFlags local))+      when (isFreestanding $ configFlags local) (do+                targetDir <- lookupEnv "IDRIS_INSTALL_DIR"+                case targetDir of+                     Just d -> generateTargetModule verbosity (autogenModulesDir local) d+                     Nothing -> error $ "Trying to build freestanding without a target directory."+                                  ++ " Set it by defining IDRIS_INSTALL_DIR.")    where       verbosity = S.fromFlag $ S.configVerbosity flags       version   = pkgVersion . package $ localPkgDescr local@@ -128,12 +164,16 @@   let dir = S.fromFlag (S.sDistDirectory flags)   let verb = S.fromFlag (S.sDistVerbosity flags)   generateVersionModule verb ("src") True+  generateTargetModule verb "src" "./libs"   preSDist simpleUserHooks args flags  idrisPostSDist args flags desc lbi = do   Control.Exception.catch (do let file = "src" </> "Version_idris" Px.<.> "hs"-                              putStrLn $ "Removing generated module " ++ file-                              removeFile file)+                              let targetFile = "src" </> "Target_idris" Px.<.> "hs"+                              putStrLn $ "Removing generated modules:\n "+                                        ++ file ++ "\n" ++ targetFile+                              removeFile file+                              removeFile targetFile)              (\e -> let e' = (e :: SomeException) in return ())   postSDist simpleUserHooks args flags desc lbi @@ -166,6 +206,7 @@        gmpflag False = []       gmpflag True = ["GMP=-DIDRIS_GMP"]+   -- -----------------------------------------------------------------------------
config.mk view
@@ -1,6 +1,6 @@ CC              ?=cc CABAL           :=cabal-CFLAGS          :=-O2 -Wall $(CFLAGS)+CFLAGS          :=-O2 -Wall -DHAS_PTHREAD $(CFLAGS) #CABALFLAGS	:= ## Disable building of Effects #CABALFLAGS :=-f NoEffects@@ -35,4 +35,3 @@ 	SHLIB_SUFFIX    :=.so endif endif-
idris.cabal view
@@ -1,5 +1,5 @@ Name:           idris-Version:        0.9.13.1+Version:        0.9.14 License:        BSD3 License-file:   LICENSE Author:         Edwin Brady@@ -100,11 +100,6 @@                        libs/effects/Effect/*.idr                        libs/effects/*.idr -                       libs/oldeffects/Makefile-                       libs/oldeffects/oldeffects.ipkg-                       libs/oldeffects/Effect/*.idr-                       libs/oldeffects/*.idr-                        llvm/*.c                        llvm/Makefile @@ -131,9 +126,6 @@                        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@@ -237,14 +229,18 @@                        test/reg042/run                        test/reg042/*.idr                        test/reg042/expected-                       test/reg043/run-                       test/reg043/expected                        test/reg044/run                        test/reg044/*.idr                        test/reg044/expected                        test/reg045/run                        test/reg045/*.idr                        test/reg045/expected+                       test/reg046/run+                       test/reg046/*.idr+                       test/reg046/expected+                       test/reg047/run+                       test/reg047/*.idr+                       test/reg047/expected                         test/basic001/run                        test/basic001/*.idr@@ -289,6 +285,9 @@                        test/dsl002/test                        test/dsl002/*.idr                        test/dsl002/expected+                       test/dsl003/run+                       test/dsl003/*.idr+                       test/dsl003/expected                         test/effects001/run                        test/effects001/*.idr@@ -417,6 +416,17 @@                        test/proof004/*.idr                        test/proof004/expected +                       test/quasiquote001/run+                       test/quasiquote001/*.idr+                       test/quasiquote001/expected+                       test/quasiquote002/run+                       test/quasiquote002/*.idr+                       test/quasiquote002/expected+                       test/quasiquote003/run+                       test/quasiquote003/*.idr+                       test/quasiquote003/expected++                        test/records001/run                        test/records001/*.idr                        test/records001/expected@@ -513,10 +523,16 @@   Default:      True   manual:       True +Flag freestanding+  Description:  Build an Idris that doesn't use cabal+  Default:      False+  manual:       True+ Library   hs-source-dirs: src   Exposed-modules:-                  Idris.Core.CaseTree+                  Idris.Core.Binary+                , Idris.Core.CaseTree                 , Idris.Core.Constraints                 , Idris.Core.DeepSeq                 , Idris.Core.Elaborate@@ -544,6 +560,7 @@                 , Idris.Docs                 , Idris.Docstrings                 , Idris.ElabDecls+                , Idris.ElabQuasiquote                 , Idris.ElabTerm                 , Idris.Erasure                 , Idris.Error@@ -580,6 +597,7 @@                 , IRTS.CodegenCommon                 , IRTS.CodegenJava                 , IRTS.CodegenJavaScript+                , IRTS.JavaScript.AST                 , IRTS.Compiler                 , IRTS.Defunctionalise                 , IRTS.DumpBC@@ -613,6 +631,7 @@                 , annotated-wl-pprint >= 0.5.3                 , ansi-terminal                 , ansi-wl-pprint+                , base64-bytestring                 , binary                 , blaze-html >= 0.6.1.3                 , blaze-markup >= 0.5.2.1 && < 0.7.0.0@@ -622,6 +641,7 @@                 , directory                 , directory >= 1.2                 , filepath+                , fingertree >= 0.1                 , haskeline >= 0.7                 , language-java >= 0.2.6                 , lens >= 4.1.1@@ -680,6 +700,9 @@   if flag(curses)      build-depends: hscurses      cpp-options:   -DCURSES+  if flag(freestanding)+     other-modules: Target_idris+     cpp-options:   -DFREESTANDING  Executable idris   Main-is:        Main.hs
jsrts/Runtime-browser.js view
@@ -1,14 +1,14 @@-var __IDRRT__print = function(s) {+var i$putStr = function(s) {   console.log(s); };  -var __IDRRT__systemInfo = function(index) {-    switch(index) {-        case 0:-            return "javascript";-        case 1:-            return navigator.platform;-    }-    return "";+var i$systemInfo = function(index) {+  switch(index) {+    case 0:+      return "javascript";+    case 1:+      return navigator.platform;+  }+  return ""; }
jsrts/Runtime-common.js view
@@ -1,51 +1,91 @@ /** @constructor */-var __IDRRT__Type = function(type) {-  this.type = type;-};+var i$VM = function() {+  this.valstack = [];+  this.valstack_top = 0;+  this.valstack_base = 0; -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');+  this.ret = null; -var __IDRRT__ffiWrap = function(fid) {-  return function(){+  this.callstack = [];+}++var i$vm;+var i$valstack;+var i$valstack_top;+var i$valstack_base;+var i$ret;+var i$callstack;++/** @constructor */+var i$CON = function(tag,args,app,ev) {+  this.tag = tag;+  this.args = args;+  this.app = app;+  this.ev = ev;+}++var i$SCHED = function(vm) {+  i$vm = vm;+  i$valstack = vm.valstack;+  i$valstack_top = vm.valstack_top;+  i$valstack_base = vm.valstack_base;+  i$ret = vm.ret;+  i$callstack = vm.callstack;+}++var i$SLIDE = function(args) {+  for (var i = 0; i < args; ++i)+    i$valstack[i$valstack_base + i] = i$valstack[i$valstack_top + i];+}++var i$PROJECT = function(val,loc,arity) {+  for (var i = 0; i < arity; ++i)+    i$valstack[i$valstack_base + i + loc] = val.args[i];+}++var i$CALL = function(fun,args) {+  i$callstack.push(args);+  i$callstack.push(fun);+}++var i$ffiWrap = function(fid,oldbase,myoldbase) {+  return function() {+    i$callstack = [];+     var res = fid;-    var i = 0;-    var arg;-    while (res instanceof __IDRRT__Con){-      arg = arguments[i];-      res = __IDRRT__tailcall(function(){-        return __IDR__mAPPLY0(res, arg);-      });-      ++i;++    for(var i = 0; i < arguments.length; ++i) {+      while (res instanceof i$CON) {+        i$valstack_top += 1;+        i$valstack[i$valstack_top] = res;+        i$valstack[i$valstack_top + 1] = arguments[i];+        i$SLIDE(2);+        i$valstack_top = i$valstack_base + 2;+        i$CALL(_idris__123_APPLY0_125_,[oldbase])+        while (i$callstack.length) {+          var func = i$callstack.pop();+          var args = i$callstack.pop();+          func.apply(this,args);+        }+        res = i$ret;+      }     }-    return res;-  }-}; -var __IDRRT__tailcall = function(k) {-  var ret = k();-  while (ret instanceof __IDRRT__Cont)-    ret = ret.k();+    i$callstack = i$vm.callstack; -  return ret;-};+    return i$ret;+  }+} -var __IDRRT__charCode = function(str) {-  var type = typeof str;-  if (type == "string")+var i$charCode = function(str) {+  if (typeof str == "string")     return str.charCodeAt(0);   else     return str; } -var __IDRRT__fromCharCode = function(chr) {-  var type = typeof chr;-  if (type == "string")+var i$fromCharCode = function(chr) {+  if (typeof chr == "string")     return chr;   else     return String.fromCharCode(chr);
jsrts/Runtime-node.js view
@@ -1,17 +1,17 @@-var __IDRRT__print = (function() {+var i$putStr = (function() {   var util = require('util');   return function(s) {     util.print(s);   }; })(); -var __IDRRT__systemInfo = function(index) {-    var os = require('os')+var i$systemInfo = function(index) {+  var os = require('os')     switch(index) {-        case 0:-            return "node";-        case 1:-            return os.platform();+      case 0:+        return "node";+      case 1:+        return os.platform();     }-    return "";+  return ""; }
jsrts/jsbn/jsbn.js view
@@ -1,4 +1,4 @@-var __IDRRT__bigInt = (function() {+var i$bigInt = (function() { // Copyright (c) 2005  Tom Wu // All Rights Reserved. // See "LICENSE" for details.@@ -1234,5 +1234,5 @@ } })(); -var __IDRRT__ZERO = __IDRRT__bigInt("0");-var __IDRRT__ONE = __IDRRT__bigInt("1");+var i$ZERO = i$bigInt("0");+var i$ONE = i$bigInt("1");
libs/Makefile view
@@ -13,5 +13,16 @@ 	$(MAKE) -C prelude clean 	$(MAKE) -C base clean 	$(MAKE) -C effects clean-        -.PHONY: build install clean++doc:+	$(MAKE)	-C prelude doc 	+	$(MAKE)	-C base doc 	+	$(MAKE)	-C effects doc 	++doc_clean:+	$(MAKE)	-C prelude doc_clean+	$(MAKE)	-C base doc_clean 	+	$(MAKE)	-C effects  doc_clean	+++.PHONY: build install clean doc doc_clean
libs/base/Data/HVect.idr view
@@ -5,68 +5,67 @@ %access public %default total -using (k : Nat, ts : Vect k Type)-  ||| Heterogeneous vectors where the type index gives, element-wise,-  ||| the types of the contents.-  data HVect : Vect k Type -> Type where-    Nil : HVect []-    (::) : t -> HVect ts -> HVect (t::ts)+||| Heterogeneous vectors where the type index gives, element-wise,+||| the types of the contents.+data HVect : Vect k Type -> Type where+  Nil : HVect []+  (::) : t -> HVect ts -> HVect (t::ts) -  ||| Extract an element from an HVect-  index : (i : Fin k) -> HVect ts -> index i ts-  index fZ (x::xs) = x-  index (fS j) (x::xs) = index j xs+||| Extract an element from an HVect+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 {l = Z}   (fS j) (x::xs) = absurd j-  deleteAt _ [] impossible+deleteAt : (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 {l = Z}   (fS j) (x::xs) = absurd j+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+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+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 -  ||| Append two `HVect`s.-  (++) : {us : Vect l Type} -> HVect ts -> HVect us -> HVect (ts ++ us)-  (++) [] ys = ys-  (++) (x::xs) ys = x :: (xs ++ ys)+||| Append two `HVect`s.+(++) : HVect ts -> HVect us -> HVect (ts ++ us)+(++) [] ys = ys+(++) (x::xs) ys = x :: (xs ++ ys) -  instance Eq (HVect []) where-    [] == [] = True+instance Eq (HVect []) where+  [] == [] = True -  instance (Eq t, Eq (HVect ts)) => Eq (HVect (t::ts)) where-    (x::xs) == (y::ys) = x == y && xs == ys+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+class Shows (k : Nat) (ts : Vect k Type) where+  shows : HVect ts -> Vect k String -  instance Shows Z [] where-    shows [] = []+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 (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)+instance (Shows k ts) => Show (HVect ts) where+  show xs = "[" ++ (pack . intercalate [','] . map unpack . toList $ shows xs) ++ "]" -  ||| Extract an arbitrary element of the correct type.-  ||| @ t the goal type-  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+||| Extract an arbitrary element of the correct type.+||| @ t the goal type+get : {default tactics { search 100; } p : Elem t ts} -> HVect ts -> t+get {p = Here} (x::xs) = x+get {p = There p'} (x::xs) = get {p = p'} xs -  ||| Replace an element with the correct type.-  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+||| Replace an element with the correct type.+put : {default tactics { search 100; } 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 -  ||| Replace an element with the correct type.-  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+||| Update an element with the correct type.+update : {default tactics { search 100; } 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
libs/base/Data/List.idr view
@@ -2,30 +2,29 @@  %access public -using (xs : List a)-  ||| A proof that some element is found in a list-  data Elem : a -> List a -> Type where-       Here : Elem x (x :: xs)-       There : Elem x xs -> Elem x (y :: xs)+||| A proof that some element is found in a list+data Elem : a -> List a -> Type where+     Here : Elem x (x :: xs)+     There : Elem x xs -> Elem x (y :: xs) -  instance Uninhabited (Elem {a} x []) where-       uninhabited Here impossible-       uninhabited (There p) impossible+instance Uninhabited (Elem {a} x []) where+     uninhabited Here impossible+     uninhabited (There p) impossible -  ||| Is the given element a member of the given list.-  |||-  ||| @x The element to be tested.-  ||| @xs The list to be checked against-  isElem : DecEq a => (x : a) -> (xs : List a) -> Dec (Elem x xs)-  isElem x [] = No absurd-  isElem x (y :: xs) with (decEq x y)-    isElem x (x :: xs) | (Yes refl) = Yes Here-    isElem x (y :: xs) | (No contra) with (isElem x xs)-      isElem x (y :: xs) | (No contra) | (Yes prf) = Yes (There prf)-      isElem x (y :: xs) | (No contra) | (No f) = No (mkNo contra f)-        where-          mkNo : {xs' : List a} ->-                 ((x' = y') -> _|_) -> (Elem x' xs' -> _|_) ->-                 Elem x' (y' :: xs') -> _|_-          mkNo f g Here = f refl-          mkNo f g (There x) = g x+||| Is the given element a member of the given list.+|||+||| @x The element to be tested.+||| @xs The list to be checked against+isElem : DecEq a => (x : a) -> (xs : List a) -> Dec (Elem x xs)+isElem x [] = No absurd+isElem x (y :: xs) with (decEq x y)+  isElem x (x :: xs) | (Yes refl) = Yes Here+  isElem x (y :: xs) | (No contra) with (isElem x xs)+    isElem x (y :: xs) | (No contra) | (Yes prf) = Yes (There prf)+    isElem x (y :: xs) | (No contra) | (No f) = No (mkNo contra f)+      where+        mkNo : {xs' : List a} ->+               ((x' = y') -> _|_) -> (Elem x' xs' -> _|_) ->+               Elem x' (y' :: xs') -> _|_+        mkNo f g Here = f refl+        mkNo f g (There x) = g x
libs/base/Data/Vect.idr view
@@ -9,11 +9,10 @@ -- Elem -------------------------------------------------------------------------------- -using (xs : Vect k a)-  ||| A proof that some element is found in a vector-  data Elem : a -> Vect k a -> Type where-    Here : Elem x (x::xs)-    There : Elem x xs -> Elem x (y::xs)+||| A proof that some element is found in a vector+data Elem : a -> Vect k a -> Type where+     Here : Elem x (x::xs)+     There : Elem x xs -> Elem x (y::xs)  ||| Nothing can be in an empty Vect noEmptyElem : {x : a} -> Elem x [] -> _|_
libs/base/Language/Reflection.idr view
@@ -192,8 +192,10 @@             -- ^ focus a named hole             | Rewrite TT             -- ^ rewrite using the reflected rep. of a equality proof-            | Induction TTName+            | Induction TT             -- ^ do induction on the particular expression+            | Case TT+            -- ^ do case analysis on particular expression             | LetTac TTName TT             -- ^ name a reflected term             | LetTacTy TTName TT TT
libs/base/Makefile view
@@ -1,15 +1,22 @@ IDRIS := idris+PKG := base  build:-	$(IDRIS) --build base.ipkg+	$(IDRIS) --build ${PKG}.ipkg  install: -	$(IDRIS) --install base.ipkg+	$(IDRIS) --install ${PKG}.ipkg  clean:-	$(IDRIS) --clean base.ipkg+	$(IDRIS) --clean ${PKG}.ipkg  rebuild: clean build++doc:+	${IDRIS} --mkdoc ${PKG}.ipkg++doc_clean:+	rm -rf ${PKG}_doc  linecount: 	find . -name '*.idr' | xargs wc -l
libs/base/Network/Socket.idr view
@@ -1,10 +1,10 @@ -- Time to do this properly. -- Low-Level C Sockets bindings for Idris. Used by higher-level, cleverer things. -- (C) SimonJF, MIT Licensed, 2014-module Network.Socket+module IdrisNet.Socket  %include C "idris_net.h"-%include C "sys/types.h" -- Pushing my luck, might need to re-export everything+%include C "sys/types.h"  %include C "sys/socket.h"  %include C "netdb.h" @@ -54,6 +54,12 @@   toCode Datagram   = 2   toCode Raw        = 3 ++data RecvStructPtr = RSPtr Ptr+data RecvfromStructPtr = RFPtr Ptr+data BufPtr = BPtr Ptr+data SockaddrPtr = SAPtr Ptr+ -- Protocol Number. Generally good enough to just set it to 0. ProtocolNumber : Type ProtocolNumber = Int@@ -88,17 +94,36 @@ EAGAIN : Int  EAGAIN = 11 --- Allocates an amount of memory given by the ByteLength parameter.--- Used to allocate a mutable pointer to be given to the Recv functions.-private-alloc : ByteLength -> IO Ptr-alloc bl = mkForeign (FFun "idrnet_malloc" [FInt] FPtr) bl+-- TODO: Expand to non-string payloads+record UDPRecvData : Type where+  MkUDPRecvData : +    (remote_addr : SocketAddress) ->+    (remote_port : Port) ->+    (recv_data : String) ->+    (data_len : Int) ->+    UDPRecvData +record UDPAddrInfo : Type where+  MkUDPAddrInfo : +    (remote_addr : SocketAddress) ->+    (remote_port : Port) ->+    UDPAddrInfo+ -- Frees a given pointer-private-free : Ptr -> IO ()-free ptr = mkForeign (FFun "idrnet_free" [FPtr] FUnit) ptr+public+sock_free : BufPtr -> IO ()+sock_free (BPtr ptr) = mkForeign (FFun "idrnet_free" [FPtr] FUnit) ptr +public+sockaddr_free : SockaddrPtr -> IO ()+sockaddr_free (SAPtr ptr) = mkForeign (FFun "idrnet_free" [FPtr] FUnit) ptr++-- Allocates an amount of memory given by the ByteLength parameter.+-- Used to allocate a mutable pointer to be given to the Recv functions.+public+sock_alloc : ByteLength -> IO BufPtr+sock_alloc bl = map BPtr $ mkForeign (FFun "idrnet_malloc" [FInt] FPtr) bl+ record Socket : Type where   MkSocket : (descriptor : SocketDescriptor) ->              (family : SocketFamily) ->@@ -123,12 +148,17 @@ close : Socket -> IO () close sock = mkForeign (FFun "close" [FInt] FUnit) (descriptor sock) +private+saString : (Maybe SocketAddress) -> String+saString (Just sa) = show sa+saString Nothing = ""+ -- Binds a socket to the given socket address and port. -- Returns 0 on success, an error code otherwise.-bind : Socket -> SocketAddress -> Port -> IO Int+bind : Socket -> (Maybe SocketAddress) -> Port -> IO Int bind sock addr port = do   bind_res <- (mkForeign (FFun "idrnet_bind" [FInt, FInt, FInt, FString, FInt] FInt) -                           (descriptor sock) (toCode $ family sock) (toCode $ socketType sock) (show addr) port)+                           (descriptor sock) (toCode $ family sock) (toCode $ socketType sock) (saString addr) port)   if bind_res == (-1) then -- error     getErrno   else return 0 -- Success@@ -152,11 +182,10 @@   else return 0  -- Parses a textual representation of an IPv4 address into a SocketAddress-private parseIPv4 : String -> SocketAddress parseIPv4 str = case splitted of-                     (i1 :: i2 :: i3 :: i4 :: _) => IPv4Addr i1 i2 i3 i4-                     _ => InvalidAddress+                  (i1 :: i2 :: i3 :: i4 :: _) => IPv4Addr i1 i2 i3 i4+                  _ => InvalidAddress   where toInt' : String -> Integer         toInt' = cast         toInt : String -> Int@@ -166,32 +195,30 @@   -- Retrieves a socket address from a sockaddr pointer-private-getSockAddr : Ptr -> IO SocketAddress-getSockAddr ptr = do+getSockAddr : SockaddrPtr -> IO SocketAddress+getSockAddr (SAPtr ptr) = do   addr_family_int <- mkForeign (FFun "idrnet_sockaddr_family" [FPtr] FInt) ptr-  -- FIXME: Is this really a safe assertion? Depends where the Ptr came-  -- from!-  assert_total $ case getSocketFamily addr_family_int of+ -- putStrLn $ "Addr family int: " ++ (show addr_family_int)+  -- ASSUMPTION: Foreign call returns a valid int+  assert_total (case getSocketFamily addr_family_int of     Just AF_INET => do       ipv4_addr <- mkForeign (FFun "idrnet_sockaddr_ipv4" [FPtr] FString) ptr       return $ parseIPv4 ipv4_addr     Just AF_INET6 => return IPv6Addr-    Just AF_UNSPEC => return IPv6Addr -- FIXME: Horrible hack+    Just AF_UNSPEC => return InvalidAddress) --- Accepts a connection from a listening socket. accept : Socket -> IO (Either SocketError (Socket, SocketAddress)) accept sock = do   -- We need a pointer to a sockaddr structure. This is then passed into   -- idrnet_accept and populated. We can then query it for the SocketAddr and free it.-  sockaddr_ptr <- mkForeign (FFun "idrnet_create_sockaddr" [] FPtr) +  sockaddr_ptr <- mkForeign (FFun "idrnet_create_sockaddr" [] FPtr)   accept_res <- mkForeign (FFun "idrnet_accept" [FInt, FPtr] FInt) (descriptor sock) sockaddr_ptr   if accept_res == (-1) then     map Left getErrno   else do     let (MkSocket _ fam ty p_num) = sock-    sockaddr <- getSockAddr sockaddr_ptr-    free sockaddr_ptr+    sockaddr <- getSockAddr (SAPtr sockaddr_ptr)+    sockaddr_free (SAPtr sockaddr_ptr)     return $ Right ((MkSocket accept_res fam ty p_num), sockaddr)  send : Socket -> String -> IO (Either SocketError ByteLength)@@ -202,11 +229,13 @@   else     return $ Right send_res -private-freeRecvStruct : Ptr -> IO ()-freeRecvStruct p = mkForeign (FFun "idrnet_free_recv_struct" [FPtr] FUnit) p +freeRecvStruct : RecvStructPtr -> IO ()+freeRecvStruct (RSPtr p) = mkForeign (FFun "idrnet_free_recv_struct" [FPtr] FUnit) p +freeRecvfromStruct : RecvfromStructPtr -> IO ()+freeRecvfromStruct (RFPtr p) = mkForeign (FFun "idrnet_free_recvfrom_struct" [FPtr] FUnit) p+ recv : Socket -> Int -> IO (Either SocketError (String, ByteLength)) recv sock len = do   -- Firstly make the request, get some kind of recv structure which@@ -215,32 +244,106 @@   recv_res <- mkForeign (FFun "idrnet_get_recv_res" [FPtr] FInt) recv_struct_ptr   if recv_res == (-1) then do     errno <- getErrno-    freeRecvStruct recv_struct_ptr+    freeRecvStruct (RSPtr recv_struct_ptr)     return $ Left errno   else      if recv_res == 0 then do-       freeRecvStruct recv_struct_ptr+       freeRecvStruct (RSPtr recv_struct_ptr)        return $ Left 0     else do        payload <- mkForeign (FFun "idrnet_get_recv_payload" [FPtr] FString) recv_struct_ptr-       freeRecvStruct recv_struct_ptr+       freeRecvStruct (RSPtr recv_struct_ptr)        return $ Right (payload, recv_res)   -- Sends the data in a given memory location-sendBuf : Socket -> Ptr -> ByteLength -> IO (Either SocketError ByteLength)-sendBuf sock ptr len = do+sendBuf : Socket -> BufPtr -> ByteLength -> IO (Either SocketError ByteLength)+sendBuf sock (BPtr ptr) len = do   send_res <- mkForeign (FFun "idrnet_send_buf" [FInt, FPtr, FInt] FInt) (descriptor sock) ptr len   if send_res == (-1) then     map Left getErrno   else      return $ Right send_res -recvBuf : Socket -> Ptr -> ByteLength -> IO (Either SocketError ByteLength)-recvBuf sock ptr len = do+recvBuf : Socket -> BufPtr -> ByteLength -> IO (Either SocketError ByteLength)+recvBuf sock (BPtr ptr) len = do   recv_res <- mkForeign (FFun "idrnet_recv_buf" [FInt, FPtr, FInt] FInt) (descriptor sock) ptr len   if (recv_res == (-1)) then     map Left getErrno   else     return $ Right recv_res++sendTo : Socket -> SocketAddress -> Port -> String -> IO (Either SocketError ByteLength)+sendTo sock addr p dat = do+  sendto_res <- mkForeign (FFun "idrnet_sendto" [FInt, FString, FString, FInt, FInt] FInt)+                            (descriptor sock) dat (show addr) p (toCode $ family sock)+  if sendto_res == (-1) then+    map Left getErrno+  else+    return $ Right sendto_res+++sendToBuf : Socket -> SocketAddress -> Port -> BufPtr -> ByteLength -> IO (Either SocketError ByteLength)+sendToBuf sock addr p (BPtr dat) len = do+  sendto_res <- mkForeign (FFun "idrnet_sendto_buf" [FInt, FPtr, FInt, FString, FInt, FInt] FInt)+                            (descriptor sock) dat len (show addr) p (toCode $ family sock)+  if sendto_res == (-1) then+    map Left getErrno+  else+    return $ Right sendto_res+++foreignGetRecvfromPayload : RecvfromStructPtr -> IO String+foreignGetRecvfromPayload (RFPtr p) = mkForeign (FFun "idrnet_get_recvfrom_payload" [FPtr] FString) p++foreignGetRecvfromAddr : RecvfromStructPtr -> IO SocketAddress+foreignGetRecvfromAddr (RFPtr p) = do+  sockaddr_ptr <- map SAPtr $ mkForeign (FFun "idrnet_get_recvfrom_sockaddr" [FPtr] FPtr) p+  getSockAddr sockaddr_ptr+++foreignGetRecvfromPort : RecvfromStructPtr -> IO Port+foreignGetRecvfromPort (RFPtr p) = do+  sockaddr_ptr <- mkForeign (FFun "idrnet_get_recvfrom_sockaddr" [FPtr] FPtr) p+  port <- mkForeign (FFun "idrnet_sockaddr_ipv4_port" [FPtr] FInt) sockaddr_ptr+  return port++recvFrom : Socket -> ByteLength -> IO (Either SocketError (UDPAddrInfo, String, ByteLength))+recvFrom sock bl = do+  recv_ptr <- mkForeign (FFun "idrnet_recvfrom" [FInt, FInt] FPtr) +                (descriptor sock) bl+  let recv_ptr' = RFPtr recv_ptr+  if !(nullPtr recv_ptr) then -- ! notation = monadic bind shortcut, not "not"+    map Left getErrno+  else do+    result <- mkForeign (FFun "idrnet_get_recvfrom_res" [FPtr] FInt) recv_ptr+    if result == -1 then do+      freeRecvfromStruct recv_ptr'+      map Left getErrno+    else do+      payload <- foreignGetRecvfromPayload recv_ptr'+      port <- foreignGetRecvfromPort recv_ptr'+      addr <- foreignGetRecvfromAddr recv_ptr'+      freeRecvfromStruct recv_ptr'+      return $ Right (MkUDPAddrInfo addr port, payload, result)+++recvFromBuf : Socket -> BufPtr -> ByteLength -> IO (Either SocketError (UDPAddrInfo, ByteLength))+recvFromBuf sock (BPtr ptr) bl = do+  recv_ptr <- mkForeign (FFun "idrnet_recvfrom_buf" [FInt, FPtr, FInt] FPtr) (descriptor sock) ptr bl+  let recv_ptr' = RFPtr recv_ptr+  if !(nullPtr recv_ptr) then -- ! notation = monadic bind shortcut, not "not"+    map Left getErrno+  else do+    result <- mkForeign (FFun "idrnet_get_recvfrom_res" [FPtr] FInt) recv_ptr+    if result == -1 then do+      freeRecvfromStruct recv_ptr'+      map Left getErrno+    else do+      port <- foreignGetRecvfromPort recv_ptr'+      addr <- foreignGetRecvfromAddr recv_ptr'+      freeRecvfromStruct recv_ptr'+      return $ Right (MkUDPAddrInfo addr port, result + 1)++
libs/base/System.idr view
@@ -80,3 +80,6 @@ usleep : Int -> IO () usleep i = mkForeign (FFun "usleep" [FInt] FUnit) i +system : String -> IO Int+system cmd = mkForeign (FFun "system" [FString] FInt) cmd+
libs/effects/Effect/Exception.idr view
@@ -26,7 +26,7 @@ EXCEPTION : Type -> EFFECT EXCEPTION t = MkEff () (Exception t) -raise : a -> { [EXCEPTION a ] } Eff m b +raise : a -> { [EXCEPTION a ] } Eff b  raise err = call $ Raise err
libs/effects/Effect/File.idr view
@@ -105,24 +105,24 @@        -> (m : Mode)        -> { [FILE_IO ()] ==> [FILE_IO (if result                                           then OpenFile m-                                          else ())] } Eff e Bool+                                          else ())] } Eff Bool open f m = call $ Open f m   ||| Close a file.-close : { [FILE_IO (OpenFile m)] ==> [FILE_IO ()] } Eff e ()+close : { [FILE_IO (OpenFile m)] ==> [FILE_IO ()] } Eff () close = call $ Close  ||| Read a line from the file.-readLine : { [FILE_IO (OpenFile Read)] } Eff e String +readLine : { [FILE_IO (OpenFile Read)] } Eff String  readLine = call $ ReadLine  ||| Write a line to a file.-writeLine : String -> { [FILE_IO (OpenFile Write)] } Eff e ()+writeLine : String -> { [FILE_IO (OpenFile Write)] } Eff () writeLine str = call $ WriteLine str  ||| End of file?-eof : { [FILE_IO (OpenFile Read)] } Eff e Bool +eof : { [FILE_IO (OpenFile Read)] } Eff Bool  eof = call $ EOF  -- --------------------------------------------------------------------- [ EOF ]
libs/effects/Effect/Memory.idr view
@@ -101,7 +101,7 @@ RAW_MEMORY t = MkEff t RawMemory  allocate : (n : Nat) -> -           Eff m () [RAW_MEMORY ()] (\v => [RAW_MEMORY (MemoryChunk n 0)])+           Eff () [RAW_MEMORY ()] (\v => [RAW_MEMORY (MemoryChunk n 0)]) allocate size = call $ Allocate size  initialize : {i : Nat} ->@@ -109,18 +109,18 @@              Bits8 ->              (size : Nat) ->              so (i + size <= n) ->-             Eff m () [RAW_MEMORY (MemoryChunk n i)] +             Eff () [RAW_MEMORY (MemoryChunk n i)]                         (\v => [RAW_MEMORY (MemoryChunk n (i + size))]) initialize c size prf = call $ Initialize c size prf -free : Eff m () [RAW_MEMORY (MemoryChunk n i)] (\v => [RAW_MEMORY ()])+free : Eff () [RAW_MEMORY (MemoryChunk n i)] (\v => [RAW_MEMORY ()]) free = call Free  peek : {i : Nat} ->        (offset : Nat) ->        (size : Nat) ->        so (offset + size <= i) ->-       { [RAW_MEMORY (MemoryChunk n i)] } Eff m (Vect size Bits8) +       { [RAW_MEMORY (MemoryChunk n i)] } Eff (Vect size Bits8)  peek offset size prf = call $ Peek offset size prf  poke : {n : Nat} ->@@ -128,12 +128,12 @@        (offset : Nat) ->        Vect size Bits8 ->        so (offset <= i && offset + size <= n) ->-       Eff m () [RAW_MEMORY (MemoryChunk n i)] +       Eff () [RAW_MEMORY (MemoryChunk n i)]                (\v => [RAW_MEMORY (MemoryChunk n (max i (offset + size)))]) poke offset content prf = call $ Poke offset content prf  private-getRawPtr : { [RAW_MEMORY (MemoryChunk n i)] } Eff m (MemoryChunk n i) +getRawPtr : { [RAW_MEMORY (MemoryChunk n i)] } Eff (MemoryChunk n i)  getRawPtr = call $ GetRawPtr  private@@ -146,7 +146,7 @@         (size : Nat) ->         so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->         so (src_offset + size <= src_init) ->-        Eff m () [RAW_MEMORY (MemoryChunk dst_size dst_init)]+        Eff () [RAW_MEMORY (MemoryChunk dst_size dst_init)]                (\v => [RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))]) move' src_ptr dst_offset src_offset size dst_bounds src_bounds   = call $ Move src_ptr dst_offset src_offset size dst_bounds src_bounds@@ -162,7 +162,7 @@        (size : Nat) ->        so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->        so (src_offset + size <= src_init) ->-       Eff m ()+       Eff ()               [ Dst ::: RAW_MEMORY (MemoryChunk dst_size dst_init)               , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)]               (\v =>
libs/effects/Effect/Random.idr view
@@ -17,14 +17,14 @@ RND = MkEff Integer Random  ||| Generates a random Integer in a given range-rndInt : Integer -> Integer -> { [RND] } Eff m Integer+rndInt : Integer -> Integer -> { [RND] } Eff Integer rndInt lower upper = do v <- call $ getRandom                         return (v `prim__sremBigInt` (upper - lower) + lower)  ||| Generate a random number in Fin (S `k`) |||  ||| Note that rndFin k takes values 0, 1, ..., k.-rndFin : (k : Nat) -> { [RND] } Eff m (Fin (S k))+rndFin : (k : Nat) -> { [RND] } Eff (Fin (S k)) rndFin k = do let v = assert_total $ !(call getRandom) `prim__sremBigInt` (cast (S k))               return (toFin v)  where toFin : Integer -> Fin (S k) @@ -33,15 +33,15 @@                       Nothing => toFin (assert_smaller x (x - cast (S k)))  ||| Select a random element from a vector-rndSelect' : Vect (S k) a -> { [RND] } Eff IO a+rndSelect' : Vect (S k) a -> { [RND] } Eff a rndSelect' {k} xs = return (Vect.index !(rndFin k)  xs)  ||| Select a random element from a list, or Nothing if the list is empty-rndSelect : List a -> { [RND] } Eff IO (Maybe a)+rndSelect : List a -> { [RND] } Eff (Maybe a) rndSelect []      = return Nothing rndSelect (x::xs) = return (Just !(rndSelect' (x::(fromList xs))))  ||| Sets the random seed-srand : Integer -> { [RND] } Eff m ()+srand : Integer -> { [RND] } Eff () srand n = call $ setSeed n
libs/effects/Effect/Select.idr view
@@ -18,6 +18,6 @@ SELECT : EFFECT SELECT = MkEff () Selection -select : List a -> { [SELECT] } Eff m a +select : List a -> { [SELECT] } Eff a  select xs = call $ Select xs
libs/effects/Effect/State.idr view
@@ -8,30 +8,30 @@   Get :      { a }       State a   Put : b -> { a ==> b } State ()  -using (m : Type -> Type)-  instance Handler State m where+-- using (m : Type -> Type)+instance Handler State m where      handle st Get     k = k st st      handle st (Put n) k = k () n  STATE : Type -> EFFECT STATE t = MkEff t State -get : { [STATE x] } Eff m x+get : { [STATE x] } Eff x get = call $ Get -put : x -> { [STATE x] } Eff m () +put : x -> { [STATE x] } Eff ()  put val = call $ Put val -putM : y -> { [STATE x] ==> [STATE y] } Eff m () +putM : y -> { [STATE x] ==> [STATE y] } Eff ()  putM val = call $ Put val -update : (x -> x) -> { [STATE x] } Eff m () +update : (x -> x) -> { [STATE x] } Eff ()  update f = put (f !get) -updateM : (x -> y) -> { [STATE x] ==> [STATE y] } Eff m () +updateM : (x -> y) -> { [STATE x] ==> [STATE y] } Eff ()  updateM f = putM (f !get) -locally : x -> ({ [STATE x] } Eff m t) -> { [STATE y] } Eff m t +locally : x -> ({ [STATE x] } Eff t) -> { [STATE y] } Eff t  locally newst prog = do st <- get                         putM newst                         val <- prog
libs/effects/Effect/StdIO.idr view
@@ -39,22 +39,22 @@ STDIO = MkEff () StdIO  ||| Write a string to standard output.-putStr : String -> { [STDIO] } Eff e ()+putStr : String -> { [STDIO] } Eff () putStr s = call $ PutStr s  ||| Write a character to standard output.-putChar : Char -> { [STDIO] } Eff e ()+putChar : Char -> { [STDIO] } Eff () putChar c = call $ PutCh c  ||| Write a string to standard output, terminating with a newline.-putStrLn : String -> { [STDIO] } Eff e ()+putStrLn : String -> { [STDIO] } Eff () putStrLn s = putStr (s ++ "\n")  ||| Read a string from standard input.-getStr : { [STDIO] } Eff e String+getStr : { [STDIO] } Eff String getStr = call $ GetStr  ||| Read a character from standard input.-getChar : { [STDIO] } Eff e Char+getChar : { [STDIO] } Eff Char getChar = call $ GetCh
libs/effects/Effect/System.idr view
@@ -11,28 +11,33 @@      Args : { () } System (List String)      Time : { () } System Int      GetEnv : String -> { () } System (Maybe String)+     CSystem : String -> { () } System Int  instance Handler System IO where     handle () Args k = do x <- getArgs; k x ()     handle () Time k = do x <- time; k x ()     handle () (GetEnv s) k = do x <- getEnv s; k x ()+    handle () (CSystem s) k = do x <- system s; k x ()  instance Handler System (IOExcept a) where     handle () Args k = do x <- ioe_lift getArgs; k x ()     handle () Time k = do x <- ioe_lift time; k x ()     handle () (GetEnv s) k = do x <- ioe_lift $ getEnv s; k x ()+    handle () (CSystem s) k = do x <- ioe_lift $ system s; k x ()  --- The Effect and associated functions  SYSTEM : EFFECT SYSTEM = MkEff () System -getArgs : Handler System e => { [SYSTEM] } Eff e (List String)+getArgs : { [SYSTEM] } Eff (List String) getArgs = call Args -time : Handler System e => { [SYSTEM] } Eff e Int+time : { [SYSTEM] } Eff Int time = call Time -getEnv : Handler System e => String -> { [SYSTEM] } Eff e (Maybe String)+getEnv : String -> { [SYSTEM] } Eff (Maybe String) getEnv s = call $ GetEnv s +system : String -> { [SYSTEM] } Eff Int+system s = call $ CSystem s
libs/effects/Effects.idr view
@@ -10,7 +10,7 @@ %access public -- ----------------------------------------------------------------- [ Effects ] ||| The Effect type describes effectful computations.-||| +||| ||| This type is parameterised by: ||| + The input resource. ||| + The return type of the computation.@@ -28,11 +28,11 @@ ||| underlying computation context `m` for execution. class Handler (e : Effect) (m : Type -> Type) where   ||| How to handle the effect.-  ||| +  |||   ||| @ r The resource being handled.   ||| @ eff The effect to be applied.   ||| @ k The continuation to pass the result of the effect-  covering handle : (r : res) -> (eff : e t res resk) -> +  covering handle : (r : res) -> (eff : e t res resk) ->                     (k : ((x : t) -> resk x -> m a)) -> m a  ||| Get the resource type (handy at the REPL to find out about an effect)@@ -48,28 +48,27 @@ syntax "{" [inst] "}" [eff] = eff inst (\result => inst)  -- The state transition is dependent on a result `b`, a bound variable.-syntax "{" [inst] "==>" "{" {b} "}" [outst] "}" [eff] +syntax "{" [inst] "==>" "{" {b} "}" [outst] "}" [eff]        = eff inst (\b => outst)  --- A simple state transition syntax "{" [inst] "==>" [outst] "}" [eff] = eff inst (\result => outst)  -- --------------------------------------- [ Properties and Proof Construction ]-using (xs : List a, ys : List a)-  data SubList : List a -> List a -> Type where-       SubNil : SubList {a} [] []-       Keep   : SubList xs ys -> SubList (x :: xs) (x :: ys)-       Drop   : SubList xs ys -> SubList xs (x :: ys)+data SubList : List a -> List a -> Type where+     SubNil : SubList [] []+     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+subListId : SubList xs xs+subListId {xs = Nil} = SubNil+subListId {xs = x :: xs} = Keep subListId  namespace Env   data Env  : (m : Type -> Type) -> List EFFECT -> Type where        Nil  : Env m Nil        (::) : Handler eff m => a -> Env m xs -> Env m (MkEff a eff :: xs)-       + data EffElem : Effect -> Type ->                List EFFECT -> Type where      Here : EffElem x a (MkEff a x :: xs)@@ -129,71 +128,62 @@ relabel {xs = (MkEff a e :: xs)} l (v :: vs) = (l := v) :: relabel l vs  -- ------------------------------------------------- [ The Language of Effects ]-||| Definition of an Effect.-||| -||| @ m The computation context+||| Definition of a language of effectful programs.+||| ||| @ x The return type of the result. ||| @ es The list of allowed side-effects. ||| @ ce Function to compute a new list of allowed side-effects.-data Eff : (m : Type -> Type)-           -> (x : Type)+data Eff : (x : Type)            -> (es : List EFFECT)            -> (ce : x -> List EFFECT) -> Type where-     value    : a -> Eff m a xs (\v => xs)-     with_val : (val : a) -> Eff m () xs (\v => xs' val) ->-                Eff m a xs xs'-     ebind    : Eff m a xs xs' -> -                ((val : a) -> Eff m b (xs' val) xs'') -> Eff m b xs xs''+     value    : a -> Eff a xs (\v => xs)+     with_val : (val : a) -> Eff () xs (\v => xs' val) ->+                Eff a xs xs'+     ebind    : Eff a xs xs' ->+                ((val : a) -> Eff b (xs' val) xs'') -> Eff b xs xs''      callP    : (prf : EffElem e a xs) ->                 (eff : e t a b) ->-                Eff m t xs (\v => updateResTy v xs prf eff)+                Eff t xs (\v => updateResTy v xs prf eff)       liftP    : (prf : SubList ys xs) ->-                Eff m t ys ys' -> Eff m t xs (\v => updateWith (ys' v) xs prf)-     newInit  : Handler e m =>-                res -> -                Eff m a (MkEff res e :: xs) (\v => (MkEff res' e :: xs')) ->-                Eff m a xs (\v => xs')-     catch    : Catchable m err =>-                Eff m a xs xs' -> (err -> Eff m a xs xs') ->-                Eff m a xs xs'+                Eff t ys ys' -> Eff t xs (\v => updateWith (ys' v) xs prf) -     (:-)     : (l : ty) -> -                Eff m t [x] xs' -> -- [x] (\v => xs) -> -                Eff m t [l ::: x] (\v => map (l :::) (xs' v))+     (:-)     : (l : ty) ->+                Eff t [x] xs' -> -- [x] (\v => xs) ->+                Eff t [l ::: x] (\v => map (l :::) (xs' v)) -(>>=)   : Eff m a xs xs' -> -          ((val : a) -> Eff m b (xs' val) xs'') -> Eff m b xs xs''-(>>=) = ebind +(>>=)   : Eff a xs xs' ->+          ((val : a) -> Eff b (xs' val) xs'') -> Eff b xs xs''+(>>=) = ebind  -- namespace SimpleBind---   (>>=) : Eff m a xs (\v => xs) -> +--   (>>=) : Eff m a xs (\v => xs) -> --           ((val : a) -> Eff m b xs xs') -> Eff m b xs xs'---   (>>=) = ebind +--   (>>=) = ebind  ||| Run a subprogram which results in an effect state the same as the input.-staticEff : Eff m a xs (\v => xs) -> Eff m a xs (\v => xs)+staticEff : Eff a xs (\v => xs) -> Eff a xs (\v => xs) staticEff = id  ||| Explicitly give the expected set of result effects for an effectful ||| operation.-toEff : .(xs' : List EFFECT) -> Eff m a xs (\v => xs') -> Eff m a xs (\v => xs')+toEff : .(xs' : List EFFECT) -> Eff a xs (\v => xs') -> Eff a xs (\v => xs') toEff xs' = id -return : a -> Eff m a xs (\v => xs)+return : a -> Eff a xs (\v => xs) return x = value x  -- ------------------------------------------------------ [ for idiom brackets ]  infixl 2 <$> -pure : a -> Eff m a xs (\v => xs)+pure : a -> Eff a xs (\v => xs) pure = value  syntax pureM [val] = with_val val (pure ()) -(<$>) : Eff m (a -> b) xs (\v => xs) -> -        Eff m a xs (\v => xs) -> Eff m b xs (\v => xs)+(<$>) : Eff (a -> b) xs (\v => xs) ->+        Eff a xs (\v => xs) -> Eff b xs (\v => xs) (<$>) prog v = do fn <- prog                   arg <- v                   return (fn arg)@@ -213,20 +203,15 @@ -- 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 -> Eff m a xs xs' -> ((x : a) -> Env m (xs' x) -> m b) -> m b+eff : Env m xs -> Eff a xs xs' -> ((x : a) -> Env m (xs' x) -> m b) -> m b eff env (value x) k = k x env-eff env (with_val x prog) k = eff env prog (\p', env' => k x env') +eff env (with_val x prog) k = eff env prog (\p', env' => k x env') eff env (prog `ebind` c) k    = eff env prog (\p', env' => eff env' (c p') k) eff env (callP prf effP) k = execEff env prf effP k eff env (liftP prf effP) k    = let env' = dropEnv env prf in          eff env' effP (\p', envk => k p' (rebuildEnv envk prf env))-eff env (newInit r prog) k-   = eff (r :: env) prog (\p' => \ (v :: envk) => k p' envk)-eff env (catch prog handler) k-   = catch (eff env prog k)-           (\e => eff env (handler e) k) -- FIXME: -- xs is needed explicitly because otherwise the pattern binding for -- 'l' appears too late. Solution seems to be to reorder patterns at the@@ -251,61 +236,78 @@        (eff : e t a b) ->        {default tactics { search 100; }           prf : EffElem e a xs} ->-      Eff m t xs (\v => updateResTy v xs prf eff)+      Eff t xs (\v => updateResTy v xs prf eff) call e {prf} = callP prf e  implicit-lift : Eff m t ys ys' ->+lift : Eff t ys ys' ->        {default tactics { search 100; }           prf : SubList ys xs} ->-       Eff m t xs (\v => updateWith (ys' v) xs prf)+       Eff t xs (\v => updateWith (ys' v) xs prf) lift e {prf} = liftP prf e  -new : Handler e m =>-      {default default r : res} -> -      Eff m a (MkEff res e :: xs) (\v => (MkEff res' e :: xs')) ->-      Eff m a xs (\v => xs')-new {r} e = newInit r e- -- --------------------------------------------------------- [ Running Effects ]--||| Run an effectful program-run : Applicative m => {default MkDefaultEnv env : Env m xs} -> Eff m a xs xs' -> m a+||| Run an effectful program.+|||+||| The content (`m`) in which to run the program is taken from the+||| environment in which the program is called. The `env` argument is+||| implicit and initialised automatically.+|||+||| @prog The effectful program to run.+run : Applicative m => {default MkDefaultEnv env : Env m xs}+    -> (prog : Eff a xs xs') -> m a run {env} prog = eff env prog (\r, env => pure r) -runPure : {default MkDefaultEnv env : Env id xs} -> Eff id a xs xs' -> a+||| Run an effectful program in the identity context.+|||+||| A helper function useful for when the given context is 'pure'.+||| The `env` argument is implicit and initialised automatically.+|||+||| @prog The effectful program to run.+runPure : {default MkDefaultEnv env : Env id xs} -> (prog : Eff a xs xs') -> a runPure {env} prog = eff env prog (\r, env => r) -runInit : Applicative m => Env m xs -> Eff m a xs xs' -> m a+||| Run an effectful program in a given context `m` with a default value for the environment.+|||+||| This is useful for when there is no default environment for the given context.+|||+||| @env The environment to use.+||| @prog The effectful program to run.+runInit : Applicative m => (env : Env m xs) -> (prog : Eff a xs xs') -> m a runInit env prog = eff env prog (\r, env => pure r) -runPureInit : Env id xs -> Eff id a xs xs' -> a+||| Run an effectful program with a given default value for the environment.+|||+||| A helper function useful for when the given context is 'pure' and there is no default environment.+|||+||| @env The environment to use.+||| @prog The effectful program to run.+runPureInit : (env : Env id xs) -> (prog : Eff a xs xs') -> a runPureInit env prog = eff env prog (\r, env => r) -runWith : (a -> m a) -> Env m xs -> Eff m a xs xs' -> m a+runWith : (a -> m a) -> Env m xs -> Eff a xs xs' -> m a runWith inj env prog = eff env prog (\r, env => inj r) -runEnv : Applicative m => Env m xs -> Eff m a xs xs' -> +runEnv : Applicative m => Env m xs -> Eff a xs xs' ->          m (x : a ** Env m (xs' x)) runEnv env prog = eff env prog (\r, env => pure (r ** env))  -- ----------------------------------------------- [ some higher order things ] -mapE : Applicative m => (a -> {xs} Eff m b) -> List a -> {xs} Eff m (List b)+mapE : (a -> {xs} Eff b) -> List a -> {xs} Eff (List b) mapE f []        = pure [] mapE f (x :: xs) = [| f x :: mapE f xs |]  -mapVE : Applicative m => -          (a -> {xs} Eff m b) -> -          Vect n a -> -          {xs} Eff m (Vect n b)+mapVE : (a -> {xs} Eff b) ->+        Vect n a ->+        {xs} Eff (Vect n b) mapVE f []        = pure [] mapVE f (x :: xs) = [| f x :: mapVE f xs |]  -when : Applicative m => Bool -> Lazy ({xs} Eff m ()) -> {xs} Eff m ()+when : Bool -> Lazy ({xs} Eff ()) -> {xs} Eff () when True  e = Force e when False e = pure ()
− libs/oldeffects/Effect/Exception.idr 
@@ -1,40 +0,0 @@-module Effect.Exception--import Effects-import System-import Control.IOExcept--data Exception : Type -> Type -> Type -> Type -> Type where-     Raise : a -> Exception a () () b--instance Handler (Exception a) Maybe where-     handle _ (Raise e) k = Nothing--instance Show a => Handler (Exception a) IO where-     handle _ (Raise e) k = do print e-                               believe_me (exit 1)--instance Handler (Exception a) (IOExcept a) where-     handle _ (Raise e) k = ioM (return (Left e))--instance Handler (Exception a) (Either a) where-     handle _ (Raise e) k = Left e--EXCEPTION : Type -> EFFECT-EXCEPTION t = MkEff () (Exception t)--raise : a -> Eff m [EXCEPTION a] b-raise err = Raise err---------- TODO: Catching exceptions mid program?--- probably need to invoke a new interpreter---- possibly add a 'handle' to the Eff language so that an alternative--- handler can be introduced mid interpretation?-
− libs/oldeffects/Effect/File.idr 
@@ -1,69 +0,0 @@-module Effect.File--import Effects-import Control.IOExcept--data OpenFile : Mode -> Type where-     FH : File -> OpenFile m--data FileIO : Effect where-     Open  : String -> (m : Mode) -> FileIO () (Either () (OpenFile m)) Bool-     Close :                         FileIO (OpenFile m) () ()--     ReadLine  :           FileIO (OpenFile Read)  (OpenFile Read) String-     WriteLine : String -> FileIO (OpenFile Write) (OpenFile Write) ()-     EOF       :           FileIO (OpenFile Read)  (OpenFile Read) Bool---instance Handler FileIO IO where-    handle () (Open fname m) k = do h <- openFile fname m-                                    valid <- validFile h-                                    if valid then k (Right (FH h)) True-                                             else k (Left ()) False-    handle (FH h) Close      k = do closeFile h-                                    k () ()-    handle (FH h) ReadLine        k = do str <- fread h-                                         k (FH h) str-    handle (FH h) (WriteLine str) k = do fwrite h str-                                         k (FH h) ()-    handle (FH h) EOF             k = do e <- feof h-                                         k (FH h) e--instance Handler FileIO (IOExcept String) where-    handle () (Open fname m) k-       = do h <- ioe_lift (openFile fname m)-            valid <- ioe_lift (validFile h)-            if valid then k (Right (FH h)) True-                     else k (Left ()) False-    handle (FH h) Close           k = do ioe_lift (closeFile h); k () ()-    handle (FH h) ReadLine        k = do str <- ioe_lift (fread h)-                                         k (FH h) str-    handle (FH h) (WriteLine str) k = do ioe_lift (fwrite h str)-                                         k (FH h) ()-    handle (FH h) EOF             k = do e <- ioe_lift (feof h)-                                         k (FH h) e--FILE_IO : Type -> EFFECT-FILE_IO t = MkEff t FileIO--open : Handler FileIO e =>-       String -> (m : Mode) -> EffM e [FILE_IO ()]-                                      [FILE_IO (Either () (OpenFile m))] Bool-open f m = Open f m--close : Handler FileIO e =>-        EffM e [FILE_IO (OpenFile m)] [FILE_IO ()] ()-close = Close--readLine : Handler FileIO e => Eff e [FILE_IO (OpenFile Read)] String-readLine = ReadLine--writeLine : Handler FileIO e => String -> Eff e [FILE_IO (OpenFile Write)] ()-writeLine str = WriteLine str--eof : Handler FileIO e => Eff e [FILE_IO (OpenFile Read)] Bool-eof = EOF----
− libs/oldeffects/Effect/Memory.idr 
@@ -1,169 +0,0 @@-module Effect.Memory--import Effects-import Control.IOExcept--%access public--abstract-data MemoryChunk : Nat -> Nat -> Type where-     CH : Ptr -> MemoryChunk size initialized--abstract-data RawMemory : Effect where-     Allocate   : (n : Nat) ->-                  RawMemory () (MemoryChunk n 0) ()-     Free       : RawMemory (MemoryChunk n i) () ()-     Initialize : Bits8 ->-                  (size : Nat) ->-                  so (i + size <= n) ->-                  RawMemory (MemoryChunk n i) (MemoryChunk n (i + size)) ()-     Peek       : (offset : Nat) ->-                  (size : Nat) ->-                  so (offset + size <= i) ->-                  RawMemory (MemoryChunk n i) (MemoryChunk n i) (Vect size Bits8)-     Poke       :  (offset : Nat) ->-                  (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) ->-                  (dst_offset : Nat) ->-                  (src_offset : Nat) ->-                  (size : Nat) ->-                  so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->-                  so (src_offset + size <= src_init) ->-                  RawMemory (MemoryChunk dst_size dst_init)-                            (MemoryChunk dst_size (max dst_init (dst_offset + size))) ()-     GetRawPtr  : RawMemory (MemoryChunk n i) (MemoryChunk n i) (MemoryChunk n i)--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) (fromInteger $ cast size)-               fail  <- ioe_lift $ nullPtr ptr-               if fail then ioe_fail "Cannot allocate memory"-               else return ptr-  | False = ioe_fail "The target architecture does not support adressing enough memory"--private-do_memset : Ptr -> Nat -> Bits8 -> Nat -> IO ()-do_memset ptr offset c size-  = mkForeign (FFun "idris_memset" [FPtr, FInt, FByte, FInt] FUnit)-              ptr (fromInteger $ cast offset) c (fromInteger $ cast size)--private-do_free : Ptr -> IO ()-do_free ptr = mkForeign (FFun "free" [FPtr] FUnit) ptr--private-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 (fromInteger $ cast dest_offset) (fromInteger $ cast src_offset) (fromInteger $ cast size)--private-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] 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 size Bits8 -> IO ()-do_poke _   _      []     = return ()-do_poke ptr offset (b::bs)-  = 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-  handle () (Allocate n) k-    = do ptr <- do_malloc n-         k (CH ptr) ()-  handle (CH ptr) (Initialize {i} c size _) k-    = ioe_lift (do_memset ptr i c size) $> k (CH ptr) ()-  handle (CH ptr) (Free) k-    = ioe_lift (do_free ptr) $> k () ()-  handle (CH ptr) (Peek offset size _) k-    = do res <- ioe_lift (do_peek ptr offset size)-         k (CH ptr) res-  handle (CH ptr) (Poke offset content _) k-    = do ioe_lift (do_poke ptr offset content)-         k (CH ptr) ()-  handle (CH dest_ptr) (Move (CH src_ptr) dest_offset src_offset size _ _) k-    = do ioe_lift (do_memmove dest_ptr src_ptr dest_offset src_offset size)-         k (CH dest_ptr) ()-  handle chunk (GetRawPtr) k-    = k chunk chunk--RAW_MEMORY : Type -> EFFECT-RAW_MEMORY t = MkEff t RawMemory--allocate : (n : Nat) -> EffM m [RAW_MEMORY ()] [RAW_MEMORY (MemoryChunk n 0)] ()-allocate size = Allocate size--initialize : {i : Nat} ->-             {n : Nat} ->-             Bits8 ->-             (size : Nat) ->-             so (i + size <= n) ->-             EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY (MemoryChunk n (i + size))] ()-initialize c size prf = Initialize c size prf--free : EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY ()] ()-free = Free--peek : {i : Nat} ->-       (offset : Nat) ->-       (size : Nat) ->-       so (offset + size <= i) ->-       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 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--private-getRawPtr : Eff m [RAW_MEMORY (MemoryChunk n i)] (MemoryChunk n i)-getRawPtr = GetRawPtr--private-move' : {dst_size : Nat} ->-        {dst_init : Nat} ->-        {src_init : Nat} ->-        (src_ptr : MemoryChunk src_size src_init) ->-        (dst_offset : Nat) ->-        (src_offset : Nat) ->-        (size : Nat) ->-        so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->-        so (src_offset + size <= src_init) ->-        EffM m [RAW_MEMORY (MemoryChunk dst_size dst_init)]-               [RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))] ()-move' src_ptr dst_offset src_offset size dst_bounds src_bounds-  = Move src_ptr dst_offset src_offset size dst_bounds src_bounds--data MoveDescriptor = Dst | Src--move : {dst_size : Nat} ->-       {dst_init : Nat} ->-       {src_size : Nat} ->-       {src_init : Nat} ->-       (dst_offset : Nat) ->-       (src_offset : Nat) ->-       (size : Nat) ->-       so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->-       so (src_offset + size <= src_init) ->-       EffM m [ Dst ::: RAW_MEMORY (MemoryChunk dst_size dst_init)-              , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)]-              [ Dst ::: RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))-              , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)] ()-move dst_offset src_offset size dst_bounds src_bounds-  = do src_ptr <- Src :- getRawPtr-       Dst :- move' src_ptr dst_offset src_offset size dst_bounds src_bounds-       return () -
− libs/oldeffects/Effect/Monad.idr 
@@ -1,21 +0,0 @@-module Effect.Monad--import Effects---- Eff is a monad too, so we can happily use it in a monad transformer.--using (xs : List EFFECT, m : Type -> Type)-  instance Functor (EffM m xs xs) where-    map f prog = do t <- prog-                    value (f t)--  instance Applicative (EffM m xs xs) where-    pure = value-    (<$>) f a = do f' <- f-                   a' <- a-                   value (f' a')--  instance Monad (EffM m xs xs) where-    (>>=) = ebind--
− libs/oldeffects/Effect/Random.idr 
@@ -1,25 +0,0 @@-module Effect.Random--import Effects--data Random : Type -> Type -> Type -> Type where-     getRandom : Random Integer Integer Integer-     setSeed   : Integer -> Random Integer Integer ()--using (m : Type -> Type)-  instance Handler Random m where-     handle seed getRandom k-              = let seed' = (1664525 * seed + 1013904223) `prim__sremBigInt` (pow 2 32) in-                    k seed' seed'-     handle seed (setSeed n) k = k n ()--RND : EFFECT-RND = MkEff Integer Random--rndInt : Integer -> Integer -> Eff m [RND] Integer-rndInt lower upper = do v <- getRandom-                        return (v `prim__sremBigInt` (upper - lower) + lower)--srand : Integer -> Eff m [RND] ()-srand n = setSeed n-
− libs/oldeffects/Effect/Select.idr 
@@ -1,23 +0,0 @@-module Effect.Select--import Effects--data Selection : Effect where-     Select : List a -> Selection () () a--instance Handler Selection Maybe where-     handle _ (Select xs) k = tryAll xs where-         tryAll [] = Nothing-         tryAll (x :: xs) = case k () x of-                                 Nothing => tryAll xs-                                 Just v => Just v--instance Handler Selection List where-     handle r (Select xs) k = concatMap (k r) xs--SELECT : EFFECT-SELECT = MkEff () Selection--select : List a -> Eff m [SELECT] a-select xs = Select xs-
− libs/oldeffects/Effect/State.idr 
@@ -1,40 +0,0 @@-module Effect.State--import Effects--%access public--data State : Effect where-     Get :      State a a a-     Put : b -> State a b ()--using (m : Type -> Type)-  instance Handler State m where-     handle st Get     k = k st st-     handle st (Put n) k = k n ()--STATE : Type -> EFFECT-STATE t = MkEff t State--get : Eff m [STATE x] x-get = Get--put : x -> Eff m [STATE x] ()-put val = Put val--putM : y -> EffM m [STATE x] [STATE y] ()-putM val = Put val--update : (x -> x) -> Eff m [STATE x] ()-update f = put (f !get)--updateM : (x -> y) -> EffM m [STATE x] [STATE y] ()-updateM f = putM (f !get)--locally : x -> Eff m [STATE x] t -> Eff m [STATE y] t-locally newst prog = do st <- get-                        putM newst-                        val <- prog-                        putM st-                        return val-
− libs/oldeffects/Effect/StdIO.idr 
@@ -1,60 +0,0 @@-module Effect.StdIO--import Effects-import Control.IOExcept--data StdIO : Effect where-     PutStr : String -> StdIO () () ()-     GetStr : StdIO () () String--instance Handler StdIO IO where-    handle () (PutStr s) k = do putStr s; k () ()-    handle () GetStr     k = do x <- getLine; k () x--instance Handler StdIO (IOExcept a) where-    handle () (PutStr s) k = do ioe_lift (putStr s); k () ()-    handle () GetStr     k = do x <- ioe_lift getLine; k () x---- Handle effects in a pure way, for simulating IO for unit testing/proof--data IOStream a = MkStream (List String -> (a, List String))--instance Handler StdIO IOStream where-    handle () (PutStr s) k-       = MkStream (\x => case k () () of-                         MkStream f => let (res, str) = f x in-                                           (res, s :: str))-    handle {a} () GetStr k-       = MkStream (\x => case x of-                              [] => cont "" []-                              (t :: ts) => cont t ts)-        where-            cont : String -> List String -> (a, List String)-            cont t ts = case k () t of-                             MkStream f => f ts----- The Effect and associated functions--STDIO : EFFECT-STDIO = MkEff () StdIO--putStr : Handler StdIO e => String -> Eff e [STDIO] ()-putStr s = PutStr s--putStrLn : Handler StdIO e => String -> Eff e [STDIO] ()-putStrLn s = putStr (s ++ "\n")--getStr : Handler StdIO e => Eff e [STDIO] String-getStr = GetStr--mkStrFn : Env IOStream xs ->-          Eff IOStream xs a ->-          List String -> (a, List String)-mkStrFn {a} env p input = case mkStrFn' of-                               MkStream f => f input-  where injStream : a -> IOStream a-        injStream v = MkStream (\x => (v, []))-        mkStrFn' : IOStream a-        mkStrFn' = runWith injStream env p--
− libs/oldeffects/Effects.idr 
@@ -1,308 +0,0 @@-module Effects--import Language.Reflection-import Control.Catchable--%access public------ Effects--Effect : Type-Effect = Type -> Type -> Type -> Type--%error_reverse-data EFFECT : Type where-     MkEff : Type -> Effect -> EFFECT--class Handler (e : Effect) (m : Type -> Type) where-     handle : res -> (eff : e res res' t) -> (res' -> t -> m a) -> m a------ Properties and proof construction--using (xs : List a, ys : List a)-  data SubList : List a -> List a -> 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--data Env  : (m : Type -> Type) -> List EFFECT -> Type where-     Nil  : Env m Nil-     (::) : Handler eff m => a -> Env m xs -> Env m (MkEff a eff :: xs)--data EffElem : (Type -> Type -> Type -> Type) -> Type ->-               List EFFECT -> 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' : List a) -> (xs : List a) ->-             SubList ys xs -> List a-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) ->-             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-rebuildEnv (x :: xs) SubNil      [] = x :: xs------ The Effect EDSL itself -------- some proof automation--%reflection-reflectListEffElem : List a -> Tactic-reflectListEffElem [] = Refine "Here" `Seq` Solve-reflectListEffElem (x :: xs)-     = Try (Refine "Here" `Seq` Solve)-           (Refine "There" `Seq` (Solve `Seq` reflectListEffElem xs))--- TMP HACK! FIXME!--- The evaluator needs a 'function case' to know its a reflection function--- until we propagate that information! Without this, the _ case won't get--- matched. -reflectListEffElem (x ++ y) = Refine "Here" `Seq` Solve-reflectListEffElem _ = Refine "Here" `Seq` Solve--%reflection-reflectSubList : List a -> Tactic-reflectSubList [] = Refine "SubNil" `Seq` Solve-reflectSubList (x :: xs)-     = Try (Refine "subListId" `Seq` Solve)-           (Try (Refine "Keep" `Seq` (Solve `Seq` reflectSubList xs))-                (Refine "Drop" `Seq` (Solve `Seq` reflectSubList xs)))-reflectSubList (x ++ y) = Refine "subListId" `Seq` Solve-reflectSubList _ = Refine "subListId" `Seq` Solve--%reflection-reflectEff : (P : Type) -> Tactic-reflectEff (EffElem m a xs)-     = reflectListEffElem xs `Seq` Solve-reflectEff (SubList xs ys)-     = reflectSubList ys `Seq` Solve--updateResTy : (xs : List EFFECT) -> EffElem e a xs -> e a b t ->-              List EFFECT-updateResTy {b} (MkEff a e :: xs) Here n = (MkEff b e) :: xs-updateResTy (x :: xs)        (There p) n = x :: updateResTy xs p n--updateResTyImm : (xs : List EFFECT) -> EffElem e a xs -> Type ->-                 List EFFECT-updateResTyImm (MkEff a e :: xs) Here b = (MkEff b e) :: xs-updateResTyImm (x :: xs)    (There p) b = x :: updateResTyImm xs p b--infix 5 :::, :-, :=--data LRes : lbl -> Type -> Type where-     (:=) : (x : lbl) -> res -> LRes x res--(:::) : lbl -> EFFECT -> EFFECT-(:::) {lbl} x (MkEff r eff) = MkEff (LRes x r) eff--private-unlabel : {l : ty} -> Env m [l ::: x] -> Env m [x]-unlabel {m} {x = MkEff a eff} [l := v] = [v]--private-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) ->-            List EFFECT -> List EFFECT -> 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  : (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     : Handler e m =>-               res -> EffM m (MkEff res e :: xs) (MkEff res' e :: xs') a ->-               EffM m xs xs' a-     test    : (prf : EffElem e (Either l r) xs) ->-               EffM m (updateResTyImm xs prf l) xs' t ->-               EffM m (updateResTyImm xs prf r) xs' t ->-               EffM m xs xs' t-     test_lbl : {x : lbl} ->-                (prf : EffElem e (LRes x (Either l r)) xs) ->-                EffM m (updateResTyImm xs prf (LRes x l)) xs' t ->-                EffM m (updateResTyImm xs prf (LRes x r)) xs' t ->-                EffM m xs xs' t-     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--syntax [tag] ":!" [val] = !(tag :- val)----   Eff : List (EFFECT m) -> Type -> Type---- For making proofs implicitly for 'test' and 'test_lbl'--syntax if_valid then [e] else [t] =-  test (tactics { byReflection reflectEff; }) t e--syntax if_valid [lbl] then [e] else [t] =-  test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e--syntax if_error then [t] else [e] =-  test (tactics { byReflection reflectEff; }) t e--syntax if_error [lbl] then [t] else [e] =-  test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e---- These may read better in some contexts--syntax if_right then [e] else [t] =-  test (tactics { byReflection reflectEff; }) t e--syntax if_right [lbl] then [e] else [t] =-  test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e--syntax if_left then [t] else [e] =-  test (tactics { byReflection reflectEff; }) t e--syntax if_left [lbl] then [t] else [e] =-  test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t 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 : a -> EffM m xs xs a-pure = value--(<$>) : 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--private-execEff : 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-    = handle val eff' (\res, v => k (res :: env) v)-execEff {e} {res} {b} {a} (val :: env) (There p) eff k-    = execEff {e} {res} {b} {a} env p eff (\env', v => k (val :: env') v)--private-testEff : Env m xs -> (p : EffElem e (Either l r) xs) ->-          (Env m (updateResTyImm xs p l) -> m b) ->-          (Env m (updateResTyImm xs p r) -> m b) ->-          m b-testEff (Left err :: env) Here lk rk = lk (err :: env)-testEff (Right ok :: env) Here lk rk = rk (ok :: env)-testEff (val :: env) (There p) lk rk-   = testEff env p (\envk => lk (val :: envk))-                   (\envk => rk (val :: envk))--private-testEffLbl : {x : lblTy} ->-             Env m xs -> (p : EffElem e (LRes x (Either l r)) xs) ->-             (Env m (updateResTyImm xs p (LRes x l)) -> m b) ->-             (Env m (updateResTyImm xs p (LRes x r)) -> m b) ->-             m b-testEffLbl ((lbl := Left err) :: env) Here lk rk = lk ((lbl := err) :: env)-testEffLbl ((lbl := Right ok) :: env) Here lk rk = rk ((lbl := ok) :: env)-testEffLbl (val :: env) (There p) lk rk-   = testEffLbl env p (\envk => lk (val :: envk))-                      (\envk => rk (val :: envk))---- 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-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-   = eff (r :: env) prog (\(v :: envk), p' => k envk p')-eff env (test prf l r) k-   = testEff env prf (\envk => eff envk l k) (\envk => eff envk r k)-eff env (test_lbl prf l r) k-   = testEffLbl env prf (\envk => eff envk l k) (\envk => eff envk r k)-eff env (catch prog handler) k-   = catch (eff env prog k)-           (\e => eff env (handler e) k)--- FIXME:--- xs is needed explicitly because otherwise the pattern binding for--- 'l' appears too late. Solution seems to be to reorder patterns at the--- end so that everything is in scope when it needs to be.-eff {xs = [l ::: x]} env (l :- prog) k-   = let env' = unlabel env in-         eff env' prog (\envk, p' => k (relabel l envk) p')--implicit-lift' : EffM m ys ys' t ->-        {default tactics { byReflection reflectEff; }-           prf : SubList ys xs} ->-        EffM m xs (updateWith ys' xs prf) t-lift' e {prf} = lift prf e--implicit-effect' : {a, b: _} -> {e : Effect} ->-          (eff : e a b t) ->-          {default tactics { byReflection reflectEff; }-             prf : EffElem e a xs} ->-         EffM m xs (updateResTy xs prf eff) t-effect' e {prf} = effect prf e---run : Applicative m => Env m xs -> EffM m xs xs' a -> m a-run env prog = eff env prog (\env, r => pure r)--runEnv : Applicative m => Env m xs -> EffM m xs xs' a -> m (Env m xs', a)-runEnv env prog = eff env prog (\env, r => pure (env, r))--runPure : Env id xs -> EffM id xs xs' a -> a-runPure env prog = eff env prog (\env, r => r)---- runPureEnv : Env id xs -> EffM id xs xs' a -> (Env id xs', a)--- runPureEnv env prog = eff env prog (\env, r => (env, r))--runWith : (a -> m a) -> Env m xs -> EffM m xs xs' a -> m a-runWith inj env prog = eff env prog (\env, r => inj r)--Eff : (Type -> Type) -> List EFFECT -> Type -> Type-Eff m xs t = EffM m xs xs t---- some higher order things--mapE : Applicative m => (a -> Eff m xs b) -> List a -> Eff m xs (List b)-mapE f []        = pure []-mapE f (x :: xs) = [| f x :: mapE f xs |]--when : Applicative m => Bool -> Lazy (Eff m xs ()) -> Eff m xs ()-when True  e = e-when False e = pure ()
− libs/oldeffects/Makefile 
@@ -1,14 +0,0 @@-IDRIS     := idris--build:-	$(IDRIS) --build oldeffects.ipkg--clean:-	$(IDRIS) --clean oldeffects.ipkg--install:-	$(IDRIS) --install oldeffects.ipkg--rebuild: clean build--.PHONY: build clean install rebuild
− libs/oldeffects/oldeffects.ipkg 
@@ -1,8 +0,0 @@-package oldeffects--opts    = "--nobasepkgs -i ../prelude -i ../base"-modules = Effects, -          Effect.Exception, Effect.File, Effect.State,-          Effect.Random, Effect.StdIO, Effect.Select,-          Effect.Memory, Effect.Monad-
libs/prelude/Builtins.idr view
@@ -15,6 +15,14 @@ ||| For 'symbol syntax. 'foo becomes Symbol_ "foo" data Symbol_ : String -> Type where +-- Eq_ : a -> a -> Type+-- Eq_ x y = (=) _ _ x y+ +infix 5 ~=~++(~=~) : a -> b -> Type+(~=~) x y = (=) _ _ x y+ -- ------------------------------------------------------ [ For rewrite tactic ] ||| Perform substitution in a term according to some equality. |||
libs/prelude/Makefile view
@@ -1,17 +1,24 @@ IDRIS := idris+PKG   := prelude  build:-	$(IDRIS) --build prelude.ipkg+	$(IDRIS) --build ${PKG}.ipkg  install: -	$(IDRIS) --install prelude.ipkg+	$(IDRIS) --install ${PKG}.ipkg  clean:-	$(IDRIS) --clean prelude.ipkg+	$(IDRIS) --clean ${PKG}.ipkg  rebuild: clean build  linecount: 	find . -name '*.idr' | xargs wc -l -.PHONY: build install clean rebuild linecount+doc:+	$(IDRIS) --mkdoc ${PKG}.ipkg++doc_clean:+	rm -rf ${PKG}_doc++.PHONY: build install clean rebuild linecount doc
libs/prelude/Prelude/Algebra.idr view
@@ -177,7 +177,7 @@   total meetSemilatticeMeetIsIdempotent  : (e : a)       -> meet e e = e  ||| Sets equipped with a binary operation that is commutative, associative and-||| idempotent and supplied with a neutral element.  Must satisfy the following+||| idempotent and supplied with a unitary element.  Must satisfy the following ||| laws: ||| ||| + Associativity of join:@@ -186,8 +186,8 @@ |||     forall a b,   join a b          == join b a ||| + Idempotency of join: |||     forall a,     join a a          == a-||| + Bottom:-|||     forall a,     join a bottom     == bottom+||| + Bottom (Unitary Element):+|||     forall a,     join a bottom     == a ||| |||  Join semilattices capture the notion of sets with a "least upper bound" |||  equipped with a "bottom" element.@@ -195,10 +195,10 @@   bottom  : a  class (VerifiedJoinSemilattice a, BoundedJoinSemilattice a) => VerifiedBoundedJoinSemilattice a where-  total boundedJoinSemilatticeBottomIsBottom : (e : a) -> join e bottom = bottom+  total boundedJoinSemilatticeBottomIsBottom : (e : a) -> join e bottom = e  ||| Sets equipped with a binary operation that is commutative, associative and-||| idempotent and supplied with a neutral element.  Must satisfy the following+||| idempotent and supplied with a unitary element.  Must satisfy the following ||| laws: ||| ||| + Associativity of meet:@@ -207,8 +207,8 @@ |||     forall a b,   meet a b          == meet b a ||| + Idempotency of meet: |||     forall a,     meet a a          == a-||| +  Top:-|||     forall a,     meet a top        == top+||| +  Top (Unitary Element):+|||     forall a,     meet a top        == a ||| ||| Meet semilattices capture the notion of sets with a "greatest lower bound" ||| equipped with a "top" element.@@ -216,7 +216,7 @@   top : a  class (VerifiedMeetSemilattice a, BoundedMeetSemilattice a) => VerifiedBoundedMeetSemilattice a where-  total boundedMeetSemilatticeTopIsTop : (e : a) -> meet e top = top+  total boundedMeetSemilatticeTopIsTop : (e : a) -> meet e top = e  ||| Sets equipped with two binary operations that are both commutative, ||| associative and idempotent, along with absorbtion laws for relating the two
libs/prelude/Prelude/Bool.idr view
@@ -5,7 +5,7 @@ import Prelude.Uninhabited  ||| Boolean Data Type-data Bool = False | True+%case data Bool = False | True  ||| The underlying implementation of the if ... then ... else ... syntax ||| @ b the condition on the if
libs/prelude/Prelude/Classes.idr view
@@ -124,6 +124,13 @@                   GT  +instance Ord Bool where+    compare True True = EQ+    compare False False = EQ+    compare False True = LT+    compare True False = GT++ instance (Ord a, Ord b) => Ord (a, b) where   compare (xl, xr) (yl, yr) =     if xl /= yl
libs/prelude/Prelude/List.idr view
@@ -557,6 +557,12 @@   []        => []   _ :: xs'  => tails xs' +splitOn : Eq a => a -> List a -> List (List a)+splitOn a = split (== a)++replaceOn : Eq a => a -> a -> List a -> List a+replaceOn a b l = map (\c => if c == a then b else c) l+ -------------------------------------------------------------------------------- -- Predicates --------------------------------------------------------------------------------@@ -578,6 +584,9 @@  isSuffixOf : Eq a => List a -> List a -> Bool isSuffixOf = isSuffixOfBy (==)++isInfixOf : Eq a => List a -> List a -> Bool+isInfixOf n h = any (isPrefixOf n) (tails h)  -------------------------------------------------------------------------------- -- Sorting
libs/prelude/Prelude/Nat.idr view
@@ -110,6 +110,22 @@ total GT : Nat -> Nat -> Type GT left right = LT right left +||| A successor is never less than or equal zero+succNotLTEzero : Not (S m `LTE` Z)+succNotLTEzero lteZero impossible++||| If two numbers are ordered, their predecessors are too+fromLteSucc : (S m `LTE` S n) -> (m `LTE` n)+fromLteSucc (lteSucc x) = x++||| A decision procedure for `LTE`+isLTE : (m, n : Nat) -> Dec (m `LTE` n)+isLTE Z n = Yes lteZero+isLTE (S k) Z = No succNotLTEzero+isLTE (S k) (S j) with (isLTE k j)+  isLTE (S k) (S j) | (Yes prf) = Yes (lteSucc prf)+  isLTE (S k) (S j) | (No contra) = No (contra . fromLteSucc)+ ||| Boolean test than one Nat is less than or equal to another total lte : Nat -> Nat -> Bool lte Z        right     = True@@ -130,19 +146,15 @@  ||| Find the least of two natural numbers total minimum : Nat -> Nat -> Nat-minimum left right =-  if lte left right then-    left-  else-    right+minimum Z m = Z+minimum (S n) Z = Z+minimum (S n) (S m) = S (minimum n m)  ||| Find the greatest of two natural numbers total maximum : Nat -> Nat -> Nat-maximum left right =-  if lte left right then-    right-  else-    left+maximum Z m = m+maximum (S n) Z = S n+maximum (S n) (S m) = S (maximum n m)  -------------------------------------------------------------------------------- -- Type class instances@@ -312,7 +324,25 @@ lcm Z _ = Z lcm x y = divNat (x * y) (gcd x y) + --------------------------------------------------------------------------------+-- An informative comparison view +--------------------------------------------------------------------------------+data CmpNat : Nat -> Nat -> Type where+     cmpLT : (y : _) -> CmpNat x (x + S y)+     cmpEQ : CmpNat x x+     cmpGT : (x : _) -> CmpNat (y + S x) y++total cmp : (x, y : Nat) -> CmpNat 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++-------------------------------------------------------------------------------- -- Properties -------------------------------------------------------------------------------- @@ -601,8 +631,40 @@ lteSuccZeroFalse (S n) = refl  -- Minimum and maximum+total maximumAssociative : (l,c,r : Nat) -> maximum l (maximum c r) = maximum (maximum l c) r+maximumAssociative Z c r = refl+maximumAssociative (S k) Z r = refl+maximumAssociative (S k) (S j) Z = refl+maximumAssociative (S k) (S j) (S i) = rewrite maximumAssociative k j i in refl++total maximumCommutative : (l, r : Nat) -> maximum l r = maximum r l+maximumCommutative Z Z = refl+maximumCommutative Z (S k) = refl+maximumCommutative (S k) Z = refl+maximumCommutative (S k) (S j) = rewrite maximumCommutative k j in refl++total maximumIdempotent : (n : Nat) -> maximum n n = n+maximumIdempotent Z = refl+maximumIdempotent (S k) = cong (maximumIdempotent k)++total minimumAssociative : (l,c,r : Nat) -> minimum l (minimum c r) = minimum (minimum l c) r+minimumAssociative Z c r = refl+minimumAssociative (S k) Z r = refl+minimumAssociative (S k) (S j) Z = refl+minimumAssociative (S k) (S j) (S i) = rewrite minimumAssociative k j i in refl++total minimumCommutative : (l, r : Nat) -> minimum l r = minimum r l+minimumCommutative Z Z = refl+minimumCommutative Z (S k) = refl+minimumCommutative (S k) Z = refl+minimumCommutative (S k) (S j) = rewrite minimumCommutative k j in refl++total minimumIdempotent : (n : Nat) -> minimum n n = n+minimumIdempotent Z = refl+minimumIdempotent (S k) = cong (minimumIdempotent k)+ total minimumZeroZeroRight : (right : Nat) -> minimum 0 right = Z-minimumZeroZeroRight Z         = refl+minimumZeroZeroRight Z = refl minimumZeroZeroRight (S right) = minimumZeroZeroRight right  total minimumZeroZeroLeft : (left : Nat) -> minimum left 0 = Z@@ -618,15 +680,6 @@   let inductiveHypothesis = minimumSuccSucc left right in     ?minimumSuccSuccStepCase -total minimumCommutative : (left : Nat) -> (right : Nat) ->-  minimum left right = minimum right left-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 Z right = right maximumZeroNRight Z         = refl maximumZeroNRight (S right) = refl@@ -644,15 +697,22 @@   let inductiveHypothesis = maximumSuccSucc left right in     ?maximumSuccSuccStepCase -total maximumCommutative : (left : Nat) -> (right : Nat) ->-  maximum left right = maximum right left-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+total sucMaxL : (l : Nat) -> maximum (S l) l = (S l)+sucMaxL Z = refl+sucMaxL (S l) = cong (sucMaxL l) +total sucMaxR : (l : Nat) -> maximum l (S l) = (S l)+sucMaxR Z = refl+sucMaxR (S l) = cong (sucMaxR l)++total sucMinL : (l : Nat) -> minimum (S l) l = l+sucMinL Z = refl+sucMinL (S l) = cong (sucMinL l)++total sucMinR : (l : Nat) -> minimum l (S l) = l+sucMinR Z = refl+sucMinR (S l) = cong (sucMinR l)+ -- div and mod total modZeroZero : (n : Nat) -> mod 0 n = Z modZeroZero Z     = refl@@ -818,25 +878,9 @@     trivial; } -maximumCommutativeStepCase = proof {-    intros;-    rewrite (boolElimSuccSucc (lte left right) right left);-    rewrite (boolElimSuccSucc (lte right left) left right);-    rewrite inductiveHypothesis;-    trivial;-}- maximumSuccSuccStepCase = proof {     intros;     rewrite sym (boolElimSuccSucc (lte left right) (S right) (S left));-    trivial;-}--minimumCommutativeStepCase = proof {-    intros;-    rewrite (boolElimSuccSucc (lte left right) left right);-    rewrite (boolElimSuccSucc (lte right left) right left);-    rewrite inductiveHypothesis;     trivial; }
libs/prelude/Prelude/Stream.idr view
@@ -72,6 +72,7 @@ ||| Fold a Stream corecursively. Since there is no Nil, no initial value is used. ||| @ f the combining function ||| @ xs the Stream to fold up+partial -- the recursive call isn't guarded! foldr : (f : a -> Inf b -> b) -> (xs : Stream a) -> b foldr f (x :: xs) = f x (foldr f xs) @@ -85,9 +86,10 @@ ||| Produce a Stream of (corecursive) right folds of tails of the given Stream ||| @ f the combining function ||| @ xs the Stream to fold up--- Reusing the head of the corecursion in the obvious way doesn’t productivity check+-- Reusing the head of the corecursion in the obvious way doesn't productivity check+partial -- and the call to foldr isn't guarded anyway! scanr : (f : a -> Inf b -> b) -> (xs : Stream a) -> Stream b-scanr f (x :: Delay xs) = f x (foldr f xs) :: scanr f xs+scanr f (x :: xs) = f x (foldr f xs) :: scanr f xs  ||| Produce a Stream repeating a sequence ||| @ xs the sequence to repeat
libs/prelude/Prelude/Strings.idr view
@@ -271,4 +271,16 @@   strToLower ""             | StrNil = ""   strToLower (strCons c cs) | (StrCons c cs) =     strCons (toUpper c) (toUpper (assert_smaller (strCons c cs) cs ))+   +--------------------------------------------------------------------------------+-- Predicates+-------------------------------------------------------------------------------- +isPrefixOf : String -> String -> Bool+isPrefixOf a b = isPrefixOf (unpack a) (unpack b)++isSuffixOf : String -> String -> Bool+isSuffixOf a b = isSuffixOf (unpack a) (unpack b)++isInfixOf : String -> String -> Bool+isInfixOf a b = isInfixOf (unpack a) (unpack b)
libs/prelude/Prelude/Vect.idr view
@@ -100,17 +100,15 @@  ||| Get the first m elements of a Vect ||| @ m the number of elements to take-take : {n : Nat} -> (m : Fin (S n)) -> Vect n a -> Vect (cast m) a-take (fS k) []      = FinZElim k-take fZ     _       = []-take (fS k) (x::xs) = x :: take k xs+take : (n : Nat) -> Vect (n + m) a -> Vect n a+take Z xs = []+take (S k) (x :: xs) = x :: take k xs  ||| Remove the first m elements of a Vect ||| @ m the number of elements to remove-drop : (m : Fin (S n)) -> Vect n a -> Vect (n - cast m) a-drop (fS k) []      = FinZElim k-drop fZ     xs      ?= xs-drop (fS k) (x::xs) = drop k xs+drop : (n : Nat) -> Vect (n + m) a -> Vect m a+drop Z xs = xs+drop (S k) (x :: xs) = drop k xs  -------------------------------------------------------------------------------- -- Transformations@@ -407,7 +405,7 @@ ||| It is equivalent to (take n xs, drop n xs) ||| @ m   the index to split at ||| @ xs  the Vect to split in two-splitAt : {n : Nat} -> (m : Fin (S n)) -> (xs : Vect n a) -> (Vect (cast m) a, Vect (n - cast m) a)+splitAt : (n : Nat) -> (xs : Vect (n + m) a) -> (Vect n a, Vect m a) splitAt n xs = (take n xs, drop n xs)  --------------------------------------------------------------------------------@@ -488,12 +486,6 @@ -------------------------------------------------------------------------------- -- Proofs ----------------------------------------------------------------------------------Prelude.Vect.drop_lemma_1 = proof {-  intros;-  rewrite sym (minusZeroRight n);-  trivial;-}  Prelude.Vect.reverse'_lemma_1 = proof {     intros;
llvm/Makefile view
@@ -1,13 +1,14 @@ include ../config.mk -CFLAGS:=-Wextra -fPIC -Wno-unused-parameter $(CFLAGS)+PKG_CONFIG_CFLAGS:=$(shell (pkg-config --version >/dev/null 2>&1) && pkg-config --cflags bdw-gc)+CFLAGS:=-Wextra -fPIC -Wno-unused-parameter $(PKG_CONFIG_CFLAGS) $(CFLAGS) SOURCES=defs.c OBJECTS=$(SOURCES:.c=.o) LIB=libidris_rts.a  build: $(SOURCES) $(LIB) -$(LIB): $(OBJECTS) +$(LIB): $(OBJECTS) 	ar r $@ $(OBJECTS) 	ranlib $@
rts/idris_gc.c view
@@ -103,7 +103,14 @@         free(vm->heap.old);      vm->heap.heap = newheap;-    vm->heap.next = newheap;+#ifdef FORCE_ALIGNMENT+    if (((i_int)(vm->heap.heap)&1) == 1) {+        vm->heap.next = newheap + 1;+    } else+#endif+    {+        vm->heap.next = newheap;+    }     vm->heap.end  = newheap + vm->heap.size;      VAL* root;@@ -111,10 +118,12 @@     for(root = vm->valstack; root < vm->valstack_top; ++root) {         *root = copy(vm, *root);     }++#ifdef HAS_PTHREAD     for(root = vm->inbox_ptr; root < vm->inbox_write; ++root) {         *root = copy(vm, *root);     }-    +#endif     vm->ret = copy(vm, vm->ret);     vm->reg1 = copy(vm, vm->reg1);
rts/idris_heap.c view
@@ -16,7 +16,14 @@     }      h->heap = mem;-    h->next = h->heap;+#ifdef FORCE_ALIGNMENT+    if (((i_int)(h->heap)&1) == 1) {+        h->next = h->heap + 1;+    } else+#endif+    {+        h->next = h->heap;+    }     h->end  = h->heap + heap_size;      h->size   = heap_size;
rts/idris_net.c view
@@ -1,6 +1,7 @@ // C-Side of the Idris network library // (C) Simon Fowler, 2014 // MIT Licensed. Have fun!+#include "idris_net.h" #include <errno.h> #include <netdb.h> #include <stdbool.h>@@ -12,8 +13,22 @@ #include <netinet/in.h> #include <arpa/inet.h> -#include "idris_net.h"+void buf_htonl(void* buf, int len) {+    int* buf_i = (int*) buf;+    int i;+    for (i = 0; i < (len / sizeof(int)) + 1; i++) {+        buf_i[i] = htonl(buf_i[i]);+    }+} +void buf_ntohl(void* buf, int len) {+    int* buf_i = (int*) buf;+    int i;+    for (i = 0; i < (len / sizeof(int)) + 1; i++) {+        buf_i[i] = ntohl(buf_i[i]);+    }+}+ void* idrnet_malloc(int size) {     return malloc(size); }@@ -22,9 +37,12 @@     free(ptr); } -int idrnet_bind(int sockfd, int family, int socket_type, char* host, int port) {+// We call this from quite a few functions. Given a textual host and an int port,+// populates a struct addrinfo. +int idrnet_getaddrinfo(struct addrinfo** address_res, char* host, int port, +                       int family, int socket_type) {+     struct addrinfo hints;-    struct addrinfo* address_res;     // Convert port into string     char str_port[8];     sprintf(str_port, "%d", port);@@ -38,43 +56,42 @@     // then we want to instruct the C library to fill in the IP automatically     if (strlen(host) == 0) {         hints.ai_flags = AI_PASSIVE; // fill in IP automatically-    }+        return getaddrinfo(NULL, str_port, &hints, address_res);+    } +    return getaddrinfo(host, str_port, &hints, address_res); -    int addr_res = getaddrinfo(host, str_port, &hints, &address_res);+}++int idrnet_bind(int sockfd, int family, int socket_type, char* host, int port) {+    struct addrinfo* address_res;+    int addr_res = idrnet_getaddrinfo(&address_res, host, port, family, socket_type);     if (addr_res == -1) {+        //printf("Lib err: bind getaddrinfo\n");         return -1;     }      int bind_res = bind(sockfd, address_res->ai_addr, address_res->ai_addrlen);     if (bind_res == -1) {+        //freeaddrinfo(address_res);+        //printf("Lib err: bind\n");         return -1;     } -     return 0; }  int idrnet_connect(int sockfd, int family, int socket_type, char* host, int port) {-    char str_port[8];-    sprintf(str_port, "%d", port);-    struct addrinfo hints;     struct addrinfo* remote_host;--    // Set up hints structure for getaddrinfo-    memset(&hints, 0, sizeof(hints));-    hints.ai_family = family;-    hints.ai_socktype = socket_type;--    // Get info about the remote host (DNS lookup etc)-    int addr_res = getaddrinfo(host, str_port, &hints, &remote_host);+    int addr_res = idrnet_getaddrinfo(&remote_host, host, port, family, socket_type);     if (addr_res == -1) {         return -1;     }      int connect_res = connect(sockfd, remote_host->ai_addr, remote_host->ai_addrlen);     if (connect_res == -1) {+        freeaddrinfo(remote_host);         return -1;     }-+    freeaddrinfo(remote_host);     return 0; } @@ -88,9 +105,15 @@     struct sockaddr_in* addr = (struct sockaddr_in*) sockaddr;     char* ip_addr = (char*) malloc(sizeof(char) * INET_ADDRSTRLEN);     inet_ntop(AF_INET, &(addr->sin_addr), ip_addr, INET_ADDRSTRLEN);+    //printf("Lib: ip_addr: %s\n", ip_addr);     return ip_addr; } +int idrnet_sockaddr_ipv4_port(void* sockaddr) {+    struct sockaddr_in* addr = (struct sockaddr_in*) sockaddr;+    return ((int) ntohs(addr->sin_port));  +}+ void* idrnet_create_sockaddr() {     return malloc(sizeof(struct sockaddr_storage)); }@@ -108,33 +131,43 @@ }  int idrnet_send_buf(int sockfd, void* data, int len) {-    return send(sockfd, data, len, 0);+    void* buf_cpy = malloc(len);+    memset(buf_cpy, 0, len);+    memcpy(buf_cpy, data, len);+    buf_htonl(buf_cpy, len);+    int res = send(sockfd, buf_cpy, len, 0);+    free(buf_cpy);+    return res; }  void* idrnet_recv(int sockfd, int len) {     idrnet_recv_result* res_struct =          (idrnet_recv_result*) malloc(sizeof(idrnet_recv_result));-     char* buf = malloc(len + 1);+    memset(buf, 0, len + 1);     int recv_res = recv(sockfd, buf, len, 0);     res_struct->result = recv_res;          if (recv_res > 0) { // Data was received         buf[recv_res + 1] = 0x00; // Null-term, so Idris can interpret it     }-    res_struct->payload = (void*) buf;+    res_struct->payload = buf;     return (void*) res_struct; }  int idrnet_recv_buf(int sockfd, void* buf, int len) {-    return recv(sockfd, buf, len, 0);+    int recv_res = recv(sockfd, buf, len, 0);+    if (recv_res != -1) {+        buf_ntohl(buf, len);+    }+    return recv_res; }  int idrnet_get_recv_res(void* res_struct) {     return (((idrnet_recv_result*) res_struct)->result); } -void* idrnet_get_recv_payload(void* res_struct) {+char* idrnet_get_recv_payload(void* res_struct) {     return (((idrnet_recv_result*) res_struct)->payload); } @@ -150,4 +183,138 @@ int idrnet_errno() {     return errno; }+++int idrnet_sendto(int sockfd, char* data, char* host, int port, int family) {++    struct addrinfo* remote_host;+    int addr_res = idrnet_getaddrinfo(&remote_host, host, port, family, SOCK_DGRAM);+    if (addr_res == -1) {+        return -1;+    } ++    int send_res = sendto(sockfd, data, strlen(data), 0, +                        remote_host->ai_addr, remote_host->ai_addrlen);+    freeaddrinfo(remote_host);+    return send_res;+}++int idrnet_sendto_buf(int sockfd, void* buf, int buf_len, char* host, int port, int family) {++    struct addrinfo* remote_host;+    int addr_res = idrnet_getaddrinfo(&remote_host, host, port, family, SOCK_DGRAM);+    if (addr_res == -1) {+        //printf("lib err: sendto getaddrinfo \n");+        return -1;+    } ++    buf_htonl(buf, buf_len);++    int send_res = sendto(sockfd, buf, buf_len, 0, +                        remote_host->ai_addr, remote_host->ai_addrlen);+    if (send_res == -1) {+        perror("lib err: sendto \n");+    }+    //freeaddrinfo(remote_host);+    return send_res;+}++++void* idrnet_recvfrom(int sockfd, int len) {+/*+ * int recvfrom(int sockfd, void *buf, int len, unsigned int flags,+             struct sockaddr *from, int *fromlen); +*/+    // Allocate the required structures, and nuke them+    struct sockaddr_storage* remote_addr = +        (struct sockaddr_storage*) malloc(sizeof(struct sockaddr_storage));+    char* buf = (char*) malloc(len + 1);+    idrnet_recvfrom_result* ret = +        (idrnet_recvfrom_result*) malloc(sizeof(idrnet_recvfrom_result));+    memset(remote_addr, 0, sizeof(struct sockaddr_storage));+    memset(buf, 0, len + 1);+    memset(ret, 0, sizeof(idrnet_recvfrom_result));+    socklen_t fromlen = sizeof(struct sockaddr_storage);++    int recv_res = recvfrom(sockfd, buf, len, 0, (struct sockaddr*) remote_addr, &fromlen);+    ret->result = recv_res;+    // Check for failure...+    if (recv_res == -1) { +        free(buf);+        free(remote_addr);+    } else {+        // If data was received, process and populate+        ret->result = recv_res;+        ret->remote_addr = remote_addr;+        // Ensure the last byte is NULL, since in this mode we're sending strings+        buf[len] = 0x00;+        ret->payload = (void*) buf;+    }++    return ret;+}+++void* idrnet_recvfrom_buf(int sockfd, void* buf, int len) {+    // Allocate the required structures, and nuke them+    struct sockaddr_storage* remote_addr = +        (struct sockaddr_storage*) malloc(sizeof(struct sockaddr_storage));+    idrnet_recvfrom_result* ret = +        (idrnet_recvfrom_result*) malloc(sizeof(idrnet_recvfrom_result));+    memset(remote_addr, 0, sizeof(struct sockaddr_storage));+    memset(ret, 0, sizeof(idrnet_recvfrom_result));+    socklen_t fromlen = 0;++    int recv_res = recvfrom(sockfd, buf, len, 0, (struct sockaddr*) remote_addr, &fromlen);+    // Check for failure... But don't free the buffer! Not our job.+    ret->result = recv_res;+    if (recv_res == -1) { +        free(remote_addr);+    }+    // Payload will be NULL -- since it's been put into the user-specified buffer. We+    // still need the return struct to get our hands on the remote address, though.+    if (recv_res > 0) {+        buf_ntohl(buf, len);+        ret->payload = NULL;+        ret->remote_addr = remote_addr;+    }+    return ret;+}++int idrnet_get_recvfrom_res(void* res_struct) {+    return (((idrnet_recvfrom_result*) res_struct)->result);+}++char* idrnet_get_recvfrom_payload(void* res_struct) {+    return (((idrnet_recvfrom_result*) res_struct)->payload);+}++void* idrnet_get_recvfrom_sockaddr(void* res_struct) {+    idrnet_recvfrom_result* recv_struct = (idrnet_recvfrom_result*) res_struct;+    return recv_struct->remote_addr;+}++int idrnet_get_recvfrom_port(void* res_struct) {+    idrnet_recvfrom_result* recv_struct = (idrnet_recvfrom_result*) res_struct;+    if (recv_struct->remote_addr != NULL) {+        struct sockaddr_in* remote_addr_in = +            (struct sockaddr_in*) recv_struct->remote_addr;+        return ((int) ntohs(remote_addr_in->sin_port));+    }+    return -1;+}++void idrnet_free_recvfrom_struct(void* res_struct) {+    idrnet_recvfrom_result* recv_struct = (idrnet_recvfrom_result*) res_struct;+    if (recv_struct != NULL) {+        if (recv_struct->payload != NULL) {+            free(recv_struct->payload);+        }+        if (recv_struct->remote_addr != NULL) {+            free(recv_struct->remote_addr);+        }+    }+}+
rts/idris_net.h view
@@ -1,11 +1,22 @@ #ifndef IDRISNET_H #define IDRISNET_H +struct sockaddr_storage;+struct addrinfo;+ typedef struct idrnet_recv_result {     int result;     void* payload; } idrnet_recv_result; +// Same type of thing as idrnet_recv_result, but for UDP, so stores some +// address information+typedef struct idrnet_recvfrom_result {+    int result;+    void* payload;+    struct sockaddr_storage* remote_addr;+} idrnet_recvfrom_result;+ // Memory management functions void* idrnet_malloc(int size); void idrnet_free(void* ptr);@@ -22,6 +33,7 @@ // Accessor functions for struct_sockaddr int idrnet_sockaddr_family(void* sockaddr); char* idrnet_sockaddr_ipv4(void* sockaddr);+int idrnet_sockaddr_ipv4_port(void* sockaddr); void* idrnet_create_sockaddr();  // Accept@@ -37,8 +49,29 @@ // Receives directly into a buffer int idrnet_recv_buf(int sockfd, void* buf, int len); +// UDP Send+int idrnet_sendto(int sockfd, char* data, char* host, int port, int family);+int idrnet_sendto_buf(int sockfd, void* buf, int buf_len, char* host, int port, int family);+++// UDP Receive+void* idrnet_recvfrom(int sockfd, int len);+void* idrnet_recvfrom_buf(int sockfd, void* buf, int len);+ // Receive structure accessors int idrnet_get_recv_res(void* res_struct);-void* idrnet_get_recv_payload(void* res_struct);+char* idrnet_get_recv_payload(void* res_struct); void idrnet_free_recv_struct(void* res_struct);++// Recvfrom structure accessors+int idrnet_get_recvfrom_res(void* res_struct);+char* idrnet_get_recvfrom_payload(void* res_struct);+void* idrnet_get_recvfrom_sockaddr(void* res_struct);+void idrnet_free_recvfrom_struct(void* res_struct);+++int idrnet_getaddrinfo(struct addrinfo** address_res, char* host, +    int port, int family, int socket_type);++ #endif
rts/idris_rts.c view
@@ -1,10 +1,11 @@ #include <stdlib.h> #include <stdio.h> #include <string.h>-#include <unistd.h> #include <stdarg.h> #include <assert.h>+#ifdef HAS_PTHREAD #include <pthread.h>+#endif  #include "idris_rts.h" #include "idris_gc.h"@@ -30,7 +31,7 @@      vm->ret = NULL;     vm->reg1 = NULL;-+#ifdef HAS_PTHREAD     vm->inbox = malloc(1024*sizeof(VAL));     memset(vm->inbox, 0, 1024*sizeof(VAL));     vm->inbox_end = vm->inbox + 1024;@@ -53,7 +54,7 @@      vm->max_threads = max_threads;     vm->processes = 0;-+#endif     STATS_LEAVE_INIT(vm->stats)     return vm; }@@ -61,14 +62,16 @@ Stats terminate(VM* vm) {     Stats stats = vm->stats;     STATS_ENTER_EXIT(stats)-+#ifdef HAS_PTHREAD     free(vm->inbox);+#endif     free(vm->valstack);     free_heap(&(vm->heap));-+#ifdef HAS_PTHREAD     pthread_mutex_destroy(&(vm -> inbox_lock));     pthread_mutex_destroy(&(vm -> inbox_block));     pthread_cond_destroy(&(vm -> inbox_waiting));+#endif     free(vm);      STATS_LEAVE_EXIT(stats)@@ -79,18 +82,21 @@     if (!(vm->heap.next + size < vm->heap.end)) {         idris_gc(vm);     }-+#ifdef HAS_PTHREAD     int lock = vm->processes > 0;     if (lock) { // We only need to lock if we're in concurrent mode        pthread_mutex_lock(&vm->alloc_lock);      }+#endif }  void idris_doneAlloc(VM* vm) {+#ifdef HAS_PTHREAD     int lock = vm->processes > 0;     if (lock) { // We only need to lock if we're in concurrent mode        pthread_mutex_unlock(&vm->alloc_lock);      }+#endif }  int space(VM* vm, size_t size) {@@ -99,16 +105,18 @@  void* allocate(VM* vm, size_t size, int outerlock) { //    return malloc(size);+#ifdef HAS_PTHREAD     int lock = vm->processes > 0 && !outerlock;      if (lock) { // not message passing        pthread_mutex_lock(&vm->alloc_lock);      }+#endif      if ((size & 7)!=0) { 	size = 8 + ((size >> 3) << 3);     }-    +     size_t chunk_size = size + sizeof(size_t);      if (vm->heap.next + chunk_size < vm->heap.end) {@@ -120,16 +128,19 @@         assert(vm->heap.next <= vm->heap.end);          memset(ptr, 0, size);-+#ifdef HAS_PTHREAD         if (lock) { // not message passing            pthread_mutex_unlock(&vm->alloc_lock);          }+#endif         return ptr;     } else {         idris_gc(vm);+#ifdef HAS_PTHREAD         if (lock) { // not message passing            pthread_mutex_unlock(&vm->alloc_lock);          }+#endif         return allocate(vm, size, 0);     } @@ -187,7 +198,7 @@     return cl; } -VAL MKMPTR(VM* vm, void* ptr, int size) {+VAL MKMPTR(VM* vm, void* ptr, size_t size) {     Closure* cl = allocate(vm, sizeof(Closure) +                                sizeof(ManagedPtr) + size, 0);     SETTY(cl, MANAGEDPTR);@@ -222,7 +233,7 @@     return cl; } -VAL MKMPTRc(VM* vm, void* ptr, int size) {+VAL MKMPTRc(VM* vm, void* ptr, size_t size) {     Closure* cl = allocate(vm, sizeof(Closure) +                                sizeof(ManagedPtr) + size, 1);     SETTY(cl, MANAGEDPTR);@@ -760,6 +771,7 @@     VAL arg; } ThreadData; +#ifdef HAS_PTHREAD void* runThread(void* arg) {     ThreadData* td = (ThreadData*)arg;     VM* vm = td->vm;@@ -949,7 +961,7 @@      return msg; }-+#endif int __idris_argc; char **__idris_argv;
rts/idris_rts.h view
@@ -4,9 +4,10 @@ #include <stdlib.h> #include <stdio.h> #include <string.h>-#include <unistd.h> #include <stdarg.h>+#ifdef HAS_PTHREAD #include <pthread.h>+#endif #include <stdint.h>  #include "idris_heap.h"@@ -23,13 +24,13 @@ typedef struct Closure *VAL;  typedef struct {-    int tag_arity;+    uint32_t tag_arity;     VAL args[]; } con;  typedef struct {     VAL str;-    int offset;+    size_t offset; } StrOffset;  typedef struct {@@ -49,7 +50,10 @@ typedef struct Closure { // Use top 16 bits of ty for saying which heap value is in // Bottom 16 bits for closure type-    ClosureType ty;+//+// NOTE: ty can not have type ClosureType because ty must be a+// uint32_t but enum is platform dependent+    uint32_t ty;     union {         con c;         int i;@@ -73,7 +77,7 @@     VAL* stack_max;          Heap heap;-+#ifdef HAS_PTHREAD     pthread_mutex_t inbox_lock;     pthread_mutex_t inbox_block;     pthread_mutex_t alloc_lock;@@ -87,7 +91,7 @@      int processes; // Number of child processes     int max_threads; // maximum number of threads to run in parallel-    +#endif     Stats stats;      VAL ret;@@ -170,7 +174,7 @@ VAL MKFLOAT(VM* vm, double val); VAL MKSTR(VM* vm, const char* str); VAL MKPTR(VM* vm, void* ptr);-VAL MKMPTR(VM* vm, void* ptr, int size);+VAL MKMPTR(VM* vm, void* ptr, size_t size); VAL MKB8(VM* vm, uint8_t b); VAL MKB16(VM* vm, uint16_t b); VAL MKB32(VM* vm, uint32_t b);@@ -181,7 +185,7 @@ VAL MKSTROFFc(VM* vm, StrOffset* off); VAL MKSTRc(VM* vm, char* str); VAL MKPTRc(VM* vm, void* ptr);-VAL MKMPTRc(VM* vm, void* ptr, int size);+VAL MKMPTRc(VM* vm, void* ptr, size_t size); VAL MKBUFFERc(VM* vm, Buffer* buf);  char* GETSTROFF(VAL stroff);@@ -208,7 +212,7 @@ #define allocCon(cl, vm, t, a, o) \   cl = allocate(vm, sizeof(Closure) + sizeof(VAL)*a, o); \   SETTY(cl, CON); \-  cl->info.c.tag_arity = ((t) << 8) + (a);+  cl->info.c.tag_arity = ((t) << 8) | (a);  void* vmThread(VM* callvm, func f, VAL arg);
rts/windows/idris_net.c view
@@ -177,7 +177,7 @@     return (((idrnet_recv_result*) res_struct)->result); } -void* idrnet_get_recv_payload(void* res_struct) {+char* idrnet_get_recv_payload(void* res_struct) {     return (((idrnet_recv_result*) res_struct)->payload); }
src/IRTS/CodegenC.hs view
@@ -7,7 +7,6 @@ import IRTS.System import IRTS.CodegenCommon import Idris.Core.TT-import Paths_idris import Util.System  import Numeric@@ -68,6 +67,7 @@              let gcc = comp ++ " " ++                        gccDbg dbg ++ " " ++                        gccFlags +++                       " -DHAS_PTHREAD " ++                        " -I. " ++ objs ++ " -x c " ++                        (if (exec == Executable) then "" else " -c ") ++                        " " ++ tmpn ++
src/IRTS/CodegenJava.hs view
@@ -169,7 +169,7 @@   ++ "if test -n \"$JAVA_HOME\"; then\n"   ++ "  java=\"$JAVA_HOME/bin/java\"\n"   ++ "fi\n"-  ++ "exec \"$java\" $java_args -jar $MYSELF \"$@\""+  ++ "exec \"$java\" $java_args -jar $MYSELF \"$@\"\n"   ++ "exit 1\n"  -----------------------------------------------------------------------@@ -312,6 +312,7 @@                             , ImportDecl True idrisPrelude True                             , ImportDecl False bigInteger False                             , ImportDecl False runtimeException False+                            , ImportDecl False byteBuffer False                             ] ++ otherHdrs                           )                           <$> mkTypeDecl clsName globalInit defs@@ -320,6 +321,7 @@     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"]+    byteBuffer = J.Name $ map Ident ["java", "nio", "ByteBuffer"]     otherHdrs = map ( (\ name -> ImportDecl False name False)                       . J.Name                       . map (Ident . T.unpack)@@ -386,9 +388,7 @@     "main"     [FormalParam [] (array stringType) False (VarId $ Ident "args")]     $ Block [ BlockStmt . ExpStmt-              $ call "idris_initArgs" [ (threadType ~> "currentThread") []-                                      , jConst "args"-                                      ]+              $ call "idris_initArgs" [ jConst "args" ]             , BlockStmt . ExpStmt $ call (mangle' (sMN 0 "runMain")) []             ] @@ -484,6 +484,8 @@   (mkThread arg) >>= ppExp pp mkExp pp (SOp LPar [arg]) =   (Nothing <>@! arg) >>= ppExp pp+mkExp pp (SOp LRegisterPtr [ptr, i]) =+  (Nothing <>@! ptr) >>= ppExp pp mkExp pp (SOp LNoOp args) =   (Nothing <>@! (last args)) >>= ppExp pp mkExp pp (SOp LNullPtr args) =@@ -707,6 +709,7 @@ mkConstant c@(StrType   ) = ClassLit (Just $ stringType) mkConstant c@(PtrType   ) = ClassLit (Just $ objectType) mkConstant c@(ManagedPtrType) = ClassLit (Just $ objectType)+mkConstant c@(BufferType) = ClassLit (Just $ bufferType) mkConstant c@(VoidType  ) = ClassLit (Just $ voidType) mkConstant c@(Forgot    ) = ClassLit (Just $ objectType) @@ -744,7 +747,7 @@  mkPrimitiveFunction :: PrimFn -> [LVar] -> CodeGeneration Exp mkPrimitiveFunction op args =-  (\ args -> (primFnType ~> opName op) args)+  (\ args -> (primFnType ~> opName op) (endiannessArguments op ++ args))   <$> sequence (zipWith (\ a t -> (Just t) <>@! a) args (sourceTypes op))  mkThread :: LVar -> CodeGeneration Exp
src/IRTS/CodegenJavaScript.hs view
@@ -1,2641 +1,1324 @@ {-# LANGUAGE PatternGuards #-}--module IRTS.CodegenJavaScript (codegenJavaScript, codegenNode, JSTarget(..)) where--import Idris.AbsSyntax hiding (TypeCase)-import IRTS.Bytecode-import IRTS.Lang-import IRTS.Simplified-import IRTS.CodegenCommon-import Idris.Core.TT-import Paths_idris-import Util.System--import Control.Arrow-import Control.Applicative ((<$>), (<*>), pure)-import Data.Char-import Numeric-import Data.List-import Data.Maybe-import Data.Word-import System.IO-import System.Directory---idrNamespace :: String-idrNamespace    = "__IDR__"-idrRTNamespace  = "__IDRRT__"-idrLTNamespace  = "__IDRLT__"-idrCTRNamespace = "__IDRCTR__"---data JSTarget = Node | JavaScript deriving Eq---data JSType = JSIntTy-            | JSStringTy-            | JSIntegerTy-            | JSFloatTy-            | JSCharTy-            | JSPtrTy-            | JSForgotTy-            deriving Eq---data JSInteger = JSBigZero-               | JSBigOne-               | JSBigInt Integer-               deriving Eq---data JSNum = JSInt Int-           | JSFloat Double-           | JSInteger JSInteger-           deriving Eq---data JSWord = JSWord8 Word8-            | JSWord16 Word16-            | JSWord32 Word32-            | JSWord64 Word64-            deriving Eq---data JSAnnotation = JSConstructor deriving Eq---instance Show JSAnnotation where-  show JSConstructor = "constructor"---data JS = JSRaw String-        | JSIdent String-        | JSFunction [String] JS-        | JSType JSType-        | JSSeq [JS]-        | JSReturn JS-        | JSApp JS [JS]-        | JSNew String [JS]-        | JSError String-        | JSBinOp String JS JS-        | JSPreOp String JS-        | JSPostOp String JS-        | JSProj JS String-        | JSVar LVar-        | JSNull-        | JSThis-        | JSTrue-        | JSFalse-        | JSArray [JS]-        | JSString String-        | JSNum JSNum-        | JSWord JSWord-        | JSAssign JS JS-        | JSAlloc String (Maybe JS)-        | JSIndex JS JS-        | JSCond [(JS, JS)]-        | JSTernary JS JS JS-        | JSParens JS-        | JSWhile JS JS-        | JSFFI String [JS]-        | JSAnnotation JSAnnotation JS-        | JSNoop-        deriving Eq---data FFI = FFICode Char | FFIArg Int | FFIError String---ffi :: String -> [String] -> String-ffi code args = let parsed = ffiParse code in-                    case ffiError parsed of-                         Just err -> error err-                         Nothing  -> renderFFI parsed args-  where-    ffiParse :: String -> [FFI]-    ffiParse ""           = []-    ffiParse ['%']        = [FFIError $ "FFI - Invalid positional argument"]-    ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss-    ffiParse ('%':s:ss)-      | isDigit s =-         FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)-      | otherwise =-          [FFIError $ "FFI - Invalid positional argument"]-    ffiParse (s:ss) = FFICode s : ffiParse ss---    ffiError :: [FFI] -> Maybe String-    ffiError []                 = Nothing-    ffiError ((FFIError s):xs)  = Just s-    ffiError (x:xs)             = ffiError xs---    renderFFI :: [FFI] -> [String] -> String-    renderFFI [] _ = ""-    renderFFI ((FFICode c) : fs) args = c : renderFFI fs args-    renderFFI ((FFIArg i) : fs) args-      | i < length args && i >= 0 = args !! i ++ renderFFI fs args-      | otherwise = error "FFI - Argument index out of bounds"---compileJS :: JS -> String-compileJS JSNoop = ""--compileJS (JSAnnotation annotation js) =-  "/** @" ++ show annotation ++ " */\n" ++ compileJS js--compileJS (JSFFI raw args) =-  ffi raw (map compileJS args)--compileJS (JSRaw code) =-  code--compileJS (JSIdent ident) =-  ident--compileJS (JSFunction args body) =-     "function("-   ++ intercalate "," args-   ++ "){\n"-   ++ compileJS body-   ++ "\n}"--compileJS (JSType ty)-  | JSIntTy     <- ty = idrRTNamespace ++ "Int"-  | JSStringTy  <- ty = idrRTNamespace ++ "String"-  | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"-  | JSFloatTy   <- ty = idrRTNamespace ++ "Float"-  | JSCharTy    <- ty = idrRTNamespace ++ "Char"-  | JSPtrTy     <- ty = idrRTNamespace ++ "Ptr"-  | JSForgotTy  <- ty = idrRTNamespace ++ "Forgot"--compileJS (JSSeq seq) =-  intercalate ";\n" (map compileJS seq)--compileJS (JSReturn val) =-  "return " ++ compileJS val--compileJS (JSApp lhs rhs)-  | JSFunction {} <- lhs =-    concat ["(", compileJS lhs, ")(", args, ")"]-  | otherwise =-    concat [compileJS lhs, "(", args, ")"]-  where args :: String-        args = intercalate "," $ map compileJS rhs--compileJS (JSNew name args) =-  "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"--compileJS (JSError exc) =-  "throw new Error(\"" ++ exc ++ "\")"--compileJS (JSBinOp op lhs rhs) =-  compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs--compileJS (JSPreOp op val) =-  op ++ compileJS val--compileJS (JSProj obj field)-  | JSFunction {} <- obj =-    concat ["(", compileJS obj, ").", field]-  | JSAssign {} <- obj =-    concat ["(", compileJS obj, ").", field]-  | otherwise =-    compileJS obj ++ '.' : field--compileJS (JSVar var) =-  translateVariableName var--compileJS JSNull =-  "null"--compileJS JSThis =-  "this"--compileJS JSTrue =-  "true"--compileJS JSFalse =-  "false"--compileJS (JSArray elems) =-  "[" ++ intercalate "," (map compileJS elems) ++ "]"--compileJS (JSString str) =-  "\"" ++ str ++ "\""--compileJS (JSNum num)-  | JSInt i                <- num = show i-  | JSFloat f              <- num = show f-  | JSInteger JSBigZero    <- num = "__IDRRT__ZERO"-  | JSInteger JSBigOne     <- num = "__IDRRT__ONE"-  | JSInteger (JSBigInt i) <- num = show i--compileJS (JSAssign lhs rhs) =-  compileJS lhs ++ "=" ++ compileJS rhs--compileJS (JSAlloc name val) =-  "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val--compileJS (JSIndex lhs rhs) =-  compileJS lhs ++ "[" ++ compileJS rhs ++ "]"--compileJS (JSCond branches) =-  intercalate " else " $ map createIfBlock branches-  where-    createIfBlock (JSNoop, e) =-         "{\n"-      ++ compileJS e-      ++ ";\n}"-    createIfBlock (cond, e) =-         "if (" ++ compileJS cond ++") {\n"-      ++ compileJS e-      ++ ";\n}"--compileJS (JSTernary cond true false) =-  let c = compileJS cond-      t = compileJS true-      f = compileJS false in-      "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"--compileJS (JSParens js) =-  "(" ++ compileJS js ++ ")"--compileJS (JSWhile cond body) =-     "while (" ++ compileJS cond ++ ") {\n"-  ++ compileJS body-  ++ "\n}"--compileJS (JSWord word)-  | JSWord8  b <- word = "new Uint8Array([" ++ show b ++ "])"-  | JSWord16 b <- word = "new Uint16Array([" ++ show b ++ "])"-  | JSWord32 b <- word = "new Uint32Array([" ++ show b ++ "])"-  | JSWord64 b <- word = idrRTNamespace ++ "bigInt(\"" ++ show b ++ "\")"---jsTailcall :: JS -> JS-jsTailcall call =-  jsCall (idrRTNamespace ++ "tailcall") [-    JSFunction [] (JSReturn call)-  ]---jsCall :: String -> [JS] -> JS-jsCall fun = JSApp (JSIdent fun)---jsMeth :: JS -> String -> [JS] -> JS-jsMeth obj meth =-  JSApp (JSProj obj meth)---jsInstanceOf :: JS -> JS -> JS-jsInstanceOf = JSBinOp "instanceof"---jsEq :: JS -> JS -> JS-jsEq = JSBinOp "=="--jsNotEq :: JS -> JS -> JS-jsNotEq = JSBinOp "!="--jsAnd :: JS -> JS -> JS-jsAnd = JSBinOp "&&"---jsOr :: JS -> JS -> JS-jsOr = JSBinOp "||"---jsType :: JS-jsType = JSIdent $ idrRTNamespace ++ "Type"---jsCon :: JS-jsCon = JSIdent $ idrRTNamespace ++ "Con"---jsTag :: JS -> JS-jsTag obj = JSProj obj "tag"---jsTypeTag :: JS -> JS-jsTypeTag obj = JSProj obj "type"---jsBigInt :: JS -> JS-jsBigInt (JSString "0") = JSNum $ JSInteger JSBigZero-jsBigInt (JSString "1") = JSNum $ JSInteger JSBigOne-jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val]---jsVar :: Int -> String-jsVar = ("__var_" ++) . show---jsLet :: String -> JS -> JS -> JS-jsLet name value body =-  JSApp (-    JSFunction [name] (-      JSReturn body-    )-  ) [value]---jsError :: String -> JS-jsError err = JSApp (JSFunction [] (JSError err)) []--jsUnPackBits :: JS -> JS-jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)---jsPackUBits8 :: JS -> JS-jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]--jsPackUBits16 :: JS -> JS-jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]--jsPackUBits32 :: JS -> JS-jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]--jsPackSBits8 :: JS -> JS-jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]--jsPackSBits16 :: JS -> JS-jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]--jsPackSBits32 :: JS -> JS-jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]---foldJS :: (JS -> a) -> (a -> a -> a) -> a -> JS -> a-foldJS tr add acc js =-  fold js-  where-    fold js-      | JSFunction args body <- js =-          add (tr js) (fold body)-      | JSSeq seq            <- js =-          add (tr js) $ foldl' add acc (map fold seq)-      | JSReturn ret         <- js =-          add (tr js) (fold ret)-      | JSApp lhs rhs        <- js =-          add (tr js) $ add (fold lhs) (foldl' add acc $ map fold rhs)-      | JSNew _ args         <- js =-          add (tr js) $ foldl' add acc $ map fold args-      | JSBinOp _ lhs rhs    <- js =-          add (tr js) $ add (fold lhs) (fold rhs)-      | JSPreOp _ val        <- js =-          add (tr js) $ fold val-      | JSPostOp _ val       <- js =-          add (tr js) $ fold val-      | JSProj obj _         <- js =-          add (tr js) (fold obj)-      | JSArray vals         <- js =-          add (tr js) $ foldl' add acc $ map fold vals-      | JSAssign lhs rhs     <- js =-          add (tr js) $ add (fold lhs) (fold rhs)-      | JSIndex lhs rhs      <- js =-          add (tr js) $ add (fold lhs) (fold rhs)-      | JSAlloc _ val        <- js =-          add (tr js) $ fromMaybe acc $ fmap fold val-      | JSTernary c t f      <- js =-          add (tr js) $ add (fold c) (add (fold t) (fold f))-      | JSParens val         <- js =-          add (tr js) $ fold val-      | JSCond conds         <- js =-          add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds-      | JSWhile cond body    <- js =-          add (tr js) $ add (fold cond) (fold body)-      | JSFFI raw args       <- js =-          add (tr js) $ foldl' add acc $ map fold args-      | JSAnnotation a js    <- js =-          add (tr js) $ fold js-      | otherwise                  =-          tr js---transformJS :: (JS -> JS) -> JS -> JS-transformJS tr js =-  transformHelper js-  where-    transformHelper :: JS -> JS-    transformHelper js-      | JSFunction args body <- js = JSFunction args $ tr body-      | JSSeq seq            <- js = JSSeq $ map tr seq-      | JSReturn ret         <- js = JSReturn $ tr ret-      | JSApp lhs rhs        <- js = JSApp (tr lhs) $ map tr rhs-      | JSNew con args       <- js = JSNew con $ map tr args-      | JSBinOp op lhs rhs   <- js = JSBinOp op (tr lhs) (tr rhs)-      | JSPreOp op val       <- js = JSPreOp op (tr val)-      | JSPostOp op val      <- js = JSPostOp op (tr val)-      | JSProj obj field     <- js = JSProj (tr obj) field-      | JSArray vals         <- js = JSArray $ map tr vals-      | JSAssign lhs rhs     <- js = JSAssign (tr lhs) (tr rhs)-      | JSAlloc var val      <- js = JSAlloc var $ fmap tr val-      | JSIndex lhs rhs      <- js = JSIndex (tr lhs) (tr rhs)-      | JSCond conds         <- js = JSCond $ map (tr *** tr) conds-      | JSTernary c t f      <- js = JSTernary (tr c) (tr t) (tr f)-      | JSParens val         <- js = JSParens $ tr val-      | JSWhile cond body    <- js = JSWhile (tr cond) (tr body)-      | JSFFI raw args       <- js = JSFFI raw (map tr args)-      | JSAnnotation a js    <- js = JSAnnotation a (tr js)-      | otherwise                  = js---moveJSDeclToTop :: String -> [JS] -> [JS]-moveJSDeclToTop decl js = move ([], js)-  where-    move :: ([JS], [JS]) -> [JS]-    move (front, js@(JSAnnotation _ (JSAlloc name _)):back)-      | name == decl = js : front ++ back--    move (front, js@(JSAlloc name _):back)-      | name == decl = js : front ++ back--    move (front, js:back) =-      move (front ++ [js], back)---jsSubst :: JS -> JS -> JS -> JS-jsSubst var new old-  | var == old = new--jsSubst (JSIdent var) new (JSVar old)-  | var == translateVariableName old = new-  | otherwise                        = JSVar old--jsSubst var new old@(JSIdent _)-  | var == old = new-  | otherwise  = old--jsSubst var new (JSArray fields) =-  JSArray (map (jsSubst var new) fields)--jsSubst var new (JSNew con vals) =-  JSNew con $ map (jsSubst var new) vals--jsSubst (JSIdent var) new (JSApp (JSProj (JSFunction args body) "apply") vals)-  | var `notElem` args =-      JSApp (JSProj (JSFunction args (jsSubst (JSIdent var) new body)) "apply") (-        map (jsSubst (JSIdent var) new) vals-      )-  | otherwise =-      JSApp (JSProj (JSFunction args body) "apply") (-        map (jsSubst (JSIdent var) new) vals-      )--jsSubst (JSIdent var) new (JSApp (JSFunction [arg] body) vals)-  | var /= arg =-      JSApp (JSFunction [arg] (-        jsSubst (JSIdent var) new body-      )) $ map (jsSubst (JSIdent var) new) vals-  | otherwise =-      JSApp (JSFunction [arg] (-        body-      )) $ map (jsSubst (JSIdent var) new) vals--jsSubst var new js = transformJS (jsSubst var new) js---removeAllocations :: JS -> JS-removeAllocations (JSSeq body) =-  let opt = removeHelper (map removeAllocations body) in-      case opt of-           [ret] -> ret-           _     -> JSSeq opt-  where-    removeHelper :: [JS] -> [JS]-    removeHelper [js] = [js]-    removeHelper ((JSAlloc name (Just val@(JSIdent _))):js) =-      map (jsSubst (JSIdent name) val) (removeHelper js)-    removeHelper (j:js) = j : removeHelper js--removeAllocations js = transformJS removeAllocations js---isJSConstant :: JS -> Bool-isJSConstant js-  | JSString _   <- js = True-  | JSNum _      <- js = True-  | JSType _     <- js = True-  | JSNull       <- js = True-  | JSArray vals <- js = all isJSConstant vals--  | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True--  | otherwise = False--isJSConstantConstructor :: [String] -> JS -> Bool-isJSConstantConstructor constants js-  | isJSConstant js =-      True-  | JSArray vals <- js =-      all (isJSConstantConstructor constants) vals-  | JSNew "__IDRRT__Con" args <- js =-      all (isJSConstantConstructor constants) args-  | JSIndex (JSProj (JSIdent name) "vars") (JSNum _) <- js-  , name `elem` constants =-      True-  | JSIdent name <- js-  , name `elem` constants =-      True-  | otherwise = False---inlineJS :: JS -> JS-inlineJS = inlineAssign . inlineError . inlineApply . inlineCaseMatch . inlineJSLet-  where-    inlineJSLet :: JS -> JS-    inlineJSLet (JSApp (JSFunction [arg] (JSReturn ret)) [val])-      | opt <- inlineJSLet val =-          inlineJS $ jsSubst (JSIdent arg) opt ret--    inlineJSLet js = transformJS inlineJSLet js---    inlineCaseMatch (JSReturn (JSApp (JSFunction ["cse"] body) [val]))-      | opt <- inlineCaseMatch val =-          inlineCaseMatch $ jsSubst (JSIdent "cse") opt body--    inlineCaseMatch js = transformJS inlineCaseMatch js---    inlineApply js-      | JSApp (-          JSProj (JSFunction args (JSReturn body)) "apply"-        ) [JSThis, JSProj var "vars"] <- js =-          inlineApply $ inlineApply' var args body 0-      | JSReturn (JSApp  (-          JSProj (JSFunction args body@(JSCond _)) "apply"-        ) [JSThis, JSProj var "vars"]) <- js =-          inlineApply $ inlineApply' var args body 0-      where-        inlineApply' _   []     body _ = body-        inlineApply' var (a:as) body n =-          inlineApply' var as (-            jsSubst (JSIdent a) (-              JSIndex (JSProj var "vars") (JSNum (JSInt n))-            ) body-          ) (n + 1)--    inlineApply js = transformJS inlineApply js---    inlineError (JSReturn (JSApp (JSFunction [] error@(JSError _)) [])) =-      inlineError error--    inlineError js = transformJS inlineError js---    inlineAssign (JSAssign lhs rhs)-      | JSVar _ <- lhs-      , JSVar _ <- rhs-      , lhs == rhs =-          lhs--    inlineAssign (JSAssign lhs rhs)-      | JSIdent _ <- lhs-      , JSIdent _ <- rhs-      , lhs == rhs =-          lhs--    inlineAssign js = transformJS inlineAssign js---removeEval :: [JS] -> [JS]-removeEval js =-  let (ret, isReduced) = checkEval js in-      if isReduced-          then removeEvalApp ret-          else ret-  where-    removeEvalApp js = catMaybes (map removeEvalApp' js)-      where-        removeEvalApp' :: JS -> Maybe JS-        removeEvalApp' (JSAlloc "__IDR__mEVAL0" _) = Nothing-        removeEvalApp' js = Just $ transformJS match js-          where-            match (JSApp (JSIdent "__IDR__mEVAL0") [val]) = val-            match js = transformJS match js--    checkEval :: [JS] -> ([JS], Bool)-    checkEval js = foldr f ([], False) $ map checkEval' js-      where-        f :: (Maybe JS, Bool) -> ([JS], Bool) -> ([JS], Bool)-        f (Just js, isReduced) (ret, b) = (js : ret, isReduced || b)-        f (Nothing, isReduced) (ret, b) = (ret, isReduced || b)---        checkEval' :: JS -> (Maybe JS, Bool)-        checkEval' (JSAlloc "__IDRLT__EVAL" (Just (JSApp (JSFunction [] (-            JSSeq [ _-                  , JSReturn (JSIdent "t")-                  ]-          )) []))) = (Nothing, True)--        checkEval' js = (Just js, False)---reduceJS :: [JS] -> [JS]-reduceJS js = moveJSDeclToTop "__IDRRT__Con" $ reduceLoop [] ([], js)---funName :: JS -> String-funName (JSAlloc fun _) = fun---elimDeadLoop :: [JS] -> [JS]-elimDeadLoop js-  | ret <- deadEvalApplyCases js-  , ret /= js = elimDeadLoop ret-  | otherwise = js---deadEvalApplyCases :: [JS] -> [JS]-deadEvalApplyCases js =-  let tags = sort $ nub $ concatMap (getTags) js in-      map (removeHelper tags) js-      where-        getTags :: JS -> [Int]-        getTags = foldJS match (++) []-          where-            match js-              | JSNew "__IDRRT__Con" [JSNum (JSInt tag), _] <- js = [tag]-              | otherwise                                         = []---        removeHelper :: [Int] -> JS -> JS-        removeHelper tags (JSAlloc fun (Just (-            JSApp (JSFunction [] (JSSeq seq)) []))-          ) =-            (JSAlloc fun (Just (-              JSApp (JSFunction [] (JSSeq $ remover tags seq)) []))-            )--        removeHelper _ js = js---        remover :: [Int] -> [JS] -> [JS]-        remover tags (-            j@(JSAssign ((JSIndex (JSIdent "t") (JSNum (JSInt tag)))) _):js-          )-          | tag `notElem` tags = remover tags js--        remover tags (j:js) = j : remover tags js-        remover _    []     = []---initConstructors :: [JS] -> [JS]-initConstructors js =-    let tags = nub $ sort $ concat (map getTags js) in-        rearrangePrelude $ map createConstant tags ++ replaceConstructors tags js-      where-        rearrangePrelude :: [JS] -> [JS]-        rearrangePrelude = moveJSDeclToTop $ idrRTNamespace ++ "Con"---        getTags :: JS -> [Int]-        getTags = foldJS match (++) []-          where-            match js-              | JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []] <- js = [tag]-              | otherwise                                                  = []---        replaceConstructors :: [Int] -> [JS] -> [JS]-        replaceConstructors tags js = map (replaceHelper tags) js-          where-            replaceHelper :: [Int] -> JS -> JS-            replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []])-              | tag `elem` tags = JSIdent (idrCTRNamespace ++ show tag)--            replaceHelper tags js = transformJS (replaceHelper tags) js---        createConstant :: Int -> JS-        createConstant tag =-          JSAlloc (idrCTRNamespace ++ show tag) (Just (-            JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []]-          ))---removeIDs :: [JS] -> [JS]-removeIDs js =-  case partition isID js of-       ([], rest)  -> rest-       (ids, rest) -> removeIDs $ map (removeIDCall (map idFor ids)) rest-  where isID :: JS -> Bool-        isID (JSAlloc _ (Just (JSFunction _ (JSSeq body))))-          | JSReturn (JSVar _) <- last body = True--        isID _ = False---        idFor :: JS -> (String, Int)-        idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body))))-          | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos)---        removeIDCall :: [(String, Int)] -> JS -> JS-        removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (-                           JSReturn (JSApp (JSIdent fun) args)-                         )])-          | Just pos <- lookup fun ids-          , pos < length args  = removeIDCall ids (args !! pos)--        removeIDCall ids (JSNew _ [JSFunction [] (-                           JSReturn (JSApp (JSIdent fun) args)-                         )])-          | Just pos <- lookup fun ids-          , pos < length args = removeIDCall ids (args !! pos)--        removeIDCall ids js@(JSApp id@(JSIdent fun) args)-          | Just pos <- lookup fun ids-          , pos < length args  = removeIDCall ids (args !! pos)--        removeIDCall ids js = transformJS (removeIDCall ids) js---inlineFunction :: String -> [String] -> JS -> JS -> JS-inlineFunction fun args body js = inline' js-  where-    inline' :: JS -> JS-    inline' (JSApp (JSIdent name) vals)-      | name == fun =-          let (js, phs) = insertPlaceHolders args body in-              inline' $ foldr (uncurry jsSubst) js (zip phs vals)--    inline' js = transformJS inline' js--    insertPlaceHolders :: [String] -> JS -> (JS, [JS])-    insertPlaceHolders args body = insertPlaceHolders' args body []-      where-        insertPlaceHolders' :: [String] -> JS -> [JS] -> (JS, [JS])-        insertPlaceHolders' (a:as) body ph-          | (body', ph') <- insertPlaceHolders' as body ph =-              let phvar = JSIdent $ "__PH_" ++ show (length ph') in-                  (jsSubst (JSIdent a) phvar body', phvar : ph')--        insertPlaceHolders' [] body ph = (body, ph)---inlineFunctions :: [JS] -> [JS]-inlineFunctions js =-  inlineHelper ([], js)-  where-    inlineHelper :: ([JS], [JS]) -> [JS]-    inlineHelper (front , (JSAlloc fun (Just (JSFunction args body))):back)-      | countAll fun front + countAll fun back == 0 =-         inlineHelper (front, back)-      | Just new <- inlineAble (-            countAll fun front + countAll fun back-          ) fun args body =-              let f = map (inlineFunction fun args new) in-                  inlineHelper (f front, f back)--    inlineHelper (front, next:back) = inlineHelper (front ++ [next], back)-    inlineHelper (front, [])        = front---    inlineAble :: Int -> String -> [String] -> JS -> Maybe JS-    inlineAble 1 fun args (JSReturn body)-      | nonRecur fun body =-          if all (<= 1) (map ($ body) (map countIDOccurences args))-             then Just body-             else Nothing--    inlineAble _ _ _ _ = Nothing---    nonRecur :: String -> JS -> Bool-    nonRecur name body = countInvokations name body == 0---    countAll :: String -> [JS] -> Int-    countAll name js = sum $ map (countInvokations name) js---    countIDOccurences :: String -> JS -> Int-    countIDOccurences name = foldJS match (+) 0-      where-        match :: JS -> Int-        match js-          | JSIdent ident <- js-          , name == ident = 1-          | otherwise     = 0---    countInvokations :: String -> JS -> Int-    countInvokations name = foldJS match (+) 0-      where-        match :: JS -> Int-        match js-          | JSApp (JSIdent ident) _ <- js-          , name == ident = 1-          | JSNew con _             <- js-          , name == con   = 1-          | otherwise     = 0---reduceContinuations :: JS -> JS-reduceContinuations = inlineTC . reduceJS-  where-    reduceJS :: JS -> JS-    reduceJS (JSNew "__IDRRT__Cont" [JSFunction [] (-        JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] body])-      )]) = reduceJS js--    reduceJS js = transformJS reduceJS js---    inlineTC :: JS -> JS-    inlineTC js-      | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (-            JSReturn (JSNew "__IDRRT__Cont" [JSFunction [] (-              JSReturn ret@(JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (-                  JSReturn (JSNew "__IDRRT__Cont" _)-              )])-            )])-          )] <- js = inlineTC ret--    inlineTC js = transformJS inlineTC js-----reduceConstant :: JS -> JS-reduceConstant-  (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (-    JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [val])-  )])-  | JSNum num          <- val = val-  | JSBinOp op lhs rhs <- val =-      JSParens $ JSBinOp op (reduceConstant lhs) (reduceConstant rhs)--  | JSApp (JSProj lhs op) [rhs] <- val-  , op `elem` [ "subtract"-              , "add"-              , "multiply"-              , "divide"-              , "mod"-              , "equals"-              , "lesser"-              , "lesserOrEquals"-              , "greater"-              , "greaterOrEquals"-              ] = val--reduceConstant (JSApp ident [(JSParens js)]) =-  JSApp ident [reduceConstant js]--reduceConstant js = transformJS reduceConstant js---reduceConstants :: JS -> JS-reduceConstants js-  | ret <- reduceConstant js-  , ret /= js = reduceConstants ret-  | otherwise = js---elimDuplicateEvals :: JS -> JS-elimDuplicateEvals (JSAlloc fun (Just (JSFunction args (JSSeq seq)))) =-  JSAlloc fun $ Just (JSFunction args $ JSSeq (elimHelper seq))-  where-    elimHelper :: [JS] -> [JS]-    elimHelper (j@(JSAlloc var (Just val)):js) =-      j : map (jsSubst val (JSIdent var)) (elimHelper js)-    elimHelper (j:js) =-      j : elimHelper js-    elimHelper [] = []--elimDuplicateEvals js = js---optimizeRuntimeCalls :: String -> String -> [JS] -> [JS]-optimizeRuntimeCalls fun tc js =-  optTC tc : map optHelper js-  where-    optHelper :: JS -> JS-    optHelper (JSApp (JSIdent "__IDRRT__tailcall") [-        JSFunction [] (JSReturn (JSApp (JSIdent n) args))-      ])-      | n == fun = JSApp (JSIdent tc) $ map optHelper args--    optHelper js = transformJS optHelper js---    optTC :: String -> JS-    optTC tc@"__IDRRT__EVALTC" =-      JSAlloc tc (Just $ JSFunction ["arg0"] (-        JSSeq [ JSAlloc "ret" $ Just (-                  JSTernary (-                    (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`-                    (hasProp "__IDRLT__EVAL" "arg0")-                  ) (JSApp-                      (JSIndex-                        (JSIdent "__IDRLT__EVAL")-                        (JSProj (JSIdent "arg0") "tag")-                      )-                      [JSIdent "arg0"]-                  ) (JSIdent "arg0")-                )-              , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (-                  JSAssign (JSIdent "ret") (-                    JSApp (JSProj (JSIdent "ret") "k") []-                  )-                )-              , JSReturn $ JSIdent "ret"-              ]-      ))--    optTC tc@"__IDRRT__APPLYTC" =-      JSAlloc tc (Just $ JSFunction ["fn0", "arg0"] (-        JSSeq [ JSAlloc "ret" $ Just (-                  JSTernary (-                    (JSIdent "fn0" `jsInstanceOf` jsCon) `jsAnd`-                    (hasProp "__IDRLT__APPLY" "fn0")-                  ) (JSApp-                      (JSIndex-                        (JSIdent "__IDRLT__APPLY")-                        (JSProj (JSIdent "fn0") "tag")-                      )-                      [JSIdent "fn0", JSIdent "arg0", JSIdent "fn0"]-                  ) JSNull-                )-              , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (-                  JSAssign (JSIdent "ret") (-                    JSApp (JSProj (JSIdent "ret") "k") []-                  )-                )-              , JSReturn $ JSIdent "ret"-              ]-      ))---    hasProp :: String -> String -> JS-    hasProp table var =-      JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")---unfoldLookupTable :: [JS] -> [JS]-unfoldLookupTable input =-  let (evals, evalunfold)   = unfoldLT "__IDRLT__EVAL" input-      (applys, applyunfold) = unfoldLT "__IDRLT__APPLY" evalunfold-      js                    = applyunfold in-      adaptRuntime $ expandCons evals applys js-  where-    adaptRuntime :: [JS] -> [JS]-    adaptRuntime =-      adaptEvalTC . adaptApplyTC . adaptEval . adaptApply . adaptCon---    adaptApply :: [JS] -> [JS]-    adaptApply js = adaptApply' [] js-      where-        adaptApply' :: [JS] -> [JS] -> [JS]-        adaptApply' front ((JSAlloc "__IDR__mAPPLY0" (Just _)):back) =-          front ++ (new:back)--        adaptApply' front (next:back) =-          adaptApply' (front ++ [next]) back--        adaptApply' front [] = front--        new =-          JSAlloc "__IDR__mAPPLY0" (Just $ JSFunction ["mfn0", "marg0"] (JSReturn $-              JSTernary (-                (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`-                (JSProj (JSIdent "mfn0") "app")-              ) (JSApp-                  (JSProj (JSIdent "mfn0") "app")-                  [JSIdent "mfn0", JSIdent "marg0"]-              ) JSNull-            )-          )---    adaptApplyTC :: [JS] -> [JS]-    adaptApplyTC js = adaptApplyTC' [] js-      where-        adaptApplyTC' :: [JS] -> [JS] -> [JS]-        adaptApplyTC' front ((JSAlloc "__IDRRT__APPLYTC" (Just _)):back) =-          front ++ (new:back)--        adaptApplyTC' front (next:back) =-          adaptApplyTC' (front ++ [next]) back--        adaptApplyTC' front [] = front--        new =-          JSAlloc "__IDRRT__APPLYTC" (Just $ JSFunction ["mfn0", "marg0"] (-            JSSeq [ JSAlloc "ret" $ Just (-                      JSTernary (-                        (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`-                        (JSProj (JSIdent "mfn0") "app")-                      ) (JSApp-                          (JSProj (JSIdent "mfn0") "app")-                          [JSIdent "mfn0", JSIdent "marg0"]-                      ) JSNull-                    )-                  , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (-                      JSAssign (JSIdent "ret") (-                        JSApp (JSProj (JSIdent "ret") "k") []-                      )-                    )-                  , JSReturn $ JSIdent "ret"-                  ]-          ))---    adaptEval :: [JS] -> [JS]-    adaptEval js = adaptEval' [] js-      where-        adaptEval' :: [JS] -> [JS] -> [JS]-        adaptEval' front ((JSAlloc "__IDR__mEVAL0" (Just _)):back) =-          front ++ (new:back)--        adaptEval' front (next:back) =-          adaptEval' (front ++ [next]) back--        adaptEval' front [] = front--        new =-          JSAlloc "__IDR__mEVAL0" (Just $ JSFunction ["marg0"] (JSReturn $-              JSTernary (-                (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`-                (JSProj (JSIdent "marg0") "eval")-              ) (JSApp-                  (JSProj (JSIdent "marg0") "eval")-                  [JSIdent "marg0"]-              ) (JSIdent "marg0")-            )-          )---    adaptEvalTC :: [JS] -> [JS]-    adaptEvalTC js = adaptEvalTC' [] js-      where-        adaptEvalTC' :: [JS] -> [JS] -> [JS]-        adaptEvalTC' front ((JSAlloc "__IDRRT__EVALTC" (Just _)):back) =-          front ++ (new:back)--        adaptEvalTC' front (next:back) =-          adaptEvalTC' (front ++ [next]) back--        adaptEvalTC' front [] = front--        new =-          JSAlloc "__IDRRT__EVALTC" (Just $ JSFunction ["marg0"] (-            JSSeq [ JSAlloc "ret" $ Just (-                      JSTernary (-                        (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`-                        (JSProj (JSIdent "marg0") "eval")-                      ) (JSApp-                          (JSProj (JSIdent "marg0") "eval")-                          [JSIdent "marg0"]-                      ) (JSIdent "marg0")-                    )-                  , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (-                      JSAssign (JSIdent "ret") (-                        JSApp (JSProj (JSIdent "ret") "k") []-                      )-                    )-                  , JSReturn $ JSIdent "ret"-                  ]-          ))---    adaptCon js =-      adaptCon' [] js-      where-        adaptCon' front ((JSAnnotation _ (JSAlloc "__IDRRT__Con" _)):back) =-          front ++ (new:back)--        adaptCon' front (next:back) =-          adaptCon' (front ++ [next]) back--        adaptCon' front [] = front---        new =-          JSAnnotation JSConstructor $-            JSAlloc "__IDRRT__Con" (Just $-              JSFunction newArgs (-                JSSeq (map newVar newArgs)-              )-            )-          where-            newVar var = JSAssign (JSProj JSThis var) (JSIdent var)-            newArgs = ["tag", "eval", "app", "vars"]---    unfoldLT :: String -> [JS] -> ([Int], [JS])-    unfoldLT lt js =-      let (table, code) = extractLT lt js-          expanded      = expandLT lt table in-          (map fst expanded, map snd expanded ++ code)---    expandCons :: [Int] -> [Int] -> [JS] -> [JS]-    expandCons evals applys js =-      map expandCons' js-      where-        expandCons' :: JS -> JS-        expandCons' (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray args])-          | evalid  <- getId "__IDRLT__EVAL"  tag evals-          , applyid <- getId "__IDRLT__APPLY" tag applys =-              JSNew "__IDRRT__Con" [ JSNum (JSInt tag)-                                   , maybe JSNull JSIdent evalid-                                   , maybe JSNull JSIdent applyid-                                   , JSArray (map expandCons' args)-                                   ]--        expandCons' js = transformJS expandCons' js---        getId :: String -> Int -> [Int] -> Maybe String-        getId lt tag entries-          | tag `elem` entries = Just $ ltIdentifier lt tag-          | otherwise          = Nothing---    ltIdentifier :: String -> Int -> String-    ltIdentifier "__IDRLT__EVAL"  id = idrLTNamespace ++ "EVAL" ++ show id-    ltIdentifier "__IDRLT__APPLY" id = idrLTNamespace ++ "APPLY" ++ show id---    extractLT :: String -> [JS] -> (JS, [JS])-    extractLT lt js =-      extractLT' ([], js)-        where-          extractLT' :: ([JS], [JS]) -> (JS, [JS])-          extractLT' (front, js@(JSAlloc fun _):back)-            | fun == lt = (js, front ++ back)--          extractLT' (front, js:back) = extractLT' (front ++ [js], back)-          extractLT' (front, back)    = (JSNoop, front ++ back)---    expandLT :: String -> JS -> [(Int, JS)]-    expandLT lt (-        JSAlloc _ (Just (JSApp (JSFunction [] (JSSeq seq)) []))-      ) = catMaybes (map expandEntry seq)-          where-            expandEntry :: JS -> Maybe (Int, JS)-            expandEntry (JSAssign (JSIndex _ (JSNum (JSInt id))) body) =-              Just $ (id, JSAlloc (ltIdentifier lt id) (Just body))--            expandEntry js = Nothing--    expandLT lt JSNoop = []---removeInstanceChecks :: JS -> JS-removeInstanceChecks (JSCond conds) =-  removeNoopConds $ JSCond $ eliminateDeadBranches $ map (-    removeHelper *** removeInstanceChecks-  ) conds-  where-    removeHelper (-        JSBinOp "&&" (JSBinOp "instanceof" _ (JSIdent "__IDRRT__Con")) check-      ) = removeHelper check-    removeHelper js = js---    eliminateDeadBranches ((JSTrue, cond):_) = [(JSNoop, cond)]-    eliminateDeadBranches [(_, js)]         = [(JSNoop, js)]-    eliminateDeadBranches (x:xs)            = x : eliminateDeadBranches xs-    eliminateDeadBranches []                = []---    removeNoopConds :: JS -> JS-    removeNoopConds (JSCond [(JSNoop, js)]) = js-    removeNoopConds js                      = js--removeInstanceChecks js = transformJS removeInstanceChecks js---reduceLoop :: [String] -> ([JS], [JS]) -> [JS]-reduceLoop reduced (cons, program) =-  case partition findConstructors program of-       ([], js)           -> cons ++ js-       (candidates, rest) ->-         let names = reduced ++ map funName candidates in-             reduceLoop names (-               cons ++ map reduce candidates, map (reduceCall names) rest-             )-  where findConstructors :: JS -> Bool-        findConstructors js-          | (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js =-              reducable $ last body-          | otherwise = False-          where reducable :: JS -> Bool-                reducable js-                  | JSReturn ret   <- js = reducable ret-                  | JSNew _ args   <- js = and $ map reducable args-                  | JSArray fields <- js = and $ map reducable fields-                  | JSNum _        <- js = True-                  | JSNull         <- js = True-                  | JSIdent _      <- js = True-                  | otherwise            = False---        reduce :: JS -> JS-        reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))-          | JSReturn js <- last body = (JSAlloc fun (Just js))--        reduce js = js---        reduceCall :: [String] -> JS -> JS-        reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (-                          JSReturn (JSApp id@(JSIdent ret) _)-                        )])-          | ret `elem` funs = id--        reduceCall funs js@(JSApp id@(JSIdent fun) _)-          | fun `elem` funs = id--        reduceCall funs js = transformJS (reduceCall funs) js---extractLocalConstructors :: [JS] -> [JS]-extractLocalConstructors js =-  concatMap extractLocalConstructors' js-  where-    globalCons :: [String]-    globalCons = concatMap (getGlobalCons) js---    extractLocalConstructors' :: JS -> [JS]-    extractLocalConstructors' js@(JSAlloc fun (Just (JSFunction args body))) =-      addCons cons [foldr (uncurry jsSubst) js (reverse cons)]-      where-        cons :: [(JS, JS)]-        cons = zipWith genName (foldJS match (++) [] body) [1..]-          where-            genName :: JS -> Int -> (JS, JS)-            genName js id =-              (js, JSIdent $ idrCTRNamespace ++ fun ++ "_" ++ show id)--            match :: JS -> [JS]-            match js-              | JSNew "__IDRRT__Con" args <- js-              , all isConstant args = [js]-              | otherwise           = []---        addCons :: [(JS, JS)] -> [JS] -> [JS]-        addCons [] js = js-        addCons (con@(_, name):cons) js-          | sum (map (countOccur name) js) > 0 =-              addCons cons ((allocCon con) : js)-          | otherwise =-              addCons cons js---        countOccur :: JS -> JS -> Int-        countOccur ident js = foldJS match (+) 0 js-          where-            match :: JS -> Int-            match js-              | js == ident = 1-              | otherwise   = 0---        allocCon :: (JS, JS) -> JS-        allocCon (js, JSIdent name) =-          JSAlloc name (Just js)---        isConstant :: JS -> Bool-        isConstant js-          | JSNew "__IDRRT__Con" args <- js-          , all isConstant args =-              True-          | otherwise =-              isJSConstantConstructor globalCons js--    extractLocalConstructors' js = [js]---    getGlobalCons :: JS -> [String]-    getGlobalCons js = foldJS match (++) [] js-      where-        match :: JS -> [String]-        match js-          | (JSAlloc name (Just (JSNew "__IDRRT__Con" _))) <- js =-              [name]-          | otherwise =-              []---evalCons :: [JS] -> [JS]-evalCons js =-  map (collapseCont . collapseTC . expandProj . evalCons') js-  where-    cons :: [(String, JS)]-    cons = concatMap getGlobalCons js--    evalCons' :: JS -> JS-    evalCons' js = transformJS match js-      where-        match :: JS -> JS-        match (JSApp (JSIdent "__IDRRT__EVALTC") [arg])-          | JSIdent name                     <- arg-          , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons =-              arg--        match (JSApp (JSIdent "__IDR__mEVAL0") [arg])-          | JSIdent name                     <- arg-          , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons =-              arg--        match js = transformJS match js---    lookupConstructor :: String -> [(String, JS)] -> Maybe JS-    lookupConstructor ctr cons-      | Just (JSIdent name)  <- lookup ctr cons = lookupConstructor name cons-      | Just con@(JSNew _ _) <- lookup ctr cons = Just con-      | otherwise                               = Nothing---    expandProj :: JS -> JS-    expandProj js = transformJS match js-      where-        match :: JS -> JS-        match (-            JSIndex (-              JSProj (JSIdent name) "vars"-            ) (-              JSNum (JSInt idx)-            )-          )-          | Just (JSNew _ [_, _, _, JSArray args]) <- lookup name cons =-              args !! idx--        match js = transformJS match js---    collapseTC :: JS -> JS-    collapseTC js = transformJS match js-      where-        match :: JS -> JS-        match (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (-            JSReturn (JSIdent name)-          )])-          | Just _ <- lookup name cons = (JSIdent name)--        match js = transformJS match js---    collapseCont :: JS -> JS-    collapseCont js = transformJS match js-      where-        match :: JS -> JS-        match (JSNew "__IDRRT__Cont" [JSFunction [] (-            JSReturn ret@(JSNew "__IDRRT__Cont" [JSFunction [] _])-          )]) = collapseCont ret---        match (JSNew "__IDRRT__Cont" [JSFunction [] (-            JSReturn (JSIdent name)-          )]) = JSIdent name--        match (JSNew "__IDRRT__Cont" [JSFunction [] (-            JSReturn ret@(JSNew "__IDRRT__Con" [_, _, _, JSArray args])-          )])-          | all collapsable args = ret-          where-            collapsable :: JS -> Bool-            collapsable (JSIdent _) = True-            collapsable js          = isJSConstantConstructor (map fst cons) js---        match js = transformJS match js---elimConds :: [JS] -> [JS]-elimConds js =-  let (conds, rest) = partition isCond js in-      foldl' eraseCond rest conds-  where-    isCond :: JS -> Bool-    isCond (JSAlloc-      fun (Just (JSFunction args (JSCond-          [ (JSBinOp "==" (JSNum (JSInt tag)) (JSProj (JSIdent _) "tag"), JSReturn t)-          , (JSNoop, JSReturn f)-          ])))-      )-      | isJSConstant t && isJSConstant f =-          True--      | JSIdent _ <- t-      , JSIdent _ <- f =-          True--    isCond (JSAlloc-      fun (Just (JSFunction args (JSCond-        [ (JSBinOp "==" (JSIdent _) c, JSReturn t)-        , (JSNoop, JSReturn f)-        ])))-      )-      | isJSConstant t && isJSConstant f && isJSConstant c =-          True--      | JSIdent _ <- t-      , JSIdent _ <- f-      , isJSConstant c =-          True--    isCond _ = False---    eraseCond :: [JS] -> JS -> [JS]-    eraseCond js (JSAlloc-      fun (Just (JSFunction args (JSCond-                  [ (c, JSReturn t)-                  , (_, JSReturn f)-                  ])-                )-      )) = map (inlineFunction fun args (JSTernary c t f)) js---removeUselessCons :: [JS] -> [JS]-removeUselessCons js =-  let (cons, rest) = partition isUseless js in-      foldl' eraseCon rest cons-  where-    isUseless :: JS -> Bool-    isUseless (JSAlloc fun (Just JSNull))      = True-    isUseless (JSAlloc fun (Just (JSIdent _))) = True-    isUseless _                                = False---    eraseCon :: [JS] -> JS -> [JS]-    eraseCon js (JSAlloc fun (Just val))  = map (jsSubst (JSIdent fun) val) js---getGlobalCons :: JS -> [(String, JS)]-getGlobalCons js = foldJS match (++) [] js-  where-    match :: JS -> [(String, JS)]-    match js-      | (JSAlloc name (Just con@(JSNew "__IDRRT__Con" _))) <- js =-          [(name, con)]-      | (JSAlloc name (Just con@(JSIdent _))) <- js =-          [(name, con)]-      | otherwise =-          []---getIncludes :: [FilePath] -> IO [String]-getIncludes = mapM readFile--codegenJavaScript :: CodeGenerator-codegenJavaScript ci = codegenJS_all JavaScript (simpleDecls ci)-                              (includes ci) (outputFile ci) (outputType ci)--codegenNode :: CodeGenerator-codegenNode ci = codegenJS_all Node (simpleDecls ci)-                        (includes ci) (outputFile ci) (outputType ci)--codegenJS_all-  :: JSTarget-  -> [(Name, SDecl)]-  -> [FilePath]-  -> FilePath-  -> OutputType-  -> IO ()-codegenJS_all target definitions includes filename outputType = do-  let (header, rt) = case target of-                               Node ->-                                 ("#!/usr/bin/env node\n", "-node")-                               JavaScript ->-                                 ("", "-browser")-  included   <- getIncludes includes-  path       <- (++) <$> getDataDir <*> (pure "/jsrts/")-  idrRuntime <- readFile $ path ++ "Runtime-common.js"-  tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]-  jsbn       <- readFile $ path ++ "jsbn/jsbn.js"-  writeFile filename $ header ++ (-      intercalate "\n" $ included ++ runtime jsbn idrRuntime tgtRuntime ++ functions-    )--  setPermissions filename (emptyPermissions { readable   = True-                                            , executable = target == Node-                                            , writable   = True-                                            })-  where-    def :: [(String, SDecl)]-    def = map (first translateNamespace) definitions---    checkForBigInt :: [JS] -> Bool-    checkForBigInt js = occur-      where-        occur :: Bool-        occur = or $ map (foldJS match (||) False) js--        match :: JS -> Bool-        match (JSIdent "__IDRRT__bigInt") = True-        match (JSWord (JSWord64 _))       = True-        match (JSNum (JSInteger _))       = True-        match js                          = False---    runtime :: String -> String -> String -> [String]-    runtime jsbn idrRuntime tgtRuntime =-      if checkForBigInt optimized-         then [jsbn, idrRuntime, tgtRuntime]-         else [idrRuntime, tgtRuntime]---    optimized :: [JS]-    optimized = translate >>> optimize $ def-      where-        translate p =-          prelude ++ concatMap translateDeclaration p ++ [mainLoop, invokeLoop]-        optimize p  =-          foldl' (flip ($)) p opt--        opt =-          [ removeEval-          , map inlineJS-          , removeIDs-          , reduceJS-          , map reduceConstants-          , initConstructors-          , map removeAllocations-          , elimDeadLoop-          , map elimDuplicateEvals-          , optimizeRuntimeCalls "__IDR__mEVAL0" "__IDRRT__EVALTC"-          , optimizeRuntimeCalls "__IDR__mAPPLY0" "__IDRRT__APPLYTC"-          , map removeInstanceChecks-          , inlineFunctions-          , map reduceContinuations-          , extractLocalConstructors-          , unfoldLookupTable-          , evalCons-          , elimConds-          , removeUselessCons-          ]--    functions :: [String]-    functions = map compileJS optimized--    prelude :: [JS]-    prelude =-      [ JSAnnotation JSConstructor $-          JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (-            JSAssign (JSProj JSThis "k") (JSIdent "k")-          ))-      , JSAnnotation JSConstructor $-          JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] (-            JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag")-                  , JSAssign (JSProj JSThis "vars") (JSIdent "vars")-                  ]-          ))-      ]--    mainLoop :: JS-    mainLoop =-        JSAlloc "main" $ Just $ JSFunction [] (-          case target of-              Node       -> mainFun-              JavaScript -> JSCond [ (exists document `jsAnd` isReady, mainFun)-                                   , (exists window, windowMainFun)-                                   , (JSTrue, mainFun)-                                   ]-      )-      where-        exists :: JS -> JS-        exists js = (JSPreOp "typeof " js) `jsNotEq` JSString "undefined"--        mainFun :: JS-        mainFun = jsTailcall $ jsCall runMain []--        window :: JS-        window = JSIdent "window"--        document :: JS-        document = JSIdent "document"--        windowMainFun :: JS-        windowMainFun = jsMeth window "addEventListener" [-            JSString "DOMContentLoaded"-            , JSFunction [] ( mainFun )-            , JSFalse-            ]--        isReady :: JS-        isReady = JSParens $ readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"--        readyState :: JS-        readyState = JSProj (JSIdent "document") "readyState"---        runMain :: String-        runMain = idrNamespace ++ translateName (sMN 0 "runMain")---    invokeLoop :: JS-    invokeLoop  = jsCall "main" []---translateIdentifier :: String -> String-translateIdentifier =-  replaceReserved . concatMap replaceBadChars-  where replaceBadChars :: Char -> String-        replaceBadChars c-          | ' ' <- c  = "_"-          | '_' <- c  = "__"-          | isDigit c = '_' : show (ord c)-          | not (isLetter c && isAscii c) = '_' : show (ord c)-          | otherwise = [c]-        replaceReserved s-          | s `elem` reserved = '_' : s-          | otherwise         = s---        reserved = [ "break"-                   , "case"-                   , "catch"-                   , "continue"-                   , "debugger"-                   , "default"-                   , "delete"-                   , "do"-                   , "else"-                   , "finally"-                   , "for"-                   , "function"-                   , "if"-                   , "in"-                   , "instanceof"-                   , "new"-                   , "return"-                   , "switch"-                   , "this"-                   , "throw"-                   , "try"-                   , "typeof"-                   , "var"-                   , "void"-                   , "while"-                   , "with"--                   , "class"-                   , "enum"-                   , "export"-                   , "extends"-                   , "import"-                   , "super"--                   , "implements"-                   , "interface"-                   , "let"-                   , "package"-                   , "private"-                   , "protected"-                   , "public"-                   , "static"-                   , "yield"-                   ]---translateNamespace :: Name -> String-translateNamespace (UN _)    = idrNamespace-translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns-translateNamespace (MN _ _)  = idrNamespace-translateNamespace (SN name) = idrNamespace ++ translateSpecialName name-translateNamespace NErased   = idrNamespace---translateName :: Name -> String-translateName (UN name)   = 'u' : translateIdentifier (str name)-translateName (NS name _) = 'n' : translateName name-translateName (MN i name) = 'm' : translateIdentifier (str name) ++ show i-translateName (SN name)   = 's' : translateSpecialName name-translateName NErased     = "e"---translateSpecialName :: SpecialName -> String-translateSpecialName name-  | WhereN i m n  <- name =-    'w' : translateName m ++ translateName n ++ show i-  | InstanceN n s <- name =-    'i' : translateName n ++ concatMap (translateIdentifier . str) s-  | ParentN n s   <- name =-    'p' : translateName n ++ translateIdentifier (str s)-  | MethodN n     <- name =-    'm' : translateName n-  | CaseN n       <- name =-    'c' : translateName n---translateConstant :: Const -> JS-translateConstant (I i)                    = JSNum (JSInt i)-translateConstant (Fl f)                   = JSNum (JSFloat f)-translateConstant (Ch c)                   = JSString $ translateChar c-translateConstant (Str s)                  = JSString $ concatMap translateChar s-translateConstant (AType (ATInt ITNative)) = JSType JSIntTy-translateConstant StrType                  = JSType JSStringTy-translateConstant (AType (ATInt ITBig))    = JSType JSIntegerTy-translateConstant (AType ATFloat)          = JSType JSFloatTy-translateConstant (AType (ATInt ITChar))   = JSType JSCharTy-translateConstant PtrType                  = JSType JSPtrTy-translateConstant Forgot                   = JSType JSForgotTy-translateConstant (BI i)                   = jsBigInt $ JSString (show i)-translateConstant (B8 b)                   = JSWord (JSWord8 b)-translateConstant (B16 b)                  = JSWord (JSWord16 b)-translateConstant (B32 b)                  = JSWord (JSWord32 b)-translateConstant (B64 b)                  = JSWord (JSWord64 b)-translateConstant c =-  jsError $ "Unimplemented Constant: " ++ show c---translateChar :: Char -> String-translateChar ch-  | '\a'   <- ch       = "\\u0007"-  | '\b'   <- ch       = "\\b"-  | '\f'   <- ch       = "\\f"-  | '\n'   <- ch       = "\\n"-  | '\r'   <- ch       = "\\r"-  | '\t'   <- ch       = "\\t"-  | '\v'   <- ch       = "\\v"-  | '\SO'  <- ch       = "\\u000E"-  | '\DEL' <- ch       = "\\u007F"-  | '\\'   <- ch       = "\\\\"-  | '\"'   <- ch       = "\\\""-  | '\''   <- ch       = "\\\'"-  | ch `elem` asciiTab = "\\u00" ++ fill (showIntAtBase 16 intToDigit (ord ch) "")-  | otherwise          = [ch]-  where-    fill :: String -> String-    fill s = if length s == 1-                then '0' : s-                else s--    asciiTab =-      ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',-       '\BS',  '\HT',  '\LF',  '\VT',  '\FF',  '\CR',  '\SO',  '\SI',-       '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',-       '\CAN', '\EM',  '\SUB', '\ESC', '\FS',  '\GS',  '\RS',  '\US']---translateDeclaration :: (String, SDecl) -> [JS]-translateDeclaration (path, SFun name params stackSize body)-  | (MN _ ap)             <- name-  , (SChkCase var cases) <- body-  , ap == txt "APPLY" =-      [ lookupTable "APPLY" [] var cases-      , jsDecl $ JSFunction ["mfn0", "marg0"] (JSReturn $-          JSTernary (-            (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`-            (hasProp (idrLTNamespace ++ "APPLY") "mfn0")-          ) (JSApp-              (JSIndex-                (JSIdent (idrLTNamespace ++ "APPLY"))-                (JSProj (JSIdent "mfn0") "tag")-              )-              [JSIdent "mfn0", JSIdent "marg0"]-          ) JSNull-        )-      ]--  | (MN _ ev)            <- name-  , (SChkCase var cases) <- body-  , ev == txt "EVAL" =-      [ lookupTable "EVAL" [] var cases-      , jsDecl $ JSFunction ["marg0"] (JSReturn $-          JSTernary (-            (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`-            (hasProp (idrLTNamespace ++ "EVAL") "marg0")-          ) (JSApp-              (JSIndex-                (JSIdent (idrLTNamespace ++ "EVAL"))-                (JSProj (JSIdent "marg0") "tag")-              )-              [JSIdent "marg0"]-          ) (JSIdent "marg0")-        )-      ]-  | otherwise =-    let fun = translateExpression body in-        [jsDecl $ jsFun fun]--  where-    hasProp :: String -> String -> JS-    hasProp table var =-      JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")---    caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS-    caseFun aux var cse =-      let (JSReturn c) = translateCase (Just (translateVariableName var)) cse in-          jsFunAux aux c---    getTag :: SAlt -> Maybe Int-    getTag (SConCase _ tag _ _ _) = Just tag-    getTag _                      = Nothing---    lookupTable :: String -> [(LVar, String)] -> LVar -> [SAlt] -> JS-    lookupTable table aux var cases =-      JSAlloc (idrLTNamespace ++ table) $ Just (-        JSApp (JSFunction [] (-          JSSeq $ [-            JSAlloc "t" $ Just (JSArray [])-          ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [-            JSReturn (JSIdent "t")-          ]-        )) []-      )-      where-        assignEntries :: [(Int, JS)] -> [JS]-        assignEntries entries =-          map (\(tag, fun) ->-            JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun-          ) entries---        lookupEntry :: [(LVar, String)] ->  LVar -> SAlt -> Maybe (Int, JS)-        lookupEntry aux var alt = do-          tag <- getTag alt-          return (tag, caseFun aux var alt)---    jsDecl :: JS -> JS-    jsDecl = JSAlloc (path ++ translateName name) . Just---    jsFun body = jsFunAux [] body---    jsFunAux :: [(LVar, String)] -> JS -> JS-    jsFunAux aux body =-      JSFunction (p ++ map snd aux) (-        JSSeq $-        zipWith assignVar [0..] p ++-        map assignAux aux ++-        [JSReturn body]-      )-      where-        assignVar :: Int -> String -> JS-        assignVar n s = JSAlloc (jsVar n)  (Just $ JSIdent s)---        assignAux :: (LVar, String) -> JS-        assignAux (Loc var, val) =-          JSAlloc (jsVar var) (Just $ JSIdent val)---        p :: [String]-        p = map translateName params---translateVariableName :: LVar -> String-translateVariableName (Loc i) =-  jsVar i---translateExpression :: SExp -> JS-translateExpression (SLet name value body) =-  jsLet (translateVariableName name) (-    translateExpression value-  ) (translateExpression body)--translateExpression (SConst cst) =-  translateConstant cst--translateExpression (SV var) =-  JSVar var--translateExpression (SApp tc name vars)-  | False <- tc =-    jsTailcall $ translateFunctionCall name vars-  | True <- tc =-    JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (-      JSReturn $ translateFunctionCall name vars-    )]-  where-    translateFunctionCall name vars =-      jsCall (translateNamespace name ++ translateName name) (map JSVar vars)--translateExpression (SOp op vars)-  | LNoOp <- op = JSVar (last vars)--  | (LZExt (ITFixed IT8) ITNative)  <- op = jsUnPackBits $ JSVar (last vars)-  | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ JSVar (last vars)-  | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ JSVar (last vars)--  | (LZExt _ ITBig)        <- op = jsBigInt $ jsCall "String" [JSVar (last vars)]-  | (LPlus (ATInt ITBig))  <- op-  , (lhs:rhs:_)            <- vars = invokeMeth lhs "add" [rhs]-  | (LMinus (ATInt ITBig)) <- op-  , (lhs:rhs:_)            <- vars = invokeMeth lhs "subtract" [rhs]-  | (LTimes (ATInt ITBig)) <- op-  , (lhs:rhs:_)            <- vars = invokeMeth lhs "multiply" [rhs]-  | (LSDiv (ATInt ITBig))  <- op-  , (lhs:rhs:_)            <- vars = invokeMeth lhs "divide" [rhs]-  | (LSRem (ATInt ITBig))  <- op-  , (lhs:rhs:_)            <- vars = invokeMeth lhs "mod" [rhs]-  | (LEq (ATInt ITBig))    <- op-  , (lhs:rhs:_)            <- vars = invokeMeth lhs "equals" [rhs]-  | (LSLt (ATInt ITBig))   <- op-  , (lhs:rhs:_)            <- vars = invokeMeth lhs "lesser" [rhs]-  | (LSLe (ATInt ITBig))   <- op-  , (lhs:rhs:_)            <- vars = invokeMeth lhs "lesserOrEquals" [rhs]-  | (LSGt (ATInt ITBig))   <- op-  , (lhs:rhs:_)            <- vars = invokeMeth lhs "greater" [rhs]-  | (LSGe (ATInt ITBig))   <- op-  , (lhs:rhs:_)            <- vars = invokeMeth lhs "greaterOrEquals" [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-  | (LSLt ATFloat)   <- op-  , (lhs:rhs:_)      <- vars = translateBinaryOp "<" lhs rhs-  | (LSLe ATFloat)   <- op-  , (lhs:rhs:_)      <- vars = translateBinaryOp "<=" lhs rhs-  | (LSGt ATFloat)   <- op-  , (lhs:rhs:_)      <- vars = translateBinaryOp ">" lhs rhs-  | (LSGe ATFloat)   <- op-  , (lhs:rhs:_)      <- vars = translateBinaryOp ">=" lhs rhs--  | (LPlus (ATInt ITChar)) <- op-  , (lhs:rhs:_)            <- vars =-      jsCall "__IDRRT__fromCharCode" [-        JSBinOp "+" (-          jsCall "__IDRRT__charCode" [JSVar lhs]-        ) (-          jsCall "__IDRRT__charCode" [JSVar rhs]-        )-      ]--  | (LTrunc (ITFixed IT16) (ITFixed IT8)) <- op-  , (arg:_)                               <- vars =-      jsPackUBits8 (-        JSBinOp "&" (jsUnPackBits $ JSVar arg) (JSNum (JSInt 0xFF))-      )--  | (LTrunc (ITFixed IT32) (ITFixed IT16)) <- op-  , (arg:_)                                <- vars =-      jsPackUBits16 (-        JSBinOp "&" (jsUnPackBits $ JSVar arg) (JSNum (JSInt 0xFFFF))-      )--  | (LTrunc (ITFixed IT64) (ITFixed IT32)) <- op-  , (arg:_)                                <- vars =-      jsPackUBits32 (-        jsMeth (jsMeth (JSVar arg) "and" [-          jsBigInt (JSString $ show 0xFFFFFFFF)-        ]) "intValue" []-      )--  | (LTrunc ITBig (ITFixed IT64)) <- op-  , (arg:_)                       <- vars =-      jsMeth (JSVar arg) "and" [-        jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)-      ]--  | (LLSHR (ITFixed IT8)) <- op-  , (lhs:rhs:_)           <- vars =-      jsPackUBits8 (-        JSBinOp ">>" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)-      )--  | (LLSHR (ITFixed IT16)) <- op-  , (lhs:rhs:_)            <- vars =-      jsPackUBits16 (-        JSBinOp ">>" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)-      )--  | (LLSHR (ITFixed IT32)) <- op-  , (lhs:rhs:_)            <- vars =-      jsPackUBits32  (-        JSBinOp ">>" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)-      )--  | (LLSHR (ITFixed IT64)) <- op-  , (lhs:rhs:_)            <- vars =-      jsMeth (JSVar lhs) "shiftRight" [JSVar rhs]--  | (LSHL (ITFixed IT8)) <- op-  , (lhs:rhs:_)          <- vars =-      jsPackUBits8 (-        JSBinOp "<<" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)-      )--  | (LSHL (ITFixed IT16)) <- op-  , (lhs:rhs:_)           <- vars =-      jsPackUBits16 (-        JSBinOp "<<" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)-      )--  | (LSHL (ITFixed IT32)) <- op-  , (lhs:rhs:_)           <- vars =-      jsPackUBits32  (-        JSBinOp "<<" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)-      )--  | (LSHL (ITFixed IT64)) <- op-  , (lhs:rhs:_)           <- vars =-      jsMeth (jsMeth (JSVar lhs) "shiftLeft" [JSVar rhs]) "and" [-        jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)-      ]--  | (LAnd (ITFixed IT8)) <- op-  , (lhs:rhs:_)          <- vars =-      jsPackUBits8 (-        JSBinOp "&" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LAnd (ITFixed IT16)) <- op-  , (lhs:rhs:_)           <- vars =-      jsPackUBits16 (-        JSBinOp "&" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LAnd (ITFixed IT32)) <- op-  , (lhs:rhs:_)           <- vars =-      jsPackUBits32 (-        JSBinOp "&" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LAnd (ITFixed IT64)) <- op-  , (lhs:rhs:_)           <- vars =-      jsMeth (JSVar lhs) "and" [JSVar rhs]--  | (LOr (ITFixed IT8)) <- op-  , (lhs:rhs:_)         <- vars =-      jsPackUBits8 (-        JSBinOp "|" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LOr (ITFixed IT16)) <- op-  , (lhs:rhs:_)          <- vars =-      jsPackUBits16 (-        JSBinOp "|" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LOr (ITFixed IT32)) <- op-  , (lhs:rhs:_)          <- vars =-      jsPackUBits32 (-        JSBinOp "|" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LOr (ITFixed IT64)) <- op-  , (lhs:rhs:_)          <- vars =-      jsMeth (JSVar lhs) "or" [JSVar rhs]--  | (LXOr (ITFixed IT8)) <- op-  , (lhs:rhs:_)          <- vars =-      jsPackUBits8 (-        JSBinOp "^" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LXOr (ITFixed IT16)) <- op-  , (lhs:rhs:_)           <- vars =-      jsPackUBits16 (-        JSBinOp "^" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LXOr (ITFixed IT32)) <- op-  , (lhs:rhs:_)           <- vars =-      jsPackUBits32 (-        JSBinOp "^" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LXOr (ITFixed IT64)) <- op-  , (lhs:rhs:_)           <- vars =-      jsMeth (JSVar lhs) "xor" [JSVar rhs]--  | (LPlus (ATInt (ITFixed IT8))) <- op-  , (lhs:rhs:_)                   <- vars =-      jsPackUBits8 (-        JSBinOp "+" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LPlus (ATInt (ITFixed IT16))) <- op-  , (lhs:rhs:_)                    <- vars =-      jsPackUBits16 (-        JSBinOp "+" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LPlus (ATInt (ITFixed IT32))) <- op-  , (lhs:rhs:_)                    <- vars =-      jsPackUBits32 (-        JSBinOp "+" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LPlus (ATInt (ITFixed IT64))) <- op-  , (lhs:rhs:_)                    <- vars =-      jsMeth (jsMeth (JSVar lhs) "add" [JSVar rhs]) "and" [-        jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)-      ]--  | (LMinus (ATInt (ITFixed IT8))) <- op-  , (lhs:rhs:_)                    <- vars =-      jsPackUBits8 (-        JSBinOp "-" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LMinus (ATInt (ITFixed IT16))) <- op-  , (lhs:rhs:_)                     <- vars =-      jsPackUBits16 (-        JSBinOp "-" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LMinus (ATInt (ITFixed IT32))) <- op-  , (lhs:rhs:_)                     <- vars =-      jsPackUBits32 (-        JSBinOp "-" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LMinus (ATInt (ITFixed IT64))) <- op-  , (lhs:rhs:_)                     <- vars =-      jsMeth (jsMeth (JSVar lhs) "subtract" [JSVar rhs]) "and" [-        jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)-      ]--  | (LTimes (ATInt (ITFixed IT8))) <- op-  , (lhs:rhs:_)                    <- vars =-      jsPackUBits8 (-        JSBinOp "*" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LTimes (ATInt (ITFixed IT16))) <- op-  , (lhs:rhs:_)                     <- vars =-      jsPackUBits16 (-        JSBinOp "*" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LTimes (ATInt (ITFixed IT32))) <- op-  , (lhs:rhs:_)                     <- vars =-      jsPackUBits32 (-        JSBinOp "*" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LTimes (ATInt (ITFixed IT64))) <- op-  , (lhs:rhs:_)                     <- vars =-      jsMeth (jsMeth (JSVar lhs) "multiply" [JSVar rhs]) "and" [-        jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)-      ]--  | (LEq (ATInt (ITFixed IT8))) <- op-  , (lhs:rhs:_)                 <- vars =-      jsPackUBits8 (-        JSBinOp "==" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LEq (ATInt (ITFixed IT16))) <- op-  , (lhs:rhs:_)                  <- vars =-      jsPackUBits16 (-        JSBinOp "==" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LEq (ATInt (ITFixed IT32))) <- op-  , (lhs:rhs:_)                  <- vars =-      jsPackUBits32 (-        JSBinOp "==" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LEq (ATInt (ITFixed IT64))) <- op-  , (lhs:rhs:_)                   <- vars =-      jsMeth (jsMeth (JSVar lhs) "equals" [JSVar rhs]) "and" [-        jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)-      ]--  | (LLt (ITFixed IT8)) <- op-  , (lhs:rhs:_)         <- vars =-      jsPackUBits8 (-        JSBinOp "<" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LLt (ITFixed IT16)) <- op-  , (lhs:rhs:_)          <- vars =-      jsPackUBits16 (-        JSBinOp "<" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LLt (ITFixed IT32)) <- op-  , (lhs:rhs:_)          <- vars =-      jsPackUBits32 (-        JSBinOp "<" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LLt (ITFixed IT64)) <- op-  , (lhs:rhs:_)          <- vars = invokeMeth lhs "lesser" [rhs]--  | (LLe (ITFixed IT8)) <- op-  , (lhs:rhs:_)         <- vars =-      jsPackUBits8 (-        JSBinOp "<=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LLe (ITFixed IT16)) <- op-  , (lhs:rhs:_)          <- vars =-      jsPackUBits16 (-        JSBinOp "<=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LLe (ITFixed IT32)) <- op-  , (lhs:rhs:_)          <- vars =-      jsPackUBits32 (-        JSBinOp "<=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LLe (ITFixed IT64)) <- op-  , (lhs:rhs:_)          <- vars = invokeMeth lhs "lesserOrEquals" [rhs]--  | (LGt (ITFixed IT8)) <- op-  , (lhs:rhs:_)         <- vars =-      jsPackUBits8 (-        JSBinOp ">" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LGt (ITFixed IT16)) <- op-  , (lhs:rhs:_)          <- vars =-      jsPackUBits16 (-        JSBinOp ">" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )-  | (LGt (ITFixed IT32)) <- op-  , (lhs:rhs:_)          <- vars =-      jsPackUBits32 (-        JSBinOp ">" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LGt (ITFixed IT64)) <- op-  , (lhs:rhs:_)          <- vars = invokeMeth lhs "greater" [rhs]--  | (LGe (ITFixed IT8)) <- op-  , (lhs:rhs:_)         <- vars =-      jsPackUBits8 (-        JSBinOp ">=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LGe (ITFixed IT16)) <- op-  , (lhs:rhs:_)          <- vars =-      jsPackUBits16 (-        JSBinOp ">=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )-  | (LGe (ITFixed IT32)) <- op-  , (lhs:rhs:_)          <- vars =-      jsPackUBits32 (-        JSBinOp ">=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LGe (ITFixed IT64)) <- op-  , (lhs:rhs:_)          <- vars = invokeMeth lhs "greaterOrEquals" [rhs]--  | (LUDiv (ITFixed IT8)) <- op-  , (lhs:rhs:_)           <- vars =-      jsPackUBits8 (-        JSBinOp "/" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LUDiv (ITFixed IT16)) <- op-  , (lhs:rhs:_)            <- vars =-      jsPackUBits16 (-        JSBinOp "/" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LUDiv (ITFixed IT32)) <- op-  , (lhs:rhs:_)            <- vars =-      jsPackUBits32 (-        JSBinOp "/" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))-      )--  | (LUDiv (ITFixed IT64)) <- op-  , (lhs:rhs:_)            <- vars = invokeMeth lhs "divide" [rhs]--  | (LSDiv (ATInt (ITFixed IT8))) <- op-  , (lhs:rhs:_)                   <- vars =-      jsPackSBits8 (-        JSBinOp "/" (-          jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar lhs)-        ) (-          jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar rhs)-        )-      )--  | (LSDiv (ATInt (ITFixed IT16))) <- op-  , (lhs:rhs:_)                    <- vars =-      jsPackSBits16 (-        JSBinOp "/" (-          jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar lhs)-        ) (-          jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar rhs)-        )-      )--  | (LSDiv (ATInt (ITFixed IT32))) <- op-  , (lhs:rhs:_)                    <- vars =-      jsPackSBits32 (-        JSBinOp "/" (-          jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (JSVar lhs)-        ) (-          jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (JSVar rhs)-        )-      )--  | (LSDiv (ATInt (ITFixed IT64))) <- op-  , (lhs:rhs:_)                    <- vars = invokeMeth lhs "divide" [rhs]--  | (LSRem (ATInt (ITFixed IT8))) <- op-  , (lhs:rhs:_)                   <- vars =-      jsPackSBits8 (-        JSBinOp "%" (-          jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar lhs)-        ) (-          jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar rhs)-        )-      )--  | (LSRem (ATInt (ITFixed IT16))) <- op-  , (lhs:rhs:_)                    <- vars =-      jsPackSBits16 (-        JSBinOp "%" (-          jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar lhs)-        ) (-          jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar rhs)-        )-      )--  | (LSRem (ATInt (ITFixed IT32))) <- op-  , (lhs:rhs:_)                    <- vars =-      jsPackSBits32 (-        JSBinOp "%" (-          jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (JSVar lhs)-        ) (-          jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (JSVar rhs)-        )-      )--  | (LSRem (ATInt (ITFixed IT64))) <- op-  , (lhs:rhs:_)                    <- vars = invokeMeth lhs "mod" [rhs]--  | (LCompl (ITFixed IT8)) <- op-  , (arg:_)                <- vars =-      jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (JSVar arg)--  | (LCompl (ITFixed IT16)) <- op-  , (arg:_)                 <- vars =-      jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (JSVar arg)--  | (LCompl (ITFixed IT32)) <- op-  , (arg:_)                 <- vars =-      jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (JSVar arg)--  | (LCompl (ITFixed IT64)) <- op-  , (arg:_)     <- vars =-      invokeMeth arg "not" []--  | (LPlus _)   <- op-  , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs-  | (LMinus _)  <- op-  , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs-  | (LTimes _)  <- op-  , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs-  | (LSDiv _)   <- op-  , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs-  | (LSRem _)   <- op-  , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs-  | (LEq _)     <- op-  , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs-  | (LSLt _)    <- op-  , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs-  | (LSLe _)    <- op-  , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs-  | (LSGt _)    <- op-  , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs-  | (LSGe _)    <- op-  , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs-  | (LAnd _)    <- op-  , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs-  | (LOr _)     <- op-  , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs-  | (LXOr _)    <- op-  , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs-  | (LSHL _)    <- op-  , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs-  | (LASHR _)   <- op-  , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs-  | (LCompl _)  <- op-  , (arg:_)     <- vars = JSPreOp "~" (JSVar arg)--  | LStrConcat  <- op-  , (lhs:rhs:_) <- vars = invokeMeth lhs "concat" [rhs]-  | LStrEq      <- op-  , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs-  | LStrLt      <- op-  , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs-  | LStrLen     <- op-  , (arg:_)     <- vars = JSProj (JSVar arg) "length"--  | (LStrInt ITNative)      <- op-  , (arg:_)                 <- vars = jsCall "parseInt" [JSVar arg]-  | (LIntStr ITNative)      <- op-  , (arg:_)                 <- vars = jsCall "String" [JSVar arg]-  | (LSExt ITNative ITBig)  <- op-  , (arg:_)                 <- vars = jsBigInt $ jsCall "String" [JSVar arg]-  | (LTrunc ITBig ITNative) <- op-  , (arg:_)                 <- vars = jsMeth (JSVar arg) "intValue" []-  | (LIntStr ITBig)         <- op-  , (arg:_)                 <- vars = jsMeth (JSVar arg) "toString" []-  | (LStrInt ITBig)         <- op-  , (arg:_)                 <- vars = jsBigInt $ JSVar arg-  | LFloatStr               <- op-  , (arg:_)                 <- vars = jsCall "String" [JSVar arg]-  | LStrFloat               <- op-  , (arg:_)                 <- vars = jsCall "parseFloat" [JSVar arg]-  | (LIntFloat ITNative)    <- op-  , (arg:_)                 <- vars = JSVar arg-  | (LFloatInt ITNative)    <- op-  , (arg:_)                 <- vars = JSVar arg-  | (LChInt ITNative)       <- op-  , (arg:_)                 <- vars = jsCall "__IDRRT__charCode" [JSVar arg]-  | (LIntCh ITNative)       <- op-  , (arg:_)                 <- vars = jsCall "__IDRRT__fromCharCode" [JSVar arg]--  | LFExp       <- op-  , (arg:_)     <- vars = jsCall "Math.exp" [JSVar arg]-  | LFLog       <- op-  , (arg:_)     <- vars = jsCall "Math.log" [JSVar arg]-  | LFSin       <- op-  , (arg:_)     <- vars = jsCall "Math.sin" [JSVar arg]-  | LFCos       <- op-  , (arg:_)     <- vars = jsCall "Math.cos" [JSVar arg]-  | LFTan       <- op-  , (arg:_)     <- vars = jsCall "Math.tan" [JSVar arg]-  | LFASin      <- op-  , (arg:_)     <- vars = jsCall "Math.asin" [JSVar arg]-  | LFACos      <- op-  , (arg:_)     <- vars = jsCall "Math.acos" [JSVar arg]-  | LFATan      <- op-  , (arg:_)     <- vars = jsCall "Math.atan" [JSVar arg]-  | LFSqrt      <- op-  , (arg:_)     <- vars = jsCall "Math.sqrt" [JSVar arg]-  | LFFloor     <- op-  , (arg:_)     <- vars = jsCall "Math.floor" [JSVar arg]-  | LFCeil      <- op-  , (arg:_)     <- vars = jsCall "Math.ceil" [JSVar arg]--  | LStrCons    <- op-  , (lhs:rhs:_) <- vars = invokeMeth lhs "concat" [rhs]-  | LStrHead    <- op-  , (arg:_)     <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))-  | LStrRev     <- op-  , (arg:_)     <- vars = JSProj (JSVar arg) "split('').reverse().join('')"-  | LStrIndex   <- op-  , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)-  | LStrTail    <- op-  , (arg:_)     <- vars = let v = translateVariableName arg in-                              JSApp (JSProj (JSIdent v) "substr") [-                                JSNum (JSInt 1),-                                JSBinOp "-" (JSProj (JSIdent v) "length") (JSNum (JSInt 1))-                              ]-  | LSystemInfo <- op-  , (arg:_) <- vars = jsCall "__IDRRT__systemInfo"  [JSVar arg]-  | LNullPtr    <- op-  , (_)         <- vars = JSNull--  where-    translateBinaryOp :: String -> LVar -> LVar -> JS-    translateBinaryOp f lhs rhs = JSParens $ JSBinOp f (JSVar lhs) (JSVar rhs)---    invokeMeth :: LVar -> String -> [LVar] -> JS-    invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)--translateExpression (SError msg) =-  jsError msg--translateExpression (SForeign _ _ "putStr" [(FString, var)]) =-  jsCall (idrRTNamespace ++ "print") [JSVar var]--translateExpression (SForeign _ _ "isNull" [(FPtr, var)]) =-  JSBinOp "==" (JSVar var) JSNull--translateExpression (SForeign _ _ "idris_eqPtr" [(FPtr, lhs),(FPtr, rhs)]) =-  JSBinOp "==" (JSVar lhs) (JSVar rhs)--translateExpression (SForeign _ _ "idris_time" []) =-  JSRaw "(new Date()).getTime()"--translateExpression (SForeign _ _ fun args) =-  JSFFI fun (map generateWrapper args)-  where-    generateWrapper (ffunc, name)-      | FFunction   <- ffunc =-          JSApp (-            JSIdent $ idrRTNamespace ++ "ffiWrap"-          ) [JSIdent $ translateVariableName name]-      | FFunctionIO <- ffunc =-          JSApp (-            JSIdent $ idrRTNamespace ++ "ffiWrap"-          ) [JSIdent $ translateVariableName name]--    generateWrapper (_, name) =-      JSIdent $ translateVariableName name--translateExpression patterncase-  | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"-  | (SCase var cases)    <- patterncase = caseHelper var cases "cse"-  where-    caseHelper var cases param =-      JSApp (JSFunction [param] (-        JSCond $ map (expandCase param . translateCaseCond param) cases-      )) [JSVar var]---    expandCase :: String -> (Cond, JS) -> (JS, JS)-    expandCase _ (RawCond cond, branch) = (cond, branch)-    expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)-    expandCase var (CaseCond caseTy, branch)-      | ConCase tag <- caseTy =-          let checkCon = JSIdent var `jsInstanceOf` jsCon-              checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in-              (checkCon `jsAnd` checkTag, branch)--      | TypeCase ty <- caseTy =-          let checkTy  = JSIdent var `jsInstanceOf` jsType-              checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in-              (checkTy `jsAnd` checkTag, branch)--translateExpression (SCon i name vars) =-  JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i-                                  , JSArray $ map JSVar vars-                                  ]--translateExpression (SUpdate var@(Loc i) e) =-  JSAssign (JSVar var) (translateExpression e)--translateExpression (SProj var i) =-  JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i)--translateExpression SNothing = JSNull--translateExpression e =-  jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)---data CaseType = ConCase Int-              | TypeCase JSType-              | DefaultCase-              deriving Eq---data Cond = CaseCond CaseType-          | RawCond JS---translateCaseCond :: String -> SAlt -> (Cond, JS)-translateCaseCond _ cse@(SDefaultCase _) =-  (CaseCond DefaultCase, translateCase Nothing cse)--translateCaseCond var cse@(SConstCase ty _)-  | StrType                  <- ty = matchHelper JSStringTy-  | PtrType                  <- ty = matchHelper JSPtrTy-  | Forgot                   <- ty = matchHelper JSForgotTy-  | (AType ATFloat)          <- ty = matchHelper JSFloatTy-  | (AType (ATInt ITBig))    <- ty = matchHelper JSIntegerTy-  | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy-  | (AType (ATInt ITChar))   <- ty = matchHelper JSCharTy-  where-    matchHelper :: JSType -> (Cond, JS)-    matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)--translateCaseCond var cse@(SConstCase cst@(BI _) _) =-  let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in-      (RawCond cond, translateCase Nothing cse)--translateCaseCond var cse@(SConstCase cst _) =-  let cond = JSIdent var `jsEq` translateConstant cst in-      (RawCond cond, translateCase Nothing cse)--translateCaseCond var cse@(SConCase _ tag _ _ _) =-  (CaseCond $ ConCase tag, translateCase (Just var) cse)---translateCase :: Maybe String -> SAlt -> JS-translateCase _          (SDefaultCase e) = JSReturn $ translateExpression e-translateCase _          (SConstCase _ e) = JSReturn $ translateExpression e-translateCase (Just var) (SConCase a _ _ vars e) =-  let params = map jsVar [a .. (a + length vars)] in-      JSReturn $ jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [-        JSThis, JSProj (JSIdent var) "vars"-      ]+{-# LANGUAGE OverloadedStrings #-}+module IRTS.CodegenJavaScript (codegenJavaScript, codegenNode, JSTarget(..)) where++import IRTS.JavaScript.AST++import Idris.AbsSyntax hiding (TypeCase)+import IRTS.Bytecode+import IRTS.Lang+import IRTS.Simplified+import IRTS.CodegenCommon+import Idris.Core.TT+import IRTS.System+import Util.System++import Control.Arrow+import Control.Monad (mapM)+import Control.Applicative ((<$>), (<*>), pure)+import Control.Monad.RWS hiding (mapM)+import Control.Monad.State+import Data.Char+import Numeric+import Data.List+import Data.Maybe+import Data.Word+import Data.Traversable hiding (mapM)+import System.IO+import System.Directory++import qualified Data.Map.Strict as M+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+++data CompileInfo = CompileInfo { compileInfoApplyCases  :: [Int]+                               , compileInfoEvalCases   :: [Int]+                               , compileInfoNeedsBigInt :: Bool+                               }+++initCompileInfo :: [(Name, [BC])] -> CompileInfo+initCompileInfo bc =+  CompileInfo (collectCases "APPLY" bc) (collectCases "EVAL" bc) (lookupBigInt bc)+  where+    lookupBigInt :: [(Name, [BC])] -> Bool+    lookupBigInt = any (needsBigInt . snd)+      where+        needsBigInt :: [BC] -> Bool+        needsBigInt bc = or $ map testBCForBigInt bc+          where+            testBCForBigInt :: BC -> Bool+            testBCForBigInt (ASSIGNCONST _ c)  =+              testConstForBigInt c++            testBCForBigInt (CONSTCASE _ c d) =+                 maybe False needsBigInt d+              || (or $ map (needsBigInt . snd) c)+              || (or $ map (testConstForBigInt . fst) c)++            testBCForBigInt _ = False++            testConstForBigInt :: Const -> Bool+            testConstForBigInt (BI _)  = True+            testConstForBigInt (B64 _) = True+            testConstForBigInt _       = False+++    collectCases :: String ->  [(Name, [BC])] -> [Int]+    collectCases fun bc = getCases $ findFunction fun bc++    findFunction :: String -> [(Name, [BC])] -> [BC]+    findFunction f ((MN 0 fun, bc):_)+      | fun == txt f = bc+    findFunction f (_:bc) = findFunction f bc++    getCases :: [BC] -> [Int]+    getCases = concatMap analyze+      where+        analyze :: BC -> [Int]+        analyze (CASE _ _ b _) = map fst b+        analyze _              = []+++data JSTarget = Node | JavaScript deriving Eq+++codegenJavaScript :: CodeGenerator+codegenJavaScript ci =+  codegenJS_all JavaScript (simpleDecls ci)+    (includes ci) [] (outputFile ci) (outputType ci)++codegenNode :: CodeGenerator+codegenNode ci =+  codegenJS_all Node (simpleDecls ci)+    (includes ci) (compileLibs ci) (outputFile ci) (outputType ci)++codegenJS_all+  :: JSTarget+  -> [(Name, SDecl)]+  -> [FilePath]+  -> [String]+  -> FilePath+  -> OutputType+  -> IO ()+codegenJS_all target definitions includes libs filename outputType = do+  let bytecode = map toBC definitions+  let info = initCompileInfo bytecode+  let js = concatMap (translateDecl info) bytecode+  let full = concatMap processFunction js+  let code = deadCodeElim full+  let (cons, opt) = optimizeConstructors code+  let (header, rt) = case target of+                          Node -> ("#!/usr/bin/env node\n", "-node")+                          JavaScript -> ("", "-browser")++  included   <- concat <$> getIncludes includes+  path       <- (++) <$> getDataDir <*> (pure "/jsrts/")+  idrRuntime <- readFile $ path ++ "Runtime-common.js"+  tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]+  jsbn       <- if compileInfoNeedsBigInt info+                   then readFile $ path ++ "jsbn/jsbn.js"+                   else return ""+  let runtime = (  header+                ++ includeLibs libs+                ++ included+                ++ jsbn+                ++ idrRuntime+                ++ tgtRuntime+                )+  TIO.writeFile filename (  T.pack runtime+                         `T.append` T.concat (map compileJS opt)+                         `T.append` T.concat (map compileJS cons)+                         `T.append` main+                         `T.append` invokeMain+                         )+  setPermissions filename (emptyPermissions { readable   = True+                                            , executable = target == Node+                                            , writable   = True+                                            })+    where+      deadCodeElim :: [JS] -> [JS]+      deadCodeElim js = concatMap collectFunctions js+        where+          collectFunctions :: JS -> [JS]+          collectFunctions fun@(JSAlloc name _)+            | name == translateName (sMN 0 "runMain") = [fun]++          collectFunctions fun@(JSAlloc name (Just (JSFunction _ body))) =+            let invokations = sum $ map (+                    \x -> execState (countInvokations name x) 0+                  ) js+             in if invokations == 0+                   then []+                   else [fun]++          countInvokations :: String -> JS -> State Int ()+          countInvokations name (JSAlloc _ (Just (JSFunction _ body))) =+            countInvokations name body++          countInvokations name (JSSeq seq) =+            void $ traverse (countInvokations name) seq++          countInvokations name (JSAssign _ rhs) =+            countInvokations name rhs++          countInvokations name (JSCond conds) =+            void $ traverse (+                runKleisli $ arr id *** Kleisli (countInvokations name)+              ) conds++          countInvokations name (JSSwitch _ conds def) =+            void $ traverse (+              runKleisli $ arr id *** Kleisli (countInvokations name)+            ) conds >> traverse (countInvokations name) def++          countInvokations name (JSApp lhs rhs) =+            void $ countInvokations name lhs >> traverse (countInvokations name) rhs++          countInvokations name (JSNew _ args) =+            void $ traverse (countInvokations name) args++          countInvokations name (JSArray args) =+            void $ traverse (countInvokations name) args++          countInvokations name (JSIdent name')+            | name == name' = get >>= put . (+1)+            | otherwise     = return ()++          countInvokations _ _ = return ()++      processFunction :: JS -> [JS]+      processFunction =+        collectSplitFunctions . (\x -> evalRWS (splitFunction x) () 0)++      includeLibs :: [String] -> String+      includeLibs =+        concatMap (\lib -> "var " ++ lib ++ " = require(\"" ++ lib ++"\");\n")++      getIncludes :: [FilePath] -> IO [String]+      getIncludes = mapM readFile++      main :: T.Text+      main =+        compileJS $ JSAlloc "main" (Just $+          JSFunction [] (+            case target of+                 Node       -> mainFun+                 JavaScript -> jsMain+          )+        )++      jsMain :: JS+      jsMain =+        JSCond [ (exists document `jsAnd` isReady, mainFun)+               , (exists window, windowMainFun)+               , (JSTrue, mainFun)+               ]+        where+          exists :: JS -> JS+          exists js = jsTypeOf js `jsNotEq` JSString "undefined"++          window :: JS+          window = JSIdent "window"++          document :: JS+          document = JSIdent "document"++          windowMainFun :: JS+          windowMainFun =+            jsMeth window "addEventListener" [ JSString "DOMContentLoaded"+                                             , JSFunction [] ( mainFun )+                                             , JSFalse+                                             ]++          isReady :: JS+          isReady = JSParens $ readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"++          readyState :: JS+          readyState = JSProj (JSIdent "document") "readyState"++      mainFun :: JS+      mainFun =+        JSSeq [ JSAlloc "vm" (Just $ JSNew "i$VM" [])+              , JSApp (JSIdent "i$SCHED") [JSIdent "vm"]+              , JSApp (+                  JSIdent (translateName (sMN 0 "runMain"))+                ) [JSNum (JSInt 0)]+              , JSWhile (JSProj jsCALLSTACK "length") (+                  JSSeq [ JSAlloc "func" (Just jsPOP)+                        , JSAlloc "args" (Just jsPOP)+                        , JSApp (JSProj (JSIdent "func") "apply") [JSThis, JSIdent "args"]+                        ]+                )+              ]++      invokeMain :: T.Text+      invokeMain = compileJS $ JSApp (JSIdent "main") []++optimizeConstructors :: [JS] -> ([JS], [JS])+optimizeConstructors js =+    let (js', cons) = runState (traverse optimizeConstructor' js) M.empty in+        (map (allocCon . snd) (M.toList cons), js')+  where+    allocCon :: (String, JS) -> JS+    allocCon (name, con) = JSAlloc name (Just con)++    newConstructor :: Int -> String+    newConstructor n = "i$CON$" ++ show n++    optimizeConstructor' :: JS -> State (M.Map Int (String, JS)) JS+    optimizeConstructor' js@(JSNew "i$CON" [ JSNum (JSInt tag)+                                           , JSArray []+                                           , a+                                           , e+                                           ]) = do+      s <- get+      case M.lookup tag s of+           Just (i, c) -> return $ JSIdent i+           Nothing     -> do let n = newConstructor tag+                             put $ M.insert tag (n, js) s+                             return $ JSIdent n++    optimizeConstructor' (JSSeq seq) =+      JSSeq <$> traverse optimizeConstructor' seq++    optimizeConstructor' (JSSwitch reg cond def) = do+      cond' <- traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond+      def'  <- traverse optimizeConstructor' def+      return $ JSSwitch reg cond' def'++    optimizeConstructor' (JSCond cond) =+      JSCond <$> traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond++    optimizeConstructor' (JSAlloc fun (Just (JSFunction args body))) = do+      body' <- optimizeConstructor' body+      return $ JSAlloc fun (Just (JSFunction args body'))++    optimizeConstructor' (JSAssign lhs rhs) = do+      lhs' <- optimizeConstructor' lhs+      rhs' <- optimizeConstructor' rhs+      return $ JSAssign lhs' rhs'++    optimizeConstructor' js = return js++collectSplitFunctions :: (JS, [(Int,JS)]) -> [JS]+collectSplitFunctions (fun, splits) = map generateSplitFunction splits ++ [fun]+  where+    generateSplitFunction :: (Int,JS) -> JS+    generateSplitFunction (depth, JSAlloc name fun) =+      JSAlloc (name ++ "$" ++ show depth) fun++splitFunction :: JS -> RWS () [(Int,JS)] Int JS+splitFunction (JSAlloc name (Just (JSFunction args body@(JSSeq _)))) = do+  body' <- splitSequence body+  return $ JSAlloc name (Just (JSFunction args body'))+    where+      splitCondition :: JS -> RWS () [(Int,JS)] Int JS+      splitCondition js+        | JSCond branches <- js =+            JSCond <$> processBranches branches+        | JSSwitch cond branches def <- js =+            JSSwitch cond <$> (processBranches branches) <*> (traverse splitSequence def)+        | otherwise = return js+        where+          processBranches :: [(JS,JS)] -> RWS () [(Int,JS)] Int [(JS,JS)]+          processBranches =+            traverse (runKleisli (arr id *** Kleisli splitSequence))++      splitSequence :: JS -> RWS () [(Int, JS)] Int JS+      splitSequence js@(JSSeq seq) =+        let (pre,post) = break isCall seq in+            case post of+                 []                    -> JSSeq <$> traverse splitCondition seq+                 [js@(JSCond _)]       -> splitCondition js+                 [js@(JSSwitch {})] -> splitCondition js+                 [_]                   -> return js+                 (call:rest) -> do+                   depth <- get+                   put (depth + 1)+                   new <- splitFunction (newFun rest)+                   tell [(depth, new)]+                   return $ JSSeq (pre ++ (newCall depth : [call]))++      splitSequence js = return js++      isCall :: JS -> Bool+      isCall (JSApp (JSIdent "i$CALL") _) = True+      isCall _                            = False++      newCall :: Int -> JS+      newCall depth =+        JSApp (JSIdent "i$CALL") [ JSIdent $ name ++ "$" ++ show depth+                                 , JSArray [jsOLDBASE, jsMYOLDBASE]+                                 ]++      newFun :: [JS] -> JS+      newFun seq =+        JSAlloc name (Just $ JSFunction ["oldbase", "myoldbase"] (JSSeq seq))++splitFunction js = return js++translateDecl :: CompileInfo -> (Name, [BC]) -> [JS]+translateDecl info (name@(MN 0 fun), bc)+  | txt "APPLY" == fun =+         allocCaseFunctions (snd body)+      ++ [ JSAlloc (+               translateName name+           ) (Just $ JSFunction ["oldbase"] (+               JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [+                 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "app")+                          , JSApp (JSProj (translateReg $ caseReg (snd body)) "app") [jsOLDBASE, jsMYOLDBASE]+                          )+                          , ( JSNoop+                            , JSSeq $ map (translateBC info) (defaultCase (snd body))+                            )+                        ]+               ]+             )+           )+         ]++  | txt "EVAL" == fun =+         allocCaseFunctions (snd body)+      ++ [ JSAlloc (+               translateName name+           ) (Just $ JSFunction ["oldbase"] (+               JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [+                 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "ev")+                          , JSApp (JSProj (translateReg $ caseReg (snd body)) "ev") [jsOLDBASE, jsMYOLDBASE]+                          )+                          , ( JSNoop+                            , JSSeq $ map (translateBC info) (defaultCase (snd body))+                            )+                        ]+               ]+             )+           )+         ]+  where+    body :: ([BC], [BC])+    body = break isCase bc++    isCase :: BC -> Bool+    isCase bc+      | CASE {} <- bc = True+      | otherwise          = False++    defaultCase :: [BC] -> [BC]+    defaultCase ((CASE _ _ _ (Just d)):_) = d++    caseReg :: [BC] -> Reg+    caseReg ((CASE _ r _ _):_) = r++    allocCaseFunctions :: [BC] -> [JS]+    allocCaseFunctions ((CASE _ _ c _):_) = splitBranches c+    allocCaseFunctions _                  = []++    splitBranches :: [(Int, [BC])] -> [JS]+    splitBranches = map prepBranch++    prepBranch :: (Int, [BC]) -> JS+    prepBranch (tag, code) =+      JSAlloc (+        translateName name ++ "$" ++ show tag+      ) (Just $ JSFunction ["oldbase", "myoldbase"] (+          JSSeq $ map (translateBC info) code+        )+      )++translateDecl info (name, bc) =+  [ JSAlloc (+       translateName name+     ) (Just $ JSFunction ["oldbase"] (+         JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info)bc+       )+     )+  ]+++translateReg :: Reg -> JS+translateReg reg+  | RVal <- reg = jsRET+  | Tmp  <- reg = JSRaw "//TMPREG"+  | L n  <- reg = jsLOC n+  | T n  <- reg = jsTOP n++translateConstant :: Const -> JS+translateConstant (I i)                    = JSNum (JSInt i)+translateConstant (Fl f)                   = JSNum (JSFloat f)+translateConstant (Ch c)                   = JSString $ translateChar c+translateConstant (Str s)                  = JSString $ concatMap translateChar s+translateConstant (AType (ATInt ITNative)) = JSType JSIntTy+translateConstant StrType                  = JSType JSStringTy+translateConstant (AType (ATInt ITBig))    = JSType JSIntegerTy+translateConstant (AType ATFloat)          = JSType JSFloatTy+translateConstant (AType (ATInt ITChar))   = JSType JSCharTy+translateConstant PtrType                  = JSType JSPtrTy+translateConstant Forgot                   = JSType JSForgotTy+translateConstant (BI 0)                   = JSNum (JSInteger JSBigZero)+translateConstant (BI 1)                   = JSNum (JSInteger JSBigOne)+translateConstant (BI i)                   = jsBigInt (JSString $ show i)+translateConstant (B8 b)                   = JSWord (JSWord8 b)+translateConstant (B16 b)                  = JSWord (JSWord16 b)+translateConstant (B32 b)                  = JSWord (JSWord32 b)+translateConstant (B64 b)                  = JSWord (JSWord64 b)+translateConstant c =+  JSError $ "Unimplemented Constant: " ++ show c+++translateChar :: Char -> String+translateChar ch+  | '\a'   <- ch       = "\\u0007"+  | '\b'   <- ch       = "\\b"+  | '\f'   <- ch       = "\\f"+  | '\n'   <- ch       = "\\n"+  | '\r'   <- ch       = "\\r"+  | '\t'   <- ch       = "\\t"+  | '\v'   <- ch       = "\\v"+  | '\SO'  <- ch       = "\\u000E"+  | '\DEL' <- ch       = "\\u007F"+  | '\\'   <- ch       = "\\\\"+  | '\"'   <- ch       = "\\\""+  | '\''   <- ch       = "\\\'"+  | ch `elem` asciiTab = "\\u00" ++ fill (showHex (ord ch) "")+  | otherwise          = [ch]+  where+    fill :: String -> String+    fill s = if length s == 1+                then '0' : s+                else s++    asciiTab =+      ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',+       '\BS',  '\HT',  '\LF',  '\VT',  '\FF',  '\CR',  '\SO',  '\SI',+       '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',+       '\CAN', '\EM',  '\SUB', '\ESC', '\FS',  '\GS',  '\RS',  '\US']++translateName :: Name -> String+translateName n = "_idris_" ++ concatMap cchar (showCG n)+  where cchar x | isAlphaNum x = [x]+                | otherwise    = "_" ++ show (fromEnum x) ++ "_"++jsASSIGN :: CompileInfo -> Reg -> Reg -> JS+jsASSIGN _ r1 r2 = JSAssign (translateReg r1) (translateReg r2)++jsASSIGNCONST :: CompileInfo -> Reg -> Const -> JS+jsASSIGNCONST _ r c = JSAssign (translateReg r) (translateConstant c)++jsCALL :: CompileInfo -> Name -> JS+jsCALL _ n =+  JSApp (+    JSIdent "i$CALL"+  ) [JSIdent (translateName n), JSArray [jsMYOLDBASE]]++jsTAILCALL :: CompileInfo -> Name -> JS+jsTAILCALL _ n =+  JSApp (+    JSIdent "i$CALL"+  ) [JSIdent (translateName n), JSArray [jsOLDBASE]]++jsFOREIGN :: CompileInfo -> Reg -> String -> [(FType, Reg)] -> JS+jsFOREIGN _ reg n args+  | n == "putStr"+  , [(FString, arg)] <- args =+      JSAssign (+        translateReg reg+      ) (+        JSApp (JSIdent "i$putStr") [translateReg arg]+      )++  | n == "isNull"+  , [(FPtr, arg)] <- args =+      JSAssign (+        translateReg reg+      ) (+        JSBinOp "==" (translateReg arg) JSNull+      )++  | n == "idris_eqPtr"+  , [(_, lhs),(_, rhs)] <- args =+      JSAssign (+        translateReg reg+      ) (+        JSBinOp "==" (translateReg lhs) (translateReg rhs)+      )+  | otherwise =+     JSAssign (+       translateReg reg+     ) (+       JSFFI n (map generateWrapper args)+     )+    where+      generateWrapper :: (FType, Reg) -> JS+      generateWrapper (ty, reg)+        | FFunction   <- ty =+            JSApp (JSIdent "i$ffiWrap") [ translateReg reg+                                        , JSIdent "oldbase"+                                        , JSIdent "myoldbase"+                                        ]+        | FFunctionIO <- ty =+            JSApp (JSIdent "i$ffiWrap") [ translateReg reg+                                        , JSIdent "oldbase"+                                        , JSIdent "myoldbase"+                                        ]++      generateWrapper (_, reg) =+        translateReg reg++jsREBASE :: CompileInfo -> JS+jsREBASE _ = JSAssign jsSTACKBASE jsOLDBASE++jsSTOREOLD :: CompileInfo ->JS+jsSTOREOLD _ = JSAssign jsMYOLDBASE jsSTACKBASE++jsADDTOP :: CompileInfo -> Int -> JS+jsADDTOP info n+  | 0 <- n    = JSNoop+  | otherwise =+      JSBinOp "+=" jsSTACKTOP (JSNum (JSInt n))++jsTOPBASE :: CompileInfo -> Int -> JS+jsTOPBASE _ 0  = JSAssign jsSTACKTOP jsSTACKBASE+jsTOPBASE _ n  = JSAssign jsSTACKTOP (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))+++jsBASETOP :: CompileInfo -> Int -> JS+jsBASETOP _ 0 = JSAssign jsSTACKBASE jsSTACKTOP+jsBASETOP _ n = JSAssign jsSTACKBASE (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))++jsNULL :: CompileInfo -> Reg -> JS+jsNULL _ r = JSAssign (translateReg r) JSNull++jsERROR :: CompileInfo -> String -> JS+jsERROR _ = JSError++jsSLIDE :: CompileInfo -> Int -> JS+jsSLIDE _ 1 = JSAssign (jsLOC 0) (jsTOP 0)+jsSLIDE _ n = JSApp (JSIdent "i$SLIDE") [JSNum (JSInt n)]++jsMKCON :: CompileInfo -> Reg -> Int -> [Reg] -> JS+jsMKCON info r t rs =+  JSAssign (translateReg r) (+    JSNew "i$CON" [ JSNum (JSInt t)+                  , JSArray (map translateReg rs)+                  , if t `elem` compileInfoApplyCases info+                       then JSIdent $ translateName (sMN 0 "APPLY") ++ "$" ++ show t+                       else JSNull+                  , if t `elem` compileInfoEvalCases info+                       then JSIdent $ translateName (sMN 0 "EVAL") ++ "$" ++ show t+                       else JSNull+                  ]+  )++jsCASE :: CompileInfo -> Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS+jsCASE info safe reg cases def =+  JSSwitch (tag safe $ translateReg reg) (+    map ((JSNum . JSInt) *** prepBranch) cases+  ) (fmap prepBranch def)+    where+      tag :: Bool -> JS -> JS+      tag True  = jsCTAG+      tag False = jsTAG++      prepBranch :: [BC] -> JS+      prepBranch bc = JSSeq $ map (translateBC info) bc++      jsTAG :: JS -> JS+      jsTAG js =+        (JSTernary (js `jsInstanceOf` "i$CON") (+          JSProj js "tag"+        ) (JSNum (JSInt $ negate 1)))++      jsCTAG :: JS -> JS+      jsCTAG js = JSProj js "tag"+++jsCONSTCASE :: CompileInfo -> Reg -> [(Const, [BC])] -> Maybe [BC] -> JS+jsCONSTCASE info reg cases def =+  JSCond $ (+    map (jsEq (translateReg reg) . translateConstant *** prepBranch) cases+  ) ++ (maybe [] ((:[]) . ((,) JSNoop) . prepBranch) def)+    where+      prepBranch :: [BC] -> JS+      prepBranch bc = JSSeq $ map (translateBC info) bc++jsPROJECT :: CompileInfo -> Reg -> Int -> Int -> JS+jsPROJECT _ reg loc 0  = JSNoop+jsPROJECT _ reg loc 1  =+  JSAssign (jsLOC loc) (+    JSIndex (+      JSProj (translateReg reg) "args"+    ) (+      JSNum (JSInt 0)+    )+  )+jsPROJECT _ reg loc ar =+  JSApp (JSIdent "i$PROJECT") [ translateReg reg+                              , JSNum (JSInt loc)+                              , JSNum (JSInt ar)+                              ]++jsOP :: CompileInfo -> Reg -> PrimFn -> [Reg] -> JS+jsOP _ reg op args = JSAssign (translateReg reg) jsOP'+  where+    jsOP' :: JS+    jsOP'+      | LNoOp <- op = translateReg (last args)++      | (LZExt (ITFixed IT8) ITNative)  <- op = jsUnPackBits $ translateReg (last args)+      | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ translateReg (last args)+      | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ translateReg (last args)++      | (LZExt _ ITBig)        <- op = jsBigInt $ JSApp  (JSIdent "String") [translateReg (last args)]+      | (LPlus (ATInt ITBig))  <- op+      , (lhs:rhs:_)            <- args = invokeMeth lhs "add" [rhs]+      | (LMinus (ATInt ITBig)) <- op+      , (lhs:rhs:_)            <- args = invokeMeth lhs "subtract" [rhs]+      | (LTimes (ATInt ITBig)) <- op+      , (lhs:rhs:_)            <- args = invokeMeth lhs "multiply" [rhs]+      | (LSDiv (ATInt ITBig))  <- op+      , (lhs:rhs:_)            <- args = invokeMeth lhs "divide" [rhs]+      | (LSRem (ATInt ITBig))  <- op+      , (lhs:rhs:_)            <- args = invokeMeth lhs "mod" [rhs]+      | (LEq (ATInt ITBig))    <- op+      , (lhs:rhs:_)            <- args = invokeMeth lhs "equals" [rhs]+      | (LSLt (ATInt ITBig))   <- op+      , (lhs:rhs:_)            <- args = invokeMeth lhs "lesser" [rhs]+      | (LSLe (ATInt ITBig))   <- op+      , (lhs:rhs:_)            <- args = invokeMeth lhs "lesserOrEquals" [rhs]+      | (LSGt (ATInt ITBig))   <- op+      , (lhs:rhs:_)            <- args = invokeMeth lhs "greater" [rhs]+      | (LSGe (ATInt ITBig))   <- op+      , (lhs:rhs:_)            <- args = invokeMeth lhs "greaterOrEquals" [rhs]++      | (LPlus ATFloat)  <- op+      , (lhs:rhs:_)      <- args = translateBinaryOp "+" lhs rhs+      | (LMinus ATFloat) <- op+      , (lhs:rhs:_)      <- args = translateBinaryOp "-" lhs rhs+      | (LTimes ATFloat) <- op+      , (lhs:rhs:_)      <- args = translateBinaryOp "*" lhs rhs+      | (LSDiv ATFloat)  <- op+      , (lhs:rhs:_)      <- args = translateBinaryOp "/" lhs rhs+      | (LEq ATFloat)    <- op+      , (lhs:rhs:_)      <- args = translateBinaryOp "==" lhs rhs+      | (LSLt ATFloat)   <- op+      , (lhs:rhs:_)      <- args = translateBinaryOp "<" lhs rhs+      | (LSLe ATFloat)   <- op+      , (lhs:rhs:_)      <- args = translateBinaryOp "<=" lhs rhs+      | (LSGt ATFloat)   <- op+      , (lhs:rhs:_)      <- args = translateBinaryOp ">" lhs rhs+      | (LSGe ATFloat)   <- op+      , (lhs:rhs:_)      <- args = translateBinaryOp ">=" lhs rhs++      | (LPlus (ATInt ITChar)) <- op+      , (lhs:rhs:_)            <- args =+          jsCall "i$fromCharCode" [+            JSBinOp "+" (+              jsCall "i$charCode" [translateReg lhs]+            ) (+              jsCall "i$charCode" [translateReg rhs]+            )+          ]++      | (LTrunc (ITFixed IT16) (ITFixed IT8)) <- op+      , (arg:_)                               <- args =+          jsPackUBits8 (+            JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFF))+          )++      | (LTrunc (ITFixed IT32) (ITFixed IT16)) <- op+      , (arg:_)                                <- args =+          jsPackUBits16 (+            JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFFFF))+          )++      | (LTrunc (ITFixed IT64) (ITFixed IT32)) <- op+      , (arg:_)                                <- args =+          jsPackUBits32 (+            jsMeth (jsMeth (translateReg arg) "and" [+              jsBigInt (JSString $ show 0xFFFFFFFF)+            ]) "intValue" []+          )++      | (LTrunc ITBig (ITFixed IT64)) <- op+      , (arg:_)                       <- args =+          jsMeth (translateReg arg) "and" [+            jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)+          ]++      | (LLSHR (ITFixed IT8)) <- op+      , (lhs:rhs:_)           <- args =+          jsPackUBits8 (+            JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)+          )++      | (LLSHR (ITFixed IT16)) <- op+      , (lhs:rhs:_)            <- args =+          jsPackUBits16 (+            JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)+          )++      | (LLSHR (ITFixed IT32)) <- op+      , (lhs:rhs:_)            <- args =+          jsPackUBits32  (+            JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)+          )++      | (LLSHR (ITFixed IT64)) <- op+      , (lhs:rhs:_)            <- args =+          jsMeth (translateReg lhs) "shiftRight" [translateReg rhs]++      | (LSHL (ITFixed IT8)) <- op+      , (lhs:rhs:_)          <- args =+          jsPackUBits8 (+            JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)+          )++      | (LSHL (ITFixed IT16)) <- op+      , (lhs:rhs:_)           <- args =+          jsPackUBits16 (+            JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)+          )++      | (LSHL (ITFixed IT32)) <- op+      , (lhs:rhs:_)           <- args =+          jsPackUBits32  (+            JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)+          )++      | (LSHL (ITFixed IT64)) <- op+      , (lhs:rhs:_)           <- args =+          jsMeth (jsMeth (translateReg lhs) "shiftLeft" [translateReg rhs]) "and" [+            jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)+          ]++      | (LAnd (ITFixed IT8)) <- op+      , (lhs:rhs:_)          <- args =+          jsPackUBits8 (+            JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LAnd (ITFixed IT16)) <- op+      , (lhs:rhs:_)           <- args =+          jsPackUBits16 (+            JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LAnd (ITFixed IT32)) <- op+      , (lhs:rhs:_)           <- args =+          jsPackUBits32 (+            JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LAnd (ITFixed IT64)) <- op+      , (lhs:rhs:_)           <- args =+          jsMeth (translateReg lhs) "and" [translateReg rhs]++      | (LOr (ITFixed IT8)) <- op+      , (lhs:rhs:_)         <- args =+          jsPackUBits8 (+            JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LOr (ITFixed IT16)) <- op+      , (lhs:rhs:_)          <- args =+          jsPackUBits16 (+            JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LOr (ITFixed IT32)) <- op+      , (lhs:rhs:_)          <- args =+          jsPackUBits32 (+            JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LOr (ITFixed IT64)) <- op+      , (lhs:rhs:_)          <- args =+          jsMeth (translateReg lhs) "or" [translateReg rhs]++      | (LXOr (ITFixed IT8)) <- op+      , (lhs:rhs:_)          <- args =+          jsPackUBits8 (+            JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LXOr (ITFixed IT16)) <- op+      , (lhs:rhs:_)           <- args =+          jsPackUBits16 (+            JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LXOr (ITFixed IT32)) <- op+      , (lhs:rhs:_)           <- args =+          jsPackUBits32 (+            JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LXOr (ITFixed IT64)) <- op+      , (lhs:rhs:_)           <- args =+          jsMeth (translateReg lhs) "xor" [translateReg rhs]++      | (LPlus (ATInt (ITFixed IT8))) <- op+      , (lhs:rhs:_)                   <- args =+          jsPackUBits8 (+            JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LPlus (ATInt (ITFixed IT16))) <- op+      , (lhs:rhs:_)                    <- args =+          jsPackUBits16 (+            JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LPlus (ATInt (ITFixed IT32))) <- op+      , (lhs:rhs:_)                    <- args =+          jsPackUBits32 (+            JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LPlus (ATInt (ITFixed IT64))) <- op+      , (lhs:rhs:_)                    <- args =+          jsMeth (jsMeth (translateReg lhs) "add" [translateReg rhs]) "and" [+            jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)+          ]++      | (LMinus (ATInt (ITFixed IT8))) <- op+      , (lhs:rhs:_)                    <- args =+          jsPackUBits8 (+            JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LMinus (ATInt (ITFixed IT16))) <- op+      , (lhs:rhs:_)                     <- args =+          jsPackUBits16 (+            JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LMinus (ATInt (ITFixed IT32))) <- op+      , (lhs:rhs:_)                     <- args =+          jsPackUBits32 (+            JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LMinus (ATInt (ITFixed IT64))) <- op+      , (lhs:rhs:_)                     <- args =+          jsMeth (jsMeth (translateReg lhs) "subtract" [translateReg rhs]) "and" [+            jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)+          ]++      | (LTimes (ATInt (ITFixed IT8))) <- op+      , (lhs:rhs:_)                    <- args =+          jsPackUBits8 (+            JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LTimes (ATInt (ITFixed IT16))) <- op+      , (lhs:rhs:_)                     <- args =+          jsPackUBits16 (+            JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LTimes (ATInt (ITFixed IT32))) <- op+      , (lhs:rhs:_)                     <- args =+          jsPackUBits32 (+            JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LTimes (ATInt (ITFixed IT64))) <- op+      , (lhs:rhs:_)                     <- args =+          jsMeth (jsMeth (translateReg lhs) "multiply" [translateReg rhs]) "and" [+            jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)+          ]++      | (LEq (ATInt (ITFixed IT8))) <- op+      , (lhs:rhs:_)                 <- args =+          jsPackUBits8 (+            JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LEq (ATInt (ITFixed IT16))) <- op+      , (lhs:rhs:_)                  <- args =+          jsPackUBits16 (+            JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LEq (ATInt (ITFixed IT32))) <- op+      , (lhs:rhs:_)                  <- args =+          jsPackUBits32 (+            JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LEq (ATInt (ITFixed IT64))) <- op+      , (lhs:rhs:_)                   <- args =+          jsMeth (jsMeth (translateReg lhs) "equals" [translateReg rhs]) "and" [+            jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)+          ]++      | (LLt (ITFixed IT8)) <- op+      , (lhs:rhs:_)         <- args =+          jsPackUBits8 (+            JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LLt (ITFixed IT16)) <- op+      , (lhs:rhs:_)          <- args =+          jsPackUBits16 (+            JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LLt (ITFixed IT32)) <- op+      , (lhs:rhs:_)          <- args =+          jsPackUBits32 (+            JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LLt (ITFixed IT64)) <- op+      , (lhs:rhs:_)          <- args = invokeMeth lhs "lesser" [rhs]++      | (LLe (ITFixed IT8)) <- op+      , (lhs:rhs:_)         <- args =+          jsPackUBits8 (+            JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LLe (ITFixed IT16)) <- op+      , (lhs:rhs:_)          <- args =+          jsPackUBits16 (+            JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LLe (ITFixed IT32)) <- op+      , (lhs:rhs:_)          <- args =+          jsPackUBits32 (+            JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LLe (ITFixed IT64)) <- op+      , (lhs:rhs:_)          <- args = invokeMeth lhs "lesserOrEquals" [rhs]++      | (LGt (ITFixed IT8)) <- op+      , (lhs:rhs:_)         <- args =+          jsPackUBits8 (+            JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LGt (ITFixed IT16)) <- op+      , (lhs:rhs:_)          <- args =+          jsPackUBits16 (+            JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )+      | (LGt (ITFixed IT32)) <- op+      , (lhs:rhs:_)          <- args =+          jsPackUBits32 (+            JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LGt (ITFixed IT64)) <- op+      , (lhs:rhs:_)          <- args = invokeMeth lhs "greater" [rhs]++      | (LGe (ITFixed IT8)) <- op+      , (lhs:rhs:_)         <- args =+          jsPackUBits8 (+            JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LGe (ITFixed IT16)) <- op+      , (lhs:rhs:_)          <- args =+          jsPackUBits16 (+            JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )+      | (LGe (ITFixed IT32)) <- op+      , (lhs:rhs:_)          <- args =+          jsPackUBits32 (+            JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LGe (ITFixed IT64)) <- op+      , (lhs:rhs:_)          <- args = invokeMeth lhs "greaterOrEquals" [rhs]++      | (LUDiv (ITFixed IT8)) <- op+      , (lhs:rhs:_)           <- args =+          jsPackUBits8 (+            JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LUDiv (ITFixed IT16)) <- op+      , (lhs:rhs:_)            <- args =+          jsPackUBits16 (+            JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LUDiv (ITFixed IT32)) <- op+      , (lhs:rhs:_)            <- args =+          jsPackUBits32 (+            JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))+          )++      | (LUDiv (ITFixed IT64)) <- op+      , (lhs:rhs:_)            <- args = invokeMeth lhs "divide" [rhs]++      | (LSDiv (ATInt (ITFixed IT8))) <- op+      , (lhs:rhs:_)                   <- args =+          jsPackSBits8 (+            JSBinOp "/" (+              jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)+            ) (+              jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)+            )+          )++      | (LSDiv (ATInt (ITFixed IT16))) <- op+      , (lhs:rhs:_)                    <- args =+          jsPackSBits16 (+            JSBinOp "/" (+              jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)+            ) (+              jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)+            )+          )++      | (LSDiv (ATInt (ITFixed IT32))) <- op+      , (lhs:rhs:_)                    <- args =+          jsPackSBits32 (+            JSBinOp "/" (+              jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)+            ) (+              jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)+            )+          )++      | (LSDiv (ATInt (ITFixed IT64))) <- op+      , (lhs:rhs:_)                    <- args = invokeMeth lhs "divide" [rhs]++      | (LSRem (ATInt (ITFixed IT8))) <- op+      , (lhs:rhs:_)                   <- args =+          jsPackSBits8 (+            JSBinOp "%" (+              jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)+            ) (+              jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)+            )+          )++      | (LSRem (ATInt (ITFixed IT16))) <- op+      , (lhs:rhs:_)                    <- args =+          jsPackSBits16 (+            JSBinOp "%" (+              jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)+            ) (+              jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)+            )+          )++      | (LSRem (ATInt (ITFixed IT32))) <- op+      , (lhs:rhs:_)                    <- args =+          jsPackSBits32 (+            JSBinOp "%" (+              jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)+            ) (+              jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)+            )+          )++      | (LSRem (ATInt (ITFixed IT64))) <- op+      , (lhs:rhs:_)                    <- args = invokeMeth lhs "mod" [rhs]++      | (LCompl (ITFixed IT8)) <- op+      , (arg:_)                <- args =+          jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)++      | (LCompl (ITFixed IT16)) <- op+      , (arg:_)                 <- args =+          jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)++      | (LCompl (ITFixed IT32)) <- op+      , (arg:_)                 <- args =+          jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)++      | (LCompl (ITFixed IT64)) <- op+      , (arg:_)     <- args =+          invokeMeth arg "not" []++      | (LPlus _)   <- op+      , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs+      | (LMinus _)  <- op+      , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs+      | (LTimes _)  <- op+      , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs+      | (LSDiv _)   <- op+      , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs+      | (LSRem _)   <- op+      , (lhs:rhs:_) <- args = translateBinaryOp "%" lhs rhs+      | (LEq _)     <- op+      , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs+      | (LSLt _)    <- op+      , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs+      | (LSLe _)    <- op+      , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs+      | (LSGt _)    <- op+      , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs+      | (LSGe _)    <- op+      , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs+      | (LAnd _)    <- op+      , (lhs:rhs:_) <- args = translateBinaryOp "&" lhs rhs+      | (LOr _)     <- op+      , (lhs:rhs:_) <- args = translateBinaryOp "|" lhs rhs+      | (LXOr _)    <- op+      , (lhs:rhs:_) <- args = translateBinaryOp "^" lhs rhs+      | (LSHL _)    <- op+      , (lhs:rhs:_) <- args = translateBinaryOp "<<" rhs lhs+      | (LASHR _)   <- op+      , (lhs:rhs:_) <- args = translateBinaryOp ">>" rhs lhs+      | (LCompl _)  <- op+      , (arg:_)     <- args = JSPreOp "~" (translateReg arg)++      | LStrConcat  <- op+      , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs+      | LStrEq      <- op+      , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs+      | LStrLt      <- op+      , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs+      | LStrLen     <- op+      , (arg:_)     <- args = JSProj (translateReg arg) "length"+      | (LStrInt ITNative)      <- op+      , (arg:_)                 <- args = jsCall "parseInt" [translateReg arg]+      | (LIntStr ITNative)      <- op+      , (arg:_)                 <- args = jsCall "String" [translateReg arg]+      | (LSExt ITNative ITBig)  <- op+      , (arg:_)                 <- args = jsBigInt $ jsCall "String" [translateReg arg]+      | (LTrunc ITBig ITNative) <- op+      , (arg:_)                 <- args = jsMeth (translateReg arg) "intValue" []+      | (LIntStr ITBig)         <- op+      , (arg:_)                 <- args = jsMeth (translateReg arg) "toString" []+      | (LStrInt ITBig)         <- op+      , (arg:_)                 <- args = jsBigInt $ translateReg arg+      | LFloatStr               <- op+      , (arg:_)                 <- args = jsCall "String" [translateReg arg]+      | LStrFloat               <- op+      , (arg:_)                 <- args = jsCall "parseFloat" [translateReg arg]+      | (LIntFloat ITNative)    <- op+      , (arg:_)                 <- args = translateReg arg+      | (LFloatInt ITNative)    <- op+      , (arg:_)                 <- args = translateReg arg+      | (LChInt ITNative)       <- op+      , (arg:_)                 <- args = jsCall "i$charCode" [translateReg arg]+      | (LIntCh ITNative)       <- op+      , (arg:_)                 <- args = jsCall "i$fromCharCode" [translateReg arg]++      | LFExp       <- op+      , (arg:_)     <- args = jsCall "Math.exp" [translateReg arg]+      | LFLog       <- op+      , (arg:_)     <- args = jsCall "Math.log" [translateReg arg]+      | LFSin       <- op+      , (arg:_)     <- args = jsCall "Math.sin" [translateReg arg]+      | LFCos       <- op+      , (arg:_)     <- args = jsCall "Math.cos" [translateReg arg]+      | LFTan       <- op+      , (arg:_)     <- args = jsCall "Math.tan" [translateReg arg]+      | LFASin      <- op+      , (arg:_)     <- args = jsCall "Math.asin" [translateReg arg]+      | LFACos      <- op+      , (arg:_)     <- args = jsCall "Math.acos" [translateReg arg]+      | LFATan      <- op+      , (arg:_)     <- args = jsCall "Math.atan" [translateReg arg]+      | LFSqrt      <- op+      , (arg:_)     <- args = jsCall "Math.sqrt" [translateReg arg]+      | LFFloor     <- op+      , (arg:_)     <- args = jsCall "Math.floor" [translateReg arg]+      | LFCeil      <- op+      , (arg:_)     <- args = jsCall "Math.ceil" [translateReg arg]++      | LStrCons    <- op+      , (lhs:rhs:_) <- args = invokeMeth lhs "concat" [rhs]+      | LStrHead    <- op+      , (arg:_)     <- args = JSIndex (translateReg arg) (JSNum (JSInt 0))+      | LStrRev     <- op+      , (arg:_)     <- args = JSProj (translateReg arg) "split('').reverse().join('')"+      | LStrIndex   <- op+      , (lhs:rhs:_) <- args = JSIndex (translateReg lhs) (translateReg rhs)+      | LStrTail    <- op+      , (arg:_)     <- args =+          let v = translateReg arg in+              JSApp (JSProj v "substr") [+                JSNum (JSInt 1),+                JSBinOp "-" (JSProj v "length") (JSNum (JSInt 1))+              ]++      | LSystemInfo <- op+      , (arg:_) <- args = jsCall "i$systemInfo"  [translateReg arg]+      | LNullPtr    <- op+      , (_)         <- args = JSNull+      | otherwise = JSError $ "Not implemented: " ++ show op+        where+          translateBinaryOp :: String -> Reg -> Reg -> JS+          translateBinaryOp op lhs rhs =+            JSBinOp op (translateReg lhs) (translateReg rhs)++          invokeMeth :: Reg -> String -> [Reg] -> JS+          invokeMeth obj meth args =+            JSApp (JSProj (translateReg obj) meth) $ map translateReg args+++jsRESERVE :: CompileInfo -> Int -> JS+jsRESERVE _ _ = JSNoop++jsSTACK :: JS+jsSTACK = JSIdent "i$valstack"++jsCALLSTACK :: JS+jsCALLSTACK = JSIdent "i$callstack"++jsSTACKBASE :: JS+jsSTACKBASE = JSIdent "i$valstack_base"++jsSTACKTOP :: JS+jsSTACKTOP = JSIdent "i$valstack_top"++jsOLDBASE :: JS+jsOLDBASE = JSIdent "oldbase"++jsMYOLDBASE :: JS+jsMYOLDBASE = JSIdent "myoldbase"++jsRET :: JS+jsRET = JSIdent "i$ret"++jsLOC :: Int -> JS+jsLOC 0 = JSIndex jsSTACK jsSTACKBASE+jsLOC n = JSIndex jsSTACK (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))++jsTOP :: Int -> JS+jsTOP 0 = JSIndex jsSTACK jsSTACKTOP+jsTOP n = JSIndex jsSTACK (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))++jsPUSH :: [JS] -> JS+jsPUSH args = JSApp (JSProj jsCALLSTACK "push") args++jsPOP :: JS+jsPOP = JSApp (JSProj jsCALLSTACK "pop") []++translateBC :: CompileInfo -> BC -> JS+translateBC info bc+  | ASSIGN r1 r2          <- bc = jsASSIGN info r1 r2+  | ASSIGNCONST r c       <- bc = jsASSIGNCONST info r c+  | UPDATE r1 r2          <- bc = jsASSIGN info r1 r2+  | ADDTOP n              <- bc = jsADDTOP info n+  | NULL r                <- bc = jsNULL info r+  | CALL n                <- bc = jsCALL info n+  | TAILCALL n            <- bc = jsTAILCALL info n+  | FOREIGNCALL r _ _ n a <- bc = jsFOREIGN info r n a+  | TOPBASE n             <- bc = jsTOPBASE info n+  | BASETOP n             <- bc = jsBASETOP info n+  | STOREOLD              <- bc = jsSTOREOLD info+  | SLIDE n               <- bc = jsSLIDE info n+  | REBASE                <- bc = jsREBASE info+  | RESERVE n             <- bc = jsRESERVE info n+  | MKCON r t rs          <- bc = jsMKCON info r t rs+  | CASE s r c d          <- bc = jsCASE info s r c d+  | CONSTCASE r c d       <- bc = jsCONSTCASE info r c d+  | PROJECT r l a         <- bc = jsPROJECT info r l a+  | OP r o a              <- bc = jsOP info r o a+  | ERROR e               <- bc = jsERROR info e+  | otherwise                   = JSRaw $ "//" ++ show bc+
src/IRTS/CodegenLLVM.hs view
@@ -9,7 +9,6 @@ import Idris.Core.TT (ArithTy(..), IntTy(..), NativeTy(..), nativeTyWidth)  import Util.System-import Paths_idris  import LLVM.General.Context import LLVM.General.Diagnostic
src/IRTS/Compiler.hs view
@@ -47,8 +47,6 @@ import System.Environment import System.FilePath ((</>), addTrailingPathSeparator) -import Paths_idris- compile :: Codegen -> FilePath -> Term -> Idris () compile codegen f tm    = do checkMVs  -- check for undefined metavariables@@ -299,7 +297,7 @@         -- hence it takes a lambda: \unerased_argname_list -> resulting_LExp.         let padLams = padLambdas used (length args) arity -        case compare arity (length args) of+        case compare (length args) arity of              -- overapplied             GT  -> ifail ("overapplied data constructor: " ++ show tm)@@ -488,6 +486,7 @@ irSC :: Vars -> SC -> Idris LExp irSC vs (STerm t) = irTerm vs [] t irSC vs (UnmatchedCase str) = return $ LError str+ irSC vs (ProjCase tm alts) = do     tm'   <- irTerm vs [] tm     alts' <- mapM (irAlt vs tm') alts@@ -496,8 +495,9 @@ -- Transform matching on Delay to applications of Force. irSC vs (Case n [ConCase (UN delay) i [_, _, n'] sc])     | delay == txt "Delay"-    = irSC vs $ mkForce n n' sc-+    = do sc' <- irSC vs $ mkForce n' n sc+         return $ LLet n' (LForce (LV (Glob n))) sc'+     -- There are two transformations in this case: -- --  1. Newtype-case elimination:
src/IRTS/Java/JTypes.hs view
@@ -33,6 +33,9 @@ array :: J.Type -> J.Type array t = RefType . ArrayType $ t +addressType :: J.Type+addressType = longType+ ----------------------------------------------------------------------- -- Boxed types @@ -48,6 +51,10 @@ stringType =   RefType . ClassRefType $ ClassType [(Ident "String", [])] +bufferType :: J.Type+bufferType =+  RefType . ClassRefType $ ClassType [(Ident "ByteBuffer", [])]+ threadType :: J.Type threadType =   RefType . ClassRefType $ ClassType [(Ident "Thread", [])]@@ -132,6 +139,9 @@ runtimeExceptionType =   RefType . ClassRefType $ ClassType [(Ident "RuntimeException", [])] +-----------------------------------------------------------------------+-- Integer types+ nativeTyToJType :: NativeTy -> J.Type nativeTyToJType IT8  = byteType nativeTyToJType IT16 = shortType@@ -219,6 +229,7 @@   | (LFloatInt to) <- x = "LFloatInt" ++ (suffixFor to)   | (LStrInt to)   <- x = "LStrInt" ++ (suffixFor to)   | (LChInt to)    <- x = "LChInt" ++ (suffixFor to)+  | (LPeek to _)   <- x = "LPeek" ++ (suffixFor to)   | otherwise = takeWhile ((/=) ' ') $ show x   where     suffixFor (ITFixed nt) = show nt@@ -291,10 +302,30 @@ sourceTypes (LStdIn) = [] sourceTypes (LStdOut) = [] sourceTypes (LStdErr) = []+sourceTypes (LAllocate) = [addressType]+sourceTypes (LAppendBuffer) =+  [bufferType, addressType, addressType, addressType, addressType, bufferType]+sourceTypes (LSystemInfo) = [integerType]+sourceTypes (LAppend nt _) = [bufferType, addressType, addressType, intTyToJType nt]+sourceTypes (LPeek _ _) = [bufferType, addressType] sourceTypes (LFork) = [objectType] sourceTypes (LPar) = [objectType] sourceTypes (LVMPtr) = [] sourceTypes (LNullPtr) = [objectType] sourceTypes (LNoOp) = repeat objectType +-----------------------------------------------------------------------+-- Endianess markers +endiannessConstant :: Endianness -> Exp+endiannessConstant c =+  ExpName . Name . map Ident $ ["java", "nio", "ByteOrder", endiannessConstant' c]+  where+    endiannessConstant' BE                 = "BIG_ENDIAN"+    endiannessConstant' LE                 = "LITTLE_ENDIAN"+    endiannessConstant' (IRTS.Lang.Native) = endiannessConstant' BE++endiannessArguments :: PrimFn -> [Exp]+endiannessArguments (LAppend _ end) = [endiannessConstant end]+endiannessArguments (LPeek _ end)   = [endiannessConstant end]+endiannessArguments _               = []
src/IRTS/Java/Pom.hs view
@@ -3,6 +3,9 @@ import Data.List (unfoldr) import Text.XML.Light +-----------------------------------------------------------------------+-- String <-> XML processing+ uattr :: String -> String -> Attr uattr k v = Attr (QName k Nothing Nothing) v @@ -31,6 +34,9 @@ pomString :: String -> String -> [String] -> String pomString c a d = ppElement $ pom c a d +-----------------------------------------------------------------------+-- The pom template for idris projects+ pom :: String -> String -> [String] -> Element pom clsName artifactName dependencies = unode "project" ([     uattr "xmlns" "http://maven.apache.org/POM/4.0.0",@@ -49,7 +55,7 @@       unode "skipTest" "true"     ],     unode "dependencies" (-      dependency "org.idris-lang" "idris" "0.9.10-alpha-2" :+      dependency "org.idris-lang" "idris" "0.9.14" :       map parseToDep dependencies     ),     unode "build" [
+ src/IRTS/JavaScript/AST.hs view
@@ -0,0 +1,397 @@+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE OverloadedStrings #-}+module IRTS.JavaScript.AST where++import Data.Word+import Data.Char (isDigit)++import qualified Data.Text as T++data JSType = JSIntTy+            | JSStringTy+            | JSIntegerTy+            | JSFloatTy+            | JSCharTy+            | JSPtrTy+            | JSForgotTy+            deriving Eq+++data JSInteger = JSBigZero+               | JSBigOne+               | JSBigInt Integer+               | JSBigIntExpr JS+               deriving Eq+++data JSNum = JSInt Int+           | JSFloat Double+           | JSInteger JSInteger+           deriving Eq+++data JSWord = JSWord8 Word8+            | JSWord16 Word16+            | JSWord32 Word32+            | JSWord64 Word64+            deriving Eq+++data JSAnnotation = JSConstructor deriving Eq+++instance Show JSAnnotation where+  show JSConstructor = "constructor"+++data JS = JSRaw String+        | JSIdent String+        | JSFunction [String] JS+        | JSType JSType+        | JSSeq [JS]+        | JSReturn JS+        | JSApp JS [JS]+        | JSNew String [JS]+        | JSError String+        | JSBinOp String JS JS+        | JSPreOp String JS+        | JSPostOp String JS+        | JSProj JS String+        | JSNull+        | JSUndefined+        | JSThis+        | JSTrue+        | JSFalse+        | JSArray [JS]+        | JSString String+        | JSNum JSNum+        | JSWord JSWord+        | JSAssign JS JS+        | JSAlloc String (Maybe JS)+        | JSIndex JS JS+        | JSSwitch JS [(JS, JS)] (Maybe JS)+        | JSCond [(JS, JS)]+        | JSTernary JS JS JS+        | JSParens JS+        | JSWhile JS JS+        | JSFFI String [JS]+        | JSAnnotation JSAnnotation JS+        | JSNoop+        deriving Eq+++data FFI = FFICode Char | FFIArg Int | FFIError String++ffi :: String -> [String] -> T.Text+ffi code args = let parsed = ffiParse code in+                    case ffiError parsed of+                         Just err -> error err+                         Nothing  -> renderFFI parsed args+  where+    ffiParse :: String -> [FFI]+    ffiParse ""           = []+    ffiParse ['%']        = [FFIError $ "FFI - Invalid positional argument"]+    ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss+    ffiParse ('%':s:ss)+      | isDigit s =+         FFIArg (+           read $ s : takeWhile isDigit ss+          ) : ffiParse (dropWhile isDigit ss)+      | otherwise =+          [FFIError "FFI - Invalid positional argument"]+    ffiParse (s:ss) = FFICode s : ffiParse ss+++    ffiError :: [FFI] -> Maybe String+    ffiError []                 = Nothing+    ffiError ((FFIError s):xs)  = Just s+    ffiError (x:xs)             = ffiError xs+++    renderFFI :: [FFI] -> [String] -> T.Text+    renderFFI [] _ = ""+    renderFFI (FFICode c : fs) args = c `T.cons` renderFFI fs args+    renderFFI (FFIArg i : fs) args+      | i < length args && i >= 0 =+            T.pack (args !! i)+          `T.append` renderFFI fs args+      | otherwise = error "FFI - Argument index out of bounds"++compileJS :: JS -> T.Text+compileJS = compileJS' 0++compileJS' :: Int -> JS -> T.Text+compileJS' indent JSNoop = ""++compileJS' indent (JSAnnotation annotation js) =+    "/** @"+  `T.append` T.pack (show annotation)+  `T.append` " */\n"+  `T.append` compileJS' indent js++compileJS' indent (JSFFI raw args) =+  ffi raw (map (T.unpack . compileJS' indent) args)++compileJS' indent (JSRaw code) =+  T.pack code++compileJS' indent (JSIdent ident) =+  T.pack ident++compileJS' indent (JSFunction args body) =+      T.replicate indent " " `T.append` "function("+   `T.append` T.intercalate "," (map T.pack args)+   `T.append` "){\n"+   `T.append` compileJS' (indent + 2) body+   `T.append` "\n}\n"++compileJS' indent (JSType ty)+  | JSIntTy     <- ty = "i$Int"+  | JSStringTy  <- ty = "i$String"+  | JSIntegerTy <- ty = "i$Integer"+  | JSFloatTy   <- ty = "i$Float"+  | JSCharTy    <- ty = "i$Char"+  | JSPtrTy     <- ty = "i$Ptr"+  | JSForgotTy  <- ty = "i$Forgot"++compileJS' indent (JSSeq seq) =+  T.intercalate ";\n" (+    map (+      (T.replicate indent " " `T.append`) . (compileJS' indent)+    ) $ filter (/= JSNoop) seq+  ) `T.append` ";"++compileJS' indent (JSReturn val) =+  "return " `T.append` compileJS' indent val++compileJS' indent (JSApp lhs rhs)+  | JSFunction {} <- lhs =+    T.concat ["(", compileJS' indent lhs, ")(", args, ")"]+  | otherwise =+    T.concat [compileJS' indent lhs, "(", args, ")"]+  where args :: T.Text+        args = T.intercalate "," $ map (compileJS' 0) rhs++compileJS' indent (JSNew name args) =+    "new "+  `T.append` T.pack name+  `T.append` "("+  `T.append` T.intercalate "," (map (compileJS' 0) args)+  `T.append` ")"++compileJS' indent (JSError exc) =+  "(function(){throw new Error(\"" `T.append` T.pack exc `T.append` "\")})()"++compileJS' indent (JSBinOp op lhs rhs) =+    compileJS' indent lhs+  `T.append` " "+  `T.append` T.pack op+  `T.append` " "+  `T.append` compileJS' indent rhs++compileJS' indent (JSPreOp op val) =+  T.pack op `T.append` compileJS' indent val++compileJS' indent (JSProj obj field)+  | JSFunction {} <- obj =+    T.concat ["(", compileJS' indent obj, ").", T.pack field]+  | JSAssign {} <- obj =+    T.concat ["(", compileJS' indent obj, ").", T.pack field]+  | otherwise =+    compileJS' indent obj `T.append` ('.' `T.cons` T.pack field)++compileJS' indent JSNull =+  "null"++compileJS' indent JSUndefined =+  "undefined"++compileJS' indent JSThis =+  "this"++compileJS' indent JSTrue =+  "true"++compileJS' indent JSFalse =+  "false"++compileJS' indent (JSArray elems) =+  "[" `T.append` T.intercalate "," (map (compileJS' 0) elems) `T.append` "]"++compileJS' indent (JSString str) =+  "\"" `T.append` T.pack str `T.append` "\""++compileJS' indent (JSNum num)+  | JSInt i                    <- num = T.pack (show i)+  | JSFloat f                  <- num = T.pack (show f)+  | JSInteger JSBigZero        <- num = T.pack "i$ZERO"+  | JSInteger JSBigOne         <- num = T.pack "i$ONE"+  | JSInteger (JSBigInt i)     <- num = T.pack (show i)+  | JSInteger (JSBigIntExpr e) <- num =+      "i$bigInt(" `T.append` compileJS' indent e `T.append` ")"++compileJS' indent (JSAssign lhs rhs) =+  compileJS' indent lhs `T.append` " = " `T.append` compileJS' indent rhs++compileJS' 0 (JSAlloc name (Just val@(JSNew _ _))) =+    "var "+  `T.append` T.pack name+  `T.append` " = "+  `T.append` compileJS' 0 val+  `T.append` ";\n"++compileJS' indent (JSAlloc name val) =+    "var "+  `T.append` T.pack name+  `T.append` maybe "" ((" = " `T.append`) . compileJS' indent) val++compileJS' indent (JSIndex lhs rhs) =+    compileJS' indent lhs+  `T.append` "["+  `T.append` compileJS' indent rhs+  `T.append` "]"++compileJS' indent (JSCond branches) =+  T.intercalate " else " $ map createIfBlock branches+  where+    createIfBlock (JSNoop, e@(JSSeq _)) =+         "{\n"+      `T.append` compileJS' (indent + 2) e+      `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"+    createIfBlock (JSNoop, e) =+         "{\n"+      `T.append` compileJS' (indent + 2) e+      `T.append` ";\n" `T.append` T.replicate indent " " `T.append` "}"+    createIfBlock (cond, e@(JSSeq _)) =+         "if (" `T.append` compileJS' indent cond `T.append`") {\n"+      `T.append` compileJS' (indent + 2) e+      `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"+    createIfBlock (cond, e) =+         "if (" `T.append` compileJS' indent cond `T.append`") {\n"+      `T.append` T.replicate (indent + 2) " "+      `T.append` compileJS' (indent + 2) e+      `T.append` ";\n"+      `T.append` T.replicate indent " "+      `T.append` "}"++compileJS' indent (JSSwitch val [(_,JSSeq seq)] Nothing) =+  let (h,t) = splitAt 1 seq in+         (T.concat (map (compileJS' indent) h) `T.append` ";\n")+      `T.append` (+        T.intercalate ";\n" $ map (+          (T.replicate indent " " `T.append`) . compileJS' indent+        ) t+      )++compileJS' indent (JSSwitch val branches def) =+     "switch(" `T.append` compileJS' indent val `T.append` "){\n"+  `T.append` T.concat (map mkBranch branches)+  `T.append` mkDefault def+  `T.append` T.replicate indent " " `T.append` "}"+  where+    mkBranch :: (JS, JS) -> T.Text+    mkBranch (tag, code) =+         T.replicate (indent + 2) " "+      `T.append` "case "+      `T.append` compileJS' indent tag+      `T.append` ":\n"+      `T.append` compileJS' (indent + 4) code+      `T.append` "\n"+      `T.append` (T.replicate (indent + 4) " " `T.append` "break;\n")++    mkDefault :: Maybe JS -> T.Text+    mkDefault Nothing = ""+    mkDefault (Just def) =+         T.replicate (indent + 2) " " `T.append` "default:\n"+      `T.append` compileJS' (indent + 4)def+      `T.append` "\n"+++compileJS' indent (JSTernary cond true false) =+  let c = compileJS' indent cond+      t = compileJS' indent true+      f = compileJS' indent false in+        "("+      `T.append` c+      `T.append` ")?("+      `T.append` t+      `T.append` "):("+      `T.append` f+      `T.append` ")"++compileJS' indent (JSParens js) =+  "(" `T.append` compileJS' indent js `T.append` ")"++compileJS' indent (JSWhile cond body) =+     "while (" `T.append` compileJS' indent cond `T.append` ") {\n"+  `T.append` compileJS' (indent + 2) body+  `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"++compileJS' indent (JSWord word)+  | JSWord8  b <- word =+      "new Uint8Array([" `T.append` T.pack (show b) `T.append` "])"+  | JSWord16 b <- word =+      "new Uint16Array([" `T.append` T.pack (show b) `T.append` "])"+  | JSWord32 b <- word =+      "new Uint32Array([" `T.append` T.pack (show b) `T.append` "])"+  | JSWord64 b <- word =+      "i$bigInt(\"" `T.append` T.pack (show b) `T.append` "\")"++jsInstanceOf :: JS -> String -> JS+jsInstanceOf obj cls = JSBinOp "instanceof" obj (JSIdent cls)++jsOr :: JS -> JS -> JS+jsOr lhs rhs = JSBinOp "||" lhs rhs++jsAnd :: JS -> JS -> JS+jsAnd lhs rhs = JSBinOp "&&" lhs rhs++jsMeth :: JS -> String -> [JS] -> JS+jsMeth obj meth args = JSApp (JSProj obj meth) args++jsCall :: String -> [JS] -> JS+jsCall fun args = JSApp (JSIdent fun) args++jsTypeOf :: JS -> JS+jsTypeOf js = JSPreOp "typeof " js++jsEq :: JS -> JS -> JS+jsEq lhs@(JSNum (JSInteger _)) rhs = JSApp (JSProj lhs "equals") [rhs]+jsEq lhs rhs@(JSNum (JSInteger _)) = JSApp (JSProj lhs "equals") [rhs]+jsEq lhs rhs = JSBinOp "==" lhs rhs++jsNotEq :: JS -> JS -> JS+jsNotEq lhs rhs = JSBinOp "!=" lhs rhs++jsIsNumber :: JS -> JS+jsIsNumber js = (jsTypeOf js) `jsEq` (JSString "number")++jsIsNull :: JS -> JS+jsIsNull js = JSBinOp "==" js JSNull++jsBigInt :: JS -> JS+jsBigInt (JSString "0") = JSNum (JSInteger JSBigZero)+jsBigInt (JSString "1") = JSNum (JSInteger JSBigOne)+jsBigInt js             = JSNum $ JSInteger $ JSBigIntExpr js++jsUnPackBits :: JS -> JS+jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)++jsPackUBits8 :: JS -> JS+jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]++jsPackUBits16 :: JS -> JS+jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]++jsPackUBits32 :: JS -> JS+jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]++jsPackSBits8 :: JS -> JS+jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]++jsPackSBits16 :: JS -> JS+jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]++jsPackSBits32 :: JS -> JS+jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]+
src/IRTS/System.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-}-module IRTS.System(getTargetDir,getCC,getLibFlags,getIdrisLibDir,-                   getIncFlags,getMvn,getExecutablePom) where+module IRTS.System(getDataFileName, getDataDir, getTargetDir,getCC,getLibFlags,getIdrisLibDir,+                   getIncFlags,getMvn,getExecutablePom, version) where  import Util.System @@ -9,7 +9,12 @@ import System.FilePath ((</>), addTrailingPathSeparator) import System.Environment +#ifdef FREESTANDING+import Target_idris+import Paths_idris (version)+#else import Paths_idris+#endif  getCC :: IO String getCC = fromMaybe "gcc" <$> environment "IDRIS_CC"
src/Idris/AbsSyntax.hs view
@@ -14,8 +14,6 @@ import IRTS.CodegenCommon import Util.DynamicLinker -import Paths_idris- import System.Console.Haskeline import System.IO @@ -484,7 +482,10 @@        i <- getIState        putIState $ i { idris_metavars = map (\(n, (i, top, _, isTopLevel)) -> (n, (top, i, isTopLevel))) ns ++                                             idris_metavars i }-  where tidyNames used (Bind (MN i x) b sc)+  where +        -- 'tidyNames' is to generate user accessible names in case they are+        -- needed in tactic scripts+        tidyNames used (Bind (MN i x) b sc)             = let n' = uniqueName (UN x) used in                   Bind n' b $ tidyNames (n':used) sc         tidyNames used (Bind n b sc)@@ -855,7 +856,7 @@        | n `elem` (map fst ps ++ ns) && t /= Placeholder            = let n' = mkShadow n in                  PDPair f p (PRef f' n') (en t) (en (shadow n n' r))-    en (PEq f l r) = PEq f (en l) (en r)+    en (PEq f lt rt l r) = PEq f (en lt) (en rt) (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 p l r) = PPair f p (en l) (en r)@@ -1024,7 +1025,7 @@     pri (PTrue _ _) = 0     pri (PFalse _) = 0     pri (PRefl _ _) = 1-    pri (PEq _ l r) = max 1 (max (pri l) (pri r))+    pri (PEq _ _ _ 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 (PAppBind _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.getTm) as)))@@ -1080,6 +1081,16 @@  -- Dealing with implicit arguments +-- Add some bound implicits to the using block if they aren't there already++addToUsing :: [Using] -> [(Name, PTerm)] -> [Using]+addToUsing us [] = us+addToUsing us ((n, t) : ns)+   | n `notElem` mapMaybe impName us = addToUsing (us ++ [UImplicit n t]) ns+   | otherwise = addToUsing us ns+  where impName (UImplicit n _) = Just n+        impName _ = Nothing+ -- Add constraint bindings from using block  addUsingConstraints :: SyntaxInfo -> FC -> PTerm -> Idris PTerm@@ -1088,8 +1099,6 @@         let ns = namesIn [] ist t         let cs = getConstraints t -- check declared constraints         let addconsts = uconsts \\ cs-        -- if all names in the arguments of addconsts appear in ns,-        -- add the constraint implicitly         return (doAdd addconsts ns t)    where uconsts = filter uconst (using syn)          uconst (UConstraint _ _) = True@@ -1119,11 +1128,72 @@          getName (PExp _ _ _ (PRef _ n)) = return n          getName _ = [] +-- Add implicit bindings from using block, and bind any missing names+addUsingImpls :: SyntaxInfo -> Name -> FC -> PTerm -> Idris PTerm+addUsingImpls syn n fc t+   = do ist <- getIState+        let ns = implicitNamesIn (map iname uimpls) ist t+        let badnames = filter (\n -> not (implicitable n) &&+                                     n `notElem` (map iname uimpls)) ns+        when (not (null badnames)) $ +           throwError (At fc (Elaborating "type of " n +                         (NoSuchVariable (head badnames))))+        let cs = getArgnames t -- get already bound names +        let addimpls = filter (\n -> iname n `notElem` cs) uimpls +        -- if all names in the arguments of addconsts appear in ns,+        -- add the constraint implicitly+        return (bindFree ns (doAdd addimpls ns t))+   where uimpls = filter uimpl (using syn)+         uimpl (UImplicit _ _) = True+         uimpl _ = False++         iname (UImplicit n _) = n+         iname (UConstraint _ _) = error "Can't happen addUsingImpls"++         doAdd [] _ t = t+         -- if all of args in ns, then add it+         doAdd (UImplicit n ty : cs) ns t+             | elem n ns+                   = PPi (Imp [] Dynamic False) n ty (doAdd cs ns t)+             | otherwise = doAdd cs ns t++         -- bind the free names which weren't in the using block+         bindFree [] tm = tm+         bindFree (n:ns) tm +             | elem n (map iname uimpls) = bindFree ns tm+             | otherwise +                    = PPi (Imp [] Dynamic False) n Placeholder (bindFree ns tm)++         getArgnames (PPi _ n c sc)+             = n : getArgnames sc+         getArgnames _ = []++-- Given the original type and the elaborated type, return the implicitness+-- status of each pi-bound argument, and whether it's inaccessible (True) or not.++getUnboundImplicits :: IState -> Type -> PTerm -> [(Bool, PArg)]+getUnboundImplicits i (Bind n (Pi t) sc) (PPi p n' t' sc')+     | n == n' = argInfo n p : getUnboundImplicits i sc sc'+  where+    argInfo n (Imp opt _ _) = (True, PImp (getPriority i t') True opt n t')+    argInfo n (Exp opt _ _) = (InaccessibleArg `elem` opt,+                                  PExp (getPriority i t') opt n t')+    argInfo n (Constraint opt _) = (InaccessibleArg `elem` opt,+                                      PConstraint 10 opt n t')+    argInfo n (TacImp opt _ scr) = (InaccessibleArg `elem` opt,+                                      PTacImplicit 10 opt n scr t')+getUnboundImplicits i (Bind n (Pi t) sc) tm+     = impBind n t : getUnboundImplicits i sc tm+  where+    impBind n t = (True, PImp 1 True [] n Placeholder)+getUnboundImplicits i sc tm = []+ -- Add implicit Pi bindings for any names in the term which appear in an -- argument position.  -- This has become a right mess already. Better redo it some time...-+-- TODO: This is obsoleted by the new way of elaborating types, but there's still+-- a couple of places which use it. Clean them up! implicit :: ElabInfo -> SyntaxInfo -> Name -> PTerm -> Idris PTerm implicit info syn n ptm = implicit' info syn [] n ptm @@ -1220,7 +1290,7 @@              put (PTacImplicit 10 l n scr Placeholder : decls,                   nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))              imps True (n:env) sc-    imps top env (PEq _ l r)+    imps top env (PEq _ _ _ 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)))))@@ -1272,6 +1342,7 @@ addImplBoundInf :: IState -> [Name] -> [Name] -> PTerm -> PTerm addImplBoundInf ist ns inf = addImpl' False ns inf ist +-- | Add the implicit arguments to applications in the term addImpl :: IState -> PTerm -> PTerm addImpl = addImpl' False [] [] @@ -1279,86 +1350,92 @@ -- and *not* inside a PHidden  addImpl' :: Bool -> [Name] -> [Name] -> IState -> PTerm -> PTerm-addImpl' inpat env infns ist ptm -         = mkUniqueNames env (ai (zip env (repeat Nothing)) [] ptm)+addImpl' inpat env infns ist ptm+         = mkUniqueNames env (ai False (zip env (repeat Nothing)) [] ptm)   where-    ai env ds (PRef fc f)+    ai :: Bool -> [(Name, Maybe PTerm)] -> [[T.Text]] -> PTerm -> PTerm+    ai qq env ds (PRef fc f)         | f `elem` infns = PInferRef fc f-        | not (f `elem` map fst env) = handleErr $ aiFn inpat inpat ist fc f ds []-    ai env ds (PHidden (PRef fc f))-        | not (f `elem` map fst env) = handleErr $ aiFn inpat False ist fc f ds []-    ai env ds (PEq fc l r)   -      = let l' = ai env ds l-            r' = ai env ds r in-            PEq fc l' r'-    ai env ds (PRewrite fc l r g)   -       = let l' = ai env ds l-             r' = ai env ds r-             g' = fmap (ai env ds) g in+        | not (f `elem` map fst env) = handleErr $ aiFn inpat inpat qq ist fc f ds []+    ai qq env ds (PHidden (PRef fc f))+        | not (f `elem` map fst env) = handleErr $ aiFn inpat False qq ist fc f ds []+    ai qq env ds (PEq fc lt rt l r)+      = let lt' = ai qq env ds lt+            rt' = ai qq env ds rt+            l' = ai qq env ds l+            r' = ai qq env ds r in+            PEq fc lt' rt' l' r'+    ai qq env ds (PRewrite fc l r g)+       = let l' = ai qq env ds l+             r' = ai qq env ds r+             g' = fmap (ai qq env ds) g in          PRewrite fc l' r' g'-    ai env ds (PTyped l r) -      = let l' = ai env ds l-            r' = ai env ds r in+    ai qq env ds (PTyped l r)+      = let l' = ai qq env ds l+            r' = ai qq env ds r in             PTyped l' r'-    ai env ds (PPair fc p l r) -      = let l' = ai env ds l-            r' = ai env ds r in+    ai qq env ds (PPair fc p l r)+      = let l' = ai qq env ds l+            r' = ai qq env ds r in             PPair fc p l' r'-    ai env ds (PDPair fc p l t r)-         = let l' = ai env ds l-               t' = ai env ds t-               r' = ai env ds r in+    ai qq env ds (PDPair fc p l t r)+         = let l' = ai qq env ds l+               t' = ai qq env ds t+               r' = ai qq env ds r in            PDPair fc p l' t' r'-    ai env ds (PAlternative a as) -           = let as' = map (ai env ds) as in+    ai qq env ds (PAlternative a as)+           = let as' = map (ai qq env ds) as in                  PAlternative a as'-    ai env _ (PDisamb ds' as) = ai env ds' as-    ai env ds (PApp fc (PInferRef _ f) as)-        = let as' = map (fmap (ai env ds)) as in+    ai qq env _ (PDisamb ds' as) = ai qq env ds' as+    ai qq env ds (PApp fc (PInferRef _ f) as)+        = let as' = map (fmap (ai qq env ds)) as in               PApp fc (PInferRef fc f) as'-    ai env ds (PApp fc ftm@(PRef _ f) as)-        | f `elem` infns = ai env ds (PApp fc (PInferRef fc f) as)+    ai qq env ds (PApp fc ftm@(PRef _ f) as)+        | f `elem` infns = ai qq env ds (PApp fc (PInferRef fc f) as)         | not (f `elem` map fst env)-                          = let as' = map (fmap (ai env ds)) as in-                                handleErr $ aiFn inpat False ist fc f ds as'+                          = let as' = map (fmap (ai qq env ds)) as in+                                handleErr $ aiFn inpat False qq ist fc f ds as'         | Just (Just ty) <- lookup f env =-             let as' = map (fmap (ai env ds)) as+             let as' = map (fmap (ai qq env ds)) as                  arity = getPArity ty in               mkPApp fc arity ftm as'-    ai env ds (PApp fc f as) -      = let f' = ai env ds f-            as' = map (fmap (ai env ds)) as in-         mkPApp fc 1 f' as'-    ai env ds (PCase fc c os) -      = let c' = ai env ds c in+    ai qq env ds (PApp fc f as)+      = let f' = ai qq env ds f+            as' = map (fmap (ai qq env ds)) as in+            mkPApp fc 1 f' as'+    ai qq env ds (PCase fc c os)+      = let c' = ai qq env ds c in         -- leave os alone, because they get lifted into a new pattern match         -- definition which is passed through addImpl again with more scope         -- information             PCase fc c' os-    ai env ds (PLam n ty sc) -      = let ty' = ai env ds ty-            sc' = ai ((n, Just ty):env) ds sc in+    ai qq env ds (PLam n ty sc)+      = let ty' = ai qq env ds ty+            sc' = ai qq ((n, Just ty):env) ds sc in             PLam n ty' sc'-    ai env ds (PLet n ty val sc)-      = let ty' = ai env ds ty-            val' = ai env ds val-            sc' = ai ((n, Just ty):env) ds sc in+    ai qq env ds (PLet n ty val sc)+      = let ty' = ai qq env ds ty+            val' = ai qq env ds val+            sc' = ai qq ((n, Just ty):env) ds sc in             PLet n ty' val' sc'-    ai env ds (PPi p n ty sc) -      = let ty' = ai env ds ty-            sc' = ai ((n, Just ty):env) ds sc in+    ai qq env ds (PPi p n ty sc)+      = let ty' = ai qq env ds ty+            sc' = ai qq ((n, Just ty):env) ds sc in             PPi p n ty' sc'-    ai env ds (PGoal fc r n sc) -      = let r' = ai env ds r-            sc' = ai ((n, Nothing):env) ds sc in+    ai qq env ds (PGoal fc r n sc)+      = let r' = ai qq env ds r+            sc' = ai qq ((n, Nothing):env) ds sc in             PGoal fc r' n sc'-    ai env ds (PHidden tm) = PHidden (ai env ds tm)-    ai env ds (PProof ts) = PProof (map (fmap (ai env ds)) ts)-    ai env ds (PTactics ts) = PTactics (map (fmap (ai env ds)) ts)-    ai env ds (PRefl fc tm) = PRefl fc (ai env ds tm)-    ai env ds (PUnifyLog tm) = PUnifyLog (ai env ds tm)-    ai env ds (PNoImplicits tm) = PNoImplicits (ai env ds tm)-    ai env ds tm = tm+    ai qq env ds (PHidden tm) = PHidden (ai qq env ds tm)+    -- Don't do PProof or PTactics since implicits get added when scope is+    -- properly known in ElabTerm.runTac+    ai qq env ds (PRefl fc tm) = PRefl fc (ai qq env ds tm)+    ai qq env ds (PUnifyLog tm) = PUnifyLog (ai qq env ds tm)+    ai qq env ds (PNoImplicits tm) = PNoImplicits (ai qq env ds tm)+    ai qq env ds (PQuasiquote tm g) = PQuasiquote (ai True env ds tm)+                                                  (fmap (ai True env ds) g)+    ai qq env ds (PUnquote tm) = PUnquote (ai False env ds tm)+    ai qq env ds tm = tm      handleErr (Left err) = PElabError err     handleErr (Right x) = x@@ -1366,8 +1443,8 @@ -- if in a pattern, and there are no arguments, and there's no possible -- names with zero explicit arguments, don't add implicits. -aiFn :: Bool -> Bool -> IState -> FC -> Name -> [[T.Text]] -> [PArg] -> Either Err PTerm-aiFn inpat True ist fc f ds []+aiFn :: Bool -> Bool -> Bool -> IState -> FC -> Name -> [[T.Text]] -> [PArg] -> Either Err PTerm+aiFn inpat True qq ist fc f ds []   = case lookupDef f (tt_ctxt ist) of         [] -> Right $ PPatvar fc f         alts -> let ialts = lookupCtxtName f (idris_implicits ist) in@@ -1375,7 +1452,7 @@                     if (not (vname f) || tcname f                            || any (conCaf (tt_ctxt ist)) ialts) --                            any constructor alts || any allImp ialts))-                        then aiFn inpat False ist fc f ds [] -- use it as a constructor+                        then aiFn inpat False qq ist fc f ds [] -- use it as a constructor                         else Right $ PPatvar fc f     where imp (PExp _ _ _ _) = False           imp _ = True@@ -1384,14 +1461,14 @@           constructor (TyDecl (DCon _ _) _) = True           constructor _ = False -          conCaf ctxt (n, cia) = isDConName n ctxt && allImp cia+          conCaf ctxt (n, cia) = (isDConName n ctxt || (qq && isTConName n ctxt)) && allImp cia            vname (UN n) = True -- non qualified           vname _ = False -aiFn inpat expat ist fc f ds as+aiFn inpat expat qq ist fc f ds as     | f `elem` primNames = Right $ PApp fc (PRef fc f) as-aiFn inpat expat ist fc f ds as+aiFn inpat expat qq ist fc f ds as           -- This is where namespaces get resolved by adding PAlternative      = do let ns = lookupCtxtName f (idris_implicits ist)           let nh = filter (\(n, _) -> notHidden n) ns@@ -1425,40 +1502,46 @@                     _ -> Public      insertImpl :: [PArg] -> [PArg] -> [PArg]-    insertImpl ps as = insImpAcc M.empty ps as+    insertImpl ps as = insImpAcc M.empty ps (filter exp as) (filter (not.exp) as) +    exp (PExp _ _ _ _) = True+    exp (PConstraint _ _ _ _) = True+    exp _ = False+     insImpAcc :: M.Map Name PTerm -- accumulated param names & arg terms               -> [PArg]           -- parameters-              -> [PArg]           -- arguments+              -> [PArg]           -- explicit arguments+              -> [PArg]           -- implicits given               -> [PArg]-    insImpAcc pnas (PExp p l n ty : ps) (PExp _ _ _ tm : given) =-      PExp p l n tm : insImpAcc (M.insert n tm pnas) ps given-    insImpAcc pnas (PConstraint p l n ty : ps) (PConstraint _ _ _ tm : given) =-      PConstraint p l n tm : insImpAcc (M.insert n tm pnas) ps given-    insImpAcc pnas (PConstraint p l n ty : ps) given =+    insImpAcc pnas (PExp p l n ty : ps) (PExp _ _ _ tm : given) imps =+      PExp p l n tm : insImpAcc (M.insert n tm pnas) ps given imps+    insImpAcc pnas (PConstraint p l n ty : ps) (PConstraint _ _ _ tm : given) imps =+      PConstraint p l n tm : insImpAcc (M.insert n tm pnas) ps given imps+    insImpAcc pnas (PConstraint p l n ty : ps) given imps =       let rtc = PResolveTC fc in-        PConstraint p l n rtc : insImpAcc (M.insert n rtc pnas) ps given-    insImpAcc pnas (PImp p _ l n ty : ps) given =-        case find n given [] of-            Just (tm, given') ->-              PImp p False l n tm : insImpAcc (M.insert n tm pnas) ps given'+        PConstraint p l n rtc : insImpAcc (M.insert n rtc pnas) ps given imps+    insImpAcc pnas (PImp p _ l n ty : ps) given imps =+        case find n imps [] of+            Just (tm, imps') ->+              PImp p False l n tm : insImpAcc (M.insert n tm pnas) ps given imps'             Nothing ->               PImp p True l n Placeholder :-                insImpAcc (M.insert n Placeholder pnas) ps given-    insImpAcc pnas (PTacImplicit p l n sc' ty : ps) given =+                insImpAcc (M.insert n Placeholder pnas) ps given imps+    insImpAcc pnas (PTacImplicit p l n sc' ty : ps) given imps =       let sc = addImpl ist (substMatches (M.toList pnas) sc') in-        case find n given [] of-            Just (tm, given') ->+        case find n imps [] of+            Just (tm, imps') ->               PTacImplicit p l n sc tm :-                insImpAcc (M.insert n tm pnas) ps given'+                insImpAcc (M.insert n tm pnas) ps given imps'             Nothing ->               if inpat                 then PTacImplicit p l n sc Placeholder :-                  insImpAcc (M.insert n Placeholder pnas) ps given+                  insImpAcc (M.insert n Placeholder pnas) ps given imps                 else PTacImplicit p l n sc sc :-                  insImpAcc (M.insert n sc pnas) ps given-    insImpAcc _ expected [] = []-    insImpAcc _ _        given  = given+                  insImpAcc (M.insert n sc pnas) ps given imps+    insImpAcc _ expected [] imps = imps -- so that unused implicits give error+                                     -- TODO: report here, and prune alternatives+    insImpAcc _ _        given imps = given ++ imps      find n []               acc = Nothing     find n (PImp _ _ _ n' t : gs) acc@@ -1619,7 +1702,8 @@         | not names && (not (isConName n (tt_ctxt i) ||                              isFnName n (tt_ctxt i)) || tm == Placeholder)             = return [(n, tm)]-    match (PEq _ l r) (PEq _ l' r') = do ml <- match' l l'+    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' _)@@ -1710,7 +1794,7 @@          | otherwise = PPi p x (sm xs t) (sm (x : xs) sc)     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 (PEq f xt yt x y) = PEq f (sm xs xt) (sm xs yt) (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)@@ -1734,7 +1818,7 @@     sm (PApp f x as) = PApp f (sm x) (map (fmap sm) as)     sm (PAppBind f x as) = PAppBind 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 (PEq f xt yt x y) = PEq f (sm xt) (sm yt) (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 p x y) = PPair f p (sm x) (sm y)
src/Idris/AbsSyntaxTree.hs view
@@ -15,8 +15,6 @@  import Idris.Colours -import Paths_idris- import System.Console.Haskeline import System.IO @@ -289,6 +287,7 @@ data Command = Quit              | Help              | Eval PTerm+             | NewDefn [PDecl] -- ^ Each 'PDecl' should be either a type declaration (at most one) or a clause defining the same name.              | Check PTerm              | DocStr (Either Name Const)              | TotCheck Name@@ -485,8 +484,9 @@   -- | Data declaration options-data DataOpt = Codata -- Set if the the data-type is coinductive-             | DefaultEliminator -- Set if an eliminator should be generated for data type+data DataOpt = Codata -- ^ Set if the the data-type is coinductive+             | DefaultEliminator -- ^ Set if an eliminator should be generated for data type+             | DefaultCaseFun -- ^ Set if a case function should be generated for data type              | DataErrRev     deriving (Show, Eq) @@ -681,7 +681,7 @@            | PFalse FC -- ^ _|_            | PRefl FC PTerm            | PResolveTC FC-           | PEq FC PTerm PTerm -- ^ Equality type: A = B+           | PEq FC PTerm PTerm PTerm PTerm -- ^ Heterogeneous equality type: A = B            | PRewrite FC PTerm PTerm (Maybe PTerm)            | PPair FC PunInfo PTerm PTerm            | PDPair FC PunInfo PTerm PTerm PTerm@@ -703,6 +703,8 @@            | PDisamb [[T.Text]] PTerm -- ^ Preferences for explicit namespaces            | PUnifyLog PTerm -- ^ dump a trace of unifications when building term            | PNoImplicits PTerm -- ^ never run implicit converions on the term+           | PQuasiquote PTerm (Maybe PTerm) -- ^ `(Term [: Term])+           | PUnquote PTerm -- ^ ,Term        deriving Eq  @@ -721,7 +723,7 @@   mpt (PApp fc t as) = PApp fc (mapPT f t) (map (fmap (mapPT f)) as)   mpt (PAppBind fc t as) = PAppBind 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)+  mpt (PEq fc lt rt l r) = PEq fc (mapPT f lt) (mapPT f rt) (mapPT f l) (mapPT f r)   mpt (PTyped l r) = PTyped (mapPT f l) (mapPT f r)   mpt (PPair fc p l r) = PPair fc p (mapPT f l) (mapPT f r)   mpt (PDPair fc p l t r) = PDPair fc p (mapPT f l) (mapPT f t) (mapPT f r)@@ -739,7 +741,8 @@  data PTactic' t = Intro [Name] | Intros | Focus Name                 | Refine Name [Bool] | Rewrite t | DoUnify-                | Induction Name+                | Induction t+                | CaseTac t                 | Equiv t                 | MatchRefine Name                 | LetTac Name t | LetTacTy Name t t@@ -758,6 +761,8 @@                 | GoalType String (PTactic' t)                 | TCheck t                 | TEval t+                | TDocStr (Either Name Const)+                | TSearch t                 | Qed | Abandon     deriving (Show, Eq, Functor) {-!@@ -833,7 +838,7 @@                               getTm :: t }     deriving (Show, Eq, Functor) -data ArgOpt = HideDisplay | InaccessibleArg+data ArgOpt = AlwaysShow | HideDisplay | InaccessibleArg     deriving (Show, Eq)  instance Sized a => Sized (PArg' a) where@@ -904,7 +909,8 @@                     index_first :: Maybe t,                     index_next  :: Maybe t,                     dsl_lambda  :: Maybe t,-                    dsl_let     :: Maybe t+                    dsl_let     :: Maybe t,+                    dsl_pi      :: Maybe t                   }     deriving (Show, Functor) {-!@@ -948,6 +954,7 @@               Nothing               Nothing               Nothing+              Nothing   where f = fileFC "(builtin)"  data Using = UImplicit Name PTerm@@ -967,14 +974,15 @@                         implicitAllowed :: Bool,                         maxline :: Maybe Int,                         mut_nesting :: Int,-                        dsl_info :: DSL }+                        dsl_info :: DSL,+                        syn_in_quasiquote :: Bool }     deriving Show {-! deriving instance NFData SyntaxInfo deriving instance Binary SyntaxInfo !-} -defaultSyntax = Syn [] [] [] [] id False False Nothing 0 initDSL+defaultSyntax = Syn [] [] [] [] id False False Nothing 0 initDSL False  expandNS :: SyntaxInfo -> Name -> Name expandNS syn n@(NS _ _) = n@@ -1070,9 +1078,9 @@           "Thus, if Idris can't infer the type of one side of the equality, then " ++           "you may need to annotate it. See the function `the`." -eqDecl = PDatadecl eqTy (piBind [(n "A", PType), (n "B", PType),-                                 (n "x", PRef bi (n "A")), (n "y", PRef bi (n "B"))]-                                 PType)+eqDecl = PDatadecl eqTy (piBindp impl [(n "A", PType), (n "B", PType)]+                                 (piBind [(n "x", PRef bi (n "A")), (n "y", PRef bi (n "B"))]+                                 PType))                 [(reflDoc, reflParamDoc,                   eqCon, PPi impl (n "A") PType (                                   PPi impl (n "x") (PRef bi (n "A"))@@ -1080,7 +1088,7 @@                                                                pimp (n "B") Placeholder False,                                                                pexp (PRef bi (n "x")),                                                                pexp (PRef bi (n "x"))])), bi, [])]-    where n a = sMN 0 a+    where n a = sUN a           reflDoc = parseDocstring . T.pack $                       "A proof that `x` in fact equals `x`. To construct this, you must have already " ++                       "shown that both sides are in fact equal."@@ -1090,7 +1098,7 @@ eqParamDoc = [(n "A", parseDocstring . T.pack $ "the type of the left side of the equality"),               (n "B", parseDocstring . T.pack $ "the type of the right side of the equality")               ]-    where n a = sMN 0 a+    where n a = sUN a  eqOpts = [] @@ -1122,7 +1130,7 @@   showsPrec _ tm = (displayS . renderPretty 1.0 10000000 . prettyImp defaultPPOption) tm  instance Show PDecl where-  showsPrec _ d = (displayS . renderPretty 1.0 10000000 . showDeclImp defaultPPOption) d+  showsPrec _ d = (displayS . renderPretty 1.0 10000000 . showDeclImp verbosePPOption) d  instance Show PClause where   showsPrec _ c = (displayS . renderPretty 1.0 10000000 . showCImp verbosePPOption) c@@ -1160,6 +1168,7 @@   where colour BoldText      = IdrisColour Nothing True False True False         colour UnderlineText = IdrisColour Nothing True True False False         colour ItalicText    = IdrisColour Nothing True False False True+consoleDecorate ist (AnnTerm _ _) = id  isPostulateName :: Name -> IState -> Bool isPostulateName n ist = S.member n (idris_postulates ist)@@ -1170,6 +1179,8 @@           -> Doc OutputAnnotation prettyImp impl = pprintPTerm impl [] [] [] +-- | Serialise something to base64 using its Binary instance.+ -- | Do the right thing for rendering a term in an IState prettyIst ::  IState -> PTerm -> Doc OutputAnnotation prettyIst ist = pprintPTerm (ppOptionIst ist) [] [] (idris_infixes ist)@@ -1190,7 +1201,7 @@     prettySe p bnd e       | Just str <- slist p bnd e = str       | Just n <- snat p e = annotate (AnnData "Nat" "") (text (show n))-    prettySe p bnd (PRef fc n) = prettyName (ppopt_impl ppo) bnd n+    prettySe p bnd (PRef fc n) = prettyName True (ppopt_impl ppo) bnd n     prettySe p bnd (PLam n ty sc) =       bracket p 2 . group . align . hang 2 $       text "\\" <> bindingOf n False <+> text "=>" <$>@@ -1233,25 +1244,25 @@       rbrace <+> text "->" </> prettySe 10 ((n, True):bnd) sc     prettySe p bnd (PApp _ (PRef _ f) args) -- normal names, no explicit args       | UN nm <- basename f-      , not (ppopt_impl ppo) && null (getExps args) =-          if isAlpha (thead nm)-              then prettyName (ppopt_impl ppo) bnd f-              else enclose lparen rparen $ prettyName (ppopt_impl ppo) bnd f+      , not (ppopt_impl ppo) && null (getShowArgs args) =+          prettyName True (ppopt_impl ppo) bnd f     prettySe p bnd (PAppBind _ (PRef _ f) [])-      | not (ppopt_impl ppo) = text "!" <> prettyName (ppopt_impl ppo) bnd f+      | not (ppopt_impl ppo) = text "!" <> prettyName True (ppopt_impl ppo) bnd f     prettySe p bnd (PApp _ (PRef _ op) args) -- infix operators       | UN nm <- basename op       , not (tnull nm) &&         (not (ppopt_impl ppo)) && (not $ isAlpha (thead nm)) =-          case getExps args of-            [] -> enclose lparen rparen opName-            [x] -> group (enclose lparen rparen opName <$> group (prettySe 0 bnd x))+          case getShowArgs args of+            [] -> opName True+            [x] -> group (opName True <$> group (prettySe 0 bnd (getTm x)))             [l,r] -> let precedence = fromMaybe 20 (fmap prec f)-                     in bracket p precedence $ inFix l r-            (l:r:rest) -> bracket p 1 $-                          enclose lparen rparen (inFix l r) <+>-                          align (group (vsep (map (prettyArgSe bnd) rest)))-          where opName = prettyName (ppopt_impl ppo) bnd op+                     in bracket p precedence $ inFix (getTm l) (getTm r)+            (l@(PExp _ _ _ _) : r@(PExp _ _ _ _) : rest) -> +                   bracket p 1 $+                          enclose lparen rparen (inFix (getTm l) (getTm r)) <+>+                          align (group (vsep (map (prettyArgS bnd) rest)))+            as -> opName True <+> align (vsep (map (prettyArgS bnd) as))+          where opName isPrefix = prettyName isPrefix (ppopt_impl ppo) bnd op                 f = getFixity (opStr op)                 left l = case f of                            Nothing -> prettySe (-1) bnd l@@ -1262,13 +1273,13 @@                             Just (Infixr p') -> prettySe p' bnd r                             Just f' -> prettySe (prec f'-1) bnd r                 inFix l r = align . group $-                              (left l <+> opName) <$> group (right r)+                              (left l <+> opName False) <$> group (right r)     prettySe p bnd (PApp _ hd@(PRef fc f) [tm]) -- symbols, like 'foo       | PConstant (Idris.Core.TT.Str str) <- getTm tm,         f == sUN "Symbol_" = annotate (AnnType ("'" ++ str) ("The symbol " ++ str)) $                                char '\'' <> prettySe 10 bnd (PRef fc (sUN str))     prettySe p bnd (PApp _ f as) = -- Normal prefix applications-      let args = getExps as+      let args = getShowArgs as           fp   = prettySe 1 bnd f       in         bracket p 1 . group $@@ -1278,7 +1289,7 @@                    else fp <+> align (vsep (map (prettyArgS bnd) as))             else if null args                    then fp-                   else fp <+> align (vsep (map (prettyArgSe bnd) args))+                   else fp <+> align (vsep (map (prettyArgS bnd) args))     prettySe p bnd (PCase _ scr opts) =       kwd "case" <+> prettySe 10 bnd scr <+> kwd "of" <> prettyBody       where@@ -1292,7 +1303,7 @@     prettySe p bnd (PTrue _ IsTerm) = annName unitCon $ text "()"     prettySe p bnd (PTrue _ TypeOrTerm) = text "()"     prettySe p bnd (PFalse _) = annName falseTy $ text "_|_"-    prettySe p bnd (PEq _ l r) =+    prettySe p bnd (PEq _ _ _ l r) =       bracket p 2 . align . group $       prettySe 10 bnd l <+> eq <$> group (prettySe 10 bnd r)       where eq = annName eqTy (text "=")@@ -1348,8 +1359,12 @@     prettySe p bnd (PDoBlock _) = text "do block pretty not implemented"     prettySe p bnd (PCoerced t) = prettySe p bnd t     prettySe p bnd (PElabError s) = pretty s+    -- Quasiquote pprinting ignores bound vars+    prettySe p bnd (PQuasiquote t Nothing) = text "`(" <> prettySe p [] t <> text ")"+    prettySe p bnd (PQuasiquote t (Just g)) = text "`(" <> prettySe p [] t <+> colon <+> prettySe p [] g <> text ")"+    prettySe p bnd (PUnquote t) = text "~" <> prettySe p bnd t -    prettySe p bnd _ = text "test"+    prettySe p bnd _ = text "missing pretty-printer for term"      prettyArgS bnd (PImp _ _ _ n tm) = prettyArgSi bnd (n, tm)     prettyArgS bnd (PExp _ _ _ tm)   = prettyArgSe bnd tm@@ -1429,7 +1444,7 @@  prettyDocumentedIst :: IState -> (Name, PTerm, Maybe Docstring) -> Doc OutputAnnotation prettyDocumentedIst ist (name, ty, docs) =-          prettyName True [] name <+> colon <+> align (prettyIst ist ty) <$>+          prettyName True True [] name <+> colon <+> align (prettyIst ist ty) <$>           fromMaybe empty (fmap (\d -> renderDocstring d <> line) docs)  -- | Pretty-printer helper for the binding site of a name@@ -1439,18 +1454,28 @@ bindingOf n imp = annotate (AnnBoundName n imp) (text (show n))  -- | Pretty-printer helper for names that attaches the correct annotations-prettyName :: Bool -- ^^ whether to show namespaces-           -> [(Name, Bool)] -- ^^ the current bound variables and whether they are implicit-           -> Name -- ^^ the name to pprint-           -> Doc OutputAnnotation-prettyName showNS bnd n | Just imp <- lookup n bnd = annotate (AnnBoundName n imp) (text (strName n))-                        | otherwise = annotate (AnnName n Nothing Nothing Nothing) (text (strName n))-  where strName (UN n) = T.unpack n-        strName (NS n ns) | showNS    = (concatMap (++ ".") . map T.unpack . reverse) ns ++ strName n-                          | otherwise = strName n-        strName n | n == falseTy = "_|_"-        strName (MN i s) = T.unpack s-        strName other = show other+prettyName+  :: Bool -- ^^ whether the name should be parenthesised if it is an infix operator+  -> Bool -- ^^ whether to show namespaces+  -> [(Name, Bool)] -- ^^ the current bound variables and whether they are implicit+  -> Name -- ^^ the name to pprint+  -> Doc OutputAnnotation+prettyName infixParen showNS bnd n +    | Just imp <- lookup n bnd = annotate (AnnBoundName n imp) fullName+    | otherwise                = annotate (AnnName n Nothing Nothing Nothing) fullName+  where fullName = text nameSpace <> parenthesise (text (baseName n))+        baseName (UN n) = T.unpack n+        baseName (NS n ns) = baseName n+        baseName (MN i s) = T.unpack s +        baseName n | n == falseTy = "_|_"+        baseName other = show other+        nameSpace = case n of+          (NS n' ns) -> if showNS then (concatMap (++ ".") . map T.unpack . reverse) ns else ""+          _ -> ""+        isInfix = case baseName n of+          ""      -> False+          (c : _) -> not (isAlpha c)+        parenthesise = if isInfix && infixParen then enclose lparen rparen else id   showCImp :: PPOption -> PClause -> Doc OutputAnnotation@@ -1471,7 +1496,7 @@ showDImp :: PPOption -> PData -> Doc OutputAnnotation showDImp ppo (PDatadecl n ty cons)  = text "data" <+> text (show n) <+> colon <+> prettyImp ppo ty <+> text "where" <$>-    (indent 2 $ vsep (map (\ (_, _, n, t, _, _) -> pipe <+> prettyName False [] n <+> colon <+> prettyImp ppo t) cons))+    (indent 2 $ vsep (map (\ (_, _, n, t, _, _) -> pipe <+> prettyName True False [] n <+> colon <+> prettyImp ppo t) cons))  showDecls :: PPOption -> [PDecl] -> Doc OutputAnnotation showDecls o ds = vsep (map (showDeclImp o) ds)@@ -1504,6 +1529,12 @@ getExps (PExp _ _ _ tm : xs) = tm : getExps xs getExps (_ : xs) = getExps xs +getShowArgs :: [PArg] -> [PArg]+getShowArgs [] = []+getShowArgs (e@(PExp _ _ _ tm) : xs) = e : getShowArgs xs+getShowArgs (e : xs) | AlwaysShow `elem` argopts e = e : getShowArgs xs+getShowArgs (_ : xs) = getShowArgs xs+ getConsts :: [PArg] -> [PTerm] getConsts [] = [] getConsts (PConstraint _ _ _ tm : xs) = tm : getConsts xs@@ -1525,7 +1556,7 @@                                    Nothing -> showbasic n     where name = if ppopt_impl ppo then show n else showbasic n           showbasic n@(UN _) = showCG n-          showbasic (MN _ s) = str s+          showbasic (MN i s) = str s           showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n           showbasic (SN s) = show s           fst3 (x, _, _) = x@@ -1569,7 +1600,7 @@   size (PFalse fc) = 1   size (PRefl fc _) = 1   size (PResolveTC fc) = 1-  size (PEq fc left right) = 1 + size left + size right+  size (PEq 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@@ -1607,7 +1638,7 @@     ni env (PLam n ty sc)  = ni env ty ++ ni (n:env) sc     ni env (PPi p n ty sc) = niTacImp env p ++ 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 (PEq _ _ _ 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@@ -1632,7 +1663,7 @@     ni (PLam n ty sc)  = n : (ni ty ++ ni sc)     ni (PLet n ty val sc)  = n : (ni ty ++ ni val ++ ni sc)     ni (PPi p n ty sc) = niTacImp p ++ (n : (ni ty ++ ni sc))-    ni (PEq _ l r)     = ni l ++ ni r+    ni (PEq _ _ _ l r)     = ni l ++ ni r     ni (PRewrite _ l r _) = ni l ++ ni r     ni (PTyped l r)    = ni l ++ ni r     ni (PPair _ _ l r)   = ni l ++ ni r@@ -1648,6 +1679,42 @@     niTacImp (TacImp _ _ scr) = ni scr     niTacImp _                = [] +-- Return names which are valid implicits in the given term (type).+implicitNamesIn :: [Name] -> IState -> PTerm -> [Name]+implicitNamesIn uvars ist tm = nub $ ni [] tm+  where+    ni env (PRef _ n)+        | not (n `elem` env) +            = case lookupTy n (tt_ctxt ist) of+                [] -> [n]+                _ -> if n `elem` uvars then [n] else []+    ni env (PApp _ f@(PRef _ n) as) +        | n `elem` uvars = ni env f ++ concatMap (ni env) (map getTm as)+        | otherwise = concatMap (ni env) (map getTm as)+    ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as)+    ni env (PAppBind _ f as)   = ni env f ++ concatMap (ni env) (map getTm as)+    ni env (PCase _ c os)  = ni env c ++ +    -- names in 'os', not counting the names bound in the cases+                                (nub (concatMap (ni env) (map snd os))+                                     \\ nub (concatMap (ni env) (map fst os)))+    ni env (PLam n ty sc)  = ni env ty ++ ni (n:env) sc+    ni env (PPi p n ty sc) = niTacImp env p ++ 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 (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 (PDisamb _ tm)    = ni env tm+    ni env (PNoImplicits tm) = ni env tm+    ni env _               = []++    niTacImp env (TacImp _ _ scr) = ni env scr+    niTacImp _ _                  = []+ -- Return names which are free in the given term. namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name] namesIn uvars ist tm = nub $ ni [] tm@@ -1659,10 +1726,13 @@                 _ -> if n `elem` (map fst uvars) then [n] else []     ni env (PApp _ f as)   = ni env f ++ concatMap (ni env) (map getTm as)     ni env (PAppBind _ f as)   = ni env f ++ concatMap (ni env) (map getTm as)-    ni env (PCase _ c os)  = ni env c ++ concatMap (ni env) (map snd os)+    ni env (PCase _ c os)  = ni env c ++ +    -- names in 'os', not counting the names bound in the cases+                                (nub (concatMap (ni env) (map snd os))+                                     \\ nub (concatMap (ni env) (map fst os)))     ni env (PLam n ty sc)  = ni env ty ++ ni (n:env) sc     ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc-    ni env (PEq _ l r)     = ni env l ++ ni env r+    ni env (PEq _ _ _ 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@@ -1693,7 +1763,7 @@     ni env (PCase _ c os)  = ni env c ++ concatMap (ni env) (map snd os)     ni env (PLam n ty sc)  = ni env ty ++ ni (n:env) sc     ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc-    ni env (PEq _ l r)     = ni env l ++ ni env r+    ni env (PEq _ _ _ 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@@ -1708,3 +1778,10 @@      niTacImp env (TacImp _ _ scr) = ni env scr     niTacImp _ _                = []++-- Return the list of inaccessible (= dotted) positions for a name.+getErasureInfo :: IState -> Name -> [Int]+getErasureInfo ist n =+    case lookupCtxtExact n (idris_optimisation ist) of+        Just (Optimise inacc detagg) -> map fst inacc+        Nothing -> []
src/Idris/CaseSplit.hs view
@@ -55,7 +55,7 @@    = do ist <- getIState         -- Make sure all the names in the term are accessible         mapM_ (\n -> setAccessibility n Public) (allNamesIn t')-        (tm, ty, pats) <- elabValBind toplevel True True (addImplPat ist t')+        (tm, ty, pats) <- elabValBind toplevel ELHS True (addImplPat ist t')         -- ASSUMPTION: tm is in normal form after elabValBind, so we don't         -- need to do anything special to find out what family each argument         -- is in@@ -201,7 +201,7 @@ --         tidyVar t = t  elabNewPat :: PTerm -> Idris (Maybe PTerm)-elabNewPat t = idrisCatch (do (tm, ty) <- elabVal toplevel True t+elabNewPat t = idrisCatch (do (tm, ty) <- elabVal toplevel ELHS t                               i <- getIState                               return (Just (delab i tm)))                           (\e -> do i <- getIState@@ -231,7 +231,7 @@         subst (PApp fc (PRef _ t) pats)              | isTConName t ctxt = Placeholder -- infer types         subst (PApp fc f pats) = PApp fc f (map substArg pats)-        subst (PEq fc l r) = Placeholder -- PEq fc (subst l) (subst r)+        subst (PEq fc _ _ l r) = Placeholder -- PEq fc (subst l) (subst r)         subst x = x          substArg arg = arg { getTm = subst (getTm arg) }@@ -276,7 +276,7 @@     -- this isn't supported in a pattern, so special case here     nshow (PRef _ (UN z)) | z == txt "Z" = "Z"     nshow (PApp _ (PRef _ (UN s)) [x]) | s == txt "S" =-               "S " ++ addBrackets (nshow (getTm x))+               "(S " ++ addBrackets (nshow (getTm x)) ++ ")"     nshow t = show t      -- if there's any {n} replace with {n=n}@@ -349,7 +349,7 @@          getNameFrom i used (PPi _ _ _ _)                = uniqueNameFrom (mkSupply [sUN "f", sUN "g"]) used          getNameFrom i used (PApp fc f as) = getNameFrom i used f-         getNameFrom i used (PEq _ _ _) = uniqueNameFrom [sUN "prf"] used +         getNameFrom i used (PEq _ _ _ _ _) = uniqueNameFrom [sUN "prf"] used           getNameFrom i used (PRef fc f)              = case getNameHints i f of                    [] -> uniqueName (sUN "x") used
src/Idris/Completion.hs view
@@ -44,7 +44,8 @@              , ("reflect", Just ExprTArg)              , ("fill", Just ExprTArg)              , ("try", Just AltsTArg)-             , ("induction", Just NameTArg)+             , ("induction", Just ExprTArg)+             , ("case", Just ExprTArg)              , (":t", Just ExprTArg)              , (":type", Just ExprTArg)              , (":e", Just ExprTArg)
+ src/Idris/Core/Binary.hs view
@@ -0,0 +1,356 @@+{-| Binary instances for the core datatypes -}+module Idris.Core.Binary where++import Data.Binary+import Data.Vector.Binary+import qualified Data.Text as T++import Idris.Core.TT++----- Generated by 'derive'++instance Binary FC where+        put (FC x1 (x2, x3) (x4, x5))+          = do put x1+               put (x2 * 65536 + x3)+               put (x4 * 65536 + x5)+        get+          = do x1 <- get+               x2x3 <- get+               x4x5 <- get+               return (FC x1 (x2x3 `div` 65536, x2x3 `mod` 65536) (x4x5 `div` 65536, x4x5 `mod` 65536))+++instance Binary Name where+        put x+          = case x of+                UN x1 -> do putWord8 0+                            put x1+                NS x1 x2 -> do putWord8 1+                               put x1+                               put x2+                MN x1 x2 -> do putWord8 2+                               put x1+                               put x2+                NErased -> putWord8 3+                SN x1 -> do putWord8 4+                            put x1+                SymRef x1 -> do putWord8 5+                                put x1+        get+          = do i <- getWord8+               case i of+                   0 -> do x1 <- get+                           return (UN x1)+                   1 -> do x1 <- get+                           x2 <- get+                           return (NS x1 x2)+                   2 -> do x1 <- get+                           x2 <- get+                           return (MN x1 x2)+                   3 -> return NErased+                   4 -> do x1 <- get+                           return (SN x1)+                   5 -> do x1 <- get+                           return (SymRef x1)+                   _ -> error "Corrupted binary data for Name"++instance Binary T.Text where+        put x = put (str x)+        get = do x <- get+                 return (txt x)++instance Binary SpecialName where+        put x+          = case x of+                WhereN x1 x2 x3 -> do putWord8 0+                                      put x1+                                      put x2+                                      put x3+                InstanceN x1 x2 -> do putWord8 1+                                      put x1+                                      put x2+                ParentN x1 x2 -> do putWord8 2+                                    put x1+                                    put x2+                MethodN x1 -> do putWord8 3+                                 put x1+                CaseN x1 -> do putWord8 4; put x1+                ElimN x1 -> do putWord8 5; put x1+                InstanceCtorN x1 -> do putWord8 6; put x1+        get+          = do i <- getWord8+               case i of+                   0 -> do x1 <- get+                           x2 <- get+                           x3 <- get+                           return (WhereN x1 x2 x3)+                   1 -> do x1 <- get+                           x2 <- get+                           return (InstanceN x1 x2)+                   2 -> do x1 <- get+                           x2 <- get+                           return (ParentN x1 x2)+                   3 -> do x1 <- get+                           return (MethodN x1)+                   4 -> do x1 <- get+                           return (CaseN x1)+                   5 -> do x1 <- get+                           return (ElimN x1)+                   6 -> do x1 <- get+                           return (InstanceCtorN x1)+                   _ -> error "Corrupted binary data for SpecialName"+++instance Binary Const where+        put x+          = case x of+                I x1 -> do putWord8 0+                           put x1+                BI x1 -> do putWord8 1+                            put x1+                Fl x1 -> do putWord8 2+                            put x1+                Ch x1 -> do putWord8 3+                            put x1+                Str x1 -> do putWord8 4+                             put x1+                B8 x1 -> putWord8 5 >> put x1+                B16 x1 -> putWord8 6 >> put x1+                B32 x1 -> putWord8 7 >> put x1+                B64 x1 -> putWord8 8 >> put x1++                (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+                (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+                BufferType -> putWord8 25+                ManagedPtrType -> putWord8 26+        get+          = do i <- getWord8+               case i of+                   0 -> do x1 <- get+                           return (I x1)+                   1 -> do x1 <- get+                           return (BI x1)+                   2 -> do x1 <- get+                           return (Fl x1)+                   3 -> do x1 <- get+                           return (Ch x1)+                   4 -> do x1 <- get+                           return (Str x1)+                   5 -> fmap B8 get+                   6 -> fmap B16 get+                   7 -> fmap B32 get+                   8 -> fmap B64 get++                   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 (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+                   25 -> return BufferType+                   26 -> return ManagedPtrType++                   _ -> error "Corrupted binary data for Const"+++instance Binary Raw where+        put x+          = case x of+                Var x1 -> do putWord8 0+                             put x1+                RBind x1 x2 x3 -> do putWord8 1+                                     put x1+                                     put x2+                                     put x3+                RApp x1 x2 -> do putWord8 2+                                 put x1+                                 put x2+                RType -> putWord8 3+                RConstant x1 -> do putWord8 4+                                   put x1+                RForce x1 -> do putWord8 5+                                put x1+        get+          = do i <- getWord8+               case i of+                   0 -> do x1 <- get+                           return (Var x1)+                   1 -> do x1 <- get+                           x2 <- get+                           x3 <- get+                           return (RBind x1 x2 x3)+                   2 -> do x1 <- get+                           x2 <- get+                           return (RApp x1 x2)+                   3 -> return RType+                   4 -> do x1 <- get+                           return (RConstant x1)+                   5 -> do x1 <- get+                           return (RForce x1)+                   _ -> error "Corrupted binary data for Raw"+++instance (Binary b) => Binary (Binder b) where+        put x+          = case x of+                Lam x1 -> do putWord8 0+                             put x1+                Pi x1 -> do putWord8 1+                            put x1+                Let x1 x2 -> do putWord8 2+                                put x1+                                put x2+                NLet x1 x2 -> do putWord8 3+                                 put x1+                                 put x2+                Hole x1 -> do putWord8 4+                              put x1+                GHole x1 x2 -> do putWord8 5+                                  put x1+                                  put x2+                Guess x1 x2 -> do putWord8 6+                                  put x1+                                  put x2+                PVar x1 -> do putWord8 7+                              put x1+                PVTy x1 -> do putWord8 8+                              put x1+        get+          = do i <- getWord8+               case i of+                   0 -> do x1 <- get+                           return (Lam x1)+                   1 -> do x1 <- get+                           return (Pi x1)+                   2 -> do x1 <- get+                           x2 <- get+                           return (Let x1 x2)+                   3 -> do x1 <- get+                           x2 <- get+                           return (NLet x1 x2)+                   4 -> do x1 <- get+                           return (Hole x1)+                   5 -> do x1 <- get+                           x2 <- get+                           return (GHole x1 x2)+                   6 -> do x1 <- get+                           x2 <- get+                           return (Guess x1 x2)+                   7 -> do x1 <- get+                           return (PVar x1)+                   8 -> do x1 <- get+                           return (PVTy x1)+                   _ -> error "Corrupted binary data for Binder"+++instance Binary NameType where+        put x+          = case x of+                Bound -> putWord8 0+                Ref -> putWord8 1+                DCon x1 x2 -> do putWord8 2+                                 put (x1 * 65536 + x2)+                TCon x1 x2 -> do putWord8 3+                                 put (x1 * 65536 + x2)+        get+          = do i <- getWord8+               case i of+                   0 -> return Bound+                   1 -> return Ref+                   2 -> do x1x2 <- get+                           return (DCon (x1x2 `div` 65536) (x1x2 `mod` 65536))+                   3 -> do x1x2 <- get+                           return (TCon (x1x2 `div` 65536) (x1x2 `mod` 65536))+                   _ -> error "Corrupted binary data for NameType"+++instance {- (Binary n) => -} Binary (TT Name) where+        put x+          = {-# SCC "putTT" #-}+            case x of+                P x1 x2 x3 -> do putWord8 0+                                 put x1+                                 put x2+--                                  put x3+                V x1 -> if (x1 >= 0 && x1 < 256)+                           then do putWord8 1+                                   putWord8 (toEnum (x1 + 1))+                           else do putWord8 9+                                   put x1+                Bind x1 x2 x3 -> do putWord8 2+                                    put x1+                                    put x2+                                    put x3+                App x1 x2 -> do putWord8 3+                                put x1+                                put x2+                Constant x1 -> do putWord8 4+                                  put x1+                Proj x1 x2 -> do putWord8 5+                                 put x1+                                 putWord8 (toEnum (x2 + 1))+                Erased -> putWord8 6+                TType x1 -> do putWord8 7+                               put x1+                Impossible -> putWord8 8+        get+          = do i <- getWord8+               case i of+                   0 -> do x1 <- get+                           x2 <- get+--                            x3 <- get+                           return (P x1 x2 Erased)+                   1 -> do x1 <- getWord8+                           return (V ((fromEnum x1) - 1))+                   2 -> do x1 <- get+                           x2 <- get+                           x3 <- get+                           return (Bind x1 x2 x3)+                   3 -> do x1 <- get+                           x2 <- get+                           return (App x1 x2)+                   4 -> do x1 <- get+                           return (Constant x1)+                   5 -> do x1 <- get+                           x2 <- getWord8+                           return (Proj x1 ((fromEnum x2)-1))+                   6 -> return Erased+                   7 -> do x1 <- get+                           return (TType x1)+                   8 -> return Impossible+                   9 -> do x1 <- get+                           return (V x1)+                   _ -> error "Corrupted binary data for TT"+
src/Idris/Core/CaseTree.hs view
@@ -1,13 +1,15 @@ {-# LANGUAGE PatternGuards, DeriveFunctor, TypeSynonymInstances #-} -module Idris.Core.CaseTree(CaseDef(..), SC, SC'(..), CaseAlt, CaseAlt'(..),+module Idris.Core.CaseTree(CaseDef(..), SC, SC'(..), CaseAlt, CaseAlt'(..), ErasureInfo,                      Phase(..), CaseTree,                      simpleCase, small, namesUsed, findCalls, findUsedArgs,                      substSC, substAlt, mkForce) where  import Idris.Core.TT +import Control.Applicative hiding (Const) import Control.Monad.State+import Control.Monad.Reader import Data.Maybe import Data.List hiding (partition) import qualified Data.List(partition)@@ -24,7 +26,7 @@ -- in the function `prune` as a means of optimisation -- of already built case trees. ----- While the intermediate representation (follows in the pipeline)+-- While the intermediate representation (follows in the pipeline, named LExp) -- allows casing on arbitrary terms, here we choose to maintain the distinction -- in order to allow for better optimisation opportunities. --@@ -213,7 +215,12 @@   usedA (SucCase _ sc) = used sc   usedA (DefaultCase sc) = used sc +type ErasureInfo = Name -> [Int]  -- name to list of inaccessible arguments; empty list if name not found+type CaseBuilder a = ReaderT ErasureInfo (State CS) a +runCaseBuilder :: ErasureInfo -> CaseBuilder a -> (CS -> (a, CS))+runCaseBuilder ei bld = runState $ runReaderT bld ei+ data Phase = CompileTime | RunTime     deriving (Show, Eq) @@ -223,8 +230,9 @@ simpleCase :: Bool -> Bool -> Bool ->               Phase -> FC -> [Int] -> [Type] ->               [([Name], Term, Term)] ->+              ErasureInfo ->               TC CaseDef-simpleCase tc cover reflect phase fc inacc argtys cs+simpleCase tc cover reflect phase fc inacc argtys cs erInfo       = sc' tc cover phase fc (filter (\(_, _, r) ->                                           case r of                                             Impossible -> False@@ -243,7 +251,7 @@                     let numargs    = length (fst (head pats))                         ns         = take numargs args                         (ns', ps') = order [(n, i `elem` inacc) | (i,n) <- zip [0..] ns] pats-                        (tree, st) = runState+                        (tree, st) = runCaseBuilder erInfo                                          (match ns' ps' (defaultCase cover))                                           ([], numargs, [])                         t          = CaseDef ns (prune proj (depatt ns' tree)) (fstT st) in@@ -334,18 +342,20 @@    getArgs _ = []  toPat :: Bool -> Bool -> [Term] -> [Pat]-toPat reflect tc tms = evalState (mapM (\x -> toPat' x []) tms) []+toPat reflect tc = map $ toPat' []   where-    toPat' (P (DCon t a) nm@(UN n) _) [_,_,arg]-           | n == txt "Delay" = do arg' <- toPat' arg []-                                   return $ PCon nm t [PAny, PAny, arg']-    toPat' (P (DCon t a) n _) args = do args' <- mapM (\x -> toPat' x []) args-                                        return $ PCon n t args'+    toPat' [_,_,arg](P (DCon t a) nm@(UN n) _)+        | n == txt "Delay"+        = PCon nm t [PAny, PAny, toPat' [] arg]++    toPat' args (P (DCon t a) n _)+        = PCon n t $ map (toPat' []) args+     -- n + 1-    toPat' (P _ (UN pabi) _)-                  [p, Constant (BI 1)] | pabi == txt "prim__addBigInt"-                                   = do p' <- toPat' p []-                                        return $ PSuc p'+    toPat' [p, Constant (BI 1)] (P _ (UN pabi) _)+        | pabi == txt "prim__addBigInt"+        = PSuc $ toPat' [] p+     -- Typecase --     toPat' (P (TCon t a) n _) args | tc --                                    = do args' <- mapM (\x -> toPat' x []) args@@ -360,27 +370,26 @@ --         | 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 ty)     []   = -- trace (show (n, ty)) $-                                     do ns <- get-                                        if n `elem` ns-                                          then return PAny-                                          else do put (n : ns)-                                                  return (PV n ty)-    toPat' (App f a)  args = toPat' f (a : args)-    toPat' (Constant (AType _)) [] = return PTyPat-    toPat' (Constant StrType) [] = return PTyPat-    toPat' (Constant PtrType) [] = return PTyPat-    toPat' (Constant VoidType) [] = return PTyPat-    toPat' (Constant x) [] = return $ PConst x-    toPat' (Bind n (Pi t) sc) [] | reflect && noOccurrence n sc-          = do t' <- toPat' t []-               sc' <- toPat' sc []-               return $ PReflected (sUN "->") (t':sc':[])-    toPat' (P _ n _) args | reflect-          = do args' <- mapM (\x -> toPat' x []) args-               return $ PReflected n args'-    toPat' t            _  = return PAny+-- +    toPat' []   (P Bound n ty) = PV n ty+    toPat' args (App f a)      = toPat' (a : args) f+    toPat' [] (Constant (AType _)) = PTyPat+    toPat' [] (Constant StrType)   = PTyPat+    toPat' [] (Constant PtrType)   = PTyPat+    toPat' [] (Constant VoidType)  = PTyPat+    toPat' [] (Constant x)         = PConst x++    toPat' [] (Bind n (Pi t) sc)+        | reflect && noOccurrence n sc+        = PReflected (sUN "->") [toPat' [] t, toPat' [] sc]++    toPat' args (P _ n _)+        | reflect+        = PReflected n $ map (toPat' []) args++    toPat' _ t = PAny+     fixedN IT8 = "Bits8"     fixedN IT16 = "Bits16"     fixedN IT32 = "Bits32"@@ -459,7 +468,7 @@     numNames xs [] = length xs  match :: [Name] -> [Clause] -> SC -- error case-                            -> State CS SC+                            -> CaseBuilder SC match [] (([], ret) : xs) err     = do (ts, v, ntys) <- get          put (ts ++ (map (fst.snd) xs), v, ntys)@@ -469,13 +478,19 @@ match vs cs err = do let ps = partition cs                      mixture vs ps err -mixture :: [Name] -> [Partition] -> SC -> State CS SC+mixture :: [Name] -> [Partition] -> SC -> CaseBuilder SC mixture vs [] err = return err mixture vs (Cons ms : ps) err = do fallthrough <- mixture vs ps err                                    conRule vs ms fallthrough mixture vs (Vars ms : ps) err = do fallthrough <- mixture vs ps err                                    varRule vs ms fallthrough +-- Return the list of inaccessible arguments of a data constructor.+inaccessibleArgs :: Name -> CaseBuilder [Int]+inaccessibleArgs n = do+    getInaccessiblePositions <- ask  -- this function is the only thing in the environment+    return $ getInaccessiblePositions n+ data ConType = CName Name Int -- named constructor              | CFn Name -- reflected function name              | CSuc -- n+1@@ -486,76 +501,99 @@                       [([Pat], Clause)] -- arguments and rest of alternative    deriving Show -conRule :: [Name] -> [Clause] -> SC -> State CS SC+conRule :: [Name] -> [Clause] -> SC -> CaseBuilder SC conRule (v:vs) cs err = do groups <- groupCons cs                            caseGroups (v:vs) groups err -caseGroups :: [Name] -> [Group] -> SC -> State CS SC+caseGroups :: [Name] -> [Group] -> SC -> CaseBuilder SC caseGroups (v:vs) gs err = do g <- altGroups gs                               return $ Case v (sort g)   where     altGroups [] = return [DefaultCase err]+     altGroups (ConGroup (CName n i) args : cs)-        = do g <- altGroup n i args-             rest <- altGroups cs-             return (g : rest)+        = (:) <$> altGroup n i args <*> altGroups cs+     altGroups (ConGroup (CFn n) args : cs)-        = do g <- altFnGroup n args-             rest <- altGroups cs-             return (g : rest)+        = (:) <$> altFnGroup n args <*> altGroups cs+     altGroups (ConGroup CSuc args : cs)-        = do g <- altSucGroup args-             rest <- altGroups cs-             return (g : rest)+        = (:) <$> altSucGroup args <*> altGroups cs+     altGroups (ConGroup (CConst c) args : cs)-        = do g <- altConstGroup c args-             rest <- altGroups cs-             return (g : rest)+        = (:) <$> altConstGroup c args <*> altGroups cs -    altGroup n i gs = do (newArgs, nextCs) <- argsToAlt gs-                         matchCs <- match (newArgs ++ vs) nextCs err-                         return $ ConCase n i newArgs matchCs-    altFnGroup n gs = do (newArgs, nextCs) <- argsToAlt gs-                         matchCs <- match (newArgs ++ vs) nextCs err-                         return $ FnCase n newArgs matchCs-    altSucGroup gs = do ([newArg], nextCs) <- argsToAlt gs-                        matchCs <- match (newArg:vs) nextCs err-                        return $ SucCase newArg matchCs-    altConstGroup n gs = do (_, nextCs) <- argsToAlt gs-                            matchCs <- match vs nextCs err-                            return $ ConstCase n matchCs+    altGroup n i args = do inacc <- inaccessibleArgs n+                           (newVars, accVars, inaccVars, nextCs) <- argsToAlt inacc args+                           matchCs <- match (accVars ++ vs ++ inaccVars) nextCs err+                           return $ ConCase n i newVars matchCs -argsToAlt :: [([Pat], Clause)] -> State CS ([Name], [Clause])-argsToAlt [] = return ([], [])-argsToAlt rs@((r, m) : rest)-    = do newArgs <- getNewVars r-         return (newArgs, addRs rs)+    altFnGroup n args = do (newVars, _, [], nextCs) <- argsToAlt [] args+                           matchCs <- match (newVars ++ vs) nextCs err+                           return $ FnCase n newVars matchCs++    altSucGroup args = do ([newVar], _, [], nextCs) <- argsToAlt [] args+                          matchCs <- match (newVar:vs) nextCs err+                          return $ SucCase newVar matchCs++    altConstGroup n args = do (_, _, [], nextCs) <- argsToAlt [] args+                              matchCs <- match vs nextCs err+                              return $ ConstCase n matchCs++-- Returns:+--   * names of all variables arising from match+--   * names of accessible variables (subset of all variables)+--   * names of inaccessible variables (subset of all variables)+--   * clauses corresponding to (accVars ++ origVars ++ inaccVars)+argsToAlt :: [Int] -> [([Pat], Clause)] -> CaseBuilder ([Name], [Name], [Name], [Clause])+argsToAlt _ [] = return ([], [], [], [])+argsToAlt inacc rs@((r, m) : rest) = do+    newVars <- getNewVars r+    let (accVars, inaccVars) = partitionAcc newVars+    return (newVars, accVars, inaccVars, addRs rs)   where+    -- Create names for new variables arising from the given patterns.+    getNewVars :: [Pat] -> CaseBuilder [Name]     getNewVars [] = return []     getNewVars ((PV n t) : ns) = do v <- getVar "e" +                                    nsv <- getNewVars ns++                                    -- Record the type of the variable.+                                    --+                                    -- It seems that the ordering is not important+                                    -- and we can put (v,t) always in front of "ntys"+                                    -- (the varName-type pairs seem to represent a mapping).+                                    --+                                    -- The code that reads this is currently+                                    -- commented out, anyway.                                     (cs, i, ntys) <- get                                     put (cs, i, (v, t) : ntys)-                                    nsv <- getNewVars ns+                                     return (v : nsv)-    getNewVars (PAny : ns) = do v <- getVar "i"-                                nsv <- getNewVars ns-                                return (v : nsv)-    getNewVars (PTyPat : ns) = do v <- getVar "t"-                                  nsv <- getNewVars ns-                                  return (v : nsv)-    getNewVars (_ : ns) = do v <- getVar "e"-                             nsv <- getNewVars ns-                             return (v : nsv)++    getNewVars (PAny   : ns) = (:) <$> getVar "i" <*> getNewVars ns+    getNewVars (PTyPat : ns) = (:) <$> getVar "t" <*> getNewVars ns+    getNewVars (_      : ns) = (:) <$> getVar "e" <*> getNewVars ns++    -- Partition a list of things into (accessible, inaccessible) things,+    -- according to the list of inaccessible indices.+    partitionAcc xs =+        ( [x | (i,x) <- zip [0..] xs, i `notElem` inacc]+        , [x | (i,x) <- zip [0..] xs, i    `elem` inacc]+        )+     addRs [] = []-    addRs ((r, (ps, res)) : rs) = ((r++ps, res) : addRs rs)+    addRs ((r, (ps, res)) : rs) = ((acc++ps++inacc, res) : addRs rs)+      where+        (acc, inacc) = partitionAcc r      uniq i (UN n) = MN i n     uniq i n = n -getVar :: String -> State CS Name+getVar :: String -> CaseBuilder Name getVar b = do (t, v, ntys) <- get; put (t, v+1, ntys); return (sMN v b) -groupCons :: [Clause] -> State CS [Group]+groupCons :: [Clause] -> CaseBuilder [Group] groupCons cs = gc [] cs   where     gc acc [] = return acc@@ -581,7 +619,7 @@ --         | otherwise = g : addConG con res gs     addConG con res (g : gs) = g : addConG con res gs -varRule :: [Name] -> [Clause] -> SC -> State CS SC+varRule :: [Name] -> [Clause] -> SC -> CaseBuilder SC varRule (v : vs) alts err =     do alts' <- mapM (repVar v) alts        match vs alts' err@@ -728,19 +766,20 @@     | otherwise = SucCase n' (substSC n repl sc) substAlt n repl (DefaultCase sc)     = DefaultCase (substSC n repl sc) +-- mkForce n' n t updates the tree t under the assumption that+-- n' = force n (so basically updating n to n') mkForce :: Name -> Name -> SC -> SC mkForce = mkForceSC   where     mkForceSC n arg (Case x alts) | x == arg-        = ProjCase (forceArg n) $ map (mkForceAlt n arg) alts+        = Case n $ map (mkForceAlt n arg) alts      mkForceSC n arg (Case x alts)         = Case x (map (mkForceAlt n arg) alts)      mkForceSC n arg (ProjCase t alts)-        = ProjCase (forceTm n arg t) $ map (mkForceAlt n arg) alts+        = ProjCase t $ map (mkForceAlt n arg) alts -    mkForceSC n arg (STerm t) = STerm (forceTm n arg t)     mkForceSC n arg c = c      mkForceAlt n arg (ConCase cn t args rhs)@@ -754,7 +793,5 @@     mkForceAlt n arg (DefaultCase rhs)         = DefaultCase (mkForceSC n arg rhs) -    forceTm n arg t = subst arg (forceArg n) t+    forceTm n arg t = subst n arg t -    forceArg n = App (App (App (P Ref (sUN "Force") Erased) Erased) Erased)-                    (P Bound n Erased)
src/Idris/Core/Elaborate.hs view
@@ -77,6 +77,7 @@                                      then MN (next+500) x                                      else MN (next+100) x                         NS (UN x) s -> MN (next+100) x+                        _ -> n                    return $! n'  setNextName :: Elab' aux ()@@ -371,12 +372,16 @@ rewrite :: Raw -> Elab' aux () rewrite tm = processTactic' (Rewrite tm) -induction :: Name -> Elab' aux ()-induction nm = processTactic' (Induction nm)+induction :: Raw -> Elab' aux ()+induction tm = processTactic' (Induction tm) +casetac :: Raw -> Elab' aux ()+casetac tm = processTactic' (CaseTac tm)+ equiv :: Raw -> Elab' aux () equiv tm = processTactic' (Equiv tm) +-- | Turn the current hole into a pattern variable with the provided name, made unique if MN patvar :: Name -> Elab' aux () patvar n = do env <- get_env               hs <- get_holes@@ -452,7 +457,7 @@              -> [(Name, Name)] -- ^ Accumulator for produced claims              -> [Name] -- ^ Hypotheses              -> Elab' aux [(Name, Name)] -- ^ The names of the arguments and their holes, resp.-    mkClaims (Bind n' (Pi t_in) sc) (i : is) claims hs =+    mkClaims (Bind n' (Pi t_in) sc) (i : is) claims hs =          do let t = rebind hs t_in            n <- getNameFrom (mkMN n') --            when (null claims) (start_unify n)@@ -509,8 +514,10 @@        put (ES (p { dontunify = dont, unified = (n, unify),                     notunified = notunify ++ notunified p }, a) s prev)        fillt (raw_apply fn (map (Var . snd) args))---        trace ("Goal " ++ show g ++ "\n" ++ show (fn,  imps, unify) ++ "\n" ++ show ptm) $-       end_unify+       ulog <- getUnifyLog+       g <- goal+       traceWhen ulog ("Goal " ++ show g ++ " -- when elaborating " ++ show fn) $+        end_unify        return $! (map (\(argName, argHole) -> (argName, updateUnify unify argHole)) args)   where updateUnify us n = case lookup n us of                                 Just (P _ t _) -> t
src/Idris/Core/Evaluate.hs view
@@ -8,7 +8,7 @@                 Context, initContext, ctxtAlist, uconstraints, next_tvar,                 addToCtxt, setAccess, setTotal, setMetaInformation, addCtxtDef, addTyDecl,                 addDatatype, addCasedef, simplifyCasedef, addOperator,-                lookupNames, lookupTyName, lookupTy, lookupP, lookupDef, lookupNameDef, lookupDefExact, lookupDefAcc, lookupVal,+                lookupNames, lookupTyName, lookupTyNameExact, lookupTy, lookupTyExact, lookupP, lookupDef, lookupNameDef, lookupDefExact, lookupDefAcc, lookupVal,                 mapDefCtxt,                 lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isDConName, isTConName, isConName, isFnName,                 Value(..), Quote(..), initEval, uniqueNameCtxt, uniqueBindersCtxt, definitions) where@@ -549,6 +549,12 @@         | n == n' = ceq ps x y     ceq ps (Bind n (Lam t) (App x (P Bound n' _))) y         | n == n' = ceq ps x y++    ceq ps (Bind n (PVar t) sc) y = ceq ps sc y+    ceq ps x (Bind n (PVar t) sc) = ceq ps x sc+    ceq ps (Bind n (PVTy t) sc) y = ceq ps sc y+    ceq ps x (Bind n (PVTy t) sc) = ceq ps x sc+     ceq ps (V x)      (V y)      = return (x == y)     ceq ps (V x)      (P _ y _)           | x >= 0 && length ps > x = return (fst (ps!!x) == y)@@ -788,7 +794,8 @@                   (TyDecl (DCon tag (arity ty')) ty, Public, Unchecked, EmptyMI) ctxt)  -- FIXME: Too many arguments! Refactor all these Bools.-addCasedef :: Name -> CaseInfo -> Bool -> Bool -> Bool -> Bool ->+addCasedef :: Name -> ErasureInfo -> CaseInfo ->+              Bool -> Bool -> Bool -> Bool ->               [Type] -> -- argument types               [Int] ->  -- inaccessible arguments               [Either Term (Term, Term)] ->@@ -797,17 +804,17 @@               [([Name], Term, Term)] -> -- inlined               [([Name], Term, Term)] -> -- run time               Type -> Context -> Context-addCasedef n ci@(CaseInfo alwaysInline tcdict)+addCasedef n ei ci@(CaseInfo alwaysInline tcdict)            tcase covering reflect asserted argtys inacc            ps_in ps_tot ps_inl ps_ct ps_rt ty uctxt     = let ctxt = definitions uctxt           access = case lookupDefAcc n False uctxt of                         [(_, acc)] -> acc                         _ -> Public-          ctxt' = case (simpleCase tcase covering reflect CompileTime emptyFC inacc argtys ps_tot,-                        simpleCase tcase covering reflect CompileTime emptyFC inacc argtys ps_ct,-                        simpleCase tcase covering reflect CompileTime emptyFC inacc argtys ps_inl,-                        simpleCase tcase covering reflect RunTime emptyFC inacc argtys ps_rt) of+          ctxt' = case (simpleCase tcase covering reflect CompileTime emptyFC inacc argtys ps_tot ei,+                        simpleCase tcase covering reflect CompileTime emptyFC inacc argtys ps_ct ei,+                        simpleCase tcase covering reflect CompileTime emptyFC inacc argtys ps_inl ei,+                        simpleCase tcase covering reflect RunTime emptyFC inacc argtys ps_rt ei) of                     (OK (CaseDef args_tot sc_tot _),                      OK (CaseDef args_ct sc_ct _),                      OK (CaseDef args_inl sc_inl _),@@ -825,8 +832,8 @@           uctxt { definitions = ctxt' }  -- simplify a definition for totality checking-simplifyCasedef :: Name -> Context -> Context-simplifyCasedef n uctxt+simplifyCasedef :: Name -> ErasureInfo -> Context -> Context+simplifyCasedef n ei uctxt    = let ctxt = definitions uctxt          ctxt' = case lookupCtxt n ctxt of               [(CaseOp ci ty atys [] ps _, acc, tot, metainf)] ->@@ -834,7 +841,7 @@               [(CaseOp ci ty atys ps_in ps cd, acc, tot, metainf)] ->                  let ps_in' = map simpl ps_in                      pdef = map debind ps_in' in-                     case simpleCase False True False CompileTime emptyFC [] atys pdef of+                     case simpleCase False True False CompileTime emptyFC [] atys pdef ei of                        OK (CaseDef args sc _) ->                           addDef n (CaseOp ci                                            ty atys ps_in' ps (cd { cases_totcheck = (args, sc) }),@@ -868,8 +875,9 @@                 = let ns = lookupCtxtName n (definitions ctxt) in                       map fst ns +-- | Get the list of pairs of fully-qualified names and their types that match some name lookupTyName :: Name -> Context -> [(Name, Type)]-lookupTyName n ctxt = do +lookupTyName n ctxt = do   (name, def) <- lookupCtxtName n (definitions ctxt)   ty <- case tfst def of                        (Function ty _) -> return ty@@ -878,9 +886,21 @@                        (CaseOp _ ty _ _ _ _) -> return ty   return (name, ty) +-- | Get the pair of a fully-qualified name and its type, if there is a unique one matching the name used as a key.+lookupTyNameExact :: Name -> Context -> Maybe (Name, Type)+lookupTyNameExact n ctxt = case lookupTyName n ctxt of+                             [x] -> Just x+                             _   -> Nothing +-- | Get the types that match some name lookupTy :: Name -> Context -> [Type] lookupTy n ctxt = map snd (lookupTyName n ctxt)++-- | Get the single type that matches some name precisely+lookupTyExact :: Name -> Context -> Maybe Type+lookupTyExact n ctxt = case lookupTy n ctxt of+                         [t] -> Just t+                         _   -> Nothing  isConName :: Name -> Context -> Bool isConName n ctxt = isTConName n ctxt || isDConName n ctxt
src/Idris/Core/ProofState.hs view
@@ -72,7 +72,8 @@             | LetBind Name Raw Raw             | ExpandLet Name Term             | Rewrite Raw-            | Induction Name+            | Induction Raw+            | CaseTac Raw             | Equiv Raw             | PatVar Name             | PatBind Name@@ -167,12 +168,16 @@                   ++ "\n" ++ show (pterm ps) ++ "\n\n"                  ) $        case match_unify ctxt env topx topy inj (holes ps) while of-            OK u -> do let (h, ns) = unified ps-                       put (ps { unified = (h, u ++ ns) })-                       return u-            Error e -> do put (ps { problems = (topx, topy, env, e, while, Match) :-                                                  problems ps })-                          return []+            OK u -> traceWhen (unifylog ps)+                        ("Matched " ++ show u) $+                     do let (h, ns) = unified ps+                        put (ps { unified = (h, u ++ ns) })+                        return u+            Error e -> traceWhen (unifylog ps)+                         ("No match " ++ show e) $+                        do put (ps { problems = (topx, topy, env, e, while, Match) :+                                                 problems ps })+                           return [] --       traceWhen (unifylog ps) --             ("Matched " ++ show (topx, topy) ++ " without " ++ show dont ++ --              "\nSolved: " ++ show u @@ -208,7 +213,8 @@                          "\nHoles: " ++ show (holes ps)                          ++ "\nInjective: " ++ show (injective ps)                          ++ "\n") $-                     lift $ unify ctxt env topx topy inj (holes ps) while+                     lift $ unify ctxt env topx topy inj (holes ps) +                                  (map fst (notunified ps)) while       let notu = filter (\ (n, t) -> case t of                                         P _ _ _ -> False                                         _ -> n `elem` dont) u@@ -228,9 +234,11 @@                                               (fails ++ problems ps)                                               (injective ps)                                               (holes ps)+                                              (map fst (notunified ps))            let (notu', probs_notu) = mergeNotunified env (notu ++ notunified ps)            traceWhen (unifylog ps)-            ("Now solved: " ++ show ns') $+            ("Now solved: " ++ show ns' +++             "\nNow problems: " ++ qshow (probs' ++ probs_notu)) $              put (ps { problems = probs' ++ probs_notu,                        unified = (h, ns'),                        injective = updateInj u (injective ps),@@ -537,10 +545,11 @@    = do ps <- get         let (uh, uns) = unified ps         case lookup x (notunified ps) of-            Just tm -> -- trace ("NEED MATCH: " ++ show (tm, val)) $+            Just tm -> -- trace ("NEED MATCH: " ++ show (x, tm, val) ++ "\nIN " ++ show (pterm ps)) $                          match_unify' ctxt env tm val             _ -> return []-        action (\ps -> ps { holes = holes ps \\ [x],+        action (\ps -> ps { holes = traceWhen (unifylog ps) ("Dropping hole " ++ show x) $+                                       holes ps \\ [x],                             solved = Just (x, val),                             notunified = updateNotunified [(x,val)]                                            (notunified ps),@@ -551,7 +560,7 @@    = do ps <- get         case findType x sc of              Just t -> lift $ tfail (CantInferType (show t))-             _ -> fail $ "Not a guess " ++ show h ++ "\n" ++ show (holes ps, pterm ps)+             _ -> lift $ tfail (IncompleteTerm h)    where findType x (Bind n (Let t v) sc)               = findType x v `mplus` findType x sc          findType x (Bind n t sc) @@ -604,7 +613,9 @@  patvar :: Name -> RunTactic patvar n ctxt env (Bind x (Hole t) sc) =-    do action (\ps -> ps { holes = holes ps \\ [x],+    do action (\ps -> ps { holes = traceWhen (unifylog ps) ("Dropping pattern hole " ++ show x) $+                                     holes ps \\ [x],+                           solved = Just (x, P Bound n t),                            notunified = updateNotunified [(x,P Bound n t)]                                           (notunified ps),                            injective = addInj n x (injective ps) })@@ -661,13 +672,16 @@                              b { binderTy = ty' } mkP lt l r x = x -induction :: Name -> RunTactic-induction nm ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do-  (tmv, tmt) <- lift $ check ctxt env (Var nm)+casetac :: Raw -> Bool -> RunTactic+casetac tm induction ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do+  (tmv, tmt) <- lift $ check ctxt env tm   let tmt' = normalise ctxt env tmt+  let (tacn, tacstr, tactt) = if induction+              then (ElimN, "an eliminator", "induction")+              else (CaseN, "a case function", "case analysis")   case unApply tmt' of     (P _ tnm _, tyargs) -> do-        case lookupTy (SN (ElimN tnm)) ctxt of+        case lookupTy (SN (tacn tnm)) ctxt of           [elimTy] -> do              param_pos <- case lookupMetaInformation tnm ctxt of                                [DataMI param_pos] -> return param_pos@@ -683,9 +697,14 @@              let indxargs = drop (length restargs - length indicies) $ restargs              let scr      = last $ tail args'              let indxnames = makeIndexNames indicies-             prop <- replaceIndicies indxnames indicies $ Bind nm (Lam tmt') t+             currentNames <- query $ allTTNames . pterm+             let tmnm = case tm of+                         Var nm -> uniqueNameCtxt ctxt nm currentNames+                         _ -> uniqueNameCtxt ctxt (sMN 0 "iv") currentNames+             let tmvar = P Bound tmnm tmt'+             prop <- replaceIndicies indxnames indicies $ Bind tmnm (Lam tmt') (mkP tmvar tmv tmvar t)              consargs' <- query (\ps -> map (flip (uniqueNameCtxt (context ps)) (holes ps ++ allTTNames (pterm ps)) *** uniqueBindersCtxt (context ps) (holes ps ++ allTTNames (pterm ps))) consargs)-             let res = flip (foldr substV) params $ (substV prop $ bindConsArgs consargs' (mkApp (P Ref (SN (ElimN tnm)) (TType (UVal 0)))+             let res = flip (foldr substV) params $ (substV prop $ bindConsArgs consargs' (mkApp (P Ref (SN (tacn tnm)) (TType (UVal 0)))                                                         (params ++ [prop] ++ map makeConsArg consargs' ++ indicies ++ [tmv])))              action (\ps -> ps {holes = holes ps \\ [x]})              mapM_ addConsHole (reverse consargs')@@ -693,9 +712,9 @@              (scv, sct) <- lift $ check ctxt env res'              let scv' = specialise ctxt env [] scv              return scv'-          [] -> fail $ "Induction needs an eliminator for " ++ show tnm-          xs -> fail $ "Multiple definitions found when searching for the eliminator of " ++ show tnm-    _ -> fail "Unkown type for induction"+          [] -> fail $ tactt ++ " needs " ++ tacstr ++ " for " ++ show tnm+          xs -> fail $ "Multiple definitions found when searching for " ++ tacstr ++ "of " ++ show tnm+    _ -> fail $ "Unkown type for " ++ if induction then "induction" else "case analysis"     where scname = sMN 0 "scarg"           makeConsArg (nm, ty) = P Bound nm ty           bindConsArgs ((nm, ty):args) v = Bind nm (Hole ty) $ bindConsArgs args v@@ -709,7 +728,7 @@           replaceIndicies idnms idxs prop = foldM (\t (idnm, idx) -> do (idxv, idxt) <- lift $ check ctxt env (forget idx)                                                                         let var = P Bound idnm idxt                                                                         return $ Bind idnm (Lam idxt) (mkP var idxv var t)) prop $ zip idnms idxs-induction tm ctxt env _ = do fail "Can't do induction here"+induction tm induction ctxt env _ = do fail "Can't do induction here"   equiv :: Raw -> RunTactic@@ -778,7 +797,8 @@     do ps <- get        let (_, ns) = unified ps        let unify = dropGiven (dontunify ps) ns (holes ps)-       action (\ps -> ps { holes = holes ps \\ map fst unify })+       action (\ps -> ps { holes = traceWhen (unifylog ps) ("Dropping holes " ++ show (map fst unify)) $+                                     holes ps \\ map fst unify })        action (\ps -> ps { pterm = updateSolved unify (pterm ps) })        return (updateSolved unify tm) @@ -841,8 +861,8 @@   mnu [] ns_acc ps_acc = (reverse ns_acc, reverse ps_acc)   mnu ((n, t):ns) ns_acc ps_acc       | Just t' <- lookup n ns, t /= t'-             = mnu ns ((n,t') : ns_acc)-                      ((t,t',env,Msg "", [],Unify) : ps_acc)+             = mnu ns ((n,t') : ns_acc) +                      ((t,t',env,CantUnify True t t' (Msg "") [] 0, [],Match) : ps_acc)       | otherwise = mnu ns ((n,t) : ns_acc) ps_acc  updateNotunified [] nu = nu@@ -851,10 +871,11 @@   up ((n, t) : nus) = let t' = updateSolved ns t in                           ((n, t') : up nus) -updateProblems :: Context -> [(Name, TT Name)] -> Fails -> [Name] -> [Name]+-- FIXME: Why not just pass the whole proof state?+updateProblems :: Context -> [(Name, TT Name)] -> Fails -> [Name] -> [Name] -> [Name]                -> ([(Name, TT Name)], Fails)-updateProblems ctxt [] ps inj holes = ([], ps)-updateProblems ctxt ns ps inj holes = up ns ps where+-- updateProblems ctxt [] ps inj holes = ([], ps)+updateProblems ctxt ns ps inj holes usupp = up ns ps where   up ns [] = (ns, [])   up ns ((x, y, env, err, while, um) : ps) =     let x' = updateSolved ns x@@ -862,7 +883,7 @@         err' = updateError ns err         env' = updateEnv ns env in --          trace ("Updating " ++ show (x',y')) $ -          case unify ctxt env' x' y' inj holes while of+          case unify ctxt env' x' y' inj holes usupp while of             OK (v, []) -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $                                up (ns ++ v) ps             e -> -- trace ("Failed " ++ show e) $@@ -903,12 +924,14 @@           ns' = map (\ (n, t) -> (n, updateSolved ns t)) ns           (ns'', probs') = updateProblems (context ps) ns' (problems ps)                                           (injective ps) (holes ps)+                                          (map fst (notunified ps))           tm' = updateSolved ns'' (pterm ps) in-          return (ps { pterm = tm',-                       unified = (h, []),-                       problems = probs',-                       notunified = updateNotunified ns'' (notunified ps),-                       holes = holes ps \\ map fst ns'' }, "")+          traceWhen (unifylog ps) ("Dropping holes: " ++ show (map fst ns'')) $+            return (ps { pterm = tm',+                         unified = (h, []),+                         problems = probs',+                         notunified = updateNotunified ns'' (notunified ps),+                         holes = holes ps \\ map fst ns'' }, "") processTactic UnifyAll ps     = let tm' = updateSolved (notunified ps) (pterm ps) in           return (ps { pterm = tm',@@ -924,11 +947,13 @@                                          (problems ps)                                          (injective ps)                                          (holes ps)+                                         (map fst (notunified ps))           pterm' = updateSolved ns' (pterm ps) in-      return (ps { pterm = pterm', solved = Nothing, problems = probs',-                   previous = Just ps, plog = "",-                   notunified = updateNotunified ns' (notunified ps),-                   holes = holes ps \\ (map fst ns') }, plog ps)+      traceWhen (unifylog ps) ("Dropping holes: " ++ show (map fst ns')) $+        return (ps { pterm = pterm', solved = Nothing, problems = probs',+                     previous = Just ps, plog = "",+                     notunified = updateNotunified ns' (notunified ps),+                     holes = holes ps \\ (map fst ns') }, plog ps) processTactic (MatchProblems all) ps     = let (ns', probs') = matchProblems all [] (context ps)                                             (problems ps)@@ -939,6 +964,7 @@                                            (injective ps)                                            (holes ps)           pterm' = updateSolved ns'' (pterm ps) in+       traceWhen (unifylog ps) ("Dropping holes: " ++ show (map fst ns'')) $         return (ps { pterm = pterm', solved = Nothing, problems = probs'',                    previous = Just ps, plog = "",                    notunified = updateNotunified ns'' (notunified ps),@@ -955,16 +981,18 @@                                                       [s] (problems ps')                                                       (injective ps')                                                       (holes ps')+                                                      (map fst (notunified ps))                                     _ -> ([], problems ps')                      -- rechecking problems may find more solutions, so                      -- apply them here                      let pterm'' = updateSolved ns' (pterm ps')-                     return (ps' { pterm = pterm'',-                                   solved = Nothing,-                                   problems = probs',-                                   notunified = updateNotunified ns' (notunified ps'),-                                   previous = Just ps, plog = "",-                                   holes = holes ps' \\ (map fst ns')}, plog ps')+                     traceWhen (unifylog ps) ("Dropping holes: " ++ show (map fst ns')) $+                       return (ps' { pterm = pterm'',+                                     solved = Nothing,+                                     problems = probs',+                                     notunified = updateNotunified ns' (notunified ps'),+                                     previous = Just ps, plog = "",+                                     holes = holes ps' \\ (map fst ns')}, plog ps')  process :: Tactic -> Name -> StateT TState TC () process EndUnify _@@ -991,7 +1019,8 @@          mktac (LetBind n t v)   = letbind n t v          mktac (ExpandLet n b)   = expandLet n b          mktac (Rewrite t)       = rewrite t-         mktac (Induction t)     = induction t+         mktac (Induction t)     = casetac t True+         mktac (CaseTac t)       = casetac t False          mktac (Equiv t)         = equiv t          mktac (PatVar n)        = patvar n          mktac (PatBind n)       = patbind n
src/Idris/Core/TT.hs view
@@ -99,6 +99,7 @@                       | AnnKeyword                       | AnnFC FC                       | AnnTextFmt TextFormatting+                      | AnnTerm [(Name, Bool)] (TT Name) -- ^ pprint bound vars, original term  -- | Used for error reflection data ErrorReportPart = TextPart String@@ -195,8 +196,9 @@ instance Show Err where     show (Msg s) = s     show (InternalMsg s) = "Internal error: " ++ show s-    show (CantUnify _ l r e sc i) = "CantUnify " ++ show l ++ " " ++ show r ++ " "-                                      ++ show e ++ " in " ++ show sc ++ " " ++ show i+    show (CantUnify rec l r e sc i) = "CantUnify " ++ show rec ++ " " +++                                         show l ++ " " ++ show r ++ " " +++                                         show e ++ " in " ++ show sc ++ " " ++ show i     show (CantSolveGoal g _) = "CantSolve " ++ show g     show (Inaccessible n) = show n ++ " is not an accessible pattern variable"     show (ProviderError msg) = "Type provider error: " ++ msg@@ -382,8 +384,8 @@  implicitable (NS n _) = implicitable n implicitable (UN xs) | T.null xs = False-                     | otherwise = isLower (T.head xs)-implicitable (MN _ _) = True+                     | otherwise = isLower (T.head xs) || T.head xs == '_'+implicitable (MN _ x) = not (tnull x) && thead x /= '_' implicitable _ = False  nsroot (NS n _) = n@@ -1263,8 +1265,11 @@ orderPats :: Term -> Term orderPats tm = op [] tm   where+    op [] (App f a) = App f (op [] a) -- for Infer terms+     op ps (Bind n (PVar t) sc) = op ((n, PVar t) : ps) sc     op ps (Bind n (Hole t) sc) = op ((n, Hole t) : ps) sc+    op ps (Bind n (Pi t)   sc) = op ((n, Pi t) : ps) sc     op ps sc = bindAll (sortP ps) sc      sortP ps = pick [] (reverse ps)@@ -1286,6 +1291,44 @@                       concatMap namesIn (map (binderTy . snd) ps))             = (n', t') : insert n t ps         | otherwise = (n,t):(n',t'):ps++-- Make sure all the pattern bindings are as far out as possible+liftPats :: Term -> Term+liftPats tm = let (tm', ps) = runState (getPats tm) [] in+                  orderPats $ bindPats (reverse ps) tm'+  where+    bindPats []          tm = tm+    bindPats ((n, t):ps) tm +         | n `notElem` map fst ps = Bind n (PVar t) (bindPats ps tm)+         | otherwise = bindPats ps tm++    getPats :: Term -> State [(Name, Type)] Term+    getPats (Bind n (PVar t) sc) = do ps <- get+                                      put ((n, t) : ps)+                                      getPats sc+    getPats (Bind n (Guess t v) sc) = do t' <- getPats t+                                         v' <- getPats v+                                         sc' <- getPats sc+                                         return (Bind n (Guess t' v') sc')+    getPats (Bind n (Let t v) sc) = do t' <- getPats t+                                       v' <- getPats v+                                       sc' <- getPats sc+                                       return (Bind n (Let t' v') sc')+    getPats (Bind n (Pi t) sc) = do t' <- getPats t+                                    sc' <- getPats sc+                                    return (Bind n (Pi t') sc')+    getPats (Bind n (Lam t) sc) = do t' <- getPats t+                                     sc' <- getPats sc+                                     return (Bind n (Lam t') sc')+    getPats (Bind n (Hole t) sc) = do t' <- getPats t+                                      sc' <- getPats sc+                                      return (Bind n (Hole t') sc')+++    getPats (App f a) = do f' <- getPats f+                           a' <- getPats a+                           return (App f' a')+    getPats t = return t  allTTNames :: Eq n => TT n -> [n] allTTNames = nub . allNamesIn
src/Idris/Core/Unify.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE PatternGuards #-} -module Idris.Core.Unify(match_unify, unify, Fails, FailContext(..), FailAt(..)) where+module Idris.Core.Unify(match_unify, unify, Fails, FailContext(..), FailAt(..),+                        unrecoverable) where  import Idris.Core.TT import Idris.Core.Evaluate@@ -30,6 +31,16 @@ type Injs = [(TT Name, TT Name, TT Name)] type Fails = [(TT Name, TT Name, Env, Err, [FailContext], FailAt)] +unrecoverable :: Fails -> Bool+unrecoverable = any bad +  where bad (_,_,_, err, _, _) = unrec err++        unrec (CantUnify r _ _ _ _ _) = not r+        unrec (At _ e) = unrec e+        unrec (Elaborating _ _ e) = unrec e+        unrec (ElaboratingArg _ _ _ e) = unrec e+        unrec _ = False+ data UInfo = UI Int Fails      deriving Show @@ -84,11 +95,11 @@            = let n' = uniqueName fn (map fst env) in                  checkCycle names (f, Bind n' (Lam t) x)  -    un names (P _ x _) tm-        | holeIn env x || x `elem` holes+    un names tx@(P _ x _) tm+        | tx /= 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+    un names tm ty@(P _ y _)+        | ty /= tm && holeIn env y || y `elem` holes             = do sc 1; checkCycle names (y, tm)     un bnames (V i) (P _ x _)         | length bnames > i, @@ -153,11 +164,13 @@         = 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) +--     substN n tm (var, sol) = (var, subst n tm sol)++    checkCycle ns p@(x, P _ x' _) | x == x' = return []     checkCycle ns p@(x, P _ _ _) = return [p]     checkCycle ns (x, tm)         | not (x `elem` freeNames tm) = checkScope ns (x, tm)@@ -229,9 +242,10 @@ hasv (Bind x b sc) = hasv (binderTy b) || hasv sc hasv _ = False -unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> [FailContext] ->+unify :: Context -> Env -> TT Name -> TT Name -> +         [Name] -> [Name] -> [Name] -> [FailContext] ->          TC ([(Name, TT Name)], Fails)-unify ctxt env topx topy inj holes from =+unify ctxt env topx topy inj holes usersupp from = --      traceWhen (hasv topx || hasv topy)  --           ("Unifying " ++ show topx ++ "\nAND\n" ++ show topy ++ "\n") $              -- don't bother if topx and topy are different at the head@@ -415,18 +429,12 @@      unApp fn bnames appx@(App fx ax) appy@(App fy ay)          | (injectiveApp fx && injectiveApp fy)-        || (injectiveApp fx && rigid appx && metavarApp appy && numArgs appx == numArgs appy)-        || (injectiveApp fy && rigid appy && metavarApp appx && numArgs appx == numArgs appy)         || (injectiveApp fx && metavarApp fy && ax == ay)         || (injectiveApp fy && metavarApp fx && ax == ay)          = do let (headx, _) = unApply fx               let (heady, _) = unApply fy               -- fail quickly if the heads are disjoint               checkHeads headx heady---              if True then -- (injective fx || injective fy || fx == fy) then---              if (injective fx && metavarApp appy) ||---                 (injective fy && metavarApp appx) ||---                 (injective fx && injective fy) || fx == fy               uplus                 (do hf <- un' True bnames fx fy                     let ax' = hnormalise hf ctxt env (substNames hf ax)@@ -490,7 +498,8 @@                                 _ -> False              metavar t = case t of-                             P _ x _ -> (x `elem` holes || holeIn env x)+                             P _ x _ -> (x `notElem` usersupp && +                                             (x `elem` holes || holeIn env x))                                           || globmetavar t                              _ -> False             pat t = case t of@@ -611,12 +620,13 @@ -- ASSUMPTION: inputs are in normal form  recoverable t@(App _ _) _-    | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy" = False+    | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy'" = False recoverable _ t@(App _ _)-    | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy" = False+    | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy'" = False recoverable (P (DCon _ _) x _) (P (DCon _ _) y _) = x == y recoverable (P (TCon _ _) x _) (P (TCon _ _) y _) = x == y recoverable (Constant _) (P (DCon _ _) y _) = False+recoverable (Constant x) (Constant y) = x == y recoverable (P (DCon _ _) x _) (Constant _) = False recoverable (Constant _) (P (TCon _ _) y _) = False recoverable (P (TCon _ _) x _) (Constant _) = False@@ -626,6 +636,8 @@ 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')+    | f == f' = recoverable a a'  recoverable (App f a) (App f' a')     = recoverable f f' -- && recoverable a a' recoverable f (Bind _ (Pi _) sc)
src/Idris/Coverage.hs view
@@ -360,9 +360,7 @@                             _ -> []          case mapMaybe (checkLHS i) (map (\ (_, l, r) -> l) pats) of             (failure : _) -> return failure-            _ -> if (Coinductive `elem` opts)-                      then calcProd i fc n pats-                      else checkSizeChange n+            _ -> checkSizeChange n   where     checkLHS i (P _ fn _)         = case lookupTotal fn (tt_ctxt i) of@@ -376,7 +374,8 @@     | n `elem` path = return (Partial (Mutual (n : path)))     | otherwise = do         t <- getTotality n-        updateContext (simplifyCasedef n)+        i <- getIState+        updateContext (simplifyCasedef n $ getErasureInfo i)         ctxt <- getContext         i <- getIState         let opts = case lookupCtxt n (idris_flags i) of@@ -470,7 +469,7 @@                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+                  logLvl 5 $ "SCG is: " ++ show newscg                   addToCG n ( cg { scg = newscg } )        [] -> logLvl 5 $ "Could not build SCG for " ++ show n ++ "\n"        x -> error $ "buildSCG: " ++ show (n, x)@@ -488,13 +487,14 @@ delazy' all t = t  data Guardedness = Toplevel | Unguarded | Guarded+  deriving Show  buildSCG' :: IState -> [(Term, Term)] -> [Name] -> [SCGEntry] buildSCG' ist pats args = nub $ concatMap scgPat pats where   scgPat (lhs, rhs) = let lhs' = delazy lhs                           rhs' = delazy rhs                           (f, pargs) = unApply (dePat lhs') in-                          findCalls Toplevel (dePat rhs') (patvars lhs') pargs+                            findCalls Toplevel (dePat rhs') (patvars lhs') pargs    findCalls guarded ap@(App f a) pvs pargs      -- under a call to "assert_total", don't do any checking, just believe@@ -505,10 +505,10 @@      -- immediate call, as long as the call is guarded.       -- Then check its arguments      | (P _ (UN del) _, [_,_,arg]) <- unApply ap,-       guarded <- Guarded,+       Guarded <- guarded,        del == txt "Delay"             = let (capp, args) = unApply arg in-                 concatMap (\x -> findCalls Toplevel x pvs pargs) args+                 concatMap (\x -> findCalls guarded x pvs pargs) args      | (P _ n _, args) <- unApply ap         = let nguarded = case guarded of                               Unguarded -> Unguarded
src/Idris/DSL.hs view
@@ -3,7 +3,6 @@ module Idris.DSL where  import Idris.AbsSyntax-import Paths_idris  import Idris.Core.TT import Idris.Core.Evaluate@@ -29,6 +28,10 @@         = let sc = PApp (fileFC "(dsl)") letb [pexp v, pexp (var dsl n tm 0)] in               expandDo dsl sc expandDo dsl (PLet n ty v tm) = PLet n (expandDo dsl ty) (expandDo dsl v) (expandDo dsl tm)+expandDo dsl (PPi p n ty tm)+    | Just pi <- dsl_pi dsl+        = let sc = PApp (fileFC "(dsl)") pi [pexp ty, pexp (var dsl n tm 0)] in+              expandDo dsl sc expandDo dsl (PPi p n ty tm) = PPi p n (expandDo dsl ty) (expandDo dsl tm) expandDo dsl (PApp fc t args) = PApp fc (expandDo dsl t)                                         (map (fmap (expandDo dsl)) args)@@ -36,7 +39,8 @@                                                 (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 (PEq fc lt rt l r) = PEq fc (expandDo dsl lt) (expandDo dsl rt)+                                         (expandDo dsl l) (expandDo dsl r) expandDo dsl (PPair fc p l r) = PPair fc p (expandDo dsl l) (expandDo dsl r) expandDo dsl (PDPair fc p l t r) = PDPair fc p (expandDo dsl l) (expandDo dsl t)                                                (expandDo dsl r)@@ -88,11 +92,14 @@         | Nothing <- dsl_let dsl             = PLet n (v' i ty) (v' i val) (v' i sc)         | otherwise = PLet n (v' i ty) (v' i val) (v' (i + 1) sc)-    v' i (PPi p n ty sc) = PPi p n (v' i ty) (v' i sc)+    v' i (PPi p n ty sc)+        | Nothing <- dsl_pi dsl+            = PPi p n (v' i ty) (v' i sc)+        | otherwise = PPi p n (v' i ty) (v' (i+1) sc)     v' i (PTyped l r)    = PTyped (v' i l) (v' i r)     v' i (PApp f x as)   = PApp f (v' i x) (fmap (fmap (v' i)) as)     v' i (PCase f t as)  = PCase f (v' i t) (fmap (pmap (v' i)) as)-    v' i (PEq f l r)     = PEq f (v' i l) (v' i r)+    v' i (PEq f lt rt l r) = PEq f (v' i lt) (v' i rt) (v' i l) (v' i r)     v' i (PPair f p l r) = PPair f p (v' i l) (v' i r)     v' i (PDPair f p l t r) = PDPair f p (v' i l) (v' i t) (v' i r)     v' i (PAlternative a as) = PAlternative a $ map (v' i) as
src/Idris/DeepSeq.hs view
@@ -119,6 +119,7 @@ instance NFData DataOpt where         rnf Codata = ()         rnf DefaultEliminator = ()+        rnf DefaultCaseFun = ()  instance (NFData t) => NFData (PDecl' t) where         rnf (PFix x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()@@ -204,7 +205,7 @@         rnf (PFalse x1) = rnf x1 `seq` ()         rnf (PRefl x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PResolveTC x1) = rnf x1 `seq` ()-        rnf (PEq x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()+        rnf (PEq x1 x2 x3 x4 x5) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()         rnf (PRewrite x1 x2 x3 x4)           = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()         rnf (PPair x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()@@ -236,6 +237,7 @@         rnf (Refine x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (Rewrite x1) = rnf x1 `seq` ()         rnf (Induction x1) = rnf x1 `seq` ()+        rnf (CaseTac x1) = rnf x1 `seq` ()         rnf (Equiv x1) = rnf x1 `seq` ()         rnf (MatchRefine x1) = rnf x1 `seq` ()         rnf (LetTac x1 x2) = rnf x1 `seq` rnf x2 `seq` ()@@ -291,12 +293,13 @@         rnf (TI x1 x2 x3 x4 x5) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()  instance (NFData t) => NFData (DSL' t) where-        rnf (DSL x1 x2 x3 x4 x5 x6 x7 x8 x9)+        rnf (DSL x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)           = rnf x1 `seq`               rnf x2 `seq`                 rnf x3 `seq`                   rnf x4 `seq`-                    rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` ()+                    rnf x5 `seq`+                      rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` ()  instance NFData SynContext where         rnf PatternSyntax = ()@@ -317,13 +320,14 @@         rnf (UImplicit x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (UConstraint x1 x2) = rnf x1 `seq` rnf x2 `seq` () -  instance NFData SyntaxInfo where-        rnf (Syn x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)+        rnf (Syn x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)           = rnf x1 `seq`               rnf x2 `seq`                 rnf x3 `seq`-                  rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` ()+                  rnf x4 `seq`+                    rnf x5 `seq`+                      rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` rnf x11 `seq` ()
src/Idris/Delaborate.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE PatternGuards #-}-module Idris.Delaborate (bugaddr, delab, delab', delabMV, delabTy, delabTy', fancifyAnnots, pprintErr) where+module Idris.Delaborate (bugaddr, delab, delab', delabMV, delabTy, delabTy', fancifyAnnots, pprintDelab, pprintDelabTy, pprintErr) where  -- Convert core TT back into high level syntax, primarily for display -- purposes.@@ -12,8 +12,9 @@ import Idris.Docstrings (overview, renderDocstring) import Idris.ErrReverse -import Data.List (intersperse)+import Data.List (intersperse, nub) import qualified Data.Text as T+import Control.Monad.State  import Debug.Trace @@ -96,9 +97,10 @@          | n == sUN "Sigma"                = PDPair un IsType (PRef un x) (de env [] ty)                            (de ((x,x):env) [] (instantiate (P Bound x ty) r))-    deFn env (P _ n _) [_,_,l,r]+    deFn env (P _ n _) [lt,rt,l,r]          | n == pairCon = PPair un IsTerm (de env [] l) (de env [] r)-         | n == eqTy    = PEq un (de env [] l) (de env [] r)+         | n == eqTy    = PEq un (de env [] lt) (de env [] rt)+                                 (de env [] l) (de env [] r)          | n == sUN "Sg_intro" = PDPair un IsTerm (de env [] l) Placeholder                                            (de env [] r)     deFn env f@(P _ n _) args @@ -135,6 +137,20 @@ indented :: Doc a -> Doc a indented = nest errorIndent . (line <>) +-- | Pretty-print a core term using delaboration+pprintDelab :: IState -> Term -> Doc OutputAnnotation+pprintDelab ist tm = annotate (AnnTerm [] tm)+                              (prettyIst ist (delab ist tm))++-- | Pretty-print the type of some name+pprintDelabTy :: IState -> Name -> Doc OutputAnnotation+pprintDelabTy i n+    = case lookupTy n (tt_ctxt i) of+           (ty:_) -> annotate (AnnTerm [] ty) . prettyIst i $+                     case lookupCtxt n (idris_implicits i) of+                         (imps:_) -> delabTy' i imps ty False False+                         _ -> delabTy' i [] ty False False+ pprintTerm :: IState -> PTerm -> Doc OutputAnnotation pprintTerm ist = pprintTerm' ist [] @@ -150,56 +166,62 @@          text "This is probably a bug, or a missing error message.",          text ("Please consider reporting at " ++ bugaddr)        ]-pprintErr' i (CantUnify _ x y e sc s) =-  text "Can't unify" <> indented (pprintTerm' i (map (\ (n, b) -> (n, False)) sc) (delab i x)) <$>-  text "with" <> indented (pprintTerm' i (map (\ (n, b) -> (n, False)) sc) (delab i y)) <>-  case e of-    Msg "" -> empty-    _ -> line <> line <> text "Specifically:" <>-         indented (pprintErr' i e) <>-         if (opt_errContext (idris_options i)) then showSc i sc else empty+pprintErr' i (CantUnify _ x_in y_in e sc s) =+  let (x_ns, y_ns, nms) = renameMNs x_in y_in+      (x, y) = addImplicitDiffs (delab i x_ns) (delab i y_ns) in+    text "Can't unify" <> indented (annTm x_ns +                      (pprintTerm' i (map (\ (n, b) -> (n, False)) sc+                                        ++ zip nms (repeat False)) x)) <$>+    text "with" <> indented (annTm y_ns +                      (pprintTerm' i (map (\ (n, b) -> (n, False)) sc+                                        ++ zip nms (repeat False)) y)) <>+    case e of+      Msg "" -> empty+      _ -> line <> line <> text "Specifically:" <>+           indented (pprintErr' i e) <>+           if (opt_errContext (idris_options i)) then showSc i sc else empty pprintErr' i (CantConvert x y env) =   text "Can't convert" <>-  indented (pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delab i x)) <$>+  indented (annTm x (pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delab i x))) <$>   text "with" <>-  indented (pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delab i y)) <>+  indented (annTm y (pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delab i y))) <>   if (opt_errContext (idris_options i)) then line <> showSc i env else empty pprintErr' i (CantSolveGoal x env) =   text "Can't solve goal " <>-  indented (pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delab i x)) <>+  indented (annTm x (pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delab i x))) <>   if (opt_errContext (idris_options i)) then line <> showSc i env else empty pprintErr' i (UnifyScope n out tm env) =   text "Can't unify" <> indented (annName n) <+>-  text "with" <> indented (pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delab i tm)) <+>-  text "as" <> indented (annName out) <> text "is not in scope" <>+  text "with" <> indented (annTm tm (pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delab i tm))) <+>+ text "as" <> indented (annName out) <> text "is not in scope" <>   if (opt_errContext (idris_options i)) then line <> showSc i env else empty pprintErr' i (CantInferType t) = text "Can't infer type for" <+> text t pprintErr' i (NonFunctionType f ty) =-  pprintTerm i (delab i f) <+>+  annTm f (pprintTerm i (delab i f)) <+>   text "does not have a function type" <+>   parens (pprintTerm i (delab i ty)) pprintErr' i (NotEquality tm ty) =-  pprintTerm i (delab i tm) <+>+  annTm tm (pprintTerm i (delab i tm)) <+>   text "does not have an equality type" <+>-  parens (pprintTerm i (delab i ty))+  annTm ty (parens (pprintTerm i (delab i ty))) pprintErr' i (TooManyArguments f) = text "Too many arguments for" <+> annName f pprintErr' i (CantIntroduce ty) =-  text "Can't use lambda here: type is" <+> pprintTerm i (delab i ty)+  text "Can't use lambda here: type is" <+> annTm ty (pprintTerm i (delab i ty)) pprintErr' i (InfiniteUnify x tm env) =   text "Unifying" <+> annName' x (showbasic x) <+> text "and" <+>-  pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delab i tm) <+>+  annTm tm (pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delab i tm)) <+>   text "would lead to infinite value" <>   if (opt_errContext (idris_options i)) then line <> showSc i env else empty pprintErr' i (NotInjective p x y) =-  text "Can't verify injectivity of" <+> pprintTerm i (delab i p) <+>-  text " when unifying" <+> pprintTerm i (delab i x) <+> text "and" <+>-  pprintTerm i (delab i y)+  text "Can't verify injectivity of" <+> annTm p (pprintTerm i (delab i p)) <+>+  text " when unifying" <+> annTm x (pprintTerm i (delab i x)) <+> text "and" <+>+  annTm y (pprintTerm i (delab i y)) pprintErr' i (CantResolve c) = text "Can't resolve type class" <+> pprintTerm i (delab i c) pprintErr' i (CantResolveAlts as) = text "Can't disambiguate name:" <+>                                     align (cat (punctuate (comma <> space) (map (fmap (fancifyAnnots i) . annName) as))) pprintErr' i (NoTypeDecl n) = text "No type declaration for" <+> annName n pprintErr' i (NoSuchVariable n) = text "No such variable" <+> annName n-pprintErr' i (IncompleteTerm t) = text "Incomplete term" <+> pprintTerm i (delab i t)+pprintErr' i (IncompleteTerm t) = text "Incomplete term" <+> annTm t (pprintTerm i (delab i t)) pprintErr' i UniverseError = text "Universe inconsistency" pprintErr' i ProgramLineComment = text "Program line next to comment" pprintErr' i (Inaccessible n) = annName n <+> text "is not an accessible pattern variable"@@ -208,7 +230,7 @@ pprintErr' i (AlreadyDefined n) = annName n<+>                                   text "is already defined" pprintErr' i (ProofSearchFail e) = pprintErr' i e-pprintErr' i (NoRewriting tm) = text "rewrite did not change type" <+> pprintTerm i (delab i tm)+pprintErr' i (NoRewriting tm) = text "rewrite did not change type" <+> annTm tm (pprintTerm i (delab i tm)) pprintErr' i (At f e) = annotate (AnnFC f) (text (show f)) <> colon <> pprintErr' i e pprintErr' i (Elaborating s n e) = text "When elaborating" <+> text s <>                                    annName' n (showqual i n) <> colon <$>@@ -248,6 +270,117 @@   indented (pprintErr' i err) <>   text ("This is probably a bug. Please consider reporting it at " ++ bugaddr) +-- Make sure the machine invented names are shown helpfully to the user, so+-- that any names which differ internally also differ visibly+-- FIXME: I can't actually contrive an error to test this! Will revisit later...+renameMNs :: Term -> Term -> (Term, Term, [Name])+renameMNs x y = let ns = nub $ allTTNames x ++ allTTNames y+                    newnames = evalState (getRenames [] ns) 1 in+                      (rename newnames x, rename newnames y, map snd newnames)+  where+    getRenames :: [(Name, Name)] -> [Name] -> State Int [(Name, Name)]+    getRenames acc [] = return acc+    getRenames acc (n@(MN i x) : xs) | UN x `elem` xs+         = do idx <- get+              put (idx + 1)+              let x' = sUN (str x ++ show idx)+              getRenames ((n, x') : acc) xs+    getRenames acc (x : xs) = getRenames acc xs++    rename :: [(Name, Name)] -> Term -> Term+    rename ns (P nt x t) | Just x' <- lookup x ns = P nt x' t+    rename ns (App f a) = App (rename ns f) (rename ns a)+    rename ns (Bind x b sc) +           = let b' = fmap (rename ns) b+                 sc' = rename ns sc in+                 case lookup x ns of+                      Just x' -> Bind x' b' sc'+                      Nothing -> Bind x b' sc'+    rename ns x = x++-- If the two terms only differ in their implicits, mark the implicits which+-- differ as AlwaysShow so that they appear in errors+addImplicitDiffs :: PTerm -> PTerm -> (PTerm, PTerm)+addImplicitDiffs x y +    = if (x `expLike` y) then addI x y else (x, y)+  where+    addI :: PTerm -> PTerm -> (PTerm, PTerm)+    addI (PApp fc f as) (PApp gc g bs) +         = let (as', bs') = addShows as bs in+               (PApp fc f as', PApp gc g bs')+       where addShows [] [] = ([], [])+             addShows (a:as) (b:bs) +                = let (as', bs') = addShows as bs+                      (a', b') = addI (getTm a) (getTm b) in+                      if (not (a' `expLike` b'))+                         then (a { argopts = AlwaysShow : argopts a,+                                   getTm = a' } : as',+                               b { argopts = AlwaysShow : argopts b,+                                   getTm = b' } : bs')+                         else (a { getTm = a' } : as', +                               b { getTm = b' } : bs')+    addI (PLam n a b) (PLam n' c d) +         = let (a', c') = addI a c+               (b', d') = addI b d in+               (PLam n a' b', PLam n' c' d')+    addI (PPi p n a b) (PPi p' n' c d) +         = let (a', c') = addI a c+               (b', d') = addI b d in+               (PPi p n a' b', PPi p' n' c' d')+    addI (PRefl fc a) (PRefl fc' b) +         = let (a', b') = addI a b in+               (PRefl fc a', PRefl fc' b')+    addI (PEq fc at bt a b) (PEq fc' ct dt c d) +         | trace (show (at,bt)) False = undefined+         | at `expLike` ct && bt `expLike` dt+         = let (a', c') = addI a c+               (b', d') = addI b d in+               (PEq fc at bt a' b', PEq fc' ct dt c' d')+         | otherwise+         = let (at', ct') = addI at ct+               (bt', dt') = addI bt dt+               (a', c') = addI a c+               (b', d') = addI b d +               showa = if at `expLike` ct then [] else [AlwaysShow] +               showb = if bt `expLike` dt then [] else [AlwaysShow] in+               (PApp fc (PRef fc eqTy) [(pimp (sUN "A") at' True)+                                               { argopts = showa },+                                        (pimp (sUN "B") bt' True)+                                               { argopts = showb },+                                        pexp a', pexp b'],+                PApp fc (PRef fc eqTy) [(pimp (sUN "A") ct' True)+                                               { argopts = showa },+                                        (pimp (sUN "B") dt' True)+                                               { argopts = showb },+                                        pexp c', pexp d'])+                                                +    addI (PPair fc pi a b) (PPair fc' pi' c d) +         = let (a', c') = addI a c+               (b', d') = addI b d in+               (PPair fc pi a' b', PPair fc' pi' c' d')+    addI (PDPair fc pi a t b) (PDPair fc' pi' c u d) +         = let (a', c') = addI a c+               (t', u') = addI t u+               (b', d') = addI b d in+               (PDPair fc pi a' t' b', PDPair fc' pi' c' u' d')+    addI x y = (x, y)++    -- Just the ones which appear desugared in errors+    expLike (PRef _ n) (PRef _ n') = n == n'+    expLike (PApp _ f as) (PApp _ f' as')+        = expLike f f' && length as == length as' &&+          and (zipWith expLike (getExps as) (getExps as'))+    expLike (PPi _ n s t) (PPi _ n' s' t') +        = n == n' && expLike s s' && expLike t t'+    expLike (PLam n s t) (PLam n' s' t') +        = n == n' && expLike s s' && expLike t t'+    expLike (PPair _ _ x y) (PPair _ _ x' y') = expLike x x' && expLike y y'+    expLike (PDPair _ _ x _ y) (PDPair _ _ x' _ y') = expLike x x' && expLike y y'+    expLike (PEq _ xt yt x y) (PEq _ xt' yt' x' y') +         = expLike x x' && expLike y y'+    expLike (PRefl _ x) (PRefl _ x') = expLike x x'+    expLike x y = x == y+ isUN :: Name -> Bool isUN (UN n) = not $ T.isPrefixOf (T.pack "__") n -- TODO figure out why MNs are getting rewritte to UNs for top-level pattern-matching functions isUN (NS n _) = isUN n@@ -258,6 +391,9 @@  annName' :: Name -> String -> Doc OutputAnnotation annName' n str = annotate (AnnName n Nothing Nothing Nothing) (text str)++annTm :: Term -> Doc OutputAnnotation -> Doc OutputAnnotation+annTm tm = annotate (AnnTerm [] tm)  fancifyAnnots :: IState -> OutputAnnotation -> OutputAnnotation fancifyAnnots ist annot@(AnnName n _ _ _) =
src/Idris/Docs.hs view
@@ -37,7 +37,7 @@  pprintFD :: IState -> FunDoc -> Doc OutputAnnotation pprintFD ist (FD n doc args ty f)-    = nest 4 (prettyName (ppopt_impl ppo) [] n <+> colon <+>+    = nest 4 (prettyName True (ppopt_impl ppo) [] n <+> colon <+>               pprintPTerm ppo [] [ n | (n@(UN n'),_,_,_) <- args                                      , not (T.isPrefixOf (T.pack "__") n') ] infixes ty <$>               renderDocstring doc <$>@@ -79,7 +79,7 @@              else nest 4 (text "Constructors:" <> line <>                           vsep (map (pprintFD ist) args)) pprintDocs ist (ClassDoc n doc meths params instances superclasses)-           = nest 4 (text "Type class" <+> prettyName (ppopt_impl ppo) [] n <>+           = nest 4 (text "Type class" <+> prettyName True (ppopt_impl ppo) [] n <>                      if nullDocstring doc then empty else line <> renderDocstring doc)              <> line <$>              nest 4 (text "Parameters:" <$> prettyParameters)@@ -131,8 +131,8 @@     (subclasses, instances') = partition isSubclass instances      prettyParameters = if any (isJust . snd) params-                       then vsep (map (\(nm,md) -> prettyName False params' nm <+> maybe empty showDoc md) params)-                       else hsep (punctuate comma (map (prettyName False params' . fst) params))+                       then vsep (map (\(nm,md) -> prettyName True False params' nm <+> maybe empty showDoc md) params)+                       else hsep (punctuate comma (map (prettyName True False params' . fst) params))  getDocs :: Name -> Idris Docs getDocs n
src/Idris/ElabDecls.hs view
@@ -19,7 +19,6 @@ import Idris.DeepSeq import Idris.Output (iputStrLn, pshow, iWarn) import IRTS.Lang-import Paths_idris  import Idris.Core.TT import Idris.Core.Elaborate hiding (Tactic(..))@@ -72,33 +71,28 @@ --                     mapM (\(n, (i, top, t)) -> do (t', _) <- recheckC fc [] t --                                                   return (n, (i, top, t'))) ns --- | Elaborate a top-level type declaration - for example, "foo : Int -> Int".-elabType :: ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] ->-            FC -> FnOpts -> Name -> PTerm -> Idris Type-elabType = elabType' False--elabType' :: Bool -> -- normalise it-             ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] ->-             FC -> FnOpts -> Name -> PTerm -> Idris Type-elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params info) ty_in-                                                       n  = liftname info n_in in    -}-      do checkUndefined fc n+buildType :: ElabInfo -> SyntaxInfo -> FC -> FnOpts -> Name -> PTerm -> +             Idris (Type, PTerm, [(Int, Name)])+buildType info syn fc opts n ty' = do          ctxt <- getContext          i <- getIState -         logLvl 5 $ show n ++ " pre-type " ++ showTmImpls ty'+         logLvl 3 $ show n ++ " pre-type " ++ showTmImpls ty'          ty' <- addUsingConstraints syn fc ty'-         ty' <- implicit info syn n ty'+         ty' <- addUsingImpls syn n fc ty'+         let ty = addImpl i ty' -         let ty    = addImpl i ty'-             inacc = inaccessibleArgs 0 ty-         logLvl 5 $ show n ++ " type pre-addimpl " ++ showTmImpls ty'-         logLvl 5 $ show n ++ " type " ++ showTmImpls ty-         logLvl 3 $ show n ++ ": inaccessible arguments: " ++ show inacc+         logLvl 3 $ show n ++ " type pre-addimpl " ++ showTmImpls ty'+         logLvl 3 $ show n ++ " type " ++ show (using syn) ++ "\n" ++ showTmImpls ty -         ((tyT, defer, is), log) <-+         ((tyT', defer, is), log) <-                tclift $ elaborate ctxt n (TType (UVal 0)) []-                        (errAt "type of " n (erun fc (build i info False [] n ty)))+                        (errAt "type of " n (erun fc (build i info ETyDecl [] n ty)))++         let tyT = patToImp tyT'++         logLvl 3 $ show ty ++ "\nElaborated: " ++ show tyT'+          ds <- checkAddDef True False fc defer          -- if the type is not complete, note that we'll need to infer          -- things later (for solving metavariables)@@ -108,19 +102,52 @@          ctxt <- getContext          logLvl 5 $ "Rechecking"          logLvl 6 $ show tyT+         logLvl 10 $ "Elaborated to " ++ showEnvDbg [] tyT          (cty, _)   <- recheckC fc [] tyT-         addStatics n cty ty'-         logLvl 6 $ "Elaborated to " ++ showEnvDbg [] tyT-         logLvl 2 $ "Rechecked to " ++ show cty++         -- record the implicit and inaccessible arguments+         i <- getIState+         let (inaccData, impls) = unzip $ getUnboundImplicits i cty ty+         let inacc = inaccessibleImps 0 cty inaccData+         logLvl 3 $ show n ++ ": inaccessible arguments: " ++ show inacc++         putIState $ i { idris_implicits = addDef n impls (idris_implicits i) }+         logLvl 3 ("Implicit " ++ show n ++ " " ++ show impls)+         addIBC (IBCImp n)++         return (cty, ty, inacc)+  where+    patToImp (Bind n (PVar t) sc) = Bind n (Pi t) (patToImp sc)+    patToImp (Bind n b sc) = Bind n b (patToImp sc)+    patToImp t = t+++-- | Elaborate a top-level type declaration - for example, "foo : Int -> Int".+elabType :: ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] ->+            FC -> FnOpts -> Name -> PTerm -> Idris Type+elabType = elabType' False++elabType' :: Bool -> -- normalise it+             ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] ->+             FC -> FnOpts -> Name -> PTerm -> Idris Type+elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params info) ty_in+                                                       n  = liftname info n_in in    -}+      do checkUndefined fc n+         (cty, ty, inacc) <- buildType info syn fc opts n ty'++         addStatics n cty ty          let nty = cty -- normalise ctxt [] cty          -- if the return type is something coinductive, freeze the definition+         ctxt <- getContext          let nty' = normalise ctxt [] nty+         logLvl 2 $ "Rechecked to " ++ show nty'           -- Add normalised type to internals+         i <- getIState          rep <- useREPL          when rep $ do-           addInternalApp (fc_fname fc) (fst . fc_start $ fc) (mergeTy ty' (delab i nty')) -- TODO: Should use span instead of line and filename?-           addIBC (IBCLineApp (fc_fname fc) (fst . fc_start $ fc) (mergeTy ty' (delab i nty')))+           addInternalApp (fc_fname fc) (fst . fc_start $ fc) ty' -- (mergeTy ty' (delab i nty')) -- TODO: Should use span instead of line and filename?+           addIBC (IBCLineApp (fc_fname fc) (fst . fc_start $ fc) ty') -- (mergeTy ty' (delab i nty')))           let (t, _) = unApply (getRetTy nty')          let corec = case t of@@ -164,7 +191,7 @@     -- for making an internalapp, we only want the explicit ones, and don't     -- want the parameters, so just take the arguments which correspond to the     -- user declared explicit ones-    mergeTy (PPi e n ty sc) (PPi e' _ _ sc')+    mergeTy (PPi e n ty sc) (PPi e' n' _ sc')          | e == e' = PPi e n ty (mergeTy sc sc')          | otherwise = mergeTy sc sc'     mergeTy _ sc = sc@@ -185,6 +212,14 @@         , ns4 == map txt ["Errors","Reflection","Language"] = True     tyIsHandler _                                           = False +-- Get the list of (index, name) of inaccessible arguments from an elaborated+-- type+inaccessibleImps :: Int -> Type -> [Bool] -> [(Int, Name)]+inaccessibleImps i (Bind n (Pi t) sc) (inacc : ins)+    | inacc = (i, n) : inaccessibleImps (i + 1) sc ins+    | otherwise = inaccessibleImps (i + 1) sc ins+inaccessibleImps _ _ _ = []+ -- Get the list of (index, name) of inaccessible arguments from the type. inaccessibleArgs :: Int -> PTerm -> [(Int, Name)] inaccessibleArgs i (PPi (Imp _ _ _) n Placeholder t)@@ -211,42 +246,20 @@     = do let codata = Codata `elem` opts          iLOG (show (fc, doc))          checkUndefined fc n-         ctxt <- getContext-         i <- getIState-         -- TODO think: something more in info?-         t_in <- implicit info syn n t_in-         let t = addImpl i t_in-         ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) []-                                            (erun fc (build i info False [] n t))-         def' <- checkDef fc defer-         let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) def'-         addDeferredTyCon def''+         (cty, t, inacc) <- buildType info syn fc [] n t_in+          addIBC (IBCDef n)-         mapM_ (elabCaseBlock info []) is-         (cty, _)  <- recheckC fc [] t'-         logLvl 2 $ "---> " ++ show cty          updateContext (addTyDecl n (TCon 0 0) cty) -- temporary, to check cons  elabData info syn doc argDocs fc opts (PDatadecl n t_in dcons)     = do let codata = Codata `elem` opts          iLOG (show fc)          undef <- isUndefined fc n-         ctxt <- getContext-         i <- getIState-         t_in <- implicit info syn n t_in-         let t = addImpl i t_in-         ((t', defer, is), log) <--             tclift $ elaborate ctxt n (TType (UVal 0)) []-                  (errAt "data declaration " n (erun fc (build i info False [] n t)))-         def' <- checkDef fc defer-         let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) def'+         (cty, t, inacc) <- buildType info syn fc [] n t_in          -- if n is defined already, make sure it is just a type declaration          -- with the same type we've just elaborated-         checkDefinedAs fc n t' (tt_ctxt i)-         addDeferredTyCon def''-         mapM_ (elabCaseBlock info []) is-         (cty, _)  <- recheckC fc [] t'-         logLvl 2 $ "---> " ++ show cty+         i <- getIState+         checkDefinedAs fc n cty (tt_ctxt i)          -- temporary, to check cons          when undef $ updateContext (addTyDecl n (TCon 0 0) cty)          let cnameinfo = cinfo info (map cname dcons)@@ -263,7 +276,7 @@                                              (idris_datatypes i) })          addIBC (IBCDef n)          addIBC (IBCData n)-         checkDocs fc argDocs t_in+         checkDocs fc argDocs t          addDocStr n doc argDocs          addIBC (IBCDoc n)          let metainf = DataMI params@@ -283,7 +296,10 @@           -- create an eliminator          when (DefaultEliminator `elem` opts) $-            evalStateT (elabEliminator params n t dcons info) Map.empty+            evalStateT (elabCaseFun True params n t dcons info) Map.empty+         -- create a case function+         when (DefaultCaseFun `elem` opts) $+            evalStateT (elabCaseFun False params n t dcons info) Map.empty   where         setDetaggable :: Name -> Idris ()         setDetaggable n = do@@ -366,14 +382,66 @@                        liftname = id -- Is this appropriate?                      } +-- FIXME: 'forcenames' is an almighty hack! Need a better way of+-- erasing non-forceable things+-- ^^^+-- TODO: the above is a comment from the past;+-- forcenames is probably no longer needed+elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->+           (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name]) -> Idris (Name, Type)+elabCon info syn tn codata (doc, argDocs, n, t_in, fc, forcenames)+    = do checkUndefined fc n+         (cty, t, inacc) <- buildType info syn fc [] n (if codata then mkLazy t_in else t_in)+         ctxt <- getContext+         let cty' = normalise ctxt [] cty++         logLvl 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ show t+         logLvl 5 $ "Inaccessible args: " ++ show inacc+         logLvl 2 $ "---> " ++ show n ++ " : " ++ show cty'++         addIBC (IBCDef n)+         checkDocs fc argDocs t+         addDocStr n doc argDocs+         addIBC (IBCDoc n)+         fputState (opt_inaccessible . ist_optimisation n) inacc+         addIBC (IBCOpt n)+         return (n, cty')+  where+    tyIs (Bind n b sc) = tyIs sc+    tyIs t | (P _ n' _, _) <- unApply t+        = if n' /= tn then tclift $ tfail (At fc (Msg (show n' ++ " is not " ++ show tn)))+             else return ()+    tyIs t = tclift $ tfail (At fc (Msg (show t ++ " is not " ++ show tn)))++    mkLazy (PPi pl n ty sc) +        = let ty' = if getTyName ty+                       then PApp fc (PRef fc (sUN "Lazy'"))+                            [pexp (PRef fc (sUN "LazyCodata")),+                             pexp ty]+                       else ty in+              PPi pl n ty' (mkLazy sc)+    mkLazy t = t++    getTyName (PApp _ (PRef _ n) _) = n == nsroot tn+    getTyName (PRef _ n) = n == nsroot tn+    getTyName _ = False+++    getNamePos :: Int -> PTerm -> Name -> Maybe Int+    getNamePos i (PPi _ n _ sc) x | n == x = Just i+                                  | otherwise = getNamePos (i + 1) sc x+    getNamePos _ _ _ = Nothing+ type EliminatorState = StateT (Map.Map String Int) Idris  -- TODO: Rewrite everything to use idris_implicits instead of manual splitting (or in TT)-elabEliminator :: [Int] -> Name -> PTerm ->+-- FIXME: Many things have name starting with elim internally since this was the only purpose in the first edition of the function+-- rename to caseFun to match updated intend+elabCaseFun :: Bool -> [Int] -> Name -> PTerm ->                   [(Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name])] ->                   ElabInfo -> EliminatorState ()-elabEliminator paramPos n ty cons info = do-  elimLog $ "Elaborating eliminator"+elabCaseFun ind paramPos n ty cons info = do+  elimLog $ "Elaborating case function"   put (Map.fromList $ zip (concatMap (\(_, p, _, ty, _, _) -> (map show $ boundNamesIn ty) ++ map (show . fst) p) cons ++ (map show $ boundNamesIn ty)) (repeat 0))   let (cnstrs, _) = splitPi ty   let (splittedTy@(pms, idxs)) = splitPms cnstrs@@ -381,7 +449,8 @@   motiveIdxs    <- namePis False idxs   let motive = mkMotive n paramPos generalParams motiveIdxs   consTerms <- mapM (\(c@(_, _, cnm, _, _, _)) -> do-                               name <- freshName $ "elim_" ++ simpleName cnm+                               let casefunt = if ind then "elim_" else "case_"+                               name <- freshName $ casefunt ++ simpleName cnm                                consTerm <- extractConsTerm c generalParams                                return (name, expl, consTerm)) cons   scrutineeIdxs <- namePis False idxs@@ -392,11 +461,11 @@   let clauseConsElimArgs = map getPiName consTerms   let clauseGeneralArgs' = map getPiName generalParams ++ [motiveName] ++ clauseConsElimArgs   let clauseGeneralArgs  = map (\arg -> pexp (PRef elimFC arg)) clauseGeneralArgs'-  let elimSig = "-- eliminator signature: " ++ showTmImpls eliminatorTy+  let elimSig = "-- case function signature: " ++ showTmImpls eliminatorTy   elimLog elimSig   eliminatorClauses <- mapM (\(cns, cnsElim) -> generateEliminatorClauses cns cnsElim clauseGeneralArgs generalParams) (zip cons clauseConsElimArgs)   let eliminatorDef = PClauses emptyFC [TotalFn] elimDeclName eliminatorClauses-  elimLog $ "-- eliminator definition: " ++ (show . showDeclImp verbosePPOption) eliminatorDef+  elimLog $ "-- case function definition: " ++ (show . showDeclImp verbosePPOption) eliminatorDef   State.lift $ idrisCatch (elabDecl EAll info eliminatorTyDecl) (\err -> return ())   -- Do not elaborate clauses if there aren't any   case eliminatorClauses of@@ -406,10 +475,10 @@         elimLog s = State.lift (logLvl 2 s)          elimFC :: FC-        elimFC = fileFC "(eliminator)"+        elimFC = fileFC "(casefun)"          elimDeclName :: Name-        elimDeclName = SN $ ElimN n+        elimDeclName = if ind then SN . ElimN $ n else SN . CaseN $ n          applyNS :: Name -> [String] -> Name         applyNS n []  = n@@ -560,7 +629,7 @@           implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)           consArgs <- namePis False args           let recArgs = findRecArgs consArgs-          let recMotives = map applyRecMotive recArgs+          let recMotives = if ind then map applyRecMotive recArgs else []           let (_, consIdxs) = splitArgPms resTy           return $ piConstr (implidxs ++ consArgs ++ recMotives) (applyMotive consIdxs (applyCons cnm consArgs))             where applyRecMotive :: (Name, Plicity, PTerm) -> (Name, Plicity, PTerm)@@ -600,7 +669,7 @@           consArgs <- namePis False args           let lhsPattern = PApp elimFC (PRef elimFC elimDeclName) (generalArgs ++ generalIdxs ++ [pexp $ applyCons cnm consArgs])           let recArgs = findRecArgs consArgs-          let recElims = map applyRecElim recArgs+          let recElims = if ind then map applyRecElim recArgs else []           let rhsExpr    = PApp elimFC (PRef elimFC cnsElim) (map convertArg implidxs ++ map convertArg consArgs ++ recElims)           return $ PClause elimFC elimDeclName lhsPattern [] rhsExpr []             where applyRecElim :: (Name, Plicity, PTerm) -> PArg@@ -694,15 +763,15 @@          -- First elaborate the expected type (and check that it's a type)          -- The goal type for a postulate is always Type.          (ty', typ) <- case what of-                         ProvTerm ty p   -> elabVal toplevel False ty-                         ProvPostulate _ -> elabVal toplevel False PType+                         ProvTerm ty p   -> elabVal toplevel ERHS ty+                         ProvPostulate _ -> elabVal toplevel ERHS PType          unless (isTType typ) $            ifail ("Expected a type, got " ++ show ty' ++ " : " ++ show typ)           -- Elaborate the provider term to TT and check that the type matches          (e, et) <- case what of-                      ProvTerm _ tm    -> elabVal toplevel False tm-                      ProvPostulate tm -> elabVal toplevel False tm+                      ProvTerm _ tm    -> elabVal toplevel ERHS tm+                      ProvPostulate tm -> elabVal toplevel ERHS tm          unless (isProviderOf (normalise ctxt [] ty') et) $            ifail $ "Expected provider type IO (Provider (" ++                    show ty' ++ "))" ++ ", got " ++ show et ++ " instead."@@ -751,7 +820,7 @@          let lhs = addImplPat i lhs_in          ((lhs', dlhs, []), _) <-               tclift $ elaborate ctxt (sMN 0 "transLHS") infP []-                       (erun fc (buildTC i info True [] (sUN "transform")+                       (erun fc (buildTC i info ELHS [] (sUN "transform")                                    (infTerm lhs)))          let lhs_tm = orderPats (getInferTerm lhs')          let lhs_ty = getInferType lhs'@@ -764,7 +833,7 @@               tclift $ elaborate ctxt (sMN 0 "transRHS") clhs_ty []                        (do pbinds i lhs_tm                            setNextName-                           erun fc (build i info False [] (sUN "transform") rhs)+                           erun fc (build i info ERHS [] (sUN "transform") rhs)                            erun fc $ psolve lhs_tm                            tt <- get_term                            return (runState (collectDeferred Nothing tt) []))@@ -794,19 +863,31 @@                     _ -> ifail "Something went inexplicably wrong"          cimp <- case lookupCtxt cn (idris_implicits i) of                     [imps] -> return imps-         let ptys = getProjs [] (renameBs cimp cty)+         ppos <- case lookupCtxt tyn (idris_datatypes i) of+                    [ti] -> return $ param_pos ti+         let cty_imp = renameBs cimp cty+         let ptys = getProjs [] cty_imp          let ptys_u = getProjs [] cty-         let recty = getRecTy cty+         let recty = getRecTy cty_imp+         let recty_u = getRecTy cty +         let paramNames = getPNames recty ppos+          -- rename indices when we generate the getter/setter types, so          -- that they don't clash with the names of the projections          -- we're generating-         let index_names_in = getRecNameMap "_in" recty+         let index_names_in = getRecNameMap "_in" ppos recty          let recty_in = substMatches index_names_in recty -         logLvl 1 $ show (recty, ptys)-         let substs = map (\ (n, _) -> (n, PApp fc (PRef fc n)-                                                [pexp (PRef fc rec)])) ptys+         logLvl 3 $ show (recty, recty_u, ppos, paramNames, ptys)+         -- Substitute indices with projection functions, and parameters with+         -- the updated parameter name+         let substs = map (\ (n, _) -> +                             if n `elem` paramNames+                                then (n, PRef fc (mkp n))+                                else (n, PApp fc (PRef fc n)+                                                [pexp (PRef fc rec)])) +                          ptys            -- Generate projection functions          proj_decls <- mapM (mkProj recty_in substs cimp) (zip ptys [0..])@@ -815,7 +896,7 @@          let implBinds = getImplB id cty'           -- Generate update functions-         update_decls <- mapM (mkUpdate recty index_names_in extraImpls+         update_decls <- mapM (mkUpdate recty_u index_names_in extraImpls                                    (getFieldNames cty')                                    implBinds (length nonImp)) (zip nonImp [0..])          mapM_ (elabDecl EAll info) (concat proj_decls)@@ -827,6 +908,14 @@     isNonImp (PExp _ _ _ _, a) = Just a     isNonImp _ = Nothing +    getPNames (PApp _ _ as) ppos = getpn as ppos+      where+        getpn as [] = []+        getpn as (i:is) | length as > i,+                          PRef _ n <- getTm (as!!i) = n : getpn as is+                        | otherwise = getpn as is+    getPNames _ _ = []+        tryElabDecl info (fn, ty, val)         = do i <- getIState              idrisCatch (do elabDecl' EAll info ty@@ -863,15 +952,21 @@     getRecTy (PPi _ n ty s) = getRecTy s     getRecTy t = t -    getRecNameMap x (PApp fc t args) = mapMaybe (toMN . getTm) args+    -- make sure we pick a consistent name for parameters; any name will do+    -- otherwise+    getRecNameMap x ppos (PApp fc t args) +         = mapMaybe toMN (zip [0..] (map getTm args))       where-        toMN (PRef fc n) = Just (n, PRef fc (sMN 0 (show n ++ x)))+        toMN (i, PRef fc n) +             | i `elem` ppos = Just (n, PRef fc (mkp n))+             | otherwise = Just (n, PRef fc (sMN 0 (show n ++ x)))         toMN _ = Nothing-    getRecNameMap x _ = []+    getRecNameMap x _ _ = []      rec = sMN 0 "rec" -    mkp (UN n) = sMN 0 ("p_" ++ str n)+    -- only UNs propagate properly as parameters (bit of a hack then...)+    mkp (UN n) = sUN ("_p_" ++ str n)     mkp (MN i n) = sMN i ("p_" ++ str n)     mkp (NS n s) = NS (mkp n) s @@ -884,18 +979,19 @@     mkType (NS n s) = NS (mkType n) s      mkProj recty substs cimp ((pn_in, pty), pos)-        = do let pn = expandNS syn pn_in+        = do let pn = expandNS syn pn_in -- projection name+             -- use pn_in in the indices, consistently, to avoid clash              let pfnTy = PTy emptyDocstring [] defaultSyntax fc [] pn                             (PPi expl rec recty                                (substMatches substs pty))              let pls = repeat Placeholder              let before = pos              let after = length substs - (pos + 1)-             let args = take before pls ++ PRef fc (mkp pn) : take after pls+             let args = take before pls ++ PRef fc (mkp pn_in) : take after pls              let iargs = map implicitise (zip cimp args)              let lhs = PApp fc (PRef fc pn)                         [pexp (PApp fc (PRef fc cn) iargs)]-             let rhs = PRef fc (mkp pn)+             let rhs = PRef fc (mkp pn_in)              let pclause = PClause fc pn lhs [] rhs []              return [pfnTy, PClauses fc [] pn [pclause]] @@ -940,68 +1036,6 @@                   then PPi impl n' ty (implBindUp ns is t)                   else implBindUp ns is t --- FIXME: 'forcenames' is an almighty hack! Need a better way of--- erasing non-forceable things--- ^^^--- TODO: the above is a comment from the past;--- forcenames is probably no longer needed-elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->-           (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name]) -> Idris (Name, Type)-elabCon info syn tn codata (doc, argDocs, n, t_in, fc, forcenames)-    = do checkUndefined fc n-         ctxt <- getContext-         i <- getIState-         t_in <- implicit info syn n (if codata then mkLazy t_in else t_in)-         let t = addImpl i t_in-         logLvl 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ show t-         let inacc = inaccessibleArgs 0 t-         logLvl 5 $ "Inaccessible args: " ++ show inacc-         ((t', defer, is), log) <--              tclift $ elaborate ctxt n (TType (UVal 0)) []-                       (errAt "constructor " n (erun fc (build i info False [] n t)))-         logLvl 2 $ "Rechecking " ++ show t'-         def' <- checkDef fc defer-         let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) def'-         addDeferred def''-         mapM_ (elabCaseBlock info []) is-         ctxt <- getContext-         (cty, _)  <- recheckC fc [] t'-         let cty' = normaliseC ctxt [] cty-         tyIs cty'-         logLvl 2 $ "---> " ++ show n ++ " : " ++ show cty'-         addIBC (IBCDef n)-         checkDocs fc argDocs t_in-         addDocStr n doc argDocs-         addIBC (IBCDoc n)-         fputState (opt_inaccessible . ist_optimisation n) inacc-         addIBC (IBCOpt n)-         return (n, cty')-  where-    tyIs (Bind n b sc) = tyIs sc-    tyIs t | (P _ n' _, _) <- unApply t-        = if n' /= tn then tclift $ tfail (At fc (Msg (show n' ++ " is not " ++ show tn)))-             else return ()-    tyIs t = tclift $ tfail (At fc (Msg (show t ++ " is not " ++ show tn)))--    mkLazy (PPi pl n ty sc) -        = let ty' = if getTyName ty-                       then PApp fc (PRef fc (sUN "Lazy'"))-                            [pexp (PRef fc (sUN "LazyCodata")),-                             pexp ty]-                       else ty in-              PPi pl n ty' (mkLazy sc)-    mkLazy t = t--    getTyName (PApp _ (PRef _ n) _) = n == nsroot tn-    getTyName (PRef _ n) = n == nsroot tn-    getTyName _ = False---    getNamePos :: Int -> PTerm -> Name -> Maybe Int-    getNamePos i (PPi _ n _ sc) x | n == x = Just i-                                  | otherwise = getNamePos (i + 1) sc x-    getNamePos _ _ _ = Nothing- -- | Elaborate a collection of left-hand and right-hand pairs - that is, a -- top-level definition. elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris ()@@ -1076,8 +1110,9 @@                 Just _ -> logLvl 5 $ "Partially evaluated:\n" ++ show pats                 _ -> return () +           erInfo <- getErasureInfo <$> getIState            tree@(CaseDef scargs sc _) <- tclift $-                   simpleCase tcase False reflect CompileTime fc inacc atys pdef+                   simpleCase tcase False reflect CompileTime fc inacc atys pdef erInfo            cov <- coverage            pmissing <-                    if cov && not (hasDefault cs)@@ -1126,7 +1161,7 @@            let knowncovering = (pcover && cov) || AssertTotal `elem` opts             tree' <- tclift $ simpleCase tcase knowncovering reflect-                                        RunTime fc inacc atys pdef'+                                        RunTime fc inacc atys pdef' erInfo            logLvl 3 $ "Unoptimised " ++ show n ++ ": " ++ show tree            logLvl 3 $ "Optimised: " ++ show tree'            ctxt <- getContext@@ -1136,7 +1171,7 @@                                                 (idris_patdefs ist) })            let caseInfo = CaseInfo (inlinable opts) (dictionary opts)            case lookupTy n ctxt of-               [ty] -> do updateContext (addCasedef n caseInfo+               [ty] -> do updateContext (addCasedef n erInfo caseInfo                                                        tcase knowncovering                                                        reflect                                                        (AssertTotal `elem` opts)@@ -1230,7 +1265,7 @@                 Nothing -> pats                 Just ns -> partial_eval (tt_ctxt ist) ns pats --- Find 'static' applications in a term and partially evaluate them+-- | Find 'static' applications in a term and partially evaluate them elabPE :: ElabInfo -> FC -> Name -> Term -> Idris () elabPE info fc caller r =   do ist <- getIState@@ -1301,6 +1336,7 @@ --                             (normalise (tt_ctxt ist) [] (specType args ty))               _ -> error "Can't happen (getSpecTy)" +    -- get the clause of a specialised application     getSpecClause ist (n, args)        = let newnm = sUN ("__"++show (nsroot n) ++ "_" ++                                 showSep "_" (map showArg args)) in @@ -1313,7 +1349,7 @@  -- Elaborate a value, returning any new bindings created (this will only -- happen if elaborating as a pattern clause)-elabValBind :: ElabInfo -> Bool -> Bool -> PTerm -> Idris (Term, Type, [(Name, Type)])+elabValBind :: ElabInfo -> ElabMode -> Bool -> PTerm -> Idris (Term, Type, [(Name, Type)]) elabValBind info aspat norm tm_in    = do ctxt <- getContext         i <- getIState@@ -1347,7 +1383,7 @@          return (vtm, vty, bargs) -elabVal :: ElabInfo -> Bool -> PTerm -> Idris (Term, Type)+elabVal :: ElabInfo -> ElabMode -> PTerm -> Idris (Term, Type) elabVal info aspat tm_in    = do (tm, ty, _) <- elabValBind info aspat False tm_in         return (tm, ty)@@ -1362,7 +1398,7 @@         let lhs = addImplPat i lhs_in         -- if the LHS type checks, it is possible         case elaborate ctxt (sMN 0 "patLHS") infP []-                            (erun fc (buildTC i info True [] fname (infTerm lhs))) of+                            (erun fc (buildTC i info ELHS [] fname (infTerm lhs))) of             OK ((lhs', _, _), _) ->                do let lhs_tm = orderPats (getInferTerm lhs')                   case recheck ctxt [] (forget lhs_tm) lhs_tm of@@ -1416,7 +1452,8 @@                     | otherwise = False -- name is different, unrecoverable  getFixedInType i env (PExp _ _ _ _ : is) (Bind n (Pi t) sc)-    = getFixedInType i (n : env) is (instantiate (P Bound n t) sc)+    = nub $ getFixedInType i env [] t +++            getFixedInType i (n : env) is (instantiate (P Bound n t) sc) getFixedInType i env (_ : is) (Bind n (Pi t) sc)     = getFixedInType i (n : env) is (instantiate (P Bound n t) sc) getFixedInType i env is tm@(App f a)@@ -1463,8 +1500,8 @@                           _ -> paramNames args env ps    | otherwise = paramNames args env ps -propagateParams :: [Name] -> Type -> PTerm -> PTerm-propagateParams ps t tm@(PApp _ (PRef fc n) args)+propagateParams :: IState -> [Name] -> Type -> PTerm -> PTerm+propagateParams i ps t tm@(PApp _ (PRef fc n) args)      = PApp fc (PRef fc n) (addP t args)    where addP (Bind n _ sc) (t : ts)               | Placeholder <- getTm t,@@ -1473,9 +1510,15 @@                     = t { getTm = PRef fc n } : addP sc ts          addP (Bind n _ sc) (t : ts) = t : addP sc ts          addP _ ts = ts-propagateParams ps t (PRef fc n)-     = PApp fc (PRef fc n) (map (\x -> pimp x (PRef fc x) True) ps)-propagateParams ps t x = x+propagateParams i ps t (PRef fc n)+     = case lookupCtxt n (idris_implicits i) of+            [is] -> let ps' = filter (isImplicit is) ps in+                        PApp fc (PRef fc n) (map (\x -> pimp x (PRef fc x) True) ps')+            _ -> PRef fc n+    where isImplicit [] n = False+          isImplicit (PImp _ _ _ x _ : is) n | x == n = True+          isImplicit (_ : is) n = isImplicit is n+propagateParams i ps t x = x  -- Return the elaborated LHS/RHS, and the original LHS with implicits added elabClause :: ElabInfo -> FnOpts -> (Int, PClause) ->@@ -1507,7 +1550,7 @@                          _ -> []         let params = getParamsInType i [] fn_is fn_ty         let lhs = mkLHSapp $ stripUnmatchable i $-                    propagateParams params fn_ty (addImplPat i (stripLinear i lhs_in))+                    propagateParams i params fn_ty (addImplPat i (stripLinear i lhs_in))         logLvl 5 ("LHS: " ++ show fc ++ " " ++ showTmImpls lhs)         logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show lhs_in ++                   "\n" ++ show (fn_ty, fn_is))@@ -1515,7 +1558,7 @@         (((lhs', dlhs, []), probs, inj), _) <-             tclift $ elaborate ctxt (sMN 0 "patLHS") infP []                      (do res <- errAt "left hand side of " fname-                                  (erun fc (buildTC i info True opts fname (infTerm lhs)))+                                  (erun fc (buildTC i info ELHS opts fname (infTerm lhs)))                          probs <- get_probs                          inj <- get_inj                          return (res, probs, inj))@@ -1573,7 +1616,7 @@                         mapM_ setinj (nub (params ++ inj))                         setNextName                          (_, _, is) <- errAt "right hand side of " fname-                                         (erun fc (build i winfo False opts fname rhs))+                                         (erun fc (build i winfo ERHS opts fname rhs))                         errAt "right hand side of " fname                               (erun fc $ psolve lhs_tm)                         hs <- get_holes@@ -1702,19 +1745,19 @@                          [t] -> t                          _ -> []         let params = getParamsInType i [] fn_is fn_ty-        let lhs = propagateParams params fn_ty (addImplPat i (stripLinear i lhs_in))+        let lhs = propagateParams i params fn_ty (addImplPat i (stripLinear i lhs_in))         logLvl 2 ("LHS: " ++ show lhs)         ((lhs', dlhs, []), _) <-             tclift $ elaborate ctxt (sMN 0 "patLHS") infP []               (errAt "left hand side of with in " fname-                (erun fc (buildTC i info True opts fname (infTerm lhs))) )+                (erun fc (buildTC i info ELHS opts fname (infTerm lhs))) )         let lhs_tm = orderPats (getInferTerm lhs')         let lhs_ty = getInferType lhs'-        let ret_ty = getRetTy lhs_ty+        let ret_ty = getRetTy (explicitNames (normalise ctxt [] lhs_ty))         logLvl 3 (show lhs_tm)         (clhs, clhsty) <- recheckC fc [] lhs_tm         logLvl 5 ("Checked " ++ show clhs)-        let bargs = getPBtys lhs_tm+        let bargs = getPBtys (explicitNames (normalise ctxt [] lhs_tm))         let wval = addImplBound i (map fst bargs) wval_in         logLvl 5 ("Checking " ++ showTmImpls wval)         -- Elaborate wval in this context@@ -1725,7 +1768,7 @@                             setNextName                             -- TODO: may want where here - see winfo abpve                             (_', d, is) <- errAt "with value in " fname-                              (erun fc (build i info False opts fname (infTerm wval)))+                              (erun fc (build i info ERHS opts fname (infTerm wval)))                             erun fc $ psolve lhs_tm                             tt <- get_term                             return (tt, d, is))@@ -1735,8 +1778,8 @@         mapM_ (elabCaseBlock info opts) is         logLvl 5 ("Checked wval " ++ show wval')         (cwval, cwvalty) <- recheckC fc [] (getInferTerm wval')-        let cwvaltyN = explicitNames cwvalty-        let cwvalN = explicitNames cwval+        let cwvaltyN = explicitNames (normalise ctxt [] cwvalty)+        let cwvalN = explicitNames (normalise ctxt [] cwval)         logLvl 5 ("With type " ++ show cwvalty ++ "\nRet type " ++ show ret_ty)         let pvars = map fst (getPBtys cwvalty)         -- we need the unelaborated term to get the names it depends on@@ -1751,12 +1794,12 @@         -- (ps : Xs) -> (withval : cwvalty) -> (ps' : Xs') -> ret_ty         let wargval = getRetTy cwvalN         let wargtype = getRetTy cwvaltyN-        logLvl 5 ("Abstract over " ++ show wargval)+        logLvl 5 ("Abstract over " ++ show wargval ++ " in " ++ show wargtype)         let wtype = bindTyArgs Pi (bargs_pre ++                      (sMN 0 "warg", wargtype) :                      map (abstract (sMN 0 "warg") wargval wargtype) bargs_post)                      (substTerm wargval (P Bound (sMN 0 "warg") wargtype) ret_ty)-        logLvl 3 ("New function type " ++ show wtype)+        logLvl 5 ("New function type " ++ show wtype)         let wname = sMN windex (show fname)          let imps = getImps wtype -- add to implicits context@@ -1788,7 +1831,7 @@            tclift $ elaborate ctxt (sMN 0 "wpatRHS") clhsty []                     (do pbinds i lhs_tm                         setNextName-                        (_, d, is) <- erun fc (build i info False opts fname rhs)+                        (_, d, is) <- erun fc (build i info ERHS opts fname rhs)                         psolve lhs_tm                         tt <- get_term                         return (tt, d, is))@@ -1815,7 +1858,7 @@              logLvl 2 ("Matching " ++ showTmImpls tm ++ " against " ++                                       showTmImpls toplhs)              case matchClause i toplhs tm of-                Left (a,b) -> trace ("matchClause: " ++ show a ++ " =/= " ++ show b) (ifail $ show fc ++ ":with clause does not match top level")+                Left (a,b) -> ifail $ show fc ++ ":with clause does not match top level"                 Right mvars ->                     do logLvl 3 ("Match vars : " ++ show mvars)                        lhs <- updateLHS n wname mvars ns ns' (fullApp tm) w@@ -1865,11 +1908,14 @@ elabClass :: ElabInfo -> SyntaxInfo -> Docstring ->              FC -> [PTerm] ->              Name -> [(Name, PTerm)] -> [(Name, Docstring)] -> [PDecl] -> Idris ()-elabClass info syn doc fc constraints tn ps pDocs ds+elabClass info syn_in doc fc constraints tn ps pDocs ds     = do let cn = SN (InstanceCtorN tn) -- sUN ("instance" ++ show tn) -- MN 0 ("instance" ++ show tn)          let tty = pibind ps PType          let constraint = PApp fc (PRef fc tn)                                   (map (pexp . PRef fc) (map fst ps))++         let syn = syn_in { using = addToUsing (using syn_in) ps }+          -- build data declaration          let mdecls = filter tydecl ds -- method declarations          let idecls = filter instdecl ds -- default superclass instance declarations@@ -1895,12 +1941,12 @@          elabData info (syn { no_imp = no_imp syn ++ mnames }) doc pDocs fc [] ddecl          -- for each constraint, build a top level function to chase it          logLvl 5 $ "Building functions"-         let usyn = syn { using = map (\ (x,y) -> UImplicit x y) ps-                                      ++ using syn }-         fns <- mapM (cfun cn constraint usyn (map fst imethods)) constraints+--          let usyn = syn { using = map (\ (x,y) -> UImplicit x y) ps+--                                       ++ using syn }+         fns <- mapM (cfun cn constraint syn (map fst imethods)) constraints          mapM_ (elabDecl EAll info) (concat fns)          -- for each method, build a top level function-         fns <- mapM (tfun cn constraint usyn (map fst imethods)) imethods+         fns <- mapM (tfun cn constraint syn (map fst imethods)) imethods          mapM_ (elabDecl EAll info) (concat fns)          -- add the default definitions          mapM_ (elabDecl EAll info) (concat (map (snd.snd) defs))@@ -2145,7 +2191,7 @@              ctxt <- getContext              ((tyT, _, _), _) <-                    tclift $ elaborate ctxt iname (TType (UVal 0)) []-                            (errAt "type of " iname (erun fc (build i info False [] iname ty)))+                            (errAt "type of " iname (erun fc (build i info ERHS [] iname ty)))              ctxt <- getContext              (cty, _) <- recheckC fc [] tyT              let nty = normalise ctxt [] cty@@ -2353,7 +2399,7 @@          -- Do totality checking after entire mutual block          i <- get          mapM_ (\n -> do logLvl 5 $ "Simplifying " ++ show n-                         updateContext (simplifyCasedef n))+                         updateContext (simplifyCasedef n $ getErasureInfo i))                  (map snd (idris_totcheck i))          mapM_ buildSCG (idris_totcheck i)          mapM_ checkDeclTotality (idris_totcheck i)
+ src/Idris/ElabQuasiquote.hs view
@@ -0,0 +1,171 @@+module Idris.ElabQuasiquote (extractUnquotes) where++import Idris.Core.Elaborate hiding (Tactic(..))+import Idris.Core.TT+import Idris.AbsSyntax+++extract1 :: (PTerm -> a) -> PTerm -> Elab' aux (a, [(Name, PTerm)])+extract1 c tm = do (tm', ex) <- extractUnquotes tm+                   return (c tm', ex)++extract2 :: (PTerm -> PTerm -> a) -> PTerm -> PTerm -> Elab' aux (a, [(Name, PTerm)])+extract2 c a b = do (a', ex1) <- extractUnquotes a+                    (b', ex2) <- extractUnquotes b+                    return (c a' b', ex1 ++ ex2)++extractTUnquotes :: PTactic -> Elab' aux (PTactic, [(Name, PTerm)])+extractTUnquotes (Rewrite t) = extract1 Rewrite t+extractTUnquotes (Induction t) = extract1 Induction t+extractTUnquotes (LetTac n t) = extract1 (LetTac n) t+extractTUnquotes (LetTacTy n t1 t2) = extract2 (LetTacTy n) t1 t2+extractTUnquotes (Exact tm) = extract1 Exact tm+extractTUnquotes (Try tac1 tac2)+  = do (tac1', ex1) <- extractTUnquotes tac1+       (tac2', ex2) <- extractTUnquotes tac2+       return (Try tac1' tac2', ex1 ++ ex2)+extractTUnquotes (TSeq tac1 tac2)+  = do (tac1', ex1) <- extractTUnquotes tac1+       (tac2', ex2) <- extractTUnquotes tac2+       return (TSeq tac1' tac2', ex1 ++ ex2)+extractTUnquotes (ApplyTactic t) = extract1 ApplyTactic t+extractTUnquotes (ByReflection t) = extract1 ByReflection t+extractTUnquotes (Reflect t) = extract1 Reflect t+extractTUnquotes (GoalType s tac)+  = do (tac', ex) <- extractTUnquotes tac+       return (GoalType s tac', ex)+extractTUnquotes (TCheck t) = extract1 TCheck t+extractTUnquotes (TEval t) = extract1 TEval t+extractTUnquotes tac = return (tac, []) -- the rest don't contain PTerms++extractPArgUnquotes :: PArg -> Elab' aux (PArg, [(Name, PTerm)])+extractPArgUnquotes (PImp p m opts n t) =+  do (t', ex) <- extractUnquotes t+     return (PImp p m opts n t', ex)+extractPArgUnquotes (PExp p opts n t) =+  do (t', ex) <- extractUnquotes t+     return (PExp p opts n t', ex)+extractPArgUnquotes (PConstraint p opts n t) =+  do (t', ex) <- extractUnquotes t+     return (PConstraint p opts n t', ex)+extractPArgUnquotes (PTacImplicit p opts n scpt t) =+  do (scpt', ex1) <- extractUnquotes scpt+     (t', ex2) <- extractUnquotes t+     return (PTacImplicit p opts n scpt' t', ex1 ++ ex2)++extractDoUnquotes :: PDo -> Elab' aux (PDo, [(Name, PTerm)])+extractDoUnquotes (DoExp fc tm)+  = do (tm', ex) <- extractUnquotes tm+       return (DoExp fc tm', ex)+extractDoUnquotes (DoBind fc n tm)+  = do (tm', ex) <- extractUnquotes tm+       return (DoBind fc n tm', ex)+extractDoUnquotes (DoBindP fc t t' alts)+  = fail "Pattern-matching binds cannot be quasiquoted"+extractDoUnquotes (DoLet  fc n v b)+  = do (v', ex1) <- extractUnquotes v+       (b', ex2) <- extractUnquotes b+       return (DoLet fc n v' b', ex1 ++ ex2)+extractDoUnquotes (DoLetP fc t t') = fail "Pattern-matching lets cannot be quasiquoted"+++extractUnquotes :: PTerm -> Elab' aux (PTerm, [(Name, PTerm)])+extractUnquotes (PLam n ty body)+  = do (ty', ex1) <- extractUnquotes ty+       (body', ex2) <- extractUnquotes body+       return (PLam n ty' body', ex1 ++ ex2)+extractUnquotes (PPi  plicity n ty body)+  = do (ty', ex1) <- extractUnquotes ty+       (body', ex2) <- extractUnquotes body+       return (PPi plicity n ty' body', ex1 ++ ex2)+extractUnquotes (PLet n ty val body)+  = do (ty', ex1) <- extractUnquotes ty+       (val', ex2) <- extractUnquotes val+       (body', ex3) <- extractUnquotes body+       return (PLet n ty' val' body', ex1 ++ ex2 ++ ex3)+extractUnquotes (PTyped tm ty)+  = do (tm', ex1) <- extractUnquotes tm+       (ty', ex2) <- extractUnquotes ty+       return (PTyped tm' ty', ex1 ++ ex2)+extractUnquotes (PApp fc f args)+  = do (f', ex1) <- extractUnquotes f+       args' <- mapM extractPArgUnquotes args+       let (args'', exs) = unzip args'+       return (PApp fc f' args'', ex1 ++ concat exs)+extractUnquotes (PAppBind fc f args)+  = do (f', ex1) <- extractUnquotes f+       args' <- mapM extractPArgUnquotes args+       let (args'', exs) = unzip args'+       return (PAppBind fc f' args'', ex1 ++ concat exs)+extractUnquotes (PCase fc expr cases)+  = do (expr', ex1) <- extractUnquotes expr+       let (pats, rhss) = unzip cases+       (pats', exs1) <- fmap unzip $ mapM extractUnquotes pats+       (rhss', exs2) <- fmap unzip $ mapM extractUnquotes rhss+       return (PCase fc expr' (zip pats' rhss'), ex1 ++ concat exs1 ++ concat exs2)+extractUnquotes (PRefl fc x)+  = do (x', ex) <- extractUnquotes x+       return (PRefl fc x', ex)+extractUnquotes (PEq fc at bt a b)+  = do (at', ex1) <- extractUnquotes at+       (bt', ex2) <- extractUnquotes bt+       (a', ex1) <- extractUnquotes a+       (b', ex2) <- extractUnquotes b+       return (PEq fc at' bt' a' b', ex1 ++ ex2)+extractUnquotes (PRewrite fc x y z)+  = do (x', ex1) <- extractUnquotes x+       (y', ex2) <- extractUnquotes y+       case z of+         Just zz -> do (z', ex3) <- extractUnquotes zz+                       return (PRewrite fc x' y' (Just z'), ex1 ++ ex2 ++ ex3)+         Nothing -> return (PRewrite fc x' y' Nothing, ex1 ++ ex2)+extractUnquotes (PPair fc info l r)+  = do (l', ex1) <- extractUnquotes l+       (r', ex2) <- extractUnquotes r+       return (PPair fc info l' r', ex1 ++ ex2)+extractUnquotes (PDPair fc info a b c)+  = do (a', ex1) <- extractUnquotes a+       (b', ex2) <- extractUnquotes b+       (c', ex3) <- extractUnquotes c+       return (PDPair fc info a' b' c', ex1 ++ ex2 ++ ex3)+extractUnquotes (PAlternative b alts)+  = do alts' <- mapM extractUnquotes alts+       let (alts'', exs) = unzip alts'+       return (PAlternative b alts'', concat exs)+extractUnquotes (PHidden tm)+  = do (tm', ex) <- extractUnquotes tm+       return (PHidden tm', ex)+extractUnquotes (PGoal fc a n b)+  = do (a', ex1) <- extractUnquotes a+       (b', ex2) <- extractUnquotes b+       return (PGoal fc a' n b', ex1 ++ ex2)+extractUnquotes (PDoBlock steps)+  = do steps' <- mapM extractDoUnquotes steps+       let (steps'', exs) = unzip steps'+       return (PDoBlock steps'', concat exs)+extractUnquotes (PIdiom fc tm)+  = fmap (\(tm', ex) -> (PIdiom fc tm', ex)) $ extractUnquotes tm+extractUnquotes (PProof tacs)+  = do (tacs', exs) <- fmap unzip $ mapM extractTUnquotes tacs+       return (PProof tacs', concat exs)+extractUnquotes (PTactics tacs)+  = do (tacs', exs) <- fmap unzip $ mapM extractTUnquotes tacs+       return (PTactics tacs', concat exs)+extractUnquotes (PElabError err) = fail "Can't quasiquote an error"+extractUnquotes (PCoerced tm)+  = do (tm', ex) <- extractUnquotes tm+       return (PCoerced tm', ex)+extractUnquotes (PDisamb ns tm)+  = do (tm', ex) <- extractUnquotes tm+       return (PDisamb ns tm', ex)+extractUnquotes (PUnifyLog tm)+  = fmap (\(tm', ex) -> (PUnifyLog tm', ex)) $ extractUnquotes tm+extractUnquotes (PNoImplicits tm)+  = fmap (\(tm', ex) -> (PNoImplicits tm', ex)) $ extractUnquotes tm+extractUnquotes (PQuasiquote _ _) = fail "Nested quasiquotes not supported"+extractUnquotes (PUnquote tm) =+  do n <- getNameFrom (sMN 0 "unquotation")+     return (PRef (fileFC "(unquote)") n, [(n, tm)])+extractUnquotes x = return (x, []) -- no subterms!++
src/Idris/ElabTerm.hs view
@@ -14,8 +14,9 @@ import Idris.Core.TT import Idris.Core.Evaluate import Idris.Core.Unify-import Idris.Core.Typecheck (check)+import Idris.Core.Typecheck (check, recheck) import Idris.ErrReverse (errReverse)+import Idris.ElabQuasiquote (extractUnquotes)  import Control.Applicative ((<$>)) import Control.Monad@@ -28,6 +29,9 @@  import Debug.Trace +data ElabMode = ETyDecl | ELHS | ERHS+  deriving Eq+ -- Using the elaborator, convert a term in raw syntax to a fully -- elaborated, typechecked term. --@@ -36,10 +40,10 @@  -- Also find deferred names in the term and their types -build :: IState -> ElabInfo -> Bool -> FnOpts -> Name -> PTerm ->+build :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm ->          ElabD (Term, [(Name, (Int, Maybe Name, Type))], [PDecl])-build ist info pattern opts fn tm-    = do elab ist info pattern opts fn tm+build ist info emode opts fn tm+    = do elab ist info emode opts fn tm          let tmIn = tm          let inf = case lookupCtxt fn (idris_tyinfodata ist) of                         [TIPartial] -> True@@ -79,20 +83,32 @@             ((_,_,_,e,_,_):es) -> traceWhen u ("Final problems:\n" ++ show probs) $                                    if inf then return ()                                           else lift (Error e)++         when tydecl (do update_term orderPats+                         mkPat)+--                          update_term liftPats)          is <- getAux          tt <- get_term          let (tm, ds) = runState (collectDeferred (Just fn) tt) []          log <- getLog          if (log /= "") then trace log $ return (tm, ds, is)             else return (tm, ds, is)+  where pattern = emode == ELHS+        tydecl = emode == ETyDecl+    +        mkPat = do hs <- get_holes+                   tm <- get_term+                   case hs of+                      (h: hs) -> do patvar h; mkPat+                      [] -> return ()  -- Build a term autogenerated as a typeclass method definition -- (Separate, so we don't go overboard resolving things that we don't -- know about yet on the LHS of a pattern def) -buildTC :: IState -> ElabInfo -> Bool -> FnOpts -> Name -> PTerm ->+buildTC :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm ->          ElabD (Term, [(Name, (Int, Maybe Name, Type))], [PDecl])-buildTC ist info pattern opts fn tm+buildTC ist info emode opts fn tm     = do -- set name supply to begin after highest index in tm          let ns = allNamesIn tm          let tmIn = tm@@ -100,7 +116,7 @@                         [TIPartial] -> True                         _ -> False          initNextNameFrom ns-         elab ist info pattern opts fn tm+         elab ist info emode opts fn tm          probs <- get_probs          tm <- get_term          case probs of@@ -113,17 +129,18 @@          log <- getLog          if (log /= "") then trace log $ return (tm, ds, is)             else return (tm, ds, is)+  where pattern = emode == ELHS  -- Returns the set of declarations we need to add to complete the definition -- (most likely case blocks to elaborate) -elab :: IState -> ElabInfo -> Bool -> FnOpts -> Name -> PTerm ->+elab :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm ->         ElabD ()-elab ist info pattern opts fn tm+elab ist info emode opts fn tm     = do let loglvl = opt_logLevel (idris_options ist)          when (loglvl > 5) $ unifyLog True          compute -- expand type synonyms, etc-         elabE (False, False, False) tm -- (in argument, guarded, in type)+         elabE (False, False, False, False) tm -- (in argument, guarded, in type, in qquote)          end_unify          when pattern -- convert remaining holes to pattern vars               (do update_term orderPats@@ -132,12 +149,15 @@                   unifyProblems                   mkPat)   where+    pattern = emode == ELHS+    bindfree = emode == ETyDecl || emode == ELHS+     tcgen = Dictionary `elem` opts-    reflect = Reflection `elem` opts+    reflection = Reflection `elem` opts      isph arg = case getTm arg of         Placeholder -> (True, priority arg)-        _ -> (False, priority arg)+        tm -> (False, priority arg)      toElab ina arg = case getTm arg of         Placeholder -> Nothing@@ -153,8 +173,12 @@                   (h: hs) -> do patvar h; mkPat                   [] -> return () -    elabE :: (Bool, Bool, Bool) -> PTerm -> ElabD ()-    elabE ina t = +    -- | elabE elaborates an expression, possibly wrapping implicit coercions+    -- and forces/delays.  If you make a recursive call in elab', it is+    -- normally correct to call elabE - the ones that don't are desugarings+    -- typically+    elabE :: (Bool, Bool, Bool, Bool) -> PTerm -> ElabD ()+    elabE ina t =                --do g <- goal                   --trace ("Elaborating " ++ show t ++ " : " ++ show g) $                   do ct <- insertCoerce ina t@@ -203,13 +227,15 @@     constType VoidType = True     constType _ = False -    elab' :: (Bool, Bool, Bool)  -- ^ (in an argument, guarded, in a type)+    -- "guarded" means immediately under a constructor, to help find patvars++    elab' :: (Bool, Bool, Bool, Bool)  -- ^ (in an argument, guarded, in a type, in a quasiquote)           -> PTerm -- ^ The term to elaborate           -> ElabD ()     elab' ina (PNoImplicits t) = elab' ina t -- skip elabE step     elab' ina PType           = do apply RType []; solve --  elab' (_,_,inty) (PConstant c) ---     | constType c && pattern && not reflect && not inty+--     | constType c && pattern && not reflection && not inty --       = lift $ tfail (Msg "Typecase is not allowed")      elab' ina (PConstant c)  = do apply (RConstant c) []; solve     elab' ina (PQuote r)     = do fill r; solve@@ -219,29 +245,44 @@     elab' ina (PResolveTC (FC "HACK" _ _)) -- for chasing parent classes        = do g <- goal; resolveTC 5 g fn ist     elab' ina (PResolveTC fc)-        | True = do c <- getNameFrom (sMN 0 "class")-                    instanceArg c-        | otherwise = do g <- goal-                         try (resolveTC 2 g fn ist)-                          (do c <- getNameFrom (sMN 0 "class")-                              instanceArg c)+        = do c <- getNameFrom (sMN 0 "class")+             instanceArg c     elab' ina (PRefl fc t)         = elab' ina (PApp fc (PRef fc eqCon) [pimp (sMN 0 "A") Placeholder True,                                               pimp (sMN 0 "x") t False])-    elab' ina (PEq fc l r)   = elab' ina (PApp fc (PRef fc eqTy)-                                    [pimp (sMN 0 "A") Placeholder True,-                                     pimp (sMN 0 "B") Placeholder False,+    elab' ina (PEq fc Placeholder Placeholder l r)+       = try (do tyn <- getNameFrom (sMN 0 "aqty")+                 claim tyn RType+                 movelast tyn+                 elab' ina (PApp fc (PRef fc eqTy)+                              [pimp (sUN "A") (PRef fc tyn) True,+                               pimp (sUN "B") (PRef fc tyn) False,+                               pexp l, pexp r]))+             (do atyn <- getNameFrom (sMN 0 "aqty")+                 btyn <- getNameFrom (sMN 0 "bqty")+                 claim atyn RType+                 movelast atyn+                 claim btyn RType+                 movelast btyn+                 elab' ina (PApp fc (PRef fc eqTy)+                              [pimp (sUN "A") (PRef fc atyn) True,+                               pimp (sUN "B") (PRef fc btyn) False,+                               pexp l, pexp r]))++    elab' ina (PEq fc lt rt l r) = elab' ina (PApp fc (PRef fc eqTy)+                                    [pimp (sUN "A") lt True,+                                     pimp (sUN "B") rt False,                                      pexp l, pexp r])-    elab' ina@(_, a, inty) (PPair fc _ l r)+    elab' ina@(_, a, inty, qq) (PPair fc _ l r)         = do hnf_compute              g <- goal              case g of-                TType _ -> elabE (True, a,inty) (PApp fc (PRef fc pairTy)-                                                  [pexp l,pexp r])-                _ -> elabE (True, a, inty) (PApp fc (PRef fc pairCon)-                                            [pimp (sMN 0 "A") Placeholder True,-                                             pimp (sMN 0 "B") Placeholder True,-                                             pexp l, pexp r])+                TType _ -> elabE (True, a,inty, qq) (PApp fc (PRef fc pairTy)+                                                      [pexp l,pexp r])+                _ -> elabE (True, a, inty, qq) (PApp fc (PRef fc pairCon)+                                                [pimp (sMN 0 "A") Placeholder True,+                                                 pimp (sMN 0 "B") Placeholder True,+                                                 pexp l, pexp r])     elab' ina (PDPair fc p l@(PRef _ n) t r)             = case t of                 Placeholder ->@@ -283,28 +324,32 @@               trySeq' deferr [] = proofFail deferr               trySeq' deferr (x : xs)                   = try' (elab' ina x) (trySeq' deferr xs) True-    elab' ina (PPatvar fc n) | pattern = patvar n+    elab' ina (PPatvar fc n) | bindfree = do patvar n; -- update_term liftPats --    elab' (_, _, inty) (PRef fc f)---       | isTConName f (tt_ctxt ist) && pattern && not reflect && not inty---          = lift $ tfail (Msg "Typecase is not allowed") -    elab' (ina, guarded, inty) (PRef fc n) | pattern && not (inparamBlock n)+--       | isTConName f (tt_ctxt ist) && pattern && not reflection && not inty+--          = lift $ tfail (Msg "Typecase is not allowed")+    elab' (ina, guarded, inty, qq) (PRef fc n) +      | (pattern || (bindfree && bindable n)) && not (inparamBlock n) && not qq         = do ctxt <- get_context              let defined = case lookupTy n ctxt of                                [] -> False                                _ -> True            -- this is to stop us resolve type classes recursively              -- trace (show (n, guarded)) $-             if (tcname n && ina) then erun fc $ patvar n+             if (tcname n && ina) then erun fc $ do patvar n; -- update_term liftPats                else if (defined && not guarded)                        then do apply (Var n) []; solve                        else try (do apply (Var n) []; solve)-                                (patvar n)+                                (do patvar n; ) -- update_term liftPats)       where inparamBlock n = case lookupCtxtName n (inblock info) of                                 [] -> False                                 _ -> True+            bindable (NS _ _) = False+            bindable (UN xs) = True+            bindable n = implicitable n     elab' ina f@(PInferRef fc n) = elab' ina (PApp fc f [])     elab' ina (PRef fc n) = erun fc $ do apply (Var n) []; solve-    elab' ina@(_, a, inty) (PLam n Placeholder sc)+    elab' ina@(_, a, inty, qq) (PLam n Placeholder sc)           = do -- if n is a type constructor name, this makes no sense...                ctxt <- get_context                when (isTConName n ctxt) $@@ -312,8 +357,8 @@                checkPiGoal n                attack; intro (Just n);                -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm)-               elabE (True, a, inty) sc; solve-    elab' ina@(_, a, inty) (PLam n ty sc)+               elabE (True, a, inty, qq) sc; solve+    elab' ina@(_, a, inty, qq) (PLam n ty sc)           = do tyn <- getNameFrom (sMN 0 "lamty")                -- if n is a type constructor name, this makes no sense...                ctxt <- get_context@@ -327,12 +372,12 @@                hs <- get_holes                introTy (Var tyn) (Just n)                focus tyn-               elabE (True, a, True) ty-               elabE (True, a, inty) sc+               elabE (True, a, True, qq) ty+               elabE (True, a, inty, qq) sc                solve-    elab' ina@(_, a, _) (PPi _ n Placeholder sc)-          = do attack; arg n (sMN 0 "ty"); elabE (True, a, True) sc; solve-    elab' ina@(_, a, _) (PPi _ n ty sc)+    elab' ina@(_, a, _, qq) (PPi _ n Placeholder sc)+          = do attack; arg n (sMN 0 "ty"); elabE (True, a, True, qq) sc; solve+    elab' ina@(_, a, _, qq) (PPi _ n ty sc)           = do attack; tyn <- getNameFrom (sMN 0 "ty")                claim tyn RType                n' <- case n of@@ -340,11 +385,12 @@                         _ -> return n                forall n' (Var tyn)                focus tyn-               elabE (True, a, True) ty-               elabE (True, a, True) sc+               elabE (True, a, True, qq) ty+               elabE (True, a, True, qq) sc                solve-    elab' ina@(_, a, inty) (PLet n ty val sc)-          = do attack;+    elab' ina@(_, a, inty, qq) (PLet n ty val sc)+          = do attack+               ivs <- get_instances                tyn <- getNameFrom (sMN 0 "letty")                claim tyn RType                valn <- getNameFrom (sMN 0 "letval")@@ -355,17 +401,28 @@                    Placeholder -> return ()                    _ -> do focus tyn                            explicit tyn-                           elabE (True, a, True) ty+                           elabE (True, a, True, qq) ty                focus valn-               elabE (True, a, True) val+               elabE (True, a, True, qq) val+               ivs' <- get_instances+               when (not pattern) $+                   mapM_ (\n -> do focus n+                                   g <- goal+                                   hs <- get_holes+                                   if all (\n -> n == tyn || not (n `elem` hs)) (freeNames g)+                                   -- let insts = filter tcname $ map fst (ctxtAlist (tt_ctxt ist))+                                    then try (resolveTC 7 g fn ist)+                                             (movelast n)+                                    else movelast n)+                         (ivs' \\ ivs)                env <- get_env-               elabE (True, a, inty) sc+               elabE (True, a, inty, qq) sc                -- 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@(_, a, inty) (PGoal fc r n sc) = do+    elab' ina@(_, a, inty, qq) (PGoal fc r n sc) = do          rty <- goal          attack          tyn <- getNameFrom (sMN 0 "letty")@@ -374,10 +431,10 @@          claim valn (Var tyn)          letbind n (Var tyn) (Var valn)          focus valn-         elabE (True, a, True) (PApp fc r [pexp (delab ist rty)])+         elabE (True, a, True, qq) (PApp fc r [pexp (delab ist rty)])          env <- get_env          computeLet n-         elabE (True, a, inty) sc+         elabE (True, a, inty, qq) sc          solve --          elab' ina (PLet n Placeholder --              (PApp fc r [pexp (delab ist rty)]) sc)@@ -433,16 +490,16 @@                              _ -> lift $ tfail (NoSuchVariable fn)             ns <- match_apply (Var fn') (map (\x -> (x,0)) imps)             solve-    elab' (_, _, inty) (PApp fc (PRef _ f) args')-       | isTConName f (tt_ctxt ist) && pattern && not reflect && not inty+    elab' (_, _, inty, qq) (PApp fc (PRef _ f) args')+       | isTConName f (tt_ctxt ist) && pattern && not reflection && not inty && not qq           = lift $ tfail (Msg "Typecase is not allowed")     -- if f is local, just do a simple_app-    elab' (ina, g, inty) tm@(PApp fc (PRef _ f) args)+    elab' (ina, g, inty, qq) tm@(PApp fc (PRef _ f) args)        = do env <- get_env             if (f `elem` map fst env && length args == 1)                then -- simple app, as below-                    do simple_app (elabE (ina, g, inty) (PRef fc f))-                                  (elabE (True, g, inty) (getTm (head args)))+                    do simple_app (elabE (ina, g, inty, qq) (PRef fc f))+                                  (elabE (True, g, inty, qq) (getTm (head args)))                                   (show tm)                        solve                else@@ -455,7 +512,9 @@                     -- we can unify with them                     case lookupCtxt f (idris_classes ist) of                         [] -> return ()-                        _ -> mapM_ setInjective (map getTm args)+                        _ -> do mapM_ setInjective (map getTm args)+                                -- maybe more things are solvable now+                                unifyProblems                     ctxt <- get_context                     let guarded = isConName f ctxt --                    trace ("args is " ++ show args) $ return ()@@ -468,10 +527,11 @@                     -- Sort so that the implicit tactics and alternatives go last                     let (ns', eargs) = unzip $                              sortBy cmpArg (zip ns args)-                    elabArgs ist (ina || not isinf, guarded, inty)+                    ulog <- getUnifyLog+                    elabArgs ist (ina || not isinf, guarded, inty, qq)                            [] fc False f ns'                               (f == sUN "Force")-                             (map (\x -> (False, getTm x)) eargs) -- TODO: remove this False arg+                             (map (\x -> getTm x) eargs) -- TODO: remove this False arg                     solve                     ivs' <- get_instances                     -- Attempt to resolve any type classes which have 'complete' types,@@ -495,16 +555,23 @@             -- FIXME: Better would be to allow alternative resolution to be             -- retried after more information is in.             cmpArg (_, x) (_, y)+                | constraint x && not (constraint y) = LT+                | constraint y && not (constraint x) = GT+                | otherwise                    = compare (conDepth 0 (getTm x) + priority x + alt x)                               (conDepth 0 (getTm y) + priority y + alt y)                 where alt t = case getTm t of                                    PAlternative False _ -> 5-                                   PAlternative True _ -> 1+                                   PAlternative True _ -> 2                                    PTactics _ -> 150-                                   PLam _ _ _ -> 2-                                   PRewrite _ _ _ _ -> 3-                                   _ -> 0+                                   PLam _ _ _ -> 3+                                   PRewrite _ _ _ _ -> 4+                                   PResolveTC _ -> 0+                                   _ -> 1 +            constraint (PConstraint _ _ _ _) = True+            constraint _ = False+              -- Score a point for every level where there is a non-constructor             -- function (so higher score --> done later)             -- Only relevant when on lhs@@ -516,6 +583,7 @@             conDepth d (PPatvar _ _) = 0             conDepth d (PAlternative _ as) = maximum (map (conDepth d) as)             conDepth d Placeholder = 0+            conDepth d (PResolveTC _) = 0             conDepth d t = max (100 - d) 1              checkIfInjective n = do@@ -528,7 +596,14 @@                                 case lookupCtxt c (idris_classes ist) of                                    [] -> return ()                                    _ -> -- type class, set as injective-                                        mapM_ setinjArg args+                                        do mapM_ setinjArg args+                                        -- maybe we can solve more things now...+                                           ulog <- getUnifyLog+                                           probs <- get_probs+                                           traceWhen ulog ("Injective now " ++ show args ++ "\n" ++ qshow probs) $+                                             unifyProblems+                                           probs <- get_probs+                                           traceWhen ulog (qshow probs) $ return ()                             _ -> return ()                                   setinjArg (P _ n _) = setinj n@@ -542,9 +617,9 @@             setInjective (PApp _ (PRef _ n) _) = setinj n             setInjective _ = return () -    elab' ina@(_, a, inty) tm@(PApp fc f [arg])+    elab' ina@(_, a, inty, qq) tm@(PApp fc f [arg])           = erun fc $-             do simple_app (elabE ina f) (elabE (True, a, inty) (getTm arg))+             do simple_app (elabE ina f) (elabE (True, a, inty, qq) (getTm arg))                            (show tm)                 solve     elab' ina Placeholder = do (h : hs) <- get_holes@@ -593,7 +668,7 @@                    elab' ina sc                    elab' ina (PRef fc letn)                    solve-    elab' ina@(_, a, inty) c@(PCase fc scr opts)+    elab' ina@(_, a, inty, qq) c@(PCase fc scr opts)         = do attack              tyn <- getNameFrom (sMN 0 "scty")              claim tyn RType@@ -602,7 +677,7 @@              claim valn (Var tyn)              letbind scvn (Var tyn) (Var valn)              focus valn-             elabE (True, a, inty) scr+             elabE (True, a, inty, qq) scr              args <- get_env              cname <- unique_hole' True (mkCaseName fn)              let cname' = mkN cname@@ -629,6 +704,85 @@     elab' ina (PUnifyLog t) = do unifyLog True                                  elab' ina t                                  unifyLog False+    elab' (ina, g, inty, qq) (PQuasiquote t goal) -- TODO: goal type+        = do -- First extract the unquoted subterms, replacing them with fresh+             -- names in the quasiquoted term. Claim their reflections to be+             -- of type TT.+             (t, unq) <- extractUnquotes t+             let unquoteNames = map fst unq+             mapM_ (flip claim (Var tt)) unquoteNames+++             -- Save the old state - we need a fresh proof state to avoid+             -- capturing lexically available variables in the quoted term.+             ctxt <- get_context+             saveState+             updatePS (const .+                       newProof (sMN 0 "q") ctxt $+                       P Ref tt Erased)++             -- Re-add the unquotes, letting Idris infer the (fictional)+             -- types. Here, they represent the real type rather than the type+             -- of their reflection.+             mapM_ (\n -> do ty <- getNameFrom (sMN 0 "unqTy")+                             claim ty RType+                             movelast ty+                             claim n (Var ty)+                             movelast n)+                   unquoteNames++             -- Determine whether there's an explicit goal type, and act accordingly+             -- Establish holes for the type and value of the term to be+             -- quasiquoted+             qTy <- getNameFrom (sMN 0 "qquoteTy")+             claim qTy RType+             movelast qTy+             qTm <- getNameFrom (sMN 0 "qquoteTm")+             claim qTm (Var qTy)++             -- Let-bind the result of elaborating the contained term, so that+             -- the hole doesn't disappear+             nTm <- getNameFrom (sMN 0 "quotedTerm")+             letbind nTm (Var qTy) (Var qTm)++             -- Fill out the goal type, if relevant+             case goal of+               Nothing  -> return ()+               Just gTy -> do focus qTy+                              elabE (ina, g, inty, True) gTy++             -- Elaborate the quasiquoted term into the hole+             focus qTm+             elabE (ina, g, inty, True) t+             end_unify++             -- We now have an elaborated term. Reflect it and solve the+             -- original goal in the original proof state.+             env <- get_env+             loadState+             let quoted = fmap (explicitNames . binderVal) $ lookup nTm env++             case quoted of+               Just q -> do ctxt <- get_context+                            (q', _, _) <- lift $ recheck ctxt [(uq, Lam Erased) | uq <- unquoteNames] (forget q) q+                            if pattern+                              then reflectQuotePattern unquoteNames q'+                              else do fill $ reflectQuote unquoteNames q'+                                      solve+               Nothing -> lift . tfail . Msg $ "Broken elaboration of quasiquote"++             -- Finally fill in the terms or patterns from the unquotes. This+             -- happens last so that their holes still exist while elaborating+             -- the main quotation.+             mapM_ elabUnquote unq+      where tt = sNS (sUN "TT") ["Reflection", "Language"]++            elabUnquote (n, tm)+                = do focus n+                     elabE (ina, g, inty, False) tm+++    elab' ina (PUnquote t) = fail "Found unquote outside of quasiquote"     elab' ina x = fail $ "Unelaboratable syntactic form " ++ showTmImpls x      isScr :: PTerm -> (Name, Binder Term) -> (Name, (Bool, Binder Term))@@ -687,16 +841,17 @@         do ty <- goal            env <- get_env            let (tyh, _) = unApply (normalise (tt_ctxt ist) env ty)-           let tries = if pattern then [t, mkDelay t] else [mkDelay t, t]+           let tries = if pattern then [t, mkDelay env t] else [mkDelay env t, t]            case tyh of                 P _ (UN l) _ | l == txt "Lazy'"                     -> return (PAlternative False tries)                 _ -> return t       where-        mkDelay (PAlternative b xs) = PAlternative b (map mkDelay xs)-        mkDelay t = let fc = fileFC "Delay" in-                        addImpl ist (PApp fc (PRef fc (sUN "Delay"))-                                          [pexp t])+        mkDelay env (PAlternative b xs) = PAlternative b (map (mkDelay env) xs)+        mkDelay env t +            = let fc = fileFC "Delay" in+                  addImplBound ist (map fst env) (PApp fc (PRef fc (sUN "Delay"))+                                                 [pexp t])      -- case is tricky enough without implicit coercions! If they are needed,     -- they can go in the branches separately.@@ -712,32 +867,29 @@                          (PCoerced tm, _) -> tm                          (_, []) -> t                          (_, cs) -> PAlternative False [t ,-                                       PAlternative True (map (mkCoerce t) cs)]+                                       PAlternative True (map (mkCoerce env t) cs)]            return t'        where-         mkCoerce t n = let fc = fileFC "Coercion" in -- line never appears!-                            addImpl ist (PApp fc (PRef fc n) [pexp (PCoerced t)])+         mkCoerce env t n = let fc = fileFC "Coercion" in -- line never appears!+                                addImplBound ist (map fst env)+                                  (PApp fc (PRef fc n) [pexp (PCoerced t)])      -- | Elaborate the arguments to a function     elabArgs :: IState -- ^ The current Idris state-             -> (Bool, Bool, Bool) -- ^ (in an argument, guarded, in a type)+             -> (Bool, Bool, Bool, Bool) -- ^ (in an argument, guarded, in a type, in a qquote)              -> [Bool]              -> FC -- ^ Source location              -> Bool              -> Name -- ^ Name of the function being applied              -> [(Name, Name)] -- ^ (Argument Name, Hole Name)              -> Bool -- ^ under a 'force'-             -> [(Bool, PTerm)] -- ^ (Laziness, argument)+             -> [PTerm] -- ^ (Laziness, argument)              -> ElabD ()     elabArgs ist ina failed fc retry f [] force _ = return ()-    elabArgs ist ina failed fc r f (n:ns) force ((_, Placeholder) : args)+    elabArgs ist ina failed fc r f (n:ns) force (Placeholder : args)         = elabArgs ist ina failed fc r f ns force args-    elabArgs ist ina failed fc r f ((argName, holeName):ns) force ((lazy, t) : args)-        | lazy && not pattern-          = elabArg argName holeName (PApp bi (PRef bi (sUN "Delay"))-                                           [pimp (sUN "a") Placeholder True,-                                            pexp t])-        | otherwise = elabArg argName holeName t+    elabArgs ist ina failed fc r f ((argName, holeName):ns) force (t : args)+        = do elabArg argName holeName t       where elabArg argName holeName t =               do now_elaborating fc f argName                  wrapErr f argName $ do@@ -749,7 +901,11 @@                    failed' <- -- trace (show (n, t, hs, tm)) $                               -- traceWhen (not (null cs)) (show ty ++ "\n" ++ showImp True t) $                               case holeName `elem` hs of-                                True -> do focus holeName; elab ina t; return failed+                                True -> do focus holeName; +                                           g <- goal+                                           ulog <- getUnifyLog+                                           traceWhen ulog ("Elaborating argument " ++ show (argName, holeName, g)) $ +                                             elab ina t; return failed                                 False -> return failed                    done_elaborating_arg f argName                    elabArgs ist ina failed fc r f ns force args@@ -842,11 +998,11 @@     | otherwise = []  trivial' ist-    = trivial (elab ist toplevel False [] (sMN 0 "tac")) ist+    = trivial (elab ist toplevel ERHS [] (sMN 0 "tac")) ist proofSearch' ist rec depth prv top n hints     = do unifyProblems          proofSearch rec prv depth -                     (elab ist toplevel False [] (sMN 0 "tac")) top n hints ist+                     (elab ist toplevel ERHS [] (sMN 0 "tac")) top n hints ist  resolveTC :: Int -> Term -> Name -> IState -> ElabD () resolveTC = resTC' [] @@ -920,7 +1076,8 @@                 args <- map snd <$> try' (apply (Var n) imps)                                          (match_apply (Var n) imps) True                 ps' <- get_probs-                when (length ps < length ps') $ fail "Can't apply type class"+                when (length ps < length ps' || unrecoverable ps') $ +                     fail "Can't apply type class" --                 traceWhen (all boundVar ttypes) ("Progress: " ++ show t ++ " with " ++ show n) $                 mapM_ (\ (_,n) -> do focus n                                      t' <- goal@@ -956,6 +1113,24 @@ collectDeferred top (App f a) = liftM2 App (collectDeferred top f) (collectDeferred top a) collectDeferred top t = return t +case_ :: Bool -> Bool -> IState -> Name -> PTerm -> ElabD ()+case_ ind autoSolve ist fn tm = do+  attack+  tyn <- getNameFrom (sMN 0 "ity")+  claim tyn RType+  valn <- getNameFrom (sMN 0 "ival")+  claim valn (Var tyn)+  letn <- getNameFrom (sMN 0 "irule")+  letbind letn (Var tyn) (Var valn)+  focus valn+  elab ist toplevel ERHS [] (sMN 0 "tac") tm+  env <- get_env+  let (Just binding) = lookup letn env+  let val = binderVal binding+  if ind then induction (forget val)+         else casetac (forget val)+  when autoSolve solveAll+ -- Running tactics directly -- if a tactic adds unification problems, return an error @@ -963,9 +1138,10 @@ runTac autoSolve ist fn tac      = do env <- get_env          g <- goal+         let tac' = fmap (addImplBound ist (map fst env)) tac          if autoSolve -            then runT (fmap (addImplBound ist (map fst env)) tac)-            else no_errors (runT (fmap (addImplBound ist (map fst env)) tac))+            then runT tac'+            else no_errors (runT tac')                    (Just (CantSolveGoal g (map (\(n, b) -> (n, binderTy b)) env)))   where     runT (Intro []) = do g <- goal@@ -981,7 +1157,7 @@       where         bname (Bind n _ _) = Just n         bname _ = Nothing-    runT (Exact tm) = do elab ist toplevel False [] (sMN 0 "tac") tm+    runT (Exact tm) = do elab ist toplevel ERHS [] (sMN 0 "tac") tm                          when autoSolve solveAll     runT (MatchRefine fn)         = do fnimps <-@@ -1030,7 +1206,7 @@                    letn <- getNameFrom (sMN 0 "equiv_val")                    letbind letn (Var tyn) (Var valn)                    focus tyn-                   elab ist toplevel False [] (sMN 0 "tac") tm+                   elab ist toplevel ERHS [] (sMN 0 "tac") tm                    focus valn                    when autoSolve solveAll     runT (Rewrite tm) -- to elaborate tm, let bind it, then rewrite by that@@ -1043,12 +1219,13 @@                    letn <- getNameFrom (sMN 0 "rewrite_rule")                    letbind letn (Var tyn) (Var valn)                    focus valn-                   elab ist toplevel False [] (sMN 0 "tac") tm+                   elab ist toplevel ERHS [] (sMN 0 "tac") tm                    rewrite (Var letn)                    when autoSolve solveAll-    runT (Induction nm)-              = do induction nm-                   when autoSolve solveAll+    runT (Induction tm) -- let bind tm, similar to the others+              = case_ True autoSolve ist fn tm+    runT (CaseTac tm)+              = case_ False autoSolve ist fn tm     runT (LetTac n tm)               = do attack                    tyn <- getNameFrom (sMN 0 "letty")@@ -1058,7 +1235,7 @@                    letn <- unique_hole n                    letbind letn (Var tyn) (Var valn)                    focus valn-                   elab ist toplevel False [] (sMN 0 "tac") tm+                   elab ist toplevel ERHS [] (sMN 0 "tac") tm                    when autoSolve solveAll     runT (LetTacTy n ty tm)               = do attack@@ -1069,9 +1246,9 @@                    letn <- unique_hole n                    letbind letn (Var tyn) (Var valn)                    focus tyn-                   elab ist toplevel False [] (sMN 0 "tac") ty+                   elab ist toplevel ERHS [] (sMN 0 "tac") ty                    focus valn-                   elab ist toplevel False [] (sMN 0 "tac") tm+                   elab ist toplevel ERHS [] (sMN 0 "tac") tm                    when autoSolve solveAll     runT Compute = compute     runT Trivial = do trivial' ist; when autoSolve solveAll@@ -1091,7 +1268,7 @@                                scriptvar <- getNameFrom (sMN 0 "scriptvar" )                                letbind scriptvar scriptTy (Var script)                                focus script-                               elab ist toplevel False [] (sMN 0 "tac") tm+                               elab ist toplevel ERHS [] (sMN 0 "tac") tm                                (script', _) <- get_type_val (Var scriptvar)                                -- now that we have the script apply                                -- it to the reflected goal and context@@ -1124,7 +1301,7 @@              letbind scriptvar scriptTy (Var script)              focus script              ptm <- get_term-             elab ist toplevel False [] (sMN 0 "tac") +             elab ist toplevel ERHS [] (sMN 0 "tac")                    (PApp emptyFC tm [pexp (delabTy' ist [] tgoal True True)])              (script', _) <- get_type_val (Var scriptvar)              -- now that we have the script apply@@ -1152,7 +1329,7 @@                           letn <- getNameFrom (sMN 0 "letvar")                           letbind letn (Var tyn) (Var valn)                           focus valn-                          elab ist toplevel False [] (sMN 0 "tac") v+                          elab ist toplevel ERHS [] (sMN 0 "tac") v                           (value, _) <- get_type_val (Var letn)                           ctxt <- get_context                           env <- get_env@@ -1166,7 +1343,7 @@                        letn <- getNameFrom (sMN 0 "letvar")                        letbind letn (Var tyn) (Var valn)                        focus valn-                       elab ist toplevel False [] (sMN 0 "tac") v+                       elab ist toplevel ERHS [] (sMN 0 "tac") v                        (value, _) <- get_type_val (Var letn)                        ctxt <- get_context                        env <- get_env@@ -1214,7 +1391,8 @@ reifyApp ist t [Constant (Str n), x]              | t == reflm "GoalType" = liftM (GoalType n) (reify ist x) reifyApp _ t [n] | t == reflm "Intro" = liftM (Intro . (:[])) (reifyTTName n)-reifyApp _ t [n] | t == reflm "Induction" = liftM Induction (reifyTTName n)+reifyApp ist t [t'] | t == reflm "Induction" = liftM (Induction . delab ist) (reifyTT t')+reifyApp ist t [t'] | t == reflm "Case" = liftM (Induction . delab ist) (reifyTT t') reifyApp ist t [t']              | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t') reifyApp ist t [t']@@ -1421,21 +1599,159 @@  -- | Lift a term into its Language.Reflection.TT representation reflect :: Term -> Raw-reflect (P nt n t)-  = reflCall "P" [reflectNameType nt, reflectName n, reflect t]-reflect (V n)+reflect = reflectQuote []++claimTT :: Name -> ElabD Name+claimTT n = do n' <- getNameFrom n+               claim n' (Var (sNS (sUN "TT") ["Reflection", "Language"]))+               return n'++-- | Convert a reflected term to a more suitable form for pattern-matching.+-- In particular, the less-interesting bits are elaborated to _ patterns. This+-- happens to NameTypes, universe levels, names that are bound but not used,+-- and the type annotation field of the P constructor.+reflectQuotePattern :: [Name] -> Term -> ElabD ()+reflectQuotePattern unq (P _ n _)+  | n `elem` unq = -- the unquoted names have been claimed as TT already - just use them+    do fill (Var n) ; solve+  | otherwise =+    do tyannot <- claimTT (sMN 0 "pTyAnnot")+       movelast tyannot  -- use a _ pattern here+       nt <- getNameFrom (sMN 0 "nt")+       claim nt (Var (reflm "NameType"))+       movelast nt       -- use a _ pattern here+       n' <- getNameFrom (sMN 0 "n")+       claim n' (Var (reflm "TTName"))+       fill $ reflCall "P" [Var nt, Var n', Var tyannot]+       solve+       focus n'; reflectNameQuotePattern n+reflectQuotePattern unq (V n)+  = do fill $ reflCall "V" [RConstant (I n)]+       solve+reflectQuotePattern unq (Bind n b x)+  = do x' <- claimTT (sMN 0 "sc")+       movelast x'+       b' <- getNameFrom (sMN 0 "binder")+       claim b' (RApp (Var (sNS (sUN "Binder") ["Reflection", "Language"]))+                      (Var (sNS (sUN "TT") ["Reflection", "Language"])))+       if n `elem` freeNames x+         then do fill $ reflCall "Bind"+                                 [reflectName n,+                                  Var b',+                                  Var x']+                 solve+         else do any <- getNameFrom (sMN 0 "anyName")+                 claim any (Var (reflm "TTName"))+                 movelast any+                 fill $ reflCall "Bind"+                                 [Var any,+                                  Var b',+                                  Var x']+                 solve+       focus x'; reflectQuotePattern unq x+       focus b'; reflectBinderQuotePattern unq b++  where+    reflectBinderQuotePattern :: [Name] -> Binder Term -> ElabD ()+    reflectBinderQuotePattern unq (Lam t)+       = do t' <- claimTT (sMN 0 "ty"); movelast t'+            fill $ reflCall "Lam" [Var (reflm "TT"), Var t']+            solve+            focus t'; reflectQuotePattern unq t+    reflectBinderQuotePattern unq (Pi t)+       = do t' <- claimTT (sMN 0 "ty") ; movelast t'+            fill $ reflCall "Pi" [Var (reflm "TT"), Var t']+            solve+            focus t'; reflectQuotePattern unq t+    reflectBinderQuotePattern unq (Let x y)+       = do x' <- claimTT (sMN 0 "ty"); movelast x';+            y' <- claimTT (sMN 0 "v"); movelast y';+            fill $ reflCall "Let" [Var (reflm "TT"), Var x', Var y']+            solve+            focus x'; reflectQuotePattern unq x+            focus y'; reflectQuotePattern unq y+    reflectBinderQuotePattern unq (NLet x y)+       = do x' <- claimTT (sMN 0 "ty"); movelast x'+            y' <- claimTT (sMN 0 "v"); movelast y'+            fill $ reflCall "NLet" [Var (reflm "TT"), Var x', Var y']+            solve+            focus x'; reflectQuotePattern unq x+            focus y'; reflectQuotePattern unq y+    reflectBinderQuotePattern unq (Hole t)+       = do t' <- claimTT (sMN 0 "ty"); movelast t'+            fill $ reflCall "Hole" [Var (reflm "TT"), Var t']+            solve+            focus t'; reflectQuotePattern unq t+    reflectBinderQuotePattern unq (GHole _ t)+       = do t' <- claimTT (sMN 0 "ty"); movelast t'+            fill $ reflCall "GHole" [Var (reflm "TT"), Var t']+            solve+            focus t'; reflectQuotePattern unq t+    reflectBinderQuotePattern unq (Guess x y)+       = do x' <- claimTT (sMN 0 "ty"); movelast x'+            y' <- claimTT (sMN 0 "v"); movelast y'+            fill $ reflCall "Guess" [Var (reflm "TT"), Var x', Var y']+            solve+            focus x'; reflectQuotePattern unq x+            focus y'; reflectQuotePattern unq y+    reflectBinderQuotePattern unq (PVar t)+       = do t' <- claimTT (sMN 0 "ty"); movelast t'+            fill $ reflCall "PVar" [Var (reflm "TT"), Var t']+            solve+            focus t'; reflectQuotePattern unq t+    reflectBinderQuotePattern unq (PVTy t)+       = do t' <- claimTT (sMN 0 "ty"); movelast t'+            fill $ reflCall "PVTy" [Var (reflm "TT"), Var t']+            solve+            focus t'; reflectQuotePattern unq t+reflectQuotePattern unq (App f x)+  = do f' <- claimTT (sMN 0 "f"); movelast f'+       x' <- claimTT (sMN 0 "x"); movelast x'+       fill $ reflCall "App" [Var f', Var x']+       solve+       focus f'; reflectQuotePattern unq f+       focus x'; reflectQuotePattern unq x+reflectQuotePattern unq (Constant c)+  = do fill $ reflCall "TConst" [reflectConstant c]+       solve+reflectQuotePattern unq (Proj t i)+  = do t' <- claimTT (sMN 0 "t"); movelast t'+       fill $ reflCall "Proj" [Var t', RConstant (I i)]+       solve+       focus t'; reflectQuotePattern unq t+reflectQuotePattern unq (Erased)+  = do erased <- claimTT (sMN 0 "erased")+       movelast erased+       fill $ (Var erased)+       solve+reflectQuotePattern unq (Impossible)+  = do fill $ Var (reflm "Impossible")+       solve+reflectQuotePattern unq (TType exp)+  = do ue <- getNameFrom (sMN 0 "uexp")+       claim ue (Var (sNS (sUN "TTUExp") ["Reflection", "Language"]))+       movelast ue+       fill $ reflCall "TType" [Var ue]+       solve++-- | Create a reflected term, but leave refs to the provided name intact+reflectQuote :: [Name] -> Term -> Raw+reflectQuote unq (P nt n t)+  | n `elem` unq = Var n+  | otherwise = reflCall "P" [reflectNameType nt, reflectName n, reflectQuote unq t]+reflectQuote unq (V n)   = reflCall "V" [RConstant (I n)]-reflect (Bind n b x)-  = reflCall "Bind" [reflectName n, reflectBinder b, reflect x]-reflect (App f x)-  = reflCall "App" [reflect f, reflect x]-reflect (Constant c)+reflectQuote unq (Bind n b x)+  = reflCall "Bind" [reflectName n, reflectBinderQuote unq b, reflectQuote unq x]+reflectQuote unq (App f x)+  = reflCall "App" [reflectQuote unq f, reflectQuote unq x]+reflectQuote unq (Constant c)   = reflCall "TConst" [reflectConstant c]-reflect (Proj t i)-  = reflCall "Proj" [reflect t, RConstant (I i)]-reflect (Erased) = Var (reflm "Erased")-reflect (Impossible) = Var (reflm "Impossible")-reflect (TType exp) = reflCall "TType" [reflectUExp exp]+reflectQuote unq (Proj t i)+  = reflCall "Proj" [reflectQuote unq t, RConstant (I i)]+reflectQuote unq (Erased) = Var (reflm "Erased")+reflectQuote unq (Impossible) = Var (reflm "Impossible")+reflectQuote unq (TType exp) = reflCall "TType" [reflectUExp exp]  reflectNameType :: NameType -> Raw reflectNameType (Bound) = Var (reflm "Bound")@@ -1462,25 +1778,44 @@ reflectName (NErased) = Var (reflm "NErased") reflectName n = Var (reflm "NErased") -- special name, not yet implemented +-- | Elaborate a name to a pattern. This means that NS and UN will be intact,+-- while all others become _+reflectNameQuotePattern :: Name -> ElabD ()+reflectNameQuotePattern n@(UN s)+  = do fill $ reflectName n+       solve+reflectNameQuotePattern n@(NS _ _)+  = do fill $ reflectName n+       solve+reflectNameQuotePattern _ -- for all other names, match any+  = do nameHole <- getNameFrom (sMN 0 "name")+       claim nameHole (Var (reflm "TTName"))+       movelast nameHole+       fill (Var nameHole)+       solve+ reflectBinder :: Binder Term -> Raw-reflectBinder (Lam t)-   = reflCall "Lam" [Var (reflm "TT"), reflect t]-reflectBinder (Pi t)-   = reflCall "Pi" [Var (reflm "TT"), reflect t]-reflectBinder (Let x y)-   = reflCall "Let" [Var (reflm "TT"), reflect x, reflect y]-reflectBinder (NLet x y)-   = reflCall "NLet" [Var (reflm "TT"), reflect x, reflect y]-reflectBinder (Hole t)-   = reflCall "Hole" [Var (reflm "TT"), reflect t]-reflectBinder (GHole _ t)-   = reflCall "GHole" [Var (reflm "TT"), reflect t]-reflectBinder (Guess x y)-   = reflCall "Guess" [Var (reflm "TT"), reflect x, reflect y]-reflectBinder (PVar t)-   = reflCall "PVar" [Var (reflm "TT"), reflect t]-reflectBinder (PVTy t)-   = reflCall "PVTy" [Var (reflm "TT"), reflect t]+reflectBinder = reflectBinderQuote []++reflectBinderQuote :: [Name] -> Binder Term -> Raw+reflectBinderQuote unq (Lam t)+   = reflCall "Lam" [Var (reflm "TT"), reflectQuote unq t]+reflectBinderQuote unq (Pi t)+   = reflCall "Pi" [Var (reflm "TT"), reflectQuote unq t]+reflectBinderQuote unq (Let x y)+   = reflCall "Let" [Var (reflm "TT"), reflectQuote unq x, reflectQuote unq y]+reflectBinderQuote unq (NLet x y)+   = reflCall "NLet" [Var (reflm "TT"), reflectQuote unq x, reflectQuote unq y]+reflectBinderQuote unq (Hole t)+   = reflCall "Hole" [Var (reflm "TT"), reflectQuote unq t]+reflectBinderQuote unq (GHole _ t)+   = reflCall "GHole" [Var (reflm "TT"), reflectQuote unq t]+reflectBinderQuote unq (Guess x y)+   = reflCall "Guess" [Var (reflm "TT"), reflectQuote unq x, reflectQuote unq y]+reflectBinderQuote unq (PVar t)+   = reflCall "PVar" [Var (reflm "TT"), reflectQuote unq t]+reflectBinderQuote unq (PVTy t)+   = reflCall "PVTy" [Var (reflm "TT"), reflectQuote unq t]  reflectConstant :: Const -> Raw reflectConstant c@(I  _) = reflCall "I"  [RConstant c]
src/Idris/IBC.hs view
@@ -4,6 +4,7 @@  import Idris.Core.Evaluate import Idris.Core.TT+import Idris.Core.Binary import Idris.Core.CaseTree import Idris.AbsSyntax import Idris.Imports@@ -30,7 +31,7 @@ import Util.Zlib (decompressEither)  ibcVersion :: Word8-ibcVersion = 74+ibcVersion = 75  data IBCFile = IBCFile { ver :: Word8,                          sourcefile :: FilePath,@@ -617,352 +618,6 @@                x4 <- get                x5 <- get                return (CGInfo x1 x2 [] x4 x5)--instance Binary FC where-        put (FC x1 (x2, x3) (x4, x5))-          = do put x1-               put (x2 * 65536 + x3)-               put (x4 * 65536 + x5)-        get-          = do x1 <- get-               x2x3 <- get-               x4x5 <- get-               return (FC x1 (x2x3 `div` 65536, x2x3 `mod` 65536) (x4x5 `div` 65536, x4x5 `mod` 65536))---instance Binary Name where-        put x-          = case x of-                UN x1 -> do putWord8 0-                            put x1-                NS x1 x2 -> do putWord8 1-                               put x1-                               put x2-                MN x1 x2 -> do putWord8 2-                               put x1-                               put x2-                NErased -> putWord8 3-                SN x1 -> do putWord8 4-                            put x1-                SymRef x1 -> do putWord8 5-                                put x1-        get-          = do i <- getWord8-               case i of-                   0 -> do x1 <- get-                           return (UN x1)-                   1 -> do x1 <- get-                           x2 <- get-                           return (NS x1 x2)-                   2 -> do x1 <- get-                           x2 <- get-                           return (MN x1 x2)-                   3 -> return NErased-                   4 -> do x1 <- get-                           return (SN x1)-                   5 -> do x1 <- get-                           return (SymRef x1)-                   _ -> error "Corrupted binary data for Name"--instance Binary T.Text where-        put x = put (str x)-        get = do x <- get-                 return (txt x)--instance Binary SpecialName where-        put x-          = case x of-                WhereN x1 x2 x3 -> do putWord8 0-                                      put x1-                                      put x2-                                      put x3-                InstanceN x1 x2 -> do putWord8 1-                                      put x1-                                      put x2-                ParentN x1 x2 -> do putWord8 2-                                    put x1-                                    put x2-                MethodN x1 -> do putWord8 3-                                 put x1-                CaseN x1 -> do putWord8 4; put x1-                ElimN x1 -> do putWord8 5; put x1-                InstanceCtorN x1 -> do putWord8 6; put x1-        get-          = do i <- getWord8-               case i of-                   0 -> do x1 <- get-                           x2 <- get-                           x3 <- get-                           return (WhereN x1 x2 x3)-                   1 -> do x1 <- get-                           x2 <- get-                           return (InstanceN x1 x2)-                   2 -> do x1 <- get-                           x2 <- get-                           return (ParentN x1 x2)-                   3 -> do x1 <- get-                           return (MethodN x1)-                   4 -> do x1 <- get-                           return (CaseN x1)-                   5 -> do x1 <- get-                           return (ElimN x1)-                   6 -> do x1 <- get-                           return (InstanceCtorN x1)-                   _ -> error "Corrupted binary data for SpecialName"---instance Binary Const where-        put x-          = case x of-                I x1 -> do putWord8 0-                           put x1-                BI x1 -> do putWord8 1-                            put x1-                Fl x1 -> do putWord8 2-                            put x1-                Ch x1 -> do putWord8 3-                            put x1-                Str x1 -> do putWord8 4-                             put x1-                B8 x1 -> putWord8 5 >> put x1-                B16 x1 -> putWord8 6 >> put x1-                B32 x1 -> putWord8 7 >> put x1-                B64 x1 -> putWord8 8 >> put x1--                (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-                (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-                BufferType -> putWord8 25-                ManagedPtrType -> putWord8 26-        get-          = do i <- getWord8-               case i of-                   0 -> do x1 <- get-                           return (I x1)-                   1 -> do x1 <- get-                           return (BI x1)-                   2 -> do x1 <- get-                           return (Fl x1)-                   3 -> do x1 <- get-                           return (Ch x1)-                   4 -> do x1 <- get-                           return (Str x1)-                   5 -> fmap B8 get-                   6 -> fmap B16 get-                   7 -> fmap B32 get-                   8 -> fmap B64 get--                   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 (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-                   25 -> return BufferType-                   26 -> return ManagedPtrType--                   _ -> error "Corrupted binary data for Const"---instance Binary Raw where-        put x-          = case x of-                Var x1 -> do putWord8 0-                             put x1-                RBind x1 x2 x3 -> do putWord8 1-                                     put x1-                                     put x2-                                     put x3-                RApp x1 x2 -> do putWord8 2-                                 put x1-                                 put x2-                RType -> putWord8 3-                RConstant x1 -> do putWord8 4-                                   put x1-                RForce x1 -> do putWord8 5-                                put x1-        get-          = do i <- getWord8-               case i of-                   0 -> do x1 <- get-                           return (Var x1)-                   1 -> do x1 <- get-                           x2 <- get-                           x3 <- get-                           return (RBind x1 x2 x3)-                   2 -> do x1 <- get-                           x2 <- get-                           return (RApp x1 x2)-                   3 -> return RType-                   4 -> do x1 <- get-                           return (RConstant x1)-                   5 -> do x1 <- get-                           return (RForce x1)-                   _ -> error "Corrupted binary data for Raw"---instance (Binary b) => Binary (Binder b) where-        put x-          = case x of-                Lam x1 -> do putWord8 0-                             put x1-                Pi x1 -> do putWord8 1-                            put x1-                Let x1 x2 -> do putWord8 2-                                put x1-                                put x2-                NLet x1 x2 -> do putWord8 3-                                 put x1-                                 put x2-                Hole x1 -> do putWord8 4-                              put x1-                GHole x1 x2 -> do putWord8 5-                                  put x1-                                  put x2-                Guess x1 x2 -> do putWord8 6-                                  put x1-                                  put x2-                PVar x1 -> do putWord8 7-                              put x1-                PVTy x1 -> do putWord8 8-                              put x1-        get-          = do i <- getWord8-               case i of-                   0 -> do x1 <- get-                           return (Lam x1)-                   1 -> do x1 <- get-                           return (Pi x1)-                   2 -> do x1 <- get-                           x2 <- get-                           return (Let x1 x2)-                   3 -> do x1 <- get-                           x2 <- get-                           return (NLet x1 x2)-                   4 -> do x1 <- get-                           return (Hole x1)-                   5 -> do x1 <- get-                           x2 <- get-                           return (GHole x1 x2)-                   6 -> do x1 <- get-                           x2 <- get-                           return (Guess x1 x2)-                   7 -> do x1 <- get-                           return (PVar x1)-                   8 -> do x1 <- get-                           return (PVTy x1)-                   _ -> error "Corrupted binary data for Binder"---instance Binary NameType where-        put x-          = case x of-                Bound -> putWord8 0-                Ref -> putWord8 1-                DCon x1 x2 -> do putWord8 2-                                 put (x1 * 65536 + x2)-                TCon x1 x2 -> do putWord8 3-                                 put (x1 * 65536 + x2)-        get-          = do i <- getWord8-               case i of-                   0 -> return Bound-                   1 -> return Ref-                   2 -> do x1x2 <- get-                           return (DCon (x1x2 `div` 65536) (x1x2 `mod` 65536))-                   3 -> do x1x2 <- get-                           return (TCon (x1x2 `div` 65536) (x1x2 `mod` 65536))-                   _ -> error "Corrupted binary data for NameType"---instance {- (Binary n) => -} Binary (TT Name) where-        put x-          = {-# SCC "putTT" #-}-            case x of-                P x1 x2 x3 -> do putWord8 0-                                 put x1-                                 put x2---                                  put x3-                V x1 -> if (x1 >= 0 && x1 < 256)-                           then do putWord8 1-                                   putWord8 (toEnum (x1 + 1))-                           else do putWord8 9-                                   put x1-                Bind x1 x2 x3 -> do putWord8 2-                                    put x1-                                    put x2-                                    put x3-                App x1 x2 -> do putWord8 3-                                put x1-                                put x2-                Constant x1 -> do putWord8 4-                                  put x1-                Proj x1 x2 -> do putWord8 5-                                 put x1-                                 putWord8 (toEnum (x2 + 1))-                Erased -> putWord8 6-                TType x1 -> do putWord8 7-                               put x1-                Impossible -> putWord8 8-        get-          = do i <- getWord8-               case i of-                   0 -> do x1 <- get-                           x2 <- get---                            x3 <- get-                           return (P x1 x2 Erased)-                   1 -> do x1 <- getWord8-                           return (V ((fromEnum x1) - 1))-                   2 -> do x1 <- get-                           x2 <- get-                           x3 <- get-                           return (Bind x1 x2 x3)-                   3 -> do x1 <- get-                           x2 <- get-                           return (App x1 x2)-                   4 -> do x1 <- get-                           return (Constant x1)-                   5 -> do x1 <- get-                           x2 <- getWord8-                           return (Proj x1 ((fromEnum x2)-1))-                   6 -> return Erased-                   7 -> do x1 <- get-                           return (TType x1)-                   8 -> return Impossible-                   9 -> do x1 <- get-                           return (V x1)-                   _ -> error "Corrupted binary data for TT"- instance Binary SC where         put x           = case x of@@ -1264,11 +919,13 @@     Codata -> putWord8 0     DefaultEliminator -> putWord8 1     DataErrRev -> putWord8 2+    DefaultCaseFun -> putWord8 3   get = do i <- getWord8            case i of             0 -> return Codata             1 -> return DefaultEliminator             2 -> return DataErrRev+            3 -> return DefaultCaseFun  instance Binary FnOpt where         put x@@ -1344,11 +1001,13 @@           = case x of                 HideDisplay -> putWord8 0                 InaccessibleArg -> putWord8 1+                AlwaysShow -> putWord8 2         get           = do i <- getWord8                case i of                    0 -> return HideDisplay                    1 -> return InaccessibleArg+                   2 -> return AlwaysShow                    _ -> error "Corrupted binary data for Static"  instance Binary Static where@@ -1582,7 +1241,7 @@                     1 -> do x1 <- get; x2 <- get; return (UConstraint x1 x2)  instance Binary SyntaxInfo where-        put (Syn x1 x2 x3 x4 _ x5 x6 _ _ x7)+        put (Syn x1 x2 x3 x4 _ x5 x6 _ _ x7 _)           = do put x1                put x2                put x3@@ -1598,7 +1257,7 @@                x5 <- get                x6 <- get                x7 <- get-               return (Syn x1 x2 x3 x4 id x5 x6 Nothing 0 x7)+               return (Syn x1 x2 x3 x4 id x5 x6 Nothing 0 x7 False)  instance (Binary t) => Binary (PClause' t) where         put x@@ -1747,10 +1406,12 @@                                   put x2                 PResolveTC x1 -> do putWord8 15                                     put x1-                PEq x1 x2 x3 -> do putWord8 16-                                   put x1-                                   put x2-                                   put x3+                PEq x1 x2 x3 x4 x5 -> do putWord8 16+                                         put x1+                                         put x2+                                         put x3+                                         put x4+                                         put x5                 PRewrite x1 x2 x3 x4 -> do putWord8 17                                            put x1                                            put x2@@ -1864,7 +1525,9 @@                    16 -> do x1 <- get                             x2 <- get                             x3 <- get-                            return (PEq x1 x2 x3)+                            x4 <- get+                            x5 <- get+                            return (PEq x1 x2 x3 x4 x5)                    17 -> do x1 <- get                             x2 <- get                             x3 <- get@@ -1968,6 +1631,8 @@                                                  put x4                                                  put x5                 DoUnify -> putWord8 22+                CaseTac x1 -> do putWord8 23+                                 put x1         get           = do i <- getWord8                case i of@@ -2016,6 +1681,8 @@                             x5 <- get                             return (ProofSearch x1 x2 x3 x4 x5)                    22 -> return DoUnify+                   23 -> do x1 <- get+                            return (CaseTac x1)                    _ -> error "Corrupted binary data for PTactic'"  @@ -2191,7 +1858,7 @@                return (Rule x1 x2 x3)  instance (Binary t) => Binary (DSL' t) where-        put (DSL x1 x2 x3 x4 x5 x6 x7 x8 x9)+        put (DSL x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)           = do put x1                put x2                put x3@@ -2201,6 +1868,7 @@                put x7                put x8                put x9+               put x10         get           = do x1 <- get                x2 <- get@@ -2211,7 +1879,8 @@                x7 <- get                x8 <- get                x9 <- get-               return (DSL x1 x2 x3 x4 x5 x6 x7 x8 x9)+               x10 <- get+               return (DSL x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)  instance Binary SSymbol where         put x
src/Idris/IdeSlave.hs view
@@ -5,12 +5,16 @@ import Text.Printf import Numeric import Data.List+import qualified Data.Binary as Binary+import qualified Data.ByteString.Base64 as Base64+import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString.UTF8 as UTF8 -- import qualified Data.Text as T import Text.Trifecta hiding (Err) import Text.Trifecta.Delta  import Idris.Core.TT+import Idris.Core.Binary  import Control.Applicative hiding (Const) @@ -128,7 +132,15 @@                        BoldText      -> "bold"                        ItalicText    -> "italic"                        UnderlineText -> "underline"+  toSExp (AnnTerm bnd tm) = toSExp [(SymbolAtom "tt-term", StringAtom (encodeTerm bnd tm))] +encodeTerm :: [(Name, Bool)] -> Term -> String+encodeTerm bnd tm = UTF8.toString . Base64.encode . Lazy.toStrict . Binary.encode $+                    (bnd, tm)++decodeTerm :: String -> ([(Name, Bool)], Term)+decodeTerm = Binary.decode . Lazy.fromStrict . Base64.decodeLenient . UTF8.fromString+ instance SExpable FC where   toSExp (FC f (sl, sc) (el, ec)) =     toSExp ((SymbolAtom "filename", StringAtom f),@@ -185,6 +197,9 @@                      | Metavariables Int -- ^^ the Int is the column count for pretty-printing                      | WhoCalls String                      | CallsWho String+                     | TermNormalise [(Name, Bool)] Term+                     | TermShowImplicits [(Name, Bool)] Term+                     | TermNoImplicits [(Name, Bool)] Term  sexpToCommand :: SExp -> Maybe IdeSlaveCommand sexpToCommand (SexpList (x:[]))                                                         = sexpToCommand x@@ -221,6 +236,12 @@ sexpToCommand (SexpList [SymbolAtom "metavariables", IntegerAtom cols])                 = Just (Metavariables (fromIntegral cols)) sexpToCommand (SexpList [SymbolAtom "who-calls", StringAtom name])                      = Just (WhoCalls name) sexpToCommand (SexpList [SymbolAtom "calls-who", StringAtom name])                      = Just (CallsWho name)+sexpToCommand (SexpList [SymbolAtom "normalise-term", StringAtom encoded])              = let (bnd, tm) = decodeTerm encoded in+                                                                                          Just (TermNormalise bnd tm)+sexpToCommand (SexpList [SymbolAtom "show-term-implicits", StringAtom encoded])         = let (bnd, tm) = decodeTerm encoded in+                                                                                          Just (TermShowImplicits bnd tm)+sexpToCommand (SexpList [SymbolAtom "hide-term-implicits", StringAtom encoded])         = let (bnd, tm) = decodeTerm encoded in+                                                                                          Just (TermNoImplicits bnd tm) sexpToCommand _                                                                         = Nothing  parseMessage :: String -> Either Err (SExp, Integer)
src/Idris/IdrisDoc.hs view
@@ -14,7 +14,7 @@ import Idris.Docs import Idris.Docstrings (nullDocstring) -import Paths_idris (getDataFileName)+import IRTS.System (getDataFileName)  import Control.Monad (forM_) import Control.Monad.Trans.Error@@ -285,7 +285,7 @@ extractPTermNames (PCase _ p ps)     = let (ps1, ps2) = unzip ps                                        in  concatMap extract (p:(ps1 ++ ps2)) extractPTermNames (PRefl _ p)        = extract p-extractPTermNames (PEq _ p1 p2)      = concatMap extract [p1, p2]+extractPTermNames (PEq _ _ _ p1 p2)  = concatMap extract [p1, p2] extractPTermNames (PRewrite _ a b m) | Just c <- m =                                        concatMap extract [a, b, c] extractPTermNames (PRewrite _ a b _) = concatMap extract [a, b]@@ -334,7 +334,8 @@ extractPTactic (Focus n)          = [n] extractPTactic (Refine n _)       = [n] extractPTactic (Rewrite p)        = extract p-extractPTactic (Induction n)      = [n]+extractPTactic (Induction p)      = extract p+extractPTactic (CaseTac p)        = extract p extractPTactic (Equiv p)          = extract p extractPTactic (MatchRefine n)    = [n] extractPTactic (LetTac n p)       = n : extract p
src/Idris/Imports.hs view
@@ -4,7 +4,6 @@ import Idris.Error  import Idris.Core.TT-import Paths_idris  import System.FilePath import System.Directory
src/Idris/Interactive.hs view
@@ -12,6 +12,7 @@ import Idris.CaseSplit import Idris.AbsSyntax import Idris.ElabDecls+import Idris.ElabTerm import Idris.Error import Idris.Delaborate import Idris.Output@@ -26,6 +27,7 @@ import Data.Char import Data.Maybe (fromMaybe) +import Debug.Trace  caseSplitAt :: Handle -> FilePath -> Bool -> Int -> Name -> Idris () caseSplitAt h fn updatefile l n@@ -173,7 +175,7 @@          let def = PClause fc mn (PRef fc mn) [] (body top) []          newmv <- idrisCatch              (do elabDecl' EAll toplevel (PClauses fc [] mn [def])-                 (tm, ty) <- elabVal toplevel False (PRef fc mn)+                 (tm, ty) <- elabVal toplevel ERHS (PRef fc mn)                  ctxt <- getContext                  i <- getIState                  return . flip displayS "" . renderPretty 1.0 80 $@@ -247,12 +249,15 @@                     [] -> ierror (NoSuchVariable n)                     ns -> ierror (CantResolveAlts (map fst ns))         i <- getIState+        margs <- case lookup n (idris_metavars i) of+                      Just (_, arity, _) -> return arity+                      _ -> return (-1)          if (not isProv) then do             let skip = guessImps (tt_ctxt i) mty              let lem = show n ++ " : " ++ show (stripMNBind skip (delab i mty))-            let lem_app = show n ++ appArgs skip mty+            let lem_app = show n ++ appArgs skip margs mty              if updatefile then                do let fb = fn ++ "~"@@ -270,7 +275,7 @@                         in runIO . hPutStrLn h $ convSExp "return" good n            else do -- provisional definition-            let lem_app = show n ++ appArgs [] mty +++            let lem_app = show n ++ appArgs [] (-1) mty ++                                  " = ?" ++ show n ++ "_rhs"             if updatefile then                do let fb = fn ++ "~"@@ -287,15 +292,17 @@    where getIndent s = length (takeWhile isSpace s) -        appArgs skip (Bind n@(UN c) (Pi _) sc) -           | thead c /= '_' && n `notElem` skip-                = " " ++ show n ++ appArgs skip sc-        appArgs skip (Bind _ (Pi _) sc) = appArgs skip sc-        appArgs skip _ = ""+        appArgs skip 0 _ = ""+        appArgs skip i (Bind n@(UN c) (Pi _) sc) +           | (thead c /= '_' && n `notElem` skip)+                = " " ++ show n ++ appArgs skip (i - 1) sc+        appArgs skip i (Bind _ (Pi _) sc) = appArgs skip (i - 1) sc+        appArgs skip i _ = ""          stripMNBind skip (PPi b n@(UN c) ty sc) -           | thead c /= '_' && -             n `notElem` skip = PPi b n ty (stripMNBind skip sc)+           | (thead c /= '_' && n `notElem` skip) ||+               take 4 (str c) == "__pi" -- keep in type, but not in app+                = PPi b n ty (stripMNBind skip sc)         stripMNBind skip (PPi b _ ty sc) = stripMNBind skip sc         stripMNBind skip t = t
src/Idris/Output.hs view
@@ -15,6 +15,7 @@  import System.IO (stdout, Handle, hPutStrLn) +import Data.Char (isAlpha) import Data.List (nub) import Data.Maybe (fromMaybe) @@ -73,10 +74,21 @@                                        let infixes = idris_infixes ist                                        let output = vsep (map (uncurry (ppOverload ppo infixes)) overloads)                                        ihRenderResult h output-  where fullName n = prettyName True bnd n+  where fullName n = prettyName True True bnd n         ppOverload ppo infixes n tm =           fullName n <+> colon <+> align (pprintPTerm ppo bnd [] infixes tm) +ihRenderOutput :: Handle -> Doc OutputAnnotation -> Idris ()+ihRenderOutput h doc =+  do i <- getIState+     case idris_outputmode i of+       RawOutput -> do out <- iRender doc+                       runIO $ putStrLn (displayDecorated (consoleDecorate i) out)+       IdeSlave n ->+        do (str, spans) <- fmap displaySpans . iRender . fmap (fancifyAnnots i) $ doc+           let out = [toSExp str, toSExp spans]+           runIO . putStrLn $ convSExp "write-decorated" out n+ ihRenderResult :: Handle -> Doc OutputAnnotation -> Idris () ihRenderResult h d = do ist <- getIState                         case idris_outputmode ist of@@ -84,7 +96,7 @@                           IdeSlave n -> ideSlaveReturnAnnotated n h d  ideSlaveReturnWithStatus :: String -> Integer -> Handle -> Doc OutputAnnotation -> Idris ()-ideSlaveReturnWithStatus status n h out = do +ideSlaveReturnWithStatus status n h out = do   ist <- getIState   (str, spans) <- fmap displaySpans .                   iRender .@@ -140,13 +152,15 @@                                    IdeSlave n -> runIO . putStrLn $ convSExp cmd info n                                    _ -> return () --- this needs some typing magic and more structured output towards emacs+-- TODO: send structured output similar to the metavariable list iputGoal :: SimpleDoc OutputAnnotation -> Idris () iputGoal g = do i <- getIState                 case idris_outputmode i of                   RawOutput -> runIO $ putStrLn (displayDecorated (consoleDecorate i) g)-                  IdeSlave n -> runIO . putStrLn $-                                convSExp "write-goal" (displayS (fmap (fancifyAnnots i) g) "") n+                  IdeSlave n ->+                    let (str, spans) = displaySpans . fmap (fancifyAnnots i) $ g+                        goal = [toSExp str, toSExp spans]+                    in runIO . putStrLn $ convSExp "write-goal" goal n  -- | Warn about totality problems without failing to compile warnTotality :: Idris ()
src/Idris/ParseData.hs view
@@ -79,12 +79,13 @@ dataI = do reserved "data"; return []     <|> do reserved "codata"; return [Codata] -{- | Parses if a data should not have a default eliminator +{- | Parses if a data should not have a default eliminator DefaultEliminator ::= 'noelim'?  -} dataOpts :: DataOpts -> IdrisParser DataOpts dataOpts opts-    = do reserved "%elim"; dataOpts (DefaultEliminator : opts)+    = do reserved "%elim"; dataOpts (DefaultEliminator : DefaultCaseFun : opts)+  <|> do reserved "%case"; dataOpts (DefaultCaseFun : opts)   <|> do reserved "%error_reverse"; dataOpts (DataErrRev : opts)   <|> return opts   <?> "data options"@@ -129,7 +130,7 @@                     let tyn = expandNS syn tyn_in                     option (PData doc argDocs syn fc dataOpts (PLaterdecl tyn ty)) (do                       try (lchar '=') <|> do reserved "where"-                                             let kw = (if DefaultEliminator `elem` dataOpts then "" else "%noelim ") ++ (if Codata `elem` dataOpts then "co" else "") ++ "data "+                                             let kw = (if DefaultEliminator `elem` dataOpts then "%elim" else "") ++ (if Codata `elem` dataOpts then "co" else "") ++ "data "                                              let n  = show tyn_in ++ " "                                              let s  = kw ++ n                                              let as = concat (intersperse " " $ map show args) ++ " "@@ -209,12 +210,14 @@                              first  = lookup "index_first" bs                              next   = lookup "index_next" bs                              leto   = lookup "let" bs-                             lambda = lookup "lambda" bs in+                             lambda = lookup "lambda" bs+                             pi     = lookup "pi" bs in                              initDSL { dsl_var = var,                                        index_first = first,                                        index_next = next,                                        dsl_lambda = lambda,-                                       dsl_let = leto }+                                       dsl_let = leto,+                                       dsl_pi = pi }  {- | Checks DSL for errors -} -- FIXME: currently does nothing, check if DSL is really sane@@ -235,6 +238,6 @@                        t <- expr syn                        return (o, t)                <?> "dsl overload declaratioN"-    where overloadable = ["let","lambda","index_first","index_next","variable"]+    where overloadable = ["let","lambda","pi","index_first","index_next","variable"]
src/Idris/ParseExpr.hs view
@@ -289,6 +289,8 @@   | Constant   | Type   | '_|_'+  | Quasiquote+  | Unquote   | '_'   ; @@@ -326,6 +328,8 @@         <|> do symbol "_|_"                fc <- getFC                return (PFalse fc)+        <|> quasiquote syn+        <|> unquote syn         <|> do lchar '_'; return Placeholder         <?> "expression" @@ -587,7 +591,35 @@                        return (pconst e)                     <?> "constraint argument" +{-| Parses a quasiquote expression (for building reflected terms using the elaborator) +> Quasiquote ::= '`(' Expr ')'++-}+quasiquote :: SyntaxInfo -> IdrisParser PTerm+quasiquote syn = do guard (not (syn_in_quasiquote syn))+                    symbol "`("+                    e <- expr syn { syn_in_quasiquote = True , inPattern = False}+                    g <- optional $ do+                           symbol ":"+                           expr syn { inPattern = False } -- don't allow antiquotes+                    symbol ")"+                    return $ PQuasiquote e g+                 <?> "quasiquotation"++{-| Parses an unquoting inside a quasiquotation (for building reflected terms using the elaborator)++> Unquote ::= ',' Expr++-}+unquote :: SyntaxInfo -> IdrisParser PTerm+unquote syn = do guard (syn_in_quasiquote syn)+                 symbol "~"+                 e <- simpleExpr syn { syn_in_quasiquote = False }+                 return $ PUnquote e+              <?> "unquotation"++ {-| Parses a record field setter expression @ RecordType ::=@@ -748,24 +780,27 @@ @  -} let_ :: SyntaxInfo -> IdrisParser PTerm-let_ syn = try (do reserved "let"; fc <- getFC; n <- name;-                   ty <- option Placeholder (do lchar ':'; expr' syn)-                   lchar '='-                   v <- expr syn-                   ts <- option [] (do lchar '|'-                                       sepBy1 (do_alt syn) (lchar '|'))+let_ syn = try (do reserved "let"+                   ls <- indentedBlock (let_binding syn)                    reserved "in";  sc <- expr syn-                   case ts of-                        [] -> return (PLet n ty v sc)-                        alts -> return (PCase fc v ((PRef fc n, sc) : ts)))-           <|> (do reserved "let"; fc <- getFC; pat <- expr' (syn { inPattern = True } )-                   symbol "="; v <- expr syn-                   ts <- option [] (do lchar '|'-                                       sepBy1 (do_alt syn) (lchar '|'))-                   reserved "in"; sc <- expr syn-                   return (PCase fc v ((pat, sc) : ts)))+                   return (buildLets ls sc))            <?> "let binding"+  where buildLets [] sc = sc+        buildLets ((fc,PRef _ n,ty,v,[]):ls) sc+          = PLet n ty v (buildLets ls sc)+        buildLets ((fc,pat,ty,v,alts):ls) sc+          = PCase fc v ((pat, buildLets ls sc) : alts) +let_binding syn = do fc <- getFC; +                     pat <- expr' (syn { inPattern = True })+                     ty <- option Placeholder (do lchar ':'; expr' syn)+                     lchar '='+                     v <- expr syn+                     ts <- option [] (do lchar '|'+                                         sepBy1 (do_alt syn) (lchar '|'))+                     return (fc,pat,ty,v,ts)+                  + {- | Parses a quote goal  @@@ -816,7 +851,7 @@                    symbol "->"                    sc <- expr syn                    return (bindList (PPi-                     (TacImp [] Dynamic (PTactics [Trivial]))) xt sc)) <|> (do+                     (TacImp [] Dynamic (PTactics [ProofSearch True True 100 Nothing []]))) xt sc)) <|> (do                        try (lchar '{' *> reserved "default")                        when (st == Static) $ fail "default tactic constraints can not be lazy or static"                        script <- simpleExpr syn@@ -1033,9 +1068,10 @@    <?> "do block expression"  do_alt syn = do l <- expr' syn-                symbol "=>"-                r <- expr' syn-                return (l, r)+                option (Placeholder, l)+                       (do symbol "=>"+                           r <- expr' syn+                           return (l, r))  {- | Parses an expression in idiom brackets @@@ -1136,6 +1172,7 @@        |   'refine'      Name Imp+        |   'mrefine'     Name        |   'rewrite'     Expr+       |   'induction'   Expr        |   'equiv'       Expr        |   'let'         Name ':' Expr' '=' Expr        |   'let'         Name           '=' Expr@@ -1183,8 +1220,12 @@           <|> do reserved "rewrite"; t <- (indentPropHolds gtProp *> expr syn);                  i <- get                  return $ Rewrite (desugar syn i t)-          <|> do reserved "induction"; nm <- (indentPropHolds gtProp *> fnName);-                 return $ Induction nm+          <|> do reserved "case"; t <- (indentPropHolds gtProp *> expr syn);+                 i <- get+                 return $ CaseTac (desugar syn i t)+          <|> do reserved "induction"; t <- (indentPropHolds gtProp *> expr syn);+                 i <- get+                 return $ Induction (desugar syn i t)           <|> do reserved "equiv"; t <- (indentPropHolds gtProp *> expr syn);                  i <- get                  return $ Equiv (desugar syn i t)@@ -1247,6 +1288,21 @@                           t <- (indentPropHolds gtProp *> expr syn);                           i <- get                           return $ TCheck (desugar syn i t))+                  <|> try (do reserved "doc"+                              whiteSpace+                              c <- constant+                              eof+                              return (TDocStr (Right c)))+                  <|> try (do reserved "doc"+                              whiteSpace+                              n <- (fnName <|> (string "_|_" >> return falseTy))+                              eof+                              return (TDocStr (Left n)))+                  <|> try (do reserved "search"+                              whiteSpace+                              t <- (indentPropHolds gtProp *> expr syn);+                              i <- get+                              return $ TSearch (desugar syn i t))                   <?> "prover command")           <?> "tactic"   where
src/Idris/ParseHelpers.hs view
@@ -439,7 +439,8 @@                         Nothing : xs -> lchar '}' >> return xs <?> "end of block"                         Just lvl : xs -> (do i   <- indent                                              isParen <- lookAheadMatches (char ')')-                                             if i >= lvl && not isParen+                                             isIn <- lookAheadMatches (reserved "in")+                                             if i >= lvl && not (isParen || isIn)                                                 then fail "not end of block"                                                 else return xs)                                           <|> (do notOpenBraces@@ -462,7 +463,8 @@               <|> do c <- indent; l <- lastIndent                      unless (c <= l) $ fail "not a terminator"               <|> do isParen <- lookAheadMatches (oneOf ")}|")-                     unless isParen $ fail "not a terminator"+                     isIn <- lookAheadMatches (reserved "in")+                     unless (isIn || isParen) $ fail "not a terminator"               <|> lookAhead eof  -- | Checks if application expression does not end
src/Idris/ParseOps.hs view
@@ -38,7 +38,7 @@        ++ toTable (reverse fixes) ++       [[backtick],        [binary "$" (\fc x y -> flatten $ PApp fc x [pexp y]) AssocRight],-       [binary "="  PEq AssocLeft]]+       [binary "="  (\fc x y -> PEq fc Placeholder Placeholder x y) AssocLeft]]   where     flatten :: PTerm -> PTerm -- flatten application     flatten (PApp fc (PApp _ f as) bs) = flatten (PApp fc f (as ++ bs))
src/Idris/Parser.hs view
@@ -739,7 +739,9 @@         <|> do reserved "impossible"; return PImpossible         <?> "function right hand side"   where mkN :: Name -> Name-        mkN (UN x)   = sUN (str x++"_lemma_1")+        mkN (UN x)   = if (tnull x || not (isAlpha (thead x)))+                         then sUN "infix_op_lemma_1"+                         else sUN (str x++"_lemma_1")         mkN (NS x n) = NS (mkN x) n         n' :: Name         n' = mkN n@@ -1282,7 +1284,7 @@                   -- simplify every definition do give the totality checker                   -- a better chance                   mapM_ (\n -> do logLvl 5 $ "Simplifying " ++ show n-                                  updateContext (simplifyCasedef n))+                                  updateContext (simplifyCasedef n $ getErasureInfo i))                            (map snd (idris_totcheck i))                   -- build size change graph from simplified definitions                   iLOG "Totality checking"
src/Idris/PartialEval.hs view
@@ -12,11 +12,14 @@ import Control.Monad.State import Debug.Trace +-- | Partially evaluates given terms under the given context. partial_eval :: Context -> [(Name, Maybe Int)] ->                 [Either Term (Term, Term)] ->                 [Either Term (Term, Term)] partial_eval ctxt ns tms = map peClause tms where+   -- If the term is not a clause, it is simply kept as is    peClause (Left t) = Left t+   -- If the term is a clause, specialise the right hand side    peClause (Right (lhs, rhs))        = let rhs' = specialise ctxt [] (map toLimit ns) rhs in              Right (lhs, rhs')@@ -24,20 +27,28 @@    toLimit (n, Nothing) = (n, 65536) -- somewhat arbitrary reduction limit    toLimit (n, Just l) = (n, l) +-- | Specialises the type of a partially evaluated TT function returning+-- a pair of the specialised type and the types of expected arguments. specType :: [(PEArgType, Term)] -> Type -> (Type, [(PEArgType, Term)]) specType args ty = let (t, args') = runState (unifyEq args ty) [] in                        (st (map fst args') t, map fst args')   where+    -- Specialise static argument in type by let-binding provided value instead+    -- of expecting it as a function argument     st ((ExplicitS, v) : xs) (Bind n (Pi t) sc)          = Bind n (Let t v) (st xs sc)     st ((ImplicitS, v) : xs) (Bind n (Pi t) sc)          = Bind n (Let t v) (st xs sc)+    -- Erase argument from function type     st ((UnifiedD, _) : xs) (Bind n (Pi t) sc)          = st xs sc+    -- Keep types as is     st (_ : xs) (Bind n (Pi t) sc)          = Bind n (Pi t) (st xs sc)     st _ t = t +    -- Erase implicit dynamic argument if existing argument shares it value,+    -- by substituting the value of previous argument     unifyEq (imp@(ImplicitD, v) : xs) (Bind n (Pi t) sc)          = do amap <- get               case lookup imp amap of@@ -57,6 +68,8 @@                       put (args ++ (zip xs (repeat (sUN "_"))))                       return t +-- | Creates an Idris type declaration given current state and a specialised TT function application type.+-- Can be used in combination with the output of 'specType'. mkPE_TyDecl :: IState -> [(PEArgType, Term)] -> Type -> PTerm mkPE_TyDecl ist args ty = mkty args ty   where@@ -71,12 +84,15 @@        = mkty xs t     mkty [] t = delab ist t +-- | Checks if a given argument is a type class constraint argument classConstraint ist v     | (P _ c _, args) <- unApply v = case lookupCtxt c (idris_classes ist) of                                           [_] -> True                                           _ -> False     | otherwise = False +-- | Checks if the given arguments of a type class constraint are all either constants+-- or references (i.e. that it doesn't contain any complex terms). concreteClass ist v     | not (classConstraint ist v) = False     | (P _ c _, args) <- unApply v = all concrete args@@ -88,6 +104,7 @@                                  _ -> False                     | otherwise = False +-- | Creates a new clause for a specialised function application mkPE_TermDecl :: IState -> Name -> Name ->                  [(PEArgType, Term)] -> [(PTerm, PTerm)] mkPE_TermDecl ist newname sname ns @@ -106,11 +123,15 @@   deImpArg a@(PImp _ _ _ _ _) = a { getTm = Placeholder }   deImpArg a = a -data PEArgType = ImplicitS | ImplicitD-               | ExplicitS | ExplicitD-               | UnifiedD+-- | Data type representing binding-time annotations for partial evaluation of arguments+data PEArgType = ImplicitS -- ^ Implicit static argument+               | ImplicitD -- ^ Implicit dynamic argument+               | ExplicitS -- ^ Explicit static argument+               | ExplicitD -- ^ Explicit dynamic argument+               | UnifiedD  -- ^ Erasable dynamic argument (found under unification)   deriving (Eq, Show) +-- | Get specialised applications for a given function getSpecApps :: IState -> [Name] -> Term ->                 [(Name, [(PEArgType, Term)])] getSpecApps ist env tm = ga env (explicitNames tm) where
src/Idris/Prover.hs view
@@ -9,6 +9,7 @@ import Idris.AbsSyntax import Idris.AbsSyntaxTree import Idris.Delaborate+import Idris.Docs (getDocs, pprintDocs, pprintConstDocs) import Idris.ElabDecls import Idris.ElabTerm import Idris.Parser hiding (params)@@ -17,6 +18,7 @@ import Idris.Completion import Idris.IdeSlave import Idris.Output+import Idris.TypeSearch (searchByType)  import Text.Trifecta.Result(Result(..)) @@ -78,7 +80,8 @@               OK _ -> return ()               Error e -> ierror (CantUnify False ty pty e [] 0)          ptm' <- applyOpts ptm-         updateContext (addCasedef n (CaseInfo True False) False False True False+         ei <- getErasureInfo `fmap` getIState+         updateContext (addCasedef n ei (CaseInfo True False) False False True False                                  [] []  -- argtys, inaccArgs                                  [Right (P Ref n ty, ptm)]                                  [([], P Ref n ty, ptm)]@@ -97,6 +100,8 @@                      OK (a, st') -> return (a, st')                      Error a -> ierror a   where eCheck = do res <- e+                    matchProblems True+                    unifyProblems                     probs' <- get_probs                     case probs' of                          [] -> do tm <- get_term@@ -107,7 +112,7 @@  dumpState :: IState -> ProofState -> Idris () dumpState ist (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) =-  do rendered <- iRender $ prettyName False [] nm <> colon <+> text "No more goals."+  do rendered <- iRender $ prettyName True False [] nm <> colon <+> text "No more goals."      iputGoal rendered dumpState ist ps@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ problems i _ _ ctxy _ _ _ _) = do   let OK ty  = goalAtFocus ps@@ -121,7 +126,9 @@   where     ppo = ppOptionIst ist -    tPretty bnd t = pprintPTerm ppo bnd [] (idris_infixes ist) $ delab ist t+    tPretty bnd t = annotate (AnnTerm bnd t) .+                    pprintPTerm ppo bnd [] (idris_infixes ist) $+                    delab ist t      assumptionNames :: Env -> [Name]     assumptionNames = map fst@@ -177,6 +184,8 @@             ideslavePutSExp "return" good             receiveInput e        Just (Interpret cmd) -> return (Just cmd)+       Just (TypeOf str) -> return (Just (":t " ++ str))+       Just (DocsFor str) -> return (Just (":doc " ++ str))        _ -> return Nothing  ploop :: Name -> Bool -> String -> [String] -> ElabState [PDecl] -> Maybe History -> Idris (Term, [String])@@ -208,21 +217,23 @@            (case cmd of               Failure err -> return (False, e, False, prf, Left . Msg . show . fixColour (idris_colourRepl i) $ err)               Success Undo -> do (_, st) <- elabStep e loadState-                                 return (True, st, False, init prf, Right "")-              Success ProofState -> return (True, e, False, prf, Right "")+                                 return (True, st, False, init prf, Right $ iPrintResult "")+              Success ProofState -> return (True, e, False, prf, Right $ iPrintResult "")               Success ProofTerm -> do tm <- lifte e get_term                                       iputStrLn $ "TT: " ++ show tm ++ "\n"-                                      return (False, e, False, prf, Right "")+                                      return (False, e, False, prf, Right $ iPrintResult "")               Success Qed -> do hs <- lifte e get_holes                                 when (not (null hs)) $ ifail "Incomplete proof"                                 iputStrLn "Proof completed!"-                                return (False, e, True, prf, Right "")+                                return (False, e, True, prf, Right $ iPrintResult "")               Success (TCheck (PRef _ n)) -> checkNameType n               Success (TCheck t) -> checkType t               Success (TEval t)  -> evalTerm t e+              Success (TDocStr x) -> docStr x+              Success (TSearch t) -> search t               Success tac -> do (_, e) <- elabStep e saveState                                 (_, st) <- elabStep e (runTac autoSolve i fn tac)-                                return (True, st, False, prf ++ [step], Right ""))+                                return (True, st, False, prf ++ [step], Right $ iPrintResult ""))            (\err -> return (False, e, False, prf, Left err))          ideslavePutSExp "write-proof-state" (prf', length prf')          case res of@@ -231,7 +242,7 @@            Right ok ->              if done then do (tm, _) <- elabStep st get_term                              return (tm, prf')-                     else do iPrintResult ok+                     else do ok                              ploop fn d prompt prf' st h'   where envCtxt env ctxt = foldl (\c (n, b) -> addTyDecl n Bound (binderTy b) c) ctxt env         checkNameType n = do@@ -247,11 +258,11 @@               putIState ist'               -- Unlike the REPL, metavars have no special treatment, to               -- make it easier to see how to prove with them.-              case lookupNames n ctxt' of-                [] -> ihPrintError h $ "No such variable " ++ show n-                ts -> ihPrintFunTypes h bnd n (map (\n -> (n, delabTy ist' n)) ts)+              let action = case lookupNames n ctxt' of+                             [] -> ihPrintError h $ "No such variable " ++ show n+                             ts -> ihPrintFunTypes h bnd n (map (\n -> (n, delabTy ist' n)) ts)               putIState ist-              return (False, e, False, prf, Right ""))+              return (False, e, False, prf, Right action))             (\err -> do putIState ist ; ierror err)          checkType t = do@@ -261,19 +272,19 @@               let OK env = envAtFocus (proof e)                   ctxt'  = envCtxt env ctxt               putIState ist { tt_ctxt = ctxt' }-              (tm, ty) <- elabVal toplevel False t+              (tm, ty) <- elabVal toplevel ERHS t               let ppo = ppOptionIst ist                   ty'     = normaliseC ctxt [] ty                   h       = idris_outh ist                   infixes = idris_infixes ist-              case tm of-                 TType _ ->-                   ihPrintTermWithType h (prettyImp ppo PType) type1Doc-                 _ -> let bnd = map (\x -> (fst x, False)) env in-                      ihPrintTermWithType h (pprintPTerm ppo bnd [] infixes (delab ist tm))-                                            (pprintPTerm ppo bnd [] infixes (delab ist ty))+                  action = case tm of+                    TType _ ->+                      ihPrintTermWithType h (prettyImp ppo PType) type1Doc+                    _ -> let bnd = map (\x -> (fst x, False)) env in+                         ihPrintTermWithType h (pprintPTerm ppo bnd [] infixes (delab ist tm))+                                               (pprintPTerm ppo bnd [] infixes (delab ist ty))               putIState ist-              return (False, e, False, prf, Right ""))+              return (False, e, False, prf, Right action))             (\err -> do putIState ist { tt_ctxt = ctxt } ; ierror err)          evalTerm t e = withErrorReflection $@@ -285,14 +296,32 @@                    ist'   = ist { tt_ctxt = ctxt' }                    bnd    = map (\x -> (fst x, False)) env                putIState ist'-               (tm, ty) <- elabVal toplevel False t+               (tm, ty) <- elabVal toplevel ERHS t                let tm'     = force (normaliseAll ctxt' env tm)                    ty'     = force (normaliseAll ctxt' env ty)                    ppo     = ppOption (idris_options ist')                    infixes = idris_infixes ist                    tmDoc   = pprintPTerm ppo bnd [] infixes (delab ist' tm')                    tyDoc   = pprintPTerm ppo bnd [] infixes (delab ist' ty')-               ihPrintTermWithType (idris_outh ist') tmDoc tyDoc+                   action  = ihPrintTermWithType (idris_outh ist') tmDoc tyDoc                putIState ist-               return (False, e, False, prf, Right ""))+               return (False, e, False, prf, Right action))               (\err -> do putIState ist ; ierror err)+        docStr :: Either Name Const -> Idris (Bool, ElabState [PDecl], Bool, [String], Either Err (Idris ()))+        docStr (Left n) = do ist <- getIState+                             let h = idris_outh ist+                             idrisCatch (case lookupCtxtName n (idris_docstrings ist) of+                                           [] -> return (False, e, False, prf,+                                                         Left . Msg $ "No documentation for " ++ show n)+                                           ns -> do toShow <- mapM (showDoc ist) ns+                                                    return (False,  e, False, prf,+                                                            Right $ ihRenderResult h (vsep toShow)))+                                        (\err -> do putIState ist ; ierror err)+               where showDoc ist (n, d) = do doc <- getDocs n+                                             return $ pprintDocs ist doc+        docStr (Right c) = do ist <- getIState+                              let h = idris_outh ist+                              return (False, e, False, prf, Right . ihRenderResult h $ pprintConstDocs ist c (constDocs c))+        search t = do ist <- getIState+                      let h = idris_outh ist+                      return (False, e, False, prf, Right $ searchByType h t)
src/Idris/REPL.hs view
@@ -34,7 +34,6 @@ import Idris.WhoCalls import Idris.TypeSearch (searchByType) -import Paths_idris import Version_idris (gitHash) import Util.System import Util.DynamicLinker@@ -48,8 +47,10 @@  import IRTS.Compiler import IRTS.CodegenCommon+import IRTS.System  import Data.List.Split (splitOn)+import Data.List (groupBy) import qualified Data.Text as T  import Text.Trifecta.Result(Result(..))@@ -151,6 +152,7 @@          loop fn ist sock             = do (h,_,_) <- accept sock+                 hSetEncoding h utf8                  cmd <- hGetLine h                  (ist', fn) <- processNetCmd orig ist h fn cmd                  hClose h@@ -189,6 +191,7 @@ runClient :: String -> IO () runClient str = withSocketsDo $ do                   h <- connectTo "localhost" (PortNumber 4294)+                  hSetEncoding h utf8                   hPutStrLn h str                   resp <- hGetResp "" h                   putStr resp@@ -342,34 +345,63 @@   do ist <- getIState      let mvs = reverse $ map fst (idris_metavars ist) \\ primDefs      let ppo = ppOptionIst ist-     let mvarTys = map (delabTy ist) mvs-     let res = (IdeSlave.SymbolAtom "ok",-                zipWith (\ n (prems, concl) -> (n, prems, concl))-                        (map (IdeSlave.StringAtom . show) mvs)-                        (map (sexpGoal ist cols ppo [] . getGoal) mvarTys))-     runIO . putStrLn $ IdeSlave.convSExp "return" res id-  where getGoal :: PTerm -> ([(Name, PTerm)], PTerm)-        getGoal (PPi _ n t sc) = let (prems, conc) = getGoal sc-                                 in ((n, t):prems, conc)-        getGoal tm = ([], tm)-        sexpGoal :: IState -> Int -> PPOption -> [Name] -> ([(Name, PTerm)], PTerm)-                 -> ([(String, String, SpanList OutputAnnotation)],-                     (String, SpanList OutputAnnotation))-        sexpGoal ist cols ppo ns ([],        concl) =-          let infixes = idris_infixes ist-              concl' = displaySpans . renderPretty 0.9 cols . fmap (fancifyAnnots ist) $-                       pprintPTerm ppo (zip ns (repeat False)) [] infixes concl-          in ([], concl')-        sexpGoal ist cols ppo ns ((n, t):ps, concl) =-          let n'          = case n of-                              NS (UN nm) ns -> str nm-                              UN nm | ('_':'_':_) <- str nm -> "_"-                                    | otherwise -> str nm-                              _ -> "_"-              (t', spans) = displaySpans . renderPretty 0.9 cols . fmap (fancifyAnnots ist) $-                            pprintPTerm ppo (zip ns (repeat False)) [] (idris_infixes ist) t-              rest        = sexpGoal ist cols ppo (n:ns) (ps, concl)-          in ((n', t', spans) : fst rest, snd rest)+     -- splitMvs is a list of pairs of names and their split types+     let splitMvs = mapSnd (splitPi ist) (mvTys ist mvs)+     -- mvOutput is the pretty-printed version ready for conversion to SExpr+     let mvOutput = map (\(n, (hs, c)) -> (n, hs, c)) $+                    mapPair show+                            (\(hs, c, pc) ->+                             let bnd = [ n | (n,_,_) <- hs ] in+                             let bnds = inits bnd in+                             (map (\(bnd, h) -> processPremise ist bnd h)+                                  (zip bnds hs),+                              render ist bnd c pc))+                            splitMvs+     runIO . putStrLn $+       IdeSlave.convSExp "return" (IdeSlave.SymbolAtom "ok", mvOutput) id+  where mapPair f g xs = zip (map (f . fst) xs) (map (g . snd) xs)+        mapSnd f xs = zip (map fst xs) (map (f . snd) xs)++        -- | Split a function type into a pair of premises, conclusion.+        -- Each maintains both the original and delaborated versions.+        splitPi :: IState -> Type -> ([(Name, Type, PTerm)], Type, PTerm)+        splitPi ist (Bind n (Pi t) rest) =+          let (hs, c, pc) = splitPi ist rest in+            ((n, t, delabTy' ist [] t False False):hs,+             c, delabTy' ist [] c False False)+        splitPi ist tm = ([], tm, delabTy' ist [] tm False False)++        -- | Get the types of a list of metavariable names+        mvTys :: IState -> [Name] -> [(Name, Type)]+        mvTys ist = mapSnd vToP . mapMaybe (flip lookupTyNameExact (tt_ctxt ist))++        -- | Show a type and its corresponding PTerm in a format suitable+        -- for the IDE - that is, pretty-printed and annotated.+        render :: IState -> [Name] -> Type -> PTerm -> (String, SpanList OutputAnnotation)+        render ist bnd t pt =+          let prettyT = pprintPTerm (ppOptionIst ist)+                                    (zip bnd (repeat False))+                                    []+                                    (idris_infixes ist)+                                    pt+          in+            displaySpans .+            renderPretty 0.9 cols .+            fmap (fancifyAnnots ist) .+            annotate (AnnTerm (zip bnd (take (length bnd) (repeat False))) t) $+              prettyT++        -- | Juggle the bits of a premise to prepare for output.+        processPremise :: IState+                       -> [Name] -- ^ the names to highlight as bound+                       -> (Name, Type, PTerm)+                       -> (String,+                           String,+                           SpanList OutputAnnotation)+        processPremise ist bnd (n, t, pt) =+          let (out, spans) = render ist bnd t pt in+          (show n , out, spans)+ runIdeSlaveCommand id orig fn mods (IdeSlave.WhoCalls n) =   case splitName n of        Left err -> iPrintError err@@ -381,7 +413,7 @@   where pn ist = displaySpans .                  renderPretty 0.9 1000 .                  fmap (fancifyAnnots ist) .-                 prettyName True []+                 prettyName True True [] runIdeSlaveCommand id orig fn mods (IdeSlave.CallsWho n) =   case splitName n of        Left err -> iPrintError err@@ -393,8 +425,42 @@   where pn ist = displaySpans .                  renderPretty 0.9 1000 .                  fmap (fancifyAnnots ist) .-                 prettyName True []+                 prettyName True True [] +runIdeSlaveCommand id orig fn modes (IdeSlave.TermNormalise bnd tm) =+  do ctxt <- getContext+     ist <- getIState+     let tm' = force (normaliseAll ctxt [] tm)+         ptm = annotate (AnnTerm bnd tm')+               (pprintPTerm (ppOptionIst ist)+                            bnd+                            []+                            (idris_infixes ist)+                            (delab ist tm'))+         msg = (IdeSlave.SymbolAtom "ok",+                displaySpans .+                renderPretty 0.9 80 .+                fmap (fancifyAnnots ist) $ ptm)+     runIO . putStrLn $ IdeSlave.convSExp "return" msg id+runIdeSlaveCommand id orig fn modes (IdeSlave.TermShowImplicits bnd tm) =+  ideSlaveForceTermImplicits id bnd True tm+runIdeSlaveCommand id orig fn modes (IdeSlave.TermNoImplicits bnd tm) =+  ideSlaveForceTermImplicits id bnd False tm++-- | Show a term for IDESlave with the specified implicitness+ideSlaveForceTermImplicits :: Integer -> [(Name, Bool)] -> Bool -> Term -> Idris ()+ideSlaveForceTermImplicits id bnd impl tm =+  do ist <- getIState+     let expl = annotate (AnnTerm bnd tm)+                (pprintPTerm ((ppOptionIst ist) { ppopt_impl = impl })+                             bnd [] (idris_infixes ist)+                             (delab ist tm))+         msg = (IdeSlave.SymbolAtom "ok",+                displaySpans .+                renderPretty 0.9 80 .+                fmap (fancifyAnnots ist) $ expl)+     runIO . putStrLn $ IdeSlave.convSExp "return" msg id+ splitName :: String -> Either String Name splitName s = case reverse $ splitOn "." s of                 [] -> Left ("Didn't understand name '" ++ s ++ "'")@@ -407,6 +473,8 @@ ideslaveProcess fn (ChangeDirectory f) = do process stdout fn (ChangeDirectory f)                                             iPrintResult "changed directory to" ideslaveProcess fn (Eval t) = process stdout fn (Eval t)+ideslaveProcess fn (NewDefn decls) = do process stdout fn (NewDefn decls)+                                        iPrintResult "defined" ideslaveProcess fn (ExecVal t) = process stdout fn (ExecVal t) ideslaveProcess fn (Check (PRef x n)) = process stdout fn (Check (PRef x n)) ideslaveProcess fn (Check t) = process stdout fn (Check t)@@ -585,7 +653,7 @@                       return () process h fn (Eval t)                  = withErrorReflection $ do logLvl 5 $ show t-                                            (tm, ty) <- elabVal toplevel False t+                                            (tm, ty) <- elabVal toplevel ERHS t                                             ctxt <- getContext                                             let tm' = force (normaliseAll ctxt [] tm)                                             let ty' = force (normaliseAll ctxt [] ty)@@ -594,14 +662,46 @@                                             ist <- getIState                                             logLvl 3 $ "Raw: " ++ show (tm', ty')                                             logLvl 10 $ "Debug: " ++ showEnvDbg [] tm'-                                            let tmDoc = prettyIst ist (delab ist tm')-                                                tyDoc = prettyIst ist (delab ist ty')+                                            let tmDoc = pprintDelab ist tm'+                                                tyDoc = pprintDelab ist ty'                                             ihPrintTermWithType h tmDoc tyDoc ++process h fn (NewDefn decls) = logLvl 3 ("Defining names using these decls: " ++ show namedGroups) >> mapM_ defineName namedGroups where+  namedGroups = groupBy (\d1 d2 -> getName d1 == getName d2) decls+  getName :: PDecl -> Maybe Name+  getName (PTy docs argdocs syn fc opts name ty) = Just name+  getName (PClauses fc opts name (clause:clauses)) = Just (getClauseName clause)+  getName (PData doc argdocs syn fc opts dataDecl) = Just (d_name dataDecl)+  getName _ = Nothing+  -- getClauseName is partial and I am not sure it's used safely! -- trillioneyes+  getClauseName (PClause fc name whole with rhs whereBlock) = name+  getClauseName (PWith fc name whole with rhs whereBlock) = name+  defineName :: [PDecl] -> Idris ()+  defineName (tyDecl@(PTy docs argdocs syn fc opts name ty) : decls) = do +    elabDecl EAll toplevel tyDecl+    elabClauses toplevel fc opts name (concatMap getClauses decls)+  defineName [PClauses fc opts _ [clause]] = do+    let pterm = getRHS clause+    (tm,ty) <- elabVal toplevel ERHS pterm+    ctxt <- getContext+    let tm' = force (normaliseAll ctxt [] tm)+    let ty' = force (normaliseAll ctxt [] ty)+    updateContext (addCtxtDef (getClauseName clause) (Function ty' tm'))+  defineName [PData doc argdocs syn fc opts decl] = do+    elabData toplevel syn doc argdocs fc opts decl+  getClauses (PClauses fc opts name clauses) = clauses+  getClauses _ = []+  getRHS :: PClause -> PTerm+  getRHS (PClause fc name whole with rhs whereBlock) = rhs+  getRHS (PWith fc name whole with rhs whereBlock) = rhs+  getRHS (PClauseR fc with rhs whereBlock) = rhs+  getRHS (PWithR fc with rhs whereBlock) = rhs+ process h fn (ExecVal t)                   = do ctxt <- getContext                        ist <- getIState-                       (tm, ty) <- elabVal toplevel False t+                       (tm, ty) <- elabVal toplevel ERHS t --                       let tm' = normaliseAll ctxt [] tm                        let ty' = normaliseAll ctxt [] ty                        res <- execute tm@@ -645,7 +745,7 @@   process h fn (Check t)-   = do (tm, ty) <- elabVal toplevel False t+   = do (tm, ty) <- elabVal toplevel ERHS t         ctxt <- getContext         ist <- getIState         let ppo = ppOptionIst ist@@ -653,8 +753,8 @@         case tm of            TType _ ->              ihPrintTermWithType h (prettyIst ist PType) type1Doc-           _ -> ihPrintTermWithType h (prettyIst ist (delab ist tm))-                                      (prettyIst ist (delab ist ty))+           _ -> ihPrintTermWithType h (pprintDelab ist tm)+                                      (pprintDelab ist ty)  process h fn (DocStr (Left n))    = do ist <- getIState@@ -740,7 +840,7 @@ process h fn (DoProofSearch updatefile rec l n hints)     = doProofSearch h fn updatefile rec l n hints Nothing process h fn (Spec t)-                    = do (tm, ty) <- elabVal toplevel False t+                    = do (tm, ty) <- elabVal toplevel ERHS t                          ctxt <- getContext                          ist <- getIState                          let tm' = simplify ctxt [] {- (idris_statics ist) -} tm@@ -819,13 +919,13 @@           warnTotality  process h fn (HNF t)-                    = do (tm, ty) <- elabVal toplevel False t+                    = do (tm, ty) <- elabVal toplevel ERHS t                          ctxt <- getContext                          ist <- getIState                          let tm' = hnf ctxt [] tm                          iPrintResult (show (delab ist tm')) process h fn (TestInline t)-                           = do (tm, ty) <- elabVal toplevel False t+                           = do (tm, ty) <- elabVal toplevel ERHS t                                 ctxt <- getContext                                 ist <- getIState                                 let tm' = inlineTerm ist tm@@ -834,7 +934,7 @@ process h fn Execute                    = idrisCatch                        (do ist <- getIState-                           (m, _) <- elabVal toplevel False+                           (m, _) <- elabVal toplevel ERHS                                            (PApp fc                                               (PRef fc (sUN "run__IO"))                                               [pexp $ PRef fc (sNS (sUN "main") ["Main"])])@@ -850,7 +950,7 @@                        (\e -> getIState >>= ihRenderError stdout . flip pprintErr e)   where fc = fileFC "main" process h fn (Compile codegen f)-      = do (m, _) <- elabVal toplevel False+      = do (m, _) <- elabVal toplevel ERHS                        (PApp fc (PRef fc (sUN "run__IO"))                        [pexp $ PRef fc (sNS (sUN "main") ["Main"])])            compile codegen f m@@ -858,7 +958,7 @@ process h fn (LogLvl i) = setLogLevel i -- Elaborate as if LHS of a pattern (debug command) process h fn (Pattelab t)-     = do (tm, ty) <- elabVal toplevel True t+     = do (tm, ty) <- elabVal toplevel ELHS t           iPrintResult $ show tm ++ "\n\n : " ++ show ty  process h fn (Missing n)@@ -942,8 +1042,8 @@      ist <- getIState      ihRenderResult h . vsep $        map (\(n, ns) ->-             text "Callers of" <+> prettyName True [] n <$>-             indent 1 (vsep (map ((text "*" <+>) . align . prettyName True []) ns)))+             text "Callers of" <+> prettyName True True [] n <$>+             indent 1 (vsep (map ((text "*" <+>) . align . prettyName True True []) ns)))            calls  process h fn (CallsWho n) =@@ -951,8 +1051,8 @@      ist <- getIState      ihRenderResult h . vsep $        map (\(n, ns) ->-             prettyName True [] n <+> text "calls:" <$>-             indent 1 (vsep (map ((text "*" <+>) . align . prettyName True []) ns)))+             prettyName True True [] n <+> text "calls:" <$>+             indent 1 (vsep (map ((text "*" <+>) . align . prettyName True True []) ns)))            calls -- IdrisDoc process h fn (MakeDoc s) =@@ -1276,7 +1376,7 @@                           Failure err -> do iputStrLn $ show (fixColour c err)                                             runIO $ exitWith (ExitFailure 1)                           Success term -> do ctxt <- getContext-                                             (tm, _) <- elabVal toplevel False term+                                             (tm, _) <- elabVal toplevel ERHS term                                              res <- execute tm                                              runIO $ exitWith ExitSuccess
src/Idris/REPLParser.hs view
@@ -1,3 +1,4 @@+ module Idris.REPLParser(parseCmd) where  import System.FilePath ((</>))@@ -49,6 +50,9 @@               <|> try (do cmd ["rmproof"]; n <- P.name; eof; return (RmProof n))               <|> try (do cmd ["showproof"]; n <- P.name; eof; return (ShowProof n))               <|> try (do cmd ["log"]; i <- P.natural; eof; return (LogLvl (fromIntegral i)))+              <|> try (do cmd ["let"]+                          defn <- concat <$> many (P.decl defaultSyntax)+                          return (NewDefn defn))               <|> try (do cmd ["lto", "loadto"];                           toline <- P.natural                           f <- many anyChar;@@ -61,7 +65,7 @@               <|> try (do cmd ["inline"]; P.whiteSpace; t <- P.fullExpr defaultSyntax; return (TestInline t))               <|> try (do cmd ["doc"]; c <- P.constant; eof; return (DocStr (Right c)))               <|> try (do cmd ["doc"]; n <- (P.fnName <|> (P.string "_|_" >> return falseTy)); eof; return (DocStr (Left n)))-              <|> try (do cmd ["d", "def"]; some (P.char ' ') ; n <- P.fnName; eof; return (Defn n))+              <|> try (do cmd ["d", "def"]; P.whiteSpace; n <- P.fnName; eof; return (Defn n))               <|> try (do cmd ["total"]; do n <- P.fnName; eof; return (TotCheck n))               <|> try (do cmd ["t", "type"]; do P.whiteSpace; t <- P.fullExpr defaultSyntax; return (Check t))               <|> try (do cmd ["u", "universes"]; eof; return Universes)
src/Idris/TypeSearch.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ScopedTypeVariables #-}+ module Idris.TypeSearch (   searchByType, searchPred, defaultScoreFunction ) where@@ -6,30 +8,32 @@ import Control.Arrow (first, second, (&&&)) import Control.Monad (forM_, guard) -import Data.Function (on)-import Data.List (find, minimumBy, sortBy, (\\))+import Data.List (find, delete, deleteBy, minimumBy, partition, sortBy, (\\)) import Data.Map (Map) import qualified Data.Map as M-import Data.Maybe (catMaybes, fromMaybe, isJust)+import Data.Maybe (catMaybes, fromMaybe, isJust, maybeToList, mapMaybe) import Data.Monoid (Monoid (mempty, mappend))+import Data.Ord (comparing)+import qualified Data.PriorityQueue.FingerTree as Q import Data.Set (Set) import qualified Data.Set as S+import qualified Data.Text as T (pack, isPrefixOf)  import Idris.AbsSyntax (addUsingConstraints, addImpl, getContext, getIState, putIState, implicit)-import Idris.AbsSyntaxTree (class_instances, defaultSyntax, Idris, -  IState (idris_classes, idris_docstrings, tt_ctxt),-  implicitAllowed, prettyDocumentedIst, prettyIst, PTerm, toplevel)+import Idris.AbsSyntaxTree (class_instances, ClassInfo, defaultSyntax, Idris,+  IState (idris_classes, idris_docstrings, tt_ctxt, idris_outputmode),+  implicitAllowed, OutputMode(..), prettyDocumentedIst, prettyIst, PTerm, toplevel) import Idris.Core.Evaluate (Context (definitions), Def (Function, TyDecl, CaseOp), normaliseC)-import Idris.Core.TT+import Idris.Core.TT hiding (score) import Idris.Core.Unify (match_unify)-import Idris.Delaborate (delab, delabTy)+import Idris.Delaborate (delabTy) import Idris.Docstrings (noDocs, overview) import Idris.ElabDecls (elabType')-import Idris.Output (ihRenderResult, ihPrintResult, ihPrintFunTypes)+import Idris.Output (ihRenderOutput, ihPrintResult, ihRenderResult)  import System.IO (Handle) -import Util.Pretty (text, vsep, char, (<>), Doc)+import Util.Pretty (text, char, vsep, (<>), Doc)  searchByType :: Handle -> PTerm -> Idris () searchByType h pterm = do@@ -40,264 +44,401 @@   ty <- elabType' False toplevel syn (fst noDocs) (snd noDocs) emptyFC [] n pterm'   putIState i -- don't actually make any changes   let names = searchUsing searchPred i ty-  let names' = take numLimit . takeWhile ((< scoreLimit) . getScore) $ -         sortBy (compare `on` getScore) names+  let names' = take numLimit $ names   let docs =        [ let docInfo = (n, delabTy i n, fmap (overview . fst) (lookupCtxtExact n (idris_docstrings i))) in          displayScore score <> char ' ' <> prettyDocumentedIst i docInfo-                | (n, (_,score)) <- names']-  ihRenderResult h $ vsep docs-  where -    getScore = defaultScoreFunction . snd . snd+                | (n, score) <- names']+  case idris_outputmode i of+    RawOutput -> do mapM_ (ihRenderOutput h) docs+                    ihPrintResult h ""+    IdeSlave n -> ihRenderResult h (vsep docs)+  where     numLimit = 50-    scoreLimit = 100     syn = defaultSyntax { implicitAllowed = True } -- syntax     n = sMN 0 "searchType" -- name-   -searchUsing :: (IState -> Type -> Type -> Maybe a) -> IState -> Type -> [(Name, (Type, a))]-searchUsing pred istate ty = -  concat . M.elems $ M.mapWithKey (\key -> M.toAscList . M.mapMaybe (f key)) (definitions ctxt)+-- | Conduct a type-directed search using a given match predicate+searchUsing :: (IState -> Type -> [(Name, Type)] -> [(Name, a)]) +  -> IState -> Type -> [(Name, a)]+searchUsing pred istate ty = pred istate nty . concat . M.elems $ +  M.mapWithKey (\key -> M.toAscList . M.mapMaybe (f key)) (definitions ctxt)   where+  nty = normaliseC ctxt [] ty   ctxt = tt_ctxt istate   f k x = do     guard $ not (special k)-    y <- get (fst4 x)-    let ny = normaliseC ctxt [] y-  --  traceShow k False `seq` return ()-    val <- pred istate nty ny-    return (y, val)-  nty = normaliseC ctxt [] ty-  fst4 :: (a,b,c,d) -> a-  fst4 (w,x,y,z) = w-  get :: Def -> Maybe Type-  get (Function ty tm) = Just ty-  get (TyDecl _ ty) = Just ty- -- get (Operator ty _ _) = Just ty-  get (CaseOp _ ty _ _ _ _)  = Just ty-  get _ = Nothing+    type2 <- typeFromDef x+    return $ normaliseC ctxt [] type2   special :: Name -> Bool+  special (NS n ns) = special n   special (SN _) = True+  special (UN n) =    T.pack "default#" `T.isPrefixOf` n +                   || n `elem` map T.pack ["believe_me", "really_believe_me"]   special _ = False --tcToMaybe :: TC' e a -> Maybe a-tcToMaybe (OK x) = Just x-tcToMaybe (Error _) = Nothing----searchPred :: IState -> Type -> Type -> Maybe Score-searchPred istate ty1 = \ty2 -> case matcher ty2 of-  Nothing -> Nothing-  Just xs -> guard (not (null xs)) >> return (minimumBy (compare `on` defaultScoreFunction) xs)-  where-  matcher = unifyWithHoles True istate ty1+-- Our default search predicate.+searchPred :: IState -> Type -> [(Name, Type)] -> [(Name, Score)]+searchPred istate ty1 = matcher where+  maxScore = 100+  matcher = matchTypesBulk istate maxScore ty1  +typeFromDef :: (Def, b, c, d) -> Maybe Type+typeFromDef (def, _, _, _) = get def where+  get :: Def -> Maybe Type+  get (Function ty tm) = Just ty+  get (TyDecl _ ty) = Just ty+ -- get (Operator ty _ _) = Just ty+  get (CaseOp _ ty _ _ _ _)  = Just ty+  get _ = Nothing  +-- | reverse the edges for a directed acyclic graph reverseDag :: Ord k => [((k, a), Set k)] -> [((k, a), Set k)] reverseDag xs = map f xs where   f ((k, v), _) = ((k, v), S.fromList . map (fst . fst) $ filter (S.member k . snd) xs)  -- run vToP first!+-- | Compute a directed acyclic graph corresponding to the+-- arguments of a function.  -- returns [(the name and type of the bound variable --          the names in the type of the bound variable)]-computeDagP :: Ord n => TT n -> ([((n, TT n), Set n)], TT n)-computeDagP t = (reverse (map f args), retTy) where-+computeDagP :: Ord n +  => (TT n -> Bool) -- ^ filter to remove some arguments+  -> TT n+  -> ([((n, TT n), Set n)], [(n, TT n)], TT n)+computeDagP removePred t = (reverse (map f args), reverse removedArgs , retTy) where   f (n, t) = ((n, t), M.keysSet (usedVars t)) -  (numArgs, args, retTy) = go 0 [] t+  (numArgs, args, removedArgs, retTy) = go 0 [] [] t    -- NOTE : args are in reverse order-  go k args (Bind n (Pi t) sc) = go (succ k) ( (n, t) : args ) sc-  go k args retTy = (k, args, retTy)-+  go k args removedArgs (Bind n (Pi t) sc) = let arg = (n, t) in+    if removePred t+      then go k        args (arg : removedArgs) sc+      else go (succ k) (arg : args) removedArgs sc+  go k args removedArgs retTy = (k, args, removedArgs, retTy) -usedVars :: Ord n => TT n -> Map n (TT n)-usedVars (V j) = error "unexpected! run vToP first"-usedVars (P Bound n t) = M.singleton n t `M.union` usedVars t-usedVars (Bind n binder t2) = (M.delete n (usedVars t2) `M.union`) $ case binder of-  Let t v ->   usedVars t `M.union` usedVars v-  Guess t v -> usedVars t `M.union` usedVars v-  b -> usedVars (binderTy b)-usedVars (App t1 t2) = usedVars t1 `M.union` usedVars t2-usedVars (Proj t _) = usedVars t-usedVars _ = M.empty+-- | Collect the names and types of all the free variables+-- The Boolean indicates those variables which are determined due to injectivity+-- I have not given nearly enough thought to know whether this is correct+usedVars :: Ord n => TT n -> Map n (TT n, Bool)+usedVars = f True where+  f b (P Bound n t) = M.singleton n (t, b) `M.union` f b t+  f b (Bind n binder t2) = (M.delete n (f b t2) `M.union`) $ case binder of+    Let t v ->   f b t `M.union` f b v+    Guess t v -> f b t `M.union` f b v+    bind -> f b (binderTy bind)+  f b (App t1 t2) = f b t1 `M.union` f (b && isInjective t1) t2+  f b (Proj t _) = f b t+  f _ (V j) = error "unexpected! run vToP first"+  f _ _ = M.empty +-- | Remove a node from a directed acyclic graph deleteFromDag :: Ord n => n -> [((n, TT n), (a, Set n))] -> [((n, TT n), (a, Set n))] deleteFromDag name [] = [] deleteFromDag name (((name2, ty), (ix, set)) : xs) = (if name == name2   then id   else (((name2, ty) , (ix, S.delete name set)) :) ) (deleteFromDag name xs) +deleteFromArgList :: Ord n => n -> [(n, TT n)] -> [(n, TT n)]+deleteFromArgList n = filter ((/= n) . fst)  data Score = Score-  { transposition :: Int-  , leftApplied   :: Int-  , rightApplied  :: Int-  , leftTypeClass :: Int-  , rightTypeClass :: Int } deriving (Eq, Show)+  { transposition       :: !Int+  , leftApplied         :: !Int+  , rightApplied        :: !Int+  , leftTypeClassApp    :: !Int+  , rightTypeClassApp   :: !Int+  , leftTypeClassIntro  :: !Int+  , rightTypeClassIntro :: !Int } deriving (Eq, Show)  displayScore :: Score -> Doc a-displayScore (Score trans lapp rapp lclass rclass) = text $ case (lt, gt) of-  (True , True ) -> "="-  (True , False) -> "<"-  (False, True ) -> ">"-  (False, False) -> " "-  where lt = lapp + lclass == 0-        gt = rapp + rclass == 0+displayScore (Score trans lapp rapp lclassapp rclassapp lclassintro rclassintro) = text $ case (lt, gt) of+  (True , True ) -> "=" -- types are isomorphic+  (True , False) -> "<" -- found type is more general than searched type+  (False, True ) -> ">" -- searched type is more general than found type+  (False, False) -> "_"+  where lt = lapp + lclassapp + lclassintro == 0+        gt = rapp + rclassapp + rclassintro == 0   scoreCriterion :: Score -> Bool-scoreCriterion (Score a b c d e) = True {- not-  ( (b > 0 && c > 0) || (b + c) > 2 ) -}+scoreCriterion (Score a b c d e f g) = not+  ( (b > 0 && c > 0) || (b + c) > 4 || any (> 3) [d,e,f,g])  defaultScoreFunction :: Score -> Int-defaultScoreFunction (Score a b c d e) = a + 9*b + 3*c + 12*d + 4*e + 100*(2*b + d)*(2*c + e)+defaultScoreFunction (Score a b c d e f g) = a + 9*b + 3*c + 12*d + 4*e + 6*f + 2*g + 100*(2*b + d + f)*(2*c + e + g)   -- it's very bad to have *both* upcasting and downcasting  instance Monoid Score where-  mempty = Score 0 0 0 0 0-  (Score a b c d e) `mappend` (Score a' b' c' d' e') = Score (a + a') (b + b') (c + c') (d + d') (e + e')-+  mempty = Score 0 0 0 0 0 0 0+  (Score a b c d e f g) `mappend` (Score a' b' c' d' e' f' g') =+    Score (a + a') (b + b') (c + c') (d + d') (e + e') (f + f') (g + g') +-- | A directed acyclic graph representing the arguments to a function+-- The 'Int' represents the position of the argument (1st argument, 2nd, etc.) type ArgsDAG = [((Name, Type), (Int, Set Name))]-type ResType = ( [Name] , ArgsDAG , ArgsDAG ) +-- | The state corresponding to an attempted match of two types. data State = State-  { holes :: ![Name]-  , args1 :: !ArgsDAG-  , args2 :: !ArgsDAG-  , score :: !Score-  }+  { holes     :: ![(Name, Type)] -- ^ names which have yet to be resolved+  , args1     :: !ArgsDAG -- ^ arguments for the left  type which have yet to be resolved+  , args2     :: !ArgsDAG -- ^ arguments for the right type which have yet to be resolved+  , classes1  :: ![(Name, Type)] -- ^ typeclass arguments for the left  type which haven't been resolved+  , classes2  :: ![(Name, Type)] -- ^ typeclass arguments for the right type which haven't been resolved+  , score     :: !Score -- ^ the score so far+  , usedNames :: ![Name] -- ^ all names that have been used+  } deriving Show +modifyTypes :: (Type -> Type) -> State -> State+modifyTypes f (State h a1 a2 c1 c2 s un) = +  State h (modifyDag a1) (modifyDag a2) +          (modifyList c1) (modifyList c2)+          s un+  where+  modifyDag = map (first (second f))+  modifyList = map (second f) ---DONT run vToP first!-unifyWithHoles :: Bool -> IState -> Type -> Type -> Maybe [Score]-unifyWithHoles debugParam istate type1 = \type2 -> let-  (dag2, retTy2) = makeDag (uniqueBinders argNames1 type2)-  argNames2 = map (fst . fst) dag2-  startingHoles = argNames1 ++ argNames2+findNameInArgsDAG :: Name -> ArgsDAG -> Maybe (Type, Maybe Int)+findNameInArgsDAG name xs = fmap ((snd . fst) &&& (Just . fst . snd)) . find ((name ==) . fst . fst) $ xs -  startingTypes = (retTy1, retTy2) : [] -  in do -  state <- go (State startingHoles dag1 dag2 mempty) startingTypes-  return $ processDags state+findLeft, findRight :: Name -> State -> Maybe (Type, Maybe Int)+findLeft  n (State _ a1 a2 c1 c2 _ _) = findNameInArgsDAG n a1 <|> ((,) <$> lookup n c1 <*> Nothing)+findRight n (State _ a1 a2 c1 c2 _ _) = findNameInArgsDAG n a2 <|> ((,) <$> lookup n c2 <*> Nothing)++deleteLeft, deleteRight :: Name -> State -> State+deleteLeft  n state = state { args1 = deleteFromDag n (args1 state) , classes1 = filter ((/= n) . fst) (classes1 state) }+deleteRight n state = state { args2 = deleteFromDag n (args2 state) , classes2 = filter ((/= n) . fst) (classes2 state) }+++tcToMaybe :: TC' e a -> Maybe a+tcToMaybe (OK x) = Just x+tcToMaybe (Error _) = Nothing++inArgTys :: (Type -> Type) -> ArgsDAG -> ArgsDAG+inArgTys = map . first . second+++typeclassUnify :: Ctxt ClassInfo -> Context -> Type -> Type -> Maybe [(Name, Type)]+typeclassUnify classInfo ctxt ty tyTry = do+  res <- tcToMaybe $ match_unify ctxt [] ty retTy [] holes []+  guard $ null (holes \\ map fst res)+  let argTys' = map (second $ foldr (.) id [ subst n t | (n, t) <- res ]) tcArgs+  return argTys'   where+  tyTry' = vToP tyTry+  holes = map fst nonTcArgs+  retTy = getRetTy tyTry'+  (tcArgs, nonTcArgs) = partition (isTypeClassArg classInfo . snd) $ getArgTys tyTry'++isTypeClassArg :: Ctxt ClassInfo -> Type -> Bool+isTypeClassArg classInfo ty = not (null (getClassName clss >>= flip lookupCtxt classInfo)) where+  (clss, args) = unApply ty+  getClassName (P (TCon _ _) className _) = [className]+  getClassName _ = []+++instance Ord Score where+  compare = comparing defaultScoreFunction++-- | Compute the power set+subsets :: [a] -> [[a]]+subsets [] = [[]]+subsets (x : xs) = let ss = subsets xs in map (x :) ss ++ ss+++--DONT run vToP first!+-- | Try to match two types together in a unification-like procedure.+-- Returns a list of types and their minimum scores, sorted in order+-- of increasing score.+matchTypesBulk :: forall info. IState -> Int -> Type -> [(info, Type)] -> [(info, Score)]+matchTypesBulk istate maxScore type1 types = getAllResults startQueueOfQueues where+  getStartQueue :: (info, Type) -> Maybe (Score, (info, Q.PQueue Score State))+  getStartQueue nty@(info, type2) = do+    state <- unifyQueue (State startingHoles dag1 dag2 +              typeClassArgs1 typeClassArgs2+              mempty usedNames) startingTypes+    let sc = score state+    return $ (sc, (info, Q.singleton sc state))+    where+    (dag2, typeClassArgs2, retTy2) = makeDag (uniqueBinders (map fst argNames1) type2)+    argNames2 = map fst dag2+    usedNames = map fst (argNames1 ++ argNames2)+    startingHoles = argNames1 ++ argNames2++    startingTypes = (retTy1, retTy2) : [] +++  startQueueOfQueues :: Q.PQueue Score (info, Q.PQueue Score State)+  startQueueOfQueues = Q.fromList $ mapMaybe getStartQueue types++  getAllResults :: Q.PQueue Score (info, Q.PQueue Score State) -> [(info, Score)]+  getAllResults q = case Q.minViewWithKey q of+    Nothing -> []+    Just ((nextScore, (info, stateQ)), q') ->+      if defaultScoreFunction nextScore <= maxScore+        then case nextStepsQueue stateQ of+          Nothing -> getAllResults q'+          Just (Left stateQ') -> case Q.minViewWithKey stateQ' of+             Nothing -> getAllResults q'+             Just ((newQscore,_), _) -> getAllResults (Q.add newQscore (info, stateQ') q')+          Just (Right score) -> (info, score) : getAllResults q'+        else []++   ctxt = tt_ctxt istate   classInfo = idris_classes istate-  (dag1, retTy1) = makeDag type1-  argNames1 = map (fst . fst) dag1-  makeDag = first (zipWith (\i (ty, deps) -> (ty, (i, deps))) [0..] . reverseDag) . computeDagP . vToP -  matchf :: (Name, Term) -> Maybe (Name, Name)-  matchf (name, P Bound name2 _) = Just (name, name2)-  matchf _ = Nothing+  (dag1, typeClassArgs1, retTy1) = makeDag type1+  argNames1 = map fst dag1+  makeDag :: Type -> (ArgsDAG, [(Name, Type)], Type)+  makeDag = first3 (zipWith (\i (ty, deps) -> (ty, (i, deps))) [0..] . reverseDag) . +    computeDagP (isTypeClassArg classInfo) . vToP+  first3 f (a,b,c) = (f a, b, c)      -- update our state with the unification resolutions-  updateDags :: [(Name, Type)] -> ResType -> Maybe (ResType, [(Type, Type)], Score)-  updateDags [] res = Just (res, [], mempty)-  updateDags ((name, term@(P Bound name2 _)) : xs) (holes, args1, args2) | isJust findArgs = do+  resolveUnis :: [(Name, Type)] -> State -> Maybe (State, [(Type, Type)])+  resolveUnis [] state = Just (state, [])+  resolveUnis ((name, term@(P Bound name2 _)) : xs) +    state@(State holes args1 args2 _ _ _ _) | isJust findArgs = do     ((ty1, ix1), (ty2, ix2)) <- findArgs -    (res, queue, score) <- updateDags xs (holes', args1'', args2'')-    --traceShow (ty1, ty2) False `seq` return ()-    return $ (res, (ty1, ty2) : queue , score { transposition = transposition score + abs (ix2 - ix1) })+    (state'', queue) <- resolveUnis xs state'+    let transScore = fromMaybe 0 (abs <$> ((-) <$> ix1 <*> ix2))+    return $ (inScore (\s -> s { transposition = transposition s + transScore }) state'', (ty1, ty2) : queue)     where-    findArgs = ((,) <$> mgetType name args1 <*> mgetType name2 args2) <|>-               ((,) <$> mgetType name2 args1 <*> mgetType name args2)-    matchnames = [name, name2]-    holes' = holes \\ matchnames-    substf = deleteFromDag name . deleteFromDag name2-    args1' = substf args1-    args2' = substf args2-    args1'' = map (first . second $ subst name term) args1'-    args2'' = map (first . second $ subst name term) args2'     mgetType name xs = fmap ((snd . fst) &&& (fst . snd)) . find ((name ==) . fst . fst) $ xs+    inScore f state = state { score = f (score state) }+    findArgs = ((,) <$> findLeft name state <*> findRight name2 state) <|>+               ((,) <$> findLeft name2 state <*> findRight name state)+    matchnames = [name, name2]+    holes' = filter (not . (`elem` matchnames) . fst) holes+    deleteArgs = deleteLeft name . deleteLeft name2 . deleteRight name . deleteRight name2+    state' = modifyTypes (subst name term) $ deleteArgs+              (state { holes = holes'}) -  updateDags ((name, term) : xs) (holes, args1, args2) = case (mgetType name args1, mgetType name args2) of-        (Just (_,ix), Nothing) -> thrd (\score -> score { leftApplied = succ (leftApplied score) }) <$> nextStep-        (Nothing, Just (_, ix)) -> thrd (\score -> score { rightApplied = succ (rightApplied score) }) <$> nextStep-        (Nothing, Nothing) -> nextStep-        _ -> error ("Shouldn't happen. Watch the alpha conversion!\n" ++ show args1 ++ "\n\n" ++ show args2)+  resolveUnis ((name, term) : xs)+    state@(State holes args1 args2 _ _ _ _) = case (findLeft name state, findRight name state) of+      (Just (_,ix), Nothing) -> first (addScore (mempty { leftApplied  = 1, rightApplied = otherApplied})) <$> nextStep+      (Nothing, Just (_,ix)) -> first (addScore (mempty { rightApplied = 1, leftApplied  = otherApplied})) <$> nextStep+      (Nothing, Nothing) -> nextStep+      _ -> error ("Idris internal error: TypeSearch.resolveUnis")     where-    varsInTy = map fst $ M.toList (usedVars term)-    deleteMany = foldr (.) id $ map deleteFromDag (name : varsInTy)-    thrd f (a,b,c) = (a,b,f c)-    nextStep = updateDags xs (holes \\ [name], updatef args1, updatef args2 )-    updatef = map (first . second $ subst name term) . deleteMany-    mgetType name xs = fmap ((snd . fst) &&& (fst . snd)) . find ((name ==) . fst . fst) $ xs+    -- find variables which are determined uniquely by the type+    -- due to injectivity+    matchedVarMap = usedVars term+    both f (x, y) = (f x, f y)+    (injUsedVars, notInjUsedVars) = both M.keys . M.partition id . M.filterWithKey (\k _-> k `elem` map fst holes) $ M.map snd matchedVarMap +    varsInTy = injUsedVars ++ notInjUsedVars+    toDelete = name : varsInTy+    deleteMany = foldr (.) id $ [ deleteLeft t . deleteRight t | t <- toDelete ] +    otherApplied = length notInjUsedVars -  go :: State -> [(Type, Type)] -> Maybe State-  --go (State holes args1 args2 score) queue | trace ("go\n\t" ++ show holes ++ "\n\t" ++ show args1 ++ "\n\t" ++ show args2 ++ "\n\t" ++ show queue) False = undefined-  go state [] = return state-  go (State holes args1 args2 score) ((ty1, ty2) : queue) = do-    res <- tcToMaybe $ match_unify ctxt [] ty1 ty2 [] holes []-    --trace ("UnifyResult: " ++ show (ty1, ty2, res, errors)) False `seq` return ()-    --guard (null errors)-    ((holes', args1', args2'), queueAdditions, scoreAdditions) <- updateDags res (holes, args1, args2)-    let newScore = score `mappend` scoreAdditions-    guard $ scoreCriterion newScore-    go (State holes' args1' args2' newScore) (queue ++ queueAdditions)+    addScore additions state = state { score = score state `mappend` additions }+    state' = modifyTypes (subst name term) . deleteMany $ +               state { holes = filter (not . (`elem` toDelete) . fst) holes }+    nextStep = resolveUnis xs state'  -  processDags :: State -> [Score]-  processDags (State [] [] [] scoreAcc) = [scoreAcc]-  --processDags (State holes (_:_) [] scoreAcc) = []-  --processDags (State holes [] (_:_) scoreAcc) = []-  processDags (State holes dag1 dag2 scoreAcc) = concat [ processDags state | state <- allResults ] where+  -- | resolve a queue of unification constraints+  unifyQueue :: State -> [(Type, Type)] -> Maybe State+  unifyQueue state [] = return state+  unifyQueue state ((ty1, ty2) : queue) = do+    --trace ("go: \n" ++ show state) True `seq` return ()+    res <- tcToMaybe $ match_unify ctxt [ (n, Pi ty) | (n, ty) <- holes state] ty1 ty2 [] (map fst $ holes state) []+    (state', queueAdditions) <- resolveUnis res state+    guard $ scoreCriterion (score state')+    unifyQueue state' (queue ++ queueAdditions) -    results = catMaybes [ go (State (holes \\ (map nameOf [ty1, ty2])) (deleteFromDag (nameOf ty1) dag1)-         (inArgTys (psubst (nameOf ty2) (P Bound (nameOf ty1) (typeOf ty1))) $ deleteFromDag (nameOf ty2) dag2) scoreAcc) [(typeOf ty1, typeOf ty2)] -     | ty1 <- canBeFirst dag1, ty2 <- canBeFirst dag2 {-, exactTypeEquality ctxt (typeOf ty1) (typeOf ty2) -} ]+  possClassInstances :: [Name] -> Type -> [Type]+  possClassInstances usedNames ty = do+    className <- getClassName clss+    classDef <- lookupCtxt className classInfo+    n <- class_instances classDef+    def <- lookupCtxt n (definitions ctxt)+    ty <- normaliseC ctxt [] <$> (case typeFromDef def of Just x -> [x]; Nothing -> [])+    let ty' = vToP (uniqueBinders usedNames ty)+    return ty'+    where+    (clss, _) = unApply ty+    getClassName (P (TCon _ _) className _) = [className]+    getClassName _ = [] -    results2 = [ State (holes \\ [nameOf ty]) -               (deleteFromDag (nameOf ty) dag1) dag2-               (scoreAcc `mappend` (mempty { leftTypeClass = 1 }))-               | ty <- typeClassArgs1 ]+  -- Just if the computation hasn't totally failed yet, Nothing if it has+  -- Left if we haven't found a terminal state, Right if we have+  nextStepsQueue :: Q.PQueue Score State -> Maybe (Either (Q.PQueue Score State) Score)+  nextStepsQueue queue = do+    ((nextScore, next), rest) <- Q.minViewWithKey queue+    if isFinal next +      then Just $ Right nextScore+      else let additions = if scoreCriterion nextScore+                 then Q.fromList [ (score state, state) | state <- nextSteps next ]+                 else Q.empty in+           Just $ Left (Q.union rest additions)+    where+    isFinal (State [] [] [] [] [] score _) = True+    isFinal _ = False -    typeClassArgs1 = filter (isSaturatedClass . typeOf) dag1-    typeClassArgs2 = filter (isSaturatedClass . typeOf) dag2+  -- | Find all possible matches starting from a given state.+  -- We go in stages rather than concatenating all three results in hopes of narrowing+  -- the search tree. Once we advance in a phase, there should be no going back.+  nextSteps :: State -> [State] +  -- Stage 3 - match typeclasses+  nextSteps (State [] [] [] c1 c2 scoreAcc usedNames) = +    if null results3 then results4 else results3+    where+    -- try to match a typeclass argument from the left with a typeclass argument from the right+    results3 =+         catMaybes [ unifyQueue (State [] [] []+         (deleteFromArgList n1 c1) (map (second subst2for1) (deleteFromArgList n2 c2)) scoreAcc usedNames) [(ty1, ty2)] +     | (n1, ty1) <- c1, (n2, ty2) <- c2, let subst2for1 = psubst n2 (P Bound n1 ty1)] -    results3 = [ State (holes \\ [nameOf ty]) -               dag1 (deleteFromDag (nameOf ty) dag2)-               (scoreAcc `mappend` (mempty { rightTypeClass = 1 }))-               | ty <- typeClassArgs2 ]+    -- try to hunt match a typeclass constraint by replacing it with an instance+    results4 = results4A ++ results4B+    typeClassArgs classes = [ ((n, ty), inst) | (n, ty) <- classes, inst <- possClassInstances usedNames ty ]+    results4A = [ State [] [] []+                  (deleteFromArgList n c1 ++ newClassArgs) c2+                  (scoreAcc `mappend` (mempty { leftTypeClassApp = 1 }))+                  (usedNames ++ newHoles)+                | ((n, ty), inst) <- typeClassArgs c1+                , newClassArgs <- maybeToList $ typeclassUnify classInfo ctxt ty inst+                , let newHoles = map fst newClassArgs ]+    results4B = [ State [] [] []+                  c1 (deleteFromArgList n c2 ++ newClassArgs)+                  (scoreAcc `mappend` (mempty { rightTypeClassApp = 1 }))+                  (usedNames ++ newHoles)+                | ((n, ty), inst) <- typeClassArgs c2+                , newClassArgs <- maybeToList $ typeclassUnify classInfo ctxt ty inst+                , let newHoles = map fst newClassArgs ] -    allResults :: [State]-    allResults = {- (if not (null typeClasses) then (traceShow typeClasses False `seq` id) else id ) -}-                 (results ++ results2 ++ results3)-      where-      typeClasses = filter (isSaturatedClass . typeOf) (dag1 ++ dag2)-                -    -- check if the canBeFirst thing is losing any possibilities+  -- Stage 1 - match arguments+  nextSteps (State holes dag1 dag2 c1 c2 scoreAcc usedNames) = results where +    results = concatMap takeSomeClasses results1 -    inArgTys = map . first . second-    typeOf ((name, ty), set) = ty-    nameOf ((name, ty), set) = name+    -- we only try to match arguments whose names don't appear in the types+    -- of any other arguments+    canBeFirst :: ArgsDAG -> [(Name, Type)]+    canBeFirst = map fst . filter (S.null . snd . snd) -    -- XXX : debug stuff-    canBeFirst = if debugParam then filter (S.null . snd . snd) else id-    holes = map (fst . fst) dag1 ++ map (fst . fst) dag2+    -- try to match an argument from the left with an argument from the right+    results1 = catMaybes [ unifyQueue (State (filter (not . (`elem` [n1,n2]) . fst) holes) (deleteFromDag n1 dag1)+         ((inArgTys subst2for1) $ deleteFromDag n2 dag2) c1 (map (second subst2for1) c2) scoreAcc usedNames) [(ty1, ty2)] +     | (n1, ty1) <- canBeFirst dag1, (n2, ty2) <- canBeFirst dag2, let subst2for1 = psubst n2 (P Bound n1 ty1)] -    deleteIdx _ [] = []-    deleteIdx idx l@(x@(i,_,_) : xs) = if i == idx then xs else x : deleteIdx idx xs -  isSaturatedClass :: Type -> Bool-  isSaturatedClass ty = fromMaybe False $ do-    className <- getClassName clss-    let possInstances = concatMap class_instances $ lookupCtxt className classInfo -    return $ (SN (sInstanceN className (map argToName args))) `elem` possInstances-    where-    (clss, args) = unApply ty-    getClassName (P (TCon _ _) className _) = Just className-    getClassName _ = Nothing-    argToName arg = show (delab istate arg)-+    -- Stage 2 - simply introduce a subset of the typeclasses+    -- we've finished, so take some classes+    takeSomeClasses (State [] [] [] c1 c2 scoreAcc usedNames) = +      let lc1 = length c1; lc2 = length c2 in+       [ State [] [] [] c1' c2' (scoreAcc `mappend` +           mempty { rightTypeClassIntro = lc1 - length c1',+                    leftTypeClassIntro  = lc2 - length c2' }) usedNames+       | c1' <- subsets c1, c2' <- subsets c2 ]+    -- still have arguments to match, so just be the identity+    takeSomeClasses s = [s]
src/Pkg/PParser.hs view
@@ -10,12 +10,12 @@ import Idris.ParseHelpers import Idris.CmdOptions -import Paths_idris- import Control.Monad.State.Strict import Control.Applicative +import System.Info (os) + type PParser = StateT PkgDesc IdrisInnerParser  data PkgDesc = PkgDesc { pkgname :: String,@@ -56,7 +56,10 @@ pClause = do reserved "executable"; lchar '=';              exec <- iName []              st <- get-             put (st { execout = Just (show exec) })+             put (st { execout = Just (if os `elem` ["win32", "mingw32", "cygwin32"] +                                          then ((show exec) ++ ".exe")+                                          else ( show exec )+                                      ) })       <|> do reserved "main"; lchar '=';              main <- iName []              st <- get
src/Pkg/Package.hs view
@@ -29,8 +29,6 @@  import Pkg.PParser -import Paths_idris (getDataDir)- -- To build a package: -- * read the package description -- * check all the library dependencies exist
+ src/Target_idris.hs view
@@ -0,0 +1,13 @@+module Target_idris where++import System.FilePath+import System.Environment+getDataDir :: IO String+getDataDir = do +   expath <- getExecutablePath+   execDir <- return $ dropFileName expath+   return $ execDir ++ "./libs"+getDataFileName :: FilePath -> IO FilePath+getDataFileName name = do+   dir <- getDataDir+   return (dir ++ "/" ++ name)
test/Makefile view
@@ -8,7 +8,7 @@ 	@perl ./runtest.pl $(patsubst %.test,%,$@)  test_java:-	perl ./runtest.pl without sugar004 buffer001 --codegen Java+	@perl ./runtest.pl without --codegen Java  test_js: 	@perl ./runtest.pl without sugar004 reg029 io001 dsl002 io003 effects001 effects002 buffer001 --codegen node
+ test/basic001/basic001a.idr view
@@ -0,0 +1,32 @@+module Main++data RLE : Vect n Char -> Type where+     REnd  : RLE []+     RChar : {xs : Vect k Char} ->+             (n : Nat) -> (c : Char) -> (rs : RLE xs) ->+             RLE (replicate (S n) c ++ xs)++------------++rle : (xs : Vect n Char) -> RLE xs+rle [] = REnd+rle (x :: xs) with (rle xs)+  rle (x :: []) | REnd = RChar 0 x REnd+  rle (x :: (c :: (replicate n c ++ ys))) | (RChar n c rs) with (decEq x c)+    rle (x :: (x :: (replicate n x ++ ys))) | (RChar n x rs) | (Yes refl) +        = RChar (S n) x rs+    rle (x :: (c :: (replicate n c ++ ys))) | (RChar n c rs) | (No f) +        = RChar 0 x (RChar n c rs)++compress : Vect n Char -> String+compress xs with (rle xs)+  compress [] | REnd = ""+  compress (c :: (replicate n c ++ xs1)) | (RChar n c rs) +       = show (the Integer (cast (S n))) +++           strCons c (compress xs1)++compressString : String -> String+compressString xs = compress (fromList (unpack xs))++main : IO ()+main = putStrLn (compressString "foooobaaaarbaaaz")
test/basic001/expected view
@@ -1,1 +1,2 @@ 1f4o1b4a1r1b3a1z+1f4o1b4a1r1b3a1z
+ test/basic001/rle-vect.idr view
@@ -0,0 +1,32 @@+module Main++data RLE : Vect n Char -> Type where+     REnd  : RLE []+     RChar : {xs : Vect k Char} ->+             (n : Nat) -> (c : Char) -> (rs : RLE xs) ->+             RLE (replicate (S n) c ++ xs)++------------++rle : (xs : Vect n Char) -> RLE xs+rle [] = REnd+rle (x :: xs) with (rle xs)+  rle (x :: []) | REnd = RChar 0 x REnd+  rle (x :: (c :: (replicate n c ++ ys))) | (RChar n c rs) with (decEq x c)+    rle (x :: (x :: (replicate n x ++ ys))) | (RChar n x rs) | (Yes refl) +        = RChar (S n) x rs+    rle (x :: (c :: (replicate n c ++ ys))) | (RChar n c rs) | (No f) +        = RChar 0 x (RChar n c rs)++compress : Vect n Char -> String+compress xs with (rle xs)+  compress [] | REnd = ""+  compress (c :: (replicate n c ++ xs1)) | (RChar n c rs) +       = show (the Integer (cast (S n))) +++           strCons c (compress xs1)++compressString : String -> String+compressString xs = compress (fromList (unpack xs))++main : IO ()+main = putStrLn (compressString "foooobaaaarbaaaz")
test/basic001/run view
@@ -1,4 +1,6 @@ #!/usr/bin/env bash idris $@ reg005.idr -o reg005+idris $@ basic001a.idr -o basic001a ./reg005-rm -f reg005 *.ibc+./basic001a+rm -f reg005 basic001a *.ibc
test/basic009/expected view
@@ -1,5 +1,5 @@ MAIN-PASS Faulty.idr:6:7:When elaborating type of Faulty.fault:-When elaborating an application of type constructor =:+When elaborating argument x to type constructor =:         Can't disambiguate name: A.num, B.C.num Multiple.idr:3:1:import alias not unique: "X"
+ test/dsl003/DSLPi.idr view
@@ -0,0 +1,38 @@+module DSLPi++data Ty = BOOL | INT | UNIT | ARR Ty Ty++dsl simple_type+  pi = ARR++test1 : simple_type (BOOL -> INT -> UNIT) = BOOL `ARR` (INT `ARR` UNIT)+test1 = refl++using (vars : Vect n Ty)+  infix 2 ===++  data Expr : Vect n Ty -> Ty -> Type where+    Var : (i : Fin n) -> Expr vars (index i vars)+    (===) : Expr vars t -> Expr vars t -> Expr vars BOOL++  data Spec : Vect n Ty -> Type where+    ForAll : (t : Ty) -> Spec (t :: vars) -> Spec vars+    ItHolds : Expr vars BOOL -> Spec vars++  implicit exprSpec : Expr vars BOOL -> Spec vars+  exprSpec = ItHolds++dsl specs+  pi = ForAll+  variable = Var+  index_first = fZ+  index_next = fS++test2 : Spec []+test2 = specs ((x, y : INT) -> x === y)++test3 : Spec []+test3 = ForAll INT . ForAll INT . ItHolds $ Var (fS fZ) === Var fZ++test4 : test2 = test3+test4 = refl
+ test/dsl003/expected view
@@ -0,0 +1,2 @@+ForAll INT (ForAll INT (ItHolds (Var (fS fZ) === Var fZ))) : Spec []+refl : ARR BOOL (ARR INT UNIT) = ARR BOOL (ARR INT UNIT)
+ test/dsl003/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ --nocolour --check DSLPi.idr -e test1 -e test2+rm -f *.ibc
test/effects001/test021.idr view
@@ -9,7 +9,7 @@  FileIO : Type -> Type -> Type FileIO st t-   = { [FILE_IO st, STDIO, Count ::: STATE Int] } Eff IO t+   = { [FILE_IO st, STDIO, Count ::: STATE Int] } Eff t  readFile : FileIO (OpenFile Read) (List String) readFile = readAcc [] where
test/effects001/test021a.idr view
@@ -17,7 +17,7 @@ -- Evaluator t --    = Eff m [EXCEPTION String, RND, STATE Env] t -eval : Expr -> { [EXCEPTION String, STDIO, RND, STATE Env] } Eff IO Integer+eval : Expr -> { [EXCEPTION String, STDIO, RND, STATE Env] } Eff Integer eval (Var x) = do vs <- get                   case lookup x vs of                         Nothing => raise ("No such variable " ++ x)
test/effects002/test025.idr view
@@ -6,7 +6,7 @@  MemoryIO : Type -> Type -> Type -> Type MemoryIO td ts r = { [ Dst ::: RAW_MEMORY td-                     , Src ::: RAW_MEMORY ts ] } Eff (IOExcept String) r+                     , Src ::: RAW_MEMORY ts ] } Eff r  inpVect : Vect 5 Bits8 inpVect = map prim__truncInt_B8 [0, 1, 2, 3, 5]
test/error003/ErrorReflection.idr view
@@ -58,7 +58,7 @@                                         tm2' <- getTmTy tm2                                         ty1 <- reifyTy tm1'                                         ty2 <- reifyTy tm2'-                                        return [TextPart $ "DSL type error: " ++ (show ty1) ++ " doesn't match " ++(show ty2)]+                                        Just [TextPart $ "DSL type error: " ++ (show ty1) ++ " doesn't match " ++(show ty2)] dslerr _ = Nothing
test/error003/expected view
@@ -1,2 +1,2 @@ ErrorReflection.idr:67:5:When elaborating right hand side of bad:-DSL type error: (t(503) => t'(504)) doesn't match ()+DSL type error: (t(502) => t'(503)) doesn't match ()
test/proof002/expected view
@@ -1,7 +1,7 @@ Reflect.idr:207:38:When elaborating right hand side of testReflect1: When elaborating an application of function Reflect.getJust:         Can't unify-                IsJust (Just x)+                IsJust (Just x2)         with                 IsJust (prove (getProof x))
+ test/quasiquote001/QuasiquoteBasics.idr view
@@ -0,0 +1,30 @@+module QuasiquoteBasics++import Language.Reflection+import Language.Reflection.Utils++nat : TT+nat = `(Nat)++three : TT+three = `(S (S (S Z)))++twoElems : TT+twoElems = `(with List [(), ()])++copy : TT -> TT+copy q = `((~q,~q) : (Type, Type))++thing : TT -> TT+thing tm = `(with List [Type, ~tm])+++++namespace Main+  main : IO ()+  main = do putStrLn . show $ twoElems+            putStrLn "--------------"+            putStrLn . show . thing $ copy nat+            putStrLn "--------------"+            putStrLn . show . copy . copy $ `(Type)
+ test/quasiquote001/expected view
@@ -0,0 +1,5 @@+(App (App (App (P (DCon 1 3) (NS (UN ::) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (Bind (MN 0 "_t") (Pi (V 0)) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 2)))))) (P (TCon 7 0) (MN 0 "__Unit") (TType (UVar 6)))) (P (DCon 0 0) (MN 0 "__II") (P (TCon 0 0) (MN 0 "__Unit") (TType (UVar 6))))) (App (App (App (P (DCon 1 3) (NS (UN ::) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (Bind (MN 0 "_t") (Pi (V 0)) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 2)))))) (P (TCon 7 0) (MN 0 "__Unit") (TType (UVar 6)))) (P (DCon 0 0) (MN 0 "__II") (P (TCon 0 0) (MN 0 "__Unit") (TType (UVar 6))))) (App (P (DCon 0 1) (NS (UN Nil) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 0)))) (P (TCon 7 0) (MN 0 "__Unit") (TType (UVar 6))))))+--------------+(App (App (App (P (DCon 1 3) (NS (UN ::) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (Bind (MN 0 "_t") (Pi (V 0)) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 2)))))) (TType (UVar 110))) (TType (UVar 112))) (App (App (App (P (DCon 1 3) (NS (UN ::) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (Bind (MN 0 "_t") (Pi (V 0)) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 2)))))) (TType (UVar 114))) (App (App (App (App (P (DCon 0 4) (MN 0 "__MkPair") (Bind (MN 0 "A") (Pi (TType (UVar 36))) (Bind (MN 0 "B") (Pi (TType (UVar 38))) (Bind (MN 0 "a") (Pi (V 1)) (Bind (MN 0 "b") (Pi (V 1)) (App (App (P (TCon 0 0) (MN 0 "__Pair") (Bind (MN 1 "A") (Pi (TType (UVar 28))) (Bind (MN 1 "B") (Pi (TType (UVar 30))) (TType (UVar 32))))) (V 3)) (V 2))))))) (TType (UVar 108))) (TType (UVar 110))) (P (TCon 15 0) (NS (UN Nat) ["Nat", "Prelude"]) (TType (UVar -1)))) (P (TCon 15 0) (NS (UN Nat) ["Nat", "Prelude"]) (TType (UVar -1))))) (App (P (DCon 0 1) (NS (UN Nil) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 0)))) (TType (UVar 116)))))+--------------+(App (App (App (App (P (DCon 0 4) (MN 0 "__MkPair") (Bind (MN 0 "A") (Pi (TType (UVar 36))) (Bind (MN 0 "B") (Pi (TType (UVar 38))) (Bind (MN 0 "a") (Pi (V 1)) (Bind (MN 0 "b") (Pi (V 1)) (App (App (P (TCon 0 0) (MN 0 "__Pair") (Bind (MN 1 "A") (Pi (TType (UVar 28))) (Bind (MN 1 "B") (Pi (TType (UVar 30))) (TType (UVar 32))))) (V 3)) (V 2))))))) (TType (UVar 108))) (TType (UVar 110))) (App (App (App (App (P (DCon 0 4) (MN 0 "__MkPair") (Bind (MN 0 "A") (Pi (TType (UVar 36))) (Bind (MN 0 "B") (Pi (TType (UVar 38))) (Bind (MN 0 "a") (Pi (V 1)) (Bind (MN 0 "b") (Pi (V 1)) (App (App (P (TCon 0 0) (MN 0 "__Pair") (Bind (MN 1 "A") (Pi (TType (UVar 28))) (Bind (MN 1 "B") (Pi (TType (UVar 30))) (TType (UVar 32))))) (V 3)) (V 2))))))) (TType (UVar 108))) (TType (UVar 110))) (TType (UVar 110))) (TType (UVar 110)))) (App (App (App (App (P (DCon 0 4) (MN 0 "__MkPair") (Bind (MN 0 "A") (Pi (TType (UVar 36))) (Bind (MN 0 "B") (Pi (TType (UVar 38))) (Bind (MN 0 "a") (Pi (V 1)) (Bind (MN 0 "b") (Pi (V 1)) (App (App (P (TCon 0 0) (MN 0 "__Pair") (Bind (MN 1 "A") (Pi (TType (UVar 28))) (Bind (MN 1 "B") (Pi (TType (UVar 30))) (TType (UVar 32))))) (V 3)) (V 2))))))) (TType (UVar 108))) (TType (UVar 110))) (TType (UVar 110))) (TType (UVar 110))))
+ test/quasiquote001/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ QuasiquoteBasics.idr -o quasiquote001+./quasiquote001+rm -f quasiquote001 *.ibc
+ test/quasiquote002/GoalQQuote.idr view
@@ -0,0 +1,30 @@+module GoalQQuote++import Language.Reflection+import Language.Reflection.Utils++uCon : TT+uCon = `(() : ())++uTy : TT+uTy = `(() : Type)++isDefault : TT -> Bool+isDefault `(()) = True+isDefault _ = False++pTy : TT -> TT -> TT+pTy a b = `((~a, ~b) : Type)++pair : TT -> TT -> TT+pair a b = `((~a, ~b) : (Nat, Nat))++vect : TT+vect = `([1,2] : Vect 2 Nat)++namespace Main+  main : IO ()+  main = putStrLn $+           if isDefault uCon then "con"+                             else if isDefault uTy then "ty"+                                                   else "neither"
+ test/quasiquote002/expected view
@@ -0,0 +1,1 @@+con
+ test/quasiquote002/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ GoalQQuote.idr -o quasiquote002+./quasiquote002+rm -f quasiquote002 *.ibc
+ test/quasiquote003/NoInfer.idr view
@@ -0,0 +1,10 @@+module NoInfer++import Language.Reflection+import Language.Reflection.Utils++zzz2 : TT+zzz2 = `(fZ : Fin 3)++zzz : TT+zzz = `(fZ)
+ test/quasiquote003/expected view
@@ -0,0 +1,2 @@+NoInfer.idr:10:5:When elaborating right hand side of zzz:+No such variable k
+ test/quasiquote003/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ --check NoInfer.idr+rm -f *.ibc
test/records003/records003.idr view
@@ -45,4 +45,3 @@           print (record { organiser->age } idm_gbg)           print (record { year } idm_gbg) -
test/reg003/expected view
@@ -1,2 +1,2 @@-reg003a.idr:4:20:When elaborating constructor Main.ECons:+reg003a.idr:4:11:When elaborating type of Main.ECons: No such variable OddList
− test/reg008/expected 
− test/reg008/reg008.idr 
@@ -1,15 +0,0 @@-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 
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-idris $@ reg008.idr --check-rm -f *.ibc
test/reg029/reg029.idr view
@@ -2,6 +2,7 @@  import System +-- necessary to find the getenv symbol %dynamic "libm"  main : IO ()
test/reg029/run view
@@ -1,7 +1,17 @@ #!/usr/bin/env bash+ idris $@ reg029.idr -o reg029 unset IDRIS_REG029_NONEXISTENT_VAR export IDRIS_REG029_EXISTENT_VAR='exists!'-./reg029++IsJava=`echo "$@" | grep -E "\-\-codegen([[:space:]]+)Java\>"`+if [ -z "$IsJava" ]+then+  ./reg029+else+  javac -cp reg029:. Reg029Wrapper.java+  java -cp reg029:. Reg029Wrapper+fi idris $@ reg029.idr --execute-rm -f reg029 *.ibc+rm -f reg029 *.ibc *.class+
test/reg034/expected view
@@ -1,24 +1,24 @@ reg034.idr:6:5:When elaborating left hand side of bar: When elaborating an application of main.bar:         Can't unify-                [92mlength[0m [95mys[0m [94m=[0m [92mlength[0m [95mys[0m+                [92mlength[0m ys [94m=[0m [92mlength[0m ys         with-                [92mlength[0m [95mxs[0m [94m=[0m [92mlength[0m [95mys[0m+                [92mlength[0m [95mxs[0m [94m=[0m [92mlength[0m ys                  Specifically:                 Can't unify-                        [92mlength[0m [95mys[0m+                        [92mlength[0m ys                 with                         [92mlength[0m [95mxs[0m reg034.idr:9:5:When elaborating left hand side of foo: When elaborating an application of main.foo:         Can't unify-                [95mf[0m [95my[0m [94m=[0m [95mf[0m [95my[0m+                [95mf[0m y [94m=[0m [95mf[0m y         with-                [95mf[0m [95mx[0m [94m=[0m [95mf[0m [95my[0m+                [95mf[0m [95mx[0m [94m=[0m [95mf[0m y                  Specifically:                 Can't unify-                        [95mf[0m [95my[0m+                        [95mf[0m y                 with                         [95mf[0m [95mx[0m
− test/reg043/expected 
@@ -1,1 +0,0 @@-take : (m : Fin 3) -> Vect 2 Nat -> Vect (finToNat m) Nat
− test/reg043/run 
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-idris $@ --nocolour -e "Vect.take {n=2} {a=Nat}"-
+ test/reg046/expected view
+ test/reg046/reg046.idr view
@@ -0,0 +1,19 @@+module test++data MyList : (A : Type) -> Type where+    nil : (A : Type) -> MyList A+    cons : (A : Type) -> A -> MyList A -> MyList A++elimList : (A : Type) ->+           (m : MyList A -> Type) ->+           (f1 : m (nil A)) ->+           (f2 : (a : A) -> (as : MyList A) -> m as -> m (cons A a as)) ->+           (e : MyList A) ->+           m e+elimList A m f1 f2 (nil A) = f1+elimList A m f1 f2 (cons A a as) = f2 a as (elimList A m f1 f2 as)++append : (A : Type) ->  (b : MyList A) ->  (c : MyList A) ->  MyList A+append A b c = (elimList A (\ d =>  MyList A) c+                (\ d =>  \ e =>  \ f =>  cons A d f)+                b)
+ test/reg046/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ reg046.idr --check+rm -f reg046 *.ibc
+ test/reg047/expected view
+ test/reg047/reg047.idr view
@@ -0,0 +1,18 @@+module test++data TTSigma : (A : Type) -> (B : A -> Type) -> Type where+    sigma : (A : Type) -> (B : A -> Type) -> (a : A) -> B a -> TTSigma A B++data Nat = zero | succ Nat++Id : (A : Type) -> A -> A -> Type+Id A = (=) {a0 = A} {b0 = A}++Refl : (A : Type) -> (a : A) -> Id A a a+Refl A a = refl {a}++zzz : Id Nat zero zero+zzz = Refl Nat zero++eep : TTSigma Nat (\ a =>  Id Nat a zero)+eep = sigma Nat (\ a =>  Id Nat a zero) zero zzz
+ test/reg047/reg047a.idr view
@@ -0,0 +1,24 @@+module test++data TTSigma : (A : Type) -> (B : A -> Type) -> Type where+    sigma : (A : Type) -> (B : A -> Type) -> (a : A) -> B a -> TTSigma A B++data MNat = zero | succ MNat++Id : (A : Type) -> A -> A -> Type+Id = \A,x,y => x = y --  {a = A} {b = A}++Refl : (A : Type) -> (a : A) -> Id A a a+Refl A a = refl {a}++zzzz : Id MNat zero zero+zzzz = Refl MNat zero++eep : TTSigma MNat (\ c =>  Id MNat c zero)+eep = (sigma MNat (\b => Id MNat b zero) zero zzzz)++eep2 : TTSigma MNat (\ c =>  Id MNat c zero)+eep2 = (sigma MNat (\b => Id MNat b zero) zero (Refl MNat zero))+++
+ test/reg047/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ reg047.idr --check --nobuiltins+idris $@ reg047a.idr --check+rm -f *.ibc