packages feed

idris 0.9.12 → 0.9.13

raw patch · 216 files changed

+8360/−3135 lines, 216 filesdep +blaze-htmldep +blaze-markupdep +optparse-applicativedep ~parsers

Dependencies added: blaze-html, blaze-markup, optparse-applicative

Dependency ranges changed: parsers

Files

Makefile view
@@ -43,7 +43,7 @@  #Note: this doesn't yet link to Hackage properly doc: dist/setup-config-	$(CABAL) haddock --executables --hyperlink-source --html --hoogle --html-location="http://hackage.haskell.org/packages/archive/\$$pkg/latest/doc/html" --haddock-options="--title Idris"+	$(CABAL) haddock --hyperlink-source --html --hoogle --html-location="http://hackage.haskell.org/packages/archive/\$$pkg/latest/doc/html" --haddock-options="--title Idris"   dist/setup-config:
config.mk view
@@ -1,4 +1,4 @@-CC              :=cc+CC              ?=cc CABAL           :=cabal CFLAGS          :=-O2 -Wall $(CFLAGS) #CABALFLAGS	:=
idris.cabal view
@@ -1,5 +1,5 @@ Name:           idris-Version:        0.9.12+Version:        0.9.13 License:        BSD3 License-file:   LICENSE Author:         Edwin Brady@@ -46,7 +46,8 @@  Build-type:     Custom -Data-files:            jsrts/Runtime-browser.js+Data-files:            idrisdoc/styles.css+                       jsrts/Runtime-browser.js                        jsrts/Runtime-common.js                        jsrts/Runtime-node.js                        jsrts/jsbn/jsbn.js@@ -65,6 +66,7 @@                         rts/*.c                        rts/*.h+                       rts/windows/*.c                        rts/Makefile                         libs/Makefile@@ -88,6 +90,7 @@                        libs/base/Language/Reflection/*.idr                        libs/base/Makefile                        libs/base/Network/*.idr+                       libs/base/System/*.idr                        libs/base/System/Concurrency/*.idr                        libs/base/Syntax/*.idr @@ -102,11 +105,6 @@                        libs/oldeffects/Effect/*.idr                        libs/oldeffects/*.idr -                       libs/javascript/*.idr-                       libs/javascript/JavaScript/*.idr-                       libs/javascript/Makefile-                       libs/javascript/javascript.ipkg-                        llvm/*.c                        llvm/Makefile @@ -227,6 +225,23 @@                        test/reg038/run                        test/reg038/*.idr                        test/reg038/expected+                       test/reg039/run+                       test/reg039/*.idr+                       test/reg039/expected+                       test/reg040/run+                       test/reg040/*.idr+                       test/reg040/expected+                       test/reg041/run+                       test/reg041/*.idr+                       test/reg041/expected+                       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/basic001/run                        test/basic001/*.idr@@ -309,6 +324,40 @@                        test/ffi005/run                        test/ffi005/expected +                       test/idrisdoc001/run+                       test/idrisdoc001/expected+                       test/idrisdoc001/*.idr+                       test/idrisdoc001/*.ipkg+                       test/idrisdoc002/run+                       test/idrisdoc002/expected+                       test/idrisdoc002/*.idr+                       test/idrisdoc002/*.ipkg+                       test/idrisdoc003/run+                       test/idrisdoc003/expected+                       test/idrisdoc003/*.idr+                       test/idrisdoc003/*.ipkg+                       test/idrisdoc004/run+                       test/idrisdoc004/expected+                       test/idrisdoc004/*.idr+                       test/idrisdoc004/*.ipkg+                       test/idrisdoc005/run+                       test/idrisdoc005/expected+                       test/idrisdoc005/*.idr+                       test/idrisdoc005/*.ipkg+                       test/idrisdoc006/run+                       test/idrisdoc006/expected+                       test/idrisdoc006/A/fully/Qualified/NAME.idr+                       test/idrisdoc006/*.idr+                       test/idrisdoc006/*.ipkg+                       test/idrisdoc007/run+                       test/idrisdoc007/expected+                       test/idrisdoc007/*.idr+                       test/idrisdoc007/*.ipkg+                       test/idrisdoc008/run+                       test/idrisdoc008/expected+                       test/idrisdoc008/*.idr+                       test/idrisdoc008/*.ipkg+                        test/interactive001/run                        test/interactive001/input                        test/interactive001/*.idr@@ -321,6 +370,10 @@                        test/interactive003/input                        test/interactive003/*.idr                        test/interactive003/expected+                       test/interactive004/run+                       test/interactive004/input+                       test/interactive004/*.idr+                       test/interactive004/expected                         test/io001/run                        test/io001/*.idr@@ -361,6 +414,12 @@                        test/records001/run                        test/records001/*.idr                        test/records001/expected+                       test/records002/run+                       test/records002/*.idr+                       test/records002/expected+                       test/records003/run+                       test/records003/*.idr+                       test/records003/expected                         test/sugar001/run                        test/sugar001/*.idr@@ -387,6 +446,16 @@                        test/totality005/run                        test/totality005/*.idr                        test/totality005/expected+                       test/totality006/run+                       test/totality006/*.idr+                       test/totality006/expected+                       test/totality007/run+                       test/totality007/*.ipkg+                       test/totality007/src/*.idr+                       test/totality007/expected+                       test/totality008/run+                       test/totality008/*.idr+                       test/totality008/expected                         test/tutorial001/run                        test/tutorial001/*.idr@@ -456,6 +525,7 @@                 , Idris.AbsSyntax                 , Idris.AbsSyntaxTree                 , Idris.Apropos+                , Idris.ASTUtils                 , Idris.CaseSplit                 , Idris.Chaser                 , Idris.Colours@@ -469,13 +539,16 @@                 , Idris.Docstrings                 , Idris.ElabDecls                 , Idris.ElabTerm+                , Idris.Erasure                 , Idris.Error                 , Idris.ErrReverse                 , Idris.Help                 , Idris.IBC                 , Idris.IdeSlave+                , Idris.IdrisDoc                 , Idris.Imports                 , Idris.Inliner+                , Idris.Interactive                 , Idris.Output                 , Idris.Parser                 , Idris.ParseHelpers@@ -490,8 +563,10 @@                 , Idris.REPL                 , Idris.REPLParser                 , Idris.Transforms+                , Idris.TypeSearch                 , Idris.Unlit-                , Idris.UnusedArgs+                , Idris.WhoCalls+                , Idris.CmdOptions                  , IRTS.BCImp                 , IRTS.Bytecode@@ -533,6 +608,8 @@                 , ansi-terminal                 , ansi-wl-pprint                 , binary+                , blaze-html >= 0.6.1.3+                , blaze-markup >= 0.5.2.1 && < 0.7.0.0                 , bytestring                 , cheapskate                 , containers >= 0.5@@ -543,7 +620,7 @@                 , language-java >= 0.2.6                 , lens >= 4.1.1                 , mtl-                , parsers >= 0.9+                , parsers >= 0.9 && < 0.11.0.2                  , pretty                 , process                 , split@@ -559,6 +636,7 @@                 , xml                 , deepseq                 , zlib+                , optparse-applicative   Extensions:     MultiParamTypeClasses                 , FunctionalDependencies                 , FlexibleContexts
+ idrisdoc/styles.css view
@@ -0,0 +1,320 @@+html, body {++  margin: 0;+  padding: 0;+  border: 0;+  +  height: 100%;++  font-family: "Trebuchet MS", Helvetica, sans-serif;+  font-size: 11pt;++  background-color: #FFF;+}++a, a:active, a:visited {++  text-decoration: none;+  color: inherit;+}++a:hover {++  text-decoration: underline;+}++header {++  padding: 5px 11px;++  border-bottom: 3px solid #659FDB;+  box-shadow: 0 -8px 22px 0px;+  +  background-color: #252525;+  color: white;+  +  font-size: 9pt;+}++.wrapper {++  min-height: 100%;+}++header nav, header strong {++  font-size: 11pt;+}++header nav {++  float: right;+}++footer {++  height: 30px;+  width: 100%;+  border-top: 1px solid #AAAAAA;+  +  margin-top: -31px;+  +  text-align: center;+  color: #666;+  line-height: 30px;+  font-size: 9pt;+  +  background: none repeat scroll 0 0 #DDDDDD;+}++.container {+  +  padding: 10px 10px 41px 20px;+}++body.index .container a:visited {++  color: #666;+}++body.index .container a:hover {++  color: #04819E;+}++h1 {++  margin: 0;+  margin-bottom: 5px;+  font-size: 14pt;+  +  font-family: "Trebuchet MS", Helvetica, sans-serif;+}++body.namespace h1 {++  border-bottom: 1px solid #BBB;+  padding-bottom: 2px;+}++ul {++  list-style-type: none;++  margin: 0;+  padding: 0;+}++hr {++  margin: 0;+  padding: 0;+  border: 0;+  +  border-bottom: 1px solid #BBB;+}++p {++  margin: 0;+  padding: 0;+}++.code {++  font-family: "Lucida Console", Monaco, monospace;+  font-size: 10pt;+}++.decls {++  margin-top: 15px;+}++.decls > dt {++  font-family: "Lucida Console", Monaco, monospace;+  font-size: 10pt;+  line-height: 20px;+  +  padding: 2px 0;+  +  border: 1px solid #CCC;+  background-color: #F0F0F0;+  +  display: table;+  width: 100%;+}++.decls > dt > :first-child {++  padding-left: 6px;+}++.decls > dt > :last-child {++  padding-right: 6px;+}++.decls > dd {++  margin: 10px 0 10px 20px;+  +  font-family: Arial, sans-serif;+  font-size: 10pt;+}++.decls > dd > p {++  margin-bottom: 8px;+}++.decls > dd > dl:not(.decls):not(:first-child) {+  +  padding-top: 5px;+  border-top: 1px solid #EEE;+}++.decls > dd > dl:not(.decls) > dt {++  display: block;+  min-width: 70px;+  +  float: left;+  +  font-weight: bold;+}++.decls > dd > dl:not(.decls) > dd {++  margin-bottom: 2px;+}++.fixity {++  font-style: italic;+  font-weight: normal !important;+}++dd.fixity {++  cursor: default;+}++.word {++  display: table-cell;+  white-space: nowrap;+  width: 0;+}++.signature {++  display: table-cell;+  width: 100%;+}++.name {+  +  display: table-cell;+  white-space: nowrap;+  width: 0;+}++.documented, .name {++  cursor: default;+}++.documented {++  font-weight: bold;+}++a.function {++  color: #00BA00;+}++.function {++  color: #007C21;+}++a.constructor {++  color: #FF0000;+}++.constructor {++  color: #BF3030;+}++a.type {++  color: #0000FF;+}++.type {++  color: #050599;+}++.keyword {++  color: inherit;+}++.boundvar {++  color: #BF30BF; /* Too much colour makes it hard to differ the rest of the colours */+  color: inherit;+}++.boundvar.implicit {++  text-decoration: underline;+}++/******************* Old colours++a {++  color: #04819E;+}++a:visited {++  color: #26A3BF;+}++********************/++ul.names {++  border: 1px solid #666;+}++ul.names li:nth-child(odd) {++  background-color: #EEEEEF;+}++ul.names li:nth-child(even) {++  background-color: white;+}++ul.names li {++  padding-left: 5px;+}++ul.names li a {++  display: inline-block;+  width: 100%;+  +  padding: 2px 0;+}
jsrts/Runtime-browser.js view
@@ -1,3 +1,14 @@ var __IDRRT__print = function(s) {   console.log(s); };+++var __IDRRT__systemInfo = function(index) {+    switch(index) {+        case 0:+            return "javascript";+        case 1:+            return navigator.platform;+    }+    return "";+}
jsrts/Runtime-common.js view
@@ -34,3 +34,19 @@    return ret; };++var __IDRRT__charCode = function(str) {+  var type = typeof str;+  if (type == "string")+    return str.charCodeAt(0);+  else+    return str;+}++var __IDRRT__fromCharCode = function(chr) {+  var type = typeof chr;+  if (type == "string")+    return chr;+  else+    return String.fromCharCode(chr);+}
jsrts/Runtime-node.js view
@@ -4,3 +4,14 @@     util.print(s);   }; })();++var __IDRRT__systemInfo = function(index) {+    var os = require('os')+    switch(index) {+        case 0:+            return "node";+        case 1:+            return os.platform();+    }+    return "";+}
libs/Makefile view
@@ -2,22 +2,16 @@ 	$(MAKE) -C prelude build 	$(MAKE) -C base build 	$(MAKE) -C effects build-	$(MAKE) -C oldeffects build-	$(MAKE) -C javascript build   install: 	$(MAKE) -C prelude install 	$(MAKE) -C base install 	$(MAKE) -C effects install-	$(MAKE) -C oldeffects install-	$(MAKE) -C javascript install  clean: 	$(MAKE) -C prelude clean 	$(MAKE) -C base clean 	$(MAKE) -C effects clean-	$(MAKE) -C oldeffects clean-	$(MAKE) -C javascript clean          .PHONY: build install clean
libs/base/Control/Arrow.idr view
@@ -1,4 +1,4 @@-module Category.Arrow+module Control.Arrow  import Data.Morphisms import Control.Category@@ -37,4 +37,3 @@   (Kleisli f) &&& (Kleisli g) = Kleisli $ \a => do x <- f a                                                    y <- g a                                                    return (x, y)-
libs/base/Control/Catchable.idr view
@@ -1,4 +1,4 @@-module Prelude.Catchable+module Control.Catchable  import Control.IOExcept
libs/base/Data/Bits.idr view
@@ -356,8 +356,8 @@ bitsToInt (MkBits x) = bitsToInt' x  -- Zero out the high bits of a truncated bitstring---zeroUnused : machineTy (nextBytes n) -> machineTy (nextBytes n)---zeroUnused {n} x = x `and'` complement' (intToBits' {n=n} 0)+zeroUnused : machineTy (nextBytes n) -> machineTy (nextBytes n)+zeroUnused {n} x = x `and'` complement' (intToBits' {n=n} 0)  --instance Cast Nat (Bits n) where --    cast x = MkBits (zeroUnused (natToBits n))@@ -399,8 +399,8 @@  -- TODO: Prove %assert_total -- can't verify coverage of with block-trunc' : machineTy (nextBytes (n+m)) -> machineTy (nextBytes n)-trunc' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m))+trunc' : machineTy (nextBytes (m+n)) -> machineTy (nextBytes n)+trunc' {m=m} {n=n} x with (nextBytes n, nextBytes (m+n))     | (Z, Z) = believe_me x     | (Z, S Z) = believe_me (prim__truncB16_B8 (believe_me x))     | (Z, S (S Z)) = believe_me (prim__truncB32_B8 (believe_me x))@@ -412,9 +412,9 @@     | (S (S Z), S (S (S _))) = believe_me (prim__truncB64_B32 (believe_me x))     | (S (S (S _)), S (S (S _))) = believe_me x ---public---truncate : Bits (n+m) -> Bits n---truncate (MkBits x) = MkBits (zeroUnused (trunc' x))+public+truncate : Bits (m+n) -> Bits n+truncate (MkBits x) = MkBits (zeroUnused (trunc' x))  public bitAt : Fin n -> Bits n
libs/base/Data/BoundedList.idr view
@@ -3,11 +3,13 @@ %access public %default total -data BoundedList : Type -> Nat -> Type where-  Nil : BoundedList a n-  (::) : a -> BoundedList a n -> BoundedList a (S n)+||| A list with an upper bound on its length.+data BoundedList : Nat -> Type -> Type where+  Nil : BoundedList n a+  (::) : a -> BoundedList n a -> BoundedList (S n) a -length : BoundedList a n -> Fin (S n)+||| Compute the length of a list.+length : BoundedList n a -> Fin (S n) length [] = fZ length (x :: xs) = fS (length xs) @@ -15,7 +17,7 @@ -- Indexing into bounded lists -------------------------------------------------------------------------------- -index : Fin (S n) -> BoundedList a n -> Maybe a+index : Fin (S n) -> BoundedList n a -> Maybe a index _      []        = Nothing index fZ     (x :: _)  = Just x index (fS f) (_ :: xs) = index f xs@@ -24,7 +26,8 @@ -- Adjusting bounds -------------------------------------------------------------------------------- -weaken : BoundedList a n -> BoundedList a (n + m)+||| Loosen the bounds on a list's length.+weaken : BoundedList n a -> BoundedList (n + m) a weaken []        = [] weaken (x :: xs) = x :: weaken xs @@ -32,16 +35,16 @@ -- Conversions to and from list -------------------------------------------------------------------------------- -take : (n : Nat) -> List a -> BoundedList a n+take : (n : Nat) -> List a -> BoundedList n a take _ [] = [] take Z _ = [] take (S n') (x :: xs) = x :: take n' xs -toList : BoundedList a n -> List a+toList : BoundedList n a -> List a toList [] = []-toList (x :: xs) = x :: toList xs+toList (x :: xs) = x :: Data.BoundedList.toList xs -fromList : (xs : List a) -> BoundedList a (length xs)+fromList : (xs : List a) -> BoundedList (length xs) a fromList [] = [] fromList (x :: xs) = x :: fromList xs @@ -49,7 +52,7 @@ -- Building (bigger) bounded lists -------------------------------------------------------------------------------- -replicate : (n : Nat) -> a -> BoundedList a n+replicate : (n : Nat) -> a -> BoundedList n a replicate Z _ = [] replicate (S n) x = x :: replicate n x @@ -57,27 +60,26 @@ -- Folds -------------------------------------------------------------------------------- -foldl : (a -> b -> a) -> a -> BoundedList b n -> a-foldl f e []      = e-foldl f e (x::xs) = foldl f (f e x) xs--foldr : (a -> b -> b) -> b -> BoundedList a n -> b-foldr f e []      = e-foldr f e (x::xs) = f x (foldr f e xs)+instance Foldable (BoundedList n) where+  foldr f e []      = e+  foldr f e (x::xs) = f x (foldr f e xs)+  foldl f e []      = e+  foldl f e (x::xs) = foldl f (f e x) xs  -------------------------------------------------------------------------------- -- Maps -------------------------------------------------------------------------------- -map : (a -> b) -> BoundedList a n -> BoundedList b n-map f [] = []-map f (x :: xs) = f x :: map f xs+instance Functor (BoundedList n) where+  map f [] = []+  map f (x :: xs) = f x :: map f xs  -------------------------------------------------------------------------------- -- Misc -------------------------------------------------------------------------------- -pad : (xs : BoundedList a n) -> (padding : a) -> BoundedList a n+||| Extend a bounded list to the maximum size by padding on the left.+pad : BoundedList n a -> a -> BoundedList n a pad {n=Z}    []        _       = [] pad {n=S n'} []        padding = padding :: (pad {n=n'} [] padding) pad {n=S n'} (x :: xs) padding = x :: pad {n=n'} xs padding@@ -87,6 +89,6 @@ -- Simple properties -------------------------------------------------------------------------------- -zeroBoundIsEmpty : (xs : BoundedList a 0) -> xs = the (BoundedList a 0) []+zeroBoundIsEmpty : (xs : BoundedList 0 a) -> xs = the (BoundedList 0 a) [] zeroBoundIsEmpty [] = refl zeroBoundIsEmpty (_ :: _) impossible
libs/base/Data/Buffer.idr view
@@ -36,15 +36,15 @@ bitsFromFin fZ     = 0 bitsFromFin (fS k) = 1 + bitsFromFin k --- Allocate an empty Buffer. The size hint can be used to avoid--- unnecessary reallocations and copies under the hood if the--- approximate ultimate size of the Buffer is known. Users can assume--- the new Buffer is word-aligned.+||| Allocate an empty Buffer. The size hint can be used to avoid+||| unnecessary reallocations and copies under the hood if the+||| approximate ultimate size of the Buffer is known. Users can assume+||| the new Buffer is word-aligned. public allocate : ( hint : Nat ) -> Buffer Z allocate = MkBuffer Z . prim__allocate . bitsFromNat --- Append count repetitions of a Buffer to another Buffer+||| Append count repetitions of a Buffer to another Buffer %assert_total public appendBuffer : Buffer n        ->@@ -63,13 +63,13 @@     off : Bits64     off = bitsFromNat o2 --- Copy a buffer, potentially allowing the (potentially large) space it--- pointed to to be freed+||| Copy a buffer, potentially allowing the (potentially large) space it+||| pointed to to be freed public copy : Buffer n -> Buffer n copy { n } = replace ( plusZeroRightNeutral n ) . appendBuffer ( allocate n ) 1 --- Create a view over a buffer+||| Create a view over a buffer public peekBuffer : { n : Nat } -> { offset : Nat } -> Buffer ( n + offset ) -> ( offset : Nat ) -> Buffer n peekBuffer ( MkBuffer o r ) off = MkBuffer ( o + off ) r@@ -93,7 +93,7 @@   MkBuffer o . prim r ( bitsFromNat $ n + o ) ( bitsFromNat count )  --- Read a Bits8 from a Buffer starting at offset+||| Read a Bits8 from a Buffer starting at offset %assert_total public peekBits8 : Buffer ( 1 + n )           ->@@ -101,7 +101,7 @@             Bits8 peekBits8 = peekBits { m = 1 } prim__peekB8Native --- Append count repetitions of a Bits8 to a Buffer+||| Append count repetitions of a Bits8 to a Buffer %assert_total public appendBits8 : Buffer n        ->@@ -110,7 +110,7 @@               Buffer ( n + count * 1 ) appendBits8 = appendBits prim__appendB8Native --- Read a Bits16 in native byte order from a Buffer starting at offset+||| Read a Bits16 in native byte order from a Buffer starting at offset %assert_total public peekBits16Native : Buffer ( 2 + n )           ->@@ -118,19 +118,19 @@                    Bits16 peekBits16Native = peekBits { m = 2 } prim__peekB16Native --- Read a little-endian Bits16 from a Buffer starting at offset+||| Read a little-endian Bits16 from a Buffer starting at offset %assert_total public peekBits16LE : Buffer ( 2 + n ) -> ( offset : Fin ( S n ) ) -> Bits16 peekBits16LE = peekBits { m = 2 } prim__peekB16LE --- Read a big-endian Bits16 from a Buffer starting at offset+||| Read a big-endian Bits16 from a Buffer starting at offset %assert_total public peekBits16BE : Buffer ( 2 + n ) -> ( offset : Fin ( S n ) ) -> Bits16 peekBits16BE = peekBits { m = 2 } prim__peekB16BE --- Append count repetitions of a Bits16 in native byte order to a Buffer+||| Append count repetitions of a Bits16 in native byte order to a Buffer %assert_total public appendBits16Native : Buffer n        ->@@ -139,7 +139,7 @@                      Buffer ( n + count * 2 ) appendBits16Native = appendBits prim__appendB16Native --- Append count repetitions of a little-endian Bits16 to a Buffer+||| Append count repetitions of a little-endian Bits16 to a Buffer %assert_total public appendBits16LE : Buffer n        ->@@ -148,7 +148,7 @@                  Buffer ( n + count * 2 ) appendBits16LE = appendBits prim__appendB16LE --- Append count repetitions of a big-endian Bits16 to a Buffer+||| Append count repetitions of a big-endian Bits16 to a Buffer %assert_total public appendBits16BE : Buffer n        ->@@ -157,7 +157,7 @@                  Buffer ( n + count * 2 ) appendBits16BE = appendBits prim__appendB16BE --- Read a Bits32 in native byte order from a Buffer starting at offset+||| Read a Bits32 in native byte order from a Buffer starting at offset %assert_total public peekBits32Native : Buffer ( 4 + n )           ->@@ -165,19 +165,19 @@                    Bits32 peekBits32Native = peekBits { m = 4 } prim__peekB32Native --- Read a little-endian Bits32 from a Buffer starting at offset+||| Read a little-endian Bits32 from a Buffer starting at offset %assert_total public peekBits32LE : Buffer ( 4 + n ) -> ( offset : Fin ( S n ) ) -> Bits32 peekBits32LE = peekBits { m = 4 } prim__peekB32LE --- Read a big-endian Bits32 from a Buffer starting at offset+||| Read a big-endian Bits32 from a Buffer starting at offset %assert_total public peekBits32BE : Buffer ( 4 + n ) -> ( offset : Fin ( S n ) ) -> Bits32 peekBits32BE = peekBits { m = 4 } prim__peekB32BE --- Append count repetitions of a Bits32 in native byte order to a Buffer+||| Append count repetitions of a Bits32 in native byte order to a Buffer %assert_total public appendBits32Native : Buffer n        ->@@ -186,7 +186,7 @@                      Buffer ( n + count * 4 ) appendBits32Native = appendBits prim__appendB32Native --- Append count repetitions of a little-endian Bits32 to a Buffer+||| Append count repetitions of a little-endian Bits32 to a Buffer %assert_total public appendBits32LE : Buffer n        ->@@ -195,7 +195,7 @@                  Buffer ( n + count * 4 ) appendBits32LE = appendBits prim__appendB32LE --- Append count repetitions of a big-endian Bits32 to a Buffer+||| Append count repetitions of a big-endian Bits32 to a Buffer %assert_total public appendBits32BE : Buffer n        ->@@ -204,7 +204,7 @@                  Buffer ( n + count * 4 ) appendBits32BE = appendBits prim__appendB32BE --- Read a Bits64 in native byte order from a Buffer starting at offset+||| Read a Bits64 in native byte order from a Buffer starting at offset %assert_total public peekBits64Native : Buffer ( 8 + n )           ->@@ -212,19 +212,19 @@                    Bits64 peekBits64Native = peekBits { m = 8 } prim__peekB64Native --- Read a little-endian Bits64 from a Buffer starting at offset+||| Read a little-endian Bits64 from a Buffer starting at offset %assert_total public peekBits64LE : Buffer ( 8 + n ) -> ( offset : Fin ( S n ) ) -> Bits64 peekBits64LE = peekBits { m = 8 } prim__peekB64LE --- Read a big-endian Bits64 from a Buffer starting at offset+||| Read a big-endian Bits64 from a Buffer starting at offset %assert_total public peekBits64BE : Buffer ( 8 + n ) -> ( offset : Fin ( S n ) ) -> Bits64 peekBits64BE = peekBits { m = 8 } prim__peekB64BE --- Append count repetitions of a Bits64 in native byte order to a Buffer+||| Append count repetitions of a Bits64 in native byte order to a Buffer %assert_total public appendBits64Native : Buffer n        ->@@ -233,7 +233,7 @@                      Buffer ( n + count * 8 ) appendBits64Native = appendBits prim__appendB64Native --- Append count repetitions of a little-endian Bits64 to a Buffer+||| Append count repetitions of a little-endian Bits64 to a Buffer %assert_total public appendBits64LE : Buffer n        ->@@ -242,7 +242,7 @@                  Buffer ( n + count * 8 ) appendBits64LE = appendBits prim__appendB64LE --- Append count repetitions of a big-endian Bits64 to a Buffer+||| Append count repetitions of a big-endian Bits64 to a Buffer %assert_total public appendBits64BE : Buffer n        ->
libs/base/Data/Complex.idr view
@@ -62,8 +62,8 @@ -- We can't do "instance Num a => Num (Complex a)" because -- we need "abs" which needs "magnitude" which needs "sqrt" which needs Float instance Num (Complex Float) where-    (+) (a:+b) (c:+d) = ((a+b):+(c+d))-    (-) (a:+b) (c:+d) = ((a-b):+(c-d))+    (+) (a:+b) (c:+d) = ((a+c):+(b+d))+    (-) (a:+b) (c:+d) = ((a-c):+(b-d))     (*) (a:+b) (c:+d) = ((a*c-b*d):+(b*c+a*d))     fromInteger x = (fromInteger x:+0)     abs (a:+b) = (magnitude (a:+b):+0)
+ libs/base/Data/Erased.idr view
@@ -0,0 +1,29 @@+module Data.Erased++%access public+%default total++||| The erasure monad.+|||+||| Used when explicit modelling of erasure in the type system is needed.+data Erased : Type -> Type where++    ||| Construct an erased value from any value.+    Erase : .(x : a) -> Erased a++instance Functor Erased where+  map f (Erase x) = Erase (f x)++instance Applicative Erased where+  pure = Erase+  (<$>) (Erase f) (Erase x) = Erase (f x)++instance Monad Erased where+  (>>=) (Erase x) f = f x++||| Project the erased value out of the monad.+|||+||| This is usable only in types and other erased contexts,+||| where it won't cause erasure violations.+unerase : Erased a -> a+unerase (Erase x) = x
libs/base/Data/Fun.idr view
@@ -2,9 +2,7 @@  %default total ------------------------------------------------------------------------------------ Build an n-ary function type from a Vect of Types and a result type---------------------------------------------------------------------------------+||| Build an n-ary function type from a Vect of Types and a result type Fun : Vect n Type -> Type -> Type Fun [] r = r Fun (t::ts) r = t -> Fun ts r@@ -14,5 +12,4 @@ chain {ts = (_::_)} g f = \ x => chain g (f x)  target : {ts : Vect n Type} -> Fun ts r -> Type-target {r} _ = r -+target {r} _ = r
libs/base/Data/HVect.idr view
@@ -6,7 +6,8 @@ %default total  using (k : Nat, ts : Vect k Type)-  ||| Heterogeneous vectors where the type index gives, element-wise, the types of the contents+  ||| 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)@@ -30,6 +31,7 @@   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)@@ -52,16 +54,18 @@   instance (Shows k ts) => Show (HVect ts) where     show xs = show (shows xs) -  ||| Extract an arbitrary element of the correct type+  ||| 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 +  ||| 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.   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
+ libs/base/Data/List.idr view
@@ -0,0 +1,31 @@+module Data.List++%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)++  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
libs/base/Data/Mod2.idr view
@@ -4,7 +4,7 @@  %default total --- Integers modulo 2^n+||| Integers modulo 2^n public data Mod2 : Nat -> Type where     MkMod2 : {n : Nat} -> Bits n -> Mod2 n
libs/base/Data/Rel.idr view
@@ -2,9 +2,8 @@  import Data.Fun ------------------------------------------------------------------------------------ Build an n-ary relation type from a Vect of Types---------------------------------------------------------------------------------++||| Build an n-ary relation type from a Vect of Types Rel : Vect n Type -> Type Rel ts = Fun ts Type
libs/base/Data/SortedMap.idr view
@@ -183,10 +183,10 @@       Left t3' => Left (Branch3 t1 k1 t2 k2 t3')       Right t3' => Left (merge3 t1 k1 t2 k2 t3') -treeToList : Ord k => Tree n k v -> List (k, v)+treeToList : Tree n k v -> List (k, v) treeToList = treeToList' (:: [])   where-    treeToList' : Ord k => ((k, v) -> List (k, v)) -> Tree n k v -> List (k, v)+    treeToList' : ((k, v) -> List (k, v)) -> Tree n k v -> List (k, v)     treeToList' cont (Leaf k v) = cont (k, v)     treeToList' cont (Branch2 t1 _ t2) = treeToList' (:: treeToList' cont t2) t1     treeToList' cont (Branch3 t1 _ t2 _ t3) = treeToList' (:: treeToList' (:: treeToList' cont t3) t2) t1@@ -223,7 +223,7 @@ fromList : Ord k => List (k, v) -> SortedMap k v fromList l = foldl (flip (uncurry insert)) empty l -toList : Ord k => SortedMap k v -> List (k, v)+toList : SortedMap k v -> List (k, v) toList Empty = [] toList (M _ t) = treeToList t
libs/base/Data/SortedSet.idr view
@@ -21,5 +21,8 @@ fromList : Ord k => List k -> SortedSet k fromList l = SetWrapper (Data.SortedMap.fromList (map (\i => (i, ())) l)) -toList : Ord k => SortedSet k -> List k+toList : SortedSet k -> List k toList (SetWrapper m) = map (\(i, _) => i) (Data.SortedMap.toList m)++instance Foldable SortedSet where+  foldr f e xs = foldr f e (Data.SortedSet.toList xs)
libs/base/Data/Vect.idr view
@@ -15,6 +15,24 @@     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 [] -> _|_+noEmptyElem Here impossible++||| An item not in the head and not in the tail is not in the Vect at all+neitherHereNorThere : {x, y : a} -> {xs : Vect n a} -> Not (x = y) -> Not (Elem x xs) -> Not (Elem x (y :: xs))+neitherHereNorThere xneqy xninxs Here = xneqy refl+neitherHereNorThere xneqy xninxs (There xinxs) = xninxs xinxs++||| A decision procedure for Elem+isElem : DecEq a => (x : a) -> (xs : Vect n a) -> Dec (Elem x xs)+isElem x [] = No noEmptyElem+isElem x (y :: xs) with (decEq x y)+  isElem x (x :: xs) | (Yes refl) = Yes Here+  isElem x (y :: xs) | (No xneqy) with (isElem x xs)+    isElem x (y :: xs) | (No xneqy) | (Yes xinxs) = Yes (There xinxs)+    isElem x (y :: xs) | (No xneqy) | (No xninxs) = No (neitherHereNorThere xneqy xninxs)+ ||| A tactic for discovering where, if anywhere, an element is in a vector ||| @ n how many elements to search before giving up findElem : (n : Nat) -> List (TTName, Binder TT) -> TT -> Tactic
libs/base/Language/Reflection.idr view
@@ -167,6 +167,8 @@             -- ^ apply both tactics in sequence             | Trivial             -- ^ intelligently construct the proof target from the context+            | Search Int+            -- ^ build a proof by applying contructors up to a maximum depth              | Instance             -- ^ resolve a type class              | Solve
libs/base/System/Concurrency/Process.idr view
@@ -9,9 +9,8 @@ abstract data ProcID msg = MkPID Ptr --- Type safe message passing programs. Parameterised over the type of--- message which can be send, and the return type.-+||| Type safe message passing programs. Parameterised over the type of+||| message which can be send, and the return type. data Process : (msgType : Type) -> Type -> Type where      lift : IO a -> Process msg a @@ -30,31 +29,26 @@ run : Process msg x -> IO x run (lift prog) = prog --- Get current process ID-+||| Get current process ID myID : Process msg (ProcID msg) myID = lift (return (MkPID prim__vm)) --- Send a message to another process-+||| Send a message to another process send : ProcID msg -> msg -> Process msg () send (MkPID p) m = lift (sendToThread p (prim__vm, m)) --- Return whether a message is waiting in the queue-+||| Return whether a message is waiting in the queue msgWaiting : Process msg Bool msgWaiting = lift checkMsgs --- Receive a message - blocks if there is no message waiting-+||| Receive a message - blocks if there is no message waiting recv : Process msg msg recv {msg} = do (senderid, m) <- lift get                 return m   where get : IO (Ptr, msg)         get = getMsg --- receive a message, and return with the sender's process ID.-+||| receive a message, and return with the sender's process ID. recvWithSender : Process msg (ProcID msg, msg) recvWithSender {msg}      = do (senderid, m) <- lift get@@ -65,4 +59,3 @@ create : Process msg () -> Process msg (ProcID msg) create (lift p) = do ptr <- lift (fork p)                      return (MkPID ptr)-
libs/base/System/Concurrency/Raw.idr view
@@ -6,8 +6,7 @@  import System --- Send a message of any type to the thread with the given thread id-+||| Send a message of any type to the thread with the given thread id sendToThread : (thread_id : Ptr) -> a -> IO () sendToThread {a} dest val    = mkForeign (FFun "idris_sendMessage"@@ -18,10 +17,8 @@                         [FPtr] FInt) prim__vm                return (intToBool msgs) --- Check inbox for messages. If there are none, blocks until a message--- arrives.-+||| Check inbox for messages. If there are none, blocks until a message+||| arrives. getMsg : IO a getMsg {a} = mkForeign (FFun "idris_recvMessage"                 [FPtr] (FAny a)) prim__vm-
+ libs/base/System/Info.idr view
@@ -0,0 +1,13 @@+module System.Info++||| The Idris backend in use+backend : String+backend = prim__systemInfo 0++||| The operating system in use.+os : String+os = prim__systemInfo 1++||| The triple this program was targeted for+targetTriple : String+targetTriple = prim__systemInfo 2
libs/base/base.ipkg view
@@ -6,6 +6,7 @@           Network.Cgi, Network.Socket,           Debug.Trace, +          System.Info,           System.Concurrency.Raw, System.Concurrency.Process,            Decidable.Decidable, Decidable.Order,@@ -22,7 +23,8 @@           Data.SortedMap, Data.SortedSet, Data.BoundedList,           Data.Vect, Data.HVect, Data.Vect.Quantifiers,           Data.Floats, Data.Complex, Data.Heap, Data.Fun,-          Data.Rel, Data.Buffer,+          Data.Rel, Data.Buffer, Data.Erased,+          Data.List,            Control.Isomorphism, Control.Isomorphism.Primitives,           Control.Monad.Identity,
libs/effects/Effect/Exception.idr view
@@ -27,7 +27,7 @@ EXCEPTION t = MkEff () (Exception t)  raise : a -> { [EXCEPTION a ] } Eff m b -raise err = Raise err+raise err = call $ Raise err
libs/effects/Effect/File.idr view
@@ -107,27 +107,27 @@        -> { [FILE_IO ()] ==> [FILE_IO (if result                                           then OpenFile m                                           else ())] } Eff e Bool-open f m = Open f m+open f m = call $ Open f m   ||| Close a file. close : Handler FileIO e =>         { [FILE_IO (OpenFile m)] ==> [FILE_IO ()] } Eff e ()-close = Close+close = call $ Close  ||| Read a line from the file. readLine : Handler FileIO e =>             { [FILE_IO (OpenFile Read)] } Eff e String -readLine = ReadLine+readLine = call $ ReadLine  ||| Write a line to a file. writeLine : Handler FileIO e =>              String -> { [FILE_IO (OpenFile Write)] } Eff e ()-writeLine str = WriteLine str+writeLine str = call $ WriteLine str  ||| End of file? eof : Handler FileIO e =>        { [FILE_IO (OpenFile Read)] } Eff e Bool -eof = EOF+eof = call $ EOF  -- --------------------------------------------------------------------- [ EOF ]
libs/effects/Effect/Memory.idr view
@@ -102,7 +102,7 @@  allocate : (n : Nat) ->             Eff m () [RAW_MEMORY ()] (\v => [RAW_MEMORY (MemoryChunk n 0)])-allocate size = Allocate size+allocate size = call $ Allocate size  initialize : {i : Nat} ->              {n : Nat} ->@@ -111,17 +111,17 @@              so (i + size <= n) ->              Eff m () [RAW_MEMORY (MemoryChunk n i)]                         (\v => [RAW_MEMORY (MemoryChunk n (i + size))])-initialize c size prf = Initialize c size prf+initialize c size prf = call $ Initialize c size prf  free : Eff m () [RAW_MEMORY (MemoryChunk n i)] (\v => [RAW_MEMORY ()])-free = Free+free = call Free  peek : {i : Nat} ->        (offset : Nat) ->        (size : Nat) ->        so (offset + size <= i) ->        { [RAW_MEMORY (MemoryChunk n i)] } Eff m (Vect size Bits8) -peek offset size prf = Peek offset size prf+peek offset size prf = call $ Peek offset size prf  poke : {n : Nat} ->        {i : Nat} ->@@ -130,11 +130,11 @@        so (offset <= i && offset + size <= n) ->        Eff m () [RAW_MEMORY (MemoryChunk n i)]                (\v => [RAW_MEMORY (MemoryChunk n (max i (offset + size)))])-poke offset content prf = Poke offset content prf+poke offset content prf = call $ Poke offset content prf  private getRawPtr : { [RAW_MEMORY (MemoryChunk n i)] } Eff m (MemoryChunk n i) -getRawPtr = GetRawPtr+getRawPtr = call $ GetRawPtr  private move' : {dst_size : Nat} ->@@ -149,7 +149,7 @@         Eff m () [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-  = 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  data MoveDescriptor = Dst | Src
libs/effects/Effect/Random.idr view
@@ -9,25 +9,39 @@ using (m : Type -> Type)   instance Handler Random m where      handle seed getRandom k-              = let seed' = (1664525 * seed + 1013904223) `prim__sremBigInt` (pow 2 32) in+              = let seed' = assert_total ((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 +||| Generates a random Integer in a given range rndInt : Integer -> Integer -> { [RND] } Eff m Integer-rndInt lower upper = do v <- getRandom+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 = do let v = !getRandom `prim__sremBigInt` (cast k)+rndFin k = do let v = assert_total $ !(call getRandom) `prim__sremBigInt` (cast (S k))               return (toFin v)  where toFin : Integer -> Fin (S k)         toFin x = case integerToFin x (S k) of                       Just v => v                       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' {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 []      = return Nothing+rndSelect (x::xs) = return (Just !(rndSelect' (x::(fromList xs))))++||| Sets the random seed srand : Integer -> { [RND] } Eff m ()-srand n = setSeed n+srand n = call $ setSeed n
libs/effects/Effect/Select.idr view
@@ -19,5 +19,5 @@ SELECT = MkEff () Selection  select : List a -> { [SELECT] } Eff m a -select xs = Select xs+select xs = call $ Select xs
libs/effects/Effect/State.idr view
@@ -17,13 +17,13 @@ STATE t = MkEff t State  get : { [STATE x] } Eff m x-get = Get+get = call $ Get  put : x -> { [STATE x] } Eff m () -put val = Put val+put val = call $ Put val  putM : y -> { [STATE x] ==> [STATE y] } Eff m () -putM val = Put val+putM val = call $ Put val  update : (x -> x) -> { [STATE x] } Eff m ()  update f = put (f !get)
libs/effects/Effect/StdIO.idr view
@@ -3,12 +3,22 @@ import Effects import Control.IOExcept +-------------------------------------------------------------+-- IO effects internals+-------------------------------------------------------------++||| The internal representation of StdIO effects data StdIO : Effect where      PutStr : String -> { () } StdIO ()       GetStr : { () } StdIO String       PutCh : Char -> { () } StdIO ()      GetCh : { () } StdIO Char ++-------------------------------------------------------------+-- IO effects handlers+-------------------------------------------------------------+ instance Handler StdIO IO where     handle () (PutStr s) k = do putStr s; k () ()     handle () GetStr     k = do x <- getLine; k x ()@@ -21,23 +31,30 @@     handle () (PutCh c)  k = do ioe_lift $ putChar c; k () ()      handle () GetCh      k = do x <- ioe_lift $ getChar; k x () +------------------------------------------------------------- --- The Effect and associated functions+-------------------------------------------------------------  STDIO : EFFECT STDIO = MkEff () StdIO +||| Write a string to standard output. putStr : Handler StdIO e => String -> { [STDIO] } Eff e ()-putStr s = PutStr s+putStr s = call $ PutStr s +||| Write a character to standard output. putChar : Handler StdIO e => Char -> { [STDIO] } Eff e ()-putChar c = PutCh c+putChar c = call $ PutCh c +||| Write a string to standard output, terminating with a newline. putStrLn : Handler StdIO e => String -> { [STDIO] } Eff e () putStrLn s = putStr (s ++ "\n") +||| Read a string from standard input. getStr : Handler StdIO e => { [STDIO] } Eff e String-getStr = GetStr+getStr = call $ GetStr +||| Read a character from standard input. getChar : Handler StdIO e => { [STDIO] } Eff e Char-getChar = GetCh+getChar = call $ GetCh
libs/effects/Effect/System.idr view
@@ -28,11 +28,11 @@ SYSTEM = MkEff () System  getArgs : Handler System e => { [SYSTEM] } Eff e (List String)-getArgs = Args+getArgs = call Args  time : Handler System e => { [SYSTEM] } Eff e Int-time = Time+time = call Time  getEnv : Handler System e => String -> { [SYSTEM] } Eff e (Maybe String)-getEnv s = GetEnv s+getEnv s = call $ GetEnv s
libs/effects/Effects.idr view
@@ -31,9 +31,9 @@   |||    ||| @ r The resource being handled.   ||| @ eff The effect to be applied.-  ||| @ ctxt The context in which to handle the effect.-  handle : (r : res) -> (eff : e t res resk) -> -           (ctxt : ((x : t) -> resk x -> m a)) -> m a+  ||| @ k The continuation to pass the result of the effect+  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) resourceType : EFFECT -> Type@@ -93,58 +93,13 @@ rebuildEnv : Env m ys' -> (prf : SubList ys xs) ->              Env m xs -> Env m (updateWith ys' xs prf) rebuildEnv []        SubNil      env = env+rebuildEnv (x :: xs) SubNil      env = x :: xs+rebuildEnv []        (Keep rest) (y :: 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 "subListId" `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-reflectDefaultList : List a -> Tactic-reflectDefaultList [] = Refine "enil" `Seq` Solve-reflectDefaultList (x :: xs)-     = Refine "econs" `Seq` -         (Solve `Seq`-           (Instance `Seq` -         (Refine "default" `Seq`-           (Solve `Seq`-             (Instance `Seq`-              (reflectDefaultList xs))))))-reflectDefaultList (x ++ y) = Refine "Nil" `Seq` Solve-reflectDefaultList _ = Refine "Nil" `Seq` Solve--%reflection-reflectEff : (P : Type) -> Tactic-reflectEff (EffElem m a xs)-     = reflectListEffElem xs `Seq` Solve-reflectEff (SubList xs ys)-     = reflectSubList ys `Seq` Solve-reflectEff (Env m xs)-     = reflectDefaultList xs `Seq` Solve+-- -------------------------------------------------- [ The Effect EDSL itself ]  updateResTy : (val : t) ->               (xs : List EFFECT) -> EffElem e a xs -> e t a b ->@@ -189,11 +144,11 @@                 Eff m a xs xs'      ebind    : Eff m a xs xs' ->                  ((val : a) -> Eff m b (xs' val) xs'') -> Eff m b xs xs''-     effect   : (prf : EffElem e a xs) ->+     callP    : (prf : EffElem e a xs) ->                 (eff : e t a b) ->                 Eff m t xs (\v => updateResTy v xs prf eff) -     lift     : (prf : SubList ys xs) ->+     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 -> @@ -211,6 +166,20 @@           ((val : a) -> Eff m b (xs' val) xs'') -> Eff m b xs xs'' (>>=) = ebind  +-- namespace SimpleBind+--   (>>=) : Eff m a xs (\v => xs) -> +--           ((val : a) -> Eff m b xs xs') -> Eff m b xs xs'+--   (>>=) = 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 = 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' = id+ return : a -> Eff m a xs (\v => xs) return x = value x @@ -249,8 +218,8 @@ 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 (effect prf effP) k = execEff env prf effP k-eff env (lift prf effP) 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@@ -267,7 +236,8 @@          eff env' prog (\p', envk => k p' (relabel l envk))  -- yuck :) Haven't got type class instances working nicely in tactic--- proofs yet, so just brute force it.+-- proofs yet, and 'search' can't be told about any hints yet,+-- so just brute force it. syntax MkDefaultEnv = with Env                        (| [], [default], [default, default],                           [default, default, default],@@ -277,21 +247,21 @@                           [default, default, default, default, default, default, default],                           [default, default, default, default, default, default, default, default] |) -implicit-lift' : Eff m t ys ys' ->-        {default tactics { byReflection reflectEff; }-           prf : SubList ys xs} ->-        Eff m t xs (\v => updateWith (ys' v) xs prf)-lift' e {prf} = lift prf e+call : {a, b: _} -> {e : Effect} ->+       (eff : e t a b) ->+       {default tactics { search 100; }+          prf : EffElem e a xs} ->+      Eff m t xs (\v => updateResTy v xs prf eff)+call e {prf} = callP prf e  implicit-effect' : {a, b: _} -> {e : Effect} ->-          (eff : e t a b) ->-          {default tactics { byReflection reflectEff; }-             prf : EffElem e a xs} ->-         Eff m t xs (\v => updateResTy v xs prf eff)-effect' e {prf} = effect prf e+lift : Eff m t ys ys' ->+       {default tactics { search 100; }+          prf : SubList ys xs} ->+       Eff m 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')) ->@@ -335,8 +305,8 @@ mapVE f (x :: xs) = [| f x :: mapVE f xs |]  -when : Applicative m => Bool -> ({xs} Eff m ()) -> {xs} Eff m ()-when True  e = e+when : Applicative m => Bool -> Lazy ({xs} Eff m ()) -> {xs} Eff m ()+when True  e = Force e when False e = pure ()  -- --------------------------------------------------------------------- [ EOF ]
− libs/javascript/JavaScript.idr 
@@ -1,104 +0,0 @@-module JavaScript--%access public--private-isUndefined : Ptr -> IO Bool-isUndefined p = do-  res <- mkForeign (-    FFun "%0 === undefined" [FPtr] FString) p-  if res == "false"-     then (return False)-     else (return True)------------------------------------------------------------------------------------- Events----------------------------------------------------------------------------------abstract-data Event : Type where-  MkEvent : Ptr -> Event------------------------------------------------------------------------------------- Elements----------------------------------------------------------------------------------abstract-data Element : Type where-  MkElem : Ptr -> Element--setText : Element -> String -> IO ()-setText (MkElem p) s =-  mkForeign (FFun "%0.textContent=%1" [FPtr, FString] FUnit) p s---setOnClick : Element -> (Event -> IO Bool) -> IO ()-setOnClick (MkElem e) f =-  mkForeign (-    FFun "%0['onclick']=%1" [ FPtr-                            , FFunction (FAny Event) (FAny (IO Bool))-                            ] FUnit) e f------------------------------------------------------------------------------------ Nodelists----------------------------------------------------------------------------------abstract-data NodeList : Type where-  MkNodeList : Ptr -> NodeList--elemAt : NodeList -> Nat -> IO (Maybe Element)-elemAt (MkNodeList p) i = do-  e <- mkForeign (FFun "%0.item(%1)" [FPtr, FInt] FPtr) p (-    prim__truncBigInt_Int (cast i)-  )-  d <- isUndefined e-  if d-     then return $ Just (MkElem e)-     else return Nothing------------------------------------------------------------------------------------- Intervals----------------------------------------------------------------------------------abstract-data Interval : Type where-  MkInterval : Ptr -> Interval--setInterval : (() -> IO ()) -> Float -> IO Interval-setInterval f t = do-  e <- mkForeign (-    FFun "setInterval(%0,%1)" [FFunction FUnit (FAny (IO ())), FFloat] FPtr-  ) f t-  return (MkInterval e)--clearInterval : Interval -> IO ()-clearInterval (MkInterval p) =-  mkForeign (FFun "clearInterval(%0)" [FPtr] FUnit) p------------------------------------------------------------------------------------- Timeouts----------------------------------------------------------------------------------data Timeout : Type where-  MkTimeout : Ptr -> Timeout--setTimeout : (() -> IO ()) -> Float -> IO Timeout-setTimeout f t = do-  e <- mkForeign (-    FFun "setTimeout(%0,%1)" [FFunction FUnit (FAny (IO ())), FFloat] FPtr-  ) f t-  return (MkTimeout e)--clearTimeout : Timeout -> IO ()-clearTimeout (MkTimeout p) =-  mkForeign (FFun "clearTimeout(%0)" [FPtr] FUnit) p------------------------------------------------------------------------------------- Basic IO----------------------------------------------------------------------------------alert : String -> IO ()-alert msg =-  mkForeign (FFun "alert(%0)" [FString] FUnit) msg------------------------------------------------------------------------------------- DOM----------------------------------------------------------------------------------query : String -> IO NodeList-query q = do-  e <- mkForeign (FFun "document.querySelectorAll(%0)" [FString] FPtr) q-  return (MkNodeList e)
− libs/javascript/JavaScript/JSON.idr 
@@ -1,44 +0,0 @@-module JSON--import Data.SortedMap--data JSONType : Type where-  JSONArray  : (n : Nat) -> Vect n JSONType -> JSONType-  JSONString : JSONType-  JSONNumber : JSONType-  JSONBool   : JSONType-  JSONObject : SortedMap String JSONType -> JSONType-  JSONNull   : JSONType--mutual-  using (ts : Vect n JSONType, fs : SortedMap String JSONType)-    namespace JArray-      data JArray : (n : Nat) -> Vect n JSONType -> Type where-        Nil  : JArray 0 []-        (::) : JSON t -> JArray n ts -> JArray (S n) (t :: ts)--    namespace JObject-      data JObject : SortedMap String JSONType -> Type where-        Nil  : JObject empty-        (::) : (f : (String, JSON t)) ->-               JObject fs ->-               JObject (insert (fst f) t fs)--    data JSON : JSONType -> Type where-      JSString : String -> JSON JSONString-      JSNumber : Float -> JSON JSONNumber-      JSBool   : Bool -> JSON JSONBool-      JSNull   : JSON JSONNull-      JSArray  : JArray n ts -> JSON (JSONArray n ts)-      JSObject : JObject fs -> JSON (JSONObject fs)--index : (i : Fin n) -> JSON (JSONArray n ts) -> JSON (index i ts)-index fZ     (JSArray (x :: xs)) = x-index (fS i) (JSArray (x :: xs)) = index i (JSArray xs)--(++) : JSON (JSONArray m ts1) ->-       JSON (JSONArray n ts2) ->-       JSON (JSONArray (m + n) (ts1 ++ ts2))-(++) (JSArray [])        ys = ys-(++) (JSArray (x :: xs)) ys with ((JSArray xs) ++ ys)-   | (JSArray as) = JSArray (x :: as)
− libs/javascript/Makefile 
@@ -1,14 +0,0 @@-IDRIS := idris--build:-	$(IDRIS) --build javascript.ipkg--install:-	$(IDRIS) --install javascript.ipkg--clean:-	$(IDRIS) --clean javascript.ipkg--rebuild: clean build--.PHONY: build install clean rebuild
− libs/javascript/javascript.ipkg 
@@ -1,5 +0,0 @@-package javascript--opts    = "--nobasepkgs -i ../prelude -i ../base"-modules = JavaScript, JavaScript.JSON-
libs/oldeffects/Effects.idr view
@@ -303,6 +303,6 @@ mapE f []        = pure [] mapE f (x :: xs) = [| f x :: mapE f xs |] -when : Applicative m => Bool -> Eff m xs () -> Eff m xs ()+when : Applicative m => Bool -> Lazy (Eff m xs ()) -> Eff m xs () when True  e = e when False e = pure ()
libs/prelude/Builtins.idr view
@@ -17,6 +17,7 @@ getProof : {P : a -> Type} -> (s : Exists a P) -> P (getWitness s) getProof (a ** v) = v +||| The eliminator for the empty type. FalseElim : _|_ -> a  ||| For 'symbol syntax. 'foo becomes Symbol_ "foo"@@ -34,26 +35,39 @@ sym refl = refl  ||| Transitivity of propositional equality-trans : {a:x} -> {b:x} -> {c:x} -> a = b -> b = c -> a = c+trans : {a:x} -> {b:y} -> {c:z} -> a = b -> b = c -> a = c trans refl refl = refl -lazy : a -> a-lazy x = x -- compiled specially--force : a -> a-force x = x -- compiled specially-+||| There are two types of laziness: that arising from lazy functions, and that+||| arising from codata. They differ in their totality condition. data LazyType = LazyCodata | LazyEval +||| The underlying implementation of Lazy and Inf.+%error_reverse data Lazy' : LazyType -> Type -> Type where+     ||| A delayed computation.+     |||+     |||Delay is inserted automatically by the elaborator where necessary.+     |||+     ||| Note that compiled code gives `Delay` special semantics.+     ||| @ t   whether this is laziness from codata or normal lazy evaluation+     ||| @ a   the type of the eventual value+     ||| @ val a computation that will produce a value      Delay : {t, a : _} -> (val : a) -> Lazy' t a +||| Compute a value from a delayed computation.+|||+||| Inserted by the elaborator where necessary. Force : {t, a : _} -> Lazy' t a -> a Force (Delay x) = x +||| Lazily evaluated values. This has special evaluation semantics. Lazy : Type -> Type Lazy t = Lazy' LazyEval t +||| Recursive parameters to codata. Inserted automatically by the elaborator+||| on a "codata" definition but is necessary by hand if mixing inductive and+||| coinductive parameters. Inf : Type -> Type Inf t = Lazy' LazyCodata t @@ -71,7 +85,7 @@ ||| x (which is typically a pattern argument) ||| @ x the larger value (typically a pattern argument) ||| @ y the smaller value (typically an argument to a recursive call)-assert_smaller : (x, y : a) -> a+assert_smaller : (x : a) -> (y : b) -> b assert_smaller x y = y  ||| Assert to the totality checker than the given expression will always
libs/prelude/Decidable/Equality.idr view
@@ -176,11 +176,21 @@  instance DecEq a => DecEq (Vect n a) where   decEq [] [] = Yes refl+  decEq (x :: xs) (y :: ys) with (decEq x y)+    decEq (x :: xs) (x :: ys)   | Yes refl with (decEq xs ys)+      decEq (x :: xs) (x :: xs) | Yes refl | Yes refl = Yes refl+      decEq (x :: xs) (x :: ys) | Yes refl | No  neq  = No (neq . vectInjective2)+    decEq (x :: xs) (y :: ys)   | No  neq             = No (neq . vectInjective1)++{- The following definition is elaborated in a wrong case-tree. Examination pending.++instance DecEq a => DecEq (Vect n a) where+  decEq [] [] = Yes refl   decEq (x :: xs) (y :: ys) with (decEq x y, decEq xs ys)     decEq (x :: xs) (x :: xs) | (Yes refl, Yes refl) = Yes refl     decEq (x :: xs) (y :: ys) | (_, No nEqTl) = No (\p => nEqTl (vectInjective2 p))     decEq (x :: xs) (y :: ys) | (No nEqHd, _) = No (\p => nEqHd (vectInjective1 p))-    +-}  -- For the primitives, we have to cheat because we don't have access to their -- internal implementations.
libs/prelude/IO.idr view
@@ -132,16 +132,13 @@ io_return x = MkIO (\w => prim_io_return x)  liftPrimIO : (World -> PrimIO a) -> IO a-liftPrimIO f = MkIO (\w => prim_io_bind (f w)-                         (\x => prim_io_return x))+liftPrimIO = MkIO  run__IO : IO () -> PrimIO ()-run__IO (MkIO f) = prim_io_bind (f TheWorld)-                        (\ b => prim_io_return b)+run__IO (MkIO f) = f TheWorld  run__provider : IO a -> PrimIO a-run__provider (MkIO f) = prim_io_bind (f TheWorld)-                            (\ b => prim_io_return b)+run__provider (MkIO f) = f TheWorld  -- io_bind v (\v' => io_return v')
libs/prelude/Prelude.idr view
@@ -347,27 +347,38 @@   where go Z = []         go (S n) = n :: go n +-- predefine Nat versions of Enum, so we can use them in the default impls+total natEnumFromThen : Nat -> Nat -> Stream Nat+natEnumFromThen n inc = n :: natEnumFromThen (inc + n) inc+total natEnumFromTo : Nat -> Nat -> List Nat+natEnumFromTo n m = map (plus n) (natRange ((S m) - n))+total natEnumFromThenTo : Nat -> Nat -> Nat -> List Nat+natEnumFromThenTo _ Z   _ = []+natEnumFromThenTo n inc m = map (plus n . (* inc)) (natRange (S ((m - n) `div` inc)))+ class Enum a where   total pred : a -> a   total succ : a -> a+  succ e = fromNat (S (toNat e))   total toNat : a -> Nat   total fromNat : Nat -> a   total enumFrom : a -> Stream a   enumFrom n = n :: enumFrom (succ n)   total enumFromThen : a -> a -> Stream a+  enumFromThen x y = map fromNat (natEnumFromThen (toNat x) (toNat y))   total enumFromTo : a -> a -> List a+  enumFromTo x y = map fromNat (natEnumFromTo (toNat x) (toNat y))   total enumFromThenTo : a -> a -> a -> List a-+  enumFromThenTo x1 x2 y = map fromNat (natEnumFromThenTo (toNat x1) (toNat x2) (toNat y))  instance Enum Nat where-  pred = Nat.pred-  succ = S-  toNat = id-  fromNat = id-  enumFromThen n inc = n :: enumFromThen (fromNat (plus (toNat inc) (toNat n))) inc-  enumFromThenTo _ Z   _ = []-  enumFromThenTo n inc m = map (plus n . (* inc)) (natRange (S ((m - n) `div` inc)))-  enumFromTo n m = map (plus n) (natRange ((S m) - n))+  pred n = Nat.pred n+  succ n = S n+  toNat x = id x+  fromNat x = id x+  enumFromThen x y = natEnumFromThen x y+  enumFromThenTo x y z = natEnumFromThenTo x y z+  enumFromTo x y = natEnumFromTo x y  instance Enum Integer where   pred n = n - 1@@ -407,14 +418,25 @@           go [] = []           go (x :: xs) = n + (cast x * inc) :: go xs +instance Enum (Fin (S n)) where+  pred fZ = fZ+  pred (fS n) = weaken n+  succ n = case strengthen (fS n) of+    Left _ => last+    Right k => k+  toNat n = cast n+  fromNat {n=n} m = case natToFin m (S n) of+    Just k => k+    Nothing => last+ syntax "[" [start] ".." [end] "]"      = enumFromTo start end syntax "[" [start] "," [next] ".." [end] "]"      = enumFromThenTo start (next - start) end -syntax "[" [start] "..]"+syntax "[" [start] ".." "]"      = enumFrom start-syntax "[" [start] "," [next] "..]"+syntax "[" [start] "," [next] ".." "]"      = enumFromThen start (next - start)  ---- More utilities@@ -478,6 +500,14 @@ partial stdin : File stdin = FHandle prim__stdin +||| Standard output+partial stdout : File+stdout = FHandle prim__stdout++||| Standard output+partial stderr : File+stderr = FHandle prim__stderr+ ||| Call the RTS's file opening function do_fopen : String -> String -> IO Ptr do_fopen f m@@ -519,9 +549,9 @@ fgetc (FHandle h) = return (cast !(mkForeign (FFun "fgetc" [FPtr] FInt) h))  fgetc' : File -> IO (Maybe Char)-fgetc' (FHandle h) +fgetc' (FHandle h)    = do x <- mkForeign (FFun "fgetc" [FPtr] FInt) h-        if (x < 0) then return Nothing +        if (x < 0) then return Nothing                    else return (Just (cast x))  fflush : File -> IO ()@@ -620,4 +650,3 @@           if not x then do l <- fread h                            readFile' h (contents ++ l)                    else return contents-
libs/prelude/Prelude/Algebra.idr view
@@ -13,238 +13,253 @@ -- A modest class hierarchy -------------------------------------------------------------------------------- --- Sets equipped with a single binary operation that is associative.  Must--- satisfy the following laws:---   Associativity of <+>:---     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c+||| Sets equipped with a single binary operation that is associative.  Must+||| satisfy the following laws:+|||+||| + Associativity of `<+>`:+|||     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c class Semigroup a where   (<+>) : a -> a -> a  class Semigroup a => VerifiedSemigroup a where-  semigroupOpIsAssociative : (l, c, r : a) -> l <+> (c <+> r) = (l <+> c) <+> r+  total semigroupOpIsAssociative : (l, c, r : a) -> l <+> (c <+> r) = (l <+> c) <+> r --- Sets equipped with a single binary operation that is associative, along with--- a neutral element for that binary operation.  Must satisfy the following--- laws:---   Associativity of <+>:---     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c---   Neutral for <+>:---     forall a,     a <+> neutral   == a---     forall a,     neutral <+> a   == a+||| Sets equipped with a single binary operation that is associative, along with+||| a neutral element for that binary operation.  Must satisfy the following+||| laws:+|||+||| + Associativity of `<+>`:+|||     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c+||| + Neutral for `<+>`:+|||     forall a,     a <+> neutral   == a+|||     forall a,     neutral <+> a   == a class Semigroup a => Monoid a where   neutral : a  class (VerifiedSemigroup a, Monoid a) => VerifiedMonoid a where-  monoidNeutralIsNeutralL : (l : a) -> l <+> neutral = l-  monoidNeutralIsNeutralR : (r : a) -> neutral <+> r = r+  total monoidNeutralIsNeutralL : (l : a) -> l <+> neutral = l+  total monoidNeutralIsNeutralR : (r : a) -> neutral <+> r = r --- Sets equipped with a single binary operation that is associative, along with--- a neutral element for that binary operation and inverses for all elements.--- Must satisfy the following laws:---   Associativity of <+>:---     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c---   Neutral for <+>:---     forall a,     a <+> neutral   == a---     forall a,     neutral <+> a   == a---   Inverse for <+>:---     forall a,     a <+> inverse a == neutral---     forall a,     inverse a <+> a == neutral+||| Sets equipped with a single binary operation that is associative, along with+||| a neutral element for that binary operation and inverses for all elements.+||| Must satisfy the following laws:+||| + Associativity of `<+>`:+|||     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c+||| + Neutral for `<+>`:+|||     forall a,     a <+> neutral   == a+|||     forall a,     neutral <+> a   == a+||| + Inverse for `<+>`:+|||     forall a,     a <+> inverse a == neutral+|||     forall a,     inverse a <+> a == neutral class Monoid a => Group a where   inverse : a -> a  class (VerifiedMonoid a, Group a) => VerifiedGroup a where-  groupInverseIsInverseL : (l : a) -> l <+> inverse l = neutral-  groupInverseIsInverseR : (r : a) -> inverse r <+> r = neutral+  total groupInverseIsInverseL : (l : a) -> l <+> inverse l = neutral+  total groupInverseIsInverseR : (r : a) -> inverse r <+> r = neutral  (<->) : Group a => a -> a -> a (<->) left right = left <+> (inverse right) --- Sets equipped with a single binary operation that is associative and--- commutative, along with a neutral element for that binary operation and--- inverses for all elements. Must satisfy the following laws:---   Associativity of <+>:---     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c---   Commutativity of <+>:---     forall a b,   a <+> b         == b <+> a---   Neutral for <+>:---     forall a,     a <+> neutral   == a---     forall a,     neutral <+> a   == a---   Inverse for <+>:---     forall a,     a <+> inverse a == neutral---     forall a,     inverse a <+> a == neutral+||| Sets equipped with a single binary operation that is associative and+||| commutative, along with a neutral element for that binary operation and+||| inverses for all elements. Must satisfy the following laws:+|||+||| + Associativity of `<+>`:+|||     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c+||| + Commutativity of `<+>`:+|||     forall a b,   a <+> b         == b <+> a+||| + Neutral for `<+>`:+|||     forall a,     a <+> neutral   == a+|||     forall a,     neutral <+> a   == a+||| + Inverse for `<+>`:+|||     forall a,     a <+> inverse a == neutral+|||     forall a,     inverse a <+> a == neutral class Group a => AbelianGroup a where { }  class (VerifiedGroup a, AbelianGroup a) => VerifiedAbelianGroup a where-  abelianGroupOpIsCommutative : (l, r : a) -> l <+> r = r <+> l+  total abelianGroupOpIsCommutative : (l, r : a) -> l <+> r = r <+> l --- Sets equipped with two binary operations, one associative and commutative--- supplied with a neutral element, and the other associative, with--- distributivity laws relating the two operations.  Must satisfy the following--- laws:---   Associativity of <+>:---     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c---   Commutativity of <+>:---     forall a b,   a <+> b         == b <+> a---   Neutral for <+>:---     forall a,     a <+> neutral   == a---     forall a,     neutral <+> a   == a---   Inverse for <+>:---     forall a,     a <+> inverse a == neutral---     forall a,     inverse a <+> a == neutral---   Associativity of <*>:---     forall a b c, a <*> (b <*> c) == (a <*> b) <*> c---   Distributivity of <*> and <->:---     forall a b c, a <*> (b <+> c) == (a <*> b) <+> (a <*> c)---     forall a b c, (a <+> b) <*> c == (a <*> c) <+> (b <*> c)+||| Sets equipped with two binary operations, one associative and commutative+||| supplied with a neutral element, and the other associative, with+||| distributivity laws relating the two operations.  Must satisfy the following+||| laws:+|||+||| + Associativity of `<+>`:+|||     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c+||| + Commutativity of `<+>`:+|||     forall a b,   a <+> b         == b <+> a+||| + Neutral for `<+>`:+|||     forall a,     a <+> neutral   == a+|||     forall a,     neutral <+> a   == a+||| + Inverse for `<+>`:+|||     forall a,     a <+> inverse a == neutral+|||     forall a,     inverse a <+> a == neutral+||| + Associativity of `<*>`:+|||     forall a b c, a <*> (b <*> c) == (a <*> b) <*> c+||| + Distributivity of `<*>` and `<->`:+|||     forall a b c, a <*> (b <+> c) == (a <*> b) <+> (a <*> c)+|||     forall a b c, (a <+> b) <*> c == (a <*> c) <+> (b <*> c) class AbelianGroup a => Ring a where   (<*>) : a -> a -> a  class (VerifiedAbelianGroup a, Ring a) => VerifiedRing a where-  ringOpIsAssociative   : (l, c, r : a) -> l <*> (c <*> r) = (l <*> c) <*> r-  ringOpIsDistributiveL : (l, c, r : a) -> l <*> (c <+> r) = (l <*> c) <+> (l <*> r)-  ringOpIsDistributiveR : (l, c, r : a) -> (l <+> c) <*> r = (l <*> r) <+> (l <*> c)+  total ringOpIsAssociative   : (l, c, r : a) -> l <*> (c <*> r) = (l <*> c) <*> r+  total ringOpIsDistributiveL : (l, c, r : a) -> l <*> (c <+> r) = (l <*> c) <+> (l <*> r)+  total ringOpIsDistributiveR : (l, c, r : a) -> (l <+> c) <*> r = (l <*> r) <+> (l <*> c) --- Sets equipped with two binary operations, one associative and commutative--- supplied with a neutral element, and the other associative supplied with a--- neutral element, with distributivity laws relating the two operations.  Must--- satisfy the following laws:---   Associativity of <+>:---     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c---   Commutativity of <+>:---     forall a b,   a <+> b         == b <+> a---   Neutral for <+>:---     forall a,     a <+> neutral   == a---     forall a,     neutral <+> a   == a---   Inverse for <+>:---     forall a,     a <+> inverse a == neutral---     forall a,     inverse a <+> a == neutral---   Associativity of <*>:---     forall a b c, a <*> (b <*> c) == (a <*> b) <*> c---   Neutral for <*>:---     forall a,     a <*> unity     == a---     forall a,     unity <*> a     == a---   Distributivity of <*> and <->:---     forall a b c, a <*> (b <+> c) == (a <*> b) <+> (a <*> c)---     forall a b c, (a <+> b) <*> c == (a <*> c) <+> (b <*> c)+||| Sets equipped with two binary operations, one associative and commutative+||| supplied with a neutral element, and the other associative supplied with a+||| neutral element, with distributivity laws relating the two operations.  Must+||| satisfy the following laws:+|||+||| +  Associativity of `<+>`:+|||     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c+||| + Commutativity of `<+>`:+|||     forall a b,   a <+> b         == b <+> a+||| + Neutral for `<+>`:+|||     forall a,     a <+> neutral   == a+|||     forall a,     neutral <+> a   == a+||| + Inverse for `<+>`:+|||     forall a,     a <+> inverse a == neutral+|||     forall a,     inverse a <+> a == neutral+||| + Associativity of `<*>a:+|||     forall a b c, a <*> (b <*> c) == (a <*> b) <*> c+||| + Neutral for `<*>`:+|||     forall a,     a <*> unity     == a+|||     forall a,     unity <*> a     == a+||| + Distributivity of `<*>` and `<->`:+|||     forall a b c, a <*> (b <+> c) == (a <*> b) <+> (a <*> c)+|||     forall a b c, (a <+> b) <*> c == (a <*> c) <+> (b <*> c) class Ring a => RingWithUnity a where   unity : a  class (VerifiedRing a, RingWithUnity a) => VerifiedRingWithUnity a where-  ringWithUnityIsUnityL : (l : a) -> l <*> unity = l-  ringWithUnityIsUnityR : (r : a) -> unity <*> r = r+  total ringWithUnityIsUnityL : (l : a) -> l <*> unity = l+  total ringWithUnityIsUnityR : (r : a) -> unity <*> r = r --- Sets equipped with a binary operation that is commutative, associative and--- idempotent.  Must satisfy the following laws:---   Associativity of join:---     forall a b c, join a (join b c) == join (join a b) c---   Commutativity of join:---     forall a b,   join a b          == join b a---   Idempotency of join:---     forall a,     join a a          == a---  Join semilattices capture the notion of sets with a "least upper bound".+||| Sets equipped with a binary operation that is commutative, associative and+||| idempotent.  Must satisfy the following laws:+|||+||| + Associativity of join:+|||     forall a b c, join a (join b c) == join (join a b) c+||| + Commutativity of join:+|||     forall a b,   join a b          == join b a+||| + Idempotency of join:+|||     forall a,     join a a          == a+|||+||| Join semilattices capture the notion of sets with a "least upper bound". class JoinSemilattice a where   join : a -> a -> a  class JoinSemilattice a => VerifiedJoinSemilattice a where-  joinSemilatticeJoinIsAssociative : (l, c, r : a) -> join l (join c r) = join (join l c) r-  joinSemilatticeJoinIsCommutative : (l, r : a)    -> join l r = join r l-  joinSemilatticeJoinIsIdempotent  : (e : a)       -> join e e = e+  total joinSemilatticeJoinIsAssociative : (l, c, r : a) -> join l (join c r) = join (join l c) r+  total joinSemilatticeJoinIsCommutative : (l, r : a)    -> join l r = join r l+  total joinSemilatticeJoinIsIdempotent  : (e : a)       -> join e e = e --- Sets equipped with a binary operation that is commutative, associative and--- idempotent.  Must satisfy the following laws:---   Associativity of meet:---     forall a b c, meet a (meet b c) == meet (meet a b) c---   Commutativity of meet:---     forall a b,   meet a b          == meet b a---   Idempotency of meet:---     forall a,     meet a a          == a---  Meet semilattices capture the notion of sets with a "greatest lower bound".+||| Sets equipped with a binary operation that is commutative, associative and+||| idempotent.  Must satisfy the following laws:+|||+||| + Associativity of meet:+|||     forall a b c, meet a (meet b c) == meet (meet a b) c+||| + Commutativity of meet:+|||     forall a b,   meet a b          == meet b a+||| + Idempotency of meet:+|||     forall a,     meet a a          == a+|||+||| Meet semilattices capture the notion of sets with a "greatest lower bound". class MeetSemilattice a where   meet : a -> a -> a  class MeetSemilattice a => VerifiedMeetSemilattice a where-  meetSemilatticeMeetIsAssociative : (l, c, r : a) -> meet l (meet c r) = meet (meet l c) r-  meetSemilatticeMeetIsCommutative : (l, r : a)    -> meet l r = meet r l-  meetSemilatticeMeetIsIdempotent  : (e : a)       -> meet e e = e+  total meetSemilatticeMeetIsAssociative : (l, c, r : a) -> meet l (meet c r) = meet (meet l c) r+  total meetSemilatticeMeetIsCommutative : (l, r : a)    -> meet l r = meet r l+  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--- laws:---   Associativity of join:---     forall a b c, join a (join b c) == join (join a b) c---   Commutativity of join:---     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---  Join semilattices capture the notion of sets with a "least upper bound"---  equipped with a "bottom" element.+||| Sets equipped with a binary operation that is commutative, associative and+||| idempotent and supplied with a neutral element.  Must satisfy the following+||| laws:+|||+||| + Associativity of join:+|||     forall a b c, join a (join b c) == join (join a b) c+||| + Commutativity of join:+|||     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+|||+|||  Join semilattices capture the notion of sets with a "least upper bound"+|||  equipped with a "bottom" element. class JoinSemilattice a => BoundedJoinSemilattice a where   bottom  : a  class (VerifiedJoinSemilattice a, BoundedJoinSemilattice a) => VerifiedBoundedJoinSemilattice a where-  boundedJoinSemilatticeBottomIsBottom : (e : a) -> join e bottom = bottom+  total boundedJoinSemilatticeBottomIsBottom : (e : a) -> join e bottom = bottom --- Sets equipped with a binary operation that is commutative, associative and--- idempotent and supplied with a neutral element.  Must satisfy the following--- laws:---   Associativity of meet:---     forall a b c, meet a (meet b c) == meet (meet a b) c---   Commutativity of meet:---     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---  Meet semilattices capture the notion of sets with a "greatest lower bound"---  equipped with a "top" element.+||| Sets equipped with a binary operation that is commutative, associative and+||| idempotent and supplied with a neutral element.  Must satisfy the following+||| laws:+|||+||| + Associativity of meet:+|||     forall a b c, meet a (meet b c) == meet (meet a b) c+||| + Commutativity of meet:+|||     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+|||+||| Meet semilattices capture the notion of sets with a "greatest lower bound"+||| equipped with a "top" element. class MeetSemilattice a => BoundedMeetSemilattice a where   top : a  class (VerifiedMeetSemilattice a, BoundedMeetSemilattice a) => VerifiedBoundedMeetSemilattice a where-  boundedMeetSemilatticeTopIsTop : (e : a) -> meet e top = top+  total boundedMeetSemilatticeTopIsTop : (e : a) -> meet e top = top --- Sets equipped with two binary operations that are both commutative,--- associative and idempotent, along with absorbtion laws for relating the two--- binary operations.  Must satisfy the following:---   Associativity of meet and join:---     forall a b c, meet a (meet b c) == meet (meet a b) c---     forall a b c, join a (join b c) == join (join a b) c---   Commutativity of meet and join:---     forall a b,   meet a b          == meet b a---     forall a b,   join a b          == join b a---   Idempotency of meet and join:---     forall a,     meet a a          == a---     forall a,     join a a          == a---   Absorbtion laws for meet and join:---     forall a b,   meet a (join a b) == a---     forall a b,   join a (meet a b) == a+||| Sets equipped with two binary operations that are both commutative,+||| associative and idempotent, along with absorbtion laws for relating the two+||| binary operations.  Must satisfy the following:+|||+||| + Associativity of meet and join:+|||     forall a b c, meet a (meet b c) == meet (meet a b) c+|||     forall a b c, join a (join b c) == join (join a b) c+||| + Commutativity of meet and join:+|||     forall a b,   meet a b          == meet b a+|||     forall a b,   join a b          == join b a+||| + Idempotency of meet and join:+|||     forall a,     meet a a          == a+|||     forall a,     join a a          == a+||| + Absorbtion laws for meet and join:+|||     forall a b,   meet a (join a b) == a+|||     forall a b,   join a (meet a b) == a class (JoinSemilattice a, MeetSemilattice a) => Lattice a where { }  class (VerifiedJoinSemilattice a, VerifiedMeetSemilattice a) => VerifiedLattice a where-  latticeMeetAbsorbsJoin : (l, r : a) -> meet l (join l r) = l-  latticeJoinAbsorbsMeet : (l, r : a) -> join l (meet l r) = l+  total latticeMeetAbsorbsJoin : (l, r : a) -> meet l (join l r) = l+  total latticeJoinAbsorbsMeet : (l, r : a) -> join l (meet l r) = l --- Sets equipped with two binary operations that are both commutative,--- associative and idempotent and supplied with neutral elements, along with--- absorbtion laws for relating the two binary operations.  Must satisfy the--- following:---   Associativity of meet and join:---     forall a b c, meet a (meet b c) == meet (meet a b) c---     forall a b c, join a (join b c) == join (join a b) c---   Commutativity of meet and join:---     forall a b,   meet a b          == meet b a---     forall a b,   join a b          == join b a---   Idempotency of meet and join:---     forall a,     meet a a          == a---     forall a,     join a a          == a---   Absorbtion laws for meet and join:---     forall a b,   meet a (join a b) == a---     forall a b,   join a (meet a b) == a---   Neutral for meet and join:---     forall a,     meet a top        == top---     forall a,     join a bottom     == bottom+||| Sets equipped with two binary operations that are both commutative,+||| associative and idempotent and supplied with neutral elements, along with+||| absorbtion laws for relating the two binary operations.  Must satisfy the+||| following:+|||+||| + Associativity of meet and join:+|||     forall a b c, meet a (meet b c) == meet (meet a b) c+|||     forall a b c, join a (join b c) == join (join a b) c+||| +  Commutativity of meet and join:+|||     forall a b,   meet a b          == meet b a+|||     forall a b,   join a b          == join b a+||| + Idempotency of meet and join:+|||     forall a,     meet a a          == a+|||     forall a,     join a a          == a+||| + Absorbtion laws for meet and join:+|||     forall a b,   meet a (join a b) == a+|||     forall a b,   join a (meet a b) == a+||| + Neutral for meet and join:+|||     forall a,     meet a top        == top+|||     forall a,     join a bottom     == bottom class (BoundedJoinSemilattice a, BoundedMeetSemilattice a) => BoundedLattice a where { }  class (VerifiedBoundedJoinSemilattice a, VerifiedBoundedMeetSemilattice a, VerifiedLattice a) => VerifiedBoundedLattice a where { }
libs/prelude/Prelude/Applicative.idr view
@@ -38,8 +38,11 @@     empty : f a     (<|>) : f a -> f a -> f a +||| `guard a` is `pure ()` if `a` is `True` and `empty` if `a` is `False` guard : Alternative f => Bool -> f () guard a = if a then pure () else empty -when : Applicative f => Bool -> f () -> f ()-when a f = if a then f else pure ()+||| Conditionally execute an applicative expression+when : Applicative f => Bool -> Lazy (f ()) -> f ()+when True f = Force f+when False f = pure ()
libs/prelude/Prelude/Bool.idr view
@@ -2,6 +2,8 @@  import Builtins +import Prelude.Uninhabited+ ||| Boolean Data Type data Bool = False | True @@ -13,22 +15,33 @@ boolElim True  t e = t boolElim False t e = e -||| Defines a predicate on Bool which guarantees that the value is true.+||| Ensure that some run-time Boolean test has been performed.+|||+||| This lifts a Boolean predicate to the type level. See the function `choose`+||| if you need to perform a Boolean test and convince the type checker of this+||| fact.+|||+||| If you find yourself using `so` for something other than primitive types,+||| it may be appropriate to define a type of evidence for the property that you+||| care about instead. data so : Bool -> Type where oh : so True +instance Uninhabited (so False) where+  uninhabited oh impossible+ -- Syntactic sugar for boolean elimination. syntax if [test] then [t] else [e] = boolElim test (Delay t) (Delay e)  -- Boolean Operator Precedence infixl 4 &&, || -||| Boolean OR-(||) : Bool -> Bool -> Bool+||| Boolean OR only evaluates the second argument if the first is `False`.+(||) : Bool -> Lazy Bool -> Bool (||) False x = x (||) True _  = True -||| Boolean AND-(&&) : Bool -> Bool -> Bool+||| Boolean AND only evaluates the second argument if the first is `True`.+(&&) : Bool -> Lazy Bool -> Bool (&&) True x  = x (&&) False _ = False
libs/prelude/Prelude/Cast.idr view
@@ -1,7 +1,11 @@ module Prelude.Cast +||| Type class for transforming a instance of a data type to another type. class Cast from to where-    cast : from -> to+    ||| Perform a cast operation.+    |||+    ||| @orig The original type.+    cast : (orig : from) -> to  -- String casts @@ -45,5 +49,3 @@  instance Cast Char Int where     cast = prim__charToInt--
libs/prelude/Prelude/Classes.idr view
@@ -244,13 +244,19 @@  -- ------------------------------------------------------------- [ Bounded ] -class MinBound b where+class Ord b => MinBound b where   ||| The lower bound for the type   minBound : b -class MaxBound b where+class Ord b => MaxBound b where   ||| The upper bound for the type   maxBound : b++instance MinBound Bits8 where+  minBound = 0x0++instance MaxBound Bits8 where+  maxBound = 0xff  instance MinBound Bits16 where   minBound = 0x0
libs/prelude/Prelude/Either.idr view
@@ -39,9 +39,9 @@ ||| @ f the action to take on Left ||| @ g the action to take on Right ||| @ e the sum to analyze-either : (f : a -> c) -> (g : b -> c) -> (e : Either a b) -> c-either l r (Left x)  = l x-either l r (Right x) = r x+either : (f : Lazy (a -> c)) -> (g : Lazy (b -> c)) -> (e : Either a b) -> c+either l r (Left x)  = (Force l) x+either l r (Right x) = (Force r) x  ||| Keep the payloads of all Left constructors in a list of Eithers lefts : List (Either a b) -> List a@@ -74,7 +74,7 @@  ||| Convert a Maybe to an Either by using a default value in case of Nothing ||| @ e the default value-maybeToEither : (def : e) -> Maybe a -> Either e a+maybeToEither : (def : Lazy e) -> Maybe a -> Either e a maybeToEither def (Just j) = Right j maybeToEither def Nothing  = Left  def
libs/prelude/Prelude/Fin.idr view
@@ -6,7 +6,10 @@  %default total -||| Numbers strictly less than some bound.  The name comes from "finite sets"+||| Numbers strictly less than some bound.  The name comes from "finite sets".+|||+||| It's probably not a good idea to use `Fin` for arithmetic, and they will be+||| exceedingly inefficient at run time. ||| @ n the upper bound data Fin : (n : Nat) -> Type where     fZ : Fin (S k)@@ -24,16 +27,19 @@     (==) (fS k) (fS k') = k == k'     (==) _ _ = False +||| There are no elements of `Fin Z` FinZAbsurd : Fin Z -> _|_ FinZAbsurd fZ impossible  FinZElim : Fin Z -> a FinZElim x = FalseElim (FinZAbsurd x) +||| Convert a Fin to a Nat finToNat : Fin n -> Nat finToNat fZ = Z finToNat (fS k) = S (finToNat k) +||| `finToNat` is injective finToNatInjective : (fm : Fin k) -> (fn : Fin k) -> (finToNat fm) = (finToNat fn) -> fm = fn finToNatInjective fZ     fZ     refl = refl finToNatInjective (fS m) fZ     refl impossible@@ -44,6 +50,7 @@ instance Cast (Fin n) Nat where     cast x = finToNat x +||| Convert a Fin to an Integer finToInteger : Fin n -> Integer finToInteger fZ     = 0 finToInteger (fS k) = 1 + finToInteger k@@ -85,7 +92,12 @@ total fSinjective : {f : Fin n} -> {f' : Fin n} -> (fS f = fS f') -> f = f' fSinjective refl = refl -+instance Ord (Fin n) where+  compare  fZ     fZ    = EQ+  compare  fZ    (fS _) = LT+  compare (fS _)  fZ    = GT+  compare (fS x) (fS y) = compare x y+   instance MinBound (Fin (S n)) where   minBound = fZ @@ -123,9 +135,13 @@ integerToFin : Integer -> (n : Nat) -> Maybe (Fin n) integerToFin x n = if x >= 0 then natToFin (cast x) n else Nothing +||| Proof that some `Maybe` is actually `Just` data IsJust : Maybe a -> Type where   ItIsJust : IsJust {a} (Just x) +||| Allow overloading of Integer literals for Fin.+||| @ x the Integer that the user typed+||| @ prf an automatically-constructed proof that `x` is in bounds fromInteger : (x : Integer) ->               {default ItIsJust                prf : (IsJust (integerToFin x n))} ->
libs/prelude/Prelude/Foldable.idr view
@@ -10,31 +10,47 @@  class Foldable (t : Type -> Type) where   foldr : (elt -> acc -> acc) -> acc -> t elt -> acc--foldl : Foldable t => (acc -> elt -> acc) -> acc -> t elt -> acc-foldl f z t = foldr (flip (.) . flip f) id t z+  foldl : Foldable t => (acc -> elt -> acc) -> acc -> t elt -> acc+  foldl f z t = foldr (flip (.) . flip f) id t z +||| Combine each element of a structure into a monoid concat : (Foldable t, Monoid a) => t a -> a concat = foldr (<+>) neutral +||| Combine into a monoid the collective results of applying a function+||| to each element of a structure concatMap : (Foldable t, Monoid m) => (a -> m) -> t a -> m concatMap f = foldr ((<+>) . f) neutral -and : Foldable t => t Bool -> Bool-and = foldr (&&) True+||| The conjunction of all elements of a structure containing+||| lazy boolean values. `and` short-circuits from left to right,+||| evaluating until either an element is `False` or no elements remain.+and : Foldable t => t (Lazy Bool) -> Bool+and = foldl (&&) True -or : Foldable t => t Bool -> Bool-or = foldr (||) False+||| The disjunction of all elements of a structure containing+||| lazy boolean values. `or` short-circuits from left to right, evaluating+||| either until an element is `True` or no elements remain.+or : Foldable t => t (Lazy Bool) -> Bool+or = foldl (||) False +||| The disjunction of the collective results of applying a+||| predicate to all elements of a structure. `any` short-circuits+||| from left to right. any : Foldable t => (a -> Bool) -> t a -> Bool-any p = foldr ((||) . p) False+any p = foldl (\x => \y => x || p y) False +||| The disjunction of the collective results of applying a+||| predicate to all elements of a structure. `all` short-circuits+||| from left to right. all : Foldable t => (a -> Bool) -> t a -> Bool-all p = foldr ((&&) . p) True+all p = foldl (\x => \y => x && p y)  True +||| Add together all the elements of a structure sum : (Foldable t, Num a) => t a -> a sum = foldr (+) 0 +||| Multiply together all elements of a structure product : (Foldable t, Num a) => t a -> a product = foldr (*) 1
libs/prelude/Prelude/List.idr view
@@ -12,11 +12,15 @@ %access public %default total +infix 5 \\ infixr 7 ::,++ -%elim data List a-  = Nil-  | (::) a (List a)+||| Linked lists+%elim data List a =+  ||| The empty list+  Nil |+  ||| Cons cell+  (::) a (List a)  -- Name hints for interactive editing %name List xs, ys, zs, ws@@ -25,10 +29,12 @@ -- Syntactic tests -------------------------------------------------------------------------------- +||| Returns `True` iff the argument is empty isNil : List a -> Bool isNil []      = True isNil (x::xs) = False +||| Returns `True` iff the argument is not empty isCons : List a -> Bool isCons []      = False isCons (x::xs) = True@@ -37,6 +43,9 @@ -- Length -------------------------------------------------------------------------------- +||| Compute the length of a list.+|||+||| Runs in linear time length : List a -> Nat length []      = 0 length (x::xs) = 1 + length xs@@ -45,49 +54,74 @@ -- Indexing into lists -------------------------------------------------------------------------------- -index : (n : Nat) -> (l : List a) -> (lt n (length l) = True) -> a+||| Find a particular element of a list.+|||+||| @ ok a proof that the index is within bounds+index : (n : Nat) -> (l : List a) -> (ok : lt n (length l) = True) -> a index Z     (x::xs) p    = x index (S n) (x::xs) p    = index n xs ?indexTailProof index _     []      refl   impossible +||| Attempt to find a particular element of a list.+|||+||| If the provided index is out of bounds, return Nothing. index' : (n : Nat) -> (l : List a) -> Maybe a index' Z     (x::xs) = Just x index' (S n) (x::xs) = index' n xs index' _     []      = Nothing -head : (l : List a) -> (isCons l = True) -> a+||| Get the first element of a non-empty list+||| @ ok proof that the list is non-empty+head : (l : List a) -> (ok : isCons l = True) -> a head []      refl   impossible head (x::xs) p    = x +||| Attempt to get the first element of a list. If the list is empty, return+||| `Nothing`. head' : (l : List a) -> Maybe a head' []      = Nothing head' (x::xs) = Just x -tail : (l : List a) -> (isCons l = True) -> List a+||| Get the tail of a non-empty list.+||| @ ok proof that the list is non-empty+tail : (l : List a) -> (ok : isCons l = True) -> List a tail []      refl   impossible tail (x::xs) p    = xs +||| Attempt to get the tail of a list.+|||+||| If the list is empty, return `Nothing`. tail' : (l : List a) -> Maybe (List a) tail' []      = Nothing tail' (x::xs) = Just xs -last : (l : List a) -> (isCons l = True) -> a+||| Retrieve the last element of a non-empty list.+||| @ ok proof that the list is non-empty+last : (l : List a) -> (ok : isCons l = True) -> a last []         refl   impossible last [x]        p    = x last (x::y::ys) p    = last (y::ys) refl +||| Attempt to retrieve the last element of a non-empty list.+|||+||| If the list is empty, return `Nothing`. last' : (l : List a) -> Maybe a last' []      = Nothing-last' (x::xs) = +last' (x::xs) =   case xs of     []      => Just x     y :: ys => last' xs -init : (l : List a) -> (isCons l = True) -> List a+||| Return all but the last element of a non-empty list.+||| @ ok proof that the list is non-empty+init : (l : List a) -> (ok : isCons l = True) -> List a init []         refl   impossible init [x]        p    = [] init (x::y::ys) p    = x :: init (y::ys) refl +||| Attempt to Return all but the last element of a list.+|||+||| If the list is empty, return `Nothing`. init' : (l : List a) -> Maybe (List a) init' []      = Nothing init' (x::xs) =@@ -103,21 +137,39 @@ -- Sublists -------------------------------------------------------------------------------- -take : Nat -> List a -> List a+||| Take the first `n` elements of `xs`+|||+||| If there are not enough elements, return the whole list.+||| @ n how many elements to take+||| @ xs the list to take them from+take : (n : Nat) -> (xs : List a) -> List a take Z     xs      = [] take (S n) []      = [] take (S n) (x::xs) = x :: take n xs -drop : Nat -> List a -> List a+||| Drop the first `n` elements of `xs`+|||+||| If there are not enough elements, return the empty list.+||| @ n how many elements to drop+||| @ xs the list to drop them from+drop : (n : Nat) -> (xs : List a) -> List a drop Z     xs      = xs drop (S n) []      = [] drop (S n) (x::xs) = drop n xs -takeWhile : (a -> Bool) -> List a -> List a+||| Take the longest prefix of a list such that all elements satsify some+||| Boolean predicate.+|||+||| @ p the predicate+takeWhile : (p : a -> Bool) -> List a -> List a takeWhile p []      = [] takeWhile p (x::xs) = if p x then x :: takeWhile p xs else [] -dropWhile : (a -> Bool) -> List a -> List a+||| Remove the longest prefix of a list such that all removed elements satsify some+||| Boolean predicate.+|||+||| @ p the predicate+dropWhile : (p : a -> Bool) -> List a -> List a dropWhile p []      = [] dropWhile p (x::xs) = if p x then dropWhile p xs else x::xs @@ -125,24 +177,29 @@ -- Misc. -------------------------------------------------------------------------------- -list : a -> (a -> List a -> a) -> List a -> a+||| Simply-typed recursion operator for lists.+|||+||| @ nil what to return at the end of the list+||| @ cons what to do at each step of recursion+||| @ xs the list to recurse over+list : (nil : Lazy b) -> (cons : Lazy (a -> List a -> b)) -> (xs : List a) -> b list nil cons []      = nil-list nil cons (x::xs) = cons x xs+list nil cons (x::xs) = (Force cons) x xs  -------------------------------------------------------------------------------- -- Building (bigger) lists -------------------------------------------------------------------------------- +||| Append two lists (++) : List a -> List a -> List a-(++) [] right      = right+(++) []      right = right (++) (x::xs) right = x :: (xs ++ right) -partial-repeat : a -> List a-repeat x = x :: lazy (repeat x)--replicate : Nat -> a -> List a-replicate Z x     = []+||| Construct a list with `n` copies of `x`+||| @ n how many copies+||| @ x the element to replicate+replicate : (n : Nat) -> (x : a) -> List a+replicate Z     x = [] replicate (S n) x = x :: replicate n x  --------------------------------------------------------------------------------@@ -187,15 +244,27 @@ -- Zips and unzips -------------------------------------------------------------------------------- +||| Combine two lists of the same length elementwise using some function.+||| @ f the function to combine elements with+||| @ l the first list+||| @ r the second list+||| @ ok a proof that the lengths of the inputs are equal zipWith : (f : a -> b -> c) -> (l : List a) -> (r : List b) ->-  (length l = length r) -> List c+  (ok : length l = length r) -> List c zipWith f []      (y::ys) refl   impossible zipWith f (x::xs) []      refl   impossible zipWith f []      []      p    = [] zipWith f (x::xs) (y::ys) p    = f x y :: (zipWith f xs ys ?zipWithTailProof) +||| Combine three lists of the same length elementwise using some function.+||| @ f the function to combine elements with+||| @ x the first list+||| @ y the second list+||| @ z the third list+||| @ ok a proof that the lengths of the first two inputs are equal+||| @ ok' a proof that the lengths of the second and third inputs are equal zipWith3 : (f : a -> b -> c -> d) -> (x : List a) -> (y : List b) ->-  (z : List c) -> (length x = length y) -> (length y = length z) -> List d+  (z : List c) -> (ok : length x = length y) -> (ok' : length y = length z) -> List d zipWith3 f _       []      (z::zs) p    refl   impossible zipWith3 f _       (y::ys) []      p    refl   impossible zipWith3 f []      (y::ys) _       refl q      impossible@@ -204,18 +273,22 @@ zipWith3 f (x::xs) (y::ys) (z::zs) p    q    =   f x y z :: (zipWith3 f xs ys zs ?zipWith3TailProof ?zipWith3TailProof') +||| Combine two lists elementwise into pairs zip : (l : List a) -> (r : List b) -> (length l = length r) -> List (a, b) zip = zipWith (\x => \y => (x, y)) +||| Combine three lists elementwise into tuples zip3 : (x : List a) -> (y : List b) -> (z : List c) -> (length x = length y) ->   (length y = length z) -> List (a, b, c) zip3 = zipWith3 (\x => \y => \z => (x, y, z)) +||| Split a list of pairs into two lists unzip : List (a, b) -> (List a, List b) unzip []           = ([], []) unzip ((l, r)::xs) with (unzip xs)   | (lefts, rights) = (l::lefts, r::rights) +||| Split a list of triples into three lists unzip3 : List (a, b, c) -> (List a, List b, List c) unzip3 []              = ([], [], []) unzip3 ((l, c, r)::xs) with (unzip3 xs)@@ -225,6 +298,8 @@ -- Maps -------------------------------------------------------------------------------- +||| Apply a partial function to the elements of a list, keeping the ones at which+||| it is defined. mapMaybe : (a -> Maybe b) -> List a -> List b mapMaybe f []      = [] mapMaybe f (x::xs) =@@ -236,6 +311,7 @@ -- Folds -------------------------------------------------------------------------------- +||| A tail recursive right fold on Lists. total foldrImpl : (t -> acc -> acc) -> acc -> (acc -> acc) -> List t -> acc foldrImpl f e go [] = go e foldrImpl f e go (x::xs) = foldrImpl f e (go . (f x)) xs@@ -247,6 +323,7 @@ -- Special folds -------------------------------------------------------------------------------- +||| Convert any Foldable structure to a list. toList : Foldable t => t a -> List a toList = foldr (::) [] @@ -254,6 +331,7 @@ -- Transformations -------------------------------------------------------------------------------- +||| Return the elements of a list in reverse order. reverse : List a -> List a reverse = reverse' []   where@@ -261,6 +339,7 @@     reverse' acc []      = acc     reverse' acc (x::xs) = reverse' (x::acc) xs +||| Insert some separator between the elements of a list. intersperse : a -> List a -> List a intersperse sep []      = [] intersperse sep (x::xs) = x :: intersperse' sep xs@@ -274,13 +353,13 @@  ||| Transposes rows and columns of a list of lists. |||-||| > transpose [[1, 2], [3, 4]] = [[1, 3], [2, 4]]+|||     > transpose [[1, 2], [3, 4]] = [[1, 3], [2, 4]] ||| ||| This also works for non square scenarios, thus ||| involution does not always hold: |||-||| > transpose [[], [1, 2]] = [[1], [2]]-||| > transpose (transpose [[], [1, 2]]) = [[1, 2]]+|||     > transpose [[], [1, 2]] = [[1], [2]]+|||     > transpose (transpose [[], [1, 2]]) = [[1, 2]] ||| ||| TODO: Solution which satisfies the totality checker? %assert_total@@ -293,6 +372,7 @@ -- Membership tests -------------------------------------------------------------------------------- +||| Check if something is a member of a list using a custom comparison. elemBy : (a -> a -> Bool) -> a -> List a -> Bool elemBy p e []      = False elemBy p e (x::xs) =@@ -301,9 +381,11 @@   else     elemBy p e xs +||| Check if something is a member of a list using the default Boolean equality. elem : Eq a => a -> List a -> Bool elem = elemBy (==) +||| Find associated information in a list using a custom comparison. lookupBy : (a -> a -> Bool) -> a -> List (a, b) -> Maybe b lookupBy p e []      = Nothing lookupBy p e (x::xs) =@@ -313,9 +395,12 @@     else       lookupBy p e xs +||| Find associated information in a list using Boolean equality. lookup : Eq a => a -> List (a, b) -> Maybe b lookup = lookupBy (==) +||| Check if any elements of the first list are found in the second, using+||| a custom comparison. hasAnyBy : (a -> a -> Bool) -> List a -> List a -> Bool hasAnyBy p elems []      = False hasAnyBy p elems (x::xs) =@@ -324,6 +409,8 @@   else     hasAnyBy p elems xs +||| Check if any elements of the first list are found in the second, using+||| Boolean equality. hasAny : Eq a => List a -> List a -> Bool hasAny = hasAnyBy (==) @@ -331,6 +418,7 @@ -- Searching with a predicate -------------------------------------------------------------------------------- +||| Find the first element of a list that satisfies a predicate, or `Nothing` if none do. find : (a -> Bool) -> List a -> Maybe a find p []      = Nothing find p (x::xs) =@@ -339,6 +427,8 @@   else     find p xs +||| Find the index of the first element of a list that satisfies a predicate, or+||| `Nothing` if none do. findIndex : (a -> Bool) -> List a -> Maybe Nat findIndex = findIndex' Z   where@@ -350,6 +440,7 @@       else         findIndex' (S cnt) p xs +||| Find the indices of all elements that satisfy some predicate. findIndices : (a -> Bool) -> List a -> List Nat findIndices = findIndices' Z   where@@ -399,10 +490,28 @@ nub : Eq a => List a -> List a nub = nubBy (==) +deleteBy : (a -> a -> Bool) -> a -> List a -> List a+deleteBy _  _ []      = []+deleteBy eq x (y::ys) = if x `eq` y then ys else y :: deleteBy eq x ys++delete : (Eq a) => a -> List a -> List a+delete = deleteBy (==)++(\\) : (Eq a) => List a -> List a -> List a+(\\) =  foldl (flip delete)++unionBy : (a -> a -> Bool) -> List a -> List a -> List a+unionBy eq xs ys =  xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs++union : (Eq a) => List a -> List a -> List a+union = unionBy (==)+ -------------------------------------------------------------------------------- -- Splitting and breaking lists -------------------------------------------------------------------------------- +||| Given a list and a predicate, returns a pair consisting of the longest+||| prefix of the list that satisfies a predicate and the rest of the list. span : (a -> Bool) -> List a -> (List a, List a) span p []      = ([], []) span p (x::xs) =@@ -416,7 +525,6 @@ break p = span (not . p)  split : (a -> Bool) -> List a -> List (List a)-split p [] = [] split p xs =   case break p xs of     (chunk, [])          => [chunk]@@ -439,6 +547,16 @@     else       (lefts, x::rights) +inits : List a -> List (List a)+inits xs = [] :: case xs of+  []        => []+  x :: xs'  => map (x ::) (inits xs')++tails : List a -> List (List a)+tails xs = xs :: case xs of+  []        => []+  _ :: xs'  => tails xs'+ -------------------------------------------------------------------------------- -- Predicates --------------------------------------------------------------------------------@@ -501,6 +619,7 @@ -- Conversions -------------------------------------------------------------------------------- +||| Either return the head of a list, or `Nothing` if it is empty. listToMaybe : List a -> Maybe a listToMaybe []      = Nothing listToMaybe (x::xs) = Just x@@ -520,7 +639,7 @@ -- Properties -------------------------------------------------------------------------------- --- append+||| The empty list is a right identity for append. appendNilRightNeutral : (l : List a) ->   l ++ [] = l appendNilRightNeutral []      = refl@@ -528,6 +647,7 @@   let inductiveHypothesis = appendNilRightNeutral xs in     ?appendNilRightNeutralStepCase +||| Appending lists is associative. appendAssociative : (l : List a) -> (c : List a) -> (r : List a) ->   l ++ (c ++ r) = (l ++ c) ++ r appendAssociative []      c r = refl@@ -535,7 +655,8 @@   let inductiveHypothesis = appendAssociative xs c r in     ?appendAssociativeStepCase --- length+||| The length of two lists that are appended is the sum of the lengths+||| of the input lists. lengthAppend : (left : List a) -> (right : List a) ->   length (left ++ right) = length left + length right lengthAppend []      right = refl@@ -543,7 +664,7 @@   let inductiveHypothesis = lengthAppend xs right in     ?lengthAppendStepCase --- map+||| Mapping a function over a list doesn't change its length. mapPreservesLength : (f : a -> b) -> (l : List a) ->   length (map f l) = length l mapPreservesLength f []      = refl@@ -551,6 +672,8 @@   let inductiveHypothesis = mapPreservesLength f xs in     ?mapPreservesLengthStepCase +||| Mapping a function over two lists and appending them is equivalent+||| to appending them and then mapping the function. mapDistributesOverAppend : (f : a -> b) -> (l : List a) -> (r : List a) ->   map f (l ++ r) = map f l ++ map f r mapDistributesOverAppend f []      r = refl@@ -558,6 +681,7 @@   let inductiveHypothesis = mapDistributesOverAppend f xs r in     ?mapDistributesOverAppendStepCase +||| Mapping two functions is the same as mapping their composition. mapFusion : (f : b -> c) -> (g : a -> b) -> (l : List a) ->   map f (map g l) = map (f . g) l mapFusion f g []      = refl@@ -565,7 +689,7 @@   let inductiveHypothesis = mapFusion f g xs in     ?mapFusionStepCase --- hasAny+||| No list contains an element of the empty list by any predicate. hasAnyByNilFalse : (p : a -> a -> Bool) -> (l : List a) ->   hasAnyBy p [] l = False hasAnyByNilFalse p []      = refl@@ -573,6 +697,7 @@   let inductiveHypothesis = hasAnyByNilFalse p xs in     ?hasAnyByNilFalseStepCase +||| No list contains an element of the empty list. hasAnyNilFalse : Eq a => (l : List a) -> hasAny [] l = False hasAnyNilFalse l = ?hasAnyNilFalseBody
libs/prelude/Prelude/Maybe.idr view
@@ -28,25 +28,32 @@ -- Misc -------------------------------------------------------------------------------- -maybe : Lazy b -> (a -> b) -> Maybe a -> b+maybe : Lazy b -> Lazy (a -> b) -> Maybe a -> b maybe n j Nothing  = n-maybe n j (Just x) = j x+maybe n j (Just x) = (Force j) x +||| Convert a `Maybe a` value to an `a` value by providing a default `a` value+||| in the case that the `Maybe` value is `Nothing`. fromMaybe : (Lazy a) -> Maybe a -> a fromMaybe def Nothing  = def fromMaybe def (Just j) = j -toMaybe : Bool -> a -> Maybe a+||| Returns `Just` the given value if the conditional is `True`+||| and `Nothing` if the conditional is `False`.+toMaybe : Bool -> Lazy a -> Maybe a toMaybe True  j = Just j toMaybe False j = Nothing  justInjective : {x : t} -> {y : t} -> (Just x = Just y) -> x = y justInjective refl = refl +||| Convert a `Maybe a` value to an `a` value, using `neutral` in the case+||| that the `Maybe` value is `Nothing`. lowerMaybe : Monoid a => Maybe a -> a lowerMaybe Nothing = neutral lowerMaybe (Just x) = x +||| Returns `Nothing` when applied to `neutral`, and `Just` the value otherwise. raiseToMaybe : (Monoid a, Eq a) => a -> Maybe a raiseToMaybe x = if x == neutral then Nothing else Just x
libs/prelude/Prelude/Stream.idr view
@@ -31,8 +31,10 @@ take Z _ = [] take (S n) (x :: xs) = x :: (take n xs) +||| Drop the first n elements from the stream+||| @ n how many elements to drop %assert_total-drop : Nat -> Stream a -> Stream a+drop : (n : Nat) -> Stream a -> Stream a drop Z     xs = xs drop (S k) (x::xs) = drop k xs @@ -67,4 +69,31 @@ diag : Stream (Stream a) -> Stream a diag ((x::xs)::xss) = x :: diag (map tail xss) +||| Fold a Stream corecursively. Since there is no Nil, no initial value is used.+||| @ f the combining function+||| @ xs the Stream to fold up+foldr : (f : a -> Inf b -> b) -> (xs : Stream a) -> b+foldr f (x :: xs) = f x (foldr f xs)++||| Produce a Stream of left folds of prefixes of the given Stream+||| @ f the combining function+||| @ acc the initial value+||| @ xs the Stream to process+scanl : (f : a -> b -> a) -> (acc : a) -> (xs : Stream b) -> Stream a+scanl f acc (x :: xs) = acc :: scanl f (f acc x) xs++||| 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+scanr : (f : a -> Inf b -> b) -> (xs : Stream a) -> Stream b+scanr f (x :: Delay xs) = f x (foldr f xs) :: scanr f xs++||| Produce a Stream repeating a sequence+||| @ xs the sequence to repeat+cycle : (xs : Vect (S n) a) -> Stream a+cycle xs = cycle_ xs xs+  where cycle_ : Vect (S n) a -> Vect m a -> Stream a+        cycle_ (x :: xs) [] = x :: cycle_ (x :: xs) xs+        cycle_ xs (x :: ys) = x :: cycle_ xs ys
libs/prelude/Prelude/Strings.idr view
@@ -8,29 +8,59 @@ import Prelude.Foldable  ||| Appends two strings together.+|||+||| Idris> "AB" ++ "C"+||| "ABC" : String (++) : String -> String -> String (++) = prim__concat  ||| Returns the first character in the specified string.+|||+||| Doesn't work for empty strings.+|||+||| Idris> strHead "A"+||| 'A' : Char partial strHead : String -> Char strHead = prim__strHead  ||| Returns the characters specified after the head of the string.+|||+||| Doesn't work for empty strings.+|||+||| Idris> strTail "AB"+||| "B" : String+||| Idris> strTail "A"+||| "" : String partial strTail : String -> String strTail = prim__strTail -||| Adds a character to the from of the specified string.+||| Adds a character to the front of the specified string.+|||+||| Idris> strCons 'A' "B"+||| "AB" : String+||| Idris> strCons 'A' ""+||| "A" : String strCons : Char -> String -> String strCons = prim__strCons  ||| Returns the nth character (starting from 0) of the specified string.+|||+||| Precondition: '0 < i < length s' for 'strIndex s i'.+|||+||| Idris> strIndex "AB" 1+||| 'B' : Char partial strIndex : String -> Int -> Char strIndex = prim__strIndex  ||| Reverses the elements within a String.+|||+||| Idris> reverse "ABC"+||| "CBA" : String+||| Idris> reverse ""+||| "" : String reverse : String -> String reverse = prim__strRev @@ -43,9 +73,11 @@     StrNil : StrM ""     StrCons : (x : Char) -> (xs : String) -> StrM (strCons x xs) +||| Version of 'strHead' that statically verifies that the string is not empty. strHead' : (x : String) -> so (not (x == "")) -> Char strHead' x p = assert_total $ prim__strHead x +||| Version of 'strTail' that statically verifies that the string is not empty. strTail' : (x : String) -> so (not (x == "")) -> String strTail' x p = assert_total $ prim__strTail x @@ -61,14 +93,23 @@ -- a recursive argument, therefore the termination checker doesn't believe -- the string is guaranteed smaller. It makes a good point. +||| Turns a string into a list of characters.+|||+||| Idris> unpack "ABC"+||| ['A', 'B', 'C'] : List Char unpack : String -> List Char unpack s with (strM s)   unpack ""             | StrNil = []   unpack (strCons x xs) | (StrCons x xs) = x :: assert_total (unpack xs) +||| Turns a Foldable of characters into a string. pack : (Foldable t) => t Char -> String pack = foldr strCons "" +||| Creates a string of a single character.+|||+||| Idris> singleton 'A'+||| "A" : String singleton : Char -> String singleton c = strCons c "" @@ -87,6 +128,13 @@ instance Monoid String where   neutral = "" +||| Splits the string into a part before the predicate+||| returns False and the rest of the string.+|||+||| Idris> span (/= 'C') "ABCD"+||| ("AB", "CD") : (String, String)+||| Idris> span (/= 'C') "EFGH"+||| ("EFGH", "") : (String, String) span : (Char -> Bool) -> String -> (String, String) span p xs with (strM xs)   span p ""             | StrNil        = ("", "")@@ -95,36 +143,76 @@       | (ys, zs) = (strCons x ys, zs)     | False = ("", strCons x xs) +||| Splits the string into a part before the predicate+||| returns True and the rest of the string.+|||+||| Idris> break (== 'C') "ABCD"+||| ("AB", "CD") : (String, String)+||| Idris> break (== 'C') "EFGH"+||| ("EFGH", "") : (String, String) break : (Char -> Bool) -> String -> (String, String) break p = span (not . p) +||| Splits the string into parts with the predicate+||| indicating separator characters.+|||+||| Idris> split (== '.') ".AB.C..D"+||| ["", "AB", "C", "", "D"] : List String split : (Char -> Bool) -> String -> List String split p xs = map pack (split p (unpack xs)) +||| Removes whitespace (determined with 'isSpace') from+||| the start of the string.+|||+||| Idris> ltrim " A\nB"+||| "A\nB" : String+||| Idris> ltrim " \nAB"+||| "AB" : String ltrim : String -> String ltrim xs with (strM xs)     ltrim "" | StrNil = ""     ltrim (strCons x xs) | StrCons _ _         = if (isSpace x) then assert_total (ltrim xs) else (strCons x xs) +||| Removes whitespace (determined with 'isSpace') from+||| the start and end of the string.+|||+||| Idris> trim " A\nB C "+||| "A\nB C" : String trim : String -> String trim xs = ltrim (reverse (ltrim (reverse xs))) +||| Splits a character list into a list of whitespace separated character lists.+|||+||| Idris> words' (unpack " A B C  D E   ")+||| [['A'], ['B'], ['C'], ['D'], ['E']] : List (List Char) words' : List Char -> List (List Char) words' s = case dropWhile isSpace s of             [] => []             s' => let (w, s'') = break isSpace s'                   in w :: words' (assert_smaller s s'') +||| Splits a string into a list of whitespace separated strings.+|||+||| Idris> words " A B C  D E   "+||| ["A", "B", "C", "D", "E"] : List String words : String -> List String words s = map pack $ words' $ unpack s +||| Splits a character list into a list of newline separated character lists.+|||+||| Idris> lines' (unpack "\rA BC\nD\r\nE\n")+||| [['A', ' ', 'B', 'C'], ['D'], ['E']] : List (List Char) lines' : List Char -> List (List Char) lines' s = case dropWhile isNL s of             [] => []             s' => let (w, s'') = break isNL s'                   in w :: lines' (assert_smaller s s'') +||| Splits a string into a list of newline separated strings.+|||+||| Idris> lines  "\rA BC\nD\r\nE\n"+||| ["A BC", "D", "E"] : List String lines : String -> List String lines s = map pack $ lines' $ unpack s @@ -133,6 +221,10 @@ foldr1 f [x] = x foldr1 f (x::xs) = f x (foldr1 f xs) +||| Joins the character lists by spaces into a single character list.+|||+||| Idris> unwords' [['A'], ['B', 'C'], ['D'], ['E']]+||| ['A', ' ', 'B', 'C', ' ', 'D', ' ', 'E'] : List Char unwords' : List (List Char) -> List Char unwords' [] = [] unwords' ws = assert_total (foldr1 addSpace ws)@@ -140,18 +232,36 @@             addSpace : List Char -> List Char -> List Char             addSpace w s = w ++ (' ' :: s) +||| Joins the strings by spaces into a single string. +|||+||| Idris> unwords ["A", "BC", "D", "E"]+||| "A BC D E" : String unwords : List String -> String unwords = pack . unwords' . map unpack +||| Returns the length of the string.+|||+||| Idris> length ""+||| 0 : Nat+||| Idris> length "ABC"+||| 3 : Nat length : String -> Nat length = fromInteger . prim__zextInt_BigInt . prim_lenString +||| Lowercases all characters in the string.+|||+||| Idris> toLower "aBc12!"+||| "abc12!" : String toLower : String -> String toLower x with (strM x)   strToLower ""             | StrNil = ""   strToLower (strCons c cs) | (StrCons c cs) =     strCons (toLower c) (toLower (assert_smaller (strCons c cs) cs)) +||| Uppercases all characters in the string.+|||+||| Idris> toLower "aBc12!"+||| "ABC12!" : String toUpper : String -> String toUpper x with (strM x)   strToLower ""             | StrNil = ""
libs/prelude/Prelude/Uninhabited.idr view
@@ -8,6 +8,9 @@   ||| @ t the uninhabited type   total uninhabited : t -> _|_ +instance Uninhabited _|_ where+  uninhabited a = a+ ||| Use an absurd assumption to discharge a proof obligation ||| @ t some empty type ||| @ a the goal type
libs/prelude/Prelude/Vect.idr view
@@ -68,6 +68,12 @@ index (fS k) (x::xs) = index k xs index fZ     [] impossible +||| Insert an element at a particular index+insertAt : Fin (S n) -> a -> Vect n a -> Vect (S n) a+insertAt fZ     y xs      = y :: xs+insertAt (fS k) y (x::xs) = x :: insertAt k y xs+insertAt (fS k) y []      = absurd k+ ||| Construct a new vector consisting of all but the indicated element deleteAt : Fin (S n) -> Vect (S n) a -> Vect n a deleteAt           fZ     (x::xs) = xs@@ -254,7 +260,19 @@ concat []      = [] concat (v::vs) = v ++ concat vs +||| Fold without seeding the accumulator+foldr1 : (t -> t -> t) -> Vect (S n) t -> t+foldr1 f (x::xs) = foldr f x xs+ --------------------------------------------------------------------------------+-- Scans+--------------------------------------------------------------------------------++scanl : (b -> a -> b) -> b -> Vect n a -> Vect (S n) b+scanl f q []      = [q]+scanl f q (x::xs) = q :: scanl f (f q x) xs++-------------------------------------------------------------------------------- -- Membership tests -------------------------------------------------------------------------------- @@ -438,6 +456,31 @@ range : Vect n (Fin n) range {n=Z} = [] range {n=S _} = fZ :: map fS range++||| Transpose a Vect of Vects, turning rows into columns and vice versa.+|||+||| As the types ensure rectangularity, this is an involution, unlike `Prelude.List.transpose`.+transpose : Vect m (Vect n a) -> Vect n (Vect m a)+transpose [] = replicate _ []+transpose (x :: xs) = zipWith (::) x (transpose xs)++--------------------------------------------------------------------------------+-- Properties+--------------------------------------------------------------------------------++vectConsCong : (x : a) -> (xs : Vect n a) -> (ys : Vect m a) -> (xs = ys) -> (x :: xs = x :: ys)+vectConsCong x xs xs refl = refl++vectNilRightNeutral : (xs : Vect n a) -> xs ++ [] = xs+vectNilRightNeutral [] = refl+vectNilRightNeutral (x :: xs) =+  vectConsCong _ _ _ (vectNilRightNeutral xs)++vectAppendAssociative : (x : Vect xLen a) -> (y : Vect yLen a) -> (z : Vect zLen a) -> x ++ (y ++ z) = (x ++ y) ++ z+vectAppendAssociative [] y z = refl+vectAppendAssociative (x :: xs) ys zs =+  vectConsCong _ _ _ (vectAppendAssociative xs ys zs)+  -------------------------------------------------------------------------------- -- Proofs
main/Main.hs view
@@ -24,6 +24,7 @@ import Idris.Primitives import Idris.Imports import Idris.Error+import Idris.CmdOptions  import IRTS.System ( getLibFlags, getIdrisLibDir, getIncFlags ) @@ -36,8 +37,7 @@ -- Main program reads command line options, parses the main program, and gets -- on with the REPL. -main = do xs <- getArgs-          let opts = parseArgs xs+main = do opts <- runArgParser           result <- runErrorT $ execStateT (runIdris opts) idrisInit           case result of             Left err -> putStrLn $ "Uncaught error: " ++ show err@@ -48,8 +48,6 @@                          setQuiet True                          runIO $ runClient c runIdris opts = do-       when (Ver `elem` opts) $ runIO showver-       when (Usage `elem` opts) $ runIO usage        when (ShowIncs `elem` opts) $ runIO showIncs        when (ShowLibs `elem` opts) $ runIO showLibs        when (ShowLibdir `elem` opts) $ runIO showLibdir@@ -61,6 +59,10 @@            [] -> return ()            fs -> do runIO $ mapM_ cleanPkg fs                     runIO $ exitWith ExitSuccess+       case opt getPkgMkDoc opts of                -- IdrisDoc+           [] -> return ()+           fs -> do runIO $ mapM_ documentPkg fs+                    runIO $ exitWith ExitSuccess        case opt getPkg opts of            [] -> case opt getPkgREPL opts of                       [] -> idrisMain opts@@ -68,9 +70,6 @@                       _ -> ifail "Too many packages"            fs -> runIO $ mapM_ (buildPkg (WarnOnly `elem` opts)) fs -usage = do putStrLn usagemsg-           exitWith ExitSuccess- showver = do putStrLn $ "Idris version " ++ ver              exitWith ExitSuccess @@ -85,56 +84,3 @@ showIncs = do incFlags <- getIncFlags               putStrLn incFlags               exitWith ExitSuccess--usagemsghdr = "Idris version " ++ ver ++ ", (C) The Idris Community 2014"--usagemsg = usagemsghdr ++ "\n" ++ -           map (\x -> '-') usagemsghdr ++ "\n" ++  -           "idris [OPTIONS] [FILE]\n\n" ++-           "Common flags:\n" ++-           "\t    --install IPKG          Install package\n" ++-           "\t    --clean IPKG            Clean package\n" ++-           "\t    --build IPKG            Build package\n" ++-           "\t    --exec EXPR             Execute as idris\n" ++-           "\t    --libdir                Display library directory\n" ++-           "\t    --link                  Display link directory\n" ++-           "\t    --include               Display the includes directory\n" ++-           "\t    --nobanner              Suppress the banner\n" ++-           "\t    --color, --colour       Force coloured output\n" ++-           "\t    --nocolor, --nocolour   Disable coloured output\n" ++-           "\t    --errorcontent          Undocumented\n" ++-           "\t    --nocoverage            Undocumented\n" ++-           "\t -o --output FILE           Specify output file\n" ++-           "\t    --check                 Undocumented\n" ++-           "\t    --total                 Require functions to be total by default\n" ++-           "\t    --partial               Undocumented\n" ++-           "\t    --warnpartial           Warn about undeclared partial functions.\n" ++-           "\t    --warn                  Undocumented\n" ++-           "\t    --typecase              Undocumented\n" ++-           "\t    --typeintype            Undocumented\n" ++-           "\t    --nobasepkgs            Undocumented\n" ++-           "\t    --noprelude             Undocumented\n" ++-           "\t    --nobuiltins            Undocumented\n" ++-           "\t -O --level LEVEL           Undocumented\n" ++-           "\t -i --idrispath DIR         Add directory to the list of import paths\n" ++-           "\t    --package ITEM          Undocumented\n" ++-           "\t    --ibcsubdir FILE        Write IBC files into sub directory\n" ++-           "\t    --codegen TARGET        Select code generator: C, Java, bytecode,\n" ++-           "\t                            javascript, node, or llvm\n" ++-           "\t    --mvn                   Create a maven project (for Java codegen)\n" ++-           "\t    --cpu=CPU               Select target CPU e.g. corei7 or cortex-m3\n" ++-           "\t                            (for LLVM codegen)\n" ++-           "\t    --target=TRIPLE         Select target triple (for llvm codegen)\n" ++-           "\t -S --codegenonly           Do no further compilation of code generator output\n" ++-           "\t -c --compileonly           Compile to object files rather than an executable\n" ++-           "\t -X --extension EXT         Turn on langage extension (TypeProviders or ErrorReflection)\n" ++-           "\t    --dumpdefuns            Undocumented\n" ++-           "\t    --dumpcases             Undocumented\n" ++-           "\t    --log LEVEL --loglevel  Debugging log level\n" ++-           "\t    --ideslave              Undocumented\n" ++-           "\t    --client                Undocumented\n" ++-           "\t -h --help                  Display help message\n" ++-           "\t -v --version               Print version information\n" ++-           "\t -V --verbose               Loud verbosity\n" ++-           "\t -q --quiet                 Quiet verbosity\n"-
rts/Makefile view
@@ -3,16 +3,15 @@ OBJS = idris_rts.o idris_heap.o idris_gc.o idris_gmp.o idris_bitstring.o \        idris_opts.o idris_stats.o mini-gmp.o HDRS = idris_rts.h idris_heap.h idris_gc.h idris_gmp.h idris_bitstring.h \-       idris_opts.h idris_stats.h mini-gmp.h+       idris_opts.h idris_stats.h mini-gmp.h idris_stdfgn.h idris_net.h CFLAGS:=-fPIC $(CFLAGS)-CFLAGS += $(GMP_INCLUDE_DIR) $(GMP)+CFLAGS += $(GMP_INCLUDE_DIR) $(GMP) -DIDRIS_TARGET_OS="\"$(OS)\""+CFLAGS += -DIDRIS_TARGET_TRIPLE="\"$(MACHINE)\""  ifeq ($(OS), windows) 	OBJS += windows/idris_stdfgn.o windows/idris_net.o-	HDRS += windows/idris_stdfgn.h windows/idris_net.h else 	OBJS += idris_stdfgn.o idris_net.o-	HDRS += idris_stdfgn.h idris_net.h endif  LIBTARGET = libidris_rts.a
rts/idris_net.c view
@@ -1,8 +1,18 @@ // 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>+#include <stdlib.h>+#include <stdio.h>+#include <string.h>+#include <sys/types.h>+#include <sys/socket.h>+#include <netinet/in.h> #include <arpa/inet.h>++#include "idris_net.h"  void* idrnet_malloc(int size) {     return malloc(size);
rts/idris_net.h view
@@ -1,16 +1,6 @@ #ifndef IDRISNET_H #define IDRISNET_H -#include <errno.h>-#include <netdb.h>-#include <stdbool.h>-#include <stdlib.h>-#include <stdio.h>-#include <string.h>-#include <sys/types.h>-#include <sys/socket.h>-#include <netinet/in.h>- typedef struct idrnet_recv_result {     int result;     void* payload;
rts/idris_rts.c view
@@ -506,6 +506,19 @@     return cl; } +VAL idris_systemInfo(VM* vm, VAL index) {+    int i = GETINT(index);+    switch(i) {+        case 0: // backend+            return MKSTR(vm, "c");+        case 1:+            return MKSTR(vm, IDRIS_TARGET_OS);+        case 2:+            return MKSTR(vm, IDRIS_TARGET_TRIPLE);+    }+    return MKSTR(vm, "");+}+ VAL MKBUFFERc(VM* vm, Buffer* buf) {     Closure* cl = allocate(vm, sizeof(Closure) + sizeof *buf + buf->cap, 1);     SETTY(cl, BUFFER);
rts/idris_rts.h view
@@ -279,6 +279,12 @@ VAL idris_peekB64LE(VM* vm, VAL buf, VAL off); VAL idris_peekB64BE(VM* vm, VAL buf, VAL off); +// system infox+// used indices:+//   0 returns backend+//   1 returns OS+VAL idris_systemInfo(VM* vm, VAL index);+ // Command line args  extern int __idris_argc;
+ rts/windows/idris_net.c view
@@ -0,0 +1,196 @@+// C-Side of the Idris network library+// (C) Simon Fowler, 2014+// MIT Licensed. Have fun!+#include "../idris_net.h"++#include <errno.h>+#include <stdbool.h>+#include <stdlib.h>+#include <stdio.h>+#include <string.h>+#include <Winsock2.h>+#include <Ws2tcpip.h>+++// inet_ntop isn't defined in the old mingw delivered with GHC, +// so put the prototype here, cribbed from a newer version of it+WINSOCK_API_LINKAGE LPCSTR WSAAPI InetNtopA(INT Family, PVOID pAddr,+        LPSTR pStringBuf, size_t StringBufSize);++static int socket_inited = 0;+static WSADATA wsa_data;++void* idrnet_malloc(int size) {+    return malloc(size);+}++void idrnet_free(void* ptr) {+    free(ptr);+}++static void clean_sockets(void) {+    WSACleanup();+}++static int check_init(void)+{+    if (!socket_inited) {+        int result = WSAStartup(MAKEWORD(2, 2), &wsa_data);+        if (result == NO_ERROR) {+            socket_inited = 1;+            atexit(clean_sockets);+        }+    }+    return socket_inited;+}++int idrnet_bind(int sockfd, int family, int socket_type, char* host, int port) {+    struct addrinfo hints;+    struct addrinfo* address_res;+    // Convert port into string+    char str_port[8];+    sprintf(str_port, "%d", port);+    +    if (!check_init()) {+        return -1;+    }+    // Set up hints structure+    memset(&hints, 0, sizeof(hints)); // zero out hints+    hints.ai_family = family;+    hints.ai_socktype = socket_type;++    // If the length of the hostname is 0 (i.e, it was set to Nothing in Idris)+    // 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+    }++    int addr_res = getaddrinfo(host, str_port, &hints, &address_res);+    if (addr_res == -1) {+        return -1;+    }++    int bind_res = bind(sockfd, address_res->ai_addr, address_res->ai_addrlen);+    if (bind_res == -1) {+        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;++    if (!check_init()) {+        return -1;+    }+    // 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);+    if (addr_res == -1) {+        return -1;+    }++    int connect_res = connect(sockfd, remote_host->ai_addr, remote_host->ai_addrlen);+    if (connect_res == -1) {+        return -1;+    }++    return 0;+}+++int idrnet_sockaddr_family(void* sockaddr) {+    struct sockaddr* addr = (struct sockaddr*) sockaddr;+    return (int) addr->sa_family;+}++char* idrnet_sockaddr_ipv4(void* sockaddr) {+    struct sockaddr_in* addr = (struct sockaddr_in*) sockaddr;+    char* ip_addr = (char*) malloc(sizeof(char) * INET_ADDRSTRLEN);+    InetNtopA(AF_INET, &(addr->sin_addr), ip_addr, INET_ADDRSTRLEN);+    return ip_addr;+}++void* idrnet_create_sockaddr() {+    return malloc(sizeof(struct sockaddr_storage));+}+++int idrnet_accept(int sockfd, void* sockaddr) {+    struct sockaddr* addr = (struct sockaddr*) sockaddr;+    socklen_t addr_size = 0;+    if (!check_init()) {+        return -1;+    }+    return accept(sockfd, addr, &addr_size);+}++int idrnet_send(int sockfd, char* data) {+    int len = strlen(data); // For now.+    if (!check_init()) {+        return -1;+    }+    return send(sockfd, (void*) data, len, 0);+}++int idrnet_send_buf(int sockfd, void* data, int len) {+    if (!check_init()) {+        return -1;+    }+    return send(sockfd, data, len, 0);+}++void* idrnet_recv(int sockfd, int len) {+    if (!check_init()) {+        return NULL;+    }+    idrnet_recv_result* res_struct = +        (idrnet_recv_result*) malloc(sizeof(idrnet_recv_result));++    char* buf = malloc(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;+    return (void*) res_struct;+}++int idrnet_recv_buf(int sockfd, void* buf, int len) {+    if (!check_init()) {+        return -1;+    }+    return recv(sockfd, buf, len, 0);+}++int idrnet_get_recv_res(void* res_struct) {+    return (((idrnet_recv_result*) res_struct)->result);+}++void* idrnet_get_recv_payload(void* res_struct) {+    return (((idrnet_recv_result*) res_struct)->payload);+}++void idrnet_free_recv_struct(void* res_struct) {+    idrnet_recv_result* i_res_struct = +        (idrnet_recv_result*) res_struct;+    if (i_res_struct->payload != NULL) {+        free(i_res_struct->payload);+    }+    free(res_struct);+}++int idrnet_errno() {+    return errno;+}+
+ rts/windows/idris_stdfgn.c view
@@ -0,0 +1,75 @@+#include "../idris_stdfgn.h"+#include "../idris_rts.h"+#include "../idris_gc.h"++#include <fcntl.h>+#include <stdio.h>+#include <time.h>++extern char** environ;++void putStr(char* str) {+    printf("%s", str);+}++void* fileOpen(char* name, char* mode) {+    FILE* f = fopen(name, mode);+    return (void*)f;+}++void fileClose(void* h) {+    FILE* f = (FILE*)h;+    fclose(f);+}++int fileEOF(void* h) {+  FILE* f = (FILE*)h;+  return feof(f);+}++int fileError(void* h) {+  FILE* f = (FILE*)h;+  return ferror(f);+}++void fputStr(void* h, char* str) {+    FILE* f = (FILE*)h;+    fputs(str, f);+}++int fpoll(void* h)+{+    return 0;+}++void* do_popen(const char* cmd, const char* mode) {+    FILE* f = _popen(cmd, mode);+//    int d = fileno(f);+//    fcntl(d, F_SETFL, O_NONBLOCK);+    return f;+}++int isNull(void* ptr) {+    return ptr==NULL;+}++int idris_eqPtr(void* x, void* y) {+    return x==y;+}++void* idris_stdin() {+    return (void*)stdin;+}++char* getEnvPair(int i) {+    return *(environ + i);+}++int idris_time() {+    time_t t = time(NULL);+    return (int)t;+}++void idris_forceGC(void* vm) {+   idris_gc((VM*)vm);+}
src/IRTS/CodegenC.hs view
@@ -62,7 +62,6 @@              hPutStr tmph cout              hFlush tmph              hClose tmph-             let useclang = False              comp <- getCC              libFlags <- getLibFlags              incFlags <- getIncFlags@@ -175,15 +174,15 @@     | length code < 4 = showCase i def code   where     showCode :: Int -> [BC] -> String-    showCode i bc = "{\n" ++ indent i ++ concatMap (bcc (i + 1)) bc +++    showCode i bc = "{\n" ++ concatMap (bcc (i + 1)) bc ++                     indent i ++ "}\n"      showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String     showCase i Nothing [(t, c)] = showCode i c     showCase i (Just def) [] = showCode i def     showCase i def ((t, c) : cs)-        = "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c-           ++ "else " ++ showCase i def cs+        = indent i ++ "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c+           ++ indent i ++ "else " ++ showCase i def cs  bcc i (CASE safe r code def)     = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++@@ -494,6 +493,8 @@ doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args doOp v (LIntCh ITNative) args = v ++ creg (last args) doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args++doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")" doOp v LNoOp args = v ++ creg (last args) doOp _ op _ = "FAIL /* " ++ show op ++ " */"
src/IRTS/CodegenJavaScript.hs view
@@ -17,6 +17,7 @@ import Numeric import Data.List import Data.Maybe+import Data.Word import System.IO import System.Directory @@ -53,6 +54,13 @@            deriving Eq  +data JSWord = JSWord8 Word8+            | JSWord16 Word16+            | JSWord32 Word32+            | JSWord64 Word64+            deriving Eq++ data JSAnnotation = JSConstructor deriving Eq  @@ -81,6 +89,7 @@         | JSArray [JS]         | JSString String         | JSNum JSNum+        | JSWord JSWord         | JSAssign JS JS         | JSAlloc String (Maybe JS)         | JSIndex JS JS@@ -257,6 +266,13 @@   ++ 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") [@@ -280,6 +296,8 @@ jsEq :: JS -> JS -> JS jsEq = JSBinOp "==" +jsNotEq :: JS -> JS -> JS+jsNotEq = JSBinOp "!="  jsAnd :: JS -> JS -> JS jsAnd = JSBinOp "&&"@@ -327,7 +345,29 @@ 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@@ -702,21 +742,44 @@                            JSReturn (JSApp (JSIdent fun) args)                          )])           | Just pos <- lookup fun ids-          , pos < length args  = args !! pos+          , pos < length args  = removeIDCall ids (args !! pos)          removeIDCall ids (JSNew _ [JSFunction [] (                            JSReturn (JSApp (JSIdent fun) args)                          )])           | Just pos <- lookup fun ids-          , pos < length args = args !! pos+          , pos < length args = removeIDCall ids (args !! pos)          removeIDCall ids js@(JSApp id@(JSIdent fun) args)           | Just pos <- lookup fun ids-          , pos < length args  = args !! pos+          , 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)@@ -728,7 +791,7 @@       | Just new <- inlineAble (             countAll fun front + countAll fun back           ) fun args body =-              let f = map (inline fun args new) in+              let f = map (inlineFunction fun args new) in                   inlineHelper (f front, f back)      inlineHelper (front, next:back) = inlineHelper (front ++ [next], back)@@ -745,29 +808,6 @@     inlineAble _ _ _ _ = Nothing  -    inline :: String -> [String] -> JS -> JS -> JS-    inline 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)--     nonRecur :: String -> JS -> Bool     nonRecur name body = countInvokations name body == 0 @@ -1154,7 +1194,7 @@  removeInstanceChecks :: JS -> JS removeInstanceChecks (JSCond conds) =-  JSCond $ eliminateDeadBranches $ map (+  removeNoopConds $ JSCond $ eliminateDeadBranches $ map (     removeHelper *** removeInstanceChecks   ) conds   where@@ -1169,6 +1209,11 @@     eliminateDeadBranches (x:xs)            = x : eliminateDeadBranches xs     eliminateDeadBranches []                = [] ++    removeNoopConds :: JS -> JS+    removeNoopConds (JSCond [(JSNoop, js)]) = js+    removeNoopConds js                      = js+ removeInstanceChecks js = transformJS removeInstanceChecks js  @@ -1373,6 +1418,67 @@         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@@ -1436,6 +1542,7 @@          match :: JS -> Bool         match (JSIdent "__IDRRT__bigInt") = True+        match (JSWord (JSWord64 _))       = True         match (JSNum (JSInteger _))       = True         match js                          = False @@ -1473,6 +1580,8 @@           , extractLocalConstructors           , unfoldLookupTable           , evalCons+          , elimConds+          , removeUselessCons           ]      functions :: [String]@@ -1494,24 +1603,37 @@      mainLoop :: JS     mainLoop =-      JSAlloc "main" $ Just $ JSFunction [] (-        case target of-             Node       -> mainFun-             JavaScript -> JSCond [(isReady, mainFun), (JSTrue, jsMeth (JSIdent "window") "addEventListener" [-                 JSString "DOMContentLoaded", JSFunction [] (-                   mainFun-                 ), JSFalse-               ])]+        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" -        isReady :: JS-        isReady = readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"+        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" @@ -1628,6 +1750,10 @@ 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 @@ -1804,6 +1930,10 @@ 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]@@ -1845,6 +1975,435 @@   | (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@@ -1879,7 +2438,7 @@   , (arg:_)     <- vars = JSPreOp "~" (JSVar arg)    | LStrConcat  <- op-  , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs+  , (lhs:rhs:_) <- vars = invokeMeth lhs "concat" [rhs]   | LStrEq      <- op   , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs   | LStrLt      <- op@@ -1908,9 +2467,9 @@   | (LFloatInt ITNative)    <- op   , (arg:_)                 <- vars = JSVar arg   | (LChInt ITNative)       <- op-  , (arg:_)                 <- vars = JSProj (JSVar arg) "charCodeAt(0)"+  , (arg:_)                 <- vars = jsCall "__IDRRT__charCode" [JSVar arg]   | (LIntCh ITNative)       <- op-  , (arg:_)                 <- vars = jsCall "String.fromCharCode" [JSVar arg]+  , (arg:_)                 <- vars = jsCall "__IDRRT__fromCharCode" [JSVar arg]    | LFExp       <- op   , (arg:_)     <- vars = jsCall "Math.exp" [JSVar arg]@@ -1936,7 +2495,7 @@   , (arg:_)     <- vars = jsCall "Math.ceil" [JSVar arg]    | LStrCons    <- op-  , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs+  , (lhs:rhs:_) <- vars = invokeMeth lhs "concat" [rhs]   | LStrHead    <- op   , (arg:_)     <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))   | LStrRev     <- op@@ -1949,12 +2508,14 @@                                 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 = JSBinOp f (JSVar lhs) (JSVar rhs)+    translateBinaryOp f lhs rhs = JSParens $ JSBinOp f (JSVar lhs) (JSVar rhs)       invokeMeth :: LVar -> String -> [LVar] -> JS
src/IRTS/Compiler.hs view
@@ -18,15 +18,29 @@ import IRTS.Inliner  import Idris.AbsSyntax-import Idris.UnusedArgs+import Idris.AbsSyntaxTree+import Idris.ASTUtils+import Idris.Erasure import Idris.Error +import Debug.Trace+ import Idris.Core.TT import Idris.Core.Evaluate import Idris.Core.CaseTree +import Control.Category+import Prelude hiding (id, (.))++import Control.Applicative import Control.Monad.State+import Data.Maybe import Data.List+import Data.Ord+import Data.IntSet (IntSet)+import qualified Data.IntSet as IS+import qualified Data.Map as M+import qualified Data.Set as S import System.Process import System.IO import System.Directory@@ -37,18 +51,17 @@  compile :: Codegen -> FilePath -> Term -> Idris () compile codegen f tm-   = do checkMVs-        let tmnames = namesUsed (STerm tm)-        usedIn <- mapM (allNames []) tmnames-        let used = [sUN "prim__subBigInt", sUN "prim__addBigInt"] : usedIn-        defsIn <- mkDecls tm (concat used)-        findUnusedArgs (concat used)+   = do checkMVs  -- check for undefined metavariables+        checkTotality -- refuse to compile if there are totality problems+        reachableNames <- performUsageAnalysis         maindef <- irMain tm+        iLOG $ "MAIN: " ++ show maindef         objs <- getObjectFiles codegen         libs <- getLibs codegen         flags <- getFlags codegen         hdrs <- getHdrs codegen         impdirs <- allImportDirs+        defsIn <- mkDecls tm reachableNames         let defs = defsIn ++ [(sMN 0 "runMain", maindef)]         -- iputStrLn $ showSep "\n" (map show defs)         let (nexttag, tagged) = addTags 65536 (liftAll defs)@@ -93,36 +106,57 @@                       case map fst (idris_metavars i) \\ primDefs of                             [] -> return ()                             ms -> ifail $ "There are undefined metavariables: " ++ show ms+        checkTotality = do i <- getIState+                           case idris_totcheckfail i of+                             [] -> return ()+                             ((fc, msg):fs) -> ierror . At fc . Msg $ "Cannot compile:\n  " ++ msg         inDir d h = do let f = d </> h                        ex <- doesFileExist f                        if ex then return f else return h  irMain :: TT Name -> Idris LDecl-irMain tm = do i <- ir tm-               return $ LFun [] (sMN 0 "runMain") [] (LForce i)+irMain tm = do+    i <- irTerm M.empty [] tm+    return $ LFun [] (sMN 0 "runMain") [] (LForce i)  mkDecls :: Term -> [Name] -> Idris [(Name, LDecl)] mkDecls t used     = do i <- getIState-         let ds = filter (\ (n, d) -> n `elem` used || isCon d) $ ctxtAlist (tt_ctxt i)-         mapM traceUnused used+         let ds = filter (\(n, d) -> n `elem` used || isCon d) $ ctxtAlist (tt_ctxt i)          decls <- mapM build ds          return decls  showCaseTrees :: [(Name, LDecl)] -> String-showCaseTrees ds = showSep "\n\n" (map showCT ds)+showCaseTrees = showSep "\n\n" . map showCT . sortBy (comparing defnRank)   where     showCT (n, LFun _ f args lexp)-       = show n ++ " " ++ showSep " " (map show args) ++ " =\n\t "+       = show n ++ " " ++ showSep " " (map show args) ++ " =\n\t"             ++ show lexp     showCT (n, LConstructor c t a) = "data " ++ show n ++ " " ++ show a +    defnRank :: (Name, LDecl) -> String+    defnRank (n, LFun _ _ _ _)       = "1" ++ nameRank n+    defnRank (n, LConstructor _ _ _) = "2" ++ nameRank n++    nameRank :: Name -> String+    nameRank (UN s)   = "1" ++ show s+    nameRank (MN i s) = "2" ++ show s ++ show i+    nameRank (NS n ns) = "3" ++ concatMap show (reverse ns) ++ nameRank n+    nameRank (SN sn) = "4" ++ snRank sn+    nameRank n = "5" ++ show n++    snRank :: SpecialName -> String+    snRank (WhereN i n n') = "1" ++ nameRank n' ++ nameRank n ++ show i+    snRank (InstanceN n args) = "2" ++ nameRank n ++ concatMap show args+    snRank (ParentN n s) = "3" ++ nameRank n ++ show s+    snRank (MethodN n) = "4" ++ nameRank n+    snRank (CaseN n) = "5" ++ nameRank n+    snRank (ElimN n) = "6" ++ nameRank n+    snRank (InstanceCtorN n) = "7" ++ nameRank n+ isCon (TyDecl _ _) = True isCon _ = False -class ToIR a where-    ir :: a -> Idris LExp- build :: (Name, Def) -> Idris (Name, LDecl) build (n, d)     = do i <- getIState@@ -135,295 +169,468 @@                       logLvl 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def                       return (n, def) -getPrim :: IState -> Name -> [LExp] -> Maybe LExp-getPrim i n args = case lookup n (idris_scprims i) of-                        Just (ar, op) ->-                           if (ar == length args)-                             then return (LOp op args)-                             else Nothing-                        _ -> Nothing- declArgs args inl n (LLam xs x) = declArgs (args ++ xs) inl n x declArgs args inl n x = LFun (if inl then [Inline] else []) n args x -mkLDecl n (Function tm _) = do e <- ir tm-                               return (declArgs [] True n e)+mkLDecl n (Function tm _)+    = declArgs [] True n <$> irTerm M.empty [] tm+ mkLDecl n (CaseOp ci _ _ _ pats cd)-   = let (args, sc) = cases_runtime cd in-         do e <- ir (args, sc)-            return (declArgs [] (case_inlinable ci) n e)-mkLDecl n (TyDecl (DCon t a) _) = return $ LConstructor n t a+    = declArgs [] (case_inlinable ci) n <$> irTree args sc+  where+    (args, sc) = cases_runtime cd++mkLDecl n (TyDecl (DCon tag arity) _) =+    LConstructor n tag . length <$> fgetState (cg_usedpos . ist_callgraph n)+ mkLDecl n (TyDecl (TCon t a) _) = return $ LConstructor n (-1) a mkLDecl n _ = return $ (declArgs [] True n LNothing) -- postulate, never run -instance ToIR (TT Name) where-    ir tm = ir' [] tm where-      ir' env tm@(App f a)-          | (P _ (UN m) _, args) <- unApply tm,-            m == txt "mkForeignPrim"-              = doForeign env args-          | (P _ (UN u) _, [_, arg]) <- unApply tm,-            u == txt "unsafePerformPrimIO"-              = ir' env arg-            -- TMP HACK - until we get inlining.-          | (P _ (UN r) _, [_, _, _, _, _, arg]) <- unApply tm,-            r == txt "replace"-              = ir' env arg-          -- Laziness, the old way-          | (P _ (UN l) _, [_, arg]) <- unApply tm,-            l == txt "lazy"-              = do arg' <- ir' env arg-                   error "lazy has crept in somehow"---                    return $ LLazyExp arg'-          | (P _ (UN l) _, [_, arg]) <- unApply tm,-            l == txt "force"-              = do arg' <- ir' env arg-                   return $ LForce arg'-          -- Laziness, the new way-          | (P _ (UN l) _, [arg]) <- unApply tm,-            l == txt "Delay"-              = do arg' <- ir' env arg-                   return $ LLazyExp arg'-          | (P _ (UN l) _, [_, _, arg]) <- unApply tm,-            l == txt "Force"-              = do arg' <- ir' env arg-                   return $ LForce arg'-          | (P _ (UN a) _, [_, _, arg]) <- unApply tm,-            a == txt "assert_smaller"-              = ir' env arg-          | (P _ (UN a) _, [_, arg]) <- unApply tm,-            a == txt "assert_total"-              = ir' env arg-          | (P _ (UN p) _, [_, arg]) <- unApply tm,-            p == txt "par"-              = do arg' <- ir' env arg-                   return $ LOp LPar [LLazyExp arg']-          | (P _ (UN pf) _, [arg]) <- unApply tm,-            pf == txt "prim_fork"-              = do arg' <- ir' env arg-                   return $ LOp LFork [LLazyExp arg']-          | (P _ (UN m) _, [_,size,t]) <- unApply tm,-            m == txt "malloc"-              = do size' <- ir' env size-                   t' <- ir' env t-                   return t' -- TODO $ malloc_ size' t'-          | (P _ (UN tm) _, [_,t]) <- unApply tm,-            tm == txt "trace_malloc"-              = do t' <- ir' env t-                   return t' -- TODO-          -- This case is here until we get more general inlining. It's just-          -- a really common case, and the laziness hurts...-          | (P _ (NS (UN be) [b,p]) _, [_,x,(App (P _ (UN d) _) t),-                                            (App (P _ (UN d') _) e)]) <- unApply tm,-            be == txt "boolElim" && d == txt "Delay" && d' == txt "Delay"-               = do x' <- ir' env x-                    t' <- ir' env t-                    e' <- ir' env e-                    return (LCase x' [LConCase 0 (sNS (sUN "False") ["Bool","Prelude"]) [] e',-                                      LConCase 1 (sNS (sUN "True") ["Bool","Prelude"]) [] t'])-          | (P (DCon t a) n _, args) <- unApply tm-              = irCon env t a n args-          | (P (TCon t a) n _, args) <- unApply tm-              = return LNothing-          | (P _ n _, args) <- unApply tm-              = do i <- getIState-                   args' <- mapM (ir' env) args-                   case getPrim i n args' of-                        Just tm -> return tm-                        _ -> do-                                 let collapse-                                        = case lookupCtxtExact n-                                                   (idris_optimisation i) of-                                               Just oi -> collapsible oi-                                               _ -> False-                                 let unused-                                        = case lookupCtxtExact n-                                                      (idris_callgraph i) of-                                               Just (CGInfo _ _ _ _ unusedpos) ->-                                                         unusedpos-                                               _ -> []-                                 if collapse-                                     then return LNothing-                                     else return (LApp False (LV (Glob n))-                                                 (mkUnused unused 0 args'))-          | (f, args) <- unApply tm-              = do f' <- ir' env f-                   args' <- mapM (ir' env) args-                   return (LApp False f' args')-        where mkUnused u i [] = []-              mkUnused u i (x : xs) | i `elem` u = LNothing : mkUnused u (i + 1) xs-                                    | otherwise = x : mkUnused u (i + 1) xs---       ir' env (P _ (NS (UN "Z") ["Nat", "Prelude"]) _)---                         = return $ LConst (BI 0)-      ir' env (P _ n _) = return $ LV (Glob n)-      ir' env (V i)     | i >= 0 && i < length env = return $ LV (Glob (env!!i))-                        | otherwise = ifail $ "IR fail " ++ show i ++ " " ++ show tm-      ir' env (Bind n (Lam _) sc)-          = do let n' = uniqueName n env-               sc' <- ir' (n' : env) sc-               return $ LLam [n'] sc'-      ir' env (Bind n (Let _ v) sc)-          = do sc' <- ir' (n : env) sc-               v' <- ir' env v-               return $ LLet n v' sc'-      ir' env (Bind _ _ _) = return $ LNothing-      ir' env (Proj t i) | i == -1-                             = do t' <- ir' env t-                                  return $ LOp (LMinus (ATInt ITBig)) -                                               [t', LConst (BI 1)]-      ir' env (Proj t i) = do t' <- ir' env t-                              return $ LProj t' i-      ir' env (Constant c) = return $ LConst c-      ir' env (TType _) = return $ LNothing-      ir' env Erased = return $ LNothing-      ir' env Impossible = return $ LNothing---       ir' env _ = return $ LError "Impossible"+data VarInfo = VI+    { viMethod :: Maybe Name+    }+    deriving Show -      irCon env t arity n args-        | length args == arity = buildApp env (LV (Glob n)) args-        | otherwise = let extra = satArgs (arity - length args) in-                          do sc' <- irCon env t arity n-                                        (args ++ map (\n -> P Bound n undefined) extra)-                             return $ LLam extra sc'+type Vars = M.Map Name VarInfo -      satArgs n = map (\i -> sMN i "sat") [1..n]+irTerm :: Vars -> [Name] -> Term -> Idris LExp+irTerm vs env tm@(App f a) = case unApply tm of+    (P _ (UN m) _, args)+        | m == txt "mkForeignPrim"+        -> doForeign vs env args -      buildApp env e [] = return e-      buildApp env e xs = do xs' <- mapM (ir' env) xs-                             return $ LApp False e xs'+    (P _ (UN u) _, [_, arg])+        | u == txt "unsafePerformPrimIO"+        -> irTerm vs env arg -      doForeign :: [Name] -> [TT Name] -> Idris LExp-      doForeign env (_ : fgn : args)-         | (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn-              = let maybeTys = getFTypes fgnArgTys-                    rty = mkIty' ret in-                case maybeTys of-                  Nothing -> ifail $ "Foreign type specification is not a constant list: " ++ show (fgn:args)-                  Just tys -> do-                    args' <- mapM (ir' env) (init args)-                    -- wrap it in a prim__IO-                    -- return $ con_ 0 @@ impossible @@-                    return $ -- LLazyExp $-                      LForeign LANG_C rty fgnName (zip tys args')-         | otherwise = ifail "Badly formed foreign function call"+    -- TMP HACK - until we get inlining.+    (P _ (UN r) _, [_, _, _, _, _, arg])+        | r == txt "replace"+        -> irTerm vs env arg -getFTypes :: TT Name -> Maybe [FType]-getFTypes tm = case unApply tm of-                 (nil, []) -> Just []-                 (cons, [ty, xs]) ->-                     fmap (mkIty' ty :) (getFTypes xs)-                 _ -> Nothing+    -- Laziness, the old way+    (P _ (UN l) _, [_, arg])+        | l == txt "lazy"+        -> error "lazy has crept in somehow" -mkIty' (P _ (UN ty) _) = mkIty (str ty)-mkIty' (App (P _ (UN fi) _) (P _ (UN intTy) _))-   | fi == txt "FIntT" = mkIntIty (str intTy)-mkIty' (App (App (P _ (UN ff) _) _) (App (P _ (UN fa) _) (App (P _ (UN io) _) _))) -   | ff == txt "FFunction" && fa == txt "FAny" &&-     io == txt "IO" +    (P _ (UN l) _, [_, arg])+        | l == txt "force"+        -> LForce <$> irTerm vs env arg++    -- Laziness, the new way+    (P _ (UN l) _, [_, _, arg])+        | l == txt "Delay"+        -> LLazyExp <$> irTerm vs env arg++    (P _ (UN l) _, [_, _, arg])+        | l == txt "Force"+        -> LForce <$> irTerm vs env arg++    (P _ (UN a) _, [_, _, _, arg])+        | a == txt "assert_smaller"+        -> irTerm vs env arg++    (P _ (UN a) _, [_, arg])+        | a == txt "assert_total"+        -> irTerm vs env arg++    (P _ (UN p) _, [_, arg])+        | p == txt "par"+        -> do arg' <- irTerm vs env arg+              return $ LOp LPar [LLazyExp arg']++    (P _ (UN pf) _, [arg])+        | pf == txt "prim_fork"+        -> do arg' <- irTerm vs env arg+              return $ LOp LFork [LLazyExp arg']++    (P _ (UN m) _, [_,size,t])+        | m == txt "malloc"+        -> irTerm vs env t++    (P _ (UN tm) _, [_,t])+        | tm == txt "trace_malloc"+        -> irTerm vs env t -- TODO++    -- This case is here until we get more general inlining. It's just+    -- a really common case, and the laziness hurts...+    (P _ (NS (UN be) [b,p]) _, [_,x,(App (App (App (P _ (UN d) _) _) _) t),+                                    (App (App (App (P _ (UN d') _) _) _) e)])+        | be == txt "boolElim"+        , d  == txt "Delay"+        , d' == txt "Delay"+        -> do+            x' <- irTerm vs env x+            t' <- irTerm vs env t+            e' <- irTerm vs env e+            return (LCase x' [LConCase 0 (sNS (sUN "False") ["Bool","Prelude"]) [] e'+                             ,LConCase 1 (sNS (sUN "True" ) ["Bool","Prelude"]) [] t'+                             ])++    -- data constructor+    (P (DCon t arity) n _, args) -> do+        detag <- fgetState (opt_detaggable . ist_optimisation n)+        used  <- map fst <$> fgetState (cg_usedpos . ist_callgraph n)++        let isNewtype = length used == 1 && detag+        let argsPruned = [a | (i,a) <- zip [0..] args, i `elem` used]++        -- The following code removes fields from data constructors+        -- and performs the newtype optimisation.+        --+        -- The general rule here is:+        -- Everything we get as input is not touched by erasure,+        -- so it conforms to the official arities and types+        -- and we can reason about it like it's plain TT.+        --+        -- It's only the data that leaves this point that's erased+        -- and possibly no longer typed as the original TT version.+        --+        -- Especially, underapplied constructors must yield functions+        -- even if all the remaining arguments are erased+        -- (the resulting function *will* be applied, to NULLs).+        --+        -- This will probably need rethinking when we get erasure from functions.++        -- "padLams" will wrap our term in LLam-bdas and give us+        -- the "list of future unerased args" coming from these lambdas.+        --+        -- We can do whatever we like with the list of unerased args,+        -- hence it takes a lambda: \unerased_argname_list -> resulting_LExp.+        let padLams = padLambdas used (length args) arity++        case compare arity (length args) of++            -- overapplied+            GT  -> ifail ("overapplied data constructor: " ++ show tm)++            -- exactly saturated+            EQ  | isNewtype+                -> irTerm vs env (head argsPruned)++                | otherwise  -- not newtype, plain data ctor+                -> buildApp (LV $ Glob n) argsPruned++            -- not saturated, underapplied+            LT  | isNewtype               -- newtype+                , length argsPruned == 1  -- and we already have the value+                -> padLams . (\tm [] -> tm)  -- the [] asserts there are no unerased args+                    <$> irTerm vs env (head argsPruned)++                | isNewtype  -- newtype but the value is not among args yet+                -> return . padLams $ \[vn] -> LApp False (LV $ Glob n) [LV $ Glob vn]++                -- not a newtype, just apply to a constructor+                | otherwise+                -> padLams . applyToNames <$> buildApp (LV $ Glob n) argsPruned++    -- type constructor+    (P (TCon t a) n _, args) -> return LNothing++    -- a name applied to arguments+    (P _ n _, args) -> do+        ist <- getIState+        case lookup n (idris_scprims ist) of+            -- if it's a primitive that is already saturated,+            -- compile to the corresponding op here already to save work+            Just (arity, op) | length args == arity+                -> LOp op <$> mapM (irTerm vs env) args++            -- otherwise, just apply the name+            _   -> applyName n ist args++    -- turn de bruijn vars into regular named references and try again+    (V i, args) -> irTerm vs env $ mkApp (P Bound (env !! i) Erased) args++    (f, args)+        -> LApp False+            <$> irTerm vs env f+            <*> mapM (irTerm vs env) args++  where+    buildApp :: LExp -> [Term] -> Idris LExp+    buildApp e [] = return e+    buildApp e xs = LApp False e <$> mapM (irTerm vs env) xs++    applyToNames :: LExp -> [Name] -> LExp+    applyToNames tm [] = tm+    applyToNames tm ns = LApp False tm $ map (LV . Glob) ns++    padLambdas :: [Int] -> Int -> Int -> ([Name] -> LExp) -> LExp+    padLambdas used startIdx endSIdx mkTerm+        = LLam allNames $ mkTerm nonerasedNames+      where+        allNames       = [sMN i "sat" | i <- [startIdx .. endSIdx-1]]+        nonerasedNames = [sMN i "sat" | i <- [startIdx .. endSIdx-1], i `elem` used]++    applyName :: Name -> IState -> [Term] -> Idris LExp+    applyName n ist args =+        LApp False (LV $ Glob n) <$> mapM (irTerm vs env . erase) (zip [0..] args)+      where+        erase (i, x)+            | i >= arity || i `elem` used = x+            | otherwise = Erased++        arity = case fst4 <$> lookupCtxtExact n (definitions . tt_ctxt $ ist) of+            Just (CaseOp ci ty tys def tot cdefs) -> length tys+            Just (TyDecl (DCon tag ar) _)         -> ar+            Just (TyDecl Ref ty)                  -> length $ getArgTys ty+            Just (Operator ty ar op)              -> ar+            Just def -> error $ "unknown arity: " ++ show (n, def)+            Nothing  -> 0  -- no definition, probably local name => can't erase anything++        -- name for purposes of usage info lookup+        uName+            | Just n' <- viMethod =<< M.lookup n vs = n'+            | otherwise = n++        used = maybe [] (map fst . usedpos) $ lookupCtxtExact uName (idris_callgraph ist)+        fst4 (x,_,_,_) = x++irTerm vs env (P _ n _) = return $ LV (Glob n)+irTerm vs env (V i)+    | i >= 0 && i < length env = return $ LV (Glob (env!!i))+    | otherwise = ifail $ "bad de bruijn index: " ++ show i++irTerm vs env (Bind n (Lam _) sc) = LLam [n'] <$> irTerm vs (n':env) sc+  where+    n' = uniqueName n env++irTerm vs env (Bind n (Let _ v) sc)+    = LLet n <$> irTerm vs env v <*> irTerm vs (n : env) sc++irTerm vs env (Bind _ _ _) = return $ LNothing++irTerm vs env (Proj t (-1)) = do+    t' <- irTerm vs env t+    return $ LOp (LMinus (ATInt ITBig)) +                 [t', LConst (BI 1)]++irTerm vs env (Proj t i)   = LProj <$> irTerm vs env t <*> pure i+irTerm vs env (Constant c) = return $ LConst c+irTerm vs env (TType _)    = return $ LNothing+irTerm vs env Erased       = return $ LNothing+irTerm vs env Impossible   = return $ LNothing++doForeign :: Vars -> [Name] -> [TT Name] -> Idris LExp+doForeign vs env (_ : fgn : args)+    | (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn+    = case getFTypes fgnArgTys of+        Nothing -> ifail $ "Foreign type specification is not a constant list: " ++ show (fgn:args)+        Just tys -> do+            args' <- mapM (irTerm vs env) (init args)+            return $ LForeign LANG_C (mkIty' ret) fgnName (zip tys args')++    | otherwise = ifail "Badly formed foreign function call"+  where+    getFTypes :: TT Name -> Maybe [FType]+    getFTypes tm = case unApply tm of+        -- nil : {a : Type} -> List a+        (nil,  [_])         -> Just []+        -- cons : {a : Type} -> a -> List a -> List a+        (cons, [_, ty, xs]) -> (mkIty' ty :) <$> getFTypes xs+        _ -> Nothing++    mkIty' (P _ (UN ty) _) = mkIty (str ty)+    mkIty' (App (P _ (UN fi) _) (P _ (UN intTy) _))+        | fi == txt "FIntT"+        = mkIntIty (str intTy)++    mkIty' (App (App (P _ (UN ff) _) _) (App (P _ (UN fa) _) (App (P _ (UN io) _) _))) +        | ff == txt "FFunction"+        , fa == txt "FAny"+        , io == txt "IO"          = FFunctionIO-mkIty' (App (App (P _ (UN ff) _) _) _) -   | ff == txt "FFunction" = FFunction-mkIty' _ = FAny --- would be better if these FInt types were evaluated at compile time--- TODO: add %eval directive for such things+    mkIty' (App (App (P _ (UN ff) _) _) _) +        | ff == txt "FFunction"+        = FFunction -mkIty "FFloat"      = FArith ATFloat-mkIty "FInt"        = mkIntIty "ITNative"-mkIty "FChar"       = mkIntIty "ITChar"-mkIty "FByte"       = mkIntIty "IT8"-mkIty "FShort"      = mkIntIty "IT16"-mkIty "FLong"       = mkIntIty "IT64"-mkIty "FBits8"      = mkIntIty "IT8"-mkIty "FBits16"     = mkIntIty "IT16"-mkIty "FBits32"     = mkIntIty "IT32"-mkIty "FBits64"     = mkIntIty "IT64"-mkIty "FString"     = FString-mkIty "FPtr"        = FPtr-mkIty "FManagedPtr" = FManagedPtr-mkIty "FUnit"       = FUnit-mkIty "FFunction"   = FFunction-mkIty "FFunctionIO" = FFunctionIO-mkIty "FBits8x16"   = FArith (ATInt (ITVec IT8 16))-mkIty "FBits16x8"   = FArith (ATInt (ITVec IT16 8))-mkIty "FBits32x4"   = FArith (ATInt (ITVec IT32 4))-mkIty "FBits64x2"   = FArith (ATInt (ITVec IT64 2))-mkIty x             = error $ "Unknown type " ++ x+    mkIty' _ = FAny -mkIntIty "ITNative" = FArith (ATInt ITNative)-mkIntIty "ITChar" = FArith (ATInt ITChar)-mkIntIty "IT8"  = FArith (ATInt (ITFixed IT8))-mkIntIty "IT16" = FArith (ATInt (ITFixed IT16))-mkIntIty "IT32" = FArith (ATInt (ITFixed IT32))-mkIntIty "IT64" = FArith (ATInt (ITFixed IT64))+    -- would be better if these FInt types were evaluated at compile time+    -- TODO: add %eval directive for such things -zname = sNS (sUN "Z") ["Nat","Prelude"]-sname = sNS (sUN "S") ["Nat","Prelude"]+    mkIty "FFloat"      = FArith ATFloat+    mkIty "FInt"        = mkIntIty "ITNative"+    mkIty "FChar"       = mkIntIty "ITChar"+    mkIty "FByte"       = mkIntIty "IT8"+    mkIty "FShort"      = mkIntIty "IT16"+    mkIty "FLong"       = mkIntIty "IT64"+    mkIty "FBits8"      = mkIntIty "IT8"+    mkIty "FBits16"     = mkIntIty "IT16"+    mkIty "FBits32"     = mkIntIty "IT32"+    mkIty "FBits64"     = mkIntIty "IT64"+    mkIty "FString"     = FString+    mkIty "FPtr"        = FPtr+    mkIty "FManagedPtr" = FManagedPtr+    mkIty "FUnit"       = FUnit+    mkIty "FFunction"   = FFunction+    mkIty "FFunctionIO" = FFunctionIO+    mkIty "FBits8x16"   = FArith (ATInt (ITVec IT8 16))+    mkIty "FBits16x8"   = FArith (ATInt (ITVec IT16 8))+    mkIty "FBits32x4"   = FArith (ATInt (ITVec IT32 4))+    mkIty "FBits64x2"   = FArith (ATInt (ITVec IT64 2))+    mkIty x             = error $ "Unknown type " ++ x -instance ToIR ([Name], SC) where-    ir (args, tree) = do logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree-                         tree' <- ir tree-                         return $ LLam args tree'+    mkIntIty "ITNative" = FArith (ATInt ITNative)+    mkIntIty "ITChar" = FArith (ATInt ITChar)+    mkIntIty "IT8"  = FArith (ATInt (ITFixed IT8))+    mkIntIty "IT16" = FArith (ATInt (ITFixed IT16))+    mkIntIty "IT32" = FArith (ATInt (ITFixed IT32))+    mkIntIty "IT64" = FArith (ATInt (ITFixed IT64)) -instance ToIR SC where-    ir t = ir' t where+irTree :: [Name] -> SC -> Idris LExp+irTree args tree = do+    logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree+    LLam args <$> irSC M.empty tree -        ir' (STerm t) = ir t-        ir' (UnmatchedCase str) = return $ LError str-        ir' (ProjCase tm alts) = do tm' <- ir tm-                                    alts' <- mapM (mkIRAlt tm') alts-                                    return $ LCase tm' alts'-        ir' (Case n alts) = do alts' <- mapM (mkIRAlt (LV (Glob n))) alts-                               return $ LCase (LV (Glob n)) alts'-        ir' ImpossibleCase = return LNothing+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+    return $ LCase tm' alts' -        -- special cases for Z and S-        -- Needs rethink: projections make this fail---         mkIRAlt n (ConCase z _ [] rhs) | z == zname---              = mkIRAlt n (ConstCase (BI 0) rhs)---         mkIRAlt n (ConCase s _ [arg] rhs) | s == sname---              = do n' <- ir n---                   rhs' <- ir rhs---                   return $ LDefaultCase---                               (LLet arg (LOp LBMinus [n', LConst (BI 1)])---                                           rhs')-        mkIRAlt _ (ConCase n t args rhs)-             = do rhs' <- ir rhs-                  return $ LConCase (-1) n args rhs'-        mkIRAlt _ (ConstCase x rhs)-          | matchable x-             = do rhs' <- ir rhs-                  return $ LConstCase x rhs'-          | matchableTy x-             = do rhs' <- ir rhs-                  return $ LDefaultCase rhs'-        mkIRAlt tm (SucCase n rhs)-           = do rhs' <- ir rhs-                return $ LDefaultCase (LLet n (LOp (LMinus (ATInt ITBig))-                                                 [tm,-                                                  LConst (BI 1)]) rhs')---                 return $ LSucCase n rhs'-        mkIRAlt _ (ConstCase c rhs)-           = ifail $ "Can't match on (" ++ show c ++ ")"-        mkIRAlt _ (DefaultCase rhs)-           = do rhs' <- ir rhs-                return $ LDefaultCase rhs'+-- 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 -        matchable (I _) = True-        matchable (BI _) = True-        matchable (Ch _) = True-        matchable (Str _) = True-        matchable _ = False+-- There are two transformations in this case:+--+--  1. Newtype-case elimination:+--      case {e0} of+--          wrap({e1}) -> P({e1})   ==>   P({e0})+--+-- This is important because newtyped constructors are compiled away entirely+-- and we need to do that everywhere.+--+--  2. Unused-case elimination (only valid for singleton branches):+--      case {e0} of                                ==>     P+--          C(x,y) -> P[... x,y not used ...]+--+-- This is important for runtime because sometimes we case on irrelevant data:+--+-- In the example above, {e0} will most probably have been erased+-- so this vain projection would make the resulting program segfault+-- because the code generator still emits a PROJECT(...) G-machine instruction.+--+-- Hence, we check whether the variables are used at all+-- and erase the casesplit if they are not.+--+irSC vs (Case n [alt]) = do+    replacement <- case alt of+        ConCase cn a ns sc -> do+            detag <- fgetState (opt_detaggable . ist_optimisation cn)+            used  <- map fst <$> fgetState (cg_usedpos . ist_callgraph cn)+            if detag && length used == 1+                then return . Just $ substSC (ns !! head used) n sc+                else return Nothing+        _ -> return Nothing -        matchableTy (AType (ATInt ITNative)) = True-        matchableTy (AType (ATInt ITBig)) = True-        matchableTy (AType (ATInt ITChar)) = True-        matchableTy StrType = True+    case replacement of+        Just sc -> irSC vs sc+        _ -> do+            alt' <- irAlt vs (LV (Glob n)) alt+            return $ case namesBoundIn alt' `usedIn` subexpr alt' of+                [] -> subexpr alt'  -- strip the unused top-most case+                _  -> LCase (LV (Glob n)) [alt']+  where+    namesBoundIn :: LAlt -> [Name]+    namesBoundIn (LConCase cn i ns sc) = ns+    namesBoundIn (LConstCase c sc)     = []+    namesBoundIn (LDefaultCase sc)     = [] -        matchableTy (AType (ATInt (ITFixed IT8)))  = True-        matchableTy (AType (ATInt (ITFixed IT16))) = True-        matchableTy (AType (ATInt (ITFixed IT32))) = True-        matchableTy (AType (ATInt (ITFixed IT64))) = True+    subexpr :: LAlt -> LExp+    subexpr (LConCase _ _ _ e) = e+    subexpr (LConstCase _   e) = e+    subexpr (LDefaultCase   e) = e -        matchableTy _ = False+-- FIXME: When we have a non-singleton case-tree of the form+--+--     case {e0} of+--         C(x) => ...+--         ...  => ...+--+-- and C is detaggable (the only constructor of the family), we can be sure+-- that the first branch will be always taken -- so we add special handling+-- to remove the dead default branch.+--+-- If we don't do so and C is newtype-optimisable, we will miss this newtype+-- transformation and the resulting code will probably segfault.+--+-- This work-around is not entirely optimal; the best approach would be+-- to ensure that such case trees don't arise in the first place.+--+irSC vs (Case n alts@[ConCase cn a ns sc, DefaultCase sc']) = do+    detag <- fgetState (opt_detaggable . ist_optimisation cn)+    if detag+        then irSC vs (Case n [ConCase cn a ns sc])+        else LCase (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts +irSC vs sc@(Case n alts) = do+    -- check that neither alternative needs the newtype optimisation,+    -- see comment above+    goneWrong <- or <$> mapM isDetaggable alts+    when goneWrong+        $ ifail ("irSC: non-trivial case-match on detaggable data: " ++ show sc)++    -- everything okay+    LCase (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts+  where+    isDetaggable (ConCase cn _ _ _) = fgetState $ opt_detaggable . ist_optimisation cn+    isDetaggable  _                 = return False++irSC vs ImpossibleCase = return LNothing++irAlt :: Vars -> LExp -> CaseAlt -> Idris LAlt++-- this leaves out all unused arguments of the constructor+irAlt vs _ (ConCase n t args sc) = do+    used <- map fst <$> fgetState (cg_usedpos . ist_callgraph n)+    let usedArgs = [a | (i,a) <- zip [0..] args, i `elem` used]+    LConCase (-1) n usedArgs <$> irSC (methodVars `M.union` vs) sc+  where+    methodVars = case n of+        SN (InstanceCtorN className)+            -> M.fromList [(v, VI+                { viMethod = Just $ mkFieldName n i+                }) | (v,i) <- zip args [0..]]+        _+            -> M.empty -- not an instance constructor++irAlt vs _ (ConstCase x rhs)+    | matchable   x = LConstCase x <$> irSC vs rhs+    | matchableTy x = LDefaultCase <$> irSC vs rhs+  where+    matchable (I _) = True+    matchable (BI _) = True+    matchable (Ch _) = True+    matchable (Str _) = True+    matchable _ = False++    matchableTy (AType (ATInt ITNative)) = True+    matchableTy (AType (ATInt ITBig)) = True+    matchableTy (AType (ATInt ITChar)) = True+    matchableTy StrType = True++    matchableTy (AType (ATInt (ITFixed IT8)))  = True+    matchableTy (AType (ATInt (ITFixed IT16))) = True+    matchableTy (AType (ATInt (ITFixed IT32))) = True+    matchableTy (AType (ATInt (ITFixed IT64))) = True++    matchableTy _ = False++irAlt vs tm (SucCase n rhs) = do+    rhs' <- irSC vs rhs+    return $ LDefaultCase (LLet n (LOp (LMinus (ATInt ITBig))+                                            [tm,+                                            LConst (BI 1)]) rhs')++irAlt vs _ (ConstCase c rhs)+    = ifail $ "Can't match on (" ++ show c ++ ")"++irAlt vs _ (DefaultCase rhs)+    = LDefaultCase <$> irSC vs rhs
src/IRTS/Defunctionalise.hs view
@@ -195,7 +195,7 @@                 (DApp False n (map (DV . Glob) (take i (genArgs 0))))))))           : [] -- mkApplyCase n 0 i     | otherwise = []-  where dupdate tlarg x = x+  where dupdate tlarg x = DUpdate tlarg x  toConsA :: [(Name, Int)] -> (Name, Int) -> [(Name, Int, EvalApply DAlt)] toConsA ns (n, i)
src/IRTS/Lang.hs view
@@ -55,6 +55,8 @@             -- Buffers             | LAllocate             | LAppendBuffer+            -- system info+            | LSystemInfo             -- Note that for Bits8 only Native endianness is actually used             -- and the user-exposed interface for Bits8 doesn't mention             -- endianness@@ -213,36 +215,61 @@ usedIn env _ = []  instance Show LExp where-   show e = show' [] e where-     show' env (LV (Loc i)) = env!!i-     show' env (LV (Glob n)) = show n-     show' env (LLazyApp e args) = show e ++ "|(" ++-                                     showSep ", " (map (show' env) args) ++")"-     show' env (LApp _ e args) = show' env e ++ "(" ++-                                   showSep ", " (map (show' env) args) ++")"-     show' env (LLazyExp e) = "%lazy(" ++ show' env e ++ ")"-     show' env (LForce e) = "%force(" ++ show' env e ++ ")"-     show' env (LLet n v e) = "let " ++ show n ++ " = " ++ show' env v ++ " in " ++-                               show' (env ++ [show n]) e-     show' env (LLam args e) = "\\ " ++ showSep "," (map show args) ++ " => " ++-                                 show' (env ++ (map show args)) e-     show' env (LProj t i) = show t ++ "!" ++ show i-     show' env (LCon i n args) = show n ++ ")" ++ showSep ", " (map (show' env) args) ++ ")"-     show' env (LCase e alts) = "case " ++ show' env e ++ " of {\n\t" ++-                                    showSep "\n\t| " (map (showAlt env) alts)-     show' env (LConst c) = show c-     show' env (LForeign lang ty n args)-           = "foreign " ++ n ++ "(" ++ showSep ", " (map (show' env) (map snd args)) ++ ")"-     show' env (LOp f args) = show f ++ "(" ++ showSep ", " (map (show' env) args) ++ ")"-     show' env (LError str) = "error " ++ show str-     show' env LNothing = "____"+   show e = show' [] "" e where+     show' env ind (LV (Loc i)) = env!!i+     show' env ind (LV (Glob n)) = show n -     showAlt env (LConCase _ n args e)-          = show n ++ "(" ++ showSep ", " (map show args) ++ ") => "-             ++ show' env e-     showAlt env (LConstCase c e) = show c ++ " => " ++ show' env e-     showAlt env (LDefaultCase e) = "_ => " ++ show' env e+     show' env ind (LLazyApp e args)+        = show e ++ "|(" ++ showSep ", " (map (show' env ind) args) ++")" +     show' env ind (LApp _ e args)+        = show' env ind e ++ "(" ++ showSep ", " (map (show' env ind) args) ++")" +     show' env ind (LLazyExp e) = "lazy{ "  ++ show' env ind e ++ " }"+     show' env ind (LForce   e) = "force{ " ++ show' env ind e ++ " }"+     show' env ind (LLet n v e)+        = "let " ++ show n ++ " = " ++ show' env ind v+            ++ " in " ++ show' (env ++ [show n]) ind e +     show' env ind (LLam args e)+        = "\\ " ++ showSep "," (map show args)+            ++ " => " ++ show' (env ++ (map show args)) ind e +     show' env ind (LProj t i) = show t ++ "!" ++ show i++     show' env ind (LCon i n args)+        = show n ++ "(" ++ showSep ", " (map (show' env ind) args) ++ ")"++     show' env ind (LCase e alts)+        = "case " ++ show' env ind e ++ " of \n" ++ fmt alts+       where+         fmt [] = ""+         fmt [alt]+            = "\t" ++ ind ++ "| " ++ showAlt env (ind ++ "    ") alt +         fmt (alt:as)+            = "\t" ++ ind ++ "| " ++ showAlt env (ind ++ ".   ") alt+                ++ "\n" ++ fmt as++     show' env ind (LConst c) = show c++     show' env ind (LForeign lang ty n args) = concat+            [ "foreign{ "+            ,       n ++ "("+            ,           showSep ", " (map (\(ty,x) -> show' env ind x ++ " : " ++ show ty) args)+            ,       ") : "+            ,       show ty+            , " }"+            ]++     show' env ind (LOp f args)+        = show f ++ "(" ++ showSep ", " (map (show' env ind) args) ++ ")"++     show' env ind (LError str) = "error " ++ show str+     show' env ind LNothing = "____"++     showAlt env ind (LConCase _ n args e)+          = show n ++ "(" ++ showSep ", " (map show args) ++ ") => "+             ++ show' env ind e++     showAlt env ind (LConstCase c e) = show c ++ " => " ++ show' env ind e+     showAlt env ind (LDefaultCase e) = "_ => " ++ show' env ind e
src/IRTS/Simplified.hs view
@@ -125,15 +125,17 @@          return xs' checkDefs ctxt ((n, DFun n' args exp) : xs)     = do let sexp = evalState (simplify True exp) (ctxt, 0)-         (exp', locs) <- runStateT (scopecheck ctxt (zip args [0..]) sexp) (length args)+         (exp', locs) <- runStateT (scopecheck n ctxt (zip args [0..]) sexp) (length args)          xs' <- checkDefs ctxt xs          return ((n, SFun n' args ((locs + 1) - length args) exp') : xs')  lvar v = do i <- get             put (max i v) -scopecheck :: DDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp-scopecheck ctxt envTop tm = sc envTop tm where+scopecheck :: Name -> DDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp+scopecheck fn ctxt envTop tm = sc envTop tm where+    failsc err = fail $ "Codegen error in " ++ show fn ++ ":" ++ err+     sc env (SV (Glob n)) =        case lookup n (reverse env) of -- most recent first               Just i -> do lvar i; return (SV (Loc i))@@ -141,20 +143,20 @@                               Just (DConstructor _ i ar) ->                                   if True -- ar == 0                                      then return (SCon i n [])-                                     else fail $ "Codegen error: Constructor " ++ show n +++                                     else failsc $ "Constructor " ++ show n ++                                                  " has arity " ++ show ar                               Just _ -> return (SV (Glob n))-                              Nothing -> fail $ "Codegen error: No such variable " ++ show n+                              Nothing -> failsc $ "No such variable " ++ show n     sc env (SApp tc f args)        = do args' <- mapM (scVar env) args             case lookupCtxtExact f ctxt of                 Just (DConstructor n tag ar) ->                     if True -- (ar == length args)                        then return $ SCon tag n args'-                       else fail $ "Codegen error: Constructor " ++ show f +++                       else failsc $ "Constructor " ++ show f ++                                    " has arity " ++ show ar                 Just _ -> return $ SApp tc f args'-                Nothing -> fail $ "Codegen error: No such variable " ++ show f+                Nothing -> failsc $ "No such variable " ++ show f     sc env (SForeign l ty f args)        = do args' <- mapM (\ (t, a) -> do a' <- scVar env a                                           return (t, a')) args@@ -165,9 +167,9 @@                 Just (DConstructor n tag ar) ->                     if True -- (ar == length args)                        then return $ SCon tag n args'-                       else fail $ "Codegen error: Constructor " ++ show f ++-                                   " has arity " ++ show ar-                _ -> fail $ "Codegen error: No such constructor " ++ show f+                       else failsc $ "Constructor " ++ show f +++                                     " has arity " ++ show ar+                _ -> failsc $ "No such constructor " ++ show f     sc env (SProj e i)        = do e' <- scVar env e             return (SProj e' i)@@ -200,9 +202,9 @@               Just i -> do lvar i; return (Loc i)               Nothing -> case lookupCtxtExact n ctxt of                               Just (DConstructor _ i ar) ->-                                  fail $ "Codegen error : can't pass constructor here"+                                  failsc $ "can't pass constructor here"                               Just _ -> return (Glob n)-                              Nothing -> fail $ "Codegen error: No such variable " ++ show n +++                              Nothing -> failsc $ "No such variable " ++ show n ++                                                " in " ++ show tm ++ " " ++ show envTop     scVar _ x = return x @@ -212,9 +214,9 @@                         Just (DConstructor _ i ar) ->                              if True -- (length args == ar)                                 then return i-                                else fail $ "Codegen error: Constructor " ++ show n +++                                else failsc $ "Constructor " ++ show n ++                                             " has arity " ++ show ar-                        _ -> fail $ "Codegen error: No constructor " ++ show n+                        _ -> failsc $ "No constructor " ++ show n             e' <- sc env' e             return (SConCase (length env) tag n args e')     scalt env (SConstCase c e) = do e' <- sc env e
+ src/Idris/ASTUtils.hs view
@@ -0,0 +1,134 @@+module Idris.ASTUtils where++-- This implements just a few basic lens-like concepts to ease state updates.+-- Similar to fclabels in approach, just without the extra dependency.+--+-- We don't include an explicit export list+-- because everything here is meant to be exported.+--+-- Short synopsis:+-- ---------------+--+-- f :: Idris ()+-- f = do+--      -- these two steps:+--      detaggable <- fgetState (opt_detaggable . ist_optimisation typeName)+--      fputState (opt_detaggable . ist_optimisation typeName) (not detaggable)+--+--      -- are equivalent to:+--      fmodifyState (opt_detaggable . ist_optimisation typeName) not+--+--      -- of course, the long accessor can be put in a variable;+--      -- everything is first-class+--      let detag n = opt_detaggable . ist_optimisation n+--      fputState (detag n1) True+--      fputState (detag n2) False+--+--      -- Note that all these operations handle missing items consistently+--      -- and transparently, as prescribed by the default values included+--      -- in the definitions of the ist_* functions.+--      --+--      -- Especially, it's no longer necessary to have initial values of+--      -- data structures copied (possibly inconsistently) all over the compiler.++import Control.Category+import Control.Applicative+import Control.Monad.State.Class+import Data.Maybe+import Prelude hiding (id, (.))++import Idris.Core.TT+import Idris.AbsSyntaxTree++data Field rec fld = Field+    { fget :: rec -> fld+    , fset :: fld -> rec -> rec+    }++fmodify :: Field rec fld -> (fld -> fld) -> rec -> rec+fmodify field f x = fset field (f $ fget field x) x++instance Category Field where+    id = Field id const+    Field g2 s2 . Field g1 s1 = Field (g2 . g1) (\v2 x1 -> s1 (s2 v2 $ g1 x1) x1)++fgetState :: MonadState s m => Field s a -> m a+fgetState field = gets $ fget field++fputState :: MonadState s m => Field s a -> a -> m ()+fputState field x = fmodifyState field (const x)++fmodifyState :: MonadState s m => Field s a -> (a -> a) -> m ()+fmodifyState field f = modify $ fmodify field f++-- Exact-name context lookup; uses Nothing for deleted values (read+write!).+-- +-- Reading a non-existing value yields Nothing,+-- writing Nothing deletes the value (if it existed).+ctxt_lookup :: Name -> Field (Ctxt a) (Maybe a)+ctxt_lookup n = Field+    { fget = lookupCtxtExact n+    , fset = \newVal -> case newVal of+        Just x  -> addDef n x+        Nothing -> deleteDefExact n+    }++-- Maybe-lens with a default value.+maybe_default :: a -> Field (Maybe a) a+maybe_default dflt = Field (fromMaybe dflt) (const . Just)+++-----------------------------------+-- Individual records and fields --+-----------------------------------+--+-- These could probably be generated; let's use lazy addition for now.+--+++-- OptInfo+----------++-- the optimisation record for the given (exact) name+ist_optimisation :: Name -> Field IState OptInfo+ist_optimisation n =+      maybe_default Optimise+        { inaccessible = []+        , detaggable = False+        }+    . ctxt_lookup n+    . Field idris_optimisation (\v ist -> ist{ idris_optimisation = v })++-- two fields of the optimisation record+opt_inaccessible :: Field OptInfo [(Int, Name)]+opt_inaccessible = Field inaccessible (\v opt -> opt{ inaccessible = v })++opt_detaggable :: Field OptInfo Bool+opt_detaggable = Field detaggable (\v opt -> opt{ detaggable = v })+++-- CGInfo+---------++-- callgraph record for the given (exact) name+ist_callgraph :: Name -> Field IState CGInfo+ist_callgraph n =+      maybe_default CGInfo+        { argsdef = [], calls = [], scg = []+        , argsused = [], usedpos = []+        }+    . ctxt_lookup n+    . Field idris_callgraph (\v ist -> ist{ idris_callgraph = v })++-- some fields of the CGInfo record+cg_usedpos :: Field CGInfo [(Int, [UsageReason])]+cg_usedpos = Field usedpos (\v cg -> cg{ usedpos = v })+++-- Commandline flags+--------------------++opts_idrisCmdline :: Field IState [Opt]+opts_idrisCmdline =+      Field opt_cmdline (\v opts -> opts{ opt_cmdline = v })+    . Field idris_options (\v ist -> ist{ idris_options = v })
src/Idris/AbsSyntax.hs view
@@ -388,6 +388,16 @@ putIState :: IState -> Idris () putIState = put +withContext :: (IState -> Ctxt a) -> Name -> b -> (a -> Idris b) -> Idris b+withContext ctx name dflt action = do+    ist <- getIState+    case lookupCtxt name (ctx ist) of+        [x] -> action x+        _   -> return dflt++withContext_ :: (IState -> Ctxt a) -> Name -> (a -> Idris ()) -> Idris ()+withContext_ ctx name action = withContext ctx name () action+ -- | A version of liftIO that puts errors into the exception type of the Idris monad runIO :: IO a -> Idris a runIO x = liftIO (tryIOError x) >>= either (throwError . Msg . show) return@@ -520,7 +530,7 @@   type1Doc :: Doc OutputAnnotation-type1Doc = (annotate AnnConstType $ text "Type 1")+type1Doc = (annotate (AnnType "Type" "The type of types, one level up") $ text "Type 1")   isetPrompt :: String -> Idris ()@@ -528,6 +538,18 @@                   case idris_outputmode i of                     IdeSlave n -> runIO . putStrLn $ convSExp "set-prompt" p n +-- | Tell clients how much was parsed and loaded+isetLoadedRegion :: Idris ()+isetLoadedRegion = do i <- getIState+                      let span = idris_parsedSpan i+                      case span of+                        Just fc ->+                          case idris_outputmode i of+                            IdeSlave n ->+                              runIO . putStrLn $+                                convSExp "set-loaded-region" fc n+                        Nothing -> return ()+ setLogLevel :: Int -> Idris () setLogLevel l = do i <- getIState                    let opts = idris_options i@@ -819,9 +841,9 @@        | otherwise = PLam n (en t) (en s)     en (PPi p n t s)        | n `elem` (map fst ps ++ ns)-               = let n' = mkShadow n in-                     PPi p n' (en t) (en (shadow n n' s))-       | otherwise = PPi p n (en t) (en s)+               = let n' = mkShadow n in -- TODO THINK SHADOWING TacImp?+                     PPi (enTacImp p) n' (en t) (en (shadow n n' s))+       | otherwise = PPi (enTacImp p) n (en t) (en s)     en (PLet n ty v s)        | n `elem` (map fst ps ++ ns)                = let n' = mkShadow n in@@ -880,6 +902,9 @@      nseq x y = nsroot x == nsroot y +    enTacImp (TacImp aos st scr)  = TacImp aos st (en scr)+    enTacImp other                = other+ expandParamsD :: Bool -> -- True = RHS only                  IState ->                  (Name -> Name) -> [(Name, PTerm)] -> [Name] -> PDecl -> PDecl@@ -924,7 +949,7 @@     updateps yn nm [] = []     updateps yn nm (((a, t), i):as)         | (a `elem` nm) == yn = (a, t) : updateps yn nm as-        | otherwise = (sMN i (show n ++ "_u"), t) : updateps yn nm as+        | otherwise = (sMN i ('_' : show n ++ "_u"), t) : updateps yn nm as      removeBound lhs ns = ns \\ nub (bnames lhs) @@ -934,6 +959,7 @@     bnames (PDPair _ _ l Placeholder r) = bnames l ++ bnames r     bnames _ = [] +-- | Expands parameters defined in parameter and where blocks inside of declarations expandParamsD rhs ist dec ps ns (PData doc argDocs syn fc co pd)     = PData doc argDocs syn fc co (expandPData pd)   where@@ -946,12 +972,12 @@             else PDatadecl n (expandParams dec ps ns [] ty) (map econ cons)     econ (doc, argDocs, n, t, fc, fs)        = (doc, argDocs, dec n, piBindp expl ps (expandParams dec ps ns [] t), fc, fs)-expandParamsD rhs ist dec ps ns (PRecord doc syn fc tn tty cdoc cn cty)+expandParamsD rhs ist dec ps ns (PRecord doc syn fc tn tty opts cdoc cn cty)    = if tn `elem` ns         then PRecord doc syn fc (dec tn) (piBind ps (expandParams dec ps ns [] tty))-                     cdoc (dec cn) conty+                     opts cdoc (dec cn) conty         else PRecord doc syn fc (dec tn) (expandParams dec ps ns [] tty)-                     cdoc (dec cn) conty+                     opts cdoc (dec cn) conty    where conty = piBindp expl ps (expandParams dec ps ns [] cty) expandParamsD rhs ist dec ps ns (PParams f params pds)    = PParams f (ps ++ map (mapsnd (expandParams dec ps ns [])) params)@@ -959,11 +985,12 @@ --                (map (expandParamsD ist dec ps ns) pds) expandParamsD rhs ist dec ps ns (PMutual f pds)    = PMutual f (map (expandParamsD rhs ist dec ps ns) pds)-expandParamsD rhs ist dec ps ns (PClass doc info f cs n params decls)+expandParamsD rhs ist dec ps ns (PClass doc info f cs n params pDocs decls)    = PClass doc info f            (map (expandParams dec ps ns []) cs)            n            (map (mapsnd (expandParams dec ps ns [])) params)+           pDocs            (map (expandParamsD rhs ist dec ps ns) decls) expandParamsD rhs ist dec ps ns (PInstance info f cs n params ty cn decls)    = PInstance info f@@ -1076,7 +1103,7 @@              | otherwise = doAdd cs ns t           mkConst c args = PApp fc (PRef fc c)-                             (map (\n -> PExp 0 [] (PRef fc n)) args)+                           (map (\n -> PExp 0 [] (sMN 0 "carg") (PRef fc n)) args)           getConstraints (PPi (Constraint _ _) _ c sc)              = getcapp c ++ getConstraints sc@@ -1088,7 +1115,7 @@                   return (UConstraint c ns)          getcapp _ = [] -         getName (PExp _ _ (PRef _ n)) = return n+         getName (PExp _ _ _ (PRef _ n)) = return n          getName _ = []  -- Add implicit Pi bindings for any names in the term which appear in an@@ -1096,13 +1123,14 @@  -- This has become a right mess already. Better redo it some time... -implicit :: SyntaxInfo -> Name -> PTerm -> Idris PTerm-implicit syn n ptm = implicit' syn [] n ptm+implicit :: ElabInfo -> SyntaxInfo -> Name -> PTerm -> Idris PTerm+implicit info syn n ptm = implicit' info syn [] n ptm -implicit' :: SyntaxInfo -> [Name] -> Name -> PTerm -> Idris PTerm-implicit' syn ignore n ptm+implicit' :: ElabInfo -> SyntaxInfo -> [Name] -> Name -> PTerm -> Idris PTerm+implicit' info syn ignore n ptm     = do i <- getIState          let (tm', impdata) = implicitise syn ignore i ptm+         defaultArgCheck (eInfoNames info ++ M.keys (idris_implicits i)) impdata --          let (tm'', spos) = findStatics i tm'          putIState $ i { idris_implicits = addDef n impdata (idris_implicits i) }          addIBC (IBCImp n)@@ -1110,7 +1138,24 @@ --          i <- get --          putIState $ i { idris_statics = addDef n spos (idris_statics i) }          return tm'+  where+    --  Detect unknown names in default arguments and throw error if found.+    defaultArgCheck :: [Name] -> [PArg] -> Idris ()+    defaultArgCheck knowns params = foldM_ notFoundInDefault knowns params  +    notFoundInDefault :: [Name] -> PArg -> Idris [Name]+    notFoundInDefault kns (PTacImplicit _ _ n script _)+      = do  i <- getIState +            case notFound kns (namesIn [] i script) of+              Nothing     -> return (n:kns)+              Just name   -> throwError (NoSuchVariable name)+    notFoundInDefault kns p = return ((pname p):kns)++    notFound :: [Name] -> [Name] -> Maybe Name+    notFound kns [] = Nothing+    notFound kns (SN (WhereN _ _ _) : ns) = notFound kns ns --  Known already+    notFound kns (n:ns) = if elem n kns then notFound kns ns else Just n+ implicitise :: SyntaxInfo -> [Name] -> IState -> PTerm -> (PTerm, [PArg]) implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $       let (declimps, ns') = execState (imps True [] tm) ([], [])@@ -1155,7 +1200,7 @@                             (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]                             _ -> [])              (decls, ns) <- get -- ignore decls in HO types-             put (PExp (getPriority ist ty) l Placeholder : decls,+             put (PExp (getPriority ist ty) l n Placeholder : decls,                   nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))              imps True (n:env) sc     imps top env (PPi (Constraint l _) n ty sc)@@ -1163,7 +1208,7 @@                             (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]                             _ -> [])              (decls, ns) <- get -- ignore decls in HO types-             put (PConstraint 10 l Placeholder : decls,+             put (PConstraint 10 l n Placeholder : decls,                   nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))              imps True (n:env) sc     imps top env (PPi (TacImp l _ scr) n ty sc)@@ -1284,9 +1329,11 @@             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-            os' = map (pmap (ai env ds)) os in-            PCase fc c' os'+      = let c' = ai 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@@ -1329,7 +1376,7 @@ --                            any constructor alts || any allImp ialts))                         then aiFn inpat False ist fc f ds [] -- use it as a constructor                         else Right $ PPatvar fc f-    where imp (PExp _ _ _) = False+    where imp (PExp _ _ _ _) = False           imp _ = True --           allImp [] = False           allImp xs = all imp xs@@ -1376,27 +1423,41 @@                     [(n,t)] -> t                     _ -> Public -     insertImpl :: [PArg] -> [PArg] -> [PArg]-    insertImpl (PExp p l ty : ps) (PExp _ _ tm : given) =-                                 PExp p l tm : insertImpl ps given-    insertImpl (PConstraint p l ty : ps) (PConstraint _ _ tm : given) =-                                 PConstraint p l tm : insertImpl ps given-    insertImpl (PConstraint p l ty : ps) given =-                 PConstraint p l (PResolveTC fc) : insertImpl ps given-    insertImpl (PImp p _ l n ty : ps) given =+    insertImpl ps as = insImpAcc M.empty ps as++    insImpAcc :: M.Map Name PTerm -- accumulated param names & arg terms+              -> [PArg]           -- parameters+              -> [PArg]           -- arguments+              -> [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 =+      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 : insertImpl ps given'-            Nothing ->           PImp p True l n Placeholder : insertImpl ps given-    insertImpl (PTacImplicit p l n sc' ty : ps) given =-      let sc = addImpl ist sc' in+            Just (tm, given') ->+              PImp p False l n tm : insImpAcc (M.insert n tm pnas) ps given'+            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 =+      let sc = addImpl ist (substMatches (M.toList pnas) sc') in         case find n given [] of-            Just (tm, given') -> PTacImplicit p l n sc tm : insertImpl ps given'-            Nothing -> if inpat-                          then PTacImplicit p l n sc Placeholder : insertImpl ps given-                          else PTacImplicit p l n sc sc : insertImpl ps given-    insertImpl expected [] = []-    insertImpl _        given  = given+            Just (tm, given') ->+              PTacImplicit p l n sc tm :+                insImpAcc (M.insert n tm pnas) ps given'+            Nothing ->+              if inpat+                then PTacImplicit p l n sc Placeholder :+                  insImpAcc (M.insert n Placeholder pnas) ps given+                else PTacImplicit p l n sc sc :+                  insImpAcc (M.insert n sc pnas) ps given+    insImpAcc _ expected [] = []+    insImpAcc _ _        given  = given      find n []               acc = Nothing     find n (PImp _ _ _ n' t : gs) acc@@ -1433,11 +1494,11 @@                               return $ PApp fc fn args'        where slA (PImp p m l n t) = do t' <- sl t                                        return $ PImp p m l n t'-             slA (PExp p l t) = do t' <- sl t-                                   return $ PExp p l t'-             slA (PConstraint p l t)+             slA (PExp p l n t) = do  t' <- sl t+                                      return $ PExp p l n t'+             slA (PConstraint p l n t)                                 = do t' <- sl t-                                     return $ PConstraint p l t'+                                     return $ PConstraint p l n t'              slA (PTacImplicit p l n sc t)                                 = do t' <- sl t                                      return $ PTacImplicit p l n sc t'
src/Idris/AbsSyntaxTree.hs view
@@ -31,11 +31,25 @@ import Data.Either import qualified Data.Set as S import Data.Word (Word)+import Data.Maybe (fromMaybe)  import Debug.Trace  import Text.PrettyPrint.Annotated.Leijen +-- Data to pass to recursively called elaborators; e.g. for where blocks,+-- paramaterised declarations, etc.++data ElabInfo = EInfo { params :: [(Name, PTerm)],+                        inblock :: Ctxt [Name], -- names in the block, and their params+                        liftname :: Name -> Name,+                        namespace :: Maybe [String] }++toplevel = EInfo [] emptyContext id Nothing++eInfoNames :: ElabInfo -> [Name]+eInfoNames info = map fst (params info) ++ M.keys (inblock info)+ data IOption = IOption { opt_logLevel   :: Int,                          opt_typecase   :: Bool,                          opt_typeintype :: Bool,@@ -81,6 +95,28 @@                       , opt_autoSolve  = True                       } +data PPOption = PPOption {+    ppopt_impl :: Bool -- ^^ whether to show implicits+} deriving (Show)++-- | Pretty printing options with default verbosity.+defaultPPOption :: PPOption+defaultPPOption = PPOption { ppopt_impl = False }++-- | Pretty printing options with the most verbosity.+verbosePPOption :: PPOption+verbosePPOption = PPOption { ppopt_impl = True }++-- | Get pretty printing options from the big options record.+ppOption :: IOption -> PPOption+ppOption opt = PPOption {+    ppopt_impl = opt_showimp opt+}++-- | Get pretty printing options from an idris state record.+ppOptionIst :: IState -> PPOption+ppOptionIst = ppOption . idris_options+ data LanguageExt = TypeProviders | ErrorReflection deriving (Show, Eq, Read, Ord)  -- | The output mode in use@@ -111,8 +147,9 @@     idris_calledgraph :: Ctxt [Name],     idris_docstrings :: Ctxt (Docstring, [(Name, Docstring)]),     idris_tyinfodata :: Ctxt TIData,-    idris_totcheck :: [(FC, Name)], -- names to check totality on +    idris_totcheck :: [(FC, Name)], -- names to check totality on     idris_defertotcheck :: [(FC, Name)], -- names to check at the end+    idris_totcheckfail :: [(FC, String)],     idris_options :: IOption,     idris_name :: Int,     idris_lineapps :: [((FilePath, Int), PTerm)],@@ -137,6 +174,7 @@     indent_stack :: [Int],     brace_stack :: [Maybe Int],     lastTokenSpan :: Maybe FC, -- ^ What was the span of the latest token parsed?+    idris_parsedSpan :: Maybe FC,     hide_list :: [(Name, Maybe Accessibility)],     default_access :: Accessibility,     default_total :: Bool,@@ -152,7 +190,10 @@     idris_nameIdx :: (Int, Ctxt (Int, Name)),     idris_function_errorhandlers :: Ctxt (M.Map Name (S.Set Name)), -- ^ Specific error handlers     module_aliases :: M.Map [T.Text] [T.Text],-    idris_consolewidth :: ConsoleWidth -- ^ How many chars wide is the console?+    idris_consolewidth :: ConsoleWidth, -- ^ How many chars wide is the console?+    idris_postulates :: S.Set Name,+    idris_whocalls :: Maybe (M.Map Name [Name]),+    idris_callswho :: Maybe (M.Map Name [Name])    }  data SizeChange = Smaller | Same | Bigger | Unknown@@ -163,12 +204,13 @@ !-}  type SCGEntry = (Name, [Maybe (Int, SizeChange)])+type UsageReason = (Name, Int)  -- fn_name, its_arg_number  data CGInfo = CGInfo { argsdef :: [Name],                        calls :: [(Name, [[Name]])],                        scg :: [SCGEntry],                        argsused :: [Name],-                       unusedpos :: [Int] }+                       usedpos :: [(Int, [UsageReason])] }     deriving Show {-! deriving instance Binary CGInfo@@ -212,6 +254,9 @@               | IBCLineApp FilePath Int PTerm               | IBCErrorHandler Name               | IBCFunctionErrorHandler Name Name Name+              | IBCPostulate Name+              | IBCTotCheckErr FC String+              | IBCParsedRegion FC   deriving Show  -- | The initial state for the compiler@@ -220,10 +265,10 @@                    emptyContext emptyContext emptyContext emptyContext                    emptyContext emptyContext emptyContext emptyContext                    emptyContext emptyContext-                   [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] [] []-                   [] [] Nothing [] Nothing [] [] Nothing [] Hidden False [] Nothing [] [] RawOutput+                   [] [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] [] []+                   [] [] Nothing [] Nothing [] [] Nothing Nothing [] Hidden False [] Nothing [] [] RawOutput                    True defaultTheme stdout [] (0, emptyContext) emptyContext M.empty-                   AutomaticWidth+                   AutomaticWidth S.empty Nothing Nothing  -- | The monad for the main REPL - reading and processing files and updating -- global state (hence the IO inner monad).@@ -245,10 +290,10 @@              | Help              | Eval PTerm              | Check PTerm-             | DocStr Name+             | DocStr (Either Name Const)              | TotCheck Name              | Reload-             | Load FilePath+             | Load FilePath (Maybe Int) -- up to maximum line number              | ChangeDirectory FilePath              | ModImport String              | Edit@@ -267,7 +312,6 @@              | HNF PTerm              | TestInline PTerm              | Defn Name-             | Info Name              | Missing Name              | DynamicLink FilePath              | ListDynamic@@ -279,7 +323,10 @@              | AddProofClauseFrom Bool Int Name              | AddMissing Bool Int Name              | MakeWith Bool Int Name-             | DoProofSearch Bool Int Name [Name]+             | MakeLemma Bool Int Name+             | DoProofSearch Bool Bool Int Name [Name]+               -- ^ the first bool is whether to update,+               -- the second is whether to search recursively (i.e. for the arguments)              | SetOpt Opt              | UnsetOpt Opt              | NOP@@ -289,10 +336,12 @@              | ListErrorHandlers              | SetConsoleWidth ConsoleWidth              | Apropos String+             | WhoCalls Name+             | CallsWho Name+             | MakeDoc String                      -- IdrisDoc + data Opt = Filename String-         | Ver-         | Usage          | Quiet          | NoBanner          | ColourREPL Bool@@ -311,6 +360,7 @@          | DefaultTotal          | DefaultPartial          | WarnPartial+         | WarnReach          | NoCoverage          | ErrContext          | ShowImpl@@ -322,6 +372,7 @@          | PkgClean String          | PkgCheck String          | PkgREPL String+         | PkgMkDoc String     -- IdrisDoc          | WarnOnly          | Pkg String          | BCAsm String@@ -331,6 +382,7 @@          | OutputTy OutputType          | Extension LanguageExt          | InterpretScript String+         | EvalExpr String          | TargetTriple String          | TargetCPU String          | OptLevel Word@@ -386,7 +438,7 @@                      pparam :: Bool }              | Exp { pargopts :: [ArgOpt],                      pstatic :: Static,-                     pparam :: Bool }+                     pparam :: Bool }   -- this is a param (rather than index)              | Constraint { pargopts :: [ArgOpt],                             pstatic :: Static }              | TacImp { pargopts :: [ArgOpt],@@ -394,15 +446,12 @@                         pscript :: PTerm }   deriving (Show, Eq) -plazy :: Plicity -> Bool-plazy tm = Lazy `elem` pargopts tm- {-! deriving instance Binary Plicity deriving instance NFData Plicity !-} -impl = Imp [Lazy] Dynamic False+impl = Imp [] Dynamic False expl = Exp [] Dynamic False expl_param = Exp [] Dynamic True constraint = Constraint [] Dynamic@@ -416,7 +465,7 @@            | Implicit -- implicit coercion            | CExport String    -- export, with a C name            | ErrorHandler     -- ^^ an error handler for use with the ErrorReflection extension-           | ErrorReverse     -- ^^ attempt to reverse normalise before showing in error +           | ErrorReverse     -- ^^ attempt to reverse normalise before showing in error            | Reflection -- a reflecting function, compile-time only            | Specialise [(Name, Maybe Int)] -- specialise it, freeze these names     deriving (Show, Eq)@@ -459,11 +508,12 @@    | PData    Docstring [(Name, Docstring)] SyntaxInfo FC DataOpts (PData' t)  -- ^ Data declaration.    | PParams  FC [(Name, t)] [PDecl' t] -- ^ Params block    | PNamespace String [PDecl' t] -- ^ New namespace-   | PRecord  Docstring SyntaxInfo FC Name t Docstring Name t  -- ^ Record declaration+   | PRecord  Docstring SyntaxInfo FC Name t DataOpts Docstring Name t  -- ^ Record declaration    | PClass   Docstring SyntaxInfo FC               [t] -- constraints               Name               [(Name, t)] -- parameters+              [(Name, Docstring)] -- parameter docstrings               [PDecl' t] -- declarations               -- ^ Type class: arguments are documentation, syntax info, source location, constraints,               -- class name, parameters, method declarations@@ -545,8 +595,8 @@ declared (PData _ _ _ _ _ (PLaterdecl n _)) = [n] declared (PParams _ _ ds) = concatMap declared ds declared (PNamespace _ ds) = concatMap declared ds-declared (PRecord _ _ _ n _ _ c _) = [n, c]-declared (PClass _ _ _ _ n _ ms) = n : concatMap declared ms+declared (PRecord _ _ _ n _ _ _ c _) = [n, c]+declared (PClass _ _ _ _ n _ _ ms) = n : concatMap declared ms declared (PInstance _ _ _ _ _ _ _ _) = [] declared (PDSL n _) = [n] declared (PSyntax _ _) = []@@ -559,13 +609,13 @@ tldeclared (PTy _ _ _ _ _ n t) = [n] tldeclared (PPostulate _ _ _ _ n t) = [n] tldeclared (PClauses _ _ n _) = [] -- not a declaration-tldeclared (PRecord _ _ _ n _ _ c _) = [n, c]+tldeclared (PRecord _ _ _ n _ _ _ c _) = [n, c] tldeclared (PData _ _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts    where fstt (_, _, a, _, _, _) = a tldeclared (PParams _ _ ds) = [] tldeclared (PMutual _ ds) = concatMap tldeclared ds tldeclared (PNamespace _ ds) = concatMap tldeclared ds-tldeclared (PClass _ _ _ _ n _ ms) = concatMap tldeclared ms+tldeclared (PClass _ _ _ _ n _ _ ms) = concatMap tldeclared ms tldeclared (PInstance _ _ _ _ _ _ _ _) = [] tldeclared _ = [] @@ -580,8 +630,8 @@ defined (PData _ _ _ _ _ (PLaterdecl n _)) = [] defined (PParams _ _ ds) = concatMap defined ds defined (PNamespace _ ds) = concatMap defined ds-defined (PRecord _ _ _ n _ _ c _) = [n, c]-defined (PClass _ _ _ _ n _ ms) = n : concatMap defined ms+defined (PRecord _ _ _ n _ _ _ c _) = [n, c]+defined (PClass _ _ _ _ n _ _ ms) = n : concatMap defined ms defined (PInstance _ _ _ _ _ _ _ _) = [] defined (PDSL n _) = [n] defined (PSyntax _ _) = []@@ -618,26 +668,26 @@            | PInferRef FC Name -- ^ A name to be defined later            | PPatvar FC Name            | PLam Name PTerm PTerm-           | PPi  Plicity Name PTerm PTerm+           | PPi  Plicity Name PTerm PTerm -- ^ (n : t1) -> t2            | PLet Name PTerm PTerm PTerm            | PTyped PTerm PTerm -- ^ Term with explicit type-           | PApp FC PTerm [PArg]+           | PApp FC PTerm [PArg] -- ^ e.g. IO (), List Char, length x            | PAppBind FC PTerm [PArg] -- ^ implicitly bound application            | PMatchApp FC Name -- ^ Make an application by type matching            | PCase FC PTerm [(PTerm, PTerm)]-           | PTrue FC PunInfo-           | PFalse FC+           | PTrue FC PunInfo -- ^ Unit type..?+           | PFalse FC -- ^ _|_            | PRefl FC PTerm            | PResolveTC FC-           | PEq FC PTerm PTerm+           | PEq FC PTerm PTerm -- ^ Equality type: A = B            | PRewrite FC PTerm PTerm (Maybe PTerm)            | PPair FC PunInfo PTerm PTerm            | PDPair FC PunInfo PTerm PTerm PTerm            | PAlternative Bool [PTerm] -- True if only one may work            | PHidden PTerm -- ^ Irrelevant or hidden pattern-           | PType+           | PType -- ^ 'Type' type            | PGoal FC PTerm Name PTerm-           | PConstant Const+           | PConstant Const -- ^ Builtin types            | Placeholder            | PDoBlock [PDo]            | PIdiom FC PTerm@@ -686,13 +736,14 @@   data PTactic' t = Intro [Name] | Intros | Focus Name-                | Refine Name [Bool] | Rewrite t+                | Refine Name [Bool] | Rewrite t | DoUnify                 | Induction Name                 | Equiv t                 | MatchRefine Name                 | LetTac Name t | LetTacTy Name t t                 | Exact t | Compute | Trivial | TCInstance-                | ProofSearch (Maybe Name) [Name]+                | ProofSearch Bool Bool Int (Maybe Name) [Name]+                  -- ^ the bool is whether to search recursively                 | Solve                 | Attack                 | ProofState | ProofTerm | Undo@@ -767,9 +818,11 @@                       pname :: Name, getTm :: t }              | PExp { priority :: Int,                       argopts :: [ArgOpt],+                      pname :: Name,                       getTm :: t }              | PConstraint { priority :: Int,                              argopts :: [ArgOpt],+                             pname :: Name,                              getTm :: t }              | PTacImplicit { priority :: Int,                               argopts :: [ArgOpt],@@ -778,16 +831,13 @@                               getTm :: t }     deriving (Show, Eq, Functor) -data ArgOpt = Lazy | HideDisplay+data ArgOpt = HideDisplay | InaccessibleArg     deriving (Show, Eq) -lazyarg :: PArg' t -> Bool-lazyarg tm = Lazy `elem` argopts tm- instance Sized a => Sized (PArg' a) where   size (PImp p _ l nm trm) = 1 + size nm + size trm-  size (PExp p l trm) = 1 + size trm-  size (PConstraint p l trm) = 1 + size trm+  size (PExp p l nm trm) = 1 + size nm + size trm+  size (PConstraint p l nm trm) = 1 + size nm +size nm +  size trm   size (PTacImplicit p l nm scr trm) = 1 + size nm + size scr + size trm  {-!@@ -795,10 +845,10 @@ deriving instance NFData PArg' !-} -pimp n t mach = PImp 1 mach [Lazy] n t-pexp t = PExp 1 [] t-pconst t = PConstraint 1 [] t-ptacimp n s t = PTacImplicit 2 [Lazy] n s t+pimp n t mach = PImp 1 mach [] n t+pexp t = PExp 1 [] (sMN 0 "arg") t+pconst t = PConstraint 1 [] (sMN 0 "carg") t+ptacimp n s t = PTacImplicit 2 [] n s t  type PArg = PArg' PTerm @@ -819,25 +869,11 @@ -- Type inference data  data TIData = TIPartial -- ^ a function with a partially defined type-            | TISolution [Term] -- ^ possible solutions to a metavariable in a type +            | TISolution [Term] -- ^ possible solutions to a metavariable in a type     deriving Show --- An argument is conditionally forceable iff its forceability--- depends on the collapsibility of the whole type.-data Forceability = Conditional | Unconditional deriving (Show, Enum, Bounded, Eq, Ord)--{-!-deriving instance Binary Forceability-deriving instance NFData Forceability-!-}--data OptInfo = Optimise { collapsible :: Bool,-                          isnewtype :: Bool,-                          -- The following should actually be (IntMap Forceability)-                          -- but the corresponding Binary instance seems to be broken.-                          -- Let's store a list and convert it to IntMap whenever needed.-                          forceable :: [(Int, Forceability)],-                          recursive :: [Int] }+data OptInfo = Optimise { inaccessible :: [(Int,Name)],  -- includes names for error reporting+                          detaggable :: Bool }     deriving Show {-! deriving instance Binary OptInfo@@ -848,7 +884,8 @@ data TypeInfo = TI { con_names :: [Name],                      codata :: Bool,                      data_opts :: DataOpts,-                     param_pos :: [Int] }+                     param_pos :: [Int],+                     mutual_types :: [Name] }     deriving Show {-! deriving instance Binary TypeInfo@@ -926,6 +963,8 @@                         decoration :: Name -> Name,                         inPattern :: Bool,                         implicitAllowed :: Bool,+                        maxline :: Maybe Int,+                        mut_nesting :: Int,                         dsl_info :: DSL }     deriving Show {-!@@ -933,7 +972,7 @@ deriving instance Binary SyntaxInfo !-} -defaultSyntax = Syn [] [] [] [] id False False initDSL+defaultSyntax = Syn [] [] [] [] id False False Nothing 0 initDSL  expandNS :: SyntaxInfo -> Name -> Name expandNS syn n@(NS _ _) = n@@ -977,46 +1016,86 @@              falseTy, pairTy, pairCon,              eqTy, eqCon, inferTy, inferCon] +unitDoc = parseDocstring . T.pack $ "The canonical single-element type, also known as the trivially true proposition." unitTy   = sMN 0 "__Unit" unitCon  = sMN 0 "__II" unitDecl = PDatadecl unitTy PType-                     [(emptyDocstring, [], unitCon, PRef bi unitTy, bi, [])]+                     [(parseDocstring . T.pack $ "The trivial constructor for `()`. ", [], unitCon, PRef bi unitTy, bi, [])] unitOpts = [DefaultEliminator] +falseDoc = parseDocstring . T.pack $+             "The empty type, also known as the trivially false proposition." +++             "\n\n" +++             "Use `FalseElim` or `absurd` to prove anything if you have a variable " +++             "of type `_|_` in scope." falseTy   = sMN 0 "__False" falseDecl = PDatadecl falseTy PType [] falseOpts = [] +pairDoc   = parseDocstring . T.pack $ "The non-dependent pair type, also known as conjunction." pairTy    = sMN 0 "__Pair" pairCon   = sMN 0 "__MkPair" pairDecl  = PDatadecl pairTy (piBind [(n "A", PType), (n "B", PType)] PType)-            [(emptyDocstring, [], pairCon, PPi impl (n "A") PType (-                                       PPi impl (n "B") PType (-                                       PPi expl (n "a") (PRef bi (n "A")) (-                                       PPi expl (n "b") (PRef bi (n "B"))-                                           (PApp bi (PRef bi pairTy) [pexp (PRef bi (n "A")),-                                                                pexp (PRef bi (n "B"))])))), bi, [])]+            [(pairConDoc, pairConParamDoc,+             pairCon, PPi impl (n "A") PType (+                               PPi impl (n "B") PType (+                               PPi expl (n "a") (PRef bi (n "A")) (+                               PPi expl (n "b") (PRef bi (n "B"))+                                (PApp bi (PRef bi pairTy) [pexp (PRef bi (n "A")),+                                                           pexp (PRef bi (n "B"))])))), bi, [])]     where n a = sMN 0 a+          pairConDoc      = parseDocstring . T.pack $ "A pair of elements"+          pairConParamDoc = [(n "a", parseDocstring . T.pack $ "the left element of the pair"),+                             (n "b", parseDocstring . T.pack $ "the right element of the pair")] pairOpts = []+pairParamDoc = [(n "A", parseDocstring . T.pack $ "the type of the left elements in the pair"),+                (n "B", parseDocstring . T.pack $ "the type of the left elements in the pair")]+    where n a = sMN 0 a  eqTy = sUN "=" eqCon = sUN "refl"+eqDoc = parseDocstring . T.pack $+          "The propositional equality type. A proof that `x` = `y`." +++          "\n\n" +++          "To use such a proof, pattern-match on it, and the two equal things will " +++          "then need to be the _same_ pattern." +++          "\n\n" +++          "**Note**: Idris's equality type is _heterogeneous_, which means that it " +++          "is possible to state equalities between values of potentially different " +++          "types. This is sometimes referred to in the literature as \"John Major\" " +++          "equality." +++          "\n\n" +++          "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)-                [(emptyDocstring, [], eqCon, PPi impl (n "A") PType (-                                         PPi impl (n "x") (PRef bi (n "A"))-                                           (PApp bi (PRef bi eqTy) [pimp (n "A") Placeholder False,-                                                                    pimp (n "B") Placeholder False,-                                                                    pexp (PRef bi (n "x")),-                                                                    pexp (PRef bi (n "x"))])), bi, [])]+                [(reflDoc, reflParamDoc,+                  eqCon, PPi impl (n "A") PType (+                                  PPi impl (n "x") (PRef bi (n "A"))+                                      (PApp bi (PRef bi eqTy) [pimp (n "A") Placeholder False,+                                                               pimp (n "B") Placeholder False,+                                                               pexp (PRef bi (n "x")),+                                                               pexp (PRef bi (n "x"))])), bi, [])]     where n a = sMN 0 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."+          reflParamDoc = [(n "A", parseDocstring . T.pack $ "the type at which the equality is proven"),+                          (n "x", parseDocstring . T.pack $ "the element shown to be equal to itself.")]++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+ eqOpts = []  elimName       = sUN "__Elim" elimMethElimTy = sUN "__elimTy" elimMethElim   = sUN "elim"-elimDecl = PClass (parseDocstring . T.pack $ "Type class for eliminators") defaultSyntax bi [] elimName [(sUN "scrutineeType", PType)]+elimDecl = PClass (parseDocstring . T.pack $ "Type class for eliminators") defaultSyntax bi [] elimName [(sUN "scrutineeType", PType)] []                      [PTy emptyDocstring [] defaultSyntax bi [TotalFn] elimMethElimTy PType,                       PTy emptyDocstring [] defaultSyntax bi [TotalFn] elimMethElim (PRef bi elimMethElimTy)] @@ -1038,29 +1117,31 @@ -- could interfere with interactive editing, which calls "show".  instance Show PTerm where-  showsPrec _ tm = (displayS . renderPretty 1.0 10000000 . prettyImp False) tm+  showsPrec _ tm = (displayS . renderPretty 1.0 10000000 . prettyImp defaultPPOption) tm  instance Show PDecl where-  showsPrec _ d = (displayS . renderPretty 1.0 10000000 . showDeclImp False) d+  showsPrec _ d = (displayS . renderPretty 1.0 10000000 . showDeclImp defaultPPOption) d  instance Show PClause where-  showsPrec _ c = (displayS . renderPretty 1.0 10000000 . showCImp True) c+  showsPrec _ c = (displayS . renderPretty 1.0 10000000 . showCImp verbosePPOption) c  instance Show PData where-  showsPrec _ d = (displayS . renderPretty 1.0 10000000 . showDImp False) d+  showsPrec _ d = (displayS . renderPretty 1.0 10000000 . showDImp defaultPPOption) d  instance Pretty PTerm OutputAnnotation where-  pretty = prettyImp False+  pretty = prettyImp defaultPPOption  -- | Colourise annotations according to an Idris state. It ignores the names -- in the annotation, as there's no good way to show extended information on a -- terminal. consoleDecorate :: IState -> OutputAnnotation -> String -> String consoleDecorate ist _ | not (idris_colourRepl ist) = id-consoleDecorate ist AnnConstData = let theme = idris_colourTheme ist-                                   in colouriseData theme-consoleDecorate ist AnnConstType = let theme = idris_colourTheme ist-                                   in colouriseType theme+consoleDecorate ist (AnnConst c) = let theme = idris_colourTheme ist+                                   in if constIsType c+                                        then colouriseType theme+                                        else colouriseData theme+consoleDecorate ist (AnnData _ _) = colouriseData (idris_colourTheme ist)+consoleDecorate ist (AnnType _ _) = colouriseType (idris_colourTheme ist) consoleDecorate ist (AnnBoundName _ True) = colouriseImplicit (idris_colourTheme ist) consoleDecorate ist (AnnBoundName _ False) = colouriseBound (idris_colourTheme ist) consoleDecorate ist AnnKeyword = colouriseKeyword (idris_colourTheme ist)@@ -1077,19 +1158,24 @@         colour UnderlineText = IdrisColour Nothing True True False False         colour ItalicText    = IdrisColour Nothing True False False True --- | Pretty-print a high-level closed Idris term-prettyImp :: Bool -- ^^ whether to show implicits+-- | Pretty-print a high-level closed Idris term with no information about precedence/associativity+prettyImp :: PPOption -- ^^ pretty printing options            -> PTerm -- ^^ the term to pretty-print           -> Doc OutputAnnotation-prettyImp impl = pprintPTerm impl [] []+prettyImp impl = pprintPTerm impl [] [] [] --- | Pretty-print a high-level Idris term in some bindings context-pprintPTerm :: Bool -- ^^ whether to show implicits+-- | Do the right thing for rendering a term in an IState+prettyIst ::  IState -> PTerm -> Doc OutputAnnotation+prettyIst ist = pprintPTerm (ppOptionIst ist) [] [] (idris_infixes ist)++-- | Pretty-print a high-level Idris term in some bindings context with infix info+pprintPTerm :: PPOption -- ^^ pretty printing options              -> [(Name, Bool)] -- ^^ the currently-bound names and whether they are implicit             -> [Name] -- ^^ names to always show in pi, even if not used+            -> [FixDecl] -- ^^ Fixity declarations             -> PTerm -- ^^ the term to pretty-print             -> Doc OutputAnnotation-pprintPTerm impl bnd docArgs = prettySe 10 bnd+pprintPTerm ppo bnd docArgs infixes = prettySe 10 bnd   where     prettySe :: Int -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation     prettySe p bnd (PQuote r) =@@ -1097,8 +1183,8 @@     prettySe p bnd (PPatvar fc n) = pretty n     prettySe p bnd e       | Just str <- slist p bnd e = str-      | Just n <- snat p e = annotate AnnConstData (text (show n))-    prettySe p bnd (PRef fc n) = prettyName impl bnd n+      | 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 (PLam n ty sc) =       bracket p 2 . group . align . hang 2 $       text "\\" <> bindingOf n False <+> text "=>" <$>@@ -1109,25 +1195,23 @@       prettySe 10 bnd v <+> kwd "in" </>       prettySe 10 ((n, False):bnd) sc     prettySe p bnd (PPi (Exp l s _) n ty sc)-      | n `elem` allNamesIn sc || impl || n `elem` docArgs =-          let open = if Lazy `elem` l then text "|" <> lparen else lparen in-            bracket p 2 . group $-            enclose open rparen (group . align $ bindingOf n False <+> colon <+> prettySe 10 bnd ty) <+>-            st <> text "->" <$> prettySe 10 ((n, False):bnd) sc+      | n `elem` allNamesIn sc || ppopt_impl ppo || n `elem` docArgs =+          bracket p 2 . group $+          enclose lparen rparen (group . align $ bindingOf n False <+> colon <+> prettySe 10 bnd ty) <+>+          st <> text "->" <$> prettySe 10 ((n, False):bnd) sc       | otherwise                      =           bracket p 2 . group $-          group (prettySe 0 bnd ty <+> st) <> text "->" <$> group (prettySe 10 ((n, False):bnd) sc)+          group (prettySe 1 bnd ty <+> st) <> text "->" <$> group (prettySe 10 ((n, False):bnd) sc)       where         st =           case s of             Static -> text "[static]" <> space             _      -> empty     prettySe p bnd (PPi (Imp l s _) n ty sc)-      | impl =-          let open = if Lazy `elem` l then text "|" <> lbrace else lbrace in-            bracket p 2 $-            open <> bindingOf n True <+> colon <+> prettySe 10 bnd ty <> rbrace <+>-            st <> text "->" </> prettySe 10 ((n, True):bnd) sc+      | ppopt_impl ppo =+          bracket p 2 $+          lbrace <> bindingOf n True <+> colon <+> prettySe 10 bnd ty <> rbrace <+>+          st <> text "->" </> prettySe 10 ((n, True):bnd) sc       | otherwise = prettySe 10 ((n, True):bnd) sc       where         st =@@ -1143,35 +1227,46 @@       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 impl && null (getExps args) = if isAlpha (thead nm)-                                            then prettyName impl bnd f-                                            else enclose lparen rparen $-                                                 prettyName impl bnd 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     prettySe p bnd (PAppBind _ (PRef _ f) [])-      | not impl = text "!" <> prettyName impl bnd f-    prettySe p bnd (PApp _ (PRef _ op) args)+      | not (ppopt_impl ppo) = text "!" <> prettyName (ppopt_impl ppo) bnd f+    prettySe p bnd (PApp _ (PRef _ op) args) -- infix operators       | UN nm <- basename op       , not (tnull nm) &&-        (not impl) && (not $ isAlpha (thead 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))-            [l,r] -> bracket p 1 $ inFix l r+            [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 impl bnd op+          where opName = prettyName (ppopt_impl ppo) bnd op+                f = getFixity (opStr op)+                left l = case f of+                           Nothing -> prettySe (-1) bnd l+                           Just (Infixl p') -> prettySe p' bnd l+                           Just f' -> prettySe (prec f'-1) bnd l+                right r = case f of+                            Nothing -> prettySe (-1) bnd r+                            Just (Infixr p') -> prettySe p' bnd r+                            Just f' -> prettySe (prec f'-1) bnd r                 inFix l r = align . group $-                            (prettySe 1 bnd l <+> opName) <$> group (prettySe 0 bnd r)-    prettySe p bnd (PApp _ hd@(PRef fc f) [tm])+                              (left l <+> opName) <$> 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_" = char '\'' <> prettySe 10 bnd (PRef fc (sUN str))-    prettySe p bnd (PApp _ f as) =+        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           fp   = prettySe 1 bnd f       in         bracket p 1 . group $-          if impl+          if ppopt_impl ppo             then if null as                    then fp                    else fp <+> align (vsep (map (prettyArgS bnd) as))@@ -1233,13 +1328,8 @@         where           prettyAs =             foldr (\l -> \r -> l <+> text "," <+> r) empty $ map (prettySe 10 bnd) as-    prettySe p bnd PType = annotate AnnConstType $ text "Type"-    prettySe p bnd (PConstant c) = annotate (annot c) (text (show c))-      where annot (AType _) = AnnConstType-            annot StrType   = AnnConstType-            annot PtrType   = AnnConstType-            annot VoidType  = AnnConstType-            annot _         = AnnConstData+    prettySe p bnd PType = annotate (AnnType "Type" "The type of types") $ text "Type"+    prettySe p bnd (PConstant c) = annotate (AnnConst c) (text (show c))     -- XXX: add pretty for tactics     prettySe p bnd (PProof ts) =       text "proof" <+> lbrace <> nest nestingSize (text . show $ ts) <> rbrace@@ -1250,13 +1340,14 @@     prettySe p bnd PImpossible = kwd "impossible"     prettySe p bnd Placeholder = text "_"     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      prettySe p bnd _ = text "test"      prettyArgS bnd (PImp _ _ _ n tm) = prettyArgSi bnd (n, tm)-    prettyArgS bnd (PExp _ _ tm)   = prettyArgSe bnd tm-    prettyArgS bnd (PConstraint _ _ tm) = prettyArgSc bnd tm+    prettyArgS bnd (PExp _ _ _ tm)   = prettyArgSe bnd tm+    prettyArgS bnd (PConstraint _ _ _ tm) = prettyArgSc bnd tm     prettyArgS bnd (PTacImplicit _ _ n _ tm) = prettyArgSti bnd (n, tm)      prettyArgSe bnd arg = prettySe 0 bnd arg@@ -1267,14 +1358,18 @@     annName :: Name -> Doc OutputAnnotation -> Doc OutputAnnotation     annName n = annotate (AnnName n Nothing Nothing Nothing) +    opStr :: Name -> String+    opStr (NS n _) = opStr n+    opStr (UN n) = T.unpack n+     basename :: Name -> Name     basename (NS n _) = basename n     basename n = n      slist' p bnd (PApp _ (PRef _ nil) _)-      | not impl && nsroot nil == sUN "Nil" = Just []+      | not (ppopt_impl ppo) && nsroot nil == sUN "Nil" = Just []     slist' p bnd (PRef _ nil)-      | not impl && nsroot nil == sUN "Nil" = Just []+      | not (ppopt_impl ppo) && nsroot nil == sUN "Nil" = Just []     slist' p bnd (PApp _ (PRef _ cons) args)       | nsroot cons == sUN "::",         (PExp {getTm=tl}):(PExp {getTm=hd}):imps <- reverse args,@@ -1287,16 +1382,16 @@     slist' _ _ tm = Nothing      slist p bnd e | Just es <- slist' p bnd e = Just $-      case es of [] -> annotate AnnConstData $ text "[]"+      case es of [] -> annotate (AnnData "" "") $ text "[]"                  [x] -> enclose left right . group $                         prettySe p bnd x                  xs -> (enclose left right .                         align . group . vsep .                         punctuate comma .                         map (prettySe p bnd)) xs-      where left  = (annotate AnnConstData (text "["))-            right = (annotate AnnConstData (text "]"))-            comma = (annotate AnnConstData (text ","))+      where left  = (annotate (AnnData "" "") (text "["))+            right = (annotate (AnnData "" "") (text "]"))+            comma = (annotate (AnnData "" "") (text ","))     slist _ _ _ = Nothing      pairElts :: PTerm -> Maybe [PTerm]@@ -1320,6 +1415,17 @@      kwd = annotate AnnKeyword . text +    fixities :: M.Map String Fixity+    fixities = M.fromList [(s, f) | (Fix f s) <- infixes]++    getFixity :: String -> Maybe Fixity+    getFixity = flip M.lookup fixities++prettyDocumentedIst :: IState -> (Name, PTerm, Maybe Docstring) -> Doc OutputAnnotation+prettyDocumentedIst ist (name, ty, docs) = +          prettyName 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 bindingOf :: Name -- ^^ the bound name           -> Bool -- ^^ whether the name is implicit@@ -1336,47 +1442,48 @@   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  -showCImp :: Bool -> PClause -> Doc OutputAnnotation-showCImp impl (PClause _ n l ws r w)- = prettyImp impl l <+> showWs ws <+> text "=" <+> prettyImp impl r+showCImp :: PPOption -> PClause -> Doc OutputAnnotation+showCImp ppo (PClause _ n l ws r w)+ = prettyImp ppo l <+> showWs ws <+> text "=" <+> prettyImp ppo r              <+> text "where" <+> text (show w)   where     showWs [] = empty-    showWs (x : xs) = text "|" <+> prettyImp impl x <+> showWs xs-showCImp impl (PWith _ n l ws r w)- = prettyImp impl l <+> showWs ws <+> text "with" <+> prettyImp impl r+    showWs (x : xs) = text "|" <+> prettyImp ppo x <+> showWs xs+showCImp ppo (PWith _ n l ws r w)+ = prettyImp ppo l <+> showWs ws <+> text "with" <+> prettyImp ppo r                  <+> braces (text (show w))   where     showWs [] = empty-    showWs (x : xs) = text "|" <+> prettyImp impl x <+> showWs xs+    showWs (x : xs) = text "|" <+> prettyImp ppo x <+> showWs xs  -showDImp :: Bool -> PData -> Doc OutputAnnotation-showDImp impl (PDatadecl n ty cons)- = text "data" <+> text (show n) <+> colon <+> prettyImp impl ty <+> text "where" <$>-    (indent 2 $ vsep (map (\ (_, _, n, t, _, _) -> pipe <+> prettyName False [] n <+> colon <+> prettyImp impl t) cons))+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)) -showDecls :: Bool -> [PDecl] -> Doc OutputAnnotation-showDecls i ds = vsep (map (showDeclImp i) ds)+showDecls :: PPOption -> [PDecl] -> Doc OutputAnnotation+showDecls o ds = vsep (map (showDeclImp o) ds)  showDeclImp _ (PFix _ f ops) = text (show f) <+> cat (punctuate (text ",") (map text ops))-showDeclImp i (PTy _ _ _ _ _ n t) = text "tydecl" <+> text (showCG n) <+> colon <+> prettyImp i t-showDeclImp i (PClauses _ _ n cs) = text "pat" <+> text (showCG n) <+> text "\t" <+>-                                      indent 2 (vsep (map (showCImp i) cs))-showDeclImp _ (PData _ _ _ _ _ d) = showDImp True d-showDeclImp i (PParams _ ns ps) = text "params" <+> braces (text (show ns) <> line <> showDecls i ps <> line)-showDeclImp i (PNamespace n ps) = text "namespace" <+> text n <> braces (line <> showDecls i ps <> line)+showDeclImp o (PTy _ _ _ _ _ n t) = text "tydecl" <+> text (showCG n) <+> colon <+> prettyImp o t+showDeclImp o (PClauses _ _ n cs) = text "pat" <+> text (showCG n) <+> text "\t" <+>+                                      indent 2 (vsep (map (showCImp o) cs))+showDeclImp o (PData _ _ _ _ _ d) = showDImp o { ppopt_impl = True } d+showDeclImp o (PParams _ ns ps) = text "params" <+> braces (text (show ns) <> line <> showDecls o ps <> line)+showDeclImp o (PNamespace n ps) = text "namespace" <+> text n <> braces (line <> showDecls o ps <> line) showDeclImp _ (PSyntax _ syn) = text "syntax" <+> text (show syn)-showDeclImp i (PClass _ _ _ cs n ps ds)-   = text "class" <+> text (show cs) <+> text (show n) <+> text (show ps) <> line <> showDecls i ds-showDeclImp i (PInstance _ _ cs n _ t _ ds)-   = text "instance" <+> text (show cs) <+> text (show n) <+> prettyImp i t <> line <> showDecls i ds+showDeclImp o (PClass _ _ _ cs n ps _ ds)+   = text "class" <+> text (show cs) <+> text (show n) <+> text (show ps) <> line <> showDecls o ds+showDeclImp o (PInstance _ _ cs n _ t _ ds)+   = text "instance" <+> text (show cs) <+> text (show n) <+> prettyImp o t <> line <> showDecls o ds showDeclImp _ _ = text "..."--- showDeclImp (PImport i) = "import " ++ i+-- showDeclImp (PImport o) = "import " ++ o  instance Show (Doc OutputAnnotation) where   show = flip (displayS . renderCompact) ""@@ -1388,12 +1495,12 @@  getExps :: [PArg] -> [PTerm] getExps [] = []-getExps (PExp _ _ tm : xs) = tm : getExps xs+getExps (PExp _ _ _ tm : xs) = tm : getExps xs getExps (_ : xs) = getExps xs  getConsts :: [PArg] -> [PTerm] getConsts [] = []-getConsts (PConstraint _ _ tm : xs) = tm : getConsts xs+getConsts (PConstraint _ _ _ tm : xs) = tm : getConsts xs getConsts (_ : xs) = getConsts xs  getAll :: [PArg] -> [PTerm]@@ -1403,14 +1510,14 @@ -- | Show Idris name showName :: Maybe IState   -- ^^ the Idris state, for information about names and colours          -> [(Name, Bool)] -- ^^ the bound variables and whether they're implicit-         -> Bool           -- ^^ whether to show implicits+         -> PPOption         -- ^^ pretty printing options          -> Bool           -- ^^ whether to colourise          -> Name           -- ^^ the term to show          -> String-showName ist bnd impl colour n = case ist of+showName ist bnd ppo colour n = case ist of                                    Just i -> if colour then colourise n (idris_colourTheme i) else showbasic n                                    Nothing -> showbasic n-    where name = if impl then show n else 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 (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n@@ -1432,13 +1539,16 @@ showTm :: IState -- ^^ the Idris state, for information about identifiers and colours        -> PTerm  -- ^^ the term to show        -> String-showTm ist = displayDecorated (consoleDecorate ist) . renderCompact . prettyImp (opt_showimp (idris_options ist))+showTm ist = displayDecorated (consoleDecorate ist) .+             renderPretty 0.8 100000 .+             prettyImp (ppOptionIst ist)  -- | Show a term with implicits, no colours showTmImpls :: PTerm -> String-showTmImpls = flip (displayS . renderCompact . prettyImp True) ""+showTmImpls = flip (displayS . renderCompact . prettyImp verbosePPOption) ""  + instance Sized PTerm where   size (PQuote rawTerm) = size rawTerm   size (PRef fc name) = size name@@ -1481,7 +1591,7 @@  allNamesIn :: PTerm -> [Name] allNamesIn tm = nub $ ni [] tm-  where+  where -- TODO THINK added niTacImp, but is it right?     ni env (PRef _ n)         | not (n `elem` env) = [n]     ni env (PPatvar _ n) = [n]@@ -1489,7 +1599,7 @@     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 (PLam n ty sc)  = ni env ty ++ ni (n:env) sc-    ni env (PPi _ n ty sc) = ni env ty ++ ni (n:env) sc+    ni env (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 (PRewrite _ l r _) = ni env l ++ ni env r@@ -1503,16 +1613,19 @@     ni env (PNoImplicits tm)    = ni env tm     ni env _               = [] +    niTacImp env (TacImp _ _ scr) = ni env scr+    niTacImp _ _                   = []+ -- Return all names defined in binders in the given term boundNamesIn :: PTerm -> [Name] boundNamesIn tm = nub $ ni tm-  where+  where -- TODO THINK Added niTacImp, but is it right?     ni (PApp _ f as)   = ni f ++ concatMap (ni) (map getTm as)     ni (PAppBind _ f as)   = ni f ++ concatMap (ni) (map getTm as)     ni (PCase _ c os)  = ni c ++ concatMap (ni) (map snd os)     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 _ n ty sc) = n : (ni ty ++ ni sc)+    ni (PPi p n ty sc) = niTacImp p ++ (n : (ni ty ++ ni sc))     ni (PEq _ l r)     = ni l ++ ni r     ni (PRewrite _ l r _) = ni l ++ ni r     ni (PTyped l r)    = ni l ++ ni r@@ -1526,6 +1639,9 @@     ni (PNoImplicits tm) = ni tm     ni _               = [] +    niTacImp (TacImp _ _ scr) = ni scr+    niTacImp _                = []+ -- Return names which are free in the given term. namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name] namesIn uvars ist tm = nub $ ni [] tm@@ -1539,7 +1655,7 @@     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 (PLam n ty sc)  = ni env ty ++ ni (n:env) sc-    ni env (PPi _ n ty sc) = ni env ty ++ ni (n:env) sc+    ni env (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@@ -1553,21 +1669,24 @@     ni env (PNoImplicits tm) = ni env tm     ni env _               = [] +    niTacImp env (TacImp _ _ scr) = ni env scr+    niTacImp _ _                  = []+ -- Return which of the given names are used in the given term.  usedNamesIn :: [Name] -> IState -> PTerm -> [Name] usedNamesIn vars ist tm = nub $ ni [] tm-  where+  where -- TODO THINK added niTacImp, but is it right?     ni env (PRef _ n)         | n `elem` vars && not (n `elem` env)-            = case lookupTy n (tt_ctxt ist) of-                [] -> [n]+            = case lookupDefExact n (tt_ctxt ist) of+                Nothing -> [n]                 _ -> []     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 (PLam n ty sc)  = ni env ty ++ ni (n:env) sc-    ni env (PPi _ n ty sc) = ni env ty ++ ni (n:env) sc+    ni env (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@@ -1580,4 +1699,7 @@     ni env (PDisamb _ tm)    = ni env tm     ni env (PNoImplicits tm) = ni env tm     ni env _               = []++    niTacImp env (TacImp _ _ scr) = ni env scr+    niTacImp _ _                = []
src/Idris/Apropos.hs view
@@ -9,8 +9,8 @@ import Data.List (nub) import qualified Data.Text as T --- | Find definitions that are relevant to some string. Relevance is one or--- more of the following:+-- | Find definitions that are relevant to all space-delimited components of+-- some string. Relevance is one or more of the following: -- -- * the string is a substring of the name --@@ -20,8 +20,12 @@ apropos :: IState -> T.Text -> [Name] apropos ist what = let defs = ctxtAlist (tt_ctxt ist)                        docs = toAlist (idris_docstrings ist)-                   in nub (map fst (filter (isApropos what) defs) ++-                           map fst (filter (isApropos what) docs))+                   in nub (map fst (isAproposAll parts defs) +++                           map fst (isAproposAll parts docs))+  where isAproposAll [] xs = xs+        isAproposAll (what:more) xs = filter (isApropos what)+                                             (isAproposAll more xs)+        parts = filter ((> 0) . T.length) . T.splitOn (T.pack " ") $ what  textIn :: T.Text -> T.Text -> Bool textIn a b = T.isInfixOf (T.toLower a) (T.toLower b)@@ -48,10 +52,10 @@   isApropos str (CaseOp _ ty ty' _ _ _) = isApropos str ty  instance Apropos (Binder (TT Name)) where-  isApropos str (Lam ty)      = isApropos str ty-  isApropos str (Pi ty)       = isApropos str ty-  isApropos str (Let ty val)  = isApropos str ty || isApropos str val-  isApropos str (NLet ty val) = isApropos str ty || isApropos str val+  isApropos str (Lam ty)      = str == T.pack "\\" || isApropos str ty+  isApropos str (Pi ty)       = str == T.pack "->" || isApropos str ty+  isApropos str (Let ty val)  = str == T.pack "let" || isApropos str ty || isApropos str val+  isApropos str (NLet ty val) = str == T.pack "let" || isApropos str ty || isApropos str val   isApropos str _             = False -- these shouldn't occur in defined libraries  instance Apropos (TT Name) where
src/Idris/CaseSplit.hs view
@@ -22,6 +22,7 @@  import Data.Maybe import Data.Char+import Data.List (isPrefixOf, isSuffixOf) import Control.Monad import Control.Monad.State.Strict @@ -54,7 +55,10 @@    = 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 (addImplPat ist t')+        (tm, ty, pats) <- elabValBind toplevel True 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         logLvl 4 ("Elaborated:\n" ++ show tm ++ " : " ++ show ty ++ "\n" ++ show pats) --         iputStrLn (show (delab ist tm) ++ " : " ++ show (delab ist ty)) --         iputStrLn (show pats)@@ -296,7 +300,9 @@                  else c : updatePat (not (isAlphaNum c)) n tm rest     updatePat start n tm (c:rest) = c : updatePat (not (isAlpha c)) n tm rest -    addBrackets tm | ' ' `elem` tm = "(" ++ tm ++ ")"+    addBrackets tm | ' ' `elem` tm+                   , not (isPrefixOf "(" tm)+                   , not (isSuffixOf ")" tm) = "(" ++ tm ++ ")"                    | otherwise = tm  getUniq nm i@@ -316,12 +322,17 @@           -> Name     -- ^ Function name           -> FilePath -- ^ Source file name           -> Idris String-getClause l fn fp = do ty <- getInternalApp fp l-                       ist <- get-                       let ap = mkApp ist ty []-                       return (show fn ++ " " ++ ap ++-                                   "= ?" ++ show fn ++ "_rhs")-   where mkApp i (PPi (Exp _ _ False) (MN _ _) ty sc) used+getClause l fn fp +    = do i <- getIState+         case lookupCtxt fn (idris_classes i) of+              [c] -> return (mkClassBodies i (class_methods c))+              _ -> do ty <- getInternalApp fp l+                      ist <- get+                      let ap = mkApp ist ty []+                      return (show fn ++ " " ++ ap ++ "= ?" +                                      ++ show fn ++ "_rhs")+   where mkApp :: IState -> PTerm -> [Name] -> String+         mkApp i (PPi (Exp _ _ False) (MN _ _) ty sc) used                = let n = getNameFrom i used ty in                      show n ++ " " ++ mkApp i sc (n : used)           mkApp i (PPi (Exp _ _ False) (UN n) ty sc) used@@ -343,6 +354,19 @@                    ns -> uniqueNameFrom (mkSupply ns) used          getNameFrom i used _ = uniqueName (sUN "x") used  +         -- write method declarations, indent with 4 spaces+         mkClassBodies :: IState -> [(Name, (FnOpts, PTerm))] -> String+         mkClassBodies i ns +             = showSep "\n"+                  (zipWith (\(n, (_, ty)) m -> "    " ++ +                            def (show (nsroot n)) ++ " "+                                 ++ mkApp i ty []+                                 ++ "= ?" +                                 ++ show fn ++ "_rhs_" ++ show m) ns [1..])++         def n@(x:xs) | not (isAlphaNum x) = "(" ++ n ++ ")"+         def n = n+ getProofClause :: Int      -- ^ line number that the type is declared                -> Name     -- ^ Function name                -> FilePath -- ^ Source file name@@ -358,15 +382,18 @@  mkWith :: String -> Name -> String mkWith str n = let str' = replaceRHS str "with (_)"-                   newpat = "  " ++-                            replaceRHS str "| with_pat = ?" ++ show n ++ "_rhs" in-                   str' ++ "\n" ++ newpat+               in str' ++ "\n" ++ newpat str     where replaceRHS [] str = str          replaceRHS ('?':'=': rest) str = str-         replaceRHS ('=': rest) str +         replaceRHS ('=': rest) str               | not ('=' `elem` rest) = str          replaceRHS (x : rest) str = x : replaceRHS rest str++         newpat ('>':patstr) = '>':newpat patstr+         newpat patstr =+           "  " +++           replaceRHS patstr "| with_pat = ?" ++ show n ++ "_rhs"  -- Replace _ with names in missing clauses
src/Idris/Chaser.hs view
@@ -82,7 +82,7 @@        iLOG $ "CHASING " ++ show file        ibcsd <- valIBCSubDir i        ids <- allImportDirs-       fp <- runIO $ findImport ids ibcsd file+       fp <- findImport ids ibcsd file        iLOG $ "Found " ++ show fp        mt <- runIO $ getIModTime fp        if (file `elem` built)
+ src/Idris/CmdOptions.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE Arrows #-}+module Idris.CmdOptions where++import Idris.AbsSyntaxTree+import Idris.REPL++import IRTS.CodegenCommon++import Options.Applicative+import Options.Applicative.Arrows+import Data.Maybe++runArgParser :: IO [Opt]+runArgParser = do opts <- execParser $ info parser $+                    header ("Idris version " ++ ver ++ ", (C) The Idris Community 2014")+                  return $ preProcOpts opts []++pureArgParser :: [String] -> [Opt]+pureArgParser args = case execParserMaybe (info parser idm) args of+  Just opts -> preProcOpts opts []+  Nothing -> []++parser :: Parser [Opt]+parser = runA $ proc () -> do+  flags <- asA parseFlags -< ()+  files <- asA (many $ argument ((fmap . fmap) Filename str) (metavar "FILES")) -< ()+  A parseVersion >>> A helper -< (flags ++ files)++parseFlags :: Parser [Opt]+parseFlags = many $+  flag' NoBanner (long "nobanner" <> help "Suppress the banner")+  <|> flag' Quiet (short 'q' <> long "quiet" <> help "Quiet verbosity")+  <|> flag' Ideslave (long "ideslave")+  <|> (Client <$> strOption (long "client"))+  <|> (OLogging <$> option (long "log" <> metavar "LEVEL" <> help "Debugging log level"))+  <|> flag' NoBasePkgs (long "nobasepkgs")+  <|> flag' NoPrelude (long "noprelude")+  <|> flag' NoBuiltins (long "nobuiltins")+  <|> flag' NoREPL (long "check")+  <|> (Output <$> strOption (short 'o' <> long "output" <> metavar "FILE" <> help "Specify output file"))+  <|> flag' TypeCase (long "typecase")+  <|> flag' TypeInType (long "typeintype")+  <|> flag' DefaultTotal (long "total" <> help "Require functions to be total by default")+  <|> flag' DefaultPartial (long "partial")+  <|> flag' WarnPartial (long "warnpartial" <> help "Warn about undeclared partial functions")+  <|> flag' WarnReach (long "warnreach" <> help "Warn about reachable but inaccessible arguments")+  <|> flag' NoCoverage (long "nocoverage")+  <|> flag' ErrContext (long "errorcontext")+  <|> flag' ShowLibs (long "link" <> help "Display link flags")+  <|> flag' ShowLibdir (long "libdir" <> help "Display library directory")+  <|> flag' ShowIncs (long "include" <> help "Display the includes flags")+  <|> flag' Verbose (short 'V' <> long "verbose" <> help "Loud verbosity")+  <|> (IBCSubDir <$> strOption (long "ibcsubdir" <> metavar "FILE" <> help "Write IBC files into sub directory"))+  <|> (ImportDir <$> strOption (short 'i' <> long "idrispath" <> help "Add directory to the list of import paths"))+  <|> flag' WarnOnly (long "warn")+  <|> (Pkg <$> strOption (short 'p' <> long "package"))+  -- Package commands+  <|> (PkgBuild <$> strOption (long "build" <> metavar "IPKG" <> help "Build package"))+  <|> (PkgInstall <$> strOption (long "install" <> metavar "IPKG" <> help "Install package"))+  <|> (PkgREPL <$> strOption (long "repl"))+  <|> (PkgClean <$> strOption (long "clean" <> metavar "IPKG" <> help "Clean package"))+  <|> (PkgMkDoc <$> strOption (long "mkdoc" <> metavar "IPKG" <> help "Generate IdrisDoc for package"))+  <|> (PkgCheck <$> strOption (long "checkpkg" <> metavar "IPKG" <> help "Check package only"))+  -- Misc options+  <|> (BCAsm <$> strOption (long "bytecode"))+  <|> flag' (OutputTy Raw) (short 'S' <> long "codegenonly" <> help "Do no further compilation of code generator output")+  <|> flag' (OutputTy Object) (short 'c' <> long "compileonly" <> help "Compile to object files rather than an executable")+  <|> flag' (OutputTy MavenProject) (long "mvn" <> help "Create a maven project (for Java codegen)")+  <|> (DumpDefun <$> strOption (long "dumpdefuns"))+  <|> (DumpCases <$> strOption (long "dumpcases"))+  <|> ((\s -> UseCodegen $ parseCodegen s) <$> strOption (long "codegen" <> metavar "TARGET" <> help "Select code generator: C, Java, bytecode"))+  <|> (EvalExpr <$> strOption (long "eval" <> short 'e' <> metavar "EXPR" <> help "Evaluate an expression without loading the REPL"))+  <|> flag' (InterpretScript "Main.main") (long "execute" <> help "Execute as idris")+  <|> (InterpretScript <$> strOption (long "exec" <> metavar "EXPR" <> help "Execute as idris"))+  <|> ((\s -> Extension $ getExt s) <$> strOption (long "extension" <> short 'X' <> metavar "EXT" <> help "Turn on langage extension (TypeProviders or ErrorReflection)"))+  <|> flag' (OptLevel 3) (long "O3")+  <|> flag' (OptLevel 2) (long "O2")+  <|> flag' (OptLevel 1) (long "O1")+  <|> flag' (OptLevel 0) (long "O0")+  <|> (OptLevel <$> option (short 'O' <> long "level"))+  <|> (TargetTriple <$> strOption (long "target" <> metavar "TRIPLE" <> help "Select target triple (for llvm codegen)"))+  <|> (TargetCPU <$> strOption (long "cpu" <> metavar "CPU" <> help "Select target CPU e.g. corei7 or cortex-m3 (for LLVM codegen)"))+  <|> flag' (ColourREPL True) (long "colour" <> long "color" <> help "Force coloured output")+  <|> flag' (ColourREPL False) (long "nocolour" <> long "nocolor" <> help "Disable coloured output")+  where+    getExt s = case maybeRead s of+      Just ext -> ext+      Nothing -> error ("Unknown extension " ++ s)+    maybeRead = fmap fst . listToMaybe . reads++parseVersion :: Parser (a -> a)+parseVersion = infoOption ver (short 'v' <> long "version" <> help "Print version information")++preProcOpts :: [Opt] -> [Opt] -> [Opt]+preProcOpts [] ys = ys+preProcOpts (NoBuiltins:xs) ys = NoBuiltins : NoPrelude : preProcOpts xs ys+preProcOpts (Output s:xs) ys = Output s : NoREPL : preProcOpts xs ys+preProcOpts (BCAsm s:xs) ys = BCAsm s : NoREPL : preProcOpts xs ys+preProcOpts (x:xs) ys = preProcOpts xs (x:ys)++parseCodegen :: String -> Codegen+parseCodegen "C" = ViaC+parseCodegen "Java" = ViaJava+parseCodegen "bytecode" = Bytecode+parseCodegen "javascript" = ViaJavaScript+parseCodegen "node" = ViaNode+parseCodegen "llvm" = ViaLLVM+parseCodegen _ = error "unknown codegen" -- FIXME: partial function
src/Idris/Completion.hs view
@@ -51,7 +51,7 @@              , (":eval", Just ExprTArg)              ] ++ map (\x -> (x, Nothing)) [               "intros", "compute", "trivial", "search", "solve", "attack",-              "state", "term", "undo", "qed", "abandon", ":q"+              "unify", "state", "term", "undo", "qed", "abandon", ":q"              ] tactics = map fst tacticArgs @@ -112,6 +112,7 @@                                               , "showimplicits"                                               , "originalerrors"                                               , "autosolve"+                                              , "nobanner"                                               ]  completeConsoleWidth :: CompletionFunc Idris@@ -160,6 +161,7 @@           completeArg NameArg = completeExpr [] (prev, next) -- FIXME only complete one name           completeArg OptionArg = completeOption (prev, next)           completeArg ModuleArg = noCompletion (prev, next) -- FIXME do later+          completeArg NamespaceArg = noCompletion (prev, next) -- FIXME do later           completeArg ExprArg = completeExpr [] (prev, next)           completeArg MetaVarArg = completeMetaVar (prev, next) -- FIXME only complete one name           completeArg ColourArg = completeColour (prev, next)
src/Idris/Core/CaseTree.hs view
@@ -2,20 +2,34 @@  module Idris.Core.CaseTree(CaseDef(..), SC, SC'(..), CaseAlt, CaseAlt'(..),                      Phase(..), CaseTree,-                     simpleCase, small, namesUsed, findCalls, findUsedArgs) where+                     simpleCase, small, namesUsed, findCalls, findUsedArgs,+                     substSC, substAlt, mkForce) where  import Idris.Core.TT  import Control.Monad.State import Data.Maybe import Data.List hiding (partition)+import qualified Data.List(partition) import Debug.Trace  data CaseDef = CaseDef [Name] !SC [Term]     deriving Show -data SC' t = Case Name [CaseAlt' t] -- ^ invariant: lowest tags first-           | ProjCase t [CaseAlt' t] -- ^ special case for projections+-- Note: The case-tree elaborator only produces (Case n alts)-cases;+-- in other words, it never inspects anything else than variables.+--+-- ProjCase is a special powerful case construct that allows inspection+-- of compound terms. Occurrences of ProjCase arise no earlier than+-- in the function `prune` as a means of optimisation+-- of already built case trees.+--+-- While the intermediate representation (follows in the pipeline)+-- allows casing on arbitrary terms, here we choose to maintain the distinction+-- in order to allow for better optimisation opportunities.+--+data SC' t = Case Name [CaseAlt' t]  -- ^ invariant: lowest tags first+           | ProjCase t [CaseAlt' t] -- ^ special case for projections/thunk-forcing before inspection            | STerm !t            | UnmatchedCase String -- ^ error message            | ImpossibleCase -- ^ already checked to be impossible@@ -96,8 +110,7 @@ namesUsed :: SC -> [Name] namesUsed sc = nub $ nu' [] sc where     nu' ps (Case n alts) = nub (concatMap (nua ps) alts) \\ [n]-    nu' ps (ProjCase t alts) = nub $ (nut ps t ++-                                      (concatMap (nua ps) alts))+    nu' ps (ProjCase t alts) = nub $ nut ps t ++ concatMap (nua ps) alts     nu' ps (STerm t)     = nub $ nut ps t     nu' ps _ = [] @@ -122,7 +135,7 @@ findCalls :: SC -> [Name] -> [(Name, [[Name]])] findCalls sc topargs = nub $ nu' topargs sc where     nu' ps (Case n alts) = nub (concatMap (nua (n : ps)) alts)-    nu' ps (ProjCase t alts) = nub (nut ps t ++ concatMap (nua ps) alts)+    nu' ps (ProjCase t alts) = nub $ nut ps t ++ concatMap (nua ps) alts     nu' ps (STerm t)     = nub $ nut ps t     nu' ps _ = [] @@ -185,6 +198,22 @@     nua (SucCase _ sc)        = nu' sc     nua (DefaultCase sc)      = nu' sc +-- Return whether name is used anywhere in a case tree+isUsed :: SC -> Name -> Bool+isUsed sc n = used sc where++  used (Case n' alts) = n == n' || or (map usedA alts)+  used (ProjCase t alts) = n `elem` freeNames t || or (map usedA alts)+  used (STerm t) = n `elem` freeNames t+  used _ = False++  usedA (ConCase _ _ args sc) = used sc+  usedA (FnCase _ args sc) = used sc+  usedA (ConstCase _ sc) = used sc+  usedA (SucCase _ sc) = used sc+  usedA (DefaultCase sc) = used sc++ data Phase = CompileTime | RunTime     deriving (Show, Eq) @@ -192,10 +221,10 @@ -- Work Right to Left  simpleCase :: Bool -> Bool -> Bool ->-              Phase -> FC -> [Type] ->+              Phase -> FC -> [Int] -> [Type] ->               [([Name], Term, Term)] ->               TC CaseDef-simpleCase tc cover reflect phase fc argtys cs+simpleCase tc cover reflect phase fc inacc argtys cs       = sc' tc cover phase fc (filter (\(_, _, r) ->                                           case r of                                             Impossible -> False@@ -213,7 +242,7 @@                 OK pats ->                     let numargs    = length (fst (head pats))                         ns         = take numargs args-                        (ns', ps') = order ns pats+                        (ns', ps') = order [(n, i `elem` inacc) | (i,n) <- zip [0..] ns] pats                         (tree, st) = runState                                          (match ns' ps' (defaultCase cover))                                           ([], numargs, [])@@ -382,22 +411,43 @@ -- reorder the patterns so that the one with most distinct names -- comes next. Take rightmost first, otherwise (i.e. pick value rather -- than dependency)+--+-- The first argument means [(Name, IsInaccessible)]. -order :: [Name] -> [Clause] -> ([Name], [Clause])-order [] cs = ([], cs)-order ns [] = (ns, [])-order ns cs = let patnames = transpose (map (zip ns) (map fst cs))-                  pats' = transpose (sortBy moreDistinct (reverse patnames)) in-                  (getNOrder pats', zipWith rebuild pats' cs)+order :: [(Name, Bool)] -> [Clause] -> ([Name], [Clause])+order []  cs = ([], cs)+order ns' [] = (map fst ns', [])+order ns' cs = let patnames = transpose (map (zip ns') (map fst cs))+                   -- only sort the arguments where there is no clash in+                   -- constructor tags between families, and no constructor/constant+                   -- clash, because otherwise we can't reliable make the+                   -- case distinction on evaluation+                   (patnames_ord, patnames_rest) +                        = Data.List.partition (noClash . map snd) patnames+                   -- note: sortBy . reverse is not nonsense because sortBy is stable+                   pats' = transpose (sortBy moreDistinct (reverse patnames_ord) +                                         ++ patnames_rest) in+                   (getNOrder pats', zipWith rebuild pats' cs)   where-    getNOrder [] = error $ "Failed order on " ++ show (ns, cs)-    getNOrder (c : _) = map fst c+    getNOrder [] = error $ "Failed order on " ++ show (map fst ns', cs)+    getNOrder (c : _) = map (fst . fst) c      rebuild patnames clause = (map snd patnames, snd clause) -    moreDistinct xs ys = compare (numNames [] (map snd ys))-                                 (numNames [] (map snd xs))+    noClash [] = True+    noClash (p : ps) = not (any (clashPat p) ps) && noClash ps +    clashPat (PCon _ _ _) (PConst _) = True+    clashPat (PConst _) (PCon _ _ _) = True+    clashPat (PCon _ _ _) (PSuc _) = True+    clashPat (PSuc _) (PCon _ _ _) = True+    clashPat (PCon n i _) (PCon n' i' _) | i == i' = n /= n'+    clashPat _ _ = False++    -- this compares (+isInaccessible, -numberOfCases)+    moreDistinct xs ys = compare (snd . fst . head $ xs, numNames [] (map snd ys))+                                 (snd . fst . head $ ys, numNames [] (map snd xs))+     numNames xs (PCon n _ _ : ps)         | not (Left n `elem` xs) = numNames (Left n : xs) ps     numNames xs (PConst c : ps)@@ -576,92 +626,80 @@ -- FIXME: Do this for SucCase too prune :: Bool -- ^ Convert single branches to projections (only useful at runtime)       -> SC -> SC-prune proj (Case n alts)-    = let alts' = filter notErased (map pruneAlt alts) in-          case alts' of-            [] -> ImpossibleCase-            as@(ConCase (UN delay) i [arg] sc : _)-                | delay == txt "Delay"-                   -> if proj then mkForce n arg sc-                              else Case n as-            as@[ConCase cn i args sc] -> if proj then mkProj n 0 args sc-                                                 else Case n as-            as@[SucCase cn sc] -> if proj then mkProj n (-1) [cn] sc -                                          else Case n as-            as@[ConstCase _ sc] -> prune proj sc-            -- Bit of a hack here! The default case will always be 0, make sure-            -- it gets caught first.-            [s@(SucCase _ _), DefaultCase dc]-                -> Case n [ConstCase (BI 0) dc, s]-            as  -> Case n as-    where pruneAlt (ConCase cn i ns sc) = ConCase cn i ns (prune proj sc)-          pruneAlt (FnCase cn ns sc) = FnCase cn ns (prune proj sc)-          pruneAlt (ConstCase c sc) = ConstCase c (prune proj sc)-          pruneAlt (SucCase n sc) = SucCase n (prune proj sc)-          pruneAlt (DefaultCase sc) = DefaultCase (prune proj sc)+prune proj (Case n alts) = case alts' of+    [] -> ImpossibleCase -          notErased (DefaultCase (STerm Erased)) = False-          notErased (DefaultCase ImpossibleCase) = False-          notErased _ = True+    -- Projection transformations prevent us from seeing some uses of ctor fields+    -- because they delete information about which ctor is being used.+    -- Consider:+    --   f (X x) = ...  x  ...+    -- vs.+    --   f  x    = ... x!0 ...+    --+    -- Hence, we disable this step.+    -- TODO: re-enable this in toIR+    --+    -- as@[ConCase cn i args sc]+    --     | proj -> mkProj n 0 args (prune proj sc)+    -- mkProj n i xs sc = foldr (\x -> projRep x n i) sc xs -          mkForce n arg (Case x alts)-                | x == arg = ProjCase (forceArg n)-                                      (map (mkForceAlt n arg) alts)-                | otherwise = Case x (map (mkForceAlt n arg) alts)-          mkForce n arg (ProjCase t alts)-             = ProjCase (forceTm n arg t) (map (mkForceAlt n arg) alts)-          mkForce n arg (STerm t) = STerm (forceTm n arg t)-          mkForce n arg c = c+    -- If none of the args are used in the sc, however, we can just replace it+    -- with sc+    as@[ConCase cn i args sc]+        | proj -> let sc' = prune proj sc in+                      if any (isUsed sc') args  +                         then Case n [ConCase cn i args sc']+                         else sc'  -          mkForceAlt n arg (ConCase cn t args rhs)-             = ConCase cn t args (mkForce n arg rhs)-          mkForceAlt n arg (FnCase cn args rhs)-             = FnCase cn args (mkForce n arg rhs)-          mkForceAlt n arg (ConstCase t rhs)-             = ConstCase t (mkForce n arg rhs)-          mkForceAlt n arg (SucCase sn rhs)-             = SucCase sn (mkForce n arg rhs)-          mkForceAlt n arg (DefaultCase rhs)-             = DefaultCase (mkForce n arg rhs)-         -          forceTm n arg t = subst arg (forceArg n) t+    [SucCase cn sc]+        | proj+        -> projRep cn n (-1) $ prune proj sc -          forceArg n = App (App (App (P Ref (sUN "Force") Erased) Erased) Erased)-                           (P Bound n Erased)+    [ConstCase _ sc]+        -> prune proj sc -          mkProj n i []       sc = prune proj sc-          mkProj n i (x : xs) sc = mkProj n (i + 1) xs (projRep x n i sc)+    -- Bit of a hack here! The default case will always be 0, make sure+    -- it gets caught first.+    [s@(SucCase _ _), DefaultCase dc]+        -> Case n [ConstCase (BI 0) dc, s] -          -- Change every 'n' in sc to 'n-1'---           mkProjS n cn sc = prune proj (fmap projn sc) where---              projn pn@(P _ n' _) ---                 | cn == n' = App (App (P Ref (UN "prim__subBigInt") Erased)---                                       (P Bound n Erased)) (Constant (BI 1))---              projn t = t+    as  -> Case n as+  where+    alts' = filter (not . erased) $ map pruneAlt alts -          projRep :: Name -> Name -> Int -> SC -> SC-          projRep arg n i (Case x alts)-                | x == arg = ProjCase (Proj (P Bound n Erased) i)-                                      (map (projRepAlt arg n i) alts)-                | otherwise = Case x (map (projRepAlt arg n i) alts)-          projRep arg n i (ProjCase t alts)-                = ProjCase (projRepTm arg n i t) (map (projRepAlt arg n i) alts)-          projRep arg n i (STerm t) = STerm (projRepTm arg n i t)-          projRep arg n i c = c -- unmatched+    pruneAlt (ConCase cn i ns sc) = ConCase cn i ns (prune proj sc)+    pruneAlt (FnCase cn ns sc) = FnCase cn ns (prune proj sc)+    pruneAlt (ConstCase c sc) = ConstCase c (prune proj sc)+    pruneAlt (SucCase n sc) = SucCase n (prune proj sc)+    pruneAlt (DefaultCase sc) = DefaultCase (prune proj sc) -          projRepAlt arg n i (ConCase cn t args rhs)-              = ConCase cn t args (projRep arg n i rhs)-          projRepAlt arg n i (FnCase cn args rhs)-              = FnCase cn args (projRep arg n i rhs)-          projRepAlt arg n i (ConstCase t rhs)-              = ConstCase t (projRep arg n i rhs)-          projRepAlt arg n i (SucCase sn rhs)-              = SucCase sn (projRep arg n i rhs)-          projRepAlt arg n i (DefaultCase rhs)-              = DefaultCase (projRep arg n i rhs)+    erased (DefaultCase (STerm Erased)) = True+    erased (DefaultCase ImpossibleCase) = True+    erased _ = False -          projRepTm arg n i t = subst arg (Proj (P Bound n Erased) i) t+    projRep :: Name -> Name -> Int -> SC -> SC+    projRep arg n i (Case x alts) | x == arg+        = ProjCase (Proj (P Bound n Erased) i) $ map (projRepAlt arg n i) alts+    projRep arg n i (Case x alts)+        = Case x (map (projRepAlt arg n i) alts)+    projRep arg n i (ProjCase t alts)+        = ProjCase (projRepTm arg n i t) $ map (projRepAlt arg n i) alts+    projRep arg n i (STerm t) = STerm (projRepTm arg n i t)+    projRep arg n i c = c +    projRepAlt arg n i (ConCase cn t args rhs)+        = ConCase cn t args (projRep arg n i rhs)+    projRepAlt arg n i (FnCase cn args rhs)+        = FnCase cn args (projRep arg n i rhs)+    projRepAlt arg n i (ConstCase t rhs)+        = ConstCase t (projRep arg n i rhs)+    projRepAlt arg n i (SucCase sn rhs)+        = SucCase sn (projRep arg n i rhs)+    projRepAlt arg n i (DefaultCase rhs)+        = DefaultCase (projRep arg n i rhs)++    projRepTm arg n i t = subst arg (Proj (P Bound n Erased) i) t+ prune _ t = t  stripLambdas :: CaseDef -> CaseDef@@ -669,6 +707,51 @@     = stripLambdas (CaseDef (ns ++ [x]) (STerm (instantiate (P Bound x Erased) sc)) tm) stripLambdas x = x +substSC :: Name -> Name -> SC -> SC+substSC n repl (Case n' alts)+    | n == n'   = Case repl (map (substAlt n repl) alts)+    | otherwise = Case n'   (map (substAlt n repl) alts)+substSC n repl (STerm t) = STerm $ subst n (P Bound repl Erased) t+substSC n repl (UnmatchedCase errmsg) = UnmatchedCase errmsg+substSC n repl  ImpossibleCase = ImpossibleCase+substSC n repl sc = error $ "unsupported in substSC: " ++ show sc +substAlt :: Name -> Name -> CaseAlt -> CaseAlt+substAlt n repl (ConCase cn a ns sc) = ConCase cn a ns (substSC n repl sc)+substAlt n repl (FnCase fn ns sc)    = FnCase fn ns (substSC n repl sc)+substAlt n repl (ConstCase c sc)     = ConstCase c (substSC n repl sc)+substAlt n repl (SucCase n' sc)+    | n == n'   = SucCase n  (substSC n repl sc)+    | otherwise = SucCase n' (substSC n repl sc)+substAlt n repl (DefaultCase sc)     = DefaultCase (substSC n repl sc) +mkForce :: Name -> Name -> SC -> SC+mkForce = mkForceSC+  where+    mkForceSC n arg (Case x alts) | x == arg+        = ProjCase (forceArg 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++    mkForceSC n arg (STerm t) = STerm (forceTm n arg t)+    mkForceSC n arg c = c++    mkForceAlt n arg (ConCase cn t args rhs)+        = ConCase cn t args (mkForceSC n arg rhs)+    mkForceAlt n arg (FnCase cn args rhs)+        = FnCase cn args (mkForceSC n arg rhs)+    mkForceAlt n arg (ConstCase t rhs)+        = ConstCase t (mkForceSC n arg rhs)+    mkForceAlt n arg (SucCase sn rhs)+        = SucCase sn (mkForceSC n arg rhs)+    mkForceAlt n arg (DefaultCase rhs)+        = DefaultCase (mkForceSC n arg rhs)++    forceTm n arg t = subst arg (forceArg n) t++    forceArg n = App (App (App (P Ref (sUN "Force") Erased) Erased) Erased)+                    (P Bound n Erased)
src/Idris/Core/Elaborate.hs view
@@ -64,7 +64,7 @@ loadState = do (ES p s e) <- get                case e of                   Just st -> put st-                  _ -> fail "Nothing to undo"+                  _ -> lift $ Error . Msg $ "Nothing to undo"  getNameFrom :: Name -> Elab' aux Name getNameFrom n = do (ES (p, a) s e) <- get@@ -328,6 +328,10 @@ end_unify :: Elab' aux () end_unify = processTactic' EndUnify +-- Clear the list of variables not to unify, and try to solve them+unify_all :: Elab' aux ()+unify_all = processTactic' UnifyAll+ regret :: Elab' aux () regret = processTactic' Regret @@ -642,6 +646,7 @@                           Error _ -> lift $ Error e                           OK (a, s') -> do put s'                                            return a+            unifyProblems             ps' <- get_probs             if (length ps' > length ps) then                case reverse ps' of@@ -676,11 +681,13 @@ try' t1 t2 proofSearch           = do s <- get                ps <- get_probs+               ulog <- getUnifyLog                case prunStateT 999999 False ps t1 s of                     OK ((v, _, _), s') -> do put s'                                              return $! v-                    Error e1 -> if recoverableErr e1 then-                                   do case runStateT t2 s of+                    Error e1 -> traceWhen ulog ("try failed " ++ show e1) $+                                 if recoverableErr e1 then+                                    do case runStateT t2 s of                                          OK (v, s') -> do put s'; return $! v                                          Error e2 -> if score e1 >= score e2                                                         then lift (tfail e1)@@ -690,6 +697,7 @@              = -- traceWhen r (show err) $                r || proofSearch         recoverableErr (CantSolveGoal _ _) = False+        recoverableErr (ProofSearchFail (Msg _)) = True         recoverableErr (ProofSearchFail _) = False         recoverableErr (ElaboratingArg _ _ _ e) = recoverableErr e         recoverableErr (At _ e) = recoverableErr e@@ -719,7 +727,7 @@        = do s <- get             ps <- get_probs             case prunStateT pmax True ps x s of-                OK ((v, newps, probs), s') ->+                OK ((v, newps, probs), s') ->                      do let cs' = if (newps < pmax)                                     then [do put s'; return $! v]                                     else (do put s'; return $! v) : cs
src/Idris/Core/Evaluate.hs view
@@ -8,12 +8,13 @@                 Context, initContext, ctxtAlist, uconstraints, next_tvar,                 addToCtxt, setAccess, setTotal, setMetaInformation, addCtxtDef, addTyDecl,                 addDatatype, addCasedef, simplifyCasedef, addOperator,-                lookupNames, lookupTy, lookupP, lookupDef, lookupDefAcc, lookupVal,+                lookupNames, lookupTy, lookupP, lookupDef, lookupNameDef, lookupDefExact, lookupDefAcc, lookupVal,                 mapDefCtxt,                 lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isDConName, isTConName, isConName, isFnName,-                Value(..), Quote(..), initEval, uniqueNameCtxt) where+                Value(..), Quote(..), initEval, uniqueNameCtxt, uniqueBindersCtxt, definitions) where  import Debug.Trace+import Control.Applicative hiding (Const) import Control.Monad.State -- not Strict! import qualified Data.Binary as B import Data.Binary hiding (get, put)@@ -536,7 +537,7 @@ convEq' ctxt hs x y = evalStateT (convEq ctxt hs x y) (0, [])  convEq :: Context -> [Name] -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool-convEq ctxt holes = ceq [] where+convEq ctxt holes topx topy = ceq [] topx topy where     ceq :: [(Name, Name)] -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool     ceq ps (P xt x _) (P yt y _)         | x `elem` holes || y `elem` holes = return True@@ -549,8 +550,12 @@     ceq ps (Bind n (Lam t) (App x (P Bound n' _))) y         | n == n' = ceq ps x y     ceq ps (V x)      (V y)      = return (x == y)-    ceq ps (V x)      (P _ y _)  = return (fst (ps!!x) == y)-    ceq ps (P _ x _)  (V y)      = return (x == snd (ps!!y))+    ceq ps (V x)      (P _ y _)  +        | x >= 0 && length ps > x = return (fst (ps!!x) == y)+        | otherwise = return False+    ceq ps (P _ x _)  (V y)      +        | y >= 0 && length ps > y = return (x == snd (ps!!y))+        | otherwise = return False     ceq ps (Bind n xb xs) (Bind n' yb ys)                              = liftM2 (&&) (ceqB ps xb yb) (ceq ((n,n'):ps) xs ys)         where@@ -677,7 +682,7 @@  -- | Reasons why a function may not be total data PReason = Other [Name] | Itself | NotCovering | NotPositive | UseUndef Name-             | BelieveMe | Mutual [Name] | NotProductive+             | ExternalIO | BelieveMe | Mutual [Name] | NotProductive     deriving (Show, Eq)  instance Show Totality where@@ -687,6 +692,7 @@     show (Partial Itself) = "possibly not total as it is not well founded"     show (Partial NotCovering) = "not total as there are missing cases"     show (Partial NotPositive) = "not strictly positive"+    show (Partial ExternalIO) = "an external IO primitive"     show (Partial NotProductive) = "not productive"     show (Partial BelieveMe) = "not total due to use of believe_me in proof"     show (Partial (Other ns)) = "possibly not total due to: " ++ showSep ", " (map show ns)@@ -784,6 +790,7 @@ -- FIXME: Too many arguments! Refactor all these Bools. addCasedef :: Name -> CaseInfo -> Bool -> Bool -> Bool -> Bool ->               [Type] -> -- argument types+              [Int] ->  -- inaccessible arguments               [Either Term (Term, Term)] ->               [([Name], Term, Term)] -> -- totality               [([Name], Term, Term)] -> -- compile time@@ -791,16 +798,16 @@               [([Name], Term, Term)] -> -- run time               Type -> Context -> Context addCasedef n ci@(CaseInfo alwaysInline tcdict)-           tcase covering reflect asserted argtys +           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 argtys ps_tot,-                        simpleCase tcase covering reflect CompileTime emptyFC argtys ps_ct,-                        simpleCase tcase covering reflect CompileTime emptyFC argtys ps_inl,-                        simpleCase tcase covering reflect RunTime emptyFC argtys ps_rt) of+          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                     (OK (CaseDef args_tot sc_tot _),                      OK (CaseDef args_ct sc_ct _),                      OK (CaseDef args_inl sc_inl _),@@ -827,7 +834,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 of                        OK (CaseDef args sc _) ->                           addDef n (CaseOp ci                                            ty atys ps_in' ps (cd { cases_totcheck = (args, sc) }),@@ -908,9 +915,17 @@             Hidden -> []             _ -> return (fst p) +lookupDefExact :: Name -> Context -> Maybe Def+lookupDefExact n ctxt = tfst <$> lookupCtxtExact n (definitions ctxt)+ lookupDef :: Name -> Context -> [Def]-lookupDef n ctxt = map tfst $ lookupCtxt n (definitions ctxt)+lookupDef n ctxt = tfst <$> lookupCtxt n (definitions ctxt) +lookupNameDef :: Name -> Context -> [(Name, Def)]+lookupNameDef n ctxt = mapSnd tfst $ lookupCtxtName n (definitions ctxt)+  where mapSnd f [] = []+        mapSnd f ((x,y):xys) = (x, f y) : mapSnd f xys+ lookupDefAcc :: Name -> Bool -> Context ->                 [(Def, Accessibility)] lookupDefAcc n mkpublic ctxt@@ -951,3 +966,10 @@     | n `elem` hs = uniqueNameCtxt ctxt (nextName n) hs     | [_] <- lookupTy n ctxt = uniqueNameCtxt ctxt (nextName n) hs     | otherwise = n++uniqueBindersCtxt :: Context -> [Name] -> TT Name -> TT Name+uniqueBindersCtxt ctxt ns (Bind n b sc)+    = let n' = uniqueNameCtxt ctxt n ns in+          Bind n' (fmap (uniqueBindersCtxt ctxt (n':ns)) b) (uniqueBindersCtxt ctxt ns sc)+uniqueBindersCtxt ctxt ns (App f a) = App (uniqueBindersCtxt ctxt ns f) (uniqueBindersCtxt ctxt ns a)+uniqueBindersCtxt ctxt ns t = t
src/Idris/Core/Execute.hs view
@@ -11,6 +11,8 @@ import Idris.Core.Evaluate import Idris.Core.CaseTree +import Idris.Error+ import Debug.Trace  import Util.DynamicLinker@@ -47,11 +49,8 @@  data Lazy = Delayed ExecEnv Context Term | Forced ExecVal deriving Show -data ExecState = ExecState { exec_thunks :: M.Map Int Lazy -- ^ Thunks - the result of evaluating "lazy" or calling lazy funcs-                           , exec_next_thunk :: Int -- ^ Ensure thunk key uniqueness-                           , exec_implicits :: Ctxt [PArg] -- ^ Necessary info on laziness from idris monad-                           , exec_dynamic_libs :: [DynamicLib] -- ^ Dynamic libs from idris monad-                           }+newtype ExecState = ExecState { exec_dynamic_libs :: [DynamicLib] -- ^ Dynamic libs from idris monad+                              }  data ExecVal = EP NameType Name ExecVal              | EV Int@@ -61,20 +60,20 @@              | EErased              | EConstant Const              | forall a. EPtr (Ptr a)-             | EThunk Int+             | EThunk Context ExecEnv Term              | EHandle Handle  instance Show ExecVal where-  show (EP _ n _)       = show n-  show (EV i)           = "!!V" ++ show i ++ "!!"-  show (EBind n b body) = "EBind " ++ show b ++ " <<fn>>"-  show (EApp e1 e2)     = show e1 ++ " (" ++ show e2 ++ ")"-  show (EType _)        = "Type"-  show EErased          = "[__]"-  show (EConstant c)    = show c-  show (EPtr p)         = "<<ptr " ++ show p ++ ">>"-  show (EThunk i)       = "<<thunk " ++ show i ++ ">>"-  show (EHandle h)      = "<<handle " ++ show h ++ ">>"+  show (EP _ n _)        = show n+  show (EV i)            = "!!V" ++ show i ++ "!!"+  show (EBind n b body)  = "EBind " ++ show b ++ " <<fn>>"+  show (EApp e1 e2)      = show e1 ++ " (" ++ show e2 ++ ")"+  show (EType _)         = "Type"+  show EErased           = "[__]"+  show (EConstant c)     = show c+  show (EPtr p)          = "<<ptr " ++ show p ++ ">>"+  show (EThunk _ env tm) = "<<thunk " ++ show env ++ "||||" ++ show tm ++ ">>"+  show (EHandle h)       = "<<handle " ++ show h ++ ">>"  toTT :: ExecVal -> Exec Term toTT (EP nt n ty) = (P nt n) <$> (toTT ty)@@ -82,22 +81,25 @@ toTT (EBind n b body) = do body' <- body $ EP Bound n EErased                            b' <- fixBinder b                            Bind n b' <$> toTT body'-    where fixBinder (Lam t)       = Lam   <$> toTT t-          fixBinder (Pi t)        = Pi    <$> toTT t-          fixBinder (Let t1 t2)   = Let   <$> toTT t1 <*> toTT t2-          fixBinder (NLet t1 t2)  = NLet  <$> toTT t1 <*> toTT t2-          fixBinder (Hole t)      = Hole  <$> toTT t+    where fixBinder (Lam t)       = Lam     <$> toTT t+          fixBinder (Pi t)        = Pi      <$> toTT t+          fixBinder (Let t1 t2)   = Let     <$> toTT t1 <*> toTT t2+          fixBinder (NLet t1 t2)  = NLet    <$> toTT t1 <*> toTT t2+          fixBinder (Hole t)      = Hole    <$> toTT t           fixBinder (GHole i t)   = GHole i <$> toTT t-          fixBinder (Guess t1 t2) = Guess <$> toTT t1 <*> toTT t2-          fixBinder (PVar t)      = PVar  <$> toTT t-          fixBinder (PVTy t)      = PVTy  <$> toTT t+          fixBinder (Guess t1 t2) = Guess   <$> toTT t1 <*> toTT t2+          fixBinder (PVar t)      = PVar    <$> toTT t+          fixBinder (PVTy t)      = PVTy    <$> toTT t toTT (EApp e1 e2) = do e1' <- toTT e1                        e2' <- toTT e2                        return $ App e1' e2' toTT (EType u) = return $ TType u toTT EErased = return Erased toTT (EConstant c) = return (Constant c)-toTT (EThunk i) = return (P (DCon 0 0) (sMN i "THUNK") Erased) --(force i) >>= toTT+toTT (EThunk ctxt env tm) = do env' <- mapM toBinder env+                               return $ normalise ctxt env' tm+  where toBinder (n, v) = do v' <- toTT v+                             return (n, Let Erased v') toTT (EHandle _) = return Erased  unApplyV :: ExecVal -> (ExecVal, [ExecVal])@@ -111,11 +113,11 @@  initState :: Idris ExecState initState = do ist <- getIState-               return $ ExecState M.empty 0 (idris_implicits ist) (idris_dynamic_libs ist)+               return $ ExecState (idris_dynamic_libs ist) -type Exec = ErrorT String (StateT ExecState IO)+type Exec = ErrorT Err (StateT ExecState IO) -runExec :: Exec a -> ExecState -> IO (Either String a)+runExec :: Exec a -> ExecState -> IO (Either Err a) runExec ex st = fst <$> runStateT (runErrorT ex) st  getExecState :: Exec ExecState@@ -124,53 +126,21 @@ putExecState :: ExecState -> Exec () putExecState = lift . put -execFail :: String -> Exec a+execFail :: Err -> Exec a execFail = throwError  execIO :: IO a -> Exec a execIO = lift . lift -delay :: ExecEnv -> Context -> Term -> Exec ExecVal-delay env ctxt tm =-    do st <- getExecState-       let i = exec_next_thunk st-       putExecState $ st { exec_thunks = M.insert i (Delayed env ctxt tm) (exec_thunks st)-                         , exec_next_thunk = exec_next_thunk st + 1-                         }-       return $ EThunk i -force :: Int -> Exec ExecVal-force i = do st <- getExecState-             case M.lookup i (exec_thunks st) of-               Just (Delayed env ctxt tm) -> do tm' <- doExec env ctxt tm-                                                case tm' of-                                                  EThunk i ->-                                                      do res <- force i-                                                         update res i-                                                         return res-                                                  _ -> do update tm' i-                                                          return tm'-               Just (Forced tm) -> return tm-               Nothing -> execFail "Tried to exec non-existing thunk. This is a bug!"-    where update :: ExecVal -> Int -> Exec ()-          update tm i = do est <- getExecState-                           putExecState $ est { exec_thunks = M.insert i (Forced tm) (exec_thunks est) }--tryForce :: ExecVal -> Exec ExecVal-tryForce (EThunk i) = force i-tryForce tm = return tm--debugThunks :: Exec ()-debugThunks = do st <- getExecState-                 execIO $ putStrLn (take 4000 (show (exec_thunks st)))- execute :: Term -> Idris Term execute tm = do est <- initState                 ctxt <- getContext-                res <- lift . lift $ flip runExec est $ do res <- doExec [] ctxt tm-                                                           toTT res+                res <- lift . lift . flip runExec est $+                         do res <- doExec [] ctxt tm+                            toTT res                 case res of-                  Left err -> fail err+                  Left err -> ierror err                   Right tm' -> return tm'  ioWrap :: ExecVal -> ExecVal@@ -192,23 +162,34 @@          [CaseOp _ _ _ _ _ (CaseDefs _ ([], STerm tm) _ _)] -> -- nullary fun              doExec env ctxt tm          [CaseOp _ _ _ _ _ (CaseDefs _ (ns, sc) _ _)] -> return (EP Ref n EErased)-         [] -> execFail $ "Could not find " ++ show n ++ " in definitions."+         [] -> execFail . Msg $ "Could not find " ++ show n ++ " in definitions."          thing -> trace (take 200 $ "got to " ++ show thing ++ " lookup up " ++ show n) $ undefined doExec env ctxt p@(P Bound n ty) =   case lookup n env of-    Nothing -> execFail "not found"+    Nothing -> execFail . Msg $ "not found"     Just tm -> return tm doExec env ctxt (P (DCon a b) n _) = return (EP (DCon a b) n EErased) doExec env ctxt (P (TCon a b) n _) = return (EP (TCon a b) n EErased) doExec env ctxt v@(V i) | i < length env = return (snd (env !! i))-                        | otherwise      = execFail "env too small"+                        | otherwise      = execFail . Msg $ "env too small" doExec env ctxt (Bind n (Let t v) body) = do v' <- doExec env ctxt v                                              doExec ((n, v'):env) ctxt body doExec env ctxt (Bind n (NLet t v) body) = trace "NLet" $ undefined doExec env ctxt tm@(Bind n b body) = return $                                      EBind n (fmap (\_->EErased) b)                                            (\arg -> doExec ((n, arg):env) ctxt body)-doExec env ctxt a@(App _ _) = execApp env ctxt (unApply a)+doExec env ctxt a@(App _ _) =+  do let (f, args) = unApply a+     f' <- doExec env ctxt f+     args' <- case f' of+                (EP _ d _) | d == delay ->+                  case args of+                    [t,a,tm] -> do t' <- doExec env ctxt t+                                   a' <- doExec env ctxt a+                                   return [t', a', EThunk ctxt env tm]+                    _ -> mapM (doExec env ctxt) args -- partial applications are fine to evaluate+                fun' -> do mapM (doExec env ctxt) args+     execApp env ctxt f' args' doExec env ctxt (Constant c) = return (EConstant c) doExec env ctxt (Proj tm i) = let (x, xs) = unApply tm in                               doExec env ctxt ((x:xs) !! i)@@ -216,120 +197,138 @@ doExec env ctxt Impossible = fail "Tried to execute an impossible case" doExec env ctxt (TType u) = return (EType u) -execApp :: ExecEnv -> Context -> (Term, [Term]) -> Exec ExecVal-execApp env ctxt (f, args) = do newF <- doExec env ctxt f-                                laziness <- (++ repeat False) <$> (getLaziness newF)-                                newArgs <- mapM argExec (zip args laziness)-                                res <- execApp' env ctxt newF newArgs-                                return res-    where getLaziness (EP _ l _) | l == sUN "lazy" = return [False, True]-          getLaziness (EP _ n _) = do est <- getExecState-                                      let argInfo = exec_implicits est-                                      case lookupCtxtName n argInfo of-                                        [] -> return (repeat False)-                                        [ps] -> return $ map lazyarg (snd ps)-                                        many -> execFail $ "Ambiguous " ++ show n ++ ", found " ++ (take 200 $ show many)-          getLaziness _ = return (repeat False) -- ok due to zip above-          argExec :: (Term, Bool) -> Exec ExecVal-          argExec (tm, False) = doExec env ctxt tm-          argExec (tm, True) = delay env ctxt tm---execApp' :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal-execApp' env ctxt v [] = return v -- no args is just a constant! can result from function calls-execApp' env ctxt (EP _ fp _) (ty:action:rest) +execApp :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal+execApp env ctxt v [] = return v -- no args is just a constant! can result from function calls+execApp env ctxt (EP _ f _) (t:a:delayed:rest)+  | f == force+  , (_, [_, _, EThunk tmCtxt tmEnv tm]) <- unApplyV delayed =+    do tm' <- doExec tmEnv tmCtxt tm+       execApp env ctxt tm' rest+execApp env ctxt (EP _ fp _) (ty:action:rest)   | fp == upio,     (prim__IO, [_, v]) <- unApplyV action-       = execApp' env ctxt v rest+       = execApp env ctxt v rest -execApp' env ctxt (EP _ fp _) args@(_:_:v:k:rest) +execApp env ctxt (EP _ fp _) args@(_:_:v:k:rest)   | fp == piobind,     (prim__IO, [_, v']) <- unApplyV v =-    do v'' <- tryForce v'-       res <- execApp' env ctxt k [v''] >>= tryForce-       execApp' env ctxt res rest-execApp' env ctxt con@(EP _ fp _) args@(tp:v:rest)-  | fp == pioret =-    do v' <- tryForce v-       execApp' env ctxt (mkEApp con [tp, v']) rest+    do res <- execApp env ctxt k [v']+       execApp env ctxt res rest+execApp env ctxt con@(EP _ fp _) args@(tp:v:rest)+  | fp == pioret = execApp env ctxt (mkEApp con [tp, v]) rest  -- Special cases arising from not having access to the C RTS in the interpreter-execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str arg):_:rest)+execApp env ctxt (EP _ fp _) (_:fn:str:_:rest)     | fp == mkfprim,-      Just (FFun "putStr" _ _) <- foreignFromTT fn -           = do execIO (putStr arg)-                execApp' env ctxt ioUnit rest-execApp' env ctxt (EP _ fp _) (_:fn:_:EHandle h:_:rest)+      Just (FFun "putStr" _ _) <- foreignFromTT fn+           = case str of+               EConstant (Str arg) -> do execIO (putStr arg)+                                         execApp env ctxt ioUnit rest+               _ -> execFail . Msg $+                      "The argument to putStr should be a constant string, but it was " +++                      show str +++                      ". Are all cases covered?"+execApp env ctxt (EP _ fp _) (_:fn:ch:_:rest)     | fp == mkfprim,+      Just (FFun "putchar" _ _) <- foreignFromTT fn+           = case ch of+               EConstant (Ch c) -> do execIO (putChar c)+                                      execApp env ctxt ioUnit rest+               EConstant (I i)  -> do execIO (putChar (toEnum i))+                                      execApp env ctxt ioUnit rest+               _ -> execFail . Msg $+                      "The argument to putchar should be a constant character, but it was " +++                      show str +++                      ". Are all cases covered?"+execApp env ctxt (EP _ fp _) (_:fn:_:handle:_:rest)+    | fp == mkfprim,       Just (FFun "idris_readStr" _ _) <- foreignFromTT fn-           = do contents <- execIO $ hGetLine h-                execApp' env ctxt (EConstant (Str (contents ++ "\n"))) rest-execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)+           = case handle of+               EHandle h -> do contents <- execIO $ hGetLine h+                               execApp env ctxt (EConstant (Str (contents ++ "\n"))) rest+               _ -> execFail . Msg $+                      "The argument to idris_readStr should be a handle, but it was " +++                      show handle +++                      ". Are all cases covered?"+execApp env ctxt (EP _ fp _) (_:fn:fileStr:modeStr:rest)     | fp == mkfprim,       Just (FFun "fileOpen" _ _) <- foreignFromTT fn-           = do f <- execIO $-                     catch (do let m = case mode of-                                         "r"  -> Right ReadMode-                                         "w"  -> Right WriteMode-                                         "a"  -> Right AppendMode-                                         "rw" -> Right ReadWriteMode-                                         "wr" -> Right ReadWriteMode-                                         "r+" -> Right ReadWriteMode-                                         _    -> Left ("Invalid mode for " ++ f ++ ": " ++ mode)-                               case fmap (openFile f) m of-                                 Right h -> do h' <- h; return $ Right (ioWrap (EHandle h'), tail rest)-                                 Left err -> return $ Left err)-                           (\e -> let _ = ( e::SomeException)-                                  in return $ Right (ioWrap (EPtr nullPtr), tail rest))-                case f of-                  Left err -> execFail err-                  Right (res, rest) -> execApp' env ctxt res rest+           = case (fileStr, modeStr) of+               (EConstant (Str f), EConstant (Str mode)) ->+                 do f <- execIO $+                         catch (do let m = case mode of+                                             "r"  -> Right ReadMode+                                             "w"  -> Right WriteMode+                                             "a"  -> Right AppendMode+                                             "rw" -> Right ReadWriteMode+                                             "wr" -> Right ReadWriteMode+                                             "r+" -> Right ReadWriteMode+                                             _    -> Left ("Invalid mode for " ++ f ++ ": " ++ mode)+                                   case fmap (openFile f) m of+                                     Right h -> do h' <- h; return $ Right (ioWrap (EHandle h'), tail rest)+                                     Left err -> return $ Left err)+                               (\e -> let _ = ( e::SomeException)+                                      in return $ Right (ioWrap (EPtr nullPtr), tail rest))+                    case f of+                      Left err -> execFail . Msg $ err+                      Right (res, rest) -> execApp env ctxt res rest+               _ -> execFail . Msg $+                      "The arguments to fileOpen should be constant strings, but they were " +++                      show fileStr ++ " and " ++ show modeStr +++                      ". Are all cases covered?" -execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)+execApp env ctxt (EP _ fp _) (_:fn:handle:rest)     | fp == mkfprim,       Just (FFun "fileEOF" _ _) <- foreignFromTT fn-           = do eofp <- execIO $ hIsEOF h-                let res = ioWrap (EConstant (I $ if eofp then 1 else 0))-                execApp' env ctxt res (tail rest)+           = case handle of+               EHandle h -> do eofp <- execIO $ hIsEOF h+                               let res = ioWrap (EConstant (I $ if eofp then 1 else 0))+                               execApp env ctxt res (tail rest)+               _ -> execFail . Msg $+                      "The argument to fileEOF should be a file handle, but it was " +++                      show handle +++                      ". Are all cases covered?" -execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)+execApp env ctxt (EP _ fp _) (_:fn:handle:rest)     | fp == mkfprim,       Just (FFun "fileClose" _ _) <- foreignFromTT fn-           = do execIO $ hClose h-                execApp' env ctxt ioUnit (tail rest)+           = case handle of+               EHandle h -> do execIO $ hClose h+                               execApp env ctxt ioUnit (tail rest)+               _ -> execFail . Msg $+                      "The argument to fileClose should be a file handle, but it was " +++                      show handle +++                      ". Are all cases covered?" -execApp' env ctxt (EP _ fp _) (_:fn:(EPtr p):rest)+execApp env ctxt (EP _ fp _) (_:fn:ptr:rest)     | fp == mkfprim,       Just (FFun "isNull" _ _) <- foreignFromTT fn-           = let res = ioWrap . EConstant . I $-                       if p == nullPtr then 1 else 0-             in execApp' env ctxt res (tail rest)+           = case ptr of+               EPtr p -> let res = ioWrap . EConstant . I $+                                   if p == nullPtr then 1 else 0+                         in execApp env ctxt res (tail rest)+               -- Handles will be checked as null pointers sometimes - but if we got a+               -- real Handle, then it's valid, so just return 1.+               EHandle h -> let res = ioWrap . EConstant . I $ 0+                            in execApp env ctxt res (tail rest)+               -- A foreign-returned char* has to be tested for NULL sometimes+               EConstant (Str s) -> let res = ioWrap . EConstant . I $ 0+                                    in execApp env ctxt res (tail rest)+               _ -> execFail . Msg $+                      "The argument to isNull should be a pointer or file handle or string, but it was " +++                      show ptr +++                      ". Are all cases covered?" --- Handles will be checked as null pointers sometimes - but if we got a--- real Handle, then it's valid, so just return 1.-execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)-    | fp == mkfprim,-      Just (FFun "isNull" _ _) <- foreignFromTT fn-           = let res = ioWrap . EConstant . I $ 0-             in execApp' env ctxt res (tail rest) --- A foreign-returned char* has to be tested for NULL sometimes-execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str s):rest)-    | fp == mkfprim,-      Just (FFun "isNull" _ _) <- foreignFromTT fn-           = let res = ioWrap . EConstant . I $ 0-                 in execApp' env ctxt res (tail rest)- -- Right now, there's no way to send command-line arguments to the executor, -- so just return 0.-execApp' env ctxt (EP _ fp _) (_:fn:rest)+execApp env ctxt (EP _ fp _) (_:fn:rest)     | fp == mkfprim,       Just (FFun "idris_numArgs" _ _) <- foreignFromTT fn            = let res = ioWrap . EConstant . I $ 0-             in execApp' env ctxt res (tail rest)--- Throw away the 'World' argument to the foreign function+             in execApp env ctxt res (tail rest) -execApp' env ctxt f@(EP _ fp _) args@(ty:fn:xs) | fp == mkfprim+execApp env ctxt f@(EP _ fp _) args@(ty:fn:xs) | fp == mkfprim    = case foreignFromTT fn of         Just (FFun f argTs retT) | length xs >= length argTs ->            do let (args', xs') = (take (length argTs) xs, -- foreign args@@ -341,43 +340,41 @@                    Just r -> return (mkEApp r xs')         Nothing -> return (mkEApp f args) -execApp' env ctxt c@(EP (DCon _ arity) n _) args =-    do args' <- mapM tryForce (take arity args)+execApp env ctxt c@(EP (DCon _ arity) n _) args =+    do let args' = take arity args        let restArgs = drop arity args-       execApp' env ctxt (mkEApp c args') restArgs+       execApp env ctxt (mkEApp c args') restArgs -execApp' env ctxt c@(EP (TCon _ arity) n _) args =-    do args' <- mapM tryForce (take arity args)+execApp env ctxt c@(EP (TCon _ arity) n _) args =+    do let args' = take arity args        let restArgs = drop arity args-       execApp' env ctxt (mkEApp c args') restArgs+       execApp env ctxt (mkEApp c args') restArgs -execApp' env ctxt f@(EP _ n _) args =+execApp env ctxt f@(EP _ n _) args =     do let val = lookupDef n ctxt        case val of          [Function _ tm] -> fail "should already have been eval'd"          [TyDecl nt ty] -> return $ mkEApp f args          [Operator tp arity op] ->              if length args >= arity-               then do args' <- mapM tryForce $ take arity args-                       case getOp n args' of-                         Just res -> do r <- res-                                        execApp' env ctxt r (drop arity args)-                         Nothing -> return (mkEApp f args)+               then let args' = take arity args in+                    case getOp n args' of+                      Just res -> do r <- res+                                     execApp env ctxt r (drop arity args)+                      Nothing -> return (mkEApp f args)                else return (mkEApp f args)          [CaseOp _ _ _ _ _ (CaseDefs _ ([], STerm tm) _ _)] -> -- nullary fun              do rhs <- doExec env ctxt tm-                execApp' env ctxt rhs args+                execApp env ctxt rhs args          [CaseOp _ _ _ _ _ (CaseDefs _ (ns, sc) _ _)] ->              do res <- execCase env ctxt ns sc args                 return $ fromMaybe (mkEApp f args) res          thing -> return $ mkEApp f args-execApp' env ctxt bnd@(EBind n b body) (arg:args) = do ret <- body arg-                                                       let (f', as) = unApplyV ret-                                                       execApp' env ctxt f' (as ++ args)-execApp' env ctxt (EThunk i) args = do f <- force i-                                       execApp' env ctxt f args-execApp' env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp' env ctxt f (args1 ++ args2)-execApp' env ctxt f args = return (mkEApp f args)+execApp env ctxt bnd@(EBind n b body) (arg:args) = do ret <- body arg+                                                      let (f', as) = unApplyV ret+                                                      execApp env ctxt f' (as ++ args)+execApp env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp env ctxt f (args1 ++ args2)+execApp env ctxt f args = return (mkEApp f args)  prs = sUN "prim__readString" pbm = sUN "prim__believe_me"@@ -386,6 +383,8 @@ pioret = sUN "prim_io_return" piobind = sUN "prim_io_bind" upio = sUN "unsafePerformPrimIO"+delay = sUN "Delay"+force = sUN "Force"  -- | Look up primitive operations in the global table and transform them into ExecVal functions getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal)@@ -426,7 +425,7 @@ --            trace ("Case " ++ show sc ++ "\n   in " ++ show amap ++"\n   in env " ++ show env ++ "\n\n" ) $ return ()             caseRes <- execCase' env ctxt amap sc             case caseRes of-              Just res -> Just <$> execApp' (map (\(n, tm) -> (n, tm)) amap ++ env) ctxt res (drop arity args)+              Just res -> Just <$> execApp (map (\(n, tm) -> (n, tm)) amap ++ env) ctxt res (drop arity args)               Nothing -> return Nothing     else return Nothing @@ -436,8 +435,7 @@ execCase' env ctxt amap (STerm tm) =     Just <$> doExec (map (\(n, v) -> (n, v)) amap ++ env) ctxt tm execCase' env ctxt amap (Case n alts) | Just tm <- lookup n amap =-    do tm' <- tryForce tm-       case chooseAlt tm' alts of+       case chooseAlt tm alts of          Just (newCase, newBindings) ->              let amap' = newBindings ++ (filter (\(x,_) -> not (elem x (map fst newBindings))) amap) in              execCase' env ctxt amap' newCase
src/Idris/Core/ProofState.hs view
@@ -15,7 +15,7 @@  import Control.Monad.State.Strict import Control.Applicative hiding (empty)-import Control.Arrow (first)+import Control.Arrow ((***)) import Data.List import Debug.Trace @@ -59,6 +59,7 @@             | Solve             | StartUnify Name             | EndUnify+            | UnifyAll             | Compute             | ComputeLet Name             | Simplify@@ -179,6 +180,19 @@ -- --              ++ show (pterm ps) --              ++ "\n----------") $ +mergeSolutions :: Env -> [(Name, TT Name)] -> StateT TState TC [(Name, TT Name)]+mergeSolutions env ns = merge [] ns+  where+    merge acc [] = return (reverse acc)+    merge acc ((n, t) : ns)+          | Just t' <- lookup n ns+              = do ps <- get+                   let probs = problems ps+                   put (ps { problems = probs ++ [(t,t',env,Msg "New problem",+                                                     [], Unify)] })+                   merge acc ns+          | otherwise = merge ((n, t): acc) ns+ unify' :: Context -> Env -> TT Name -> TT Name ->           StateT TState TC [(Name, TT Name)] unify' ctxt env topx topy =@@ -205,16 +219,22 @@              ++ "\nCurrent problems:\n" ++ qshow (problems ps) --              ++ show (pterm ps)              ++ "\n----------") $-        do ps <- get-           let (h, ns) = unified ps-           let (ns', probs') = updateProblems (context ps) (u ++ ns)+        do let (h, ns) = unified ps+           -- if a metavar has multiple solutions, make a new unification+           -- problem for each.+           uns <- mergeSolutions env (u ++ ns)+           ps <- get+           let (ns', probs') = updateProblems (context ps) uns                                               (fails ++ problems ps)                                               (injective ps)                                               (holes ps)-           put (ps { problems = probs',-                     unified = (h, ns'),-                     injective = updateInj u (injective ps),-                     notunified = notu ++ notunified ps })+           let (notu', probs_notu) = mergeNotunified env (notu ++ notunified ps)+           traceWhen (unifylog ps)+            ("Now solved: " ++ show ns') $+             put (ps { problems = probs' ++ probs_notu,+                       unified = (h, ns'),+                       injective = updateInj u (injective ps),+                       notunified = notu' })            return u   where updateInj ((n, a) : us) inj               | (P _ n' _, _) <- unApply a,@@ -664,7 +684,7 @@              let scr      = last $ tail args'              let indxnames = makeIndexNames indicies              prop <- replaceIndicies indxnames indicies $ Bind nm (Lam tmt') t-             consargs' <- query (\ps -> map (first $ flip (uniqueNameCtxt (context ps)) (holes ps)) consargs)+             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)))                                                         (params ++ [prop] ++ map makeConsArg consargs' ++ indicies ++ [tmv])))              action (\ps -> ps {holes = holes ps \\ [x]})@@ -781,13 +801,15 @@    | n `elem` du = u : keepGiven du us hs keepGiven du (u : us) hs = keepGiven du us hs +updateSolved :: [(Name, Term)] -> Term -> Term  updateSolved xs x = updateSolved' xs x updateSolved' [] x = x updateSolved' xs (Bind n (Hole ty) t)     | Just v <- lookup n xs          = case xs of-               [_] -> psubst n v t-               _ -> psubst n v (updateSolved' xs t)+               [_] -> substV v $ psubst n v t -- some may be Vs! Can't assume+                                              -- explicit names+               _ -> substV v $ psubst n v (updateSolved' xs t) updateSolved' xs (Bind n b t)     | otherwise = Bind n (fmap (updateSolved' xs) b) (updateSolved' xs t) updateSolved' xs (App f a) @@ -810,6 +832,15 @@    = ((psubst x val l, psubst x val r,         updateEnv [(x, val)] env, err) : solveInProblems x val ps) +mergeNotunified :: Env -> [(Name, Term)] -> ([(Name, Term)], Fails)+mergeNotunified env ns = mnu ns [] [] where+  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)+      | otherwise = mnu ns ((n,t) : ns_acc) ps_acc+ updateNotunified [] nu = nu updateNotunified ns nu = up nu where   up [] = []@@ -826,7 +857,7 @@         y' = updateSolved ns y         err' = updateError ns err         env' = updateEnv ns env in---         trace ("Updating " ++ show (x',y')) $ +--          trace ("Updating " ++ show (x',y')) $            case unify ctxt env' x' y' inj holes while of             OK (v, []) -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $                                up (ns ++ v) ps@@ -860,7 +891,7 @@                            _  -> fail "Still holes to fill." processTactic ProofState ps = return (ps, showEnv [] (pterm ps)) processTactic Undo ps = case previous ps of-                            Nothing -> fail "Nothing to undo."+                            Nothing -> Error . Msg $ "Nothing to undo."                             Just pold -> return (pold, "") processTactic EndUnify ps     = let (h, ns_in) = unified ps@@ -874,6 +905,11 @@                        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',+                       notunified = [],+                       holes = holes ps \\ map fst (notunified ps) }, "") processTactic (Reorder n) ps     = do ps' <- execStateT (tactic (Just n) reorder_claims) ps          return (ps' { previous = Just ps, plog = "" }, plog ps')
src/Idris/Core/TC.hs view
@@ -2,6 +2,7 @@  module Idris.Core.TC(TC'(..)) where +import Control.Applicative import Control.Monad import Control.Monad.Trans.Error(Error(..)) @@ -26,3 +27,11 @@     _ `mplus` (OK y) = OK y     err `mplus` _    = err ++instance Error e => Applicative (TC' e) where+    pure = return+    (<*>) = ap++instance Error e => Alternative (TC' e) where+    empty = mzero+    (<|>) = mplus
src/Idris/Core/TT.hs view
@@ -27,6 +27,7 @@ import Debug.Trace import qualified Data.Map.Strict as Map import Data.Char+import Numeric (showIntAtBase) import qualified Data.Text as T import Data.List import Data.Maybe (listToMaybe)@@ -92,8 +93,9 @@                         -- ^^ The name, classification, docs overview, and pretty-printed type                       | AnnBoundName Name Bool                         -- ^^ The name and whether it is implicit-                      | AnnConstData-                      | AnnConstType+                      | AnnConst Const+                      | AnnData String String -- ^ type, doc overview+                      | AnnType String String -- ^ name, doc overview                       | AnnKeyword                       | AnnFC FC                       | AnnTextFmt TextFormatting@@ -182,9 +184,12 @@ score (CantUnify _ _ _ m _ s) = s + score m score (CantResolve _) = 20 score (NoSuchVariable _) = 1000-score (ProofSearchFail _) = 10000-score (CantSolveGoal _ _) = 10000+score (ProofSearchFail e) = score e+score (CantSolveGoal _ _) = 100000 score (InternalMsg _) = -1+score (At _ e) = score e+score (ElaboratingArg _ _ _ e) = score e+score (Elaborating _ _ e) = score e score _ = 0  instance Show Err where@@ -201,6 +206,7 @@     show (ElaboratingArg f x prev e) = "Elaborating " ++ show f ++ " arg " ++                                        show x ++ ": " ++ show e     show (Elaborating what n e) = "Elaborating " ++ what ++ show n ++ ":" ++ show e+    show (ProofSearchFail e) = "Proof search fail: " ++ show e     show _ = "Error"  instance Pretty Err OutputAnnotation where@@ -256,7 +262,7 @@ data Name = UN T.Text -- ^ User-provided name           | NS Name [T.Text] -- ^ Root, namespaces           | MN Int T.Text -- ^ Machine chosen names-          | NErased -- ^ Name of somethng which is never used in scope+          | NErased -- ^ Name of something which is never used in scope           | SN SpecialName -- ^ Decorated function names           | SymRef Int -- ^ Reference to IBC file symbol table (used during serialisation)   deriving (Eq, Ord)@@ -383,6 +389,7 @@ nsroot (NS n _) = n nsroot n = n +-- this will overwrite already existing definitions addDef :: Name -> a -> Ctxt a -> Ctxt a addDef n v ctxt = case Map.lookup (nsroot n) ctxt of                         Nothing -> Map.insert (nsroot n)@@ -425,6 +432,9 @@ lookupCtxtExact :: Name -> Ctxt a -> Maybe a lookupCtxtExact n ctxt = listToMaybe [ v | (nm, v) <- lookupCtxtName n ctxt, nm == n] +deleteDefExact :: Name -> Ctxt a -> Ctxt a+deleteDefExact n = Map.adjust (Map.delete n) (nsroot n)+ updateDef :: Name -> (a -> a) -> Ctxt a -> Ctxt a updateDef n f ctxt   = let ds = lookupCtxtName n ctxt in@@ -432,7 +442,7 @@  toAlist :: Ctxt a -> [(Name, a)] toAlist ctxt = let allns = map snd (Map.toList ctxt) in-                concat (map (Map.toList) allns)+                concatMap (Map.toList) allns  addAlist :: Show a => [(Name, a)] -> Ctxt a -> Ctxt a addAlist [] ctxt = ctxt@@ -520,6 +530,60 @@   pretty (B32 w) = text . show $ w   pretty (B64 w) = text . show $ w +-- | Determines whether the input constant represents a type+constIsType :: Const -> Bool+constIsType (I _) = False+constIsType (BI _) = False+constIsType (Fl _) = False+constIsType (Ch _) = False+constIsType (Str _) = False+constIsType (B8 _) = False+constIsType (B16 _) = False+constIsType (B32 _) = False+constIsType (B64 _) = False+constIsType (B8V _) = False+constIsType (B16V _) = False+constIsType (B32V _) = False+constIsType (B64V _) = False+constIsType _ = True++-- | Get the docstring for a Const+constDocs :: Const -> String+constDocs c@(AType (ATInt ITBig))          = "Arbitrary-precision integers"+constDocs c@(AType (ATInt ITNative))       = "Fixed-precision integers of undefined size"+constDocs c@(AType (ATInt ITChar))         = "Characters in some unspecified encoding"+constDocs c@(AType ATFloat)                = "Double-precision floating-point numbers"+constDocs StrType                          = "Strings in some unspecified encoding"+constDocs PtrType                          = "Foreign pointers"+constDocs ManagedPtrType                   = "Managed pointers"+constDocs BufferType                       = "Copy-on-write buffers"+constDocs c@(AType (ATInt (ITFixed IT8)))  = "Eight bits (unsigned)"+constDocs c@(AType (ATInt (ITFixed IT16))) = "Sixteen bits (unsigned)"+constDocs c@(AType (ATInt (ITFixed IT32))) = "Thirty-two bits (unsigned)"+constDocs c@(AType (ATInt (ITFixed IT64))) = "Sixty-four bits (unsigned)"+constDocs c@(AType (ATInt (ITVec IT8 16))) = "Vectors of sixteen eight-bit values"+constDocs c@(AType (ATInt (ITVec IT16 8))) = "Vectors of eight sixteen-bit values"+constDocs c@(AType (ATInt (ITVec IT32 4))) = "Vectors of four thirty-two-bit values"+constDocs c@(AType (ATInt (ITVec IT64 2))) = "Vectors of two sixty-four-bit values"+constDocs (Fl f)                           = "A float"+constDocs (I i)                            = "A fixed-precision integer"+constDocs (BI i)                           = "An arbitrary-precision integer"+constDocs (Str s)                          = "A string of length " ++ show (length s)+constDocs (Ch c)                           = "A character"+constDocs (B8 w)                           = "The eight-bit value 0x" +++                                             showIntAtBase 16 intToDigit w ""+constDocs (B16 w)                          = "The sixteen-bit value 0x" +++                                             showIntAtBase 16 intToDigit w ""+constDocs (B32 w)                          = "The thirty-two-bit value 0x" +++                                             showIntAtBase 16 intToDigit w ""+constDocs (B64 w)                          = "The sixty-four-bit value 0x" +++                                             showIntAtBase 16 intToDigit w ""+constDocs (B8V v)                          = "A vector of eight-bit values"+constDocs (B16V v)                         = "A vector of sixteen-bit values"+constDocs (B32V v)                         = "A vector of thirty-two-bit values"+constDocs (B64V v)                         = "A vector of sixty-four-bit values"+constDocs prim                             = "Undocumented"+ data Raw = Var Name          | RBind Name (Binder Raw) Raw          | RApp Raw Raw@@ -996,8 +1060,9 @@  uniqueBinders :: [Name] -> TT Name -> TT Name uniqueBinders ns (Bind n b sc)-    = let n' = uniqueName n ns in-          Bind n' (fmap (uniqueBinders (n':ns)) b) (uniqueBinders ns sc)+    = let n' = uniqueName n ns+          ns' = n' : ns in+          Bind n' (fmap (uniqueBinders ns') b) (uniqueBinders ns' sc) uniqueBinders ns (App f a) = App (uniqueBinders ns f) (uniqueBinders ns a) uniqueBinders ns t = t @@ -1222,3 +1287,12 @@             = (n', t') : insert n t ps         | otherwise = (n,t):(n',t'):ps +allTTNames :: Eq n => TT n -> [n]+allTTNames = nub . allNamesIn+  where allNamesIn (P _ n _) = [n]+        allNamesIn (Bind n b t) = [n] ++ nb b ++ allNamesIn t+          where nb (Let   t v) = allNamesIn t ++ allNamesIn v+                nb (Guess t v) = allNamesIn t ++ allNamesIn v+                nb t = allNamesIn (binderTy t)+        allNamesIn (App f a) = allNamesIn f ++ allNamesIn a+        allNamesIn _ = []
src/Idris/Core/Unify.hs view
@@ -69,7 +69,20 @@                               return (map (renameBinders env) (trimSolutions v))                            _ -> tfail e   where-+    -- This rule is highly dubious... it certainly produces a valid answer+    -- but it scares me. However, matching is never guaranteed to give a unique+    -- answer, merely a valid one, so perhaps we're okay.+    -- In other words: it may vanish without warning some day :)+    un names x tm@(App (P _ f (Bind fn (Pi t) sc)) a)+        | (P (DCon _ _) _ _, _) <- unApply x,+          holeIn env f || f `elem` holes+           = let n' = uniqueName (sMN 0 "mv") (map fst env) in+                 checkCycle names (f, Bind n' (Lam t) x) +    un names tm@(App (P _ f (Bind fn (Pi t) sc)) a) x+        | (P (DCon _ _) _ _, _) <- unApply x,+          holeIn env f || f `elem` holes+           = 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@@ -85,7 +98,7 @@         | length bnames > i,           fst (fst (bnames!!i)) == x ||            snd (fst (bnames!!i)) == x = do sc 1; return []-    un bnames (Bind x bx sx) (Bind y by sy)+    un bnames (Bind x bx sx) (Bind y by sy) | notHole bx && notHole by         = do h1 <- uB bnames bx by              h2 <- un (((x, y), binderTy bx) : bnames) sx sy              combine bnames h1 h2@@ -119,6 +132,9 @@                        put (UI s ((binderTy x, binderTy y, env, err, from, Match) : f))                        return [] +    notHole (Hole _) = False+    notHole _ = True+     -- TODO: there's an annoying amount of repetition between this and the     -- main unification function. Consider lifting it out. @@ -173,7 +189,7 @@     uniqueBinders env (Bind n b sc)         | n `elem` env               = let n' = uniqueName n env in-                   Bind n' (fmap (uniqueBinders env) b)+                   explicitHole $ Bind n' (fmap (uniqueBinders env) b)                            (uniqueBinders (n':env) (rename n n' sc))         | otherwise = Bind n (fmap (uniqueBinders (n:env)) b)                               (uniqueBinders (n:env) sc)@@ -185,6 +201,10 @@     rename n n' (App f a) = App (rename n n' f) (rename n n' a)     rename n n' t = t +    explicitHole (Bind n (Hole ty) sc) +       = Bind n (Hole ty) (instantiate (P Bound n ty) sc)+    explicitHole t = t+ trimSolutions ns = dropPairs ns   where dropPairs [] = []         dropPairs (n@(x, P _ x' _) : ns)@@ -204,11 +224,16 @@     doSubst (_ : env) tm         = doSubst env tm +hasv (V x) = True+hasv (App f a) = hasv f || hasv a+hasv (Bind x b sc) = hasv (binderTy b) || hasv sc+hasv _ = False  unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> [FailContext] ->          TC ([(Name, TT Name)], Fails) unify ctxt env topx topy inj holes from =---      trace ("Unifying " ++ show (topx, topy)) $+--      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       case runStateT (un False [] (renameBindersTm env topx)                                    (renameBindersTm env topy)) (UI 0 []) of@@ -295,7 +320,7 @@         | injective ty && not (holeIn env x || x `elem` holes)              = unifyTmpFail tx ty     un' fn bnames xtm@(P _ x _) tm-        | holeIn env x || x `elem` holes+        | pureTerm tm, holeIn env x || x `elem` holes                        = do UI s f <- get                             -- injectivity check                             x <- checkCycle bnames (x, tm)@@ -305,11 +330,11 @@                                  then unifyTmpFail xtm tm                                  else do sc 1                                          return x-        | not (injective xtm) && injective tm +        | pureTerm tm, not (injective xtm) && injective tm                         = do checkCycle bnames (x, tm)                             unifyTmpFail xtm tm     un' fn bnames tm ytm@(P _ y _)-        | holeIn env y || y `elem` holes+        | pureTerm tm, holeIn env y || y `elem` holes                        = do UI s f <- get                             -- injectivity check                             x <- checkCycle bnames (y, tm)@@ -319,7 +344,7 @@                                  then unifyTmpFail tm ytm                                  else do sc 1                                          return x-        | not (injective ytm) && injective tm +        | pureTerm tm, not (injective ytm) && injective tm                         = do checkCycle bnames (y, tm)                             unifyTmpFail tm ytm     un' fn bnames (V i) (P _ x _)@@ -524,7 +549,7 @@         | not (x `elem` freeNames tm) = checkScope ns (x, tm)         | otherwise = lift $ tfail (InfiniteUnify x tm (errEnv env)) -    checkScope ns (x, tm) =+    checkScope ns (x, tm) | pureTerm tm = --           case boundVs (envPos x 0 env) tm of --                [] -> return [(x, tm)] --                (i:_) -> lift $ tfail (UnifyScope x (fst (fst (ns!!i)))@@ -535,6 +560,7 @@                else return [(x, bind v ns tm)]       where inst [] tm = tm             inst (((n, _), _) : ns) tm = inst ns (substV (P Bound n Erased) tm)+    checkScope ns (x, tm) = lift $ tfail (Msg "HOLE ERROR")       bind i ns tm        | i < 0 = tm@@ -588,12 +614,8 @@     | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy" = False recoverable _ t@(App _ _)     | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy" = False-recoverable (P (DCon _ _) x _) (P (DCon _ _) y _)-    | x == y = True-    | otherwise = False-recoverable (P (TCon _ _) x _) (P (TCon _ _) y _)-    | x == y = True-    | otherwise = False+recoverable (P (DCon _ _) x _) (P (DCon _ _) y _) = x == y+recoverable (P (TCon _ _) x _) (P (TCon _ _) y _) = x == y recoverable (Constant _) (P (DCon _ _) y _) = False recoverable (P (DCon _ _) x _) (Constant _) = False recoverable (Constant _) (P (TCon _ _) y _) = False@@ -612,7 +634,9 @@ recoverable (Bind _ (Pi _) sc) f     | (P (DCon _ _) _ _, _) <- unApply f = False     | (P (TCon _ _) _ _, _) <- unApply f = False-recoverable _ _ = True+recoverable (Bind _ (Lam _) sc) f = recoverable sc f+recoverable f (Bind _ (Lam _) sc) = recoverable f sc+recoverable x y = True  errEnv = map (\(x, b) -> (x, binderTy b))
src/Idris/Coverage.hs view
@@ -9,7 +9,7 @@ import Idris.AbsSyntax import Idris.Delaborate import Idris.Error-import Idris.Output (iputStrLn)+import Idris.Output (iWarn, iputStrLn)  import Data.List import Data.Either@@ -72,8 +72,9 @@         -- there may be more case splitting that the idris_implicits record         -- suggests)         let parg = case lookupCtxt n (idris_implicits i) of-                        (p : _) -> p ++ repeat (PExp 0 [] Placeholder)-                        _ -> repeat (pexp Placeholder)+                        (p : _) -> +                          p ++ repeat (PExp 0 [] (sMN 0 "gcarg") Placeholder)+                        _       -> repeat (pexp Placeholder)         let tryclauses = mkClauses parg all_args         logLvl 2 $ show (length tryclauses) ++ " initially to check"         logLvl 1 $ showSep "\n" (map (showTm i) tryclauses)@@ -210,7 +211,7 @@                  let p = resugar (PApp fc (PRef fc n) (zipWith upd xs' xs))                  let tyn = getTy n (tt_ctxt i)                  case lookupCtxt tyn (idris_datatypes i) of-                         (TI ns _ _ _ : _) -> p : map (mkPat fc) (ns \\ [n])+                         (TI ns _ _ _ _ : _) -> p : map (mkPat fc) (ns \\ [n])                          _ -> [p]     ops fc n arg o = return Placeholder @@ -252,40 +253,51 @@ checkAllCovering fc done top n | not (n `elem` done)    = do i <- get         case lookupTotal n (tt_ctxt i) of-             [tot@(Partial NotCovering)] -> -                  tclift $ tfail (At fc (Msg (show top ++ " is " ++ show tot-                                     ++ " due to " ++ show n)))-             _ -> return ()-        case lookupCtxt n (idris_callgraph i) of-             [cg] -> mapM_ (checkAllCovering fc (n : done) top) -                           (map fst (calls cg))-             _ -> return ()+             [tot@(Partial NotCovering)] ->+                    do let msg = show top ++ " is " ++ show tot ++ " due to " ++ show n+                       putIState i { idris_totcheckfail = (fc, msg) : idris_totcheckfail i }+                       addIBC (IBCTotCheckErr fc msg)+             [Partial _] ->+                case lookupCtxt n (idris_callgraph i) of+                     [cg] -> mapM_ (checkAllCovering fc (n : done) top) +                                   (map fst (calls cg))+                     _ -> return ()+             x -> return () -- stop if total checkAllCovering _ _ _ _ = return () --- Check if, in a given type n, the constructor cn : ty is strictly positive,+-- Check if, in a given group of type declarations mut_ns, +-- the constructor cn : ty is strictly positive, -- and update the context accordingly -checkPositive :: Name -> (Name, Type) -> Idris ()-checkPositive n (cn, ty')-    = do let ty = delazy ty'+checkPositive :: [Name] -> (Name, Type) -> Idris Totality+checkPositive mut_ns (cn, ty')+    = do let ty = delazy' True ty'          let p = cp ty          i <- getIState          let tot = if p then Total (args ty) else Partial NotPositive          let ctxt' = setTotal cn tot (tt_ctxt i)          putIState (i { tt_ctxt = ctxt' })-         logLvl 5 $ "Constructor " ++ show cn ++ " is " ++ show tot+         logLvl 5 $ "Constructor " ++ show cn ++ " is " ++ show tot ++ " with " ++ show mut_ns          addIBC (IBCTotal cn tot)+         return tot   where     args t = [0..length (getArgTys t)-1]      cp (Bind n (Pi aty) sc) = posArg aty && cp sc-    cp t = True+    cp t | (P _ n' _, args) <- unApply t,+           n' `elem` mut_ns = all noRec args +    cp _ = True      posArg (Bind _ (Pi nty) sc)         | (P _ n' _, args) <- unApply nty-            = n /= n' && posArg sc-    posArg t = True+            = n' `notElem` mut_ns && all noRec args && posArg sc+    posArg t | (P _ n' _, args) <- unApply t,+               n' `elem` mut_ns = all noRec args+    posArg _ = True +    noRec arg = all (\x -> x `notElem` mut_ns) (allTTNames arg)++ calcProd :: IState -> FC -> Name -> [([Name], Term, Term)] -> Idris Totality calcProd i fc topn pats     = cp topn pats []@@ -332,7 +344,7 @@      cotype (DCon _ _) n ty         | (P _ t _, _) <- unApply (getRetTy ty)             = case lookupCtxt t (idris_datatypes i) of-                   [TI _ True _ _] -> True+                   [TI _ True _ _ _] -> True                    _ -> False      cotype nt n ty = False @@ -380,6 +392,14 @@                                setTotality n t'                                addIBC (IBCTotal n t')                                return t'+                        [TyDecl (DCon _ _) ty] ->+                            case unApply (getRetTy ty) of+                              (P _ tyn _, _) -> do+                                 let ms = case lookupCtxt tyn (idris_datatypes i) of+                                       [TI _ _ _ _ xs@(_:_)] -> xs+                                       ts -> [tyn]+                                 checkPositive ms (n, ty)+                              _-> return $ Total []                         _ -> return $ Total []                 x -> return x         case t' of@@ -387,18 +407,21 @@             Productive -> return t'             e -> do w <- cmdOptType WarnPartial                     if TotalFn `elem` opts-                       then totalityError t'+                       then do totalityError t'; return t'                        else do when (w && not (PartialFn `elem` opts)) $                                    warnPartial n t'                                return t'   where-    totalityError t = tclift $ tfail (At fc (Msg (show n ++ " is " ++ show t)))+    totalityError t = do i <- getIState+                         let msg = show n ++ " is " ++ show t+                         putIState i { idris_totcheckfail = (fc, msg) : idris_totcheckfail i}+                         addIBC (IBCTotCheckErr fc msg)      warnPartial n t        = do i <- getIState             case lookupDef n (tt_ctxt i) of                [x] -> do-                  iputStrLn $ show fc ++ ":Warning - " ++ show n ++ " is " ++ show t+                  iWarn fc . pprintErr i . Msg $ "Warning - " ++ show n ++ " is " ++ show t --                                ++ "\n" ++ show x --                   let cg = lookupCtxtName Nothing n (idris_callgraph i) --                   iputStrLn (show cg)@@ -409,7 +432,11 @@     = do logLvl 2 $ "Checking " ++ show n ++ " for totality" --          buildSCG (fc, n) --          logLvl 2 $ "Built SCG"-         i <- getIState +         i <- getIState+         let opts = case lookupCtxt n (idris_flags i) of+                              [fs] -> fs+                              _ -> []         +         when (CoveringFn `elem` opts) $ checkAllCovering fc [] n n          t <- checkTotality [] fc n          case t of               -- if it's not total, it can't reduce, to keep@@ -516,7 +543,7 @@       -- find which argument in pargs <a> is smaller than, if any       checkSize a (p : ps) i           | a == p = Just (i, Same)-          | (P _ (UN as) _, [_,arg,_]) <- unApply a,+          | (P _ (UN as) _, [_,_,arg,_]) <- unApply a,             as == txt "assert_smaller" && arg == p                   = Just (i, Smaller)           | smaller Nothing a (p, Nothing) = Just (i, Smaller)@@ -546,7 +573,7 @@        isInductive (P _ nty _) (P _ nty' _) =           let co = case lookupCtxt nty (idris_datatypes ist) of-                        [TI _ x _ _] -> x+                        [TI _ x _ _ _] -> x                         _ -> False in               nty == nty' && not co       isInductive _ _ = False@@ -629,7 +656,7 @@             = case lookupTotal f (tt_ctxt ist) of                    [Total _] -> Unchecked -- okay so far                    [Partial _] -> Partial (Other [f])-                   x -> error (show x)+                   x -> error $ "CAN'T HAPPEN: " ++ (show x)         | [TyDecl (TCon _ _) _] <- lookupDef f (tt_ctxt ist)             = Total []     tryPath desc path (e@(f, args) : es) arg
src/Idris/DataOpts.hs view
@@ -9,225 +9,49 @@ import Idris.Core.TT  import Control.Applicative-import qualified Data.IntMap as M import Data.List import Data.Maybe import Debug.Trace -type ForceMap = M.IntMap Forceability---- Calculate the forceable arguments to a constructor--- and update the set of optimisations.-forceArgs :: Name -> Name -> [Int] -> Type -> Idris ()-forceArgs typeName n expforce t = do-    ist <- getIState-    let fargs = getForcedArgs ist typeName t-        copt = case lookupCtxt n (idris_optimisation ist) of-          []   -> Optimise False False [] []-          op:_ -> op-        opts = addDef n (copt { forceable = M.toList fargs ++-                                            zip expforce (repeat Unconditional) }) -                        (idris_optimisation ist)-    putIState (ist { idris_optimisation = opts })-    addIBC (IBCOpt n)-    iLOG $ "Forced: " ++ show n ++ " " ++ show fargs ++ "\n   from " ++ show t--getForcedArgs :: IState -> Name -> Type -> ForceMap-getForcedArgs ist typeName t = addCollapsibleArgs 0 t $ forcedInTarget 0 t-  where-    maxUnion = M.unionWith max--    -- Label all occurrences of the variable bound in Pi in the rest of-    -- the term with the number i so that we can recognize them anytime later.-    label i = instantiate $ P Bound (sMN i "ctor_arg") Erased--    addCollapsibleArgs :: Int -> Type -> ForceMap -> ForceMap-    addCollapsibleArgs i (Bind vn (Pi ty) rest) alreadyForceable-        = addCollapsibleArgs (i+1) (label i rest) (forceable $ unApply ty)-      where-        -- forceable takes an un-applied type of a ctor argument-        forceable (P _ tn _, args)-            -- if `ty' is collapsible, the argument is unconditionally forceable-            | isCollapsible tn-            = M.insert i Unconditional alreadyForceable--            -- a recursive occurrence with known indices is conditionally forceable-            | tn == typeName-            = M.insertWith max i Conditional alreadyForceable--        forceable _ = alreadyForceable--        isCollapsible :: Name -> Bool-        isCollapsible n = case lookupCtxt n (idris_optimisation ist) of-            [oi] -> collapsible oi-            _    -> False--    addCollapsibleArgs _ _ fs = fs--    forcedInTarget :: Int -> Type -> ForceMap-    forcedInTarget i (Bind _ (Pi _) rest) = forcedInTarget (i+1) (label i rest)-    forcedInTarget i t@(App f a) | (_, as) <- unApply t = unionMap guardedArgs as-    forcedInTarget _ _ = M.empty--    guardedArgs :: Term -> ForceMap-    guardedArgs t@(App f a) | (P (DCon _ _) _ _, args) <- unApply t-        = unionMap bareArg args `maxUnion` unionMap guardedArgs args-    guardedArgs t = bareArg t--    bareArg :: Term -> ForceMap-    bareArg (P _ (MN i ctor_arg) _) -         | ctor_arg == txt "ctor_arg" = M.singleton i Unconditional-    bareArg  _                        = M.empty--    unionMap :: (a -> ForceMap) -> [a] -> ForceMap-    unionMap f = M.unionsWith max . map f---- Calculate whether a collection of constructors is collapsible--- and update the state accordingly.-collapseCons :: Name -> [(Name, Type)] -> Idris ()-collapseCons tn ctors = do-    ist <- getIState-    case ctors of-        _-          | all (ctorCollapsible ist) ctors-          , disjointTerms ctorTargetArgs-            -> mapM_ setCollapsible (tn : map fst ctors)--        [(cn, ct)]-            -> checkNewType ist cn ct--        _ -> return () -- nothing can be done-  where-    ctorTargetArgs = map (snd . unApply . getRetTy . snd) ctors--    ctorArity :: Type -> Int-    ctorArity = length . getArgTys--    ctorCollapsible :: IState -> (Name, Type) -> Bool-    ctorCollapsible ist (n, t) = all (`M.member` forceMap) [0 .. ctorArity t - 1]-      where-        forceMap = case lookupCtxt n (idris_optimisation ist) of-            oi:_ -> M.fromList $ forceable oi-            _    -> M.empty--    -- one constructor; if one remaining argument, treat as newtype-    checkNewType :: IState -> Name -> Type -> Idris ()-    checkNewType ist cn ct-        | oi:_ <- lookupCtxt cn opt-        , length (getArgTys ct) == 1 + forcedCnt (M.fromList $ forceable oi)-            = putIState ist{ idris_optimisation = opt' oi }-        | otherwise = return ()-      where-        opt = idris_optimisation ist-        opt' oi = addDef cn oi{ isnewtype = True } opt--    setCollapsible :: Name -> Idris ()-    setCollapsible n-       = do i <- getIState-            iLOG $ show n ++ " collapsible"-            case lookupCtxt n (idris_optimisation i) of-               (oi:_) -> do let oi' = oi { collapsible = True }-                            let opts = addDef n oi' (idris_optimisation i)-                            putIState (i { idris_optimisation = opts })-               [] -> do let oi = Optimise True False [] []-                        let opts = addDef n oi (idris_optimisation i)-                        putIState (i { idris_optimisation = opts })-                        addIBC (IBCOpt n)--    disjointTerms :: [[Term]] -> Bool-    disjointTerms []         = True-    disjointTerms [xs]       = True-    disjointTerms (xs : xss) =-        -- xs is disjoint with every pattern from xss-        all (or . zipWith disjoint xs) xss-        -- and xss is pairwise disjoint, too-        && disjointTerms xss--    -- Return True  if the two patterns are provably disjoint.-    -- Return False if they're not or if unsure.-    disjoint :: Term -> Term -> Bool-    disjoint x y = case (cx, cy) of-        -- data constructors -> compare their names-        (P (DCon _ _) nx _, P (DCon _ _) ny _)-            | nx /= ny  -> True-            | otherwise -> or $ zipWith disjoint xargs yargs-        _ -> False-      where-        (cx, xargs) = unApply x-        (cy, yargs) = unApply y- class Optimisable term where     applyOpts :: term -> Idris term-    stripCollapsed :: term -> Idris term  instance (Optimisable a, Optimisable b) => Optimisable (a, b) where     applyOpts (x, y) = (,) <$> applyOpts x <*> applyOpts y-    stripCollapsed (x, y) = (,) <$> stripCollapsed x <*> stripCollapsed y  instance (Optimisable a, Optimisable b) => Optimisable (vs, a, b) where     applyOpts (v, x, y) = (,,) v <$> applyOpts x <*> applyOpts y-    stripCollapsed (v, x, y) = (,,) v <$> stripCollapsed x <*> stripCollapsed y  instance Optimisable a => Optimisable [a] where     applyOpts = mapM applyOpts-    stripCollapsed = mapM stripCollapsed  instance Optimisable a => Optimisable (Either a (a, a)) where     applyOpts (Left  t) = Left  <$> applyOpts t     applyOpts (Right t) = Right <$> applyOpts t-    stripCollapsed (Left  t) = Left  <$> stripCollapsed t-    stripCollapsed (Right t) = Right <$> stripCollapsed t  -- Raw is for compile time optimisation (before type checking) -- Term is for run time optimisation (after type checking, collapsing allowed)- -- Compile time: no collapsing  instance Optimisable Raw where     applyOpts t@(RApp f a)         | (Var n, args) <- raw_unapply t -- MAGIC HERE-            = do args' <- mapM applyOpts args-                 i <- getIState-                 return $ case lookupCtxt n (idris_optimisation i) of-                    oi:_ -> applyDataOpt oi n args'-                    _    -> raw_apply (Var n) args'+            = raw_apply (Var n) <$> mapM applyOpts args         | otherwise = RApp <$> applyOpts f <*> applyOpts a      applyOpts (RBind n b t) = RBind n <$> applyOpts b <*> applyOpts t     applyOpts (RForce t)    = applyOpts t     applyOpts t = return t -    stripCollapsed t = return t- -- Erase types (makes ibc smaller, and we don't need them) instance Optimisable (Binder (TT Name)) where     applyOpts (Let t v) = Let <$> return Erased <*> applyOpts v     applyOpts b = return (b { binderTy = Erased })-    stripCollapsed (Let t v) = Let <$> return Erased <*> stripCollapsed v-    stripCollapsed b = return (b { binderTy = Erased })  instance Optimisable (Binder Raw) where     applyOpts b = do t' <- applyOpts (binderTy b)                      return (b { binderTy = t' })-    stripCollapsed (Let t v) = Let <$> stripCollapsed t <*> stripCollapsed v-    stripCollapsed b = do t' <- stripCollapsed (binderTy b)-                          return (b { binderTy = t' }) -forcedArgSeq :: OptInfo -> [Maybe Forceability]-forcedArgSeq oi = map (\i -> M.lookup i forceMap) [0..]-  where-    forceMap = M.fromList $ forceable oi--forcedCnt :: ForceMap -> Int-forcedCnt = length . filter (== Unconditional) . M.elems--applyDataOpt :: OptInfo -> Name -> [Raw] -> Raw-applyDataOpt oi n args -    = raw_apply (Var n) $ zipWith doForce (forcedArgSeq oi) args-  where-    doForce (Just Unconditional) a = RForce a-    doForce _ a = a- -- Run-time: do everything  prel = [txt "Nat", txt "Prelude"]@@ -249,54 +73,22 @@        | fn == txt "toIntegerNat" && mod == prel          = return (App (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased)     applyOpts c@(P (DCon t arity) n _)-        = do i <- getIState-             case lookupCtxt n (idris_optimisation i) of-                 (oi:_) -> return $ applyDataOptRT oi n t arity []-                 _ -> return c+        = return $ applyDataOptRT n t arity []     applyOpts t@(App f a)         | (c@(P (DCon t arity) n _), args) <- unApply t-            = do args' <- mapM applyOpts args-                 i <- getIState-                 case lookupCtxt n (idris_optimisation i) of-                      (oi:_) -> do return $ applyDataOptRT oi n t arity args'-                      _ -> return (mkApp c args')-        | otherwise = do f' <- applyOpts f-                         a' <- applyOpts a-                         return (App f' a')-    applyOpts (Bind n b t) = do b' <- applyOpts b-                                t' <- applyOpts t-                                return (Bind n b' t')-    applyOpts (Proj t i) = do t' <- applyOpts t-                              return (Proj t' i)+            = applyDataOptRT n t arity <$> mapM applyOpts args+        | otherwise = App <$> applyOpts f <*> applyOpts a+    applyOpts (Bind n b t) = Bind n <$> applyOpts b <*> applyOpts t+    applyOpts (Proj t i) = Proj <$> applyOpts t <*> pure i     applyOpts t = return t -    stripCollapsed (Bind n (PVar x) t) | (P _ ty _, _) <- unApply x-           = do i <- getIState-                -- NOTE: This assumes that 'ty' is in normal form, which it-                -- has to be before now because we're not keeping track of-                -- an environment so we can't do it here.-                case lookupCtxt ty (idris_optimisation i) of-                  [oi] -> if collapsible oi-                             then do t' <- stripCollapsed t-                                     return (Bind n (PVar x) (instantiate Erased t'))-                             else do t' <- stripCollapsed t-                                     return (Bind n (PVar x) t')-                  _ -> do t' <- stripCollapsed t-                          return (Bind n (PVar x) t')-    stripCollapsed (Bind n (PVar x) t)-                  = do t' <- stripCollapsed t-                       return (Bind n (PVar x) t')-    stripCollapsed t = return t---- Need to saturate arguments first to ensure that erasure happens uniformly--applyDataOptRT :: OptInfo -> Name -> Int -> Int -> [Term] -> Term-applyDataOptRT oi n tag arity args-    | length args == arity = doOpts n args (collapsible oi) (M.fromList $ forceable oi)+-- Need to saturate arguments first to ensure that optimisation happens uniformly+applyDataOptRT :: Name -> Int -> Int -> [Term] -> Term+applyDataOptRT n tag arity args+    | length args == arity = doOpts n args     | otherwise = let extra = satArgs (arity - length args)                       tm = doOpts n (args ++ map (\n -> P Bound n Erased) extra)-                                    (collapsible oi) (M.fromList $ forceable oi) in-                      bind extra tm+                  in bind extra tm   where     satArgs n = map (\i -> sMN i "sat") [1..n] @@ -305,20 +97,11 @@      -- Nat special cases     -- TODO: Would be nice if this was configurable in idris source!-    doOpts (NS (UN z) [nat, prelude]) [] _ _ +    doOpts (NS (UN z) [nat, prelude]) []         | z == txt "Z" && nat == txt "Nat" && prelude == txt "Prelude"           = Constant (BI 0)-    doOpts (NS (UN s) [nat, prelude]) [k] _ _+    doOpts (NS (UN s) [nat, prelude]) [k]         | s == txt "S" && nat == txt "Nat" && prelude == txt "Prelude"           = App (App (P Ref (sUN "prim__addBigInt") Erased) k) (Constant (BI 1)) -    doOpts n args True _  = Erased-    doOpts n args _ forceMap-        | isnewtype oi = case args' of-            [val] -> val-            _     -> error $ "Can't happen (newtype not a singleton): " ++ show args'-        | otherwise = mkApp ctor' args'-      where-        ctor' = (P (DCon tag (arity - forcedCnt forceMap)) n Erased)-        args' = [t | (f, t) <- zip (forcedArgSeq oi) args, f /= Just Unconditional]-+    doOpts n args = mkApp (P (DCon tag arity) n Erased) args
src/Idris/DeepSeq.hs view
@@ -50,10 +50,6 @@  -- All generated by 'derive' -instance NFData Forceability where-        rnf Conditional = ()-        rnf Unconditional = ()- instance NFData IntTy where         rnf (ITFixed x1) = rnf x1 `seq` ()         rnf ITNative = ()@@ -142,15 +138,15 @@                 rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()         rnf (PParams x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()         rnf (PNamespace x1 x2) = rnf x1 `seq` rnf x2 `seq` ()-        rnf (PRecord x1 x2 x3 x4 x5 x6 x7 x8)+        rnf (PRecord x1 x2 x3 x4 x5 x6 x7 x8 x9)           = 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 (PClass x1 x2 x3 x4 x5 x6 x7)+                  rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` ()+        rnf (PClass x1 x2 x3 x4 x5 x6 x8 x7)           = rnf x1 `seq`               rnf x2 `seq`-                rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` ()+                rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` ()         rnf (PInstance x1 x2 x3 x4 x5 x6 x7 x8)           = rnf x1 `seq`               rnf x2 `seq`@@ -249,7 +245,7 @@         rnf (Exact x1) = rnf x1 `seq` ()         rnf Compute = ()         rnf Trivial = ()-        rnf (ProofSearch x1 x2)+        rnf (ProofSearch r r1 r2 x1 x2)           = rnf x1 `seq` rnf x2 `seq` ()         rnf Solve = ()         rnf Attack = ()@@ -276,10 +272,10 @@ instance (NFData t) => NFData (PArg' t) where         rnf (PImp x1 x2 x3 x4 x5)           = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()-        rnf (PExp x1 x2 x3)-          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()-        rnf (PConstraint x1 x2 x3)-          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()+        rnf (PExp x1 x2 x3 x4)+          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()+        rnf (PConstraint x1 x2 x3 x4)+          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()         rnf (PTacImplicit x1 x2 x3 x4 x5)           = rnf x1 `seq`               rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()@@ -290,11 +286,11 @@               rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()  instance NFData OptInfo where-        rnf (Optimise x1 x2 x3 x4)-          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()+        rnf (Optimise x1 x2)+          = rnf x1 `seq` rnf x2 `seq` ()  instance NFData TypeInfo where-        rnf (TI x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()+        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)@@ -325,11 +321,11 @@    instance NFData SyntaxInfo where-        rnf (Syn x1 x2 x3 x4 x5 x6 x7 x8)+        rnf (Syn 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 x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` ()
src/Idris/Delaborate.hs view
@@ -58,7 +58,7 @@           = PLam n (de env [] ty) (de ((n,n):env) [] sc)     de env ((PImp { argopts = opts }):is) (Bind n (Pi ty) sc)           = PPi (Imp opts Dynamic False) n (de env [] ty) (de ((n,n):env) is sc)-    de env (PConstraint _ _ _:is) (Bind n (Pi ty) sc)+    de env (PConstraint _ _ _ _:is) (Bind n (Pi ty) sc)           = PPi constraint n (de env [] ty) (de ((n,n):env) is sc)     de env (PTacImplicit _ _ _ tac _:is) (Bind n (Pi ty) sc)           = PPi (tacimpl tac) n (de env [] ty) (de ((n,n):env) is sc)@@ -121,8 +121,8 @@         | otherwise = PApp un (PRef un n) (map pexp args)      imp (PImp p m l n _) arg = PImp p m l n arg-    imp (PExp p l _)   arg = PExp p l arg-    imp (PConstraint p l _) arg = PConstraint p l arg+    imp (PExp p l n _)   arg = PExp p l n arg+    imp (PConstraint p l n _) arg = PConstraint p l n arg     imp (PTacImplicit p l n sc _) arg = PTacImplicit p l n sc arg  -- | How far to indent sub-errors@@ -138,7 +138,7 @@ pprintTerm ist = pprintTerm' ist []  pprintTerm' :: IState -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation-pprintTerm' ist bnd tm = pprintPTerm (opt_showimp (idris_options ist)) bnd [] tm+pprintTerm' ist bnd tm = pprintPTerm (ppOptionIst ist) bnd [] (idris_infixes ist) tm  pprintErr :: IState -> Err -> Doc OutputAnnotation pprintErr i err = pprintErr' i (fmap (errReverse i) err)@@ -269,7 +269,7 @@   showqual :: IState -> Name -> String-showqual i n = showName (Just i) [] False False (dens n)+showqual i n = showName (Just i) [] (ppOptionIst i) { ppopt_impl = False } False (dens n)   where     dens ns@(NS n _) = case lookupCtxt n (idris_implicits i) of                               [_] -> n -- just one thing
src/Idris/Docs.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE PatternGuards #-}-module Idris.Docs where+module Idris.Docs (pprintDocs, getDocs, pprintConstDocs, FunDoc(..), Docs (..)) where  import Idris.AbsSyntax import Idris.AbsSyntaxTree@@ -27,16 +27,19 @@                     [FunDoc] -- data constructor docs           | ClassDoc Name Docstring -- class docs                      [FunDoc] -- method docs+                     [(Name, Maybe Docstring)] -- parameters and their docstrings+                     [PTerm] -- instances+                     [PTerm] -- superclasses   deriving Show  showDoc d | nullDocstring d = empty           | otherwise       = text "  -- " <> renderDocstring d -pprintFD :: Bool -> FunDoc -> Doc OutputAnnotation-pprintFD imp (FD n doc args ty f)-    = nest 4 (prettyName imp [] n <+> colon <+>-              pprintPTerm imp [] [ n | (n@(UN n'),_,_,_) <- args-                                     , not (T.isPrefixOf (T.pack "__") n') ] ty <$>+pprintFD :: IState -> FunDoc -> Doc OutputAnnotation+pprintFD ist (FD n doc args ty f)+    = nest 4 (prettyName (ppopt_impl ppo) [] n <+> colon <+>+              pprintPTerm ppo [] [ n | (n@(UN n'),_,_,_) <- args+                                     , not (T.isPrefixOf (T.pack "__") n') ] infixes ty <$>               renderDocstring doc <$>               maybe empty (\f -> text (show f) <> line) f <>               let argshow = showArgs args [] in@@ -44,21 +47,23 @@                 then nest 4 $ text "Arguments:" <$> vsep argshow                 else empty) -    where showArgs ((n, ty, Exp {}, Just d):args) bnd+    where ppo = ppOptionIst ist+          infixes = idris_infixes ist+          showArgs ((n, ty, Exp {}, Just d):args) bnd              = bindingOf n False <+> colon <+>-               pprintPTerm imp bnd [] ty <>+               pprintPTerm ppo bnd [] infixes ty <>                showDoc d <> line                :                showArgs args ((n, False):bnd)           showArgs ((n, ty, Constraint {}, Just d):args) bnd              = text "Class constraint" <+>-               pprintPTerm imp bnd [] ty <> showDoc d <> line+               pprintPTerm ppo bnd [] infixes ty <> showDoc d <> line                :                showArgs args ((n, True):bnd)           showArgs ((n, ty, Imp {}, Just d):args) bnd              = text "(implicit)" <+>                bindingOf n True <+> colon <+>-               pprintPTerm imp bnd [] ty <>+               pprintPTerm ppo bnd [] infixes ty <>                showDoc d <> line                :                showArgs args ((n, True):bnd)@@ -66,17 +71,69 @@           showArgs []                  _ = []  --pprintDocs imp (FunDoc d) = pprintFD imp d-pprintDocs imp (DataDoc t args)-           = text "Data type" <+> pprintFD imp t <$>-             nest 4 (text "Constructors:" <> line <>-                     vsep (map (pprintFD imp) args))-pprintDocs imp (ClassDoc n doc meths)-           = text "Type class" <+> prettyName imp [] n <$> -- parameters?+pprintDocs :: IState -> Docs -> Doc OutputAnnotation+pprintDocs ist (FunDoc d) = pprintFD ist d+pprintDocs ist (DataDoc t args)+           = text "Data type" <+> pprintFD ist t <$>+             if null args then text "No constructors."+             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 <>+                     if nullDocstring doc then empty else line <> renderDocstring doc)+             <> line <$>+             nest 4 (text "Parameters:" <$> prettyParameters)+             <> line <$>              nest 4 (text "Methods:" <$>-                     vsep (map (pprintFD imp) meths))+                      vsep (map (pprintFD ist) meths))+             <$>+             nest 4 (text "Instances:" <$>+                     vsep (if null instances' then [text "<no instances>"]+                           else map dumpInstance instances'))+             <>+             (if null subclasses then empty+              else line <$> nest 4 (text "Subclasses:" <$>+                                    vsep (map (dumpInstance . prettifySubclasses) subclasses)))+             <>+             (if null superclasses then empty+              else line <$> nest 4 (text "Default superclass instances:" <$>+                                     vsep (map dumpInstance superclasses)))+  where+    params' = zip pNames (repeat False) +    pNames  = map fst params++    ppo = ppOptionIst ist+    infixes = idris_infixes ist++    dumpInstance :: PTerm -> Doc OutputAnnotation+    dumpInstance = pprintPTerm ppo params' [] infixes++    prettifySubclasses (PPi (Constraint _ _) _ tm _)   = prettifySubclasses tm+    prettifySubclasses (PPi plcity           nm t1 t2) = PPi plcity (safeHead nm pNames) (prettifySubclasses t1) (prettifySubclasses t2)+    prettifySubclasses (PApp fc ref args)              = PApp fc ref $ updateArgs pNames args+    prettifySubclasses tm                              = tm++    safeHead _ (y:_) = y+    safeHead x []    = x++    updateArgs (p:ps) ((PExp prty opts _ ref):as) = (PExp prty opts p (updateRef p ref)) : updateArgs ps as+    updateArgs ps     (a:as)                      = a : updateArgs ps as+    updateArgs _      _                           = []++    updateRef nm (PRef fc _) = PRef fc nm+    updateRef _  pt          = pt++    isSubclass (PPi (Constraint _ _) _ (PApp _ _ args) (PApp _ (PRef _ nm) args')) = nm == n && map getTm args == map getTm args'+    isSubclass (PPi _                _ _ pt)                                       = isSubclass pt+    isSubclass _                                                                   = False++    (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))+ getDocs :: Name -> Idris Docs getDocs n    = do i <- getIState@@ -96,11 +153,16 @@ docClass :: Name -> ClassInfo -> Idris Docs docClass n ci   = do i <- getIState-       let docstr = case lookupCtxt n (idris_docstrings i) of-                         [str] -> fst str-                         _ -> emptyDocstring-       mdocs <- mapM docFun (map fst (class_methods ci))-       return (ClassDoc n docstr mdocs)+       let docStrings = listToMaybe $ lookupCtxt n $ idris_docstrings i+           docstr = maybe emptyDocstring fst docStrings+           params = map (\pn -> (pn, docStrings >>= (lookup pn . snd))) (class_params ci)+           instances = map (delabTy i) (class_instances ci)+           superclasses = catMaybes $ map getDInst (class_default_superclasses ci)+       mdocs <- mapM (docFun . fst) (class_methods ci)+       return $ ClassDoc n docstr mdocs params instances superclasses+  where+    getDInst (PInstance _ _ _ _ _ t _ _) = Just t+    getDInst _                           = Nothing  docFun :: Name -> Idris FunDoc docFun n@@ -120,8 +182,22 @@        where funName :: Name -> String              funName (UN n)   = str n              funName (NS n _) = funName n+             funName n+               | n == falseTy = "_|_"  getPArgNames :: PTerm -> [(Name, Docstring)] -> [(Name, PTerm, Plicity, Maybe Docstring)] getPArgNames (PPi plicity name ty body) ds =   (name, ty, plicity, lookup name ds) : getPArgNames body ds getPArgNames _ _ = []++pprintConstDocs :: IState -> Const -> String -> Doc OutputAnnotation+pprintConstDocs ist c str = text "Primitive" <+> text (if constIsType c then "type" else "value") <+>+                            pprintPTerm (ppOptionIst ist) [] [] [] (PConstant c) <+> colon <+>+                            pprintPTerm (ppOptionIst ist) [] [] [] (t c) <>+                            nest 4 (line <> text str)++  where t (Fl _)  = PConstant $ AType ATFloat+        t (BI _)  = PConstant $ AType (ATInt ITBig)+        t (Str _) = PConstant StrType+        t (Ch c)  = PConstant $ AType (ATInt ITChar)+        t _       = PType
src/Idris/Docstrings.hs view
@@ -68,7 +68,7 @@  renderInline :: CT.Inline -> Doc OutputAnnotation renderInline (CT.Str s) = text $ T.unpack s-renderInline CT.Space = space+renderInline CT.Space = softline renderInline CT.SoftBreak = softline renderInline CT.LineBreak = line renderInline (CT.Emph txt) = annotate (AnnTextFmt ItalicText) $ renderInlines txt -- TODO
src/Idris/ElabDecls.hs view
@@ -4,6 +4,7 @@ module Idris.ElabDecls where  import Idris.AbsSyntax+import Idris.ASTUtils import Idris.DSL import Idris.Error import Idris.Delaborate@@ -29,6 +30,10 @@  import Idris.Docstrings +import Prelude hiding (id, (.))+import Control.Category++import Control.Applicative hiding (Const) import Control.DeepSeq import Control.Monad import Control.Monad.State.Strict as State@@ -37,6 +42,7 @@ import Debug.Trace  import qualified Data.Map as Map+import qualified Data.Set as S import qualified Data.Text as T import Data.Char(isLetter, toLower) import Data.List.Split (splitOn)@@ -80,12 +86,16 @@          ctxt <- getContext          i <- getIState -         logLvl 3 $ show n ++ " pre-type " ++ showTmImpls ty'+         logLvl 5 $ show n ++ " pre-type " ++ showTmImpls ty'          ty' <- addUsingConstraints syn fc ty'-         ty' <- implicit syn n ty'+         ty' <- implicit info syn n ty' -         let ty = addImpl i ty'-         logLvl 3 $ show n ++ " type " ++ showTmImpls 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+          ((tyT, defer, is), log) <-                tclift $ elaborate ctxt n (TType (UVal 0)) []                         (errAt "type of " n (erun fc (build i info False [] n ty)))@@ -115,7 +125,7 @@          let (t, _) = unApply (getRetTy nty')          let corec = case t of                         P _ rcty _ -> case lookupCtxt rcty (idris_datatypes i) of-                                        [TI _ True _ _] -> True+                                        [TI _ True _ _ _] -> True                                         _ -> False                         _ -> False          -- Productivity checking now via checking for guarded 'Delay' @@ -130,8 +140,11 @@          addDocStr n doc argDocs          addIBC (IBCDoc n)          addIBC (IBCFlags n opts')+         fputState (opt_inaccessible . ist_optimisation n) inacc+         addIBC (IBCOpt n)          when (Implicit `elem` opts') $ do addCoercion n                                            addIBC (IBCCoercion n)+          -- If the function is declared as an error handler and the language          -- extension is enabled, then add it to the list of error handlers.          errorReflection <- fmap (elem ErrorReflection . idris_language_extensions) getIState@@ -172,31 +185,27 @@         , ns4 == map txt ["Errors","Reflection","Language"] = True     tyIsHandler _                                           = False +-- Get the list of (index, name) of inaccessible arguments from the type.+inaccessibleArgs :: Int -> PTerm -> [(Int, Name)]+inaccessibleArgs i (PPi (Imp _ _ _) n Placeholder t)+        = (i,n) : inaccessibleArgs (i+1) t  -- unbound implicit+inaccessibleArgs i (PPi plicity n ty t)+    | InaccessibleArg `elem` pargopts plicity+        = (i,n) : inaccessibleArgs (i+1) t  -- an .{erased : Implicit}+    | otherwise+        = inaccessibleArgs (i+1) t      -- a {regular : Implicit}+inaccessibleArgs _ _ = []  elabPostulate :: ElabInfo -> SyntaxInfo -> Docstring ->                  FC -> FnOpts -> Name -> PTerm -> Idris ()-elabPostulate info syn doc fc opts n ty-    = do elabType info syn doc [] fc opts n ty-         -- make sure it's collapsible, so it is never needed at run time-         -- start by getting the elaborated type-         ctxt <- getContext-         fty <- case lookupTy n ctxt of-            [] -> tclift $ tfail $ (At fc (NoTypeDecl n)) -- can't happen!-            [ty] -> return ty-         ist <- getIState-         let (ap, _) = unApply (getRetTy (normalise ctxt [] fty))-         logLvl 5 $ "Checking collapsibility of " ++ show (ap, fty)-         let postOK = case ap of-                            P _ tn _ -> case lookupCtxt tn-                                                (idris_optimisation ist) of-                                            [oi] -> collapsible oi-                                            _ -> False-                            _ -> False-         when (not postOK)-            $ tclift $ tfail (At fc (NonCollapsiblePostulate n))-         -- remove it from the deferred definitions list-         solveDeferred n+elabPostulate info syn doc fc opts n ty = do+    elabType info syn doc [] fc opts n ty+    putIState . (\ist -> ist{ idris_postulates = S.insert n (idris_postulates ist) }) =<< getIState+    addIBC (IBCPostulate n) +    -- remove it from the deferred definitions list+    solveDeferred n+ elabData :: ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] -> FC -> DataOpts -> PData -> Idris () elabData info syn doc argDocs fc opts (PLaterdecl n t_in)     = do let codata = Codata `elem` opts@@ -204,13 +213,15 @@          checkUndefined fc n          ctxt <- getContext          i <- getIState-         t_in <- implicit syn n t_in+         -- 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''+         addIBC (IBCDef n)          mapM_ (elabCaseBlock info []) is          (cty, _)  <- recheckC fc [] t'          logLvl 2 $ "---> " ++ show cty@@ -222,7 +233,7 @@          undef <- isUndefined fc n          ctxt <- getContext          i <- getIState-         t_in <- implicit syn n t_in+         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)) []@@ -238,14 +249,17 @@          logLvl 2 $ "---> " ++ show cty          -- temporary, to check cons          when undef $ updateContext (addTyDecl n (TCon 0 0) cty)-         cons <- mapM (elabCon info syn n codata) dcons+         let cnameinfo = cinfo info (map cname dcons)+         cons <- mapM (elabCon cnameinfo syn n codata) dcons          ttag <- getName          i <- getIState          let as = map (const Nothing) (getArgTys cty)          let params = findParams  (map snd cons)          logLvl 2 $ "Parameters : " ++ show params+         -- TI contains information about mutually declared types - this will+         -- be updated when the mutual block is complete          putIState (i { idris_datatypes =-                          addDef n (TI (map fst cons) codata opts params)+                          addDef n (TI (map fst cons) codata opts params [n])                                              (idris_datatypes i) })          addIBC (IBCDef n)          addIBC (IBCData n)@@ -255,15 +269,31 @@          let metainf = DataMI params          addIBC (IBCMetaInformation n metainf)          -- TMP HACK! Make this a data option-         when (n /= sUN "Lazy'") $ collapseCons n cons          updateContext (addDatatype (Data n ttag cty cons))          updateContext (setMetaInformation n metainf)-         mapM_ (checkPositive n) cons-         if DefaultEliminator `elem` opts-           then evalStateT (elabEliminator params n t dcons info) Map.empty-           else return ()+         mapM_ totcheck (zip (repeat fc) (map fst cons))+--          mapM_ (checkPositive n) cons++         -- if there's exactly one constructor,+         -- mark both the type and the constructor as detaggable+         case cons of+            [(cn,ct)] -> setDetaggable cn >> setDetaggable n+                >> addIBC (IBCOpt cn) >> addIBC (IBCOpt n)+            _ -> return ()++         -- create an eliminator+         when (DefaultEliminator `elem` opts) $+            evalStateT (elabEliminator params n t dcons info) Map.empty   where-        checkDefinedAs fc n t ctxt+        setDetaggable :: Name -> Idris ()+        setDetaggable n = do+            ist <- getIState+            let opt = idris_optimisation ist+            case lookupCtxt n opt of+                [oi] -> putIState ist{ idris_optimisation = addDef n oi{ detaggable = True } opt }+                _    -> putIState ist{ idris_optimisation = addDef n (Optimise [] True) opt }++        checkDefinedAs fc n t ctxt              = case lookupDef n ctxt of                    [] -> return ()                    [TyDecl _ ty] ->@@ -321,14 +351,30 @@                        | otherwise = count n ts         mParam args (_ : rest) = Nothing : mParam args rest +        cname (_, _, n, _, _, _) = n++        -- Abuse of ElabInfo.+        -- TODO Contemplate whether the ElabInfo type needs modification.+        cinfo :: ElabInfo -> [Name] -> ElabInfo+        cinfo info ds+          = let newps = params info+                dsParams = map (\n -> (n, [])) ds+                newb = addAlist dsParams (inblock info)+                l = liftname info in+                info { params = newps,+                       inblock = newb,+                       liftname = id -- Is this appropriate?+                     }+ type EliminatorState = StateT (Map.Map String Int) Idris --- TODO: Use uniqueName for generating names, rewrite everything to use idris_implicits instead of manual splitting, generally just rewrite+-- TODO: Rewrite everything to use idris_implicits instead of manual splitting (or in TT) elabEliminator :: [Int] -> Name -> PTerm ->                   [(Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name])] ->                   ElabInfo -> EliminatorState () elabEliminator paramPos n ty cons info = do   elimLog $ "Elaborating eliminator"+  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   generalParams <- namePis False pms@@ -347,13 +393,14 @@   let clauseGeneralArgs' = map getPiName generalParams ++ [motiveName] ++ clauseConsElimArgs   let clauseGeneralArgs  = map (\arg -> pexp (PRef elimFC arg)) clauseGeneralArgs'   let elimSig = "-- eliminator 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 True) eliminatorDef+  elimLog $ "-- eliminator 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-    [] -> return ()+    [] -> State.lift $ solveDeferred elimDeclName -- Remove meta-variable for type     _  -> State.lift $ idrisCatch (elabDecl EAll info eliminatorDef) (\err -> return ())   where elimLog :: String -> EliminatorState ()         elimLog s = State.lift (logLvl 2 s)@@ -416,9 +463,9 @@         freshName key = do           nameMap <- get           let i = fromMaybe 0 (Map.lookup key nameMap)-          let name = key ++ show i+          let name = uniqueName (sUN (key ++ show i)) (map (\(nm, nb) -> sUN (nm ++ show nb)) $ Map.toList nameMap)           put $ Map.insert key (i+1) nameMap-          return (sUN name)+          return name          scrutineeName :: Name         scrutineeName = sUN "scrutinee"@@ -511,7 +558,7 @@           let cons' = replaceParams paramPos generalParameters ty           let (args, resTy) = splitPi cons'           implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)-          consArgs <- namePis True args+          consArgs <- namePis False args           let recArgs = findRecArgs consArgs           let recMotives = map applyRecMotive recArgs           let (_, consIdxs) = splitArgPms resTy@@ -550,7 +597,7 @@           implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)           let (_, generalIdxs') = splitArgPms resTy           let generalIdxs = map pexp generalIdxs'-          consArgs <- namePis True args+          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@@ -564,10 +611,12 @@  elabPrims :: Idris () elabPrims = do mapM_ (elabDecl EAll toplevel)-                     (map (\(opt, decl) -> PData emptyDocstring [] defaultSyntax (fileFC "builtin") opt decl)-                        (zip+                     (map (\(opt, decl, docs, argdocs) -> PData docs argdocs defaultSyntax (fileFC "builtin") opt decl)+                        (zip4                          [inferOpts, unitOpts, falseOpts, pairOpts, eqOpts]-                         [inferDecl, unitDecl, falseDecl, pairDecl, eqDecl]))+                         [inferDecl, unitDecl, falseDecl, pairDecl, eqDecl]+                         [emptyDocstring, unitDoc, falseDoc, pairDoc, eqDoc]+                         [[], [], [], pairParamDoc, eqParamDoc]))                addNameHint eqTy (sUN "prf")                elabDecl EAll toplevel elimDecl                mapM_ elabPrim primitives@@ -727,11 +776,17 @@   elabRecord :: ElabInfo -> SyntaxInfo -> Docstring -> FC -> Name ->-              PTerm -> Docstring -> Name -> PTerm -> Idris ()-elabRecord info syn doc fc tyn ty cdoc cn cty-    = do elabData info syn doc [] fc [] (PDatadecl tyn ty [(cdoc, [], cn, cty, fc, [])])-         cty' <- implicit syn cn cty+              PTerm -> DataOpts -> Docstring -> Name -> PTerm -> Idris ()+elabRecord info syn doc fc tyn ty opts cdoc cn cty_in+    = do elabData info syn doc [] fc opts (PDatadecl tyn ty [(cdoc, [], cn, cty_in, fc, [])])+         -- TODO think: something more in info?+         cty' <- implicit info syn cn cty_in          i <- getIState++         -- get bound implicits and propagate to setters (in case they+         -- provide useful information for inference)+         let extraImpls = getBoundImpls cty'+          cty <- case lookupTy cn (tt_ctxt i) of                     [t] -> return (delab i t)                     _ -> ifail "Something went inexplicably wrong"@@ -740,19 +795,34 @@          let ptys = getProjs [] (renameBs cimp cty)          let ptys_u = getProjs [] cty          let recty = getRecTy cty-         logLvl 6 $ show (recty, ptys)++         -- 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 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-         proj_decls <- mapM (mkProj recty substs cimp) (zip ptys [0..])++         -- Generate projection functions+         proj_decls <- mapM (mkProj recty_in substs cimp) (zip ptys [0..])+         logLvl 3 $ show proj_decls          let nonImp = mapMaybe isNonImp (zip cimp ptys_u)          let implBinds = getImplB id cty'-         update_decls <- mapM (mkUpdate recty implBinds (length nonImp)) (zip nonImp [0..])++         -- Generate update functions+         update_decls <- mapM (mkUpdate recty index_names_in extraImpls+                                   (getFieldNames cty')+                                   implBinds (length nonImp)) (zip nonImp [0..])          mapM_ (elabDecl EAll info) (concat proj_decls)+         logLvl 3 $ show update_decls          mapM_ (tryElabDecl info) (update_decls)   where --     syn = syn_in { syn_namespace = show (nsroot tyn) : syn_namespace syn_in } -    isNonImp (PExp _ _ _, a) = Just a+    isNonImp (PExp _ _ _ _, a) = Just a     isNonImp _ = Nothing      tryElabDecl info (fn, ty, val)@@ -762,8 +832,12 @@                         (\v -> do iputStrLn $ show fc ++                                       ":Warning - can't generate setter for " ++                                       show fn ++ " (" ++ show ty ++ ")"+--                                       ++ "\n" ++ pshow i v                                   putIState i) +    getBoundImpls (PPi (Imp _ _ _) n ty sc) = (n, ty) : getBoundImpls sc+    getBoundImpls _ = []+     getImplB k (PPi (Imp l s _) n Placeholder sc)         = getImplB k sc     getImplB k (PPi (Imp l s p) n ty sc)@@ -780,9 +854,19 @@     getProjs acc (PPi _ n ty s) = getProjs ((n, ty) : acc) s     getProjs acc r = reverse acc +    getFieldNames (PPi (Exp _ _ _) n _ s) = n : getFieldNames s +    getFieldNames (PPi _ _ _ s) = getFieldNames s+    getFieldNames _ = []+     getRecTy (PPi _ n ty s) = getRecTy s     getRecTy t = t +    getRecNameMap x (PApp fc t args) = mapMaybe (toMN . getTm) args+      where+        toMN (PRef fc n) = Just (n, PRef fc (sMN 0 (show n ++ x)))+        toMN _ = Nothing+    getRecNameMap x _ = []+     rec = sMN 0 "rec"      mkp (UN n) = sMN 0 ("p_" ++ str n)@@ -815,13 +899,23 @@      implicitise (pa, t) = pa { getTm = t } -    mkUpdate recty k num ((pn, pty), pos)+    -- If the 'pty' we're updating includes anything in 'substs', we're+    -- updating the type as well, so use recty', otherwise just use+    -- recty+    mkUpdate recty inames extras fnames k num ((pn, pty), pos)        = do let setname = expandNS syn $ mkType pn             let valname = sMN 0 "updateval"-            let pt = k (PPi expl pn pty-                           (PPi expl rec recty recty))+            let pn_out = sMN 0 (show pn ++ "_out")+            let pn_in = sMN 0 (show pn ++ "_in")+            let recty_in = substMatches [(pn, PRef fc pn_in)] recty+            let recty_out = substMatches [(pn, PRef fc pn_out)] recty+            let pt = substMatches inames $ +                       k (implBindUp extras inames (PPi expl pn_out pty+                           (PPi expl rec recty_in recty_out)))             let pfnTy = PTy emptyDocstring [] defaultSyntax fc [] setname pt-            let pls = map (\x -> PRef fc (sMN x "field")) [0..num-1]+--             let pls = map (\x -> PRef fc (sMN x ("field" ++ show x))) [0..num-1]+            let inames_imp = map (\ (x,_) -> (x, Placeholder)) inames+            let pls = map (\x -> substMatches inames_imp (PRef fc x)) fnames             let lhsArgs = pls             let rhsArgs = take pos pls ++ (PRef fc valname) :                                drop (pos + 1) pls@@ -835,15 +929,31 @@                                                       (map pexp rhsArgs)) []             return (pn, pfnTy, PClauses fc [] setname [pclause]) +    implBindUp [] is t = t+    implBindUp ((n, ty):ns) is t +         = let n' = case lookup n is of+                         Just (PRef _ x) -> x+                         _ -> n in+               if n `elem` allNamesIn t +                  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 syn n (if codata then mkLazy t_in else t_in)+         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)))@@ -861,10 +971,8 @@          checkDocs fc argDocs t_in          addDocStr n doc argDocs          addIBC (IBCDoc n)-         let fs = map (getNamePos 0 t) forcenames-         -- FIXME: 'forcenames' is an almighty hack! Need a better way of-         -- erasing non-forceable things-         forceArgs tn n (mapMaybe (getNamePos 0 t) forcenames) cty'+         fputState (opt_inaccessible . ist_optimisation n) inacc+         addIBC (IBCOpt n)          return (n, cty')   where     tyIs (Bind n b sc) = tyIs sc@@ -875,7 +983,7 @@      mkLazy (PPi pl n ty sc)          = let ty' = if getTyName ty-                       then PApp fc (PRef fc (sUN "Lazy'")) +                       then PApp fc (PRef fc (sUN "Lazy'"))                             [pexp (PRef fc (sUN "LazyCodata")),                              pexp ty]                        else ty in@@ -897,6 +1005,9 @@ elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris () elabClauses info fc opts n_in cs = let n = liftname info n_in in       do ctxt <- getContext+         ist  <- getIState+         inacc <- map fst <$> fgetState (opt_inaccessible . ist_optimisation n)+          -- Check n actually exists, with no definition yet          let tys = lookupTy n ctxt          let reflect = Reflection `elem` opts@@ -914,29 +1025,12 @@             logLvl 3 $ "Elaborated patterns:\n" ++ show pats_in -           -- if the return type of 'ty' is collapsible, the optimised version should-           -- just do nothing-           ist <- getIState-           let (ap, _) = unApply (getRetTy fty)-           logLvl 5 $ "Checking collapsibility of " ++ show (ap, fty)-           -- FIXME: Really ought to only do this for total functions!-           let doNothing = case ap of-                              P _ tn _ -> case lookupCtxt tn-                                                  (idris_optimisation ist) of-                                              [oi] -> collapsible oi-                                              _ -> False-                              _ -> False            solveDeferred n-           ist <- getIState-           when doNothing $-              case lookupCtxt n (idris_optimisation ist) of-                 [oi] -> do let opts = addDef n (oi { collapsible = True })-                                           (idris_optimisation ist)-                            putIState (ist { idris_optimisation = opts })-                 _ -> do let opts = addDef n (Optimise True False [] [])-                                           (idris_optimisation ist)-                         putIState (ist { idris_optimisation = opts })-                         addIBC (IBCOpt n)++           -- just ensure that the structure exists+           fmodifyState (ist_optimisation n) id+           addIBC (IBCOpt n)+            ist <- getIState            let pats = map (simple_lhs (tt_ctxt ist)) $ doTransforms ist pats_in @@ -946,11 +1040,8 @@            let tcase = opt_typecase (idris_options ist)             -- Summary of what's about to happen: Definitions go:--           -- pats_in -> pats -> optpats-           -- pdef comes from pats,-           -- optpdef comes from optpats-           -- Then pdef' is optpdef with forcing/collapsing applied everywhere+           --+           -- pats_in -> pats -> pdef -> pdef'             -- addCaseDef builds case trees from <pdef> and <pdef'> @@ -979,20 +1070,12 @@             numArgs <- tclift $ sameLength pdef -           -- patterns after collapsing optimisation applied-           -- (i.e. check if the function should do nothing at run time)-           optpats <- if doNothing-                         then return $ [Right (mkApp (P Bound n Erased)-                                                    (take numArgs (repeat Erased)), Erased)]-                         else stripCollapsed pats-            case specNames opts of                 Just _ -> logLvl 5 $ "Partially evaluated:\n" ++ show pats                 _ -> return () -           let optpdef = map debind optpats -- \$ map (simple_lhs (tt_ctxt ist)) optpats            tree@(CaseDef scargs sc _) <- tclift $-                   simpleCase tcase False reflect CompileTime fc atys pdef+                   simpleCase tcase False reflect CompileTime fc inacc atys pdef            cov <- coverage            pmissing <-                    if cov && not (hasDefault cs)@@ -1014,7 +1097,7 @@            let pcover = null pmissing             -- pdef' is the version that gets compiled for run-time-           pdef_in' <- applyOpts optpdef+           pdef_in' <- applyOpts pdef            let pdef' = map (simple_rt (tt_ctxt ist)) pdef_in'             logLvl 5 $ "After data structure transformations:\n" ++ show pdef'@@ -1041,11 +1124,12 @@            let knowncovering = (pcover && cov) || AssertTotal `elem` opts             tree' <- tclift $ simpleCase tcase knowncovering reflect-                                        RunTime fc atys pdef'-           logLvl 3 (show tree)+                                        RunTime fc inacc atys pdef'+           logLvl 3 $ "Unoptimised " ++ show n ++ ": " ++ show tree            logLvl 3 $ "Optimised: " ++ show tree'            ctxt <- getContext            ist <- getIState+           let opt = idris_optimisation ist            putIState (ist { idris_patdefs = addDef n (force pdef', force pmissing)                                                 (idris_patdefs ist) })            let caseInfo = CaseInfo (inlinable opts) (dictionary opts)@@ -1055,6 +1139,7 @@                                                        reflect                                                        (AssertTotal `elem` opts)                                                        atys+                                                       inacc                                                        pats                                                        pdef pdef pdef_inl pdef' ty)                           addIBC (IBCDef n)@@ -1071,7 +1156,7 @@                                      let used = findUsedArgs sc' scargs'                                      -- let scg = buildSCG i sc scargs                                      -- add SCG later, when checking totality-                                     let cg = CGInfo scargs' calls [] used []+                                     let cg = CGInfo scargs' calls [] used []  -- TODO: remove this, not needed anymore                                      logLvl 2 $ "Called names: " ++ show cg                                      addToCG n cg                                      addToCalledG n (nub (map fst calls)) -- plus names in type!@@ -1113,7 +1198,8 @@                                             force (normalisePats ctxt [] y))     simple_lhs ctxt t = t -    simple_rt ctxt (p, x, y) = (p, x, force (rt_simplify ctxt [] y))+    simple_rt ctxt (p, x, y) = (p, x, force (uniqueBinders p +                                                (rt_simplify ctxt [] y)))      -- this is so pattern types are in the right form for erasure     normalisePats ctxt env (Bind n (PVar t) sc) @@ -1225,8 +1311,8 @@  -- Elaborate a value, returning any new bindings created (this will only -- happen if elaborating as a pattern clause)-elabValBind :: ElabInfo -> Bool -> PTerm -> Idris (Term, Type, [(Name, Type)])-elabValBind info aspat tm_in+elabValBind :: ElabInfo -> Bool -> Bool -> PTerm -> Idris (Term, Type, [(Name, Type)])+elabValBind info aspat norm tm_in    = do ctxt <- getContext         i <- getIState         let tm = addImpl i tm_in@@ -1251,14 +1337,17 @@         logLvl 3 ("Value: " ++ show vtm) --         recheckC (fileFC "(input)") [] tm' --         logLvl 2 (show vtm)-        (vtm, vty) <- recheckC (fileFC "(input)") [] vtm+        (vtm_in, vty) <- recheckC (fileFC "(input)") [] vtm++        let vtm = if norm then normalise (tt_ctxt i) [] vtm_in+                          else vtm_in         let bargs = getPBtys vtm          return (vtm, vty, bargs)  elabVal :: ElabInfo -> Bool -> PTerm -> Idris (Term, Type) elabVal info aspat tm_in-   = do (tm, ty, _) <- elabValBind info aspat tm_in+   = do (tm, ty, _) <- elabValBind info aspat False tm_in         return (tm, ty)  -- checks if the clause is a possible left hand side. Returns the term if@@ -1268,7 +1357,7 @@ checkPossible info fc tcgen fname lhs_in    = do ctxt <- getContext         i <- getIState-        let lhs = addImpl i lhs_in+        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@@ -1277,22 +1366,54 @@                   case recheck ctxt [] (forget lhs_tm) lhs_tm of                        OK _ -> return True                        err -> return False-            Error err -> if tcgen then return False-                                  else return (impossibleError err)-    where impossibleError (CantUnify _ topx topy e _ _) -              = not (sameFam topx topy || not (impossibleError e))-          impossibleError (CantConvert _ _ _) = False-          impossibleError (At _ e) = impossibleError e-          impossibleError (Elaborating _ _ e) = impossibleError e-          impossibleError (ElaboratingArg _ _ _ e) = impossibleError e-          impossibleError _ = True+            -- if it's a recoverable error, the case may become possible+            Error err -> if tcgen then return (recoverable ctxt err)+                                  else return (validCase ctxt err ||+                                                 recoverable ctxt err)+    where validCase ctxt (CantUnify _ topx topy e _ _)+              = let topx' = normalise ctxt [] topx+                    topy' = normalise ctxt [] topy in+                    not (sameFam topx' topy' || not (validCase ctxt e))+          validCase ctxt (CantConvert _ _ _) = False+          validCase ctxt (At _ e) = validCase ctxt e+          validCase ctxt (Elaborating _ _ e) = validCase ctxt e+          validCase ctxt (ElaboratingArg _ _ _ e) = validCase ctxt e+          validCase ctxt _ = True+           +          recoverable ctxt (CantUnify r topx topy e _ _) +              = let topx' = normalise ctxt [] topx+                    topy' = normalise ctxt [] topy in+                    checkRec topx' topy'+          recoverable ctxt (At _ e) = recoverable ctxt e+          recoverable ctxt (Elaborating _ _ e) = recoverable ctxt e+          recoverable ctxt (ElaboratingArg _ _ _ e) = recoverable ctxt e+          recoverable _ _ = False            sameFam topx topy                = case (unApply topx, unApply topy) of                      ((P _ x _, _), (P _ y _, _)) -> x == y                      _ -> False -getFixedInType i env (PExp _ _ _ : is) (Bind n (Pi t) sc)+          -- different notion of recoverable than in unification, since we+          -- have no metavars -- just looking to see if a constructor is failing+          -- to unify with a function that may be reduced later++          checkRec (App f a) p@(P _ _ _) = checkRec f p+          checkRec p@(P _ _ _) (App f a) = checkRec p f+          checkRec fa@(App _ _) fa'@(App _ _) +              | (f, as) <- unApply fa,+                (f', as') <- unApply fa'+                   = if (length as /= length as') +                        then checkRec f f' +                        else checkRec f f' && and (zipWith checkRec as as')+          checkRec (P xt x _) (P yt y _) = x == y || ntRec xt yt+          checkRec _ _ = False++          ntRec x y | Ref <- x = True+                    | Ref <- y = True+                    | 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) getFixedInType i env (_ : is) (Bind n (Pi t) sc)     = getFixedInType i (n : env) is (instantiate (P Bound n t) sc)@@ -1423,10 +1544,10 @@         -- Elaborate where block         ist <- getIState         windex <- getName-        let winfo = pinfo (pvars ist lhs_tm) whereblock windex         let decls = nub (concatMap declared whereblock)         let defs = nub (decls ++ concatMap defined whereblock)         let newargs = pvars ist lhs_tm+        let winfo = pinfo info newargs defs windex         let wb = map (expandParamsD False ist decorate newargs defs) whereblock          -- Split the where block into declarations with a type, and those@@ -1435,7 +1556,7 @@         let (wbefore, wafter) = sepBlocks wb          logLvl 2 $ "Where block:\n " ++ show wbefore ++ "\n" ++ show wafter-        mapM_ (elabDecl' EAll info) wbefore+        mapM_ (elabDecl' EAll winfo) wbefore         -- Now build the RHS, using the type of the LHS as the goal.         i <- getIState -- new implicits from where block         logLvl 5 (showTmImpls (expandParams decorate newargs defs (defs \\ decls) rhs_in))@@ -1450,7 +1571,7 @@                         mapM_ setinj (nub (params ++ inj))                         setNextName                          (_, _, is) <- errAt "right hand side of " fname-                                         (erun fc (build i info False opts fname rhs))+                                         (erun fc (build i winfo False opts fname rhs))                         errAt "right hand side of " fname                               (erun fc $ psolve lhs_tm)                         hs <- get_holes@@ -1478,8 +1599,8 @@         -- Now the remaining deferred (i.e. no type declarations) clauses         -- from the where block -        mapM_ (elabDecl' EAll info) wafter-        mapM_ (elabCaseBlock info opts) is+        mapM_ (elabDecl' EAll winfo) wafter+        mapM_ (elabCaseBlock winfo opts) is          ctxt <- getContext         logLvl 5 $ "Rechecking"@@ -1499,7 +1620,7 @@         rev <- case ret_fam of                     P _ rfamn _ ->                          case lookupCtxt rfamn (idris_datatypes i) of-                             [TI _ _ dopts _] -> +                             [TI _ _ dopts _ _] ->                                   return (DataErrRev `elem` dopts)                              _ -> return False                     _ -> return False@@ -1509,6 +1630,19 @@            addErrRev (crhs, clhs)          return $ (Right (clhs, crhs), lhs)   where+    pinfo :: ElabInfo -> [(Name, PTerm)] -> [Name] -> Int -> ElabInfo+    pinfo info ns ds i+          = let newps = params info ++ ns+                dsParams = map (\n -> (n, map fst newps)) ds+                newb = addAlist dsParams (inblock info)+                l = liftname info in+                info { params = newps,+                       inblock = newb,+                       liftname = id -- (\n -> case lookupCtxt n newb of+                                     --      Nothing -> n+                                     --      _ -> MN i (show n)) . l+                     }+     mkLHSapp t@(PRef _ _) = trace ("APP " ++ show t) $ PApp fc t []     mkLHSapp t = t @@ -1531,20 +1665,7 @@                                    (b : bf, af)       sepBlocks' ns [] = ([], []) -    pinfo ns ps i-          = let ds = concatMap declared ps-                newps = params info ++ ns-                dsParams = map (\n -> (n, map fst newps)) ds-                newb = addAlist dsParams (inblock info)-                l = liftname info in-                info { params = newps,-                       inblock = newb,-                       liftname = id -- (\n -> case lookupCtxt n newb of-                                     --      Nothing -> n-                                     --      _ -> MN i (show n)) . l-                    } -     -- if a hole is just an argument/result of a case block, treat it as     -- the unit type. Hack to help elaborate case in do blocks.     elabCaseHole aux h = do@@ -1610,6 +1731,7 @@         let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'         addDeferred def''         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@@ -1708,7 +1830,7 @@                     do lhs <- updateLHS n wname mvars ns ns' (fullApp tm) w                        return $ PWith fc wname lhs ws wval withs'     mkAux wname toplhs ns ns' c-        = ifail $ show fc ++ "badly formed with clause"+        = ifail $ show fc ++ ":badly formed with clause"      addArg (PApp fc f args) w = PApp fc f (args ++ [pexp w])     addArg (PRef fc f) w = PApp fc (PRef fc f) [pexp w]@@ -1719,8 +1841,8 @@               return $ substMatches mvars $                   PApp fc (PRef fc' wname)                       (map pexp ns ++ pexp w : (map pexp ns'))-    updateLHS n wname mvars ns ns' tm w-        = ifail $ "Not implemented match " ++ show tm+    updateLHS n wname mvars ns_in ns_in' tm w+        = updateLHS n wname mvars ns_in ns_in' (PApp fc tm []) w      keepMvar mvs fc v | v `elem` mvs = PRef fc v                       | otherwise = Placeholder@@ -1740,8 +1862,8 @@  elabClass :: ElabInfo -> SyntaxInfo -> Docstring ->              FC -> [PTerm] ->-             Name -> [(Name, PTerm)] -> [PDecl] -> Idris ()-elabClass info syn doc fc constraints tn ps ds+             Name -> [(Name, PTerm)] -> [(Name, Docstring)] -> [PDecl] -> Idris ()+elabClass info syn 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)@@ -1767,8 +1889,8 @@                                constraint          let cons = [(emptyDocstring, [], cn, cty, fc, [])]          let ddecl = PDatadecl tn tty cons-         logLvl 5 $ "Class data " ++ show (showDImp True ddecl)-         elabData info (syn { no_imp = no_imp syn ++ mnames }) doc [] fc [] ddecl+         logLvl 5 $ "Class data " ++ show (showDImp verbosePPOption ddecl)+         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@@ -1808,7 +1930,7 @@      getMName (PTy _ _ _ _ _ n _) = nsroot n     tdecl allmeths (PTy doc _ syn _ o n t)-           = do t' <- implicit' syn allmeths n t+           = do t' <- implicit' info syn allmeths n t                 logLvl 5 $ "Method " ++ show n ++ " : " ++ showTmImpls t'                 return ( (n, (toExp (map fst ps) Exp t')),                          (n, (doc, o, (toExp (map fst ps) Imp t'))),@@ -1885,12 +2007,12 @@     getMeth (m:ms) (a:as) x | x == a = PRef fc m                             | otherwise = getMeth ms as x -    lhsArgs (EA : xs) (n : ns) = pexp (PRef fc n) : lhsArgs xs ns+    lhsArgs (EA : xs) (n : ns) = [] -- pexp (PRef fc n) : lhsArgs xs ns     lhsArgs (IA : xs) ns = lhsArgs xs ns     lhsArgs (CA : xs) ns = lhsArgs xs ns     lhsArgs [] _ = [] -    rhsArgs (EA : xs) (n : ns) = pexp (PRef fc n) : rhsArgs xs ns+    rhsArgs (EA : xs) (n : ns) = [] -- pexp (PRef fc n) : rhsArgs xs ns     rhsArgs (IA : xs) ns = pexp Placeholder : rhsArgs xs ns     rhsArgs (CA : xs) ns = pconst (PResolveTC fc) : rhsArgs xs ns     rhsArgs [] _ = []@@ -1918,10 +2040,13 @@     i <- getIState     (n, ci) <- case lookupCtxtName n (idris_classes i) of                   [c] -> return c-                  _ -> ifail $ show fc ++ ":" ++ show n ++ " is not a type class"+                  [] -> ifail $ show fc ++ ":" ++ show n ++ " is not a type class"+                  cs -> tclift $ tfail $ At fc +                           (CantResolveAlts (map (show . fst) cs))     let constraint = PApp fc (PRef fc n) (map pexp ps)     let iname = mkiname n ps expn-    when (what /= EDefns) $ do+    let emptyclass = null (class_methods ci)+    when (what /= EDefns || (null ds && not emptyclass)) $ do          nty <- elabType' True info syn emptyDocstring [] fc [] iname t          -- if the instance type matches any of the instances we have already,          -- and it's not a named instance, then it's overlapping, so report an error@@ -1930,7 +2055,7 @@                                 (class_instances ci)                           addInstance intInst n iname             Just _ -> addInstance intInst n iname-    when (what /= ETypes) $ do +    when (what /= ETypes && (not (null ds && not emptyclass))) $ do           let ips = zip (class_params ci) ps          let ns = case n of                     NS n ns' -> ns'@@ -1961,25 +2086,25 @@          let wbTys = map mkTyDecl mtys          let wbVals = map (decorateid (decorate ns iname)) ds'          let wb = wbTys ++ wbVals-         logLvl 3 $ "Method types " ++ showSep "\n" (map (show . showDeclImp True . mkTyDecl) mtys)+         logLvl 3 $ "Method types " ++ showSep "\n" (map (show . showDeclImp verbosePPOption . mkTyDecl) mtys)          logLvl 3 $ "Instance is " ++ show ps ++ " implicits " ++                                       show (concat (nub wparams))           -- Bring variables in instance head into scope          ist <- getIState-         let headVars = mapMaybe (\p -> case p of-                                           PRef _ n -> -                                              case lookupTy n (tt_ctxt ist) of-                                                  [] -> Just n-                                                  _ -> Nothing-                                           _ -> Nothing) ps+         let headVars = nub $ mapMaybe (\p -> case p of+                                               PRef _ n -> +                                                  case lookupTy n (tt_ctxt ist) of+                                                      [] -> Just n+                                                      _ -> Nothing+                                               _ -> Nothing) ps --          let lhs = PRef fc iname          let lhs = PApp fc (PRef fc iname)                            (map (\n -> pimp n (PRef fc n) True) headVars)          let rhs = PApp fc (PRef fc (instanceName ci))                            (map (pexp . mkMethApp) mtys) -         logLvl 5 $ "Instance LHS " ++ show lhs+         logLvl 5 $ "Instance LHS " ++ show lhs ++ " " ++ show headVars          logLvl 5 $ "Instance RHS " ++ show rhs           let idecls = [PClauses fc [Dictionary] iname@@ -2012,7 +2137,8 @@     -- TODO: largely based upon elabType' - should try to abstract     elabFindOverlapping i ci iname syn t         = do ty' <- addUsingConstraints syn fc t-             ty' <- implicit syn iname ty'+             -- TODO think: something more in info?+             ty' <- implicit info syn iname ty'              let ty = addImpl i ty'              ctxt <- getContext              ((tyT, _, _), _) <-@@ -2050,9 +2176,9 @@     methArgs i (PPi (Imp _ _ _) n ty sc)         = PImp 0 True [] n (PRef fc (sMN i "meth")) : methArgs (i+1) sc     methArgs i (PPi (Exp _ _ _) n ty sc)-        = PExp 0 [] (PRef fc (sMN i "meth")) : methArgs (i+1) sc+        = PExp 0 [] (sMN 0 "marg") (PRef fc (sMN i "meth")) : methArgs (i+1) sc     methArgs i (PPi (Constraint _ _) n ty sc)-        = PConstraint 0 [] (PResolveTC fc) : methArgs (i+1) sc+        = PConstraint 0 [] (sMN 0 "marg") (PResolveTC fc) : methArgs (i+1) sc     methArgs i _ = []      papp fc f [] = f@@ -2068,7 +2194,7 @@                 _ -> return ps'     getWParams (_ : ps) = getWParams ps -    decorate ns iname (UN n) = NS (SN (MethodN (UN n))) ns+    decorate ns iname (UN n)        = NS (SN (MethodN (UN n))) ns     decorate ns iname (NS (UN n) s) = NS (SN (MethodN (UN n))) ns      mkTyDecl (n, op, t, _) = PTy emptyDocstring [] syn fc op n t@@ -2217,6 +2343,11 @@               [p] -> elabDecl what info p               _ -> do mapM_ (elabDecl ETypes info) ps                       mapM_ (elabDecl EDefns info) ps+         -- record mutually defined data definitions+         let datans = concatMap declared (filter isDataDecl ps)+         mapM_ (setMutData datans) datans+         iLOG $ "Rechecking for positivity " ++ show datans+         mapM_ (\x -> do setTotality x Unchecked) datans          -- Do totality checking after entire mutual block          i <- get          mapM_ (\n -> do logLvl 5 $ "Simplifying " ++ show n@@ -2225,7 +2356,17 @@          mapM_ buildSCG (idris_totcheck i)          mapM_ checkDeclTotality (idris_totcheck i)          clear_totcheck+  where isDataDecl (PData _ _ _ _ _ _) = True+        isDataDecl _ = False +        setMutData ns n +           = do i <- getIState+                case lookupCtxt n (idris_datatypes i) of+                   [x] -> do let x' = x { mutual_types = ns }+                             putIState $ i { idris_datatypes +                                                = addDef n x' (idris_datatypes i) }+                   _ -> return ()+ elabDecl' what info (PParams f ns ps)     = do i <- getIState          iLOG $ "Expanding params block with " ++ show ns ++ " decls " ++@@ -2247,17 +2388,17 @@     ninfo = case namespace info of                 Nothing -> info { namespace = Just [n] }                 Just ns -> info { namespace = Just (n:ns) }-elabDecl' what info (PClass doc s f cs n ps ds)+elabDecl' what info (PClass doc s f cs n ps pdocs ds)   | what /= EDefns     = do iLOG $ "Elaborating class " ++ show n-         elabClass info (s { syn_params = [] }) doc f cs n ps ds+         elabClass info (s { syn_params = [] }) doc f cs n ps pdocs ds elabDecl' what info (PInstance s f cs n ps t expn ds)     = do iLOG $ "Elaborating instance " ++ show n          elabInstance info s what f cs n ps t expn ds-elabDecl' what info (PRecord doc s f tyn ty cdoc cn cty)+elabDecl' what info (PRecord doc s f tyn ty opts cdoc cn cty)   | what /= ETypes     = do iLOG $ "Elaborating record " ++ show tyn-         elabRecord info s doc f tyn ty cdoc cn cty+         elabRecord info s doc f tyn ty opts cdoc cn cty   | otherwise     = do iLOG $ "Elaborating [type of] " ++ show tyn          elabData info s doc [] f [] (PLaterdecl tyn ty)
src/Idris/ElabTerm.hs view
@@ -3,6 +3,7 @@ module Idris.ElabTerm where  import Idris.AbsSyntax+import Idris.AbsSyntaxTree import Idris.DSL import Idris.Delaborate import Idris.Error@@ -27,16 +28,6 @@  import Debug.Trace --- Data to pass to recursively called elaborators; e.g. for where blocks,--- paramaterised declarations, etc.--data ElabInfo = EInfo { params :: [(Name, PTerm)],-                        inblock :: Ctxt [Name], -- names in the block, and their params-                        liftname :: Name -> Name,-                        namespace :: Maybe [String] }--toplevel = EInfo [] emptyContext id Nothing- -- Using the elaborator, convert a term in raw syntax to a fully -- elaborated, typechecked term. --@@ -75,15 +66,19 @@          ctxt <- get_context          probs <- get_probs          u <- getUnifyLog+         hs <- get_holes           when (not pattern) $ -           traceWhen u ("Remaining problems:\n" ++ show probs) $ -             do matchProblems True; unifyProblems+           traceWhen u ("Remaining holes:\n" ++ show hs ++ "\n" +++                        "Remaining problems:\n" ++ show probs) $ +             do unify_all; matchProblems True; unifyProblems+          probs <- get_probs          case probs of             [] -> return ()-            ((_,_,_,e,_,_):es) -> if inf then return ()-                                         else lift (Error e)+            ((_,_,_,e,_,_):es) -> traceWhen u ("Final problems:\n" ++ show probs) $+                                   if inf then return ()+                                          else lift (Error e)          is <- getAux          tt <- get_term          let (tm, ds) = runState (collectDeferred (Just fn) tt) []@@ -132,6 +127,7 @@          end_unify          when pattern -- convert remaining holes to pattern vars               (do update_term orderPats+                  unify_all                   matchProblems False -- only the ones we matched earlier                   unifyProblems                   mkPat)@@ -271,7 +267,8 @@              ty <- goal              ctxt <- get_context              let (tc, _) = unApply ty-             let as' = pruneByType tc ctxt as+             env <- get_env+             let as' = pruneByType (map fst env) tc ctxt as --              trace (show as ++ "\n ==> " ++ showSep ", " (map showTmImpls as')) $              tryAll (zip (map (elab' ina) as') (map showHd as'))         where showHd (PApp _ (PRef _ n) _) = show n@@ -474,7 +471,7 @@                     elabArgs ist (ina || not isinf, guarded, inty)                            [] fc False f ns'                               (f == sUN "Force")-                             (map (\x -> (lazyarg x, getTm x)) eargs)+                             (map (\x -> (False, getTm x)) eargs) -- TODO: remove this False arg                     solve                     ivs' <- get_instances                     -- Attempt to resolve any type classes which have 'complete' types,@@ -503,6 +500,7 @@                 where alt t = case getTm t of                                    PAlternative False _ -> 5                                    PAlternative True _ -> 1+                                   PTactics _ -> 150                                    PLam _ _ _ -> 2                                    PRewrite _ _ _ _ -> 3                                    _ -> 0@@ -568,7 +566,7 @@              claim tyn RType              valn <- getNameFrom (sMN 0 "rval")              claim valn (Var tyn)-             letn <- getNameFrom (sMN 0 "rewrite_rule")+             letn <- getNameFrom (sMN 0 "_rewrite_rule")              letbind letn (Var tyn) (Var valn)              focus valn              elab' ina r@@ -697,9 +695,12 @@       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")) +                        addImpl ist (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.+    insertCoerce ina t@(PCase _ _ _) = return t     insertCoerce ina t =         do ty <- goal            -- Check for possible coercions to get to the goal@@ -733,7 +734,7 @@         = 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 "lazy"))+          = elabArg argName holeName (PApp bi (PRef bi (sUN "Delay"))                                            [pimp (sUN "a") Placeholder True,                                             pexp t])         | otherwise = elabArg argName holeName t@@ -790,8 +791,21 @@  -- Rule out alternatives that don't return the same type as the head of the goal -- (If there are none left as a result, do nothing)-pruneByType :: Term -> Context -> [PTerm] -> [PTerm]-pruneByType (P _ n _) c as+pruneByType :: [Name] -> Term -> Context -> [PTerm] -> [PTerm]+-- if an alternative has a locally bound name at the head, take it+pruneByType env t c as+   | Just a <- locallyBound as = [a]+  where+    locallyBound [] = Nothing+    locallyBound (t:ts)+       | Just n <- getName t,+         n `elem` env = Just t+       | otherwise = locallyBound ts+    getName (PRef _ n) = Just n+    getName (PApp _ f _) = getName f+    getName _ = Nothing+                      +pruneByType env (P _ n _) c as -- if the goal type is polymorphic, keep e    | [] <- lookupTy n c = as    | otherwise@@ -817,7 +831,7 @@                                     _ -> False                        _ -> False -pruneByType t _ as = as+pruneByType _ t _ as = as  findInstances :: IState -> Term -> [Name] findInstances ist t@@ -829,9 +843,10 @@  trivial' ist     = trivial (elab ist toplevel False [] (sMN 0 "tac")) ist-proofSearch' ist top n hints-    = proofSearch (elab ist toplevel False [] (sMN 0 "tac")) top n hints 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  resolveTC :: Int -> Term -> Name -> IState -> ElabD () resolveTC = resTC' [] @@ -1004,6 +1019,8 @@                                _ -> return []     runT (Refine fn imps) = do ns <- apply (Var fn) (map (\x -> (x,0)) imps)                                when autoSolve solveAll+    runT DoUnify = do unify_all+                      when autoSolve solveAll     runT (Equiv tm) -- let bind tm, then               = do attack                    tyn <- getNameFrom (sMN 0 "ety")@@ -1059,8 +1076,9 @@     runT Compute = compute     runT Trivial = do trivial' ist; when autoSolve solveAll     runT TCInstance = runT (Exact (PResolveTC emptyFC))-    runT (ProofSearch top hints)-         = do proofSearch' ist top fn hints; when autoSolve solveAll+    runT (ProofSearch rec prover depth top hints)+         = do proofSearch' ist rec depth prover top fn hints+              when autoSolve solveAll     runT (Focus n) = focus n     runT Solve = solve     runT (Try l r) = do try' (runT l) (runT r) True@@ -1187,14 +1205,16 @@  reifyApp :: IState -> Name -> [Term] -> ElabD PTactic reifyApp ist t [l, r] | t == reflm "Try" = liftM2 Try (reify ist l) (reify ist r)+reifyApp _ t [Constant (I i)] +           | t == reflm "Search" = return (ProofSearch True True i Nothing []) reifyApp _ t [x]            | t == reflm "Refine" = do n <- reifyTTName x                                       return $ Refine n [] reifyApp ist t [l, r] | t == reflm "Seq" = liftM2 TSeq (reify ist l) (reify ist r) reifyApp ist t [Constant (Str n), x]              | t == reflm "GoalType" = liftM (GoalType n) (reify ist x)-reifyApp _ t [Constant (Str n)]-           | t == reflm "Intro" = return $ Intro [sUN n]+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 "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t') reifyApp ist t [t']@@ -1634,6 +1654,8 @@                                                                  then handle err                                                                  else applyHandlers err hs                                                       return (ElaboratingArg f a prev err')+          -- ProofSearchFail is an internal detail - so don't expose it+          handle (ProofSearchFail e) = handle e           -- TODO: argument-specific error handlers go here for ElaboratingArg           handle e = do ist <- getIState                         logLvl 2 "Starting error reflection"
+ src/Idris/Erasure.hs view
@@ -0,0 +1,513 @@+{-# LANGUAGE PatternGuards #-}++module Idris.Erasure (performUsageAnalysis, mkFieldName) where++import Idris.AbsSyntax+import Idris.ASTUtils+import Idris.Core.CaseTree+import Idris.Core.TT+import Idris.Core.Evaluate+import Idris.Primitives+import Idris.Error++import Debug.Trace+import System.IO.Unsafe++import Control.Category+import Prelude hiding (id, (.))++import Control.Arrow+import Control.Applicative+import Control.Monad.State+import Data.Maybe+import Data.List+import qualified Data.Set as S+import qualified Data.IntSet as IS+import qualified Data.Map as M+import qualified Data.IntMap as IM+import Data.Set (Set)+import Data.IntSet (IntSet)+import Data.Map (Map)+import Data.IntMap (IntMap)+import Data.Text (pack)+import qualified Data.Text as T++-- UseMap maps names to the set of used (reachable) argument positions.+type UseMap = Map Name (IntMap (Set Reason))++data Arg = Arg Int | Result deriving (Eq, Ord)++instance Show Arg where+    show (Arg i) = show i+    show Result  = "*"++type Node = (Name, Arg)+type Deps = Map Cond DepSet+type Reason = (Name, Int)  -- function name, argument index++-- Nodes along with sets of reasons for every one.+type DepSet = Map Node (Set Reason)++-- "Condition" is the conjunction+-- of elementary assumptions along the path from the root.+-- Elementary assumption (f, i) means that "function f uses the argument i".+type Cond = Set Node++-- Variables carry certain information with them.+data VarInfo = VI+    { viDeps   :: DepSet      -- dependencies drawn in by the variable+    , viFunArg :: Maybe Int   -- which function argument this variable came from (defined only for patvars)+    , viMethod :: Maybe Name  -- name of the metamethod represented by the var, if any+    }+    deriving Show++type Vars = Map Name VarInfo++-- Perform usage analysis, write the relevant information in the internal+-- structures, returning the list of reachable names.+performUsageAnalysis :: Idris [Name]+performUsageAnalysis = do+    ctx <- tt_ctxt <$> getIState+    mainName <- getMainName <$> getIState++    case mainName of+      Left reason -> return []  -- no main -> not compiling -> reachability irrelevant+      Right main  -> do+        ci  <- idris_classes <$> getIState+        cg  <- idris_callgraph <$> getIState+        opt <- idris_optimisation <$> getIState++        -- Build the dependency graph.+        let depMap = buildDepMap ci ctx main++        -- Search for reachable nodes in the graph.+        let (residDeps, (reachableNames, minUse)) = minimalUsage depMap+            usage = M.toList minUse++        -- Print some debug info.+        logLvl 5 $ "Original deps:\n" ++ unlines (map fmtItem . M.toList $ depMap)+        logLvl 3 $ "Reachable names:\n" ++ unlines (map (indent . show) . S.toList $ reachableNames)+        logLvl 4 $ "Minimal usage:\n" ++ fmtUseMap usage+        logLvl 5 $ "Residual deps:\n" ++ unlines (map fmtItem . M.toList $ residDeps)++        -- Check that everything reachable is accessible.+        checkEnabled <- (WarnReach `elem`) . opt_cmdline . idris_options <$> getIState+        when checkEnabled $+            mapM_ (checkAccessibility opt) usage++        -- Check that no postulates are reachable.+        reachablePostulates <- S.intersection reachableNames . idris_postulates <$> getIState+        when (not . S.null $ reachablePostulates)+            $ ifail ("reachable postulates:\n" ++ intercalate "\n" ["  " ++ show n | n <- S.toList reachablePostulates])++        -- Store the usage info in the internal state.+        mapM_ storeUsage usage++        return $ S.toList reachableNames+  where+    getMainName :: IState -> Either Err Name+    getMainName ist = case lookupCtxtName n (idris_implicits ist) of+        [(n', _)] -> Right n'+        []        -> Left (NoSuchVariable n)+        more      -> Left (CantResolveAlts (map (show . fst) more))+      where+        n = sNS (sUN "main") ["Main"]++    indent = ("  " ++)++    fmtItem :: (Cond, DepSet) -> String+    fmtItem (cond, deps) = indent $ show (S.toList cond) ++ " -> " ++ show (M.toList deps)++    fmtUseMap :: [(Name, IntMap (Set Reason))] -> String+    fmtUseMap = unlines . map (\(n,is) -> indent $ show n ++ " -> " ++ fmtIxs is)++    fmtIxs :: IntMap (Set Reason) -> String+    fmtIxs = intercalate ", " . map fmtArg . IM.toList+      where+        fmtArg (i, rs)+            | S.null rs = show i+            | otherwise = show i ++ " from " ++ intercalate ", " (map show $ S.toList rs)++    storeUsage :: (Name, IntMap (Set Reason)) -> Idris ()+    storeUsage (n, args) = fputState (cg_usedpos . ist_callgraph n) flat+      where+        flat = [(i, S.toList rs) | (i,rs) <- IM.toList args]++    checkAccessibility :: Ctxt OptInfo -> (Name, IntMap (Set Reason)) -> Idris ()+    checkAccessibility opt (n, reachable)+        | Just (Optimise inaccessible dt) <- lookupCtxtExact n opt+        , eargs@(_:_) <- [fmt n (S.toList rs) | (i,n) <- inaccessible, rs <- maybeToList $ IM.lookup i reachable]+        = warn $ show n ++ ": inaccessible arguments reachable:\n  " ++ intercalate "\n  " eargs++        | otherwise = return ()+      where+        fmt n [] = show n ++ " (no more information available)"+        fmt n rs = show n ++ " from " ++ intercalate ", " [show rn ++ " arg# " ++ show ri | (rn,ri) <- rs]+        warn = logLvl 0++-- Find the minimal consistent usage by forward chaining.+minimalUsage :: Deps -> (Deps, (Set Name, UseMap))+minimalUsage = second gather . forwardChain+  where+    gather :: DepSet -> (Set Name, UseMap)+    gather = foldr ins (S.empty, M.empty) . M.toList+       where+        ins :: (Node, Set Reason) -> (Set Name, UseMap) -> (Set Name, UseMap)+        ins ((n, Result), rs) (ns, umap) = (S.insert n ns, umap)+        ins ((n, Arg i ), rs) (ns, umap) = (ns, M.insertWith (IM.unionWith S.union) n (IM.singleton i rs) umap)++forwardChain :: Deps -> (Deps, DepSet)+forwardChain deps+    | Just trivials <- M.lookup S.empty deps +        = (M.unionWith S.union trivials)+            `second` forwardChain (remove trivials . M.delete S.empty $ deps)+    | otherwise = (deps, M.empty)+  where+    -- Remove the given nodes from the Deps entirely,+    -- possibly creating new empty Conds.+    remove :: DepSet -> Deps -> Deps+    remove ds = M.mapKeysWith (M.unionWith S.union) (S.\\ M.keysSet ds)++-- Build the dependency graph,+-- starting the depth-first search from a list of Names.+buildDepMap :: Ctxt ClassInfo -> Context -> Name -> Deps+buildDepMap ci ctx mainName = addPostulates $ dfs S.empty M.empty [mainName]+  where+    -- mark the result of Main.main as used with the empty assumption+    addPostulates :: Deps -> Deps+    addPostulates deps = foldr (\(ds, rs) -> M.insertWith (M.unionWith S.union) ds rs) deps postulates+      where+        -- mini-DSL for postulates+        (==>) ds rs = (S.fromList ds, M.fromList [(r, S.empty) | r <- rs])+        it n is = [(sUN n, Arg i) | i <- is]+        mn n is = [(MN 0 $ pack n, Arg i) | i <- is]++        -- believe_me is special because it does not use all its arguments+        specialPrims = S.fromList [sUN "prim__believe_me"]+        usedNames = allNames deps S.\\ specialPrims+        usedPrims = [(p_name p, p_arity p) | p <- primitives, p_name p `S.member` usedNames]++        postulates = +            [ [] ==> concat+                -- These two, Main.main and run__IO, are always evaluated+                -- but they elude analysis since they come from the seed term.+                [ [(mainName,  Result)] +                , [(sUN "run__IO", Result), (sUN "run__IO", Arg 0)]++                -- MkIO is read by run__IO,+                -- but this cannot be observed in the source code of programs.+                , it "MkIO"         [1]+                , it "prim__IO"     [1]++                -- these have been discovered as builtins but are not listed+                -- among Idris.Primitives.primitives+                , mn "__MkPair"     [2,3]+                , it "prim_fork"    [0]+                , it "unsafePerformPrimIO"  [1]++                -- believe_me is a primitive but it only uses its third argument+                -- it is special-cased in usedNames above+                , it "prim__believe_me" [2]+    +                -- in general, all other primitives use all their arguments+                , [(n, Arg i) | (n,arity) <- usedPrims, i <- [0..arity-1]]++                -- mkForeign* functions are special-cased below+                ]+            ]++    -- perform depth-first search+    -- to discover all the names used in the program+    -- and call getDeps for every name+    dfs :: Set Name -> Deps -> [Name] -> Deps+    dfs visited deps [] = deps+    dfs visited deps (n : ns)+        | n `S.member` visited = dfs visited deps ns+        | otherwise = dfs (S.insert n visited) (M.unionWith (M.unionWith S.union) deps' deps) (next ++ ns)+      where+        next = [n | n <- S.toList depn, n `S.notMember` visited]+        depn = S.delete n $ allNames deps'+        deps' = getDeps n++    -- extract all names that a function depends on+    -- from the Deps of the function+    allNames :: Deps -> Set Name+    allNames = S.unions . map names . M.toList+        where+        names (cs, ns) = S.map fst cs `S.union` S.map fst (M.keysSet ns)++    -- get Deps for a Name+    getDeps :: Name -> Deps+    getDeps (SN (WhereN i (SN (InstanceCtorN classN)) (MN i' field)))+        = M.empty  -- these deps are created when applying instance ctors+    getDeps n = case lookupDefExact n ctx of+        Just def -> getDepsDef n def+        Nothing  -> error $ "erasure checker: unknown reference: " ++ show n++    getDepsDef :: Name -> Def -> Deps+    getDepsDef fn (Function ty t) = error "a function encountered"  -- TODO+    getDepsDef fn (TyDecl   ty t) = M.empty+    getDepsDef fn (Operator ty n' f) = M.empty  -- TODO: what's this?+    getDepsDef fn (CaseOp ci ty tys def tot cdefs)+        = getDepsSC fn etaVars (etaMap `M.union` varMap) sc+      where+        -- we must eta-expand the definition with fresh variables+        -- to capture these dependencies as well+        etaIdx = [length vars .. length tys - 1]+        etaVars = [eta i | i <- etaIdx]+        etaMap = M.fromList [varPair (eta i) i | i <- etaIdx]+        eta i = MN i (pack "eta")++        -- the variables that arose as function arguments only depend on (n, i)+        varMap = M.fromList [varPair v i | (v,i) <- zip vars [0..]]++        varPair n argNo = (n, VI+            { viDeps   = M.singleton (fn, Arg argNo) S.empty+            , viFunArg = Just argNo+            , viMethod = Nothing+            })++        (vars, sc) = cases_runtime cdefs+            -- we use cases_runtime in order to have case-blocks+            -- resolved to top-level functions before our analysis++    etaExpand :: [Name] -> Term -> Term+    etaExpand []       t = t+    etaExpand (n : ns) t = etaExpand ns (App t (P Ref n Erased))++    getDepsSC :: Name -> [Name] -> Vars -> SC -> Deps+    getDepsSC fn es vs  ImpossibleCase     = M.empty+    getDepsSC fn es vs (UnmatchedCase msg) = M.empty++    -- for the purposes of erasure, we can disregard the projection+    getDepsSC fn es vs (ProjCase (Proj t i) alts) = getDepsSC fn es vs (ProjCase t alts)  -- step+    getDepsSC fn es vs (ProjCase (P  _ n _) alts) = getDepsSC fn es vs (Case     n alts)  -- base++    -- other ProjCase's are not supported+    getDepsSC fn es vs (ProjCase t alts)   = error $ "ProjCase not supported:\n" ++ show (ProjCase t alts)++    getDepsSC fn es vs (STerm    t)        = getDepsTerm vs [] (S.singleton (fn, Result)) (etaExpand es t)+    getDepsSC fn es vs (Case n alts)+        -- we case-split on this variable, which marks it as used+        -- (unless there is exactly one case branch)+        -- hence we add a new dependency, whose only precondition is+        -- that the result of this function is used at all+        = addTagDep $ unionMap (getDepsAlt fn es vs casedVar) alts  -- coming from the whole subtree+      where+        addTagDep = case alts of+            [_] -> id  -- single branch, tag not used+            _   -> M.insertWith (M.unionWith S.union) (S.singleton (fn, Result)) (viDeps casedVar)+        casedVar  = fromMaybe (error $ "nonpatvar in case: " ++ show n) (M.lookup n vs)++    getDepsAlt :: Name -> [Name] -> Vars -> VarInfo -> CaseAlt -> Deps+    getDepsAlt fn es vs var (FnCase n ns sc) = error "an FnCase encountered"  -- TODO: what's this?+    getDepsAlt fn es vs var (ConstCase c sc) = getDepsSC fn es vs sc+    getDepsAlt fn es vs var (DefaultCase sc) = getDepsSC fn es vs sc+    getDepsAlt fn es vs var (SucCase   n sc)+        = getDepsSC fn es (M.insert n var vs) sc -- we're not inserting the S-dependency here because it's special-cased++    -- data constructors+    getDepsAlt fn es vs var (ConCase n cnt ns sc)+        = getDepsSC fn es (vs' `M.union` vs) sc  -- left-biased union+      where+        -- Here we insert dependencies that arose from pattern matching on a constructor.+        -- n = ctor name, j = ctor arg#, i = fun arg# of the cased var, cs = ctors of the cased var+        vs' = M.fromList [(v, VI+            { viDeps   = M.insertWith S.union (n, Arg j) (S.singleton (fn, varIdx)) (viDeps var)+            , viFunArg = viFunArg var+            , viMethod = meth j+            })+          | (v, j) <- zip ns [0..]]+        +        -- this is safe because it's certainly a patvar+        varIdx = fromJust (viFunArg var)++        -- generate metamethod names, "n" is the instance ctor+        meth :: Int -> Maybe Name+        meth | SN (InstanceCtorN className) <- n = \j -> Just (mkFieldName n j)+             | otherwise = \j -> Nothing++    -- Named variables -> DeBruijn variables -> Conds/guards -> Term -> Deps+    getDepsTerm :: Vars -> [(Name, Cond -> Deps)] -> Cond -> Term -> Deps++    -- named variables introduce dependencies as described in `vs'+    getDepsTerm vs bs cd (P _ n _)+        -- de bruijns (lambda-bound, let-bound vars)+        | Just deps <- lookup n bs+        = deps cd++        -- ctor-bound/arg-bound variables+        | Just var <- M.lookup n vs+        = M.singleton cd (viDeps var)++        -- sanity check: machine-generated names shouldn't occur at top-level+        | MN _ _ <- n+        , n `notElem` specialMNs+        = error $ "erasure analysis: variable " ++ show n ++ " unbound in " ++ show (S.toList cd)++        -- assumed to be a global reference+        | otherwise = M.singleton cd (M.singleton (n, Result) S.empty)+      where+        specialMNs = map (sMN 0 . ("__" ++)) $ words "Unit True False II"+    +    -- dependencies of de bruijn variables are described in `bs'+    getDepsTerm vs bs cd (V i) = snd (bs !! i) cd++    getDepsTerm vs bs cd (Bind n bdr t)+        -- here we just push IM.empty on the de bruijn stack+        -- the args will be marked as used at the usage site+        | Lam ty <- bdr = getDepsTerm vs ((n, const M.empty) : bs) cd t+        | Pi  ty <- bdr = getDepsTerm vs ((n, const M.empty) : bs) cd t++        -- let-bound variables can get partially evaluated+        -- it is sufficient just to plug the Cond in when the bound names are used+        |  Let ty t <- bdr = getDepsTerm vs ((n, var t) : bs) cd t+        | NLet ty t <- bdr = getDepsTerm vs ((n, var t) : bs) cd t+      where+        var t cd = getDepsTerm vs bs cd t++    -- applications may add items to Cond+    getDepsTerm vs bs cd app@(App _ _)+        | (fun, args) <- unApply app = case fun of+            -- instance constructors -> create metamethod deps+            P (DCon _ _) ctorName@(SN (InstanceCtorN className)) _+                -> conditionalDeps ctorName args  -- regular data ctor stuff+                    `union` unionMap (methodDeps ctorName) (zip [0..] args)  -- method-specific stuff++            -- ordinary constructors+            P (TCon _ _) n _ -> unconditionalDeps args  -- does not depend on anything+            P (DCon _ _) n _ -> conditionalDeps n args  -- depends on whether (n,#) is used++            -- mkForeign* calls must be special-cased because they are variadic+            -- All arguments must be marked as used, except for the first one,+            -- which is the (Foreign a) spec that defines the type+            -- and is not needed at runtime.+            P _ (UN n) _+                | n `elem` map T.pack ["mkForeign", "mkForeignPrim", "mkLazyForeignPrim"]+                -> unconditionalDeps (drop 1 args)++            -- a bound variable might draw in additional dependencies,+            -- think: f x = x 0  <-- here, `x' _is_ used+            P _ n _+                -- debruijn-bound name+                | Just deps <- lookup n bs+                    -> deps cd `union` unconditionalDeps args++                -- local name that refers to a method+                | Just var  <- M.lookup n vs+                , Just meth <- viMethod var+                    -> viDeps var `ins` conditionalDeps meth args  -- use the method instead++                -- local name+                | Just var <- M.lookup n vs+                    -- unconditional use+                    -> viDeps var `ins` unconditionalDeps args++                -- global name+                | otherwise+                    -- depends on whether the referred thing uses its argument+                    -> conditionalDeps n args++            -- TODO: could we somehow infer how bound variables use their arguments?+            V i -> snd (bs !! i) cd `union` unconditionalDeps args++            -- we interpret applied lambdas as lets in order to reuse code here+            Bind n (Lam ty) t -> getDepsTerm vs bs cd (lamToLet [] app)++            -- and we interpret applied lets as lambdas+            Bind n ( Let ty t') t -> getDepsTerm vs bs cd (App (Bind n (Lam ty) t) t')+            Bind n (NLet ty t') t -> getDepsTerm vs bs cd (App (Bind n (Lam ty) t) t')++            Proj t i+                -> error $ "cannot[0] analyse projection !" ++ show i ++ " of " ++ show t++            Erased -> M.empty++            _ -> error $ "cannot analyse application of " ++ show fun ++ " to " ++ show args+      where+        union = M.unionWith $ M.unionWith S.union+        ins = M.insertWith (M.unionWith S.union) cd++        unconditionalDeps :: [Term] -> Deps+        unconditionalDeps = unionMap (getDepsTerm vs bs cd)++        conditionalDeps :: Name -> [Term] -> Deps+        conditionalDeps n+            = ins (M.singleton (n, Result) S.empty) . unionMap (getDepsArgs n) . zip indices+          where+            indices = map Just [0 .. getArity n - 1] ++ repeat Nothing+            getDepsArgs n (Just i,  t) = getDepsTerm vs bs (S.insert (n, Arg i) cd) t  -- conditional+            getDepsArgs n (Nothing, t) = getDepsTerm vs bs cd t                        -- unconditional++        methodDeps :: Name -> (Int, Term) -> Deps+        methodDeps ctorName (methNo, t)+            = getDepsTerm (vars `M.union` vs) (bruijns ++ bs) cond body+          where+            vars = M.fromList [(v, VI+                { viDeps   = deps i+                , viFunArg = Just i+                , viMethod = Nothing+                }) | (v, i) <- zip args [0..]]+            deps i   = M.singleton (metameth, Arg i) S.empty+            bruijns  = reverse [(n, \cd -> M.singleton cd (deps i)) | (i, n) <- zip [0..] args]+            cond     = S.singleton (metameth, Result)+            metameth = mkFieldName ctorName methNo+            (args, body) = unfoldLams t++    -- projections+    getDepsTerm vs bs cd (Proj t (-1)) = getDepsTerm vs bs cd t  -- naturals, (S n) -> n+    getDepsTerm vs bs cd (Proj t i) = error $ "cannot[1] analyse projection !" ++ show i ++ " of " ++ show t++    -- the easy cases+    getDepsTerm vs bs cd (Constant _) = M.empty+    getDepsTerm vs bs cd (TType    _) = M.empty+    getDepsTerm vs bs cd  Erased      = M.empty+    getDepsTerm vs bs cd  Impossible  = M.empty++    getDepsTerm vs bs cd t = error $ "cannot get deps of: " ++ show t++    -- Get the number of arguments that might be considered for erasure.+    getArity :: Name -> Int+    getArity (SN (WhereN i' ctorName (MN i field)))+        | Just (TyDecl (DCon _ _) ty) <- lookupDefExact ctorName ctx+        = let argTys = map snd $ getArgTys ty+            in if i <= length argTys+                then length $ getArgTys (argTys !! i)+                else error $ "invalid field number " ++ show i ++ " for " ++ show ctorName++        | otherwise = error $ "unknown instance constructor: " ++ show ctorName++    getArity n = case lookupDefExact n ctx of+        Just (CaseOp ci ty tys def tot cdefs) -> length tys+        Just (TyDecl (DCon tag arity) _)      -> arity+        Just (TyDecl (Ref) ty)                -> length $ getArgTys ty+        Just (Operator ty arity op)           -> arity+        Just df -> error $ "Erasure/getArity: unrecognised entity '"+                             ++ show n ++ "' with definition: "  ++ show df+        Nothing -> error $ "Erasure/getArity: definition not found for " ++ show n++    -- convert applications of lambdas to lets+    -- Note that this transformation preserves de bruijn numbering+    lamToLet :: [Term] -> Term -> Term+    lamToLet    xs  (App f x)           = lamToLet (x:xs) f+    lamToLet (x:xs) (Bind n (Lam ty) t) = Bind n (Let ty x) (lamToLet xs t)+    lamToLet (x:xs)  t                  = App (lamToLet xs t) x+    lamToLet    []   t                  = t++    -- split "\x_i -> T(x_i)" into [x_i] and T+    unfoldLams :: Term -> ([Name], Term)+    unfoldLams (Bind n (Lam ty) t) = let (ns,t') = unfoldLams t in (n:ns, t')+    unfoldLams t = ([], t)++    union :: Deps -> Deps -> Deps+    union = M.unionWith (M.unionWith S.union)++    unions :: [Deps] -> Deps+    unions = M.unionsWith (M.unionWith S.union)++    unionMap :: (a -> Deps) -> [a] -> Deps+    unionMap f = M.unionsWith (M.unionWith S.union) . map f++-- Make a field name out of a data constructor name and field number.+mkFieldName :: Name -> Int -> Name+mkFieldName ctorName fieldNo = SN (WhereN fieldNo ctorName $ sMN fieldNo "field")
src/Idris/Error.hs view
@@ -43,11 +43,13 @@ setAndReport :: Err -> Idris () setAndReport e = do ist <- getIState                     let h = idris_outh ist-                    case e of+                    case (unwrap e) of                       At fc e -> do setErrSpan fc                                     ihWarn h fc $ pprintErr ist e                       _ -> do setErrSpan (getErrSpan e)-                              ihputStrLn h $ pshow ist e+                              ihWarn h emptyFC $ pprintErr ist e+  where unwrap (ProofSearchFail e) = e -- remove bookkeeping constructor+        unwrap e = e  ifail :: String -> Idris a ifail = throwError . Msg
src/Idris/Help.hs view
@@ -4,6 +4,7 @@             | NameArg -- ^ The command takes a name             | FileArg -- ^ The command takes a file             | ModuleArg -- ^ The command takes a module name+            | NamespaceArg -- ^ The command takes a namespace name             | OptionArg -- ^ The command takes an option             | MetaVarArg -- ^ The command takes a metavariable             | ColourArg  -- ^ The command is the colour-setting command@@ -16,6 +17,7 @@     show NameArg          = "<name>"     show FileArg          = "<filename>"     show ModuleArg        = "<module>"+    show NamespaceArg     = "<namespace>"     show OptionArg        = "<option>"     show MetaVarArg       = "<metavar>"     show ColourArg        = "<option>"@@ -29,23 +31,25 @@     ([":t"], ExprArg, "Check the type of an expression"),     ([":miss", ":missing"], NameArg, "Show missing clauses"),     ([":doc"], NameArg, "Show internal documentation"),+    ([":mkdoc"], NamespaceArg, "Generate IdrisDoc for namespace(s) and dependencies"),     ([":apropos"], NoArg, "Search names, types, and documentation"),-    ([":i", ":info"], NameArg, "Display information about a type class"),+    ([":search", ":s"], ExprArg, "Search for values by type"),+    ([":whocalls", ":wc"], NameArg, "List the callers of some name"),+    ([":callswho", ":cw"], NameArg, "List the callees of some name"),     ([":total"], NameArg, "Check the totality of a name"),     ([":r",":reload"], NoArg, "Reload current file"),     ([":l",":load"], FileArg, "Load a new file"),     ([":cd"], FileArg, "Change working directory"),-    ([":m",":module"], ModuleArg, "Import an extra module"), -- NOTE: dragons+    ([":module"], ModuleArg, "Import an extra module"), -- NOTE: dragons     ([":e",":edit"], NoArg, "Edit current file using $EDITOR or $VISUAL"),-    ([":m",":metavars"], MetaVarArg, "Show remaining proof obligations (metavariables)"),+    ([":m",":metavars"], NoArg, "Show remaining proof obligations (metavariables)"),     ([":p",":prove"], MetaVarArg, "Prove a metavariable"),     ([":a",":addproof"], NameArg, "Add proof to source file"),     ([":rmproof"], NameArg, "Remove proof from proof stack"),     ([":showproof"], NameArg, "Show proof"),     ([":proofs"], NoArg, "Show available proofs"),     ([":x"], ExprArg, "Execute IO actions resulting from an expression using the interpreter"),-    ([":c",":compile"], FileArg, "Compile to an executable <filename>"),-    ([":js", ":javascript"], FileArg, "Compile to JavaScript <filename>"),+    ([":c",":compile"], FileArg, "Compile to an executable [codegen] <filename>"),     ([":exec",":execute"], NoArg, "Compile to an executable and run"),     ([":dynamic"], FileArg, "Dynamically load a C library (similar to %dynamic)"),     ([":dynamic"], NoArg, "List dynamically loaded C libraries"),
src/Idris/IBC.hs view
@@ -19,6 +19,7 @@ import Data.List import Data.ByteString.Lazy as B hiding (length, elem, map) import qualified Data.Text as T+import qualified Data.Set as S  import Control.Monad import Control.Monad.State.Strict hiding (get, put)@@ -29,7 +30,7 @@ import Util.Zlib (decompressEither)  ibcVersion :: Word8-ibcVersion = 65+ibcVersion = 74  data IBCFile = IBCFile { ver :: Word8,                          sourcefile :: FilePath,@@ -52,6 +53,7 @@                          ibc_hdrs :: [(Codegen, String)],                          ibc_access :: [(Name, Accessibility)],                          ibc_total :: [(Name, Totality)],+                         ibc_totcheckfail :: [(FC, String)],                          ibc_flags :: [(Name, [FnOpt])],                          ibc_cg :: [(Name, CGInfo)],                          ibc_defs :: [(Name, Def)],@@ -65,7 +67,9 @@                          ibc_errorhandlers :: [Name],                          ibc_function_errorhandlers :: [(Name, Name, Name)], -- fn, arg, handler                          ibc_metavars :: [(Name, (Maybe Name, Int, Bool))],-                         ibc_patdefs :: [(Name, ([([Name], Term, Term)], [PTerm]))]+                         ibc_patdefs :: [(Name, ([([Name], Term, Term)], [PTerm]))],+                         ibc_postulates :: [Name],+                         ibc_parsedSpan :: Maybe FC                        }    deriving Show {-!@@ -73,7 +77,7 @@ !-}  initIBC :: IBCFile-initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing  loadIBC :: FilePath -> Idris () loadIBC fp = do imps <- getImported@@ -232,10 +236,13 @@ ibc i (IBCErrorHandler n) f = return f { ibc_errorhandlers = n : ibc_errorhandlers f } ibc i (IBCFunctionErrorHandler fn a n) f =   return f { ibc_function_errorhandlers = (fn, a, n) : ibc_function_errorhandlers f }-ibc i (IBCMetavar n) f = +ibc i (IBCMetavar n) f =      case lookup n (idris_metavars i) of           Nothing -> return f           Just t -> return f { ibc_metavars = (n, t) : ibc_metavars f }+ibc i (IBCPostulate n) f = return f { ibc_postulates = n : ibc_postulates f }+ibc i (IBCTotCheckErr fc err) f = return f { ibc_totcheckfail = (fc, err) : ibc_totcheckfail f }+ibc i (IBCParsedRegion fc) f = return f { ibc_parsedSpan = Just fc }  process :: IBCFile -> FilePath -> Idris () process i fn@@ -243,7 +250,7 @@                               ifail "Incorrect ibc version --- please rebuild"    | otherwise =             do srcok <- runIO $ doesFileExist (sourcefile i)-               when srcok $ runIO $ timestampOlder (sourcefile i) fn+               when srcok $ timestampOlder (sourcefile i) fn                v <- verbose                quiet <- getQuiet --                when (v && srcok && not quiet) $ iputStrLn $ "Skipping " ++ sourcefile i@@ -267,6 +274,7 @@                pPatdefs (ibc_patdefs i)                pAccess (ibc_access i)                pTotal (ibc_total i)+               pTotCheckErr (ibc_totcheckfail i)                pCG (ibc_cg i)                pDocs (ibc_docstrings i)                pCoercions (ibc_coercions i)@@ -278,20 +286,31 @@                pErrorHandlers (ibc_errorhandlers i)                pFunctionErrorHandlers (ibc_function_errorhandlers i)                pMetavars (ibc_metavars i)+               pPostulates (ibc_postulates i)+               pParsedSpan (ibc_parsedSpan i) -timestampOlder :: FilePath -> FilePath -> IO ()-timestampOlder src ibc = do srct <- getModificationTime src-                            ibct <- getModificationTime ibc+timestampOlder :: FilePath -> FilePath -> Idris ()+timestampOlder src ibc = do srct <- runIO $ getModificationTime src+                            ibct <- runIO $ getModificationTime ibc                             if (srct > ibct)-                               then fail "Needs reloading"+                               then ifail "Needs reloading"                                else return () +pPostulates :: [Name] -> Idris ()+pPostulates ns = do+    i <- getIState+    putIState i{ idris_postulates = idris_postulates i `S.union` S.fromList ns }++pParsedSpan :: Maybe FC -> Idris ()+pParsedSpan fc = do ist <- getIState+                    putIState ist { idris_parsedSpan = fc }+ pImports :: [FilePath] -> Idris () pImports fs   = do mapM_ (\f -> do i <- getIState                        ibcsd <- valIBCSubDir i                        ids <- allImportDirs-                       fp <- runIO $ findImport ids ibcsd f+                       fp <- findImport ids ibcsd f                        if (f `elem` imported i)                         then iLOG $ "Already read " ++ f                         else do putIState (i { imported = f : imported i })@@ -445,6 +464,10 @@                          putIState (i { tt_ctxt = setTotal n a (tt_ctxt i) }))                    ds +pTotCheckErr :: [(FC, String)] -> Idris ()+pTotCheckErr es = do ist <- getIState+                     putIState ist { idris_totcheckfail = idris_totcheckfail ist ++ es }+ pCG :: [(Name, CGInfo)] -> Idris () pCG ds = mapM_ (\ (n, a) -> addToCG n a) ds @@ -1093,10 +1116,6 @@             = error $ label ++ ": corrupted binary representation in IBC"         | otherwise = toEnum x -instance Binary Forceability where-    put = putWord8 . fromIntegral . fromEnum-    get = safeToEnum "Forceability" `fmap` getWord8- instance Binary PReason where         put x           = case x of@@ -1156,7 +1175,7 @@                      return (DataMI x1)  instance Binary IBCFile where-        put x@(IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35)+        put x@(IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38)          = {-# SCC "putIBCFile" #-}             do put x1                put x2@@ -1193,6 +1212,9 @@                put x33                put x34                put x35+               put x36+               put x37+               put x38          get           = do x1 <- get@@ -1231,7 +1253,10 @@                     x33 <- get                     x34 <- get                     x35 <- get-                    return (IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35)+                    x36 <- get+                    x37 <- get+                    x38 <- get+                    return (IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38)                   else return (initIBC { ver = x1 })  instance Binary DataOpt where@@ -1317,13 +1342,13 @@ instance Binary ArgOpt where         put x           = case x of-                Lazy -> putWord8 0-                HideDisplay -> putWord8 1+                HideDisplay -> putWord8 0+                InaccessibleArg -> putWord8 1         get           = do i <- getWord8                case i of-                   0 -> return Lazy-                   1 -> return HideDisplay+                   0 -> return HideDisplay+                   1 -> return InaccessibleArg                    _ -> error "Corrupted binary data for Static"  instance Binary Static where@@ -1418,7 +1443,7 @@                 PNamespace x1 x2 -> do putWord8 5                                        put x1                                        put x2-                PRecord x1 x2 x3 x4 x5 x6 x7 x8 ->+                PRecord x1 x2 x3 x4 x5 x6 x7 x8 x9 ->                                              do putWord8 6                                                 put x1                                                 put x2@@ -1428,7 +1453,8 @@                                                 put x6                                                 put x7                                                 put x8-                PClass x1 x2 x3 x4 x5 x6 x7+                                                put x9+                PClass x1 x2 x3 x4 x5 x6 x7 x8                                          -> do putWord8 7                                                put x1                                                put x2@@ -1437,6 +1463,7 @@                                                put x5                                                put x6                                                put x7+                                               put x8                 PInstance x1 x2 x3 x4 x5 x6 x7 x8 -> do putWord8 8                                                         put x1                                                         put x2@@ -1506,7 +1533,8 @@                            x6 <- get                            x7 <- get                            x8 <- get-                           return (PRecord x1 x2 x3 x4 x5 x6 x7 x8)+                           x9 <- get+                           return (PRecord x1 x2 x3 x4 x5 x6 x7 x8 x9)                    7 -> do x1 <- get                            x2 <- get                            x3 <- get@@ -1514,7 +1542,8 @@                            x5 <- get                            x6 <- get                            x7 <- get-                           return (PClass x1 x2 x3 x4 x5 x6 x7)+                           x8 <- get+                           return (PClass x1 x2 x3 x4 x5 x6 x7 x8)                    8 -> do x1 <- get                            x2 <- get                            x3 <- get@@ -1553,7 +1582,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@@ -1569,7 +1598,7 @@                x5 <- get                x6 <- get                x7 <- get-               return (Syn x1 x2 x3 x4 id x5 x6 x7)+               return (Syn x1 x2 x3 x4 id x5 x6 Nothing 0 x7)  instance (Binary t) => Binary (PClause' t) where         put x@@ -1932,6 +1961,13 @@                                    put x1                 ByReflection x1 -> do putWord8 20                                       put x1+                ProofSearch x1 x2 x3 x4 x5 -> do putWord8 21+                                                 put x1+                                                 put x2+                                                 put x3+                                                 put x4+                                                 put x5+                DoUnify -> putWord8 22         get           = do i <- getWord8                case i of@@ -1973,6 +2009,13 @@                             return (Induction x1)                    20 -> do x1 <- get                             return (ByReflection x1)+                   21 -> do x1 <- get+                            x2 <- get+                            x3 <- get+                            x4 <- get+                            x5 <- get+                            return (ProofSearch x1 x2 x3 x4 x5)+                   22 -> return DoUnify                    _ -> error "Corrupted binary data for PTactic'"  @@ -2037,16 +2080,18 @@                                        put x3                                        put x4                                        put x5-                PExp x1 x2 x3 ->+                PExp x1 x2 x3 x4 ->                                  do putWord8 1                                     put x1                                     put x2                                     put x3-                PConstraint x1 x2 x3 ->+                                    put x4+                PConstraint x1 x2 x3 x4 ->                                         do putWord8 2                                            put x1                                            put x2                                            put x3+                                           put x4                 PTacImplicit x1 x2 x3 x4 x5 ->                                                do putWord8 3                                                   put x1@@ -2066,11 +2111,13 @@                    1 -> do x1 <- get                            x2 <- get                            x3 <- get-                           return (PExp x1 x2 x3)+                           x4 <- get+                           return (PExp x1 x2 x3 x4)                    2 -> do x1 <- get                            x2 <- get                            x3 <- get-                           return (PConstraint x1 x2 x3)+                           x4 <- get+                           return (PConstraint x1 x2 x3 x4)                    3 -> do x1 <- get                            x2 <- get                            x3 <- get@@ -2096,28 +2143,26 @@                return (CI x1 x2 x3 x4 x5 [])  instance Binary OptInfo where-        put (Optimise x1 x2 x3 x4)+        put (Optimise x1 x2)           = do put x1                put x2-               put x3-               put x4         get           = do x1 <- get                x2 <- get-               x3 <- get-               x4 <- get-               return (Optimise x1 x2 x3 x4)+               return (Optimise x1 x2)  instance Binary TypeInfo where-        put (TI x1 x2 x3 x4) = do put x1-                                  put x2-                                  put x3-                                  put x4+        put (TI x1 x2 x3 x4 x5) = do put x1+                                     put x2+                                     put x3+                                     put x4+                                     put x5         get = do x1 <- get                  x2 <- get                  x3 <- get                  x4 <- get-                 return (TI x1 x2 x3 x4)+                 x5 <- get+                 return (TI x1 x2 x3 x4 x5)  instance Binary SynContext where         put x
src/Idris/IdeSlave.hs view
@@ -12,7 +12,7 @@  import Idris.Core.TT -import Control.Applicative+import Control.Applicative hiding (Const)  data SExp = SexpList [SExp]           | StringAtom String@@ -84,6 +84,22 @@ maybeProps ((n, Just p):ps) = (SymbolAtom n, toSExp p) : maybeProps ps maybeProps ((n, Nothing):ps) = maybeProps ps +constTy :: Const -> String+constTy (I _) = "Int"+constTy (BI _) = "Integer"+constTy (Fl _) = "Float"+constTy (Ch _) = "Char"+constTy (Str _) = "String"+constTy (B8 _) = "Bits8"+constTy (B16 _) = "Bits16"+constTy (B32 _) = "Bits32"+constTy (B64 _) = "Bits64"+constTy (B8V _) = "Bits8x16"+constTy (B16V _) = "Bits16x8"+constTy (B32V _) = "Bits32x4"+constTy (B64V _) = "Bits64x2"+constTy _ = "Type"+ instance SExpable OutputAnnotation where   toSExp (AnnName n ty d t) = toSExp $ [(SymbolAtom "name", StringAtom (show n)),                                         (SymbolAtom "implicit", BoolAtom False)] ++@@ -92,19 +108,32 @@   toSExp (AnnBoundName n imp)    = toSExp [(SymbolAtom "name", StringAtom (show n)),                                            (SymbolAtom "decor", SymbolAtom "bound"),                                            (SymbolAtom "implicit", BoolAtom imp)]-  toSExp AnnConstData            = toSExp [(SymbolAtom "decor", SymbolAtom "data")]-  toSExp AnnConstType            = toSExp [(SymbolAtom "decor", SymbolAtom "type")]+  toSExp (AnnConst c)            = toSExp [(SymbolAtom "decor",+                                            SymbolAtom (if constIsType c then "type" else "data")),+                                           (SymbolAtom "type", StringAtom (constTy c)),+                                           (SymbolAtom "doc-overview", StringAtom (constDocs c)),+                                           (SymbolAtom "name", StringAtom (show c))]+  toSExp (AnnData ty doc)        = toSExp [(SymbolAtom "decor", SymbolAtom "data"),+                                           (SymbolAtom "type", StringAtom ty),+                                           (SymbolAtom "doc-overview", StringAtom doc)]+  toSExp (AnnType name doc)      = toSExp $ [(SymbolAtom "decor", SymbolAtom "type"),+                                             (SymbolAtom "type", StringAtom "Type"),+                                             (SymbolAtom "doc-overview", StringAtom doc)] +++                                             if not (null name) then [(SymbolAtom "name", StringAtom name)] else []   toSExp AnnKeyword              = toSExp [(SymbolAtom "decor", SymbolAtom "keyword")]-  toSExp (AnnFC (FC f (sl, sc) (el, ec)))      = toSExp [(SymbolAtom "source-loc",-                                                    ((SymbolAtom "filename", StringAtom f),-                                                     (SymbolAtom "start",  IntegerAtom (toInteger sl), IntegerAtom (toInteger sc)),-                                                     (SymbolAtom "end", IntegerAtom (toInteger el), IntegerAtom (toInteger ec))))]+  toSExp (AnnFC fc)      = toSExp [(SymbolAtom "source-loc", toSExp fc)]   toSExp (AnnTextFmt fmt) = toSExp [(SymbolAtom "text-formatting", SymbolAtom format)]       where format = case fmt of                        BoldText      -> "bold"                        ItalicText    -> "italic"                        UnderlineText -> "underline" +instance SExpable FC where+  toSExp (FC f (sl, sc) (el, ec)) =+    toSExp ((SymbolAtom "filename", StringAtom f),+            (SymbolAtom "start",  IntegerAtom (toInteger sl), IntegerAtom (toInteger sc)),+            (SymbolAtom "end", IntegerAtom (toInteger el), IntegerAtom (toInteger ec)))+ escape :: String -> String escape = concatMap escapeChar   where@@ -145,35 +174,52 @@                      | AddProofClause Int String                      | AddMissing Int String                      | MakeWithBlock Int String-                     | ProofSearch Int String [String]-                     | LoadFile String+                     | ProofSearch Bool Int String [String] (Maybe Int) -- ^^ Recursive?, line, name, hints, depth+                     | MakeLemma Int String+                     | LoadFile String (Maybe Int)                      | DocsFor String                      | Apropos String                      | GetOpts                      | SetOpt Opt Bool-  deriving Show+                     | Metavariables Int -- ^^ the Int is the column count for pretty-printing+                     | WhoCalls String+                     | CallsWho String  sexpToCommand :: SExp -> Maybe IdeSlaveCommand sexpToCommand (SexpList (x:[]))                                                         = sexpToCommand x sexpToCommand (SexpList [SymbolAtom "interpret", StringAtom cmd])                       = Just (Interpret cmd) sexpToCommand (SexpList [SymbolAtom "repl-completions", StringAtom prefix])             = Just (REPLCompletions prefix)-sexpToCommand (SexpList [SymbolAtom "load-file", StringAtom filename])                  = Just (LoadFile filename)+sexpToCommand (SexpList [SymbolAtom "load-file", StringAtom filename, IntegerAtom line])                  = Just (LoadFile filename (Just (fromInteger line)))+sexpToCommand (SexpList [SymbolAtom "load-file", StringAtom filename])                  = Just (LoadFile filename Nothing) sexpToCommand (SexpList [SymbolAtom "type-of", StringAtom name])                        = Just (TypeOf name) sexpToCommand (SexpList [SymbolAtom "case-split", IntegerAtom line, StringAtom name])   = Just (CaseSplit (fromInteger line) name) sexpToCommand (SexpList [SymbolAtom "add-clause", IntegerAtom line, StringAtom name])   = Just (AddClause (fromInteger line) name) sexpToCommand (SexpList [SymbolAtom "add-proof-clause", IntegerAtom line, StringAtom name])   = Just (AddProofClause (fromInteger line) name) sexpToCommand (SexpList [SymbolAtom "add-missing", IntegerAtom line, StringAtom name])  = Just (AddMissing (fromInteger line) name) sexpToCommand (SexpList [SymbolAtom "make-with", IntegerAtom line, StringAtom name])    = Just (MakeWithBlock (fromInteger line) name)-sexpToCommand (SexpList [SymbolAtom "proof-search", IntegerAtom line, StringAtom name, SexpList hintexp]) | Just hints <- getHints hintexp = Just (ProofSearch (fromInteger line) name hints)-  where getHints = mapM (\h -> case h of-                                 StringAtom s -> Just s-                                 _            -> Nothing)+-- The Boolean in ProofSearch means "search recursively"+-- If it's False, that means "refine", i.e. apply the name and fill in any+-- arguments which can be done by unification.+sexpToCommand (SexpList (SymbolAtom "proof-search" : IntegerAtom line : StringAtom name : rest))+  | [] <- rest = Just (ProofSearch True (fromInteger line) name [] Nothing)+  | [SexpList hintexp] <- rest+  ,  Just hints <- getHints hintexp = Just (ProofSearch True (fromInteger line) name hints Nothing)+  | [SexpList hintexp, IntegerAtom depth] <- rest+ , Just hints <- getHints hintexp = Just (ProofSearch True (fromInteger line) name hints (Just (fromInteger depth)))+ where getHints = mapM (\h -> case h of+                                StringAtom s -> Just s+                                _            -> Nothing)+sexpToCommand (SexpList [SymbolAtom "make-lemma", IntegerAtom line, StringAtom name])   = Just (MakeLemma (fromInteger line) name)+sexpToCommand (SexpList [SymbolAtom "refine", IntegerAtom line, StringAtom name, StringAtom hint]) = Just (ProofSearch False (fromInteger line) name [hint] Nothing) sexpToCommand (SexpList [SymbolAtom "docs-for", StringAtom name])                       = Just (DocsFor name) sexpToCommand (SexpList [SymbolAtom "apropos", StringAtom search])                      = Just (Apropos search) sexpToCommand (SymbolAtom "get-options")                                                = Just GetOpts sexpToCommand (SexpList [SymbolAtom "set-option", SymbolAtom s, BoolAtom b])   | Just opt <- lookup s opts                                                           = Just (SetOpt opt b)     where opts = [("show-implicits", ShowImpl), ("error-context", ErrContext)] --TODO support more+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 _                                                                         = Nothing  parseMessage :: String -> Either Err (SExp, Integer)
+ src/Idris/IdrisDoc.hs view
@@ -0,0 +1,661 @@+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Generation of HTML documentation for Idris code+module Idris.IdrisDoc (generateDocs) where++import Idris.Core.TT (Name (..), sUN, SpecialName (..), OutputAnnotation (..),+                      TextFormatting (..), txt, str, nsroot, constIsType)+import Idris.Core.Evaluate (ctxtAlist, Def (..), lookupDefAcc,+                            Accessibility (..), isDConName, isFnName,+                            isTConName)+import Idris.ParseHelpers (opChars)+import Idris.AbsSyntax+import Idris.Docs+import Idris.Docstrings (nullDocstring)++import Paths_idris (getDataFileName)++import Control.Monad (forM_)+import Control.Monad.Trans.Error+import Control.Monad.Trans.State.Strict++import Data.Maybe++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BS2+import qualified Data.Text.Encoding as E+import qualified Data.List as L+import qualified Data.List.Split as LS+import qualified Data.Map as M hiding ((!))+import qualified Data.Ord (compare)+import qualified Data.Set as S+import qualified Data.Text as T++import System.IO+import System.IO.Error+import System.FilePath+import System.Directory++import Cheapskate.Html (renderDoc)+import Text.PrettyPrint.Annotated.Leijen (displayDecorated, renderCompact)++import Text.Blaze (toValue, contents)+import Text.Blaze.Internal (MarkupM (Empty))+import Text.Blaze.Html5 ((!), toHtml, preEscapedToHtml)+import qualified Text.Blaze.Html5 as H+import Text.Blaze.Html5.Attributes as A+import Text.Blaze.Html.Renderer.Utf8 (renderHtml)+import qualified Text.Blaze.Html.Renderer.String as R+import Text.Blaze.Renderer.String (renderMarkup)++-- ---------------------------------------------------------------- [ Public ]++-- | Generates HTML documentation for a series of loaded namespaces+--   and their dependencies.+generateDocs :: IState   -- ^ IState where all necessary information is+                         --   extracted from.+             -> [Name]   -- ^ List of namespaces to generate+                         --   documentation for.+             -> FilePath -- ^ The directory to which documentation will+                         --   be written.+             -> IO (Either String ())+generateDocs ist nss' out =+  do let nss     = map toNsName nss'+     docs       <- fetchInfo ist nss+     let (c, io) = foldl (checker docs) (0, return ()) nss+     io+     if c < length nss+        then catchIOError (createDocs ist docs out) (err . show)+        else err "No namespaces to generate documentation for"++  where checker docs st ns | M.member ns docs = st+        checker docs (c, io) ns = (c+1, do prev <- io; warnMissing ns)+        warnMissing ns =+          putStrLn $ "Warning: Ignoring empty or non-existing namespace '" +++                     (nsName2Str ns) ++ "'"++-- ----------------------------------------------------------------- [ Types ]++-- | Either an error message or a result+type Failable = Either String++-- | Internal representation of a fully qualified namespace name+type NsName   = [T.Text]++-- | All information to be documented about a single namespace member+type NsItem   = (Name, Maybe Docs, Accessibility)++-- | All information to be documented about a namespace+type NsInfo   = [NsItem]++-- | A map from namespace names to information about them+type NsDict   = M.Map NsName NsInfo++-- --------------------------------------------------------------- [ Utility ]++-- | Make an error message+err :: String -> IO (Failable ())+err s = return $ Left s++-- | IdrisDoc version+version :: String+version = "1.0"++-- | Converts a Name into a [Text] corresponding to the namespace+--   part of a NS Name.+toNsName :: Name -- ^ Name to convert+         -> NsName+toNsName (UN n)    = [n]+toNsName (NS n ns) = (toNsName n) ++ ns+toNsName _         = []+++-- | Retrieves the namespace part of a Name+getNs :: Name -- ^ Name to retrieve namespace for+      -> NsName+getNs (NS _ ns) = ns+getNs _         = []+++-- | String to replace for the root namespace+rootNsStr :: String+rootNsStr = "[builtins]"+++-- | Converts a NsName to string form+nsName2Str :: NsName -- ^ NsName to convert+           -> String+nsName2Str n = if null n then rootNsStr else name n++  where name []       = []+        name [ns]     = str ns+        name (ns:nss) = (name nss) ++ ('.' : str ns)++-- --------------------------------------------------------- [ Info Fetching ]++-- | Fetch info about namespaces and their contents+fetchInfo :: IState    -- ^ IState to fetch info from+          -> [NsName]  -- ^ List of namespaces to fetch info for+          -> IO NsDict -- ^ Mapping from namespace name to+                       --   info about its contents+fetchInfo ist nss =+  do let originNss  = S.fromList nss+     info          <- nsDict ist+     let info'      = M.map (filter filterInclude) info+         info''     = M.map removeOrphans info'+         info'''    = M.filter (not . null) info''+         reachedNss = traceNss info''' originNss S.empty+     return $ M.filterWithKey (\k _ -> S.member k reachedNss) info'''+++-- | Removes loose class methods and data constructors,+--   leaving them documented only under their parent.+removeOrphans :: [NsItem] -- ^ List to remove orphans from+              -> [NsItem] -- ^ Orphan-free list+removeOrphans list =+  let children = S.fromList $ concatMap (names . (\(_, d, _) -> d)) list+  in  filter ((`S.notMember` children) . (\(n, _, _) -> n)) list++  where names (Just (DataDoc _ fds))          = map (\(FD n _ _ _ _) -> n) fds+        names (Just (ClassDoc _ _ fds _ _ _)) = map (\(FD n _ _ _ _) -> n) fds+        names _                               = []++-- | Whether a Name names something which should be documented+filterName :: Name -- ^ Name to check+           -> Bool -- ^ Predicate result+filterName (UN n)     | '@':'@':_ <- str n = False+filterName (UN _)     = True+filterName (NS n _)   = filterName n+filterName _          = False+++-- | Whether a NsItem should be included in the documentation.+--   It must not be Hidden and filterName must return True for the name.+--   Also it must have Docs -- without Docs, nothing can be done.+filterInclude :: NsItem -- ^ Accessibility to check+              -> Bool   -- ^ Predicate result+filterInclude (name, Just _, Public) | filterName name = True+filterInclude (name, Just _, Frozen) | filterName name = True+filterInclude _                                        = False+++-- | Finds all namespaces indirectly referred by a set of namespaces.+--   The NsItems of the namespaces are searched for references.+traceNss :: NsDict       -- ^ Mappings of namespaces and their contents+         -> S.Set NsName -- ^ Set of namespaces to trace+         -> S.Set NsName -- ^ Set of namespaces which has been traced+         -> S.Set NsName -- ^ Set of namespaces to trace and all traced one+traceNss nsd sT sD =+  let nsTracer ns | Just nsis <- M.lookup ns nsd = map referredNss nsis+      nsTracer _                                 = [S.empty] -- Ignore+      reached     = S.unions $ concatMap nsTracer (S.toList sT)+      processed   = S.union sT sD+      untraced    = S.difference reached processed+  in  if S.null untraced then processed+      else traceNss nsd untraced processed+++-- | Gets all namespaces directly referred by a NsItem+referredNss :: NsItem -- ^ The name to get all directly+                      --   referred namespaces for+            -> S.Set NsName+referredNss (_, Nothing, _) = S.empty+referredNss (n, Just d, _) =+  let fds    = getFunDocs d+      ts     = concatMap types fds+      names  = concatMap (extractPTermNames) ts+  in  S.map getNs $ S.fromList names++  where getFunDocs (FunDoc f)              = [f]+        getFunDocs (DataDoc f fs)          = f:fs+        getFunDocs (ClassDoc _ _ fs _ _ _) = fs+        types (FD _ _ args t _)            = t:(map second args)+        second (_, x, _, _)                = x+++-- | Returns an NsDict of containing all known namespaces and their contents+nsDict :: IState+       -> IO NsDict+nsDict ist =+  let nameDefList    = ctxtAlist $ tt_ctxt ist+      adder m (n, _) = do map    <- m+                          doc    <- loadDocs ist n+                          let acc = getAccess ist n+                              c   = [(n, doc, acc)]+                          return $ M.insertWith (++) (getNs n) c map+  in  foldl adder (return M.empty) nameDefList+++-- | Gets the Accessibility for a Name+getAccess :: IState        -- ^ IState containing accessibility information+          -> Name          -- ^ The Name to retrieve access for+          -> Accessibility+getAccess ist n =+  let res = lookupDefAcc n False (tt_ctxt ist)+  in case res of+     [(_, acc)] -> acc+     _          -> Hidden++-- | Simple predicate for whether an NsItem has Docs+hasDoc :: NsItem -- ^ The NsItem to test+       -> Bool   -- ^ The result+hasDoc (_, Just _, _) = True+hasDoc _              = False+++-- | Predicate saying whether a Name possibly may have docs defined+--   Without this, getDocs from Idris.Docs may fail a pattern match.+mayHaveDocs :: Name -- ^ The Name to test+            -> Bool -- ^ The result+mayHaveDocs (UN _)   = True+mayHaveDocs (NS n _) = mayHaveDocs n+mayHaveDocs _        = False+++-- | Retrieves the Docs for a Name+loadDocs :: IState     -- ^ IState to extract infomation from+         -> Name       -- ^ Name to load Docs for+         -> IO (Maybe Docs)+loadDocs ist n+  | mayHaveDocs n = do docs <- runErrorT $ evalStateT (getDocs n) ist+                       case docs of Right d -> return (Just d)+                                    Left _  -> return Nothing+  | otherwise     = return Nothing+++-- | Extracts names referred from a type.+--   The covering of all PTerms ensures that we avoid unanticipated cases,+--   though all of them are not needed. The author just did not know which!+--   TODO: Remove unnecessary cases+extractPTermNames :: PTerm  -- ^ Where to extract names from+                  -> [Name] -- ^ Extracted names+extractPTermNames (PRef _ n)         = [n]+extractPTermNames (PInferRef _ n)    = [n]+extractPTermNames (PPatvar _ n)      = [n]+extractPTermNames (PLam n p1 p2)     = n : concatMap extract [p1, p2]+extractPTermNames (PPi _ n p1 p2)    = n : concatMap extract [p1, p2]+extractPTermNames (PLet n p1 p2 p3)  = n : concatMap extract [p1, p2, p3]+extractPTermNames (PTyped p1 p2)     = concatMap extract [p1, p2]+extractPTermNames (PApp _ p pas)     = let names = concatMap extractPArg pas+                                       in  (extract p) ++ names+extractPTermNames (PAppBind _ p pas) = let names = concatMap extractPArg pas+                                       in  (extract p) ++ names+extractPTermNames (PMatchApp _ n)    = [n]+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 (PRewrite _ a b m) | Just c <- m =+                                       concatMap extract [a, b, c]+extractPTermNames (PRewrite _ a b _) = concatMap extract [a, b]+extractPTermNames (PPair _ _ p1 p2)  = concatMap extract [p1, p2]+extractPTermNames (PDPair _ _ a b c) = concatMap extract [a, b, c]+extractPTermNames (PAlternative _ l) = concatMap extract l+extractPTermNames (PHidden p)        = extract p+extractPTermNames (PGoal _ p1 n p2)  = n : concatMap extract [p1, p2]+extractPTermNames (PDoBlock pdos)    = concatMap extractPDo pdos+extractPTermNames (PIdiom _ p)       = extract p+extractPTermNames (PMetavar n)       = [n]+extractPTermNames (PProof tacts)     = concatMap extractPTactic tacts+extractPTermNames (PTactics tacts)   = concatMap extractPTactic tacts+extractPTermNames (PCoerced p)       = extract p+extractPTermNames (PDisamb _ p)      = extract p+extractPTermNames (PUnifyLog p)      = extract p+extractPTermNames (PNoImplicits p)   = extract p+extractPTermNames _                  = []++-- | Shorter name for extractPTermNames+extract :: PTerm  -- ^ Where to extract names from+        -> [Name] -- ^ Extracted names+extract                               = extractPTermNames++-- | Helper function for extractPTermNames+extractPArg :: PArg -> [Name]+extractPArg (PImp {pname=n, getTm=p}) = n : extract p+extractPArg (PExp {getTm=p})          = extract p+extractPArg (PConstraint {getTm=p})   = extract p+extractPArg (PTacImplicit {pname=n, getScript=p1, getTm=p2})+                                      = n : (concatMap extract [p1, p2])++-- | Helper function for extractPTermNames+extractPDo :: PDo -> [Name]+extractPDo (DoExp   _ p)        = extract p+extractPDo (DoBind  _ n p)      = n : extract p+extractPDo (DoBindP _ p1 p2 ps) = let (ps1, ps2) = unzip ps+                                      ps'        = ps1 ++ ps2+                                  in  concatMap extract (p1 : p2 : ps')+extractPDo (DoLet   _ n p1 p2)  = n : concatMap extract [p1, p2]+extractPDo (DoLetP  _ p1 p2)    = concatMap extract [p1, p2]++-- | Helper function for extractPTermNames+extractPTactic :: PTactic -> [Name]+extractPTactic (Intro ns)         = ns+extractPTactic (Focus n)          = [n]+extractPTactic (Refine n _)       = [n]+extractPTactic (Rewrite p)        = extract p+extractPTactic (Induction n)      = [n]+extractPTactic (Equiv p)          = extract p+extractPTactic (MatchRefine n)    = [n]+extractPTactic (LetTac n p)       = n : extract p+extractPTactic (LetTacTy n p1 p2) = n : concatMap extract [p1, p2]+extractPTactic (Exact p)          = extract p+extractPTactic (ProofSearch _ _ _ m ns) | Just n <- m = n : ns+extractPTactic (ProofSearch _ _ _ _ ns) = ns+extractPTactic (Try t1 t2)        = concatMap extractPTactic [t1, t2]+extractPTactic (TSeq t1 t2)       = concatMap extractPTactic [t1, t2]+extractPTactic (ApplyTactic p)    = extract p+extractPTactic (ByReflection p)   = extract p+extractPTactic (Reflect p)        = extract p+extractPTactic (Fill p)           = extract p+extractPTactic (GoalType _ t)     = extractPTactic t+extractPTactic (TCheck p)         = extract p+extractPTactic (TEval p)          = extract p+extractPTactic _                  = []++-- ------------------------------------------------------- [ HTML Generation ]++-- | Generates the actual HTML output based on info from a NsDict+--   A merge of the new docs and any existing docs located in the output dir+--   is attempted.+--   TODO: Ensure the merge always succeeds.+--         Currently the content of 'docs/<builtins>.html' may change between+--         runs, thus not always containing all items referred from other+--         namespace .html files.+createDocs :: IState -- ^ Needed to determine the types of names+           -> NsDict   -- ^ All info from which to generate docs+           -> FilePath -- ^ The base directory to which+                       --   documentation will be written.+           -> IO (Failable ())+createDocs ist nsd out =+  do new                <- not `fmap` (doesFileExist $ out </> "IdrisDoc")+     existing_nss       <- existingNamespaces out+     let nss             = S.union (M.keysSet nsd) existing_nss+     dExists            <- doesDirectoryExist out+     if new && dExists then err $ "Output directory (" ++ out ++ ") is" +++                                  " already in use for other than IdrisDoc."+       else do+         createDirectoryIfMissing True out+         foldl docGen (return ()) (M.toList nsd)+         createIndex nss out+         -- Create an empty IdrisDoc file to signal 'out' is used for IdrisDoc+         if new -- But only if it not already existed...+            then withFile (out </> "IdrisDoc") WriteMode ((flip hPutStr) "")+            else return ()+         copyDependencies out+         return $ Right ()++  where docGen io (n, c) = do io; createNsDoc ist n c out+++-- | (Over)writes the 'index.html' file in the given directory with+--   an (updated) index of namespaces in the documentation+createIndex :: S.Set NsName -- ^ Set of namespace names to+                            --   include in the index+            -> FilePath     -- ^ The base directory to which+                            --   documentation will be written.+            -> IO ()+createIndex nss out =+  do (path, h) <- openTempFile out "index.html"+     BS2.hPut h $ renderHtml $ wrapper Nothing $ do+       H.h1 $ "Namespaces"+       H.ul ! class_ "names" $ do+         let path ns  = "docs" </> genRelNsPath ns "html" +             item ns  = do let n    = toHtml $ nsName2Str ns+                               link = toValue $ path ns+                           H.li $ H.a ! href link ! class_ "code" $ n+             sort     = L.sortBy (\n1 n2 -> reverse n1 `compare` reverse n2)+         forM_ (sort $ S.toList nss) item+     hClose h+     renameFile path (out </> "index.html")+++-- | Generates a HTML file for a namespace and its contents.+--   The location for e.g. Prelude.Algebra is <base>/Prelude/Algebra.html+createNsDoc :: IState   -- ^ Needed to determine the types of names+            -> NsName   -- ^ The name of the namespace to+                        --   create documentation for+            -> NsInfo   -- ^ The contents of the namespace+            -> FilePath -- ^ The base directory to which+                        --   documentation will be written.+            -> IO ()+createNsDoc ist ns content out =+  do let tpath                   = out </> "docs" </> (genRelNsPath ns "html")+         dir                     = takeDirectory tpath+         file                    = takeFileName tpath +         haveDocs (_, Just d, _) = [d]+         haveDocs _              = []+                                 -- We cannot do anything without a Doc+         content'                = concatMap haveDocs content+     createDirectoryIfMissing True dir+     (path, h) <- openTempFile dir file+     BS2.hPut h $ renderHtml $ wrapper (Just ns) $ do+       H.h1 $ toHtml (nsName2Str ns)+       H.dl ! class_ "decls" $ forM_ content' (createOtherDoc ist)+     hClose h+     renameFile path tpath+++-- | Generates a relative filepath for a namespace, appending an extension+genRelNsPath :: NsName   -- ^ Namespace to generate a path for+             -> String   -- ^ Extension suffix+             -> FilePath+genRelNsPath ns suffix = nsName2Str ns <.> suffix+++-- | Generates a HTML type signature with proper tags+--   TODO: Turn docstrings into title attributes more robustly+genTypeHeader :: IState -- ^ Needed to determine the types of names+              -> FunDoc -- ^ Type to generate type declaration for+              -> H.Html -- ^ Resulting HTML+genTypeHeader ist (FD n _ args ftype _) = do+  H.span ! class_ (toValue $ "name " ++ getType n)+         ! title  (toValue $ show n)+         $ toHtml $ name $ nsroot n+  H.span ! class_ "word"     $ do nbsp; ":"; nbsp+  H.span ! class_ "signature" $ preEscapedToHtml htmlSignature++  where+        htmlSignature  = displayDecorated decorator $ renderCompact signature+        signature      = pprintPTerm defaultPPOption [] names (idris_infixes ist) ftype+        names          = [ n | (n@(UN n'), _, _, _) <- args,+                           not (T.isPrefixOf (txt "__") n') ]++        decorator (AnnConst c) str | constIsType c = htmlSpan str "type" str+                                   | otherwise     = htmlSpan str "data" str+        decorator (AnnData _ _) str = htmlSpan str "data"    str+        decorator (AnnType _ _)   str = htmlSpan str "type"    str+        decorator AnnKeyword    str = htmlSpan ""  "keyword" str+        decorator (AnnBoundName n i) str | Just t <- M.lookup n docs =+          let cs = (if i then "implicit " else "") ++ "documented boundvar"+          in  htmlSpan t cs str+        decorator (AnnBoundName _ i) str =+          let cs = (if i then "implicit " else "") ++ "boundvar"+          in  htmlSpan "" cs str+        decorator (AnnName n _ _ _) str+          | filterName n = htmlLink (show n) (getType n) (link n) str+          | otherwise    = htmlSpan ""       (getType n)          str+        decorator (AnnTextFmt BoldText)      str = "<b>" ++ str ++ "</b>"+        decorator (AnnTextFmt UnderlineText) str = "<u>" ++ str ++ "</u>"+        decorator (AnnTextFmt ItalicText)    str = "<i>" ++ str ++ "</i>"+        decorator _ str = str++        htmlSpan :: String -> String -> String -> String+        htmlSpan t cs str = do+          R.renderHtml $ H.span ! class_ (toValue cs)+                                ! title (toValue t)+                                $ toHtml str+        htmlLink :: String -> String -> String -> String -> String+        htmlLink t cs a str = do+          R.renderHtml $ H.a ! class_ (toValue cs)+                       ! title (toValue t) ! href (toValue a)+                       $ toHtml str++        docs           = M.fromList $ mapMaybe docExtractor args+        docExtractor (_, _, _, Nothing) = Nothing+        docExtractor (n, _, _, Just d)  = Just (n, doc2Str d)+                         -- TODO: Remove <p> tags more robustly+        doc2Str d      = let dirty = renderMarkup $ contents $ renderDoc $ d+                         in  take (length dirty - 8) $ drop 3 dirty++        name (NS n ns) = show (NS (sUN $ name n) ns)+        name n         = let n' = show n+                         in  if (head n') `elem` opChars+                                then '(':(n' ++ ")")+                                else n'++        link n         = let path = genRelNsPath (getNs n) "html"+                         in  path ++ "#" ++ (show n)++        getType :: Name -> String+        getType n      = let ctxt = tt_ctxt ist+                         in  case () of+                               _ | isDConName n ctxt -> "constructor"+                               _ | isFnName   n ctxt -> "function"+                               _ | isTConName n ctxt -> "type"+                               _ | otherwise         -> ""++-- | Generates HTML documentation for a function.+createFunDoc :: IState -- ^ Needed to determine the types of names+             -> FunDoc -- ^ Function to generate block for+             -> H.Html -- ^ Resulting HTML+createFunDoc ist fd@(FD name docstring args ftype fixity) = do+  H.dt ! (A.id $ toValue $ show name) $ genTypeHeader ist fd+  H.dd $ do+    (if nullDocstring docstring then Empty else renderDoc docstring)+    let args'             = filter (\(_, _, _, d) -> isJust d) args+    if (not $ null args') || (isJust fixity)+       then H.dl $ do+         if (isJust fixity) then do+             H.dt ! class_ "fixity" $ "Fixity"+             let f = fromJust fixity+             H.dd ! class_ "fixity" ! title (toValue $ show f) $ genFix f+           else Empty+         forM_ args' genArg+       else Empty++  where genFix (Infixl {prec=p})  =+          toHtml $ "Left associative, precedence " ++ show p+        genFix (Infixr {prec=p})  =+          toHtml $ "Left associative, precedence " ++ show p+        genFix (InfixN {prec=p})  =+          toHtml $ "Non-associative, precedence " ++ show p+        genFix (PrefixN {prec=p}) =+          toHtml $ "Prefix, precedence " ++ show p+        genArg (_, _, _, Nothing)           = Empty+        genArg (name, _, _, Just docstring) = do+          H.dt $ toHtml $ show name+          H.dd $ renderDoc docstring+++-- | Generates HTML documentation for any Docs type+--   TODO: Generate actual signatures for typeclasses+createOtherDoc :: IState -- ^ Needed to determine the types of names+               -> Docs   -- ^ Namespace item to generate HTML block for+               -> H.Html -- ^ Resulting HTML+createOtherDoc ist (FunDoc fd)                = createFunDoc ist fd++createOtherDoc ist (ClassDoc n docstring fds _ _ _) = do+  H.dt ! (A.id $ toValue $ show n) $ do+    H.span ! class_ "word" $ do "class"; nbsp+    H.span ! class_ "name type"+           ! title  (toValue $ show n)+           $ toHtml $ name $ nsroot n+    H.span ! class_ "signature" $ nbsp+  H.dd $ do+    (if nullDocstring docstring then Empty else renderDoc docstring)+    H.dl ! class_ "decls" $ forM_ fds (createFunDoc ist)++  where name (NS n ns) = show (NS (sUN $ name n) ns)+        name n         = let n' = show n+                         in  if (head n') `elem` opChars+                                then '(':(n' ++ ")")+                                else n'++createOtherDoc ist (DataDoc fd@(FD n docstring args _ _) fds) = do+  H.dt ! (A.id $ toValue $ show n) $ do+    H.span ! class_ "word" $ do "data"; nbsp+    genTypeHeader ist fd+  H.dd $ do+    (if nullDocstring docstring then Empty else renderDoc docstring)+    let args' = filter (\(_, _, _, d) -> isJust d) args+    if not $ null args'+       then H.dl $ forM_ args' genArg+       else Empty+    H.dl ! class_ "decls" $ forM_ fds (createFunDoc ist)++  where genArg (_, _, _, Nothing)           = Empty+        genArg (name, _, _, Just docstring) = do+          H.dt $ toHtml $ show name+          H.dd $ renderDoc docstring+++-- | Generates everything but the actual content of the page+wrapper :: Maybe NsName -- ^ Namespace name, unless it is the index+        -> H.Html         -- ^ Inner HTML+        -> H.Html+wrapper ns inner =+  let (index, str) = extract ns+      base       = if index then "" else "../"+      styles     = base ++ "styles.css" :: String+      indexPage  = base ++ "index.html" :: String+  in  H.docTypeHtml $ do+    H.head $ do+      H.title $ do+        "IdrisDoc"+        if index then " Index" else do+          ": "+          toHtml str+      H.link ! type_ "text/css" ! rel "stylesheet"+             ! href (toValue styles)+    H.body ! class_ (if index then "index" else "namespace") $ do+      H.div ! class_ "wrapper" $ do+        H.header $ do+          H.strong "IdrisDoc"+          if index then Empty else do+            ": "+            toHtml str+          H.nav $ H.a ! href (toValue indexPage) $ "Index"+        H.div ! class_ "container" $ inner+      H.footer $ do+        "Produced by IdrisDoc version "+        toHtml version++  where extract (Just ns) = (False, nsName2Str ns)+        extract _         = (True,  "")+++-- | Non-break space character+nbsp :: H.Html+nbsp = preEscapedToHtml ("&nbsp;" :: String)+++-- | Returns a list of namespaces already documented in a IdrisDoc directory+existingNamespaces :: FilePath -- ^ The base directory containing the+                               --   'docs' directory with existing+                               --   namespace pages+                   -> IO (S.Set NsName)+existingNamespaces out = do+  let docs     = out </> "docs"+      str2Ns s | s == rootNsStr = []+      str2Ns s = reverse $ T.splitOn (T.singleton '.') (txt s)+      toNs  fp = do isFile    <- doesFileExist $ docs </> fp+                    let isHtml = ".html" == takeExtension fp+                        name   = dropExtension fp+                        ns     = str2Ns name+                    return $ if isFile && isHtml then Just ns else Nothing+  docsExists  <- doesDirectoryExist docs+  if not docsExists+     then    return S.empty+     else do contents    <- getDirectoryContents docs+             namespaces  <- catMaybes `fmap` (sequence $ map toNs contents)+             return $ S.fromList namespaces+++-- | Copies IdrisDoc dependencies such as stylesheets to a directory+copyDependencies :: FilePath -- ^ The base directory to which+                             --   dependencies should be written+                 -> IO ()+copyDependencies dir =+  do styles <- getDataFileName $ "idrisdoc" </> "styles.css"+     copyFile styles (dir </> "styles.css")
src/Idris/Imports.hs view
@@ -1,6 +1,7 @@ module Idris.Imports where  import Idris.AbsSyntax+import Idris.Error  import Idris.Core.TT import Paths_idris@@ -43,15 +44,15 @@ ibcPathNoFallback :: FilePath -> FilePath -> FilePath ibcPathNoFallback ibcsd fp = ibcPath ibcsd True fp -findImport :: [FilePath] -> FilePath -> FilePath -> IO IFileType-findImport []     ibcsd fp = fail $ "Can't find import " ++ fp+findImport :: [FilePath] -> FilePath -> FilePath -> Idris IFileType+findImport []     ibcsd fp = ierror . Msg $ "Can't find import " ++ fp findImport (d:ds) ibcsd fp = do let fp_full = d </> fp-                                ibcp <- ibcPathWithFallback ibcsd fp_full+                                ibcp <- runIO $ ibcPathWithFallback ibcsd fp_full                                 let idrp = srcPath fp_full                                 let lidrp = lsrcPath fp_full-                                ibc <- doesFileExist ibcp-                                idr  <- doesFileExist idrp-                                lidr <- doesFileExist lidrp+                                ibc <- runIO $ doesFileExist ibcp+                                idr  <- runIO $ doesFileExist idrp+                                lidr <- runIO $ doesFileExist lidrp --                              when idr $ putStrLn $ idrp ++ " ok" --                              when lidr $ putStrLn $ lidrp ++ " ok" --                              when ibc $ putStrLn $ ibcp ++ " ok"
+ src/Idris/Interactive.hs view
@@ -0,0 +1,341 @@+{-# LANGUAGE PatternGuards #-}++module Idris.Interactive(caseSplitAt, addClauseFrom, addProofClauseFrom,+                         addMissing, makeWith, doProofSearch,+                         makeLemma) where++{- Bits and pieces for editing source files interactively, called from+   the REPL -}++import Idris.Core.TT+import Idris.Core.Evaluate+import Idris.CaseSplit+import Idris.AbsSyntax+import Idris.ElabDecls+import Idris.Error+import Idris.Delaborate+import Idris.Output+import Idris.IdeSlave hiding (IdeSlaveCommand(..))++import Util.Pretty+import Util.System++import System.FilePath+import System.Directory+import System.IO+import Data.Char+import Data.Maybe (fromMaybe)+++caseSplitAt :: Handle -> FilePath -> Bool -> Int -> Name -> Idris ()+caseSplitAt h fn updatefile l n+   = do src <- runIO $ readFile fn+        res <- splitOnLine l n fn+        iLOG (showSep "\n" (map show res))+        let (before, (ap : later)) = splitAt (l-1) (lines src)+        res' <- replaceSplits ap res+        let new = concat res'+        if updatefile+          then do let fb = fn ++ "~" -- make a backup!+                  runIO $ writeFile fb (unlines before ++ new ++ unlines later)+                  runIO $ copyFile fb fn+          else -- do ihputStrLn h (show res)+            ihPrintResult h new++addClauseFrom :: Handle -> FilePath -> Bool -> Int -> Name -> Idris ()+addClauseFrom h fn updatefile l n+   = do src <- runIO $ readFile fn+        let (before, tyline : later) = splitAt (l-1) (lines src)+        let indent = getIndent 0 (show n) tyline+        cl <- getClause l n fn+        -- add clause before first blank line in 'later'+        let (nonblank, rest) = span (not . all isSpace) (tyline:later)+        if updatefile+          then do let fb = fn ++ "~"+                  runIO $ writeFile fb (unlines (before ++ nonblank) +++                                        replicate indent ' ' +++                                        cl ++ "\n" +++                                        unlines rest)+                  runIO $ copyFile fb fn+          else ihPrintResult h cl+    where+       getIndent i n [] = 0+       getIndent i n xs | take 9 xs == "instance " = i+       getIndent i n xs | take (length n) xs == n = i+       getIndent i n (x : xs) = getIndent (i + 1) n xs++addProofClauseFrom :: Handle -> FilePath -> Bool -> Int -> Name -> Idris ()+addProofClauseFrom h fn updatefile l n+   = do src <- runIO $ readFile fn+        let (before, tyline : later) = splitAt (l-1) (lines src)+        let indent = getIndent 0 (show n) tyline+        cl <- getProofClause l n fn+        -- add clause before first blank line in 'later'+        let (nonblank, rest) = span (not . all isSpace) (tyline:later)+        if updatefile+          then do let fb = fn ++ "~"+                  runIO $ writeFile fb (unlines (before ++ nonblank) +++                                        replicate indent ' ' +++                                        cl ++ "\n" +++                                        unlines rest)+                  runIO $ copyFile fb fn+          else ihPrintResult h cl+    where+       getIndent i n [] = 0+       getIndent i n xs | take (length n) xs == n = i+       getIndent i n (x : xs) = getIndent (i + 1) n xs++addMissing :: Handle -> FilePath -> Bool -> Int -> Name -> Idris ()+addMissing h fn updatefile l n+   = do src <- runIO $ readFile fn+        let (before, tyline : later) = splitAt (l-1) (lines src)+        let indent = getIndent 0 (show n) tyline+        i <- getIState+        cl <- getInternalApp fn l+        let n' = getAppName cl++        extras <- case lookupCtxt n' (idris_patdefs i) of+                       [] -> return ""+                       [(_, tms)] -> do tms' <- nameMissing tms+                                        showNew (show n ++ "_rhs") 1 indent tms'+        let (nonblank, rest) = span (not . all isSpace) (tyline:later)+        if updatefile+          then do let fb = fn ++ "~"+                  runIO $ writeFile fb (unlines (before ++ nonblank)+                                        ++ extras ++ unlines rest)+                  runIO $ copyFile fb fn+          else ihPrintResult h extras+    where showPat = show . stripNS+          stripNS tm = mapPT dens tm where+              dens (PRef fc n) = PRef fc (nsroot n)+              dens t = t++          nsroot (NS n _) = nsroot n+          nsroot (SN (WhereN _ _ n)) = nsroot n+          nsroot n = n++          getAppName (PApp _ r _) = getAppName r+          getAppName (PRef _ r) = r+          getAppName _ = n++          showNew nm i ind (tm : tms)+                        = do (nm', i') <- getUniq nm i+                             rest <- showNew nm i' ind tms+                             return (replicate ind ' ' +++                                     showPat tm ++ " = ?" ++ nm' +++                                     "\n" ++ rest)+          showNew nm i _ [] = return ""++          getIndent i n [] = 0+          getIndent i n xs | take (length n) xs == n = i+          getIndent i n (x : xs) = getIndent (i + 1) n xs+++makeWith :: Handle -> FilePath -> Bool -> Int -> Name -> Idris ()+makeWith h fn updatefile l n+   = do src <- runIO $ readFile fn+        let (before, tyline : later) = splitAt (l-1) (lines src)+        let ind = getIndent tyline+        let with = mkWith tyline n+        -- add clause before first blank line in 'later',+        -- or (TODO) before first line with same indentation as tyline+        let (nonblank, rest) = span (\x -> not (all isSpace x) &&+                                           not (ind == getIndent x)) later+        if updatefile then+           do let fb = fn ++ "~"+              runIO $ writeFile fb (unlines (before ++ nonblank)+                                        ++ with ++ "\n" +++                                    unlines rest)+              runIO $ copyFile fb fn+           else ihPrintResult h with+  where getIndent s = length (takeWhile isSpace s)+++doProofSearch :: Handle -> FilePath -> Bool -> Bool -> +                 Int -> Name -> [Name] -> Maybe Int -> Idris ()+doProofSearch h fn updatefile rec l n hints Nothing+    = doProofSearch h fn updatefile rec l n hints (Just 10)+doProofSearch h fn updatefile rec l n hints (Just depth)+    = do src <- runIO $ readFile fn+         let (before, tyline : later) = splitAt (l-1) (lines src)+         ctxt <- getContext+         mn <- case lookupNames n ctxt of+                    [x] -> return x+                    [] -> return n+                    ns -> ierror (CantResolveAlts (map show ns))+         i <- getIState+         let (top, envlen, _) = case lookup mn (idris_metavars i) of+                                  Just (t, e, False) -> (t, e, False)+                                  _ -> (Nothing, 0, True)+         let fc = fileFC fn+         let body t = PProof [Try (TSeq Intros (ProofSearch rec False depth t hints))+                                  (ProofSearch rec False depth t hints)]+         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)+                 ctxt <- getContext+                 i <- getIState+                 return . flip displayS "" . renderPretty 1.0 80 $+                   pprintPTerm defaultPPOption [] [] (idris_infixes i)+                     (stripNS+                        (dropCtxt envlen+                           (delab i (specialise ctxt [] [(mn, 1)] tm)))))+             (\e -> return ("?" ++ show n))+         if updatefile then+            do let fb = fn ++ "~"+               runIO $ writeFile fb (unlines before +++                                     updateMeta False tyline (show n) newmv ++ "\n"+                                       ++ unlines later)+               runIO $ copyFile fb fn+            else ihPrintResult h newmv+    where dropCtxt 0 sc = sc+          dropCtxt i (PPi _ _ _ sc) = dropCtxt (i - 1) sc+          dropCtxt i (PLet _ _ _ sc) = dropCtxt (i - 1) sc+          dropCtxt i (PLam _ _ sc) = dropCtxt (i - 1) sc+          dropCtxt _ t = t++          stripNS tm = mapPT dens tm where+              dens (PRef fc n) = PRef fc (nsroot n)+              dens t = t++          nsroot (NS n _) = nsroot n+          nsroot (SN (WhereN _ _ n)) = nsroot n+          nsroot n = n++updateMeta brack ('?':cs) n new+    | length cs >= length n+      = case splitAt (length n) cs of+             (mv, c:cs) ->+                  if ((isSpace c || c == ')' || c == '}') && mv == n)+                     then addBracket brack new ++ (c : cs)+                     else '?' : mv ++ c : updateMeta True cs n new+             (mv, []) -> if (mv == n) then addBracket brack new else '?' : mv+updateMeta brack ('=':cs) n new = '=':updateMeta False cs n new+updateMeta brack (c:cs) n new +  = c : updateMeta (brack || not (isSpace c)) cs n new+updateMeta brack [] n new = ""++checkProv line n = isProv' False line n+  where+    isProv' p cs n | take (length n) cs == n = p+    isProv' _ ('?':cs) n = isProv' False cs n+    isProv' _ ('{':cs) n = isProv' True cs n+    isProv' _ ('}':cs) n = isProv' True cs n+    isProv' p (_:cs) n = isProv' p cs n+    isProv' _ [] n = False+    +addBracket False new = new+addBracket True new@('(':xs) | last xs == ')' = new+addBracket True new | any isSpace new = '(' : new ++ ")"+                    | otherwise = new+++makeLemma :: Handle -> FilePath -> Bool -> Int -> Name -> Idris ()+makeLemma h fn updatefile l n+   = do src <- runIO $ readFile fn+        let (before, tyline : later) = splitAt (l-1) (lines src)++        -- if the name is in braces, rather than preceded by a ?, treat it+        -- as a lemma in a provisional definition+        +        let isProv = checkProv tyline (show n)++        ctxt <- getContext+        mty <- case lookupTy n ctxt of+                    [t] -> return t+                    [] -> ierror (NoSuchVariable n)+                    ns -> ierror (CantResolveAlts (map show ns))+        i <- getIState++        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++            if updatefile then+               do let fb = fn ++ "~"+                  runIO $ writeFile fb (addLem before tyline lem lem_app later)+                  runIO $ copyFile fb fn+               else case idris_outputmode i of+                      RawOutput -> ihPrintResult h $ lem ++ "\n" ++ lem_app+                      IdeSlave n ->+                        let good = SexpList [SymbolAtom "ok",+                                             SexpList [SymbolAtom "metavariable-lemma",+                                                       SexpList [SymbolAtom "replace-metavariable",+                                                                 StringAtom lem_app],+                                                       SexpList [SymbolAtom "definition-type",+                                                                 StringAtom lem]]]+                        in runIO . hPutStrLn h $ convSExp "return" good n++          else do -- provisional definition+            let lem_app = show n ++ appArgs [] mty +++                                 " = ?" ++ show n ++ "_rhs"+            if updatefile then+               do let fb = fn ++ "~"+                  runIO $ writeFile fb (addProv before tyline lem_app later)+                  runIO $ copyFile fb fn+               else case idris_outputmode i of+                      RawOutput -> ihPrintResult h $ lem_app+                      IdeSlave n ->+                        let good = SexpList [SymbolAtom "ok",+                                             SexpList [SymbolAtom "provisional-definition-lemma",+                                                       SexpList [SymbolAtom "definition-clause",+                                                                 StringAtom lem_app]]]+                        in runIO . hPutStrLn h $ convSExp "return" good n++  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 _ = ""++        stripMNBind skip (PPi b n@(UN c) ty sc) +           | thead c /= '_' && +             n `notElem` skip = PPi b n ty (stripMNBind skip sc)+        stripMNBind skip (PPi b _ ty sc) = stripMNBind skip sc+        stripMNBind skip t = t++        -- Guess which binders should be implicits in the generated lemma.+        -- Make them implicit if they appear guarded by a top level constructor,+        -- or at the top level themselves.+        guessImps :: Context -> Term -> [Name]+        guessImps ctxt (Bind n (Pi _) sc)+           | guarded ctxt n (substV (P Bound n Erased) sc) +                = n : guessImps ctxt sc+           | otherwise = guessImps ctxt sc+        guessImps ctxt _ = []++        guarded ctxt n (P _ n' _) | n == n' = True+        guarded ctxt n ap@(App _ _)+            | (P _ f _, args) <- unApply ap,+              isConName f ctxt = any (guarded ctxt n) args+--         guarded ctxt n (Bind (UN cn) (Pi t) sc) -- ignore shadows+--             | thead cn /= '_' = guarded ctxt n t || guarded ctxt n sc+        guarded ctxt n (Bind _ (Pi t) sc) +            = guarded ctxt n t || guarded ctxt n sc+        guarded ctxt n _ = False++        blank = all isSpace++        addLem before tyline lem lem_app later+            = let (bef_end, blankline : bef_start) +                       = case span (not . blank) (reverse before) of+                              (bef, []) -> (bef, "" : [])+                              x -> x+                  mvline = updateMeta False tyline (show n) lem_app in+                unlines $ reverse bef_start +++                          [blankline, lem, blankline] +++                          reverse bef_end ++ mvline : later++        addProv before tyline lem_app later+            = let (later_bef, blankline : later_end)+                      = case span (not . blank) later of+                             (bef, []) -> (bef, "" : [])+                             x -> x in+                  unlines $ before ++ tyline : +                            (later_bef ++ [blankline, lem_app, blankline] +++                                      later_end)
src/Idris/Output.hs view
@@ -11,8 +11,13 @@ import Util.Pretty import Util.ScreenSize (getScreenWidth) +import Debug.Trace+ import System.IO (stdout, Handle, hPutStrLn) +import Data.List (nub)+import Data.Maybe (fromMaybe)+ pshow :: IState -> Err -> String pshow ist err = displayDecorated (consoleDecorate ist) .                 renderPretty 1.0 80 .@@ -23,7 +28,9 @@                      case idris_outputmode i of                        RawOutput ->                          do err' <- iRender . fmap (fancifyAnnots i) $-                                    text (show fc) <> colon <//> err+                                    if fc_fname fc /= ""+                                      then text (show fc) <> colon <//> err+                                      else err                             runIO . hPutStrLn h $ displayDecorated (consoleDecorate i) err'                        IdeSlave n ->                          do err' <- iRender . fmap (fancifyAnnots i) $ err@@ -47,16 +54,6 @@                                 | otherwise -> do width <- runIO getScreenWidth                                                   return $ renderPretty 0.8 width d -ihPrintResult :: Handle -> String -> Idris ()-ihPrintResult h s = do i <- getIState-                       case idris_outputmode i of-                         RawOutput -> case s of-                                        "" -> return ()-                                        s  -> runIO $ hPutStrLn h s-                         IdeSlave n ->-                             let good = SexpList [SymbolAtom "ok", toSExp s] in-                             runIO $ hPutStrLn h $ convSExp "return" good n- -- | Write a pretty-printed term to the console with semantic coloring consoleDisplayAnnotated :: Handle -> Doc OutputAnnotation -> Idris () consoleDisplayAnnotated h output = do ist <- getIState@@ -65,35 +62,20 @@                                         displayDecorated (consoleDecorate ist) $                                         rendered ---- | Write pretty-printed output to IDESlave with semantic annotations-ideSlaveReturnAnnotated :: Integer -> Handle -> Doc OutputAnnotation -> Idris ()-ideSlaveReturnAnnotated n h out = do ist <- getIState-                                     (str, spans) <- fmap displaySpans .-                                                     iRender .-                                                     fmap (fancifyAnnots ist) $-                                                     out-                                     let good = [SymbolAtom "ok", toSExp str, toSExp spans]-                                     runIO . hPutStrLn h $ convSExp "return" good n- ihPrintTermWithType :: Handle -> Doc OutputAnnotation -> Doc OutputAnnotation -> Idris ()-ihPrintTermWithType h tm ty = do ist <- getIState-                                 let output = tm <+> colon <+> ty-                                 case idris_outputmode ist of-                                   RawOutput -> consoleDisplayAnnotated h output-                                   IdeSlave n -> ideSlaveReturnAnnotated n h output+ihPrintTermWithType h tm ty = ihRenderResult h (tm <+> colon <+> align ty)  -- | Pretty-print a collection of overloadings to REPL or IDESlave - corresponds to :t name ihPrintFunTypes :: Handle -> [(Name, Bool)] -> Name -> [(Name, PTerm)] -> Idris () ihPrintFunTypes h bnd n []        = ihPrintError h $ "No such variable " ++ show n-ihPrintFunTypes h bnd n overloads = do imp <- impShow-                                       ist <- getIState-                                       let output = vsep (map (uncurry (ppOverload imp)) overloads)-                                       case idris_outputmode ist of-                                         RawOutput -> consoleDisplayAnnotated h output-                                         IdeSlave n -> ideSlaveReturnAnnotated n h output+ihPrintFunTypes h bnd n overloads = do ist <- getIState+                                       let ppo = ppOptionIst ist+                                       let infixes = idris_infixes ist+                                       let output = vsep (map (uncurry (ppOverload ppo infixes)) overloads)+                                       ihRenderResult h output   where fullName n = prettyName True bnd n-        ppOverload imp n tm = fullName n <+> colon <+> align (pprintPTerm imp bnd [] tm)+        ppOverload ppo infixes n tm =+          fullName n <+> colon <+> align (pprintPTerm ppo bnd [] infixes tm)  ihRenderResult :: Handle -> Doc OutputAnnotation -> Idris () ihRenderResult h d = do ist <- getIState@@ -101,51 +83,77 @@                           RawOutput -> consoleDisplayAnnotated h d                           IdeSlave n -> ideSlaveReturnAnnotated n h d -fancifyAnnots :: IState -> OutputAnnotation -> OutputAnnotation-fancifyAnnots ist annot@(AnnName n _ _ _) =-  do let ctxt = tt_ctxt ist-         docs = docOverview ist n-         ty   = Just (getTy ist n)-     case () of-       _ | isDConName    n ctxt -> AnnName n (Just DataOutput) docs ty-       _ | isFnName      n ctxt -> AnnName n (Just FunOutput) docs ty-       _ | isTConName    n ctxt -> AnnName n (Just TypeOutput) docs ty-       _ | isMetavarName n ist  -> AnnName n (Just MetavarOutput) docs ty-       _ | otherwise            -> annot-  where docOverview :: IState -> Name -> Maybe String -- pretty-print first paragraph of docs+makeAnnName :: IState -> Name -> Maybe OutputAnnotation+makeAnnName ist n+  | isDConName    n ctxt = annName DataOutput+  | isFnName      n ctxt = annName FunOutput+  | isTConName    n ctxt = annName TypeOutput+  | isMetavarName n ist  = annName MetavarOutput+  | otherwise            = Nothing+  where ctxt = tt_ctxt ist+        docs = docOverview ist n+        ty   = Just (getTy ist n)+        +        annName :: NameOutput -> Maybe OutputAnnotation+        annName nameType = Just (AnnName n (Just nameType) docs ty)+        docOverview :: IState -> Name -> Maybe String -- pretty-print first paragraph of docs         docOverview ist n = do docs <- lookupCtxtExact n (idris_docstrings ist)                                let o   = overview (fst docs)                                    -- TODO make width configurable                                    out = displayS . renderPretty 1.0 50 $ renderDocstring o                                return (out "")         getTy :: IState -> Name -> String -- fails if name not already extant!-        getTy ist n = let theTy = pprintPTerm (opt_showimp (idris_options ist)) [] [] $+        getTy ist n = let theTy = pprintPTerm (ppOptionIst ist) [] [] (idris_infixes ist) $                                   delabTy ist n                       in (displayS . renderPretty 1.0 50 $ theTy) ""+++fancifyAnnots :: IState -> OutputAnnotation -> OutputAnnotation+fancifyAnnots ist annot@(AnnName n _ _ _) = case makeAnnName ist n of+  Just fancyAnnot -> fancyAnnot+  Nothing         -> annot  fancifyAnnots _ annot = annot ++ideSlaveReturnWithStatus :: String -> Integer -> Handle -> Doc OutputAnnotation -> Idris ()+ideSlaveReturnWithStatus status n h out = do +  ist <- getIState+  (str, spans) <- fmap displaySpans .+                  iRender .+                  fmap (fancifyAnnots ist) $+                  out+  let good = [SymbolAtom status, toSExp str, toSExp spans]+  runIO . hPutStrLn h $ convSExp "return" good n+++-- | Write pretty-printed output to IDESlave with semantic annotations+ideSlaveReturnAnnotated :: Integer -> Handle -> Doc OutputAnnotation -> Idris ()+ideSlaveReturnAnnotated = ideSlaveReturnWithStatus "ok"+ -- | Show an error with semantic highlighting ihRenderError :: Handle -> Doc OutputAnnotation -> Idris () ihRenderError h e = do ist <- getIState                        case idris_outputmode ist of                          RawOutput -> consoleDisplayAnnotated h e-                         IdeSlave n -> do-                           (str, spans) <- fmap displaySpans .-                                           iRender .-                                           fmap (fancifyAnnots ist) $-                                           e-                           let good = [SymbolAtom "error", toSExp str, toSExp spans]-                           runIO . hPutStrLn h $ convSExp "return" good n+                         IdeSlave n -> ideSlaveReturnWithStatus "error" n h e +ihPrintWithStatus :: String -> Handle -> String -> Idris ()+ihPrintWithStatus status h s = do +  i <- getIState+  case idris_outputmode i of+    RawOutput -> case s of+      "" -> return ()+      s  -> runIO $ hPutStrLn h s+    IdeSlave n ->+      let good = SexpList [SymbolAtom status, toSExp s] in+      runIO $ hPutStrLn h $ convSExp "return" good n+++ihPrintResult :: Handle -> String -> Idris ()+ihPrintResult = ihPrintWithStatus "ok"+ ihPrintError :: Handle -> String -> Idris ()-ihPrintError h s = do i <- getIState-                      case idris_outputmode i of-                        RawOutput -> case s of-                                          "" -> return ()-                                          s  -> runIO $ hPutStrLn h s-                        IdeSlave n ->-                          let good = SexpList [SymbolAtom "error", toSExp s] in-                          runIO . hPutStrLn h $ convSExp "return" good n+ihPrintError = ihPrintWithStatus "error"  ihputStrLn :: Handle -> String -> Idris () ihputStrLn h s = do i <- getIState@@ -171,3 +179,9 @@                   RawOutput -> runIO $ putStrLn (displayDecorated (consoleDecorate i) g)                   IdeSlave n -> runIO . putStrLn $                                 convSExp "write-goal" (displayS (fmap (fancifyAnnots i) g) "") n++-- | Warn about totality problems without failing to compile+warnTotality :: Idris ()+warnTotality = do ist <- getIState+                  mapM_ (warn ist) (nub (idris_totcheckfail ist))+  where warn ist (fc, e) = iWarn fc (pprintErr ist (Msg e))
src/Idris/ParseData.hs view
@@ -42,11 +42,12 @@     DocComment Accessibility? 'record' FnName TypeSig 'where' OpenBlock Constructor KeepTerminator CloseBlock; -} record :: SyntaxInfo -> IdrisParser PDecl-record syn = do (doc, acc) <- try (do+record syn = do (doc, acc, opts) <- try (do                       doc <- option noDocs docComment                       acc <- optional accessibility+                      opts <- dataOpts []                       reserved "record"-                      return (doc, acc))+                      return (doc, acc, opts))                 fc <- getFC                 tyn_in <- fnName                 lchar ':'@@ -59,7 +60,7 @@                                                     syn_namespace syn }                 let fns = getRecNames rsyn cty                 mapM_ (\n -> addAcc n acc) fns-                return $ PRecord (fst doc) rsyn fc tyn ty cdoc cn cty+                return $ PRecord (fst doc) rsyn fc tyn ty opts cdoc cn cty              <?> "record type declaration"   where     getRecNames :: SyntaxInfo -> PTerm -> [Name]
src/Idris/ParseExpr.hs view
@@ -54,15 +54,23 @@                   return $ debindApp syn (desugar syn i x)  -{- |Parses an expression+{- | Parses an expression @-  Expr ::= Expr';+  Expr ::= Pi @--}+ -} expr :: SyntaxInfo -> IdrisParser PTerm-expr syn = do i <- get-              buildExpressionParser (table (idris_infixes i)) (expr' syn)+expr = pi +{- | Parses an expression with possible operator applied+@+  OpExpr ::= {- Expression Parser with Operators based on Expr' -};+@+-}+opExpr :: SyntaxInfo -> IdrisParser PTerm+opExpr syn = do i <- get+                buildExpressionParser (table (idris_infixes i)) (expr' syn)+ {- | Parses either an internally defined expression or     a user-defined one @@@ -70,16 +78,10 @@       |   InternalExpr; @  -}-expr' syn = doexpr' syn---    = do l <- restOfLine---         f <- getFC---         e <- trace (show (f, l)) $ doexpr' syn---         return e--doexpr' :: SyntaxInfo -> IdrisParser PTerm-doexpr' syn =     try (externalExpr syn)-              <|> internalExpr syn-              <?> "expression"+expr' :: SyntaxInfo -> IdrisParser PTerm+expr' syn = try (externalExpr syn)+            <|> internalExpr syn+            <?> "expression"  {- | Parses a user-defined expression -} externalExpr :: SyntaxInfo -> IdrisParser PTerm@@ -150,15 +152,23 @@     update ns (PRef fc n) = case lookup n ns of                               Just (SynTm t) -> t                               _ -> PRef fc n-    update ns (PLam n ty sc) = PLam (updateB ns n) (update ns ty) (update (dropn n ns) sc)-    update ns (PPi p n ty sc) = PPi p (updateB ns n) (update ns ty) (update (dropn n ns) sc)-    update ns (PLet n ty val sc) = PLet (updateB ns n) (update ns ty) (update ns val)-                                          (update (dropn n ns) sc)-    update ns (PApp fc t args) = PApp fc (update ns t) (map (fmap (update ns)) args)-    update ns (PAppBind fc t args) = PAppBind fc (update ns t) (map (fmap (update ns)) args)-    update ns (PCase fc c opts) = PCase fc (update ns c) (map (pmap (update ns)) opts)+    update ns (PLam n ty sc)+      = PLam (updateB ns n) (update ns ty) (update (dropn n ns) sc)+    update ns (PPi p n ty sc)+      = PPi (updTacImp ns p) (updateB ns n)+            (update ns ty) (update (dropn n ns) sc)+    update ns (PLet n ty val sc) +      = PLet  (updateB ns n) (update ns ty)+              (update ns val) (update (dropn n ns) sc)+    update ns (PApp fc t args)+      = PApp fc (update ns t) (map (fmap (update ns)) args)+    update ns (PAppBind fc t args)+      = PAppBind fc (update ns t) (map (fmap (update ns)) args)+    update ns (PCase fc c opts)+      = PCase fc (update ns c) (map (pmap (update ns)) opts)     update ns (PPair fc p l r) = PPair fc p (update ns l) (update ns r)-    update ns (PDPair fc p l t r) = PDPair fc p (update ns l) (update ns t) (update ns r)+    update ns (PDPair fc p l t r)+      = PDPair fc p (update ns l) (update ns t) (update ns r)     update ns (PAlternative a as) = PAlternative a (map (update ns) as)     update ns (PHidden t) = PHidden (update ns t)     update ns (PDoBlock ds) = PDoBlock $ upd ns ds@@ -176,40 +186,38 @@     update ns (PGoal fc r n sc) = PGoal fc (update ns r) n (update ns sc)     update ns t = t +    updTacImp ns (TacImp o st scr)  = TacImp o st (update ns scr)+    updTacImp _  x                  = x+ {- | Parses a (normal) built-in expression @ InternalExpr ::=-  App-  | MatchApp-  | UnifyLog+    UnifyLog   | RecordType   | SimpleExpr   | Lambda   | QuoteGoal   | Let   | RewriteTerm-  | Pi   | CaseExpr   | DoBlock+  | App   ; @ -} internalExpr :: SyntaxInfo -> IdrisParser PTerm internalExpr syn =-         try (app syn)-     <|> try (matchApp syn)-     <|> try (unifyLog syn)-     <|> try (disamb syn)-     <|> try (noImplicits syn)+         unifyLog syn+     <|> disamb syn+     <|> noImplicits syn      <|> recordType syn      <|> lambda syn      <|> quoteGoal syn      <|> let_ syn      <|> rewriteTerm syn-     <|> try (pi syn)      <|> doBlock syn      <|> caseExpr syn-     <|> simpleExpr syn+     <|> app syn      <?> "expression"  {- | Parses a case expression@@ -267,30 +275,28 @@ {- | Parses a simple expression @ SimpleExpr ::=-  '![' Term ']'+    {- External (User-defined) Simple Expression -}   | '?' Name   | % 'instance'   | 'refl' ('{' Expr '}')?   | ProofExpr   | TacticsExpr   | FnName+  | Idiom   | List-  | Comprehension   | Alt-  | Idiom-  | '(' Bracketed+  | Bracketed   | Constant   | Type   | '_|_'   | '_'-  | {- External (User-defined) Simple Expression -}   ; @ -} simpleExpr :: SyntaxInfo -> IdrisParser PTerm simpleExpr syn =-        {-try (do symbol "!["; t <- term; lchar ']'; return $ PQuote t)-        <|>-} do x <- try (lchar '?' *> name); return (PMetavar x)+            try (simpleExternalExpr syn)+        <|> do x <- try (lchar '?' *> name); return (PMetavar x)         <|> do lchar '%'; fc <- getFC; reserved "instance"; return (PResolveTC fc)         <|> do reserved "refl"; fc <- getFC;                tm <- option Placeholder (do lchar '{'; t <- expr syn; lchar '}';@@ -300,36 +306,40 @@         <|> proofExpr syn         <|> tacticsExpr syn         <|> do reserved "Type"; return PType-        <|> try (do c <- constant-                    fc <- getFC-                    return (modifyConst syn fc (PConstant c)))-        <|> try (do symbol "'"; fc <- getFC; str <- name-                    return (PApp fc (PRef fc (sUN "Symbol_"))-                               [pexp (PConstant (Str (show str)))]))+        <|> do c <- constant+               fc <- getFC+               return (modifyConst syn fc (PConstant c))+        <|> do symbol "'"; fc <- getFC; str <- name+               return (PApp fc (PRef fc (sUN "Symbol_"))+                          [pexp (PConstant (Str (show str)))])         <|> do fc <- getFC                x <- fnName                return (PRef fc x)-        <|> try (listExpr syn)-        <|> try (comprehension syn)-        <|> alt syn         <|> idiom syn+        <|> listExpr syn+        <|> alt syn         <|> do lchar '!'                s <- simpleExpr syn                fc <- getFC                return (PAppBind fc s [])-        <|> do lchar '('-               bracketed (disallowImp syn)+        <|> bracketed (disallowImp syn)         <|> do symbol "_|_"                fc <- getFC                return (PFalse fc)         <|> do lchar '_'; return Placeholder-        <|> simpleExternalExpr syn         <?> "expression" -+{- |Parses an expression in braces+@+Bracketed ::= '(' Bracketed'+@+ -}+bracketed :: SyntaxInfo -> IdrisParser PTerm+bracketed syn = do lchar '(' <?> "parenthesized expression"+                   bracketed' syn {- |Parses the rest of an expression in braces @-Bracketed ::=+Bracketed' ::=   ')'   | Expr ')'   | ExprList ')'@@ -340,8 +350,8 @@   ; @ -}-bracketed :: SyntaxInfo -> IdrisParser PTerm-bracketed syn =+bracketed' :: SyntaxInfo -> IdrisParser PTerm+bracketed' syn =             do lchar ')'                fc <- getFC                return $ PTrue fc TypeOrTerm@@ -354,7 +364,7 @@                     return (PDPair fc TypeOrTerm (PRef fc ln) lty r))         <|> try (do fc <- getFC; o <- operator; e <- expr syn; lchar ')'                     -- No prefix operators! (bit of a hack here...)-                    if (o == "-" || o == "!") +                    if (o == "-" || o == "!")                       then fail "minus not allowed in section"                       else return $ PLam (sMN 1000 "ARG") Placeholder                          (PApp fc (PRef fc (sUN o)) [pexp (PRef fc (sMN 1000 "ARG")),@@ -414,29 +424,6 @@                ] modifyConst syn fc x = x -{- | Parses a list literal expression e.g. [1,2,3]-@-ListExpr ::=-  '[' ExprList? ']'-;-@-@-ExprList ::=-  Expr-  | Expr ',' ExprList-  ;-@- -}-listExpr :: SyntaxInfo -> IdrisParser PTerm-listExpr syn = do lchar '['; fc <- getFC; xs <- sepBy (expr syn) (lchar ','); lchar ']'-                  return (mkList fc xs)-               <?> "list expression"-  where-    mkList :: FC -> [PTerm] -> PTerm-    mkList fc [] = PRef fc (sUN "Nil")-    mkList fc (x : xs) = PApp fc (PRef fc (sUN "::")) [pexp x, pexp (mkList fc xs)]-- {- | Parses an alternative expression @   Alt ::= '(|' Expr_List '|)';@@ -467,31 +454,13 @@   <|> simpleExpr syn   <?> "expression" -{- | Parses a matching application expression-@-MatchApp ::=-  SimpleExpr '<==' FnName-  ;-@--}-matchApp :: SyntaxInfo -> IdrisParser PTerm-matchApp syn = do ty <- simpleExpr syn-                  symbol "<=="-                  fc <- getFC-                  f <- fnName-                  return (PLet (sMN 0 "match")-                                ty-                                (PMatchApp fc f)-                                (PRef fc (sMN 0 "match")))-               <?> "matching application expression"- {- | Parses a unification log expression UnifyLog ::=   '%' 'unifyLog' SimpleExpr   ; -} unifyLog :: SyntaxInfo -> IdrisParser PTerm-unifyLog syn = do lchar '%'; reserved "unifyLog";+unifyLog syn = do try (lchar '%' *> reserved "unifyLog")                   tm <- simpleExpr syn                   return (PUnifyLog tm)                <?> "unification log expression"@@ -517,7 +486,7 @@ @ -} noImplicits :: SyntaxInfo -> IdrisParser PTerm-noImplicits syn = do lchar '%'; reserved "noImplicits";+noImplicits syn = do try (lchar '%' *> reserved "noImplicits")                      tm <- simpleExpr syn                      return (PNoImplicits tm)                  <?> "no implicits expression"@@ -526,8 +495,12 @@ @ App ::=   'mkForeign' Arg Arg*-  | SimpleExpr Arg++  | MatchApp+  | SimpleExpr Arg*   ;+MatchApp ::=+  SimpleExpr '<==' FnName+  ; @ -} app :: SyntaxInfo -> IdrisParser PTerm@@ -536,8 +509,6 @@              fn <- arg syn              args <- many (do notEndApp; arg syn)              i <- get-             -- mkForeign f args ==>-             -- liftPrimIO (\w => mkForeignPrim f args w)              let ap = PApp fc (PRef fc (sUN "liftPrimIO"))                        [pexp (PLam (sMN 0 "w")                              Placeholder@@ -547,13 +518,20 @@              return (dslify i ap)         <|> do f <- simpleExpr syn+              (do try $ symbol "<=="+                  fc <- getFC+                  ff <- fnName+                  return (PLet (sMN 0 "match")+                                f+                                (PMatchApp fc ff)+                                (PRef fc (sMN 0 "match")))+               <?> "matching application expression") <|> (do               fc <- getFC-              args <- some (do notEndApp; arg syn)               i <- get---               case f of---                    PAppBind fc ref [] ->---                       return (dslify i (PAppBind fc ref args))-              return (dslify i (PApp fc f args))+              args <- many (do notEndApp; arg syn)+              case args of+                [] -> return f+                _  -> return (dslify i (PApp fc f args)))        <?> "function application"   where     dslify :: IState -> PTerm -> PTerm@@ -628,30 +606,62 @@ @ -} recordType :: SyntaxInfo -> IdrisParser PTerm-recordType syn-    = do reserved "record"+recordType syn = +      do reserved "record"          lchar '{'-         fields <- sepBy1 fieldType (lchar ',')+         fgs <- fieldGetOrSet          lchar '}'          fc <- getFC          rec <- optional (simpleExpr syn)-         case rec of-            Nothing ->-                return (PLam (sMN 0 "fldx") Placeholder-                            (applyAll fc fields (PRef fc (sMN 0 "fldx"))))-            Just v -> return (applyAll fc fields v)+         case fgs of+              Left fields ->+                case rec of+                   Nothing ->+                       return (PLam (sMN 0 "fldx") Placeholder+                                   (applyAll fc fields (PRef fc (sMN 0 "fldx"))))+                   Just v -> return (applyAll fc fields v)+              Right fields ->+                case rec of+                   Nothing ->+                       return (PLam (sMN 0 "fldx") Placeholder+                                 (getAll fc (reverse fields) +                                     (PRef fc (sMN 0 "fldx"))))+                   Just v -> return (getAll fc (reverse fields) v)+        <?> "record setting expression"-   where fieldType :: IdrisParser (Name, PTerm)-         fieldType = do n <- fnName-                        lchar '='-                        e <- expr syn-                        return (n, e)-                     <?> "field setter"-         applyAll :: FC -> [(Name, PTerm)] -> PTerm -> PTerm+   where fieldSet :: IdrisParser ([Name], PTerm)+         fieldSet = do ns <- fieldGet+                       lchar '='+                       e <- expr syn+                       return (ns, e)+                    <?> "field setter"++         fieldGet :: IdrisParser [Name]+         fieldGet = sepBy1 fnName (symbol "->")++         fieldGetOrSet :: IdrisParser (Either [([Name], PTerm)] [Name])+         fieldGetOrSet = try (do fs <- sepBy1 fieldSet (lchar ',')+                                 return (Left fs))+                     <|> do f <- fieldGet+                            return (Right f)++         applyAll :: FC -> [([Name], PTerm)] -> PTerm -> PTerm          applyAll fc [] x = x-         applyAll fc ((n, e) : es) x-            = applyAll fc es (PApp fc (PRef fc (mkType n)) [pexp e, pexp x])+         applyAll fc ((ns, e) : es) x+            = applyAll fc es (doUpdate fc ns e x)+            +         doUpdate fc [n] e get+              = PApp fc (PRef fc (mkType n)) [pexp e, pexp get]+         doUpdate fc (n : ns) e get+              = PApp fc (PRef fc (mkType n)) +                  [pexp (doUpdate fc ns e (PApp fc (PRef fc n) [pexp get])), +                   pexp get] +         getAll :: FC -> [Name] -> PTerm -> PTerm+         getAll fc [n] e = PApp fc (PRef fc n) [pexp e]+         getAll fc (n:ns) e = PApp fc (PRef fc n) [pexp (getAll fc ns e)]++ -- | Creates setters for record types on necessary functions mkType :: Name -> Name mkType (UN n) = sUN ("set_" ++ str n)@@ -689,17 +699,17 @@ @ -} lambda :: SyntaxInfo -> IdrisParser PTerm-lambda syn = do lchar '\\'-                try (do xt <- tyOptDeclList syn-                        symbol "=>"-                        sc <- expr syn-                        return (bindList PLam xt sc)-                 <|> (do ps <- sepBy (do fc <- getFC-                                         e <- simpleExpr syn-                                         return (fc, e)) (lchar ',')-                         symbol "=>"-                         sc <- expr syn-                         return (pmList (zip [0..] ps) sc)))+lambda syn = do lchar '\\' <?> "lambda expression"+                (do xt <- try $ tyOptDeclList syn+                    symbol "=>"+                    sc <- expr syn+                    return (bindList PLam xt sc)) <|> do+                      ps <- sepBy (do fc <- getFC+                                      e <- simpleExpr syn+                                      return (fc, e)) (lchar ',')+                      symbol "=>"+                      sc <- expr syn+                      return (pmList (zip [0..] ps) sc)                  <?> "lambda expression"     where pmList :: [(Int, (FC, PTerm))] -> PTerm -> PTerm           pmList [] sc = sc@@ -777,53 +787,68 @@ {- | Parses a dependent type signature  @-Pi ::=-    '|'? Static? '('           TypeDeclList ')' DocComment '->' Expr-  | '|'? Static? '{'           TypeDeclList '}'            '->' Expr-  |              '{' 'auto'    TypeDeclList '}'            '->' Expr-  |              '{' 'default' TypeDeclList '}'            '->' Expr+Pi ::= PiOpts Static? Pi'+@++@+Pi' ::=+    OpExpr ('->' Pi)?+  | '(' TypeDeclList           ')'            '->' Pi+  | '{' TypeDeclList           '}'            '->' Pi+  | '{' 'auto'    TypeDeclList '}'            '->' Pi+  | '{' 'default' SimpleExpr TypeDeclList '}' '->' Pi   ; @  -}  pi :: SyntaxInfo -> IdrisParser PTerm pi syn =-     do opts <- -- if implicitAllowed syn -- laziness is top level only-                -- then option [] (do lchar '|'; return [Lazy])-                -- else return []-                return []-        st <- static-        (do try (lchar '('); xt <- typeDeclList syn; lchar ')'+     do opts <- piOpts syn+        st   <- static+        (do xt <- try (lchar '(' *> typeDeclList syn <* lchar ')')             symbol "->"             sc <- expr syn             return (bindList (PPi (Exp opts st False)) xt sc)) <|> (do-               lchar '{'-               (do reserved "auto"-                   when (Lazy `elem` opts || (st == Static)) $ fail "auto type constraints can not be lazy or static"+               (do try (lchar '{' *> reserved "auto")+                   when (st == Static) $ fail "auto type constraints can not be lazy or static"                    xt <- typeDeclList syn                    lchar '}'                    symbol "->"                    sc <- expr syn                    return (bindList (PPi-                     (TacImp [] Dynamic (PTactics [Trivial]))) xt sc)) -                 <|> (do-                       reserved "default"-                       when (Lazy `elem` opts || (st == Static)) $ fail "default tactic constraints can not be lazy or static"+                     (TacImp [] Dynamic (PTactics [Trivial]))) xt sc)) <|> (do+                       try (lchar '{' *> reserved "default")+                       when (st == Static) $ fail "default tactic constraints can not be lazy or static"                        script <- simpleExpr syn                        xt <- typeDeclList syn                        lchar '}'                        symbol "->"                        sc <- expr syn-                       return (bindList (PPi (TacImp [] Dynamic script)) xt sc)) +                       return (bindList (PPi (TacImp [] Dynamic script)) xt sc))                  <|> (if implicitAllowed syn then do-                            xt <- typeDeclList syn-                            lchar '}'+                            xt <- try (lchar '{' *> typeDeclList syn <* lchar '}')                             symbol "->"                             sc <- expr syn                             return (bindList (PPi (Imp opts st False)) xt sc)                        else do fail "no implicit arguments allowed here"))+                 <|> (do x <- opExpr syn+                         (do symbol "->"+                             sc <- expr syn+                             return (PPi (Exp opts st False) (sUN "__pi_arg") x sc))+                          <|> return x)   <?> "dependent type signature" +{- | Parses Possible Options for Pi Expressions+@+  PiOpts ::= '.'?+@+-}+piOpts :: SyntaxInfo -> IdrisParser [ArgOpt]+piOpts syn | implicitAllowed syn =+        lchar '.' *> return [InaccessibleArg]+    <|> return []+piOpts syn = return []+ {- | Parses a type constraint list  @@@ -897,34 +922,49 @@                                   return (sMN 0 "underscore")                            <?> "name or placeholder" -{- | Parses a list comprehension+{- | Parses a list literal expression e.g. [1,2,3] or a comprehension [ (x, y) | x <- xs , y <- ys ] @-Comprehension ::= '[' Expr '|' DoList ']';+ListExpr ::=+     '[' ']'+  | '[' Expr '|' DoList ']'+  | '[' ExprList ']'+; @- @ DoList ::=     Do   | Do ',' DoList   ; @--}-comprehension :: SyntaxInfo -> IdrisParser PTerm-comprehension syn-    = do lchar '['-         fc <- getFC-         pat <- expr syn-         lchar '|'-         qs <- sepBy1 (do_ syn) (lchar ',')-         lchar ']'-         return (PDoBlock (map addGuard qs ++-                    [DoExp fc (PApp fc (PRef fc (sUN "return"))-                                 [pexp pat])]))-      <?> "list comprehension"-    where addGuard :: PDo -> PDo-          addGuard (DoExp fc e) = DoExp fc (PApp fc (PRef fc (sUN "guard"))-                                                    [pexp e])-          addGuard x = x+@+ExprList ::=+  Expr+  | Expr ',' ExprList+  ;+@+ -}+listExpr :: SyntaxInfo -> IdrisParser PTerm+listExpr syn = do lchar '['; fc <- getFC;+                  try ((lchar ']' <?> "end of list expression") *> return (mkList fc [])) <|> (do+                    x <- expr syn <?> "expression"+                    (do try (lchar '|') <?> "list comprehension"+                        qs <- sepBy1 (do_ syn) (lchar ',')+                        lchar ']'+                        return (PDoBlock (map addGuard qs +++                                   [DoExp fc (PApp fc (PRef fc (sUN "return"))+                                                [pexp x])]))) <|> (do+                          xs <- many ((lchar ',' <?> "list element") *> expr syn)+                          lchar ']' <?> "end of list expression"+                          return (mkList fc (x:xs))))+                <?> "list expression"+  where+    mkList :: FC -> [PTerm] -> PTerm+    mkList fc [] = PRef fc (sUN "Nil")+    mkList fc (x : xs) = PApp fc (PRef fc (sUN "::")) [pexp x, pexp (mkList fc xs)]+    addGuard :: PDo -> PDo+    addGuard (DoExp fc e) = DoExp fc (PApp fc (PRef fc (sUN "guard"))+                                              [pexp e])+    addGuard x = x  {- | Parses a do-block @@@ -1056,11 +1096,11 @@         <|> do reserved "Bits16x8"; return (AType (ATInt (ITVec IT16 8)))         <|> do reserved "Bits32x4"; return (AType (ATInt (ITVec IT32 4)))         <|> do reserved "Bits64x2"; return (AType (ATInt (ITVec IT64 2)))-        <|> try (do f <- float;   return $ Fl f)-        <|> try (do i <- natural; return $ BI i)-        <|> try (do s <- verbatimStringLiteral; return $ Str s)-        <|> try (do s <- stringLiteral;  return $ Str s)-        <|> try (do c <- charLiteral;   return $ Ch c)+        <|> do f <- try float;   return $ Fl f+        <|> do i <- natural; return $ BI i+        <|> do s <- verbatimStringLiteral; return $ Str s+        <|> do s <- stringLiteral;  return $ Str s+        <|> do c <- try charLiteral; return $ Ch c --Currently ambigous with symbols         <?> "constant or literal"  {- | Parses a verbatim multi-line string literal (triple-quoted)@@ -1072,7 +1112,7 @@ @  -} verbatimStringLiteral :: MonadicParsing m => m String-verbatimStringLiteral = token $ do string "\"\"\""+verbatimStringLiteral = token $ do try $ string "\"\"\""                                    manyTill anyChar $ try (string "\"\"\"")  {- | Parses a static modifier@@ -1084,7 +1124,7 @@ @ -} static :: IdrisParser Static-static =     do lchar '['; reserved "static"; lchar ']'; return Static+static =     do reserved "[static]"; return Static          <|> return Dynamic          <?> "static modifier" @@ -1185,7 +1225,10 @@                  return $ TSeq t (mergeSeq ts)           <|> do reserved "compute"; return Compute           <|> do reserved "trivial"; return Trivial-          <|> do reserved "search"; return (ProofSearch Nothing [])+          <|> do reserved "unify"; return DoUnify+          <|> do reserved "search"+                 depth <- option 10 natural+                 return (ProofSearch True True (fromInteger depth) Nothing [])           <|> do reserved "instance"; return TCInstance           <|> do reserved "solve"; return Solve           <|> do reserved "attack"; return Attack
src/Idris/ParseHelpers.hs view
@@ -156,9 +156,11 @@ docComment :: IdrisParser (Docstring, [(Name, Docstring)]) docComment = do dc <- pushIndent *> docCommentLine                 rest <- many (indented docCommentLine)-                args <- many (indented argDocCommentLine)+                args <- many $ do (name, first) <- indented argDocCommentLine+                                  rest <- many (indented docCommentLine)+                                  return (name, concat (intersperse "\n" (first:rest)))                 popIndent-                return (parseDocstring $ T.pack (concat . intersperse "\n" $ dc:rest),+                return (parseDocstring $ T.pack (concat (intersperse "\n" (dc:rest))),                         map (\(n, d) -> (n, parseDocstring (T.pack d))) args)    where docCommentLine :: MonadicParsing m => m String@@ -170,6 +172,7 @@                                  eol ; someSpace                                  return contents)-- ++ concat rest))                         <?> ""+         argDocCommentLine = do string "|||"                                many (satisfy isSpace)                                char '@'@@ -214,7 +217,7 @@ idrisStyle = IdentifierStyle _styleName _styleStart _styleLetter _styleReserved Hi.Identifier Hi.ReservedIdentifier   where _styleName = "Idris"         _styleStart = satisfy isAlpha-        _styleLetter = satisfy isAlphaNum <|> oneOf "_'" <|> (lchar '.')+        _styleLetter = satisfy isAlphaNum <|> oneOf "_'."         _styleReserved = HS.fromList ["let", "in", "data", "codata", "record", "Type",                                       "do", "dsl", "import", "impossible",                                       "case", "of", "total", "partial", "mutual",@@ -313,7 +316,7 @@ -- | Parses an operator operator :: MonadicParsing m => m String operator = do op <- token . some $ operatorLetter-              when (op `elem` [":", "=>", "->", "<-", "=", "?="]) $ +              when (op `elem` [":", "=>", "->", "<-", "=", "?=", "|"]) $                     fail $ op ++ " is not a valid operator"               return op @@ -563,8 +566,8 @@ collect (PParams f ns ps : ds) = PParams f ns (collect ps) : collect ds collect (PMutual f ms : ds) = PMutual f (collect ms) : collect ds collect (PNamespace ns ps : ds) = PNamespace ns (collect ps) : collect ds-collect (PClass doc f s cs n ps ds : ds')-    = PClass doc f s cs n ps (collect ds) : collect ds'+collect (PClass doc f s cs n ps pdocs ds : ds')+    = PClass doc f s cs n ps pdocs (collect ds) : collect ds' collect (PInstance f s cs n ps t en ds : ds')     = PInstance f s cs n ps t en (collect ds) : collect ds' collect (d : ds) = d : collect ds
src/Idris/ParseOps.hs view
@@ -38,8 +38,7 @@        ++ toTable (reverse fixes) ++       [[backtick],        [binary "$" (\fc x y -> flatten $ PApp fc x [pexp y]) AssocRight],-       [binary "="  PEq AssocLeft],-       [binary "->" (\fc x y -> PPi expl (sUN "__pi_arg") x y) AssocRight]]+       [binary "="  PEq 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
@@ -17,14 +17,15 @@ import qualified Text.Parser.Token.Highlight as Hi  import Text.PrettyPrint.ANSI.Leijen (Doc, plain)+import qualified Text.PrettyPrint.ANSI.Leijen as ANSI -import Idris.AbsSyntax+import Idris.AbsSyntax hiding (namespace, params) import Idris.DSL import Idris.Imports import Idris.Delaborate import Idris.Error import Idris.ElabDecls-import Idris.ElabTerm hiding (namespace, params)+import Idris.ElabTerm import Idris.Coverage import Idris.IBC import Idris.Unlit@@ -46,7 +47,7 @@ import Idris.Core.TT import Idris.Core.Evaluate -import Control.Applicative+import Control.Applicative hiding (Const) import Control.Monad import Control.Monad.Error (throwError, catchError) import Control.Monad.State.Strict@@ -127,9 +128,14 @@ prog :: SyntaxInfo -> IdrisParser [PDecl] prog syn = do whiteSpace               decls <- many (decl syn)-              notOpenBraces-              eof               let c = (concat decls)+              case maxline syn of+                   Nothing -> do notOpenBraces; eof+                   _ -> return ()+              ist <- get+              fc <- getFC+              put ist { idris_parsedSpan = Just (FC (fc_fname fc) (0,0) (fc_end fc)),+                        ibc_write = IBCParsedRegion fc : ibc_write ist }               return c  {-| Parses a top-level declaration@@ -152,8 +158,16 @@ @ -} decl :: SyntaxInfo -> IdrisParser [PDecl]-decl syn = do notEndBlock-              declBody+decl syn = do fc <- getFC+              -- if we're after maxline, stop here+              let continue = case maxline syn of+                                Nothing -> True+                                Just l -> if fst (fc_end fc) > l+                                             then mut_nesting syn /= 0+                                             else True+              if continue then do notEndBlock+                                  declBody+                          else fail "End of readable input"   where declBody :: IdrisParser [PDecl]         declBody =     declBody'                    <|> using_ syn@@ -488,7 +502,7 @@     do reserved "mutual"        openBlock        let pvars = syn_params syn-       ds <- many (decl syn)+       ds <- many (decl (syn { mut_nesting = mut_nesting syn + 1 } ))        closeBlock        fc <- getFC        return [PMutual fc (concat ds)]@@ -573,7 +587,7 @@                 cs <- many carg                 ds <- option [] (classBlock syn)                 accData acc n (concatMap declared ds)-                return [PClass (fst doc) syn fc cons n cs ds]+                return [PClass (fst doc) syn fc cons n cs (snd doc) ds]              <?> "type-class declaration"   where     carg :: IdrisParser (Name, PTerm)@@ -830,7 +844,6 @@                   return $ PClause fc n capp wargs rs wheres) <|> (do                    popIndent                    reserved "with"-                   lchar '(' <?> "parenthesized expression"                    wval <- bracketed syn                    openBlock                    ds <- some $ fnDecl syn@@ -864,7 +877,6 @@                    reserved "with"                    ist <- get                    put (ist { lastParse = Just n })-                   lchar '(' <?> "parenthesized expression"                    wval <- bracketed syn                    openBlock                    ds <- some $ fnDecl syn@@ -1001,7 +1013,7 @@                                              Right msg ->                                                  fail $ msg)]              <|> do try (lchar '%' *> reserved "name")-                    ty <- iName []+                    ty <- fnName                     ns <- sepBy1 name (lchar ',')                     return [PDirective (do ty' <- disambiguate ty                                            mapM_ (addNameHint ty') ns@@ -1087,6 +1099,10 @@ parseExpr :: IState -> String -> Result PTerm parseExpr st = runparser (fullExpr defaultSyntax) st "(input)" +{- | Parses a constant form input -}+parseConst :: IState -> String -> Result Const+parseConst st = runparser constant st "(input)"+ {- | Parses a tactic from input -} parseTactic :: IState -> String -> Result PTactic parseTactic st = runparser (fullTactic defaultSyntax) st "(input)"@@ -1120,6 +1136,11 @@                    (col, ':':msg) -> let pos = (read line, read col) in                                          (FC failname pos pos, msg) +-- | Check if the coloring matches the options and corrects if necessary+fixColour :: Bool -> ANSI.Doc -> ANSI.Doc+fixColour False doc = ANSI.plain doc+fixColour True doc  = doc+ -- | A program is a list of declarations, possibly with associated -- documentation strings. parseProg :: SyntaxInfo -> FilePath -> String -> Maybe Delta ->@@ -1132,7 +1153,7 @@                                   let (fc, msg) = findFC doc                                   i <- getIState                                   case idris_outputmode i of-                                    RawOutput -> ihputStrLn (idris_outh i) (show doc)+                                    RawOutput -> ihputStrLn (idris_outh i) (show $ fixColour (idris_colourRepl i) doc)                                     IdeSlave n -> ihWarn (idris_outh i) fc (P.text msg)                                   putIState (i { errSpan = Just fc })                                   return []@@ -1154,8 +1175,7 @@    = idrisCatch (loadModule' outh f)                 (\e -> do setErrSpan (getErrSpan e)                           ist <- getIState-                          msg <- showErr e-                          ihputStrLn outh msg+                          ihWarn outh (getErrSpan e) $ pprintErr ist e                           return "")  {- | Load idris module -}@@ -1165,26 +1185,26 @@         let file = takeWhile (/= ' ') f         ibcsd <- valIBCSubDir i         ids <- allImportDirs-        fp <- liftIO $ findImport ids ibcsd file+        fp <- findImport ids ibcsd file         if file `elem` imported i           then iLOG $ "Already read " ++ file           else do putIState (i { imported = file : imported i })                   case fp of-                    IDR fn  -> loadSource outh False fn-                    LIDR fn -> loadSource outh True  fn+                    IDR fn  -> loadSource outh False fn Nothing+                    LIDR fn -> loadSource outh True  fn Nothing                     IBC fn src ->                       idrisCatch (loadIBC fn)                                  (\c -> do iLOG $ fn ++ " failed " ++ pshow i c                                            case src of-                                             IDR sfn -> loadSource outh False sfn-                                             LIDR sfn -> loadSource outh True sfn)+                                             IDR sfn -> loadSource outh False sfn Nothing+                                             LIDR sfn -> loadSource outh True sfn Nothing)         let (dir, fh) = splitFileName file         return (dropExtension fh)   {- | Load idris code from file -}-loadFromIFile :: Handle -> IFileType -> Idris ()-loadFromIFile h i@(IBC fn src)+loadFromIFile :: Handle -> IFileType -> Maybe Int -> Idris ()+loadFromIFile h i@(IBC fn src) maxline    = do iLOG $ "Skipping " ++ getSrcFile i         idrisCatch (loadIBC fn)                 (\err -> ierror $ LoadingFailed fn err)@@ -1193,20 +1213,22 @@     getSrcFile (LIDR fn) = fn     getSrcFile (IBC f src) = getSrcFile src -loadFromIFile h (IDR fn) = loadSource' h False fn-loadFromIFile h (LIDR fn) = loadSource' h True fn+loadFromIFile h (IDR fn) maxline = loadSource' h False fn maxline+loadFromIFile h (LIDR fn) maxline = loadSource' h True fn maxline  {-| Load idris source code and show error if something wrong happens -}-loadSource' :: Handle -> Bool -> FilePath -> Idris ()-loadSource' h lidr r-   = idrisCatch (loadSource h lidr r)+loadSource' :: Handle -> Bool -> FilePath -> Maybe Int -> Idris ()+loadSource' h lidr r maxline+   = idrisCatch (loadSource h lidr r maxline)                 (\e -> do setErrSpan (getErrSpan e)                           ist <- getIState-                          ihRenderError h (pprintErr ist e))+                          case e of+                            At f e' -> ihWarn h f (pprintErr ist e')+                            _ -> ihWarn h (getErrSpan e) (pprintErr ist e))  {- | Load Idris source code-}-loadSource :: Handle -> Bool -> FilePath -> Idris ()-loadSource h lidr f+loadSource :: Handle -> Bool -> FilePath -> Maybe Int -> Idris ()+loadSource h lidr f toline              = do iLOG ("Reading " ++ f)                   i <- getIState                   let def_total = default_total i@@ -1215,11 +1237,11 @@                   (mname, imports, pos) <- parseImports f file                   ids <- allImportDirs                   ibcsd <- valIBCSubDir i-                  mapM_ (\f -> do fp <- runIO $ findImport ids ibcsd f+                  mapM_ (\f -> do fp <- findImport ids ibcsd f                                   case fp of                                       LIDR fn -> ifail $ "No ibc for " ++ f                                       IDR fn -> ifail $ "No ibc for " ++ f-                                      IBC fn src -> loadIBC fn) +                                      IBC fn src -> loadIBC fn)                         [fn | (fn, _, _) <- imports]                   reportParserWarnings @@ -1237,13 +1259,14 @@                   putIState (i { default_access = Hidden, module_aliases = modAliases })                   clearIBC -- start a new .ibc file                   mapM_ (addIBC . IBCImport) [realName | (realName, alias, fc) <- imports]-                  let syntax = defaultSyntax{ syn_namespace = reverse mname }+                  let syntax = defaultSyntax{ syn_namespace = reverse mname,+                                              maxline = toline }                   ds' <- parseProg syntax f file pos                    -- Parsing done, now process declarations                    let ds = namespaces mname ds'-                  logLvl 3 (show $ showDecls True ds)+                  logLvl 3 (show $ showDecls verbosePPOption ds)                   i <- getIState                   logLvl 10 (show (toAlist (idris_implicits i)))                   logLvl 3 (show (idris_infixes i))@@ -1285,7 +1308,6 @@                   addHides (hide_list i)                    -- Finally, write an ibc if checking was successful-                   ok <- noErrors                   when ok $                     idrisCatch (do writeIBC f ibc; clearIBC)@@ -1305,7 +1327,7 @@     toMutual x = let r = PMutual (fileFC "single mutual") [x] in                  case x of                    PClauses _ _ _ _ -> r-                   PClass _ _ _ _ _ _ _ -> r+                   PClass _ _ _ _ _ _ _ _ -> r                    PInstance _ _ _ _ _ _ _ _ -> r                    _ -> x
src/Idris/PartialEval.hs view
@@ -124,7 +124,7 @@          | imparg imp = (ImplicitD, tm)          | otherwise = (ExplicitD, (P Ref (sUN (show n ++ "arg")) Erased)) -    imparg (PExp _ _ _) = False+    imparg (PExp _ _ _ _) = False     imparg _ = True      buildApp env [] [] _ _ = []
src/Idris/Primitives.hs view
@@ -28,9 +28,10 @@ ty []     x = Constant x ty (t:ts) x = Bind (sMN 0 "T") (Pi (Constant t)) (ty ts x) -total, partial :: Totality+total, partial, iopartial :: Totality total = Total [] partial = Partial NotCovering+iopartial = Partial ExternalIO  primitives :: [Prim] primitives =@@ -164,22 +165,28 @@    Prim (sUN "prim__strRev") (ty [StrType] StrType) 1 (p_strRev)     (1, LStrRev) total,    Prim (sUN "prim__readString") (ty [PtrType] StrType) 1 (p_cantreduce)-     (1, LReadStr) partial,+     (1, LReadStr) iopartial,    Prim (sUN "prim__vm") (ty [] PtrType) 0 (p_cantreduce)      (0, LVMPtr) total,    -- Streams    Prim (sUN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce)-    (0, LStdIn) partial,+    (0, LStdIn) iopartial,+   Prim (sUN "prim__stdout") (ty [] PtrType) 0 (p_cantreduce)+    (0, LStdOut) iopartial,+   Prim (sUN "prim__stderr") (ty [] PtrType) 0 (p_cantreduce)+    (0, LStdErr) iopartial,    Prim (sUN "prim__null") (ty [] PtrType) 0 (p_cantreduce)     (0, LNullPtr) total,    -- Managed pointer registration    Prim (sUN "prim__registerPtr") (ty [PtrType, AType (ATInt ITNative)] ManagedPtrType) 2 (p_cantreduce)     (2, LRegisterPtr) total,    -- Buffers-   Prim (sUN "prim__allocate") (ty [AType (ATInt (ITFixed IT64))] BufferType) 1 (p_cantreduce)+   Prim (sUN "prim__allocate") (ty [AType (ATInt (ITFixed IT64))] BufferType) 1 (p_allocate)     (1, LAllocate) total,-   Prim (sUN "prim__appendBuffer") (ty [BufferType, AType (ATInt (ITFixed IT64)), AType (ATInt (ITFixed IT64)), AType (ATInt (ITFixed IT64)), AType (ATInt (ITFixed IT64)), BufferType] BufferType) 6 (p_cantreduce)-    (6, LAppendBuffer) partial+   Prim (sUN "prim__appendBuffer") (ty [BufferType, AType (ATInt (ITFixed IT64)), AType (ATInt (ITFixed IT64)), AType (ATInt (ITFixed IT64)), AType (ATInt (ITFixed IT64)), BufferType] BufferType) 6 (p_appendBuffer)+    (6, LAppendBuffer) partial,+    Prim (sUN "prim__systemInfo") (ty [AType (ATInt ITNative)] StrType) 1 (p_cantreduce)+        (1, LSystemInfo) total   ] ++ concatMap intOps [ITFixed IT8, ITFixed IT16, ITFixed IT32, ITFixed IT64, ITBig, ITNative, ITChar]     ++ concatMap vecOps vecTypes     ++ concatMap fixedOps [ITFixed IT8, ITFixed IT16, ITFixed IT32, ITFixed IT64] -- ITNative, ITChar, ATFloat ] ++ vecTypes@@ -287,10 +294,10 @@       thisTy = AType $ ATInt ity       appendFun en = Prim (sUN $ "prim__append" ++ tyName ++ show en)                          (ty [BufferType, b64, b64, thisTy] BufferType)-                         4 (p_cantreduce) (4, LAppend ity en) partial+                         4 (p_append en) (4, LAppend ity en) partial       peekFun en = Prim (sUN $ "prim__peek" ++ tyName ++ show en)                          (ty [BufferType, b64] thisTy)-                         2 (p_cantreduce) (2, LPeek ity en) partial+                         2 (p_peek ity en) (2, LPeek ity en) partial  mapHalf :: (V.Unbox a, V.Unbox b) => ((a, a) -> b) -> Vector a -> Vector b mapHalf f xs = V.generate (V.length xs `div` 2) (\i -> f (xs V.! (i*2), xs V.! (i*2+1)))@@ -693,6 +700,53 @@ p_strRev [Str xs] = Just $ Str (reverse xs) p_strRev _ = Nothing +p_allocate, p_appendBuffer :: [Const] -> Maybe Const+p_allocate [B64 _] = Just $ B8V V.empty+p_allocate n = Nothing+p_appendBuffer [B8V vect1, B64 size1, B64 count, B64 size2, B64 off, B8V vect2] =+    Just $ B8V (foldl (V.++)+                      (V.slice 0 (fromIntegral size1) vect1)+                      (replicate (fromIntegral count) (V.slice (fromIntegral off) (fromIntegral size2) vect2)))+p_appendBuffer n = Nothing+p_append :: Endianness -> [Const] -> Maybe Const+p_append en [B8V vect, B64 size, B64 count, val] =+    let bytes = case val of+                  B8 x -> [x]+                  B16 x -> [fromIntegral x, fromIntegral (shiftR x 8)]+                  B32 x -> map (fromIntegral . shiftR x) [0,8..24]+                  B64 x -> map (fromIntegral . shiftR x) [0,8..56]+    in Just $ B8V (foldl V.snoc+                         (V.slice 0 (fromIntegral size) vect)+                         (concat (replicate (fromIntegral count)+                                            (case en of+                                               BE -> reverse bytes+                                               _  -> bytes))))+p_append _ _ = Nothing++p_peek :: IntTy -> Endianness -> [Const] -> Maybe Const+p_peek (ITFixed IT8)  _ [B8V vect, B64 offset] = Just $ B8 (vect V.! fromIntegral offset)+p_peek (ITFixed IT16) en [B8V vect, B64 offset] =+    let bytes = [0..1]+    in Just $ B16 (foldl (\full byte -> shiftL full 8 .|. fromIntegral (vect V.! (fromIntegral offset+byte)))+                         0+                         (case en of+                            BE -> bytes+                            _  -> reverse bytes))+p_peek (ITFixed IT32) en [B8V vect, B64 offset] =+    let bytes = [0..1]+    in Just $ B32 (foldl (\full byte -> shiftL full 8 .|. fromIntegral (vect V.! (fromIntegral offset+byte)))+                         0+                         (case en of+                            BE -> bytes+                            _  -> reverse bytes))+p_peek (ITFixed IT64) en [B8V vect, B64 offset] =+    let bytes = [0..1]+    in Just $ B64 (foldl (\full byte -> shiftL full 8 .|. fromIntegral (vect V.! (fromIntegral offset+byte)))+                         0+                         (case en of+                            BE -> bytes+                            _  -> reverse bytes))+p_peek _ _ _ = Nothing+ p_cantreduce :: a -> Maybe b p_cantreduce _ = Nothing-
src/Idris/ProofSearch.hs view
@@ -14,6 +14,8 @@  import Control.Applicative ((<$>)) import Control.Monad+import Control.Monad.State.Strict+import Data.List import Debug.Trace  -- Pass in a term elaborator to avoid a cyclic dependency with ElabTerm@@ -36,15 +38,55 @@                              (tryAll xs) True                    else tryAll xs -proofSearch :: (PTerm -> ElabD ()) -> Maybe Name -> Name -> [Name] ->+cantSolveGoal :: ElabD ()+cantSolveGoal = do g <- goal+                   env <- get_env+                   lift $ tfail $+                      CantSolveGoal g (map (\(n,b) -> (n, binderTy b)) env) ++proofSearch :: Bool -> +               Bool -> -- invoked from a tactic proof. If so, making+                       -- new metavariables is meaningless, and there shoudl+                       -- be an error reported instead.+               Int -> -- maximum depth+               (PTerm -> ElabD ()) -> Maybe Name -> Name -> [Name] ->                IState -> ElabD ()-proofSearch elab fn nroot hints ist +proofSearch False fromProver depth elab _ nroot [fn] ist+       = do -- get all possible versions of the name, take the first one that+            -- works+            let all_imps = lookupCtxtName fn (idris_implicits ist)+            tryAllFns all_imps+  where+    -- if nothing worked, make a new metavariable+    tryAllFns [] | fromProver = cantSolveGoal  +    tryAllFns [] = do attack; defer nroot; solve+    tryAllFns (f : fs) = try' (tryFn f) (tryAllFns fs) True++    tryFn (f, args) = do let imps = map isImp args+                         ps <- get_probs+                         hs <- get_holes+                         args <- map snd <$> try' (apply (Var f) imps)+                                                  (match_apply (Var f) imps) True+                         ps' <- get_probs+--                          when (length ps < length ps') $ fail "Can't apply constructor"+                         -- Make metavariables for new holes +                         hs' <- get_holes+                         ptm <- get_term+                         if fromProver then cantSolveGoal+                           else do+                             mapM_ (\ h -> do focus h+                                              attack; defer nroot; solve) +                                 (hs' \\ hs)+--                                  (filter (\ (x, y) -> not x) (zip (map fst imps) args))+                             solve++    isImp (PImp p _ _ _ _) = (True, p)+    isImp arg = (True, priority arg) -- try to get all of them by unification+proofSearch rec fromProver maxDepth elab fn nroot hints ist         = case lookupCtxt nroot (idris_tyinfodata ist) of               [TISolution ts] -> findInferredTy ts-              _ -> psRec maxDepth+              _ -> psRec rec maxDepth   where-    maxDepth = 6-     findInferredTy (t : _) = elab (delab ist (toUN t))       toUN t@(P nt (MN i n) ty) @@ -53,12 +95,16 @@     toUN (App f a) = App (toUN f) (toUN a)     toUN t = t -    psRec 0 = do attack; defer nroot; solve --fail "Maximum depth reached"-    psRec d = try' (trivial elab ist)-                   (try' (try' (resolveByCon (d - 1)) (resolveByLocals (d - 1))-                               True)+    psRec _ 0 | fromProver = cantSolveGoal+    psRec rec 0 = do attack; defer nroot; solve --fail "Maximum depth reached"+    psRec False d = tryCons d hints +    psRec True d = try' (trivial elab ist)+                        (try' (try' (resolveByCon (d - 1)) (resolveByLocals (d - 1))+                              True)              -- if all else fails, make a new metavariable-                         (do attack; defer nroot; solve) True) True+                         (if fromProver +                             then cantSolveGoal+                             else do attack; defer nroot; solve) True) True      getFn d Nothing = []     getFn d (Just f) | d < maxDepth-1 = [f]@@ -91,7 +137,7 @@      tryLocalArg d n 0 = elab (PRef (fileFC "prf") n)     tryLocalArg d n i = simple_app (tryLocalArg d n (i - 1))-                                   (psRec d) "proof search local apply"+                                   (psRec True d) "proof search local apply"      -- Like type class resolution, but searching with constructors     tryCon d n =@@ -100,15 +146,17 @@                             [args] -> map isImp (snd args)                             _ -> fail "Ambiguous name"             ps <- get_probs+            hs <- get_holes             args <- map snd <$> try' (apply (Var n) imps)                                      (match_apply (Var n) imps) True             ps' <- get_probs+            hs' <- get_holes             when (length ps < length ps') $ fail "Can't apply constructor"             mapM_ (\ (_, h) -> do focus h-                                  psRec d)+                                  psRec True d)                    (filter (\ (x, y) -> not x) (zip (map fst imps) args))             solve      isImp (PImp p _ _ _ _) = (True, p)-    isImp arg = (False, priority arg)+    isImp arg = (False, priority arg)
src/Idris/Prover.hs view
@@ -7,6 +7,7 @@ import Idris.Core.Typecheck  import Idris.AbsSyntax+import Idris.AbsSyntaxTree import Idris.Delaborate import Idris.ElabDecls import Idris.ElabTerm@@ -33,7 +34,7 @@               i <- getIState               case lookupTy x ctxt of                   [t] -> if elem x (map fst (idris_metavars i))-                               then prove ctxt lit x t+                               then prove (idris_optimisation i) ctxt lit x t                                else ifail $ show x ++ " is not a metavariable"                   _ -> fail "No such metavariable" @@ -56,8 +57,8 @@         names ((MN _ _, _) : bs) = names bs         names ((n, _) : bs) = show n : names bs -prove :: Context -> Bool -> Name -> Type -> Idris ()-prove ctxt lit n ty+prove :: Ctxt OptInfo -> Context -> Bool -> Name -> Type -> Idris ()+prove opt ctxt lit n ty     = do let ps = initElaborator n ctxt ty          ideslavePutSExp "start-proof-mode" n          (tm, prf) <- ploop n True ("-" ++ show n) [] (ES (ps, []) "" Nothing) Nothing@@ -67,7 +68,7 @@          ideslavePutSExp "end-proof-mode" n          let proofs = proof_list i          putIState (i { proof_list = (n, prf) : proofs })-         let tree = simpleCase False True False CompileTime (fileFC "proof") [] [([], P Ref n ty, tm)]+         let tree = simpleCase False True False CompileTime (fileFC "proof") [] [] [([], P Ref n ty, tm)]          logLvl 3 (show tree)          (ptm, pty) <- recheckC (fileFC "proof") [] tm          logLvl 5 ("Proof type: " ++ show pty ++ "\n" ++@@ -77,17 +78,26 @@               Error e -> ierror (CantUnify False ty pty e [] 0)          ptm' <- applyOpts ptm          updateContext (addCasedef n (CaseInfo True False) False False True False-                                 []+                                 [] []  -- argtys, inaccArgs                                  [Right (P Ref n ty, ptm)]                                  [([], P Ref n ty, ptm)]                                  [([], P Ref n ty, ptm)]                                  [([], P Ref n ty, ptm)]                                  [([], P Ref n ty, ptm')] ty)          solveDeferred n+ elabStep :: ElabState [PDecl] -> ElabD a -> Idris (a, ElabState [PDecl])-elabStep st e = do case runStateT e st of+elabStep st e = case runStateT eCheck st of                      OK (a, st') -> return (a, st')                      Error a -> ierror a+  where eCheck = do res <- e+                    probs' <- get_probs+                    case probs' of+                         [] -> do tm <- get_term+                                  ctxt <- get_context+                                  lift $ check ctxt [] (forget tm)+                                  return res+                         ((_,_,_,e,_,_):_) -> lift $ Error e  dumpState :: IState -> ProofState -> Idris () dumpState ist (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) =@@ -103,9 +113,9 @@   iputGoal rendered    where-    showImplicits = opt_showimp (idris_options ist)+    ppo = ppOptionIst ist -    tPretty bnd t = pprintPTerm showImplicits bnd [] $ delab ist t+    tPretty bnd t = pprintPTerm ppo bnd [] (idris_infixes ist) $ delab ist t      assumptionNames :: Env -> [Name]     assumptionNames = map fst@@ -115,10 +125,11 @@     prettyPs bnd ((n@(MN _ r), _) : bs)         | r == txt "rewrite_rule" = prettyPs ((n, False):bnd) bs     prettyPs bnd ((n, Let t v) : bs) =-      nest nestingSize (bindingOf n False <+> text "=" <+> tPretty bnd v <> colon <+>-        tPretty ((n, False):bnd) t <> line <> prettyPs ((n, False):bnd) bs)+      line <> bindingOf n False <+> text "=" <+> tPretty bnd v <+> colon <+>+        align (tPretty bnd t) <> prettyPs ((n, False):bnd) bs     prettyPs bnd ((n, b) : bs) =-      line <> bindingOf n False <+> colon <+> align (tPretty bnd (binderTy b)) <> prettyPs ((n, False):bnd) bs+      line <> bindingOf n False <+> colon <+>+      align (tPretty bnd (binderTy b)) <> prettyPs ((n, False):bnd) bs      prettyG bnd (Guess t v) = tPretty bnd t <+> text "=?=" <+> tPretty bnd v     prettyG bnd b = tPretty bnd $ binderTy b@@ -230,15 +241,16 @@                            ctxt'  = envCtxt env ctxt                        putIState ist { tt_ctxt = ctxt' }                        (tm, ty) <- elabVal toplevel False t-                       let imp = opt_showimp (idris_options ist)-                           ty' = normaliseC ctxt [] ty-                           h   = idris_outh ist+                       let ppo = ppOptionIst ist+                           ty'     = normaliseC ctxt [] ty+                           h       = idris_outh ist+                           infixes = idris_infixes ist                        case tm of                           TType _ ->-                            ihPrintTermWithType h (prettyImp imp PType) type1Doc+                            ihPrintTermWithType h (prettyImp ppo PType) type1Doc                           _ -> let bnd = map (\x -> (fst x, False)) env in-                               ihPrintTermWithType h (pprintPTerm imp bnd [] (delab ist tm))-                                                     (pprintPTerm imp bnd [] (delab ist ty))+                               ihPrintTermWithType h (pprintPTerm ppo bnd [] infixes (delab ist tm))+                                                     (pprintPTerm ppo bnd [] infixes (delab ist ty))                        putIState ist                        return (False, e, False, prf))                      (\err -> do putIState ist { tt_ctxt = ctxt } ; ierror err)@@ -252,11 +264,12 @@                                                bnd    = map (\x -> (fst x, False)) env                                            putIState ist'                                            (tm, ty) <- elabVal toplevel False t-                                           let tm'    = force (normaliseAll ctxt' env tm)-                                               ty'    = force (normaliseAll ctxt' env ty)-                                               imp    = opt_showimp (idris_options ist')-                                               tmDoc  = pprintPTerm imp bnd [] (delab ist' tm')-                                               tyDoc  = pprintPTerm imp bnd [] (delab ist' ty')+                                           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                                            putIState ist                                            return (False, e, False, prf))
src/Idris/Providers.hs view
@@ -11,7 +11,8 @@  -- | Wrap a type provider in the type of type providers providerTy :: FC -> PTerm -> PTerm-providerTy fc tm = PApp fc (PRef fc $ sUN "Provider") [PExp 0 [] tm]+providerTy fc tm +  = PApp fc (PRef fc $ sUN "Provider") [PExp 0 [] (sMN 0 "pvarg") tm]  ioret = sUN "prim_io_return" ermod = sNS (sUN "Error") ["Providers"]
src/Idris/REPL.hs view
@@ -4,19 +4,21 @@ module Idris.REPL where  import Idris.AbsSyntax+import Idris.ASTUtils import Idris.Apropos (apropos) import Idris.REPLParser import Idris.ElabDecls import Idris.ElabTerm+import Idris.Erasure import Idris.Error import Idris.ErrReverse import Idris.Delaborate import Idris.Docstrings (Docstring, overview, renderDocstring)+import Idris.IdrisDoc import Idris.Prover-import Idris.Parser+import Idris.Parser hiding (indent) import Idris.Primitives import Idris.Coverage-import Idris.UnusedArgs import Idris.Docs hiding (Doc) import Idris.Help import Idris.Completion@@ -28,6 +30,9 @@ import Idris.CaseSplit import Idris.DeepSeq import Idris.Output+import Idris.Interactive+import Idris.WhoCalls+import Idris.TypeSearch (searchByType)  import Paths_idris import Version_idris (gitHash)@@ -77,10 +82,9 @@ import Data.Char import Data.Version import Data.Word (Word)+import Data.Either (partitionEithers) import Control.DeepSeq -import qualified Text.PrettyPrint.ANSI.Leijen as ANSI- import Debug.Trace  -- | Run the REPL@@ -163,8 +167,8 @@               Left err -> do hPutStrLn h (show err)                              return (i, fn)   where-    processNet fn Reload = processNet fn (Load fn)-    processNet fn (Load f) =+    processNet fn Reload = processNet fn (Load fn Nothing)+    processNet fn (Load f toline) =         do let ist = orig { idris_options = idris_options i                           , idris_colourTheme = idris_colourTheme i                           , idris_colourRepl = False@@ -174,7 +178,7 @@            setOutH h            setQuiet True            setVerbose False-           mods <- loadInputs h [f]+           mods <- loadInputs h [f] toline            ist <- getIState            return (ist, f)     processNet fn c = do process h fn c@@ -218,84 +222,171 @@                               (f:_) -> f                               _ -> ""                    case IdeSlave.sexpToCommand sexp of-                     Just (IdeSlave.Interpret cmd) ->-                       do c <- colourise-                          case parseCmd i "(input)" cmd of-                            Failure err -> iPrintError $ show (fixColour c err)-                            Success (Prove n') -> do iPrintResult ""-                                                     idrisCatch-                                                       (process stdout fn (Prove n'))-                                                       (\e -> getIState >>= ihRenderError stdout . flip pprintErr e)-                                                     isetPrompt (mkPrompt mods)-                            Success cmd -> idrisCatch-                                             (ideslaveProcess fn cmd)-                                             (\e -> getIState >>= ihRenderError stdout . flip pprintErr e)-                     Just (IdeSlave.REPLCompletions str) ->-                       do (unused, compls) <- replCompletion (reverse str, "")-                          let good = IdeSlave.SexpList [IdeSlave.SymbolAtom "ok", IdeSlave.toSExp (map replacement compls, reverse unused)]-                          runIO $ putStrLn $ IdeSlave.convSExp "return" good id-                     Just (IdeSlave.LoadFile filename) ->-                       do clearErr-                          putIState (orig { idris_options = idris_options i,-                                            idris_outputmode = (IdeSlave id) })-                          loadInputs stdout [filename]-                          isetPrompt (mkPrompt [filename])-                          -- Report either success or failure-                          i <- getIState-                          case (errSpan i) of-                            Nothing -> iPrintResult $ "loaded " ++ filename-                            Just x -> iPrintError $ "didn't load " ++ filename-                          ideslave orig [filename]-                     Just (IdeSlave.TypeOf name) ->-                       case splitName name of-                         Left err -> iPrintError err-                         Right n -> process stdout "(ideslave)"-                                      (Check (PRef (FC "(ideslave)" (0,0) (0,0)) n))-                     Just (IdeSlave.DocsFor name) ->-                       case splitName name of-                         Left err -> iPrintError err-                         Right n -> process stdout "(ideslave)" (DocStr n)-                     Just (IdeSlave.CaseSplit line name) ->-                       process stdout fn (CaseSplitAt False line (sUN name))-                     Just (IdeSlave.AddClause line name) ->-                       process stdout fn (AddClauseFrom False line (sUN name))-                     Just (IdeSlave.AddProofClause line name) ->-                       process stdout fn (AddProofClauseFrom False line (sUN name))-                     Just (IdeSlave.AddMissing line name) ->-                       process stdout fn (AddMissing False line (sUN name))-                     Just (IdeSlave.MakeWithBlock line name) ->-                       process stdout fn (MakeWith False line (sUN name))-                     Just (IdeSlave.ProofSearch line name hints) ->-                       process stdout fn (DoProofSearch False line (sUN name) (map sUN hints))-                     Just (IdeSlave.Apropos a) ->-                       process stdout fn (Apropos a)-                     Just (IdeSlave.GetOpts) ->-                       do ist <- getIState-                          let opts = idris_options ist-                          let impshow = opt_showimp opts-                          let errCtxt = opt_errContext opts-                          let options = (IdeSlave.SymbolAtom "ok",-                                         [(IdeSlave.SymbolAtom "show-implicits", impshow),-                                          (IdeSlave.SymbolAtom "error-context", errCtxt)])-                          runIO . putStrLn $ IdeSlave.convSExp "return" options id-                     Just (IdeSlave.SetOpt IdeSlave.ShowImpl b) ->-                       do setImpShow b-                          let msg = (IdeSlave.SymbolAtom "ok", b)-                          runIO . putStrLn $ IdeSlave.convSExp "return" msg id-                     Just (IdeSlave.SetOpt IdeSlave.ErrContext b) ->-                       do setErrContext b-                          let msg = (IdeSlave.SymbolAtom "ok", b)-                          runIO . putStrLn $ IdeSlave.convSExp "return" msg id-                     Nothing -> do iPrintError "did not understand")+                     Just cmd -> runIdeSlaveCommand id orig fn mods cmd+                     Nothing  -> iPrintError "did not understand" )                (\e -> do iPrintError $ show e))          (\e -> do iPrintError $ show e)        ideslave orig mods++-- | Run IDESlave commands+runIdeSlaveCommand :: Integer -- ^^ The continuation ID for the client+                   -> IState -- ^^ The original IState+                   -> FilePath -- ^^ The current open file+                   -> [FilePath] -- ^^ The currently loaded modules+                   -> IdeSlave.IdeSlaveCommand -- ^^ The command to process+                   -> Idris ()+runIdeSlaveCommand id orig fn mods (IdeSlave.Interpret cmd) =+  do c <- colourise+     i <- getIState+     case parseCmd i "(input)" cmd of+       Failure err -> iPrintError $ show (fixColour c err)+       Success (Prove n') -> do iPrintResult ""+                                idrisCatch+                                  (process stdout fn (Prove n'))+                                  (\e -> getIState >>= ihRenderError stdout . flip pprintErr e)+                                isetPrompt (mkPrompt mods)+       Success cmd -> idrisCatch+                        (ideslaveProcess fn cmd)+                        (\e -> getIState >>= ihRenderError stdout . flip pprintErr e)+runIdeSlaveCommand id orig fn mods (IdeSlave.REPLCompletions str) =+  do (unused, compls) <- replCompletion (reverse str, "")+     let good = IdeSlave.SexpList [IdeSlave.SymbolAtom "ok",+                                   IdeSlave.toSExp (map replacement compls,+                                   reverse unused)]+     runIO $ putStrLn $ IdeSlave.convSExp "return" good id+runIdeSlaveCommand id orig fn mods (IdeSlave.LoadFile filename toline) =+  do i <- getIState+     clearErr+     putIState (orig { idris_options = idris_options i,+                       idris_outputmode = (IdeSlave id) })+     loadInputs stdout [filename] toline+     isetPrompt (mkPrompt [filename])+     -- Report either success or failure+     i <- getIState+     case (errSpan i) of+       Nothing -> let msg = maybe (IdeSlave.SexpList [IdeSlave.SymbolAtom "ok",+                                                      IdeSlave.SexpList []])+                                  (\fc -> IdeSlave.SexpList [IdeSlave.SymbolAtom "ok",+                                                             IdeSlave.toSExp fc])+                                  (idris_parsedSpan i)+                  in runIO . putStrLn $ IdeSlave.convSExp "return" msg id+       Just x -> iPrintError $ "didn't load " ++ filename+     ideslave orig [filename]+runIdeSlaveCommand id orig fn mods (IdeSlave.TypeOf name) =+  case splitName name of+    Left err -> iPrintError err+    Right n -> process stdout "(ideslave)"+                 (Check (PRef (FC "(ideslave)" (0,0) (0,0)) n))   where splitName :: String -> Either String Name         splitName s = case reverse $ splitOn "." s of                         [] -> Left ("Didn't understand name '" ++ s ++ "'")                         [n] -> Right $ sUN n                         (n:ns) -> Right $ sNS (sUN n) ns+runIdeSlaveCommand id orig fn mods (IdeSlave.DocsFor name) =+  case parseConst orig name of+    Success c -> process stdout "(ideslave)" (DocStr (Right c))+    Failure _ ->+     case splitName name of+       Left err -> iPrintError err+       Right n -> process stdout "(ideslave)" (DocStr (Left n))+runIdeSlaveCommand id orig fn mods (IdeSlave.CaseSplit line name) =+  process stdout fn (CaseSplitAt False line (sUN name))+runIdeSlaveCommand id orig fn mods (IdeSlave.AddClause line name) =+  process stdout fn (AddClauseFrom False line (sUN name))+runIdeSlaveCommand id orig fn mods (IdeSlave.AddProofClause line name) =+  process stdout fn (AddProofClauseFrom False line (sUN name))+runIdeSlaveCommand id orig fn mods (IdeSlave.AddMissing line name) =+  process stdout fn (AddMissing False line (sUN name))+runIdeSlaveCommand id orig fn mods (IdeSlave.MakeWithBlock line name) =+  process stdout fn (MakeWith False line (sUN name))+runIdeSlaveCommand id orig fn mods (IdeSlave.ProofSearch r line name hints depth) =+  doProofSearch stdout fn False r line (sUN name) (map sUN hints) depth+runIdeSlaveCommand id orig fn mods (IdeSlave.MakeLemma line name) =+  case splitName name of+    Left err -> iPrintError err+    Right n -> process stdout fn (MakeLemma False line n)+runIdeSlaveCommand id orig fn mods (IdeSlave.Apropos a) =+  process stdout fn (Apropos a)+runIdeSlaveCommand id orig fn mods (IdeSlave.GetOpts) =+  do ist <- getIState+     let opts = idris_options ist+     let impshow = opt_showimp opts+     let errCtxt = opt_errContext opts+     let options = (IdeSlave.SymbolAtom "ok",+                    [(IdeSlave.SymbolAtom "show-implicits", impshow),+                     (IdeSlave.SymbolAtom "error-context", errCtxt)])+     runIO . putStrLn $ IdeSlave.convSExp "return" options id+runIdeSlaveCommand id orig fn mods (IdeSlave.SetOpt IdeSlave.ShowImpl b) =+  do setImpShow b+     let msg = (IdeSlave.SymbolAtom "ok", b)+     runIO . putStrLn $ IdeSlave.convSExp "return" msg id+runIdeSlaveCommand id orig fn mods (IdeSlave.SetOpt IdeSlave.ErrContext b) =+  do setErrContext b+     let msg = (IdeSlave.SymbolAtom "ok", b)+     runIO . putStrLn $ IdeSlave.convSExp "return" msg id+runIdeSlaveCommand id orig fn mods (IdeSlave.Metavariables cols) =+  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)+runIdeSlaveCommand id orig fn mods (IdeSlave.WhoCalls n) =+  case splitName n of+       Left err -> iPrintError err+       Right n -> do calls <- whoCalls n+                     ist <- getIState+                     let msg = (IdeSlave.SymbolAtom "ok",+                                map (\ (n,ns) -> (pn ist n, map (pn ist) ns)) calls)+                     runIO . putStrLn $ IdeSlave.convSExp "return" msg id+  where pn ist = displaySpans .+                 renderPretty 0.9 1000 .+                 fmap (fancifyAnnots ist) .+                 prettyName True []+runIdeSlaveCommand id orig fn mods (IdeSlave.CallsWho n) =+  case splitName n of+       Left err -> iPrintError err+       Right n -> do calls <- callsWho n+                     ist <- getIState+                     let msg = (IdeSlave.SymbolAtom "ok",+                                map (\ (n,ns) -> (pn ist n, map (pn ist) ns)) calls)+                     runIO . putStrLn $ IdeSlave.convSExp "return" msg id+  where pn ist = displaySpans .+                 renderPretty 0.9 1000 .+                 fmap (fancifyAnnots ist) .+                 prettyName True [] +splitName :: String -> Either String Name+splitName s = case reverse $ splitOn "." s of+                [] -> Left ("Didn't understand name '" ++ s ++ "'")+                [n] -> Right $ sUN n+                (n:ns) -> Right $ sNS (sUN n) ns+ ideslaveProcess :: FilePath -> Command -> Idris () ideslaveProcess fn Help = process stdout fn Help ideslaveProcess fn (ChangeDirectory f) = do process stdout fn (ChangeDirectory f)@@ -311,7 +402,6 @@ ideslaveProcess fn (TotCheck n) = process stdout fn (TotCheck n) ideslaveProcess fn (DebugInfo n) = do process stdout fn (DebugInfo n)                                       iPrintResult ""-ideslaveProcess fn (Info n) = process stdout fn (Info n) ideslaveProcess fn (Search t) = process stdout fn (Search t) ideslaveProcess fn (Spec t) = process stdout fn (Spec t) -- RmProof and AddProof not supported!@@ -352,11 +442,13 @@ ideslaveProcess fn (AddClauseFrom False pos str) = process stdout fn (AddClauseFrom False pos str) ideslaveProcess fn (AddMissing False pos str) = process stdout fn (AddMissing False pos str) ideslaveProcess fn (MakeWith False pos str) = process stdout fn (MakeWith False pos str)-ideslaveProcess fn (DoProofSearch False pos str xs) = process stdout fn (DoProofSearch False pos str xs)+ideslaveProcess fn (DoProofSearch False r pos str xs) = process stdout fn (DoProofSearch False r pos str xs) ideslaveProcess fn (SetConsoleWidth w) = do process stdout fn (SetConsoleWidth w)                                             iPrintResult "" ideslaveProcess fn (Apropos a) = do process stdout fn (Apropos a)                                     iPrintResult ""+ideslaveProcess fn (WhoCalls n) = process stdout fn (WhoCalls n)+ideslaveProcess fn (CallsWho n) = process stdout fn (CallsWho n) ideslaveProcess fn _ = iPrintError "command not recognized or not supported"  @@ -388,14 +480,14 @@                                     , idris_colourTheme = idris_colourTheme i                                     }                    clearErr-                   mods <- loadInputs stdout inputs+                   mods <- loadInputs stdout inputs Nothing                    return (Just inputs)-            Success (Load f) ->+            Success (Load f toline) ->                 do putIState orig { idris_options = idris_options i                                   , idris_colourTheme = idris_colourTheme i                                   }                    clearErr-                   mod <- loadInputs stdout [f]+                   mod <- loadInputs stdout [f] toline                    return (Just [f])             Success (ModImport f) ->                 do clearErr@@ -444,7 +536,7 @@          putIState $ orig { idris_options = idris_options i                           , idris_colourTheme = idris_colourTheme i                           }-         loadInputs stdout [f]+         loadInputs stdout [f] Nothing --          clearOrigPats          iucheck          return ()@@ -476,7 +568,8 @@                  = do runIO $ setCurrentDirectory f                       return () process h fn (Eval t)-                 = withErrorReflection $ do (tm, ty) <- elabVal toplevel False t+                 = withErrorReflection $ do logLvl 5 $ show t+                                            (tm, ty) <- elabVal toplevel False t                                             ctxt <- getContext                                             let tm' = force (normaliseAll ctxt [] tm)                                             let ty' = force (normaliseAll ctxt [] ty)@@ -485,41 +578,39 @@                                             ist <- getIState                                             logLvl 3 $ "Raw: " ++ show (tm', ty')                                             logLvl 10 $ "Debug: " ++ showEnvDbg [] tm'-                                            let imp = opt_showimp (idris_options ist)-                                                tmDoc = prettyImp imp (delab ist tm')-                                                tyDoc = prettyImp imp (delab ist ty')+                                            let tmDoc = prettyIst ist (delab ist tm')+                                                tyDoc = prettyIst ist (delab ist ty')                                             ihPrintTermWithType h tmDoc tyDoc  process h fn (ExecVal t)                   = do ctxt <- getContext                        ist <- getIState-                       let imp = opt_showimp (idris_options ist)                        (tm, ty) <- elabVal toplevel False t --                       let tm' = normaliseAll ctxt [] tm                        let ty' = normaliseAll ctxt [] ty                        res <- execute tm-                       let (resOut, tyOut) = (prettyImp imp (delab ist res),-                                              prettyImp imp (delab ist ty'))+                       let (resOut, tyOut) = (prettyIst ist (delab ist res),+                                              prettyIst ist (delab ist ty'))                        ihPrintTermWithType h resOut tyOut  process h fn (Check (PRef _ n))    = do ctxt <- getContext         ist <- getIState-        imp <- impShow+        let ppo = ppOptionIst ist         case lookupNames n ctxt of           ts@(t:_) ->             case lookup t (idris_metavars ist) of                 Just (_, i, _) -> ihRenderResult h . fmap (fancifyAnnots ist) $-                                  showMetavarInfo imp ist n i+                                  showMetavarInfo ppo ist n i                 Nothing -> ihPrintFunTypes h [] n (map (\n -> (n, delabTy ist n)) ts)           [] -> ihPrintError h $ "No such variable " ++ show n   where-    showMetavarInfo imp ist n i+    showMetavarInfo ppo ist n i          = case lookupTy n (tt_ctxt ist) of-                (ty:_) -> putTy imp ist i [] (delab ist (errReverse ist ty))-    putTy :: Bool -> IState -> Int -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation-    putTy imp ist 0 bnd sc = putGoal imp ist bnd sc-    putTy imp ist i bnd (PPi _ n t sc)+                (ty:_) -> putTy ppo ist i [] (delab ist (errReverse ist ty))+    putTy :: PPOption -> IState -> Int -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation+    putTy ppo ist 0 bnd sc = putGoal ppo ist bnd sc+    putTy ppo ist i bnd (PPi _ n t sc)                = let current = text "  " <>                                (case n of                                    MN _ _ -> text "_"@@ -527,37 +618,41 @@                                    _ -> bindingOf n False) <+>                                colon <+> align (tPretty bnd ist t) <> line                  in-                    current <> putTy imp ist (i-1) ((n,False):bnd) sc-    putTy imp ist _ bnd sc = putGoal imp ist ((n,False):bnd) sc-    putGoal imp ist bnd g+                    current <> putTy ppo ist (i-1) ((n,False):bnd) sc+    putTy ppo ist _ bnd sc = putGoal ppo ist ((n,False):bnd) sc+    putGoal ppo ist bnd g                = text "--------------------------------------" <$>                  annotate (AnnName n Nothing Nothing Nothing) (text $ show n) <+> colon <+>                  align (tPretty bnd ist g) -    tPretty bnd ist t = pprintPTerm (opt_showimp (idris_options ist)) bnd [] t+    tPretty bnd ist t = pprintPTerm (ppOptionIst ist) bnd [] (idris_infixes ist) t   process h fn (Check t)    = do (tm, ty) <- elabVal toplevel False t         ctxt <- getContext         ist <- getIState-        let imp = opt_showimp (idris_options ist)+        let ppo = ppOptionIst ist             ty' = normaliseC ctxt [] ty         case tm of            TType _ ->-             ihPrintTermWithType h (prettyImp imp PType) type1Doc-           _ -> ihPrintTermWithType h (prettyImp imp (delab ist tm))-                                      (prettyImp imp (delab ist ty))+             ihPrintTermWithType h (prettyIst ist PType) type1Doc+           _ -> ihPrintTermWithType h (prettyIst ist (delab ist tm))+                                      (prettyIst ist (delab ist ty)) -process h fn (DocStr n)-   = do i <- getIState-        let imp = opt_showimp (idris_options i)-        case lookupCtxtName n (idris_docstrings i) of+process h fn (DocStr (Left n))+   = do ist <- getIState+        case lookupCtxtName n (idris_docstrings ist) of           [] -> iPrintError $ "No documentation for " ++ show n-          ns -> do toShow <- mapM (showDoc imp) ns+          ns -> do toShow <- mapM (showDoc ist) ns                    ihRenderResult h (vsep toShow)-    where showDoc imp (n, d) = do doc <- getDocs n-                                  return $ pprintDocs imp doc+    where showDoc ist (n, d) = do doc <- getDocs n+                                  return $ pprintDocs ist doc++process h fn (DocStr (Right c))+   = do ist <- getIState+        ihRenderResult h $ pprintConstDocs ist c (constDocs c)+ process h fn Universes                      = do i <- getIState                           let cs = idris_constraints i@@ -589,8 +684,8 @@                                 []  -> ihPrintError h $ "Unknown operator " ++ show n                                 ts  -> do ist <- getIState                                           c <- colourise-                                          imp <- impShow-                                          let showN = showName (Just ist) [] imp c+                                          let ppo =  ppOptionIst ist+                                          let showN = showName (Just ist) [] ppo c                                           ihPrintResult h . concat . intersperse "\n" .                                             map (\(n, t) -> showN n ++ " is " ++ showTotal t i) $                                             ts@@ -607,197 +702,27 @@         let d = lookupDef n (tt_ctxt i)         when (not (null d)) $ iputStrLn $ "Definition: " ++ (show (head d))         let cg = lookupCtxtName n (idris_callgraph i)-        findUnusedArgs (map fst cg)         i <- getIState         let cg' = lookupCtxtName n (idris_callgraph i)         sc <- checkSizeChange n         iputStrLn $ "Size change: " ++ show sc         when (not (null cg')) $ do iputStrLn "Call graph:\n"                                    iputStrLn (show cg')-process h fn (Info n)-                    = do i <- getIState-                         case lookupCtxt n (idris_classes i) of-                              [c] -> classInfo c-                              _ -> iPrintError "Not a class"-process h fn (Search t) = iPrintError "Not implemented"--- FIXME: There is far too much repetition in the cases below!-process h fn (CaseSplitAt updatefile l n)-   = do src <- runIO $ readFile fn-        res <- splitOnLine l n fn-        iLOG (showSep "\n" (map show res))-        let (before, (ap : later)) = splitAt (l-1) (lines src)-        res' <- replaceSplits ap res-        let new = concat res'-        if updatefile-          then do let fb = fn ++ "~" -- make a backup!-                  runIO $ writeFile fb (unlines before ++ new ++ unlines later)-                  runIO $ copyFile fb fn-          else -- do ihputStrLn h (show res)-            ihPrintResult h new+process h fn (Search t) = searchByType h t+process h fn (CaseSplitAt updatefile l n) +    = caseSplitAt h fn updatefile l n process h fn (AddClauseFrom updatefile l n)-   = do src <- runIO $ readFile fn-        let (before, tyline : later) = splitAt (l-1) (lines src)-        let indent = getIndent 0 (show n) tyline-        cl <- getClause l n fn-        -- add clause before first blank line in 'later'-        let (nonblank, rest) = span (not . all isSpace) (tyline:later)-        if updatefile-          then do let fb = fn ++ "~"-                  runIO $ writeFile fb (unlines (before ++ nonblank) ++-                                        replicate indent ' ' ++-                                        cl ++ "\n" ++-                                        unlines rest)-                  runIO $ copyFile fb fn-          else ihPrintResult h cl-    where-       getIndent i n [] = 0-       getIndent i n xs | take (length n) xs == n = i-       getIndent i n (x : xs) = getIndent (i + 1) n xs+    = addClauseFrom h fn updatefile l n process h fn (AddProofClauseFrom updatefile l n)-   = do src <- runIO $ readFile fn-        let (before, tyline : later) = splitAt (l-1) (lines src)-        let indent = getIndent 0 (show n) tyline-        cl <- getProofClause l n fn-        -- add clause before first blank line in 'later'-        let (nonblank, rest) = span (not . all isSpace) (tyline:later)-        if updatefile-          then do let fb = fn ++ "~"-                  runIO $ writeFile fb (unlines (before ++ nonblank) ++-                                        replicate indent ' ' ++-                                        cl ++ "\n" ++-                                        unlines rest)-                  runIO $ copyFile fb fn-          else ihPrintResult h cl-    where-       getIndent i n [] = 0-       getIndent i n xs | take (length n) xs == n = i-       getIndent i n (x : xs) = getIndent (i + 1) n xs+    = addProofClauseFrom h fn updatefile l n process h fn (AddMissing updatefile l n)-   = do src <- runIO $ readFile fn-        let (before, tyline : later) = splitAt (l-1) (lines src)-        let indent = getIndent 0 (show n) tyline-        i <- getIState-        cl <- getInternalApp fn l-        let n' = getAppName cl--        extras <- case lookupCtxt n' (idris_patdefs i) of-                       [] -> return ""-                       [(_, tms)] -> do tms' <- nameMissing tms-                                        showNew (show n ++ "_rhs") 1 indent tms'-        let (nonblank, rest) = span (not . all isSpace) (tyline:later)-        if updatefile-          then do let fb = fn ++ "~"-                  runIO $ writeFile fb (unlines (before ++ nonblank)-                                        ++ extras ++ unlines rest)-                  runIO $ copyFile fb fn-          else ihPrintResult h extras-    where showPat = show . stripNS-          stripNS tm = mapPT dens tm where-              dens (PRef fc n) = PRef fc (nsroot n)-              dens t = t--          nsroot (NS n _) = nsroot n-          nsroot (SN (WhereN _ _ n)) = nsroot n-          nsroot n = n--          getAppName (PApp _ r _) = getAppName r-          getAppName (PRef _ r) = r-          getAppName _ = n--          showNew nm i ind (tm : tms)-                        = do (nm', i') <- getUniq nm i-                             rest <- showNew nm i' ind tms-                             return (replicate ind ' ' ++-                                     showPat tm ++ " = ?" ++ nm' ++-                                     "\n" ++ rest)-          showNew nm i _ [] = return ""--          getIndent i n [] = 0-          getIndent i n xs | take (length n) xs == n = i-          getIndent i n (x : xs) = getIndent (i + 1) n xs-+    = addMissing h fn updatefile l n process h fn (MakeWith updatefile l n)-   = do src <- runIO $ readFile fn-        let (before, tyline : later) = splitAt (l-1) (lines src)-        let ind = getIndent tyline-        let with = mkWith tyline n-        -- add clause before first blank line in 'later',-        -- or (TODO) before first line with same indentation as tyline-        let (nonblank, rest) = span (\x -> not (all isSpace x) &&-                                           not (ind == getIndent x)) later-        if updatefile then-           do let fb = fn ++ "~"-              runIO $ writeFile fb (unlines (before ++ nonblank)-                                        ++ with ++ "\n" ++-                                    unlines rest)-              runIO $ copyFile fb fn-           else ihPrintResult h with-  where getIndent s = length (takeWhile isSpace s)--process h fn (DoProofSearch updatefile l n hints)-    = do src <- runIO $ readFile fn-         let (before, tyline : later) = splitAt (l-1) (lines src)-         ctxt <- getContext-         mn <- case lookupNames n ctxt of-                    [x] -> return x-                    [] -> return n-                    ns -> ierror (CantResolveAlts (map show ns))-         i <- getIState-         let (top, envlen, _) = case lookup mn (idris_metavars i) of-                                  Just (t, e, False) -> (t, e, False)-                                  _ -> (Nothing, 0, True)-         let fc = fileFC fn-         let body t = PProof [Try (TSeq Intros (ProofSearch t hints))-                                  (ProofSearch t hints)]-         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)-                 ctxt <- getContext-                 i <- getIState-                 return $ show (stripNS-                           (dropCtxt envlen-                              (delab i (specialise ctxt [] [(mn, 1)] tm)))))-             (\e -> return ("?" ++ show n))-         if updatefile then-            do let fb = fn ++ "~"-               runIO $ writeFile fb (unlines before ++-                                     updateMeta False tyline (show n) newmv ++ "\n"-                                       ++ unlines later)-               runIO $ copyFile fb fn-            else ihPrintResult h newmv-    where dropCtxt 0 sc = sc-          dropCtxt i (PPi _ _ _ sc) = dropCtxt (i - 1) sc-          dropCtxt i (PLet _ _ _ sc) = dropCtxt (i - 1) sc-          dropCtxt i (PLam _ _ sc) = dropCtxt (i - 1) sc-          dropCtxt _ t = t--          stripNS tm = mapPT dens tm where-              dens (PRef fc n) = PRef fc (nsroot n)-              dens t = t--          nsroot (NS n _) = nsroot n-          nsroot (SN (WhereN _ _ n)) = nsroot n-          nsroot n = n--          updateMeta brack ('?':cs) n new-            | length cs >= length n-              = case splitAt (length n) cs of-                     (mv, c:cs) ->-                          if ((isSpace c || c == ')' || c == '}') && mv == n)-                             then addBracket brack new ++ (c : cs)-                             else '?' : mv ++ c : updateMeta True cs n new-                     (mv, []) -> if (mv == n) then addBracket brack new else '?' : mv-          updateMeta brack ('=':cs) n new = '=':updateMeta False cs n new-          updateMeta brack (c:cs) n new -              = c : updateMeta (brack || not (isSpace c)) cs n new-          updateMeta brack [] n new = ""--          addBracket False new = new-          addBracket True new@('(':xs) | last xs == ')' = new-          addBracket True new | any isSpace new = '(' : new ++ ")"-                              | otherwise = new-+    = makeWith h fn updatefile l n+process h fn (MakeLemma updatefile l n)+    = makeLemma h fn updatefile l n+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                          ctxt <- getContext@@ -823,14 +748,15 @@  process h fn' (AddProof prf)   = do fn <- do-         ex <- runIO $ doesFileExist fn'-         let fnExt = fn' <.> "idr"+         let fn'' = takeWhile (/= ' ') fn'+         ex <- runIO $ doesFileExist fn''+         let fnExt = fn'' <.> "idr"          exExt <- runIO $ doesFileExist fnExt          if ex-            then return fn'+            then return fn''             else if exExt                     then return fnExt-                    else ifail $ "Neither \""++fn'++"\" nor \""++fnExt++"\" exist"+                    else ifail $ "Neither \""++fn''++"\" nor \""++fnExt++"\" exist"        let fb = fn ++ "~"        runIO $ copyFile fn fb -- make a backup in case something goes wrong!        prog <- runIO $ readFile fb@@ -874,6 +800,7 @@           totcheck (fileFC "(input)", n)           mapM_ (\ (f,n) -> setTotality n Unchecked) (idris_totcheck i)           mapM_ checkDeclTotality (idris_totcheck i)+          warnTotality  process h fn (HNF t)                     = do (tm, ty) <- elabVal toplevel False t@@ -886,23 +813,25 @@                                 ctxt <- getContext                                 ist <- getIState                                 let tm' = inlineTerm ist tm-                                imp <- impShow                                 c <- colourise                                 iPrintResult (showTm ist (delab ist tm')) process h fn Execute-                   = do ist <- getIState-                        (m, _) <- elabVal toplevel False-                                        (PApp fc-                                           (PRef fc (sUN "run__IO"))-                                           [pexp $ PRef fc (sNS (sUN "main") ["Main"])])-                        (tmpn, tmph) <- runIO tempfile-                        runIO $ hClose tmph-                        t <- codegen-                        compile t tmpn m-                        case idris_outputmode ist of-                          RawOutput -> do runIO $ system tmpn-                                          return ()-                          IdeSlave n -> do runIO . hPutStrLn h $ IdeSlave.convSExp "run-program" tmpn n+                   = idrisCatch+                       (do ist <- getIState+                           (m, _) <- elabVal toplevel False+                                           (PApp fc+                                              (PRef fc (sUN "run__IO"))+                                              [pexp $ PRef fc (sNS (sUN "main") ["Main"])])+                           (tmpn, tmph) <- runIO tempfile+                           runIO $ hClose tmph+                           t <- codegen+                           compile t tmpn m+                           case idris_outputmode ist of+                             RawOutput -> do runIO $ system tmpn+                                             return ()+                             IdeSlave n -> runIO . hPutStrLn h $+                                           IdeSlave.convSExp "run-program" tmpn n)+                       (\e -> getIState >>= ihRenderError stdout . flip pprintErr e)   where fc = fileFC "main" process h fn (Compile codegen f)       = do (m, _) <- elabVal toplevel False@@ -920,7 +849,7 @@     = do i <- getIState          let i' = i { idris_options = (idris_options i) { opt_showimp = True } }          case lookupCtxt n (idris_patdefs i) of-                  [] -> return ()+                  [] -> ihPrintError h $ "Unknown operator " ++ show n                   [(_, tms)] ->                        iPrintResult (showSep "\n" (map (showTm i') tms))                   _ -> iPrintError $ "Ambiguous name"@@ -959,6 +888,10 @@ process h fn (UnsetOpt ShowOrigErr) = setShowOrigErr False process h fn (SetOpt AutoSolve)     = setAutoSolve True process h fn (UnsetOpt AutoSolve)   = setAutoSolve False+process h fn (SetOpt NoBanner)      = setNoBanner True+process h fn (UnsetOpt NoBanner)    = setNoBanner False+process h fn (SetOpt WarnReach)     = fmodifyState opts_idrisCmdline $ nub . (WarnReach:)+process h fn (UnsetOpt WarnReach)   = fmodifyState opts_idrisCmdline $ delete WarnReach  process h fn (SetOpt _) = iPrintError "Not a valid option" process h fn (UnsetOpt _) = iPrintError "Not a valid option"@@ -971,51 +904,55 @@                           putIState $ ist { idris_colourRepl = False } process h fn ListErrorHandlers =   do ist <- getIState-     case idris_errorhandlers ist of-       [] -> iPrintResult "No registered error handlers"-       handlers ->-           iPrintResult $ "Registered error handlers: " ++ (concat . intersperse ", " . map show) handlers+     iPrintResult $ case idris_errorhandlers ist of+       []       -> "No registered error handlers"+       handlers -> "Registered error handlers: " ++ (concat . intersperse ", " . map show) handlers process h fn (SetConsoleWidth w) = setWidth w  process h fn (Apropos a) =   do ist <- getIState-     let impl = opt_showimp (idris_options ist)      let names = apropos ist (T.pack a)      let aproposInfo = [ (n,                           delabTy ist n,                           fmap (overview . fst) (lookupCtxtExact n (idris_docstrings ist)))                        | n <- sort names, isUN n ]-     ihRenderResult h $ vsep (map (renderApropos impl) aproposInfo)-  where renderApropos impl (name, ty, docs) =-          prettyName True [] name <+> colon <+> align (prettyImp impl ty) <$>-          fromMaybe empty (fmap (\d -> renderDocstring d <> line) docs)-        isUN (UN _) = True+     ihRenderResult h $ vsep (map (prettyDocumentedIst ist) aproposInfo)+  where isUN (UN _) = True         isUN (NS n _) = isUN n         isUN _ = False -classInfo :: ClassInfo -> Idris ()-classInfo ci = do iputStrLn "Methods:\n"-                  mapM_ dumpMethod (class_methods ci)-                  iputStrLn ""-                  iputStrLn "Default superclass instances:\n"-                  mapM_ dumpDefaultInstance (class_default_superclasses ci)-                  iputStrLn ""-                  iputStrLn "Instances:\n"-                  mapM_ dumpInstance (class_instances ci)-                  iPrintResult ""+process h fn (WhoCalls n) =+  do calls <- whoCalls n+     ist <- getIState+     ihRenderResult h . vsep $+       map (\(n, ns) ->+             text "Callers of" <+> prettyName True [] n <$>+             indent 1 (vsep (map ((text "*" <+>) . align . prettyName True []) ns)))+           calls -dumpMethod :: (Name, (FnOpts, PTerm)) -> Idris ()-dumpMethod (n, (_, t)) = iputStrLn $ show n ++ " : " ++ show t+process h fn (CallsWho n) =+  do calls <- callsWho n+     ist <- getIState+     ihRenderResult h . vsep $+       map (\(n, ns) ->+             prettyName True [] n <+> text "calls:" <$>+             indent 1 (vsep (map ((text "*" <+>) . align . prettyName True []) ns)))+           calls+-- IdrisDoc+process h fn (MakeDoc s) =+  do     istate        <- getIState+         let names      = words s+             parse n    | Success x <- runparser name istate fn n = Right x+             parse n    = Left n+             (bad, nss) = partitionEithers $ map parse names+         cd            <- runIO $ getCurrentDirectory+         let outputDir  = cd </> "doc"+         result        <- if null bad then runIO $ generateDocs istate nss outputDir+                                      else return . Left $ "Illegal name: " ++ head bad+         case result of Right _   -> iputStrLn "IdrisDoc generated"+                        Left  err -> iPrintError err -dumpDefaultInstance :: PDecl -> Idris ()-dumpDefaultInstance (PInstance _ _ _ _ _ t _ _) = iputStrLn $ show t -dumpInstance :: Name -> Idris ()-dumpInstance n = do i <- getIState-                    ctxt <- getContext-                    case lookupTy n ctxt of-                         ts -> mapM_ (\t -> iputStrLn $ showTm i (delab i t)) ts- showTotal :: Totality -> IState -> String showTotal t@(Partial (Other ns)) i    = show t ++ "\n\t" ++ showSep "\n\t" (map (showTotalN i) ns)@@ -1034,79 +971,6 @@             l ++ take (c1 - length l) (repeat ' ') ++             m ++ take (c2 - length m) (repeat ' ') ++ r ++ "\n" -parseCodegen :: String -> Codegen-parseCodegen "C" = ViaC-parseCodegen "Java" = ViaJava-parseCodegen "bytecode" = Bytecode-parseCodegen "javascript" = ViaJavaScript-parseCodegen "node" = ViaNode-parseCodegen "llvm" = ViaLLVM-parseCodegen _ = error "unknown codegen" -- FIXME: partial function--parseArgs :: [String] -> [Opt]-parseArgs [] = []-parseArgs ("--nobanner":ns)      = NoBanner : (parseArgs ns)-parseArgs ("--quiet":ns)         = Quiet : (parseArgs ns)-parseArgs ("--ideslave":ns)      = Ideslave : (parseArgs ns)-parseArgs ("--client":ns)        = [Client (showSep " " ns)]-parseArgs ("--log":lvl:ns)       = OLogging (read lvl) : (parseArgs ns)-parseArgs ("--nobasepkgs":ns)    = NoBasePkgs : (parseArgs ns)-parseArgs ("--noprelude":ns)     = NoPrelude : (parseArgs ns)-parseArgs ("--nobuiltins":ns)    = NoBuiltins : NoPrelude : (parseArgs ns)-parseArgs ("--check":ns)         = NoREPL : (parseArgs ns)-parseArgs ("-o":n:ns)            = NoREPL : Output n : (parseArgs ns)-parseArgs ("--typecase":ns)      = TypeCase : (parseArgs ns)-parseArgs ("--typeintype":ns)    = TypeInType : (parseArgs ns)-parseArgs ("--total":ns)         = DefaultTotal : (parseArgs ns)-parseArgs ("--partial":ns)       = DefaultPartial : (parseArgs ns)-parseArgs ("--warnpartial":ns)   = WarnPartial : (parseArgs ns)-parseArgs ("--nocoverage":ns)    = NoCoverage : (parseArgs ns)-parseArgs ("--errorcontext":ns)  = ErrContext : (parseArgs ns)-parseArgs ("--help":ns)          = Usage : (parseArgs ns)-parseArgs ("--link":ns)          = ShowLibs : (parseArgs ns)-parseArgs ("--libdir":ns)        = ShowLibdir : (parseArgs ns)-parseArgs ("--include":ns)       = ShowIncs : (parseArgs ns)-parseArgs ("--version":ns)       = Ver : (parseArgs ns)-parseArgs ("--verbose":ns)       = Verbose : (parseArgs ns)-parseArgs ("--ibcsubdir":n:ns)   = IBCSubDir n : (parseArgs ns)-parseArgs ("-i":n:ns)            = ImportDir n : (parseArgs ns)-parseArgs ("--warn":ns)          = WarnOnly : (parseArgs ns)--- Package Related options-parseArgs ("--package":n:ns)     = Pkg n : (parseArgs ns)-parseArgs ("-p":n:ns)            = Pkg n : (parseArgs ns)-parseArgs ("--build":n:ns)       = PkgBuild n : (parseArgs ns)-parseArgs ("--install":n:ns)     = PkgInstall n : (parseArgs ns)-parseArgs ("--repl":n:ns)        = PkgREPL n : (parseArgs ns)-parseArgs ("--clean":n:ns)       = PkgClean n : (parseArgs ns)-parseArgs ("--checkpkg":n:ns)    = PkgCheck n : (parseArgs ns)--- Misc Options-parseArgs ("--bytecode":n:ns)    = NoREPL : BCAsm n : (parseArgs ns)-parseArgs ("-S":ns)              = OutputTy Raw : (parseArgs ns)-parseArgs ("-c":ns)              = OutputTy Object : (parseArgs ns)-parseArgs ("--mvn":ns)           = OutputTy MavenProject : (parseArgs ns)-parseArgs ("--dumpdefuns":n:ns)  = DumpDefun n : (parseArgs ns)-parseArgs ("--dumpcases":n:ns)   = DumpCases n : (parseArgs ns)-parseArgs ("--codegen":n:ns)     = UseCodegen (parseCodegen n) : (parseArgs ns)-parseArgs ["--exec"]             = InterpretScript "Main.main" : []-parseArgs ("--exec":expr:ns)     = InterpretScript expr : parseArgs ns-parseArgs (('-':'X':extName):ns) = case maybeRead extName of-  Just ext -> Extension ext : parseArgs ns-  -- Not sure what to do for the Nothing case-  Nothing -> error ("Unknown extension " ++ extName)-  where maybeRead = fmap fst . listToMaybe . reads-parseArgs ("-O3":ns)             = OptLevel 3 : parseArgs ns-parseArgs ("-O2":ns)             = OptLevel 2 : parseArgs ns-parseArgs ("-O1":ns)             = OptLevel 1 : parseArgs ns-parseArgs ("-O0":ns)             = OptLevel 0 : parseArgs ns-parseArgs ("-O":n:ns)            = OptLevel (read n) : parseArgs ns-parseArgs ("--target":n:ns)      = TargetTriple n : parseArgs ns-parseArgs ("--cpu":n:ns)         = TargetCPU n : parseArgs ns-parseArgs ("--colour":ns)        = ColourREPL True : parseArgs ns-parseArgs ("--color":ns)         = ColourREPL True : parseArgs ns-parseArgs ("--nocolour":ns)      = ColourREPL False : parseArgs ns-parseArgs ("--nocolor":ns)       = ColourREPL False : parseArgs ns-parseArgs (n:ns)                 = Filename n : (parseArgs ns)- helphead =   [ (["Command"], SpecialHeaderArg, "Purpose"),     ([""], NoArg, "")@@ -1118,17 +982,22 @@                        historyFile = hFile                      } --- invoke as if from command line+-- | Invoke as if from command line. It is an error if there are unresolved totality problems. idris :: [Opt] -> IO (Maybe IState)-idris opts = do res <- runErrorT $ execStateT (idrisMain opts) idrisInit+idris opts = do res <- runErrorT $ execStateT totalMain idrisInit                 case res of                   Left err -> do putStrLn $ pshow idrisInit err                                  return Nothing                   Right ist -> return (Just ist)+    where totalMain = do idrisMain opts+                         ist <- getIState+                         case idris_totcheckfail ist of+                           ((fc, msg):_) -> ierror . At fc . Msg $ "Could not build: "++  msg+                           [] -> return ()  -loadInputs :: Handle -> [FilePath] -> Idris ()-loadInputs h inputs+loadInputs :: Handle -> [FilePath] -> Maybe Int -> Idris ()+loadInputs h inputs toline -- furthest line to read in input source files   = idrisCatch        (do ist <- getIState            -- if we're in --check and not outputting anything, don't bother@@ -1160,7 +1029,6 @@                       ninputs            inew <- getIState            let tidata = idris_tyinfodata inew-           let lineapps = idris_lineapps inew            let patdefs = idris_patdefs inew            -- If it worked, load the whole thing from all the ibcs together            case errSpan inew of@@ -1171,38 +1039,56 @@               _ -> return ()            ist <- getIState            putIState (ist { idris_tyinfodata = tidata,-                            idris_lineapps = lineapps,-                            idris_patdefs = patdefs }))+                            idris_patdefs = patdefs })++           case opt getOutput opts of+               [] -> performUsageAnalysis  -- interactive+               _  -> return []  -- batch, will be checked by the compiler++           return ())         (\e -> do i <- getIState                   case e of-                    At f _ -> do setErrSpan f-                                 ihRenderError stdout $ pprintErr i e+                    At f e' -> do setErrSpan f+                                  ihWarn stdout f $ pprintErr i e'                     ProgramLineComment -> return () -- fail elsewhere                     _ -> do setErrSpan emptyFC -- FIXME! Propagate it-                            iputStrLn (pshow i e))+                            ihWarn stdout emptyFC $ pprintErr i e)    where -- load all files, stop if any fail          tryLoad :: Bool -> [IFileType] -> Idris ()-         tryLoad keepstate [] = return ()-         tryLoad keepstate (f : fs) +         tryLoad keepstate [] = warnTotality >> return ()+         tryLoad keepstate (f : fs)                  = do ist <- getIState-                      loadFromIFile h f+                      let maxline+                            = case toline of+                                Nothing -> Nothing+                                Just l -> case f of+                                            IDR fn -> if any (fmatch fn) inputs+                                                         then Just l+                                                         else Nothing+                                            LIDR fn -> if any (fmatch fn) inputs+                                                          then Just l+                                                          else Nothing+                                            _ -> Nothing+                      loadFromIFile h f maxline                       inew <- getIState                       -- FIXME: Save these in IBC to avoid this hack! Need to                       -- preserve it all from source inputs                       let tidata = idris_tyinfodata inew-                      let lineapps = idris_lineapps inew                       let patdefs = idris_patdefs inew                       ok <- noErrors                       when ok $ do when (not keepstate) $ putIState ist                                    ist <- getIState                                    putIState (ist { idris_tyinfodata = tidata,-                                                    idris_lineapps = lineapps,                                                     idris_patdefs = patdefs })                                    tryLoad keepstate fs           ibc (IBC _ _) = True          ibc _ = False +         fmatch ('.':'/':xs) ys = fmatch xs ys+         fmatch xs ('.':'/':ys) = fmatch xs ys+         fmatch xs ys = xs == ys+          findNewIBC :: IFileType -> Idris (Maybe IFileType)          findNewIBC i@(IBC _ _) = return (Just i)          findNewIBC s@(IDR f) = do ist <- get@@ -1259,17 +1145,20 @@                    x:y:xs -> do iputStrLn "More than one interpreter expression found."                                 runIO $ exitWith (ExitFailure 1)                    [expr] -> return (Just expr)+       let immediate = opt getEvalExpr opts+        when (DefaultTotal `elem` opts) $ do i <- getIState                                             putIState (i { default_total = True })        setColourise $ not quiet && last (True : opt getColour opts)        when (not runrepl) $ setWidth InfinitelyWide        mapM_ addLangExt (opt getLanguageExt opts)        setREPL runrepl-       setQuiet (quiet || isJust script)+       setQuiet (quiet || isJust script || not (null immediate))        setIdeSlave idesl        setVerbose verbose        setCmdLine opts        setOutputTy outty+       setNoBanner nobanner        setCodegen cgn        setTargetTriple trpl        setTargetCPU tcpu@@ -1284,6 +1173,8 @@          (d:_) -> setIBCSubDir d        setImportDirs importdirs +       setNoBanner nobanner+        when (not (NoBasePkgs `elem` opts)) $ do            addPkgDir "prelude"            addPkgDir "base"@@ -1293,10 +1184,21 @@                                                 return ()        when (not (NoPrelude `elem` opts)) $ do x <- loadModule stdout "Prelude"                                                return ()-       when (runrepl && not quiet && not idesl && not (isJust script) && not nobanner) $ iputStrLn banner +       when (runrepl && not idesl) initScript++       nobanner <- getNoBanner++       when (runrepl &&+             not quiet &&+             not idesl &&+             not (isJust script) &&+             not nobanner &&+             null immediate) $+         iputStrLn banner+        orig <- getIState-       loadInputs stdout inputs+       loadInputs stdout inputs Nothing         runIO $ hSetBuffering stdout LineBuffering @@ -1305,6 +1207,20 @@                     [] -> return ()                     (o:_) -> idrisCatch (process stdout "" (Compile cgn o))                                (\e -> do ist <- getIState ; iputStrLn $ pshow ist e)++       case immediate of+         [] -> return ()+         exprs -> do setWidth InfinitelyWide+                     mapM_ (\str -> do ist <- getIState+                                       c <- colourise+                                       case parseExpr ist str of+                                         Failure err -> do iputStrLn $ show (fixColour c err)+                                                           runIO $ exitWith (ExitFailure 1)+                                         Success e -> process stdout "" (Eval e))+                           exprs+                     runIO $ exitWith ExitSuccess++        case script of          Nothing -> return ()          Just expr -> execScript expr@@ -1320,7 +1236,6 @@         when (runrepl && not idesl) $ do --          clearOrigPats-         initScript          startServer orig inputs          runInputT (replSettings (Just historyFile)) $ repl orig inputs        when (idesl) $ ideslaveStart orig inputs@@ -1349,11 +1264,6 @@                                              res <- execute tm                                              runIO $ exitWith ExitSuccess --- | Check if the coloring matches the options and corrects if necessary-fixColour :: Bool -> ANSI.Doc -> ANSI.Doc-fixColour False doc = ANSI.plain doc-fixColour True doc  = doc- -- | Get the platform-specific, user-specific Idris dir getIdrisUserDataDir :: Idris FilePath getIdrisUserDataDir = runIO $ getAppUserDataDirectory "idris"@@ -1385,7 +1295,7 @@               case parseCmd i input cmd of                    Failure err -> runIO $ print (fixColour clr err)                    Success Reload -> iPrintError "Init scripts cannot reload the file"-                   Success (Load f) -> iPrintError "Init scripts cannot load files"+                   Success (Load f _) -> iPrintError "Init scripts cannot load files"                    Success (ModImport f) -> iPrintError "Init scripts cannot import modules"                    Success Edit -> iPrintError "Init scripts cannot invoke the editor"                    Success Proofs -> proofs i@@ -1433,6 +1343,13 @@ getPkgCheck (PkgCheck str) = Just str getPkgCheck _              = Nothing +-- | Returns None if given an Opt which is not PkgMkDoc+--   Otherwise returns Just x, where x is the contents of PkgMkDoc+getPkgMkDoc :: Opt          -- ^ Opt to extract+            -> Maybe String -- ^ Result+getPkgMkDoc (PkgMkDoc str) = Just str+getPkgMkDoc _              = Nothing+ getCodegen :: Opt -> Maybe Codegen getCodegen (UseCodegen x) = Just x getCodegen _ = Nothing@@ -1440,6 +1357,10 @@ getExecScript :: Opt -> Maybe String getExecScript (InterpretScript expr) = Just expr getExecScript _ = Nothing++getEvalExpr :: Opt -> Maybe String+getEvalExpr (EvalExpr expr) = Just expr+getEvalExpr _ = Nothing  getOutputTy :: Opt -> Maybe OutputType getOutputTy (OutputTy t) = Just t
src/Idris/REPLParser.hs view
@@ -38,32 +38,41 @@                           return (ModImport (toPath f)))               <|> try (do cmd ["e", "edit"]; eof; return Edit)               <|> try (do cmd ["exec", "execute"]; eof; return Execute)-              <|> try (do cmd ["c", "compile"]; f <- P.identifier; eof; return (Compile ViaC f))-              <|> try (do cmd ["jc", "newcompile"]; f <- P.identifier; eof; return (Compile ViaJava f))-              <|> try (do cmd ["js", "javascript"]; f <- P.identifier; eof; return (Compile ViaJavaScript f))+              <|> try (do cmd ["c", "compile"]+                          i <- get+                          c <- option (opt_codegen $ idris_options i) codegenOption+                          f <- P.identifier+                          eof+                          return (Compile c f))               <|> try (do cmd ["proofs"]; eof; return Proofs)               <|> 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 ["l", "load"]; f <- many anyChar; return (Load f))+              <|> try (do cmd ["lto", "loadto"]; +                          toline <- P.natural+                          f <- many anyChar; +                          return (Load f (Just (fromInteger toline))))+              <|> try (do cmd ["l", "load"]; f <- many anyChar; +                          return (Load f Nothing))               <|> try (do cmd ["cd"]; f <- many anyChar; return (ChangeDirectory f))               <|> try (do cmd ["spec"]; P.whiteSpace; t <- P.fullExpr defaultSyntax; return (Spec t))               <|> try (do cmd ["hnf"]; P.whiteSpace; t <- P.fullExpr defaultSyntax; return (HNF t))               <|> try (do cmd ["inline"]; P.whiteSpace; t <- P.fullExpr defaultSyntax; return (TestInline t))-              <|> try (do cmd ["doc"]; n <- P.fnName; eof; return (DocStr n))+              <|> 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 ["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)               <|> try (do cmd ["di", "dbginfo"]; n <- P.fnName; eof; return (DebugInfo n))-              <|> try (do cmd ["i", "info"]; n <- P.fnName; eof; return (Info n))               <|> try (do cmd ["miss", "missing"]; n <- P.fnName; eof; return (Missing n))               <|> try (do cmd ["dynamic"]; eof; return ListDynamic)               <|> try (do cmd ["dynamic"]; l <- many anyChar; return (DynamicLink l))               <|> try (do cmd ["color", "colour"]; pSetColourCmd)               <|> try (do cmd ["set"]; o <- pOption; return (SetOpt o))               <|> try (do cmd ["unset"]; o <- pOption; return (UnsetOpt o))-              <|> try (do cmd ["s", "search"]; P.whiteSpace; t <- P.fullExpr defaultSyntax; return (Search t))+              <|> try (do cmd ["s", "search"]; P.whiteSpace; +                          t <- P.typeExpr (defaultSyntax { implicitAllowed = True }); return (Search t))               <|> try (do cmd ["cs", "casesplit"]; P.whiteSpace;                           upd <- option False (do P.lchar '!'; return True)                           l <- P.natural; n <- P.name;@@ -84,11 +93,20 @@                           upd <- option False (do P.lchar '!'; return True)                           l <- P.natural; n <- P.name;                           return (MakeWith upd (fromInteger l) n))+              <|> try (do cmd ["ml", "makelemma"]; P.whiteSpace;+                          upd <- option False (do P.lchar '!'; return True)+                          l <- P.natural; n <- P.name;+                          return (MakeLemma upd (fromInteger l) n))               <|> try (do cmd ["ps", "proofsearch"]; P.whiteSpace;                           upd <- option False (do P.lchar '!'; return True)                           l <- P.natural; n <- P.name;-                          hints <- many P.name-                          return (DoProofSearch upd (fromInteger l) n hints))+                          hints <- many P.fnName+                          return (DoProofSearch upd True (fromInteger l) n hints))+              <|> try (do cmd ["ref", "refine"]; P.whiteSpace;+                          upd <- option False (do P.lchar '!'; return True)+                          l <- P.natural; n <- P.name;+                          hint <- P.fnName+                          return (DoProofSearch upd False (fromInteger l) n [hint]))               <|> try (do cmd ["p", "prove"]; n <- P.name; eof; return (Prove n))               <|> try (do cmd ["m", "metavars"]; eof; return Metavars)               <|> try (do cmd ["a", "addproof"]; do n <- option Nothing (do x <- P.name;@@ -99,6 +117,9 @@               <|> try (do cmd ["errorhandlers"]; eof ; return ListErrorHandlers)               <|> try (do cmd ["consolewidth"]; w <- pConsoleWidth ; return (SetConsoleWidth w))               <|> try (do cmd ["apropos"]; str <- many anyChar ; return (Apropos str))+              <|> try (do cmd ["wc", "whocalls"]; P.whiteSpace; n <- P.fnName ; return (WhoCalls n))+              <|> try (do cmd ["cw", "callswho"]; P.whiteSpace; n <- P.fnName ; return (CallsWho n))+              <|> try (do cmd ["mkdoc"]; str <- many anyChar; return (MakeDoc str))               <|> do P.whiteSpace; do eof; return NOP                              <|> do t <- P.fullExpr defaultSyntax; return (Eval t) @@ -109,6 +130,16 @@       <|> do discard (P.symbol "showimplicits"); return ShowImpl       <|> do discard (P.symbol "originalerrors"); return ShowOrigErr       <|> do discard (P.symbol "autosolve"); return AutoSolve+      <|> do discard (P.symbol "nobanner") ; return NoBanner+      <|> do discard (P.symbol "warnreach"); return WarnReach++codegenOption :: P.IdrisParser Codegen+codegenOption = do discard (P.symbol "javascript"); return ViaJavaScript+            <|> do discard (P.symbol "node"); return ViaNode+            <|> do discard (P.symbol "Java"); return ViaJava+            <|> do discard (P.symbol "llvm"); return ViaLLVM+            <|> do discard (P.symbol "bytecode"); return Bytecode+            <|> do discard (P.symbol "C"); return ViaC  pConsoleWidth :: P.IdrisParser ConsoleWidth pConsoleWidth = do discard (P.symbol "auto"); return AutomaticWidth
+ src/Idris/TypeSearch.hs view
@@ -0,0 +1,303 @@+module Idris.TypeSearch (+  searchByType, searchPred, defaultScoreFunction+) where++import Control.Applicative ((<$>), (<*>), (<|>))+import Control.Arrow (first, second, (&&&))+import Control.Monad (forM_, guard)++import Data.Function (on)+import Data.List (find, minimumBy, sortBy, (\\))+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe (catMaybes, fromMaybe, isJust)+import Data.Monoid (Monoid (mempty, mappend))+import Data.Set (Set)+import qualified Data.Set as S++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.Core.Evaluate (Context (definitions), Def (Function, TyDecl, CaseOp), normaliseC)+import Idris.Core.TT+import Idris.Core.Unify (match_unify)+import Idris.Delaborate (delab, delabTy)+import Idris.Docstrings (noDocs, overview)+import Idris.ElabDecls (elabType')+import Idris.Output (ihRenderResult, ihPrintResult, ihPrintFunTypes)++import System.IO (Handle)++import Util.Pretty (text, vsep, char, (<>), Doc)++searchByType :: Handle -> PTerm -> Idris ()+searchByType h pterm = do+  pterm' <- addUsingConstraints syn emptyFC pterm+  pterm'' <- implicit toplevel syn n pterm'+  i <- getIState+  let pterm'''  = addImpl i pterm''+  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 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+    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)+  where+  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+  special :: Name -> Bool+  special (SN _) = True+  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+++++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!+-- 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++  f (n, t) = ((n, t), M.keysSet (usedVars t))++  (numArgs, args, 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)+++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++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)+++data Score = Score+  { transposition :: Int+  , leftApplied   :: Int+  , rightApplied  :: Int+  , leftTypeClass :: Int+  , rightTypeClass :: 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+++scoreCriterion :: Score -> Bool+scoreCriterion (Score a b c d e) = True {- not+  ( (b > 0 && c > 0) || (b + c) > 2 ) -}++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)+  -- 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')+++type ArgsDAG = [((Name, Type), (Int, Set Name))]+type ResType = ( [Name] , ArgsDAG , ArgsDAG )++data State = State+  { holes :: ![Name]+  , args1 :: !ArgsDAG+  , args2 :: !ArgsDAG+  , score :: !Score+  }+++--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++  startingTypes = (retTy1, retTy2) : [] +  in do +  state <- go (State startingHoles dag1 dag2 mempty) startingTypes+  return $ processDags state+  where+  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+  +  -- 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+    ((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) })+    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++  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)+    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+++  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)+++  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++    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) -} ]++    results2 = [ State (holes \\ [nameOf ty]) +               (deleteFromDag (nameOf ty) dag1) dag2+               (scoreAcc `mappend` (mempty { leftTypeClass = 1 }))+               | ty <- typeClassArgs1 ]++    typeClassArgs1 = filter (isSaturatedClass . typeOf) dag1+    typeClassArgs2 = filter (isSaturatedClass . typeOf) dag2+++    results3 = [ State (holes \\ [nameOf ty]) +               dag1 (deleteFromDag (nameOf ty) dag2)+               (scoreAcc `mappend` (mempty { rightTypeClass = 1 }))+               | ty <- typeClassArgs2 ]++    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+++    inArgTys = map . first . second+    typeOf ((name, ty), set) = ty+    nameOf ((name, ty), set) = name++    -- XXX : debug stuff+    canBeFirst = if debugParam then filter (S.null . snd . snd) else id+    holes = map (fst . fst) dag1 ++ map (fst . fst) dag2++    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)+
− src/Idris/UnusedArgs.hs 
@@ -1,65 +0,0 @@-module Idris.UnusedArgs where--import Idris.AbsSyntax--import Idris.Core.CaseTree-import Idris.Core.TT--import Control.Monad.State-import Data.Maybe-import Data.List--findUnusedArgs :: [Name] -> Idris ()-findUnusedArgs ns = mapM_ traceUnused ns--traceUnused :: Name -> Idris ()-traceUnused n-   = do i <- getIState-        case lookupCtxt n (idris_callgraph i) of-          [CGInfo args calls scg usedns _] ->-                do let argpos = zip args [0..]-                   let fargs = concatMap (getFargpos calls) argpos-                   logLvl 3 $ show n ++ " used TRACE: " ++ show fargs-                   recused <- mapM (\ (argn, i, (g, j)) ->-                                        do u <- used [(n, i)] g j-                                           return (argn, u)) fargs-                   logLvl 4 $ show n ++ " recused TRACE: " ++ show recused-                   let fused = nub $ usedns ++ map fst (filter snd recused)-                   logLvl 1 $ show n ++ " used args: " ++ show fused-                   let unusedpos = mapMaybe (getUnused fused) (zip [0..] args)-                   logLvl 1 $ show n ++ " unused args: " ++ show (args, unusedpos)-                   addToCG n (CGInfo args calls scg usedns unusedpos) -- updates-          _ -> return ()-  where-    getUnused fused (i,n) | n `elem` fused = Nothing-                          | otherwise = Just i--used :: [(Name, Int)] -> Name -> Int -> Idris Bool-used path g j-   | (g, j) `elem` path = return False -- cycle, never used on the way-   | otherwise-       = do logLvl 5 $ (show ((g, j) : path))-            i <- getIState-            case lookupCtxt g (idris_callgraph i) of-               [CGInfo args calls scg usedns unused] ->-                  if (j >= length args)-                    then -- overapplied, assume used-                         return True-                    else do let directuse = args!!j `elem` usedns-                            let garg = getFargpos calls (args!!j, j)-                            logLvl 5 $ show (g, j, garg)-                            recused <- mapM (\ (argn, j, (g', j')) ->-                                           used ((g,j):path) g' j') garg-                            -- used on any route from here, or not used recursively-                            return (directuse || or recused)-               _ -> return True -- no definition, assume used--getFargpos :: [(Name, [[Name]])] -> (Name, Int) -> [(Name, Int, (Name, Int))]-getFargpos calls (n, i) = concatMap (getCallArgpos n i) calls-   where getCallArgpos :: Name -> Int -> (Name, [[Name]]) ->-                          [(Name, Int, (Name, Int))]-         getCallArgpos n i (g, args)-               = let argpos = zip [0..] args in-                     mapMaybe (\ (j, xs) -> if n `elem` xs then Just (n, i, (g, j))-                                                           else Nothing) argpos-
+ src/Idris/WhoCalls.hs view
@@ -0,0 +1,93 @@+module Idris.WhoCalls (whoCalls, callsWho) where++import Idris.AbsSyntax++import Idris.Core.CaseTree+import Idris.Core.Evaluate+import Idris.Core.TT++import Data.List (nub)+++occurs :: Name -> Term -> Bool+occurs n (P Bound _ _) = False+occurs n (P _ n' _) = n == n'+occurs n (Bind _ b sc) = occursBinder n b || occurs n sc+occurs n (App t1 t2) = occurs n t1 || occurs n t2+occurs n (Proj t _) = occurs n t+occurs n _ = False++names :: Term -> [Name]+names (P Bound _ _) = []+names (P _ n _) = [n]+names (Bind _ b sc) = namesBinder b ++ names sc+names (App t1 t2) = names t1 ++ names t2+names (Proj t _) = names t+names _ = []++occursBinder :: Name -> Binder Term -> Bool+occursBinder n (Let ty val) = occurs n ty || occurs n val+occursBinder n (NLet ty val) = occurs n ty || occurs n val+occursBinder n b = occurs n (binderTy b)++namesBinder :: Binder Term -> [Name]+namesBinder (Let ty val) = names ty ++ names val+namesBinder (NLet ty val) = names ty ++ names val+namesBinder b = names (binderTy b)++occursSC :: Name -> SC -> Bool+occursSC n (Case _ alts) = any (occursCaseAlt n) alts+occursSC n (ProjCase t alts) = occurs n t || any (occursCaseAlt n) alts+occursSC n (STerm t) = occurs n t+occursSC n _ = False++namesSC :: SC -> [Name]+namesSC (Case _ alts) = concatMap namesCaseAlt alts+namesSC (ProjCase t alts) = names t ++ concatMap namesCaseAlt alts+namesSC (STerm t) = names t+namesSC _ = []++occursCaseAlt :: Name -> CaseAlt -> Bool+occursCaseAlt n (ConCase n' _ _ sc) = n == n' || occursSC n sc+occursCaseAlt n (FnCase n' _ sc) = n == n' || occursSC n sc+occursCaseAlt n (ConstCase _ sc) = occursSC n sc+occursCaseAlt n (SucCase _ sc) = occursSC n sc+occursCaseAlt n (DefaultCase sc) = occursSC n sc++namesCaseAlt :: CaseAlt -> [Name]+namesCaseAlt (ConCase n' _ _ sc) = n' : namesSC sc+namesCaseAlt (FnCase n' _ sc) = n' : namesSC sc+namesCaseAlt (ConstCase _ sc) = namesSC sc+namesCaseAlt (SucCase _ sc) = namesSC sc+namesCaseAlt (DefaultCase sc) = namesSC sc++occursDef :: Name -> Def -> Bool+occursDef n (Function ty tm) = occurs n ty || occurs n tm+occursDef n (TyDecl _ ty) = occurs n ty+occursDef n (Operator ty _ _) = occurs n ty+occursDef n (CaseOp _ ty _ _ _ defs) = occurs n ty || occursSC n (snd (cases_compiletime defs))++namesDef :: Def -> [Name]+namesDef (Function ty tm) = names ty ++ names tm+namesDef (TyDecl _ ty) = names ty+namesDef (Operator ty _ _) = names ty+namesDef (CaseOp _ ty _ _ _ defs) = names ty ++ namesSC (snd (cases_compiletime defs))++findOccurs :: Name -> Idris [Name]+findOccurs n = do ctxt <- getContext+                  -- A definition calls a function if the function is in the type or RHS of the definition+                  let defs = (map fst . filter (\(n', def) -> n /= n' && occursDef n def) . ctxtAlist) ctxt+                  -- A datatype calls its +                  return defs++whoCalls :: Name -> Idris [(Name, [Name])]+whoCalls n = do ctxt <- getContext+                let names = lookupNames n ctxt+                    find nm = do ns <- findOccurs nm+                                 return (nm, nub ns)+                mapM find names++callsWho :: Name -> Idris [(Name, [Name])]+callsWho n = do ctxt <- getContext+                let defs = lookupNameDef n ctxt+                return $ map (\ (n, def) -> (n, nub $ namesDef def)) defs
src/Pkg/PParser.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverlappingInstances #-}+ module Pkg.PParser where  import Text.Trifecta hiding (span, stringLiteral, charLiteral, natural, symbol, char, string, whiteSpace)@@ -6,6 +8,7 @@ import Idris.REPL import Idris.AbsSyntaxTree import Idris.ParseHelpers+import Idris.CmdOptions  import Paths_idris @@ -27,6 +30,10 @@                        }     deriving Show +instance TokenParsing PParser where+  someSpace = many (simpleWhiteSpace <|> singleLineComment <|> multiLineComment) *> pure ()++ defaultPkg = PkgDesc "" [] [] Nothing [] "" [] (sUN "") Nothing  parseDesc :: FilePath -> IO PkgDesc@@ -60,7 +67,7 @@       <|> do reserved "opts"; lchar '=';              opts <- stringLiteral              st <- get-             let args = parseArgs (words opts)+             let args = pureArgParser (words opts)              put (st { idris_opts = args })       <|> do reserved "modules"; lchar '=';              ms <- sepBy1 (iName []) (lchar ',')
src/Pkg/Package.hs view
@@ -5,18 +5,24 @@ import System.Directory import System.Exit import System.IO-import System.FilePath ((</>), addTrailingPathSeparator, takeFileName)+import System.FilePath ((</>), addTrailingPathSeparator, takeFileName, takeDirectory) import System.Directory (createDirectoryIfMissing, copyFile)  import Util.System  import Control.Monad+import Control.Monad.Trans.State.Strict (execStateT)+import Control.Monad.Error (runErrorT)+ import Data.List import Data.List.Split(splitOn)  import Idris.Core.TT import Idris.REPL+import Idris.Parser (loadModule)+import Idris.Output (pshow) import Idris.AbsSyntax+import Idris.IdrisDoc import Idris.Output  import IRTS.System@@ -74,7 +80,7 @@             -> FilePath  -- ^ Path to ipkg file.             -> IO () checkPkg warnonly quit fpath-  = do pkgdesc <-parseDesc fpath+  = do pkgdesc <- parseDesc fpath        ok <- mapM (testLib warnonly (pkgname pkgdesc)) (libdeps pkgdesc)        when (and ok) $          do dir <- getCurrentDirectory@@ -122,6 +128,38 @@                Nothing -> return ()                Just s -> rmFile $ dir </> s +-- | Generate IdrisDoc for package+-- TODO: Handle case where module does not contain a matching namespace+--       E.g. from prelude.ipkg: IO, Prelude.Chars, Builtins+documentPkg :: FilePath -- ^ Path to .ipkg file.+            -> IO ()+documentPkg fp =+  do pkgdesc        <- parseDesc fp+     cd             <- getCurrentDirectory+     let pkgDir      = cd </> takeDirectory fp+         outputDir   = cd </> (pkgname pkgdesc) ++ "_doc"+         opts        = NoREPL : Verbose : idris_opts pkgdesc+         mods        = modules pkgdesc+         fs          = map (foldl1' (</>) . splitOn "." . showCG) mods+     setCurrentDirectory $ pkgDir </> sourcedir pkgdesc+     make (makefile pkgdesc)+     setCurrentDirectory $ pkgDir+     let run l       = runErrorT . (execStateT l)+         load []     = return () +         load (f:fs) = do loadModule stdout f; load fs+         loader      = do idrisMain opts; load fs+     idrisInstance  <- run loader idrisInit+     setCurrentDirectory cd+     case idrisInstance of+          Left  err -> do putStrLn $ pshow idrisInit err; exitWith (ExitFailure 1)+          Right ist ->+                do docRes <- generateDocs ist mods outputDir+                   case docRes of+                        Right _  -> return ()+                        Left msg -> do putStrLn msg+                                       exitWith (ExitFailure 1)++ -- | Install package installPkg :: PkgDesc -> IO () installPkg pkgdesc@@ -131,7 +169,6 @@               Nothing -> mapM_ (installIBC (pkgname pkgdesc)) (modules pkgdesc)               Just o -> return () -- do nothing, keep executable locally, for noe           mapM_ (installObj (pkgname pkgdesc)) (objs pkgdesc)-  -- ---------------------------------------------------------- [ Helper Methods ] -- Methods for building, testing, installing, and removal of idris
test/Makefile view
@@ -11,7 +11,7 @@ 	perl ./runtest.pl without sugar004 buffer001 --codegen Java  test_js:-	@perl ./runtest.pl without sugar004 reg029 io001 dsl002 io003 effects001 effects002 buffer001 bounded001 folding002 --codegen node+	@perl ./runtest.pl without sugar004 reg029 io001 dsl002 io003 effects001 effects002 buffer001 --codegen node  test_llvm: 	@perl ./runtest.pl without sugar004 io003 buffer001 --codegen llvm
test/basic001/reg005.idr view
@@ -1,17 +1,22 @@ module Main +%flag C "-g3 -ggdb -O0"+ rep : (n : Nat) -> Char -> Vect n Char rep Z     x = [] rep (S k) x = x :: rep k x  data RLE : Vect n Char -> Type where      REnd  : RLE []-     RChar : {xs : Vect k Char} ->-             (n : Nat) -> (x : Char) -> RLE xs ->-             RLE (rep (S n) x ++ xs)+     RChar : .{k : Nat}+             -> {xs : Vect k Char}+             -> (n : Nat)+             -> (x : Char)+             -> RLE xs+             -> RLE (rep (S n) x ++ xs)  eq : (x : Char) -> (y : Char) -> Maybe (x = y)-eq x y = if x == y then Just ?eqCharOK else Nothing+eq x y = if x == y then Just (believe_me (refl {x})) else Nothing  ------------ @@ -32,20 +37,14 @@          = let ni : Integer = cast (S n) in                show ni ++ strCons x (compress xs) +{-+fmt : {xs : Vect n Char} -> RLE xs -> String+fmt  REnd          = ""+fmt (RChar n c xs) = show n ++ show c ++ fmt xs+-}+ compressString : String -> String compressString xs = compress (fromList (unpack xs))  main : IO () main = putStrLn (compressString "foooobaaaarbaaaz")-------------- Proofs ------------Main.eqCharOK = proof {-  intros;-  refine believe_me;-  exact x = x;-}--
test/basic002/test006.idr view
@@ -1,8 +1,8 @@ module Main  data Parity : Nat -> Type where-   even : Parity (n + n)-   odd  : Parity (S (n + n))+    even : {n : Nat} -> Parity (n + n)+    odd  : {n : Nat} -> Parity (S (n + n))  parity : (n:Nat) -> Parity n parity Z     = even {n=Z}
test/basic006/expected view
@@ -1,5 +1,5 @@-When elaborating right hand side of foo:-test020a.idr:14:18:When elaborating an application of function Prelude.List.reverse:+test020a.idr:14:18:When elaborating right hand side of foo:+When elaborating an application of function Prelude.List.reverse:         Can't unify                 Vect n a         with
test/basic007/test033.idr view
@@ -1,4 +1,4 @@ module Main  main : IO ()-main = nullPtr null >>= (putStrLn . show)+main = nullPtr null >>= print
+ test/idrisdoc001/TestEmpty.idr view
@@ -0,0 +1,1 @@+module TestEmpty
+ test/idrisdoc001/TestPrivate.idr view
@@ -0,0 +1,5 @@+module TestPrivate++private+iAmPrivate : ()+iAmPrivate = ()
+ test/idrisdoc001/expected view
@@ -0,0 +1,5 @@+Type checking ./TestEmpty.idr+Type checking ./TestPrivate.idr+Warning: Ignoring empty or non-existing namespace 'TestEmpty'+Warning: Ignoring empty or non-existing namespace 'TestPrivate'+No namespaces to generate documentation for
+ test/idrisdoc001/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+# Tests that no documentation is built for empty and/or private-only namespaces+idris --mkdoc test_empty.ipkg+rm -rf *.ibc *_doc
+ test/idrisdoc001/test_empty.ipkg view
@@ -0,0 +1,4 @@+package test_empty++modules = TestEmpty, TestPrivate+
+ test/idrisdoc002/TestFunctions.idr view
@@ -0,0 +1,5 @@+module TestFunctions++||| Test function+test : ()+test = ()
+ test/idrisdoc002/expected view
@@ -0,0 +1,2 @@+Type checking ./TestFunctions.idr+Functions are documented
+ test/idrisdoc002/run view
@@ -0,0 +1,5 @@+#!/usr/bin/env bash+# Tests that documentation is generated for functions+idris --mkdoc test_functions.ipkg+[ -d test_functions_doc ] && echo "Functions are documented"+rm -rf *.ibc *_doc
+ test/idrisdoc002/test_functions.ipkg view
@@ -0,0 +1,4 @@+package test_functions++modules = TestFunctions+
+ test/idrisdoc003/TestDatatypes.idr view
@@ -0,0 +1,6 @@+module TestDatatypes++||| This is another test+data Test : Type where+  ||| Test constructor+  ATest : Test
+ test/idrisdoc003/expected view
@@ -0,0 +1,2 @@+Type checking ./TestDatatypes.idr+Data types are documented
+ test/idrisdoc003/run view
@@ -0,0 +1,5 @@+#!/usr/bin/env bash+# Tests that documentation is generated for data types+idris --mkdoc test_datatypes.ipkg+[ -d test_datatypes_doc ] && echo "Data types are documented"+rm -rf *.ibc *_doc
+ test/idrisdoc003/test_datatypes.ipkg view
@@ -0,0 +1,4 @@+package test_datatypes++modules = TestDatatypes+
+ test/idrisdoc004/TestTypeclasses.idr view
@@ -0,0 +1,8 @@+module TestTypeclasses++||| This is a test+|||+||| @ a Test arg+class Test a where+  ||| Test function+  test : a -> Int
+ test/idrisdoc004/expected view
@@ -0,0 +1,2 @@+Type checking ./TestTypeclasses.idr+Typeclasses are documented
+ test/idrisdoc004/run view
@@ -0,0 +1,5 @@+#!/usr/bin/env bash+# Tests that documentation is generated for typeclasses+idris --mkdoc test_typeclasses.ipkg+[ -d test_typeclasses_doc ] && echo "Typeclasses are documented"+rm -rf *.ibc *_doc
+ test/idrisdoc004/test_typeclasses.ipkg view
@@ -0,0 +1,4 @@+package test_typeclasses++modules = TestTypeclasses+
+ test/idrisdoc005/TestTracing.idr view
@@ -0,0 +1,4 @@+module TestTracing++test : Bool+test = True
+ test/idrisdoc005/expected view
@@ -0,0 +1,3 @@+Type checking ./TestTracing.idr+TestTracing: Check+Prelude.Bool: Check
+ test/idrisdoc005/run view
@@ -0,0 +1,6 @@+#!/usr/bin/env bash+# Tests that references to other namespaces are traced+idris --mkdoc test_tracing.ipkg+[ -f test_tracing_doc/docs/TestTracing.html ] && echo "TestTracing: Check"+[ -f test_tracing_doc/docs/Prelude.Bool.html ] && echo "Prelude.Bool: Check"+rm -rf *.ibc *_doc
+ test/idrisdoc005/test_tracing.ipkg view
@@ -0,0 +1,4 @@+package test_tracing++modules = TestTracing+
+ test/idrisdoc006/A/fully/Qualified/NAME.idr view
@@ -0,0 +1,6 @@+module A.fully.Qualified.NAME++||| This is another test+data Test : Type where+  ||| Test constructor+  ATest : Test
+ test/idrisdoc006/B.idr view
@@ -0,0 +1,5 @@+module B++||| Test function+test : ()+test = ()
+ test/idrisdoc006/expected view
@@ -0,0 +1,7 @@+Type checking ./A/fully/Qualified/NAME.idr+IdrisDoc file written+Type checking ./B.idr+A.fully.Qualified.NAME.html+B.html+A.fully.Qualified.NAME is in the index+B is in the index
+ test/idrisdoc006/package_a.ipkg view
@@ -0,0 +1,4 @@+package test_merge++modules = A.fully.Qualified.NAME+
+ test/idrisdoc006/package_b.ipkg view
@@ -0,0 +1,4 @@+package test_merge++modules = B+
+ test/idrisdoc006/run view
@@ -0,0 +1,17 @@+#!/usr/bin/env bash+# Tests that documentation properly is merged with existent.+idris --mkdoc package_a.ipkg+[ -f test_merge_doc/IdrisDoc ] && echo "IdrisDoc file written"+idris --mkdoc package_b.ipkg+ls -1p test_merge_doc/docs+if grep -q "href\\=\"docs/A.fully.Qualified.NAME\\.html\"" test_merge_doc/index.html; then+  echo A.fully.Qualified.NAME is in the index+else+  echo A.fully.Qualified.NAME is NOT in the index+fi+if grep -q "href\\=\"docs/B\\.html\"" test_merge_doc/index.html; then+  echo B is in the index+else+  echo B is NOT in the index+fi+rm -rf *.ibc *_doc A/fully/Qualified/NAME.ibc
+ test/idrisdoc007/A.idr view
@@ -0,0 +1,6 @@+module A++||| This is a test+data Test : Type where+  ||| Test constructor+  ATest : Test
+ test/idrisdoc007/expected view
@@ -0,0 +1,1 @@+Exit status (expects 1): 1
+ test/idrisdoc007/package.ipkg view
@@ -0,0 +1,4 @@+package do_not_delete++modules = A+
+ test/idrisdoc007/run view
@@ -0,0 +1,6 @@+#!/usr/bin/env bash+# Tests that documentation only is written when safe+mkdir do_not_delete_doc+idris --mkdoc package.ipkg > nowhere+echo Exit status \(expects 1\): $?+rm -rf do_not_delete_doc *.ibc nowhere
+ test/idrisdoc008/Abstract.idr view
@@ -0,0 +1,5 @@+module Abstract++abstract+frozen : ()+frozen = ()
+ test/idrisdoc008/Visible.idr view
@@ -0,0 +1,5 @@+module Visible++public+visible : ()+visible = ()
+ test/idrisdoc008/expected view
@@ -0,0 +1,4 @@+Type checking ./Abstract.idr+Type checking ./Visible.idr+Abstract members are documented+Public members are documented
+ test/idrisdoc008/run view
@@ -0,0 +1,6 @@+#!/usr/bin/env bash+# Tests that documentation is generated for both public and abstract members.+idris --mkdoc visibility.ipkg+[ -f visibility_doc/docs/Abstract.html ] && echo "Abstract members are documented"+[ -f visibility_doc/docs/Visible.html ] && echo "Public members are documented"+rm -rf *.ibc *_doc
+ test/idrisdoc008/visibility.ipkg view
@@ -0,0 +1,4 @@+package visibility++modules = Abstract, Visible+
test/interactive001/expected view
@@ -4,7 +4,7 @@     localZipWith f (_ :: _) (x :: ys) = ?localZipWith_rhs_1 -f x :: (map f xs)+f x :: map f xs isElem2 x (y :: ys) with (_)   isElem2 x (y :: ys) | with_pat = ?isElem2_rhs   isElem3 x (x :: ys) | (Yes refl) = ?isElem3_rhs_3
test/interactive003/expected view
@@ -1,5 +1,5 @@ Type checking ./interactive003.idr ys-x :: (app xs ys)+x :: app xs ys []-f x y :: (vzipWith f xs ys)+f x y :: vzipWith f xs ys
+ test/interactive004/expected view
@@ -0,0 +1,3 @@+Type checking ./interactive004.idr+plus ?foo_rhs2 ?foo_rhs3+append k m ?append_rhs2 ?append_rhs3
+ test/interactive004/input view
@@ -0,0 +1,2 @@+:ref 2 foo_rhs1 plus +:ref 6 append_rhs1 append
+ test/interactive004/interactive004.idr view
@@ -0,0 +1,7 @@+foo : Nat -> Nat -> Nat+foo k j = ?foo_rhs1++append : (n : Nat) -> (m : Nat) -> Vect n a -> Vect m a -> Vect (n + m) a+append Z m [] ys = ys+append (S k) m (x :: xs) ys = x :: ?append_rhs1+
+ test/interactive004/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris --quiet interactive004.idr < input+rm -f *.ibc
test/proof003/Parity.idr view
@@ -1,8 +1,8 @@ module Parity  data Parity : Nat -> Type where-   even : Parity (n + n)-   odd  : Parity (S (n + n))+    even : {n : Nat} -> Parity (n + n)+    odd  : {n : Nat} -> Parity (S (n + n))  parity : (n:Nat) -> Parity n parity Z     = even {n=Z}
+ test/records002/expected view
@@ -0,0 +1,2 @@+42, 20+10, 42
+ test/records002/record002.idr view
@@ -0,0 +1,11 @@++record Foo : Nat -> Type where+       MkFoo : (param : Nat) -> (num : Int) -> Foo param++instance Show (Foo n) where+  show f = show (param f) ++ ", " ++ show (num f)++main : IO ()+main = do let x = MkFoo 10 20+          putStrLn (show (record { param = 42 } x))+          putStrLn (show (record { num = 42 } x))
+ test/records002/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ record002.idr -o record002+./record002+rm -f record002 *.ibc
+ test/records003/expected view
@@ -0,0 +1,6 @@+"Fred"+21+20+30+29+2014
+ test/records003/records003.idr view
@@ -0,0 +1,48 @@+record Person : Nat -> Type where+       MkPerson : (name : String) ->+                  (age : Nat) ->+                  Person age++record Event : Type where+       MkEvent : (name : String) -> (organiser : Person a) -> Event ++record Meeting : Int -> Type where+       MkMeeting : (event : Event) -> +                   (organiser : Person a) -> +                   (year : Int) -> +                   Meeting year++new_organiser : String -> List (Meeting x) -> List (Meeting x)+new_organiser n = map (record { event->organiser->name = n }) ++next_year : Meeting x -> Meeting (x+1)+next_year m = record { organiser->age+                          = record { organiser->age } m + 1,+                       event->organiser->age+                          = record { event->organiser->age } m + 1,+                       year = _ } m++fred : Person 20+fred = MkPerson "Fred" _++jim : Person 29+jim = MkPerson "Jim" 29++idm : Event+idm = MkEvent "Idris Developers Meeting" fred++idm_gbg : Meeting 2014+idm_gbg = MkMeeting idm jim _++test : Meeting 2015+test = next_year idm_gbg++main : IO ()+main = do print (record { event->organiser->name } test)+          print (record { event->organiser->age } test)+          print (record { event->organiser->age } idm_gbg)+          print (record { organiser->age } test)+          print (record { organiser->age } idm_gbg)+          print (record { year } idm_gbg)++
+ test/records003/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ records003.idr -o records003+./records003+rm -f records003 *.ibc
test/reg014/reg014.idr view
@@ -3,10 +3,10 @@ Matrix : Type -> Nat -> Nat -> Type Matrix a n m = Vect n (Vect m a) -transpose : Matrix a (S n) (S m) -> Matrix a (S m) (S n)-transpose ((x:: []) :: []) = [[x]]-transpose [x :: y :: xs] = [x] :: (transpose [y :: xs])-transpose (x :: y :: xs)-    = let tx = transpose [x] in-      let ux = transpose (y :: xs) in zipWith (++) tx ux+mytranspose : Matrix a (S n) (S m) -> Matrix a (S m) (S n)+mytranspose ((x:: []) :: []) = [[x]]+mytranspose [x :: y :: xs] = [x] :: (mytranspose [y :: xs])+mytranspose (x :: y :: xs)+    = let tx = mytranspose [x] in+      let ux = mytranspose (y :: xs) in zipWith (++) tx ux
test/reg018/expected view
@@ -1,4 +1,5 @@ reg018a.idr:16:1:conat.minusCoNat is possibly not total due to recursive path conat.minusCoNat+reg018a.idr:21:1:conat.loopForever is possibly not total due to: conat.minusCoNat reg018b.idr:8:1:A.showB is possibly not total due to recursive path A.showB reg018c.idr:19:1:CodataTest.inf is possibly not total due to: {CodataTest.inf19} reg018d.idr:5:1:Main.pull is not total as there are missing cases
test/reg018/run view
@@ -3,3 +3,4 @@ idris $@ reg018b.idr --check idris $@ reg018c.idr --check idris $@ reg018d.idr --check+rm *.ibc
test/reg025/reg025.idr view
@@ -9,7 +9,7 @@ data Board : Nat -> Type where   MkBoard : {n : Nat} -> Vect n (Vect n (Cell n)) -> Board n -emptyBoard : Board n+emptyBoard : {n : Nat} -> Board n emptyBoard {n=n} = MkBoard (replicate n (replicate n Nothing))  Empty : Cell n -> Type
test/reg029/run view
@@ -3,5 +3,5 @@ unset IDRIS_REG029_NONEXISTENT_VAR export IDRIS_REG029_EXISTENT_VAR='exists!' ./reg029-idris $@ reg029.idr --exec+idris $@ reg029.idr --execute rm -f reg029 *.ibc
+ test/reg039/expected view
@@ -0,0 +1,2 @@+Type checking ./reg039.idr+[3, 2, 1]
+ test/reg039/reg039.idr view
@@ -0,0 +1,12 @@+module LazyExec++-- The regression that this tests for is broken laziness in the executor.++covering+countdown : Int -> Lazy (List Int)+countdown n = if n > 0+                 then (n :: countdown (n-1))+                 else []++go : IO ()+go = putStrLn $ show (Force (countdown 3))
+ test/reg039/run view
@@ -0,0 +1,32 @@+#!/usr/bin/env bash++# From http://unix.stackexchange.com/questions/43340/how-to-introduce-timeout-for-shell-scripting+# Executes command with a timeout+# Params:+#   $1 timeout in seconds+#   $2 command+# Returns 1 if timed out 0 otherwise+timeout() {++    time=$1++    # start the command in a subshell to avoid problem with pipes+    # (spawn accepts one command)+    command="/bin/sh -c \"$2\""++    expect -c "set echo \"-noecho\"; set timeout $time; spawn -noecho $command; expect timeout { exit 1 } eof { exit 0 }"++    if [ $? = 1 ] ; then+        echo "Timeout after ${time} seconds"+    fi++}++declare -a extraargs+for arg in "$@"+do+    extraargs=("${extraargs[@]}" "'$arg'")+done++timeout 60 "idris ${extraargs[*]} --nocolour reg039.idr --exec go"+rm -f reg039 *.ibc
+ test/reg040/expected view
@@ -0,0 +1,1 @@+42
+ test/reg040/reg040.idr view
@@ -0,0 +1,7 @@+-- The regression that this tests for is defunct unsafePerformIO++io : IO Int+io = return 42++main : IO ()+main = print $ unsafePerformIO io
+ test/reg040/run view
@@ -0,0 +1,6 @@+#!/usr/bin/env bash++idris --warnreach reg040.idr -o reg040+./reg040++rm -f reg040 *.ibc
+ test/reg041/expected view
@@ -0,0 +1,3 @@+Type checking ./ott.idr+?prf : (x : Bool) -> (x1 : Bool) -> El (EQ two x two x1) -> El (EQ two x two x1)+Z
+ test/reg041/ott.idr view
@@ -0,0 +1,42 @@+module OTT++mutual++  data U : Type where+    u : U+    zero : U+    one : U+    two : U+    pi : (s : U) -> (t : El s -> U) -> U++  El : U -> Type+  El u = U+  El zero = _|_+  El one = ()+  El two = Bool+  El (pi s t) = (x : El s) -> El (t x)++infixr 10 ~>+(~>) : U -> U -> U+s ~> t = pi s $ const t++syntax "<|" [s] "|>" = El s+syntax [x] "==" [y] "in" [s] = EQ s x s y++%assert_total+EQ : (s : U) -> <| s |> -> (t : U) -> <| t |> -> U+EQ u u u u = one+EQ u zero u zero = one+EQ u one u one = one+EQ u two u two = one+EQ u (pi s t) u (pi s' t') = pi s $ \x => pi s' $ \y => EQ s x s' y ~> EQ u (t x) u (t' y)+EQ zero x zero y = one+EQ one x one y = one+EQ two True two True = one+EQ two False two False = one+EQ (pi s t) f (pi s' t') g = pi s $ \x => pi s' $ \y => EQ s x s' y ~> EQ (t x) (f x) (t' y) (g y)+EQ _ _ _ _ = zero++example : <| id == id in (two ~> two) |>+example = ?prf+
+ test/reg041/run view
@@ -0,0 +1,5 @@+#!/usr/bin/env bash+idris $@ --quiet ott.idr -e example+idris $@ showu.idr -o reg040+./reg040+rm -f reg040 *.ibc
+ test/reg041/showu.idr view
@@ -0,0 +1,23 @@+module Main++%default total++data U : Type where+  BOOL : U+  NAT : U+  PAIR : U -> U -> U++interpU : U -> Type+interpU BOOL = Bool+interpU NAT = Nat+interpU (PAIR x y) = (interpU x, interpU y)++showU : (u : U) -> interpU u -> String+showU BOOL True            = "Yes"+showU BOOL False           = "No"+showU NAT Z                = "Z"+showU NAT (S x)            = "S of " ++ showU NAT x+showU (PAIR tx ty) (x , y) = "(" ++ showU tx x ++ "," ++ showU ty y ++ ")"++main : IO ()+main = putStrLn $ showU NAT 0
+ test/reg042/expected view
@@ -0,0 +1,1 @@+7
+ test/reg042/reg042.idr view
@@ -0,0 +1,24 @@+-- This regtest tests for incorrect erasure from underapplied data constructors.++data T : Type where+    C : Nat -> Nat -> Nat -> T++data Q : Type where+    D : (Nat -> T) -> Q++-- The bug was here: (C 3 4) would compile to plain data,+-- not to a function that would expect another (albeit erased) argument.+f : Q+f = D (C 3 4)++proj : Nat -> Q -> Nat -> T+proj    Z  (D f) = f+proj (S n)    q  = proj n q++g : T -> Nat+g (C x y z) = x + y++-- Here, we'd apply the not-a-function to the erased argument 4,+-- which would make the program go wrong.+main : IO ()+main = print $ g (proj 3 f 4)
+ test/reg042/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ reg042 -o reg042 --warnreach+./reg042+rm -f reg042 *.ibc
+ test/reg043/expected view
@@ -0,0 +1,1 @@+take : (m : Fin 3) -> Vect 2 Nat -> Vect (finToNat m) Nat
+ test/reg043/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ --nocolour -e "Vect.take {n=2} {a=Nat}"+
+ test/reg044/expected view
@@ -0,0 +1,11 @@+reg044.idr:4:4:When elaborating right hand side of Main.pf:+Can't unify+        [95mb[0m [94m=[0m [95mb[0m+with+        [95ma[0m [94m=[0m [95mb[0m++Specifically:+        Can't unify+                [95mb[0m+        with+                [95ma[0m
+ test/reg044/reg044.idr view
@@ -0,0 +1,6 @@+exjection : S a = S b -> a = b+exjection = ?pf++pf = proof+  intros+  refine refl
+ test/reg044/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris reg044.idr --check+rm -f *.ibc
test/totality001/run view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash-idris $@ test010.idr -o test010-idris $@ test010a.idr -o test010-idris $@ test010b.idr -o test010+idris $@ --check test010.idr+idris $@ --check test010a.idr+idris $@ --check test010b.idr  rm -f *.ibc
test/totality004/expected view
@@ -1,2 +1,3 @@ [1, 2, 2, 4, 3, 6, 4, 8, 5, 10] totality004a.idr:13:1:Main.process is possibly not total due to recursive path Main.process --> Main.process --> Main.process+totality004a.idr:24:1:Main.main is possibly not total due to: Main.process
test/totality005/expected view
@@ -1,2 +1,1 @@-totality005.idr:6:1:Main.fib is possibly not total due to recursive path Main.fib [0, 1, 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, 144, 233, 377]
test/totality005/totality005.idr view
@@ -2,8 +2,9 @@ zipWithS : (f : a -> b -> c) -> Stream a -> Stream b -> Stream c zipWithS f (x :: xs) (y :: ys) = f x y :: zipWithS f xs ys +partial fib : Stream Nat fib = 0 :: zipWithS (+) fib (1 :: fib) -main : IO ()+partial main : IO () main = print (take 15 fib)
+ test/totality006/expected view
@@ -0,0 +1,2 @@+totality006.idr:6:1:Main.prf is not total as there are missing cases+totality006a.idr:9:6:prf' (S _) (S _) oh is a valid case
+ test/totality006/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ totality006.idr --check+idris $@ totality006a.idr --check+rm -f *.ibc
+ test/totality006/totality006.idr view
@@ -0,0 +1,11 @@+antitrue : so False -> a+antitrue oh impossible++total+prf : (a:Nat) -> (b:Nat) -> so (a > b) -> GT a b+prf Z     Z     oh impossible+prf Z     (S k) um = antitrue um+prf (S k) Z     um = lteSucc lteZero +-- prf (S _) (S _) oh impossible++
+ test/totality006/totality006a.idr view
@@ -0,0 +1,10 @@+antitrue : so False -> a+antitrue oh impossible++total+prf' : (a:Nat) -> (b:Nat) -> so (a > b) -> GT a b+prf' Z     Z     oh impossible+prf' Z     (S k) um = antitrue um+prf' (S k) Z     um = lteSucc lteZero +prf' (S _) (S _) oh impossible+
+ test/totality007/expected view
@@ -0,0 +1,3 @@+Type checking ./Totality.idr+Totality.idr:4:1:Totality.foo is not total as there are missing cases+Totality.idr:4:1:Could not build: Totality.foo is not total as there are missing cases
+ test/totality007/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ --build totality.ipkg+rm -f src/*.ibc
+ test/totality007/src/Totality.idr view
@@ -0,0 +1,4 @@+module Totality++total foo : Nat -> Nat+foo Z = Z
+ test/totality007/totality.ipkg view
@@ -0,0 +1,7 @@+package totality++-- totality007+-- Test that the package builder doesn't allow totality errors in a build+opts = ""+sourcedir = src+modules = Totality
+ test/totality008/expected view
@@ -0,0 +1,1 @@+totality008.idr:7:1:Main.ElimT is possibly not total due to: Main.c2
+ test/totality008/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ totality008.idr --check+rm -f *.ibc
+ test/totality008/totality008.idr view
@@ -0,0 +1,8 @@+ data T : Type -> Type where+  c1 : T Nat+  c2 : T (T Nat)++total+ElimT : (A : Type) -> T A -> A+ElimT _ c1 = 3+ElimT _ c2 = c1